view release on metacpan or  search on metacpan

lib/Test/Virtual/Filesystem.pm  view on Meta::CPAN

# http://use.perl.org/~ChrisDolan/journal/34920

sub Introduced : ATTR(CODE) { ## no critic(MixedCase)
   my ($class, $symbol, $code_ref, $attr, $introduced_version) = @_;
   if ($symbol eq 'ANON') {
      warn 'cannot test anonymous subs - you probably loaded ' . __PACKAGE__ . ' too late.' .
          ' (after the CHECK block was run)';
   } else {
      # Wrap the sub in a version test
      no warnings 'redefine';  ## no critic(TestingAndDebugging::ProhibitNoWarnings)
      *{$symbol} = sub {
         no strict 'refs';  ## no critic(TestingAndDebugging::ProhibitNoStrict)
         local ${$class.'::TODO'} = $_[0]->_compatible($introduced_version); ## no critic(Local)
         $code_ref->(@_);
      };

      #my $name = *{$symbol}{NAME};
      #print STDERR "record $class\::$name as $introduced_version\n";
   }
   return;
}
sub _compatible {
   my ($self, $introduced_version) = @_;
   return if !$self->{compatible};
   return if $introduced_version le $self->{compatible};
   return 'compatibility mode ' . $self->{compatible};
}

=item Features($featurelist)

This is a subroutine attribute to specify one or more features used in
the test.  The features should be listed as a comma-separated list:

  sub symlink_create : Tests(1) : Features('symlink') {
     ok(symlink($src, $dest));
  }
  sub symlink_permissions : Tests(2) : Features('symlink, permissions') {
     ok(symlink($src, $dest));
     ok(-w $dest);
  }

Subfeatures must be separated from their parent features by a C</>.  For example:

  sub atime_mtime_set : Tests(1) : Features('time/atime, time/mtime') {
     my $now = time;
     ok(utime($now, $now, $file));
  }

Look at the source code for C<%feature_defaults> to see the supported features and
subfeatures.  The C<enable_test_*> methods above describe the all the
features, but in those methods the subfeature names are flattened.

=cut

sub Features : ATTR(CODE) { ## no critic(MixedCase)
   my ($class, $symbol, $code_ref, $attr, $features) = @_;
   if ($symbol eq 'ANON') {
      warn 'cannot test anonymous subs - you probably loaded ' . $class . ' too late.' .
          ' (after the CHECK block was run)';
   } else {
      my @features = ref $features ? @{$features} : split m/\s*,\s*/xms, $features;
      # Wrap the sub in a feature test
      no warnings 'redefine';  ## no critic(TestingAndDebugging::ProhibitNoWarnings)
      *{$symbol} = sub {
         my $blocking_feature = _blocking_feature(__PACKAGE__, $_[0], @features);
         return $blocking_feature if $blocking_feature;
         return $code_ref->(@_);
      };
   }
   return;
}
sub _blocking_feature {
   my ($pkg, $self, @features) = @_;

   for my $feature (@features) {
      return $feature . ' (no OS support)' if $feature_disabled{$feature};
      my $opts = $self->{fs_opts};
      for my $part (split m{/}xms, $feature) {
         return $feature if !ref $opts;
         return $feature if !$opts->{$part};
         $opts = $opts->{$part};
      }
   }
   return;
}

=item stat_dir(), introduced in v0.01

=cut

sub stat_dir : Test(6) : Introduced('0.01') {
   my ($self) = @_;
   my $f = $self->_file(q{/});
   ok(-e $f, 'mount dir exists');
   ok(-d $f, 'mount dir is a dir');
   ok(!-f $f, 'mount dir is not a file');
   ok(!-l $f, 'mount dir is not a symlink');
   ok(-r $f, 'mount dir is readable');
   ok(-x $f, 'mount dir is searchable');
   return;
}

## This turned out to be very platform-sensitive.
#
# =item stat_dir_size(), introduced in v0.02
#
# =cut
#
# sub stat_dir_size : Test(1) : Introduced('0.02') {
#    my ($self) = @_;
#    my $f = $self->_file(q{/});
#    ok(-s $f, 'mount dir has non-zero size');
#    return;
# }

=item read_dir(), introduced in v0.01

=cut

sub read_dir : Test(3) : Introduced('0.01') {
   my ($self) = @_;
   my $f = $self->_file(q{/});
   my @files = $self->_read_dir($f);
   cmp_ok(scalar @files, '>=', 2, 'dir contains at least two entries');
   ok((any { $_ eq q{.} }  @files), 'dir contains "."');
   ok((any { $_ eq q{..} } @files), 'dir contains ".."');
   return;
}

=item read_dir_fail(), introduced in v0.01

=cut

sub read_dir_fail : Test(2) : Introduced('0.01') {
   my ($self) = @_;
   my $f = $self->_file('/no_such');
   eval {
      $self->_read_dir_die($f);

lib/Test/Virtual/Filesystem.pm  view on Meta::CPAN

   my $src = $self->_file('/rename_srcdir');
   my $dest = $self->_file('/rename_destfile.txt');
   mkdir $src or die $OS_ERROR;
   my $content = 'content';
   $self->_write_file($dest, $content);
   if ($OSNAME eq 'MSWin32' || $OSNAME eq 'cygwin') {
      # return the skip message
      return 'Windows and Cygwin allow rename(<dir>, <file>) instead of failing with ENOTDIR';
   }
   eval {
      rename $src, $dest or die $OS_ERROR;
   };
   $self->_is_errno($EVAL_ERROR, $OS_ERROR, [ENOTDIR()], 'dest is not a directory');

   return;
}

=item rename_symlink(), introduced in v0.08

=cut

sub rename_symlink : Test(6) : Introduced('0.08') : Features('symlink') {
   my ($self) = @_;
   my $srcfile = $self->_file('/rename_srcfile.txt');
   my $src = $self->_file('/rename_src');
   my $dest = $self->_file('/rename_dest');
   my $content = 'content';
   $self->_write_file($srcfile, $content);
   symlink $srcfile, $src or die $OS_ERROR;
   ok((rename $src, $dest), 'rename');
   ok(-e $dest, 'dest exists');
   ok(-e $srcfile, 'source target file still exists');
   ok(!-e $src, 'src no longer exists');
   ok(-l $dest, 'dest is a symlink');
   is($self->_read_file($dest), $content, 'read dest');
   return;
}

######### helpers ########


sub _is_errno {
   my ($self, $eval_error, $os_errno, $expected_errnos, $msg) = @_;
   my $num_errno = 0 + $os_errno;
   my $str_errno = "$os_errno";
   return pass($msg) if $eval_error && $num_errno && any {$_ == $num_errno} @{$expected_errnos};
   my $expected_str = join q{, }, map {strerror($_)} @{$expected_errnos};
   if (!$eval_error) {
      return fail("$msg; didn't throw expected exception");
   } elsif (1 == @{$expected_errnos}) {
      return is("$num_errno ($str_errno)", "$expected_errnos->[0] ($expected_str)", $msg);
   } else {
      return is("$num_errno ($str_errno)", "[@{$expected_errnos}] ($expected_str)", $msg);
   }
}

sub _file {
   my ($self, $path) = @_;
   $path =~ s{\A /}{}xms or croak 'test paths must be absolute';
   # Change path to proper OS format
   return File::Spec->catfile($self->{tempdir}, split m{/}xms, $path);
}

sub _write_file {
   my ($self, $f, @content) = @_;
   open my $fh, '>', $f or die $OS_ERROR;
   binmode $fh;
   for my $content (@content) {
      print {$fh} $content or die $OS_ERROR;
   }
   close $fh or die $OS_ERROR;
   return;
}

sub _append_file {
   my ($self, $f, @content) = @_;
   open my $fh, '>>', $f or die $OS_ERROR;
   binmode $fh;
   for my $content (@content) {
      print {$fh} $content or die $OS_ERROR;
   }
   close $fh or die $OS_ERROR;
   return;
}

sub _read_file {
   my ($self, $f) = @_;
   open my $fh, '<', $f or return;
   binmode $fh;
   my $content = do { local $INPUT_RECORD_SEPARATOR = undef; <$fh> };
   close $fh or return;
   return $content;
}

sub _read_file_die {
   my ($self, $f) = @_;
   open my $fh, '<', $f or die $OS_ERROR;
   binmode $fh;
   my $content = do { local $INPUT_RECORD_SEPARATOR = undef; <$fh> };
   close $fh or die $OS_ERROR;
   return $content;
}

sub _read_dir {
   my ($self, $f) = @_;
   opendir my $fh, $f or return;
   my @content = readdir $fh;
   closedir $fh or return;
   return @content;
}

sub _read_dir_die {
   my ($self, $f) = @_;
   opendir my $fh, $f or die $OS_ERROR;
   my @content = readdir $fh;
   closedir $fh or die $OS_ERROR;
   return @content;
}

1;