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