File Coverage

blib/lib/File/pfopen.pm
Criterion Covered Total %
statement 41 41 100.0
branch 17 18 94.4
condition n/a
subroutine 4 4 100.0
pod 1 1 100.0
total 63 64 98.4


line stmt bran cond sub pod time code
1             package File::pfopen;
2              
3             # Author Nigel Horne: njh@bandsman.co.uk
4             # Copyright (C) 2017 Nigel Horne
5              
6             # Usage is subject to licence terms.
7             # The licence terms of this software are as follows:
8             # Personal single user, single computer use: GPL2
9             # All other users (including Commercial, Charity, Educational, Government)
10             # must apply in writing for a licence for use from Nigel Horne at the
11             # above e-mail.
12              
13 2     2   113480 use strict;
  2         30  
  2         61  
14 2     2   12 use warnings;
  2         2  
  2         48  
15 2     2   10 use File::Spec;
  2         8  
  2         640  
16              
17             require Exporter;
18             our @ISA = ('Exporter');
19             our @EXPORT_OK = ('pfopen');
20              
21             =head1 NAME
22              
23             File::pfopen - Try hard to find a file
24              
25             =head1 VERSION
26              
27             Version 0.02
28              
29             =cut
30              
31             our $VERSION = '0.02';
32              
33             =head1 SYNOPSIS
34              
35             =head2 pfopen
36              
37             use File::pfopen 'pfopen';
38             ($fh, $filename) = pfopen('/tmp:/var/tmp:/home/njh/tmp', 'foo', 'txt:bin'));
39             $fh = pfopen('/tmp:/var/tmp:/home/njh/tmp', 'foo'));
40              
41             =cut
42              
43             sub pfopen {
44 13     13 1 3185 my $path = shift;
45 13         24 my $prefix = shift;
46 13         18 my $suffixes = shift;
47              
48 13         17 our $savedpaths;
49              
50 13         20 my $candidate;
51 13 100       28 if(defined($suffixes)) {
52 9         28 $candidate = "$prefix;$path;$suffixes";
53             } else {
54 4         9 $candidate = "$prefix;$path";
55             }
56 13 100       32 if($savedpaths->{$candidate}) {
57             # $self->_log({ message => "remembered $savedpaths->{$candidate}" });
58 3         8 my $rc = $savedpaths->{$candidate};
59 3         85 open(my $fh, '+<', $rc);
60 3 100       13 if(wantarray) {
61 1         5 return ($fh, $rc);
62             }
63 2         7 return $fh;
64             }
65              
66 10         45 foreach my $dir(split(/:/, $path)) {
67 13 50       177 next unless(-d $dir);
68 13 100       177 if($suffixes) {
    100          
69 8         30 foreach my $suffix(split(/:/, $suffixes)) {
70             # $self->_log({ message => "check for file $dir/$prefix.$suffix" });
71 11         98 my $rc = File::Spec->catfile($dir, "$prefix.$suffix");
72 11 100       388 if(-r $rc) {
73 4         15 $savedpaths->{$candidate} = $rc;
74 4         105 open(my $fh, '+<', $rc);
75 4 100       14 if(wantarray) {
76 1         6 return ($fh, $rc);
77             }
78 3         20 return $fh;
79             }
80             }
81             } elsif(-r "$dir/$prefix") {
82 2         21 my $rc = File::Spec->catfile($dir, $prefix);
83 2         7 $savedpaths->{$candidate} = $rc;
84             # $self->_log({ message => "using $rc" });
85 2         51 open(my $fh, '+<', $rc);
86 2 100       7 if(wantarray) {
87 1         5 return ($fh, $rc);
88             }
89 1         12 return $fh;
90             }
91             }
92 4         25 return();
93             }
94              
95             =head1 AUTHOR
96              
97             Nigel Horne, C<< >>
98              
99             =head1 BUGS
100              
101             Please report any bugs or feature requests to C,
102             or through the web interface at
103             L.
104             I will be notified, and then you'll
105             automatically be notified of progress on your bug as I make changes.
106              
107             =head1 SEE ALSO
108              
109             =head1 SUPPORT
110              
111             You can find documentation for this module with the perldoc command.
112              
113             perldoc File::pfopen
114              
115             You can also look for information at:
116              
117             =over 4
118              
119             =item * RT: CPAN's request tracker
120              
121             L
122              
123             =item * AnnoCPAN: Annotated CPAN documentation
124              
125             L
126              
127             =item * CPAN Ratings
128              
129             L
130              
131             =item * Search CPAN
132              
133             L
134              
135             =back
136              
137             =head1 LICENSE AND COPYRIGHT
138              
139             Copyright 2017 Nigel Horne.
140              
141             Usage is subject to licence terms.
142              
143             The licence terms of this software are as follows:
144              
145             * Personal single user, single computer use: GPL2
146             * All other users (including Commercial, Charity, Educational, Government)
147             must apply in writing for a licence for use from Nigel Horne at the
148             above e-mail.
149              
150             =cut
151              
152             1;