uupacktool.pl

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