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