X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=uupacktool.pl;h=bb4dc0092f2d8305854a05e6f20a43257ae86ba3;hb=458b44e7bc48569051e0eb9b5630ba87d7e5eed4;hp=20554d721dbc7f1d34feb94807dc04006d027ec0;hpb=3ab4a224eb8d34c041977288575d251ee18f009f;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/uupacktool.pl b/uupacktool.pl
index 20554d7..bb4dc00 100644
--- a/uupacktool.pl
+++ b/uupacktool.pl
@@ -4,6 +4,14 @@ 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');
 
@@ -13,11 +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 do { warn "Could not open input file $file: $!"; exit 0 };
-    binmode $fh;
     my $str = do { local $/; <$fh> };
 
     ### unpack?
@@ -25,7 +33,7 @@ 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"
@@ -60,6 +68,7 @@ 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 do { warn "Could not open $outfile for writing: $!"; exit 0 };
@@ -99,7 +108,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'} ) {
@@ -158,6 +168,33 @@ 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', 'D', 'm:s','s','d=s','v','h');