Commit | Line | Data |
---|---|---|
1266ad8f YO |
1 | #!perl |
2 | ||
3 | use strict; | |
4 | use warnings; | |
5 | use Getopt::Long; | |
6 | use File::Basename; | |
7 | ||
404c6892 JB |
8 | Getopt::Long::Configure('no_ignore_case'); |
9 | ||
1266ad8f YO |
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" | |
404c6892 | 32 | if !$head; |
1266ad8f YO |
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; | |
404c6892 JB |
67 | ### $outstr might be empty, if the file was empty |
68 | print $outfh $outstr if $outstr; | |
1266ad8f YO |
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 = {}; | |
404c6892 | 162 | GetOptions($opts,'u','p','c', 'D', 'm:s','s','d=s','v','h'); |
1266ad8f YO |
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(); |