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