scripts/dpkg-source.pl

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