'map' over the files in a zipfile

[Kragen Sitaker]

Given a zipfile, this produces another zipfile with contents
homeomorphic to the original, but with each file filtered through a
specified Unix filter command.

A security note --- this doesn't check the names in the zipfile; until
recently, neither did the Info-ZIP 'zip' command, which it uses, and
so unzipping a zipfile containing files named '../../../tmp/foo' will
put those files (probably) in /tmp.

#!/usr/bin/perl -w
use strict;
# usage: zfrun.pl script zipfilename dirname filenamesuffix outzipfilename
# extracts 'zipfilename' in a temporary dir.  runs 'script' with input
# from each file that came out of it, with output going to a file in
# a corresponding place in another dir 'dirname' whose filename is based
# on the original filename by appending 'filenamesuffix' to the original
# file, before the extension, if any.  'dirname' is then packed into
# 'outzipfilename' and deleted, along with the temporary dir.

sub dup_dir_structure {
  my ($outdir, @names) = @_;
  my %dirs = ();
  local $_;
 name: for my $x (@names) {
    $_ = $x;
    while ($_) {
      s|/?[^/]*$||;             # strip off trailing path component
      $dirs{$_} = 1 if $_ ne '';
    }
  }
  my @dirs = sort {length($a) <=> length($b)} keys %dirs;
  mkdir $outdir, 0777;
  for my $dir (@dirs) {
    die "directory name contains dots: '$dir'" if $dir =~ /\./;
    mkdir "$outdir/$dir", 0777;
  }
}
# dup_dir_structure "/tmp/crapola", "ax/bax/cax", "dax/eek", "ax/c/e", "f";

sub filename_map {
  my ($outdir, $filenamesuffix, $filename) = @_;
  $filename =~ s|(\.[^./]*)$|$filenamesuffix$1| # if it has an extension
    or $filename .= $filenamesuffix; # otherwise
  return "$outdir/$filename";
}
#my @x = map { filename_map"/tmp/crapola", "-corr", $_ }
#  ("ax/bax/cax", "ax/bax/cax.txt", "ax.bax/cax.dax/fax.c.gz");
#print "@x\n";

# return a newly created temp dir
{
  my $id = 0;
  sub get_temp_dir {
    my $name = "/tmp/$$.$id";
    $id++;
    mkdir $name, 0700 or die "mkdir $name failed: $!";
    return $name;
  }
}
;

# extract a zip file into a temporary directory and return its name
sub extract {
  my ($zipfile) = @_;
  my $dir = get_temp_dir;
  chdir $dir or die "Couldn't chdir $dir: $!";
  system "unzip", '-qq', $zipfile and die "unzip failed";  
  return $dir;
}

# list the relative paths to files under a directory
sub filelist {
  my ($dir) = @_;
  chdir $dir or die "Couldn't chdir $dir: $!";
  open FIND, "find -type f -print0|" or die "Can't fork: $!";
  my $files = do { local $/; <FIND> };
  close FIND or die "find failed";
  my @files = grep { $_ ne '.' } split /\0/, $files;
  for my $file (@files) {
    $file =~ s|\A\.\/|| or die "$file doesn't start with ./";
  }
  return @files;
}

# given a dirname, create a temporary directory and make subdirs in it
# return the name of the temporary directory
sub create_skeleton {
  my ($dirname, @files) = @_;
  my $tempdir = get_temp_dir;
  my $outdir = "$tempdir/$dirname";
  mkdir $outdir, 0777 or die "Can't mkdir $outdir: $!";
  dup_dir_structure $outdir, @files;
  return $tempdir;
}

# given a script, an indir, an outdir, a filename suffix, and a list
# of file relative paths under the indir, run the script for each file
# and put the results in the appropriate places in the outdir
sub process_files {
  my ($script, $indir, $outdir, $filenamesuffix, @files) = @_;
  for my $file (@files) {
    my $outfile = filename_map $outdir, $filenamesuffix, $file;
    my $pid = fork;
    die "fork failed: $!" if not defined $pid;
    if (not $pid) {
      # child
      close STDIN;
      close STDOUT;
      open STDIN, "< $indir/$file" or die "Can't open $indir/$file: $!";
      open STDOUT, "> $outfile" or die "Can't open $outfile: $!";
      exec $script;
    } else {
      # parent
      wait;
      die "Child process failed ($?)" if $?;
    }
  }
}

# given a directory, make a zipfile of everything beneath it under
# a given name
sub pack_zip {
  my ($indir, $subdirname, $zipfile) = @_;
  chdir $indir or die "Couldn't chdir $indir: $!";
  die "zip failed" if system "zip", "-qr", $zipfile, $subdirname;
}

# delete everything under some possibly-maliciously-named directories
sub cleanup_dirs {
  system 'rm', '-rf', @_;
}

sub main {
  my ($script, $zipfilename, $dirname, $filenamesuffix, $outzip) = @_;
  die "wrong args" if @_ != 5;
  my $tmpdir = extract $zipfilename;
  my @files = filelist $tmpdir;
  my $tmpoutdir = create_skeleton $dirname, @files;
  process_files $script, $tmpdir, "$tmpoutdir/$dirname", $filenamesuffix, @files;
  pack_zip $tmpoutdir, $dirname, $outzip;
  cleanup_dirs $tmpdir, $tmpoutdir;
}

main @ARGV;


-- 
/* By Kragen Sitaker, http://pobox.com/~kragen/puzzle2.html */
char a[99]="  KJ",d[999][16];main(){int s=socket(2,1,0),n=0,z,l,i;*(short*)a=2;
if(!bind(s,a,16))for(;;){z=16;if((l=recvfrom(s,a,99,0,d[n],&z))>0){for(i=0;i<n;
i++){z=(memcmp(d[i],d[n],8))?z:0;while(sendto(s,a,l,0,d[i],16)&0);}z?n++:0;}}}