188d92ecf16b64aff44f4d1312a4c6d3328b804c
[perl.git] / dist / PathTools / lib / File / Spec / OS2.pm
1 package File::Spec::OS2;
2
3 use strict;
4 use vars qw(@ISA $VERSION);
5 require File::Spec::Unix;
6
7 $VERSION = '3.59';
8 $VERSION =~ tr/_//d;
9
10 @ISA = qw(File::Spec::Unix);
11
12 sub devnull {
13     return "/dev/nul";
14 }
15
16 sub case_tolerant {
17     return 1;
18 }
19
20 sub file_name_is_absolute {
21     my ($self,$file) = @_;
22     return scalar($file =~ m{^([a-z]:)?[\\/]}is);
23 }
24
25 sub 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
33 sub _cwd {
34     # In OS/2 the "require Cwd" is unnecessary bloat.
35     return Cwd::sys_cwd();
36 }
37
38 sub 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
47 sub 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
58 sub 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
75 sub 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
104 sub splitdir {
105     my ($self,$directories) = @_ ;
106     split m|[\\/]|, $directories, -1;
107 }
108
109
110 sub 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
139 sub 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
202 sub 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
233 1;
234 __END__
235
236 =head1 NAME
237
238 File::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
246 See L<File::Spec> and L<File::Spec::Unix>.  This package overrides the
247 implementation of these methods, not the semantics.
248
249 Amongst the changes made for OS/2 are...
250
251 =over 4
252
253 =item tmpdir
254
255 Modifies 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
265 Volumes can be drive letters or UNC sharenames (\\server\share).
266
267 =back
268
269 =head1 COPYRIGHT
270
271 Copyright (c) 2004 by the Perl 5 Porters.  All rights reserved.
272
273 This program is free software; you can redistribute it and/or modify
274 it under the same terms as Perl itself.
275
276 =cut