home *** CD-ROM | disk | FTP | other *** search
/ RISC DISC 2 / RISC_DISC_2.iso / pd_share / utilities / cli / perl / !Perl / Lib / pm / cwd < prev    next >
Encoding:
Text File  |  1995-03-06  |  3.9 KB  |  181 lines
  1. package Cwd;
  2. require 5.000;
  3. require Exporter;
  4. use Config;
  5.  
  6. @ISA = qw(Exporter);
  7. @EXPORT = qw(getcwd fastcwd);
  8. @EXPORT_OK = qw(chdir);
  9.  
  10.  
  11. # VMS: $ENV{'DEFAULT'} points to default directory at all times
  12. # 08-Dec-1994  Charles Bailey  bailey@genetics.upenn.edu
  13. # Note: Use of Cwd::getcwd() or Cwd::chdir() (but not Cwd::fastcwd())
  14. #   causes the logical name PWD to be defined in the process 
  15. #   logical name table as the default device and directory 
  16. #   seen by Perl. This may not be the same as the default device 
  17. #   and directory seen by DCL after Perl exits, since the effects
  18. #   the CRTL chdir() function persist only until Perl exits.
  19.  
  20. # By Brandon S. Allbery
  21. #
  22. # Usage: $cwd = getcwd();
  23.  
  24. sub getcwd
  25. {
  26.     if($Config{'osname'} eq 'VMS') { return $ENV{'PWD'} = $ENV{'DEFAULT'} }
  27.  
  28.     my($dotdots, $cwd, @pst, @cst, $dir, @tst);
  29.  
  30.     unless (@cst = stat('.'))
  31.     {
  32.     warn "stat(.): $!";
  33.     return '';
  34.     }
  35.     $cwd = '';
  36.     $dotdots = '';
  37.     do
  38.     {
  39.     $dotdots .= '/' if $dotdots;
  40.     $dotdots .= '..';
  41.     @pst = @cst;
  42.     unless (opendir(PARENT, $dotdots))
  43.     {
  44.         warn "opendir($dotdots): $!";
  45.         return '';
  46.     }
  47.     unless (@cst = stat($dotdots))
  48.     {
  49.         warn "stat($dotdots): $!";
  50.         closedir(PARENT);
  51.         return '';
  52.     }
  53.     if ($pst[0] == $cst[0] && $pst[1] == $cst[1])
  54.     {
  55.         $dir = '';
  56.     }
  57.     else
  58.     {
  59.         do
  60.         {
  61.         unless (defined ($dir = readdir(PARENT)))
  62.             {
  63.             warn "readdir($dotdots): $!";
  64.             closedir(PARENT);
  65.             return '';
  66.         }
  67.         unless (@tst = lstat("$dotdots/$dir"))
  68.         {
  69.             warn "lstat($dotdots/$dir): $!";
  70.             closedir(PARENT);
  71.             return '';
  72.         }
  73.         }
  74.         while ($dir eq '.' || $dir eq '..' || $tst[0] != $pst[0] ||
  75.            $tst[1] != $pst[1]);
  76.     }
  77.     $cwd = "$dir/$cwd";
  78.     closedir(PARENT);
  79.     } while ($dir);
  80.     chop($cwd); # drop the trailing /
  81.     $cwd;
  82. }
  83.  
  84.  
  85.  
  86. # By John Bazik
  87. #
  88. # Usage: $cwd = &fastcwd;
  89. #
  90. # This is a faster version of getcwd.  It's also more dangerous because
  91. # you might chdir out of a directory that you can't chdir back into.
  92.  
  93. sub fastcwd {
  94.     if($Config{'osname'} eq 'VMS') { return $ENV{'DEFAULT'} }
  95.  
  96.     my($odev, $oino, $cdev, $cino, $tdev, $tino);
  97.     my(@path, $path);
  98.     local(*DIR);
  99.  
  100.     ($cdev, $cino) = stat('.');
  101.     for (;;) {
  102.     my $direntry;
  103.     ($odev, $oino) = ($cdev, $cino);
  104.     chdir('..');
  105.     ($cdev, $cino) = stat('.');
  106.     last if $odev == $cdev && $oino == $cino;
  107.     opendir(DIR, '.');
  108.     for (;;) {
  109.         $direntry = readdir(DIR);
  110.         next if $direntry eq '.';
  111.         next if $direntry eq '..';
  112.  
  113.         last unless defined $direntry;
  114.         ($tdev, $tino) = lstat($direntry);
  115.         last unless $tdev != $odev || $tino != $oino;
  116.     }
  117.     closedir(DIR);
  118.     unshift(@path, $direntry);
  119.     }
  120.     chdir($path = '/' . join('/', @path));
  121.     $path;
  122. }
  123.  
  124.  
  125. # keeps track of current working directory in PWD environment var
  126. #
  127. # $RCSfile: pwd.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:24:11 $
  128. #
  129. # $Log:    pwd.pl,v $
  130. #
  131. # Usage:
  132. #    use Cwd 'chdir';
  133. #    chdir $newdir;
  134.  
  135. $chdir_init = 0;
  136.  
  137. sub chdir_init{
  138.     if ($ENV{'PWD'}) {
  139.     my($dd,$di) = stat('.');
  140.     my($pd,$pi) = stat($ENV{'PWD'});
  141.     if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) {
  142.         chop($ENV{'PWD'} = `pwd`);
  143.     }
  144.     }
  145.     else {
  146.     chop($ENV{'PWD'} = `pwd`);
  147.     }
  148.     if ($ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|) {
  149.     my($pd,$pi) = stat($2);
  150.     my($dd,$di) = stat($1);
  151.     if (defined $pd and defined $dd and $di == $pi and $dd == $pd) {
  152.         $ENV{'PWD'}="$2$3";
  153.     }
  154.     }
  155.     $chdir_init = 1;
  156. }
  157.  
  158. sub chdir {
  159.     my($newdir) = shift;
  160.     $newdir =~ s|/{2,}|/|g;
  161.     chdir_init() unless $chdir_init;
  162.     return 0 unless (CORE::chdir $newdir);
  163.     if ($Config{'osname'} eq 'VMS') { return $ENV{PWD} = $ENV{DEFAULT} }
  164.  
  165.     if ($newdir =~ m#^/#) {
  166.     $ENV{'PWD'} = $newdir;
  167.     }else{
  168.     my(@curdir) = split(m#/#,$ENV{'PWD'});
  169.     @curdir = '' unless @curdir;
  170.     foreach $component (split(m#/#, $newdir)) {
  171.         next if $component eq '.';
  172.         pop(@curdir),next if $component eq '..';
  173.         push(@curdir,$component);
  174.     }
  175.     $ENV{'PWD'} = join('/',@curdir) || '/';
  176.     }
  177. }
  178.  
  179. 1;
  180.  
  181.