scripts/dpkg-scanpackages.pl

   1 #!/usr/bin/perl --
   2 # usage:
   3 #  dpkg-scanpackages .../binary .../noverride pathprefix >.../Packages.new
   4 #  mv .../Packages.new .../Packages
   5 #
   6 # This is the core script that generates Packages files (as found
   7 # on the Debian FTP site and CD-ROMs).
   8 #
   9 # The first argument should preferably be a relative filename, so that
  10 # the Filename field has good information.
  11 #
  12 # Any desired string can be prepended to each Filename value by
  13 # passing it as the third argument.
  14 #
  15 # The noverride file is a series of lines of the form
  16 # <package> <priority> <section> <maintainer>
  17 # where the <maintainer> field is optional.  Fields are separated by
  18 # whitespace.  The <maintainer> field may be <old-maintainer> => <new-maintainer>
  19 # (this is recommended).
  20
  21 $version= '1.0.12'; # This line modified by Makefile
  22
  23 %kmap= ('optional','suggests',
  24         'recommended','recommends',
  25         'class','priority',
  26         'package_revision','revision');
  27
  28 %pri= ('priority',300,
  29        'section',290,
  30        'maintainer',280,
  31        'version',270,
  32        'depends',250,
  33        'recommends',240,
  34        'suggests',230,
  35        'conflicts',220,
  36        'provides',210,
  37        'filename',200,
  38        'size',180,
  39        'md5sum',170,
  40        'description',160);
  41
  42 @ARGV==3 || die;
  43
  44 $binarydir= shift(@ARGV);
  45 -d $binarydir || die $!;
  46
  47 $override= shift(@ARGV);
  48 -e $override || die $!;
  49
  50 $pathprefix= shift(@ARGV);
  51
  52 open(F,"find $binarydir -name '*.deb' -print |") || die $!;
  53 while (<F>) {
  54     chop($fn=$_);
  55     substr($fn,0,length($binarydir)) eq $binarydir || die $fn;
  56     open(C,"dpkg-deb -I $fn control |") || die "$fn $!";
  57     $t=''; while (<C>) { $t.=$_; }
  58     $!=0; close(C); $? && die "$fn $? $!";
  59     undef %tv;
  60     $o= $t;
  61     while ($t =~ s/^\n*(\S+):[ \t]*(.*(\n[ \t].*)*)\n//) {
  62         $k= $1; $v= $2;
  63         $k =~ y/A-Z/a-z/;
  64         if (defined($kmap{$k})) { $k= $kmap{$k}; }
  65         $v =~ s/\s+$//;
  66         $tv{$k}= $v;
  67 #print STDERR "K>$k V>$v<\n";
  68     }
  69     $t =~ m/^\n*$/ || die "$fn $o / $t ?";
  70     defined($tv{'package'}) || die "$fn $o ?";
  71     $p= $tv{'package'}; delete $tv{'package'};
  72     if (defined($p1{$p})) {
  73         print(STDERR " ! Package $p (filename $fn) is repeat;\n".
  74                      "   ignored that one and using data from $pfilename{$p}) !\n")
  75             || die $!;
  76         next;
  77     }
  78     if (defined($tv{'filename'})) {
  79         print(STDERR " ! Package $p (filename $fn) has Filename field !\n") || die $!;
  80     }
  81     $tv{'filename'}= "$pathprefix$fn";
  82     open(C,"md5sum <$fn |") || die "$fn $!";
  83     chop($_=<C>); m/^[0-9a-f]{32}$/ || die "$fn \`$_' $!";
  84     $!=0; close(C); $? && die "$fn $? $!";
  85     $tv{'md5sum'}= $_;
  86     defined(@stat= stat($fn)) || die "$fn $!";
  87     $stat[7] || die "$fn $stat[7]";
  88     $tv{'size'}= $stat[7];
  89     if (length($tv{'revision'})) {
  90         $tv{'version'}.= '-'.$tv{'revision'};
  91         delete $tv{'revision'};
  92     }
  93     for $k (keys %tv) {
  94         $pv{$p,$k}= $tv{$k};
  95         $k1{$k}= 1;
  96         $p1{$p}= 1;
  97     }
  98     $_= substr($fn,length($binarydir));
  99     s#/[^/]+$##; s#^/*##;
 100     $psubdir{$p}= $_;
 101     $pfilename{$p}= $fn;
 102 }
 103 $!=0; close(F); $? && die "$? $!";
 104
 105 select(STDERR); $= = 1000; select(STDOUT);
 106
 107 format STDERR =
 108   ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
 109 $packages
 110 .
 111
 112 sub writelist {
 113     $title= shift(@_);
 114     return unless @_;
 115     print(STDERR " $title\n") || die $!;
 116     $packages= join(' ',sort @_);
 117     while (length($packages)) { write(STDERR) || die $!; }
 118     print(STDERR "\n") || die $!;
 119 }
 120
 121 @samemaint=();
 122
 123 open(O,"<$override") || die $!;
 124 while(<O>) {
 125     s/\s+$//;
 126     ($p,$priority,$section,$maintainer)= split(/\s+/,$_,4);
 127     next unless defined($p1{$p});
 128     if (length($maintainer)) {
 129         if ($maintainer =~ m/\s*=\>\s*/) {
 130             $oldmaint= $`; $newmaint= $'; $debmaint= $pv{$p,'maintainer'};
 131             if (!grep($debmaint eq $_, split(m:\s*//\s*:, $oldmaint))) {
 132                 push(@changedmaint,
 133                      "  $p (package says $pv{$p,'maintainer'}, not $oldmaint)\n");
 134             } else {
 135                 $pv{$p,'maintainer'}= $newmaint;
 136             }
 137         } elsif ($pv{$p,'maintainer'} eq $maintainer) {
 138             push(@samemaint,"  $p ($maintainer)\n");
 139         } else {
 140             print(STDERR " * Unconditional maintainer override for $p *\n") || die $!;
 141             $pv{$p,'maintainer'}= $maintainer;
 142         }
 143     }
 144     $pv{$p,'priority'}= $priority;
 145     $pv{$p,'section'}= $section;
 146     if (length($psubdir{$p}) && $section ne $psubdir{$p}) {
 147         print(STDERR " !! Package $p has \`Section: $section',".
 148                      " but file is in \`$psubdir{$p}' !!\n") || die $!;
 149         $ouches++;
 150     }
 151     $o1{$p}= 1;
 152 }
 153 close(O);
 154
 155 if ($ouches) { print(STDERR "\n") || die $!; }
 156
 157 $k1{'maintainer'}= 1;
 158 $k1{'priority'}= 1;
 159 $k1{'section'}= 1;
 160
 161 @missingover=();
 162
 163 for $p (sort keys %p1) {
 164     if (!defined($o1{$p})) {
 165         push(@missingover,$p);
 166     }
 167     $r= "Package: $p\n";
 168     for $k (sort { $pri{$b} <=> $pri{$a} } keys %k1) {
 169         next unless length($pv{$p,$k});
 170         $r.= "$k: $pv{$p,$k}\n";
 171     }
 172     $r.= "\n";
 173     $written++;
 174     print(STDOUT $r) || die $!;
 175 }
 176 close(STDOUT) || die $!;
 177
 178 &writelist("** Packages in archive but missing from override file: **",
 179            @missingover);
 180 if (@changedmaint) {
 181     print(STDERR
 182           " ++ Packages in override file with incorrect old maintainer value: ++\n",
 183           @changedmaint,
 184           "\n") || die $!;
 185 }
 186 if (@samemaint) {
 187     print(STDERR
 188           " -- Packages specifying same maintainer as override file: --\n",
 189           @samemaint,
 190           "\n") || die $!;
 191 }
 192
 193 print(STDERR " Wrote $written entries to output Packages file.\n") || die $!;