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 ($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);
  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         ($odev, $oino) = ($cdev, $cino);
  89         chdir('..');
  90         ($cdev, $cino) = stat('.');
  91         last if $odev == $cdev && $oino == $cino;
  92         opendir(DIR, '.');
  93         for (;;) {
  94             $_ = readdir(DIR);
  95             next if $_ eq '.';
  96             next if $_ eq '..';
  97
  98             last unless $_;
  99             ($tdev, $tino) = lstat($_);
 100             last unless $tdev != $odev || $tino != $oino;
 101         }
 102         closedir(DIR);
 103         unshift(@path, $_);
 104     }
 105     chdir($path = '/' . join('/', @path));
 106     $path;
 107 }
 108
 109
 110 # keeps track of current working directory in PWD environment var
 111 #
 112 # $RCSfile: pwd.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:24:11 $
 113 #
 114 # $Log: pwd.pl,v $
 115 #
 116 # Usage:
 117 #       use Cwd 'chdir';
 118 #       chdir $newdir;
 119
 120 $chdir_init = 0;
 121
 122 sub chdir_init{
 123     if ($ENV{'PWD'}) {
 124         my($dd,$di) = stat('.');
 125         my($pd,$pi) = stat($ENV{'PWD'});
 126         if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) {
 127             chop($ENV{'PWD'} = `pwd`);
 128         }
 129     }
 130     else {
 131         chop($ENV{'PWD'} = `pwd`);
 132     }
 133     if ($ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|) {
 134         my($pd,$pi) = stat($2);
 135         my($dd,$di) = stat($1);
 136         if (defined $pd and defined $dd and $di == $pi and $dd == $pd) {
 137             $ENV{'PWD'}="$2$3";
 138         }
 139     }
 140     $chdir_init = 1;
 141 }
 142
 143 sub chdir {
 144     my($newdir) = shift;
 145     chdir_init() unless $chdir_init;
 146     return 0 unless (CORE::chdir $newdir);
 147     if ($newdir =~ m#^/#) {
 148         $ENV{'PWD'} = $newdir;
 149     }else{
 150         my(@curdir) = split(m#/#,$ENV{'PWD'});
 151         @curdir = '' unless @curdir;
 152         foreach $component (split(m#/#, $newdir)) {
 153             next if $component eq '.';
 154             pop(@curdir),next if $component eq '..';
 155             push(@curdir,$component);
 156         }
 157         $ENV{'PWD'} = join('/',@curdir) || '/';
 158     }
 159 }
 160
 161 1;
 162