home *** CD-ROM | disk | FTP | other *** search
/ Personal Computer World 2007 September / PCWSEP07.iso / Software / Linux / Linux Mint 3.0 Light / LinuxMint-3.0-Light.iso / casper / filesystem.squashfs / usr / lib / perl / 5.8.8 / Cwd.pm < prev    next >
Encoding:
Perl POD Document  |  2007-03-05  |  13.4 KB  |  538 lines
  1. package Cwd;
  2.  
  3. use strict;
  4. use Exporter;
  5. use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION);
  6.  
  7. $VERSION = '3.12';
  8.  
  9. @ISA = qw/ Exporter /;
  10. @EXPORT = qw(cwd getcwd fastcwd fastgetcwd);
  11. push @EXPORT, qw(getdcwd) if $^O eq 'MSWin32';
  12. @EXPORT_OK = qw(chdir abs_path fast_abs_path realpath fast_realpath);
  13.  
  14. # sys_cwd may keep the builtin command
  15.  
  16. # All the functionality of this module may provided by builtins,
  17. # there is no sense to process the rest of the file.
  18. # The best choice may be to have this in BEGIN, but how to return from BEGIN?
  19.  
  20. if ($^O eq 'os2') {
  21.     local $^W = 0;
  22.  
  23.     *cwd                = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd;
  24.     *getcwd             = \&cwd;
  25.     *fastgetcwd         = \&cwd;
  26.     *fastcwd            = \&cwd;
  27.  
  28.     *fast_abs_path      = \&sys_abspath if defined &sys_abspath;
  29.     *abs_path           = \&fast_abs_path;
  30.     *realpath           = \&fast_abs_path;
  31.     *fast_realpath      = \&fast_abs_path;
  32.  
  33.     return 1;
  34. }
  35.  
  36. # If loading the XS stuff doesn't work, we can fall back to pure perl
  37. eval {
  38.   if ( $] >= 5.006 ) {
  39.     require XSLoader;
  40.     XSLoader::load( __PACKAGE__, $VERSION );
  41.   } else {
  42.     require DynaLoader;
  43.     push @ISA, 'DynaLoader';
  44.     __PACKAGE__->bootstrap( $VERSION );
  45.   }
  46. };
  47.  
  48. # Must be after the DynaLoader stuff:
  49. $VERSION = eval $VERSION;
  50.  
  51. # Big nasty table of function aliases
  52. my %METHOD_MAP =
  53.   (
  54.    VMS =>
  55.    {
  56.     cwd            => '_vms_cwd',
  57.     getcwd        => '_vms_cwd',
  58.     fastcwd        => '_vms_cwd',
  59.     fastgetcwd        => '_vms_cwd',
  60.     abs_path        => '_vms_abs_path',
  61.     fast_abs_path    => '_vms_abs_path',
  62.    },
  63.  
  64.    MSWin32 =>
  65.    {
  66.     # We assume that &_NT_cwd is defined as an XSUB or in the core.
  67.     cwd            => '_NT_cwd',
  68.     getcwd        => '_NT_cwd',
  69.     fastcwd        => '_NT_cwd',
  70.     fastgetcwd        => '_NT_cwd',
  71.     abs_path        => 'fast_abs_path',
  72.     realpath        => 'fast_abs_path',
  73.    },
  74.  
  75.    dos => 
  76.    {
  77.     cwd            => '_dos_cwd',
  78.     getcwd        => '_dos_cwd',
  79.     fastgetcwd        => '_dos_cwd',
  80.     fastcwd        => '_dos_cwd',
  81.     abs_path        => 'fast_abs_path',
  82.    },
  83.  
  84.    qnx =>
  85.    {
  86.     cwd            => '_qnx_cwd',
  87.     getcwd        => '_qnx_cwd',
  88.     fastgetcwd        => '_qnx_cwd',
  89.     fastcwd        => '_qnx_cwd',
  90.     abs_path        => '_qnx_abs_path',
  91.     fast_abs_path    => '_qnx_abs_path',
  92.    },
  93.  
  94.    cygwin =>
  95.    {
  96.     getcwd        => 'cwd',
  97.     fastgetcwd        => 'cwd',
  98.     fastcwd        => 'cwd',
  99.     abs_path        => 'fast_abs_path',
  100.     realpath        => 'fast_abs_path',
  101.    },
  102.  
  103.    epoc =>
  104.    {
  105.     cwd            => '_epoc_cwd',
  106.     getcwd            => '_epoc_cwd',
  107.     fastgetcwd        => '_epoc_cwd',
  108.     fastcwd        => '_epoc_cwd',
  109.     abs_path        => 'fast_abs_path',
  110.    },
  111.  
  112.    MacOS =>
  113.    {
  114.     getcwd        => 'cwd',
  115.     fastgetcwd        => 'cwd',
  116.     fastcwd        => 'cwd',
  117.     abs_path        => 'fast_abs_path',
  118.    },
  119.   );
  120.  
  121. $METHOD_MAP{NT} = $METHOD_MAP{MSWin32};
  122. $METHOD_MAP{nto} = $METHOD_MAP{qnx};
  123.  
  124. # Find the pwd command in the expected locations.  We assume these
  125. # are safe.  This prevents _backtick_pwd() consulting $ENV{PATH}
  126. # so everything works under taint mode.
  127. my $pwd_cmd;
  128. foreach my $try ('/bin/pwd',
  129.          '/usr/bin/pwd',
  130.          '/QOpenSys/bin/pwd', # OS/400 PASE.
  131.         ) {
  132.  
  133.     if( -x $try ) {
  134.         $pwd_cmd = $try;
  135.         last;
  136.     }
  137. }
  138. unless ($pwd_cmd) {
  139.     # Isn't this wrong?  _backtick_pwd() will fail if somenone has
  140.     # pwd in their path but it is not /bin/pwd or /usr/bin/pwd?
  141.     # See [perl #16774]. --jhi
  142.     $pwd_cmd = 'pwd';
  143. }
  144.  
  145. # Lazy-load Carp
  146. sub _carp  { require Carp; Carp::carp(@_)  }
  147. sub _croak { require Carp; Carp::croak(@_) }
  148.  
  149. # The 'natural and safe form' for UNIX (pwd may be setuid root)
  150. sub _backtick_pwd {
  151.     # Localize %ENV entries in a way that won't create new hash keys
  152.     my @localize = grep exists $ENV{$_}, qw(PATH IFS CDPATH ENV BASH_ENV);
  153.     local @ENV{@localize};
  154.     
  155.     my $cwd = `$pwd_cmd`;
  156.     # Belt-and-suspenders in case someone said "undef $/".
  157.     local $/ = "\n";
  158.     # `pwd` may fail e.g. if the disk is full
  159.     chomp($cwd) if defined $cwd;
  160.     $cwd;
  161. }
  162.  
  163. # Since some ports may predefine cwd internally (e.g., NT)
  164. # we take care not to override an existing definition for cwd().
  165.  
  166. unless ($METHOD_MAP{$^O}{cwd} or defined &cwd) {
  167.     # The pwd command is not available in some chroot(2)'ed environments
  168.     my $sep = $Config::Config{path_sep} || ':';
  169.     my $os = $^O;  # Protect $^O from tainting
  170.     if( $os eq 'MacOS' || (defined $ENV{PATH} &&
  171.                $os ne 'MSWin32' &&  # no pwd on Windows
  172.                grep { -x "$_/pwd" } split($sep, $ENV{PATH})) )
  173.     {
  174.     *cwd = \&_backtick_pwd;
  175.     }
  176.     else {
  177.     *cwd = \&getcwd;
  178.     }
  179. }
  180.  
  181. # set a reasonable (and very safe) default for fastgetcwd, in case it
  182. # isn't redefined later (20001212 rspier)
  183. *fastgetcwd = \&cwd;
  184.  
  185. # By Brandon S. Allbery
  186. #
  187. # Usage: $cwd = getcwd();
  188.  
  189. sub getcwd
  190. {
  191.     abs_path('.');
  192. }
  193.  
  194. # By John Bazik
  195. #
  196. # Usage: $cwd = &fastcwd;
  197. #
  198. # This is a faster version of getcwd.  It's also more dangerous because
  199. # you might chdir out of a directory that you can't chdir back into.
  200.     
  201. sub fastcwd_ {
  202.     my($odev, $oino, $cdev, $cino, $tdev, $tino);
  203.     my(@path, $path);
  204.     local(*DIR);
  205.  
  206.     my($orig_cdev, $orig_cino) = stat('.');
  207.     ($cdev, $cino) = ($orig_cdev, $orig_cino);
  208.     for (;;) {
  209.     my $direntry;
  210.     ($odev, $oino) = ($cdev, $cino);
  211.     CORE::chdir('..') || return undef;
  212.     ($cdev, $cino) = stat('.');
  213.     last if $odev == $cdev && $oino == $cino;
  214.     opendir(DIR, '.') || return undef;
  215.     for (;;) {
  216.         $direntry = readdir(DIR);
  217.         last unless defined $direntry;
  218.         next if $direntry eq '.';
  219.         next if $direntry eq '..';
  220.  
  221.         ($tdev, $tino) = lstat($direntry);
  222.         last unless $tdev != $odev || $tino != $oino;
  223.     }
  224.     closedir(DIR);
  225.     return undef unless defined $direntry; # should never happen
  226.     unshift(@path, $direntry);
  227.     }
  228.     $path = '/' . join('/', @path);
  229.     if ($^O eq 'apollo') { $path = "/".$path; }
  230.     # At this point $path may be tainted (if tainting) and chdir would fail.
  231.     # Untaint it then check that we landed where we started.
  232.     $path =~ /^(.*)\z/s        # untaint
  233.     && CORE::chdir($1) or return undef;
  234.     ($cdev, $cino) = stat('.');
  235.     die "Unstable directory path, current directory changed unexpectedly"
  236.     if $cdev != $orig_cdev || $cino != $orig_cino;
  237.     $path;
  238. }
  239. if (not defined &fastcwd) { *fastcwd = \&fastcwd_ }
  240.  
  241. # Keeps track of current working directory in PWD environment var
  242. # Usage:
  243. #    use Cwd 'chdir';
  244. #    chdir $newdir;
  245.  
  246. my $chdir_init = 0;
  247.  
  248. sub chdir_init {
  249.     if ($ENV{'PWD'} and $^O ne 'os2' and $^O ne 'dos' and $^O ne 'MSWin32') {
  250.     my($dd,$di) = stat('.');
  251.     my($pd,$pi) = stat($ENV{'PWD'});
  252.     if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) {
  253.         $ENV{'PWD'} = cwd();
  254.     }
  255.     }
  256.     else {
  257.     my $wd = cwd();
  258.     $wd = Win32::GetFullPathName($wd) if $^O eq 'MSWin32';
  259.     $ENV{'PWD'} = $wd;
  260.     }
  261.     # Strip an automounter prefix (where /tmp_mnt/foo/bar == /foo/bar)
  262.     if ($^O ne 'MSWin32' and $ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|s) {
  263.     my($pd,$pi) = stat($2);
  264.     my($dd,$di) = stat($1);
  265.     if (defined $pd and defined $dd and $di == $pi and $dd == $pd) {
  266.         $ENV{'PWD'}="$2$3";
  267.     }
  268.     }
  269.     $chdir_init = 1;
  270. }
  271.  
  272. sub chdir {
  273.     my $newdir = @_ ? shift : '';    # allow for no arg (chdir to HOME dir)
  274.     $newdir =~ s|///*|/|g unless $^O eq 'MSWin32';
  275.     chdir_init() unless $chdir_init;
  276.     my $newpwd;
  277.     if ($^O eq 'MSWin32') {
  278.     # get the full path name *before* the chdir()
  279.     $newpwd = Win32::GetFullPathName($newdir);
  280.     }
  281.  
  282.     return 0 unless CORE::chdir $newdir;
  283.  
  284.     if ($^O eq 'VMS') {
  285.     return $ENV{'PWD'} = $ENV{'DEFAULT'}
  286.     }
  287.     elsif ($^O eq 'MacOS') {
  288.     return $ENV{'PWD'} = cwd();
  289.     }
  290.     elsif ($^O eq 'MSWin32') {
  291.     $ENV{'PWD'} = $newpwd;
  292.     return 1;
  293.     }
  294.  
  295.     if ($newdir =~ m#^/#s) {
  296.     $ENV{'PWD'} = $newdir;
  297.     } else {
  298.     my @curdir = split(m#/#,$ENV{'PWD'});
  299.     @curdir = ('') unless @curdir;
  300.     my $component;
  301.     foreach $component (split(m#/#, $newdir)) {
  302.         next if $component eq '.';
  303.         pop(@curdir),next if $component eq '..';
  304.         push(@curdir,$component);
  305.     }
  306.     $ENV{'PWD'} = join('/',@curdir) || '/';
  307.     }
  308.     1;
  309. }
  310.  
  311. sub _perl_abs_path
  312. {
  313.     my $start = @_ ? shift : '.';
  314.     my($dotdots, $cwd, @pst, @cst, $dir, @tst);
  315.  
  316.     unless (@cst = stat( $start ))
  317.     {
  318.     _carp("stat($start): $!");
  319.     return '';
  320.     }
  321.  
  322.     unless (-d _) {
  323.         # Make sure we can be invoked on plain files, not just directories.
  324.         # NOTE that this routine assumes that '/' is the only directory separator.
  325.     
  326.         my ($dir, $file) = $start =~ m{^(.*)/(.+)$}
  327.         or return cwd() . '/' . $start;
  328.     
  329.     # Can't use "-l _" here, because the previous stat was a stat(), not an lstat().
  330.     if (-l $start) {
  331.         my $link_target = readlink($start);
  332.         die "Can't resolve link $start: $!" unless defined $link_target;
  333.         
  334.         require File::Spec;
  335.             $link_target = $dir . '/' . $link_target
  336.                 unless File::Spec->file_name_is_absolute($link_target);
  337.         
  338.         return abs_path($link_target);
  339.     }
  340.     
  341.     return $dir ? abs_path($dir) . "/$file" : "/$file";
  342.     }
  343.  
  344.     $cwd = '';
  345.     $dotdots = $start;
  346.     do
  347.     {
  348.     $dotdots .= '/..';
  349.     @pst = @cst;
  350.     local *PARENT;
  351.     unless (opendir(PARENT, $dotdots))
  352.     {
  353.         _carp("opendir($dotdots): $!");
  354.         return '';
  355.     }
  356.     unless (@cst = stat($dotdots))
  357.     {
  358.         _carp("stat($dotdots): $!");
  359.         closedir(PARENT);
  360.         return '';
  361.     }
  362.     if ($pst[0] == $cst[0] && $pst[1] == $cst[1])
  363.     {
  364.         $dir = undef;
  365.     }
  366.     else
  367.     {
  368.         do
  369.         {
  370.         unless (defined ($dir = readdir(PARENT)))
  371.             {
  372.             _carp("readdir($dotdots): $!");
  373.             closedir(PARENT);
  374.             return '';
  375.         }
  376.         $tst[0] = $pst[0]+1 unless (@tst = lstat("$dotdots/$dir"))
  377.         }
  378.         while ($dir eq '.' || $dir eq '..' || $tst[0] != $pst[0] ||
  379.            $tst[1] != $pst[1]);
  380.     }
  381.     $cwd = (defined $dir ? "$dir" : "" ) . "/$cwd" ;
  382.     closedir(PARENT);
  383.     } while (defined $dir);
  384.     chop($cwd) unless $cwd eq '/'; # drop the trailing /
  385.     $cwd;
  386. }
  387.  
  388. my $Curdir;
  389. sub fast_abs_path {
  390.     local $ENV{PWD} = $ENV{PWD} || ''; # Guard against clobberage
  391.     my $cwd = getcwd();
  392.     require File::Spec;
  393.     my $path = @_ ? shift : ($Curdir ||= File::Spec->curdir);
  394.  
  395.     # Detaint else we'll explode in taint mode.  This is safe because
  396.     # we're not doing anything dangerous with it.
  397.     ($path) = $path =~ /(.*)/;
  398.     ($cwd)  = $cwd  =~ /(.*)/;
  399.  
  400.     unless (-e $path) {
  401.      _croak("$path: No such file or directory");
  402.     }
  403.  
  404.     unless (-d _) {
  405.         # Make sure we can be invoked on plain files, not just directories.
  406.     
  407.     my ($vol, $dir, $file) = File::Spec->splitpath($path);
  408.     return File::Spec->catfile($cwd, $path) unless length $dir;
  409.  
  410.     if (-l $path) {
  411.         my $link_target = readlink($path);
  412.         die "Can't resolve link $path: $!" unless defined $link_target;
  413.         
  414.         $link_target = File::Spec->catpath($vol, $dir, $link_target)
  415.                 unless File::Spec->file_name_is_absolute($link_target);
  416.         
  417.         return fast_abs_path($link_target);
  418.     }
  419.     
  420.     return $dir eq File::Spec->rootdir
  421.       ? File::Spec->catpath($vol, $dir, $file)
  422.       : fast_abs_path(File::Spec->catpath($vol, $dir, '')) . '/' . $file;
  423.     }
  424.  
  425.     if (!CORE::chdir($path)) {
  426.      _croak("Cannot chdir to $path: $!");
  427.     }
  428.     my $realpath = getcwd();
  429.     if (! ((-d $cwd) && (CORE::chdir($cwd)))) {
  430.      _croak("Cannot chdir back to $cwd: $!");
  431.     }
  432.     $realpath;
  433. }
  434.  
  435. # added function alias to follow principle of least surprise
  436. # based on previous aliasing.  --tchrist 27-Jan-00
  437. *fast_realpath = \&fast_abs_path;
  438.  
  439. # --- PORTING SECTION ---
  440.  
  441. # VMS: $ENV{'DEFAULT'} points to default directory at all times
  442. # 06-Mar-1996  Charles Bailey  bailey@newman.upenn.edu
  443. # Note: Use of Cwd::chdir() causes the logical name PWD to be defined
  444. #   in the process logical name table as the default device and directory
  445. #   seen by Perl. This may not be the same as the default device
  446. #   and directory seen by DCL after Perl exits, since the effects
  447. #   the CRTL chdir() function persist only until Perl exits.
  448.  
  449. sub _vms_cwd {
  450.     return $ENV{'DEFAULT'};
  451. }
  452.  
  453. sub _vms_abs_path {
  454.     return $ENV{'DEFAULT'} unless @_;
  455.  
  456.     # may need to turn foo.dir into [.foo]
  457.     my $path = VMS::Filespec::pathify($_[0]);
  458.     $path = $_[0] unless defined $path;
  459.  
  460.     return VMS::Filespec::rmsexpand($path);
  461. }
  462.  
  463. sub _os2_cwd {
  464.     $ENV{'PWD'} = `cmd /c cd`;
  465.     chomp $ENV{'PWD'};
  466.     $ENV{'PWD'} =~ s:\\:/:g ;
  467.     return $ENV{'PWD'};
  468. }
  469.  
  470. sub _win32_cwd {
  471.     $ENV{'PWD'} = Win32::GetCwd();
  472.     $ENV{'PWD'} =~ s:\\:/:g ;
  473.     return $ENV{'PWD'};
  474. }
  475.  
  476. *_NT_cwd = defined &Win32::GetCwd ? \&_win32_cwd : \&_os2_cwd;
  477.  
  478. sub _dos_cwd {
  479.     if (!defined &Dos::GetCwd) {
  480.         $ENV{'PWD'} = `command /c cd`;
  481.         chomp $ENV{'PWD'};
  482.         $ENV{'PWD'} =~ s:\\:/:g ;
  483.     } else {
  484.         $ENV{'PWD'} = Dos::GetCwd();
  485.     }
  486.     return $ENV{'PWD'};
  487. }
  488.  
  489. sub _qnx_cwd {
  490.     local $ENV{PATH} = '';
  491.     local $ENV{CDPATH} = '';
  492.     local $ENV{ENV} = '';
  493.     $ENV{'PWD'} = `/usr/bin/fullpath -t`;
  494.     chomp $ENV{'PWD'};
  495.     return $ENV{'PWD'};
  496. }
  497.  
  498. sub _qnx_abs_path {
  499.     local $ENV{PATH} = '';
  500.     local $ENV{CDPATH} = '';
  501.     local $ENV{ENV} = '';
  502.     my $path = @_ ? shift : '.';
  503.     local *REALPATH;
  504.  
  505.     defined( open(REALPATH, '-|') || exec '/usr/bin/fullpath', '-t', $path ) or
  506.       die "Can't open /usr/bin/fullpath: $!";
  507.     my $realpath = <REALPATH>;
  508.     close REALPATH;
  509.     chomp $realpath;
  510.     return $realpath;
  511. }
  512.  
  513. sub _epoc_cwd {
  514.     $ENV{'PWD'} = EPOC::getcwd();
  515.     return $ENV{'PWD'};
  516. }
  517.  
  518. # Now that all the base-level functions are set up, alias the
  519. # user-level functions to the right places
  520.  
  521. if (exists $METHOD_MAP{$^O}) {
  522.   my $map = $METHOD_MAP{$^O};
  523.   foreach my $name (keys %$map) {
  524.     local $^W = 0;  # assignments trigger 'subroutine redefined' warning
  525.     no strict 'refs';
  526.     *{$name} = \&{$map->{$name}};
  527.   }
  528. }
  529.  
  530. # In case the XS version doesn't load.
  531. *abs_path = \&_perl_abs_path unless defined &abs_path;
  532.  
  533. # added function alias for those of us more
  534. # used to the libc function.  --tchrist 27-Jan-00
  535. *realpath = \&abs_path;
  536.  
  537. 1;
  538.