home *** CD-ROM | disk | FTP | other *** search
/ H4CK3R 4 / hacker04 / 04_HACK04.ISO / darwin / darwinx86.iso / usr / bin / dpkg-source < prev    next >
Encoding:
Text File  |  2001-09-18  |  36.7 KB  |  1,052 lines
  1. #! /usr/bin/perl
  2.  
  3. use strict refs;
  4. # use strict vars;
  5.  
  6. my $dpkglibdir, $version;
  7.  
  8. BEGIN { 
  9.     $dpkglibdir="/usr/share/dpkg";
  10.     $version=""; # This line modified by Makefile
  11.     push (@INC, $dpkglibdir); 
  12. }
  13.  
  14. use POSIX;
  15. #use POSIX qw (:errno_h :signal_h);
  16.  
  17. require 'controllib.pl';
  18.  
  19. my @filesinarchive;
  20. my %dirincluded;
  21. my %notfileobject;
  22. my $fn;
  23.  
  24. my (%filepatched);
  25.  
  26. my ($sourcestyle) = 'X';
  27.  
  28. my (@patchextra) = findpatchversion ();
  29. my ($findsep, @findextra) = &findfindversion ();
  30. my ($cpiosep, @cpioextra) = &findcpioversion ();
  31. my ($taroffset) = &findtarversion ();
  32.  
  33. sub usageversion {
  34.     print STDERR
  35. "Debian GNU/Linux dpkg-source $version.  Copyright (C) 1996, 1997
  36. Ian Jackson and SPI, Inc.  This is free software; see the GNU
  37. General Public Licence version 2 or later for copying conditions.
  38. There is NO warranty.
  39.  
  40. Usage:  dpkg-source -x <filename>.dsc
  41.         dpkg-source -b <directory> [<orig-directory>|<orig-targz>|\'\']
  42. Build options:   -c<controlfile>     get control info from this file
  43.                  -l<changelogfile>   get per-version info from this file
  44.                  -F<changelogformat> force change log format
  45.                  -V<name>=<value>    set a substitution variable
  46.                  -T<varlistfile>     read variables here, not debian/substvars
  47.                  -D<field>=<value>   override or add a .dsc field and value
  48.                  -U<field>           remove a field
  49.                  -sa                 auto select orig source (-sA is default)
  50.                  -sk                 use packed orig source (unpack & keep)
  51.                  -sp                 use packed orig source (unpack & remove)
  52.                  -su                 use unpacked orig source (pack & keep)
  53.                  -sr                 use unpacked orig source (pack & remove)
  54.                  -ss                 trust packed & unpacked orig src are same
  55.                  -sn                 there is no diff, do main tarfile only
  56.                  -sA,-sK,-sP,-sU,-sR like -sa,-sp,-sk,-su,-sr but may overwrite
  57. Extract options: -sp (default)       leave orig source packed in current dir
  58.                  -sn                 do not copy original source to current dir
  59.                  -su                 unpack original source tree too
  60. General options: -h                  print this message
  61. ";
  62. }
  63.  
  64. $i = 100;
  65. grep ($fieldimps {$_} = $i--,
  66.       qw (Source Version Binary Maintainer Architecture Standards-Version));
  67.  
  68. while (@ARGV && $ARGV[0] =~ m/^-/) {
  69.     $_=shift(@ARGV);
  70.     if (m/^-b$/) {
  71.         &setopmode('build');
  72.     } elsif (m/^-x$/) {
  73.         &setopmode('extract');
  74.     } elsif (m/^-s([akpursnAKPUR])$/) {
  75.         $sourcestyle= $1;
  76.     } elsif (m/^-c/) {
  77.         $controlfile= $';
  78.     } elsif (m/^-l/) {
  79.         $changelogfile= $';
  80.     } elsif (m/^-F([0-9a-z]+)$/) {
  81.         $changelogformat=$1;
  82.     } elsif (m/^-D([^\=:]+)[=:]/) {
  83.         $override{$1}= $';
  84.     } elsif (m/^-U([^\=:]+)$/) {
  85.         $remove{$1}= 1;
  86.     } elsif (m/^-V(\w[-:0-9A-Za-z]*)[=:]/) {
  87.         $substvar{$1}= $';
  88.     } elsif (m/^-T/) {
  89.         $varlistfile= $';
  90.     } elsif (m/^-h$/) {
  91.         &usageversion; exit(0);
  92.     } elsif (m/^--$/) {
  93.         last;
  94.     } else {
  95.         &usageerr("unknown option $_");
  96.     }
  97. }
  98.  
  99. defined($opmode) || &usageerr("need -x or -b");
  100.  
  101. if ($opmode eq 'build') {
  102.  
  103.     $sourcestyle =~ y/X/A/;
  104.     $sourcestyle =~ m/[akpursnAKPUR]/ ||
  105.         &usageerr("source handling style -s$sourcestyle not allowed with -b");
  106.  
  107.     @ARGV || &usageerr("-b needs a directory");
  108.     @ARGV<=2 || &usageerr("-b takes at most a directory and an orig source argument");
  109.     $dir= shift(@ARGV);
  110.     $dir= "./$dir" unless $dir =~ m:^/:; $dir =~ s,/*$,,;
  111.     stat($dir) || &error("cannot stat directory $dir: $!");
  112.     -d $dir || &error("directory argument $dir is not a directory");
  113.  
  114.     $changelogfile= "$dir/debian/changelog" unless defined($changelogfile);
  115.     $controlfile= "$dir/debian/control" unless defined($controlfile);
  116.     
  117.     &parsechangelog;
  118.     &parsecontrolfile;
  119.  
  120.     $archspecific=0;
  121.     for $_ (keys %fi) {
  122.         $v= $fi{$_};
  123.         if (s/^C //) {
  124. #print STDERR "G key >$_< value >$v<\n";
  125.             if (m/^Source$/) { &setsourcepackage; }
  126.             elsif (m/^Standards-Version$|^Maintainer$/) { $f{$_}= $v; }
  127.             elsif (s/^X[BC]*S[BC]*-//i) { $f{$_}= $v; }
  128.             elsif (m/^(Section|Priority|Files)$/ || m/^X[BC]+-/i) { }
  129.             else { &unknown('general section of control info file'); }
  130.         } elsif (s/^C(\d+) //) {
  131. #print STDERR "P key >$_< value >$v<\n";
  132.             $i=$1; $p=$fi{"C$i Package"};
  133.             push(@binarypackages,$p) unless $packageadded{$p}++;
  134.             if (m/^Architecture$/) {
  135. #print STDERR "$p >$v< >".join(' ',@sourcearch)."<\n";
  136.                 if ($v eq 'any') {
  137.                     @sourcearch= ('any');
  138.                 } elsif ($v eq 'all') {
  139.                     if (!@sourcearch || $sourcearch[0] eq 'all') {
  140.                         @sourcearch= ('all');
  141.                     } else {
  142.                         @sourcearch= ('any');
  143.                     }
  144.                 } else {
  145.                     if (grep($sourcearch[0] eq $_, 'any','all')) {
  146.                         @sourcearch= ('any');
  147.                     } else {
  148.                         for $a (split(/\s+/,$v)) {
  149.                             &error("architecture $a only allowed on its own".
  150.                                    " (list for package $p is \`$a')")
  151.                                    if grep($a eq $_, 'any','all');
  152.                             push(@sourcearch,$a) unless $archadded{$a}++;
  153.                         }
  154.                     }
  155.                 }
  156.                 $f{'Architecture'}= join(' ',@sourcearch);
  157.             } elsif (s/^X[BC]*S[BC]*-//i) {
  158.                 $f{$_}= $v;
  159.             } elsif (m/^(Package|Essential|Pre-Depends|Depends|Provides)$/ ||
  160.                      m/^(Recommends|Suggests|Optional|Conflicts|Replaces)$/ ||
  161.                      m/^(Description|Section|Priority)$/ ||
  162.                      m/^X[CS]+-/i) {
  163.             } else {
  164.                 &unknown("package's section of control info file");
  165.             }
  166.         } elsif (s/^L //) {
  167. #print STDERR "L key >$_< value >$v<\n";
  168.             if (m/^Source$/) {
  169.                 &setsourcepackage;
  170.             } elsif (m/^Version$/) {
  171.                 $f{$_}= $v;
  172.             } elsif (s/^X[BS]*C[BS]*-//i) {
  173.                 $f{$_}= $v;
  174.             } elsif (m/^(Maintainer|Changes|Urgency|Distribution|Date)$/ ||
  175.                      m/^X[BS]+-/i) {
  176.             } else {
  177.                 &unknown("parsed version of changelog");
  178.             }
  179.         } else {
  180.             &internerr("value from nowhere, with key >$_< and value >$v<");
  181.         }
  182.     }
  183.  
  184.     $f{'Binary'}= join(', ',@binarypackages);
  185.     for $f (keys %override) { $f{&capit($f)}= $override{$f}; }
  186.  
  187.     for $f (qw(Version)) {
  188.         defined($f{$f}) || &error("missing information for critical output field $f");
  189.     }
  190.     for $f (qw(Maintainer Architecture Standards-Version)) {
  191.         defined($f{$f}) || &warn("missing information for output field $f");
  192.     }
  193.     defined($sourcepackage) || &error("unable to determine source package name !");
  194.     $f{'Source'}= $sourcepackage;
  195.     for $f (keys %remove) { delete $f{&capit($f)}; }
  196.  
  197.     $version= $f{'Version'};
  198.     $version =~ s/^\d+://; $upstreamversion= $version; $upstreamversion =~ s/-[^-]*$//;
  199.     $basenamerev= $sourcepackage.'_'.$version;
  200.     $basename= $sourcepackage.'_'.$upstreamversion;
  201.     $basedirname= $basename;
  202. #print STDERR ">$basedirname<\n";
  203.     $basedirname =~ s/_/-/;
  204. #print STDERR ">$basedirname<\n";
  205.  
  206.     $origdir= "$dir.orig";
  207.     $origtargz= "$basename.orig.tar.gz";
  208.     if (@ARGV) {
  209.         $origarg= shift(@ARGV);
  210.         if (length($origarg)) {
  211.             stat($origarg) || &error("cannot stat orig argument $origarg: $!");
  212.             if (-d _) {
  213.                 $origdir= $origarg;
  214.                 $origdir= "./$origdir" unless $origdir =~ m,^/,; $origdir =~ s,/*$,,;
  215.                 $sourcestyle =~ y/aA/rR/;
  216.                 $sourcestyle =~ m/[ursURS]/ ||
  217.                     &error("orig argument is unpacked but source handling style".
  218.                            " -s$sourcestyle calls for packed (.orig.tar.gz)");
  219.             } elsif (-f _) {
  220.                 $origtargz= $origarg;
  221.                 $sourcestyle =~ y/aA/pP/;
  222.                 $sourcestyle =~ m/[kpsKPS]/ ||
  223.                     &error("orig argument is packed but source handling style".
  224.                            " -s$sourcestyle calls for unpacked (.orig/)");
  225.             } else {
  226.                 &error("orig argument $origarg is not a plain file or directory");
  227.             }
  228.         } else {
  229.             $sourcestyle =~ y/aA/nn/;
  230.             $sourcestyle =~ m/n/ ||
  231.                 &error("orig argument is empty (means no orig, no diff)".
  232.                        " but source handling style -s$sourcestyle wants something");
  233.         }
  234.     }
  235.  
  236.     if ($sourcestyle =~ m/[aA]/) {
  237.         if (stat("$origtargz")) {
  238.             -f _ || &error("packed orig \`$origtargz' exists but is not a plain file");
  239.             $sourcestyle =~ y/aA/pP/;
  240.         } elsif ($! != ENOENT) {
  241.             &syserr("unable to stat putative packed orig \`$origtargz'");
  242.         } elsif (stat("$origdir")) {
  243.             -d _ || &error("unpacked orig \`$origdir' exists but is not a directory");
  244.             $sourcestyle =~ y/aA/rR/;
  245.         } elsif ($! != ENOENT) {
  246.             &syserr("unable to stat putative unpacked orig \`$origdir'");
  247.         } else {
  248.             $sourcestyle =~ y/aA/nn/;
  249.         }
  250.     }
  251.     $dirbase= $dir; $dirbase =~ s,/?$,,; $dirbase =~ s,[^/]+$,,; $dirname= $&;
  252.     $dirname eq $basedirname || &warn("source directory \`$dir' is not <sourcepackage>".
  253.                                       "-<upstreamversion> \`$basedirname'");
  254.     
  255.     if ($sourcestyle ne 'n') {
  256.         $origdirbase= $origdir; $origdirbase =~ s,/?$,,;
  257.         $origdirbase =~ s,[^/]+$,,; $origdirname= $&;
  258.  
  259.         $origdirname eq "$basedirname.orig" ||
  260.             &warn(".orig directory name $origdirname is not <package>".
  261.                   "-<upstreamversion> (wanted $basedirname.orig)");
  262.         $tardirbase= $origdirbase; $tardirname= $origdirname;
  263.  
  264.         $tarname= $origtargz;
  265.         $tarname eq "$basename.orig.tar.gz" ||
  266.             &warn(".orig.tar.gz name $tarname is not <package>_<upstreamversion>".
  267.                   ".orig.tar.gz (wanted $basename.orig.tar.gz)");
  268.     } else {
  269.         $tardirbase= $dirbase; $tardirname= $dirname;
  270.         $tarname= "$basenamerev.tar.gz";
  271.     }
  272.  
  273. #print STDERR ">$dir|$origdir|$origtargz|$sourcestyle<\n";
  274.  
  275.     if ($sourcestyle =~ m/[nurUR]/) {
  276.  
  277.         if (stat($tarname)) {
  278.             $sourcestyle =~ m/[nUR]/ ||
  279.                 &error("tarfile \`$tarname' already exists, not overwriting,".
  280.                        " giving up; use -sU or -sR to override");
  281.         } elsif ($! != ENOENT) {
  282.             &syserr("unable to check for existence of \`$tarname'");
  283.         }
  284.  
  285. #print STDERR ">$tarname|$tardirbase|$tardirname<\n";
  286.     
  287.         print("$progname: building $sourcepackage in $tarname\n")
  288.             || &syserr("write building tar message");
  289.         &forkgzipwrite("$tarname.new");
  290.         defined($c2= fork) || &syserr("fork for tar");
  291.         if (!$c2) {
  292.             chdir($tardirbase) || &syserr("chdir to above (orig) source $tardirbase");
  293. #system('pwd && ls');
  294.             open(STDOUT,">&GZIP") || &syserr("reopen gzip for tar");
  295.             # FIXME: put `--' argument back when tar is fixed
  296.             exec('tar','-cf','-',$tardirname); &syserr("exec tar");
  297.         }
  298.         close(GZIP);
  299.         &reapgzip;
  300.         $c2 == waitpid($c2,0) || &syserr("wait for tar");
  301.         $? && !(WIFSIGNALED($c2) && WTERMSIG($c2) == SIGPIPE) && subprocerr("tar");
  302.         rename("$tarname.new",$tarname) ||
  303.             &syserr("unable to rename \`$tarname.new' (newly created) to \`$tarname'");
  304.  
  305.     } else {
  306.         
  307.         print("$progname: building $sourcepackage using existing $tarname\n")
  308.             || &syserr("write using existing tar message");
  309.         
  310.     }
  311.     
  312.     addfile ("$tarname");
  313.  
  314.     if ($sourcestyle =~ m/[kpKP]/) {
  315.  
  316.         if (stat ($origdir)) {
  317.             if (! $sourcestyle =~ m/[KP]/) {
  318.                 &error ("orig dir \`$origdir' already exists, not overwriting,"
  319.             . " giving up; use -sA, -sK or -sP to override");
  320.         }
  321.             erasedir ($origdir);
  322.         } elsif ($! != ENOENT) {
  323.             &syserr ("unable to check for existence of orig dir \`$origdir'");
  324.         }
  325.  
  326.         $expectprefix = $origdir; 
  327.     $expectprefix =~ s,^\./,,;
  328.         checktarsane ($origtargz, $expectprefix);
  329.         mkdir ("$origtargz.tmp-nest",0755) ||
  330.             &syserr ("unable to create \`$origtargz.tmp-nest'");
  331.         extracttar ($origtargz, "$origtargz.tmp-nest", $expectprefix);
  332.         rename ("$origtargz.tmp-nest/$expectprefix", $expectprefix) ||
  333.             &syserr ("unable to rename \`$origtargz.tmp-nest/$expectprefix' to "
  334.              . "\`$expectprefix'");
  335.         rmdir ("$origtargz.tmp-nest") ||
  336.             &syserr ("unable to remove \`$origtargz.tmp-nest'");
  337.  
  338.     }
  339.         
  340.     if ($sourcestyle =~ m/[kpursKPUR]/) {
  341.         
  342.         print ("$progname: building $sourcepackage in $basenamerev.diff.gz\n")
  343.             || &syserr ("write building diff message");
  344.         &forkgzipwrite ("$basenamerev.diff.gz");
  345.  
  346.         defined($c2= open(FIND,"-|")) || &syserr("fork for find");
  347.         if (!$c2) {
  348.             chdir($dir) || &syserr("chdir to $dir for find");
  349.         exec 'find', '.', @findextra; 
  350.         &syserr ("exec find");
  351.         }
  352.         $/= $findsep;
  353.  
  354.       file:
  355.         while (defined($fn= <FIND>)) {
  356.             if ($findversion == "new") {
  357.         $fn =~ s/\0$//;
  358.         } else {
  359.         $fn =~ s/\n$//;
  360.         }
  361.         $fn =~ s,^\./,,;
  362.             lstat("$dir/$fn") || &syserr("cannot stat file $dir/$fn");
  363.             if (-l _) {
  364.                 $type{$fn}= 'symlink';
  365.                 &checktype('-l') || next;
  366.                 defined($n= readlink("$dir/$fn")) ||
  367.                     &syserr("cannot read link $dir/$fn");
  368.                 defined($n2= readlink("$origdir/$fn")) ||
  369.                     &syserr("cannot read orig link $origdir/$fn");
  370.                 $n eq $n2 || &unrepdiff2("symlink to $n2","symlink to $n");
  371.             } elsif (-f _) {
  372.                 $type{$fn}= 'plain file';
  373.                 if (!lstat("$origdir/$fn")) {
  374.                     $! == ENOENT || &syserr("cannot stat orig file $origdir/$fn");
  375.                     $ofnread= '/dev/null';
  376.                 } elsif (-f _) {
  377.                     $ofnread= "$origdir/$fn";
  378.                 } else {
  379.                     &unrepdiff2("something else","plain file");
  380.                     next;
  381.                 }
  382.                 defined($c3= open(DIFFGEN,"-|")) || &syserr("fork for diff");
  383.                 if (!$c3) {
  384.                     exec('diff','-u',
  385.                          '-L',"$basedirname.orig/$fn",
  386.                          '-L',"$basedirname/$fn",
  387.                          '--',"$ofnread","$dir/$fn"); &syserr("exec diff");
  388.                 }
  389.                 $difflinefound= 0;
  390.                 $/= "\n";
  391.                 while (<DIFFGEN>) {
  392.                     if (m/^binary/i) {
  393.                         close(DIFFGEN); $/= $findsep;
  394.                         &unrepdiff("binary file contents changed");
  395.                         next file;
  396.                     } elsif (m/^[-+\@ ]/) {
  397.                         $difflinefound=1;
  398.                     } elsif (m/^\\ No newline at end of file$/) {
  399.                         &warn("file $fn has no final newline ".
  400.                               "(either original or modified version)");
  401.                     } else {
  402.                         s/\n$//;
  403.                         &internerr("unknown line from diff -u on $fn: \`$_'");
  404.                     }
  405.                     print(GZIP $_) || &syserr("failed to write to gzip");
  406.                 }
  407.                 close(DIFFGEN); $/= $findsep;
  408.                 if (WIFEXITED($?) && (($es=WEXITSTATUS($?))==0 || $es==1)) {
  409.                     if ($es==1 && !$difflinefound) {
  410.                         &unrepdiff("diff gave 1 but no diff lines found");
  411.                     }
  412.                 } else {
  413.                     subprocerr("diff on $dir/$fn");
  414.                 }
  415.             } elsif (-p _) {
  416.                 $type{$fn}= 'pipe';
  417.                 &checktype('-p');
  418.             } elsif (-b _ || -c _ || -S _) {
  419.                 &unrepdiff("device or socket is not allowed");
  420.             } elsif (-d _) {
  421.                 $type{$fn}= 'directory';
  422.             } else {
  423.                 &unrepdiff("unknown file type ($!)");
  424.             }
  425.         }
  426.         close (FIND); $? && subprocerr ("find on $dir");
  427.         close (GZIP) || &syserr ("finish write to gzip pipe");
  428.         &reapgzip;
  429.  
  430.         defined ($c2 = open (FIND, "-|")) || &syserr ("fork for 2nd find");
  431.         if (!$c2) {
  432.             chdir ($origdir) || &syserr ("chdir to $origdir for 2nd find");
  433.             exec 'find', '.', @findextra;
  434.         &syserr ("exec second find");
  435.         }
  436.         $/= $findsep;
  437.         while (defined ($fn = <FIND>)) {
  438.             if ($findsep == "\0") {
  439.         $fn =~ s/\0$//;
  440.         } else {
  441.         $fn =~ s/\n$//;
  442.         }
  443.         $fn =~ s,^\./,,;
  444.             next if defined ($type{$fn});
  445.             lstat ("$origdir/$fn") || &syserr ("cannot check orig file $origdir/$fn");
  446.             if (-f _) {
  447.                 &warn("ignoring deletion of file $fn");
  448.             } elsif (-d _) {
  449.                 &warn("ignoring deletion of directory $fn");
  450.             } elsif (-l _) {
  451.                 &warn("ignoring deletion of symlink $fn");
  452.             } else {
  453.                 &unrepdiff2('not a file, directory or link','nonexistent');
  454.             }
  455.         }
  456.         close (FIND); $? && subprocerr ("find on $dirname");
  457.  
  458.         &addfile ("$basenamerev.diff.gz");
  459.     }
  460.  
  461.     if ($sourcestyle =~ m/[prPR]/) {
  462.         erasedir($origdir);
  463.     }
  464.  
  465.     print("$progname: building $sourcepackage in $basenamerev.dsc\n")
  466.         || &syserr("write building message");
  467.     open(STDOUT,"> $basenamerev.dsc") || &syserr("create $basenamerev.dsc");
  468.     &outputclose(1);
  469.  
  470.     if ($ur) {
  471.         print(STDERR "$progname: unrepresentable changes to source\n")
  472.             || &syserr("write error msg: $!");
  473.         exit(1);
  474.     }
  475.     exit(0);
  476.  
  477. } else {
  478.  
  479.     $sourcestyle =~ y/X/p/;
  480.     $sourcestyle =~ m/[pun]/ ||
  481.         &usageerr("source handling style -s$sourcestyle not allowed with -b");
  482.  
  483.     @ARGV==1 || &usageerr("-x needs exactly one argument, the .dsc");
  484.     $dsc= shift(@ARGV);
  485.     $dsc= "./$dsc" unless $dsc =~ m:^/:;
  486.     $dscdir= $dsc; $dscdir= "./$dscdir" unless $dsc =~ m,^/|^\./,;
  487.     $dscdir =~ s,/[^/]+$,,;
  488.  
  489.     open (CDATA, "< $dsc") || &error ("cannot open .dsc file $dsc: $!");
  490.     &parsecdata ('S', -1, "source control file $dsc");
  491.     close (CDATA);
  492.  
  493.     for $f (qw(Source Version Files)) {
  494.         defined ($fi{"S $f"}) ||
  495.             &error ("missing critical source control field $f");
  496.     }
  497.  
  498.     $sourcepackage= $fi{'S Source'};
  499.     $sourcepackage =~ m/[^-+.0-9a-z]/ &&
  500.         &error("source package name contains illegal character \`$&'");
  501.     $sourcepackage =~ m/^[0-9a-z]./ ||
  502.         &error("source package name is too short or starts with non-alphanum");
  503.  
  504.     $version= $fi{'S Version'};
  505.     $version =~ m/[^-+:.0-9a-zA-Z]/ &&
  506.         &error("version number contains illegal character \`$&'");
  507.     $version =~ s/^\d+://;
  508.     if ($version =~ m/-([^-]+)$/) {
  509.         $baseversion= $`; $revision= $1;
  510.     } else {
  511.         $baseversion= $version; $revision= '';
  512.     }
  513.  
  514.     $files= $fi{'S Files'};
  515.     for $file (split(/\n /,$files)) {
  516.         next if $file eq '';
  517.         $file =~ m/^([0-9a-f]{32})[ \t]+(\d+)[ \t]+([0-9a-zA-Z][-+:.,=0-9a-zA-Z_]+)$/
  518.             || &error("Files field contains bad line \`$file'");
  519.         ($md5sum{$3},$size{$3},$file) = ($1,$2,$3);
  520.         &setfile(\$tarfile) if $file =~ m/\.tar\.gz$/;
  521.         &setfile(\$difffile) if $file =~ m/\.diff\.gz$/;
  522.     }
  523.  
  524.     $newdirectory = $sourcepackage . '-' . $baseversion;
  525.     $expectprefix = $newdirectory;
  526.     if (length ($difffile)) { $expectprefix.= '.orig'; }
  527.     
  528.     if (! length ($tarfile)) { &error ("no tarfile in Files field"); }
  529.     checkstats ($tarfile);
  530.     if (length ($difffile)) { checkstats ($difffile); }
  531.  
  532.     $tarprefix = checktarsane ("$dscdir/$tarfile", $expectprefix);
  533.  
  534.     my $tarsubst = quotemeta ($tarprefix);
  535.     my $expectsubst = $expectprefix;
  536.     @filesinarchive = map { s/^$tarsubst/$expectsubst/; $_ } @filesinarchive;
  537.     %dirincluded = map { s/^$tarsubst/$expectsubst/; $_=>1 } (keys %dirincluded);
  538.     %notfileobject = map { s/^$tarsubst/$expectsubst/; $_=>1 } (keys %notfileobject);
  539.  
  540.     if (length ($difffile)) {
  541.             
  542.         &forkgzipread("$dscdir/$difffile");
  543.         $/="\n";
  544.         while (<GZIP>) {
  545.             s/\n$// || &error("diff is missing trailing newline");
  546.             if (/^--- /) {
  547.                 $fn= $';
  548.                 substr($fn,0,length($expectprefix)+1) eq "$expectprefix/" ||
  549.                     &error("diff patches file ($fn) not in expected subdirectory");
  550.                 $fn =~ m/\.dpkg-orig$/ &&
  551.                     &error("diff patches file with name ending .dpkg-orig");
  552.                 $dirname= $fn;
  553.                 if ($dirname =~ s,/[^/]+$,, && !defined($dirincluded{$dirname})) {
  554.             $dirtocreate{$dirname} = 1;
  555.         }
  556.                 defined($notfileobject{$fn}) &&
  557.                     &error("diff patches something which is not a plain file");
  558.                 $_= <GZIP>; s/\n$// ||
  559.                     &error("diff finishes in middle of ---/+++ (line $.)");
  560.                 $_ eq '+++ '.$newdirectory.substr($fn,length($expectprefix)) ||
  561.                     &error("line after --- for file $fn isn't as expected");
  562.                 $filepatched{$fn}++ && &error("diff patches file $fn twice");
  563.             } elsif (/^\\ No newline at end of file$/) {
  564.             } elsif (/^[-+ \@]/) {
  565.         } else {
  566.                 &error ("diff contains unknown line \`$_'");
  567.             }
  568.         }
  569.         close(GZIP);
  570.         
  571.         &reapgzip;
  572.     }
  573.  
  574.     print("$progname: extracting $sourcepackage in $newdirectory\n")
  575.         || &syserr("write extracting message");
  576.     
  577.     &erasedir($newdirectory);
  578.     &erasedir("$newdirectory.orig");
  579.  
  580.     mkdir("$expectprefix.tmp-nest",0755)
  581.     || &syserr("unable to create \`$expectprefix.tmp-nest'");
  582.     extracttar("$dscdir/$tarfile","$expectprefix.tmp-nest","$expectprefix");
  583.     rename("$expectprefix.tmp-nest/$expectprefix","$expectprefix")
  584.     || &syserr("unable to rename \`$expectprefix.tmp-nest/$expectprefix' "
  585.            ."to \`$expectprefix'");
  586.     rmdir("$expectprefix.tmp-nest")
  587.     || &syserr("unable to remove \`$expectprefix.tmp-nest'");
  588.  
  589.     for $dircreate (keys %dirtocreate) {
  590.     $dircreatem= "";
  591.     for $dircreatep (split("/",$dirc)) {
  592.         $dircreatem.= $dircreatep;
  593.         if (!lstat($dircreatem)) {
  594.         $! == ENOENT || &syserr("cannot stat $dircreatem");
  595.         mkdir($dircreatem,0777)
  596.             || &syserr("failed to create $dircreatem subdirectory");
  597.         }
  598.         else {
  599.         -d _ || &error("diff patches file in directory \`$dircreate',"
  600.                    ." but $dircreatem isn't a directory !");
  601.         }
  602.     }
  603.     }
  604.     
  605.     if (length($difffile)) {
  606.         rename($expectprefix,$newdirectory) ||
  607.             &syserr("failed to rename newly-extracted $expectprefix to $newdirectory");
  608.  
  609.         if ($sourcestyle =~ m/u/) {
  610.         mkdir("$expectprefix.tmp-nest",0755)
  611.         || &syserr("unable to create \`$expectprefix.tmp-nest'");
  612.         extracttar("$dscdir/$tarfile","$expectprefix.tmp-nest",
  613.                "$expectprefix");
  614.         rename("$expectprefix.tmp-nest/$expectprefix","$expectprefix")
  615.         || &syserr("unable to rename \`$expectprefix.tmp-nest/"
  616.                ."$expectprefix' to \`$expectprefix'");
  617.         rmdir("$expectprefix.tmp-nest")
  618.         || &syserr("unable to remove \`$expectprefix.tmp-nest'");
  619.          } elsif ($sourcestyle =~ m/p/) {
  620.             stat("$dscdir/$tarfile") ||
  621.                 &syserr("failed to stat \`$dscdir/$tarfile' to see if need to copy");
  622.             ($dsctardev,$dsctarino) = stat _;
  623.             $dumptar= $sourcepackage.'_'.$baseversion.'.orig.tar.gz';
  624.             if (!stat($dumptar)) {
  625.                 $! == ENOENT || &syserr("failed to check destination \`$dumptar'".
  626.                                         " to see if need to copy");
  627.             } else {
  628.                 ($dumptardev,$dumptarino) = stat _;
  629.                 if ($dumptardev == $dsctardev && $dumptarino == $dsctarino) {
  630.                     $dumptar= '';
  631.                 }
  632.             }
  633.             if (length($dumptar)) {
  634.                 system('cp','--',"$dscdir/$tarfile","$dumptar");
  635.                 $? && subprocerr("cp $dscdir/$tarfile to $dumptar");
  636.             }
  637.         }                
  638.  
  639.         &forkgzipread("$dscdir/$difffile");
  640.         defined($c2= fork) || &syserr("fork for patch");
  641.         if (!$c2) {
  642.             open(STDIN,"<&GZIP") || &syserr("reopen gzip for patch");
  643.             chdir($newdirectory) || &syserr("chdir to $newdirectory for patch");
  644.         exec 'patch', '-s', '-t', '-F', '0', '-N', '-p1', '-u', '-V', 'never', @patchextra;
  645.             &syserr("exec patch");
  646.         }
  647.         close(GZIP);
  648.         $c2 == waitpid($c2,0) || &syserr("wait for patch");
  649.         $? && subprocerr("patch");
  650.         &reapgzip;
  651.  
  652.         for $fn (keys %filepatched) {
  653.             $ftr= "$newdirectory/".substr($fn,length($expectprefix)+1).".dpkg-orig";
  654.             unlink($ftr) || &syserr("remove patch backup file $ftr");
  655.         }
  656.  
  657.         if (!(@s= lstat("$newdirectory/debian/rules"))) {
  658.             $! == ENOENT || &syserr("cannot stat $newdirectory/debian/rules");
  659.             &warn("$newdirectory/debian/rules does not exist");
  660.         } elsif (-f _) {
  661.             chmod($s[2] | 0111, "$newdirectory/debian/rules") ||
  662.                 &syserr("cannot make $newdirectory/debian/rules executable");
  663.         } else {
  664.             &warn("$newdirectory/debian/rules is not a plain file");
  665.         }
  666.     }
  667.  
  668.     $execmode= 0777 & ~umask;
  669.     (@s= stat('.')) || &syserr("cannot stat \`.'");
  670.     $dirmode= $execmode | ($s[2] & 02000);
  671.     $plainmode= $execmode & ~0111;
  672.     $fifomode= ($plainmode & 0222) | (($plainmode & 0222) << 1);
  673.     for $fn (@filesinarchive) {
  674.         $fn= substr($fn,length($expectprefix)+1);
  675.         $fn= "$newdirectory/$fn";
  676.         (@s= lstat($fn)) || &syserr("cannot stat extracted object \`$fn'");
  677.         $mode= $s[2];
  678.         if (-d _) {
  679.             $newmode= $dirmode;
  680.         } elsif (-f _) {
  681.             $newmode= ($mode & 0111) ? $execmode : $plainmode;
  682.         } elsif (-p _) {
  683.             $newmode= $fifomode;
  684.         } elsif (!-l _) {
  685.             &internerr("unknown object \`$fn' after extract (mode ".
  686.                        sprintf("0%o",$mode).")");
  687.         } else { next; }
  688.         next if ($mode & 07777) == $newmode;
  689.         chmod($newmode,$fn) ||
  690.             &syserr(sprintf("cannot change mode of \`%s' to 0%o from 0%o",
  691.                             $fn,$newmode,$mode));
  692.     }
  693.     exit(0);
  694. }
  695.  
  696. sub checkstats {
  697.     my ($f) = @_;
  698.     my @s;
  699.     my $m;
  700.     open(STDIN,"< $dscdir/$f") || &syserr("cannot read $dscdir/$f");
  701.     (@s= stat(STDIN)) || &syserr("cannot fstat $dscdir/$f");
  702.     $s[7] == $size{$f} || &error("file $f has size $s[7] instead of expected $size{$f}");
  703.     $m= `md5sum`; $? && subprocerr("md5sum $f"); $m =~ s/\n$//;
  704.     $m =~ s/^([0-9a-f]{32})( +-)?$/$1/ || &failure("md5sum of $f gave bad output \`$m'");
  705.     $m eq $md5sum{$f} || &error("file $f has md5sum '$m' instead of expected $md5sum{$f}");
  706.     open(STDIN,"</dev/null") || &syserr("reopen stdin from /dev/null");
  707. }
  708.  
  709. sub erasedir {
  710.     my ($dir) = @_;
  711.     if (!lstat($dir)) {
  712.     ($! == ENOENT) && return;
  713.         &syserr("cannot stat directory $dir (before removal)");
  714.     }
  715.     system 'rm','-rf','--',$dir;
  716.     $? && subprocerr("rm -rf $dir");
  717.     if (!stat($dir)) {
  718.         ($! == ENOENT) && return;
  719.         &syserr("unable to check for removal of dir \`$dir'");
  720.     }
  721.     &failure("rm -rf failed to remove \`$dir'");
  722. }
  723.  
  724. use strict 'vars';
  725.  
  726. sub checktarcpio {
  727.  
  728.     my ($tarfileread, $wpfx) = @_;
  729.     my ($tarprefix, $c2);
  730.  
  731.     @filesinarchive = ();
  732.  
  733.     # make <CPIO> read from the uncompressed archive file
  734.     &forkgzipread ("$tarfileread");
  735.     $c2 = open (CPIO, "-|");
  736.     if (! defined ($c2)) { &syserr ("fork for cpio"); }
  737.     if ($c2 == 0) {
  738.         open (STDIN, "<&GZIP") || &syserr ("reopen gzip for cpio");
  739.     open (STDERR, "| egrep -v '^[0-9]+ blocks\$' >&2") ||
  740.         &syserr ("reopen stderr for cpio to grep out blocks message");
  741.         exec 'cpio', '-t', @cpioextra;
  742.     &syserr ("exec cpio");
  743.     }
  744.     close (GZIP);
  745.  
  746.     $/ = $cpiosep;
  747.     while (defined ($fn = <CPIO>)) {
  748.     
  749.         $fn =~ s/[\0\n]$//;
  750.  
  751.     # store printable name of file for error messages
  752.     my $pfn = $fn;
  753.     $pfn =~ y/ -~/?/c;
  754.  
  755.     # if $tarprefix not set, we are examining the first file in the archive
  756.     if (! $tarprefix) {
  757.         $tarprefix = ($fn =~ m,([^/]*)[/],)[0];
  758.         # need to check for multiple dots on some operating systems
  759.         # empty tarprefix (due to regex failure) will match emptry string
  760.         if ($tarprefix =~ /^[.]*$/) {
  761.         &error ("tarfile \`$tarfileread' does not extract into a subdirectory"
  762.             . " of the current directory ('$pfn')");
  763.         }
  764.     }
  765.  
  766.         if ($fn =~ m/\n/) {
  767.         &error ("archive file \`$tarfileread' contains object with newline in its name (`$pfn')");
  768.     }
  769.  
  770.     next if ($fn eq '././@LongLink');
  771.  
  772.     my $fprefix = substr ($fn, 0, length ($tarprefix));
  773.         my $slash = substr ($fn, length ($tarprefix), 1);
  774.         if ((($slash ne '/') && ($slash ne '')) || ($fprefix ne $tarprefix)) {
  775.         &error ("tarfile \`$tarfileread' contains object ($pfn) ".
  776.             "not in expected directory ($tarprefix)");
  777.     }
  778.  
  779.     # need to check for multiple dots on some operating systems
  780.         if ($fn =~ m/[.]{2,}/) {
  781.             &error ("tarfile \`$tarfileread' contains object with".
  782.             " /../ in its name ($pfn)");
  783.     }
  784.         push (@filesinarchive, $fn);
  785.     }
  786.     close (CPIO);
  787.     $? && subprocerr ("cpio");
  788.     &reapgzip;
  789.     $/= "\n";
  790.  
  791.     return $tarprefix;
  792. }
  793.  
  794. sub tarparse {
  795.  
  796.   my $fn;
  797.   ($fn, $_) = @_;
  798.   
  799.   if (! m;^(\S{10}) (\w{1,8})/(\w{1,8}) +(\d+) (\d{4}-\d{2}-\d{2}) (\d{2}:\d{2}) (.+)$;) {
  800.     &error ("tarfile \`$fn' contains unknown object"
  801.        . " listed by tar as \`$_'");
  802.   }
  803.   my ($mode, $uid, $gid, $size, $date, $time, $name) = 
  804.     ($1, $2, $3, $4, $5, $6, $7);
  805.   
  806.   $mode =~ s/^([-dpsl])// ||
  807.     &error ("tarfile \`$fn' contains object \`$_' with ".
  808.         "unknown or forbidden type \`" . substr ($mode, 0, 1) . "'");
  809.   my $type = $&;
  810.   
  811.   if ($type eq "l") { 
  812.     $name =~ s/ -\> .*//;
  813.   }
  814.   $name =~ s/ link to .+//;
  815.   
  816.   $name = deoctify ($name);
  817.   if ($type eq "d") {
  818.     $name =~ s,([^/])$,$1/,;
  819.   }
  820.  
  821.   return ($type, $mode, $uid, $gid, $size, $date, $time, $name);
  822. }
  823.  
  824. sub checktarsane {
  825.  
  826.     my ($tarfileread, $wpfx) = @_;
  827.     my ($c2);
  828.  
  829.     %dirincluded = ();
  830.     %notfileobject = ();
  831.  
  832.     my $tarprefix = &checktarcpio ($tarfileread, $wpfx);
  833.  
  834.     # make <TAR> read from the uncompressed archive file
  835.     &forkgzipread ("$tarfileread");
  836.     if (! defined ($c2 = open (TAR,"-|"))) { &syserr ("fork for tar -t"); }
  837.     if (! $c2) {
  838.         $ENV{'LANG'}= 'C';
  839.         open (STDIN, "<&GZIP") || &syserr ("reopen gzip for tar -t");
  840.         exec ('tar', '-vvtf', '-'); &syserr ("exec tar -vvtf -");
  841.     }
  842.     close (GZIP);
  843.  
  844.     my $efix = 0;
  845.     while (<TAR>) {
  846.  
  847.         chomp;
  848.  
  849.     my ($type, $mode, $uid, $gid, $size, $date, $time, $tarfn) 
  850.       = &tarparse ($tarfileread, $_);
  851.     
  852.     my $ptarfn = $tarfn;
  853.     $ptarfn =~ y/ -~/?/c;
  854.  
  855.     # fetch name of file as given by cpio
  856.         my $cpiofn = $filesinarchive[$efix++];
  857.     my $pcpiofn = $cpiofn;
  858.     $pcpiofn =~ y/ -~/?/c;
  859.  
  860.     if ($cpiofn ne $tarfn) {
  861.         if ((length ($cpiofn) == 99) && (length ($tarfn) >= 99)
  862.         && (substr ($cpiofn, 0, 99) eq substr ($tarfn, 0, 99))) {
  863.         # this file doesn't match because cpio truncated the name
  864.         # to the first 100 characters.  let it slide for now.
  865.         &warn ("filename \`$pcpiofn' was truncated by cpio;" .
  866.                " unable to check full pathname");
  867.         } else {
  868.         &error ("tarfile \`$tarfileread' contains unexpected object".
  869.             " listed by tar as \`$ptarfn'; expected \`$pcpiofn'");
  870.         }
  871.     }
  872.  
  873.     # if cpio truncated the name above, 
  874.     # we still can't allow files to expand into /../
  875.     # need to check for multiple dots on some operating systems
  876.      
  877.     if ($tarfn =~ m/[.]{2,}/) {
  878.             &error ("tarfile \`$tarfileread' contains object with".
  879.             "/../ in its name ($ptarfn)");
  880.     }
  881.  
  882.         if ($tarfn =~ /\.dpkg-orig$/) {
  883.             &error ("tarfile \`$tarfileread' contains file with name ending in .dpkg-orig \`$ptarfn'");
  884.     }
  885.  
  886.         if ($mode =~ /[sStT]/ && $type ne "d") {
  887.             &error ("tarfile \`$tarfileread' contains setuid, setgid".
  888.             " or sticky object \`$ptarfn'");
  889.     }
  890.  
  891.         if ($tarfn eq "$tarprefix/debian" && $type ne "d") {
  892.             &error ("tarfile \`$tarfileread' contains object \`debian'".
  893.                    " that isn't a directory");
  894.     }
  895.  
  896.         my $dirname = $tarfn;
  897.         if (($dirname =~ s,/[^/]+$,,) && (! defined ($dirincluded{$dirname}))) {
  898.             &error ("tarfile \`$tarfileread' contains object \`$ptarfn' but its containing ".
  899.             "directory \`$dirname' does not precede it");
  900.     }
  901.     
  902.     $tarfn =~ s,/$,,;
  903.     if ($type eq "d") { $dirincluded{$tarfn} = 1; }
  904.         if ($type ne "-") { $notfileobject{$tarfn} = 1; }
  905.     }
  906.     close (TAR);
  907.     $? && subprocerr ("tar -vvtf");
  908.     &reapgzip;
  909.  
  910.     return $tarprefix;
  911. }
  912.  
  913. no strict 'vars';
  914.  
  915. sub extracttar {
  916.     my ($tarfileread,$dirchdir,$newtopdir) = @_;
  917.     &forkgzipread("$tarfileread");
  918.     defined($c2= fork) || &syserr("fork for tar -xkf -");
  919.     if (!$c2) {
  920.         chdir("$dirchdir") || &syserr("cannot chdir to \`$dirchdir' for tar extract");
  921.         open(STDIN,"<&GZIP") || &syserr("reopen gzip for cpio -i");
  922.     open(STDERR,"| egrep -v '^[0-9]+ blocks\$' >&2") ||
  923.         &syserr("reopen stderr for cpio to grep out blocks message");
  924.         exec ('tar','-xkf','-'); &syserr("exec tar -xkf -");
  925.     }
  926.     close(GZIP);
  927.     $c2 == waitpid($c2,0) || &syserr("wait for tar -xkf -");
  928.     $? && subprocerr("tar -xkf -");
  929.     &reapgzip;
  930.  
  931.     opendir(D,"$dirchdir") || &syserr("Unable to open dir $dirchdir");
  932.     @dirchdirfiles = grep($_ ne "." && $_ ne "..",readdir(D));
  933.     closedir(D) || &syserr("Unable to close dir $dirchdir");
  934.     (@dirchdirfiles==1 && -d "$dirchdir/$dirchdirfiles[0]") ||
  935.     &error("$tarfileread extracted into >1 directory");
  936.     rename("$dirchdir/$dirchdirfiles[0]", "$dirchdir/$newtopdir") ||
  937.     &syserr("Unable to rename $dirchdir/$dirchdirfiles[0] to ".
  938.         "$dirchdir/$newtopdir");
  939. }
  940.  
  941. sub setfile {
  942.     my ($varref) = @_;
  943.     if (defined ($$varref)) { 
  944.     &error ("repeated file type - files " . $$varref . " and $file"); 
  945.     }
  946.     $$varref = $file;
  947. }
  948.  
  949. sub checktype {
  950.     if (!lstat("$origdir/$fn")) {
  951.         &unrepdiff2("nonexistent",$type{$fn});
  952.     } else {
  953.         $v= eval("$_[0] _ ? 2 : 1"); $v || &internerr("checktype $@ ($_[0])");
  954.         return 1 if $v == 2;
  955.         &unrepdiff2("something else",$type{$fn});
  956.     }
  957.     return 0;
  958. }
  959.  
  960. sub setopmode {
  961.     defined($opmode) && &usageerr("only one of -x or -b allowed, and only once");
  962.     $opmode= $_[0];
  963. }
  964.  
  965. sub unrepdiff {
  966.     print(STDERR "$progname: cannot represent change to $fn: $_[0]\n")
  967.         || &syserr("write syserr unrep");
  968.     $ur++;
  969. }
  970.  
  971. sub unrepdiff2 {
  972.     print(STDERR "$progname: cannot represent change to $fn:\n".
  973.           "$progname:  new version is $_[1]\n".
  974.           "$progname:  old version is $_[0]\n")
  975.         || &syserr("write syserr unrep");
  976.     $ur++;
  977. }
  978.  
  979. sub forkgzipwrite {
  980.     open (GZIPFILE, "> $_[0]") || &syserr ("create file $_[0]");
  981.     pipe (GZIPREAD, GZIP) || &syserr ("pipe for gzip");
  982.     defined ($cgz = fork ()) || &syserr ("fork for gzip");
  983.     if ($cgz == 0) {
  984.         open (STDIN, "<&GZIPREAD") || &syserr ("reopen gzip pipe"); 
  985.     close (GZIPREAD);
  986.         close (GZIP); 
  987.     open (STDOUT, ">&GZIPFILE") || &syserr ("reopen tar.gz");
  988.         exec ('gzip', '-9');
  989.     &syserr ("exec gzip");
  990.     }
  991.     close (GZIPREAD);
  992.     $gzipsigpipeok = 0;
  993. }
  994.  
  995. sub forkgzipread {
  996.     open (GZIPFILE, "< $_[0]") || &syserr ("read file $_[0]");
  997.     pipe (GZIP, GZIPWRITE) || &syserr ("pipe for gunzip");
  998.     defined ($cgz = fork ()) || &syserr ("fork for gunzip");
  999.     if ($cgz == 0) {
  1000.         open (STDOUT, ">&GZIPWRITE") || &syserr ("reopen gunzip pipe"); 
  1001.     close (GZIPWRITE);
  1002.         close (GZIP); 
  1003.     open (STDIN, "<&GZIPFILE") || &syserr ("reopen input file");
  1004.         exec ("gunzip"); 
  1005.     &syserr ("exec gunzip");
  1006.     }
  1007.     close (GZIPWRITE);
  1008.     $gzipsigpipeok = 1;
  1009. }
  1010.  
  1011. sub reapgzip {
  1012.     $cgz == waitpid ($cgz, 0);
  1013.     if (! $cgz) { &syserr ("wait for gzip"); }
  1014.     if ($? 
  1015.     && !($gzipsigpipeok 
  1016.          && WIFSIGNALED ($?) 
  1017.          && (WTERMSIG ($?) == SIGPIPE))) {
  1018.         subprocerr ("gzip");
  1019.     }
  1020.     close (GZIPFILE);
  1021. }
  1022.  
  1023. sub addfile {
  1024.     my ($filename)= @_;
  1025.     stat($filename) || &syserr("could not stat output file \`$filename'");
  1026.     $size= (stat _)[7];
  1027.     my $md5sum= `md5sum <$filename`;
  1028.     $? && &subprocerr("md5sum $filename");
  1029.     $md5sum =~ s/^([0-9a-f]{32})( +-)?$/$1/ || &failure("md5sum gave bogus output \`$_'");
  1030.     $f{'Files'}.= "\n $md5sum $size $filename";
  1031. }
  1032.  
  1033. # replace \ddd with their corresponding character, refuse \ddd > \377
  1034. # modifies $_ (hs)
  1035. {
  1036.     my $backslash;
  1037. sub deoctify {
  1038.     my $fn= $_[0];
  1039.     $backslash= sprintf("\\%03o", unpack("C", "\\")) if !$backslash;
  1040.  
  1041.     s/\\{2}/$backslash/g;
  1042.     @_= split(/\\/, $fn);
  1043.  
  1044.     foreach (@_) {
  1045.         /^(\d{3})/ or next;
  1046.         &failure("bogus character `\\$1' in `$fn'\n") if oct($1) > 255;
  1047.         $_= pack("c", oct($1)) . $';
  1048.     }
  1049.     return join("", @_);
  1050. } }
  1051.  
  1052.