home *** CD-ROM | disk | FTP | other *** search
/ PC World 2000 February / PCWorld_2000-02_cd.bin / live / usr / bin / dpkg-scanpackages.dpkg < prev    next >
Encoding:
Text File  |  1999-02-08  |  6.2 KB  |  217 lines
  1. #! /usr/bin/perl
  2.  
  3. $version="1.4.0.30"; # This line modified by Makefile
  4.  
  5. %kmap= ('optional','suggests',
  6.         'recommended','recommends',
  7.         'class','priority',
  8.         'package_revision','revision');
  9.  
  10. @fieldpri= ('Package',
  11.             'Version',
  12.             'Priority',
  13.             'Section',
  14.             'Essential',
  15.             'Maintainer',
  16.             'Pre-Depends',
  17.             'Depends',
  18.             'Recommends',
  19.             'Suggests',
  20.             'Conflicts',
  21.             'Provides',
  22.             'Replaces',
  23.             'Architecture',
  24.             'Filename',
  25.             'Size',
  26.             'MD5sum',
  27.             'Description');
  28.  
  29. $i=100; grep($pri{$_}=$i--,@fieldpri);
  30.  
  31. if ($#ARGV > -1 && $ARGV[0] eq "-m") {
  32.     shift(@ARGV);
  33.     $opt_medium = shift(@ARGV); }
  34. $#ARGV == 1 || $#ARGV == 2
  35.     or die "Usage: dpkg-scanpackages [-m medium] binarypath overridefile pathprefix > Packages
  36. \te.g. dpkg-scanpackages -m 'Debian GNU/Linux binary-i386' \\
  37. \t\tbinary-i386 /pub/debian/indices/override.hamm.gz \\
  38. \t\tdists/stable/ > binary-i386/Packages\n";
  39.  
  40. ($binarydir, $override, $pathprefix) = @ARGV;
  41. -d $binarydir or die "Binary dir $binarydir not found\n";
  42. -e $override or die "Override file $override not found\n";
  43.  
  44. # The extra slash causes symlinks to be followed.
  45. open(F,"find $binarydir/ -follow -name '*.deb' -print |")
  46.     or die "Couldn't open pipe to find: $!\n";
  47. while (<F>) {
  48.     chop($fn=$_);
  49.     substr($fn,0,length($binarydir)) eq $binarydir
  50.     or die "$fn not in binary dir $binarydir\n";
  51.     $t= `dpkg-deb -I $fn control`
  52.     or die "Couldn't call dpkg-deb on $fn: $!\n";
  53.     $? and die "\`dpkg-deb -I $fn control' exited with $?\n";
  54.     undef %tv;
  55.     $o= $t;
  56.     while ($t =~ s/^\n*(\S+):[ \t]*(.*(\n[ \t].*)*)\n//) {
  57.         $k= lc $1; $v= $2;
  58.         if (defined($kmap{$k})) { $k= $kmap{$k}; }
  59.         if (@kn= grep($k eq lc $_, @fieldpri)) {
  60.             @kn==1 || die $k;
  61.             $k= $kn[0];
  62.         }
  63.         $v =~ s/\s+$//;
  64.         $tv{$k}= $v;
  65.     }
  66.     $t =~ /^\n*$/
  67.     or die "Unprocessed text from $fn control file; info:\n$o / $t\n";
  68.  
  69.     defined($tv{'Package'})
  70.     or die "No Package field in control file of $fn\n";
  71.     $p= $tv{'Package'}; delete $tv{'Package'};
  72.  
  73.     if (defined($p1{$p})) {
  74.         print(STDERR " ! Package $p (filename $fn) is repeat;\n".
  75.                      "   ignored that one and using data from $pfilename{$p} !\n")
  76.             || die $!;
  77.         next;
  78.     }
  79.     print(STDERR " ! Package $p (filename $fn) has Filename field!\n") || die $!
  80.         if defined($tv{'Filename'});
  81.     
  82.     $tv{'Filename'}= "$pathprefix$fn";
  83.  
  84.     open(C,"md5sum <$fn |") || die "$fn $!";
  85.     chop($_=<C>); close(C); $? and die "\`md5sum < $fn' exited with $?\n";
  86.     /^[0-9a-f]{32}$/ or die "Strange text from \`md5sum < $fn': \`$_'\n";
  87.     $tv{'MD5sum'}= $_;
  88.  
  89.     @stat= stat($fn) or die "Couldn't stat $fn: $!\n";
  90.     $stat[7] or die "$fn is empty\n";
  91.     $tv{'Size'}= $stat[7];
  92.  
  93.     if (length($tv{'Revision'})) {
  94.         $tv{'Version'}.= '-'.$tv{'Revision'};
  95.         delete $tv{'Revision'};
  96.     }
  97.  
  98.     for $k (keys %tv) {
  99.         $pv{$p,$k}= $tv{$k};
  100.         $k1{$k}= 1;
  101.         $p1{$p}= 1;
  102.     }
  103.  
  104.     $_= substr($fn,length($binarydir));
  105.     s#/[^/]+$##; s#^/*##;
  106.     $psubdir{$p}= $_;
  107.     $pfilename{$p}= $fn;
  108. }
  109. close(F);
  110. $? and die "find exited with $?\n";
  111.  
  112. select(STDERR); $= = 1000; select(STDOUT);
  113.  
  114. format STDERR =
  115.   ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
  116. $packages
  117. .
  118.  
  119. sub writelist {
  120.     $title= shift(@_);
  121.     return unless @_;
  122.     print(STDERR " $title\n") || die $!;
  123.     $packages= join(' ',sort @_);
  124.     while (length($packages)) { write(STDERR) || die $!; }
  125.     print(STDERR "\n") || die $!;
  126. }
  127.  
  128. @samemaint=();
  129.  
  130. if ($override =~ /\.gz$/) {
  131. open(O, "/bin/zcat $override|")
  132.     or die "Couldn't open override file $override: $!\n";
  133. } else {
  134. open(O, $override)
  135.     or die "Couldn't open override file $override: $!\n";
  136. }
  137. while (<O>) {
  138.     s/\#.*//;
  139.     s/\s+$//;
  140.     ($p,$priority,$section,$maintainer)= split(/\s+/,$_,4);
  141.     next unless defined($p1{$p});
  142.     if (length($maintainer)) {
  143.         if ($maintainer =~ m/\s*=\>\s*/) {
  144.             $oldmaint= $`; $newmaint= $'; $debmaint= $pv{$p,'Maintainer'};
  145.             if (!grep($debmaint eq $_, split(m:\s*//\s*:, $oldmaint))) {
  146.                 push(@changedmaint,
  147.                      "  $p (package says $pv{$p,'Maintainer'}, not $oldmaint)\n");
  148.             } else {
  149.                 $pv{$p,'Maintainer'}= $newmaint;
  150.             }
  151.         } elsif ($pv{$p,'Maintainer'} eq $maintainer) {
  152.             push(@samemaint,"  $p ($maintainer)\n");
  153.         } else {
  154.             print(STDERR " * Unconditional maintainer override for $p *\n") || die $!;
  155.             $pv{$p,'Maintainer'}= $maintainer;
  156.         }
  157.     }
  158.     $pv{$p,'Priority'}= $priority;
  159.     $pv{$p,'Section'}= $section;
  160.     if (length($psubdir{$p}) && $section ne $psubdir{$p}) {
  161.         print(STDERR " !! Package $p has \`Section: $section',".
  162.                      " but file is in \`$psubdir{$p}' !!\n") || die $!;
  163.         $ouches++;
  164.     }
  165.     $o1{$p}= 1;
  166. }
  167. close(O);
  168. print(STDERR "\n") || die $! if $ouches;
  169.  
  170. $k1{'Maintainer'}= 1;
  171. $k1{'Priority'}= 1;
  172. $k1{'Section'}= 1;
  173.  
  174. @missingover=();
  175.  
  176. for $p (sort keys %p1) {
  177.     if (!defined($o1{$p})) {
  178.         push(@missingover,$p);
  179.     }
  180.     $r= "Package: $p\n";
  181.     for $k (sort { $pri{$b} <=> $pri{$a} } keys %k1) {
  182.         next unless length($pv{$p,$k});
  183.         $r.= "$k: $pv{$p,$k}\n";
  184.     }
  185.     $r.= "X-Medium: $opt_medium\n" if (defined $opt_medium);
  186.     $r.= "\n";
  187.     $written++;
  188.     $p1{$p}= 1;
  189.     print(STDOUT $r) or die "Failed when writing stdout: $!\n";
  190. }
  191. close(STDOUT) or die "Couldn't close stdout: $!\n";
  192.  
  193. @spuriousover= grep(!defined($p1{$_}),sort keys %o1);
  194.  
  195. &writelist("** Packages in archive but missing from override file: **",
  196.            @missingover);
  197. if (@changedmaint) {
  198.     print(STDERR
  199.           " ++ Packages in override file with incorrect old maintainer value: ++\n",
  200.           @changedmaint,
  201.           "\n") || die $!;
  202. }
  203. if (@samemaint) {
  204.     print(STDERR
  205.           " -- Packages specifying same maintainer as override file: --\n",
  206.           @samemaint,
  207.           "\n") || die $!;
  208. }
  209. if (@spuriousover) {
  210.     print(STDERR
  211.           " -- Packages in override file but not in archive: --\n",
  212.           @spuriousover,
  213.           "\n") || die $!;
  214. }
  215.  
  216. print(STDERR " Wrote $written entries to output Packages file.\n") || die $!;
  217.