perl/vms/ext/Filespec.pm
<<
>>
Prefs
   1#   Perl hooks into the routines in vms.c for interconversion
   2#   of VMS and Unix file specification syntax.
   3#
   4#   Version:  see $VERSION below
   5#   Author:   Charles Bailey  bailey@newman.upenn.edu
   6#   Revised:  8-DEC-2007
   7
   8=head1 NAME
   9
  10VMS::Filespec - convert between VMS and Unix file specification syntax
  11
  12=head1 SYNOPSIS
  13
  14  use VMS::Filespec;
  15  $fullspec = rmsexpand('[.VMS]file.specification'[, 'default:[file.spec]']);
  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  $case_tolerant = case_tolerant_process;
  24  $unixspec = unixrealpath('file_specification');
  25  $vmsspec = vmsrealpath('file_specification');
  26
  27=head1 DESCRIPTION
  28
  29This package provides routines to simplify conversion between VMS and
  30Unix syntax when processing file specifications.  This is useful when
  31porting scripts designed to run under either OS, and also allows you
  32to take advantage of conveniences provided by either syntax (I<e.g.>
  33ability to easily concatenate Unix-style specifications).  In
  34addition, it provides an additional file test routine, C<candelete>,
  35which determines whether you have delete access to a file.
  36
  37If you're running under VMS, the routines in this package are special,
  38in that they're automatically made available to any Perl script,
  39whether you're running F<miniperl> or the full F<perl>.  The C<use
  40VMS::Filespec> or C<require VMS::Filespec; import VMS::Filespec ...>
  41statement can be used to import the function names into the current
  42package, but they're always available if you use the fully qualified
  43name, whether or not you've mentioned the F<.pm> file in your script. 
  44If you're running under another OS and have installed this package, it
  45behaves like a normal Perl extension (in fact, you're using Perl
  46substitutes to emulate the necessary VMS system calls).
  47
  48Each of these routines accepts a file specification in either VMS or
  49Unix syntax, and returns the converted file specification, or C<undef>
  50if an error occurs.  The conversions are, for the most part, simply
  51string manipulations; the routines do not check the details of syntax
  52(e.g. that only legal characters are used).  There is one exception:
  53when running under VMS, conversions from VMS syntax use the $PARSE
  54service to expand specifications, so illegal syntax, or a relative
  55directory specification which extends above the tope of the current
  56directory path (e.g [---.foo] when in dev:[dir.sub]) will cause
  57errors.  In general, any legal file specification will be converted
  58properly, but garbage input tends to produce garbage output.  
  59
  60Each of these routines is prototyped as taking a single scalar
  61argument, so you can use them as unary operators in complex
  62expressions (as long as you don't use the C<&> form of
  63subroutine call, which bypasses prototype checking).
  64
  65
  66The routines provided are:
  67
  68=head2 rmsexpand
  69
  70Uses the RMS $PARSE and $SEARCH services to expand the input
  71specification to its fully qualified form, except that a null type
  72or version is not added unless it was present in either the original
  73file specification or the default specification passed to C<rmsexpand>.
  74(If the file does not exist, the input specification is expanded as much
  75as possible.)  If an error occurs, returns C<undef> and sets C<$!>
  76and C<$^E>.
  77
  78C<rmsexpand> on success will produce a name that fits in a 255 byte buffer,
  79which is required for parameters passed to the DCL interpreter.
  80
  81=head2 vmsify
  82
  83Converts a file specification to VMS syntax.  If the file specification
  84cannot be converted to or is already in VMS syntax, it will be
  85passed through unchanged.
  86
  87The file specifications of C<.> and C<..> will be converted to
  88C<[]> and C<[-]>.
  89
  90If the file specification is already in a valid VMS syntax, it will
  91be passed through unchanged, except that the UTF-8 flag will be cleared
  92since VMS format file specifications are never in UTF-8.
  93
  94When Perl is running on an OpenVMS system, if the C<DECC$EFS_CHARSET>
  95feature is not enabled, extra dots in the file specification will
  96be converted to underscore characters, and the C<?> character will
  97be converted to a C<%> character, if a conversion is done.
  98
  99When Perl is running on an OpenVMS system, if the C<DECC$EFS_CHARSET>
 100feature is enabled, this implies that the Unix pathname cannot have
 101a version, and that a path consisting of three dots, C<./.../>, will be
 102converted to C<[.^.^.^.]>.
 103
 104Unix style shell macros like C<$(abcd)> are passed through instead
 105of being converted to C<$^(abcd^)> independent of the C<DECC$EFS_CHARSET>
 106feature setting.  Unix style shell macros should not use characters
 107that are not in the ASCII character set, as the resulting specification
 108may or may not be still in UTF8 format.
 109
 110The feature logical name C<PERL_VMS_VTF7_FILENAMES> controls if UNICODE
 111characters in Unix filenames are encoded in VTF-7 notation in the resulting
 112OpenVMS file specification.  [Currently under development]
 113
 114C<unixify> on the resulting file specification may not result in the
 115original Unix file specification, so programs should not plan to convert
 116a file specification from Unix to VMS and then back to Unix again after
 117modification of the components.
 118
 119=head2 unixify
 120
 121Converts a file specification to Unix syntax.  If the file specification
 122cannot be converted to or is already in Unix syntax, it will be passed
 123through unchanged.
 124
 125When Perl is running on an OpenVMS system, the following C<DECC$> feature
 126settings will control how the filename is converted:
 127
 128 C<decc$disable_to_vms_logname_translation:> default = C<ENABLE>
 129 C<decc$disable_posix_root:>                 default = C<ENABLE>
 130 C<decc$efs_charset:>                        default = C<DISABLE>
 131 C<decc$filename_unix_no_version:>           default = C<DISABLE>
 132 C<decc$readdir_dropdotnotype:>              default = C<ENABLE>
 133
 134When Perl is being run under a Unix shell on OpenVMS, the defaults at
 135a future time may be more appropriate for it.
 136
 137When Perl is running on an OpenVMS system with C<DECC$EFS_CHARSET>
 138enabled, a wild card directory name of C<[...]> cannot be translated to
 139a valid Unix file specification.  Also, directory file specifications
 140will have their implied ".dir;1" removed, and a trailing C<.> character
 141indicating a null extension will be removed.
 142
 143Note that C<DECC$EFS_CHARSET> requires C<DECC$FILENAME_UNIX_NO_VERSION> because
 144the conversion routine cannot differentiate whether the last C<.> of a Unix
 145specification is delimiting a version, or is just part of a file specification.
 146
 147C<vmsify> on the resulting file specification may not result in the
 148original VMS file specification, so programs should not plan to convert
 149a file specification from VMS to Unix and then back to VMS again after
 150modification.
 151
 152=head2 pathify
 153
 154Converts a directory specification to a path - that is, a string you
 155can prepend to a file name to form a valid file specification.  If the
 156input file specification uses VMS syntax, the returned path does, too;
 157likewise for Unix syntax (Unix paths are guaranteed to end with '/').
 158Note that this routine will insist that the input be a legal directory
 159file specification; the file type and version, if specified, must be
 160F<.DIR;1>.  For compatibility with Unix usage, the type and version
 161may also be omitted.
 162
 163=head2 fileify
 164
 165Converts a directory specification to the file specification of the
 166directory file - that is, a string you can pass to functions like
 167C<stat> or C<rmdir> to manipulate the directory file.  If the
 168input directory specification uses VMS syntax, the returned file
 169specification does, too; likewise for Unix syntax.  As with
 170C<pathify>, the input file specification must have a type and
 171version of F<.DIR;1>, or the type and version must be omitted.
 172
 173=head2 vmspath
 174
 175Acts like C<pathify>, but insures the returned path uses VMS syntax.
 176
 177=head2 unixpath
 178
 179Acts like C<pathify>, but insures the returned path uses Unix syntax.
 180
 181=head2 candelete
 182
 183Determines whether you have delete access to a file.  If you do, C<candelete>
 184returns true.  If you don't, or its argument isn't a legal file specification,
 185C<candelete> returns FALSE.  Unlike other file tests, the argument to
 186C<candelete> must be a file name (not a FileHandle), and, since it's an XSUB,
 187it's a list operator, so you need to be careful about parentheses.  Both of
 188these restrictions may be removed in the future if the functionality of
 189C<candelete> becomes part of the Perl core.
 190
 191=head2 case_tolerant_process
 192
 193This reports whether the VMS process has been set to a case tolerant
 194state, and returns true when the process is in the traditional case
 195tolerant mode and false when case sensitivity has been enabled for the
 196process.   It is intended for use by the File::Spec::VMS->case_tolerant
 197method only, and it is recommended that you only use
 198File::Spec->case_tolerant.
 199
 200=head2 unixrealpath
 201
 202This exposes the VMS C library C<realpath> function where available.
 203It will always return a Unix format specification.
 204
 205If the C<realpath> function is not available, or is unable to return the
 206real path of the file, C<unixrealpath> will use the same internal
 207procedure as the C<vmsrealpath> function and convert the output to a
 208Unix format specification.  It is not available on non-VMS systems.
 209
 210=head2 vmsrealpath
 211
 212This uses the C<LIB$FID_TO_NAME> run-time library call to find the name
 213of the primary link to a file, and returns the filename in VMS format. 
 214This function is not available on non-VMS systems.
 215
 216
 217=head1 REVISION
 218
 219This document was last revised 8-DEC-2007, for Perl 5.10.0
 220
 221=cut
 222
 223package VMS::Filespec;
 224require 5.002;
 225
 226our $VERSION = '1.12';
 227
 228# If you want to use this package on a non-VMS system,
 229# uncomment the following line.
 230# use AutoLoader;
 231require Exporter;
 232
 233@ISA = qw( Exporter );
 234@EXPORT = qw( &vmsify &unixify &pathify &fileify
 235              &vmspath &unixpath &candelete &rmsexpand );
 236@EXPORT_OK = qw( &unixrealpath &vmsrealpath &case_tolerant_process );
 2371;
 238
 239
 240__END__
 241
 242
 243# The autosplit routines here are provided for use by non-VMS systems
 244# They are not guaranteed to function identically to the XSUBs of the
 245# same name, since they do not have access to the RMS system routine
 246# sys$parse() (in particular, no real provision is made for handling
 247# of complex DECnet node specifications).  However, these routines
 248# should be adequate for most purposes.
 249
 250# A sort-of sys$parse() replacement
 251sub rmsexpand ($;$) {
 252  my($fspec,$defaults) = @_;
 253  if (!$fspec) { return undef }
 254  my($node,$dev,$dir,$name,$type,$ver,$dnode,$ddev,$ddir,$dname,$dtype,$dver);
 255
 256  $fspec =~ s/:$//;
 257  $defaults = [] unless $defaults;
 258  $defaults = [ $defaults ] unless ref($defaults) && ref($defaults) eq 'ARRAY';
 259
 260  while ($fspec !~ m#[:>\]]# && $ENV{$fspec}) { $fspec = $ENV{$fspec} }
 261
 262  if ($fspec =~ /:/) {
 263    my($dev,$devtrn,$base);
 264    ($dev,$base) = split(/:/,$fspec);
 265    $devtrn = $dev;
 266    while ($devtrn = $ENV{$devtrn}) {
 267      if ($devtrn =~ /(.)([:>\]])$/) {
 268        $dev .= ':', last if $1 eq '.';
 269        $dev = $devtrn, last;
 270      }
 271    }
 272    $fspec = $dev . $base;
 273  }
 274
 275  ($node,$dev,$dir,$name,$type,$ver) = $fspec =~
 276     /([^:]*::)?([^:]*:)?([^>\]]*[>\]])?([^.;]*)(\.?[^.;]*)([.;]?\d*)/;
 277  foreach ((@$defaults,$ENV{'DEFAULT'})) {
 278    next unless defined;
 279    last if $node && $ver && $type && $dev && $dir && $name;
 280    ($dnode,$ddev,$ddir,$dname,$dtype,$dver) =
 281       /([^:]*::)?([^:]*:)?([^>\]]*[>\]])?([^.;]*)(\.?[^.;]*)([.;]?\d*)/;
 282    $node = $dnode if $dnode && !$node;
 283    $dev = $ddev if $ddev && !$dev;
 284    $dir = $ddir if $ddir && !$dir;
 285    $name = $dname if $dname && !$name;
 286    $type = $dtype if $dtype && !$type;
 287    $ver = $dver if $dver && !$ver;
 288  }
 289  # do this the long way to keep -w happy
 290  $fspec = '';
 291  $fspec .= $node if $node;
 292  $fspec .= $dev if $dev;
 293  $fspec .= $dir if $dir;
 294  $fspec .= $name if $name;
 295  $fspec .= $type if $type;
 296  $fspec .= $ver if $ver;
 297  $fspec;
 298}  
 299
 300sub vmsify ($) {
 301  my($fspec) = @_;
 302  my($hasdev,$dev,$defdirs,$dir,$base,@dirs,@realdirs);
 303
 304  if ($fspec =~ m#^\.(\.?)/?$#) { return $1 ? '[-]' : '[]'; }
 305  return $fspec if $fspec !~ m#/#;
 306  ($hasdev,$dir,$base) = $fspec =~ m#(/?)(.*)/(.*)#;
 307  @dirs = split(m#/#,$dir);
 308  if ($base eq '.') { $base = ''; }
 309  elsif ($base eq '..') {
 310    push @dirs,$base;
 311    $base = '';
 312  }
 313  foreach (@dirs) {
 314    next unless $_;  # protect against // in input
 315    next if $_ eq '.';
 316    if ($_ eq '..') {
 317      if (@realdirs && $realdirs[$#realdirs] ne '-') { pop @realdirs }
 318      else                                           { push @realdirs, '-' }
 319    }
 320    else { push @realdirs, $_; }
 321  }
 322  if ($hasdev) {
 323    $dev = shift @realdirs;
 324    @realdirs = ('000000') unless @realdirs;
 325    $base = '' unless $base;  # keep -w happy
 326    $dev . ':[' . join('.',@realdirs) . "]$base";
 327  }
 328  else {
 329    '[' . join('',map($_ eq '-' ? $_ : ".$_",@realdirs)) . "]$base";
 330  }
 331}
 332
 333sub unixify ($) {
 334  my($fspec) = @_;
 335
 336  return $fspec if $fspec !~ m#[:>\]]#;
 337  return '.' if ($fspec eq '[]' || $fspec eq '<>');
 338  if ($fspec =~ m#^[<\[](\.|-+)(.*)# ) {
 339    $fspec = ($1 eq '.' ? '' : "$1.") . $2;
 340    my($dir,$base) = split(/[\]>]/,$fspec);
 341    my(@dirs) = grep($_,split(m#\.#,$dir));
 342    if ($dirs[0] =~ /^-/) {
 343      my($steps) = shift @dirs;
 344      for (1..length($steps)) { unshift @dirs, '..'; }
 345    }
 346    join('/',@dirs) . "/$base";
 347  }
 348  else {
 349    $fspec = rmsexpand($fspec,'_N_O_T_:[_R_E_A_L_]');
 350    $fspec =~ s/.*_N_O_T_:(?:\[_R_E_A_L_\])?//;
 351    my($dev,$dir,$base) = $fspec =~ m#([^:<\[]*):?[<\[](.*)[>\]](.*)#;
 352    my(@dirs) = split(m#\.#,$dir);
 353    if ($dirs[0] && $dirs[0] =~ /^-/) {
 354      my($steps) = shift @dirs;
 355      for (1..length($steps)) { unshift @dirs, '..'; }
 356    }
 357    "/$dev/" . join('/',@dirs) . "/$base";
 358  }
 359}
 360
 361
 362sub fileify ($) {
 363  my($path) = @_;
 364
 365  if (!$path) { return undef }
 366  if ($path eq '/') { return 'sys$disk:[000000]'; }
 367  if ($path =~ /(.+)\.([^:>\]]*)$/) {
 368    $path = $1;
 369    if ($2 !~ /^dir(?:;1)?$/i) { return undef }
 370  }
 371
 372  if ($path !~ m#[/>\]]#) {
 373    $path =~ s/:$//;
 374    while ($ENV{$path}) {
 375      ($path = $ENV{$path}) =~ s/:$//;
 376      last if $path =~ m#[/>\]]#;
 377    }
 378  }
 379  if ($path =~ m#[>\]]#) {
 380    my($dir,$sep,$base) = $path =~ /(.*)([>\]])(.*)/;
 381    $sep =~ tr/<[/>]/;
 382    if ($base) {
 383      "$dir$sep$base.dir;1";
 384    }
 385    else {
 386      if ($dir !~ /\./) { $dir =~ s/([<\[])/${1}000000./; }
 387      $dir =~ s#\.(\w+)$#$sep$1#;
 388      $dir =~ s/^.$sep//;
 389      "$dir.dir;1";
 390    }
 391  }
 392  else {
 393    $path =~ s#/$##;
 394    "$path.dir;1";
 395  }
 396}
 397
 398sub pathify ($) {
 399  my($fspec) = @_;
 400
 401  if (!$fspec) { return undef }
 402  if ($fspec =~ m#[/>\]]$#) { return $fspec; }
 403  if ($fspec =~ m#(.+)\.([^/>\]]*)$# && $2 && $2 ne '.') {
 404    $fspec = $1;
 405    if ($2 !~ /^dir(?:;1)?$/i) { return undef }
 406  }
 407
 408  if ($fspec !~ m#[/>\]]#) {
 409    $fspec =~ s/:$//;
 410    while ($ENV{$fspec}) {
 411      if ($ENV{$fspec} =~ m#[>\]]$#) { return $ENV{$fspec} }
 412      else { $fspec = $ENV{$fspec} =~ s/:$// }
 413    }
 414  }
 415  
 416  if ($fspec !~ m#[>\]]#) { "$fspec/"; }
 417  else {
 418    if ($fspec =~ /([^>\]]+)([>\]])(.+)/) { "$1.$3$2"; }
 419    else { $fspec; }
 420  }
 421}
 422
 423sub vmspath ($) {
 424  pathify(vmsify($_[0]));
 425}
 426
 427sub unixpath ($) {
 428  pathify(unixify($_[0]));
 429}
 430
 431sub candelete ($) {
 432  my($fspec) = @_;
 433  my($parent);
 434
 435  return '' unless -w $fspec;
 436  $fspec =~ s#/$##;
 437  if ($fspec =~ m#/#) {
 438    ($parent = $fspec) =~ s#/[^/]+$##;
 439    return (-w $parent);
 440  }
 441  elsif ($parent = fileify($fspec)) { # fileify() here to expand lnms
 442    $parent =~ s/[>\]][^>\]]+//;
 443    return (-w fileify($parent));
 444  }
 445  else { return (-w '[-]'); }
 446}
 447
 448sub case_tolerant_process () {
 449    return 0;
 450}
 451
lxr.linux.no kindly hosted by Redpill Linpro AS, provider of Linux consulting and operations services since 1995.