contrib/perl5/lib/pwd.pl

   1 ;# pwd.pl - keeps track of current working directory in PWD environment var
   2 ;#
   3 ;# $RCSfile: pwd.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:24:11 $
   4 ;#
   5 ;# $Log:        pwd.pl,v $
   6 ;#
   7 ;# Usage:
   8 ;#      require "pwd.pl";
   9 ;#      &initpwd;
  10 ;#      ...
  11 ;#      &chdir($newdir);
  12
  13 package pwd;
  14
  15 sub main'initpwd {
  16     if ($ENV{'PWD'}) {
  17         local($dd,$di) = stat('.');
  18         local($pd,$pi) = stat($ENV{'PWD'});
  19         if ($di != $pi || $dd != $pd) {
  20             chop($ENV{'PWD'} = `pwd`);
  21         }
  22     }
  23     else {
  24         chop($ENV{'PWD'} = `pwd`);
  25     }
  26     if ($ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|) {
  27         local($pd,$pi) = stat($2);
  28         local($dd,$di) = stat($1);
  29         if ($di == $pi && $dd == $pd) {
  30             $ENV{'PWD'}="$2$3";
  31         }
  32     }
  33 }
  34
  35 sub main'chdir {
  36     local($newdir) = shift;
  37     $newdir =~ s|/{2,}|/|g;
  38     if (chdir $newdir) {
  39         if ($newdir =~ m#^/#) {
  40             $ENV{'PWD'} = $newdir;
  41         }
  42         else {
  43             local(@curdir) = split(m#/#,$ENV{'PWD'});
  44             @curdir = '' unless @curdir;
  45             foreach $component (split(m#/#, $newdir)) {
  46                 next if $component eq '.';
  47                 pop(@curdir),next if $component eq '..';
  48                 push(@curdir,$component);
  49             }
  50             $ENV{'PWD'} = join('/',@curdir) || '/';
  51         }
  52     }
  53     else {
  54         0;
  55     }
  56 }
  57
  58 1;