vms/ext/Filespec.pm

   1 #   Perl hooks into the routines in vms.c for interconversion
   2 #   of VMS and Unix file specification syntax.
   3 #
   4 #   Version:  1.1
   5 #   Author:   Charles Bailey  bailey@genetics.upenn.edu
   6 #   Revised:  08-Mar-1995
   7
   8 =head1 NAME
   9
  10 VMS::Filespec - convert between VMS and Unix file specification syntax
  11
  12 =head1 SYNOPSIS
  13
  14 use VMS::Filespec;
  15 $fullspec = rmsexpand('[.VMS]file.specification');
  16 $vmsspec = vmsify('/my/Unix/file/specification');
  17 $unixspec = unixify('my:[VMS]file.specification');
  18 $path = pathify('my:[VMS.or.Unix.directory]specification.dir');
  19 $dirfile = fileify('my:[VMS.or.Unix.directory.specification]');
  20 $vmsdir = vmspath('my/VMS/or/Unix/directory/specification.dir');
  21 $unixdir = unixpath('my:[VMS.or.Unix.directory]specification.dir');
  22 candelete('my:[VMS.or.Unix]file.specification');
  23
  24 =head1 DESCRIPTION
  25
  26 This package provides routines to simplify conversion between VMS and
  27 Unix syntax when processing file specifications.  This is useful when
  28 porting scripts designed to run under either OS, and also allows you
  29 to take advantage of conveniences provided by either syntax (I<e.g.>
  30 ability to easily concatenate Unix-style specifications).  In
  31 addition, it provides an additional file test routine, C<candelete>,
  32 which determines whether you have delete access to a file.
  33
  34 If you're running under VMS, the routines in this package are special,
  35 in that they're automatically made available to any Perl script,
  36 whether you're running F<miniperl> or the full F<perl>.  The C<use
  37 VMS::Filespec> or C<require VMS::Filespec; import VMS::Filespec ...>
  38 statement can be used to import the function names into the current
  39 package, but they're always available if you use the fully qualified
  40 name, whether or not you've mentioned the F<.pm> file in your script.
  41 If you're running under another OS and have installed this package, it
  42 behaves like a normal Perl extension (in fact, you're using Perl
  43 substitutes to emulate the necessary VMS system calls).
  44
  45 Each of these routines accepts a file specification in either VMS or
  46 Unix syntax, and returns the converted file specification, or C<undef>
  47 if an error occurs.  The conversions are, for the most part, simply
  48 string manipulations; the routines do not check the details of syntax
  49 (e.g. that only legal characters are used).  There is one exception:
  50 when running under VMS, conversions from VMS syntax use the $PARSE
  51 service to expand specifications, so illegal syntax, or a relative
  52 directory specification which extends above the tope of the current
  53 directory path (e.g [---.foo] when in dev:[dir.sub]) will cause
  54 errors.  In general, any legal file specification will be converted
  55 properly, but garbage input tends to produce garbage output.
  56
  57 Each of these routines is prototyped as taking a single scalar
  58 argument, so you can use them as unary operators in complex
  59 expressions (as long as you don't use the C<&> form of
  60 subroutine call, which bypasses prototype checking).
  61
  62
  63 The routines provided are:
  64
  65 =head2 rmsexpand
  66
  67 Uses the RMS $PARSE and $SEARCH services to expand the input
  68 specification to its fully qualified form.  (If the file does
  69 not exist, the input specification is expanded as much as
  70 possible.)  If an error occurs, returns C<undef> and sets C<$!>
  71 and C<$^E>.
  72
  73 =head2 vmsify
  74
  75 Converts a file specification to VMS syntax.
  76
  77 =head2 unixify
  78
  79 Converts a file specification to Unix syntax.
  80
  81 =head2 pathify
  82
  83 Converts a directory specification to a path - that is, a string you
  84 can prepend to a file name to form a valid file specification.  If the
  85 input file specification uses VMS syntax, the returned path does, too;
  86 likewise for Unix syntax (Unix paths are guaranteed to end with '/').
  87 Note that this routine will insist that the input be a legal directory
  88 file specification; the file type and version, if specified, must be
  89 F<.DIR;1>.  For compatibility with Unix usage, the type and version
  90 may also be omitted.
  91
  92 =head2 fileify
  93
  94 Converts a directory specification to the file specification of the
  95 directory file - that is, a string you can pass to functions like
  96 C<stat> or C<rmdir> to manipulate the directory file.  If the
  97 input directory specification uses VMS syntax, the returned file
  98 specification does, too; likewise for Unix syntax.  As with
  99 C<pathify>, the input file specification must have a type and
 100 version of F<.DIR;1>, or the type and version must be omitted.
 101
 102 =head2 vmspath
 103
 104 Acts like C<pathify>, but insures the returned path uses VMS syntax.
 105
 106 =head2 unixpath
 107
 108 Acts like C<pathify>, but insures the returned path uses Unix syntax.
 109
 110 =head2 candelete
 111
 112 Determines whether you have delete access to a file.  If you do, C<candelete>
 113 returns true.  If you don't, or its argument isn't a legal file specification,
 114 C<candelete> returns FALSE.  Unlike other file tests, the argument to
 115 C<candelete> must be a file name (not a FileHandle), and, since it's an XSUB,
 116 it's a list operator, so you need to be careful about parentheses.  Both of
 117 these restrictions may be removed in the future if the functionality of
 118 C<candelete> becomes part of the Perl core.
 119
 120 =head1 REVISION
 121
 122 This document was last revised 22-Feb-1996, for Perl 5.002.
 123
 124 =cut
 125
 126 package VMS::Filespec;
 127 require 5.002;
 128
 129
 130 # If you want to use this package on a non-VMS system,
 131 # uncomment the following line.
 132 # use AutoLoader;
 133 require Exporter;
 134
 135 @ISA = qw( Exporter );
 136 @EXPORT = qw( &vmsify &unixify &pathify &fileify
 137               &vmspath &unixpath &candelete &rmsexpand );
 138
 139 1;
 140
 141
 142 __END__
 143
 144
 145 # The autosplit routines here are provided for use by non-VMS systems
 146 # They are not guaranteed to function identically to the XSUBs of the
 147 # same name, since they do not have access to the RMS system routine
 148 # sys$parse() (in particular, no real provision is made for handling
 149 # of complex DECnet node specifications).  However, these routines
 150 # should be adequate for most purposes.
 151
 152 # A sort-of sys$parse() replacement
 153 sub rmsexpand ($;$) {
 154   my($fspec,$defaults) = @_;
 155   if (!$fspec) { return undef }
 156   my($node,$dev,$dir,$name,$type,$ver,$dnode,$ddev,$ddir,$dname,$dtype,$dver);
 157
 158   $fspec =~ s/:$//;
 159   $defaults = [] unless $defaults;
 160   $defaults = [ $defaults ] unless ref($defaults) && ref($defaults) eq 'ARRAY';
 161
 162   while ($fspec !~ m#[:>\]]# && $ENV{$fspec}) { $fspec = $ENV{$fspec} }
 163
 164   if ($fspec =~ /:/) {
 165     my($dev,$devtrn,$base);
 166     ($dev,$base) = split(/:/,$fspec);
 167     $devtrn = $dev;
 168     while ($devtrn = $ENV{$devtrn}) {
 169       if ($devtrn =~ /(.)([:>\]])$/) {
 170         $dev .= ':', last if $1 eq '.';
 171         $dev = $devtrn, last;
 172       }
 173     }
 174     $fspec = $dev . $base;
 175   }
 176
 177   ($node,$dev,$dir,$name,$type,$ver) = $fspec =~
 178      /([^:]*::)?([^:]*:)?([^>\]]*[>\]])?([^.;]*)(\.?[^.;]*)([.;]?\d*)/;
 179   foreach ((@$defaults,$ENV{'DEFAULT'})) {
 180     last if $node && $ver && $type && $dev && $dir && $name;
 181     ($dnode,$ddev,$ddir,$dname,$dtype,$dver) =
 182        /([^:]*::)?([^:]*:)?([^>\]]*[>\]])?([^.;]*)(\.?[^.;]*)([.;]?\d*)/;
 183     $node = $dnode if $dnode && !$node;
 184     $dev = $ddev if $ddev && !$dev;
 185     $dir = $ddir if $ddir && !$dir;
 186     $name = $dname if $dname && !$name;
 187     $type = $dtype if $dtype && !$type;
 188     $ver = $dver if $dver && !$ver;
 189   }
 190   # do this the long way to keep -w happy
 191   $fspec = '';
 192   $fspec .= $node if $node;
 193   $fspec .= $dev if $dev;
 194   $fspec .= $dir if $dir;
 195   $fspec .= $name if $name;
 196   $fspec .= $type if $type;
 197   $fspec .= $ver if $ver;
 198   $fspec;
 199 }
 200
 201 sub vmsify ($) {
 202   my($fspec) = @_;
 203   my($hasdev,$dev,$defdirs,$dir,$base,@dirs,@realdirs);
 204
 205   if ($fspec =~ m#^\.(\.?)/?$#) { return $1 ? '[-]' : '[]'; }
 206   return $fspec if $fspec !~ m#/#;
 207   ($hasdev,$dir,$base) = $fspec =~ m#(/?)(.*)/(.*)#;
 208   @dirs = split(m#/#,$dir);
 209   if ($base eq '.') { $base = ''; }
 210   elsif ($base eq '..') {
 211     push @dirs,$base;
 212     $base = '';
 213   }
 214   foreach (@dirs) {
 215     next unless $_;  # protect against // in input
 216     next if $_ eq '.';
 217     if ($_ eq '..') {
 218       if (@realdirs && $realdirs[$#realdirs] ne '-') { pop @realdirs }
 219       else                                           { push @realdirs, '-' }
 220     }
 221     else { push @realdirs, $_; }
 222   }
 223   if ($hasdev) {
 224     $dev = shift @realdirs;
 225     @realdirs = ('000000') unless @realdirs;
 226     $base = '' unless $base;  # keep -w happy
 227     $dev . ':[' . join('.',@realdirs) . "]$base";
 228   }
 229   else {
 230     '[' . join('',map($_ eq '-' ? $_ : ".$_",@realdirs)) . "]$base";
 231   }
 232 }
 233
 234 sub unixify ($) {
 235   my($fspec) = @_;
 236
 237   return $fspec if $fspec !~ m#[:>\]]#;
 238   return '.' if ($fspec eq '[]' || $fspec eq '<>');
 239   if ($fspec =~ m#^[<\[](\.|-+)(.*)# ) {
 240     $fspec = ($1 eq '.' ? '' : "$1.") . $2;
 241     my($dir,$base) = split(/[\]>]/,$fspec);
 242     my(@dirs) = grep($_,split(m#\.#,$dir));
 243     if ($dirs[0] =~ /^-/) {
 244       my($steps) = shift @dirs;
 245       for (1..length($steps)) { unshift @dirs, '..'; }
 246     }
 247     join('/',@dirs) . "/$base";
 248   }
 249   else {
 250     $fspec = rmsexpand($fspec,'_N_O_T_:[_R_E_A_L_]');
 251     $fspec =~ s/.*_N_O_T_:(?:\[_R_E_A_L_\])?//;
 252     my($dev,$dir,$base) = $fspec =~ m#([^:<\[]*):?[<\[](.*)[>\]](.*)#;
 253     my(@dirs) = split(m#\.#,$dir);
 254     if ($dirs[0] && $dirs[0] =~ /^-/) {
 255       my($steps) = shift @dirs;
 256       for (1..length($steps)) { unshift @dirs, '..'; }
 257     }
 258     "/$dev/" . join('/',@dirs) . "/$base";
 259   }
 260 }
 261
 262
 263 sub fileify ($) {
 264   my($path) = @_;
 265
 266   if (!$path) { return undef }
 267   if ($path =~ /(.+)\.([^:>\]]*)$/) {
 268     $path = $1;
 269     if ($2 !~ /^dir(?:;1)?$/i) { return undef }
 270   }
 271
 272   if ($path !~ m#[/>\]]#) {
 273     $path =~ s/:$//;
 274     while ($ENV{$path}) {
 275       ($path = $ENV{$path}) =~ s/:$//;
 276       last if $path =~ m#[/>\]]#;
 277     }
 278   }
 279   if ($path =~ m#[>\]]#) {
 280     my($dir,$sep,$base) = $path =~ /(.*)([>\]])(.*)/;
 281     $sep =~ tr/<[/>]/;
 282     if ($base) {
 283       "$dir$sep$base.dir;1";
 284     }
 285     else {
 286       if ($dir !~ /\./) { $dir =~ s/([<\[])/${1}000000./; }
 287       $dir =~ s#\.(\w+)$#$sep$1#;
 288       $dir =~ s/^.$sep//;
 289       "$dir.dir;1";
 290     }
 291   }
 292   else {
 293     $path =~ s#/$##;
 294     "$path.dir;1";
 295   }
 296 }
 297
 298 sub pathify ($) {
 299   my($fspec) = @_;
 300
 301   if (!$fspec) { return undef }
 302   if ($fspec =~ m#[/>\]]$#) { return $fspec; }
 303   if ($fspec =~ m#(.+)\.([^/>\]]*)$# && $2 && $2 ne '.') {
 304     $fspec = $1;
 305     if ($2 !~ /^dir(?:;1)?$/i) { return undef }
 306   }
 307
 308   if ($fspec !~ m#[/>\]]#) {
 309     $fspec =~ s/:$//;
 310     while ($ENV{$fspec}) {
 311       if ($ENV{$fspec} =~ m#[>\]]$#) { return $ENV{$fspec} }
 312       else { $fspec = $ENV{$fspec} =~ s/:$// }
 313     }
 314   }
 315
 316   if ($fspec !~ m#[>\]]#) { "$fspec/"; }
 317   else {
 318     if ($fspec =~ /([^>\]]+)([>\]])(.+)/) { "$1.$3$2"; }
 319     else { $fspec; }
 320   }
 321 }
 322
 323 sub vmspath ($) {
 324   pathify(vmsify($_[0]));
 325 }
 326
 327 sub unixpath ($) {
 328   pathify(unixify($_[0]));
 329 }
 330
 331 sub candelete ($) {
 332   my($fspec) = @_;
 333   my($parent);
 334
 335   return '' unless -w $fspec;
 336   $fspec =~ s#/$##;
 337   if ($fspec =~ m#/#) {
 338     ($parent = $fspec) =~ s#/[^/]+$#;
 339     return (-w $parent);
 340   }
 341   elsif ($parent = fileify($fspec)) { # fileify() here to expand lnms
 342     $parent =~ s/[>\]][^>\]]+//;
 343     return (-w fileify($parent));
 344   }
 345   else { return (-w '[-]'); }
 346 }