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