lib/Cwd.pm

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