uupacktool.pl

   1 #!perl
   2
   3 use strict;
   4 use warnings;
   5 use Getopt::Long;
   6 use File::Basename;
   7
   8 our $LastUpdate = -M $0;
   9
  10 sub handle_file {
  11     my $opts    = shift;
  12     my $file    = shift or die "Need file\n". usage();
  13     my $outfile = shift || '';
  14     my $mode    = (stat($file))[2] & 07777;
  15
  16     open my $fh, "<", $file
  17         or die "Could not open input file $file: $!";
  18     binmode $fh;
  19     my $str = do { local $/; <$fh> };
  20
  21     ### unpack?
  22     my $outstr;
  23     if( $opts->{u} ) {
  24         if( !$outfile ) {
  25             $outfile = $file;
  26             $outfile =~ s/\.packed//;
  27         }
  28         my ($head, $body) = split /__UU__\n/, $str;
  29         die "Can't unpack malformed data in '$file'\n"
  30             if !$head or !$body;
  31         $outstr = unpack 'u', $body;
  32
  33     } else {
  34         $outfile ||= $file . '.packed';
  35
  36         my $me = basename($0);
  37
  38         $outstr = <<"EOFBLURB" . pack 'u', $str;
  39 #########################################################################
  40 This is a binary file that was packed with the 'uupacktool.pl' which
  41 is included in the Perl distribution.
  42
  43 To unpack this file use the following command:
  44
  45      $me -u $outfile $file
  46
  47 To recreate it use the following command:
  48
  49      $me -p $file $outfile
  50
  51 Created at @{[scalar localtime]}
  52 #########################################################################
  53 __UU__
  54 EOFBLURB
  55     }
  56
  57     ### output the file
  58     if( $opts->{'s'} ) {
  59         print STDOUT $outstr;
  60     } else {
  61         print "Writing $file into $outfile\n" if $opts->{'v'};
  62         open my $outfh, ">", $outfile
  63             or die "Could not open $outfile for writing: $!";
  64         binmode $outfh;
  65         print $outfh $outstr;
  66         close $outfh;
  67
  68         chmod $mode, $outfile;
  69     }
  70
  71     ### delete source file?
  72     if( $opts->{'D'} and $file ne $outfile ) {
  73         1 while unlink $file;
  74     }
  75 }
  76
  77 sub bulk_process {
  78     my $opts = shift;
  79     my $Manifest = $opts->{'m'};
  80
  81     open my $fh, "<", $Manifest or die "Could not open '$Manifest':$!";
  82
  83     print "Reading $Manifest\n"
  84             if $opts->{'v'};
  85
  86     my $count = 0;
  87     my $lines = 0;
  88     while( my $line = <$fh> ) {
  89         chomp $line;
  90         my ($file) = split /\s+/, $line;
  91
  92         $lines++;
  93
  94         next unless $file =~ /\.packed/;
  95
  96         $count++;
  97
  98         my $out = $file;
  99         $out =~ s/\.packed//;
 100
 101         ### unpack
 102         if( !$opts->{'c'} ) {
 103             ( $out, $file ) = ( $file, $out ) if $opts->{'p'};
 104             if (-e $out) {
 105                 my $changed = -M _;
 106                 if ($changed < $LastUpdate and $changed < -M $file) {
 107                     print "Skipping '$file' as '$out' is up-to-date.\n"
 108                         if $opts->{'v'};
 109                     next;
 110                 }
 111             }
 112             handle_file($opts, $file, $out);
 113             print "Converted '$file' to '$out'\n"
 114                 if $opts->{'v'};
 115
 116         ### clean up
 117         } else {
 118
 119             ### file exists?
 120             unless( -e $out ) {
 121                 print "File '$file' was not unpacked into '$out'. Can not remove.\n";
 122
 123             ### remove it
 124             } else {
 125                 print "Removing '$out'\n";
 126                 1 while unlink $out;
 127             }
 128         }
 129     }
 130     print "Found $count files to process out of $lines in '$Manifest'\n"
 131             if $opts->{'v'};
 132 }
 133
 134 sub usage {
 135     return qq[
 136 Usage: $^X $0 [-d dir] [-v] [-c] [-D] -p|-u [orig [packed|-s] | -m [manifest]]
 137
 138     Handle binary files in source tree. Can be used to pack or
 139     unpack files individiually or as specified by a manifest file.
 140
 141 Options:
 142     -u  Unpack files (defaults to -u unless -p is specified)
 143     -p  Pack files
 144     -c  Clean up all unpacked files. Implies -m
 145
 146     -D  Delete source file after encoding/decoding
 147
 148     -s  Output to STDOUT rather than OUTPUT_FILE
 149     -m  Use manifest file, if none is explicitly provided defaults to 'MANIFEST'
 150
 151     -d  Change directory to dir before processing
 152
 153     -v  Run verbosely
 154     -h  Display this help message
 155 ];
 156 }
 157
 158 my $opts = {};
 159 GetOptions($opts,'u','p','c','m:s','s','d=s','v','h');
 160
 161 die "Can't pack and unpack at the same time!\n", usage()
 162     if $opts->{'u'} && $opts->{'p'};
 163 die usage() if $opts->{'h'};
 164
 165 if ( $opts->{'d'} ) {
 166     chdir $opts->{'d'}
 167         or die "Failed to chdir to '$opts->{'d'}':$!";
 168 }
 169 $opts->{'u'} = 1 if !$opts->{'p'};
 170 binmode STDOUT if $opts->{'s'};
 171 if ( exists $opts->{'m'} or exists $opts->{'c'} ) {
 172     $opts->{'m'} ||= "MANIFEST";
 173     bulk_process($opts);
 174     exit(0);
 175 } else {
 176     if (@ARGV) {
 177         handle_file($opts, @ARGV);
 178     } else {
 179         die "No file to process specified!\n", usage();
 180     }
 181     exit(0);
 182 }
 183
 184
 185 die usage();