File/Spec/OS2.pm

package File::Spec::OS2;

use strict;
use vars qw(@ISA $VERSION);
require File::Spec::Unix;

$VERSION = '1.2';

@ISA = qw(File::Spec::Unix);

sub devnull {
    return "/dev/nul";
}

sub case_tolerant {
    return 1;
}

sub file_name_is_absolute {
    my ($self,$file) = @_;
    return scalar($file =~ m{^([a-z]:)?[\\/]}is);
}

sub path {
    my $path = $ENV{PATH};
    $path =~ s:\\:/:g;
    my @path = split(';',$path);
    foreach (@path) { $_ = '.' if $_ eq '' }
    return @path;
}

sub _cwd {
    # In OS/2 the "require Cwd" is unnecessary bloat.
    return Cwd::sys_cwd();
}

my $tmpdir;
sub tmpdir {
    return $tmpdir if defined $tmpdir;
    my $self = shift;
    $tmpdir = $self->_tmpdir( @ENV{qw(TMPDIR TEMP TMP)},
                              '/tmp',
                              '/'  );
}

sub catdir {
    my $self = shift;
    my @args = @_;
    foreach (@args) {
        tr[\\][/];
        # append a backslash to each argument unless it has one there
        $_ .= "/" unless m{/$};
    }
    return $self->canonpath(join('', @args));
}

sub canonpath {
    my ($self,$path) = @_;
    $path =~ s/^([a-z]:)/\l$1/s;
    $path =~ s|\\|/|g;
    $path =~ s|([^/])/+|$1/|g;                  # xx////xx  -> xx/xx
    $path =~ s|(/\.)+/|/|g;                     # xx/././xx -> xx/xx
    $path =~ s|^(\./)+(?=[^/])||s;              # ./xx      -> xx
    $path =~ s|/\Z(?!\n)||
             unless $path =~ m#^([a-z]:)?/\Z(?!\n)#si;# xx/       -> xx
    $path =~ s{^/\.\.$}{/};                     # /..    -> /
    1 while $path =~ s{^/\.\.}{};               # /../xx -> /xx
    return $path;
}


sub splitpath {
    my ($self,$path, $nofile) = @_;
    my ($volume,$directory,$file) = ('','','');
    if ( $nofile ) {
        $path =~ 
            m{^( (?:[a-zA-Z]:|(?:\\\\|//)[^\\/]+[\\/][^\\/]+)? ) 
                 (.*)
             }xs;
        $volume    = $1;
        $directory = $2;
    }
    else {
        $path =~ 
            m{^ ( (?: [a-zA-Z]: |
                      (?:\\\\|//)[^\\/]+[\\/][^\\/]+
                  )?
                )
                ( (?:.*[\\\\/](?:\.\.?\Z(?!\n))?)? )
                (.*)
             }xs;
        $volume    = $1;
        $directory = $2;
        $file      = $3;
    }

    return ($volume,$directory,$file);
}


sub splitdir {
    my ($self,$directories) = @_ ;
    split m|[\\/]|, $directories, -1;
}


sub catpath {
    my ($self,$volume,$directory,$file) = @_;

    # If it's UNC, make sure the glue separator is there, reusing
    # whatever separator is first in the $volume
    $volume .= $1
        if ( $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\Z(?!\n)@s &&
             $directory =~ m@^[^\\/]@s
           ) ;

    $volume .= $directory ;

    # If the volume is not just A:, make sure the glue separator is 
    # there, reusing whatever separator is first in the $volume if possible.
    if ( $volume !~ m@^[a-zA-Z]:\Z(?!\n)@s &&
         $volume =~ m@[^\\/]\Z(?!\n)@      &&
         $file   =~ m@[^\\/]@
       ) {
        $volume =~ m@([\\/])@ ;
        my $sep = $1 ? $1 : '/' ;
        $volume .= $sep ;
    }

    $volume .= $file ;

    return $volume ;
}


sub abs2rel {
    my($self,$path,$base) = @_;

    # Clean up $path
    if ( ! $self->file_name_is_absolute( $path ) ) {
        $path = $self->rel2abs( $path ) ;
    } else {
        $path = $self->canonpath( $path ) ;
    }

    # Figure out the effective $base and clean it up.
    if ( !defined( $base ) || $base eq '' ) {
        $base = $self->_cwd();
    } elsif ( ! $self->file_name_is_absolute( $base ) ) {
        $base = $self->rel2abs( $base ) ;
    } else {
        $base = $self->canonpath( $base ) ;
    }

    # Split up paths
    my ( $path_volume, $path_directories, $path_file ) = $self->splitpath( $path, 1 ) ;
    my ( $base_volume, $base_directories ) = $self->splitpath( $base, 1 ) ;
    return $path unless $path_volume eq $base_volume;

    # Now, remove all leading components that are the same
    my @pathchunks = $self->splitdir( $path_directories );
    my @basechunks = $self->splitdir( $base_directories );

    while ( @pathchunks && 
            @basechunks && 
            lc( $pathchunks[0] ) eq lc( $basechunks[0] ) 
          ) {
        shift @pathchunks ;
        shift @basechunks ;
    }

    # No need to catdir, we know these are well formed.
    $path_directories = CORE::join( '/', @pathchunks );
    $base_directories = CORE::join( '/', @basechunks );

    # $base_directories now contains the directories the resulting relative
    # path must ascend out of before it can descend to $path_directory.  So, 
    # replace all names with $parentDir

    #FA Need to replace between backslashes...
    $base_directories =~ s|[^\\/]+|..|g ;

    # Glue the two together, using a separator if necessary, and preventing an
    # empty result.

    #FA Must check that new directories are not empty.
    if ( $path_directories ne '' && $base_directories ne '' ) {
        $path_directories = "$base_directories/$path_directories" ;
    } else {
        $path_directories = "$base_directories$path_directories" ;
    }

    return $self->canonpath( 
        $self->catpath( "", $path_directories, $path_file ) 
    ) ;
}


sub rel2abs {
    my ($self,$path,$base ) = @_;

    if ( ! $self->file_name_is_absolute( $path ) ) {

        if ( !defined( $base ) || $base eq '' ) {
            $base = $self->_cwd();
        }
        elsif ( ! $self->file_name_is_absolute( $base ) ) {
            $base = $self->rel2abs( $base ) ;
        }
        else {
            $base = $self->canonpath( $base ) ;
        }

        my ( $path_directories, $path_file ) =
            ($self->splitpath( $path, 1 ))[1,2] ;

        my ( $base_volume, $base_directories ) =
            $self->splitpath( $base, 1 ) ;

        $path = $self->catpath( 
            $base_volume, 
            $self->catdir( $base_directories, $path_directories ), 
            $path_file
        ) ;
    }

    return $self->canonpath( $path ) ;
}

1;
__END__

=head1 NAME

File::Spec::OS2 - methods for OS/2 file specs

=head1 SYNOPSIS

 require File::Spec::OS2; # Done internally by File::Spec if needed

=head1 DESCRIPTION

See L<File::Spec> and L<File::Spec::Unix>.  This package overrides the
implementation of these methods, not the semantics.

Amongst the changes made for OS/2 are...

=over 4

=item tmpdir

Modifies the list of places temp directory information is looked for.

    $ENV{TMPDIR}
    $ENV{TEMP}
    $ENV{TMP}
    /tmp
    /

=item splitpath

Volumes can be drive letters or UNC sharenames (\\server\share).

=back

=head1 COPYRIGHT

Copyright (c) 2004 by the Perl 5 Porters.  All rights reserved.

This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut
Revision:	1.1
Committed:	Thu Jun 30 14:27:12 2005 UTC (21 years, 4 months ago) by root
Branch:	MAIN
CVS Tags:	PERL-5-8-7, HEAD
Branch point for:	PERL
Log Message:	* empty log message *
#	User	Rev	Content
1	root	1.1	package File::Spec::OS2;
2
3			use strict;
4			use vars qw(@ISA $VERSION);
5			require File::Spec::Unix;
6
7			$VERSION = '1.2';
8
9			@ISA = qw(File::Spec::Unix);
10
11			sub devnull {
12			return "/dev/nul";
13			}
14
15			sub case_tolerant {
16			return 1;
17			}
18
19			sub file_name_is_absolute {
20			my ($self,$file) = @_;
21			return scalar($file =~ m{^([a-z]:)?[\\/]}is);
22			}
23
24			sub path {
25			my $path = $ENV{PATH};
26			$path =~ s:\\:/:g;
27			my @path = split(';',$path);
28			foreach (@path) { $_ = '.' if $_ eq '' }
29			return @path;
30			}
31
32			sub _cwd {
33			# In OS/2 the "require Cwd" is unnecessary bloat.
34			return Cwd::sys_cwd();
35			}
36
37			my $tmpdir;
38			sub tmpdir {
39			return $tmpdir if defined $tmpdir;
40			my $self = shift;
41			$tmpdir = $self->_tmpdir( @ENV{qw(TMPDIR TEMP TMP)},
42			'/tmp',
43			'/' );
44			}
45
46			sub catdir {
47			my $self = shift;
48			my @args = @_;
49			foreach (@args) {
50			tr[\\][/];
51			# append a backslash to each argument unless it has one there
52			$_ .= "/" unless m{/$};
53			}
54			return $self->canonpath(join('', @args));
55			}
56
57			sub canonpath {
58			my ($self,$path) = @_;
59			$path =~ s/^([a-z]:)/\l$1/s;
60			$path =~ s\|\\\|/\|g;
61			$path =~ s\|([^/])/+\|$1/\|g; # xx////xx -> xx/xx
62			$path =~ s\|(/\.)+/\|/\|g; # xx/././xx -> xx/xx
63			$path =~ s\|^(\./)+(?=[^/])\|\|s; # ./xx -> xx
64			$path =~ s\|/\Z(?!\n)\|\|
65			unless $path =~ m#^([a-z]:)?/\Z(?!\n)#si;# xx/ -> xx
66			$path =~ s{^/\.\.$}{/}; # /.. -> /
67			1 while $path =~ s{^/\.\.}{}; # /../xx -> /xx
68			return $path;
69			}
70
71
72			sub splitpath {
73			my ($self,$path, $nofile) = @_;
74			my ($volume,$directory,$file) = ('','','');
75			if ( $nofile ) {
76			$path =~
77			m{^( (?:[a-zA-Z]:\|(?:\\\\\|//)[^\\/]+[\\/][^\\/]+)? )
78			(.*)
79			}xs;
80			$volume = $1;
81			$directory = $2;
82			}
83			else {
84			$path =~
85			m{^ ( (?: [a-zA-Z]: \|
86			(?:\\\\\|//)[^\\/]+[\\/][^\\/]+
87			)?
88			)
89			( (?:.*[\\\\/](?:\.\.?\Z(?!\n))?)? )
90			(.*)
91			}xs;
92			$volume = $1;
93			$directory = $2;
94			$file = $3;
95			}
96
97			return ($volume,$directory,$file);
98			}
99
100
101			sub splitdir {
102			my ($self,$directories) = @_ ;
103			split m\|[\\/]\|, $directories, -1;
104			}
105
106
107			sub catpath {
108			my ($self,$volume,$directory,$file) = @_;
109
110			# If it's UNC, make sure the glue separator is there, reusing
111			# whatever separator is first in the $volume
112			$volume .= $1
113			if ( $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\Z(?!\n)@s &&
114			$directory =~ m@^[^\\/]@s
115			) ;
116
117			$volume .= $directory ;
118
119			# If the volume is not just A:, make sure the glue separator is
120			# there, reusing whatever separator is first in the $volume if possible.
121			if ( $volume !~ m@^[a-zA-Z]:\Z(?!\n)@s &&
122			$volume =~ m@[^\\/]\Z(?!\n)@ &&
123			$file =~ m@[^\\/]@
124			) {
125			$volume =~ m@([\\/])@ ;
126			my $sep = $1 ? $1 : '/' ;
127			$volume .= $sep ;
128			}
129
130			$volume .= $file ;
131
132			return $volume ;
133			}
134
135
136			sub abs2rel {
137			my($self,$path,$base) = @_;
138
139			# Clean up $path
140			if ( ! $self->file_name_is_absolute( $path ) ) {
141			$path = $self->rel2abs( $path ) ;
142			} else {
143			$path = $self->canonpath( $path ) ;
144			}
145
146			# Figure out the effective $base and clean it up.
147			if ( !defined( $base ) \|\| $base eq '' ) {
148			$base = $self->_cwd();
149			} elsif ( ! $self->file_name_is_absolute( $base ) ) {
150			$base = $self->rel2abs( $base ) ;
151			} else {
152			$base = $self->canonpath( $base ) ;
153			}
154
155			# Split up paths
156			my ( $path_volume, $path_directories, $path_file ) = $self->splitpath( $path, 1 ) ;
157			my ( $base_volume, $base_directories ) = $self->splitpath( $base, 1 ) ;
158			return $path unless $path_volume eq $base_volume;
159
160			# Now, remove all leading components that are the same
161			my @pathchunks = $self->splitdir( $path_directories );
162			my @basechunks = $self->splitdir( $base_directories );
163
164			while ( @pathchunks &&
165			@basechunks &&
166			lc( $pathchunks[0] ) eq lc( $basechunks[0] )
167			) {
168			shift @pathchunks ;
169			shift @basechunks ;
170			}
171
172			# No need to catdir, we know these are well formed.
173			$path_directories = CORE::join( '/', @pathchunks );
174			$base_directories = CORE::join( '/', @basechunks );
175
176			# $base_directories now contains the directories the resulting relative
177			# path must ascend out of before it can descend to $path_directory. So,
178			# replace all names with $parentDir
179
180			#FA Need to replace between backslashes...
181			$base_directories =~ s\|[^\\/]+\|..\|g ;
182
183			# Glue the two together, using a separator if necessary, and preventing an
184			# empty result.
185
186			#FA Must check that new directories are not empty.
187			if ( $path_directories ne '' && $base_directories ne '' ) {
188			$path_directories = "$base_directories/$path_directories" ;
189			} else {
190			$path_directories = "$base_directories$path_directories" ;
191			}
192
193			return $self->canonpath(
194			$self->catpath( "", $path_directories, $path_file )
195			) ;
196			}
197
198
199			sub rel2abs {
200			my ($self,$path,$base ) = @_;
201
202			if ( ! $self->file_name_is_absolute( $path ) ) {
203
204			if ( !defined( $base ) \|\| $base eq '' ) {
205			$base = $self->_cwd();
206			}
207			elsif ( ! $self->file_name_is_absolute( $base ) ) {
208			$base = $self->rel2abs( $base ) ;
209			}
210			else {
211			$base = $self->canonpath( $base ) ;
212			}
213
214			my ( $path_directories, $path_file ) =
215			($self->splitpath( $path, 1 ))[1,2] ;
216
217			my ( $base_volume, $base_directories ) =
218			$self->splitpath( $base, 1 ) ;
219
220			$path = $self->catpath(
221			$base_volume,
222			$self->catdir( $base_directories, $path_directories ),
223			$path_file
224			) ;
225			}
226
227			return $self->canonpath( $path ) ;
228			}
229
230			1;
231			__END__
232
233			=head1 NAME
234
235			File::Spec::OS2 - methods for OS/2 file specs
236
237			=head1 SYNOPSIS
238
239			require File::Spec::OS2; # Done internally by File::Spec if needed
240
241			=head1 DESCRIPTION
242
243			See L<File::Spec> and L<File::Spec::Unix>. This package overrides the
244			implementation of these methods, not the semantics.
245
246			Amongst the changes made for OS/2 are...
247
248			=over 4
249
250			=item tmpdir
251
252			Modifies the list of places temp directory information is looked for.
253
254			$ENV{TMPDIR}
255			$ENV{TEMP}
256			$ENV{TMP}
257			/tmp
258			/
259
260			=item splitpath
261
262			Volumes can be drive letters or UNC sharenames (\\server\share).
263
264			=back
265
266			=head1 COPYRIGHT
267
268			Copyright (c) 2004 by the Perl 5 Porters. All rights reserved.
269
270			This program is free software; you can redistribute it and/or modify
271			it under the same terms as Perl itself.
272
273			=cut