Test-File-1.36/0000755000175000001440000000000012261132575012271 5ustar buddyusersTest-File-1.36/Changes0000644000175000001440000001470212261132456013566 0ustar buddyusers1.36 - Wed Jan 1 16:38:13 PST 2014 * Fix RT #89849 - bad line counts on latest dev version of Perl 1.35 - Thu Oct 10 01:36:55 PDT 2013 * Fix RT #89175 - don't distribute MYMETA* * add dir_exists_ok and dir_contains_ok * add file_contains_* functions 1.34 - Sat Jun 2 16:22:36 PDT 2012 * Fixed problem in links.t. (RT #76853) Thanks to Matthew Musgrove (Mr. Muskrat) and Savio Dimatteo (DARKSMO) for the patch(es). 1.33 - Sun Feb 19 23:16:49 PST 2012 * Fixed problem in MANIFEST file. (RT #37676) 1.32 - Fri Feb 17 16:19:26 PST 2012 * Fixed qr//mx patterns to work with older Perls. (RT #74365) Thanks to Paul Howarth for the patch. * Fixed incorrect spelling of "privileges" in SKIP blocks. (RT #74483) * Skip testing of symlinks on Windows. (RT #57682) * Fixed automatically generated test name for owner_isnt. (RT #37676) 1.31 - Tue Jan 24 12:37:14 PST 2012 * Added some SKIP blocks to avoid test failures when running as root. (D'oh!) 1.30 - Mon Jan 23 09:37:38 PST 2012 * Added dir_exists_ok and dir_contains_ok * Added file_contains_like and file_contains_unlike * Fixed a few grammatical errors in POD 1.28_01 - Thu Aug 11 10:04:20 2011 * Fixes some Windows tests, I think. RT #57682 1.28 - Sun May 31 23:52:45 2009 * Make the man pages after all 1.27 - Thu May 21 08:49:29 2009 * Fix to the tests for 1.26 which didn't account for an extra setup test. 1.26 - Fri May 15 09:31:23 2009 Don't create man pages for the module (RT #45977) 1.25_001 - Tue Jul 15 23:59:42 2008 * Adding some symlink features, more later * Refactoring and separating many tests - test coverage at 90% now * This is really a test release for my new Module::Release 1.25 - Tue Jun 10 12:59:54 2008 * Same as 1.24_03, but with a user release version number. The new features are the ones in 1.24, but this time the tests should all pass :) 1.24_03 - Sun May 25 21:52:48 2008 * Make some adjustments in checking the error messages in test_files.t to make them work across platforms * Remove links.t from the distribution. It doesn't really test anything yet. 1.24_02 - Sun May 25 02:09:24 2008 * Add a binmode before writing to files so they come out right on Windows. Stupid rookie mistake. :( 1.24_01 - Sat May 24 13:27:17 2008 * Trial version to fix test ordering problem in 1.24 * Removed setup.t, which turned into setup_common but wasn't updated for the new features in 1.24 (so files were missing in other test files) 1.24 - Tue May 20 21:59:19 2008 * David Wheeler sent a patch to add file_line_count_is, so I also added file_line_count_isnt and file_line_count_between. * There aren't any other improvements, so you don't need to upgrade unless you want the new functions. 1.23 - Wed Apr 23 13:10:39 2008 * [BUG FIX] owner_is and group_is now fail if the owner or group does not exist. 1.22_01 - Sun Apr 20 14:58:41 2008 * [BUG FIX] owner_is and group_is were passing with non-existent users and groups. Now I check the arguments to see if they actually exist before I test. This is a developer release to let CPAN Testers take a whack at it first. 1.22 - Wed Oct 31 19:40:23 2007 * fixed problem with file path separators in t/rt/30346.t * no need to upgrade if you were already able to install this 1.21 - Tue Oct 30 11:11:49 2007 * Fix RT #30346 ( file_not_empty_ok passes if file doesn't exist) * require 5.006 from now on 1.19 - Sat Oct 27 20:53:47 2007 * distro cleanups after moving from CVS to SVN 1.18 - Tue Jan 9 22:48:14 2007 * updated copyright and license info * no code changes, so no need to upgrade 1.17 - Fri Nov 24 14:30:05 2006 * Updated tests for Test::More 0.65's change in error reporting * Added LICENSE field to docs * No need to upgrade it you already have this installed 1.16 - Sat Jul 8 15:38:38 2006 * updated the plan for links.t to have the right number of tests * no need to upgrade if you already have this installed. 1.15 - Wed May 17 21:42:09 2006 * Updated the distro for copyright and kwalitee. No need to upgrade. 1.14 - Wed Mar 8 12:36:22 2006 * Added Dylan Martin's test for group_is and group_isnt * No need to upgrade unless you need these features 1.13 - Sat Dec 31 13:34:30 2005 * You need the latest Test::Builder::Tester (0.32 right now) to get the owner.t test to pass. I've noted that in the PREREQ_PM. * You don't need to upgrade if you already have Test::File installed. If you run into a test problem, ensure you have the latest Test::Builder::Tester and try again. 1.12 - Sun Dec 25 18:02:58 2005 * Added the tests owner_is() and owner_isnt() from Dylan Martin 1.11 - Sun Oct 2 05:42:41 2005 * Some strings were mistakenly single-quoted. I meant to interpolate but didn't use double quotes. Should I lose my Perl license? :) * Upgrade to get the interpolated error messages. 1.10 - Sun Jun 5 17:34:54 2005 * Fixed Windows testing with patch from Tom Metro. Now that I have a Windows box, I don't need to guess on some of this stuff. * There is a minor code change, but you don't need to rush to upgrade if you already have an installed version. 1.09 - Tue Mar 8 17:58:28 2005 * Added POD coverage tests: no need to upgrade 1.08 - Thu Jan 6 17:36:20 2005 * added a patch from David Wheeler to canonicalize paths for the platform. If the paths look like unix paths, I split them on / and reconstruct them with File::Spec->catdir. * Some functions don't work with Win32, so I detect that inside those functions and automatically skip the test if I think I'm on a Windows machine. 1.07 - Mon Jan 3 17:12:51 2005 Shawn Sorichetti contributed two new funtions: file_mode_is() and file_mode_isnt(). We can now test files by their mode. 1.06 - Sun Sep 5 15:59:40 2004 * Fixed tests that failed if you ran them with root privileges, which don't actually completely depend on file permissions 1.05 - Thu Sep 2 21:27:27 2004 * fixed a documentation bug dealing with file sizes * cleaned up the distribution a bit * You don't need to upgrade if you already have this module 0.9 - Sun Jul 4 20:34:50 2004 * ported tests to Test::More * cleaned up dist files, especially Makefile.PL * fixed up some doc issues in File.pm * no change in functionality 0.06 - initial version Test-File-1.36/lib/0000755000175000001440000000000012261132575013037 5ustar buddyusersTest-File-1.36/lib/Test/0000755000175000001440000000000012261132575013756 5ustar buddyusersTest-File-1.36/lib/Test/File.pm0000644000175000001440000010134712261132536015176 0ustar buddyuserspackage Test::File; use strict; use base qw(Exporter); use vars qw(@EXPORT $VERSION); use File::Spec; use Test::Builder; @EXPORT = qw( file_exists_ok file_not_exists_ok file_empty_ok file_not_empty_ok file_size_ok file_max_size_ok file_min_size_ok file_readable_ok file_not_readable_ok file_writeable_ok file_not_writeable_ok file_executable_ok file_not_executable_ok file_mode_is file_mode_isnt file_is_symlink_ok symlink_target_exists_ok symlink_target_is symlink_target_dangles_ok dir_exists_ok dir_contains_ok link_count_is_ok link_count_gt_ok link_count_lt_ok owner_is owner_isnt group_is group_isnt file_line_count_is file_line_count_isnt file_line_count_between file_contains_like file_contains_unlike ); $VERSION = '1.36'; { use warnings; } my $Test = Test::Builder->new(); =head1 NAME Test::File -- test file attributes =head1 SYNOPSIS use Test::File; =head1 DESCRIPTION This modules provides a collection of test utilities for file attributes. Some file attributes depend on the owner of the process testing the file in the same way the file test operators do. For instance, root (or super-user or Administrator) may always be able to read files no matter the permissions. Some attributes don't make sense outside of Unix, either, so some tests automatically skip if they think they won't work on the platform. If you have a way to make these functions work on Windows, for instance, please send me a patch. :) The optional NAME parameter for every function allows you to specify a name for the test. If not supplied, a reasonable default will be generated. =head2 Functions =cut sub _normalize { my $file = shift; return unless defined $file; return $file =~ m|/| ? File::Spec->catfile( split m|/|, $file ) : $file; } sub _win32 { return 0 if $^O eq 'darwin'; return $^O =~ m/Win/; } # returns true if symlinks can't exist sub _no_symlinks_here { ! eval { symlink("",""); 1 } } # owner_is and owner_isn't should skip on OS where the question makes no # sense. I really don't know a good way to test for that, so I'm going # to skip on the two OS's that I KNOW aren't multi-user. I'd love to add # more if anyone knows of any # Note: I don't have a dos or mac os < 10 machine to test this on sub _obviously_non_multi_user { foreach my $os ( qw(dos MacOS) ) { return 1 if $^O eq $os } return 0 if $^O eq 'MSWin32'; eval { my $holder = getpwuid(0) }; return 1 if $@; eval { my $holder = getgrgid(0) }; return 1 if $@; return 0; } =over 4 =item file_exists_ok( FILENAME [, NAME ] ) Ok if the file exists, and not ok otherwise. =cut sub file_exists_ok { my $filename = _normalize( shift ); my $name = shift || "$filename exists"; my $ok = -e $filename; if( $ok ) { $Test->ok(1, $name); } else { $Test->diag("File [$filename] does not exist"); $Test->ok(0, $name); } } =item file_not_exists_ok( FILENAME [, NAME ] ) Ok if the file does not exist, and not okay if it does exist. =cut sub file_not_exists_ok { my $filename = _normalize( shift ); my $name = shift || "$filename does not exist"; my $ok = not -e $filename; if( $ok ) { $Test->ok(1, $name); } else { $Test->diag("File [$filename] exists"); $Test->ok(0, $name); } } =item file_empty_ok( FILENAME [, NAME ] ) Ok if the file exists and has empty size, not ok if the file does not exist or exists with non-zero size. =cut sub file_empty_ok { my $filename = _normalize( shift ); my $name = shift || "$filename is empty"; unless( -e $filename ) { $Test->diag( "File [$filename] does not exist!" ); return $Test->ok(0, $name); } my $ok = -z $filename; if( $ok ) { $Test->ok(1, $name); } else { $Test->diag( "File [$filename] exists with non-zero size!" ); $Test->ok(0, $name); } } =item file_not_empty_ok( FILENAME [, NAME ] ) Ok if the file exists and has non-zero size, not ok if the file does not exist or exists with zero size. =cut sub file_not_empty_ok { my $filename = _normalize( shift ); my $name = shift || "$filename is not empty"; unless( -e $filename ) { $Test->diag( "File [$filename] does not exist!" ); return $Test->ok(0, $name); } my $ok = not -z _; if( $ok ) { $Test->ok(1, $name); } else { $Test->diag( "File [$filename] exists with zero size!" ); $Test->ok(0, $name); } } =item file_size_ok( FILENAME, SIZE [, NAME ] ) Ok if the file exists and has SIZE size in bytes (exactly), not ok if the file does not exist or exists with size other than SIZE. =cut sub file_size_ok { my $filename = _normalize( shift ); my $expected = int shift; my $name = shift || "$filename has right size"; unless( -e $filename ) { $Test->diag( "File [$filename] does not exist!" ); return $Test->ok(0, $name); } my $ok = ( -s $filename ) == $expected; if( $ok ) { $Test->ok(1, $name); } else { my $actual = -s $filename; $Test->diag( "File [$filename] has actual size [$actual] not [$expected]!" ); $Test->ok(0, $name); } } =item file_max_size_ok( FILENAME, MAX [, NAME ] ) Ok if the file exists and has size less than or equal to MAX bytes, not ok if the file does not exist or exists with size greater than MAX bytes. =cut sub file_max_size_ok { my $filename = _normalize( shift ); my $max = int shift; my $name = shift || "$filename is under $max bytes"; unless( -e $filename ) { $Test->diag( "File [$filename] does not exist!" ); return $Test->ok(0, $name); } my $ok = ( -s $filename ) <= $max; if( $ok ) { $Test->ok(1, $name); } else { my $actual = -s $filename; $Test->diag( "File [$filename] has actual size [$actual] " . "greater than [$max]!" ); $Test->ok(0, $name); } } =item file_min_size_ok( FILENAME, MIN [, NAME ] ) Ok if the file exists and has size greater than or equal to MIN bytes, not ok if the file does not exist or exists with size less than MIN bytes. =cut sub file_min_size_ok { my $filename = _normalize( shift ); my $min = int shift; my $name = shift || "$filename is over $min bytes"; unless( -e $filename ) { $Test->diag( "File [$filename] does not exist!" ); return $Test->ok(0, $name); } my $ok = ( -s $filename ) >= $min; if( $ok ) { $Test->ok(1, $name); } else { my $actual = -s $filename; $Test->diag( "File [$filename] has actual size ". "[$actual] less than [$min]!" ); $Test->ok(0, $name); } } =item file_line_count_is( FILENAME, COUNT [, NAME ] ) Ok if the file exists and has COUNT lines (exactly), not ok if the file does not exist or exists with a line count other than COUNT. This function uses the current value of C<$/> as the line ending and counts the lines by reading them and counting how many it read. =cut sub _ENOFILE () { -1 } sub _ECANTOPEN () { -2 } sub _file_line_counter { my $filename = shift; return _ENOFILE unless -e $filename; # does not exist return _ECANTOPEN unless open my( $fh ), "<", $filename; my $count = 0; while( <$fh> ) { $count++ } return $count; } # XXX: lots of cut and pasting here, needs refactoring # looks like the refactoring might be worse than this though sub file_line_count_is { my $filename = _normalize( shift ); my $expected = shift; my $name = do { no warnings 'uninitialized'; shift || "$filename line count is $expected lines"; }; unless( defined $expected && int( $expected ) == $expected ) { no warnings 'uninitialized'; $Test->diag( "file_line_count_is expects a positive whole number for " . "the second argument. Got [$expected]!" ); return $Test->ok( 0, $name ); } my $got = _file_line_counter( $filename ); if( $got eq _ENOFILE ) { $Test->diag( "File [$filename] does not exist!" ); $Test->ok( 0, $name ); } elsif( $got == _ECANTOPEN ) { $Test->diag( "Could not open [$filename]: \$! is [$!]!" ); $Test->ok( 0, $name ); } elsif( $got == $expected ) { $Test->ok( 1, $name ); } else { $Test->diag( "Expected [$expected] lines in [$filename], " . "got [$got] lines!" ); $Test->ok( 0, $name ); } } =item file_line_count_isnt( FILENAME, COUNT [, NAME ] ) Ok if the file exists and doesn't have exactly COUNT lines, not ok if the file does not exist or exists with a line count of COUNT. Read that carefully: the file must exist for this test to pass! This function uses the current value of C<$/> as the line ending and counts the lines by reading them and counting how many it read. =cut sub file_line_count_isnt { my $filename = _normalize( shift ); my $expected = shift; my $name = do { no warnings 'uninitialized'; shift || "$filename line count is not $expected lines"; }; unless( defined $expected && int( $expected ) == $expected ) { no warnings 'uninitialized'; $Test->diag( "file_line_count_is expects a positive whole number for " . "the second argument. Got [$expected]!" ); return $Test->ok( 0, $name ); } my $got = _file_line_counter( $filename ); if( $got eq _ENOFILE ) { $Test->diag( "File [$filename] does not exist!" ); $Test->ok( 0, $name ); } elsif( $got == _ECANTOPEN ) { $Test->diag( "Could not open [$filename]: \$! is [$!]!" ); $Test->ok( 0, $name ); } elsif( $got != $expected ) { $Test->ok( 1, $name ); } else { $Test->diag( "Expected something other than [$expected] lines in [$filename], " . "but got [$got] lines!" ); $Test->ok( 0, $name ); } } =item file_line_count_between( FILENAME, MIN, MAX, [, NAME ] ) Ok if the file exists and has a line count between MIN and MAX, inclusively. This function uses the current value of C<$/> as the line ending and counts the lines by reading them and counting how many it read. =cut sub file_line_count_between { my $filename = _normalize( shift ); my $min = shift; my $max = shift; my $name = do { no warnings 'uninitialized'; shift || "$filename line count is between [$min] and [$max] lines"; }; foreach my $ref ( \$min, \$max ) { unless( defined $$ref && int( $$ref ) == $$ref ) { no warnings 'uninitialized'; $Test->diag( "file_line_count_between expects positive whole numbers for " . "the second and third arguments. Got [$min] and [$max]!" ); return $Test->ok( 0, $name ); } } my $got = _file_line_counter( $filename ); if( $got eq _ENOFILE ) { $Test->diag( "File [$filename] does not exist!" ); $Test->ok( 0, $name ); } elsif( $got == _ECANTOPEN ) { $Test->diag( "Could not open [$filename]: \$! is [$!]!" ); $Test->ok( 0, $name ); } elsif( $min <= $got and $got <= $max ) { $Test->ok( 1, $name ); } else { $Test->diag( "Expected a line count between [$min] and [$max] " . "in [$filename], but got [$got] lines!" ); $Test->ok( 0, $name ); } } =item file_contains_like ( FILENAME, PATTERN [, NAME ] ) Ok if the file exists and its contents (as one big string) match PATTERN, not ok if the file does not exist, is not readable, or exists but doesn't match PATTERN. Since the file contents are read into memory, you should not use this for large files. Besides memory consumption, test diagnostics for failing tests might be difficult to decipher. However, for short files this works very well. Because the entire contents are treated as one large string, you can make a pattern that tests multiple lines. Don't forget that you may need to use the /s modifier for such patterns: # make sure file has one or more paragraphs with CSS class X file_contains_like($html_file, qr{

.*?

}s); Contrariwise, if you need to match at the beginning or end of a line inside the file, use the /m modifier: # make sure file has a setting for foo file_contains_like($config_file, qr/^ foo \s* = \s* \w+ $/mx); If you want to test your file contents against multiple patterns, but don't want to have the file read in repeatedly, you can pass an arrayref of patterns instead of a single pattern, like so: # make sure our template has rendered correctly file_contains_like($template_out, [ qr/^ $title_line $/mx, map { qr/^ $_ $/mx } @chapter_headings, qr/^ $footer_line $/mx, ]); Please note that if you do this, and your file does not exist or is not readable, you'll only get one test failure instead of a failure for each pattern. This could cause your test plan to be off, although you may not care at that point because your test failed anyway. If you do care, either skip the test plan altogether by employing L's C function, or use L in conjunction with a C block. Contributed by Buddy Burden C<< >>. =item file_contains_unlike ( FILENAME, PATTERN [, NAME ] ) Ok if the file exists and its contents (as one big string) do B match PATTERN, not ok if the file does not exist, is not readable, or exists but matches PATTERN. All notes and caveats for L apply to this function as well. Contributed by Buddy Burden C<< >>. =cut sub file_contains_like { local $Test::Builder::Level = $Test::Builder::Level + 1; _file_contains(like => "contains", @_); } sub file_contains_unlike { local $Test::Builder::Level = $Test::Builder::Level + 1; _file_contains(unlike => "doesn't contain", @_); } sub _file_contains { my $method = shift; my $verb = shift; my $filename = _normalize( shift ); my $patterns = shift; my $name = shift; my (@patterns, %patterns); if (ref $patterns eq 'ARRAY') { @patterns = @$patterns; %patterns = map { $_ => $name || "$filename $verb $_" } @patterns; } else { @patterns = ($patterns); %patterns = ( $patterns => $name || "$filename $verb $patterns" ); } # for purpose of checking the file's existence, just use the first # test name as the name $name = $patterns{$patterns[0]}; unless( -e $filename ) { $Test->diag( "File [$filename] does not exist!" ); return $Test->ok(0, $name); } unless( -r $filename ) { $Test->diag( "File [$filename] is not readable!" ); return $Test->ok(0, $name); } # do the slurp my $file_contents; { unless (open(FH, $filename)) { $Test->diag( "Could not open [$filename]: \$! is [$!]!" ); return $Test->ok( 0, $name ); } local $/ = undef; $file_contents = ; close FH; } foreach my $p (@patterns) { $Test->$method($file_contents, $p, $patterns{$p}); } } =item file_readable_ok( FILENAME [, NAME ] ) Ok if the file exists and is readable, not ok if the file does not exist or is not readable. =cut sub file_readable_ok { my $filename = _normalize( shift ); my $name = shift || "$filename is readable"; my $ok = -r $filename; if( $ok ) { $Test->ok(1, $name); } else { $Test->diag( "File [$filename] is not readable!" ); $Test->ok(0, $name); } } =item file_not_readable_ok( FILENAME [, NAME ] ) Ok if the file exists and is not readable, not ok if the file does not exist or is readable. =cut sub file_not_readable_ok { my $filename = _normalize( shift ); my $name = shift || "$filename is not readable"; my $ok = not -r $filename; if( $ok ) { $Test->ok(1, $name); } else { $Test->diag( "File [$filename] is readable!" ); $Test->ok(0, $name); } } =item file_writeable_ok( FILENAME [, NAME ] ) Ok if the file exists and is writeable, not ok if the file does not exist or is not writeable. =cut sub file_writeable_ok { my $filename = _normalize( shift ); my $name = shift || "$filename is writeable"; my $ok = -w $filename; if( $ok ) { $Test->ok(1, $name); } else { $Test->diag( "File [$filename] is not writeable!" ); $Test->ok(0, $name); } } =item file_not_writeable_ok( FILENAME [, NAME ] ) Ok if the file exists and is not writeable, not ok if the file does not exist or is writeable. =cut sub file_not_writeable_ok { my $filename = _normalize( shift ); my $name = shift || "$filename is not writeable"; my $ok = not -w $filename; if( $ok ) { $Test->ok(1, $name); } else { $Test->diag("File [$filename] is writeable!"); $Test->ok(0, $name); } } =item file_executable_ok( FILENAME [, NAME ] ) Ok if the file exists and is executable, not ok if the file does not exist or is not executable. This test automatically skips if it thinks it is on a Windows platform. =cut sub file_executable_ok { if( _win32() ) { $Test->skip( "file_executable_ok doesn't work on Windows!" ); return; } my $filename = _normalize( shift ); my $name = shift || "$filename is executable"; my $ok = -x $filename; if( $ok ) { $Test->ok(1, $name); } else { $Test->diag("File [$filename] is not executable!"); $Test->ok(0, $name); } } =item file_not_executable_ok( FILENAME [, NAME ] ) Ok if the file exists and is not executable, not ok if the file does not exist or is executable. This test automatically skips if it thinks it is on a Windows platform. =cut sub file_not_executable_ok { if( _win32() ) { $Test->skip( "file_not_executable_ok doesn't work on Windows!" ); return; } my $filename = _normalize( shift ); my $name = shift || "$filename is not executable"; my $ok = not -x $filename; if( $ok ) { $Test->ok(1, $name); } else { $Test->diag("File [$filename] is executable!"); $Test->ok(0, $name); } } =item file_mode_is( FILENAME, MODE [, NAME ] ) Ok if the file exists and the mode matches, not ok if the file does not exist or the mode does not match. This test automatically skips if it thinks it is on a Windows platform. Contributed by Shawn Sorichetti C<< >> =cut sub file_mode_is { if( _win32() ) { $Test->skip( "file_mode_is doesn't work on Windows!" ); return; } my $filename = _normalize( shift ); my $mode = shift; my $name = shift || sprintf("%s mode is %04o", $filename, $mode); my $ok = -e $filename && ((stat($filename))[2] & 07777) == $mode; if( $ok ) { $Test->ok(1, $name); } else { $Test->diag(sprintf("File [%s] mode is not %04o!", $filename, $mode) ); $Test->ok(0, $name); } } =item file_mode_isnt( FILENAME, MODE [, NAME ] ) Ok if the file exists and mode does not match, not ok if the file does not exist or mode does match. This test automatically skips if it thinks it is on a Windows platform. Contributed by Shawn Sorichetti C<< >> =cut sub file_mode_isnt { if( _win32() ) { $Test->skip( "file_mode_isnt doesn't work on Windows!" ); return; } my $filename = _normalize( shift ); my $mode = shift; my $name = shift || sprintf("%s mode is not %04o",$filename,$mode); my $ok = not (-e $filename && ((stat($filename))[2] & 07777) == $mode); if( $ok ) { $Test->ok(1, $name); } else { $Test->diag(sprintf("File [%s] mode is %04o!",$filename,$mode)); $Test->ok(0, $name); } } =item file_is_symlink_ok( FILENAME [, NAME ] ) Ok if FILENAME is a symlink, even if it points to a non-existent file. This test automatically skips if the operating system does not support symlinks. If the file does not exist, the test fails. =cut sub file_is_symlink_ok { if( _no_symlinks_here() ) { $Test->skip( "file_is_symlink_ok doesn't work on systems without symlinks!" ); return; } my $file = shift; my $name = shift || "$file is a symlink"; if( -l $file ) { $Test->ok(1, $name) } else { $Test->diag( "File [$file] is not a symlink!" ); $Test->ok(0, $name); } } =item symlink_target_exists_ok( SYMLINK [, TARGET] [, NAME ] ) Ok if FILENAME is a symlink and it points to a existing file. With the optional TARGET argument, the test fails if SYMLINK's target is not TARGET. This test automatically skips if the operating system does not support symlinks. If the file does not exist, the test fails. =cut sub symlink_target_exists_ok { if( _no_symlinks_here() ) { $Test->skip( "symlink_target_exists_ok doesn't work on systems without symlinks!" ); return; } my $file = shift; my $dest = shift || readlink( $file ); my $name = shift || "$file is a symlink"; unless( -l $file ) { $Test->diag( "File [$file] is not a symlink!" ); return $Test->ok( 0, $name ); } unless( -e $dest ) { $Test->diag( "Symlink [$file] points to non-existent target [$dest]!" ); return $Test->ok( 0, $name ); } my $actual = readlink( $file ); unless( $dest eq $actual ) { $Test->diag( "Symlink [$file] points to\n" . " got: $actual\n" . " expected: $dest\n" ); return $Test->ok( 0, $name ); } $Test->ok( 1, $name ); } =item symlink_target_dangles_ok( SYMLINK [, NAME ] ) Ok if FILENAME is a symlink and if it doesn't point to a existing file. This test automatically skips if the operating system does not support symlinks. If the file does not exist, the test fails. =cut sub symlink_target_dangles_ok { if( _no_symlinks_here() ) { $Test->skip( "symlink_target_dangles_ok doesn't work on systems without symlinks!" ); return; } my $file = shift; my $dest = readlink( $file ); my $name = shift || "$file is a symlink"; unless( -l $file ) { $Test->diag( "File [$file] is not a symlink!" ); return $Test->ok( 0, $name ); } if( -e $dest ) { $Test->diag( "Symlink [$file] points to existing file [$dest] but shouldn't!" ); return $Test->ok( 0, $name ); } $Test->ok( 1, $name ); } =item symlink_target_is( SYMLINK, TARGET [, NAME ] ) Ok if FILENAME is a symlink and if points to TARGET. This test automatically skips if the operating system does not support symlinks. If the file does not exist, the test fails. =cut sub symlink_target_is { if( _no_symlinks_here() ) { $Test->skip( "symlink_target_is doesn't work on systems without symlinks!" ); return; } my $file = shift; my $dest = shift; my $name = shift || "symlink $file points to $dest"; unless( -l $file ) { $Test->diag( "File [$file] is not a symlink!" ); return $Test->ok( 0, $name ); } my $actual_dest = readlink( $file ); my $link_error = $!; unless( defined $actual_dest ) { $Test->diag( "Symlink [$file] does not have a defined target!" ); $Test->diag( "readlink error: $link_error" ) if defined $link_error; return $Test->ok( 0, $name ); } if( $dest eq $actual_dest ) { $Test->ok( 1, $name ); } else { $Test->ok( 0, $name ); $Test->diag(" got: $actual_dest" ); $Test->diag(" expected: $dest" ); } } =item symlink_target_is_absolute_ok( SYMLINK [, NAME ] ) Ok if FILENAME is a symlink and if its target is an absolute path. This test automatically skips if the operating system does not support symlinks. If the file does not exist, the test fails. =cut =pod sub symlink_target_is_absolute_ok { if( _no_symlinks_here() ) { $Test->skip( "symlink_target_exists_ok doesn't work on systems without symlinks" ); return; } my $file = shift; my $name = shift || "symlink $file points to an absolute path"; my ($from, $from_base, $to, $to_base, $name) = @_; my $link = readlink( $from ); my $link_err = defined( $link ) ? '' : $!; # $! doesn't always get reset my $link_abs = abs_path( rel2abs($link, $from_base) ); my $to_abs = abs_path( rel2abs($to, $to_base) ); if (defined( $link_abs ) && defined( $to_abs ) && $link_abs eq $to_abs) { $Test->ok( 1, $name ); } else { $Test->ok( 0, $name ); $link ||= 'undefined'; $link_abs ||= 'undefined'; $to_abs ||= 'undefined'; $Test->diag(" link: $from"); $Test->diag(" got: $link"); $Test->diag(" (abs): $link_abs"); $Test->diag(" expected: $to"); $Test->diag(" (abs): $to_abs"); $Test->diag(" readlink() error: $link_err") if ($link_err); } } =item dir_exists_ok( DIRECTORYNAME [, NAME ] ) Ok if the file exists and is a directory, not ok if the file doesn't exist, or exists but isn't a directory. Contributed by Buddy Burden C<< >>. =cut sub dir_exists_ok { my $filename = _normalize( shift ); my $name = shift || "$filename is a directory"; unless( -e $filename ) { $Test->diag( "File [$filename] does not exist!" ); return $Test->ok(0, $name); } my $ok = -d $filename; if( $ok ) { $Test->ok(1, $name); } else { $Test->diag( "File [$filename] exists but is not a directory!" ); $Test->ok(0, $name); } } =item dir_contains_ok( DIRECTORYNAME, FILENAME [, NAME ] ) Ok if the directory exists and contains the file, not ok if the directory doesn't exist, or exists but doesn't contain the file. Contributed by Buddy Burden C<< >>. =cut sub dir_contains_ok { my $dirname = _normalize( shift ); my $filename = _normalize( shift ); my $name = shift || "directory $dirname contains file $filename"; unless( -d $dirname ) { $Test->diag( "Directory [$dirname] does not exist!" ); return $Test->ok(0, $name); } my $ok = -e File::Spec->catfile($dirname, $filename); if( $ok ) { $Test->ok(1, $name); } else { $Test->diag( "File [$filename] does not exist in directory $dirname!" ); $Test->ok(0, $name); } } =item link_count_is_ok( FILE, LINK_COUNT [, NAME ] ) Ok if the link count to FILE is LINK_COUNT. LINK_COUNT is interpreted as an integer. A LINK_COUNT that evaluates to 0 returns Ok if the file does not exist. =cut sub link_count_is_ok { my $file = shift; my $count = int( 0 + shift ); my $name = shift || "$file has a link count of [$count]"; my $actual = ( stat $file )[3]; unless( $actual == $count ) { $Test->diag( "File [$file] points has [$actual] links: expected [$count]!" ); return $Test->ok( 0, $name ); } $Test->ok( 1, $name ); } =item link_count_gt_ok( FILE, LINK_COUNT [, NAME ] ) Ok if the link count to FILE is greater than LINK_COUNT. LINK_COUNT is interpreted as an integer. A LINK_COUNT that evaluates to 0 returns Ok if the file has at least one link. =cut sub link_count_gt_ok { my $file = shift; my $count = int( 0 + shift ); my $name = shift || "$file has a link count of [$count]"; my $actual = (stat $file )[3]; unless( $actual > $count ) { $Test->diag( "File [$file] points has [$actual] links: ". "expected more than [$count]!" ); return $Test->ok( 0, $name ); } $Test->ok( 1, $name ); } =item link_count_lt_ok( FILE, LINK_COUNT [, NAME ] ) Ok if the link count to FILE is less than LINK_COUNT. LINK_COUNT is interpreted as an integer. A LINK_COUNT that evaluates to 0 returns Ok if the file has at least one link. =cut sub link_count_lt_ok { my $file = shift; my $count = int( 0 + shift ); my $name = shift || "$file has a link count of [$count]"; my $actual = (stat $file )[3]; unless( $actual < $count ) { $Test->diag( "File [$file] points has [$actual] links: ". "expected less than [$count]!" ); return $Test->ok( 0, $name ); } $Test->ok( 1, $name ); } # owner_is, owner_isnt, group_is and group_isnt are almost # identical in the beginning, so I'm writing a skeleton they can all use. # I can't think of a better name... sub _dm_skeleton { no warnings 'uninitialized'; if( _obviously_non_multi_user() ) { my $calling_sub = (caller(1))[3]; $Test->skip( $calling_sub . " only works on a multi-user OS!" ); return 'skip'; } my $filename = _normalize( shift ); my $testing_for = shift; my $name = shift; unless( defined $filename ) { $Test->diag( "File name not specified!" ); return $Test->ok( 0, $name ); } unless( -e $filename ) { $Test->diag( "File [$filename] does not exist!" ); return $Test->ok( 0, $name ); } return; } =item owner_is( FILE , OWNER [, NAME ] ) Ok if FILE's owner is the same as OWNER. OWNER may be a text user name or a numeric userid. Test skips on Dos, and Mac OS <= 9. If the file does not exist, the test fails. Contributed by Dylan Martin =cut sub owner_is { my $filename = shift; my $owner = shift; my $name = shift || "$filename belongs to $owner"; my $err = _dm_skeleton( $filename, $owner, $name ); return if( defined( $err ) && $err eq 'skip' ); return $err if defined($err); my $owner_uid = _get_uid( $owner ); unless( defined $owner_uid ) { $Test->diag("User [$owner] does not exist on this system!"); return $Test->ok( 0, $name ); } my $file_uid = ( stat $filename )[4]; unless( defined $file_uid ) { $Test->skip("stat failed to return owner uid for $filename!"); return; } return $Test->ok( 1, $name ) if $file_uid == $owner_uid; my $real_owner = ( getpwuid $file_uid )[0]; unless( defined $real_owner ) { $Test->diag("File does not belong to $owner!"); return $Test->ok( 0, $name ); } $Test->diag( "File [$filename] belongs to $real_owner ($file_uid), ". "not $owner ($owner_uid)!" ); return $Test->ok( 0, $name ); } =item owner_isnt( FILE, OWNER [, NAME ] ) Ok if FILE's owner is not the same as OWNER. OWNER may be a text user name or a numeric userid. Test skips on Dos and Mac OS <= 9. If the file does not exist, the test fails. Contributed by Dylan Martin =cut sub owner_isnt { my $filename = shift; my $owner = shift; my $name = shift || "$filename doesn't belong to $owner"; my $err = _dm_skeleton( $filename, $owner, $name ); return if( defined( $err ) && $err eq 'skip' ); return $err if defined($err); my $owner_uid = _get_uid( $owner ); unless( defined $owner_uid ) { return $Test->ok( 1, $name ); } my $file_uid = ( stat $filename )[4]; #$Test->diag( "owner_isnt: $owner_uid $file_uid" ); return $Test->ok( 1, $name ) if $file_uid != $owner_uid; $Test->diag( "File [$filename] belongs to $owner ($owner_uid)!" ); return $Test->ok( 0, $name ); } =item group_is( FILE , GROUP [, NAME ] ) Ok if FILE's group is the same as GROUP. GROUP may be a text group name or a numeric group id. Test skips on Dos, Mac OS <= 9 and any other operating systems that do not support getpwuid() and friends. If the file does not exist, the test fails. Contributed by Dylan Martin =cut sub group_is { my $filename = shift; my $group = shift; my $name = ( shift || "$filename belongs to group $group" ); my $err = _dm_skeleton( $filename, $group, $name ); return if( defined( $err ) && $err eq 'skip' ); return $err if defined($err); my $group_gid = _get_gid( $group ); unless( defined $group_gid ) { $Test->diag("Group [$group] does not exist on this system!"); return $Test->ok( 0, $name ); } my $file_gid = ( stat $filename )[5]; unless( defined $file_gid ) { $Test->skip("stat failed to return group gid for $filename!"); return; } return $Test->ok( 1, $name ) if $file_gid == $group_gid; my $real_group = ( getgrgid $file_gid )[0]; unless( defined $real_group ) { $Test->diag("File does not belong to $group!"); return $Test->ok( 0, $name ); } $Test->diag( "File [$filename] belongs to $real_group ($file_gid), ". "not $group ($group_gid)!" ); return $Test->ok( 0, $name ); } =item group_isnt( FILE , GROUP [, NAME ] ) Ok if FILE's group is not the same as GROUP. GROUP may be a text group name or a numeric group id. Test skips on Dos, Mac OS <= 9 and any other operating systems that do not support getpwuid() and friends. If the file does not exist, the test fails. Contributed by Dylan Martin =cut sub group_isnt { my $filename = shift; my $group = shift; my $name = shift || "$filename does not belong to group $group"; my $err = _dm_skeleton( $filename, $group, $name ); return if( defined( $err ) && $err eq 'skip' ); return $err if defined($err); my $group_gid = _get_gid( $group ); my $file_gid = ( stat $filename )[5]; unless( defined $file_gid ) { $Test->skip("stat failed to return group gid for $filename!"); return; } return $Test->ok( 1, $name ) if $file_gid != $group_gid; $Test->diag( "File [$filename] belongs to $group ($group_gid)!" ); return $Test->ok( 0, $name ); } sub _get_uid { my $owner = shift; my $owner_uid; if ($owner =~ /^\d+/) { $owner_uid = $owner; $owner = ( getpwuid $owner )[0]; } else { $owner_uid = (getpwnam($owner))[2]; } $owner_uid; } sub _get_gid { my $group = shift; my $group_uid; if ($group =~ /^\d+/) { $group_uid = $group; $group = ( getgrgid $group )[0]; } else { $group_uid = (getgrnam($group))[2]; } $group_uid; } =back =head1 TO DO * check properties for other users (readable_by_root, for instance) * check times * check number of links to file * check path parts (directory, filename, extension) =head1 SEE ALSO L, L =head1 SOURCE AVAILABILITY This module is in Github: git://github.com/briandfoy/test-file.git =head1 AUTHOR brian d foy, C<< >> =head1 CREDITS Shawn Sorichetti C<< >> provided some functions. Tom Metro helped me figure out some Windows capabilities. Dylan Martin added C and C. David Wheeler added C. Buddy Burden C<< >> provided C, C, C, and C. =head1 COPYRIGHT AND LICENSE Copyright (c) 2002-2013 brian d foy. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut "The quick brown fox jumped over the lazy dog"; Test-File-1.36/Makefile.PL0000644000175000001440000000176112225460631014245 0ustar buddyusersuse ExtUtils::MakeMaker 6.48; require 5.006; eval "use Test::Manifest 1.21"; WriteMakefile( 'NAME' => 'Test::File', 'ABSTRACT' => 'Check file attributes', 'LICENSE' => 'perl', 'AUTHOR' => 'brian d foy ', 'VERSION_FROM' => 'lib/Test/File.pm', 'PREREQ_PM' => { 'Test::More' => '0.95', 'Test::Builder::Tester' => '1.04', 'Test::Builder' => '0.33', 'Test::Manifest' => '1.14', }, META_ADD => { no_index => { package => [ qw( version Local ) ], directory => [ qw( t/inc inc ) ], file => [ qw( t/lib/test.pm ) ], namespace => [ qw( Local ) ], }, }, META_MERGE => { 'meta-spec' => { version => 2 }, keywords => ['testing','file'], resources => { repository => { type => 'git', url => 'git://github.com/briandfoy/test-file.git', web => 'https://github.com/briandfoy/test-file', }, }, }, clean => { FILES => q|Test-File-* test_files| }, ); Test-File-1.36/README0000644000175000001440000000070511702255574013157 0ustar buddyusersYou can install this using in the usual Perl fashion perl Makefile.PL make make test make install The documentation is in the module file. Once you install the file, you can read it with perldoc. perldoc Test::File If you want to read it before you install it, you can use perldoc directly on the module file. perldoc lib/File.pm This module is in Github git://github.com/briandfoy/test-file.git Enjoy, brian d foy, bdfoy@cpan.org Test-File-1.36/META.yml0000644000175000001440000000107412261132575013544 0ustar buddyusers--- abstract: 'Check file attributes' author: - 'brian d foy ' build_requires: {} dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 6.66, CPAN::Meta::Converter version 2.131560' keywords: - testing - file license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Test-File no_index: directory: - t/inc - inc file: - t/lib/test.pm namespace: - Local package: - version - Local resources: repository: git://github.com/briandfoy/test-file.git version: 1.36 Test-File-1.36/META.json0000644000175000001440000000170012261132575013710 0ustar buddyusers{ "abstract" : "Check file attributes", "author" : [ "brian d foy " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 6.66, CPAN::Meta::Converter version 2.131560", "keywords" : [ "testing", "file" ], "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Test-File", "no_index" : { "directory" : [ "t/inc", "inc" ], "file" : [ "t/lib/test.pm" ], "namespace" : [ "Local" ], "package" : [ "version", "Local" ] }, "release_status" : "stable", "resources" : { "repository" : { "type" : "git", "url" : "git://github.com/briandfoy/test-file.git", "web" : "https://github.com/briandfoy/test-file" } }, "version" : "1.36" } Test-File-1.36/examples/0000755000175000001440000000000012261132575014107 5ustar buddyusersTest-File-1.36/examples/README0000644000175000001440000000010511702255574014767 0ustar buddyusersSee the tests in the t/ directory for examples until I add some more.Test-File-1.36/MANIFEST0000644000175000001440000000103412261132575013420 0ustar buddyusersChanges examples/README lib/Test/File.pm LICENSE Makefile.PL MANIFEST This list of files README t/dm_skeleton.t t/file_contains.t t/file_sizes.t t/line_counters.t t/link_counts.t t/links.t t/load.t t/normalize.t t/obviously_non_multi_user.t t/owner.t t/pod.t t/pod_coverage.t t/prereq.t t/rt/30346.t t/setup_common t/test_dirs.t t/test_files.t t/test_manifest t/win32.t META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) Test-File-1.36/LICENSE0000644000175000001440000000007311702255574013302 0ustar buddyusersYou can use Test::File under the same terms as Perl itself.Test-File-1.36/t/0000755000175000001440000000000012261132575012534 5ustar buddyusersTest-File-1.36/t/links.t0000644000175000001440000001271012225460631014037 0ustar buddyusersuse strict; use Test::Builder::Tester; use Test::More; use Test::File; my $can_symlink = eval { symlink("",""); 1 }; if ($can_symlink) { plan tests => 37; } else { plan skip_all => "This system does't do symlinks"; } my $test_directory = 'test_files'; SKIP: { skip "setup already done", 5 if -d $test_directory; require "t/setup_common"; }; chdir $test_directory or print "bail out! Could not change directories: $!"; # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # Things that don't work with symlinks. Fake that we don't understand # symlinks { no warnings 'redefine'; local *Test::File::_no_symlinks_here = sub { 1 }; my @subs = qw( file_is_symlink_ok symlink_target_exists_ok symlink_target_dangles_ok symlink_target_is ); foreach my $sub ( @subs ) { no strict 'refs'; ok( defined &{$sub}, "$sub is defined" ); } foreach my $sub ( @subs ) { no strict 'refs'; test_out("ok 1 # skip $sub doesn't work on systems without symlinks!"); &{$sub}(); test_test(); } } # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # Stuff that should work { my $test_name = "This is my test name"; my $readable = 'readable'; my $readable_sym = 'readable_sym'; my $not_there = 'not_there'; my $dangle_sym = 'dangle_sym'; my $s = ! $can_symlink ? "# skip file_is_symlink_ok doesn't work on systems without symlinks!" : "- $readable_sym is a symlink"; file_exists_ok( $readable ); file_not_exists_ok( $readable_sym ); if( $can_symlink ) { symlink( $readable, $readable_sym ); open my($fh), ">", $not_there; close $fh; file_exists_ok( $not_there ); symlink( $not_there, $dangle_sym ); file_exists_ok( $readable_sym ); file_exists_ok( $dangle_sym ); unlink $not_there; ok( ! -e $not_there ); file_is_symlink_ok( $dangle_sym ); } else { pass(); } test_out( "ok 1 $s" ); file_is_symlink_ok( $readable_sym ); test_test(); test_out( "ok 1 - $test_name" ); file_is_symlink_ok( $readable_sym, $test_name ); test_test(); test_out( "ok 1 - $test_name" ); symlink_target_dangles_ok( $dangle_sym, $test_name ); test_test(); test_out( "ok 1 - $test_name" ); symlink_target_exists_ok( $readable_sym, $readable, $test_name ); test_test(); test_out( "ok 1 $s\nok 2 - $test_name" ); symlink_target_exists_ok( $readable_sym, $readable ); symlink_target_is( $readable_sym, $readable, $test_name ); test_test(); # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # Stuff that shouldn't work (not a symlink) { ok( ! -l $readable, "$readable is not a symlink" ); ok( ! -l $not_there, "$not_there is not a symlink" ); test_out( "not ok 1 - $test_name" ); test_diag( "File [$readable] is not a symlink!\n" . "# Failed test '$test_name'\n" . "# at $0 line " . line_num(+5) . "." ); file_is_symlink_ok( $readable, $test_name ); test_test(); test_out( "not ok 1 - $test_name" ); test_diag( "File [$not_there] is not a symlink!\n" . "# Failed test '$test_name'\n" . "# at $0 line " . line_num(+5) . "." ); file_is_symlink_ok( $not_there, $test_name ); test_test(); test_out( "not ok 1 - $test_name" ); test_diag( "File [$not_there] is not a symlink!\n" . "# Failed test '$test_name'\n" . "# at $0 line " . line_num(+5) . "." ); symlink_target_dangles_ok( $not_there, $test_name ); test_test(); test_out( "not ok 1 - $test_name" ); test_diag( "File [$readable] is not a symlink!\n" . "# Failed test '$test_name'\n" . "# at $0 line " . line_num(+5) . "." ); symlink_target_is( $readable, $readable_sym, $test_name ); test_test(); test_out( "not ok 1 - $readable is a symlink" ); test_diag( "File [$readable] is not a symlink!\n" . "# Failed test '$readable is a symlink'\n" . "# at $0 line " . line_num(+5) . "." ); symlink_target_exists_ok( $readable ); test_test(); } # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # Test using bad target that doesn't exist test_out( "not ok 1 $s" ); test_diag( "Symlink [$readable_sym] points to non-existent target [$not_there]!\n" . "# Failed test '$readable_sym is a symlink'\n" . "# at $0 line " . line_num(+5) . "." ); symlink_target_exists_ok( $readable_sym, $not_there ); test_test(); test_out( "not ok 1 - symlink $readable_sym points to $not_there" ); test_diag( " Failed test 'symlink $readable_sym points to $not_there'\n" . "# at $0 line " . line_num(+6) . ".\n" . "# got: $readable\n" . "# expected: $not_there" ); symlink_target_is( $readable_sym, $not_there ); test_test(); # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # Test using bad target that exists test_out( "not ok 1 $s" ); test_diag( "Symlink [readable_sym] points to\n" . "# got: readable\n" . "# expected: writeable\n" . "# Failed test 'readable_sym is a symlink'\n" . "# at $0 line " . line_num(+7) . "." ); symlink_target_exists_ok( $readable_sym, "writeable" ); test_test(); # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # Test dangling with existing targets test_out( "not ok 1 - $test_name" ); test_diag( "Symlink [$readable_sym] points to existing file [$readable] but shouldn't!\n" . "# Failed test '$test_name'\n" . "# at $0 line " . line_num(+5) . "." ); symlink_target_dangles_ok( $readable_sym, $test_name ); test_test(); } # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # END { unlink glob( "test_files/*" ); rmdir "test_files"; } Test-File-1.36/t/test_files.t0000644000175000001440000000571312225460631015065 0ustar buddyusersuse strict; use Test::Builder::Tester; use Test::More tests => 20; # includes those in t/setup_common use Test::File; =pod max_file non_zero_file not_readable readable zero_file executable min_file not_executable not_writeable writeable =cut my $test_directory = 'test_files'; SKIP: { skip "setup already done", 5 if -d $test_directory; require "t/setup_common"; }; chdir $test_directory or print "bail out! Could not change directories: $!"; test_out( 'ok 1 - readable exists' ); file_exists_ok( 'readable' ); test_test(); test_out( 'ok 1 - fooey does not exist' ); file_not_exists_ok( 'fooey' ); test_test(); # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # test_out( 'ok 1 - readable is readable' ); file_readable_ok( 'readable' ); test_test(); SKIP: { skip "Superuser has special privileges", 1, if( $> == 0 or $< == 0 ); test_out( 'ok 1 - writeable is not readable' ); file_not_readable_ok( 'writeable' ); test_test(); }; test_out( 'ok 1 - writeable is writeable' ); file_writeable_ok( 'writeable' ); test_test(); SKIP: { skip "Superuser has special privileges", 1, if( $> == 0 or $< == 0 ); test_out( 'ok 1 - readable is not writeable' ); file_not_writeable_ok( 'readable' ); test_test(); }; { my $s = Test::File::_win32() ? "# skip file_executable_ok doesn't work on Windows!" : "- executable is executable"; test_out( "ok 1 $s" ); file_executable_ok( 'executable' ); test_test(); } { my $s = Test::File::_win32() ? "# skip file_not_executable_ok doesn't work on Windows!" : "- not_executable is not executable"; test_out( "ok 1 $s" ); file_not_executable_ok( 'not_executable' ); test_test(); } { my $s = Test::File::_win32() ? "# skip file_mode_is doesn't work on Windows!" : "- executable mode is 0100"; test_out( "ok 1 $s" ); file_mode_is( 'executable', 0100 ); test_test(); } { my $s = Test::File::_win32() ? "# skip file_mode_isnt doesn't work on Windows!" : "- executable mode is not 0200"; test_out( "ok 1 $s" ); file_mode_isnt( 'executable', 0200 ); test_test(); } { my $s = Test::File::_win32() ? "# skip file_mode_is doesn't work on Windows!" : "- readable mode is 0400"; test_out( "ok 1 $s" ); file_mode_is( 'readable', 0400 ); test_test(); } { my $s = Test::File::_win32() ? "# skip file_mode_isnt doesn't work on Windows!" : "- readable mode is not 0200"; test_out( "ok 1 $s" ); file_mode_isnt( 'readable', 0200 ); test_test(); } { my $s = Test::File::_win32() ? "# skip file_mode_is doesn't work on Windows!" : "- writeable mode is 0200"; test_out( "ok 1 $s" ); file_mode_is( 'writeable', 0200 ); test_test(); } { my $s = Test::File::_win32() ? "# skip file_mode_isnt doesn't work on Windows!" : "- writeable mode is not 0100"; test_out( "ok 1 $s" ); file_mode_isnt( 'writeable', 0100 ); test_test(); } # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # END { chdir '..' or print "bail out! Could not change directories: $!"; unlink glob( "test_files/*" ); rmdir "test_files"; } Test-File-1.36/t/obviously_non_multi_user.t0000644000175000001440000000276512225460631020105 0ustar buddyusersuse Test::More tests => 8; BEGIN { our $getpwuid_should_die = 0; our $getgrgid_should_die = 0; }; BEGIN{ no warnings; *CORE::GLOBAL::getpwuid = sub ($) { die "Fred" if $getpwuid_should_die }; *CORE::GLOBAL::getgrgid = sub ($) { die "Barney" if $getgrgid_should_die }; } use_ok( 'Test::File' ); ok( defined &{ "Test::File::_obviously_non_multi_user" }, "_win32 defined" ); # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # The ones that we know aren't multi-user { local $^O = 'MacOS'; ok( Test::File::_obviously_non_multi_user(), "Returns false for MacOS" ); } { local $^O = 'dos'; ok( Test::File::_obviously_non_multi_user(), "Returns true for Win32" ); } # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # The ones that use get*, but die { local $^O = 'Fooey'; $getpwuid_should_die = 1; $getgrgid_should_die = 0; ok( Test::File::_obviously_non_multi_user(), 'getpwuid dying returns true' ); } { local $^O = 'Fooey'; $getpwuid_should_die = 0; $getgrgid_should_die = 1; ok( Test::File::_obviously_non_multi_user(), 'getgrgid dying returns true' ); } # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # The ones that use get*, but don't die { local $^O = 'Fooey'; $getpwuid_should_die = 0; $getgrgid_should_die = 0; ok( ! Test::File::_obviously_non_multi_user(), 'getpwuid dying returns true' ); } { local $^O = 'Fooey'; $getpwuid_should_die = 0; $getgrgid_should_die = 0; ok( ! Test::File::_obviously_non_multi_user(), 'getgrgid dying returns true' ); } Test-File-1.36/t/test_manifest0000644000175000001440000000031011715647243015324 0ustar buddyusersload.t pod.t pod_coverage.t normalize.t dm_skeleton.t win32.t obviously_non_multi_user.t test_files.t test_dirs.t links.t link_counts.t line_counters.t file_sizes.t file_contains.t owner.t rt/30346.t Test-File-1.36/t/load.t0000644000175000001440000000027311702255574013646 0ustar buddyusersBEGIN { @classes = qw(Test::File); } use Test::More tests => scalar @classes; foreach my $class ( @classes ) { print "Bail out! $class did not compile!" unless use_ok( $class ); } Test-File-1.36/t/dm_skeleton.t0000644000175000001440000000427512225460631015232 0ustar buddyusersuse strict; use Test::Builder::Tester; use Test::More tests => 19; # includes those in t/setup_common use Test::File; my $test_directory = 'test_files'; SKIP: { skip "setup already done", 5 if -d $test_directory; require "t/setup_common"; }; chdir $test_directory or print "bail out! Could not change directories: $!"; # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # Subroutines are defined ok( defined &Test::File::_dm_skeleton, "_dm_skeleton is defined" ); my $readable = 'readable'; my $not_there = 'not_there'; my $test_name = 'This is my test name'; # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # Fake a non-multi-user OS { local $^O = 'dos'; ok( Test::File::_obviously_non_multi_user(), "Is not multi user" ); is( Test::File::_dm_skeleton(), 'skip', "Skip on single user systems" ); is( Test::File::_dm_skeleton($readable), 'skip', "Skip on single user systems" ); is( Test::File::_dm_skeleton($not_there), 'skip', "Skip on single user systems" ); } # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # Fake a multi-user OS with existing file { local $^O = 'MSWin32'; diag "$^O\n";; ok( ! Test::File::_obviously_non_multi_user(), "Is multi user" ); } # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # Fake a multi-user OS with non-existing file { local $^O = 'MSWin32'; ok( ! Test::File::_obviously_non_multi_user(), "Is multi user" ); test_out( "not ok 1" ); test_diag( "File [$not_there] does not exist!\n" . "# Failed test at $0 line " . line_num(+4) . "." ); Test::File::_dm_skeleton( $not_there ); test_test(); } # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # Fake a multi-user OS with no argument { local $^O = 'MSWin32'; ok( ! Test::File::_obviously_non_multi_user(), "Is multi user" ); test_out( "not ok 1" ); test_diag( "File name not specified!\n" . "# Failed test at $0 line " . line_num(+4) . "." ); Test::File::_dm_skeleton(); test_test(); } # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # END { chdir '..' or print "bail out! Could not change directories: $!"; unlink glob( "test_files/*" ); rmdir "test_files"; } Test-File-1.36/t/prereq.t0000644000175000001440000000024511702255574014224 0ustar buddyusersuse Test::More; eval "use Test::Prereq 1.0"; plan skip_all => "Test::Prereq required to test dependencies" if $@; prereq_ok( undef, undef, [ qw(t/setup_common) ] ); Test-File-1.36/t/file_sizes.t0000644000175000001440000001076112225460631015057 0ustar buddyusersuse strict; use Test::Builder::Tester; use Test::More tests => 26; # includes those in t/setup_common use Test::File; my $test_directory = 'test_files'; SKIP: { skip "setup already done", 5 if -d $test_directory; require "t/setup_common"; }; chdir $test_directory or print "bail out! Could not change directories: $!"; # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # test_out( 'ok 1 - zero_file is empty' ); file_empty_ok( 'zero_file' ); test_test(); test_out( 'ok 1 - min_file is not empty' ); file_not_empty_ok( 'min_file' ); test_test(); # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # Things that work { my $file = 'min_file'; file_exists_ok( $file ); my $actual_size = -s $file; my $under_size = $actual_size - 3; my $over_size = $actual_size + 3; cmp_ok( $actual_size, '>', 10, "$file should be at least 10 bytes" ); test_out( "ok 1 - $file has right size" ); file_size_ok( $file, $actual_size ); test_test(); test_out( "ok 1 - $file is under $over_size bytes" ); file_max_size_ok( $file, $over_size ); test_test(); test_out( "ok 1 - $file is over $under_size bytes" ); file_min_size_ok( $file, $under_size ); test_test(); } # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # Things that don't work (wrong size) { my $file = 'min_file'; file_exists_ok( $file ); my $actual_size = -s $file; my $under_size = $actual_size - 3; my $over_size = $actual_size + 3; cmp_ok( $actual_size, '>', 10, "$file should be at least 10 bytes" ); test_out( "not ok 1 - $file has right size" ); test_diag( "File [$file] has actual size [$actual_size] not [$under_size]!\n" . "# Failed test '$file has right size'\n" . "# at $0 line " . line_num(+5) . "." ); file_size_ok( $file, $under_size ); test_test(); test_out( "not ok 1 - $file is under $under_size bytes" ); test_diag( "File [$file] has actual size [$actual_size] greater than [$under_size]!\n" . "# Failed test '$file is under $under_size bytes'\n" . "# at $0 line " . line_num(+5) . "." ); file_max_size_ok( $file, $under_size ); test_test(); test_out( "not ok 1 - $file is over $over_size bytes" ); test_diag( "File [$file] has actual size [$actual_size] less than [$over_size]!\n" . "# Failed test '$file is over $over_size bytes'\n" . "# at $0 line " . line_num(+5) . "." ); file_min_size_ok( $file, $over_size ); test_test(); test_out( "not ok 1 - $file is empty" ); test_diag( "File [$file] exists with non-zero size!\n" . "# Failed test '$file is empty'\n" . "# at $0 line " . line_num(+5) . "." ); file_empty_ok( $file ); test_test(); test_out( "not ok 1 - zero_file is not empty" ); test_diag( "File [zero_file] exists with zero size!\n" . "# Failed test 'zero_file is not empty'\n" . "# at $0 line " . line_num(+5) . "." ); file_not_empty_ok( 'zero_file' ); test_test(); } # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # Things that don't work (missing file) { my $not_there = 'not_there'; ok( ! -e $not_there, "File [$not_there] doesn't exist (good)" ); test_out( "not ok 1 - $not_there has right size" ); test_diag( "File [$not_there] does not exist!\n" . "# Failed test '$not_there has right size'\n" . "# at $0 line " . line_num(+5) . "." ); file_size_ok( $not_there, 53 ); test_test(); test_out( "not ok 1 - $not_there is under 54 bytes" ); test_diag( "File [$not_there] does not exist!\n" . "# Failed test '$not_there is under 54 bytes'\n" . "# at $0 line " . line_num(+5) . "." ); file_max_size_ok( $not_there, 54 ); test_test(); test_out( "not ok 1 - $not_there is over 50 bytes" ); test_diag( "File [$not_there] does not exist!\n" . "# Failed test '$not_there is over 50 bytes'\n" . "# at $0 line " . line_num(+5) . "." ); file_min_size_ok( $not_there, 50 ); test_test(); test_out( "not ok 1 - $not_there is empty" ); test_diag( "File [$not_there] does not exist!\n" . "# Failed test '$not_there is empty'\n" . "# at $0 line " . line_num(+5) . "." ); file_empty_ok( $not_there ); test_test(); test_out( "not ok 1 - $not_there is not empty" ); test_diag( "File [$not_there] does not exist!\n" . "# Failed test '$not_there is not empty'\n" . "# at $0 line " . line_num(+5) . "." ); file_not_empty_ok( $not_there ); test_test(); } # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # END { chdir '..' or print "bail out! Could not change directories: $!"; unlink glob( "test_files/*" ); rmdir "test_files"; } Test-File-1.36/t/test_dirs.t0000644000175000001440000000313112225460631014714 0ustar buddyusersuse strict; use warnings; use Test::Builder::Tester; use Test::More 0.95; use Test::File; my $test_directory = 'test_files'; require "t/setup_common" unless -d $test_directory; chdir $test_directory or print "bail out! Could not change directories: $!"; mkdir 'test_dir', 0700; open FH, '> test_dir/subdir_file'; close FH; # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # test_out( 'ok 1 - test_dir is a directory' ); dir_exists_ok( 'test_dir' ); test_test(); test_out( 'not ok 1 - bmoogle is a directory' ); test_diag( 'File [bmoogle] does not exist!' ); test_fail(+1); dir_exists_ok( 'bmoogle' ); test_test(); test_out( 'not ok 1 - readable is a directory' ); test_diag( 'File [readable] exists but is not a directory!' ); test_fail(+1); dir_exists_ok( 'readable' ); test_test(); test_out( 'ok 1 - directory test_dir contains file subdir_file' ); dir_contains_ok( 'test_dir', 'subdir_file' ); test_test(); test_out( 'not ok 1 - directory bmoogle contains file subdir_file' ); test_diag( 'Directory [bmoogle] does not exist!' ); test_fail(+1); dir_contains_ok( 'bmoogle', 'subdir_file' ); test_test(); test_out( 'not ok 1 - directory test_dir contains file bmoogle' ); test_diag( 'File [bmoogle] does not exist in directory test_dir!' ); test_fail(+1); dir_contains_ok( 'test_dir', 'bmoogle' ); test_test(); done_testing(); # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # END { chdir '..' or print "bail out! Could not change directories: $!"; unlink glob( "test_files/test_dir/*" ); rmdir "test_files/test_dir"; unlink glob( "test_files/*" ); rmdir "test_files"; } Test-File-1.36/t/link_counts.t0000644000175000001440000000475312225460631015257 0ustar buddyusersuse strict; use Test::Builder::Tester; use Test::More tests => 14; # includes those in t/setup_common use Test::File; my $test_directory = 'test_files'; SKIP: { skip "setup already done", 6 if -d $test_directory; require "t/setup_common"; }; chdir $test_directory or print "bail out! Could not change directories: $!"; # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # Subroutines are defined { my @subs = qw( link_count_is_ok link_count_gt_ok link_count_lt_ok ); foreach my $sub ( @subs ) { no strict 'refs'; ok( defined &{$sub}, "$sub is defined" ); } } # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # Stuff that should work (single link) my $test_name = "This is my test name"; my $readable = 'readable'; my $readable_sym = 'readable_sym'; my $not_there = 'not_there'; my $dangle_sym = 'dangle_sym'; test_out( "ok 1 - $test_name\nok 2 - $test_name\nok 3 - $test_name" ); link_count_lt_ok( $readable, 100, $test_name ); link_count_gt_ok( $readable, 0, $test_name ); link_count_is_ok( $readable, 1, $test_name ); test_test(); test_out( "ok 1 - $readable has a link count of [1]" ); link_count_is_ok( $readable, 1 ); test_test(); # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # Stuff that should work (multipe links) # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # Stuff that should fail (missing file) # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # Stuff that should fail (bad count) test_out( "not ok 1 - $test_name" ); test_diag( "File [$readable] points has [1] links: expected [100]!\n" . "# Failed test '$test_name'\n" . "# at $0 line " . line_num(+5) . "." ); link_count_is_ok( $readable, 100, $test_name ); test_test(); test_out( "not ok 1 - $test_name" ); test_diag( "File [$readable] points has [1] links: expected less than [0]!\n" . "# Failed test '$test_name'\n" . "# at $0 line " . line_num(+5) . "." ); link_count_lt_ok( $readable, 0, $test_name ); test_test(); test_out( "not ok 1 - $test_name" ); test_diag( "File [readable] points has [1] links: expected more than [100]!\n" . "# Failed test '$test_name'\n" . "# at $0 line " . line_num(+5) . "." ); link_count_gt_ok( $readable, 100, $test_name ); test_test(); # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # END { chdir '..' or print "bail out! Could not change directories: $!"; unlink glob( "test_files/*" ); rmdir "test_files"; } Test-File-1.36/t/file_contains.t0000644000175000001440000001147411711650072015541 0ustar buddyusersuse strict; use warnings; use Test::Builder::Tester; use Test::More 0.88; use Test::File; my $test_directory = 'test_files'; require "t/setup_common" unless -d $test_directory; chdir $test_directory or print "bail out! Could not change directories: $!"; # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # my $file = 'min_file'; my $contents = do { open FH, $file; local $/; }; close FH; my $pattern1 = 'x' x 11; $pattern1 = qr/(?mx:^ $pattern1 $)/; my $pattern2 = 'x' x 40; $pattern2 = qr/(?mx:^ $pattern2 $)/; my $bad_pattern = 'x' x 20; $bad_pattern = qr/(?mx:^ $bad_pattern $)/; # like : single pattern test_out( "ok 1 - min_file contains $pattern1" ); file_contains_like( $file, $pattern1 ); test_test(); test_out( "not ok 1 - bmoogle contains $pattern1" ); test_diag( 'File [bmoogle] does not exist!' ); test_fail(+1); file_contains_like( 'bmoogle', $pattern1 ); test_test(); SKIP: { skip "Superuser has special privileges", 1, if( $> == 0 or $< == 0 ); test_out( "not ok 1 - not_readable contains $pattern1" ); test_diag( 'File [not_readable] is not readable!' ); test_fail(+1); file_contains_like( 'not_readable', $pattern1 ); test_test(); } test_out( "not ok 1 - min_file contains $bad_pattern" ); test_fail(+2); like_diag($contents, $bad_pattern, "doesn't match"); file_contains_like( 'min_file', $bad_pattern ); test_test(); # unlike : single pattern test_out( "ok 1 - min_file doesn't contain $bad_pattern" ); file_contains_unlike( $file, $bad_pattern ); test_test(); test_out( "not ok 1 - bmoogle doesn't contain $bad_pattern" ); test_diag( 'File [bmoogle] does not exist!' ); test_fail(+1); file_contains_unlike( 'bmoogle', $bad_pattern ); test_test(); SKIP: { skip "Superuser has special privileges", 1, if( $> == 0 or $< == 0 ); test_out( "not ok 1 - not_readable doesn't contain $bad_pattern" ); test_diag( 'File [not_readable] is not readable!' ); test_fail(+1); file_contains_unlike( 'not_readable', $bad_pattern ); test_test(); } test_out( "not ok 1 - min_file doesn't contain $pattern1" ); test_fail(+2); like_diag($contents, $pattern1, "matches"); file_contains_unlike( 'min_file', $pattern1 ); test_test(); # like : multiple patterns test_out( "ok 1 - min_file contains $pattern1" ); test_out( "ok 2 - min_file contains $pattern2" ); file_contains_like( $file, [ $pattern1, $pattern2 ] ); test_test(); test_out( "ok 1 - file has the goods" ); test_out( "ok 2 - file has the goods" ); file_contains_like( $file, [ $pattern1, $pattern2 ], 'file has the goods' ); test_test(); test_out( "not ok 1 - bmoogle contains $pattern1" ); test_diag( 'File [bmoogle] does not exist!' ); test_fail(+1); file_contains_like( 'bmoogle', [ $pattern1, $pattern2 ] ); test_test(); SKIP: { skip "Superuser has special privileges", 1, if( $> == 0 or $< == 0 ); test_out( "not ok 1 - not_readable contains $pattern1" ); test_diag( 'File [not_readable] is not readable!' ); test_fail(+1); file_contains_like( 'not_readable', [ $pattern1, $pattern2 ] ); test_test(); } test_out( "ok 1 - min_file contains $pattern1" ); test_out( "not ok 2 - min_file contains $bad_pattern" ); test_fail(+2); like_diag($contents, $bad_pattern, "doesn't match"); file_contains_like( 'min_file', [ $pattern1, $bad_pattern ] ); test_test(); # unlike : multiple patterns test_out( "ok 1 - min_file doesn't contain $bad_pattern" ); test_out( "ok 2 - min_file doesn't contain $bad_pattern" ); file_contains_unlike( $file, [ $bad_pattern, $bad_pattern ] ); test_test(); test_out( "ok 1 - file has the goods" ); test_out( "ok 2 - file has the goods" ); file_contains_unlike( $file, [ $bad_pattern, $bad_pattern ], 'file has the goods' ); test_test(); test_out( "not ok 1 - bmoogle doesn't contain $bad_pattern" ); test_diag( 'File [bmoogle] does not exist!' ); test_fail(+1); file_contains_unlike( 'bmoogle', [ $bad_pattern, $bad_pattern ] ); test_test(); SKIP: { skip "Superuser has special privileges", 1, if( $> == 0 or $< == 0 ); test_out( "not ok 1 - not_readable doesn't contain $bad_pattern" ); test_diag( 'File [not_readable] is not readable!' ); test_fail(+1); file_contains_unlike( 'not_readable', [ $bad_pattern, $bad_pattern ] ); test_test(); } test_out( "ok 1 - min_file doesn't contain $bad_pattern" ); test_out( "not ok 2 - min_file doesn't contain $pattern1" ); test_fail(+2); like_diag($contents, $pattern1, "matches"); file_contains_unlike( 'min_file', [ $bad_pattern, $pattern1 ] ); test_test(); done_testing(); # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # END { chdir '..' or print "bail out! Could not change directories: $!"; unlink glob( "test_files/*" ); rmdir "test_files"; } # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # sub like_diag { my ($string, $pattern, $verb) = @_; my $diag = ' ' x 18 . "'$string'\n"; $diag .= sprintf("%17s '%s'", $verb, $pattern); $diag =~ s/^/# /mg; test_err($diag); } Test-File-1.36/t/normalize.t0000644000175000001440000000312711702255574014730 0ustar buddyusersuse Test::More tests => 14; use File::Spec; use_ok( 'Test::File' ); # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # Try it when it should work { my $module = 'File::Spec::Unix'; use_ok( $module ); local @File::Spec::ISA = ( $module ); my $file = '/foo/bar/baz'; my $normalized = Test::File::_normalize( $file ); is( $normalized, $file, "Normalize gives same path for unix" ); } { my $module = 'File::Spec::Win32'; use_ok( $module ); local @File::Spec::ISA = ( $module ); my $file = '/foo/bar/baz'; my $normalized = Test::File::_normalize( $file ); isnt( $normalized, $file, "Normalize gives different path for Win32" ); is( $normalized, '\foo\bar\baz', "Normalize gives right path for Win32" ); } { my $module = 'File::Spec::Mac'; use_ok( $module ); local @File::Spec::ISA = ( $module ); my $file = '/foo/bar/baz'; my $normalized = Test::File::_normalize( $file ); isnt( $normalized, $file, "Normalize gives different path for Mac" ); is( $normalized, 'foo:bar:baz', "Normalize gives right path for Mac" ); } # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # Try it when it shouldn't work { my $normalized = Test::File::_normalize( undef ); ok( ! defined $normalized, "Passing undef fails" ); } { my $normalized = Test::File::_normalize( '' ); ok( defined $normalized, "Passing empty string returns defined value" ); is( $normalized, '', "Passing empty string returns empty string" ); ok( ! $normalized, "Passing empty string fails" ); } { my $normalized = Test::File::_normalize(); ok( ! defined $normalized, "Passing nothing fails" ); } Test-File-1.36/t/line_counters.t0000644000175000001440000001346512255723347015611 0ustar buddyusersuse strict; use Test::Builder::Tester; use Test::More tests => 30; # includes those in t/setup_common use Test::File; my $test_directory = 'test_files'; SKIP: { skip "setup already done", 5 if -d $test_directory; require "t/setup_common"; }; chdir $test_directory or print "bail out! Could not change directories: $!"; # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # Subroutines are defined { my @subs = qw( file_line_count_between file_line_count_is file_line_count_isnt ); foreach my $sub ( @subs ) { no strict 'refs'; ok( defined &{$sub}, "$sub is defined" ); } } # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # Line count my $file = 'min_file'; file_exists_ok( $file ); my @lines = do { local @ARGV = $file; <> }; cmp_ok( scalar @lines, ">", 1, "$file has at least one line" ); my $lines = @lines; my $linesm = $lines - 1; my $linesp = $lines + 1; # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # Things that should work { test_out( "ok 1 - $file line count is between [$linesm] and [$linesp] lines" ); file_line_count_between( $file, $linesm, $linesp ); test_test(); test_out( "ok 1 - $file line count is between [$lines] and [$linesp] lines" ); file_line_count_between( $file, $lines, $linesp ); test_test(); test_out( "ok 1 - $file line count is between [$lines] and [$lines] lines" ); file_line_count_between( $file, $lines, $lines ); test_test(); test_out( "ok 1 - $file line count is $lines lines" ); file_line_count_is( $file, $lines ); test_test(); test_out( "ok 1 - $file line count is not $linesp lines" ); file_line_count_isnt( $file, $linesp ); test_test(); } # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # Things that should fail (missing file) { my $missing = 'not_there'; file_not_exists_ok( $missing ); test_out( "not ok 1 - $missing line count is between [$linesm] and [$linesp] lines" ); test_diag( "File [$missing] does not exist!\n" . "# Failed test '$missing line count is between [$linesm] and [$linesp] lines'\n" . "# at $0 line " . line_num(+5) . "." ); file_line_count_between( $missing, $linesm, $linesp ); test_test(); test_out( "not ok 1 - $missing line count is between [$lines] and [$linesp] lines" ); test_diag( "File [$missing] does not exist!\n" . "# Failed test '$missing line count is between [$lines] and [$linesp] lines'\n" . "# at $0 line " . line_num(+5) . "." ); file_line_count_between( $missing, $lines, $linesp ); test_test(); test_out( "not ok 1 - $missing line count is between [$lines] and [$lines] lines" ); test_diag( "File [$missing] does not exist!\n" . "# Failed test '$missing line count is between [$lines] and [$lines] lines'\n" . "# at $0 line " . line_num(+5) . "." ); file_line_count_between( $missing, $lines, $lines ); test_test(); test_out( "not ok 1 - $missing line count is $lines lines" ); test_diag( "File [$missing] does not exist!\n" . "# Failed test '$missing line count is $lines lines'\n" . "# at $0 line " . line_num(+5) . "." ); file_line_count_is( $missing, $lines ); test_test(); test_out( "not ok 1 - $missing line count is not $lines lines" ); test_diag( "File [$missing] does not exist!\n" . "# Failed test '$missing line count is not $lines lines'\n" . "# at $0 line " . line_num(+5) . "." ); file_line_count_isnt( $missing, $lines ); test_test(); } # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # Things that should fail (missing line count) { my $file = 'min_file'; file_exists_ok( $file ); test_out( "not ok 1 - $file line count is between [] and [] lines" ); test_diag( "file_line_count_between expects positive whole numbers for the second and third arguments. Got [] and []!\n" . "# Failed test '$file line count is between [] and [] lines'\n" . "# at $0 line " . line_num(+5) . "." ); file_line_count_between( $file ); test_test(); test_out( "not ok 1 - $file line count is lines" ); test_diag( "file_line_count_is expects a positive whole number for the second argument. Got []!\n" . "# Failed test '$file line count is lines'\n" . "# at $0 line " . line_num(+5) . "." ); file_line_count_is( $file ); test_test(); test_out( "not ok 1 - $file line count is not lines" ); test_diag( "file_line_count_is expects a positive whole number for the second argument. Got []!\n" . "# Failed test '$file line count is not lines'\n" . "# at $0 line " . line_num(+5) . "." ); file_line_count_isnt( $file ); test_test(); } # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # Things that should fail (wrong number) { my $name = "$file line count is $linesp lines"; test_out( "not ok 1 - $name" ); test_diag( "Expected [3] lines in [$file], got [$lines] lines!\n" . "# Failed test '$name'\n" . "# at $0 line " . line_num(+5) . "." ); file_line_count_is( $file, $linesp ); test_test(); test_out( "ok 1 - $file line count is not $linesp lines" ); file_line_count_isnt( $file, $linesp ); test_test(); $name = "$file line count is not $lines lines"; test_out( "not ok 1 - $name" ); test_diag( "Expected something other than [$lines] lines in [$file], but got [$lines] lines!\n" . "# Failed test '$name'\n" . "# at $0 line " . line_num(+5) . "." ); file_line_count_isnt( $file, $lines ); test_test(); my $linespp = $linesp + 1; $name = "$file line count is between [$linesp] and [$linespp] lines"; test_out( "not ok 1 - $name" ); test_diag( "Expected a line count between [$linesp] and [$linespp] in [$file], but got [$lines] lines!\n" . "# Failed test '$name'\n" . "# at $0 line " . line_num(+5) . "." ); file_line_count_between( $file, $linesp, $linespp ); test_test(); } # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # END { chdir '..' or print "bail out! Could not change directories: $!"; unlink glob( "test_files/*" ); rmdir "test_files"; } Test-File-1.36/t/win32.t0000644000175000001440000000111112225460631013652 0ustar buddyusersuse strict; use warnings; use Test::Builder::Tester; use Test::More tests => 8; use_ok( 'Test::File' ); ok( defined &{ "Test::File::_win32" }, "_win32 defined" ); { local $^O = 'darwin'; ok( ! Test::File::_win32(), "Returns false for darwin" ); } { local $^O = 'Win32'; ok( Test::File::_win32(), "Returns true for Win32" ); } { local $^O = 'Win32'; my @subs = qw( file_mode_is file_mode_isnt file_executable_ok file_not_executable_ok ); foreach my $sub ( @subs ) { no strict 'refs'; test_out("ok 1 # skip $sub doesn't work on Windows!"); &{$sub}(); test_test(); } } Test-File-1.36/t/setup_common0000644000175000001440000000250011702255574015170 0ustar buddyusers# $Id$ use strict; unless( -d 'test_files' ) { mkdir 'test_files', 0700 or print "bail out! Could not make directory! $!"; } chdir 'test_files' or print "bail out! Could not change directory! $!"; my @files = qw( max_file non_zero_file not_readable readable zero_file executable min_file not_executable not_writeable writeable ); foreach my $file ( @files ) { open FH, "> $file"; close FH; } { my $count = chmod 0644, @files; is( $count, scalar @files ) or print 'bail out! Could not make files readable'; } { my $count = chmod 0400, 'readable', 'not_writeable', 'not_executable'; is( $count, 3 ) or print 'bail out! Could not make files readable'; } { my $count = chmod 0200, 'writeable', 'not_readable', 'zero_file', 'max_file', 'non_zero_file'; is( $count, 5 ) or print 'bail out! Could not make files writeable'; } { my $count = chmod 0100, 'executable'; is( $count, 1 ) or print 'bail out! Could not make files executable'; } truncate 'zero_file', 0; truncate 'max_file', 10; truncate 'min_file', 0; { open FH, '> min_file' or print "bail out! Could not write to min_file: $!"; binmode FH; #, Windows, yo! print FH 'x' x 40, $/, 'x' x 11, $/; close FH; } is( -s 'min_file', 51 + 2 * length( $/ ) ); chdir '..' or print "bail out! Could not change back to original directory: $!"; pass(); Test-File-1.36/t/pod_coverage.t0000644000175000001440000000030212225460631015346 0ustar buddyusersuse Test::More; eval "use Test::Pod::Coverage"; if( $@ ) { plan skip_all => "Test::Pod::Coverage required for testing POD"; } else { plan tests => 1; pod_coverage_ok( "Test::File" ); } Test-File-1.36/t/owner.t0000644000175000001440000001377512225460631014065 0ustar buddyusersuse strict; use Test::Builder::Tester; use Test::More; use Test::File; # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #let's test with the first file we find in the current dir my( $filename, $file_gid, $owner_uid, $owner_name, $file_group_name ); eval { $filename = glob( "*" ); #print STDERR "Filename is $filename\n"; die "Could not find a file" unless defined $filename; $owner_uid = ( stat $filename )[4]; die "failed to find $filename's owner\n" unless defined $owner_uid; $file_gid = ( stat $filename )[5]; die "failed to find $filename's owner\n" unless defined $file_gid; $owner_name = ( getpwuid $owner_uid )[0]; die "failed to find $filename's owner as name\n" unless defined $owner_name; $file_group_name = ( getgrgid $file_gid )[0]; die "failed to find $filename's group as name\n" unless defined $file_group_name; }; plan skip_all => "I can't find a file to test with: $@" if $@; # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # find some name that isn't the one we found before my( $other_name, $other_uid, $other_group_name, $other_gid ); eval { for( my $i = 0; $i < 65535; $i++ ) { next if $i == $owner_uid; my @stats = getpwuid $i; next unless @stats; ( $other_uid, $other_name ) = ( $i, $stats[0] ); last; } # XXX: why the for loop? for( my $i = 0; $i < 65535; $i++ ) { next if $i == $file_gid; my @stats = getgrgid $i; next unless @stats; ( $other_gid, $other_group_name ) = ( $i, $stats[0] ); last; } die "Failed to find another uid" unless defined $other_uid; die "Failed to find name for other uid ($other_uid)" unless defined $other_name; die "Failed to find another gid" unless defined $other_gid; die "Failed to find name for other gid ($other_gid)" unless defined $other_group_name; }; plan skip_all => "I can't find a second user id to test with: $@" if $@; # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # find some names that don't exist, to test bad input my( $invalid_user_name, $invalid_group_name ); eval { foreach my $user ( 'aaaa' .. 'zzzz' ) { my @stats = getpwnam $user; next if @stats; $invalid_user_name = $user; #diag "Using invalid user [$user] for tests"; last; } foreach my $group ( 'aaaa' .. 'zzzz' ) { my @stats = getpwnam $group; next if @stats; $invalid_group_name = $group; #diag "Using invalid group [$group] for tests"; last; } diag "Failed to find an invalid username" unless defined $other_uid; diag "Failed to find another gid" unless defined $other_gid; }; # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # plan tests => 15; # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # test owner stuff owner_is( $filename, $owner_name, 'owner_is with text username' ); owner_is( $filename, $owner_uid, 'owner_is with numeric UID' ); owner_isnt( $filename, $other_name, 'owner_isnt with text username' ); owner_isnt( $filename, $other_uid, 'owner_isnt with numeric UID' ); my $name = 'Intentional owner_is failure with wrong user'; my $testname = "$filename belongs to $other_name"; test_out( "not ok 1 - $testname"); test_diag( "File [$filename] belongs to $owner_name ($owner_uid), not $other_name " . "($other_uid)!\n" . "# Failed test '$testname'\n". "# at t/owner.t line " . line_num(+6) . "." ); owner_is( $filename, $other_name ); test_test( $name ); $name = "Intentional owner_is failure with invalid user [$invalid_user_name]"; $testname = "$filename belongs to $invalid_user_name"; test_out( "not ok 1 - $testname"); test_diag( "User [$invalid_user_name] does not exist on this system!\n" . "# Failed test '$testname'\n". "# at t/owner.t line " . line_num(+5) . "." ); owner_is( $filename, $invalid_user_name ); test_test( $name ); $name = 'owner_isnt for non-existent name'; $testname = "$filename doesn't belong to $invalid_user_name"; test_out( "ok 1 - $testname"); owner_isnt( $filename, $invalid_user_name ); test_test( $name ); $name = 'Intentional owner_isnt failure'; $testname = "$filename doesn't belong to $owner_name"; test_out( "not ok 1 - $testname"); test_diag( "File [$filename] belongs to $owner_name ($owner_uid)!\n" . "# Failed test '$testname'\n" . "# at t/owner.t line " . line_num(+5) . "." ); owner_isnt( $filename, $owner_name ); test_test( $name ); # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # test group stuff group_is( $filename, $file_group_name, 'group_is with text groupname' ); group_is( $filename, $file_gid, 'group_is with numeric GID' ); group_isnt( $filename, $other_group_name, 'group_isnt with text groupname' ); group_isnt( $filename, $other_gid, 'group_isnt with numeric GID' ); $name = 'Intentional group_is failure'; test_out( "not ok 1 - $name"); test_diag( "File [$filename] belongs to $file_group_name ($file_gid), not ". "$other_group_name " . "($other_gid)!\n" . "# Failed test '$name'\n". "# at t/owner.t line " . line_num(+7) . "." ); group_is( $filename, $other_group_name, $name ); test_test( $name ); $name = "Intentional group_is failure with invalid group [$invalid_group_name]"; test_out( "not ok 1 - $name"); test_diag( "Group [$invalid_group_name] does not exist on this system!\n" . "# Failed test '$name'\n". "# at t/owner.t line " . line_num(+5) . "." ); group_is( $filename, $invalid_group_name, $name ); test_test( $name ); $name = 'Intentional group_isnt failure'; test_out( "not ok 1 - $name"); test_diag( "File [$filename] belongs to $file_group_name ($file_gid)!\n" . "# Failed test '$name'\n" . "# at t/owner.t line " . line_num(+5) . "." ); group_isnt( $filename, $file_group_name, $name ); test_test( $name ); # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # END { unlink glob( "test_files/*" ); rmdir "test_files"; } Test-File-1.36/t/pod.t0000644000175000001440000000020111702255574013500 0ustar buddyusersuse Test::More; eval "use Test::Pod 1.00"; plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; all_pod_files_ok(); Test-File-1.36/t/rt/0000755000175000001440000000000012261132575013161 5ustar buddyusersTest-File-1.36/t/rt/30346.t0000644000175000001440000000201511702255574014027 0ustar buddyusersuse strict; use Test::Builder::Tester; use Test::More tests => 3; use Test::File; use Cwd; # File does not exist { my $file = "no_such_file-" . "$$" . time() . "b$<$>m"; unlink $file; my $name = "$file is not empty"; test_out( "not ok 1 - $name"); test_diag( "File [$file] does not exist!\n" . "# Failed test '$name'\n". "# at $0 line " . line_num(+5) . "." ); file_not_empty_ok( $file ); test_test( $name ); } # File exists, non zero size { my $file = $0; # hey, that's me! my $name = "$file is not empty"; test_out( "ok 1 - $name"); file_not_empty_ok( $file ); test_test( $name ); } # File exists, zero size { require File::Spec; my $file = File::Spec->catfile( qw(t rt file_not_empty_ok_test) ); open my $fh, ">", $file; truncate $fh, 0; close $fh; my $name = "$file is not empty"; test_out( "not ok 1 - $name"); test_diag( "File [$file] exists with zero size!\n" . "# Failed test '$name'\n". "# at $0 line " . line_num(+5) . "." ); file_not_empty_ok( $file ); test_test( $name ); unlink $file; }