#include "perl.h"
#include "XSUB.h"
#ifndef NO_PPPORT_H
-# define NEED_sv_2pv_nolen
+# define NEED_my_strlcpy
+# define NEED_my_strlcat
# include "ppport.h"
#endif
# include <unistd.h>
#endif
-/* The realpath() implementation from OpenBSD 2.9 (realpath.c 1.4)
+/* The realpath() implementation from OpenBSD 3.9 to 4.2 (realpath.c 1.13)
* Renamed here to bsd_realpath() to avoid library conflicts.
- * --jhi 2000-06-20
*/
/* See
*/
/*
- * Copyright (c) 1994
- * The Regents of the University of California. All rights reserved.
- *
- * This code is derived from software contributed to Berkeley by
- * Jan-Simon Pendry.
+ * Copyright (c) 2003 Constantin S. Svintsoff <kostik@iclub.nsu.ru>
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions
* 2. Redistributions in binary form must reproduce the above copyright
* notice, this list of conditions and the following disclaimer in the
* documentation and/or other materials provided with the distribution.
- * 3. Neither the name of the University nor the names of its contributors
- * may be used to endorse or promote products derived from this software
- * without specific prior written permission.
+ * 3. The names of the authors may not be used to endorse or promote
+ * products derived from this software without specific prior written
+ * permission.
*
- * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
* ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
- * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
* FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
* DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
* OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
* SUCH DAMAGE.
*/
-#if defined(LIBC_SCCS) && !defined(lint)
-static char *rcsid = "$OpenBSD: realpath.c,v 1.4 1998/05/18 09:55:19 deraadt Exp $";
-#endif /* LIBC_SCCS and not lint */
-
/* OpenBSD system #includes removed since the Perl ones should do. --jhi */
#ifndef MAXSYMLINKS
#endif
/*
- * char *realpath(const char *path, char resolved_path[MAXPATHLEN]);
+ * char *realpath(const char *path, char resolved[MAXPATHLEN]);
*
* Find the real name of path, by removing all ".", ".." and symlink
* components. Returns (resolved) on success, or (NULL) on failure,
# Cwd::chdir should also update $ENV{PWD}
dir_ends_with( $ENV{PWD}, $Test_Dir, 'Cwd::chdir() updates $ENV{PWD}' );
my $updir = File::Spec->updir;
-Cwd::chdir $updir;
-print "#$ENV{PWD}\n";
-Cwd::chdir $updir;
-print "#$ENV{PWD}\n";
-Cwd::chdir $updir;
-print "#$ENV{PWD}\n";
-Cwd::chdir $updir;
-print "#$ENV{PWD}\n";
-Cwd::chdir $updir;
-print "#$ENV{PWD}\n";
+
+for (1..@test_dirs) {
+ Cwd::chdir $updir;
+ print "#$ENV{PWD}\n";
+}
rmtree($test_dirs[0], 0, 0);
use Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION);
-$VERSION = '3.2501';
+$VERSION = '3.27';
@ISA = qw/ Exporter /;
@EXPORT = qw(cwd getcwd fastcwd fastgetcwd);
local *PARENT;
unless (opendir(PARENT, $dotdots))
{
- _carp("opendir($dotdots): $!");
- return '';
+ # probably a permissions issue. Try the native command.
+ return File::Spec->rel2abs( $start, _backtick_pwd() );
}
unless (@cst = stat($dotdots))
{
return _vms_abs_path($link_target);
}
+ if (defined &VMS::Filespec::vms_realpath) {
+ my $path = $_[0];
+ if ($path =~ m#(?<=\^)/# ) {
+ # Unix format
+ return VMS::Filespec::vms_realpath($path);
+ }
+
+ # VMS format
+
+ my $new_path = VMS::Filespec::vms_realname($path);
+
+ # Perl expects directories to be in directory format
+ $new_path = VMS::Filespec::pathify($new_path) if -d $path;
+ return $new_path;
+ }
+
+ # Fallback to older algorithm if correct ones are not
+ # available.
+
# may need to turn foo.dir into [.foo]
my $pathified = VMS::Filespec::pathify($path);
$path = $pathified if defined $pathified;
use strict;
use vars qw(@ISA $VERSION);
-$VERSION = '3.2501';
+$VERSION = '3.27';
$VERSION = eval $VERSION;
my %module = (MacOS => 'Mac',
use vars qw(@ISA $VERSION);
require File::Spec::Unix;
-$VERSION = '3.2501';
+$VERSION = '3.27';
@ISA = qw(File::Spec::Unix);
sub canonpath {
my($self,$path) = @_;
+ return unless defined $path;
+
$path =~ s|\\|/|g;
# Handle network path names beginning with double slash
sub catdir {
my $self = shift;
+ return unless @_;
# Don't create something that looks like a //network/path
if ($_[0] and ($_[0] eq '/' or $_[0] eq '\\')) {
=cut
sub case_tolerant () {
- if ($^O ne 'cygwin') {
- return 1;
- }
+ return 1 unless $^O eq 'cygwin'
+ and defined &Cygwin::mount_flags;
+
my $drive = shift;
if (! $drive) {
my @flags = split(/,/, Cygwin::mount_flags('/cygwin'));
use strict;
use vars qw($VERSION @ISA);
-$VERSION = '3.2501';
+$VERSION = '3.27';
require File::Spec::Unix;
@ISA = qw(File::Spec::Unix);
sub canonpath {
my ($self,$path) = @_;
+ return unless defined $path;
$path =~ s|/+|/|g; # xx////xx -> xx/xx
$path =~ s|(/\.)+/|/|g; # xx/././xx -> xx/xx
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
-$VERSION = '3.2501';
+$VERSION = '3.27';
require Exporter;
use vars qw(@ISA $VERSION);
require File::Spec::Unix;
-$VERSION = '3.2501';
+$VERSION = '3.27';
@ISA = qw(File::Spec::Unix);
my @result = ();
my ($head, $sep, $tail, $volume, $directories);
- return ('') if ( (!defined($path)) || ($path eq '') );
+ return @result if ( (!defined($path)) || ($path eq '') );
return (':') if ($path eq ':');
( $volume, $sep, $directories ) = $path =~ m|^((?:[^:]+:)?)(:*)(.*)|s;
use vars qw(@ISA $VERSION);
require File::Spec::Unix;
-$VERSION = '3.2501';
+$VERSION = '3.27';
@ISA = qw(File::Spec::Unix);
sub canonpath {
my ($self,$path) = @_;
+ return unless defined $path;
+
$path =~ s/^([a-z]:)/\l$1/s;
$path =~ s|\\|/|g;
$path =~ s|([^/])/+|$1/|g; # xx////xx -> xx/xx
use strict;
use vars qw($VERSION);
-$VERSION = '3.2501';
+$VERSION = '3.27';
=head1 NAME
sub canonpath {
my ($self,$path) = @_;
+ return unless defined $path;
# Handle POSIX-style node names beginning with double slash (qnx, nto)
# (POSIX says: "a pathname that begins with two successive slashes
use vars qw(@ISA $VERSION);
require File::Spec::Unix;
-$VERSION = '3.2501';
+$VERSION = '3.27';
@ISA = qw(File::Spec::Unix);
use vars qw(@ISA $VERSION);
require File::Spec::Unix;
-$VERSION = '3.2501';
+$VERSION = '3.27';
@ISA = qw(File::Spec::Unix);
=cut
sub catfile {
- my $self = shift;
- my $file = $self->canonpath(pop @_);
- return $file unless @_;
- my $dir = $self->catdir(@_);
- $dir .= "\\" unless substr($dir,-1) eq "\\";
- return $dir.$file;
+ shift;
+
+ # Legacy / compatibility support
+ #
+ shift, return _canon_cat( "/", @_ )
+ if $_[0] eq "";
+
+ return _canon_cat( @_ );
}
sub catdir {
- my $self = shift;
- my @args = @_;
- foreach (@args) {
- tr[/][\\];
- # append a backslash to each argument unless it has one there
- $_ .= "\\" unless m{\\$};
- }
- return $self->canonpath(join('', @args));
+ shift;
+
+ # Legacy / compatibility support
+ #
+ return ""
+ unless @_;
+ shift, return _canon_cat( "/", @_ )
+ if $_[0] eq "";
+
+ return _canon_cat( @_ );
}
sub path {
=cut
sub canonpath {
- my ($self,$path) = @_;
-
- $path =~ s/^([a-z]:)/\u$1/s;
- $path =~ s|/|\\|g;
- $path =~ s|([^\\])\\+|$1\\|g; # xx\\\\xx -> xx\xx
- $path =~ s|(\\\.)+\\|\\|g; # xx\.\.\xx -> xx\xx
- $path =~ s|^(\.\\)+||s unless $path eq ".\\"; # .\xx -> xx
- $path =~ s|\\\Z(?!\n)||
- unless $path =~ m{^([A-Z]:)?\\\Z(?!\n)}s; # xx\ -> xx
- # xx1/xx2/xx3/../../xx -> xx1/xx
- $path =~ s|\\\.\.\.\\|\\\.\.\\\.\.\\|g; # \...\ is 2 levels up
- $path =~ s|^\.\.\.\\|\.\.\\\.\.\\|g; # ...\ is 2 levels up
- return $path if $path =~ m|^\.\.|; # skip relative paths
- return $path unless $path =~ /\.\./; # too few .'s to cleanup
- return $path if $path =~ /\.\.\.\./; # too many .'s to cleanup
- $path =~ s{^\\\.\.$}{\\}; # \.. -> \
- 1 while $path =~ s{^\\\.\.}{}; # \..\xx -> \xx
-
- return $self->_collapse($path);
+ # Legacy / compatibility support
+ #
+ return $_[1] if !defined($_[1]) or $_[1] eq '';
+ return _canon_cat( $_[1] );
}
=item splitpath
=cut
+
+sub _canon_cat(@) # @path -> path
+{
+ my $first = shift;
+ my $volume = $first =~ s{ \A ([A-Za-z]:) ([\\/]?) }{}x # drive letter
+ ? ucfirst( $1 ).( $2 ? "\\" : "" )
+ : $first =~ s{ \A (?:\\\\|//) ([^\\/]+)
+ (?: [\\/] ([^\\/]+) )?
+ [\\/]? }{}xs # UNC volume
+ ? "\\\\$1".( defined $2 ? "\\$2" : "" )."\\"
+ : $first =~ s{ \A [\\/] }{}x # root dir
+ ? "\\"
+ : "";
+ my $path = join "\\", $first, @_;
+
+ $path =~ tr#\\/#\\\\#s; # xx/yy --> xx\yy & xx\\yy --> xx\yy
+
+ # xx/././yy --> xx/yy
+ $path =~ s{(?:
+ (?:\A|\\) # at begin or after a slash
+ \.
+ (?:\\\.)* # and more
+ (?:\\|\z) # at end or followed by slash
+ )+ # performance boost -- I do not know why
+ }{\\}gx;
+
+ # XXX I do not know whether more dots are supported by the OS supporting
+ # this ... annotation (NetWare or symbian but not MSWin32).
+ # Then .... could easily become ../../.. etc:
+ # Replace \.\.\. by (\.\.\.+) and substitute with
+ # { $1 . ".." . "\\.." x (length($2)-2) }gex
+ # ... --> ../..
+ $path =~ s{ (\A|\\) # at begin or after a slash
+ \.\.\.
+ (?=\\|\z) # at end or followed by slash
+ }{$1..\\..}gx;
+ # xx\yy\..\zz --> xx\zz
+ while ( $path =~ s{(?:
+ (?:\A|\\) # at begin or after a slash
+ [^\\]+ # rip this 'yy' off
+ \\\.\.
+ (?<!\A\.\.\\\.\.) # do *not* replace ^..\..
+ (?<!\\\.\.\\\.\.) # do *not* replace \..\..
+ (?:\\|\z) # at end or followed by slash
+ )+ # performance boost -- I do not know why
+ }{\\}sx ) {}
+
+ $path =~ s#\A\\##; # \xx --> xx NOTE: this is *not* root
+ $path =~ s#\\\z##; # xx\ --> xx
+
+ if ( $volume =~ m#\\\z# )
+ { # <vol>\.. --> <vol>\
+ $path =~ s{ \A # at begin
+ \.\.
+ (?:\\\.\.)* # and more
+ (?:\\|\z) # at end or followed by slash
+ }{}x;
+
+ return $1 # \\HOST\SHARE\ --> \\HOST\SHARE
+ if $path eq ""
+ and $volume =~ m#\A(\\\\.*)\\\z#s;
+ }
+ return $path ne "" || $volume ? $volume.$path : ".";
+}
+
1;
[ "Win32->catdir('\\d1','d2')", '\\d1\\d2' ],
[ "Win32->catdir('\\d1','\\d2')", '\\d1\\d2' ],
[ "Win32->catdir('\\d1','\\d2\\')", '\\d1\\d2' ],
-[ "Win32->catdir('','/d1','d2')", '\\\\d1\\d2' ],
-[ "Win32->catdir('','','/d1','d2')", '\\\\\\d1\\d2' ],
-[ "Win32->catdir('','//d1','d2')", '\\\\\\d1\\d2' ],
-[ "Win32->catdir('','','//d1','d2')", '\\\\\\\\d1\\d2' ],
+[ "Win32->catdir('','/d1','d2')", '\\d1\\d2' ],
+[ "Win32->catdir('','','/d1','d2')", '\\d1\\d2' ],
+[ "Win32->catdir('','//d1','d2')", '\\d1\\d2' ],
+[ "Win32->catdir('','','//d1','d2')", '\\d1\\d2' ],
[ "Win32->catdir('','d1','','d2','')", '\\d1\\d2' ],
[ "Win32->catdir('','d1','d2','d3','')", '\\d1\\d2\\d3' ],
[ "Win32->catdir('d1','d2','d3','')", 'd1\\d2\\d3' ],
[ "Win32->catdir('A:/d1','B:/d2','d3','')", 'A:\\d1\\B:\\d2\\d3' ],
[ "Win32->catdir('A:/')", 'A:\\' ],
[ "Win32->catdir('\\', 'foo')", '\\foo' ],
-
+[ "Win32->catdir('','','..')", '\\' ],
[ "Win32->catfile('a','b','c')", 'a\\b\\c' ],
[ "Win32->catfile('a','b','.\\c')", 'a\\b\\c' ],
[ "Win32->catfile('.\\a','b','c')", 'a\\b\\c' ],
[ "Win32->catfile('c')", 'c' ],
[ "Win32->catfile('.\\c')", 'c' ],
+[ "Win32->catfile('a/..','../b')", '..\\b' ],
[ "Win32->canonpath('')", '' ],
[ "Win32->canonpath('//a\\b//c')", '\\\\a\\b\\c' ],
[ "Win32->canonpath('/a/..../c')", '\\a\\....\\c' ],
[ "Win32->canonpath('//a/b\\c')", '\\\\a\\b\\c' ],
-[ "Win32->canonpath('////')", '\\\\\\' ],
+[ "Win32->canonpath('////')", '\\' ],
[ "Win32->canonpath('//')", '\\' ],
-[ "Win32->canonpath('/.')", '\\.' ],
+[ "Win32->canonpath('/.')", '\\' ],
[ "Win32->canonpath('//a/b/../../c')", '\\\\a\\b\\c' ],
[ "Win32->canonpath('//a/b/c/../d')", '\\\\a\\b\\d' ],
[ "Win32->canonpath('//a/b/c/../../d')",'\\\\a\\b\\d' ],
[ "Cygwin->rel2abs('..','/t1/t2/t3')", '/t1/t2/t3/..' ],
[ "Cygwin->rel2abs('../t4','/t1/t2/t3')", '/t1/t2/t3/../t4' ],
[ "Cygwin->rel2abs('/t1','/t1/t2/t3')", '/t1' ],
+[ "Cygwin->rel2abs('//t1/t2/t3','/foo')", '//t1/t2/t3' ],
) ;
local $|=1;
my @platforms = qw(Cygwin Epoc Mac OS2 Unix VMS Win32);
-my $tests_per_platform = 7;
+my $tests_per_platform = 10;
plan tests => 1 + @platforms * $tests_per_platform;
is $module->file_name_is_absolute($base), 1, "$base is absolute on $platform";
+ # splitdir('') -> ()
+ my @result = $module->splitdir('');
+ is @result, 0, "$platform->splitdir('') -> ()";
+
+ # canonpath() -> undef
+ $result = $module->canonpath();
+ is $result, undef, "$platform->canonpath() -> undef";
+
+ # canonpath(undef) -> undef
+ $result = $module->canonpath(undef);
+ is $result, undef, "$platform->canonpath(undef) -> undef";
# abs2rel('A:/foo/bar', 'A:/foo') -> 'bar'
$file = $module->catpath($v, $module->catdir($module->rootdir, 'foo', 'bar'), 'file');
ok scalar keys %ENV, $num_keys, "tmpdir() shouldn't change the contents of %ENV";
if ($^O eq 'VMS') {
- skip('Can\'t make list assignment to \%ENV on this system', 1);
-}
-else {
+ skip("Can't make list assignment to %ENV on this system", 1);
+} else {
local %ENV;
File::Spec::Win32->tmpdir;
ok scalar keys %ENV, 0, "Win32->tmpdir() shouldn't change the contents of %ENV";
projects / p5sagit/p5-mst-13.2.git / commitdiff