Cross Reference: OS2.pm
xref
: /
osnet-11
/
usr
/
src
/
cmd
/
perl
/
5.8.4
/
distrib
/
lib
/
File
/
Spec
/
OS2.pm
Home
History
Annotate
Line#
Navigate
Download
Search
only in
./
1
N/A
package
File
::
Spec
::
OS2
;
1
N/A
1
N/A
use
strict
;
1
N/A
use
vars
qw
(@
ISA
$
VERSION
);
1
N/A
require
File
::
Spec
::
Unix
;
1
N/A
1
N/A
$
VERSION
=
'1.2'
;
1
N/A
1
N/A
@
ISA
=
qw
(
File
::
Spec
::
Unix
);
1
N/A
1
N/A
sub
devnull
{
1
N/A
return
"/
dev
/
nul
"
;
1
N/A
}
1
N/A
1
N/A
sub
case_tolerant
{
1
N/A
return
1
;
1
N/A
}
1
N/A
1
N/A
sub
file_name_is_absolute
{
1
N/A
my
($
self
,$
file
) = @_;
1
N/A
return
scalar
($
file
=~ m{^([a-z]:)?[\\/]}
is
);
1
N/A
}
1
N/A
1
N/A
sub
path
{
1
N/A
my
$
path
= $
ENV
{
PATH
};
1
N/A
$
path
=~ s:\\:/:g;
1
N/A
my
@
path
=
split
(
';'
,$
path
);
1
N/A
foreach
(@
path
) { $_ =
'.'
if
$_
eq
''
}
1
N/A
return
@
path
;
1
N/A
}
1
N/A
1
N/A
sub
_cwd
{
1
N/A
# In OS/2 the "require Cwd" is unnecessary bloat.
1
N/A
return
Cwd
::
sys_cwd
();
1
N/A
}
1
N/A
1
N/A
my
$
tmpdir
;
1
N/A
sub
tmpdir
{
1
N/A
return
$
tmpdir
if
defined
$
tmpdir
;
1
N/A
my
$
self
=
shift
;
1
N/A
$
tmpdir
= $
self
->
_tmpdir
( @
ENV
{
qw
(
TMPDIR
TEMP
TMP
)},
1
N/A
'/tmp'
,
1
N/A
'/'
);
1
N/A
}
1
N/A
1
N/A
sub
catdir
{
1
N/A
my
$
self
=
shift
;
1
N/A
my
@
args
= @_;
1
N/A
foreach
(@
args
) {
1
N/A
tr
[\\][/];
1
N/A
# append a backslash to each argument unless it has one there
1
N/A
$_ .=
"/"
unless
m{/$};
1
N/A
}
1
N/A
return
$
self
->
canonpath
(
join
(
''
, @
args
));
1
N/A
}
1
N/A
1
N/A
sub
canonpath
{
1
N/A
my
($
self
,$
path
) = @_;
1
N/A
$
path
=~ s/^([a-z]:)/\l$
1
/s;
1
N/A
$
path
=~ s|\\|/|g;
1
N/A
$
path
=~ s|([^/])/+|$
1
/|g;
# xx////xx ->
xx
/
xx
1
N/A
$
path
=~ s|(/\.)+/|/|g;
# xx/././xx ->
xx
/
xx
1
N/A
$
path
=~ s|^(\./)+(?=[^/])||s;
# ./xx -> xx
1
N/A
$
path
=~ s|/\Z(?!\n)||
1
N/A
unless
$
path
=~ m
#^([a-z]:)?/\Z(?!\n)#si;# xx/ -> xx
1
N/A
$
path
=~ s{^/\.\.$}{/};
# /.. -> /
1
N/A
1
while
$
path
=~ s{^/\.\.}{};
# /../xx -> /xx
1
N/A
return
$
path
;
1
N/A
}
1
N/A
1
N/A
1
N/A
sub
splitpath
{
1
N/A
my
($
self
,$
path
, $
nofile
) = @_;
1
N/A
my
($
volume
,$
directory
,$
file
) = (
''
,
''
,
''
);
1
N/A
if
( $
nofile
) {
1
N/A
$
path
=~
1
N/A
m{^( (?:[a-
zA
-Z]:|(?:\\\\|//)[^\\/]+[\\/][^\\/]+)? )
1
N/A
(.*)
1
N/A
}
xs
;
1
N/A
$
volume
= $
1
;
1
N/A
$
directory
= $
2
;
1
N/A
}
1
N/A
else
{
1
N/A
$
path
=~
1
N/A
m{^ ( (?: [a-
zA
-Z]: |
1
N/A
(?:\\\\|//)[^\\/]+[\\/][^\\/]+
1
N/A
)?
1
N/A
)
1
N/A
( (?:.*[\\\\/](?:\.\.?\Z(?!\n))?)? )
1
N/A
(.*)
1
N/A
}
xs
;
1
N/A
$
volume
= $
1
;
1
N/A
$
directory
= $
2
;
1
N/A
$
file
= $
3
;
1
N/A
}
1
N/A
1
N/A
return
($
volume
,$
directory
,$
file
);
1
N/A
}
1
N/A
1
N/A
1
N/A
sub
splitdir
{
1
N/A
my
($
self
,$
directories
) = @_ ;
1
N/A
split
m|[\\/]|, $
directories
, -
1
;
1
N/A
}
1
N/A
1
N/A
1
N/A
sub
catpath
{
1
N/A
my
($
self
,$
volume
,$
directory
,$
file
) = @_;
1
N/A
1
N/A
# If it's UNC, make sure the glue separator is there, reusing
1
N/A
# whatever separator is first in the $volume
1
N/A
$
volume
.= $
1
1
N/A
if
( $
volume
=~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\Z(?!\n)@s &&
1
N/A
$
directory
=~ m@^[^\\/]@s
1
N/A
) ;
1
N/A
1
N/A
$
volume
.= $
directory
;
1
N/A
1
N/A
# If the volume is not just A:, make sure the glue separator is
1
N/A
# there, reusing whatever separator is first in the $volume if possible.
1
N/A
if
( $
volume
!~ m@^[a-
zA
-Z]:\Z(?!\n)@s &&
1
N/A
$
volume
=~ m@[^\\/]\Z(?!\n)@ &&
1
N/A
$
file
=~ m@[^\\/]@
1
N/A
) {
1
N/A
$
volume
=~ m@([\\/])@ ;
1
N/A
my
$
sep
= $
1
? $
1
:
'/'
;
1
N/A
$
volume
.= $
sep
;
1
N/A
}
1
N/A
1
N/A
$
volume
.= $
file
;
1
N/A
1
N/A
return
$
volume
;
1
N/A
}
1
N/A
1
N/A
1
N/A
sub
abs2rel
{
1
N/A
my
($
self
,$
path
,$
base
) = @_;
1
N/A
1
N/A
# Clean up $path
1
N/A
if
( ! $
self
->
file_name_is_absolute
( $
path
) ) {
1
N/A
$
path
= $
self
->
rel2abs
( $
path
) ;
1
N/A
}
else
{
1
N/A
$
path
= $
self
->
canonpath
( $
path
) ;
1
N/A
}
1
N/A
1
N/A
# Figure out the effective $base and clean it up.
1
N/A
if
( !
defined
( $
base
) || $
base
eq
''
) {
1
N/A
$
base
= $
self
->
_cwd
();
1
N/A
}
elsif
( ! $
self
->
file_name_is_absolute
( $
base
) ) {
1
N/A
$
base
= $
self
->
rel2abs
( $
base
) ;
1
N/A
}
else
{
1
N/A
$
base
= $
self
->
canonpath
( $
base
) ;
1
N/A
}
1
N/A
1
N/A
# Split up paths
1
N/A
my
( $
path_volume
, $
path_directories
, $
path_file
) = $
self
->
splitpath
( $
path
,
1
) ;
1
N/A
my
( $
base_volume
, $
base_directories
) = $
self
->
splitpath
( $
base
,
1
) ;
1
N/A
return
$
path
unless
$
path_volume
eq
$
base_volume
;
1
N/A
1
N/A
# Now, remove all leading components that are the same
1
N/A
my
@
pathchunks
= $
self
->
splitdir
( $
path_directories
);
1
N/A
my
@
basechunks
= $
self
->
splitdir
( $
base_directories
);
1
N/A
1
N/A
while
( @
pathchunks
&&
1
N/A
@
basechunks
&&
1
N/A
lc
( $
pathchunks
[
0
] )
eq
lc
( $
basechunks
[
0
] )
1
N/A
) {
1
N/A
shift
@
pathchunks
;
1
N/A
shift
@
basechunks
;
1
N/A
}
1
N/A
1
N/A
# No need to catdir, we know these are well formed.
1
N/A
$
path_directories
=
CORE
::
join
(
'/'
, @
pathchunks
);
1
N/A
$
base_directories
=
CORE
::
join
(
'/'
, @
basechunks
);
1
N/A
1
N/A
# $base_directories now contains the directories the resulting relative
1
N/A
# path must ascend out of before it can descend to $path_directory. So,
1
N/A
# replace all names with $parentDir
1
N/A
1
N/A
#FA Need to replace between backslashes...
1
N/A
$
base_directories
=~ s|[^\\/]+|..|g ;
1
N/A
1
N/A
# Glue the two together, using a separator if necessary, and preventing an
1
N/A
# empty result.
1
N/A
1
N/A
#FA Must check that new directories are not empty.
1
N/A
if
( $
path_directories
ne
''
&& $
base_directories
ne
''
) {
1
N/A
$
path_directories
=
"$base_directories/$path_directories"
;
1
N/A
}
else
{
1
N/A
$
path_directories
=
"$base_directories$path_directories"
;
1
N/A
}
1
N/A
1
N/A
return
$
self
->
canonpath
(
1
N/A
$
self
->
catpath
(
""
, $
path_directories
, $
path_file
)
1
N/A
) ;
1
N/A
}
1
N/A
1
N/A
1
N/A
sub
rel2abs
{
1
N/A
my
($
self
,$
path
,$
base
) = @_;
1
N/A
1
N/A
if
( ! $
self
->
file_name_is_absolute
( $
path
) ) {
1
N/A
1
N/A
if
( !
defined
( $
base
) || $
base
eq
''
) {
1
N/A
$
base
= $
self
->
_cwd
();
1
N/A
}
1
N/A
elsif
( ! $
self
->
file_name_is_absolute
( $
base
) ) {
1
N/A
$
base
= $
self
->
rel2abs
( $
base
) ;
1
N/A
}
1
N/A
else
{
1
N/A
$
base
= $
self
->
canonpath
( $
base
) ;
1
N/A
}
1
N/A
1
N/A
my
( $
path_directories
, $
path_file
) =
1
N/A
($
self
->
splitpath
( $
path
,
1
))[
1
,
2
] ;
1
N/A
1
N/A
my
( $
base_volume
, $
base_directories
) =
1
N/A
$
self
->
splitpath
( $
base
,
1
) ;
1
N/A
1
N/A
$
path
= $
self
->
catpath
(
1
N/A
$
base_volume
,
1
N/A
$
self
->
catdir
( $
base_directories
, $
path_directories
),
1
N/A
$
path_file
1
N/A
) ;
1
N/A
}
1
N/A
1
N/A
return
$
self
->
canonpath
( $
path
) ;
1
N/A
}
1
N/A
1
N/A
1
;
1
N/A
__END__
1
N/A
1
N/A
=head1 NAME
1
N/A
1
N/A
File::Spec::OS2 - methods for OS/2 file specs
1
N/A
1
N/A
=head1 SYNOPSIS
1
N/A
1
N/A
require File::Spec::OS2; # Done internally by File::Spec if needed
1
N/A
1
N/A
=head1 DESCRIPTION
1
N/A
1
N/A
See L<File::Spec> and L<File::Spec::Unix>. This package overrides the
1
N/A
implementation of these methods, not the semantics.
1
N/A
1
N/A
Amongst the changes made for OS/2 are...
1
N/A
1
N/A
=over 4
1
N/A
1
N/A
=item tmpdir
1
N/A
1
N/A
Modifies the list of places temp directory information is looked for.
1
N/A
1
N/A
$ENV{TMPDIR}
1
N/A
$ENV{TEMP}
1
N/A
$ENV{TMP}
1
N/A
/tmp
1
N/A
/
1
N/A
1
N/A
=item splitpath
1
N/A
1
N/A
Volumes can be drive letters or UNC sharenames (\\server\share).
1
N/A
1
N/A
=back
1
N/A
1
N/A
=cut