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