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;
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: $!";
- binmode $fh;
+ or do { warn "Could not open input file $file: $!"; exit 0 };
my $str = do { local $/; <$fh> };
### unpack?
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 {
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;
$count++;
my $out = $file;
- $out =~ s/\.packed//;
+ $out =~ s/\.packed\z//;
+ $out = vms_check_name($out) if $^O eq 'VMS';
### unpack
if( !$opts->{'c'} ) {
];
}
+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'};