From 53cef9d5cf86b7db01a2c1ac251c75eaaff5f8b1 Mon Sep 17 00:00:00 2001 From: Raphael Hertzog Date: Sun, 24 Feb 2008 22:11:46 +0100 Subject: [PATCH] Dpkg::Source::Package and Dpkg::Source::Package:V1_0: new modules * scripts/Dpkg/Source/Package.pm: New module that represents a source package. It provides some common functions and is the base class from which real format of source packages must derive. The two main functions that subclass must implement are build($dir) and extract($dir). * scripts/Dpkg/Source/Package/V1_0.pm: Implementation of the Debian source package version 1.0, the current version in wide-spread use. --- scripts/Dpkg/Source/Package.pm | 263 ++++++++++++++++++++ scripts/Dpkg/Source/Package/V1_0.pm | 373 ++++++++++++++++++++++++++++ scripts/Makefile.am | 2 + 3 files changed, 638 insertions(+) create mode 100644 scripts/Dpkg/Source/Package.pm create mode 100644 scripts/Dpkg/Source/Package/V1_0.pm diff --git a/scripts/Dpkg/Source/Package.pm b/scripts/Dpkg/Source/Package.pm new file mode 100644 index 00000000..61bda058 --- /dev/null +++ b/scripts/Dpkg/Source/Package.pm @@ -0,0 +1,263 @@ +# Copyright 2008 Raphaël Hertzog + +# 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, write to the Free Software Foundation, Inc., +# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + +package Dpkg::Source::Package; + +use strict; +use warnings; + +use Dpkg::Gettext; +use Dpkg::ErrorHandling qw(error syserr warning internerr); +use Dpkg::Fields; +use Dpkg::Cdata; +use Dpkg::Checksums; +use Dpkg::Version qw(parseversion); +use Dpkg::Deps qw(@src_dep_fields); + +use File::Basename; + +my @dsc_fields = (qw(Format Source Binary Architecture Version Origin + Maintainer Uploaders Dm-Upload-Allowed Homepage + Standards-Version Vcs-Browser Vcs-Arch Vcs-Bzr + Vcs-Cvs Vcs-Darcs Vcs-Git Vcs-Hg Vcs-Mtn Vcs-Svn), + @src_dep_fields, + qw(Files)); + +# Object methods +sub new { + my ($this, %args) = @_; + my $class = ref($this) || $this; + my $self = { + 'fields' => Dpkg::Fields::Object->new(), + 'options' => {}, + }; + bless $self, $class; + if (exists $args{"filename"}) { + $self->initialize($args{"filename"}); + } + if (exists $args{"options"}) { + $self->{'options'} = $args{'options'}; + } + return $self; +} + +sub initialize { + my ($self, $filename) = @_; + my ($fn, $dir) = fileparse($filename); + error(_g("%s is not the name of a file"), $filename) unless $fn; + $self->{'basedir'} = $dir || "./"; + $self->{'filename'} = $fn; + + # Check if it contains a signature + open(DSC, "<", $filename) || syserr(_g("cannot open %s"), $filename); + $self->{'is_signed'} = 0; + while () { + next if /^\s*$/o; + $self->{'is_signed'} = 1 if /^-----BEGIN PGP SIGNED MESSAGE-----$/o; + last; + } + close(DSC); + # Read the fields + open(CDATA, "<", $filename) || syserr(_g("cannot open %s"), $filename); + my $fields = parsecdata(\*CDATA, + sprintf(_g("source control file %s"), $filename), + allow_pgp => 1); + close(CDATA); + $self->{'fields'} = $fields; + + foreach my $f (qw(Source Format Version Files)) { + unless (defined($fields->{$f})) { + error(_g("missing critical source control field %s"), $f); + } + } + + $self->parse_files(); + + $self->upgrade_object_type(); +} + +sub upgrade_object_type { + my ($self) = @_; + my $format = $self->{'fields'}{'Format'}; + + if ($format =~ /^([\d\.]+)(?:\s+\((.*)\))?$/) { + my ($version, $variant) = ($1, $2); + $version =~ s/\./_/; + my $module = "Dpkg::Source::Package::V$version"; + $module .= "::$variant" if defined $variant; + eval "require $module"; + if ($@) { + error(_g("source package format `%s' is not supported (perl module %s is required)"), $format, $module); + } + bless $self, $module; + } else { + error(_g("invalid Format field `%s'"), $format); + } +} + +sub get_filename { + my ($self) = @_; + return $self->{'basedir'} . $self->{'filename'}; +} + +sub get_files { + my ($self) = @_; + return keys %{$self->{'files'}}; +} + +sub parse_files { + my ($self) = @_; + my $rx_fname = qr/[0-9a-zA-Z][-+:.,=0-9a-zA-Z_~]+/; + my $files = $self->{'fields'}{'Files'}; + foreach my $file (split(/\n /, $files)) { + next if $file eq ''; + $file =~ m/^($check_regex{md5}) # checksum + [ \t]+(\d+) # size + [ \t]+($rx_fname) # filename + $/x + || error(_g("Files field contains bad line `%s'"), $file); + if (exists $self->{'files'}{$3}) { + error(_g("file `%s' listed twice in Files field"), $3); + } else { + $self->{'files'}{$3} = $2; + } + } +} + +sub check_checksums { + my ($self) = @_; + my ($fields, %checksum, %size) = $self->{'fields'}; + my $has_md5 = 1; + if (not exists $fields->{'Checksums-Md5'}) { + $fields->{'Checksums-Md5'} = $fields->{'Files'}; + $has_md5 = 0; + } + # extract the checksums from the fields in two hashes + readallchecksums($self->{'fields'}, \%checksum, \%size); + delete $fields->{'Checksums-Md5'} unless $has_md5; + # getchecksums verify the checksums if they are pre-filled + foreach my $file ($self->get_files()) { + getchecksums($self->{'basedir'} . $file, $checksum{$file}, + \$size{$file}); + } +} + +sub get_basename { + my ($self, $with_revision) = @_; + my $f = $self->{'fields'}; + unless (exists $f->{'Source'} and exists $f->{'Version'}) { + error(_g("source and version are required to compute the source basename")); + } + my %v = parseversion($f->{'Version'}); + my $basename = $f->{'Source'} . "_" . $v{"version"}; + if ($with_revision and $f->{'Version'} =~ /-/) { + $basename .= "-" . $v{'revision'}; + } + return $basename; +} + +sub is_signed { + my $self = shift; + return $self->{'is_signed'}; +} + +sub check_signature { + my ($self) = @_; + my $dsc = $self->get_filename(); + if (-x '/usr/bin/gpg') { + my $gpg_command = 'gpg -q --verify '; + if (-r '/usr/share/keyrings/debian-keyring.gpg') { + $gpg_command = $gpg_command.'--keyring /usr/share/keyrings/debian-keyring.gpg '; + } + $gpg_command = $gpg_command.quotemeta($dsc).' 2>&1'; + + #TODO: cleanup here + my @gpg_output = `$gpg_command`; + my $gpg_status = $? >> 8; + if ($gpg_status) { + print STDERR join("",@gpg_output); + error(_g("failed to verify signature on %s"), $dsc) + if ($gpg_status == 1); + } + } else { + warning(_g("could not verify signature on %s since gpg isn't installed"), + $dsc); + } +} + +sub extract { + error("Dpkg::Source::Package doesn't know how to unpack a source package. Use one of the subclass."); +} + +# Function used specifically during creation of a source package + +sub build { + error("Dpkg::Source::Package doesn't know how to build a source package. Use one of the subclass."); +} + +sub add_file { + my ($self, $filename) = @_; + if (exists $self->{'files'}{$filename}) { + internerr(_g("tried to add file `%s' twice"), $filename); + } + my (%sums, $size); + getchecksums($filename, \%sums, \$size); + $self->{'files'}{$filename} = $size; + foreach my $alg (sort keys %sums) { + $self->{'fields'}{"Checksums-$alg"} .= "\n $sums{$alg} $size $filename"; + } + $self->{'fields'}{'Files'}.= "\n $sums{md5} $size $filename"; +} + +sub write_dsc { + my ($self, %opts) = @_; + my $fields = $self->{'fields'}; + + foreach my $f (keys %{$opts{'override'}}) { + $fields->{$f} = $opts{'override'}{$f}; + } + + unless($opts{'nocheck'}) { + foreach my $f (qw(Source Version)) { + unless (defined($fields->{$f})) { + error(_g("missing information for critical output field %s"), $f); + } + } + foreach my $f (qw(Maintainer Architecture Standards-Version)) { + unless (defined($fields->{$f})) { + warning(_g("missing information for output field %s"), $f); + } + } + } + + foreach my $f (keys %{$opts{'remove'}}) { + delete $fields->{$f}; + } + + my $filename = $opts{'filename'}; + unless (defined $filename) { + $filename = $self->get_basename(1) . ".dsc"; + } + open(DSC, ">", $filename) || syserr(_g("cannot write %s"), $filename); + + delete $fields->{'Checksums-Md5'}; # identical with Files field + tied(%{$fields})->set_field_importance(@dsc_fields); + tied(%{$fields})->output(\*DSC, $opts{'substvars'}); + close(DSC); +} + +# vim: set et sw=4 ts=8 +1; diff --git a/scripts/Dpkg/Source/Package/V1_0.pm b/scripts/Dpkg/Source/Package/V1_0.pm new file mode 100644 index 00000000..8760a06e --- /dev/null +++ b/scripts/Dpkg/Source/Package/V1_0.pm @@ -0,0 +1,373 @@ +# Copyright 2008 Raphaël Hertzog + +# 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, write to the Free Software Foundation, Inc., +# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + +package Dpkg::Source::Package::V1_0; + +use strict; +use warnings; + +use base 'Dpkg::Source::Package'; + +use Dpkg; +use Dpkg::Gettext; +use Dpkg::ErrorHandling qw(error syserr warning usageerr subprocerr); +use Dpkg::Compression; +use Dpkg::Source::Archive; +use Dpkg::Source::Patch; +use Dpkg::Version qw(check_version parseversion); +use Dpkg::Exit; +use Dpkg::Source::Functions qw(erasedir); + +use POSIX; +use File::Basename; +use File::Temp qw(tempfile); + +sub extract { + my ($self, $newdirectory) = @_; + my $sourcestyle = $self->{'options'}{'sourcestyle'}; + my $fields = $self->{'fields'}; + + $sourcestyle =~ y/X/p/; + $sourcestyle =~ m/[pun]/ || + usageerr(_g("source handling style -s%s not allowed with -x"), + $sourcestyle); + + my $dsc = $self->get_filename(); + my $dscdir = $self->{'basedir'}; + + my $sourcepackage = $fields->{'Source'}; + + check_version($fields->{'Version'}); + + my %v = parseversion($fields->{'Version'}); + my $baseversion = $v{'version'}; + my $revision = ($version =~ m/-/) ? $v{'revision'} : ''; + my $version = $baseversion . ($revision ? "-$revision" : ""); + my $basename = $self->get_basename(); + my $basenamerev = $self->get_basename(1); + + # V1.0 only supports gzip compression + my ($tarfile, $difffile); + foreach my $file ($self->get_files()) { + if ($file =~ /^(?:\Q$basename\E\.orig|\Q$basenamerev\E)\.tar\.gz$/) { + error(_g("multiple tarfiles in v1.0 source package")) if $tarfile; + $tarfile = $file; + } elsif ($file =~ /^\Q$basenamerev\E\.diff\.gz$/) { + $difffile = $file; + } else { + error(_g("unrecognized file for a v1.0 source package: %s"), $file); + } + } + + error(_g("no tarfile in Files field")) unless $tarfile; + my $native = $difffile ? 0 : 1; + if ($native) { + warning(_g("native package with .orig.tar")) + if $tarfile =~ /\.orig\.tar\.gz$/; + } else { + warning(_g("no upstream tarfile in Files field")) + unless defined $tarfile; + } + + $newdirectory = $sourcepackage.'-'.$baseversion unless defined($newdirectory); + my $expectprefix = $newdirectory; + $expectprefix .= '.orig' if $difffile; + + erasedir($newdirectory); + if (-e "$expectprefix") { + rename("$expectprefix","$newdirectory.tmp-keep") || + syserr(_g("unable to rename `%s' to `%s'"), $expectprefix, + "$newdirectory.tmp-keep"); + } + + printf(_g("%s: unpacking %s")."\n", $progname, $tarfile); + my $tar = Dpkg::Source::Archive->new(filename => "$dscdir$tarfile"); + $tar->extract($expectprefix); + + # for the first tar file: + if ($tarfile and not $native) + { + # -sp: copy the .orig.tar.gz if required + if ($sourcestyle =~ /p/) { + stat("$dscdir$tarfile") || + syserr(_g("failed to stat `%s' to see if need to copy"), + "$dscdir$tarfile"); + + my ($dsctardev, $dsctarino) = stat _; + my $copy_required; + + if (stat($tarfile)) { + my ($dumptardev, $dumptarino) = stat _; + $copy_required = ($dumptardev != $dsctardev || + $dumptarino != $dsctarino); + } else { + unless ($! == ENOENT) { + syserr(_g("failed to check destination `%s' " . + "to see if need to copy"), $tarfile); + } + $copy_required = 1; + } + + if ($copy_required) { + system('cp','--',"$dscdir$tarfile", $tarfile); + subprocerr("cp $dscdir$tarfile to $tarfile") if $?; + } + } + # -su: keep .orig directory unpacked + elsif ($sourcestyle =~ /u/ and $expectprefix ne $newdirectory) { + if (-e "$newdirectory.tmp-keep") { + error(_g("unable to keep orig directory (already exists)")); + } + system('cp','-ar','--',$expectprefix,"$newdirectory.tmp-keep"); + subprocerr("cp $expectprefix to $newdirectory.tmp-keep") if $?; + } + } + + if ($newdirectory ne $expectprefix) + { + rename($expectprefix,$newdirectory) || + syserr(_g("failed to rename newly-extracted %s to %s"), + $expectprefix, $newdirectory); + + # rename the copied .orig directory + if (-e "$newdirectory.tmp-keep") { + rename("$newdirectory.tmp-keep",$expectprefix) || + syserr(_g("failed to rename saved %s to %s"), + "$newdirectory.tmp-keep", $expectprefix); + } + } + + if ($difffile) { + my $patch = "$dscdir$difffile"; + printf(_g("%s: applying %s")."\n", $progname, $patch); + my $patch_obj = Dpkg::Source::Patch->new(filename => $patch); + $patch_obj->apply($newdirectory, force_timestamp => 1, + timestamp => time()); + } +} + +sub build { + my ($self, $dir) = @_; + my $sourcestyle = $self->{'options'}{'sourcestyle'}; + my @argv = @{$self->{'options'}{'ARGV'}}; + my @tar_ignore = map { "--exclude=$_" } @{$self->{'options'}{'tar_ignore'}}; + my $diff_ignore_regexp = $self->{'options'}{'diff_ignore_regexp'}; + + $dir =~ s{/+$}{}; # Strip trailing / + + if (scalar(@argv) > 1) { + usageerr(_g("-b takes at most a directory and an orig source ". + "argument (with v1.0 source package)")); + } + + $sourcestyle =~ y/X/A/; + unless ($sourcestyle =~ m/[akpursnAKPUR]/) { + usageerr(_g("source handling style -s%s not allowed with -b"), + $sourcestyle); + } + + my $sourcepackage = $self->{'fields'}{'Source'}; + my $basenamerev = $self->get_basename(1); + my $basename = $self->get_basename(); + my $basedirname = $basename; + $basedirname =~ s/_/-/; + + # Try to find a .orig tarball for the package + my $origdir = "$dir.orig"; + my $origtargz = $self->get_basename() . ".orig.tar.gz"; + if (-e $origtargz) { + unless (-f $origtargz) { + error(_g("packed orig `%s' exists but is not a plain file"), $origtargz); + } + } else { + $origtargz = undef; + } + + if (@argv) { + # We have a second-argument or , check what it + # is to decide the mode to use + my $origarg = shift(@argv); + if (length($origarg)) { + stat($origarg) || + syserr(_g("cannot stat orig argument %s"), $origarg); + if (-d _) { + $origdir = $origarg; + $origdir =~ s{/*$}{}; + + $sourcestyle =~ y/aA/rR/; + unless ($sourcestyle =~ m/[ursURS]/) { + error(_g("orig argument is unpacked but source handling " . + "style -s%s calls for packed (.orig.tar.)"), + $sourcestyle); + } + } elsif (-f _) { + $origtargz = $origarg; + $sourcestyle =~ y/aA/pP/; + unless ($sourcestyle =~ m/[kpsKPS]/) { + error(_g("orig argument is packed but source handling " . + "style -s%s calls for unpacked (.orig/)"), + $sourcestyle); + } + } else { + error("orig argument $origarg is not a plain file or directory"); + } + } else { + $sourcestyle =~ y/aA/nn/; + $sourcestyle =~ m/n/ || + error(_g("orig argument is empty (means no orig, no diff) " . + "but source handling style -s%s wants something"), + $sourcestyle); + } + } elsif ($sourcestyle =~ m/[aA]/) { + # We have no explicit or , try to use + # a .orig tarball first, then a .orig directory and fall back to + # creating a native .tar.gz + if ($origtargz) { + $sourcestyle =~ y/aA/pP/; # .orig.tar. + } else { + if (stat($origdir)) { + unless (-d _) { + error(_g("unpacked orig `%s' exists but is not a directory"), + $origdir); + } + $sourcestyle =~ y/aA/rR/; # .orig directory + } elsif ($! != ENOENT) { + syserr(_g("unable to stat putative unpacked orig `%s'"), $origdir); + } else { + $sourcestyle =~ y/aA/nn/; # Native tar.gz + } + } + } + + my ($dirname, $dirbase) = fileparse($dir); + if ($dirname ne $basedirname) { + warning(_g("source directory '%s' is not " . + "- '%s'"), $dir, $basedirname); + } + + my ($tarname, $tardirname, $tardirbase, $origdirname); + if ($sourcestyle ne 'n') { + my ($origdirname, $origdirbase) = fileparse($origdir); + + if ($origdirname ne "$basedirname.orig") { + warning(_g(".orig directory name %s is not " . + "- (wanted %s)"), + $origdirname, "$basedirname.orig"); + } + $tardirbase = $origdirbase; + $tardirname = $origdirname; + + $tarname = $origtargz || "$basename.orig.tar.gz"; + unless ($tarname =~ /\Q$basename\E\.orig\.tar\.gz/) { + warning(_g(".orig.tar name %s is not _" . + ".orig.tar (wanted %s)"), + $tarname, "$basename.orig.tar.gz"); + } + } else { + $tardirbase = $dirbase; + $tardirname = $dirname; + $tarname = "$basenamerev.tar.gz"; + } + + if ($sourcestyle =~ m/[nurUR]/) { + if (stat($tarname)) { + unless ($sourcestyle =~ m/[nUR]/) { + error(_g("tarfile `%s' already exists, not overwriting, " . + "giving up; use -sU or -sR to override"), $tarname); + } + } elsif ($! != ENOENT) { + syserr(_g("unable to check for existence of `%s'"), $tarname); + } + + printf(_g("%s: building %s in %s")."\n", + $progname, $sourcepackage, $tarname); + + my ($ntfh, $newtar) = tempfile("$tarname.new.XXXXXX", + DIR => getcwd(), UNLINK => 0); + my $tar = Dpkg::Source::Archive->new(filename => $newtar, + compression => get_compression_from_filename($tarname), + compression_level => $self->{'options'}{'comp_level'}); + $tar->create(options => \@tar_ignore, 'chdir' => $tardirbase); + $tar->add_directory($tardirname); + $tar->finish(); + rename($newtar, $tarname) || + syserr(_g("unable to rename `%s' (newly created) to `%s'"), + $newtar, $tarname); + chmod(0666 &~ umask(), $tarname) || + syserr(_g("unable to change permission of `%s'"), $tarname); + } else { + printf(_g("%s: building %s using existing %s")."\n", + $progname, $sourcepackage, $tarname); + } + + $self->add_file($tarname); + + if ($sourcestyle =~ m/[kpKP]/) { + if (stat($origdir)) { + unless ($sourcestyle =~ m/[KP]/) { + error(_g("orig dir `%s' already exists, not overwriting, ". + "giving up; use -sA, -sK or -sP to override"), + $origdir); + } + push @Dpkg::Exit::handlers, sub { erasedir($origdir) }; + erasedir($origdir); + pop @Dpkg::Exit::handlers; + } elsif ($! != ENOENT) { + syserr(_g("unable to check for existence of orig dir `%s'"), + $origdir); + } + + my $tar = Dpkg::Source::Archive->new(filename => $origtargz); + $tar->extract($origdir); + } + + my $ur; # Unrepresentable changes + if ($sourcestyle =~ m/[kpursKPUR]/) { + my $diffname = "$basenamerev.diff.gz"; + printf(_g("%s: building %s in %s")."\n", + $progname, $sourcepackage, $diffname); + my ($ndfh, $newdiffgz) = tempfile("$diffname.new.XXXXXX", + DIR => getcwd(), UNLINK => 0); + my $diff = Dpkg::Source::Patch->new(filename => $newdiffgz, + compression => get_compression_from_filename($diffname)); + $diff->create(); + $diff->add_diff_directory($origdir, $dir, + basedirname => $basedirname, + diff_ignore_regexp => $diff_ignore_regexp); + $diff->finish() || $ur++; + + rename($newdiffgz, $diffname) || + syserr(_g("unable to rename `%s' (newly created) to `%s'"), + $newdiffgz, $diffname); + chmod(0666 &~ umask(), $diffname) || + syserr(_g("unable to change permission of `%s'"), $diffname); + + $self->add_file($diffname); + } + + if ($sourcestyle =~ m/[prPR]/) { + erasedir($origdir); + } + + if ($ur) { + printf(STDERR _g("%s: unrepresentable changes to source")."\n", + $progname); + exit(1); + } +} + +# vim: set et sw=4 ts=8 +1; diff --git a/scripts/Makefile.am b/scripts/Makefile.am index 71e12eb3..6213c62f 100644 --- a/scripts/Makefile.am +++ b/scripts/Makefile.am @@ -110,6 +110,8 @@ nobase_dist_perllib_DATA = \ Dpkg/Source/CompressedFile.pm \ Dpkg/Source/Compressor.pm \ Dpkg/Source/Functions.pm \ + Dpkg/Source/Package.pm \ + Dpkg/Source/Package/V1_0.pm \ Dpkg/Source/Patch.pm \ Dpkg/Source/VCS/git.pm \ Dpkg.pm -- 2.39.5