| 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(); |