home *** CD-ROM | disk | FTP | other *** search
/ Australian Personal Computer 2004 July / APC0407D2.iso / workshop / apache / files / ActivePerl-5.6.1.638-MSWin32-x86.msi / _94929b38f1607141a7aa7def2578c9ed < prev    next >
Encoding:
Text File  |  2004-04-13  |  13.6 KB  |  506 lines
  1. package File::Spec::VMS;
  2.  
  3. use strict;
  4. use vars qw(@ISA $VERSION);
  5. require File::Spec::Unix;
  6.  
  7. $VERSION = '1.1';
  8.  
  9. @ISA = qw(File::Spec::Unix);
  10.  
  11. use Cwd;
  12. use File::Basename;
  13. use VMS::Filespec;
  14.  
  15. =head1 NAME
  16.  
  17. File::Spec::VMS - methods for VMS file specs
  18.  
  19. =head1 SYNOPSIS
  20.  
  21.  require File::Spec::VMS; # Done internally by File::Spec if needed
  22.  
  23. =head1 DESCRIPTION
  24.  
  25. See File::Spec::Unix for a documentation of the methods provided
  26. there. This package overrides the implementation of these methods, not
  27. the semantics.
  28.  
  29. =over
  30.  
  31. =item eliminate_macros
  32.  
  33. Expands MM[KS]/Make macros in a text string, using the contents of
  34. identically named elements of C<%$self>, and returns the result
  35. as a file specification in Unix syntax.
  36.  
  37. =cut
  38.  
  39. sub eliminate_macros {
  40.     my($self,$path) = @_;
  41.     return '' unless $path;
  42.     $self = {} unless ref $self;
  43.  
  44.     if ($path =~ /\s/) {
  45.       return join ' ', map { $self->eliminate_macros($_) } split /\s+/, $path;
  46.     }
  47.  
  48.     my($npath) = unixify($path);
  49.     my($complex) = 0;
  50.     my($head,$macro,$tail);
  51.  
  52.     # perform m##g in scalar context so it acts as an iterator
  53.     while ($npath =~ m#(.*?)\$\((\S+?)\)(.*)#gs) { 
  54.         if ($self->{$2}) {
  55.             ($head,$macro,$tail) = ($1,$2,$3);
  56.             if (ref $self->{$macro}) {
  57.                 if (ref $self->{$macro} eq 'ARRAY') {
  58.                     $macro = join ' ', @{$self->{$macro}};
  59.                 }
  60.                 else {
  61.                     print "Note: can't expand macro \$($macro) containing ",ref($self->{$macro}),
  62.                           "\n\t(using MMK-specific deferred substitutuon; MMS will break)\n";
  63.                     $macro = "\cB$macro\cB";
  64.                     $complex = 1;
  65.                 }
  66.             }
  67.             else { ($macro = unixify($self->{$macro})) =~ s#/\Z(?!\n)##; }
  68.             $npath = "$head$macro$tail";
  69.         }
  70.     }
  71.     if ($complex) { $npath =~ s#\cB(.*?)\cB#\${$1}#gs; }
  72.     $npath;
  73. }
  74.  
  75. =item fixpath
  76.  
  77. Catchall routine to clean up problem MM[SK]/Make macros.  Expands macros
  78. in any directory specification, in order to avoid juxtaposing two
  79. VMS-syntax directories when MM[SK] is run.  Also expands expressions which
  80. are all macro, so that we can tell how long the expansion is, and avoid
  81. overrunning DCL's command buffer when MM[KS] is running.
  82.  
  83. If optional second argument has a TRUE value, then the return string is
  84. a VMS-syntax directory specification, if it is FALSE, the return string
  85. is a VMS-syntax file specification, and if it is not specified, fixpath()
  86. checks to see whether it matches the name of a directory in the current
  87. default directory, and returns a directory or file specification accordingly.
  88.  
  89. =cut
  90.  
  91. sub fixpath {
  92.     my($self,$path,$force_path) = @_;
  93.     return '' unless $path;
  94.     $self = bless {} unless ref $self;
  95.     my($fixedpath,$prefix,$name);
  96.  
  97.     if ($path =~ /\s/) {
  98.       return join ' ',
  99.              map { $self->fixpath($_,$force_path) }
  100.          split /\s+/, $path;
  101.     }
  102.  
  103.     if ($path =~ m#^\$\([^\)]+\)\Z(?!\n)#s || $path =~ m#[/:>\]]#) { 
  104.         if ($force_path or $path =~ /(?:DIR\)|\])\Z(?!\n)/) {
  105.             $fixedpath = vmspath($self->eliminate_macros($path));
  106.         }
  107.         else {
  108.             $fixedpath = vmsify($self->eliminate_macros($path));
  109.         }
  110.     }
  111.     elsif ((($prefix,$name) = ($path =~ m#^\$\(([^\)]+)\)(.+)#s)) && $self->{$prefix}) {
  112.         my($vmspre) = $self->eliminate_macros("\$($prefix)");
  113.         # is it a dir or just a name?
  114.         $vmspre = ($vmspre =~ m|/| or $prefix =~ /DIR\Z(?!\n)/) ? vmspath($vmspre) : '';
  115.         $fixedpath = ($vmspre ? $vmspre : $self->{$prefix}) . $name;
  116.         $fixedpath = vmspath($fixedpath) if $force_path;
  117.     }
  118.     else {
  119.         $fixedpath = $path;
  120.         $fixedpath = vmspath($fixedpath) if $force_path;
  121.     }
  122.     # No hints, so we try to guess
  123.     if (!defined($force_path) and $fixedpath !~ /[:>(.\]]/) {
  124.         $fixedpath = vmspath($fixedpath) if -d $fixedpath;
  125.     }
  126.  
  127.     # Trim off root dirname if it's had other dirs inserted in front of it.
  128.     $fixedpath =~ s/\.000000([\]>])/$1/;
  129.     # Special case for VMS absolute directory specs: these will have had device
  130.     # prepended during trip through Unix syntax in eliminate_macros(), since
  131.     # Unix syntax has no way to express "absolute from the top of this device's
  132.     # directory tree".
  133.     if ($path =~ /^[\[>][^.\-]/) { $fixedpath =~ s/^[^\[<]+//; }
  134.     $fixedpath;
  135. }
  136.  
  137. =back
  138.  
  139. =head2 Methods always loaded
  140.  
  141. =over
  142.  
  143. =item canonpath (override)
  144.  
  145. Removes redundant portions of file specifications according to VMS syntax.
  146.  
  147. =cut
  148.  
  149. sub canonpath {
  150.     my($self,$path) = @_;
  151.  
  152.     if ($path =~ m|/|) { # Fake Unix
  153.       my $pathify = $path =~ m|/\Z(?!\n)|;
  154.       $path = $self->SUPER::canonpath($path);
  155.       if ($pathify) { return vmspath($path); }
  156.       else          { return vmsify($path);  }
  157.     }
  158.     else {
  159.       $path =~ s-\]\[--g;  $path =~ s/><//g;            # foo.][bar       ==> foo.bar
  160.       $path =~ s/([\[<])000000\./$1/;                   # [000000.foo     ==> foo
  161.       1 while $path =~ s{([\[<-])\.-}{$1-};             # [.-.-           ==> [--
  162.       $path =~ s/\.[^\[<\.]+\.-([\]\>])/$1/;            # bar.foo.-]      ==> bar]
  163.       $path =~ s/([\[<])(-+)/$1 . "\cx" x length($2)/e; # encode leading '-'s
  164.       $path =~ s/([\[<\.])([^\[<\.\cx]+)\.-\.?/$1/g;    # bar.-.foo       ==> foo
  165.       $path =~ s/([\[<])(\cx+)/$1 . '-' x length($2)/e; # then decode
  166.       return $path;
  167.     }
  168. }
  169.  
  170. =item catdir
  171.  
  172. Concatenates a list of file specifications, and returns the result as a
  173. VMS-syntax directory specification.  No check is made for "impossible"
  174. cases (e.g. elements other than the first being absolute filespecs).
  175.  
  176. =cut
  177.  
  178. sub catdir {
  179.     my ($self,@dirs) = @_;
  180.     my $dir = pop @dirs;
  181.     @dirs = grep($_,@dirs);
  182.     my $rslt;
  183.     if (@dirs) {
  184.     my $path = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs));
  185.     my ($spath,$sdir) = ($path,$dir);
  186.     $spath =~ s/\.dir\Z(?!\n)//; $sdir =~ s/\.dir\Z(?!\n)//; 
  187.     $sdir = $self->eliminate_macros($sdir) unless $sdir =~ /^[\w\-]+\Z(?!\n)/s;
  188.     $rslt = $self->fixpath($self->eliminate_macros($spath)."/$sdir",1);
  189.  
  190.     # Special case for VMS absolute directory specs: these will have had device
  191.     # prepended during trip through Unix syntax in eliminate_macros(), since
  192.     # Unix syntax has no way to express "absolute from the top of this device's
  193.     # directory tree".
  194.     if ($spath =~ /^[\[<][^.\-]/s) { $rslt =~ s/^[^\[<]+//s; }
  195.     }
  196.     else {
  197.     if    (not defined $dir or not length $dir) { $rslt = ''; }
  198.     elsif ($dir =~ /^\$\([^\)]+\)\Z(?!\n)/s)          { $rslt = $dir; }
  199.     else                                        { $rslt = vmspath($dir); }
  200.     }
  201.     return $self->canonpath($rslt);
  202. }
  203.  
  204. =item catfile
  205.  
  206. Concatenates a list of file specifications, and returns the result as a
  207. VMS-syntax file specification.
  208.  
  209. =cut
  210.  
  211. sub catfile {
  212.     my ($self,@files) = @_;
  213.     my $file = pop @files;
  214.     @files = grep($_,@files);
  215.     my $rslt;
  216.     if (@files) {
  217.     my $path = (@files == 1 ? $files[0] : $self->catdir(@files));
  218.     my $spath = $path;
  219.     $spath =~ s/\.dir\Z(?!\n)//;
  220.     if ($spath =~ /^[^\)\]\/:>]+\)\Z(?!\n)/s && basename($file) eq $file) {
  221.         $rslt = "$spath$file";
  222.     }
  223.     else {
  224.         $rslt = $self->eliminate_macros($spath);
  225.         $rslt = vmsify($rslt.($rslt ? '/' : '').unixify($file));
  226.     }
  227.     }
  228.     else { $rslt = (defined($file) && length($file)) ? vmsify($file) : ''; }
  229.     return $self->canonpath($rslt);
  230. }
  231.  
  232.  
  233. =item curdir (override)
  234.  
  235. Returns a string representation of the current directory: '[]'
  236.  
  237. =cut
  238.  
  239. sub curdir {
  240.     return '[]';
  241. }
  242.  
  243. =item devnull (override)
  244.  
  245. Returns a string representation of the null device: '_NLA0:'
  246.  
  247. =cut
  248.  
  249. sub devnull {
  250.     return "_NLA0:";
  251. }
  252.  
  253. =item rootdir (override)
  254.  
  255. Returns a string representation of the root directory: 'SYS$DISK:[000000]'
  256.  
  257. =cut
  258.  
  259. sub rootdir {
  260.     return 'SYS$DISK:[000000]';
  261. }
  262.  
  263. =item tmpdir (override)
  264.  
  265. Returns a string representation of the first writable directory
  266. from the following list or '' if none are writable:
  267.  
  268.     sys$scratch:
  269.     $ENV{TMPDIR}
  270.  
  271. =cut
  272.  
  273. my $tmpdir;
  274. sub tmpdir {
  275.     return $tmpdir if defined $tmpdir;
  276.     foreach ('sys$scratch:', $ENV{TMPDIR}) {
  277.     next unless defined && -d && -w _;
  278.     $tmpdir = $_;
  279.     last;
  280.     }
  281.     $tmpdir = '' unless defined $tmpdir;
  282.     return $tmpdir;
  283. }
  284.  
  285. =item updir (override)
  286.  
  287. Returns a string representation of the parent directory: '[-]'
  288.  
  289. =cut
  290.  
  291. sub updir {
  292.     return '[-]';
  293. }
  294.  
  295. =item case_tolerant (override)
  296.  
  297. VMS file specification syntax is case-tolerant.
  298.  
  299. =cut
  300.  
  301. sub case_tolerant {
  302.     return 1;
  303. }
  304.  
  305. =item path (override)
  306.  
  307. Translate logical name DCL$PATH as a searchlist, rather than trying
  308. to C<split> string value of C<$ENV{'PATH'}>.
  309.  
  310. =cut
  311.  
  312. sub path {
  313.     my (@dirs,$dir,$i);
  314.     while ($dir = $ENV{'DCL$PATH;' . $i++}) { push(@dirs,$dir); }
  315.     return @dirs;
  316. }
  317.  
  318. =item file_name_is_absolute (override)
  319.  
  320. Checks for VMS directory spec as well as Unix separators.
  321.  
  322. =cut
  323.  
  324. sub file_name_is_absolute {
  325.     my ($self,$file) = @_;
  326.     # If it's a logical name, expand it.
  327.     $file = $ENV{$file} while $file =~ /^[\w\$\-]+\Z(?!\n)/s && $ENV{$file};
  328.     return scalar($file =~ m!^/!s             ||
  329.           $file =~ m![<\[][^.\-\]>]!  ||
  330.           $file =~ /:[^<\[]/);
  331. }
  332.  
  333. =item splitpath (override)
  334.  
  335. Splits using VMS syntax.
  336.  
  337. =cut
  338.  
  339. sub splitpath {
  340.     my($self,$path) = @_;
  341.     my($dev,$dir,$file) = ('','','');
  342.  
  343.     vmsify($path) =~ /(.+:)?([\[<].*[\]>])?(.*)/s;
  344.     return ($1 || '',$2 || '',$3);
  345. }
  346.  
  347. =item splitdir (override)
  348.  
  349. Split dirspec using VMS syntax.
  350.  
  351. =cut
  352.  
  353. sub splitdir {
  354.     my($self,$dirspec) = @_;
  355.     $dirspec =~ s/\]\[//g;  $dirspec =~ s/\-\-/-.-/g;
  356.     $dirspec = "[$dirspec]" unless $dirspec =~ /[\[<]/; # make legal
  357.     my(@dirs) = split('\.', vmspath($dirspec));
  358.     $dirs[0] =~ s/^[\[<]//s;  $dirs[-1] =~ s/[\]>]\Z(?!\n)//s;
  359.     @dirs;
  360. }
  361.  
  362.  
  363. =item catpath (override)
  364.  
  365. Construct a complete filespec using VMS syntax
  366.  
  367. =cut
  368.  
  369. sub catpath {
  370.     my($self,$dev,$dir,$file) = @_;
  371.     if ($dev =~ m|^/+([^/]+)|) { $dev = "$1:"; }
  372.     else { $dev .= ':' unless $dev eq '' or $dev =~ /:\Z(?!\n)/; }
  373.     if (length($dev) or length($dir)) {
  374.       $dir = "[$dir]" unless $dir =~ /[\[<\/]/;
  375.       $dir = vmspath($dir);
  376.     }
  377.     "$dev$dir$file";
  378. }
  379.  
  380. =item abs2rel (override)
  381.  
  382. Use VMS syntax when converting filespecs.
  383.  
  384. =cut
  385.  
  386. sub abs2rel {
  387.     my $self = shift;
  388.  
  389.     return vmspath(File::Spec::Unix::abs2rel( $self, @_ ))
  390.         if ( join( '', @_ ) =~ m{/} ) ;
  391.  
  392.     my($path,$base) = @_;
  393.  
  394.     # Note: we use '/' to glue things together here, then let canonpath()
  395.     # clean them up at the end.
  396.  
  397.     # Clean up $path
  398.     if ( ! $self->file_name_is_absolute( $path ) ) {
  399.         $path = $self->rel2abs( $path ) ;
  400.     }
  401.     else {
  402.         $path = $self->canonpath( $path ) ;
  403.     }
  404.  
  405.     # Figure out the effective $base and clean it up.
  406.     if ( !defined( $base ) || $base eq '' ) {
  407.         $base = cwd() ;
  408.     }
  409.     elsif ( ! $self->file_name_is_absolute( $base ) ) {
  410.         $base = $self->rel2abs( $base ) ;
  411.     }
  412.     else {
  413.         $base = $self->canonpath( $base ) ;
  414.     }
  415.  
  416.     # Split up paths
  417.     my ( $path_directories, $path_file ) =
  418.         ($self->splitpath( $path, 1 ))[1,2] ;
  419.  
  420.     $path_directories = $1
  421.         if $path_directories =~ /^\[(.*)\]\Z(?!\n)/s ;
  422.  
  423.     my $base_directories = ($self->splitpath( $base, 1 ))[1] ;
  424.  
  425.     $base_directories = $1
  426.         if $base_directories =~ /^\[(.*)\]\Z(?!\n)/s ;
  427.  
  428.     # Now, remove all leading components that are the same
  429.     my @pathchunks = $self->splitdir( $path_directories );
  430.     my @basechunks = $self->splitdir( $base_directories );
  431.  
  432.     while ( @pathchunks && 
  433.             @basechunks && 
  434.             lc( $pathchunks[0] ) eq lc( $basechunks[0] ) 
  435.           ) {
  436.         shift @pathchunks ;
  437.         shift @basechunks ;
  438.     }
  439.  
  440.     # @basechunks now contains the directories to climb out of,
  441.     # @pathchunks now has the directories to descend in to.
  442.     $path_directories = '-.' x @basechunks . join( '.', @pathchunks ) ;
  443.     $path_directories =~ s{\.\Z(?!\n)}{} ;
  444.     return $self->canonpath( $self->catpath( '', $path_directories, $path_file ) ) ;
  445. }
  446.  
  447.  
  448. =item rel2abs (override)
  449.  
  450. Use VMS syntax when converting filespecs.
  451.  
  452. =cut
  453.  
  454. sub rel2abs {
  455.     my $self = shift ;
  456.     return vmspath(File::Spec::Unix::rel2abs( $self, @_ ))
  457.         if ( join( '', @_ ) =~ m{/} ) ;
  458.  
  459.     my ($path,$base ) = @_;
  460.     # Clean up and split up $path
  461.     if ( ! $self->file_name_is_absolute( $path ) ) {
  462.         # Figure out the effective $base and clean it up.
  463.         if ( !defined( $base ) || $base eq '' ) {
  464.             $base = cwd() ;
  465.         }
  466.         elsif ( ! $self->file_name_is_absolute( $base ) ) {
  467.             $base = $self->rel2abs( $base ) ;
  468.         }
  469.         else {
  470.             $base = $self->canonpath( $base ) ;
  471.         }
  472.  
  473.         # Split up paths
  474.         my ( $path_directories, $path_file ) =
  475.             ($self->splitpath( $path ))[1,2] ;
  476.  
  477.         my ( $base_volume, $base_directories ) =
  478.             $self->splitpath( $base ) ;
  479.  
  480.         $path_directories = '' if $path_directories eq '[]' ||
  481.                                   $path_directories eq '<>';
  482.         my $sep = '' ;
  483.         $sep = '.'
  484.             if ( $base_directories =~ m{[^.\]>]\Z(?!\n)} &&
  485.                  $path_directories =~ m{^[^.\[<]}s
  486.             ) ;
  487.         $base_directories = "$base_directories$sep$path_directories";
  488.         $base_directories =~ s{\.?[\]>][\[<]\.?}{.};
  489.  
  490.         $path = $self->catpath( $base_volume, $base_directories, $path_file );
  491.    }
  492.  
  493.     return $self->canonpath( $path ) ;
  494. }
  495.  
  496.  
  497. =back
  498.  
  499. =head1 SEE ALSO
  500.  
  501. L<File::Spec>
  502.  
  503. =cut
  504.  
  505. 1;
  506.