From a9939470558f41efaae5bf23fe0c76fc3a2402ea Mon Sep 17 00:00:00 2001 From: Nicholas Clark Date: Sat, 27 Dec 2003 17:20:23 +0000 Subject: [PATCH] Assimilate Cwd 2.12 from CPAN. Cwd wasn't in Maintainers, so change 21646 was only applied to core (must punt this back and thereby unfork) Need to fix test boilerplate properly for PERL_CORE p4raw-id: //depot/perl@21972 --- MANIFEST | 1 + Porting/Maintainers.pl | 7 +++ ext/Cwd/Cwd.xs | 151 +++++++++++++++++++++++++++++++++++++++++++++++++ ext/Cwd/t/cwd.t | 3 +- ext/Cwd/t/taint.t | 7 +-- lib/Cwd.pm | 66 ++++++++++----------- 6 files changed, 193 insertions(+), 42 deletions(-) diff --git a/MANIFEST b/MANIFEST index e851d1d..a0e533d 100644 --- a/MANIFEST +++ b/MANIFEST @@ -130,6 +130,7 @@ ext/ByteLoader/byterun.c Runtime support for bytecode loader ext/ByteLoader/byterun.h Header for byterun.c ext/ByteLoader/hints/sunos.pl Hints for named architecture ext/ByteLoader/Makefile.PL Bytecode loader makefile writer +ext/Cwd/Changes Cwd extension Changelog ext/Cwd/Cwd.xs Cwd extension external subroutines ext/Cwd/Makefile.PL Cwd extension makefile maker ext/Cwd/t/cwd.t See if Cwd works diff --git a/Porting/Maintainers.pl b/Porting/Maintainers.pl index bcdb25a..7f90a78 100644 --- a/Porting/Maintainers.pl +++ b/Porting/Maintainers.pl @@ -108,6 +108,13 @@ package Maintainers; 'CPAN' => 1, }, + 'Cwd' => + { + 'MAINTAINER' => 'kwilliams', + 'FILES' => q[ext/Cwd lib/Cwd.pm], + 'CPAN' => 1, + }, + 'Data::Dumper' => { 'MAINTAINER' => 'ilyam', # Not gsar. diff --git a/ext/Cwd/Cwd.xs b/ext/Cwd/Cwd.xs index 4600fef..6f8dc96 100644 --- a/ext/Cwd/Cwd.xs +++ b/ext/Cwd/Cwd.xs @@ -210,6 +210,157 @@ err2: #endif } +#ifndef getcwd_sv +// Taken from perl 5.8's util.c +int getcwd_sv(pTHX_ register SV *sv) +{ +#ifndef PERL_MICRO + +#ifndef INCOMPLETE_TAINTS + SvTAINTED_on(sv); +#endif + +#ifdef HAS_GETCWD + { + char buf[MAXPATHLEN]; + + /* Some getcwd()s automatically allocate a buffer of the given + * size from the heap if they are given a NULL buffer pointer. + * The problem is that this behaviour is not portable. */ + if (getcwd(buf, sizeof(buf) - 1)) { + STRLEN len = strlen(buf); + sv_setpvn(sv, buf, len); + return TRUE; + } + else { + sv_setsv(sv, &PL_sv_undef); + return FALSE; + } + } + +#else + + Stat_t statbuf; + int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino; + int namelen, pathlen=0; + DIR *dir; + Direntry_t *dp; + + (void)SvUPGRADE(sv, SVt_PV); + + if (PerlLIO_lstat(".", &statbuf) < 0) { + SV_CWD_RETURN_UNDEF; + } + + orig_cdev = statbuf.st_dev; + orig_cino = statbuf.st_ino; + cdev = orig_cdev; + cino = orig_cino; + + for (;;) { + odev = cdev; + oino = cino; + + if (PerlDir_chdir("..") < 0) { + SV_CWD_RETURN_UNDEF; + } + if (PerlLIO_stat(".", &statbuf) < 0) { + SV_CWD_RETURN_UNDEF; + } + + cdev = statbuf.st_dev; + cino = statbuf.st_ino; + + if (odev == cdev && oino == cino) { + break; + } + if (!(dir = PerlDir_open("."))) { + SV_CWD_RETURN_UNDEF; + } + + while ((dp = PerlDir_read(dir)) != NULL) { +#ifdef DIRNAMLEN + namelen = dp->d_namlen; +#else + namelen = strlen(dp->d_name); +#endif + /* skip . and .. */ + if (SV_CWD_ISDOT(dp)) { + continue; + } + + if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) { + SV_CWD_RETURN_UNDEF; + } + + tdev = statbuf.st_dev; + tino = statbuf.st_ino; + if (tino == oino && tdev == odev) { + break; + } + } + + if (!dp) { + SV_CWD_RETURN_UNDEF; + } + + if (pathlen + namelen + 1 >= MAXPATHLEN) { + SV_CWD_RETURN_UNDEF; + } + + SvGROW(sv, pathlen + namelen + 1); + + if (pathlen) { + /* shift down */ + Move(SvPVX(sv), SvPVX(sv) + namelen + 1, pathlen, char); + } + + /* prepend current directory to the front */ + *SvPVX(sv) = '/'; + Move(dp->d_name, SvPVX(sv)+1, namelen, char); + pathlen += (namelen + 1); + +#ifdef VOID_CLOSEDIR + PerlDir_close(dir); +#else + if (PerlDir_close(dir) < 0) { + SV_CWD_RETURN_UNDEF; + } +#endif + } + + if (pathlen) { + SvCUR_set(sv, pathlen); + *SvEND(sv) = '\0'; + SvPOK_only(sv); + + if (PerlDir_chdir(SvPVX(sv)) < 0) { + SV_CWD_RETURN_UNDEF; + } + } + if (PerlLIO_stat(".", &statbuf) < 0) { + SV_CWD_RETURN_UNDEF; + } + + cdev = statbuf.st_dev; + cino = statbuf.st_ino; + + if (cdev != orig_cdev || cino != orig_cino) { + Perl_croak(aTHX_ "Unstable directory path, " + "current directory changed unexpectedly"); + } + + return TRUE; +#endif + +#else + return FALSE; +#endif +} + +#endif + + MODULE = Cwd PACKAGE = Cwd PROTOTYPES: ENABLE diff --git a/ext/Cwd/t/cwd.t b/ext/Cwd/t/cwd.t index 514f2b1..92ec184 100644 --- a/ext/Cwd/t/cwd.t +++ b/ext/Cwd/t/cwd.t @@ -1,12 +1,11 @@ #!./perl +use Cwd; BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; } use Config; -use Cwd; use strict; use warnings; use File::Spec; diff --git a/ext/Cwd/t/taint.t b/ext/Cwd/t/taint.t index 2cd7d19..9c6748e 100644 --- a/ext/Cwd/t/taint.t +++ b/ext/Cwd/t/taint.t @@ -1,13 +1,12 @@ #!./perl -Tw # Testing Cwd under taint mode. +use Cwd; BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; } use strict; -use Cwd; use Test::More tests => 16; use Scalar::Util qw/tainted/; @@ -20,6 +19,6 @@ foreach my $func (@Functions) { no strict 'refs'; my $cwd; eval { $cwd = &{'Cwd::'.$func} }; - is( $@, '', "$func() does not explode under taint mode" ); - ok( tainted($cwd), "its return value is tainted" ); + is( $@, '', "$func() should not explode under taint mode" ); + ok( tainted($cwd), "its return value should be tainted" ); } diff --git a/lib/Cwd.pm b/lib/Cwd.pm index 984375f..51ca5b6 100644 --- a/lib/Cwd.pm +++ b/lib/Cwd.pm @@ -1,5 +1,4 @@ package Cwd; -use 5.006; =head1 NAME @@ -137,12 +136,14 @@ L =cut use strict; +use Exporter; +use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); -our $VERSION = '2.08'; +$VERSION = '2.12'; -use base qw/ Exporter /; -our @EXPORT = qw(cwd getcwd fastcwd fastgetcwd); -our @EXPORT_OK = qw(chdir abs_path fast_abs_path realpath fast_realpath); +@ISA = qw/ Exporter /; +@EXPORT = qw(cwd getcwd fastcwd fastgetcwd); +@EXPORT_OK = qw(chdir abs_path fast_abs_path realpath fast_realpath); # sys_cwd may keep the builtin command @@ -150,16 +151,19 @@ our @EXPORT_OK = qw(chdir abs_path fast_abs_path realpath fast_realpath); # there is no sense to process the rest of the file. # The best choice may be to have this in BEGIN, but how to return from BEGIN? -if ($^O eq 'os2' && defined &sys_cwd && defined &sys_abspath) { +if ($^O eq 'os2') { local $^W = 0; - *cwd = \&sys_cwd; - *getcwd = \&cwd; - *fastgetcwd = \&cwd; - *fastcwd = \&cwd; - *abs_path = \&sys_abspath; - *fast_abs_path = \&abs_path; - *realpath = \&abs_path; - *fast_realpath = \&abs_path; + + *cwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd; + *getcwd = \&cwd; + *fastgetcwd = \&cwd; + *fastcwd = \&cwd; + + *fast_abs_path = \&sys_abspath if defined &sys_abspath; + *abs_path = \&fast_abs_path; + *realpath = \&fast_abs_path; + *fast_realpath = \&fast_abs_path; + return 1; } @@ -191,6 +195,10 @@ unless ($pwd_cmd) { } } +# Lazy-load Carp +sub _carp { require Carp; Carp::carp(@_) } +sub _croak { require Carp; Carp::croak(@_) } + # The 'natural and safe form' for UNIX (pwd may be setuid root) sub _backtick_pwd { local @ENV{qw(PATH IFS CDPATH ENV BASH_ENV)}; @@ -358,8 +366,7 @@ sub _perl_abs_path unless (@cst = stat( $start )) { - require Carp; - Carp::carp ("stat($start): $!"); + _carp("stat($start): $!"); return ''; } $cwd = ''; @@ -371,14 +378,12 @@ sub _perl_abs_path local *PARENT; unless (opendir(PARENT, $dotdots)) { - require Carp; - Carp::carp ("opendir($dotdots): $!"); + _carp("opendir($dotdots): $!"); return ''; } unless (@cst = stat($dotdots)) { - require Carp; - Carp::carp ("stat($dotdots): $!"); + _carp("stat($dotdots): $!"); closedir(PARENT); return ''; } @@ -392,8 +397,7 @@ sub _perl_abs_path { unless (defined ($dir = readdir(PARENT))) { - require Carp; - Carp::carp ("readdir($dotdots): $!"); + _carp("readdir($dotdots): $!"); closedir(PARENT); return ''; } @@ -426,13 +430,11 @@ sub fast_abs_path { ($cwd) = $cwd =~ /(.*)/; if (!CORE::chdir($path)) { - require Carp; - Carp::croak ("Cannot chdir to $path: $!"); + _croak("Cannot chdir to $path: $!"); } my $realpath = getcwd(); if (! ((-d $cwd) && (CORE::chdir($cwd)))) { - require Carp; - Carp::croak ("Cannot chdir back to $cwd: $!"); + _croak("Cannot chdir back to $cwd: $!"); } $realpath; } @@ -461,8 +463,7 @@ sub _vms_abs_path { my $path = VMS::Filespec::pathify($_[0]); if (! defined $path) { - require Carp; - Carp::croak("Invalid path name $_[0]") + _croak("Invalid path name $_[0]") } return VMS::Filespec::rmsexpand($path); } @@ -545,14 +546,6 @@ sub _epoc_cwd { *abs_path = \&fast_abs_path; *realpath = \&fast_abs_path; } - elsif ($^O eq 'os2') { - # sys_cwd may keep the builtin command - *cwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd; - *getcwd = \&cwd; - *fastgetcwd = \&cwd; - *fastcwd = \&cwd; - *abs_path = \&fast_abs_path; - } elsif ($^O eq 'dos') { *cwd = \&_dos_cwd; *getcwd = \&_dos_cwd; @@ -573,6 +566,7 @@ sub _epoc_cwd { *fastgetcwd = \&cwd; *fastcwd = \&cwd; *abs_path = \&fast_abs_path; + *realpath = \&abs_path; } elsif ($^O eq 'epoc') { *cwd = \&_epoc_cwd; -- 2.7.4