[15957] | 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
|
---|