File Coverage

blib/lib/File/stat/Extra.pm
Criterion Covered Total %
statement 85 90 94.4
branch 17 26 65.3
condition n/a
subroutine 31 31 100.0
pod 13 13 100.0
total 146 160 91.2


line stmt bran cond sub pod time code
1             package File::stat::Extra;
2 1     1   12680 use strict;
  1         1  
  1         23  
3 1     1   3 use warnings;
  1         1  
  1         21  
4 1     1   3 use warnings::register;
  1         1  
  1         98  
5              
6 1     1   12 use 5.006;
  1         2  
7              
8             # ABSTRACT: An extension of the File::stat module, provides additional methods.
9             our $VERSION = '0.007'; # VERSION
10              
11             #pod =head1 SYNOPSIS
12             #pod
13             #pod =for test_synopsis
14             #pod my ($st, $file);
15             #pod
16             #pod use File::stat::Extra;
17             #pod
18             #pod $st = lstat($file) or die "No $file: $!";
19             #pod
20             #pod if ($st->isLink) {
21             #pod print "$file is a symbolic link";
22             #pod }
23             #pod
24             #pod if (-x $st) {
25             #pod print "$file is executable";
26             #pod }
27             #pod
28             #pod use Fcntl 'S_IRUSR';
29             #pod if ( $st->cando(S_IRUSR, 1) ) {
30             #pod print "My effective uid can read $file";
31             #pod }
32             #pod
33             #pod if ($st == stat($file)) {
34             #pod printf "%s and $file are the same", $st->file;
35             #pod }
36             #pod
37             #pod =head1 DESCRIPTION
38             #pod
39             #pod This module's default exports override the core stat() and lstat()
40             #pod functions, replacing them with versions that return
41             #pod C objects when called in scalar context. In list
42             #pod context the same 13 item list is returned as with the original C
43             #pod and C functions.
44             #pod
45             #pod C is an extension of the L
46             #pod module.
47             #pod
48             #pod =for :list
49             #pod * Returns non-object result in list context.
50             #pod * You can now pass in bare file handles to C and C under C.
51             #pod * File tests C<-t> C<-T>, and C<-B> have been implemented too.
52             #pod * Convenience functions C and C for direct access to filetype and permission parts of the mode field.
53             #pod * Named access to common file tests (C / C, C, C, C, C, C / C, C).
54             #pod * Access to the name of the file / file handle used for the stat (C, C / C).
55             #pod
56             #pod =head1 SEE ALSO
57             #pod
58             #pod =for :list
59             #pod * L for the module for which C is the extension.
60             #pod * L and L for the original C and C functions.
61             #pod
62             #pod =head1 COMPATIBILITY
63             #pod
64             #pod As with L, you can no longer use the implicit C<$_> or the
65             #pod special filehandle C<_> with this module's versions of C and
66             #pod C.
67             #pod
68             #pod Currently C only provides an object interface, the
69             #pod L C<$st_*> variables and C funtion are not
70             #pod available. This may change in a future version of this module.
71             #pod
72             #pod =head1 WARNINGS
73             #pod
74             #pod When a file (handle) can not be (l)stat-ed, a warning C
75             #pod stat: %s>. To disable this warning, specify
76             #pod
77             #pod no warnings "File::stat::Extra";
78             #pod
79             #pod The following warnings are inhereted from C, these can all
80             #pod be disabled with
81             #pod
82             #pod no warnings "File::stat";
83             #pod
84             #pod =over 4
85             #pod
86             #pod =item File::stat ignores use filetest 'access'
87             #pod
88             #pod You have tried to use one of the C<-rwxRWX> filetests with C
89             #pod filetest 'access'> in effect. C will ignore the pragma, and
90             #pod just use the information in the C member as usual.
91             #pod
92             #pod =item File::stat ignores VMS ACLs
93             #pod
94             #pod VMS systems have a permissions structure that cannot be completely
95             #pod represented in a stat buffer, and unlike on other systems the builtin
96             #pod filetest operators respect this. The C overloads, however,
97             #pod do not, since the information required is not available.
98             #pod
99             #pod =back
100             #pod
101             #pod =cut
102              
103             # Note: we are not defining File::stat::Extra as a subclass of File::stat
104             # as we need to add an additional field and can not rely on the fact that
105             # File::stat will always be implemented as an array (struct).
106              
107             our @ISA = qw(Exporter);
108             our @EXPORT = qw(stat lstat);
109              
110 1     1   390 use File::stat ();
  1         5960  
  1         17  
111 1     1   5 use File::Spec ();
  1         1  
  1         11  
112 1     1   3 use Cwd ();
  1         1  
  1         8  
113 1     1   3 use Fcntl ();
  1         0  
  1         85  
114              
115             require Carp;
116             $Carp::Internal{ (__PACKAGE__) }++; # To get warnings reported at correct caller level
117              
118             #pod =func stat( I )
119             #pod
120             #pod =func stat( I )
121             #pod
122             #pod =func stat( I )
123             #pod
124             #pod =func lstat( I )
125             #pod
126             #pod =func lstat( I )
127             #pod
128             #pod =func lstat( I )
129             #pod
130             #pod When called in list context, these functions behave as the original
131             #pod C and C functions, returning the 13 element C list.
132             #pod When called in scalar context, a C object is
133             #pod returned with the methods as outlined below.
134             #pod
135             #pod =cut
136              
137             # Runs stat or lstat on "file"
138             sub __stat_lstat {
139 29     29   36 my $func = shift;
140 29         22 my $file = shift;
141              
142 29 100       267 return $func eq 'lstat' ? CORE::lstat($file) : CORE::stat($file);
143             }
144              
145             # Wrapper around stat/lstat, handles passing of file as a bare handle too
146             sub _stat_lstat {
147 25     25   25 my $func = shift;
148 25         17 my $file = shift;
149              
150 25         30 my @stat = __stat_lstat($func, $file);
151              
152 25 100       37 if (@stat) {
153             # We have a file, so make it absolute (NOT resolving the symlinks)
154 21 100       248 $file = File::Spec->rel2abs($file) if !ref $file;
155             } else {
156             # Try again, interpretting $file as handle
157 1     1   3 no strict 'refs'; ## no critic (TestingAndDebugging::ProhibitNoStrict)
  1         1  
  1         162  
158 4         20 local $! = undef;
159 4         458 require Symbol;
160 4         620 my $fh = \*{ Symbol::qualify($file, caller(1)) };
  4         23  
161 4 50       57 if (defined fileno $fh) {
162 4         6 @stat = __stat_lstat($func, $fh);
163             }
164 4 50       10 if (!@stat) {
165 0         0 warnings::warnif("Unable to stat: $file");
166 0         0 return;
167             }
168             # We have a (valid) file handle, so we make file point to it
169 4         8 $file = $fh;
170             }
171              
172 25 100       35 if (wantarray) {
173 8         22 return @stat;
174             } else {
175 17         30 return bless [ File::stat::populate(@stat), $file ], 'File::stat::Extra';
176             }
177             }
178              
179             sub stat(*) { ## no critic (Subroutines::ProhibitSubroutinePrototypes)
180 17     17 1 4074 return _stat_lstat('stat', shift);
181             }
182              
183             sub lstat(*) { ## no critic (Subroutines::ProhibitSubroutinePrototypes)
184 8     8 1 417 return _stat_lstat('lstat', shift);
185             }
186              
187             #pod =method dev
188             #pod
189             #pod =method ino
190             #pod
191             #pod =method mode
192             #pod
193             #pod =method nlink
194             #pod
195             #pod =method uid
196             #pod
197             #pod =method gid
198             #pod
199             #pod =method rdev
200             #pod
201             #pod =method size
202             #pod
203             #pod =method atime
204             #pod
205             #pod =method mtime
206             #pod
207             #pod =method ctime
208             #pod
209             #pod =method blksize
210             #pod
211             #pod =method blocks
212             #pod
213             #pod These methods provide named acced to the same fields in the original
214             #pod C result. Just like the original L.
215             #pod
216             #pod =method cando( I, I )
217             #pod
218             #pod Interprets the C, C and C fields, and returns whether
219             #pod or not the current process would be allowed the specified access.
220             #pod
221             #pod I is one of C, C or C from the
222             #pod L module, and I indicates whether to use
223             #pod effective (true) or real (false) ids.
224             #pod
225             #pod =cut
226              
227             BEGIN {
228 1     1   10 no strict 'refs'; ## no critic (TestingAndDebugging::ProhibitNoStrict)
  1         2  
  1         126  
229              
230             # Define the main field accessors and the cando method using the File::stat version
231 1     1   1 for my $f (qw(dev ino mode nlink uid gid rdev size atime mtime ctime blksize blocks cando)) {
232 14     93   32 *{$f} = sub { $_[0][0]->$f; }
  93         5435  
233 14         22 }
234              
235             #pod =for Pod::Coverage S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISLNK S_ISREG S_ISSOCK
236             #pod
237             #pod =cut
238              
239             # Create own versions of these functions as they will croak on use
240             # if the platform doesn't define them. It's important to avoid
241             # inflicting that on the user.
242             # Note: to stay (more) version independent, we do not rely on the
243             # implementation in File::stat, but rather recreate here.
244 1         2 for (qw(BLK CHR DIR LNK REG SOCK)) {
245 6 50       6 *{"S_IS$_"} = defined eval { &{"Fcntl::S_IF$_"} } ? \&{"Fcntl::S_IS$_"} : sub { '' };
  6         11  
  6         2  
  6         15  
  6         6  
  0         0  
246             }
247             # FIFO flag and macro don't quite follow the S_IF/S_IS pattern above
248 1 50       3 *{'S_ISFIFO'} = defined &Fcntl::S_IFIFO ? \&Fcntl::S_ISFIFO : sub { '' };
  1         727  
  0         0  
249             }
250              
251             #pod =method file
252             #pod
253             #pod Returns the full path to the original file (or the filehandle) on which
254             #pod C or C was called.
255             #pod
256             #pod Note: Symlinks are not resolved. And, like C, neither are
257             #pod C constructs. Use the C / C methods to
258             #pod resolve these too.
259             #pod
260             #pod =cut
261              
262             sub file {
263 9     9 1 761 return $_[0][1];
264             }
265              
266             #pod =method abs_file
267             #pod
268             #pod =method target
269             #pod
270             #pod Returns the absolute path of the file. In case of a file handle, this is returned unaltered.
271             #pod
272             #pod =cut
273              
274             sub abs_file {
275 2 50   2 1 5 return ref $_[0]->file ? $_[0]->file : Cwd::abs_path($_[0]->file);
276             }
277              
278             *target = *abs_file;
279              
280             #pod =method permissions
281             #pod
282             #pod Returns just the permissions (including setuid/setgid/sticky bits) of the C stat field.
283             #pod
284             #pod =cut
285              
286             sub permissions {
287 2     2 1 846 return Fcntl::S_IMODE($_[0]->mode);
288             }
289              
290             #pod =method filetype
291             #pod
292             #pod Returns just the filetype of the C stat field.
293             #pod
294             #pod =cut
295              
296             sub filetype {
297 2     2 1 518 return Fcntl::S_IFMT($_[0]->mode);
298             }
299              
300             #pod =method isFile
301             #pod
302             #pod =method isRegular
303             #pod
304             #pod Returns true if the file is a regular file (same as -f file test).
305             #pod
306             #pod =cut
307              
308             sub isFile {
309 2     2 1 245 return S_ISREG($_[0]->mode);
310             }
311              
312             *isRegular = *isFile;
313              
314             #pod =method isDir
315             #pod
316             #pod Returns true if the file is a directory (same as -d file test).
317             #pod
318             #pod =cut
319              
320             sub isDir {
321 2     2 1 362 return S_ISDIR($_[0]->mode);
322             }
323              
324             #pod =method isLink
325             #pod
326             #pod Returns true if the file is a symbolic link (same as -l file test).
327             #pod
328             #pod Note: Only relevant when C was used!
329             #pod
330             #pod =cut
331              
332             sub isLink {
333 5     5 1 776 return S_ISLNK($_[0]->mode);
334             }
335              
336             #pod =method isBlock
337             #pod
338             #pod Returns true if the file is a block special file (same as -b file test).
339             #pod
340             #pod =cut
341              
342             sub isBlock {
343 1     1 1 170 return S_ISBLK($_[0]->mode);
344             }
345              
346             #pod =method isChar
347             #pod
348             #pod Returns true if the file is a character special file (same as -c file test).
349             #pod
350             #pod =cut
351              
352             sub isChar {
353 1     1 1 199 return S_ISCHR($_[0]->mode);
354             }
355              
356             #pod =method isFIFO
357             #pod
358             #pod =method isPipe
359             #pod
360             #pod Returns true if the file is a FIFO file or, in case of a file handle, a pipe (same as -p file test).
361             #pod
362             #pod =cut
363              
364             sub isFIFO {
365 1     1 1 171 return S_ISFIFO($_[0]->mode);
366             }
367              
368             *isPipe = *isFIFO;
369              
370             #pod =method isSocket
371             #pod
372             #pod Returns true if the file is a socket file (same as -S file test).
373             #pod
374             #pod =cut
375              
376             sub isSocket {
377 1     1 1 170 return S_ISSOCK($_[0]->mode);
378             }
379              
380             #pod =method -X operator
381             #pod
382             #pod You can use the file test operators on the C object
383             #pod just as you would on a file (handle). However, instead of querying the
384             #pod file system, these operators will use the information from the
385             #pod object itself.
386             #pod
387             #pod The overloaded filetests are only supported from Perl version 5.12 and
388             #pod higer. The named access to these tests can still be used though.
389             #pod
390             #pod Note: in case of the special file tests C<-t>, C<-T>, and C<-B>, the
391             #pod file (handle) I tested the I time the operator is
392             #pod used. After the first time, the initial result is re-used and no
393             #pod further testing of the file (handle) is performed.
394             #pod
395             #pod =method Unary C<""> (stringification) operator
396             #pod
397             #pod The unary C<""> (stringification) operator is overloaded to return the the device and inode
398             #pod numbers separated by a C<.> (C.I>). This yields a uniqe file identifier (as string).
399             #pod
400             #pod =method Comparison operators C<< <=> >>, C, and C<~~>
401             #pod
402             #pod The comparison operators use the string representation of the
403             #pod C object. So, to see if two C
404             #pod object point to the same (hardlinked) file, you can simply say
405             #pod something like this:
406             #pod
407             #pod print 'Same file' if $obj1 == $obj2;
408             #pod
409             #pod For objects created from an C of a symbolic link, the actual
410             #pod I of the link is used in the comparison! If you want to
411             #pod compare the actual symlink file, use C instead.
412             #pod
413             #pod Note: All comparisons (also the numeric versions) are performed on the
414             #pod full stringified versions of the object. This to prevent files on the
415             #pod same device, but with an inode number ending in a zero to compare
416             #pod equally while they aren't (e.g., 5.10 and 5.100 compare equal
417             #pod numerically but denote a different file).
418             #pod
419             #pod Note: the smartmatch C<~~> operator is only overloaded on Perl version
420             #pod 5.10 and above.
421             #pod
422             #pod =method Other operators
423             #pod
424             #pod As the other operators (C<+>, C<->, C<*>, etc.) are meaningless, they
425             #pod have not been overloaded and will cause a run-time error.
426             #pod
427             #pod =cut
428              
429             my %op = (
430             # Use the named version of these tests
431             f => sub { $_[0]->isRegular },
432             d => sub { $_[0]->isDir },
433             l => sub { $_[0]->isLink },
434             p => sub { $_[0]->isFIFO },
435             S => sub { $_[0]->isSocket },
436             b => sub { $_[0]->isBlock },
437             c => sub { $_[0]->isChar },
438              
439             # Defer implementation of rest to File::stat
440             r => sub { -r $_[0][0] },
441             w => sub { -w $_[0][0] },
442             x => sub { -x $_[0][0] },
443             o => sub { -o $_[0][0] },
444              
445             R => sub { -R $_[0][0] },
446             W => sub { -W $_[0][0] },
447             X => sub { -X $_[0][0] },
448             O => sub { -O $_[0][0] },
449              
450             e => sub { -e $_[0][0] },
451             z => sub { -z $_[0][0] },
452             s => sub { -s $_[0][0] },
453              
454             u => sub { -u $_[0][0] },
455             g => sub { -g $_[0][0] },
456             k => sub { -k $_[0][0] },
457              
458             M => sub { -M $_[0][0] },
459             C => sub { -C $_[0][0] },
460             A => sub { -A $_[0][0] },
461              
462             # Implement these operators by testing the underlying file, caching the result
463             t => sub { defined $_[0][2] ? $_[0][2] : $_[0][2] = (-t $_[0]->file) || 0 }, ## no critic (InputOutput::ProhibitInteractiveTest)
464             T => sub { defined $_[0][3] ? $_[0][3] : $_[0][3] = (-T $_[0]->file) || 0 },
465             B => sub { defined $_[0][4] ? $_[0][4] : $_[0][4] = (-B $_[0]->file) || 0 },
466             );
467              
468             sub _filetest {
469 6     6   706 my ($s, $op) = @_;
470 6 50       14 if ($op{$op}) {
471 6         14 return $op{$op}->($s);
472             } else {
473             # We should have everything covered so this is just a safegauard
474 0         0 Carp::croak "-$op is not implemented on a File::stat::Extra object";
475             }
476             }
477              
478             sub _dev_ino {
479 12     12   42 return $_[0]->dev . "." . $_[0]->ino;
480             }
481              
482             sub _compare {
483 6     6   1339 my $va = shift;
484 6         7 my $vb = shift;
485 6         7 my $swapped = shift;
486 6 50       10 ($vb, $va) = ($va, $vb) if $swapped;
487              
488 6         9 return "$va" cmp "$vb"; # Force stringification when comparing
489             }
490              
491             use overload
492             # File test operators (as of Perl v5.12)
493 1 50       24 $^V >= 5.012 ? (-X => \&_filetest) : (),
    50          
494              
495             # Unary "" returns the object as "dev.ino", this should be a
496             # unique string for each file.
497             '""' => \&_dev_ino,
498              
499             # Comparison is done based on the unique string created with the stringification
500             '<=>' => \&_compare,
501             'cmp' => \&_compare,
502              
503             # Smartmatch as of Perl v5.10
504             $^V >= 5.010 ? ('~~' => \&_compare) : (),
505              
506 1     1   4 ;
  1         1  
507              
508             1;
509              
510             __END__