Re: Perl 5.10.0 getting close: please test

[perl5.git] / uupacktool.pl

diff --git a/uupacktool.pl b/uupacktool.pl
index 5656cef..bf947bb 100644 (file)
--- a/uupacktool.pl
+++ b/uupacktool.pl
@@ -4,6 +4,16 @@ use strict;
 use warnings;
 use Getopt::Long;
 use File::Basename;
+use File::Spec;
+
+BEGIN {
+    if ($^O eq 'VMS') {
+        require VMS::Filespec;
+        import VMS::Filespec;
+    }
+}
+
+Getopt::Long::Configure('no_ignore_case');
 
 our $LastUpdate = -M $0;
 
@@ -11,10 +21,11 @@ sub handle_file {
     my $opts    = shift;
     my $file    = shift or die "Need file\n". usage();
     my $outfile = shift || '';
+    $file = vms_check_name($file) if $^O eq 'VMS';
     my $mode    = (stat($file))[2] & 07777;
 
     open my $fh, "<", $file
-        or die "Could not open input file $file: $!";
+        or do { warn "Could not open input file $file: $!"; exit 0 };
     binmode $fh;
     my $str = do { local $/; <$fh> };
 
@@ -23,11 +34,11 @@ sub handle_file {
     if( $opts->{u} ) {
         if( !$outfile ) {
             $outfile = $file;
-            $outfile =~ s/\.packed//;
+            $outfile =~ s/\.packed\z//;
         }
         my ($head, $body) = split /__UU__\n/, $str;
         die "Can't unpack malformed data in '$file'\n"
-            if !$head or !$body;
+            if !$head;
         $outstr = unpack 'u', $body;
 
     } else {
@@ -58,11 +69,13 @@ EOFBLURB
     if( $opts->{'s'} ) {
         print STDOUT $outstr;
     } else {
+        $outfile = VMS::Filespec::vmsify($outfile) if $^O eq 'VMS';
         print "Writing $file into $outfile\n" if $opts->{'v'};
         open my $outfh, ">", $outfile
-            or die "Could not open $outfile for writing: $!";
+            or do { warn "Could not open $outfile for writing: $!"; exit 0 };
         binmode $outfh;
-        print $outfh $outstr;
+        ### $outstr might be empty, if the file was empty
+        print $outfh $outstr if $outstr;
         close $outfh;
 
         chmod $mode, $outfile;
@@ -96,7 +109,8 @@ sub bulk_process {
         $count++;
 
         my $out = $file;
-        $out =~ s/\.packed//;
+        $out =~ s/\.packed\z//;
+        $out = vms_check_name($out) if $^O eq 'VMS';
 
         ### unpack
         if( !$opts->{'c'} ) {
@@ -155,8 +169,35 @@ Options:
 ];
 }
 
+sub vms_check_name {
+
+# Packed files tend to have multiple dots, which the CRTL may or may not handle
+# properly, so convert to native format.  And depending on how the archive was
+# unpacked, foo.bar.baz may be foo_bar.baz or foo.bar_baz.  N.B. This checks for
+# existence, so is not suitable as-is to generate ODS-2-safe names in preparation
+# for file creation.
+
+    my $file = shift;
+
+    $file = VMS::Filespec::vmsify($file);
+    return $file if -e $file;
+
+    my ($vol,$dirs,$base) = File::Spec->splitpath($file);
+    my $tmp = $base;
+    1 while $tmp =~ s/([^\.]+)\.(.+\..+)/$1_$2/;
+    my $try = File::Spec->catpath($vol, $dirs, $tmp);
+    return $try if -e $try;
+
+    $tmp = $base;
+    1 while $tmp =~ s/(.+\..+)\.([^\.]+)/$1_$2/;
+    $try = File::Spec->catpath($vol, $dirs, $tmp);
+    return $try if -e $try;
+
+    return $file;
+}
+
 my $opts = {};
-GetOptions($opts,'u','p','c','m:s','s','d=s','v','h');
+GetOptions($opts,'u','p','c', 'D', 'm:s','s','d=s','v','h');
 
 die "Can't pack and unpack at the same time!\n", usage()
     if $opts->{'u'} && $opts->{'p'};