File Coverage

blib/lib/Test/File.pm
Criterion Covered Total %
statement 529 638 82.9
branch 216 290 74.4
condition 101 191 52.8
subroutine 68 74 91.8
pod 47 47 100.0
total 961 1240 77.5


line stmt bran cond sub pod time code
1             package Test::File;
2 17     17   825528 use strict;
  17         94  
  17         597  
3              
4 17     17   95 use vars qw(@EXPORT $VERSION);
  17         31  
  17         1061  
5              
6 17     17   102 use Carp qw(carp);
  17         28  
  17         769  
7 17     17   102 use Exporter qw(import);
  17         28  
  17         487  
8 17     17   88 use File::Spec;
  17         42  
  17         524  
9 17     17   86 use Test::Builder;
  17         39  
  17         409  
10 17     17   86 use XSLoader;
  17         54  
  17         10028  
11              
12             @EXPORT = qw(
13             file_exists_ok file_not_exists_ok
14             file_empty_ok file_not_empty_ok file_size_ok file_max_size_ok
15             file_min_size_ok file_readable_ok file_not_readable_ok
16             file_writeable_ok file_writable_ok file_not_writeable_ok file_not_writable_ok
17             file_executable_ok file_not_executable_ok
18             file_mode_is file_mode_isnt
19             file_mode_has file_mode_hasnt
20             file_is_symlink_ok file_is_not_symlink_ok
21             symlink_target_exists_ok symlink_target_is
22             symlink_target_dangles_ok
23             dir_exists_ok dir_contains_ok
24             link_count_is_ok link_count_gt_ok link_count_lt_ok
25             owner_is owner_isnt
26             group_is group_isnt
27             file_line_count_is file_line_count_isnt file_line_count_between
28             file_contains_like file_contains_unlike
29             file_contains_utf8_like file_contains_utf8_unlike
30             file_contains_encoded_like file_contains_encoded_unlike
31             file_mtime_gt_ok file_mtime_lt_ok file_mtime_age_ok
32             );
33              
34             $VERSION = '1.993';
35             XSLoader::load(__PACKAGE__, $VERSION) if $^O eq 'MSWin32';
36              
37             my $Test = Test::Builder->new();
38              
39             =encoding utf8
40              
41             =head1 NAME
42              
43             Test::File -- test file attributes
44              
45             =head1 SYNOPSIS
46              
47             use Test::File;
48              
49             =head1 DESCRIPTION
50              
51             This modules provides a collection of test utilities for file
52             attributes.
53              
54             Some file attributes depend on the owner of the process testing the
55             file in the same way the file test operators do. For instance, root
56             (or super-user or Administrator) may always be able to read files no
57             matter the permissions.
58              
59             Some attributes don't make sense outside of Unix, either, so some
60             tests automatically skip if they think they won't work on the
61             platform. If you have a way to make these functions work on Windows,
62             for instance, please send me a patch. :) If you want to pretend to be
63             Windows on a non-Windows machine (for instance, to test C),
64             you can set the C environment variable.
65              
66             The optional NAME parameter for every function allows you to specify a
67             name for the test. If not supplied, a reasonable default will be
68             generated.
69              
70             =head2 Functions
71              
72             =over 4
73              
74             =cut
75              
76             sub _is_plain_file {
77 74     74   126 my $filename = _normalize( shift );
78              
79 74         116 my $message = do {
80 74 100       1203 if( ! -e $filename ) { "does not exist" }
  15 50       51  
    50          
81 0         0 elsif( ! -f _ ) { "is not a plain file" }
82 0         0 elsif( -d _ ) { "is a directory" }
83 59         175 else { () }
84             };
85              
86 74 100       193 if( $message ) {
87 15         81 $Test->diag( "file [$filename] $message");
88 15         4715 return 0;
89             }
90              
91 59         200 return 1;
92             }
93              
94             sub _normalize {
95 241     241   30720 my $file = shift;
96 241 100       561 return unless defined $file;
97              
98 237 100       743 return $file =~ m|/|
99             ? File::Spec->catfile( split m|/|, $file )
100             : $file;
101             }
102              
103             sub _win32 {
104 40 100   40   57060 return 0 if $^O eq 'darwin';
105 39 100       98 return $ENV{PRETEND_TO_BE_WIN32} if defined $ENV{PRETEND_TO_BE_WIN32};
106 38   66     229 return $^O =~ m/Win/ || $^O eq 'msys';
107             }
108              
109             # returns true if symlinks can't exist
110 0         0 BEGIN {
111 17     17   19271 my $cannot_symlink;
112              
113             sub _no_symlinks_here {
114 19 100   19   73 return $cannot_symlink if defined $cannot_symlink;
115              
116 1         2 $cannot_symlink = ! do {
117 1         2 eval {
118 1         13 symlink("",""); # symlink exist in perl
119 1         9 _IsSymlinkCreationAllowed() # symlink is ok in current session
120             }
121             };
122             }
123              
124             sub _IsSymlinkCreationAllowed {
125 1 50   1   5 if ($^O eq 'MSWin32') {
126             #
127             # Bare copy of Perl's Win32::IsSymlinkCreationAllowed but with Test::File::Win32 namespace instead of Win32
128             #
129 0         0 my(undef, $major, $minor, $build) = Test::File::Win32::GetOSVersion();
130              
131             # Vista was the first Windows version with symlink support
132 0 0       0 return !!0 if $major < 6;
133              
134             # Since Windows 10 1703, enabling the developer mode allows to create
135             # symlinks regardless of process privileges
136 0 0 0     0 if ($major > 10 || ($major == 10 && ($minor > 0 || $build > 15063))) {
      0        
      0        
137 0 0       0 return !!1 if Test::File::Win32::IsDeveloperModeEnabled();
138             }
139              
140 0         0 my $privs = Test::File::Win32::GetProcessPrivileges();
141              
142 0 0       0 return !!0 unless $privs;
143              
144             # It doesn't matter if the permission is enabled or not, it just has to
145             # exist. CreateSymbolicLink() will automatically enable it when needed.
146 0         0 return exists $privs->{SeCreateSymbolicLinkPrivilege};
147             }
148              
149 1         6 1;
150             }
151              
152             =item has_symlinks
153              
154             Returns true is this module thinks that the current system supports
155             symlinks.
156              
157             This is not a test function. It's something that tests can use to
158             determine what it should expect or skip.
159              
160             =cut
161              
162 1     1 1 91 sub has_symlinks { ! _no_symlinks_here() }
163             }
164              
165             # owner_is and owner_isn't should skip on OS where the question makes no
166             # sense. I really don't know a good way to test for that, so I'm going
167             # to skip on the two OS's that I KNOW aren't multi-user. I'd love to add
168             # more if anyone knows of any
169             # Note: I don't have a dos or mac os < 10 machine to test this on
170             sub _obviously_non_multi_user {
171 31 100   31   50554 foreach my $os ( qw(dos MacOS) ) { return 1 if $^O eq $os }
  57         189  
172              
173 25 100       121 return 0 if $^O eq 'MSWin32';
174              
175 20         35 eval { my $holder = getpwuid(0) };
  20         969  
176 20 100       103 return 1 if $@;
177              
178 19         30 eval { my $holder = getgrgid(0) };
  19         697  
179 19 100       82 return 1 if $@;
180              
181 18         47 return 0;
182             }
183              
184             =item file_exists_ok( FILENAME [, NAME ] )
185              
186             Ok if the file exists, and not ok otherwise.
187              
188             =cut
189              
190             sub file_exists_ok {
191 11     11 1 78334 my $filename = _normalize( shift );
192 11   66     131 my $name = shift || "$filename exists";
193              
194 11         179 my $ok = -e $filename;
195              
196 11 100       43 if( $ok ) {
197 10         49 $Test->ok(1, $name);
198             }
199             else {
200 1         10 $Test->diag("file [$filename] does not exist");
201 1         329 $Test->ok(0, $name);
202             }
203             }
204              
205             =item file_not_exists_ok( FILENAME [, NAME ] )
206              
207             Ok if the file does not exist, and not okay if it does exist.
208              
209             =cut
210              
211             sub file_not_exists_ok {
212 5     5 1 16144 my $filename = _normalize( shift );
213 5   66     31 my $name = shift || "$filename does not exist";
214              
215 5         95 my $ok = not -e $filename;
216              
217 5 100       22 if( $ok ) {
218 4         30 $Test->ok(1, $name);
219             }
220             else {
221 1         8 $Test->diag("file [$filename] exists");
222 1         312 $Test->ok(0, $name);
223             }
224             }
225              
226             =item file_empty_ok( FILENAME [, NAME ] )
227              
228             Ok if the file exists and has empty size, not ok if the file does not
229             exist or exists with non-zero size.
230              
231             Previously this tried to test any sort of file. Sometime in the future
232             this will fail if the argument is not a plain file or is a directory.
233              
234             =cut
235              
236             sub file_empty_ok {
237 4     4 1 34353 my $filename = _normalize( shift );
238 4   66     17 my $name = shift || "$filename is empty";
239              
240 4 100       9 return $Test->ok( 0, $name ) unless _is_plain_file( $filename );
241              
242 3         27 my $ok = -z $filename;
243              
244 3 100       10 if( $ok ) {
245 2         9 $Test->ok(1, $name);
246             }
247             else {
248 1         14 $Test->diag( "file [$filename] exists with non-zero size" );
249 1         302 $Test->ok(0, $name);
250             }
251             }
252              
253             =item file_not_empty_ok( FILENAME [, NAME ] )
254              
255             Ok if the file exists and has non-zero size, not ok if the file does
256             not exist or exists with zero size.
257              
258             Previously this tried to test any sort of file. Sometime in the future
259             this will fail if the argument is not a plain file or is a directory.
260              
261             =cut
262              
263             sub file_not_empty_ok {
264 7     7 1 50716 my $filename = _normalize( shift );
265 7   66     35 my $name = shift || "$filename is not empty";
266              
267 7 100       17 return $Test->ok( 0, $name ) unless _is_plain_file( $filename );
268              
269 5         13 my $ok = not -z _;
270              
271 5 100       15 if( $ok ) {
272 3         15 $Test->ok(1, $name);
273             }
274             else {
275 2         17 $Test->diag( "file [$filename] exists with zero size" );
276 2         634 $Test->ok(0, $name);
277             }
278             }
279              
280             =item file_size_ok( FILENAME, SIZE [, NAME ] )
281              
282             Ok if the file exists and has SIZE size in bytes (exactly), not ok if
283             the file does not exist or exists with size other than SIZE.
284              
285             Previously this tried to test any sort of file. Sometime in the future
286             this will fail if the argument is not a plain file or is a directory.
287              
288             =cut
289              
290             sub file_size_ok {
291 4     4 1 12377 my $filename = _normalize( shift );
292 4         10 my $expected = int shift;
293 4   66     15 my $name = shift || "$filename has right size";
294              
295 4 100       9 return $Test->ok( 0, $name ) unless _is_plain_file( $filename );
296              
297 3         29 my $ok = ( -s $filename ) == $expected;
298              
299 3 100       10 if( $ok ) {
300 2         10 $Test->ok(1, $name);
301             }
302             else {
303 1         10 my $actual = -s $filename;
304 1         10 $Test->diag(
305             "file [$filename] has actual size [$actual] not [$expected]" );
306              
307 1         344 $Test->ok(0, $name);
308             }
309             }
310              
311             =item file_max_size_ok( FILENAME, MAX [, NAME ] )
312              
313             Ok if the file exists and has size less than or equal to MAX bytes, not
314             ok if the file does not exist or exists with size greater than MAX
315             bytes.
316              
317             Previously this tried to test any sort of file. Sometime in the future
318             this will fail if the argument is not a plain file or is a directory.
319              
320             =cut
321              
322             sub file_max_size_ok {
323 4     4 1 10641 my $filename = _normalize( shift );
324 4         8 my $max = int shift;
325 4   66     30 my $name = shift || "$filename is under $max bytes";
326              
327 4 100       10 return $Test->ok( 0, $name ) unless _is_plain_file( $filename );
328              
329 3         29 my $ok = ( -s $filename ) <= $max;
330              
331 3 100       9 if( $ok ) {
332 2         9 $Test->ok(1, $name);
333             }
334             else {
335 1         10 my $actual = -s $filename;
336 1         9 $Test->diag(
337             "file [$filename] has actual size [$actual] " .
338             "greater than [$max]"
339             );
340              
341 1         303 $Test->ok(0, $name);
342             }
343             }
344              
345             =item file_min_size_ok( FILENAME, MIN [, NAME ] )
346              
347             Ok if the file exists and has size greater than or equal to MIN bytes,
348             not ok if the file does not exist or exists with size less than MIN
349             bytes.
350              
351             Previously this tried to test any sort of file. Sometime in the future
352             this will fail if the argument is not a plain file or is a directory.
353              
354             =cut
355              
356             sub file_min_size_ok {
357 4     4 1 10737 my $filename = _normalize( shift );
358 4         13 my $min = int shift;
359 4   66     18 my $name = shift || "$filename is over $min bytes";
360              
361 4 100       8 return $Test->ok( 0, $name ) unless _is_plain_file( $filename );
362              
363 3         31 my $ok = ( -s $filename ) >= $min;
364              
365 3 100       15 if( $ok ) {
366 2         10 $Test->ok(1, $name);
367             }
368             else {
369 1         15 my $actual = -s $filename;
370 1         11 $Test->diag(
371             "file [$filename] has actual size ".
372             "[$actual] less than [$min]"
373             );
374              
375 1         316 $Test->ok(0, $name);
376             }
377             }
378              
379             =item file_line_count_is( FILENAME, COUNT [, NAME ] )
380              
381             Ok if the file exists and has COUNT lines (exactly), not ok if the
382             file does not exist or exists with a line count other than COUNT.
383              
384             This function uses the current value of C<$/> as the line ending and
385             counts the lines by reading them and counting how many it read.
386              
387             Previously this tried to test any sort of file. Sometime in the future
388             this will fail if the argument is not a plain file or is a directory.
389              
390             =cut
391              
392             sub _ENOFILE () { -1 }
393             sub _ECANTOPEN () { -2 }
394             sub _ENOTPLAIN () { -3 }
395              
396             sub _file_line_counter {
397 9     9   13 my $filename = shift;
398              
399 9 50       118 return _ENOFILE unless -e $filename;
400 9 50       85 return _ENOTPLAIN unless -f $filename;
401 9 50       320 return _ECANTOPEN unless open my( $fh ), "<", $filename;
402              
403 9         24 my $count = 0;
404 9         198 while( <$fh> ) { $count++ }
  18         99  
405              
406 9         131 return $count;
407             }
408              
409             # XXX: lots of cut and pasting here, needs refactoring
410             # looks like the refactoring might be worse than this though
411             sub file_line_count_is {
412 4     4 1 16370 my $filename = _normalize( shift );
413 4         8 my $expected = shift;
414 4         7 my $name = do {
415 17     17   133 no warnings 'uninitialized';
  17         48  
  17         1832  
416 4 50       39 shift || "$filename line count is $expected lines";
417             };
418              
419 4 100       11 return $Test->ok( 0, $name ) unless _is_plain_file( $filename );
420              
421 3 100 66     18 unless( defined $expected && int( $expected ) == $expected ) {
422 17     17   126 no warnings 'uninitialized';
  17         44  
  17         4612  
423 1         9 $Test->diag( "file_line_count_is expects a positive whole number for " .
424             "the second argument. Got [$expected]" );
425 1         316 return $Test->ok( 0, $name );
426             }
427              
428 2         8 my $got = _file_line_counter( $filename );
429              
430 2 50       16 if( $got eq _ENOFILE ) {
    50          
    50          
    100          
431 0         0 $Test->diag( "file [$filename] does not exist" );
432 0         0 $Test->ok( 0, $name );
433             }
434             elsif( $got eq _ENOTPLAIN ) {
435 0         0 $Test->diag( "file [$filename] is not a plain file" );
436 0         0 $Test->ok( 0, $name );
437             }
438             elsif( $got == _ECANTOPEN ) {
439 0         0 $Test->diag( "file [$filename] could not be opened: \$! is [$!]" );
440 0         0 $Test->ok( 0, $name );
441             }
442             elsif( $got == $expected ) {
443 1         7 $Test->ok( 1, $name );
444             }
445             else {
446 1         11 $Test->diag( "expected [$expected] lines in [$filename], " .
447             "got [$got] lines" );
448 1         323 $Test->ok( 0, $name );
449             }
450              
451             }
452              
453             =item file_line_count_isnt( FILENAME, COUNT [, NAME ] )
454              
455             Ok if the file exists and doesn't have exactly COUNT lines, not ok if
456             the file does not exist or exists with a line count of COUNT. Read
457             that carefully: the file must exist for this test to pass!
458              
459             This function uses the current value of C<$/> as the line ending and
460             counts the lines by reading them and counting how many it read.
461              
462             Previously this tried to test any sort of file. Sometime in the future
463             this will fail if the argument is not a plain file or is a directory.
464              
465             =cut
466              
467             sub file_line_count_isnt {
468 5     5 1 16649 my $filename = _normalize( shift );
469 5         12 my $expected = shift;
470 5         9 my $name = do {
471 17     17   125 no warnings 'uninitialized';
  17         51  
  17         1684  
472 5 50       36 shift || "$filename line count is not $expected lines";
473             };
474              
475 5 100       14 return $Test->ok( 0, $name ) unless _is_plain_file( $filename );
476              
477 4 100 66     21 unless( defined $expected && int( $expected ) == $expected ) {
478 17     17   164 no warnings 'uninitialized';
  17         41  
  17         4743  
479 1         9 $Test->diag( "file_line_count_is expects a positive whole number for " .
480             "the second argument. Got [$expected]" );
481 1         305 return $Test->ok( 0, $name );
482             }
483              
484 3         9 my $got = _file_line_counter( $filename );
485              
486 3 50       29 if( $got eq _ENOFILE ) {
    50          
    50          
    100          
487 0         0 $Test->diag( "file [$filename] does not exist" );
488 0         0 $Test->ok( 0, $name );
489             }
490             elsif( $got eq _ENOTPLAIN ) {
491 0         0 $Test->diag( "file [$filename] is not a plain file" );
492 0         0 $Test->ok( 0, $name );
493             }
494             elsif( $got == _ECANTOPEN ) {
495 0         0 $Test->diag( "file [$filename] could not be opened: \$! is [$!]" );
496 0         0 $Test->ok( 0, $name );
497             }
498             elsif( $got != $expected ) {
499 2         9 $Test->ok( 1, $name );
500             }
501             else {
502 1         11 $Test->diag( "expected something other than [$expected] lines in [$filename], " .
503             "but got [$got] lines" );
504 1         364 $Test->ok( 0, $name );
505             }
506              
507             }
508              
509             =item file_line_count_between( FILENAME, MIN, MAX, [, NAME ] )
510              
511             Ok if the file exists and has a line count between MIN and MAX,
512             inclusively.
513              
514             This function uses the current value of C<$/> as the line ending and
515             counts the lines by reading them and counting how many it read.
516              
517             Previously this tried to test any sort of file. Sometime in the future
518             this will fail if the argument is not a plain file or is a directory.
519              
520             =cut
521              
522             sub file_line_count_between {
523 8     8 1 23977 my $filename = _normalize( shift );
524 8         18 my $min = shift;
525 8         22 my $max = shift;
526              
527 8         13 my $name = do {
528 17     17   124 no warnings 'uninitialized';
  17         56  
  17         1907  
529 8 50       45 shift || "$filename line count is between [$min] and [$max] lines";
530             };
531 8 100       18 return $Test->ok( 0, $name ) unless _is_plain_file( $filename );
532              
533 5         15 foreach my $ref ( \$min, \$max ) {
534 9 100 66     36 unless( defined $$ref && int( $$ref ) == $$ref ) {
535 17     17   222 no warnings 'uninitialized';
  17         41  
  17         61992  
536 1         11 $Test->diag( "file_line_count_between expects positive whole numbers for " .
537             "the second and third arguments. Got [$min] and [$max]" );
538 1         308 return $Test->ok( 0, $name );
539             }
540             }
541              
542 4         15 my $got = _file_line_counter( $filename );
543              
544 4 50 66     41 if( $got eq _ENOFILE ) {
    50          
    50          
    100          
545 0         0 $Test->diag( "file [$filename] does not exist" );
546 0         0 $Test->ok( 0, $name );
547             }
548             elsif( $got eq _ENOTPLAIN ) {
549 0         0 $Test->diag( "file [$filename] is not a plain file" );
550 0         0 $Test->ok( 0, $name );
551             }
552             elsif( $got == _ECANTOPEN ) {
553 0         0 $Test->diag( "file [$filename] could not be opened: \$! is [$!]" );
554 0         0 $Test->ok( 0, $name );
555             }
556             elsif( $min <= $got and $got <= $max ) {
557 3         14 $Test->ok( 1, $name );
558             }
559             else {
560 1         11 $Test->diag( "expected a line count between [$min] and [$max] " .
561             "in [$filename], but got [$got] lines"
562             );
563 1         360 $Test->ok( 0, $name );
564             }
565             }
566              
567             =item file_contains_like ( FILENAME, PATTERN [, NAME ] )
568              
569             Ok if the file exists and its contents (as one big string) match
570             PATTERN, not ok if the file does not exist, is not readable, or exists
571             but doesn't match PATTERN.
572              
573             Since the file contents are read into memory, you should not use this
574             for large files. Besides memory consumption, test diagnostics for
575             failing tests might be difficult to decipher. However, for short
576             files this works very well.
577              
578             Because the entire contents are treated as one large string, you can
579             make a pattern that tests multiple lines. Don't forget that you may
580             need to use the /s modifier for such patterns:
581              
582             # make sure file has one or more paragraphs with CSS class X
583             file_contains_like($html_file, qr{

.*?

}s);
584              
585             Contrariwise, if you need to match at the beginning or end of a line
586             inside the file, use the /m modifier:
587              
588             # make sure file has a setting for foo
589             file_contains_like($config_file, qr/^ foo \s* = \s* \w+ $/mx);
590              
591             If you want to test your file contents against multiple patterns, but
592             don't want to have the file read in repeatedly, you can pass an
593             arrayref of patterns instead of a single pattern, like so:
594              
595             # make sure our template has rendered correctly
596             file_contains_like($template_out,
597             [
598             qr/^ $title_line $/mx,
599             map { qr/^ $_ $/mx } @chapter_headings,
600             qr/^ $footer_line $/mx,
601             ]);
602              
603             Please note that if you do this, and your file does not exist or is
604             not readable, you'll only get one test failure instead of a failure
605             for each pattern. This could cause your test plan to be off, although
606             you may not care at that point because your test failed anyway. If
607             you do care, either skip the test plan altogether by employing
608             L's C function, or use
609             L in conjunction with a C block.
610              
611             Contributed by Buddy Burden C<< >>.
612              
613             =item file_contains_unlike ( FILENAME, PATTERN [, NAME ] )
614              
615             Ok if the file exists and its contents (as one big string) do B
616             match PATTERN, not ok if the file does not exist, is not readable, or
617             exists but matches PATTERN.
618              
619             All notes and caveats for L apply to this
620             function as well.
621              
622             Contributed by Buddy Burden C<< >>.
623              
624             =item file_contains_utf8_like ( FILENAME, PATTERN [, NAME ] )
625              
626             The same as C, except the file is opened as UTF-8.
627              
628             =item file_contains_utf8_unlike ( FILENAME, PATTERN [, NAME ] )
629              
630             The same as C, except the file is opened as UTF-8.
631              
632             =item file_contains_encoded_like ( FILENAME, ENCODING, PATTERN [, NAME ] )
633              
634             The same as C, except the file is opened with ENCODING
635              
636             =item file_contains_encoded_unlike ( FILENAME, ENCODING, PATTERN [, NAME ] )
637              
638             The same as C, except the file is opened with ENCODING.
639              
640             =cut
641              
642             sub file_contains_like {
643 7     7 1 48083 local $Test::Builder::Level = $Test::Builder::Level + 1;
644 7         23 _file_contains(like => "contains", undef, @_);
645             }
646              
647             sub file_contains_unlike {
648 7     7 1 24313 local $Test::Builder::Level = $Test::Builder::Level + 1;
649 7         21 _file_contains(unlike => "doesn't contain", undef, @_);
650             }
651              
652             sub file_contains_utf8_like {
653 5     5 1 50420 local $Test::Builder::Level = $Test::Builder::Level + 1;
654 5         14 _file_contains(like => "contains", 'UTF-8', @_);
655             }
656              
657             sub file_contains_utf8_unlike {
658 5     5 1 16637 local $Test::Builder::Level = $Test::Builder::Level + 1;
659 5         13 _file_contains(unlike => "doesn't contain", 'UTF-8', @_);
660             }
661              
662             sub file_contains_encoded_like {
663 5     5 1 64440 local $Test::Builder::Level = $Test::Builder::Level + 1;
664 5         12 my $filename = shift;
665 5         8 my $encoding = shift;
666 5         17 _file_contains(like => "contains", $encoding, $filename, @_);
667             }
668              
669             sub file_contains_encoded_unlike {
670 5     5 1 16534 local $Test::Builder::Level = $Test::Builder::Level + 1;
671 5         8 my $filename = shift;
672 5         8 my $encoding = shift;
673 5         13 _file_contains(unlike => "doesn't contain", $encoding, $filename, @_);
674             }
675              
676             sub _file_contains {
677 34     34   54 my $method = shift;
678 34         55 my $verb = shift;
679 34         49 my $encoding = shift;
680 34         73 my $filename = _normalize( shift );
681 34         65 my $patterns = shift;
682 34         48 my $name = shift;
683              
684 34         57 my (@patterns, %patterns);
685 34 100       95 if (ref $patterns eq 'ARRAY') {
686 20         42 @patterns = @$patterns;
687 20   66     44 %patterns = map { $_ => $name || "$filename $verb $_" } @patterns;
  40         215  
688             }
689             else {
690 14         25 @patterns = ($patterns);
691 14   33     94 %patterns = ( $patterns => $name || "$filename $verb $patterns" );
692             }
693              
694             # for purpose of checking the file's existence, just use the first
695             # test name as the name
696 34         83 $name = $patterns{$patterns[0]};
697              
698 34 100       77 return $Test->ok( 0, $name ) unless _is_plain_file( $filename );
699              
700 30 50       363 unless( -r $filename ) {
701 0         0 $Test->diag( "file [$filename] is not readable" );
702 0         0 return $Test->ok(0, $name);
703             }
704              
705             # do the slurp
706 30         69 my $file_contents;
707             {
708 30 50       41 unless (open(FH, $filename)) {
  30         920  
709 0         0 $Test->diag( "file [$filename] could not be opened: \$! is [$!]" );
710 0         0 return $Test->ok( 0, $name );
711             }
712              
713 30 100       115 if (defined $encoding) {
714 20         252 binmode FH, ":encoding($encoding)";
715             }
716              
717 30         897 local $/ = undef;
718 30         931 $file_contents = ;
719 30         568 close FH;
720             }
721              
722 30         102 foreach my $p (@patterns) {
723 48         9734 $Test->$method($file_contents, $p, $patterns{$p});
724             }
725             }
726              
727             =item file_readable_ok( FILENAME [, NAME ] )
728              
729             Ok if the file exists and is readable, not ok if the file does not
730             exist or is not readable.
731              
732             =cut
733              
734             sub file_readable_ok {
735 2     2 1 6855 my $filename = _normalize( shift );
736 2   66     9 my $name = shift || "$filename is readable";
737              
738 2         35 my $ok = -r $filename;
739              
740 2 50       7 if( $ok ) {
741 2         10 $Test->ok(1, $name);
742             }
743             else {
744 0         0 $Test->diag( "file [$filename] is not readable" );
745 0         0 $Test->ok(0, $name);
746             }
747             }
748              
749             =item file_not_readable_ok( FILENAME [, NAME ] )
750              
751             Ok if the file exists and is not readable, not ok if the file does not
752             exist or is readable.
753              
754             =cut
755              
756             sub file_not_readable_ok {
757 0     0 1 0 my $filename = _normalize( shift );
758 0   0     0 my $name = shift || "$filename is not readable";
759              
760 0         0 my $ok = not -r $filename;
761              
762 0 0       0 if( $ok ) {
763 0         0 $Test->ok(1, $name);
764             }
765             else {
766 0         0 $Test->diag( "file [$filename] is readable" );
767 0         0 $Test->ok(0, $name);
768             }
769             }
770              
771             =item file_writable_ok( FILENAME [, NAME ] )
772              
773             =item file_writeable_ok( FILENAME [, NAME ] )
774              
775             Ok if the file exists and is writable, not ok if the file does not
776             exist or is not writable.
777              
778             The original name is C with that extra I. That
779             still works but there's a function with the correct spelling too.
780              
781             =cut
782              
783             sub file_writeable_ok {
784 0     0 1 0 carp "file_writeable_ok is now file_writable_ok";
785              
786 0         0 &file_writable_ok;
787             }
788              
789             sub file_writable_ok {
790 3     3 1 12997 my $filename = _normalize( shift );
791 3   66     14 my $name = shift || "$filename is writable";
792              
793 3         62 my $ok = -w $filename;
794              
795 3 50       14 if( $ok ) {
796 3         18 $Test->ok(1, $name);
797             }
798             else {
799 0         0 $Test->diag( "file [$filename] is not writable" );
800 0         0 $Test->ok(0, $name);
801             }
802             }
803              
804             =item file_not_writeable_ok( FILENAME [, NAME ] )
805              
806             =item file_not_writable_ok( FILENAME [, NAME ] )
807              
808             Ok if the file exists and is not writable, not ok if the file does not
809             exist or is writable.
810              
811             The original name is C with that extra I.
812             That still works but there's a function with the correct spelling too.
813              
814             =cut
815              
816             sub file_not_writeable_ok {
817 0     0 1 0 carp "file_not_writeable_ok is now file_not_writable_ok";
818              
819 0         0 &file_not_writable_ok;
820             }
821              
822             sub file_not_writable_ok {
823 0     0 1 0 my $filename = _normalize( shift );
824 0   0     0 my $name = shift || "$filename is not writable";
825              
826 0         0 my $ok = not -w $filename;
827              
828 0 0       0 if( $ok ) {
829 0         0 $Test->ok(1, $name);
830             }
831             else {
832 0         0 $Test->diag("file [$filename] is writable");
833 0         0 $Test->ok(0, $name);
834             }
835             }
836              
837             =item file_executable_ok( FILENAME [, NAME ] )
838              
839             Ok if the file exists and is executable, not ok if the file does not
840             exist or is not executable.
841              
842             This test automatically skips if it thinks it is on a Windows
843             platform.
844              
845             =cut
846              
847             sub file_executable_ok {
848 4 100   4 1 4792 if( _win32() ) {
849 1         4 $Test->skip( "file_executable_ok doesn't work on Windows" );
850 1         407 return;
851             }
852              
853 3         9 my $filename = _normalize( shift );
854 3   66     17 my $name = shift || "$filename is executable";
855              
856 3         50 my $ok = -x $filename;
857              
858 3 100       12 if( $ok ) {
859 2         10 $Test->ok(1, $name);
860             }
861             else {
862 1         19 $Test->diag("file [$filename] is not executable");
863 1         298 $Test->ok(0, $name);
864             }
865             }
866              
867             =item file_not_executable_ok( FILENAME [, NAME ] )
868              
869             Ok if the file exists and is not executable, not ok if the file does
870             not exist or is executable.
871              
872             This test automatically skips if it thinks it is on a Windows
873             platform.
874              
875             =cut
876              
877             sub file_not_executable_ok {
878 4 100   4 1 4631 if( _win32() ) {
879 1         33 $Test->skip( "file_not_executable_ok doesn't work on Windows" );
880 1         368 return;
881             }
882              
883 3         10 my $filename = _normalize( shift );
884 3   66     15 my $name = shift || "$filename is not executable";
885              
886 3         50 my $ok = not -x $filename;
887              
888 3 100       12 if( $ok ) {
889 2         9 $Test->ok(1, $name);
890             }
891             else {
892 1         9 $Test->diag("file [$filename] is executable");
893 1         294 $Test->ok(0, $name);
894             }
895             }
896              
897             =item file_mode_is( FILENAME, MODE [, NAME ] )
898              
899             Ok if the file exists and the mode matches, not ok if the file does
900             not exist or the mode does not match.
901              
902             This test automatically skips if it thinks it is on a Windows
903             platform.
904              
905             Contributed by Shawn Sorichetti C<< >>
906              
907             =cut
908              
909             sub file_mode_is {
910 6 100   6 1 9126 if( _win32() ) {
911 1         4 $Test->skip( "file_mode_is doesn't work on Windows" );
912 1         501 return;
913             }
914              
915 5         12 my $filename = _normalize( shift );
916 5         10 my $mode = shift;
917              
918 5   66     29 my $name = shift || sprintf("%s mode is %04o", $filename, $mode);
919              
920 5   66     133 my $ok = -e $filename && ((stat($filename))[2] & 07777) == $mode;
921              
922 5 100       22 if( $ok ) {
923 4         31 $Test->ok(1, $name);
924             }
925             else {
926 1         11 $Test->diag(sprintf("file [%s] mode is not %04o", $filename, $mode) );
927 1         296 $Test->ok(0, $name);
928             }
929             }
930              
931             =item file_mode_isnt( FILENAME, MODE [, NAME ] )
932              
933             Ok if the file exists and mode does not match, not ok if the file does
934             not exist or mode does match.
935              
936             This test automatically skips if it thinks it is on a Windows
937             platform.
938              
939             Contributed by Shawn Sorichetti C<< >>
940              
941             =cut
942              
943             sub file_mode_isnt {
944 6 100   6 1 7420 if( _win32() ) {
945 1         5 $Test->skip( "file_mode_isnt doesn't work on Windows" );
946 1         358 return;
947             }
948              
949 5         13 my $filename = _normalize( shift );
950 5         9 my $mode = shift;
951              
952 5   66     28 my $name = shift || sprintf("%s mode is not %04o",$filename,$mode);
953              
954 5   66     134 my $ok = not (-e $filename && ((stat($filename))[2] & 07777) == $mode);
955              
956 5 100       19 if( $ok ) {
957 4         15 $Test->ok(1, $name);
958             }
959             else {
960 1         10 $Test->diag(sprintf("file [%s] mode is %04o",$filename,$mode));
961 1         331 $Test->ok(0, $name);
962             }
963             }
964              
965             =item file_mode_has( FILENAME, MODE [, NAME ] )
966              
967             Ok if the file exists and has all the bits in mode turned on, not ok
968             if the file does not exist or the mode does not match. That is, C<<
969             FILEMODE & MODE == MODE >> must be true.
970              
971             This test automatically skips if it thinks it is on a Windows
972             platform.
973              
974             Contributed by Ricardo Signes C<< >>
975              
976             =cut
977              
978             sub file_mode_has {
979 4 50   4 1 3397 if( _win32() ) {
980 0         0 $Test->skip( "file_mode_has doesn't work on Windows" );
981 0         0 return;
982             }
983              
984 4         13 my $filename = _normalize( shift );
985 4         8 my $mode = shift;
986              
987 4   66     22 my $name = shift || sprintf("%s mode has all bits of %04o", $filename, $mode);
988              
989 4         57 my $present = -e $filename;
990 4 50       45 my $gotmode = $present ? (stat($filename))[2] : undef;
991 4   66     28 my $ok = $present && ($gotmode & $mode) == $mode;
992              
993 4 100       9 if( $ok ) {
994 2         9 $Test->ok(1, $name);
995             }
996             else {
997 2         8 my $missing = ($gotmode ^ $mode) & $mode;
998 2         15 $Test->diag(sprintf("file [%s] mode is missing component %04o", $filename, $missing) );
999 2         591 $Test->ok(0, $name);
1000             }
1001             }
1002              
1003             =item file_mode_hasnt( FILENAME, MODE [, NAME ] )
1004              
1005             Ok if the file exists and has all the bits in mode turned off, not ok
1006             if the file does not exist or the mode does not match. That is,
1007             C<< FILEMODE & MODE == 0 >> must be true.
1008              
1009             This test automatically skips if it thinks it is on a
1010             Windows platform.
1011              
1012             Contributed by Ricardo Signes C<< >>
1013              
1014             =cut
1015              
1016             sub file_mode_hasnt {
1017 3 50   3 1 2137 if( _win32() ) {
1018 0         0 $Test->skip( "file_mode_hasnt doesn't work on Windows" );
1019 0         0 return;
1020             }
1021              
1022 3         9 my $filename = _normalize( shift );
1023 3         8 my $mode = shift;
1024              
1025 3   66     15 my $name = shift || sprintf("%s mode has no bits of %04o", $filename, $mode);
1026              
1027 3         43 my $present = -e $filename;
1028 3 50       36 my $gotmode = $present ? (stat($filename))[2] : undef;
1029 3   66     21 my $ok = $present && ($gotmode & $mode) == 0;
1030              
1031 3 100       8 if( $ok ) {
1032 2         7 $Test->ok(1, $name);
1033             }
1034             else {
1035 1         3 my $bad = $gotmode & $mode;
1036 1         9 $Test->diag(sprintf("file [%s] mode has forbidden component %04o", $filename, $bad) );
1037 1         294 $Test->ok(0, $name);
1038             }
1039             }
1040              
1041             =item file_is_symlink_ok( FILENAME [, NAME ] )
1042              
1043             Ok if FILENAME is a symlink, even if it points to a non-existent
1044             file. This test automatically skips if the operating system does
1045             not support symlinks.
1046              
1047             =cut
1048              
1049             sub file_is_symlink_ok {
1050 7 100   7 1 42683 if( _no_symlinks_here() ) {
1051 1         9 $Test->skip(
1052             "file_is_symlink_ok doesn't work on systems without symlinks" );
1053 1         506 return;
1054             }
1055              
1056 6         13 my $file = shift;
1057 6   66     22 my $name = shift || "$file is a symlink";
1058              
1059 6 100       87 if( -l $file ) {
1060 4         20 $Test->ok(1, $name)
1061             }
1062             else {
1063 2         18 $Test->diag( "file [$file] is not a symlink" );
1064 2         707 $Test->ok(0, $name);
1065             }
1066             }
1067              
1068             =item file_is_not_symlink_ok( FILENAME [, NAME ] )
1069              
1070             Ok if FILENAME is a not symlink. This test automatically skips if the
1071             operating system does not support symlinks. If the file does not
1072             exist, the test fails.
1073              
1074             =cut
1075              
1076             sub file_is_not_symlink_ok {
1077 0 0   0 1 0 if( _no_symlinks_here() ) {
1078 0         0 $Test->skip(
1079             "file_is_symlink_ok doesn't work on systems without symlinks" );
1080 0         0 return;
1081             }
1082              
1083 0         0 my $file = shift;
1084 0   0     0 my $name = shift || "$file is not a symlink";
1085              
1086 0 0       0 unless( -e $file ) {
1087 0         0 $Test->diag( "file [$file] does not exist" );
1088 0         0 return $Test->ok(0, $name);
1089             }
1090              
1091 0 0       0 if( ! -l $file ) {
1092 0         0 $Test->ok(1, $name)
1093             }
1094             else {
1095 0         0 $Test->diag( "file [$file] is a symlink" );
1096 0         0 $Test->ok(0, $name);
1097             }
1098             }
1099              
1100             =item symlink_target_exists_ok( SYMLINK [, TARGET] [, NAME ] )
1101              
1102             Ok if FILENAME is a symlink and it points to a existing file. With the
1103             optional TARGET argument, the test fails if SYMLINK's target is not
1104             TARGET. This test automatically skips if the operating system does not
1105             support symlinks. If the file does not exist, the test fails.
1106              
1107             =cut
1108              
1109             sub symlink_target_exists_ok {
1110 6 100   6 1 22929 if( _no_symlinks_here() ) {
1111 1         8 $Test->skip(
1112             "symlink_target_exists_ok doesn't work on systems without symlinks"
1113             );
1114 1         394 return;
1115             }
1116              
1117 5         13 my $file = shift;
1118 5   66     24 my $dest = shift || readlink( $file );
1119 5   66     23 my $name = shift || "$file is a symlink";
1120              
1121 5 100       89 unless( -l $file )
1122             {
1123 1         15 $Test->diag( "file [$file] is not a symlink" );
1124 1         315 return $Test->ok( 0, $name );
1125             }
1126              
1127 4 100       42 unless( -e $dest ) {
1128 1         11 $Test->diag( "symlink [$file] points to non-existent target [$dest]" );
1129 1         307 return $Test->ok( 0, $name );
1130             }
1131              
1132 3         31 my $actual = readlink( $file );
1133 3 100       12 unless( $dest eq $actual ) {
1134 1         10 $Test->diag(
1135             "symlink [$file] points to\n" .
1136             " got: $actual\n" .
1137             " expected: $dest\n"
1138             );
1139 1         392 return $Test->ok( 0, $name );
1140             }
1141              
1142 2         19 $Test->ok( 1, $name );
1143             }
1144              
1145             =item symlink_target_dangles_ok( SYMLINK [, NAME ] )
1146              
1147             Ok if FILENAME is a symlink and if it doesn't point to a existing
1148             file. This test automatically skips if the operating system does not
1149             support symlinks. If the file does not exist, the test fails.
1150              
1151             =cut
1152              
1153             sub symlink_target_dangles_ok
1154             {
1155 5 100   5 1 16563 if( _no_symlinks_here() ) {
1156 1         8 $Test->skip(
1157             "symlink_target_dangles_ok doesn't work on systems without symlinks" );
1158 1         422 return;
1159             }
1160              
1161 4         12 my $file = shift;
1162 4         52 my $dest = readlink( $file );
1163 4   66     26 my $name = shift || "$file is a symlink";
1164              
1165 4 100       44 unless( -l $file ) {
1166 1         9 $Test->diag( "file [$file] is not a symlink" );
1167 1         302 return $Test->ok( 0, $name );
1168             }
1169              
1170 3 100       32 if( -e $dest ) {
1171 2         15 $Test->diag(
1172             "symlink [$file] points to existing file [$dest] but shouldn't" );
1173 2         606 return $Test->ok( 0, $name );
1174             }
1175              
1176 1         5 $Test->ok( 1, $name );
1177             }
1178              
1179             =item symlink_target_is( SYMLINK, TARGET [, NAME ] )
1180              
1181             Ok if FILENAME is a symlink and if points to TARGET. This test
1182             automatically skips if the operating system does not support symlinks.
1183             If the file does not exist, the test fails.
1184              
1185             =cut
1186              
1187             sub symlink_target_is {
1188 4 100   4 1 10147 if( _no_symlinks_here() ) {
1189 1         10 $Test->skip(
1190             "symlink_target_is doesn't work on systems without symlinks" );
1191 1         397 return;
1192             }
1193              
1194 3         8 my $file = shift;
1195 3         6 my $dest = shift;
1196 3   66     15 my $name = shift || "symlink $file points to $dest";
1197              
1198 3 100       49 unless( -l $file ) {
1199 1         10 $Test->diag( "file [$file] is not a symlink" );
1200 1         304 return $Test->ok( 0, $name );
1201             }
1202              
1203 2         20 my $actual_dest = readlink( $file );
1204 2         12 my $link_error = $!;
1205              
1206 2 50       6 unless( defined $actual_dest ) {
1207 0         0 $Test->diag( "symlink [$file] does not have a defined target" );
1208 0 0       0 $Test->diag( "readlink error: $link_error" ) if defined $link_error;
1209 0         0 return $Test->ok( 0, $name );
1210             }
1211              
1212 2 100       8 if( $dest eq $actual_dest ) {
1213 1         5 $Test->ok( 1, $name );
1214             }
1215             else {
1216 1         8 $Test->ok( 0, $name );
1217 1         1166 $Test->diag(" got: $actual_dest" );
1218 1         284 $Test->diag(" expected: $dest" );
1219             }
1220             }
1221              
1222             =item symlink_target_is_absolute_ok( SYMLINK [, NAME ] )
1223              
1224             Ok if FILENAME is a symlink and if its target is an absolute path.
1225             This test automatically skips if the operating system does not support
1226             symlinks. If the file does not exist, the test fails.
1227              
1228             =cut
1229              
1230             sub symlink_target_is_absolute_ok {
1231 0 0   0 1 0 if( _no_symlinks_here() ) {
1232 0         0 $Test->skip(
1233             "symlink_target_exists_ok doesn't work on systems without symlinks" );
1234 0         0 return;
1235             }
1236              
1237 0         0 my( $from, $from_base, $to, $to_base, $name ) = @_;
1238 0         0 my $link = readlink( $from );
1239 0 0       0 my $link_err = defined( $link ) ? '' : $!; # $! doesn't always get reset
1240 0         0 my $link_abs = abs_path( rel2abs($link, $from_base) );
1241 0         0 my $to_abs = abs_path( rel2abs($to, $to_base) );
1242              
1243 0 0 0     0 if (defined( $link_abs ) && defined( $to_abs ) && $link_abs eq $to_abs) {
      0        
1244 0         0 $Test->ok( 1, $name );
1245             }
1246             else {
1247 0         0 $Test->ok( 0, $name );
1248 0   0     0 $link ||= 'undefined';
1249 0   0     0 $link_abs ||= 'undefined';
1250 0   0     0 $to_abs ||= 'undefined';
1251              
1252 0         0 $Test->diag(" link: $from");
1253 0         0 $Test->diag(" got: $link");
1254 0         0 $Test->diag(" (abs): $link_abs");
1255 0         0 $Test->diag(" expected: $to");
1256 0         0 $Test->diag(" (abs): $to_abs");
1257 0 0       0 $Test->diag(" readlink() error: $link_err") if ($link_err);
1258             }
1259             }
1260              
1261             =item dir_exists_ok( DIRECTORYNAME [, NAME ] )
1262              
1263             Ok if the file exists and is a directory, not ok if the file doesn't exist, or exists but isn't a
1264             directory.
1265              
1266             Contributed by Buddy Burden C<< >>.
1267              
1268             =cut
1269              
1270             sub dir_exists_ok {
1271 4     4 1 32946 my $filename = _normalize( shift );
1272 4   66     19 my $name = shift || "$filename is a directory";
1273              
1274 4 100       66 unless( -e $filename ) {
1275 1         11 $Test->diag( "directory [$filename] does not exist" );
1276 1         305 return $Test->ok(0, $name);
1277             }
1278              
1279 3         29 my $ok = -d $filename;
1280              
1281 3 100       11 if( $ok ) {
1282 2         7 $Test->ok(1, $name);
1283             }
1284             else {
1285 1         7 $Test->diag( "file [$filename] exists but is not a directory" );
1286 1         248 $Test->ok(0, $name);
1287             }
1288             }
1289              
1290             =item dir_contains_ok( DIRECTORYNAME, FILENAME [, NAME ] )
1291              
1292             Ok if the directory exists and contains the file, not ok if the directory doesn't exist, or exists
1293             but doesn't contain the file.
1294              
1295             Contributed by Buddy Burden C<< >>.
1296              
1297             =cut
1298              
1299             sub dir_contains_ok {
1300 4     4 1 9918 my $dirname = _normalize( shift );
1301 4         9 my $filename = _normalize( shift );
1302 4   66     21 my $name = shift || "directory $dirname contains file $filename";
1303              
1304 4 100       57 unless( -d $dirname ) {
1305 1         7 $Test->diag( "directory [$dirname] does not exist" );
1306 1         248 return $Test->ok(0, $name);
1307             }
1308              
1309 3         75 my $ok = -e File::Spec->catfile($dirname, $filename);
1310              
1311 3 100       15 if( $ok ) {
1312 2         9 $Test->ok(1, $name);
1313             }
1314             else {
1315 1         7 $Test->diag( "file [$filename] does not exist in directory $dirname" );
1316 1         250 $Test->ok(0, $name);
1317             }
1318             }
1319              
1320             =item link_count_is_ok( FILE, LINK_COUNT [, NAME ] )
1321              
1322             Ok if the link count to FILE is LINK_COUNT. LINK_COUNT is interpreted
1323             as an integer. A LINK_COUNT that evaluates to 0 returns Ok if the file
1324             does not exist.
1325              
1326              
1327             =cut
1328              
1329             sub link_count_is_ok {
1330 3     3 1 8090 my $file = shift;
1331 3         8 my $count = int( 0 + shift );
1332              
1333 3   66     12 my $name = shift || "$file has a link count of [$count]";
1334              
1335 3         48 my $actual = ( stat $file )[3];
1336              
1337 3 100       16 unless( $actual == $count ) {
1338 1         9 $Test->diag(
1339             "file [$file] points has [$actual] links: expected [$count]" );
1340 1         363 return $Test->ok( 0, $name );
1341             }
1342              
1343 2         9 $Test->ok( 1, $name );
1344             }
1345              
1346             =item link_count_gt_ok( FILE, LINK_COUNT [, NAME ] )
1347              
1348             Ok if the link count to FILE is greater than LINK_COUNT. LINK_COUNT is
1349             interpreted as an integer. A LINK_COUNT that evaluates to 0 returns Ok
1350             if the file has at least one link.
1351              
1352             =cut
1353              
1354             sub link_count_gt_ok {
1355 3     3 1 4241 my $file = shift;
1356 3         6 my $count = int( 0 + shift );
1357              
1358 3   66     13 my $name = shift || "$file has a link count of [$count]";
1359              
1360 3         43 my $actual = (stat $file )[3];
1361              
1362 3 100       15 unless( $actual > $count ) {
1363 1         11 $Test->diag(
1364             "file [$file] points has [$actual] links: ".
1365             "expected more than [$count]" );
1366 1         299 return $Test->ok( 0, $name );
1367             }
1368              
1369 2         9 $Test->ok( 1, $name );
1370             }
1371              
1372             =item link_count_lt_ok( FILE, LINK_COUNT [, NAME ] )
1373              
1374             Ok if the link count to FILE is less than LINK_COUNT. LINK_COUNT is
1375             interpreted as an integer. A LINK_COUNT that evaluates to 0 returns Ok
1376             if the file has at least one link.
1377              
1378             =cut
1379              
1380             sub link_count_lt_ok {
1381 3     3 1 34452 my $file = shift;
1382 3         8 my $count = int( 0 + shift );
1383              
1384 3   66     13 my $name = shift || "$file has a link count of [$count]";
1385              
1386 3         51 my $actual = (stat $file )[3];
1387              
1388 3 100       18 unless( $actual < $count ) {
1389 1         11 $Test->diag(
1390             "file [$file] points has [$actual] links: ".
1391             "expected less than [$count]" );
1392 1         302 return $Test->ok( 0, $name );
1393             }
1394              
1395 2         10 $Test->ok( 1, $name );
1396             }
1397              
1398              
1399             # owner_is, owner_isnt, group_is and group_isnt are almost
1400             # identical in the beginning, so I'm writing a skeleton they can all use.
1401             # I can't think of a better name...
1402             sub _dm_skeleton {
1403 17     17   145 no warnings 'uninitialized';
  17         56  
  17         29107  
1404              
1405 22 100   22   144 if( _obviously_non_multi_user() ) {
1406 3         22 my $calling_sub = (caller(1))[3];
1407 3         18 $Test->skip( $calling_sub . " only works on a multi-user OS" );
1408 3         1313 return 'skip';
1409             }
1410              
1411 19         56 my $filename = _normalize( shift );
1412 19         35 my $testing_for = shift;
1413 19         31 my $name = shift;
1414              
1415 19 100       41 unless( defined $filename ) {
1416 1         9 $Test->diag( "file name not specified" );
1417 1         297 return $Test->ok( 0, $name );
1418             }
1419              
1420 18 100       222 unless( -e $filename ) {
1421 1         10 $Test->diag( "file [$filename] does not exist" );
1422 1         337 return $Test->ok( 0, $name );
1423             }
1424              
1425 17         59 return;
1426             }
1427              
1428             =item owner_is( FILE , OWNER [, NAME ] )
1429              
1430             Ok if FILE's owner is the same as OWNER. OWNER may be a text user name
1431             or a numeric userid. Test skips on Dos, and Mac OS <= 9.
1432             If the file does not exist, the test fails.
1433              
1434             Contributed by Dylan Martin
1435              
1436             =cut
1437              
1438             sub owner_is {
1439 4     4 1 7504 my $filename = shift;
1440 4         9 my $owner = shift;
1441 4   66     17 my $name = shift || "$filename belongs to $owner";
1442              
1443 4         14 my $err = _dm_skeleton( $filename, $owner, $name );
1444 4 50 33     12 return if( defined( $err ) && $err eq 'skip' );
1445 4 50       10 return $err if defined($err);
1446              
1447 4         10 my $owner_uid = _get_uid( $owner );
1448 4 100       9 unless( defined $owner_uid ) {
1449 1         10 $Test->diag("user [$owner] does not exist on this system");
1450 1         253 return $Test->ok( 0, $name );
1451             }
1452              
1453 3         36 my $file_uid = ( stat $filename )[4];
1454              
1455 3 50       11 unless( defined $file_uid ) {
1456 0         0 $Test->skip("stat failed to return owner uid for $filename");
1457 0         0 return;
1458             }
1459              
1460 3 100       17 return $Test->ok( 1, $name ) if $file_uid == $owner_uid;
1461              
1462 1         77 my $real_owner = ( getpwuid $file_uid )[0];
1463 1 50       6 unless( defined $real_owner ) {
1464 0         0 $Test->diag("file does not belong to $owner");
1465 0         0 return $Test->ok( 0, $name );
1466             }
1467              
1468 1         13 $Test->diag( "file [$filename] belongs to $real_owner ($file_uid), ".
1469             "not $owner ($owner_uid)" );
1470 1         326 return $Test->ok( 0, $name );
1471             }
1472              
1473             =item owner_isnt( FILE, OWNER [, NAME ] )
1474              
1475             Ok if FILE's owner is not the same as OWNER. OWNER may be a text user name
1476             or a numeric userid. Test skips on Dos and Mac OS <= 9. If the file
1477             does not exist, the test fails.
1478              
1479             Contributed by Dylan Martin
1480              
1481             =cut
1482              
1483             sub owner_isnt {
1484 4     4 1 6478 my $filename = shift;
1485 4         10 my $owner = shift;
1486 4   66     17 my $name = shift || "$filename doesn't belong to $owner";
1487              
1488 4         12 my $err = _dm_skeleton( $filename, $owner, $name );
1489 4 50 33     11 return if( defined( $err ) && $err eq 'skip' );
1490 4 50       11 return $err if defined($err);
1491              
1492 4         11 my $owner_uid = _get_uid( $owner );
1493 4 100       11 unless( defined $owner_uid ) {
1494 1         5 return $Test->ok( 1, $name );
1495             }
1496              
1497 3         33 my $file_uid = ( stat $filename )[4];
1498              
1499             #$Test->diag( "owner_isnt: $owner_uid $file_uid" );
1500 3 100       18 return $Test->ok( 1, $name ) if $file_uid != $owner_uid;
1501              
1502 1         9 $Test->diag( "file [$filename] belongs to $owner ($owner_uid)" );
1503 1         254 return $Test->ok( 0, $name );
1504             }
1505              
1506             =item group_is( FILE , GROUP [, NAME ] )
1507              
1508             Ok if FILE's group is the same as GROUP. GROUP may be a text group name or
1509             a numeric group id. Test skips on Dos, Mac OS <= 9 and any other operating
1510             systems that do not support getpwuid() and friends. If the file does not
1511             exist, the test fails.
1512              
1513             Contributed by Dylan Martin
1514              
1515             =cut
1516              
1517             sub group_is {
1518 5     5 1 7567 my $filename = shift;
1519 5         9 my $group = shift;
1520 5   66     21 my $name = ( shift || "$filename belongs to group $group" );
1521              
1522 5         13 my $err = _dm_skeleton( $filename, $group, $name );
1523 5 50 33     22 return if( defined( $err ) && $err eq 'skip' );
1524 5 50       9 return $err if defined($err);
1525              
1526 5         14 my $group_gid = _get_gid( $group );
1527 5 100       12 unless( defined $group_gid ) {
1528 1         9 $Test->diag("group [$group] does not exist on this system");
1529 1         260 return $Test->ok( 0, $name );
1530             }
1531              
1532 4         46 my $file_gid = ( stat $filename )[5];
1533              
1534 4 50       18 unless( defined $file_gid ) {
1535 0         0 $Test->skip("stat failed to return group gid for $filename");
1536 0         0 return;
1537             }
1538              
1539 4 100       20 return $Test->ok( 1, $name ) if $file_gid == $group_gid;
1540              
1541 1         46 my $real_group = ( getgrgid $file_gid )[0];
1542 1 50       7 unless( defined $real_group ) {
1543 0         0 $Test->diag("file does not belong to $group");
1544 0         0 return $Test->ok( 0, $name );
1545             }
1546              
1547 1         13 $Test->diag( "file [$filename] belongs to $real_group ($file_gid), ".
1548             "not $group ($group_gid)" );
1549              
1550 1         255 return $Test->ok( 0, $name );
1551             }
1552              
1553             =item group_isnt( FILE , GROUP [, NAME ] )
1554              
1555             Ok if FILE's group is not the same as GROUP. GROUP may be a text group name or
1556             a numeric group id. Test skips on Dos, Mac OS <= 9 and any other operating
1557             systems that do not support getpwuid() and friends. If the file does not
1558             exist, the test fails.
1559              
1560             Contributed by Dylan Martin
1561              
1562             =cut
1563              
1564             sub group_isnt {
1565 4     4 1 4182 my $filename = shift;
1566 4         7 my $group = shift;
1567 4   66     18 my $name = shift || "$filename does not belong to group $group";
1568              
1569 4         11 my $err = _dm_skeleton( $filename, $group, $name );
1570 4 50 33     15 return if( defined( $err ) && $err eq 'skip' );
1571 4 50       10 return $err if defined($err);
1572              
1573 4         11 my $group_gid = _get_gid( $group );
1574 4         45 my $file_gid = ( stat $filename )[5];
1575              
1576 4 50       16 unless( defined $file_gid ) {
1577 0         0 $Test->skip("stat failed to return group gid for $filename");
1578 0         0 return;
1579             }
1580              
1581 4 100       21 return $Test->ok( 1, $name ) if $file_gid != $group_gid;
1582              
1583 1         10 $Test->diag( "file [$filename] belongs to $group ($group_gid)" );
1584 1         256 return $Test->ok( 0, $name );
1585             }
1586              
1587             sub _get_uid {
1588 8     8   14 my $arg = shift;
1589              
1590             # the name might be numeric (why would you do that?), so we need
1591             # to figure out which of several possibilities we have. And, 0 means
1592             # root, so we have to be very careful with the values.
1593              
1594             # maybe the argument is a UID. First, it has to be numeric. If it's
1595             # a UID, we'll get the same UID back. But, if we get back a value
1596             # that doesn't mean that we are done. There might be a name with
1597             # the same value.
1598             #
1599             # Don't use this value in comparisons! An undef could be turned
1600             # into zero!
1601 8 100       187 my $from_uid = (getpwuid($arg))[2] if $arg =~ /\A[0-9]+\z/;
1602              
1603             # Now try the argument as a name. If it's a name, then we'll get
1604             # back a UID. Maybe we get back nothing.
1605 8         528 my $from_nam = (getpwnam($arg))[2];
1606              
1607 8         26 return do {
1608             # first case, we got back nothing from getpwnam but did get
1609             # something from getpwuid. The arg is not a name and is a
1610             # UID.
1611 8 100 66     68 if( defined $from_uid and not defined $from_nam ) { $arg }
  2 100 66     9  
    50 33        
1612             # second case, we got back nothing from getpwuid but did get
1613             # something from getpwnam. The arg is a name and is not a
1614             # UID.
1615 4         12 elsif( not defined $from_uid and defined $from_nam ) { $from_nam }
1616             # Now, what happens if neither are defined? The argument does
1617             # not correspond to a name or GID on the system. Since no such
1618             # user exists, we return undef.
1619 2         7 elsif( not defined $from_uid and not defined $from_nam ) { undef }
1620             # But what if they are both defined? The argument could represent
1621             # a UID and a name, and those could be different users! In this
1622             # case, we'll choose the original argument. That might be wrong,
1623             # so the best we can do is a warning.
1624             else {
1625 0         0 carp( "Found both a UID or name for <$arg>. Guessing the UID is <$arg>." );
1626 0         0 $arg
1627             }
1628             };
1629             }
1630              
1631             sub _get_gid {
1632 9     9   13 my $arg = shift;
1633              
1634             # the name might be numeric (why would you do that?), so we need
1635             # to figure out which of several possibilities we have. And, 0 means
1636             # root, so we have to be very careful with the values.
1637              
1638             # maybe the argument is a GID. First, it has to be numeric. If it's
1639             # a GID, we'll get the same GID back. But, if we get back a value
1640             # that doesn't mean that we are done. There might be a name with
1641             # the same value.
1642             #
1643             # Don't use this value in comparisons! An undef could be turned
1644             # into zero!
1645 9 100       178 my $from_gid = (getgrgid($arg))[2] if $arg =~ /\A[0-9]+\z/;
1646              
1647             # Now try the argument as a name. If it's a name, then we'll get
1648             # back a GID. Maybe we get back nothing.
1649 9         434 my $from_nam = (getgrnam($arg))[2];
1650              
1651 9         31 return do {
1652             # first case, we got back nothing from getgrnam but did get
1653             # something from getpwuid. The arg is not a name and is a
1654             # GID.
1655 9 100 66     58 if( defined $from_gid and not defined $from_nam ) { $arg }
  3 100 66     11  
    50 33        
1656             # second case, we got back nothing from getgrgid but did get
1657             # something from getgrnam. The arg is a name and is not a
1658             # GID.
1659 5         12 elsif( not defined $from_gid and defined $from_nam ) { $from_nam }
1660             # Now, what happens if neither are defined? The argument does
1661             # not correspond to a name or GID on the system. Since no such
1662             # user exists, we return undef.
1663 1         4 elsif( not defined $from_gid and not defined $from_nam ) { undef }
1664             # But what if they are both defined? The argument could represent
1665             # a GID and a name, and those could be different users! In this
1666             # case, we'll choose the original argument. That might be wrong,
1667             # so the best we can do is a warning.
1668             else {
1669 0         0 carp( "Found both a GID or name for <$arg>. Guessing the GID is <$arg>." );
1670 0         0 $arg;
1671             }
1672             };
1673             }
1674              
1675             =item file_mtime_age_ok( FILE [, WITHIN_SECONDS ] [, NAME ] )
1676              
1677             Ok if FILE's modified time is WITHIN_SECONDS inclusive of the system's current time.
1678             This test uses stat() to obtain the mtime. If the file does not exist the test
1679             returns failure. If stat() fails, the test is skipped.
1680              
1681             =cut
1682              
1683             sub file_mtime_age_ok {
1684 4     4 1 37645 my $filename = shift;
1685 4   100     16 my $within_secs = shift || 0;
1686 4   66     20 my $name = shift || "$filename mtime within $within_secs seconds of current time";
1687              
1688 4         7 my $time = time();
1689              
1690 4         8 my $filetime = _stat_file($filename, 9);
1691              
1692 4 50       12 return if ( $filetime == -1 ); #skip
1693              
1694 4 100       15 return $Test->ok(1, $name) if ( $filetime + $within_secs > $time-1 );
1695              
1696 2         16 $Test->diag( "file [$filename] mtime [$filetime] is not $within_secs seconds within current system time [$time].");
1697 2         681 return $Test->ok(0, $name);
1698             }
1699              
1700             =item file_mtime_gt_ok( FILE, UNIXTIME [, NAME ] )
1701              
1702             Ok if FILE's mtime is > UNIXTIME. This test uses stat() to get the mtime. If stat() fails
1703             this test is skipped. If FILE does not exist, this test fails.
1704              
1705             =cut
1706              
1707             sub file_mtime_gt_ok {
1708 3     3 1 9134 my $filename = shift;
1709 3         6 my $time = int shift;
1710 3   66     16 my $name = shift || "$filename mtime is greater than unix timestamp $time";
1711              
1712 3         7 my $filetime = _stat_file($filename, 9);
1713              
1714 3 50       10 return if ( $filetime == -1 ); #skip
1715              
1716 3 100       16 return $Test->ok(1, $name) if ( $filetime > $time );
1717              
1718 1         9 $Test->diag( "file [$filename] mtime [$filetime] not greater than $time" );
1719 1         307 $Test->ok(0, $name);
1720             }
1721              
1722             =item file_mtime_lt_ok( FILE, UNIXTIME, [, NAME ] )
1723              
1724             Ok if FILE's modified time is < UNIXTIME. This test uses stat() to get the mtime. If stat() fails
1725             this test is skipped. If FILE does not exist, this test fails.
1726              
1727             =cut
1728              
1729             sub file_mtime_lt_ok {
1730 3     3 1 9128 my $filename = shift;
1731 3         6 my $time = int shift;
1732 3   66     13 my $name = shift || "$filename mtime less than unix timestamp $time";
1733              
1734             # gets mtime
1735 3         8 my $filetime = _stat_file($filename, 9);
1736              
1737 3 50       10 return if ( $filetime == -1 ); #skip
1738              
1739 3 100       17 return $Test->ok(1, $name) if ( $filetime < $time );
1740              
1741 1         10 $Test->diag( "file [$filename] mtime [$filetime] not less than $time" );
1742 1         309 $Test->ok(0, $name);
1743             }
1744              
1745             # private function to safely stat a file
1746             #
1747             # Arugments:
1748             # filename file to perform on
1749             # attr_pos pos of the array returned from stat we want to compare. perldoc -f stat
1750             #
1751             # Returns:
1752             # -1 - stat failed
1753             # 0 - failure (file doesn't exist etc)
1754             # filetime - on success, time requested provided by stat
1755             #
1756             sub _stat_file {
1757 12     12   8377 my $filename = _normalize( shift );
1758 12         17 my $attr_pos = shift;
1759              
1760 12 100       25 unless( defined $filename ) {
1761 1         5 $Test->diag( "file name not specified" );
1762 1         291 return 0;
1763             }
1764              
1765 11 100       178 unless( -e $filename ) {
1766 1         9 $Test->diag( "file [$filename] does not exist" );
1767 1         305 return 0;
1768             }
1769              
1770 10         111 my $filetime = ( stat($filename) )[$attr_pos];
1771              
1772 10 50       34 unless( $filetime ) {
1773 0         0 $Test->diag( "stat of $filename failed" );
1774 0         0 return -1; #skip on stat failure
1775             }
1776              
1777 10         24 return $filetime;
1778             }
1779              
1780             =back
1781              
1782             =head1 TO DO
1783              
1784             * check properties for other users (readable_by_root, for instance)
1785              
1786             * check times
1787              
1788             * check number of links to file
1789              
1790             * check path parts (directory, filename, extension)
1791              
1792             =head1 SEE ALSO
1793              
1794             L,
1795             L
1796              
1797             If you are using the new C stuff, see Test2::Tools::File
1798             (https://github.com/torbjorn/Test2-Tools-File).
1799              
1800             =head1 SOURCE AVAILABILITY
1801              
1802             This module is in Github:
1803              
1804             https://github.com/briandfoy/test-file
1805              
1806             =head1 AUTHOR
1807              
1808             brian d foy, C<< >>
1809              
1810             =head1 CREDITS
1811              
1812             Shawn Sorichetti C<< >> provided
1813             some functions.
1814              
1815             Tom Metro helped me figure out some Windows capabilities.
1816              
1817             Dylan Martin added C and C.
1818              
1819             David Wheeler added C.
1820              
1821             Buddy Burden C<< >> provided C,
1822             C, C, and
1823             C.
1824              
1825             xmikew C<< >> provided the C
1826             stuff.
1827              
1828             Torbjørn Lindahl is working on L and we're
1829             working together to align our interfaces.
1830              
1831             Jean-Damien Durand added bits to use Win32::IsSymlinkCreationAllowed,
1832             new since Win32 0.55.
1833              
1834             =head1 COPYRIGHT AND LICENSE
1835              
1836             Copyright © 2002-2023, brian d foy . All rights reserved.
1837              
1838             This program is free software; you can redistribute it and/or modify
1839             it under the terms of the Artistic License 2.0
1840              
1841             =cut
1842              
1843             "The quick brown fox jumped over the lazy dog";