lib/Cwd.pm

   1 package Cwd;
   2 require 5.000;
   3 require Exporter;
   4 use Config;
   5
   6 =head1 NAME
   7
   8 getcwd - get pathname of current working directory
   9
  10 =head1 SYNOPSIS
  11
  12     require Cwd;
  13     $dir = Cwd::getcwd();
  14
  15     use Cwd;
  16     $dir = getcwd();
  17
  18     use Cwd 'chdir';
  19     chdir "/tmp";
  20     print $ENV{'PWD'};
  21
  22 =head1 DESCRIPTION
  23
  24 The getcwd() function re-implements the getcwd(3) (or getwd(3)) functions
  25 in Perl.  If you ask to override your chdir() built-in function, then your
  26 PWD environment variable will be kept up to date.  (See
  27 L<perlsub/Overriding builtin functions>.)
  28
  29 The fastgetcwd() function looks the same as getcwd(), but runs faster.
  30 It's also more dangerous because you might conceivably chdir() out of a
  31 directory that you can't chdir() back into.
  32
  33 =cut
  34
  35 @ISA = qw(Exporter);
  36 @EXPORT = qw(getcwd fastcwd);
  37 @EXPORT_OK = qw(chdir);
  38
  39
  40 # VMS: $ENV{'DEFAULT'} points to default directory at all times
  41 # 08-Dec-1994  Charles Bailey  bailey@genetics.upenn.edu
  42 # Note: Use of Cwd::getcwd() or Cwd::chdir() (but not Cwd::fastcwd())
  43 #   causes the logical name PWD to be defined in the process
  44 #   logical name table as the default device and directory
  45 #   seen by Perl. This may not be the same as the default device
  46 #   and directory seen by DCL after Perl exits, since the effects
  47 #   the CRTL chdir() function persist only until Perl exits.
  48
  49 # By Brandon S. Allbery
  50 #
  51 # Usage: $cwd = getcwd();
  52
  53 sub getcwd
  54 {
  55     if($Config{'osname'} eq 'VMS') { return $ENV{'PWD'} = $ENV{'DEFAULT'} }
  56
  57     my($dotdots, $cwd, @pst, @cst, $dir, @tst);
  58
  59     unless (@cst = stat('.'))
  60     {
  61         warn "stat(.): $!";
  62         return '';
  63     }
  64     $cwd = '';
  65     $dotdots = '';
  66     do
  67     {
  68         $dotdots .= '/' if $dotdots;
  69         $dotdots .= '..';
  70         @pst = @cst;
  71         unless (opendir(PARENT, $dotdots))
  72         {
  73             warn "opendir($dotdots): $!";
  74             return '';
  75         }
  76         unless (@cst = stat($dotdots))
  77         {
  78             warn "stat($dotdots): $!";
  79             closedir(PARENT);
  80             return '';
  81         }
  82         if ($pst[0] == $cst[0] && $pst[1] == $cst[1])
  83         {
  84             $dir = '';
  85         }
  86         else
  87         {
  88             do
  89             {
  90                 unless (defined ($dir = readdir(PARENT)))
  91                 {
  92                     warn "readdir($dotdots): $!";
  93                     closedir(PARENT);
  94                     return '';
  95                 }
  96                 unless (@tst = lstat("$dotdots/$dir"))
  97                 {
  98                     warn "lstat($dotdots/$dir): $!";
  99                     closedir(PARENT);
 100                     return '';
 101                 }
 102             }
 103             while ($dir eq '.' || $dir eq '..' || $tst[0] != $pst[0] ||
 104                    $tst[1] != $pst[1]);
 105         }
 106         $cwd = "$dir/$cwd";
 107         closedir(PARENT);
 108     } while ($dir);
 109     chop($cwd); # drop the trailing /
 110     $cwd;
 111 }
 112
 113
 114
 115 # By John Bazik
 116 #
 117 # Usage: $cwd = &fastcwd;
 118 #
 119 # This is a faster version of getcwd.  It's also more dangerous because
 120 # you might chdir out of a directory that you can't chdir back into.
 121
 122 sub fastcwd {
 123     if($Config{'osname'} eq 'VMS') { return $ENV{'DEFAULT'} }
 124
 125     my($odev, $oino, $cdev, $cino, $tdev, $tino);
 126     my(@path, $path);
 127     local(*DIR);
 128
 129     ($cdev, $cino) = stat('.');
 130     for (;;) {
 131         my $direntry;
 132         ($odev, $oino) = ($cdev, $cino);
 133         chdir('..');
 134         ($cdev, $cino) = stat('.');
 135         last if $odev == $cdev && $oino == $cino;
 136         opendir(DIR, '.');
 137         for (;;) {
 138             $direntry = readdir(DIR);
 139             next if $direntry eq '.';
 140             next if $direntry eq '..';
 141
 142             last unless defined $direntry;
 143             ($tdev, $tino) = lstat($direntry);
 144             last unless $tdev != $odev || $tino != $oino;
 145         }
 146         closedir(DIR);
 147         unshift(@path, $direntry);
 148     }
 149     chdir($path = '/' . join('/', @path));
 150     $path;
 151 }
 152
 153
 154 # keeps track of current working directory in PWD environment var
 155 #
 156 # $RCSfile: pwd.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:24:11 $
 157 #
 158 # $Log: pwd.pl,v $
 159 #
 160 # Usage:
 161 #       use Cwd 'chdir';
 162 #       chdir $newdir;
 163
 164 $chdir_init = 0;
 165
 166 sub chdir_init{
 167     if ($ENV{'PWD'}) {
 168         my($dd,$di) = stat('.');
 169         my($pd,$pi) = stat($ENV{'PWD'});
 170         if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) {
 171             chop($ENV{'PWD'} = `pwd`);
 172         }
 173     }
 174     else {
 175         chop($ENV{'PWD'} = `pwd`);
 176     }
 177     if ($ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|) {
 178         my($pd,$pi) = stat($2);
 179         my($dd,$di) = stat($1);
 180         if (defined $pd and defined $dd and $di == $pi and $dd == $pd) {
 181             $ENV{'PWD'}="$2$3";
 182         }
 183     }
 184     $chdir_init = 1;
 185 }
 186
 187 sub chdir {
 188     my($newdir) = shift;
 189     $newdir =~ s|/{2,}|/|g;
 190     chdir_init() unless $chdir_init;
 191     return 0 unless (CORE::chdir $newdir);
 192     if ($Config{'osname'} eq 'VMS') { return $ENV{PWD} = $ENV{DEFAULT} }
 193
 194     if ($newdir =~ m#^/#) {
 195         $ENV{'PWD'} = $newdir;
 196     }else{
 197         my(@curdir) = split(m#/#,$ENV{'PWD'});
 198         @curdir = '' unless @curdir;
 199         foreach $component (split(m#/#, $newdir)) {
 200             next if $component eq '.';
 201             pop(@curdir),next if $component eq '..';
 202             push(@curdir,$component);
 203         }
 204         $ENV{'PWD'} = join('/',@curdir) || '/';
 205     }
 206 }
 207
 208 1;
 209