Commit | Line | Data |
---|---|---|
1479465f GJ |
1 | #!/usr/bin/perl |
2 | # | |
3 | # dpkg-checkbuilddeps | |
4 | # | |
5 | # Copyright © 2001 Joey Hess <joeyh@debian.org> | |
6 | # Copyright © 2006-2009, 2011-2015 Guillem Jover <guillem@debian.org> | |
7 | # Copyright © 2007-2011 Raphael Hertzog <hertzog@debian.org> | |
8 | # | |
9 | # This program is free software; you can redistribute it and/or modify | |
10 | # it under the terms of the GNU General Public License as published by | |
11 | # the Free Software Foundation; either version 2 of the License, or | |
12 | # (at your option) any later version. | |
13 | # | |
14 | # This program is distributed in the hope that it will be useful, | |
15 | # but WITHOUT ANY WARRANTY; without even the implied warranty of | |
16 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
17 | # GNU General Public License for more details. | |
18 | # | |
19 | # You should have received a copy of the GNU General Public License | |
20 | # along with this program. If not, see <https://www.gnu.org/licenses/>. | |
21 | ||
22 | use strict; | |
23 | use warnings; | |
24 | ||
25 | use Getopt::Long qw(:config posix_default bundling no_ignorecase); | |
26 | ||
27 | use Dpkg (); | |
28 | use Dpkg::Gettext; | |
29 | use Dpkg::ErrorHandling; | |
30 | use Dpkg::Arch qw(get_host_arch); | |
31 | use Dpkg::Vendor qw(run_vendor_hook); | |
32 | use Dpkg::BuildProfiles qw(get_build_profiles set_build_profiles); | |
33 | use Dpkg::Deps; | |
34 | use Dpkg::Control::Info; | |
35 | ||
36 | textdomain('dpkg-dev'); | |
37 | ||
38 | sub version() | |
39 | { | |
40 | printf g_("Debian %s version %s.\n"), $Dpkg::PROGNAME, $Dpkg::PROGVERSION; | |
41 | } | |
42 | ||
43 | sub usage { | |
44 | printf g_( | |
45 | 'Usage: %s [<option>...] [<control-file>]') | |
46 | . "\n\n" . g_( | |
47 | 'Options: | |
48 | -A ignore Build-Depends-Arch and Build-Conflicts-Arch. | |
49 | -B ignore Build-Depends-Indep and Build-Conflicts-Indep. | |
50 | -I ignore built-in build dependencies and conflicts. | |
51 | -d build-deps use given string as build dependencies instead of | |
52 | retrieving them from control file | |
53 | -c build-conf use given string for build conflicts instead of | |
54 | retrieving them from control file | |
55 | -a arch assume given host architecture | |
56 | -P profiles assume given build profiles (comma-separated list) | |
57 | --admindir=<directory> | |
58 | change the administrative directory. | |
59 | -?, --help show this help message. | |
60 | --version show the version.') | |
61 | . "\n\n" . g_( | |
62 | '<control-file> is the control file to process (default: debian/control).') | |
63 | . "\n", $Dpkg::PROGNAME; | |
64 | } | |
65 | ||
66 | my $ignore_bd_arch = 0; | |
67 | my $ignore_bd_indep = 0; | |
68 | my $ignore_bd_builtin = 0; | |
69 | my ($bd_value, $bc_value); | |
70 | my $bp_value; | |
71 | my $host_arch = get_host_arch(); | |
72 | my $admindir = $Dpkg::ADMINDIR; | |
73 | my @options_spec = ( | |
74 | 'help|?' => sub { usage(); exit(0); }, | |
75 | 'version' => sub { version(); exit 0; }, | |
76 | 'A' => \$ignore_bd_arch, | |
77 | 'B' => \$ignore_bd_indep, | |
78 | 'I' => \$ignore_bd_builtin, | |
79 | 'd=s' => \$bd_value, | |
80 | 'c=s' => \$bc_value, | |
81 | 'a=s' => \$host_arch, | |
82 | 'P=s' => \$bp_value, | |
83 | 'admindir=s' => \$admindir, | |
84 | ); | |
85 | ||
86 | { | |
87 | local $SIG{__WARN__} = sub { usageerr($_[0]) }; | |
88 | GetOptions(@options_spec); | |
89 | } | |
90 | ||
91 | # Update currently active build profiles. | |
92 | set_build_profiles(split(/,/, $bp_value)) if ($bp_value); | |
93 | my @build_profiles = get_build_profiles(); | |
94 | ||
95 | my $controlfile = shift // 'debian/control'; | |
96 | ||
97 | my $control = Dpkg::Control::Info->new($controlfile); | |
98 | my $fields = $control->get_source(); | |
99 | ||
100 | my $facts = parse_status("$admindir/status"); | |
101 | ||
102 | unless (defined($bd_value) or defined($bc_value)) { | |
103 | my @bd_list; | |
104 | push @bd_list, run_vendor_hook('builtin-build-depends') | |
105 | if not $ignore_bd_builtin; | |
106 | push @bd_list, $fields->{'Build-Depends'}; | |
107 | push @bd_list, $fields->{'Build-Depends-Arch'} if not $ignore_bd_arch; | |
108 | push @bd_list, $fields->{'Build-Depends-Indep'} if not $ignore_bd_indep; | |
109 | $bd_value = deps_concat(@bd_list); | |
110 | ||
111 | my @bc_list; | |
112 | push @bc_list, run_vendor_hook('builtin-build-conflicts') | |
113 | if not $ignore_bd_builtin; | |
114 | push @bc_list, $fields->{'Build-Conflicts'}; | |
115 | push @bc_list, $fields->{'Build-Conflicts-Arch'} if not $ignore_bd_arch; | |
116 | push @bc_list, $fields->{'Build-Conflicts-Indep'} if not $ignore_bd_indep; | |
117 | $bc_value = deps_concat(@bc_list); | |
118 | } | |
119 | my (@unmet, @conflicts); | |
120 | ||
121 | if ($bd_value) { | |
122 | my $dep = deps_parse($bd_value, reduce_restrictions => 1, | |
123 | build_dep => 1, build_profiles => \@build_profiles, | |
124 | host_arch => $host_arch); | |
125 | error(g_('error occurred while parsing %s'), | |
126 | 'Build-Depends/Build-Depends-Arch/Build-Depends-Indep') | |
127 | unless defined $dep; | |
128 | push @unmet, build_depends($dep, $facts); | |
129 | } | |
130 | if ($bc_value) { | |
131 | my $dep = deps_parse($bc_value, reduce_restrictions => 1, union => 1, | |
132 | build_dep => 1, build_profiles => \@build_profiles, | |
133 | host_arch => $host_arch); | |
134 | error(g_('error occurred while parsing %s'), | |
135 | 'Build-Conflicts/Build-Conflicts-Arch/Build-Conflicts-Indep') | |
136 | unless defined $dep; | |
137 | push @conflicts, build_conflicts($dep, $facts); | |
138 | } | |
139 | ||
140 | if (@unmet) { | |
141 | errormsg(g_('Unmet build dependencies: %s'), | |
142 | join(' ', map { $_->output() } @unmet)); | |
143 | } | |
144 | if (@conflicts) { | |
145 | errormsg(g_('Build conflicts: %s'), | |
146 | join(' ', map { $_->output() } @conflicts)); | |
147 | } | |
148 | exit 1 if @unmet || @conflicts; | |
149 | ||
150 | # Silly little status file parser that returns a Dpkg::Deps::KnownFacts | |
151 | sub parse_status { | |
152 | my $status = shift; | |
153 | ||
154 | my $facts = Dpkg::Deps::KnownFacts->new(); | |
155 | local $/ = ''; | |
156 | open(my $status_fh, '<', $status) | |
157 | or syserr(g_('cannot open %s'), $status); | |
158 | while (<$status_fh>) { | |
159 | next unless /^Status: .*ok installed$/m; | |
160 | ||
161 | my ($package) = /^Package: (.*)$/m; | |
162 | my ($version) = /^Version: (.*)$/m; | |
163 | my ($arch) = /^Architecture: (.*)$/m; | |
164 | my ($multiarch) = /^Multi-Arch: (.*)$/m; | |
165 | $facts->add_installed_package($package, $version, $arch, | |
166 | $multiarch); | |
167 | ||
168 | if (/^Provides: (.*)$/m) { | |
169 | my $provides = deps_parse($1, reduce_arch => 1, union => 1); | |
170 | next if not defined $provides; | |
171 | foreach (grep { $_->isa('Dpkg::Deps::Simple') } | |
172 | $provides->get_deps()) | |
173 | { | |
174 | $facts->add_provided_package($_->{package}, | |
175 | $_->{relation}, $_->{version}, | |
176 | $package); | |
177 | } | |
178 | } | |
179 | } | |
180 | close $status_fh; | |
181 | ||
182 | return $facts; | |
183 | } | |
184 | ||
185 | # This function checks the build dependencies passed in as the first | |
186 | # parameter. If they are satisfied, returns false. If they are unsatisfied, | |
187 | # an list of the unsatisfied depends is returned. | |
188 | # | |
189 | # Additional parameters that must be passed: | |
190 | # * A reference to a hash of all "ok installed" the packages on the system, | |
191 | # with the hash key being the package name, and the value being the | |
192 | # installed version. | |
193 | # * A reference to a hash, where the keys are package names, and the | |
194 | # value is a true value iff some package installed on the system provides | |
195 | # that package (all installed packages provide themselves) | |
196 | # | |
197 | # Optionally, the architecture the package is to be built for can be passed | |
198 | # in as the 4th parameter. If not set, dpkg will be queried for the build | |
199 | # architecture. | |
200 | sub build_depends { | |
201 | my ($dep_list, $facts) = @_; | |
202 | ||
203 | $dep_list->simplify_deps($facts); | |
204 | if ($dep_list->is_empty()) { | |
205 | return (); | |
206 | } else { | |
207 | return $dep_list->get_deps(); | |
208 | } | |
209 | } | |
210 | ||
211 | # This function is exactly like build_depends(), except it | |
212 | # checks for build conflicts, and returns a list of the packages | |
213 | # that are installed and are conflicted with. | |
214 | sub build_conflicts { | |
215 | my ($dep_list, $facts) = @_; | |
216 | ||
217 | my @conflicts = (); | |
218 | foreach my $dep ($dep_list->get_deps()) { | |
219 | if ($dep->get_evaluation($facts)) { | |
220 | push @conflicts, $dep; | |
221 | } | |
222 | } | |
223 | return @conflicts; | |
224 | } |