Commit | Line | Data |
---|---|---|
1266ad8f YO |
1 | #!perl |
2 | ||
3 | use strict; | |
4 | use warnings; | |
5 | use Getopt::Long; | |
6 | use File::Basename; | |
6f21b45f CB |
7 | use File::Spec; |
8 | ||
9 | BEGIN { | |
10 | if ($^O eq 'VMS') { | |
11 | require VMS::Filespec; | |
12 | import VMS::Filespec; | |
13 | } | |
14 | } | |
1266ad8f | 15 | |
404c6892 JB |
16 | Getopt::Long::Configure('no_ignore_case'); |
17 | ||
1266ad8f YO |
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 || ''; | |
6f21b45f | 24 | $file = vms_check_name($file) if $^O eq 'VMS'; |
1266ad8f YO |
25 | my $mode = (stat($file))[2] & 07777; |
26 | ||
27 | open my $fh, "<", $file | |
3ab4a224 | 28 | or do { warn "Could not open input file $file: $!"; exit 0 }; |
1266ad8f YO |
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; | |
6f21b45f | 37 | $outfile =~ s/\.packed\z//; |
1266ad8f YO |
38 | } |
39 | my ($head, $body) = split /__UU__\n/, $str; | |
40 | die "Can't unpack malformed data in '$file'\n" | |
404c6892 | 41 | if !$head; |
1266ad8f YO |
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 { | |
6f21b45f | 72 | $outfile = VMS::Filespec::vmsify($outfile) if $^O eq 'VMS'; |
1266ad8f YO |
73 | print "Writing $file into $outfile\n" if $opts->{'v'}; |
74 | open my $outfh, ">", $outfile | |
3ab4a224 | 75 | or do { warn "Could not open $outfile for writing: $!"; exit 0 }; |
1266ad8f | 76 | binmode $outfh; |
404c6892 JB |
77 | ### $outstr might be empty, if the file was empty |
78 | print $outfh $outstr if $outstr; | |
1266ad8f YO |
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; | |
6f21b45f CB |
112 | $out =~ s/\.packed\z//; |
113 | $out = vms_check_name($out) if $^O eq 'VMS'; | |
1266ad8f YO |
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 | ||
6f21b45f CB |
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 | ||
1266ad8f | 199 | my $opts = {}; |
404c6892 | 200 | GetOptions($opts,'u','p','c', 'D', 'm:s','s','d=s','v','h'); |
1266ad8f YO |
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(); |