uupacktool.pl

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