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