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