lib/pwd.pl

   1 ;# pwd.pl - keeps track of current working directory in PWD environment var
   2 ;#
   3 #
   4 # This library is no longer being maintained, and is included for backward
   5 # compatibility with Perl 4 programs which may require it.
   6 # This legacy library is deprecated and will be removed in a future
   7 # release of perl.
   8 #
   9 # In particular, this should not be used as an example of modern Perl
  10 # programming techniques.
  11 #
  12 # Suggested alternative: Cwd
  13
  14 warn( "The 'pwd.pl' legacy library is deprecated and will be"
  15       . " removed in the next major release of perl. Please use the"
  16       . " Cwd module instead." );
  17
  18 ;# $RCSfile: pwd.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:24:11 $
  19 ;#
  20 ;# $Log:        pwd.pl,v $
  21 ;#
  22 ;# Usage:
  23 ;#      require "pwd.pl";
  24 ;#      &initpwd;
  25 ;#      ...
  26 ;#      &chdir($newdir);
  27
  28 package pwd;
  29
  30 sub main'initpwd {
  31     if ($ENV{'PWD'}) {
  32         local($dd,$di) = stat('.');
  33         local($pd,$pi) = stat($ENV{'PWD'});
  34         if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) {
  35             chop($ENV{'PWD'} = `pwd`);
  36         }
  37     }
  38     else {
  39         chop($ENV{'PWD'} = `pwd`);
  40     }
  41     if ($ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|) {
  42         local($pd,$pi) = stat($2);
  43         local($dd,$di) = stat($1);
  44         if (defined $pd and defined $dd and $di == $pi and $dd == $pd) {
  45             $ENV{'PWD'}="$2$3";
  46         }
  47     }
  48 }
  49
  50 sub main'chdir {
  51     local($newdir) = shift;
  52     $newdir =~ s|/{2,}|/|g;
  53     if (chdir $newdir) {
  54         if ($newdir =~ m#^/#) {
  55             $ENV{'PWD'} = $newdir;
  56         }
  57         else {
  58             local(@curdir) = split(m#/#,$ENV{'PWD'});
  59             @curdir = '' unless @curdir;
  60             foreach $component (split(m#/#, $newdir)) {
  61                 next if $component eq '.';
  62                 pop(@curdir),next if $component eq '..';
  63                 push(@curdir,$component);
  64             }
  65             $ENV{'PWD'} = join('/',@curdir) || '/';
  66         }
  67     }
  68     else {
  69         0;
  70     }
  71 }
  72
  73 1;