perl5.git.perl.org Git - perl5.git/blame_incremental

... / ...

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