PageRenderTime 53ms CodeModel.GetById 21ms RepoModel.GetById 1ms app.codeStats 0ms

/Builder/Perl/File/Spec/VMS.pm

http://corejs.codeplex.com
Perl | 1141 lines | 763 code | 214 blank | 164 comment | 279 complexity | f42e06875283ba00cae33315ab025d8a MD5 | raw file
Possible License(s): BSD-3-Clause, GPL-2.0, LGPL-2.1, GPL-3.0, AGPL-3.0, Unlicense, AGPL-1.0, LGPL-2.0, LGPL-3.0
  1. package File::Spec::VMS;
  2. use strict;
  3. use vars qw(@ISA $VERSION);
  4. require File::Spec::Unix;
  5. $VERSION = '3.34';
  6. $VERSION = eval $VERSION;
  7. @ISA = qw(File::Spec::Unix);
  8. use File::Basename;
  9. use VMS::Filespec;
  10. =head1 NAME
  11. File::Spec::VMS - methods for VMS file specs
  12. =head1 SYNOPSIS
  13. require File::Spec::VMS; # Done internally by File::Spec if needed
  14. =head1 DESCRIPTION
  15. See File::Spec::Unix for a documentation of the methods provided
  16. there. This package overrides the implementation of these methods, not
  17. the semantics.
  18. The default behavior is to allow either VMS or Unix syntax on input and to
  19. return VMS syntax on output, even when Unix syntax was given on input.
  20. When used with a Perl of version 5.10 or greater and a CRTL possessing the
  21. relevant capabilities, override behavior depends on the CRTL features
  22. C<DECC$FILENAME_UNIX_REPORT> and C<DECC$EFS_CHARSET>. When the
  23. C<DECC$EFS_CHARSET> feature is enabled and the input parameters are clearly
  24. in Unix syntax, the output will be in Unix syntax. If
  25. C<DECC$FILENAME_UNIX_REPORT> is enabled and the output syntax cannot be
  26. determined from the input syntax, the output will be in Unix syntax.
  27. =over 4
  28. =cut
  29. # Need to look up the feature settings. The preferred way is to use the
  30. # VMS::Feature module, but that may not be available to dual life modules.
  31. my $use_feature;
  32. BEGIN {
  33. if (eval { local $SIG{__DIE__}; require VMS::Feature; }) {
  34. $use_feature = 1;
  35. }
  36. }
  37. # Need to look up the UNIX report mode. This may become a dynamic mode
  38. # in the future.
  39. sub _unix_rpt {
  40. my $unix_rpt;
  41. if ($use_feature) {
  42. $unix_rpt = VMS::Feature::current("filename_unix_report");
  43. } else {
  44. my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || '';
  45. $unix_rpt = $env_unix_rpt =~ /^[ET1]/i;
  46. }
  47. return $unix_rpt;
  48. }
  49. # Need to look up the EFS character set mode. This may become a dynamic
  50. # mode in the future.
  51. sub _efs {
  52. my $efs;
  53. if ($use_feature) {
  54. $efs = VMS::Feature::current("efs_charset");
  55. } else {
  56. my $env_efs = $ENV{'DECC$EFS_CHARSET'} || '';
  57. $efs = $env_efs =~ /^[ET1]/i;
  58. }
  59. return $efs;
  60. }
  61. =item canonpath (override)
  62. Removes redundant portions of file specifications according to the syntax
  63. detected.
  64. =cut
  65. sub canonpath {
  66. my($self,$path) = @_;
  67. return undef unless defined $path;
  68. my $efs = $self->_efs;
  69. if ($path =~ m|/|) { # Fake Unix
  70. my $pathify = $path =~ m|/\Z(?!\n)|;
  71. $path = $self->SUPER::canonpath($path);
  72. # Do not convert to VMS when EFS character sets are in use
  73. return $path if $efs;
  74. if ($pathify) { return vmspath($path); }
  75. else { return vmsify($path); }
  76. }
  77. else {
  78. #FIXME - efs parsing has different rules. Characters in a VMS filespec
  79. # are only delimiters if not preceded by '^';
  80. $path =~ tr/<>/[]/; # < and > ==> [ and ]
  81. $path =~ s/\]\[\./\.\]\[/g; # ][. ==> .][
  82. $path =~ s/\[000000\.\]\[/\[/g; # [000000.][ ==> [
  83. $path =~ s/\[000000\./\[/g; # [000000. ==> [
  84. $path =~ s/\.\]\[000000\]/\]/g; # .][000000] ==> ]
  85. $path =~ s/\.\]\[/\./g; # foo.][bar ==> foo.bar
  86. 1 while ($path =~ s/([\[\.])(-+)\.(-+)([\.\]])/$1$2$3$4/);
  87. # That loop does the following
  88. # with any amount of dashes:
  89. # .-.-. ==> .--.
  90. # [-.-. ==> [--.
  91. # .-.-] ==> .--]
  92. # [-.-] ==> [--]
  93. 1 while ($path =~ s/([\[\.])[^\]\.]+\.-(-+)([\]\.])/$1$2$3/);
  94. # That loop does the following
  95. # with any amount (minimum 2)
  96. # of dashes:
  97. # .foo.--. ==> .-.
  98. # .foo.--] ==> .-]
  99. # [foo.--. ==> [-.
  100. # [foo.--] ==> [-]
  101. #
  102. # And then, the remaining cases
  103. $path =~ s/\[\.-/[-/; # [.- ==> [-
  104. $path =~ s/\.[^\]\.]+\.-\./\./g; # .foo.-. ==> .
  105. $path =~ s/\[[^\]\.]+\.-\./\[/g; # [foo.-. ==> [
  106. $path =~ s/\.[^\]\.]+\.-\]/\]/g; # .foo.-] ==> ]
  107. $path =~ s/\[[^\]\.]+\.-\]/\[000000\]/g;# [foo.-] ==> [000000]
  108. $path =~ s/\[\]// unless $path eq '[]'; # [] ==>
  109. return $path;
  110. }
  111. }
  112. =item catdir (override)
  113. Concatenates a list of file specifications, and returns the result as a
  114. directory specification. No check is made for "impossible"
  115. cases (e.g. elements other than the first being absolute filespecs).
  116. =cut
  117. sub catdir {
  118. my $self = shift;
  119. my $dir = pop;
  120. my $efs = $self->_efs;
  121. my $unix_rpt = $self->_unix_rpt;
  122. my @dirs = grep {defined() && length()} @_;
  123. if ($efs) {
  124. # Legacy mode removes blank entries.
  125. # But that breaks existing generic perl code that
  126. # uses a blank path at the beginning of the array
  127. # to indicate an absolute path.
  128. # So put it back if found.
  129. if (@_) {
  130. if ($_[0] eq '') {
  131. unshift @dirs, '';
  132. }
  133. }
  134. }
  135. my $rslt;
  136. if (@dirs) {
  137. my $path = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs));
  138. my ($spath,$sdir) = ($path,$dir);
  139. if ($efs) {
  140. # Extended character set in use, go into DWIM mode.
  141. # Now we need to identify what the directory is in
  142. # of the specification in order to merge them.
  143. my $path_unix = 0;
  144. $path_unix = 1 if ($path =~ m#/#);
  145. $path_unix = 1 if ($path =~ /^\.\.?$/);
  146. my $path_vms = 0;
  147. $path_vms = 1 if ($path =~ m#(?<!\^)[\[<\]:]#);
  148. $path_vms = 1 if ($path =~ /^--?$/);
  149. my $dir_unix = 0;
  150. $dir_unix = 1 if ($dir =~ m#/#);
  151. $dir_unix = 1 if ($dir =~ /^\.\.?$/);
  152. my $dir_vms = 0;
  153. $dir_vms = 1 if ($dir =~ m#(?<!\^)[\[<\]:]#);
  154. $dir_vms = 1 if ($dir =~ /^--?$/);
  155. my $unix_mode = 0;
  156. if (($path_unix != $dir_unix) && ($path_vms != $dir_vms)) {
  157. # Ambiguous, so if in $unix_rpt mode then assume UNIX.
  158. $unix_mode = 1 if $unix_rpt;
  159. } else {
  160. $unix_mode = 1 if (!$path_vms && !$dir_vms && $unix_rpt);
  161. $unix_mode = 1 if ($path_unix || $dir_unix);
  162. }
  163. if ($unix_mode) {
  164. # Fix up mixed syntax input as good as possible - GIGO
  165. $path = unixify($path) if $path_vms;
  166. $dir = unixify($dir) if $dir_vms;
  167. $rslt = $path;
  168. # Append a path delimiter
  169. $rslt .= '/' unless ($rslt =~ m#/$#);
  170. $rslt .= $dir;
  171. return $self->SUPER::canonpath($rslt);
  172. } else {
  173. #with <> possible instead of [.
  174. # Normalize the brackets
  175. # Fixme - need to not switch when preceded by ^.
  176. $path =~ s/</\[/g;
  177. $path =~ s/>/\]/g;
  178. $dir =~ s/</\[/g;
  179. $dir =~ s/>/\]/g;
  180. # Fix up mixed syntax input as good as possible - GIGO
  181. $path = vmsify($path) if $path_unix;
  182. $dir = vmsify($dir) if $dir_unix;
  183. #Possible path values: foo: [.foo] [foo] foo, and $(foo)
  184. #or starting with '-', or foo.dir
  185. #If path is foo, it needs to be converted to [.foo]
  186. # Fix up a bare path name.
  187. unless ($path_vms) {
  188. $path =~ s/\.dir\Z(?!\n)//i;
  189. if (($path ne '') && ($path !~ /^-/)) {
  190. # Non blank and not prefixed with '-', add a dot
  191. $path = '[.' . $path;
  192. } else {
  193. # Just start a directory.
  194. $path = '[' . $path;
  195. }
  196. } else {
  197. $path =~ s/\]$//;
  198. }
  199. #Possible dir values: [.dir] dir and $(foo)
  200. # No punctuation may have a trailing .dir
  201. unless ($dir_vms) {
  202. $dir =~ s/\.dir\Z(?!\n)//i;
  203. } else {
  204. #strip off the brackets
  205. $dir =~ s/^\[//;
  206. $dir =~ s/\]$//;
  207. }
  208. #strip off the leading dot if present.
  209. $dir =~ s/^\.//;
  210. # Now put the specifications together.
  211. if ($dir ne '') {
  212. # Add a separator unless this is an absolute path
  213. $path .= '.' if ($path ne '[');
  214. $rslt = $path . $dir . ']';
  215. } else {
  216. $rslt = $path . ']';
  217. }
  218. }
  219. } else {
  220. # Traditional ODS-2 mode.
  221. $spath =~ s/\.dir\Z(?!\n)//i; $sdir =~ s/\.dir\Z(?!\n)//i;
  222. $sdir = $self->eliminate_macros($sdir)
  223. unless $sdir =~ /^[\w\-]+\Z(?!\n)/s;
  224. $rslt = $self->fixpath($self->eliminate_macros($spath)."/$sdir",1);
  225. # Special case for VMS absolute directory specs: these will have
  226. # had device prepended during trip through Unix syntax in
  227. # eliminate_macros(), since Unix syntax has no way to express
  228. # "absolute from the top of this device's directory tree".
  229. if ($spath =~ /^[\[<][^.\-]/s) { $rslt =~ s/^[^\[<]+//s; }
  230. }
  231. } else {
  232. # Single directory, just make sure it is in directory format
  233. # Return an empty string on null input, and pass through macros.
  234. if (not defined $dir or not length $dir) { $rslt = ''; }
  235. elsif ($dir =~ /^\$\([^\)]+\)\Z(?!\n)/s) {
  236. $rslt = $dir;
  237. } else {
  238. my $unix_mode = 0;
  239. if ($efs) {
  240. my $dir_unix = 0;
  241. $dir_unix = 1 if ($dir =~ m#/#);
  242. $dir_unix = 1 if ($dir =~ /^\.\.?$/);
  243. my $dir_vms = 0;
  244. $dir_vms = 1 if ($dir =~ m#(?<!\^)[\[<\]:]#);
  245. $dir_vms = 1 if ($dir =~ /^--?$/);
  246. if ($dir_vms == $dir_unix) {
  247. # Ambiguous, so if in $unix_rpt mode then assume UNIX.
  248. $unix_mode = 1 if $unix_rpt;
  249. } else {
  250. $unix_mode = 1 if $dir_unix;
  251. }
  252. }
  253. if ($unix_mode) {
  254. return $dir;
  255. } else {
  256. # For VMS, force it to be in directory format
  257. $rslt = vmspath($dir);
  258. }
  259. }
  260. }
  261. return $self->canonpath($rslt);
  262. }
  263. =item catfile (override)
  264. Concatenates a list of directory specifications with a filename specification
  265. to build a path.
  266. =cut
  267. sub catfile {
  268. my $self = shift;
  269. my $tfile = pop();
  270. my $file = $self->canonpath($tfile);
  271. my @files = grep {defined() && length()} @_;
  272. my $efs = $self->_efs;
  273. my $unix_rpt = $self->_unix_rpt;
  274. # Assume VMS mode
  275. my $unix_mode = 0;
  276. my $file_unix = 0;
  277. my $file_vms = 0;
  278. if ($efs) {
  279. # Now we need to identify format the file is in
  280. # of the specification in order to merge them.
  281. $file_unix = 1 if ($tfile =~ m#/#);
  282. $file_unix = 1 if ($tfile =~ /^\.\.?$/);
  283. $file_vms = 1 if ($tfile =~ m#(?<!\^)[\[<\]:]#);
  284. $file_vms = 1 if ($tfile =~ /^--?$/);
  285. # We may know for sure what the format is.
  286. if (($file_unix != $file_vms)) {
  287. $unix_mode = 1 if ($file_unix && $unix_rpt);
  288. }
  289. }
  290. my $rslt;
  291. if (@files) {
  292. # concatenate the directories.
  293. my $path;
  294. if (@files == 1) {
  295. $path = $files[0];
  296. } else {
  297. if ($file_vms) {
  298. # We need to make sure this is in VMS mode to avoid doing
  299. # both a vmsify and unixfy on the same path, as that may
  300. # lose significant data.
  301. my $i = @files - 1;
  302. my $tdir = $files[$i];
  303. my $tdir_vms = 0;
  304. my $tdir_unix = 0;
  305. $tdir_vms = 1 if ($tdir =~ m#(?<!\^)[\[<\]:]#);
  306. $tdir_unix = 1 if ($tdir =~ m#/#);
  307. $tdir_unix = 1 if ($tdir =~ /^\.\.?$/);
  308. if (!$tdir_vms) {
  309. if ($tdir_unix) {
  310. $tdir = vmspath($tdir);
  311. } else {
  312. $tdir =~ s/\.dir\Z(?!\n)//i;
  313. $tdir = '[.' . $tdir . ']';
  314. }
  315. $files[$i] = $tdir;
  316. }
  317. }
  318. $path = $self->catdir(@files);
  319. }
  320. my $spath = $path;
  321. # Some thing building a VMS path in pieces may try to pass a
  322. # directory name in filename format, so normalize it.
  323. $spath =~ s/\.dir\Z(?!\n)//i;
  324. # if the spath ends with a directory delimiter and the file is bare,
  325. # then just concat them.
  326. if ($spath =~ /^(?<!\^)[^\)\]\/:>]+\)\Z(?!\n)/s && basename($file) eq $file) {
  327. $rslt = "$spath$file";
  328. } else {
  329. if ($efs) {
  330. # Now we need to identify what the directory is in
  331. # of the specification in order to merge them.
  332. my $spath_unix = 0;
  333. $spath_unix = 1 if ($spath =~ m#/#);
  334. $spath_unix = 1 if ($spath =~ /^\.\.?$/);
  335. my $spath_vms = 0;
  336. $spath_vms = 1 if ($spath =~ m#(?<!\^)[\[<\]:]#);
  337. $spath_vms = 1 if ($spath =~ /^--?$/);
  338. # Assume VMS mode
  339. if (($spath_unix == $spath_vms) &&
  340. ($file_unix == $file_vms)) {
  341. # Ambiguous, so if in $unix_rpt mode then assume UNIX.
  342. $unix_mode = 1 if $unix_rpt;
  343. } else {
  344. $unix_mode = 1
  345. if (($spath_unix || $file_unix) && $unix_rpt);
  346. }
  347. if (!$unix_mode) {
  348. if ($spath_vms) {
  349. $spath = '[' . $spath . ']' if $spath =~ /^-/;
  350. $rslt = vmspath($spath);
  351. } else {
  352. $rslt = '[.' . $spath . ']';
  353. }
  354. $file = vmsify($file) if ($file_unix);
  355. } else {
  356. $spath = unixify($spath) if ($spath_vms);
  357. $rslt = $spath;
  358. $file = unixify($file) if ($file_vms);
  359. # Unix merge may need a directory delimiter.
  360. # A null path indicates root on Unix.
  361. $rslt .= '/' unless ($rslt =~ m#/$#);
  362. }
  363. $rslt .= $file;
  364. $rslt =~ s/\]\[//;
  365. } else {
  366. # Traditional VMS Perl mode expects that this is done.
  367. # Note for future maintainers:
  368. # This is left here for compatibility with perl scripts
  369. # that have come to expect this behavior, even though
  370. # usually the Perl scripts ported to VMS have to be
  371. # patched because of it changing Unix syntax file
  372. # to VMS format.
  373. $rslt = $self->eliminate_macros($spath);
  374. $rslt = vmsify($rslt.((defined $rslt) &&
  375. ($rslt ne '') ? '/' : '').unixify($file));
  376. }
  377. }
  378. }
  379. else {
  380. # Only passed a single file?
  381. my $xfile = $file;
  382. # Traditional VMS perl expects this conversion.
  383. $xfile = vmsify($file) unless ($efs);
  384. $rslt = (defined($file) && length($file)) ? $xfile : '';
  385. }
  386. return $self->canonpath($rslt) unless $unix_rpt;
  387. # In Unix report mode, do not strip off redundant path information.
  388. return $rslt;
  389. }
  390. =item curdir (override)
  391. Returns a string representation of the current directory: '[]' or '.'
  392. =cut
  393. sub curdir {
  394. my $self = shift @_;
  395. return '.' if ($self->_unix_rpt);
  396. return '[]';
  397. }
  398. =item devnull (override)
  399. Returns a string representation of the null device: '_NLA0:' or '/dev/null'
  400. =cut
  401. sub devnull {
  402. my $self = shift @_;
  403. return '/dev/null' if ($self->_unix_rpt);
  404. return "_NLA0:";
  405. }
  406. =item rootdir (override)
  407. Returns a string representation of the root directory: 'SYS$DISK:[000000]'
  408. or '/'
  409. =cut
  410. sub rootdir {
  411. my $self = shift @_;
  412. if ($self->_unix_rpt) {
  413. # Root may exist, try it first.
  414. my $try = '/';
  415. my ($dev1, $ino1) = stat('/');
  416. my ($dev2, $ino2) = stat('.');
  417. # Perl falls back to '.' if it can not determine '/'
  418. if (($dev1 != $dev2) || ($ino1 != $ino2)) {
  419. return $try;
  420. }
  421. # Fall back to UNIX format sys$disk.
  422. return '/sys$disk/';
  423. }
  424. return 'SYS$DISK:[000000]';
  425. }
  426. =item tmpdir (override)
  427. Returns a string representation of the first writable directory
  428. from the following list or '' if none are writable:
  429. /tmp if C<DECC$FILENAME_UNIX_REPORT> is enabled.
  430. sys$scratch:
  431. $ENV{TMPDIR}
  432. Since perl 5.8.0, if running under taint mode, and if $ENV{TMPDIR}
  433. is tainted, it is not used.
  434. =cut
  435. my $tmpdir;
  436. sub tmpdir {
  437. my $self = shift @_;
  438. return $tmpdir if defined $tmpdir;
  439. if ($self->_unix_rpt) {
  440. $tmpdir = $self->_tmpdir('/tmp', '/sys$scratch', $ENV{TMPDIR});
  441. return $tmpdir;
  442. }
  443. $tmpdir = $self->_tmpdir( 'sys$scratch:', $ENV{TMPDIR} );
  444. }
  445. =item updir (override)
  446. Returns a string representation of the parent directory: '[-]' or '..'
  447. =cut
  448. sub updir {
  449. my $self = shift @_;
  450. return '..' if ($self->_unix_rpt);
  451. return '[-]';
  452. }
  453. =item case_tolerant (override)
  454. VMS file specification syntax is case-tolerant.
  455. =cut
  456. sub case_tolerant {
  457. return 1;
  458. }
  459. =item path (override)
  460. Translate logical name DCL$PATH as a searchlist, rather than trying
  461. to C<split> string value of C<$ENV{'PATH'}>.
  462. =cut
  463. sub path {
  464. my (@dirs,$dir,$i);
  465. while ($dir = $ENV{'DCL$PATH;' . $i++}) { push(@dirs,$dir); }
  466. return @dirs;
  467. }
  468. =item file_name_is_absolute (override)
  469. Checks for VMS directory spec as well as Unix separators.
  470. =cut
  471. sub file_name_is_absolute {
  472. my ($self,$file) = @_;
  473. # If it's a logical name, expand it.
  474. $file = $ENV{$file} while $file =~ /^[\w\$\-]+\Z(?!\n)/s && $ENV{$file};
  475. return scalar($file =~ m!^/!s ||
  476. $file =~ m![<\[][^.\-\]>]! ||
  477. $file =~ /:[^<\[]/);
  478. }
  479. =item splitpath (override)
  480. ($volume,$directories,$file) = File::Spec->splitpath( $path );
  481. ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file );
  482. Passing a true value for C<$no_file> indicates that the path being
  483. split only contains directory components, even on systems where you
  484. can usually (when not supporting a foreign syntax) tell the difference
  485. between directories and files at a glance.
  486. =cut
  487. sub splitpath {
  488. my($self,$path, $nofile) = @_;
  489. my($dev,$dir,$file) = ('','','');
  490. my $efs = $self->_efs;
  491. my $vmsify_path = vmsify($path);
  492. if ($efs) {
  493. my $path_vms = 0;
  494. $path_vms = 1 if ($path =~ m#(?<!\^)[\[<\]:]#);
  495. $path_vms = 1 if ($path =~ /^--?$/);
  496. if (!$path_vms) {
  497. return $self->SUPER::splitpath($path, $nofile);
  498. }
  499. $vmsify_path = $path;
  500. }
  501. if ( $nofile ) {
  502. #vmsify('d1/d2/d3') returns '[.d1.d2]d3'
  503. #vmsify('/d1/d2/d3') returns 'd1:[d2]d3'
  504. if( $vmsify_path =~ /(.*)\](.+)/ ){
  505. $vmsify_path = $1.'.'.$2.']';
  506. }
  507. $vmsify_path =~ /(.+:)?(.*)/s;
  508. $dir = defined $2 ? $2 : ''; # dir can be '0'
  509. return ($1 || '',$dir,$file);
  510. }
  511. else {
  512. $vmsify_path =~ /(.+:)?([\[<].*[\]>])?(.*)/s;
  513. return ($1 || '',$2 || '',$3);
  514. }
  515. }
  516. =item splitdir (override)
  517. Split a directory specification into the components.
  518. =cut
  519. sub splitdir {
  520. my($self,$dirspec) = @_;
  521. my @dirs = ();
  522. return @dirs if ( (!defined $dirspec) || ('' eq $dirspec) );
  523. my $efs = $self->_efs;
  524. my $dir_unix = 0;
  525. $dir_unix = 1 if ($dirspec =~ m#/#);
  526. $dir_unix = 1 if ($dirspec =~ /^\.\.?$/);
  527. # Unix filespecs in EFS mode handled by Unix routines.
  528. if ($efs && $dir_unix) {
  529. return $self->SUPER::splitdir($dirspec);
  530. }
  531. # FIX ME, only split for VMS delimiters not prefixed with '^'.
  532. $dirspec =~ tr/<>/[]/; # < and > ==> [ and ]
  533. $dirspec =~ s/\]\[\./\.\]\[/g; # ][. ==> .][
  534. $dirspec =~ s/\[000000\.\]\[/\[/g; # [000000.][ ==> [
  535. $dirspec =~ s/\[000000\./\[/g; # [000000. ==> [
  536. $dirspec =~ s/\.\]\[000000\]/\]/g; # .][000000] ==> ]
  537. $dirspec =~ s/\.\]\[/\./g; # foo.][bar ==> foo.bar
  538. while ($dirspec =~ s/(^|[\[\<\.])\-(\-+)($|[\]\>\.])/$1-.$2$3/g) {}
  539. # That loop does the following
  540. # with any amount of dashes:
  541. # .--. ==> .-.-.
  542. # [--. ==> [-.-.
  543. # .--] ==> .-.-]
  544. # [--] ==> [-.-]
  545. $dirspec = "[$dirspec]" unless $dirspec =~ /(?<!\^)[\[<]/; # make legal
  546. $dirspec =~ s/^(\[|<)\./$1/;
  547. @dirs = split /(?<!\^)\./, vmspath($dirspec);
  548. $dirs[0] =~ s/^[\[<]//s; $dirs[-1] =~ s/[\]>]\Z(?!\n)//s;
  549. @dirs;
  550. }
  551. =item catpath (override)
  552. Construct a complete filespec.
  553. =cut
  554. sub catpath {
  555. my($self,$dev,$dir,$file) = @_;
  556. my $efs = $self->_efs;
  557. my $unix_rpt = $self->_unix_rpt;
  558. my $unix_mode = 0;
  559. my $dir_unix = 0;
  560. $dir_unix = 1 if ($dir =~ m#/#);
  561. $dir_unix = 1 if ($dir =~ /^\.\.?$/);
  562. my $dir_vms = 0;
  563. $dir_vms = 1 if ($dir =~ m#(?<!\^)[\[<\]:]#);
  564. $dir_vms = 1 if ($dir =~ /^--?$/);
  565. if ($efs && (length($dev) == 0)) {
  566. if ($dir_unix == $dir_vms) {
  567. $unix_mode = $unix_rpt;
  568. } else {
  569. $unix_mode = $dir_unix;
  570. }
  571. }
  572. # We look for a volume in $dev, then in $dir, but not both
  573. # but only if using VMS syntax.
  574. if (!$unix_mode) {
  575. $dir = vmspath($dir) if $dir_unix;
  576. my ($dir_volume, $dir_dir, $dir_file) = $self->splitpath($dir);
  577. $dev = $dir_volume unless length $dev;
  578. $dir = length $dir_file ? $self->catfile($dir_dir, $dir_file) :
  579. $dir_dir;
  580. }
  581. if ($dev =~ m|^/+([^/]+)|) { $dev = "$1:"; }
  582. else { $dev .= ':' unless $dev eq '' or $dev =~ /:\Z(?!\n)/; }
  583. if (length($dev) or length($dir)) {
  584. if ($efs) {
  585. if ($unix_mode) {
  586. $dir .= '/' unless ($dir =~ m#/$#);
  587. } else {
  588. $dir = vmspath($dir) if (($dir =~ m#/#) || ($dir =~ /^\.\.?$/));
  589. $dir = "[$dir]" unless $dir =~ /^[\[<]/;
  590. }
  591. } else {
  592. $dir = "[$dir]" unless $dir =~ /[\[<\/]/;
  593. $dir = vmspath($dir);
  594. }
  595. }
  596. $dir = '' if length($dev) && ($dir eq '[]' || $dir eq '<>');
  597. "$dev$dir$file";
  598. }
  599. =item abs2rel (override)
  600. Attempt to convert a file specification to a relative specification.
  601. On a system with volumes, like VMS, this may not be possible.
  602. =cut
  603. sub abs2rel {
  604. my $self = shift;
  605. my($path,$base) = @_;
  606. my $efs = $self->_efs;
  607. my $unix_rpt = $self->_unix_rpt;
  608. # We need to identify what the directory is in
  609. # of the specification in order to process them
  610. my $path_unix = 0;
  611. $path_unix = 1 if ($path =~ m#/#);
  612. $path_unix = 1 if ($path =~ /^\.\.?$/);
  613. my $path_vms = 0;
  614. $path_vms = 1 if ($path =~ m#(?<!\^)[\[<\]:]#);
  615. $path_vms = 1 if ($path =~ /^--?$/);
  616. my $unix_mode = 0;
  617. if ($path_vms == $path_unix) {
  618. $unix_mode = $unix_rpt;
  619. } else {
  620. $unix_mode = $path_unix;
  621. }
  622. my $base_unix = 0;
  623. my $base_vms = 0;
  624. if (defined $base) {
  625. $base_unix = 1 if ($base =~ m#/#);
  626. $base_unix = 1 if ($base =~ /^\.\.?$/);
  627. $base_vms = 1 if ($base =~ m#(?<!\^)[\[<\]:]#);
  628. $base_vms = 1 if ($base =~ /^--?$/);
  629. if ($path_vms == $path_unix) {
  630. if ($base_vms == $base_unix) {
  631. $unix_mode = $unix_rpt;
  632. } else {
  633. $unix_mode = $base_unix;
  634. }
  635. } else {
  636. $unix_mode = 0 if $base_vms;
  637. }
  638. }
  639. if ($efs) {
  640. if ($unix_mode) {
  641. # We are UNIX mode.
  642. $base = unixpath($base) if $base_vms;
  643. $base = unixify($path) if $path_vms;
  644. # Here VMS is different, and in order to do this right
  645. # we have to take the realpath for both the path and the base
  646. # so that we can remove the common components.
  647. if ($path =~ m#^/#) {
  648. if (defined $base) {
  649. # For the shorterm, if the starting directories are
  650. # common, remove them.
  651. my $bq = qq($base);
  652. $bq =~ s/\$/\\\$/;
  653. $path =~ s/^$bq//i;
  654. }
  655. return $path;
  656. }
  657. return File::Spec::Unix::abs2rel( $self, $path, $base );
  658. } else {
  659. $base = vmspath($base) if $base_unix;
  660. $path = vmsify($path) if $path_unix;
  661. }
  662. }
  663. unless (defined $base and length $base) {
  664. $base = $self->_cwd();
  665. if ($efs) {
  666. $base_unix = 1 if ($base =~ m#/#);
  667. $base_unix = 1 if ($base =~ /^\.\.?$/);
  668. $base = vmspath($base) if $base_unix;
  669. }
  670. }
  671. for ($path, $base) { $_ = $self->canonpath($_) }
  672. # Are we even starting $path on the same (node::)device as $base? Note that
  673. # logical paths or nodename differences may be on the "same device"
  674. # but the comparison that ignores device differences so as to concatenate
  675. # [---] up directory specs is not even a good idea in cases where there is
  676. # a logical path difference between $path and $base nodename and/or device.
  677. # Hence we fall back to returning the absolute $path spec
  678. # if there is a case blind device (or node) difference of any sort
  679. # and we do not even try to call $parse() or consult %ENV for $trnlnm()
  680. # (this module needs to run on non VMS platforms after all).
  681. my ($path_volume, $path_directories, $path_file) = $self->splitpath($path);
  682. my ($base_volume, $base_directories, $base_file) = $self->splitpath($base);
  683. return $path unless lc($path_volume) eq lc($base_volume);
  684. for ($path, $base) { $_ = $self->rel2abs($_) }
  685. # Now, remove all leading components that are the same
  686. my @pathchunks = $self->splitdir( $path_directories );
  687. my $pathchunks = @pathchunks;
  688. unshift(@pathchunks,'000000') unless $pathchunks[0] eq '000000';
  689. my @basechunks = $self->splitdir( $base_directories );
  690. my $basechunks = @basechunks;
  691. unshift(@basechunks,'000000') unless $basechunks[0] eq '000000';
  692. while ( @pathchunks &&
  693. @basechunks &&
  694. lc( $pathchunks[0] ) eq lc( $basechunks[0] )
  695. ) {
  696. shift @pathchunks ;
  697. shift @basechunks ;
  698. }
  699. # @basechunks now contains the directories to climb out of,
  700. # @pathchunks now has the directories to descend in to.
  701. if ((@basechunks > 0) || ($basechunks != $pathchunks)) {
  702. $path_directories = join '.', ('-' x @basechunks, @pathchunks) ;
  703. }
  704. else {
  705. $path_directories = join '.', @pathchunks;
  706. }
  707. $path_directories = '['.$path_directories.']';
  708. return $self->canonpath( $self->catpath( '', $path_directories, $path_file ) ) ;
  709. }
  710. =item rel2abs (override)
  711. Return an absolute file specification from a relative one.
  712. =cut
  713. sub rel2abs {
  714. my $self = shift ;
  715. my ($path,$base ) = @_;
  716. return undef unless defined $path;
  717. my $efs = $self->_efs;
  718. my $unix_rpt = $self->_unix_rpt;
  719. # We need to identify what the directory is in
  720. # of the specification in order to process them
  721. my $path_unix = 0;
  722. $path_unix = 1 if ($path =~ m#/#);
  723. $path_unix = 1 if ($path =~ /^\.\.?$/);
  724. my $path_vms = 0;
  725. $path_vms = 1 if ($path =~ m#(?<!\^)[\[<\]:]#);
  726. $path_vms = 1 if ($path =~ /^--?$/);
  727. my $unix_mode = 0;
  728. if ($path_vms == $path_unix) {
  729. $unix_mode = $unix_rpt;
  730. } else {
  731. $unix_mode = $path_unix;
  732. }
  733. my $base_unix = 0;
  734. my $base_vms = 0;
  735. if (defined $base) {
  736. $base_unix = 1 if ($base =~ m#/#);
  737. $base_unix = 1 if ($base =~ /^\.\.?$/);
  738. $base_vms = 1 if ($base =~ m#(?<!\^)[\[<\]:]#);
  739. $base_vms = 1 if ($base =~ /^--?$/);
  740. # If we could not determine the path mode, see if we can find out
  741. # from the base.
  742. if ($path_vms == $path_unix) {
  743. if ($base_vms != $base_unix) {
  744. $unix_mode = $base_unix;
  745. }
  746. }
  747. }
  748. if (!$efs) {
  749. # Legacy behavior, convert to VMS syntax.
  750. $unix_mode = 0;
  751. if (defined $base) {
  752. $base = vmspath($base) if $base =~ m/\//;
  753. }
  754. if ($path =~ m/\//) {
  755. $path = ( -d $path || $path =~ m/\/\z/ # educated guessing about
  756. ? vmspath($path) # whether it's a directory
  757. : vmsify($path) );
  758. }
  759. }
  760. # Clean up and split up $path
  761. if ( ! $self->file_name_is_absolute( $path ) ) {
  762. # Figure out the effective $base and clean it up.
  763. if ( !defined( $base ) || $base eq '' ) {
  764. $base = $self->_cwd;
  765. }
  766. elsif ( ! $self->file_name_is_absolute( $base ) ) {
  767. $base = $self->rel2abs( $base ) ;
  768. }
  769. else {
  770. $base = $self->canonpath( $base ) ;
  771. }
  772. if ($efs) {
  773. # base may have changed, so need to look up format again.
  774. if ($unix_mode) {
  775. $base_vms = 1 if ($base =~ m#(?<!\^)[\[<\]:]#);
  776. $base_vms = 1 if ($base =~ /^--?$/);
  777. $base = unixpath($base) if $base_vms;
  778. $base .= '/' unless ($base =~ m#/$#);
  779. } else {
  780. $base_unix = 1 if ($base =~ m#/#);
  781. $base_unix = 1 if ($base =~ /^\.\.?$/);
  782. $base = vmspath($base) if $base_unix;
  783. }
  784. }
  785. # Split up paths
  786. my ( $path_directories, $path_file ) =
  787. ($self->splitpath( $path ))[1,2] ;
  788. my ( $base_volume, $base_directories ) =
  789. $self->splitpath( $base ) ;
  790. $path_directories = '' if $path_directories eq '[]' ||
  791. $path_directories eq '<>';
  792. my $sep = '' ;
  793. if ($efs) {
  794. # Merge the paths assuming that the base is absolute.
  795. $base_directories = $self->catdir('',
  796. $base_directories,
  797. $path_directories);
  798. } else {
  799. # Legacy behavior assumes VMS only paths
  800. $sep = '.'
  801. if ( $base_directories =~ m{[^.\]>]\Z(?!\n)} &&
  802. $path_directories =~ m{^[^.\[<]}s
  803. ) ;
  804. $base_directories = "$base_directories$sep$path_directories";
  805. $base_directories =~ s{\.?[\]>][\[<]\.?}{.};
  806. }
  807. $path_file = '' if ($path_file eq '.') && $unix_mode;
  808. $path = $self->catpath( $base_volume, $base_directories, $path_file );
  809. }
  810. return $self->canonpath( $path ) ;
  811. }
  812. # eliminate_macros() and fixpath() are MakeMaker-specific methods
  813. # which are used inside catfile() and catdir(). MakeMaker has its own
  814. # copies as of 6.06_03 which are the canonical ones. We leave these
  815. # here, in peace, so that File::Spec continues to work with MakeMakers
  816. # prior to 6.06_03.
  817. #
  818. # Please consider these two methods deprecated. Do not patch them,
  819. # patch the ones in ExtUtils::MM_VMS instead.
  820. #
  821. # Update: MakeMaker 6.48 is still using these routines on VMS.
  822. # so they need to be kept up to date with ExtUtils::MM_VMS.
  823. #
  824. # The traditional VMS mode using ODS-2 disks depends on these routines
  825. # being here. These routines should not be called in when the
  826. # C<DECC$EFS_CHARSET> or C<DECC$FILENAME_UNIX_REPORT> modes are enabled.
  827. sub eliminate_macros {
  828. my($self,$path) = @_;
  829. return '' unless (defined $path) && ($path ne '');
  830. $self = {} unless ref $self;
  831. if ($path =~ /\s/) {
  832. return join ' ', map { $self->eliminate_macros($_) } split /\s+/, $path;
  833. }
  834. my $npath = unixify($path);
  835. # sometimes unixify will return a string with an off-by-one trailing null
  836. $npath =~ s{\0$}{};
  837. my($complex) = 0;
  838. my($head,$macro,$tail);
  839. # perform m##g in scalar context so it acts as an iterator
  840. while ($npath =~ m#(.*?)\$\((\S+?)\)(.*)#gs) {
  841. if (defined $self->{$2}) {
  842. ($head,$macro,$tail) = ($1,$2,$3);
  843. if (ref $self->{$macro}) {
  844. if (ref $self->{$macro} eq 'ARRAY') {
  845. $macro = join ' ', @{$self->{$macro}};
  846. }
  847. else {
  848. print "Note: can't expand macro \$($macro) containing ",ref($self->{$macro}),
  849. "\n\t(using MMK-specific deferred substitutuon; MMS will break)\n";
  850. $macro = "\cB$macro\cB";
  851. $complex = 1;
  852. }
  853. }
  854. else { ($macro = unixify($self->{$macro})) =~ s#/\Z(?!\n)##; }
  855. $npath = "$head$macro$tail";
  856. }
  857. }
  858. if ($complex) { $npath =~ s#\cB(.*?)\cB#\${$1}#gs; }
  859. $npath;
  860. }
  861. # Deprecated. See the note above for eliminate_macros().
  862. # Catchall routine to clean up problem MM[SK]/Make macros. Expands macros
  863. # in any directory specification, in order to avoid juxtaposing two
  864. # VMS-syntax directories when MM[SK] is run. Also expands expressions which
  865. # are all macro, so that we can tell how long the expansion is, and avoid
  866. # overrunning DCL's command buffer when MM[KS] is running.
  867. # fixpath() checks to see whether the result matches the name of a
  868. # directory in the current default directory and returns a directory or
  869. # file specification accordingly. C<$is_dir> can be set to true to
  870. # force fixpath() to consider the path to be a directory or false to force
  871. # it to be a file.
  872. sub fixpath {
  873. my($self,$path,$force_path) = @_;
  874. return '' unless $path;
  875. $self = bless {}, $self unless ref $self;
  876. my($fixedpath,$prefix,$name);
  877. if ($path =~ /\s/) {
  878. return join ' ',
  879. map { $self->fixpath($_,$force_path) }
  880. split /\s+/, $path;
  881. }
  882. if ($path =~ m#^\$\([^\)]+\)\Z(?!\n)#s || $path =~ m#[/:>\]]#) {
  883. if ($force_path or $path =~ /(?:DIR\)|\])\Z(?!\n)/) {
  884. $fixedpath = vmspath($self->eliminate_macros($path));
  885. }
  886. else {
  887. $fixedpath = vmsify($self->eliminate_macros($path));
  888. }
  889. }
  890. elsif ((($prefix,$name) = ($path =~ m#^\$\(([^\)]+)\)(.+)#s)) && $self->{$prefix}) {
  891. my($vmspre) = $self->eliminate_macros("\$($prefix)");
  892. # is it a dir or just a name?
  893. $vmspre = ($vmspre =~ m|/| or $prefix =~ /DIR\Z(?!\n)/) ? vmspath($vmspre) : '';
  894. $fixedpath = ($vmspre ? $vmspre : $self->{$prefix}) . $name;
  895. $fixedpath = vmspath($fixedpath) if $force_path;
  896. }
  897. else {
  898. $fixedpath = $path;
  899. $fixedpath = vmspath($fixedpath) if $force_path;
  900. }
  901. # No hints, so we try to guess
  902. if (!defined($force_path) and $fixedpath !~ /[:>(.\]]/) {
  903. $fixedpath = vmspath($fixedpath) if -d $fixedpath;
  904. }
  905. # Trim off root dirname if it's had other dirs inserted in front of it.
  906. $fixedpath =~ s/\.000000([\]>])/$1/;
  907. # Special case for VMS absolute directory specs: these will have had device
  908. # prepended during trip through Unix syntax in eliminate_macros(), since
  909. # Unix syntax has no way to express "absolute from the top of this device's
  910. # directory tree".
  911. if ($path =~ /^[\[>][^.\-]/) { $fixedpath =~ s/^[^\[<]+//; }
  912. $fixedpath;
  913. }
  914. =back
  915. =head1 COPYRIGHT
  916. Copyright (c) 2004 by the Perl 5 Porters. All rights reserved.
  917. This program is free software; you can redistribute it and/or modify
  918. it under the same terms as Perl itself.
  919. =head1 SEE ALSO
  920. See L<File::Spec> and L<File::Spec::Unix>. This package overrides the
  921. implementation of these methods, not the semantics.
  922. An explanation of VMS file specs can be found at
  923. L<http://h71000.www7.hp.com/doc/731FINAL/4506/4506pro_014.html#apps_locating_naming_files>.
  924. =cut
  925. 1;