home *** CD-ROM | disk | FTP | other *** search
/ PC World 2000 February / PCWorld_2000-02_cd.bin / live / usr / lib / dpkg / controllib.pl next >
Text File  |  1999-03-02  |  7KB  |  233 lines
  1.  
  2. $parsechangelog= 'dpkg-parsechangelog';
  3.  
  4. grep($capit{lc $_}=$_, qw(Pre-Depends Standards-Version Installed-Size));
  5.  
  6. $substvar{'Format'}= 1.5;
  7. $substvar{'Newline'}= "\n";
  8. $substvar{'Space'}= " ";
  9. $substvar{'Tab'}= "\t";
  10. $maxsubsts=50;
  11.  
  12. $progname= $0; $progname= $& if $progname =~ m,[^/]+$,;
  13.  
  14. $getlogin = getlogin();
  15. if(!defined($getlogin)) {
  16.     open(SAVEIN, "<&STDIN");
  17.     close(STDIN);
  18.     open(STDIN, "<&STDERR");
  19.  
  20.     $getlogin = getlogin();
  21.  
  22.     close(STDIN);
  23.     open(STDIN, "<&SAVEIN");
  24.     close(SAVEIN);
  25. }
  26. if(!defined($getlogin)) {
  27.     open(SAVEIN, "<&STDIN");
  28.     close(STDIN);
  29.     open(STDIN, "<&STDOUT");
  30.  
  31.     $getlogin = getlogin();
  32.  
  33.     close(STDIN);
  34.     open(STDIN, "<&SAVEIN");
  35.     close(SAVEIN);
  36. }
  37.  
  38. if (defined ($ENV{'LOGNAME'})) {
  39.     if (!defined ($getlogin)) { 
  40.     warn (sprintf ('no utmp entry available, using value of LOGNAME ("%s")', $ENV{'LOGNAME'})); 
  41.     } else {
  42.     if ($getlogin ne $ENV{'LOGNAME'}) { 
  43.         warn (sprintf ('utmp entry ("%s") does not match value of LOGNAME ("%s"); using "%s"',
  44.                $getlogin, $ENV{'LOGNAME'}, $ENV{'LOGNAME'}));
  45.     }
  46.     }
  47.     @fowner = getpwnam ($ENV{'LOGNAME'});
  48.     if (! @fowner) { die (sprintf ('unable to get login information for username "%s"', $ENV{'LOGNAME'})); }
  49. } elsif (defined ($getlogin)) {
  50.     @fowner = getpwnam ($getlogin);
  51.     if (! @fowner) { die (sprintf ('unable to get login information for username "%s"', $getlogin)); }
  52. } else {
  53.     warn (sprintf ('no utmp entry available and LOGNAME not defined; using uid of process (%d)', $<));
  54.     @fowner = getpwuid ($<);
  55.     if (! @fowner) { die (sprintf ('unable to get login information for uid %d', $<)); }
  56. }
  57. @fowner = @fowner[2,3];
  58.  
  59. sub capit {
  60.     return defined($capit{lc $_[0]}) ? $capit{lc $_[0]} :
  61.         (uc substr($_[0],0,1)).(lc substr($_[0],1));
  62. }
  63.  
  64. sub findarch {
  65.     $arch=`dpkg --print-architecture`;
  66.     $? && &subprocerr("dpkg --print-architecture");
  67.     $arch =~ s/\n$//;
  68.     $substvar{'Arch'}= $arch;
  69. }
  70.  
  71. sub substvars {
  72.     my ($v) = @_;
  73.     my ($lhs,$vn,$rhs,$count);
  74.     $count=0;
  75.     while ($v =~ m/\$\{([-:0-9a-z]+)\}/i) {
  76.         $count < $maxsubsts ||
  77.             &error("too many substitutions - recursive ? - in \`$v'");
  78.         $lhs=$`; $vn=$1; $rhs=$';
  79.         if (defined($substvar{$vn})) {
  80.             $v= $lhs.$substvar{$vn}.$rhs;
  81.             $count++;
  82.         } else {
  83.             &warn("unknown substitution variable \${$vn}");
  84.             $v= $lhs.$rhs;
  85.         }
  86.     }
  87.     return $v;
  88. }
  89.  
  90. sub outputclose {
  91.     my ($dosubstvars) = @_;
  92.     for $f (keys %f) { $substvar{"F:$f"}= $f{$f}; }
  93.     if (length($varlistfile) and $dosubstvars) {
  94.         $varlistfile="./$varlistfile" if $varlistfile =~ m/\s/;
  95.         if (open(SV,"< $varlistfile")) {
  96.             while (<SV>) {
  97.                 next if m/^\#/ || !m/\S/;
  98.                 s/\s*\n$//;
  99.                 m/^(\w[-:0-9A-Za-z]*)\=/ ||
  100.                     &error("bad line in substvars file $varlistfile at line $.");
  101.                 $substvar{$1}= $';
  102.             }
  103.             close(SV);
  104.         } elsif ($! != ENOENT ) {
  105.             &error("unable to open substvars file $varlistfile: $!");
  106.         }
  107.     }
  108.     for $f (sort { $fieldimps{$b} <=> $fieldimps{$a} } keys %f) {
  109.         $v= $f{$f};
  110.         if ($dosubstvars) {
  111.         $v= &substvars($v);
  112.     }
  113.         $v =~ m/\S/ || next; # delete whitespace-only fields
  114.         $v =~ m/\n\S/ && &internerr("field $f has newline then non whitespace >$v<");
  115.         $v =~ m/\n[ \t]*\n/ && &internerr("field $f has blank lines >$v<");
  116.         $v =~ m/\n$/ && &internerr("field $f has trailing newline >$v<");
  117.         $v =~ s/\$\{\}/\$/g;
  118.         print("$f: $v\n") || &syserr("write error on control data");
  119.     }
  120.  
  121.     close(STDOUT) || &syserr("write error on close control data");
  122. }
  123.  
  124. sub parsecontrolfile {
  125.     $controlfile="./$controlfile" if $controlfile =~ m/^\s/;
  126.  
  127.     open(CDATA,"< $controlfile") || &error("cannot read control file $controlfile: $!");
  128.     $indices= &parsecdata('C',1,"control file $controlfile");
  129.     $indices >= 2 || &error("control file must have at least one binary package part");
  130.  
  131.     for ($i=1;$i<$indices;$i++) {
  132.         defined($fi{"C$i Package"}) ||
  133.             &error("per-package paragraph $i in control info file is ".
  134.                    "missing Package line");
  135.     }
  136. }
  137.  
  138. sub parsechangelog {
  139.     defined($c=open(CDATA,"-|")) || &syserr("fork for parse changelog");
  140.     if (!$c) {
  141.         @al=($parsechangelog);
  142.         push(@al,"-F$changelogformat") if length($changelogformat);
  143.         push(@al,"-v$since") if length($since);
  144.         push(@al,"-l$changelogfile");
  145.         exec(@al) || &syserr("exec parsechangelog $parsechangelog");
  146.     }
  147.     &parsecdata('L',0,"parsed version of changelog");
  148.     close(CDATA); $? && &subprocerr("parse changelog");
  149.     $substvar{'Source-Version'}= $fi{"L Version"};
  150. }
  151.  
  152.  
  153. sub setsourcepackage {
  154.     if (length($sourcepackage)) {
  155.         $v eq $sourcepackage ||
  156.             &error("source package has two conflicting values - $sourcepackage and $v");
  157.     } else {
  158.         $sourcepackage= $v;
  159.     }
  160. }
  161.  
  162. sub parsecdata {
  163.     local ($source,$many,$whatmsg) = @_;
  164.     # many=0: ordinary control data like output from dpkg-parsechangelog
  165.     # many=1: many paragraphs like in source control file
  166.     # many=-1: single paragraph of control data optionally signed
  167.     local ($index,$cf);
  168.     $index=''; $cf='';
  169.     while (<CDATA>) {
  170.         s/\s*\n$//;
  171.         if (m/^(\S+)\s*:\s*(.*)$/) {
  172.             $cf=$1; $v=$2;
  173.             $cf= &capit($cf);
  174.             $fi{"$source$index $cf"}= $v;
  175.             if (lc $cf eq 'package') { $p2i{"$source $v"}= $index; }
  176.         } elsif (m/^\s+\S/) {
  177.             length($cf) || &syntax("continued value line not in field");
  178.             $fi{"$source$index $cf"}.= "\n$_";
  179.         } elsif (m/^-----BEGIN PGP/ && $many<0) {
  180.             while (<CDATA>) { last if m/^$/; }
  181.             $many= -2;
  182.         } elsif (m/^$/) {
  183.             if ($many>0) {
  184.                 $index++; $cf='';
  185.             } elsif ($many == -2) {
  186.                 $_= <CDATA>;
  187.                 length($_) ||
  188.                     &syntax("expected PGP signature, found EOF after blank line");
  189.                 s/\n$//;
  190.                 m/^-----BEGIN PGP/ ||
  191.                     &syntax("expected PGP signature, found something else \`$_'");
  192.                 $many= -3; last;
  193.             } else {
  194.                 &syntax("found several \`paragraphs' where only one expected");
  195.             }
  196.         } else {
  197.             &syntax("line with unknown format (not field-colon-value)");
  198.         }
  199.     }
  200.     $many == -2 && &syntax("found start of PGP body but no signature");
  201.     if (length($cf)) { $index++; }
  202.     $index || &syntax("empty file");
  203.     return $index;
  204. }
  205.  
  206. sub unknown {
  207.     &warn("unknown information field $_ in input data in $_[0]");
  208. }
  209.  
  210. sub syntax {
  211.     &error("syntax error in $whatmsg at line $.: $_[0]");
  212. }
  213.  
  214. sub failure { die "$progname: failure: $_[0]\n"; }
  215. sub syserr { die "$progname: failure: $_[0]: $!\n"; }
  216. sub error { die "$progname: error: $_[0]\n"; }
  217. sub internerr { die "$progname: internal error: $_[0]\n"; }
  218. sub warn { warn "$progname: warning: $_[0]\n"; }
  219. sub usageerr { print(STDERR "$progname: @_\n\n"); &usageversion; exit(2); }
  220.  
  221. sub subprocerr {
  222.     local ($p) = @_;
  223.     if (WIFEXITED($?)) {
  224.         die "$progname: failure: $p gave error exit status ".WEXITSTATUS($?)."\n";
  225.     } elsif (WIFSIGNALED($?)) {
  226.         die "$progname: failure: $p died from signal ".WTERMSIG($?)."\n";
  227.     } else {
  228.         die "$progname: failure: $p failed with unknown exit code $?\n";
  229.     }
  230. }
  231.  
  232. 1;
  233.