← Back to branch summary

~ubuntu-branches/ubuntu/utopic/dpkg/utopic

« back to all changes in this revision

Viewing changes to scripts/dpkg-gencontrol.pl

  • Committer: Package Import Robot
  • Author(s): Adam Conrad
  • Date: 2013-11-17 10:42:09 UTC
  • mfrom: (1.6.2 sid) (1.5.18 jessie)
  • Revision ID: package-import@ubuntu.com-20131117104209-ixwjosuxm5q99qt7
Tags: 1.17.1ubuntu1
* Merge from Debian unstable.  Remaining changes:
  - Change the multiarch downgrade version checks in prerm/postrm
    from 1.16.2 to 1.16.0~ to reflect when multiarch landed in Ubuntu.
  - Migrate dpkg multiarch conffile (and other multi-arch-related
    conf settings) to the new DB with dpkg --add-architecture, but
    keep a copy of the old conffile if it was modified.
  - Out of paranoia, keep an option handler for foreign-architecture
    that informs people that they need to scrub their config files
    and upgrade, on the off chance that the above migration fails
    for some reason (this mitigates the chances of leaving users with
    a dpkg that fails to run due to a broken config).
  - Add DPKG_UNTRANSLATED_MESSAGES environment check so that higher-level
    tools can get untranslated dpkg terminal log messages while at the
    same time having translated debconf prompts.  This is useful for tools
    that hide the dpkg terminal by default and use apport for bug
    reporting with the untranslated error message.
  - Apply patch from Steve McIntyre to special-case armhf/armel ELF
    objects in Shlibs/Objdump.pm, so we don't get incorrect deps.
  - lib/dpkg/pkg-spec.c: map unqualified package names of multiarch-same
    packages to the native arch instead of throwing an error, so that we
    don't break on upgrade when there are unqualified names stored in
    dpkg's own trigger database.
  - Add logic to the postinst to `dpkg --add-architecture i386' on new
    installs on amd64, and to also do so on upgrades from pre-conffile
    Ubuntu versions, mimicking our previous behaviour with the conffile.
  - Apply a workaround from mvo to consider RC packages as multiarch,
    during the dpkg consistency checks. (see LP: 1015567 and 1057367).
  - Add ppc64el/powerpc64le support to cputable (backported from 1.17.2).
* Forward-port manpages-it dpkg/dpkg-dev/dselect Replaces from 1.16.12.

Show diffs side-by-side

added added

removed removed

Lines of Context:
scripts/dpkg-gencontrol.pl
22
22
use strict;
23
23
use warnings;
24
24
 
25
 
use POSIX;
26
 
use POSIX qw(:errno_h);
27
 
use Dpkg;
 
25
use POSIX qw(:errno_h :fcntl_h);
 
26
use Dpkg ();
28
27
use Dpkg::Gettext;
29
28
use Dpkg::ErrorHandling;
 
29
use Dpkg::Util qw(:list);
30
30
use Dpkg::File;
31
31
use Dpkg::Arch qw(get_host_arch debarch_eq debarch_is);
32
32
use Dpkg::Package;
38
38
use Dpkg::Vars;
39
39
use Dpkg::Changelog::Parse;
40
40
 
41
 
textdomain("dpkg-dev");
 
41
textdomain('dpkg-dev');
42
42
 
43
43
 
44
44
my $controlfile = 'debian/control';
60
60
 
61
61
 
62
62
sub version {
63
 
    printf _g("Debian %s version %s.\n"), $progname, $version;
 
63
    printf _g("Debian %s version %s.\n"), $Dpkg::PROGNAME, $Dpkg::PROGVERSION;
64
64
 
65
 
    printf _g("
 
65
    printf _g('
66
66
This is free software; see the GNU General Public License version 2 or
67
67
later for copying conditions. There is NO warranty.
68
 
");
 
68
');
69
69
}
70
70
 
71
71
sub usage {
72
72
    printf _g(
73
 
"Usage: %s [<option>...]")
 
73
'Usage: %s [<option>...]')
74
74
    . "\n\n" . _g(
75
 
"Options:
 
75
'Options:
76
76
  -p<package>              print control file for package.
77
77
  -c<control-file>         get control info from this file.
78
78
  -l<changelog-file>       get per-version info from this file.
89
89
  -T<substvars-file>       read variables here, not debian/substvars.
90
90
  -?, --help               show this help message.
91
91
      --version            show the version.
92
 
"), $progname;
 
92
'), $Dpkg::PROGNAME;
93
93
}
94
94
 
95
95
while (@ARGV) {
138
138
 
139
139
umask 0022; # ensure sane default permissions for created files
140
140
my %options = (file => $changelogfile);
141
 
$options{"changelogformat"} = $changelogformat if $changelogformat;
 
141
$options{changelogformat} = $changelogformat if $changelogformat;
142
142
my $changelog = changelog_parse(%options);
143
 
if ($changelog->{"Binary-Only"}) {
144
 
    $options{"count"} = 1;
145
 
    $options{"offset"} = 1;
 
143
if ($changelog->{'Binary-Only'}) {
 
144
    $options{count} = 1;
 
145
    $options{offset} = 1;
146
146
    my $prev_changelog = changelog_parse(%options);
147
 
    $sourceversion = $prev_changelog->{"Version"};
 
147
    $sourceversion = $prev_changelog->{'Version'};
148
148
} else {
149
 
    $sourceversion = $changelog->{"Version"};
 
149
    $sourceversion = $changelog->{'Version'};
150
150
}
151
151
 
152
152
if (defined $forceversion) {
153
153
    $binaryversion = $forceversion;
154
154
} else {
155
 
    $binaryversion = $changelog->{"Version"};
 
155
    $binaryversion = $changelog->{'Version'};
156
156
}
157
157
 
158
158
$substvars->set_version_substvars($sourceversion, $binaryversion);
159
159
$substvars->set_arch_substvars();
160
 
$substvars->load("debian/substvars") if -e "debian/substvars" and not $substvars_loaded;
 
160
$substvars->load('debian/substvars') if -e 'debian/substvars' and not $substvars_loaded;
161
161
my $control = Dpkg::Control::Info->new($controlfile);
162
162
my $fields = Dpkg::Control->new(type => CTRL_PKG_DEB);
163
163
 
164
164
# Old-style bin-nmus change the source version submitted to
165
165
# set_version_substvars()
166
 
$sourceversion = $substvars->get("source:Version");
 
166
$sourceversion = $substvars->get('source:Version');
167
167
 
168
168
my $pkg;
169
169
 
170
170
if (defined($oppackage)) {
171
171
    $pkg = $control->get_pkg_by_name($oppackage);
172
 
    defined($pkg) || error(_g("package %s not in control info"), $oppackage);
 
172
    defined($pkg) || error(_g('package %s not in control info'), $oppackage);
173
173
} else {
174
174
    my @packages = map { $_->{'Package'} } $control->get_packages();
175
175
    if (@packages == 0) {
176
 
        error(_g("no package stanza found in control info"));
 
176
        error(_g('no package stanza found in control info'));
177
177
    } elsif (@packages > 1) {
178
 
        error(_g("must specify package since control info has many (%s)"),
 
178
        error(_g('must specify package since control info has many (%s)'),
179
179
              "@packages");
180
180
    }
181
181
    $pkg = $control->get_pkg_by_idx(1);
182
182
}
183
 
$substvars->set_msg_prefix(sprintf(_g("package %s: "), $pkg->{Package}));
 
183
$substvars->set_msg_prefix(sprintf(_g('package %s: '), $pkg->{Package}));
184
184
 
185
185
# Scan source package
186
186
my $src_fields = $control->get_source();
187
 
foreach $_ (keys %{$src_fields}) {
 
187
foreach (keys %{$src_fields}) {
188
188
    if (m/^Source$/) {
189
189
        set_source_package($src_fields->{$_});
190
190
    } else {
193
193
}
194
194
 
195
195
# Scan binary package
196
 
foreach $_ (keys %{$pkg}) {
 
196
foreach (keys %{$pkg}) {
197
197
    my $v = $pkg->{$_};
198
198
    if (field_get_dep_type($_)) {
199
199
        # Delay the parsing until later
204
204
            $fields->{$_} = $v;
205
205
        } else {
206
206
            my @archlist = split(/\s+/, $v);
207
 
            my @invalid_archs = grep m/[^\w-]/, @archlist;
 
207
            my @invalid_archs = grep { m/[^\w-]/ } @archlist;
208
208
            warning(ngettext("`%s' is not a legal architecture string.",
209
209
                             "`%s' are not legal architecture strings.",
210
210
                             scalar(@invalid_archs)),
211
211
                    join("' `", @invalid_archs))
212
212
                if @invalid_archs >= 1;
213
 
            grep(debarch_is($host_arch, $_), @archlist) ||
 
213
            if (none { debarch_is($host_arch, $_) } @archlist) {
214
214
                error(_g("current host architecture '%s' does not " .
215
215
                         "appear in package's architecture list (%s)"),
216
216
                      $host_arch, "@archlist");
 
217
            }
217
218
            $fields->{$_} = $host_arch;
218
219
        }
219
220
    } else {
222
223
}
223
224
 
224
225
# Scan fields of dpkg-parsechangelog
225
 
foreach $_ (keys %{$changelog}) {
 
226
foreach (keys %{$changelog}) {
226
227
    my $v = $changelog->{$_};
227
228
 
228
229
    if (m/^Source$/) {
245
246
my $facts = Dpkg::Deps::KnownFacts->new();
246
247
$facts->add_installed_package($fields->{'Package'}, $fields->{'Version'},
247
248
                              $fields->{'Architecture'}, $fields->{'Multi-Arch'});
248
 
if (exists $pkg->{"Provides"}) {
249
 
    my $provides = deps_parse($substvars->substvars($pkg->{"Provides"}, no_warn => 1),
 
249
if (exists $pkg->{'Provides'}) {
 
250
    my $provides = deps_parse($substvars->substvars($pkg->{'Provides'}, no_warn => 1),
250
251
                              reduce_arch => 1, union => 1);
251
252
    if (defined $provides) {
252
253
        foreach my $subdep ($provides->get_deps()) {
262
263
my (@seen_deps);
263
264
foreach my $field (field_list_pkg_dep()) {
264
265
    # Arch: all can't be simplified as the host architecture is not known
265
 
    my $reduce_arch = debarch_eq('all', $pkg->{Architecture} || "all") ? 0 : 1;
 
266
    my $reduce_arch = debarch_eq('all', $pkg->{Architecture} || 'all') ? 0 : 1;
266
267
    if (exists $pkg->{$field}) {
267
268
        my $dep;
268
269
        my $field_value = $substvars->substvars($pkg->{$field},
269
 
            msg_prefix => sprintf(_g("%s field of package %s: "), $field, $pkg->{Package}));
 
270
            msg_prefix => sprintf(_g('%s field of package %s: '), $field, $pkg->{Package}));
270
271
        if (field_get_dep_type($field) eq 'normal') {
271
272
            $dep = deps_parse($field_value, use_arch => 1,
272
273
                              reduce_arch => $reduce_arch);
273
 
            error(_g("error occurred while parsing %s field: %s"), $field,
 
274
            error(_g('error occurred while parsing %s field: %s'), $field,
274
275
                  $field_value) unless defined $dep;
275
276
            $dep->simplify_deps($facts, @seen_deps);
276
277
            # Remember normal deps to simplify even further weaker deps
278
279
        } else {
279
280
            $dep = deps_parse($field_value, use_arch => 1,
280
281
                              reduce_arch => $reduce_arch, union => 1);
281
 
            error(_g("error occurred while parsing %s field: %s"), $field,
 
282
            error(_g('error occurred while parsing %s field: %s'), $field,
282
283
                  $field_value) unless defined $dep;
283
284
            $dep->simplify_deps($facts);
284
285
            $dep->sort();
285
286
        }
286
 
        error(_g("the %s field contains an arch-specific dependency but the " .
287
 
                 "package is architecture all"), $field)
 
287
        error(_g('the %s field contains an arch-specific dependency but the ' .
 
288
                 'package is architecture all'), $field)
288
289
            if $dep->has_arch_restriction();
289
290
        $fields->{$field} = $dep->output();
290
291
        delete $fields->{$field} unless $fields->{$field}; # Delete empty field
292
293
}
293
294
 
294
295
for my $f (qw(Package Version)) {
295
 
    defined($fields->{$f}) || error(_g("missing information for output field %s"), $f);
 
296
    defined($fields->{$f}) || error(_g('missing information for output field %s'), $f);
296
297
}
297
298
for my $f (qw(Maintainer Description Architecture)) {
298
 
    defined($fields->{$f}) || warning(_g("missing information for output field %s"), $f);
 
299
    defined($fields->{$f}) || warning(_g('missing information for output field %s'), $f);
299
300
}
300
301
$oppackage = $fields->{'Package'};
301
302
 
307
308
    delete $fields->{'Homepage'};
308
309
} else {
309
310
    for my $f (qw(Subarchitecture Kernel-Version Installer-Menu-Item)) {
310
 
        warning(_g("%s package with udeb specific field %s"), $pkg_type, $f)
 
311
        warning(_g('%s package with udeb specific field %s'), $pkg_type, $f)
311
312
            if defined($fields->{$f});
312
313
    }
313
314
}
315
316
my $verdiff = $binaryversion ne $sourceversion;
316
317
if ($oppackage ne $sourcepackage || $verdiff) {
317
318
    $fields->{'Source'} = $sourcepackage;
318
 
    $fields->{'Source'} .= " (" . $sourceversion . ")" if $verdiff;
 
319
    $fields->{'Source'} .= ' (' . $sourceversion . ')' if $verdiff;
319
320
}
320
321
 
321
322
if (!defined($substvars->get('Installed-Size'))) {
322
 
    defined(my $c = open(DU, "-|")) || syserr(_g("cannot fork for %s"), "du");
 
323
    my $du_fh;
 
324
    defined(my $c = open($du_fh, '-|')) || syserr(_g('cannot fork for %s'), 'du');
323
325
    if (!$c) {
324
326
        chdir("$packagebuilddir") ||
325
327
            syserr(_g("chdir for du to \`%s'"), $packagebuilddir);
326
 
        exec("du", "-k", "-s", "--apparent-size", ".") or
327
 
            syserr(_g("unable to execute %s"), "du");
 
328
        exec('du', '-k', '-s', '--apparent-size', '.') or
 
329
            syserr(_g('unable to execute %s'), 'du');
328
330
    }
329
331
    my $duo = '';
330
 
    while (<DU>) {
 
332
    while (<$du_fh>) {
331
333
        $duo .= $_;
332
334
    }
333
 
    close(DU);
 
335
    close($du_fh);
334
336
    $? && subprocerr(_g("du in \`%s'"), $packagebuilddir);
335
337
    $duo =~ m/^(\d+)\s+\.$/ ||
336
338
        error(_g("du gave unexpected output \`%s'"), $duo);
354
356
# Obtain a lock on debian/control to avoid simultaneous updates
355
357
# of debian/files when parallel building is in use
356
358
my $lockfh;
357
 
sysopen($lockfh, "debian/control", O_WRONLY) ||
358
 
    syserr(_g("cannot write %s"), "debian/control");
359
 
file_lock($lockfh, "debian/control");
 
359
sysopen($lockfh, 'debian/control', O_WRONLY) ||
 
360
    syserr(_g('cannot write %s'), 'debian/control');
 
361
file_lock($lockfh, 'debian/control');
360
362
 
361
363
$fileslistfile="./$fileslistfile" if $fileslistfile =~ m/^\s/;
362
 
open(Y, ">", "$fileslistfile.new") || syserr(_g("open new files list file"));
363
 
binmode(Y);
364
 
if (open(X, "<", $fileslistfile)) {
365
 
    binmode(X);
366
 
    while (<X>) {
 
364
open(my $fileslistnew_fh, '>', "$fileslistfile.new") ||
 
365
    syserr(_g('open new files list file'));
 
366
binmode($fileslistnew_fh);
 
367
if (open(my $fileslist_fh, '<', $fileslistfile)) {
 
368
    binmode($fileslist_fh);
 
369
    while (<$fileslist_fh>) {
367
370
        chomp;
368
371
        next if m/^([-+0-9a-z.]+)_[^_]+_([\w-]+)\.(a-z+) /
369
372
                && ($1 eq $oppackage)
370
373
                && ($3 eq $pkg_type)
371
 
                && (debarch_eq($2, $fields->{'Architecture'} || "")
 
374
                && (debarch_eq($2, $fields->{'Architecture'} || '')
372
375
                    || debarch_eq($2, 'all'));
373
 
        print(Y "$_\n") || syserr(_g("copy old entry to new files list file"));
 
376
        print($fileslistnew_fh "$_\n") ||
 
377
            syserr(_g('copy old entry to new files list file'));
374
378
    }
375
 
    close(X) || syserr(_g("close old files list file"));
 
379
    close($fileslist_fh) || syserr(_g('close old files list file'));
376
380
} elsif ($! != ENOENT) {
377
 
    syserr(_g("read old files list file"));
 
381
    syserr(_g('read old files list file'));
378
382
}
379
383
my $sversion = $fields->{'Version'};
380
384
$sversion =~ s/^\d+://;
381
 
$forcefilename = sprintf("%s_%s_%s.%s", $oppackage, $sversion,
382
 
                         $fields->{'Architecture'} || "", $pkg_type)
383
 
           unless ($forcefilename);
384
 
print(Y $substvars->substvars(sprintf("%s %s %s\n", $forcefilename,
385
 
                                      $fields->{'Section'} || '-',
386
 
                                      $fields->{'Priority'} || '-')))
387
 
    || syserr(_g("write new entry to new files list file"));
388
 
close(Y) || syserr(_g("close new files list file"));
389
 
rename("$fileslistfile.new", $fileslistfile) || syserr(_g("install new files list file"));
 
385
$forcefilename //= sprintf('%s_%s_%s.%s', $oppackage, $sversion,
 
386
                           $fields->{'Architecture'} || '', $pkg_type);
 
387
 
 
388
print($fileslistnew_fh $substvars->substvars(sprintf("%s %s %s\n",
 
389
                                             $forcefilename,
 
390
                                             $fields->{'Section'} || '-',
 
391
                                             $fields->{'Priority'} || '-')))
 
392
    || syserr(_g('write new entry to new files list file'));
 
393
close($fileslistnew_fh) || syserr(_g('close new files list file'));
 
394
rename("$fileslistfile.new", $fileslistfile) || syserr(_g('install new files list file'));
390
395
 
391
396
# Release the lock
392
 
close($lockfh) || syserr(_g("cannot close %s"), "debian/control");
 
397
close($lockfh) || syserr(_g('cannot close %s'), 'debian/control');
393
398
 
394
399
my $cf;
395
400
my $fh_output;
396
401
if (!$stdout) {
397
402
    $cf= "$packagebuilddir/DEBIAN/control";
398
403
    $cf= "./$cf" if $cf =~ m/^\s/;
399
 
    open($fh_output, ">", "$cf.new") ||
 
404
    open($fh_output, '>', "$cf.new") ||
400
405
        syserr(_g("cannot open new output control file \`%s'"), "$cf.new");
401
406
} else {
402
407
    $fh_output = \*STDOUT;
406
411
$fields->output($fh_output);
407
412
 
408
413
if (!$stdout) {
409
 
    close($fh_output) || syserr(_g("cannot close %s"), "$cf.new");
 
414
    close($fh_output) || syserr(_g('cannot close %s'), "$cf.new");
410
415
    rename("$cf.new", "$cf") ||
411
416
        syserr(_g("cannot install output control file \`%s'"), $cf);
412
417
}