cpan/File-Path/t/FilePathTest.pm

   1 package FilePathTest;
   2 use strict;
   3 use warnings;
   4 use base 'Exporter';
   5 use SelectSaver;
   6 use Cwd;
   7 use File::Spec::Functions;
   8
   9 our @EXPORT = qw(_run_for_warning _run_for_verbose _basedir
  10                  _cannot_delete_safe_mode
  11                  _verbose_expected);
  12
  13 sub _basedir {
  14   return catdir( curdir(),
  15                  sprintf( 'test-%x-%x-%x', time, $$, rand(99999) ),
  16   );
  17
  18 }
  19
  20 sub _run_for_warning {
  21   my $coderef = shift;
  22   my $warn = '';
  23   local $SIG{__WARN__} = sub { $warn .= shift };
  24   &$coderef;
  25   return $warn;
  26 }
  27
  28 sub _run_for_verbose {
  29   my $coderef = shift;
  30   my $stdout = '';
  31   {
  32     my $guard = SelectSaver->new(_ref_to_fh(\$stdout));
  33     &$coderef;
  34   }
  35   return $stdout;
  36 }
  37
  38 sub _ref_to_fh {
  39   my $output = shift;
  40   open my $fh, '>', $output;
  41   return $fh;
  42 }
  43
  44 # Whether a directory can be deleted without modifying permissions varies
  45 # by platform and by current privileges, so we really have to do the same
  46 # check the module does in safe mode to determine that.
  47
  48 sub _cannot_delete_safe_mode {
  49   my $path = shift;
  50   return $^O eq 'VMS'
  51          ? !&VMS::Filespec::candelete($path)
  52          : !-w $path;
  53 }
  54
  55 # What verbose mode reports depends on what it can do in safe mode.
  56 # Plus on VMS, mkpath may report what it's operating on in a
  57 # different format from the format of the path passed to it.
  58
  59 sub _verbose_expected {
  60   my ($function, $path, $safe_mode, $base) = @_;
  61   my $expected;
  62
  63   if ($function =~ m/^(mkpath|make_path)$/) {
  64     # On VMS, mkpath reports in Unix format.  Maddeningly, it
  65     # reports the top-level directory without a trailing slash
  66     # and everything else with.
  67     if ($^O eq 'VMS') {
  68       $path = VMS::Filespec::unixify($path);
  69       $path =~ s/\/$// if defined $base && $base;
  70     }
  71     $expected = "mkdir $path\n";
  72   }
  73   elsif ($function =~ m/^(rmtree|remove_tree)$/) {
  74     # N.B. Directories must still/already exist for this to work.
  75     $expected = $safe_mode && _cannot_delete_safe_mode($path)
  76               ? "skipped $path\n"
  77               : "rmdir $path\n";
  78   }
  79   elsif ($function =~ m/^(unlink)$/) {
  80     $expected = "unlink $path\n";
  81     $expected =~ s/\n\z/\.\n/ if $^O eq 'VMS';
  82   }
  83   else {
  84     die "Unknown function $function in _verbose_expected";
  85   }
  86   return $expected;
  87 }
  88
  89 BEGIN {
  90   if ($] < 5.008000) {
  91     eval qq{#line @{[__LINE__+1]} "@{[__FILE__]}"\n} . <<'END' or die $@;
  92       no warnings 'redefine';
  93       use Symbol ();
  94
  95       sub _ref_to_fh {
  96         my $output = shift;
  97         my $fh = Symbol::gensym();
  98         tie *$fh, 'StringIO', $output;
  99         return $fh;
 100       }
 101
 102       package StringIO;
 103       sub TIEHANDLE { bless [ $_[1] ], $_[0] }
 104       sub CLOSE    { @{$_[0]} = (); 1 }
 105       sub PRINT    { ${ $_[0][0] } .= $_[1] }
 106       sub PRINTF   { ${ $_[0][0] } .= sprintf $_[1], @_[2..$#_] }
 107       1;
 108 END
 109   }
 110 }
 111
 112 1;