File Coverage

blib/lib/File/pfopen.pm
Criterion Covered Total %
statement 25 26 96.1
branch 19 20 95.0
condition 2 2 100.0
subroutine 4 4 100.0
pod 1 1 100.0
total 51 53 96.2


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-2024 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   523692 use strict;
  2         4  
  2         72  
14 2     2   9 use warnings;
  2         3  
  2         109  
15 2     2   9 use File::Spec;
  2         4  
  2         854  
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.03
28              
29             =cut
30              
31             our $VERSION = '0.03';
32              
33             =head1 SUBROUTINES/METHODS
34              
35             =head2 pfopen
36              
37             Look in a list of directories for a file with an optional list of suffixes.
38              
39             use File::pfopen 'pfopen';
40             ($fh, $filename) = pfopen('/tmp:/var/tmp:/home/njh/tmp', 'foo', 'txt:bin');
41             $fh = pfopen('/tmp:/var/tmp:/home/njh/tmp', 'foo', '<');
42              
43             If mode (argument 4) isn't given, the file is open read/write ('+<')
44              
45             =cut
46              
47             sub pfopen
48             {
49 24     24 1 8855 my ($path, $prefix, $suffixes, $mode) = @_;
50 24 100       67 my $candidate = defined($suffixes) ? "$prefix;$path;$suffixes" : "$prefix;$path";
51 24         26 our $savedpaths;
52              
53 24   100     125 $mode ||= '+<'; # defaults to opening RW
54              
55             # Return cached filename if available
56 24 100       64 if(my $rc = $savedpaths->{$candidate}) {
57             # $self->_log({ message => "remembered $savedpaths->{$candidate}" });
58 4 50       183 if(open(my $fh, $mode, $rc)) {
59 4 100       38 return wantarray ? ($fh, $rc) : $fh;
60             }
61 0         0 delete $savedpaths->{$candidate}; # Failed to open cached file
62             }
63              
64 20         63 foreach my $dir (split /:/, $path) {
65 27 100       728 next unless -d $dir;
66              
67 24 100       66 foreach my $suffix (defined($suffixes) ? split(/:/, $suffixes) : undef) {
68 28 100       320 my $rc = File::Spec->catfile($dir, defined $suffix ? "$prefix.$suffix" : $prefix);
69 28 100       785 next unless -r $rc;
70              
71             # $self->_log({ message => "using $rc" });
72              
73             # FIXME: Doesn't play well in taint mode
74 13 100       417 open(my $fh, $mode, $rc) or next;
75              
76 12         46 $savedpaths->{$candidate} = $rc;
77 12 100       79 return wantarray ? ($fh, $rc) : $fh;
78             }
79             }
80              
81 8         56 return;
82             }
83              
84              
85             =head1 AUTHOR
86              
87             Nigel Horne, C<< >>
88              
89             =head1 BUGS
90              
91             Doesn't play well in taint mode.
92              
93             Using the colon separator can cause confusion on Windows.
94              
95             Would be better if the mode and suffixes options were the other way around, but it's too late to change that now.
96              
97             Please report any bugs or feature requests to C,
98             or through the web interface at
99             L.
100             I will be notified, and then you'll
101             automatically be notified of progress on your bug as I make changes.
102              
103             =head1 SUPPORT
104              
105             You can find documentation for this module with the perldoc command.
106              
107             perldoc File::pfopen
108              
109             You can also look for information at:
110              
111             =over 4
112              
113             =item * MetaCPAN
114              
115             L
116              
117             =item * RT: CPAN's request tracker
118              
119             L
120              
121             =item * CPANTS
122              
123             L
124              
125             =item * CPAN Testers' Matrix
126              
127             L
128              
129             =item * CPAN Testers Dependencies
130              
131             L
132              
133             =back
134              
135             =head1 LICENSE AND COPYRIGHT
136              
137             Copyright 2017-2024 Nigel Horne.
138              
139             Usage is subject to licence terms.
140              
141             The licence terms of this software are as follows:
142              
143             * Personal single user, single computer use: GPL2
144             * All other users (including Commercial, Charity, Educational, Government)
145             must apply in writing for a licence for use from Nigel Horne at the
146             above e-mail.
147              
148             =cut
149              
150             1;