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