From: Craig A. Berry <craigberry@mac.com>
Date: Mon, 21 May 2007 04:33:27 +0000 (+0000)
Subject: VMSify uupacktool.pl and run it during VMS build.
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=6f21b45f63d7a8aa1cbaa86a63e83a3078c61492;p=p5sagit%2Fp5-mst-13.2.git

VMSify uupacktool.pl and run it during VMS build.

p4raw-id: //depot/perl@31247
---

diff --git a/uupacktool.pl b/uupacktool.pl
index 20554d7..bf947bb 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,6 +21,7 @@ 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
@@ -25,7 +34,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 +69,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 +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'} ) {
@@ -158,6 +169,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');
 
diff --git a/vms/descrip_mms.template b/vms/descrip_mms.template
index 8894c13..2b66a74 100644
--- a/vms/descrip_mms.template
+++ b/vms/descrip_mms.template
@@ -1399,10 +1399,16 @@ perly$(O) : perly.c, perly.h, $(h)
 [.t.lib]vms_stdio.t : [.vms.ext.Stdio]test.pl
 	Copy/NoConfirm/Log $(MMS$SOURCE) $(MMS$TARGET)
 
+unpack_files :
+	- $(MINIPERL) uupacktool.pl -u -m
+
+cleanup_unpacked_files :
+	- IF F$SEARCH("$(MINIPERL_EXE)") .NES. "" THEN $(MINIPERL) uupacktool.pl -c
+
 check : test
 	@ Continue
 
-test : all [.t.lib]vmsfspec.t [.t.lib]vms_dclsym.t [.t.lib]vms_stdio.t
+test : all [.t.lib]vmsfspec.t [.t.lib]vms_dclsym.t [.t.lib]vms_stdio.t unpack_files
 	@ PERL_TEST_DRIVER == "TEST."
 	- @[.vms]test.com "$(E)" "$(__DEBUG__)"
 	@ $(MINIPERL) -e "print ""Ran tests"";" > [.t]rantests.
@@ -1785,7 +1791,7 @@ tidy : cleanlis
 	- If F$Search("[.x2p]*.com;-1").nes."" Then Purge/NoConfirm/Log [.x2p]*.com
 	- If F$Search("[.lib.pods]*.com;-1").nes."" Then Purge/NoConfirm/Log [.lib.pods]*.com
 
-clean : tidy cleantest
+clean : tidy cleantest cleanup_unpacked_files
 	- @make_ext "$(MINIPERL_EXE)" "$(MMS)" clean
 	- If F$Search("*.Opt").nes."" Then Delete/NoConfirm/Log *.Opt;*/Exclude=PerlShr_*.Opt
 	- If F$Search("[...]*$(O);*") .nes."" Then Delete/NoConfirm/Log [...]*$(O);*