view release on metacpan or  search on metacpan

inc/bundle/File/Spec/VMS.pm  view on Meta::CPAN

        # If the spath ends with a directory delimiter and the file is bare,
        # then just concatenate them.
	if ($spath =~ /^(?<!\^)[^\)\]\/:>]+\)\Z(?!\n)/s && basename($file) eq $file) {
	    $rslt = "$spath$file";
	} else {
           $rslt = unixify($spath);
           $rslt .= (defined($rslt) && length($rslt) ? '/' : '') . unixify($file);
           $rslt = vmsify($rslt) unless $unix_rpt;
	}
    }
    else {
        # Only passed a single file?
        my $xfile = (defined($file) && length($file)) ? $file : '';

        $rslt = $unix_rpt ? $xfile : vmsify($xfile);
    }
    return $self->canonpath($rslt) unless $unix_rpt;

    # In Unix report mode, do not strip off redundant path information.
    return $rslt;
}


=item curdir (override)

Returns a string representation of the current directory: '[]' or '.'

=cut

sub curdir {
    my $self = shift @_;
    return '.' if ($self->_unix_rpt);
    return '[]';
}

=item devnull (override)

Returns a string representation of the null device: '_NLA0:' or '/dev/null'

=cut

sub devnull {
    my $self = shift @_;
    return '/dev/null' if ($self->_unix_rpt);
    return "_NLA0:";
}

=item rootdir (override)

Returns a string representation of the root directory: 'SYS$DISK:[000000]'
or '/'

=cut

sub rootdir {
    my $self = shift @_;
    if ($self->_unix_rpt) {
       # Root may exist, try it first.
       my $try = '/';
       my ($dev1, $ino1) = stat('/');
       my ($dev2, $ino2) = stat('.');

       # Perl falls back to '.' if it can not determine '/'
       if (($dev1 != $dev2) || ($ino1 != $ino2)) {
           return $try;
       }
       # Fall back to UNIX format sys$disk.
       return '/sys$disk/';
    }
    return 'SYS$DISK:[000000]';
}

=item tmpdir (override)

Returns a string representation of the first writable directory
from the following list or '' if none are writable:

    /tmp if C<DECC$FILENAME_UNIX_REPORT> is enabled.
    sys$scratch:
    $ENV{TMPDIR}

If running under taint mode, and if $ENV{TMPDIR}
is tainted, it is not used.

=cut

sub tmpdir {
    my $self = shift @_;
    my $tmpdir = $self->_cached_tmpdir('TMPDIR');
    return $tmpdir if defined $tmpdir;
    if ($self->_unix_rpt) {
        $tmpdir = $self->_tmpdir('/tmp', '/sys$scratch', $ENV{TMPDIR});
    }
    else {
        $tmpdir = $self->_tmpdir( 'sys$scratch:', $ENV{TMPDIR} );
    }
    $self->_cache_tmpdir($tmpdir, 'TMPDIR');
}

=item updir (override)

Returns a string representation of the parent directory: '[-]' or '..'

=cut

sub updir {
    my $self = shift @_;
    return '..' if ($self->_unix_rpt);
    return '[-]';
}

=item case_tolerant (override)

VMS file specification syntax is case-tolerant.

=cut

sub case_tolerant {
    return 1;
}