xref: /openbsd-src/gnu/usr.bin/perl/cpan/File-Path/t/FilePathTest.pm (revision 2e109fb9e8c0dc273648ddbc62f0a74abf9e098d)

package FilePathTest;
use strict;
use warnings;
use base 'Exporter';
use SelectSaver;
use Carp;
use Cwd;
use File::Spec::Functions;
use File::Path ();
use Test::More ();

our @EXPORT_OK = qw(
    _run_for_warning
    _run_for_verbose
    _cannot_delete_safe_mode
    _verbose_expected
    create_3_level_subdirs
    cleanup_3_level_subdirs
);

sub _basedir {
  return catdir(
      curdir(),
      sprintf( 'test-%x-%x-%x', time, $$, rand(99999) ),
  );
}

sub _run_for_warning {
  my $coderef = shift;
  my $warn = '';
  local $SIG{__WARN__} = sub { $warn .= shift };
  &$coderef;
  return $warn;
}

sub _run_for_verbose {
  my $coderef = shift;
  my $stdout = '';
  {
    my $guard = SelectSaver->new(_ref_to_fh(\$stdout));
    &$coderef;
  }
  return $stdout;
}

sub _ref_to_fh {
  my $output = shift;
  open my $fh, '>', $output;
  return $fh;
}

# Whether a directory can be deleted without modifying permissions varies
# by platform and by current privileges, so we really have to do the same
# check the module does in safe mode to determine that.

sub _cannot_delete_safe_mode {
  my $path = shift;
  return $^O eq 'VMS'
         ? !&VMS::Filespec::candelete($path)
         : !-w $path;
}

# What verbose mode reports depends on what it can do in safe mode.
# Plus on VMS, mkpath may report what it's operating on in a
# different format from the format of the path passed to it.

sub _verbose_expected {
  my ($function, $path, $safe_mode, $base) = @_;
  my $expected;

  if ($function =~ m/^(mkpath|make_path)$/) {
    # On VMS, mkpath reports in Unix format.  Maddeningly, it
    # reports the top-level directory without a trailing slash
    # and everything else with.
    if ($^O eq 'VMS') {
      $path = VMS::Filespec::unixify($path);
      $path =~ s/\/$// if defined $base && $base;
    }
    $expected = "mkdir $path\n";
  }
  elsif ($function =~ m/^(rmtree|remove_tree)$/) {
    # N.B. Directories must still/already exist for this to work.
    $expected = $safe_mode && _cannot_delete_safe_mode($path)
              ? "skipped $path\n"
              : "rmdir $path\n";
  }
  elsif ($function =~ m/^(unlink)$/) {
    $expected = "unlink $path\n";
    $expected =~ s/\n\z/\.\n/ if $^O eq 'VMS';
  }
  else {
    die "Unknown function $function in _verbose_expected";
  }
  return $expected;
}

BEGIN {
  if ($] < 5.008000) {
    eval qq{#line @{[__LINE__+1]} "@{[__FILE__]}"\n} . <<'END' or die $@;
      no warnings 'redefine';
      use Symbol ();

      sub _ref_to_fh {
        my $output = shift;
        my $fh = Symbol::gensym();
        tie *$fh, 'StringIO', $output;
        return $fh;
      }

      package StringIO;
      sub TIEHANDLE { bless [ $_[1] ], $_[0] }
      sub CLOSE    { @{$_[0]} = (); 1 }
      sub PRINT    { ${ $_[0][0] } .= $_[1] }
      sub PRINTF   { ${ $_[0][0] } .= sprintf $_[1], @_[2..$#_] }
      1;
END
  }
}

sub create_3_level_subdirs {
    my @dirnames = @_;
    my %seen = map {$_ => 1} @dirnames;
    croak "Need 3 distinct names for subdirectories"
        unless scalar(keys %seen) == 3;
    my $tdir = File::Spec::Functions::tmpdir();
    my $least_deep      = catdir($tdir, $dirnames[0]);
    my $next_deepest    = catdir($least_deep, $dirnames[1]);
    my $deepest         = catdir($next_deepest, $dirnames[2]);
    return ($least_deep, $next_deepest, $deepest);
}

sub cleanup_3_level_subdirs {
    # runs 2 tests
    my $least_deep = shift;
    croak "Must provide path of least subdirectory"
        unless (length($least_deep) and (-d $least_deep));
    my $x;
    my $opts = { error => \$x };
    File::Path::remove_tree($least_deep, $opts);
    Test::More::ok(! -d $least_deep, "directory '$least_deep' removed, as expected");
    Test::More::is(scalar(@{$x}), 0, "no error messages using remove_tree() with \$opts");
}

1;