"Fossies" - the Fresh Open Source Software Archive

Member "dpkg-1.19.7/scripts/Dpkg/Source/Package/V1.pm" (9 May 2019, 17136 Bytes) of package /linux/misc/dpkg_1.19.7.tar.xz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. For more information about "V1.pm" see the Fossies "Dox" file reference documentation and the last Fossies "Diffs" side-by-side code changes report: 1.19.5_vs_1.19.6.

    1 # Copyright © 2008-2009 Raphaël Hertzog <hertzog@debian.org>
    2 # Copyright © 2008, 2012-2015 Guillem Jover <guillem@debian.org>
    3 #
    4 # This program is free software; you can redistribute it and/or modify
    5 # it under the terms of the GNU General Public License as published by
    6 # the Free Software Foundation; either version 2 of the License, or
    7 # (at your option) any later version.
    8 #
    9 # This program is distributed in the hope that it will be useful,
   10 # but WITHOUT ANY WARRANTY; without even the implied warranty of
   11 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   12 # GNU General Public License for more details.
   13 #
   14 # You should have received a copy of the GNU General Public License
   15 # along with this program.  If not, see <https://www.gnu.org/licenses/>.
   16 
   17 package Dpkg::Source::Package::V1;
   18 
   19 use strict;
   20 use warnings;
   21 
   22 our $VERSION = '0.01';
   23 
   24 use Errno qw(ENOENT);
   25 use Cwd;
   26 use File::Basename;
   27 use File::Temp qw(tempfile);
   28 use File::Spec;
   29 
   30 use Dpkg ();
   31 use Dpkg::Gettext;
   32 use Dpkg::ErrorHandling;
   33 use Dpkg::Compression;
   34 use Dpkg::Source::Archive;
   35 use Dpkg::Source::Patch;
   36 use Dpkg::Exit qw(push_exit_handler pop_exit_handler);
   37 use Dpkg::Source::Functions qw(erasedir);
   38 use Dpkg::Source::Package::V3::Native;
   39 use Dpkg::OpenPGP;
   40 
   41 use parent qw(Dpkg::Source::Package);
   42 
   43 our $CURRENT_MINOR_VERSION = '0';
   44 
   45 sub init_options {
   46     my $self = shift;
   47 
   48     # Don't call $self->SUPER::init_options() on purpose, V1.0 has no
   49     # ignore by default
   50     if ($self->{options}{diff_ignore_regex}) {
   51     $self->{options}{diff_ignore_regex} .= '|(?:^|/)debian/source/local-.*$';
   52     } else {
   53     $self->{options}{diff_ignore_regex} = '(?:^|/)debian/source/local-.*$';
   54     }
   55     $self->{options}{diff_ignore_regex} .= '|(?:^|/)debian/files(?:\.new)?$';
   56     push @{$self->{options}{tar_ignore}},
   57          'debian/source/local-options',
   58          'debian/source/local-patch-header',
   59          'debian/files',
   60          'debian/files.new';
   61     $self->{options}{sourcestyle} //= 'X';
   62     $self->{options}{skip_debianization} //= 0;
   63     $self->{options}{ignore_bad_version} //= 0;
   64     $self->{options}{abort_on_upstream_changes} //= 0;
   65 
   66     # V1.0 only supports gzip compression.
   67     $self->{options}{compression} //= 'gzip';
   68     $self->{options}{comp_level} //= compression_get_property('gzip', 'default_level');
   69     $self->{options}{comp_ext} //= compression_get_property('gzip', 'file_ext');
   70 }
   71 
   72 my @module_cmdline = (
   73     {
   74         name => '-sa',
   75         help => N_('auto select original source'),
   76         when => 'build',
   77     }, {
   78         name => '-sk',
   79         help => N_('use packed original source (unpack and keep)'),
   80         when => 'build',
   81     }, {
   82         name => '-sp',
   83         help => N_('use packed original source (unpack and remove)'),
   84         when => 'build',
   85     }, {
   86         name => '-su',
   87         help => N_('use unpacked original source (pack and keep)'),
   88         when => 'build',
   89     }, {
   90         name => '-sr',
   91         help => N_('use unpacked original source (pack and remove)'),
   92         when => 'build',
   93     }, {
   94         name => '-ss',
   95         help => N_('trust packed and unpacked original sources are same'),
   96         when => 'build',
   97     }, {
   98         name => '-sn',
   99         help => N_('there is no diff, do main tarfile only'),
  100         when => 'build',
  101     }, {
  102         name => '-sA, -sK, -sP, -sU, -sR',
  103         help => N_('like -sa, -sk, -sp, -su, -sr but may overwrite'),
  104         when => 'build',
  105     }, {
  106         name => '--abort-on-upstream-changes',
  107         help => N_('abort if generated diff has upstream files changes'),
  108         when => 'build',
  109     }, {
  110         name => '-sp',
  111         help => N_('leave original source packed in current directory'),
  112         when => 'extract',
  113     }, {
  114         name => '-su',
  115         help => N_('do not copy original source to current directory'),
  116         when => 'extract',
  117     }, {
  118         name => '-sn',
  119         help => N_('unpack original source tree too'),
  120         when => 'extract',
  121     }, {
  122         name => '--skip-debianization',
  123         help => N_('do not apply debian diff to upstream sources'),
  124         when => 'extract',
  125     },
  126 );
  127 
  128 sub describe_cmdline_options {
  129     return @module_cmdline;
  130 }
  131 
  132 sub parse_cmdline_option {
  133     my ($self, $opt) = @_;
  134     my $o = $self->{options};
  135     if ($opt =~ m/^-s([akpursnAKPUR])$/) {
  136         warning(g_('-s%s option overrides earlier -s%s option'), $1,
  137                 $o->{sourcestyle}) if $o->{sourcestyle} ne 'X';
  138         $o->{sourcestyle} = $1;
  139         $o->{copy_orig_tarballs} = 0 if $1 eq 'n'; # Extract option -sn
  140         return 1;
  141     } elsif ($opt eq '--skip-debianization') {
  142         $o->{skip_debianization} = 1;
  143         return 1;
  144     } elsif ($opt eq '--ignore-bad-version') {
  145         $o->{ignore_bad_version} = 1;
  146         return 1;
  147     } elsif ($opt eq '--abort-on-upstream-changes') {
  148         $o->{abort_on_upstream_changes} = 1;
  149         return 1;
  150     }
  151     return 0;
  152 }
  153 
  154 sub do_extract {
  155     my ($self, $newdirectory) = @_;
  156     my $sourcestyle = $self->{options}{sourcestyle};
  157     my $fields = $self->{fields};
  158 
  159     $sourcestyle =~ y/X/p/;
  160     unless ($sourcestyle =~ m/[pun]/) {
  161     usageerr(g_('source handling style -s%s not allowed with -x'),
  162              $sourcestyle);
  163     }
  164 
  165     my $dscdir = $self->{basedir};
  166 
  167     my $basename = $self->get_basename();
  168     my $basenamerev = $self->get_basename(1);
  169 
  170     # V1.0 only supports gzip compression
  171     my ($tarfile, $difffile);
  172     my $tarsign;
  173     foreach my $file ($self->get_files()) {
  174     if ($file =~ /^(?:\Q$basename\E\.orig|\Q$basenamerev\E)\.tar\.gz$/) {
  175             error(g_('multiple tarfiles in v1.0 source package')) if $tarfile;
  176             $tarfile = $file;
  177         } elsif ($file =~ /^\Q$basename\E\.orig\.tar\.gz\.asc$/) {
  178             $tarsign = $file;
  179     } elsif ($file =~ /^\Q$basenamerev\E\.diff\.gz$/) {
  180         $difffile = $file;
  181     } else {
  182         error(g_('unrecognized file for a %s source package: %s'),
  183                   'v1.0', $file);
  184     }
  185     }
  186 
  187     error(g_('no tarfile in Files field')) unless $tarfile;
  188     my $native = $difffile ? 0 : 1;
  189     if ($native and ($tarfile =~ /\.orig\.tar\.gz$/)) {
  190         warning(g_('native package with .orig.tar'));
  191         $native = 0; # V3::Native doesn't handle orig.tar
  192     }
  193 
  194     if ($native) {
  195         Dpkg::Source::Package::V3::Native::do_extract($self, $newdirectory);
  196     } else {
  197         my $expectprefix = $newdirectory;
  198         $expectprefix .= '.orig';
  199 
  200         if ($self->{options}{no_overwrite_dir} and -e $newdirectory) {
  201             error(g_('unpack target exists: %s'), $newdirectory);
  202         } else {
  203             erasedir($newdirectory);
  204         }
  205         if (-e $expectprefix) {
  206             rename($expectprefix, "$newdirectory.tmp-keep")
  207                 or syserr(g_("unable to rename '%s' to '%s'"), $expectprefix,
  208                           "$newdirectory.tmp-keep");
  209         }
  210 
  211         info(g_('unpacking %s'), $tarfile);
  212         my $tar = Dpkg::Source::Archive->new(filename => "$dscdir$tarfile");
  213         $tar->extract($expectprefix);
  214 
  215         if ($sourcestyle =~ /u/) {
  216             # -su: keep .orig directory unpacked
  217             if (-e "$newdirectory.tmp-keep") {
  218                 error(g_('unable to keep orig directory (already exists)'));
  219             }
  220             system('cp', '-ar', '--', $expectprefix, "$newdirectory.tmp-keep");
  221             subprocerr("cp $expectprefix to $newdirectory.tmp-keep") if $?;
  222         }
  223 
  224     rename($expectprefix, $newdirectory)
  225         or syserr(g_('failed to rename newly-extracted %s to %s'),
  226                   $expectprefix, $newdirectory);
  227 
  228     # rename the copied .orig directory
  229     if (-e "$newdirectory.tmp-keep") {
  230         rename("$newdirectory.tmp-keep", $expectprefix)
  231             or syserr(g_('failed to rename saved %s to %s'),
  232                       "$newdirectory.tmp-keep", $expectprefix);
  233         }
  234     }
  235 
  236     if ($difffile and not $self->{options}{skip_debianization}) {
  237         my $patch = "$dscdir$difffile";
  238     info(g_('applying %s'), $difffile);
  239     my $patch_obj = Dpkg::Source::Patch->new(filename => $patch);
  240     my $analysis = $patch_obj->apply($newdirectory, force_timestamp => 1);
  241     my @files = grep { ! m{^\Q$newdirectory\E/debian/} }
  242             sort keys %{$analysis->{filepatched}};
  243     info(g_('upstream files that have been modified: %s'),
  244          "\n " . join("\n ", @files)) if scalar @files;
  245     }
  246 }
  247 
  248 sub can_build {
  249     my ($self, $dir) = @_;
  250 
  251     # As long as we can use gzip, we can do it as we have
  252     # native packages as fallback
  253     return (0, g_('only supports gzip compression'))
  254         unless $self->{options}{compression} eq 'gzip';
  255     return 1;
  256 }
  257 
  258 sub do_build {
  259     my ($self, $dir) = @_;
  260     my $sourcestyle = $self->{options}{sourcestyle};
  261     my @argv = @{$self->{options}{ARGV}};
  262     my @tar_ignore = map { "--exclude=$_" } @{$self->{options}{tar_ignore}};
  263     my $diff_ignore_regex = $self->{options}{diff_ignore_regex};
  264 
  265     if (scalar(@argv) > 1) {
  266         usageerr(g_('-b takes at most a directory and an orig source ' .
  267                     'argument (with v1.0 source package)'));
  268     }
  269 
  270     $sourcestyle =~ y/X/a/;
  271     unless ($sourcestyle =~ m/[akpursnAKPUR]/) {
  272         usageerr(g_('source handling style -s%s not allowed with -b'),
  273                  $sourcestyle);
  274     }
  275 
  276     my $sourcepackage = $self->{fields}{'Source'};
  277     my $basenamerev = $self->get_basename(1);
  278     my $basename = $self->get_basename();
  279     my $basedirname = $basename;
  280     $basedirname =~ s/_/-/;
  281 
  282     # Try to find a .orig tarball for the package
  283     my $origdir = "$dir.orig";
  284     my $origtargz = $self->get_basename() . '.orig.tar.gz';
  285     if (-e $origtargz) {
  286         unless (-f $origtargz) {
  287             error(g_("packed orig '%s' exists but is not a plain file"), $origtargz);
  288         }
  289     } else {
  290         $origtargz = undef;
  291     }
  292 
  293     if (@argv) {
  294     # We have a second-argument <orig-dir> or <orig-targz>, check what it
  295     # is to decide the mode to use
  296         my $origarg = shift(@argv);
  297         if (length($origarg)) {
  298             stat($origarg)
  299                 or syserr(g_('cannot stat orig argument %s'), $origarg);
  300             if (-d _) {
  301                 $origdir = File::Spec->catdir($origarg);
  302 
  303                 $sourcestyle =~ y/aA/rR/;
  304                 unless ($sourcestyle =~ m/[ursURS]/) {
  305                     error(g_('orig argument is unpacked but source handling ' .
  306                              'style -s%s calls for packed (.orig.tar.<ext>)'),
  307                           $sourcestyle);
  308                 }
  309             } elsif (-f _) {
  310                 $origtargz = $origarg;
  311                 $sourcestyle =~ y/aA/pP/;
  312                 unless ($sourcestyle =~ m/[kpsKPS]/) {
  313                     error(g_('orig argument is packed but source handling ' .
  314                              'style -s%s calls for unpacked (.orig/)'),
  315                           $sourcestyle);
  316                 }
  317             } else {
  318                 error(g_('orig argument %s is not a plain file or directory'),
  319                       $origarg);
  320             }
  321         } else {
  322             $sourcestyle =~ y/aA/nn/;
  323             unless ($sourcestyle =~ m/n/) {
  324                 error(g_('orig argument is empty (means no orig, no diff) ' .
  325                          'but source handling style -s%s wants something'),
  326                       $sourcestyle);
  327             }
  328         }
  329     } elsif ($sourcestyle =~ m/[aA]/) {
  330     # We have no explicit <orig-dir> or <orig-targz>, try to use
  331     # a .orig tarball first, then a .orig directory and fall back to
  332     # creating a native .tar.gz
  333     if ($origtargz) {
  334         $sourcestyle =~ y/aA/pP/; # .orig.tar.<ext>
  335     } else {
  336         if (stat($origdir)) {
  337         unless (-d _) {
  338                     error(g_("unpacked orig '%s' exists but is not a directory"),
  339                   $origdir);
  340                 }
  341         $sourcestyle =~ y/aA/rR/; # .orig directory
  342         } elsif ($! != ENOENT) {
  343         syserr(g_("unable to stat putative unpacked orig '%s'"), $origdir);
  344         } else {
  345         $sourcestyle =~ y/aA/nn/; # Native tar.gz
  346         }
  347     }
  348     }
  349 
  350     my ($dirname, $dirbase) = fileparse($dir);
  351     if ($dirname ne $basedirname) {
  352     warning(g_("source directory '%s' is not <sourcepackage>" .
  353                "-<upstreamversion> '%s'"), $dir, $basedirname);
  354     }
  355 
  356     my ($tarname, $tardirname, $tardirbase);
  357     my $tarsign;
  358     if ($sourcestyle ne 'n') {
  359     my ($origdirname, $origdirbase) = fileparse($origdir);
  360 
  361         if ($origdirname ne "$basedirname.orig") {
  362             warning(g_('.orig directory name %s is not <package>' .
  363                    '-<upstreamversion> (wanted %s)'),
  364                 $origdirname, "$basedirname.orig");
  365         }
  366         $tardirbase = $origdirbase;
  367         $tardirname = $origdirname;
  368 
  369     $tarname = $origtargz || "$basename.orig.tar.gz";
  370     $tarsign = "$tarname.asc";
  371     unless ($tarname =~ /\Q$basename\E\.orig\.tar\.gz/) {
  372         warning(g_('.orig.tar name %s is not <package>_<upstreamversion>' .
  373                    '.orig.tar (wanted %s)'),
  374                 $tarname, "$basename.orig.tar.gz");
  375     }
  376     }
  377 
  378     if ($sourcestyle eq 'n') {
  379         $self->{options}{ARGV} = []; # ensure we have no error
  380         Dpkg::Source::Package::V3::Native::do_build($self, $dir);
  381     } elsif ($sourcestyle =~ m/[urUR]/) {
  382         if (stat($tarname)) {
  383             unless ($sourcestyle =~ m/[UR]/) {
  384         error(g_("tarfile '%s' already exists, not overwriting, " .
  385                  'giving up; use -sU or -sR to override'), $tarname);
  386             }
  387         } elsif ($! != ENOENT) {
  388         syserr(g_("unable to check for existence of '%s'"), $tarname);
  389         }
  390 
  391     info(g_('building %s in %s'),
  392          $sourcepackage, $tarname);
  393 
  394     my ($ntfh, $newtar) = tempfile("$tarname.new.XXXXXX",
  395                        DIR => getcwd(), UNLINK => 0);
  396     my $tar = Dpkg::Source::Archive->new(filename => $newtar,
  397             compression => compression_guess_from_filename($tarname),
  398             compression_level => $self->{options}{comp_level});
  399     $tar->create(options => \@tar_ignore, chdir => $tardirbase);
  400     $tar->add_directory($tardirname);
  401     $tar->finish();
  402     rename($newtar, $tarname)
  403         or syserr(g_("unable to rename '%s' (newly created) to '%s'"),
  404                   $newtar, $tarname);
  405     chmod(0666 &~ umask(), $tarname)
  406         or syserr(g_("unable to change permission of '%s'"), $tarname);
  407     } else {
  408     info(g_('building %s using existing %s'),
  409          $sourcepackage, $tarname);
  410     }
  411 
  412     $self->add_file($tarname) if $tarname;
  413     if ($tarname and -e "$tarname.sig" and not -e "$tarname.asc") {
  414         openpgp_sig_to_asc("$tarname.sig", "$tarname.asc");
  415     }
  416     if ($tarsign and -e $tarsign) {
  417         info(g_('building %s using existing %s'), $sourcepackage, $tarsign);
  418         $self->add_file($tarsign);
  419     }
  420 
  421     if ($sourcestyle =~ m/[kpKP]/) {
  422         if (stat($origdir)) {
  423             unless ($sourcestyle =~ m/[KP]/) {
  424                 error(g_("orig directory '%s' already exists, not overwriting, ".
  425                          'giving up; use -sA, -sK or -sP to override'),
  426                       $origdir);
  427             }
  428             push_exit_handler(sub { erasedir($origdir) });
  429             erasedir($origdir);
  430             pop_exit_handler();
  431         } elsif ($! != ENOENT) {
  432             syserr(g_("unable to check for existence of orig directory '%s'"),
  433                     $origdir);
  434         }
  435 
  436     my $tar = Dpkg::Source::Archive->new(filename => $origtargz);
  437     $tar->extract($origdir);
  438     }
  439 
  440     my $ur; # Unrepresentable changes
  441     if ($sourcestyle =~ m/[kpursKPUR]/) {
  442     my $diffname = "$basenamerev.diff.gz";
  443     info(g_('building %s in %s'),
  444          $sourcepackage, $diffname);
  445     my ($ndfh, $newdiffgz) = tempfile("$diffname.new.XXXXXX",
  446                     DIR => getcwd(), UNLINK => 0);
  447         push_exit_handler(sub { unlink($newdiffgz) });
  448         my $diff = Dpkg::Source::Patch->new(filename => $newdiffgz,
  449                                             compression => 'gzip',
  450                                             compression_level => $self->{options}{comp_level});
  451         $diff->create();
  452         $diff->add_diff_directory($origdir, $dir,
  453                 basedirname => $basedirname,
  454                 diff_ignore_regex => $diff_ignore_regex,
  455                 options => []); # Force empty set of options to drop the
  456                                 # default -p option
  457         $diff->finish() || $ur++;
  458         pop_exit_handler();
  459 
  460     my $analysis = $diff->analyze($origdir);
  461     my @files = grep { ! m{^debian/} }
  462             map { s{^[^/]+/+}{}r }
  463             sort keys %{$analysis->{filepatched}};
  464     if (scalar @files) {
  465         warning(g_('the diff modifies the following upstream files: %s'),
  466                 "\n " . join("\n ", @files));
  467         info(g_("use the '3.0 (quilt)' format to have separate and " .
  468                 'documented changes to upstream files, see dpkg-source(1)'));
  469         error(g_('aborting due to --abort-on-upstream-changes'))
  470         if $self->{options}{abort_on_upstream_changes};
  471     }
  472 
  473     rename($newdiffgz, $diffname)
  474         or syserr(g_("unable to rename '%s' (newly created) to '%s'"),
  475                   $newdiffgz, $diffname);
  476     chmod(0666 &~ umask(), $diffname)
  477         or syserr(g_("unable to change permission of '%s'"), $diffname);
  478 
  479     $self->add_file($diffname);
  480     }
  481 
  482     if ($sourcestyle =~ m/[prPR]/) {
  483         erasedir($origdir);
  484     }
  485 
  486     if ($ur) {
  487         errormsg(g_('unrepresentable changes to source'));
  488         exit(1);
  489     }
  490 }
  491 
  492 1;