X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FCwd.pm;h=bee2e179aef6273680f1c5b3414fd67fa3c3d807;hb=79dd614e1e8c3b0e4ed35016e6971240b606da64;hp=9aa57ecad481124ae979acfb117332c503d7f50c;hpb=3edbfbe5ecbb7e6fb99acc874379580a458f3cff;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/Cwd.pm b/lib/Cwd.pm index 9aa57ec..bee2e17 100644 --- a/lib/Cwd.pm +++ b/lib/Cwd.pm @@ -2,10 +2,64 @@ package Cwd; require 5.000; require Exporter; +=head1 NAME + +getcwd - get pathname of current working directory + +=head1 SYNOPSIS + + use Cwd; + $dir = cwd; + + use Cwd; + $dir = getcwd; + + use Cwd; + $dir = fastgetcwd; + + use Cwd 'chdir'; + chdir "/tmp"; + print $ENV{'PWD'}; + +=head1 DESCRIPTION + +The getcwd() function re-implements the getcwd(3) (or getwd(3)) functions +in Perl. + +The fastcwd() function looks the same as getcwd(), but runs faster. +It's also more dangerous because you might conceivably chdir() out of a +directory that you can't chdir() back into. + +The cwd() function looks the same as getcwd and fastgetcwd but is +implemented using the most natural and safe form for the current +architecture. For most systems it is identical to `pwd` (but without +the trailing line terminator). It is recommended that cwd (or another +*cwd() function) is used in I code to ensure portability. + +If you ask to override your chdir() built-in function, then your PWD +environment variable will be kept up to date. (See +L.) Note that it will only be +kept up to date it all packages which use chdir import it from Cwd. + +=cut + @ISA = qw(Exporter); -@EXPORT = qw(getcwd fastcwd); +@EXPORT = qw(cwd getcwd fastcwd fastgetcwd); @EXPORT_OK = qw(chdir); +# use strict; + +sub _backtick_pwd { # The 'natural and safe form' for UNIX (pwd may be setuid root) + my $cwd; + chop($cwd = `pwd`); + $cwd; +} + +# Since some ports may predefine cwd internally (e.g., NT) +# we take care not to override an existing definition for cwd(). + +*cwd = \&_backtick_pwd unless defined &cwd; + # By Brandon S. Allbery # @@ -55,8 +109,10 @@ sub getcwd unless (@tst = lstat("$dotdots/$dir")) { warn "lstat($dotdots/$dir): $!"; - closedir(PARENT); - return ''; + # Just because you can't lstat this directory + # doesn't mean you'll never find the right one. + # closedir(PARENT); + # return ''; } } while ($dir eq '.' || $dir eq '..' || $tst[0] != $pst[0] || @@ -85,51 +141,48 @@ sub fastcwd { ($cdev, $cino) = stat('.'); for (;;) { + my $direntry; ($odev, $oino) = ($cdev, $cino); chdir('..'); ($cdev, $cino) = stat('.'); last if $odev == $cdev && $oino == $cino; opendir(DIR, '.'); for (;;) { - $_ = readdir(DIR); - next if $_ eq '.'; - next if $_ eq '..'; + $direntry = readdir(DIR); + next if $direntry eq '.'; + next if $direntry eq '..'; - last unless defined; - ($tdev, $tino) = lstat($_); + last unless defined $direntry; + ($tdev, $tino) = lstat($direntry); last unless $tdev != $odev || $tino != $oino; } closedir(DIR); - unshift(@path, $_); + unshift(@path, $direntry); } chdir($path = '/' . join('/', @path)); $path; } -# keeps track of current working directory in PWD environment var -# -# $RCSfile: pwd.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:24:11 $ -# -# $Log: pwd.pl,v $ -# +# Keeps track of current working directory in PWD environment var # Usage: # use Cwd 'chdir'; # chdir $newdir; -$chdir_init = 0; +my $chdir_init = 0; -sub chdir_init{ - if ($ENV{'PWD'}) { +sub chdir_init { + if ($ENV{'PWD'} and $^O ne 'os2') { my($dd,$di) = stat('.'); my($pd,$pi) = stat($ENV{'PWD'}); if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) { - chop($ENV{'PWD'} = `pwd`); + $ENV{'PWD'} = cwd(); } } else { - chop($ENV{'PWD'} = `pwd`); + $ENV{'PWD'} = cwd(); } + # Strip an automounter prefix (where /tmp_mnt/foo/bar == /foo/bar) if ($ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|) { my($pd,$pi) = stat($2); my($dd,$di) = stat($1); @@ -141,14 +194,18 @@ sub chdir_init{ } sub chdir { - my($newdir) = shift; + my $newdir = shift || ''; # allow for no arg (chdir to HOME dir) + $newdir =~ s|///*|/|g; chdir_init() unless $chdir_init; - return 0 unless (CORE::chdir $newdir); + return 0 unless CORE::chdir $newdir; + if ($^O eq 'VMS') { return $ENV{'PWD'} = $ENV{'DEFAULT'} } + if ($newdir =~ m#^/#) { $ENV{'PWD'} = $newdir; - }else{ - my(@curdir) = split(m#/#,$ENV{'PWD'}); - @curdir = '' unless @curdir; + } else { + my @curdir = split(m#/#,$ENV{'PWD'}); + @curdir = ('') unless @curdir; + my $component; foreach $component (split(m#/#, $newdir)) { next if $component eq '.'; pop(@curdir),next if $component eq '..'; @@ -156,7 +213,59 @@ sub chdir { } $ENV{'PWD'} = join('/',@curdir) || '/'; } + 1; +} + + +# --- PORTING SECTION --- + +# VMS: $ENV{'DEFAULT'} points to default directory at all times +# 06-Mar-1996 Charles Bailey bailey@genetics.upenn.edu +# Note: Use of Cwd::chdir() causes the logical name PWD to be defined +# in the process logical name table as the default device and directory +# seen by Perl. This may not be the same as the default device +# and directory seen by DCL after Perl exits, since the effects +# the CRTL chdir() function persist only until Perl exits. + +sub _vms_cwd { + return $ENV{'DEFAULT'} +} +sub _os2_cwd { + $ENV{'PWD'} = `cmd /c cd`; + chop $ENV{'PWD'}; + $ENV{'PWD'} =~ s:\\:/:g ; + return $ENV{'PWD'}; +} + +my($oldw) = $^W; +$^W = 0; # assignments trigger 'subroutine redefined' warning +if ($^O eq 'VMS') { + + *cwd = \&_vms_cwd; + *getcwd = \&_vms_cwd; + *fastcwd = \&_vms_cwd; + *fastgetcwd = \&_vms_cwd; } +elsif ($^O eq 'NT') { + + *getcwd = \&cwd; + *fastgetcwd = \&cwd; +} +elsif ($^O eq 'os2') { + *cwd = \&_os2_cwd; + *getcwd = \&_os2_cwd; + *fastgetcwd = \&_os2_cwd; + *fastcwd = \&_os2_cwd; +} +$^W = $oldw; + +# package main; eval join('',) || die $@; # quick test 1; +__END__ +BEGIN { import Cwd qw(:DEFAULT chdir); } +print join("\n", cwd, getcwd, fastcwd, ""); +chdir('..'); +print join("\n", cwd, getcwd, fastcwd, ""); +print "$ENV{PWD}\n";