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 | my $str = do { local $/; <$fh> }; |
30 | ||
31 | ### unpack? | |
32 | my $outstr; | |
33 | if( $opts->{u} ) { | |
34 | if( !$outfile ) { | |
35 | $outfile = $file; | |
6f21b45f | 36 | $outfile =~ s/\.packed\z//; |
1266ad8f YO |
37 | } |
38 | my ($head, $body) = split /__UU__\n/, $str; | |
39 | die "Can't unpack malformed data in '$file'\n" | |
404c6892 | 40 | if !$head; |
1266ad8f YO |
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 | ######################################################################### | |
50 | This is a binary file that was packed with the 'uupacktool.pl' which | |
51 | is included in the Perl distribution. | |
52 | ||
53 | To unpack this file use the following command: | |
54 | ||
55 | $me -u $outfile $file | |
56 | ||
57 | To recreate it use the following command: | |
58 | ||
59 | $me -p $file $outfile | |
60 | ||
61 | Created at @{[scalar localtime]} | |
62 | ######################################################################### | |
63 | __UU__ | |
64 | EOFBLURB | |
65 | } | |
66 | ||
67 | ### output the file | |
68 | if( $opts->{'s'} ) { | |
69 | print STDOUT $outstr; | |
70 | } else { | |
6f21b45f | 71 | $outfile = VMS::Filespec::vmsify($outfile) if $^O eq 'VMS'; |
1266ad8f YO |
72 | print "Writing $file into $outfile\n" if $opts->{'v'}; |
73 | open my $outfh, ">", $outfile | |
3ab4a224 | 74 | or do { warn "Could not open $outfile for writing: $!"; exit 0 }; |
1266ad8f | 75 | binmode $outfh; |
404c6892 JB |
76 | ### $outstr might be empty, if the file was empty |
77 | print $outfh $outstr if $outstr; | |
1266ad8f YO |
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 | ||
89 | sub 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; | |
6f21b45f CB |
111 | $out =~ s/\.packed\z//; |
112 | $out = vms_check_name($out) if $^O eq 'VMS'; | |
1266ad8f YO |
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 | ||
147 | sub usage { | |
148 | return qq[ | |
149 | Usage: $^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 | ||
154 | Options: | |
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 | ||
6f21b45f CB |
171 | sub 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 | ||
1266ad8f | 198 | my $opts = {}; |
404c6892 | 199 | GetOptions($opts,'u','p','c', 'D', 'm:s','s','d=s','v','h'); |
1266ad8f YO |
200 | |
201 | die "Can't pack and unpack at the same time!\n", usage() | |
202 | if $opts->{'u'} && $opts->{'p'}; | |
203 | die usage() if $opts->{'h'}; | |
204 | ||
205 | if ( $opts->{'d'} ) { | |
206 | chdir $opts->{'d'} | |
207 | or die "Failed to chdir to '$opts->{'d'}':$!"; | |
208 | } | |
209 | $opts->{'u'} = 1 if !$opts->{'p'}; | |
210 | binmode STDOUT if $opts->{'s'}; | |
211 | if ( 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 | ||
225 | die usage(); |