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