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