lib/fastcwd.pl

   1 warn "Legacy library @{[(caller(0))[6]]} will be removed from the Perl core distribution in the next major release. Please install it from the CPAN distribution Perl4::CoreLibs. It is being used at @{[(caller)[1]]}, line @{[(caller)[2]]}.\n";
   2
   3 # By John Bazik
   4 #
   5 # This library is no longer being maintained, and is included for backward
   6 # compatibility with Perl 4 programs which may require it.
   7 # This legacy library is deprecated and will be removed in a future
   8 # release of perl.
   9 #
  10 # In particular, this should not be used as an example of modern Perl
  11 # programming techniques.
  12 #
  13 # Suggested alternative: Cwd
  14
  15 # Usage: $cwd = &fastcwd;
  16 #
  17 # This is a faster version of getcwd.  It's also more dangerous because
  18 # you might chdir out of a directory that you can't chdir back into.
  19
  20 sub fastcwd {
  21         local($odev, $oino, $cdev, $cino, $tdev, $tino);
  22         local(@path, $path);
  23         local(*DIR);
  24
  25         ($cdev, $cino) = stat('.');
  26         for (;;) {
  27                 ($odev, $oino) = ($cdev, $cino);
  28                 chdir('..');
  29                 ($cdev, $cino) = stat('.');
  30                 last if $odev == $cdev && $oino == $cino;
  31                 opendir(DIR, '.');
  32                 for (;;) {
  33                         $_ = readdir(DIR);
  34                         next if $_ eq '.';
  35                         next if $_ eq '..';
  36
  37                         last unless $_;
  38                         ($tdev, $tino) = lstat($_);
  39                         last unless $tdev != $odev || $tino != $oino;
  40                 }
  41                 closedir(DIR);
  42                 unshift(@path, $_);
  43         }
  44         chdir($path = '/' . join('/', @path));
  45         $path;
  46 }
  47 1;