diff options
Diffstat (limited to 'vms/ext/Filespec.pm')
| -rw-r--r-- | vms/ext/Filespec.pm | 323 |
1 files changed, 323 insertions, 0 deletions
diff --git a/vms/ext/Filespec.pm b/vms/ext/Filespec.pm new file mode 100644 index 0000000000..35c8365c4c --- /dev/null +++ b/vms/ext/Filespec.pm @@ -0,0 +1,323 @@ +# Perl hooks into the routines in vms.c for interconversion +# of VMS and Unix file specification syntax. +# +# Version: 1.1 +# Author: Charles Bailey bailey@genetics.upenn.edu +# Revised: 08-Mar-1995 + +=head1 NAME + +VMS::Filespec - convert between VMS and Unix file specification syntax + +=head1 SYNOPSIS + +use VMS::Filespec; +$vmsspec = vmsify('/my/Unix/file/specification'); +$unixspec = unixify('my:[VMS]file.specification'); +$path = pathify('my:[VMS.or.Unix.directory]specification.dir'); +$dirfile = fileify('my:[VMS.or.Unix.directory.specification]'); +$vmsdir = vmspath('my/VMS/or/Unix/directory/specification.dir'); +$unixdir = unixpath('my:[VMS.or.Unix.directory]specification.dir'); +candelete('my:[VMS.or.Unix]file.specification'); + +=head1 DESCRIPTION + +This package provides routines to simplify conversion between VMS and +Unix syntax when processing file specifications. This is useful when +porting scripts designed to run under either OS, and also allows you +to take advantage of conveniences provided by either syntax (e.g. +ability to easily concatenate Unix-style specifications). In +addition, it provides an additional file test routine, C<candelete>, +which determines whether you have delete access to a file. + +If you're running under VMS, the routines in this package are special, +in that they're automatically made available to any Perl script, +whether you're running F<miniperl> or the full F<perl>. The C<use +VMS::Filespec> or C<require VMS::Filespec; import VMS::Filespec ...> +statement can be used to import the function names into the current +package, but they're always available if you use the fully qualified +name, whether or not you've mentioned the F<.pm> file in your script. +If you're running under another OS and have installed this package, it +behaves like a normal Perl extension (in fact, you're using Perl +substitutes to emulate the necessary VMS system calls). + +Each of these routines accepts a file specification in either VMS or +Unix syntax, and returns the converted file specification, ir undef if +an error occurs. The conversions are, for the most part, simply +string manipulations; the routines do not check the details of syntax +(e.g. that only legal characters are used). There is one exception: +when running under VMS, conversions from VMS syntax use the $PARSE +service to expand specifications, so illegal syntax, or a relative +directory specification which extends above the tope of the current +directory path (e.g [---.foo] when in dev:[dir.sub]) will cause +errors. In general, any legal file specification will be converted +properly, but garbage input tends to produce garbage output. + +The routines provided are: + +=head2 vmsify + +Converts a file specification to VMS syntax. + +=head2 unixify + +Converts a file specification to Unix syntax. + +=head2 pathify + +Converts a directory specification to a path - that is, a string you +can prepend to a file name to form a valid file specification. If the +input file specification uses VMS syntax, the returned path does, too; +likewise for Unix syntax (Unix paths are guaranteed to end with '/'). + +=head2 fileify + +Converts a directory specification to the file specification of the +directory file - that is, a string you can pass to functions like +C<stat> or C<rmdir> to manipulate the directory file. If the +input directory specification uses VMS syntax, the returned file +specification does, too; likewise for Unix syntax. + +=head2 vmspath + +Acts like C<pathify>, but insures the returned path uses VMS syntax. + +=head2 unixpath + +Acts like C<pathify>, but insures the returned path uses Unix syntax. + +=head2 candelete + +Determines whether you have delete access to a file. If you do, C<candelete> +returns true. If you don't, or its argument isn't a legal file specification, +C<candelete> returns FALSE. Unlike other file tests, the argument to +C<candelete> must be a file name (not a FileHandle), and, since it's an XSUB, +it's a list operator, so you need to be careful about parentheses. Both of +these restrictions may be removed in the future if the functionality of +C<candelete> becomes part of the Perl core. + +=head1 REVISION + +This document was last revised 08-Mar-1995, for Perl 5.001. + +=cut + +package VMS::Filespec; + +# If you want to use this package on a non-VMS system, uncomment +# the following line, and add AutoLoader to @ISA. +# require AutoLoader; +require Exporter; + +@ISA = qw( Exporter ); +@EXPORT = qw( &rmsexpand &vmsify &unixify &pathify + &fileify &vmspath &unixpath &candelete); + +1; + + +__END__ + + +# The autosplit routines here are provided for use by non-VMS systems +# They are not guaranteed to function identically to the XSUBs of the +# same name, since they do not have access to the RMS system routine +# sys$parse() (in particular, no real provision is made for handling +# of complex DECnet node specifications). However, these routines +# should be adequate for most purposes. + +# A sort-of sys$parse() replacement +sub rmsexpand { + my($fspec,$defaults) = @_; + if (!$fspec) { return undef } + my($node,$dev,$dir,$name,$type,$ver,$dnode,$ddev,$ddir,$dname,$dtype,$dver); + + $fspec =~ s/:$//; + $defaults = [] unless $defaults; + $defaults = [ $defaults ] unless ref($defaults) && ref($defaults) eq 'ARRAY'; + + while ($fspec !~ m#[:>\]]# && $ENV{$fspec}) { $fspec = $ENV{$fspec} } + + if ($fspec =~ /:/) { + my($dev,$devtrn,$base); + ($dev,$base) = split(/:/,$fspec); + $devtrn = $dev; + while ($devtrn = $ENV{$devtrn}) { + if ($devtrn =~ /(.)([:>\]])$/) { + $dev .= ':', last if $1 eq '.'; + $dev = $devtrn, last; + } + } + $fspec = $dev . $base; + } + + ($node,$dev,$dir,$name,$type,$ver) = $fspec =~ + /([^:]*::)?([^:]*:)?([^>\]]*[>\]])?([^.;]*)(\.?[^.;]*)([.;]?\d*)/; + foreach ((@$defaults,$ENV{'DEFAULT'})) { + last if $node && $ver && $type && $dev && $dir && $name; + ($dnode,$ddev,$ddir,$dname,$dtype,$dver) = + /([^:]*::)?([^:]*:)?([^>\]]*[>\]])?([^.;]*)(\.?[^.;]*)([.;]?\d*)/; + $node = $dnode if $dnode && !$node; + $dev = $ddev if $ddev && !$dev; + $dir = $ddir if $ddir && !$dir; + $name = $dname if $dname && !$name; + $type = $dtype if $dtype && !$type; + $ver = $dver if $dver && !$ver; + } + # do this the long way to keep -w happy + $fspec = ''; + $fspec .= $node if $node; + $fspec .= $dev if $dev; + $fspec .= $dir if $dir; + $fspec .= $name if $name; + $fspec .= $type if $type; + $fspec .= $ver if $ver; + $fspec; +} + +sub vmsify { + my($fspec) = @_; + my($hasdev,$dev,$defdirs,$dir,$base,@dirs,@realdirs); + + if ($fspec =~ m#^\.(\.?)/?$#) { return $1 ? '[-]' : '[]'; } + return $fspec if $fspec !~ m#/#; + ($hasdev,$dir,$base) = $fspec =~ m#(/?)(.*)/(.*)#; + @dirs = split(m#/#,$dir); + if ($base eq '.') { $base = ''; } + elsif ($base eq '..') { + push @dirs,$base; + $base = ''; + } + foreach (@dirs) { + next unless $_; # protect against // in input + next if $_ eq '.'; + if ($_ eq '..') { + if (@realdirs && $realdirs[$#realdirs] ne '-') { pop @realdirs } + else { push @realdirs, '-' } + } + else { push @realdirs, $_; } + } + if ($hasdev) { + $dev = shift @realdirs; + @realdirs = ('000000') unless @realdirs; + $base = '' unless $base; # keep -w happy + $dev . ':[' . join('.',@realdirs) . "]$base"; + } + else { + '[' . join('',map($_ eq '-' ? $_ : ".$_",@realdirs)) . "]$base"; + } +} + +sub unixify { + my($fspec) = @_; + + return $fspec if $fspec !~ m#[:>\]]#; + return '.' if ($fspec eq '[]' || $fspec eq '<>'); + if ($fspec =~ m#^[<\[](\.|-+)(.*)# ) { + $fspec = ($1 eq '.' ? '' : "$1.") . $2; + my($dir,$base) = split(/[\]>]/,$fspec); + my(@dirs) = grep($_,split(m#\.#,$dir)); + if ($dirs[0] =~ /^-/) { + my($steps) = shift @dirs; + for (1..length($steps)) { unshift @dirs, '..'; } + } + join('/',@dirs) . "/$base"; + } + else { + $fspec = rmsexpand($fspec,'_N_O_T_:[_R_E_A_L_]'); + $fspec =~ s/.*_N_O_T_:(?:\[_R_E_A_L_\])?//; + my($dev,$dir,$base) = $fspec =~ m#([^:<\[]*):?[<\[](.*)[>\]](.*)#; + my(@dirs) = split(m#\.#,$dir); + if ($dirs[0] && $dirs[0] =~ /^-/) { + my($steps) = shift @dirs; + for (1..length($steps)) { unshift @dirs, '..'; } + } + "/$dev/" . join('/',@dirs) . "/$base"; + } +} + + +sub fileify { + my($path) = @_; + + if (!$path) { return undef } + if ($path =~ /(.+)\.([^:>\]]*)$/) { + $path = $1; + if ($2 !~ /^dir(?:;1)?$/i) { return undef } + } + + if ($path !~ m#[/>\]]#) { + $path =~ s/:$//; + while ($ENV{$path}) { + ($path = $ENV{$path}) =~ s/:$//; + last if $path =~ m#[/>\]]#; + } + } + if ($path =~ m#[>\]]#) { + my($dir,$sep,$base) = $path =~ /(.*)([>\]])(.*)/; + $sep =~ tr/<[/>]/; + if ($base) { + "$dir$sep$base.dir;1"; + } + else { + if ($dir !~ /\./) { $dir =~ s/([<\[])/${1}000000./; } + $dir =~ s#\.(\w+)$#$sep$1#; + $dir =~ s/^.$sep//; + "$dir.dir;1"; + } + } + else { + $path =~ s#/$##; + "$path.dir;1"; + } +} + +sub pathify { + my($fspec) = @_; + + if (!$fspec) { return undef } + if ($fspec =~ m#[/>\]]$#) { return $fspec; } + if ($fspec =~ m#(.+)\.([^/>\]]*)$# && $2 && $2 ne '.') { + $fspec = $1; + if ($2 !~ /^dir(?:;1)?$/i) { return undef } + } + + if ($fspec !~ m#[/>\]]#) { + $fspec =~ s/:$//; + while ($ENV{$fspec}) { + if ($ENV{$fspec} =~ m#[>\]]$#) { return $ENV{$fspec} } + else { $fspec = $ENV{$fspec} =~ s/:$// } + } + } + + if ($fspec !~ m#[>\]]#) { "$fspec/"; } + else { + if ($fspec =~ /([^>\]]+)([>\]])(.+)/) { "$1.$3$2"; } + else { $fspec; } + } +} + +sub vmspath { + pathify(vmsify($_[0])); +} + +sub unixpath { + pathify(unixify($_[0])); +} + +sub candelete { + my($fspec) = @_; + my($parent); + + return '' unless -w $fspec; + $fspec =~ s#/$##; + if ($fspec =~ m#/#) { + ($parent = $fspec) =~ s#/[^/]+$#; + return (-w $parent); + } + elsif ($parent = fileify($fspec)) { # fileify() here to expand lnms + $parent =~ s/[>\]][^>\]]+//; + return (-w fileify($parent)); + } + else { return (-w '[-]'); } +} |