lib/Cwd.pm

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