lib/getcwd.pl

   1 # By Brandon S. Allbery
   2 #
   3 # This library is no longer being maintained, and is included for backward
   4 # compatibility with Perl 4 programs which may require it.
   5 # This legacy library is deprecated and will be removed in a future
   6 # release of perl.
   7 # In particular, this should not be used as an example of modern Perl
   8 # programming techniques.
   9 #
  10 # Suggested alternative: Cwd
  11
  12 #
  13 # Usage: $cwd = &getcwd;
  14
  15 sub getcwd
  16 {
  17     local($dotdots, $cwd, @pst, @cst, $dir, @tst);
  18
  19     unless (@cst = stat('.'))
  20     {
  21         warn "stat(.): $!";
  22         return '';
  23     }
  24     $cwd = '';
  25     do
  26     {
  27         $dotdots .= '/' if $dotdots;
  28         $dotdots .= '..';
  29         @pst = @cst;
  30         unless (opendir(getcwd'PARENT, $dotdots))                       #'))
  31         {
  32             warn "opendir($dotdots): $!";
  33             return '';
  34         }
  35         unless (@cst = stat($dotdots))
  36         {
  37             warn "stat($dotdots): $!";
  38             closedir(getcwd'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(getcwd'PARENT)))        #'))
  50                 {
  51                     warn "readdir($dotdots): $!";
  52                     closedir(getcwd'PARENT);                            #');
  53                     return '';
  54                 }
  55                 unless (@tst = lstat("$dotdots/$dir"))
  56                 {
  57                     # warn "lstat($dotdots/$dir): $!";
  58                     # closedir(getcwd'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(getcwd'PARENT);                                        #');
  67     } while ($dir ne '');
  68     chop($cwd);
  69     $cwd;
  70 }
  71
  72 1;