Reimplement parts of File::Spec in XS. Mainly File::Spec::Unix methods.
The methods can be used as methods on File::Spec::Unix, as methods
inherited by File::Spec::$notunix, and as standalone functions. Quite a
lot of complexity comes from making them work in all of these roles,
without the compatibility damaging the performance of any of them.
The methods therefore need to check their invocant, using C code
where the invocant is File::Spec::Unix, and calling other methods if
it is not, so that they play nicely in composition with other methods.
The standalone function is another XS entry point, entirely unencumbered
by OO interface paraphernalia. File::Spec::Functions is modified to
pick up the separate function version.
There is new logic for File::Spec to fall back to pure Perl, in the way
that Cwd.pm already does, for XS-impaired systems.
use Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION);
-$VERSION = '3.41';
+$VERSION = '3.44';
my $xs_version = $VERSION;
$VERSION =~ tr/_//;
# If loading the XS stuff doesn't work, we can fall back to pure perl
-eval {
- if ( $] >= 5.006 ) {
- require XSLoader;
- XSLoader::load( __PACKAGE__, $xs_version);
- } else {
- require DynaLoader;
- push @ISA, 'DynaLoader';
- __PACKAGE__->bootstrap( $xs_version );
- }
-};
+unless (defined &getcwd) {
+ eval {
+ if ( $] >= 5.006 ) {
+ require XSLoader;
+ XSLoader::load( __PACKAGE__, $xs_version);
+ } else {
+ require DynaLoader;
+ push @ISA, 'DynaLoader';
+ __PACKAGE__->bootstrap( $xs_version );
+ }
+ };
+}
# Big nasty table of function aliases
my %METHOD_MAP =
#endif
+#if defined(START_MY_CXT) && defined(MY_CXT_CLONE)
+# define USE_MY_CXT 1
+#else
+# define USE_MY_CXT 0
+#endif
+
+#if USE_MY_CXT
+# define MY_CXT_KEY "Cwd::_guts"XS_VERSION
+typedef struct {
+ SV *empty_string_sv, *slash_string_sv;
+} my_cxt_t;
+START_MY_CXT
+# define dUSE_MY_CXT dMY_CXT
+# define EMPTY_STRING_SV MY_CXT.empty_string_sv
+# define SLASH_STRING_SV MY_CXT.slash_string_sv
+# define POPULATE_MY_CXT do { \
+ MY_CXT.empty_string_sv = newSVpvs(""); \
+ MY_CXT.slash_string_sv = newSVpvs("/"); \
+ } while(0)
+#else
+# define dUSE_MY_CXT dNOOP
+# define EMPTY_STRING_SV sv_2mortal(newSVpvs(""))
+# define SLASH_STRING_SV sv_2mortal(newSVpvs("/"))
+#endif
+
+#define invocant_is_unix(i) THX_invocant_is_unix(aTHX_ i)
+static
+bool
+THX_invocant_is_unix(pTHX_ SV *invocant)
+{
+ /*
+ * This is used to enable optimisations that avoid method calls
+ * by knowing how they would resolve. False negatives, disabling
+ * the optimisation where it would actually behave correctly, are
+ * acceptable.
+ */
+ return SvPOK(invocant) && SvCUR(invocant) == 16 &&
+ !memcmp(SvPVX(invocant), "File::Spec::Unix", 16);
+}
+
+#define unix_canonpath(p) THX_unix_canonpath(aTHX_ p)
+static
+SV *
+THX_unix_canonpath(pTHX_ SV *path)
+{
+ SV *retval;
+ char const *p, *pe, *q;
+ STRLEN l;
+ char *o;
+ STRLEN plen;
+ SvGETMAGIC(path);
+ if(!SvOK(path)) return &PL_sv_undef;
+ p = SvPV_nomg(path, plen);
+ if(plen == 0) return newSVpvs("");
+ pe = p + plen;
+ retval = newSV(plen);
+#ifdef SvUTF8
+ if(SvUTF8(path)) SvUTF8_on(retval);
+#endif
+ o = SvPVX(retval);
+ if(DOUBLE_SLASHES_SPECIAL && p[0] == '/' && p[1] == '/' && p[2] != '/') {
+ q = memchr(p+2, '/', pe-(p+2));
+ if(!q) q = pe;
+ l = q - p;
+ memcpy(o, p, l);
+ p = q;
+ o += l;
+ }
+ /*
+ * The transformations performed here are:
+ * . squeeze multiple slashes
+ * . eliminate "." segments, except one if that's all there is
+ * . eliminate leading ".." segments
+ * . eliminate trailing slash, unless it's all there is
+ */
+ if(p[0] == '/') {
+ *o++ = '/';
+ while(1) {
+ do { p++; } while(p[0] == '/');
+ if(p[0] == '.' && p[1] == '.' && (p+2 == pe || p[2] == '/')) {
+ p++;
+ /* advance past second "." next time round loop */
+ } else if(p[0] == '.' && (p+1 == pe || p[1] == '/')) {
+ /* advance past "." next time round loop */
+ } else {
+ break;
+ }
+ }
+ } else if(p[0] == '.' && p[1] == '/') {
+ do {
+ p++;
+ do { p++; } while(p[0] == '/');
+ } while(p[0] == '.' && p[1] == '/');
+ if(p == pe) *o++ = '.';
+ }
+ if(p == pe) goto end;
+ while(1) {
+ q = memchr(p, '/', pe-p);
+ if(!q) q = pe;
+ l = q - p;
+ memcpy(o, p, l);
+ p = q;
+ o += l;
+ if(p == pe) goto end;
+ while(1) {
+ do { p++; } while(p[0] == '/');
+ if(p == pe) goto end;
+ if(p[0] != '.') break;
+ if(p+1 == pe) goto end;
+ if(p[1] != '/') break;
+ p++;
+ }
+ *o++ = '/';
+ }
+ end: ;
+ *o = 0;
+ SvPOK_on(retval);
+ SvCUR_set(retval, o - SvPVX(retval));
+ return retval;
+}
MODULE = Cwd PACKAGE = Cwd
PROTOTYPES: DISABLE
+BOOT:
+#if USE_MY_CXT
+{
+ MY_CXT_INIT;
+ POPULATE_MY_CXT;
+}
+#endif
+
+#if USE_MY_CXT
+
+void
+CLONE(...)
+CODE:
+ PERL_UNUSED_VAR(items);
+ { MY_CXT_CLONE; POPULATE_MY_CXT; }
+
+#endif
+
void
getcwd(...)
ALIAS:
}
#endif
+
+MODULE = Cwd PACKAGE = File::Spec::Unix
+
+SV *
+canonpath(SV *self, SV *path = &PL_sv_undef, ...)
+CODE:
+ PERL_UNUSED_VAR(self);
+ RETVAL = unix_canonpath(path);
+OUTPUT:
+ RETVAL
+
+SV *
+_fn_canonpath(SV *path = &PL_sv_undef, ...)
+CODE:
+ RETVAL = unix_canonpath(path);
+OUTPUT:
+ RETVAL
+
+SV *
+catdir(SV *self, ...)
+PREINIT:
+ dUSE_MY_CXT;
+ SV *joined;
+CODE:
+ EXTEND(SP, items+1);
+ ST(items) = EMPTY_STRING_SV;
+ joined = sv_newmortal();
+ do_join(joined, SLASH_STRING_SV, &ST(0), &ST(items));
+ if(invocant_is_unix(self)) {
+ RETVAL = unix_canonpath(joined);
+ } else {
+ ENTER;
+ PUSHMARK(SP);
+ EXTEND(SP, 2);
+ PUSHs(self);
+ PUSHs(joined);
+ PUTBACK;
+ call_method("canonpath", G_SCALAR);
+ SPAGAIN;
+ RETVAL = POPs;
+ LEAVE;
+ SvREFCNT_inc(RETVAL);
+ }
+OUTPUT:
+ RETVAL
+
+SV *
+_fn_catdir(...)
+PREINIT:
+ dUSE_MY_CXT;
+ SV *joined;
+CODE:
+ EXTEND(SP, items+1);
+ ST(items) = EMPTY_STRING_SV;
+ joined = sv_newmortal();
+ do_join(joined, SLASH_STRING_SV, &ST(-1), &ST(items));
+ RETVAL = unix_canonpath(joined);
+OUTPUT:
+ RETVAL
+
+SV *
+catfile(SV *self, ...)
+PREINIT:
+ dUSE_MY_CXT;
+CODE:
+ if(invocant_is_unix(self)) {
+ if(items == 1) {
+ RETVAL = &PL_sv_undef;
+ } else {
+ SV *file = unix_canonpath(ST(items-1));
+ if(items == 2) {
+ RETVAL = file;
+ } else {
+ SV *dir = sv_newmortal();
+ sv_2mortal(file);
+ ST(items-1) = EMPTY_STRING_SV;
+ do_join(dir, SLASH_STRING_SV, &ST(0), &ST(items-1));
+ RETVAL = unix_canonpath(dir);
+ if(SvCUR(RETVAL) == 0 || SvPVX(RETVAL)[SvCUR(RETVAL)-1] != '/')
+ sv_catsv(RETVAL, SLASH_STRING_SV);
+ sv_catsv(RETVAL, file);
+ }
+ }
+ } else {
+ SV *file, *dir;
+ ENTER;
+ PUSHMARK(SP);
+ EXTEND(SP, 2);
+ PUSHs(self);
+ PUSHs(items == 1 ? &PL_sv_undef : ST(items-1));
+ PUTBACK;
+ call_method("canonpath", G_SCALAR);
+ SPAGAIN;
+ file = POPs;
+ LEAVE;
+ if(items <= 2) {
+ RETVAL = SvREFCNT_inc(file);
+ } else {
+ char const *pv;
+ STRLEN len;
+ bool need_slash;
+ SP--;
+ ENTER;
+ PUSHMARK(&ST(-1));
+ PUTBACK;
+ call_method("catdir", G_SCALAR);
+ SPAGAIN;
+ dir = POPs;
+ LEAVE;
+ pv = SvPV(dir, len);
+ need_slash = len == 0 || pv[len-1] != '/';
+ RETVAL = newSVsv(dir);
+ if(need_slash) sv_catsv(RETVAL, SLASH_STRING_SV);
+ sv_catsv(RETVAL, file);
+ }
+ }
+OUTPUT:
+ RETVAL
+
+SV *
+_fn_catfile(...)
+PREINIT:
+ dUSE_MY_CXT;
+CODE:
+ if(items == 0) {
+ RETVAL = &PL_sv_undef;
+ } else {
+ SV *file = unix_canonpath(ST(items-1));
+ if(items == 1) {
+ RETVAL = file;
+ } else {
+ SV *dir = sv_newmortal();
+ sv_2mortal(file);
+ ST(items-1) = EMPTY_STRING_SV;
+ do_join(dir, SLASH_STRING_SV, &ST(-1), &ST(items-1));
+ RETVAL = unix_canonpath(dir);
+ if(SvCUR(RETVAL) == 0 || SvPVX(RETVAL)[SvCUR(RETVAL)-1] != '/')
+ sv_catsv(RETVAL, SLASH_STRING_SV);
+ sv_catsv(RETVAL, file);
+ }
+ }
+OUTPUT:
+ RETVAL
BEGIN { @INC = grep {!/blib/} @INC }
-# Note: this file was auto-generated by Module::Build::Compat version 0.2808_01
require 5.005;
use ExtUtils::MakeMaker;
WriteMakefile
'DISTNAME' => 'PathTools',
'NAME' => 'Cwd',
'VERSION_FROM' => 'Cwd.pm',
- (
- (grep { $_ eq 'PERL_CORE=1' } @ARGV)
- ? ('DEFINE' => '-DNO_PPPORT_H')
- : ()
- ),
+ 'DEFINE' => join(" ",
+ "-DDOUBLE_SLASHES_SPECIAL=@{[$^O eq q(qnx) || $^O eq q(nto) ? 1 : 0]}",
+ ((grep { $_ eq 'PERL_CORE=1' } @ARGV) ? '-DNO_PPPORT_H' : ()),
+ ),
'PREREQ_PM' => {
'Carp' => '0',
'File::Basename' => '0',
use strict;
use vars qw(@ISA $VERSION);
-$VERSION = '3.41';
+$VERSION = '3.44';
$VERSION =~ tr/_//;
my %module = (MacOS => 'Mac',
use vars qw(@ISA $VERSION);
require File::Spec::Unix;
-$VERSION = '3.41';
+$VERSION = '3.44';
$VERSION =~ tr/_//;
@ISA = qw(File::Spec::Unix);
use strict;
use vars qw($VERSION @ISA);
-$VERSION = '3.41';
+$VERSION = '3.44';
$VERSION =~ tr/_//;
require File::Spec::Unix;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
-$VERSION = '3.40';
+$VERSION = '3.44';
$VERSION =~ tr/_//;
require Exporter;
%EXPORT_TAGS = ( ALL => [ @EXPORT_OK, @EXPORT ] );
+require File::Spec::Unix;
+my %udeps = (
+ canonpath => [],
+ catdir => [qw(canonpath)],
+ catfile => [qw(canonpath catdir)],
+ case_tolerant => [],
+ curdir => [],
+ devnull => [],
+ rootdir => [],
+ updir => [],
+);
+
foreach my $meth (@EXPORT, @EXPORT_OK) {
my $sub = File::Spec->can($meth);
no strict 'refs';
- *{$meth} = sub {&$sub('File::Spec', @_)};
+ if (exists($udeps{$meth}) && $sub == File::Spec::Unix->can($meth) &&
+ !(grep {
+ File::Spec->can($_) != File::Spec::Unix->can($_)
+ } @{$udeps{$meth}}) &&
+ defined(&{"File::Spec::Unix::_fn_$meth"})) {
+ *{$meth} = \&{"File::Spec::Unix::_fn_$meth"};
+ } else {
+ *{$meth} = sub {&$sub('File::Spec', @_)};
+ }
}
use vars qw(@ISA $VERSION);
require File::Spec::Unix;
-$VERSION = '3.41';
+$VERSION = '3.44';
$VERSION =~ tr/_//;
@ISA = qw(File::Spec::Unix);
use vars qw(@ISA $VERSION);
require File::Spec::Unix;
-$VERSION = '3.41';
+$VERSION = '3.44';
$VERSION =~ tr/_//;
@ISA = qw(File::Spec::Unix);
use strict;
use vars qw($VERSION);
-$VERSION = '3.41';
+$VERSION = '3.44';
+my $xs_version = $VERSION;
$VERSION =~ tr/_//;
+unless (defined &canonpath) {
+ eval {
+ if ( $] >= 5.006 ) {
+ require XSLoader;
+ XSLoader::load("Cwd", $xs_version);
+ } else {
+ require Cwd;
+ }
+ };
+}
+
=head1 NAME
File::Spec::Unix - File::Spec for Unix, base for other File::Spec modules
=cut
-sub canonpath {
+sub _pp_canonpath {
my ($self,$path) = @_;
return unless defined $path;
$path =~ s|/\z|| unless $path eq "/"; # xx/ -> xx
return "$node$path";
}
+*canonpath = \&_pp_canonpath unless defined &canonpath;
=item catdir()
=cut
-sub catdir {
+sub _pp_catdir {
my $self = shift;
$self->canonpath(join('/', @_, '')); # '' because need a trailing '/'
}
+*catdir = \&_pp_catdir unless defined &catdir;
=item catfile
=cut
-sub catfile {
+sub _pp_catfile {
my $self = shift;
my $file = $self->canonpath(pop @_);
return $file unless @_;
$dir .= "/" unless substr($dir,-1) eq "/";
return $dir.$file;
}
+*catfile = \&_pp_catfile unless defined &catfile;
=item curdir
=cut
sub curdir { '.' }
+use constant _fn_curdir => ".";
=item devnull
=cut
sub devnull { '/dev/null' }
+use constant _fn_devnull => "/dev/null";
=item rootdir
=cut
sub rootdir { '/' }
+use constant _fn_rootdir => "/";
=item tmpdir
=cut
sub updir { '..' }
+use constant _fn_updir => "..";
=item no_upwards
=cut
sub case_tolerant { 0 }
+use constant _fn_case_tolerant => 0;
=item file_name_is_absolute
use vars qw(@ISA $VERSION);
require File::Spec::Unix;
-$VERSION = '3.43';
+$VERSION = '3.44';
$VERSION =~ tr/_//;
@ISA = qw(File::Spec::Unix);
use vars qw(@ISA $VERSION);
require File::Spec::Unix;
-$VERSION = '3.42';
+$VERSION = '3.44';
$VERSION =~ tr/_//;
@ISA = qw(File::Spec::Unix);
#!/usr/bin/perl -w
-use Test::More tests => 3;
+use Test::More tests => 15;
BEGIN {use_ok('File::Spec::Functions', ':ALL');}
+is(canonpath('a/b/c'), File::Spec->canonpath('a/b/c'));
+is(case_tolerant(), File::Spec->case_tolerant());
+is(catdir(), File::Spec->catdir());
+is(catdir('a'), File::Spec->catdir('a'));
+is(catdir('a','b'), File::Spec->catdir('a','b'));
+is(catdir('a','b','c'), File::Spec->catdir('a','b','c'));
+is(catfile(), File::Spec->catfile());
+is(catfile('a'), File::Spec->catfile('a'));
+is(catfile('a','b'), File::Spec->catfile('a','b'));
is(catfile('a','b','c'), File::Spec->catfile('a','b','c'));
-
-# seems to return 0 or 1, so see if we can call it - 2003-07-07 tels
-like(case_tolerant(), qr/\A(?:0|1)\z/);
+is(curdir(), File::Spec->curdir());
+is(devnull(), File::Spec->devnull());
+is(rootdir(), File::Spec->rootdir());
+is(updir(), File::Spec->updir());
[ "Unix->catfile('./a','b','c')", 'a/b/c' ],
[ "Unix->catfile('c')", 'c' ],
[ "Unix->catfile('./c')", 'c' ],
+[ "Unix->catfile('a', 'b'.chr(0xaf))", 'a/b'.chr(0xaf) ],
+($] >= 5.008 ? (
+[ "Unix->catfile('a', do { my \$x = 'b'.chr(0xaf); use utf8 (); utf8::upgrade(\$x); \$x })", 'a/b'.chr(0xaf) ],
+) : ()),
+[ "Unix->catfile(substr('foo', 2))", 'o' ],
[ "Unix->splitpath('file')", ',,file' ],
[ "Unix->splitpath('/d1/d2/d3/')", ',/d1/d2/d3/,' ],
[ "Unix->catdir('d1','d2','d3')", 'd1/d2/d3' ],
# QNX is POSIXly special
[ "Unix->catdir('/','d2/d3')", ( $^O =~ m!^(nto|qnx)! ? '//d2/d3' : '/d2/d3' ) ],
+[ "Unix->catdir('a', 'b'.chr(0xaf))", 'a/b'.chr(0xaf) ],
+($] >= 5.008 ? (
+[ "Unix->catdir('a', do { my \$x = 'b'.chr(0xaf); use utf8 (); utf8::upgrade(\$x); \$x })", 'a/b'.chr(0xaf) ],
+) : ()),
[ "Unix->canonpath('///../../..//./././a//b/.././c/././')", '/a/b/../c' ],
[ "Unix->canonpath('')", '' ],
# rt.perl.org 27052
[ "Unix->canonpath('a/../../b/c')", 'a/../../b/c' ],
+[ "Unix->canonpath('/')", '/' ],
+[ "Unix->canonpath('///')", '/' ],
[ "Unix->canonpath('/.')", '/' ],
[ "Unix->canonpath('/./')", '/' ],
+[ "Unix->canonpath('///.')", '/' ],
+[ "Unix->canonpath('///.///')", '/' ],
+[ "Unix->canonpath('///..')", '/' ],
+[ "Unix->canonpath('///..///')", '/' ],
+[ "Unix->canonpath('///..///.///..///')", '/' ],
+[ "Unix->canonpath('.')", '.' ],
+[ "Unix->canonpath('.///')", '.' ],
+[ "Unix->canonpath('.///.')", '.' ],
+[ "Unix->canonpath('.///.///')", '.' ],
+[ "Unix->canonpath('..')", '..' ],
+[ "Unix->canonpath('..///')", '..' ],
+[ "Unix->canonpath('../..')", '../..' ],
+[ "Unix->canonpath('../../')", '../..' ],
+[ "Unix->canonpath('..///.///..///')", '../..' ],
+[ "Unix->canonpath('///../../..//./././a//b/.././c/././')", '/a/b/../c' ],
+[ "Unix->canonpath('a/../../b/c')", 'a/../../b/c' ],
+[ "Unix->canonpath('a///..///..///b////c')", 'a/../../b/c' ],
+[ "Unix->canonpath('.///a///.///..///.///..///.///b///.////c///.')", 'a/../../b/c' ],
[ "Unix->canonpath('/a/./')", '/a' ],
[ "Unix->canonpath('/a/.')", '/a' ],
[ "Unix->canonpath('/../../')", '/' ],
[ "Unix->canonpath('/../..')", '/' ],
+[ "Unix->canonpath('/foo', '/bar')", '/foo' ],
+[ "Unix->canonpath('///a'.chr(0xaf))", '/a'.chr(0xaf) ],
+($] >= 5.008 ? (
+[ "Unix->canonpath(do { my \$x = '///a'.chr(0xaf); use utf8 (); utf8::upgrade(\$x); \$x })", '/a'.chr(0xaf) ],
+) : ()),
[ "Unix->abs2rel('/t1/t2/t3','/t1/t2/t3')", '.' ],
[ "Unix->abs2rel('/t1/t2/t4','/t1/t2/t3')", '../t4' ],
}
}
+is +File::Spec::Unix->canonpath(), undef;
+
done_testing();