(?p{}) has been deprecated for a long time.
[p5sagit/p5-mst-13.2.git] / uupacktool.pl
CommitLineData
1266ad8f 1#!perl
2
3use strict;
4use warnings;
5use Getopt::Long;
6use File::Basename;
7
404c6892 8Getopt::Long::Configure('no_ignore_case');
9
1266ad8f 10our $LastUpdate = -M $0;
11
12sub 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 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#########################################################################
42This is a binary file that was packed with the 'uupacktool.pl' which
43is included in the Perl distribution.
44
45To unpack this file use the following command:
46
47 $me -u $outfile $file
48
49To recreate it use the following command:
50
51 $me -p $file $outfile
52
53Created at @{[scalar localtime]}
54#########################################################################
55__UU__
56EOFBLURB
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 67 ### $outstr might be empty, if the file was empty
68 print $outfh $outstr if $outstr;
1266ad8f 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
80sub 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
137sub usage {
138 return qq[
139Usage: $^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
144Options:
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
161my $opts = {};
404c6892 162GetOptions($opts,'u','p','c', 'D', 'm:s','s','d=s','v','h');
1266ad8f 163
164die "Can't pack and unpack at the same time!\n", usage()
165 if $opts->{'u'} && $opts->{'p'};
166die usage() if $opts->{'h'};
167
168if ( $opts->{'d'} ) {
169 chdir $opts->{'d'}
170 or die "Failed to chdir to '$opts->{'d'}':$!";
171}
172$opts->{'u'} = 1 if !$opts->{'p'};
173binmode STDOUT if $opts->{'s'};
174if ( 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
188die usage();