lib/getcwd.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 Brandon S. Allbery
   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 # In particular, this should not be used as an example of modern Perl
  10 # programming techniques.
  11 #
  12 # Suggested alternative: Cwd
  13
  14 #
  15 # Usage: $cwd = &getcwd;
  16
  17 sub getcwd
  18 {
  19     local($dotdots, $cwd, @pst, @cst, $dir, @tst);
  20
  21     unless (@cst = stat('.'))
  22     {
  23         warn "stat(.): $!";
  24         return '';
  25     }
  26     $cwd = '';
  27     do
  28     {
  29         $dotdots .= '/' if $dotdots;
  30         $dotdots .= '..';
  31         @pst = @cst;
  32         unless (opendir(getcwd'PARENT, $dotdots))                       #'))
  33         {
  34             warn "opendir($dotdots): $!";
  35             return '';
  36         }
  37         unless (@cst = stat($dotdots))
  38         {
  39             warn "stat($dotdots): $!";
  40             closedir(getcwd'PARENT);                                    #');
  41             return '';
  42         }
  43         if ($pst[0] == $cst[0] && $pst[1] == $cst[1])
  44         {
  45             $dir = '';
  46         }
  47         else
  48         {
  49             do
  50             {
  51                 unless (defined ($dir = readdir(getcwd'PARENT)))        #'))
  52                 {
  53                     warn "readdir($dotdots): $!";
  54                     closedir(getcwd'PARENT);                            #');
  55                     return '';
  56                 }
  57                 unless (@tst = lstat("$dotdots/$dir"))
  58                 {
  59                     # warn "lstat($dotdots/$dir): $!";
  60                     # closedir(getcwd'PARENT);                          #');
  61                     # return '';
  62                 }
  63             }
  64             while ($dir eq '.' || $dir eq '..' || $tst[0] != $pst[0] ||
  65                    $tst[1] != $pst[1]);
  66         }
  67         $cwd = "$dir/$cwd";
  68         closedir(getcwd'PARENT);                                        #');
  69     } while ($dir ne '');
  70     chop($cwd);
  71     $cwd;
  72 }
  73
  74 1;