* man/C/dpkg-scanpackages.1: Document new dpkg-scanpackages

-m option.
* scripts/dpkg-scanpackages.pl: Rewrite the script to support
multiple versions of packages in a single Packages file;
use Getopt::Long instead of attempting to parse the command line
ourselves and doing it badly;
get rid of unecessary hashes and arrays that aren't used at all;
output help when given the --help/-h/-? options
Closes: #229589, #319541

ChangeLog

@@ -1,3 +1,19 @@
+2006-01-29  Frank Lichtenheld  <djpig@debian.org>
+
+	* man/C/dpkg-scanpackages.1: Document new dpkg-scanpackages
+	-m option added by Don Armstrong.
+	* scripts/dpkg-scanpackages.pl: Fix some bugs introduced by
+	the rewrite.
+
+2006-01-29  Don Armstrong  <don@debian.org>
+
+	* scripts/dpkg-scanpackages.pl: Rewrite the script to support
+	multiple versions of packages in a single Packages file;
+	use Getopt::Long instead of attempting to parse the command line
+	ourselves and doing it badly;
+	get rid of unecessary hashes and arrays that aren't used at all;
+	output help when given the --help/-h/-? options
+
 2006-01-29  maximilian attems  <debian@sternwelten.at>
 
 	* scripts/dpkg-source.pl: Add files and

debian/changelog

@@ -13,6 +13,11 @@ dpkg (1.13.14~) UNRELEASED; urgency=low
     more complex setups (Julian Gilbey). Closes: #163061
   * Add files and dirs used by bzr to default dpkg-source -i regex
     (maximilian attems). Closes: #345164
+  * dpkg-scanpackages can now output Packages files with multiple
+    versions of a single package (Don Armstrong). Closes: #229589.
+  * dpkg-scanpackages outputs help when given the --help or -h option
+    (Don Armstrong). Closes: #319541
+  * Document dpkg-scanpackage -m in man page.
 
  -- Guillem Jover <guillem@debian.org>  Sun, 29 Jan 2006 06:02:58 +0200
 

man/C/dpkg-scanpackages.1

@@ -21,6 +21,7 @@ dpkg\-scanpackages - create Packages files
 .B dpkg\-scanpackages
 .RI [ \-u ]
 .RI [ \-a<arch> ]
+.RI [ \-m ]
 .I binarydir
 .I overridefile
 .RI [ pathprefix ]
@@ -59,6 +60,12 @@ is specified, then scan for *.udeb, instead of *.deb.
 .PP
 When \-a\fI<arch>\fP is specified, then instead of scanning for all debs,
 a pattern consisting of *_all.deb and *_arch.deb is used.
+.PP
+If more than one version of a package is found only the newest one
+is included in the output. If they have the same version and only
+differ in architecture only the first one found is used. You can override
+this behaviour with the \fI\-m\fP switch. If given, all found packages
+are included in the output.
 .
 .SH THE OVERRIDE FILE
 While most information about a package can be found in the control file,

scripts/dpkg-scanpackages.pl

@@ -1,241 +1,243 @@
 #!/usr/bin/perl
 
-$version= '1.2.6'; # This line modified by Makefile
+use warnings;
+use strict;
 
-%kmap= ('optional','suggests',
-        'recommended','recommends',
-        'class','priority',
-        'package_revision','revision');
+use IO::Handle;
+use IO::File;
 
-@fieldpri= ('Package',
-	    'Source',
-            'Version',
-            'Priority',
-            'Section',
-            'Essential',
-            'Maintainer',
-            'Pre-Depends',
-            'Depends',
-            'Recommends',
-            'Suggests',
-            'Conflicts',
-            'Provides',
-            'Replaces',
-            'Architecture',
-            'Filename',
-            'Size',
-	    'Installed-Size',
-            'MD5sum',
-            'Description',
-            'Origin',
-            'Bugs');
+my $version= '1.2.6'; # This line modified by Makefile
 
-$written=0;
-$i=100; grep($pri{$_}=$i--,@fieldpri);
+my %kmap= (optional         => 'suggests',
+	   recommended      => 'recommends',
+	   class            => 'priority',
+	   package_revision => 'revision',
+	  );
 
-$udeb = 0;
-$arch = '';
-while ($ARGV[0] =~ m/^-.*/) {
-    my $opt = shift @ARGV;
-    if ($opt eq '-u') {
-        $udeb = 1;
-    } elsif ($opt =~ m/-a(.*)/) {
-        if ($1) {
-            $arch = $1;
-        } else {
-            $arch = shift @ARGV;
-        }
-    } else {
-        print STDERR "Unknown option($opt)!\n";
-        exit(1);
-    }
-}
-$ext = $udeb ? 'udeb' : 'deb';
-$pattern = $arch ? "'(' -name '*_all.$ext' -o -name '*_$arch.$ext' ')'" : "-name '*.$ext'";
-if ($ARGV[1] eq '-u') {
-    $udeb = 1;
-    shift @ARGV;
-}
+my @fieldpri= ('Package',
+	       'Source',
+	       'Version',
+	       'Priority',
+	       'Section',
+	       'Essential',
+	       'Maintainer',
+	       'Pre-Depends',
+	       'Depends',
+	       'Recommends',
+	       'Suggests',
+	       'Conflicts',
+	       'Provides',
+	       'Replaces',
+	       'Enhances',
+	       'Architecture',
+	       'Filename',
+	       'Size',
+	       'Installed-Size',
+	       'MD5sum',
+	       'Description',
+	       'Origin',
+	       'Bugs'
+	      );
 
-$#ARGV == 1 || $#ARGV == 2
-    or die "Usage: dpkg-scanpackages [-u] [-a<arch>] binarypath overridefile [pathprefix] > Packages\n";
-($binarydir, $override, $pathprefix) = @ARGV;
--d $binarydir or die "Binary dir $binarydir not found\n";
--e $override or die "Override file $override not found\n";
+# This maps the fields into the proper case
+my %field_case;
+@field_case{map{lc($_)} @fieldpri} = @fieldpri;
 
-sub vercmp {
-	($a,$b)=@_;
-	return $vercache{$a,$b} if defined($vercache{$a,$b});
-	system("dpkg --compare-versions $a le $b");
-	$vercache{$a,$a}=$?;
-	return $?;
-}
+use Getopt::Long;
 
-# The extra slash causes symlinks to be followed.
-open(F,"find $binarydir/ -follow $pattern -print |")
-    or die "Couldn't open pipe to find: $!\n";
-while (<F>) {
-    chomp($fn=$_);
-    substr($fn,0,length($binarydir)) eq $binarydir
-	or die "$fn not in binary dir $binarydir\n";
-    $t= `dpkg-deb -I $fn control`;
-    if ($t eq "") {
-	warn "Couldn't call dpkg-deb on $fn: $!, skipping package\n";
-	next;
-    }
-    if ($?) {
-    	warn "\`dpkg-deb -I $fn control' exited with $?, skipping package\n";
-	next;
-    }
+my %options = (help            => 0,
+	       udeb            => 0,
+	       arch            => undef,
+	       multiversion    => 0,
+	      );
 
-    undef %tv;
-    $o= $t;
-    while ($t =~ s/^\n*(\S+):[ \t]*(.*(\n[ \t].*)*)\n//) {
-        $k= lc $1; $v= $2;
-        if (defined($kmap{$k})) { $k= $kmap{$k}; }
-        if (@kn= grep($k eq lc $_, @fieldpri)) {
-            @kn==1 || die $k;
-            $k= $kn[0];
-        }
-        $v =~ s/\s+$//;
-        $tv{$k}= $v;
-    }
-    $t =~ /^\n*$/
-	or die "Unprocessed text from $fn control file; info:\n$o / $t\n";
+my $result = GetOptions(\%options,'help|h|?','udeb|u!','arch|a=s','multiversion|m!');
 
-    defined($tv{'Package'})
-	or die "No Package field in control file of $fn\n";
-    $p= $tv{'Package'}; delete $tv{'Package'};
+print <<END and exit 1 if not $result or $options{help} or @ARGV < 2;
+dpkg-scanpackages [-u] [-a<arch>] [-m] binarypath overridefile [pathprefix] > Packages
 
-    if (defined($p1{$p})) {
-	if (&vercmp($tv{'Version'}, $pv{$p,'Version'})) {
-	    print(STDERR " ! Package $p (filename $fn) is repeat but newer version;\n".
-		    "   used that one and ignored data from $pfilename{$p} !\n")
-		    || die $!;
-	    delete $p1{$p};
-	    for $k (keys %k1) {
-		delete $pv{$p,$k};
-	    }
-	} else {
-	    print(STDERR " ! Package $p (filename $fn) is repeat;\n".
-			 "   ignored that one and using data from $pfilename{$p} !\n")
-		|| die $!;
-	    next;
-	}
-    }
-    print(STDERR " ! Package $p (filename $fn) has Filename field!\n") || die $!
-        if defined($tv{'Filename'});
-    
-    $tv{'Filename'}= "$pathprefix$fn";
+ Options:
+ --udeb, -u scan for udebs
+ --arch, -a architecture to scan for
+ --multiversion, -m allow multiple versions of a single package
+ --help, -h show this help
 
-    open(C,"md5sum <$fn |") || die "$fn $!";
-    chop($_=<C>); close(C); $? and die "\`md5sum < $fn' exited with $?\n";
-    /^([0-9a-f]{32})\s*-?\s*$/ or die "Strange text from \`md5sum < $fn': \`$_'\n";
-    $tv{'MD5sum'}= $1;
+END
 
-    @stat= stat($fn) or die "Couldn't stat $fn: $!\n";
-    $stat[7] or die "$fn is empty\n";
-    $tv{'Size'}= $stat[7];
 
-    if (length($tv{'Revision'})) {
-        $tv{'Version'}.= '-'.$tv{'Revision'};
-        delete $tv{'Revision'};
-    }
+my $udeb = $options{udeb};
+my $arch = $options{arch};
 
-    for $k (keys %tv) {
-        $pv{$p,$k}= $tv{$k};
-        $k1{$k}= 1;
-        $p1{$p}= 1;
-    }
+my $ext = $options{udeb} ? 'udeb' : 'deb';
+my @find_args;
+if ($options{arch}) {
+     @find_args = ('(','-name',"*_all.$ext",'-o','-name',"_${arch}.$ext",')',);
+}
+else {
+     @find_args = ('-name',"*.$ext");
+}
+my ($binarydir, $override, $pathprefix) = @ARGV;
+-d $binarydir or die "Binary dir $binarydir not found\n";
+-e $override or die "Override file $override not found\n";
 
-    $_= substr($fn,length($binarydir));
-    s#/[^/]+$##; s#^/*##;
-    $psubdir{$p}= $_;
-    $pfilename{$p}= $fn;
+$pathprefix = '' if not defined $pathprefix;
+
+our %vercache;
+sub vercmp {
+     my ($a,$b)=@_;
+     return $vercache{$a}{$b} if exists $vercache{$a}{$b};
+     system('dpkg','--compare-versions',$a,'le',$b);
+     $vercache{$a}{$b}=$?;
+     return $?;
 }
-close(F);
-$? and warn "find exited with $?\n";
+
+my %packages;
+my $find_h = new IO::Handle;
+open($find_h,'-|','find',"$binarydir/",@find_args,'-print')
+     or die "Couldn't open $binarydir for reading: $!\n";
+FILE:
+    while (<$find_h>) {
+	chomp;
+	my $fn = $_;
+	my $control = `dpkg-deb -I $fn control`;
+	if ($control eq "") {
+	    warn "Couldn't call dpkg-deb on $fn: $!, skipping package\n";
+	    next;
+	}
+	if ($?) {
+	    warn "\`dpkg-deb -I $fn control' exited with $?, skipping package\n";
+	    next;
+	}
+	
+	my %tv = ();
+	my $temp = $control;
+	while ($temp =~ s/^\n*(\S+):[ \t]*(.*(\n[ \t].*)*)\n//) {
+	    my ($key,$value)= (lc $1,$2);
+	    if (defined($kmap{$key})) { $key= $kmap{$key}; }
+	    if (defined($field_case{$key})) { $key= $field_case{$key}; }
+	    $value =~ s/\s+$//;
+	    $tv{$key}= $value;
+	}
+	$temp =~ /^\n*$/
+	    or die "Unprocessed text from $fn control file; info:\n$control / $temp\n";
+	
+	defined($tv{'Package'})
+	    or die "No Package field in control file of $fn\n";
+	my $p= $tv{'Package'}; delete $tv{'Package'};
+	
+	if (defined($packages{$p}) and not $options{multiversion}) {
+	    foreach (@{$packages{$p}}) {
+		if (&vercmp($tv{'Version'}, $_->{'Version'})) {
+		    print(STDERR " ! Package $p (filename $fn) is repeat but newer version;\n".
+			  "   used that one and ignored data from $_->{Filename} !\n")
+			|| die $!;
+		    $packages{$p} = [];
+		} else {
+		    print(STDERR " ! Package $p (filename $fn) is repeat;\n".
+			  "   ignored that one and using data from $_->{Filename} !\n")
+			or die $!;
+		    next FILE;
+		}
+	    }
+	}
+	print(STDERR " ! Package $p (filename $fn) has Filename field!\n") || die $!
+	    if defined($tv{'Filename'});
+	
+	$tv{'Filename'}= "$pathprefix$fn";
+	
+	open(C,"md5sum <$fn |") || die "$fn $!";
+	chop($_=<C>); close(C); $? and die "\`md5sum < $fn' exited with $?\n";
+	/^([0-9a-f]{32})\s*-?\s*$/ or die "Strange text from \`md5sum < $fn': \`$_'\n";
+	$tv{'MD5sum'}= $1;
+	
+	my @stat= stat($fn) or die "Couldn't stat $fn: $!\n";
+	$stat[7] or die "$fn is empty\n";
+	$tv{'Size'}= $stat[7];
+	
+	if (defined $tv{Revision} and length($tv{Revision})) {
+	    $tv{Version}.= '-'.$tv{Revision};
+	    delete $tv{Revision};
+	}
+	
+	push @{$packages{$p}}, {%tv};
+    }
+close($find_h);
 
 select(STDERR); $= = 1000; select(STDOUT);
 
+sub writelist {
+    my $title= shift(@_);
+    return unless @_;
+
+    print(STDERR " $title\n") || die $!;
+    my $packages= join(' ',sort @_);
+
 format STDERR =
   ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
 $packages
 .
-
-sub writelist {
-    $title= shift(@_);
-    return unless @_;
-    print(STDERR " $title\n") || die $!;
-    $packages= join(' ',sort @_);
     while (length($packages)) { write(STDERR) || die $!; }
     print(STDERR "\n") || die $!;
 }
 
-@samemaint=();
+my (@samemaint,@changedmaint);
+
 
-open(O, $override)
+my %overridden;
+my $override_fh = new IO::File $override,'r'
     or die "Couldn't open override file $override: $!\n";
-while (<O>) {
+while (<$override_fh>) {
     s/\#.*//;
     s/\s+$//;
-    ($p,$priority,$section,$maintainer)= split(/\s+/,$_,4);
-    next unless defined($p1{$p});
-    if (length($maintainer)) {
-        if ($maintainer =~ m/\s*=\>\s*/) {
-            $oldmaint= $`; $newmaint= $'; $debmaint= $pv{$p,'Maintainer'};
-            if (!grep($debmaint eq $_, split(m:\s*//\s*:, $oldmaint))) {
-                push(@changedmaint,
-                     "  $p (package says $pv{$p,'Maintainer'}, not $oldmaint)\n");
-            } else {
-                $pv{$p,'Maintainer'}= $newmaint;
-            }
-        } elsif ($pv{$p,'Maintainer'} eq $maintainer) {
-            push(@samemaint,"  $p ($maintainer)\n");
-        } else {
-            print(STDERR " * Unconditional maintainer override for $p *\n") || die $!;
-            $pv{$p,'Maintainer'}= $maintainer;
-        }
+    my ($p,$priority,$section,$maintainer)= split(/\s+/,$_,4);
+    next unless defined($packages{$p});
+    for my $package (@{$packages{$p}}) {
+	 if (defined $maintainer and length($maintainer)) {
+	      if ($maintainer =~ m/(.+?)\s*=\>\s*(.+)/) {
+		   my $oldmaint= $1;
+		   my $newmaint= $2;
+		   my $debmaint= $$package{Maintainer};
+		   if (!grep($debmaint eq $_, split(m:\s*//\s*:, $oldmaint))) {
+			push(@changedmaint,
+			     "  $p (package says $$package{Maintainer}, not $oldmaint)\n");
+		   } else {
+			$$package{Maintainer}= $newmaint;
+		   }
+	      }
+	 } elsif ($$package{Maintainer} eq $maintainer) {
+	      push(@samemaint,"  $p ($maintainer)\n");
+	 } else {
+	      print(STDERR " * Unconditional maintainer override for $p *\n") || die $!;
+	      $$package{Maintainer}= $maintainer;
+	 }
+	 $packages{$p}{Priority}= $priority;
+	 $packages{$p}{Section}= $section;
     }
-    $pv{$p,'Priority'}= $priority;
-    $pv{$p,'Section'}= $section;
-    ($sectioncut = $section) =~ s:^[^/]*/::;
-    if (length($psubdir{$p}) && $section ne $psubdir{$p} &&
-	$sectioncut ne $psubdir{$p}) {
-    if (length($psubdir{$p}) && $section ne $psubdir{$p}) {
-        print(STDERR " !! Package $p has \`Section: $section',".
-                     " but file is in \`$psubdir{$p}' !!\n") || die $!;
-        $ouches++;
-      }
-    }
-    $o1{$p}= 1;
+    $overridden{$p} = 1;
 }
-close(O);
-print(STDERR "\n") || die $! if $ouches;
-
-$k1{'Maintainer'}= 1;
-$k1{'Priority'}= 1;
-$k1{'Section'}= 1;
+close($override_fh);
 
-@missingover=();
+my @missingover=();
 
-for $p (sort keys %p1) {
-    if (!defined($o1{$p})) {
+my $records_written = 0;
+for my $p (sort keys %packages) {
+    if (not defined($overridden{$p})) {
         push(@missingover,$p);
     }
-    $r= "Package: $p\n";
-    for $k (sort { $pri{$b} <=> $pri{$a} } keys %k1) {
-        next unless length($pv{$p,$k});
-        $r.= "$k: $pv{$p,$k}\n";
+    for my $package (@{$packages{$p}}) {
+	 my $record= "Package: $p\n";
+	 for my $key (@fieldpri) {
+	      next unless defined $$package{$key};
+	      $record .= "$key: $$package{$key}\n";
+	 }
+	 $record .= "\n";
+	 $records_written++;
+	 print(STDOUT $record) or die "Failed when writing stdout: $!\n";
     }
-    $r.= "\n";
-    $written++;
-    $p1{$p}= 1;
-    print(STDOUT $r) or die "Failed when writing stdout: $!\n";
 }
 close(STDOUT) or die "Couldn't close stdout: $!\n";
 
-@spuriousover= grep(!defined($p1{$_}),sort keys %o1);
+my @spuriousover= grep(!defined($packages{$_}),sort keys %overridden);
 
 &writelist("** Packages in archive but missing from override file: **",
            @missingover);
@@ -258,4 +260,4 @@ if (@spuriousover) {
           "\n") || die $!;
 }
 
-print(STDERR " Wrote $written entries to output Packages file.\n") || die $!;
+print(STDERR " Wrote $records_written entries to output Packages file.\n") || die $!;