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