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