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 | $tmpdir = $_[0]->_tmpdir( @ENV{qw(TMPDIR TEMP TMP)},
|
---|
41 | '/tmp',
|
---|
42 | '/' );
|
---|
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 | $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 |
|
---|
71 | sub 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 |
|
---|
100 | sub splitdir {
|
---|
101 | my ($self,$directories) = @_ ;
|
---|
102 | split m|[\\/]|, $directories, -1;
|
---|
103 | }
|
---|
104 |
|
---|
105 |
|
---|
106 | sub 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 |
|
---|
135 | sub 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 |
|
---|
198 | sub 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 |
|
---|
229 | 1;
|
---|
230 | __END__
|
---|
231 |
|
---|
232 | =head1 NAME
|
---|
233 |
|
---|
234 | File::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 |
|
---|
242 | See L<File::Spec> and L<File::Spec::Unix>. This package overrides the
|
---|
243 | implementation of these methods, not the semantics.
|
---|
244 |
|
---|
245 | Amongst the changes made for OS/2 are...
|
---|
246 |
|
---|
247 | =over 4
|
---|
248 |
|
---|
249 | =item tmpdir
|
---|
250 |
|
---|
251 | Modifies 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 |
|
---|
261 | Volumes can be drive letters or UNC sharenames (\\server\share).
|
---|
262 |
|
---|
263 | =back
|
---|
264 |
|
---|
265 | =head1 COPYRIGHT
|
---|
266 |
|
---|
267 | Copyright (c) 2004 by the Perl 5 Porters. All rights reserved.
|
---|
268 |
|
---|
269 | This program is free software; you can redistribute it and/or modify
|
---|
270 | it under the same terms as Perl itself.
|
---|
271 |
|
---|
272 | =cut
|
---|