lib/File/Spec/VMS.pm

   1 package File::Spec::VMS;
   2
   3 use strict;
   4 use vars qw(@ISA);
   5 require File::Spec::Unix;
   6 @ISA = qw(File::Spec::Unix);
   7
   8 use File::Basename;
   9 use VMS::Filespec;
  10
  11 =head1 NAME
  12
  13 File::Spec::VMS - methods for VMS file specs
  14
  15 =head1 SYNOPSIS
  16
  17  require File::Spec::VMS; # Done internally by File::Spec if needed
  18
  19 =head1 DESCRIPTION
  20
  21 See File::Spec::Unix for a documentation of the methods provided
  22 there. This package overrides the implementation of these methods, not
  23 the semantics.
  24
  25 =head2 Methods always loaded
  26
  27 =over
  28
  29 =item catdir
  30
  31 Concatenates a list of file specifications, and returns the result as a
  32 VMS-syntax directory specification.
  33
  34 =cut
  35
  36 sub catdir {
  37     my ($self,@dirs) = @_;
  38     my $dir = pop @dirs;
  39     @dirs = grep($_,@dirs);
  40     my $rslt;
  41     if (@dirs) {
  42         my $path = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs));
  43         my ($spath,$sdir) = ($path,$dir);
  44         $spath =~ s/.dir$//; $sdir =~ s/.dir$//;
  45         $sdir = $self->eliminate_macros($sdir) unless $sdir =~ /^[\w\-]+$/;
  46         $rslt = $self->fixpath($self->eliminate_macros($spath)."/$sdir",1);
  47     }
  48     else {
  49         if ($dir =~ /^\$\([^\)]+\)$/) { $rslt = $dir; }
  50         else                          { $rslt = vmspath($dir); }
  51     }
  52     return $rslt;
  53 }
  54
  55 =item catfile
  56
  57 Concatenates a list of file specifications, and returns the result as a
  58 VMS-syntax directory specification.
  59
  60 =cut
  61
  62 sub catfile {
  63     my ($self,@files) = @_;
  64     my $file = pop @files;
  65     @files = grep($_,@files);
  66     my $rslt;
  67     if (@files) {
  68         my $path = (@files == 1 ? $files[0] : $self->catdir(@files));
  69         my $spath = $path;
  70         $spath =~ s/.dir$//;
  71         if ($spath =~ /^[^\)\]\/:>]+\)$/ && basename($file) eq $file) {
  72             $rslt = "$spath$file";
  73         }
  74         else {
  75             $rslt = $self->eliminate_macros($spath);
  76             $rslt = vmsify($rslt.($rslt ? '/' : '').unixify($file));
  77         }
  78     }
  79     else { $rslt = vmsify($file); }
  80     return $rslt;
  81 }
  82
  83 =item curdir (override)
  84
  85 Returns a string representation of the current directory: '[]'
  86
  87 =cut
  88
  89 sub curdir {
  90     return '[]';
  91 }
  92
  93 =item devnull (override)
  94
  95 Returns a string representation of the null device: '_NLA0:'
  96
  97 =cut
  98
  99 sub devnull {
 100     return "_NLA0:";
 101 }
 102
 103 =item rootdir (override)
 104
 105 Returns a string representation of the root directory: 'SYS$DISK:[000000]'
 106
 107 =cut
 108
 109 sub rootdir {
 110     return 'SYS$DISK:[000000]';
 111 }
 112
 113 =item tmpdir (override)
 114
 115 Returns a string representation of the first writable directory
 116 from the following list or '' if none are writable:
 117
 118     /sys$scratch
 119     $ENV{TMPDIR}
 120
 121 =cut
 122
 123 my $tmpdir;
 124 sub tmpdir {
 125     return $tmpdir if defined $tmpdir;
 126     foreach ('/sys$scratch', $ENV{TMPDIR}) {
 127         next unless defined && -d && -w _;
 128         $tmpdir = $_;
 129         last;
 130     }
 131     $tmpdir = '' unless defined $tmpdir;
 132     return $tmpdir;
 133 }
 134
 135 =item updir (override)
 136
 137 Returns a string representation of the parent directory: '[-]'
 138
 139 =cut
 140
 141 sub updir {
 142     return '[-]';
 143 }
 144
 145 =item path (override)
 146
 147 Translate logical name DCL$PATH as a searchlist, rather than trying
 148 to C<split> string value of C<$ENV{'PATH'}>.
 149
 150 =cut
 151
 152 sub path {
 153     my (@dirs,$dir,$i);
 154     while ($dir = $ENV{'DCL$PATH;' . $i++}) { push(@dirs,$dir); }
 155     return @dirs;
 156 }
 157
 158 =item file_name_is_absolute (override)
 159
 160 Checks for VMS directory spec as well as Unix separators.
 161
 162 =cut
 163
 164 sub file_name_is_absolute {
 165     my ($self,$file) = @_;
 166     # If it's a logical name, expand it.
 167     $file = $ENV{$file} while $file =~ /^[\w\$\-]+$/ && $ENV{$file};
 168     return scalar($file =~ m!^/!              ||
 169                   $file =~ m![<\[][^.\-\]>]!  ||
 170                   $file =~ /:[^<\[]/);
 171 }
 172
 173 =back
 174
 175 =head1 SEE ALSO
 176
 177 L<File::Spec>
 178
 179 =cut
 180
 181 1;