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