debian-cd-clone/etch/tools/my-dpkg-scanpackages

#! /usr/bin/perl

$version="1.9.17"; # diverted from dpkg 1.9.17

%kmap= ('optional','suggests',
        'recommended','recommends',
        'class','priority',
        'package_revision','revision');

@fieldpri= ('Package',
            'Version',
            'Priority',
            'Section',
            'Essential',
            'Maintainer',
            'Pre-Depends',
            'Depends',
            'Recommends',
            'Suggests',
            'Conflicts',
            'Provides',
            'Replaces',
            'Architecture',
            'Filename',
            'Size',
            'MD5sum',
            'Description');

$written=0;
$i=100; grep($pri{$_}=$i--,@fieldpri);

if ($#ARGV > -1 && $ARGV[0] eq "-m") {
    shift(@ARGV);
    $opt_medium = shift(@ARGV); }
if ($#ARGV > -1 && $ARGV[0] eq "-a") {
    shift(@ARGV);
    $opt_arch = shift(@ARGV); }
$#ARGV == 1 || $#ARGV == 2
    or die "Usage: dpkg-scanpackages [-m medium] [-a architecture ] binarypath overridefile [pathprefix] > Packages
\te.g. dpkg-scanpackages -m 'Debian GNU/Linux -a i386 binary-i386' \\
\t\tbinary-i386 /pub/debian/indices/override.hamm.gz \\
\t\tdists/stable/ > binary-i386/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";

sub vercmp {
	($a,$b)=@_;
	return $vercache{$a,$b} if defined($vercache{$a,$b});
	system("dpkg --compare-versions $a le $b");
	$vercache{$a,$a}=$?;
	return $?;
}

# The extra slash causes symlinks to be followed.
open(F,"find $binarydir/ -follow -name '*.deb' -print |")
    or die "Couldn't open pipe to find: $!\n";

# Note: contrib and other sections are written as contrib/foo in
#       the overrides and control file
($sectdir) = "$pathprefix/$binarydir" =~ m:dists/[^\\]+/([^/]+/):;
$sectdir =~ s:(main|hamm)/::;

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;
    }

    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";

    defined($tv{'Package'})
	or die "No Package field in control file of $fn\n";
    $p= $tv{'Package'}; delete $tv{'Package'};

    $arch=$tv{'Architecture'};
    if (defined($opt_arch)) {
        if ($arch =~ $opt_arch || $arch =~ "all") {
#            print(STDERR " ! Package $p ($fn) is for the correct architecture $opt_arch: $arch\n");
        } else {
#            print(STDERR " ! Package $p ($fn) is not for the correct architecture $opt_arch: $arch\n");
            next;
        }
    }

    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";

    open(C,"md5sum $fn |") || die "$fn $!";
    chop($_=<C>); close(C); $? and die "\`md5sum < $fn' exited with $?\n";
    /^[0-9a-f]{32}/ or die "Strange text from \`md5sum < $fn': \`$_'\n";
    s/\ .*$//;
    $tv{'MD5sum'}= $_;

    @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'};
    }

    for $k (keys %tv) {
        $pv{$p,$k}= $tv{$k};
        $k1{$k}= 1;
        $p1{$p}= 1;
    }

    $_= substr($fn,length($binarydir));
    s#/[^/]+$##; s#^/*##;
    $psubdir{$p}= $_;
    $pfilename{$p}= $fn;
}
close(F);
$? and warn "find exited with $?\n";

select(STDERR); $= = 1000; select(STDOUT);

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=();

if ($override =~ /\.gz$/) {
open(O, "zcat $override|")
    or die "Couldn't open override file $override: $!\n";
} else {
open(O, $override)
    or die "Couldn't open override file $override: $!\n";
}
while (<O>) {
    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;
        }
    }
    $pv{$p,'Priority'}= $priority;
    $pv{$p,'Section'}= $section;
    ($sectioncut = $section) =~ s:^[^/]*/::;
    if (length($psubdir{$p}) && $section ne $psubdir{$p} &&
	$sectioncut ne $psubdir{$p}) {
        print(STDERR " !! Package $p has \`Section: $section',".
                     " but file is in \`$psubdir{$p}' !!\n") || die $!;
        $ouches++;
    }
    $o1{$p}= 1;
}
close(O);
print(STDERR "\n") || die $! if $ouches;

$k1{'Maintainer'}= 1;
$k1{'Priority'}= 1;
$k1{'Section'}= 1;

@missingover=();

for $p (sort keys %p1) {
    if (!defined($o1{$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";
    }
    $r.= "X-Medium: $opt_medium\n" if (defined $opt_medium);
    $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);

&writelist("** Packages in archive but missing from override file: **",
           @missingover);
if (@changedmaint) {
    print(STDERR
          " ++ Packages in override file with incorrect old maintainer value: ++\n",
          @changedmaint,
          "\n") || die $!;
}
if (@samemaint) {
    print(STDERR
          " -- Packages specifying same maintainer as override file: --\n",
          @samemaint,
          "\n") || die $!;
}
if (@spuriousover) {
    print(STDERR
          " -- Packages in override file but not in archive: --\n",
          @spuriousover,
          "\n") || die $!;
}

print(STDERR " Wrote $written entries to output Packages file.\n") || die $!;