| #!/usr/bin/perl |
| # |
| # dpkg-gencontrol |
| # |
| # This program is free software; you can redistribute it and/or modify |
| # it under the terms of the GNU General Public License as published by |
| # the Free Software Foundation; either version 2 of the License, or |
| # (at your option) any later version. |
| # |
| # This program is distributed in the hope that it will be useful, |
| # but WITHOUT ANY WARRANTY; without even the implied warranty of |
| # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| # GNU General Public License for more details. |
| # |
| # You should have received a copy of the GNU General Public License |
| # along with this program. If not, see <http://www.gnu.org/licenses/>. |
| |
| use strict; |
| use warnings; |
| |
| use POSIX; |
| use POSIX qw(:errno_h); |
| use Dpkg; |
| use Dpkg::Gettext; |
| use Dpkg::ErrorHandling; |
| use Dpkg::Arch qw(get_host_arch debarch_eq debarch_is); |
| use Dpkg::Deps; |
| use Dpkg::Control; |
| use Dpkg::Control::Info; |
| use Dpkg::Control::Fields; |
| use Dpkg::Substvars; |
| use Dpkg::Vars; |
| use Dpkg::Changelog::Parse; |
| |
| textdomain("dpkg-dev"); |
| |
| |
| my $controlfile = 'debian/control'; |
| my $changelogfile = 'debian/changelog'; |
| my $changelogformat; |
| my $fileslistfile = 'debian/files'; |
| my $packagebuilddir = 'debian/tmp'; |
| |
| my $sourceversion; |
| my $forceversion; |
| my $forcefilename; |
| my $stdout; |
| my %remove; |
| my %override; |
| my $oppackage; |
| my $substvars = Dpkg::Substvars->new(); |
| my $substvars_loaded = 0; |
| |
| |
| sub version { |
| printf _g("Debian %s version %s.\n"), $progname, $version; |
| |
| printf _g(" |
| Copyright (C) 1996 Ian Jackson. |
| Copyright (C) 2000,2002 Wichert Akkerman."); |
| |
| printf _g(" |
| This is free software; see the GNU General Public License version 2 or |
| later for copying conditions. There is NO warranty. |
| "); |
| } |
| |
| sub usage { |
| printf _g( |
| "Usage: %s [<option> ...] |
| |
| Options: |
| -p<package> print control file for package. |
| -c<controlfile> get control info from this file. |
| -l<changelogfile> get per-version info from this file. |
| -F<changelogformat> force change log format. |
| -v<forceversion> set version of binary package. |
| -f<fileslistfile> write files here instead of debian/files. |
| -P<packagebuilddir> temporary build dir instead of debian/tmp. |
| -n<filename> assume the package filename will be <filename>. |
| -O write to stdout, not .../DEBIAN/control. |
| -is, -ip, -isp, -ips deprecated, ignored for compatibility. |
| -D<field>=<value> override or add a field and value. |
| -U<field> remove a field. |
| -V<name>=<value> set a substitution variable. |
| -T<varlistfile> read variables here, not debian/substvars. |
| -h, --help show this help message. |
| --version show the version. |
| "), $progname; |
| } |
| |
| while (@ARGV) { |
| $_=shift(@ARGV); |
| if (m/^-p([-+0-9a-z.]+)$/) { |
| $oppackage= $1; |
| } elsif (m/^-p(.*)/) { |
| error(_g("Illegal package name \`%s'"), $1); |
| } elsif (m/^-c/) { |
| $controlfile= $'; |
| } elsif (m/^-l/) { |
| $changelogfile= $'; |
| } elsif (m/^-P/) { |
| $packagebuilddir= $'; |
| } elsif (m/^-f/) { |
| $fileslistfile= $'; |
| } elsif (m/^-v(.+)$/) { |
| $forceversion= $1; |
| } elsif (m/^-O$/) { |
| $stdout= 1; |
| } elsif (m/^-i[sp][sp]?$/) { |
| # ignored for backwards compatibility |
| } elsif (m/^-F([0-9a-z]+)$/) { |
| $changelogformat=$1; |
| } elsif (m/^-D([^\=:]+)[=:]/) { |
| $override{$1}= $'; |
| } elsif (m/^-U([^\=:]+)$/) { |
| $remove{$1}= 1; |
| } elsif (m/^-V(\w[-:0-9A-Za-z]*)[=:]/) { |
| $substvars->set($1, $'); |
| $substvars->no_warn($1); |
| } elsif (m/^-T(.*)$/) { |
| $substvars->load($1) if -e $1; |
| $substvars_loaded = 1; |
| } elsif (m/^-n/) { |
| $forcefilename= $'; |
| } elsif (m/^-(h|-help)$/) { |
| usage(); |
| exit(0); |
| } elsif (m/^--version$/) { |
| version(); |
| exit(0); |
| } else { |
| usageerr(_g("unknown option \`%s'"), $_); |
| } |
| } |
| |
| umask 0022; # ensure sane default permissions for created files |
| my %options = (file => $changelogfile); |
| $options{"changelogformat"} = $changelogformat if $changelogformat; |
| my $changelog = changelog_parse(%options); |
| $substvars->set_version_substvars($changelog->{"Version"}); |
| $substvars->set_arch_substvars(); |
| $substvars->load("debian/substvars") if -e "debian/substvars" and not $substvars_loaded; |
| $substvars->set("binary:Version", $forceversion) if defined $forceversion; |
| my $control = Dpkg::Control::Info->new($controlfile); |
| my $fields = Dpkg::Control->new(type => CTRL_PKG_DEB); |
| |
| my $pkg; |
| |
| if (defined($oppackage)) { |
| $pkg = $control->get_pkg_by_name($oppackage); |
| defined($pkg) || error(_g("package %s not in control info"), $oppackage); |
| } else { |
| my @packages = map { $_->{'Package'} } $control->get_packages(); |
| @packages==1 || |
| error(_g("must specify package since control info has many (%s)"), |
| "@packages"); |
| $pkg = $control->get_pkg_by_idx(1); |
| } |
| $substvars->set_msg_prefix(sprintf(_g("package %s: "), $pkg->{Package})); |
| |
| # Scan source package |
| my $src_fields = $control->get_source(); |
| foreach $_ (keys %{$src_fields}) { |
| if (m/^Source$/) { |
| set_source_package($src_fields->{$_}); |
| } else { |
| field_transfer_single($src_fields, $fields); |
| } |
| } |
| |
| # Scan binary package |
| foreach $_ (keys %{$pkg}) { |
| my $v = $pkg->{$_}; |
| if (field_get_dep_type($_)) { |
| # Delay the parsing until later |
| } elsif (m/^Architecture$/) { |
| my $host_arch = get_host_arch(); |
| |
| if (debarch_eq('all', $v)) { |
| $fields->{$_} = $v; |
| } else { |
| my @archlist = split(/\s+/, $v); |
| my @invalid_archs = grep m/[^\w-]/, @archlist; |
| warning(ngettext("`%s' is not a legal architecture string.", |
| "`%s' are not legal architecture strings.", |
| scalar(@invalid_archs)), |
| join("' `", @invalid_archs)) |
| if @invalid_archs >= 1; |
| grep(debarch_is($host_arch, $_), @archlist) || |
| error(_g("current host architecture '%s' does not " . |
| "appear in package's architecture list (%s)"), |
| $host_arch, "@archlist"); |
| $fields->{$_} = $host_arch; |
| } |
| } else { |
| field_transfer_single($pkg, $fields); |
| } |
| } |
| |
| # Scan fields of dpkg-parsechangelog |
| foreach $_ (keys %{$changelog}) { |
| my $v = $changelog->{$_}; |
| |
| if (m/^Source$/) { |
| set_source_package($v); |
| } elsif (m/^Version$/) { |
| $sourceversion = $v; |
| $fields->{$_} = $v unless defined($forceversion); |
| } elsif (m/^Maintainer$/) { |
| # That field must not be copied from changelog even if it's |
| # allowed in the binary package control information |
| } else { |
| field_transfer_single($changelog, $fields); |
| } |
| } |
| |
| $fields->{'Version'} = $forceversion if defined($forceversion); |
| |
| # Process dependency fields in a second pass, now that substvars have been |
| # initialized. |
| |
| my $facts = Dpkg::Deps::KnownFacts->new(); |
| $facts->add_installed_package($fields->{'Package'}, $fields->{'Version'}); |
| if (exists $pkg->{"Provides"}) { |
| my $provides = deps_parse($substvars->substvars($pkg->{"Provides"}, no_warn => 1), |
| reduce_arch => 1, union => 1); |
| if (defined $provides) { |
| foreach my $subdep ($provides->get_deps()) { |
| if ($subdep->isa('Dpkg::Deps::Simple')) { |
| $facts->add_provided_package($subdep->{package}, |
| $subdep->{relation}, $subdep->{version}, |
| $fields->{'Package'}); |
| } |
| } |
| } |
| } |
| |
| my (@seen_deps); |
| foreach my $field (field_list_pkg_dep()) { |
| # Arch: all can't be simplified as the host architecture is not known |
| my $reduce_arch = debarch_eq('all', $pkg->{Architecture} || "all") ? 0 : 1; |
| if (exists $pkg->{$field}) { |
| my $dep; |
| my $field_value = $substvars->substvars($pkg->{$field}, |
| msg_prefix => sprintf(_g("%s field of package %s: "), $field, $pkg->{Package})); |
| if (field_get_dep_type($field) eq 'normal') { |
| $dep = deps_parse($field_value, use_arch => 1, |
| reduce_arch => $reduce_arch); |
| error(_g("error occurred while parsing %s field: %s"), $field, |
| $field_value) unless defined $dep; |
| $dep->simplify_deps($facts, @seen_deps); |
| # Remember normal deps to simplify even further weaker deps |
| push @seen_deps, $dep; |
| } else { |
| $dep = deps_parse($field_value, use_arch => 1, |
| reduce_arch => $reduce_arch, union => 1); |
| error(_g("error occurred while parsing %s field: %s"), $field, |
| $field_value) unless defined $dep; |
| $dep->simplify_deps($facts); |
| $dep->sort(); |
| } |
| error(_g("the %s field contains an arch-specific dependency but the " . |
| "package is architecture all"), $field) |
| if $dep->has_arch_restriction(); |
| $fields->{$field} = $dep->output(); |
| delete $fields->{$field} unless $fields->{$field}; # Delete empty field |
| } |
| } |
| |
| for my $f (qw(Package Version)) { |
| defined($fields->{$f}) || error(_g("missing information for output field %s"), $f); |
| } |
| for my $f (qw(Maintainer Description Architecture)) { |
| defined($fields->{$f}) || warning(_g("missing information for output field %s"), $f); |
| } |
| $oppackage = $fields->{'Package'}; |
| |
| my $pkg_type = $pkg->{'Package-Type'} || |
| $pkg->get_custom_field('Package-Type') || 'deb'; |
| |
| if ($pkg_type eq 'udeb') { |
| delete $fields->{'Package-Type'}; |
| delete $fields->{'Homepage'}; |
| } else { |
| for my $f (qw(Subarchitecture Kernel-Version Installer-Menu-Item)) { |
| warning(_g("%s package with udeb specific field %s"), $pkg_type, $f) |
| if defined($fields->{$f}); |
| } |
| } |
| |
| my $verdiff = $fields->{'Version'} ne $substvars->get('source:Version') || |
| $fields->{'Version'} ne $sourceversion; |
| if ($oppackage ne $sourcepackage || $verdiff) { |
| $fields->{'Source'} = $sourcepackage; |
| $fields->{'Source'} .= " (" . $substvars->get('source:Version') . ")" if $verdiff; |
| } |
| |
| if (!defined($substvars->get('Installed-Size'))) { |
| defined(my $c = open(DU, "-|")) || syserr(_g("cannot fork for %s"), "du"); |
| if (!$c) { |
| chdir("$packagebuilddir") || |
| syserr(_g("chdir for du to \`%s'"), $packagebuilddir); |
| exec("du", "-k", "-s", "--apparent-size", ".") or |
| syserr(_g("unable to execute %s"), "du"); |
| } |
| my $duo = ''; |
| while (<DU>) { |
| $duo .= $_; |
| } |
| close(DU); |
| $? && subprocerr(_g("du in \`%s'"), $packagebuilddir); |
| $duo =~ m/^(\d+)\s+\.$/ || |
| error(_g("du gave unexpected output \`%s'"), $duo); |
| $substvars->set('Installed-Size', $1); |
| } |
| if (defined($substvars->get('Extra-Size'))) { |
| my $size = $substvars->get('Extra-Size') + $substvars->get('Installed-Size'); |
| $substvars->set('Installed-Size', $size); |
| } |
| if (defined($substvars->get('Installed-Size'))) { |
| $fields->{'Installed-Size'} = $substvars->get('Installed-Size'); |
| } |
| $substvars->no_warn('Installed-Size'); |
| |
| for my $f (keys %override) { |
| $fields->{$f} = $override{$f}; |
| } |
| for my $f (keys %remove) { |
| delete $fields->{$f}; |
| } |
| |
| $fileslistfile="./$fileslistfile" if $fileslistfile =~ m/^\s/; |
| open(Y, ">", "$fileslistfile.new") || syserr(_g("open new files list file")); |
| binmode(Y); |
| if (open(X, "<", $fileslistfile)) { |
| binmode(X); |
| while (<X>) { |
| chomp; |
| next if m/^([-+0-9a-z.]+)_[^_]+_([\w-]+)\.(a-z+) / |
| && ($1 eq $oppackage) |
| && ($3 eq $pkg_type) |
| && (debarch_eq($2, $fields->{'Architecture'} || "") |
| || debarch_eq($2, 'all')); |
| print(Y "$_\n") || syserr(_g("copy old entry to new files list file")); |
| } |
| close(X) || syserr(_g("close old files list file")); |
| } elsif ($! != ENOENT) { |
| syserr(_g("read old files list file")); |
| } |
| my $sversion = $fields->{'Version'}; |
| $sversion =~ s/^\d+://; |
| $forcefilename = sprintf("%s_%s_%s.%s", $oppackage, $sversion, |
| $fields->{'Architecture'} || "", $pkg_type) |
| unless ($forcefilename); |
| print(Y $substvars->substvars(sprintf("%s %s %s\n", $forcefilename, |
| $fields->{'Section'} || '-', |
| $fields->{'Priority'} || '-'))) |
| || syserr(_g("write new entry to new files list file")); |
| close(Y) || syserr(_g("close new files list file")); |
| rename("$fileslistfile.new", $fileslistfile) || syserr(_g("install new files list file")); |
| |
| my $cf; |
| my $fh_output; |
| if (!$stdout) { |
| $cf= "$packagebuilddir/DEBIAN/control"; |
| $cf= "./$cf" if $cf =~ m/^\s/; |
| open($fh_output, ">", "$cf.new") || |
| syserr(_g("cannot open new output control file \`%s'"), "$cf.new"); |
| } else { |
| $fh_output = \*STDOUT; |
| } |
| |
| $fields->apply_substvars($substvars); |
| $fields->output($fh_output); |
| |
| if (!$stdout) { |
| close($fh_output) || syserr(_g("cannot close %s"), "$cf.new"); |
| rename("$cf.new", "$cf") || |
| syserr(_g("cannot install output control file \`%s'"), $cf); |
| } |
| |
| $substvars->warn_about_unused(); |
