File Coverage

lib/File/Valet.pm
Criterion Covered Total %
statement 160 286 55.9
branch 57 148 38.5
condition 19 65 29.2
subroutine 18 22 81.8
pod 9 12 75.0
total 263 533 49.3


line stmt bran cond sub pod time code
1             package File::Valet;
2 20     20   1962277 use 5.010;
  20         236  
3 20     20   80 use strict;
  20         21  
  20         319  
4 20     20   65 use warnings;
  20         39  
  20         386  
5 20     20   63 use Config; # Provides OS-portable means of determining platform type
  20         20  
  20         611  
6 20     20   7714 use POSIX;
  20         101295  
  20         81  
7 20     20   44327 use File::Basename qw(fileparse);
  20         38  
  20         1310  
8 20     20   7884 use File::Copy;
  20         36896  
  20         975  
9 20     20   358 use vars qw(@EXPORT @EXPORT_OK @ISA $VERSION);
  20         20  
  20         1443  
10              
11             BEGIN {
12 20     20   102 require Exporter;
13 20         386 @ISA = qw(Exporter);
14 20         178 $VERSION = '1.10';
15 20         54620 @EXPORT = @EXPORT_OK = qw(rd_f wr_f ap_f find_home find_temp find_bin lockafile unlockafile unlock_all_the_files);
16             }
17              
18             our $OK = 'OK'; # one of "OK", "WARNING" or "ERROR", reflecting most recently performed operation
19             our $ERROR = ''; # short invariant description of error, or empty string if none
20             our $ERRNO = ''; # variant description of error (such as $!), or empty string if none
21             our $ERRNUM = 0; # numerical variant description of error (such as $!), or empty string if none, undocumented, only used for unit tests
22             our %LOCKS_HASH; # keys on lockfile to bind count, for supporting nested locks.
23              
24             # File::Copy::move() almost doest the right thing, just needs syscopy() as failover instead of copy().
25             # This _rename() function more or less duplicates the needed functionality of File::Copy::_move's logic after the rename,
26             # but uses syscopy() and captures failures in $OK, $ERROR, $ERRNO, $ERRNUM.
27             sub _rename {
28 0     0   0 my ($from, $to) = @_;
29              
30 0         0 ($OK, $ERROR, $ERRNO, $ERRNUM) = ('OK', '', '', 0);
31 0 0       0 return 'OK' if (rename ($from, $to));
32              
33 0         0 my $result = File::Copy::syscopy($from, $to);
34 0 0       0 unless ($result) {
35 0         0 ($OK, $ERROR, $ERRNO, $ERRNUM) = ('ERROR', 'File::Copy::syscopy failed', $!, 0+$!);
36 0         0 return undef;
37             }
38              
39 0         0 my @st = stat($from);
40 0 0       0 unless (@st) {
41 0         0 ($OK, $ERROR, $ERRNO, $ERRNUM) = ('ERROR', 'after-copy stat failed', $!, 0+$!);
42 0         0 return undef;
43             }
44              
45 0         0 my ($atime, $mtime) = (@st)[8,9];
46 0 0       0 unless (utime($atime, $mtime, $to)) {
47 0         0 ($OK, $ERROR, $ERRNO, $ERRNUM) = ('ERROR', 'after-copy utime failed', $!, 0+$!);
48 0         0 return undef;
49             }
50              
51 0 0       0 unless (unlink($from)) {
52 0         0 ($OK, $ERROR, $ERRNO, $ERRNUM) = ('ERROR', 'after-copy unlink failed', $!, 0+$!);
53 0         0 return undef;
54             }
55 0         0 return 'OK';
56             }
57              
58             sub rename_vms {
59 0     0 0 0 my ($fn, $dest) = @_;
60 0 0 0     0 if (!defined($fn) || ($fn eq '')) {
61 0         0 ($OK, $ERROR, $ERRNO, $ERRNUM) = ('ERROR', 'no filename supplied', -1, 0);
62 0         0 return undef;
63             }
64 0 0 0     0 if (!defined($dest) || ($dest eq '')) {
65 0         0 ($OK, $ERROR, $ERRNO, $ERRNUM) = ('ERROR', 'no destination directory supplied', -1, 0);
66 0         0 return undef;
67             }
68 0         0 my $dest_fn = $fn;
69 0 0       0 if (!-d $dest) {
70 0         0 ($dest, $dest_fn) = fileparse($dest);
71             }
72 0 0       0 if (!-e $dest) {
73 0         0 ($OK, $ERROR, $ERRNO, $ERRNUM) = ('ERROR', 'destination directory does not exist', -1, 0);
74 0         0 return undef;
75             }
76 0 0       0 if (!-d _) {
77 0         0 ($OK, $ERROR, $ERRNO, $ERRNUM) = ('ERROR', 'destination directory is not a directory', -1, 0);
78 0         0 return undef;
79             }
80 0 0       0 if (!-w _) {
81 0         0 ($OK, $ERROR, $ERRNO, $ERRNUM) = ('ERROR', 'destination directory is not writable', -1, 0);
82 0         0 return undef;
83             }
84              
85 0 0       0 if (!-e "$dest/$dest_fn") {
86             # degenerate case; just rename it.
87 0         0 return _rename($fn, "$dest/$dest_fn");
88             }
89              
90 0         0 my $i = 1;
91 0         0 $i++ while(-e "$dest/$dest_fn.$i");
92 0         0 return _rename($fn, "$dest/$dest_fn.$i");
93             }
94              
95             sub rd_f {
96 118     118 1 14730 my ($fn) = @_;
97 118         277 my ($fh, $buf);
98 118 100 100     913 if (!defined($fn) || ($fn eq '')) {
99 2         5 ($OK, $ERROR, $ERRNO, $ERRNUM) = ('ERROR', 'no filename supplied', -1, 0);
100 2         4 return undef;
101             }
102 116         585 $! = 0;
103 116 100       4157 unless (open($fh, '< :raw', $fn)) {
104 27         1028 ($OK, $ERROR, $ERRNO, $ERRNUM) = ('ERROR', "cannot open for reading", $!, 0+$!);
105 27         201 return undef;
106             }
107 89         305 binmode($fh);
108 89         929 my $file_size = (stat($fn))[7];
109 89 100       627 if ($file_size) {
110 79         932 my $n_bytes = sysread($fh, $buf, $file_size);
111 79 50       494 if (!defined($n_bytes)) {
    50          
112 0         0 ($OK, $ERROR, $ERRNO, $ERRNUM) = ('ERROR', 'read failed', $!, 0+$!);
113 0         0 return undef;
114             }
115             elsif ($n_bytes != $file_size) {
116 0         0 ($OK, $ERROR, $ERRNO, $ERRNUM) = ('ERROR', 'read underflow', $!, 0+$!);
117 0         0 return undef;
118             }
119             }
120             else {
121 10         353 my $res = sysread($fh, $buf, 0x7FFFFFFF);
122 10 50       148 if (!defined $res) {
123 0         0 ($OK, $ERROR, $ERRNO, $ERRNUM) = ('ERROR', 'read failed', $!, 0+$!);
124 0         0 return undef;
125             }
126             }
127 89         1346 my $res = close($fh);
128 89 50       394 unless ($res) {
129 0         0 ($OK, $ERROR, $ERRNO, $ERRNUM) = ('WARNING', 'close failed', $!, 0+$!);
130 0         0 return undef;
131             }
132 89         571 ($OK, $ERROR, $ERRNO, $ERRNUM) = ('OK', '', '', 0);
133 89         466 return $buf;
134             }
135              
136             sub wr_f {
137 5     5 1 1942 my ($fn, $buf) = @_;
138 5         6 my $fh;
139 5 100 100     20 if (!defined($fn) || ($fn eq '')) {
140 3         5 ($OK, $ERROR, $ERRNO, $ERRNUM) = ('ERROR', 'no filename supplied', -1, 0);
141 3         8 return undef;
142             }
143 2         3 $! = 0;
144 2 50       121 unless (open($fh, '> :raw', $fn)) {
145 0         0 ($OK, $ERROR, $ERRNO, $ERRNUM) = ('ERROR', "cannot open for writing", $!, 0+$!);
146 0         0 return undef;
147             }
148 2         6 binmode($fh);
149 2         67 my $res = syswrite($fh, $buf);
150 2 50       8 unless (defined $res) {
151 0         0 ($OK, $ERROR, $ERRNO, $ERRNUM) = ('ERROR', 'write error', $!, 0+$!);
152 0         0 return undef;
153             }
154 2         103 $res = close($fh);
155 2 50       8 unless ($res) {
156 0         0 ($OK, $ERROR, $ERRNO, $ERRNUM) = ('WARNING', 'close failed', $!, 0+$!);
157 0         0 return undef;
158             }
159 2         5 ($OK, $ERROR, $ERRNO, $ERRNUM) = ('OK', '', '', 0);
160 2         8 return 'OK';
161             }
162              
163             sub ap_f {
164 1604     1604 1 33911 my ($fn, $buf) = @_;
165 1604         1954 my $fh;
166 1604 100 100     8471 if (!defined($fn) || ($fn eq '')) {
167 2         4 ($OK, $ERROR, $ERRNO, $ERRNUM) = ('ERROR', 'no filename supplied', -1, 0);
168 2         4 return undef;
169             }
170 1602         3756 $! = 0;
171 1602 50       60308 unless (open($fh, '>> :raw', $fn)) {
172 0         0 ($OK, $ERROR, $ERRNO, $ERRNUM) = ('ERROR', "cannot open for appending", $!, 0+$!);
173 0         0 return undef;
174             }
175 1602         5376 binmode($fh);
176 1602         50088 my $res = syswrite($fh, $buf);
177 1602 50       5539 unless (defined $res) {
178 0         0 ($OK, $ERROR, $ERRNO, $ERRNUM) = ('ERROR', 'write error', $!, 0+$!);
179 0         0 return undef;
180             }
181 1602         14359 $res = close($fh);
182 1602 50       4339 unless ($res) {
183 0         0 ($OK, $ERROR, $ERRNO, $ERRNUM) = ('WARNING', 'close failed', $!, 0+$!);
184 0         0 return undef;
185             }
186 1602         4270 ($OK, $ERROR, $ERRNO, $ERRNUM) = ('OK', '', '', 0);
187 1602         8321 return 'OK';
188             }
189              
190             sub detect_windows {
191 62 50 33 62 0 1042 return ($^O eq 'MSWin32' || $Config{'osname'} =~ /windows/i || $Config{'osname'} =~ /winserver/i || $Config{'osname'} =~ /microsoft/i) ? 1 : 0;
192             }
193              
194             sub find_home {
195 42     42 1 244 for my $d (@_) {
196 0 0 0     0 return $d if (defined $d && -d $d && -w _);
      0        
197             }
198              
199 42         65 my $is_windows = detect_windows;
200 42         134 ($OK, $ERROR, $ERRNO, $ERRNUM) = ('OK', '', '', 0);
201              
202 42         98 my $env_home = $ENV{HOME};
203 42 50 33     633 return $env_home if (defined $env_home && -d $env_home);
204              
205 0   0     0 my $username = $ENV{USER} // $ENV{USERNAME};
206 0 0       0 if ($is_windows) {
207 0   0     0 my $home_drive = $ENV{HOMEDRIVE} // 'C:';
208 0         0 my $home_path = $ENV{HOMEPATH};
209 0 0       0 if (defined $home_path) {
    0          
210 0         0 $env_home = $home_drive . $home_path;
211             }
212             elsif (defined $username) {
213 0         0 $env_home = $home_drive . '\\Users\\' . $username;
214             }
215 0 0 0     0 return $env_home if (defined $env_home && -d $env_home);
216             } else {
217 0         0 my @row = getpwuid($<);
218 0 0       0 if (@row >= 9) {
219 0         0 my $home_dir = $row[7];
220 0 0 0     0 return $home_dir if (defined $home_dir && -d $home_dir);
221             }
222 0 0 0     0 return '/root' if (-d '/root' && -w '/root');
223             }
224              
225 0         0 ($OK, $ERROR, $ERRNO, $ERRNUM) = ('WARNING', 'cannot find home directory', $is_windows, 1);
226 0         0 return undef;
227             }
228              
229             sub find_temp {
230 20     20 1 2201 my $is_windows = detect_windows;
231 20         59 my $dir_sep_tok = '/';
232 20         220 my $home_dir = find_home;
233              
234 20 50       98 push(@_, $ENV{TEMPDIR}) if (defined($ENV{TEMPDIR}));
235 20 50       77 push(@_, $ENV{TEMP}) if (defined($ENV{TEMP}));
236 20 50       59 push(@_, $ENV{TMP}) if (defined($ENV{TMP})); # set in Windows sometimes
237              
238 20 50       57 if ($is_windows) {
239 0         0 $dir_sep_tok = '\\';
240 0         0 push(@_, 'C:\\Windows\\Temp');
241 0         0 push(@_, 'D:\\Windows\\Temp');
242 0         0 foreach my $vol (qw(C D E F G W X Y Z)) {
243 0         0 push(@_, "$vol:\\Temp");
244             }
245             }
246             # might be CygWin, so adding these regardless of OS:
247 20         39 push(@_, qw (/var/tmp /tmp));
248              
249 20 50       94 push(@_, map {join($dir_sep_tok,("$home_dir",$_))} qw(.tmp .temp tmp temp), $home_dir) if (defined($home_dir));
  100         218  
250 20 50       82 push(@_, map {join($dir_sep_tok,("$ENV{PWD}", $_))} qw(.tmp .temp tmp temp), $ENV{PWD} ) if (defined($ENV{PWD} ));
  100         235  
251 20 50       62 push(@_, '/dev/shm') unless ($is_windows); # Lowest priority, since this is typically a ramdisk.
252 20         57 foreach my $d (@_) {
253 20 50       264 next unless (-d $d);
254 20         78 ($OK, $ERROR, $ERRNO, $ERRNUM) = ('OK', '', '', 0);
255 20 50       183 return $d if (-w _);
256             }
257 0         0 ($OK, $ERROR, $ERRNO, $ERRNUM) = ('WARNING', 'no appropriate temporary directory found', '', 0);
258 0         0 return undef;
259             }
260              
261             sub find_bin {
262 21 50   21 1 2062 return find_bin_win32 (@_) if ($Config::Config{osname} =~ /MSWin/);
263 21         46 my ($bin_name, @bin_dirs) = @_;
264 21         42 my $home_dir = find_home;
265 21 50       184 push(@bin_dirs, split(/\:/, $ENV{PATH})) if (defined($ENV{PATH}));
266 21 50       98 push(@bin_dirs, "$home_dir/bin") if (defined($home_dir));
267 21         78 push(@bin_dirs, ('/usr/local/sbin', '/usr/local/bin', '/sbin', '/bin', '/usr/sbin', '/usr/bin'));
268 21         40 my %been_there = ();
269 21         39 foreach my $d (@bin_dirs) {
270 168 100       333 next if (defined($been_there{$d}));
271 147         204 $been_there{$d} = 1;
272 147         359 my $f = "$d/$bin_name";
273 147 100       1819 next unless (-x $f);
274 21         98 ($OK, $ERROR, $ERRNO, $ERRNUM) = ('OK', '', '', 0);
275 21         150 return $f;
276             }
277 0         0 ($OK, $ERROR, $ERRNO, $ERRNUM) = ('WARNING', 'no executable found', '', 0);
278 0         0 return undef;
279             }
280              
281             sub find_bin_win32 {
282 0     0 0 0 my ($bin_name, @bin_dirs) = @_;
283 0 0       0 push(@bin_dirs, split(/\;/, $ENV{PATH})) if (defined($ENV{PATH}));
284 0         0 push(@bin_dirs, ('C:\\WINDOWS\\system32', 'C:\\WINDOWS'));
285 0         0 my %been_there = ();
286 0         0 foreach my $d (@bin_dirs) {
287 0 0       0 next if (defined($been_there{$d}));
288 0         0 $been_there{$d} = 1;
289 0         0 my $f = "$d\\$bin_name";
290 0 0       0 next unless (-x $f);
291 0         0 ($OK, $ERROR, $ERRNO, $ERRNUM) = ('OK', '', '', 0);
292 0         0 return $f;
293             }
294 0         0 ($OK, $ERROR, $ERRNO, $ERRNUM) = ('WARNING', 'no executable found', '', 0);
295 0         0 return undef;
296             }
297              
298             # returns 1 on great success, 0 on miserable failure
299             sub lockafile {
300 1600     1600 1 16238292 my ($f, %opt) = @_;
301 1600 50 33     9650 $opt{nsec} = 30 unless (defined($opt{nsec}) && int($opt{nsec}) > 0); # Number of seconds we expect to have the file locked. If we hold the lock for longer than this, other processes are welcome to kill us and take the lock themselves.
302 1600 50 33     6594 $opt{msg} = "programmer is lame" unless (defined($opt{msg}) && $opt{msg} ne ''); # Helpful message for the human to understand wtf this lock is about
303 1600 50 33     5615 $opt{limit} = 30 unless (defined($opt{limit}) && int($opt{limit}) > 0); # Number of seconds caller is willing to wait for a lock before failing out.
304 1600 50 33     4251 $opt{sleep_duration} = 0.25 unless (defined($opt{sleep_duration}) && $opt{sleep_duration} > 0.0);
305 1600   33     8986 my $lockfile_name = $opt{lockfile_name} || "$f.lock";
306 1600         2950 my $tm_start = time();
307 1600         1807 my $lockfile_fh;
308              
309             # TODO - This is fast and simple, but fails to handle expired lockfiles and extending lockfile durations.
310 1600 50       5000 if ($LOCKS_HASH{$f}) {
311 0         0 $LOCKS_HASH{$f}++;
312 0         0 return 1;
313             }
314              
315 1600         143329 while (!sysopen($lockfile_fh, $lockfile_name, &O_RDWR | &O_CREAT | &O_EXCL)) {
316 113 100       2265 if (-e $lockfile_name) {
317             # re-scanning after every sleep(), because it could expire while we are sleeping and someone else might grab it while we are sleeping.
318 109         572 my $mtime = (stat(_))[9];
319 109         765 my $txt = File::Valet::rd_f($lockfile_name);
320              
321 109 100       437 if (!defined($txt)) { # handling potential race condition or naughty unreadable lockfile
322 26 50       166 if ((time() - $tm_start) > $opt{limit}) {
323 0         0 ($OK, $ERROR, $ERRNO, $ERRNUM) = ('WARNING', 'lockfile racy or unreadable', $lockfile_name, 0);
324 0         0 return 0;
325             }
326 26         6508640 select(undef, undef, undef, $opt{sleep_duration});
327 26         2306 next;
328             }
329              
330 83         227 chomp($txt);
331 83 50       1132 if ($txt =~ /^\d+\t/) {
332 83         640 my ($pid, $lock_duration, $message, $whence) = split(/\t/, $txt);
333 83 50       208 $lock_duration = 30 unless (defined($lock_duration));
334 83         1188 my $locking_process_still_lives = kill(0, $pid);
335             # TODO - Potential race condition; another process might acquire the expired lock after this second stat() and before unlink().
336             # Perhaps use senate? Slow in filesystem, but could use shm on systems which support SysV shared memory.
337 83 50 33     909 unlink($lockfile_name) if ((time() > $mtime + $lock_duration) || ($locking_process_still_lives < 1));
338             }
339             }
340              
341 87 50       463 if ((time() - $tm_start) > $opt{limit}) {
342 0         0 ($OK, $ERROR, $ERRNO, $ERRNUM) = ('OK', '', '', 0); # Not an error; simply unable to acquire lock within specified duration
343 0         0 return 0;
344             }
345              
346 87         21791139 select(undef, undef, undef, $opt{sleep_duration});
347             }
348 1600         18601 my $msg = sprintf("\%d\t\%d\t%s\t%s\n", $$, $opt{nsec}, $opt{msg}, $0); # populating lockfile with information about locking process
349 1600         48502 syswrite($lockfile_fh, $msg);
350 1600         19434 close($lockfile_fh);
351 1600         4539 $LOCKS_HASH{$f} = 1;
352 1600         5756 ($OK, $ERROR, $ERRNO, $ERRNUM) = ('OK', '', '', 0);
353 1600         11040 return 1;
354             }
355              
356             sub unlockafile {
357 1600     1600 1 15539 my ($f, %opt) = @_;
358 1600         2357 my $lockfile_fh;
359             my $dgram;
360 1600   33     7192 my $lockfile_name = $opt{lockfile_name} || "$f.lock";
361 1600         3560 ($OK, $ERROR, $ERRNO, $ERRNUM) = ('OK', '', '', 0);
362              
363             # TODO - This is fast and simple, but fails to handle expired lockfiles
364 1600 50       3589 if ($LOCKS_HASH{$f}) {
365 1600         2270 $LOCKS_HASH{$f}--;
366 1600 50       3831 return 1 if ($LOCKS_HASH{$f} > 0);
367             }
368 1600         2946 $! = 0;
369 1600 50       48317 unless (sysopen($lockfile_fh, $lockfile_name, &O_RDONLY)) {
370 0         0 ($OK, $ERROR, $ERRNO, $ERRNUM) = ('ERROR', 'open failure', $!, 0+$!);
371 0         0 return 0;
372             }
373 1600 50       19226 unless(my $result = sysread($lockfile_fh, $dgram, 4095)) {
374 0 0       0 if (defined($result)) {
375 0         0 ($OK, $ERROR, $ERRNO, $ERRNUM) = ('ERROR', 'read zero bytes from lockfile', '', 0+$!);
376             } else {
377 0         0 ($OK, $ERROR, $ERRNO, $ERRNUM) = ('ERROR', 'read error', $!, 0+$!);
378             }
379 0         0 return 0;
380             }
381 1600         3706 chomp($dgram);
382 1600         7701 my ($lpid, $nsec, $msg, $whence) = split(/\t/, $dgram);
383 1600         12493 close($lockfile_fh);
384 1600         3821 $LOCKS_HASH{$f} = 0;
385 1600 50 33     8699 if (defined($lpid) && ($lpid ne $$)) {
386             # oops! not ours anymore
387 0         0 ($OK, $ERROR, $ERRNO, $ERRNUM) = ('ERROR', 'lost lock', $dgram, 0+$!);
388 0         0 return 0;
389             }
390 1600         71714 unlink($lockfile_name);
391 1600         11000 return 1;
392             }
393              
394             sub unlock_all_the_files {
395             # Best effort only .. eh, make that "some effort only".
396             # That might still be overly charitable.
397             # Truth be told, you're only using this function if you can't be assed to fix the bugs in your own code,
398             # which relieves me somewhat of any moral imperative.
399 0     0 1   my $n_locks = 0;
400 0           my $n_files = 0;
401 0           my $n_errors = 0;
402 0           foreach my $f (keys %LOCKS_HASH) {
403 0 0         next unless ($LOCKS_HASH{$f});
404 0           $n_locks += $LOCKS_HASH{$f};
405 0           $LOCKS_HASH{$f} = 0;
406 0           unlockafile($f);
407 0 0         $n_errors++ unless ($OK eq 'OK');
408 0           $n_files++;
409             }
410 0           return ($n_errors, $n_locks, $n_files);
411             }
412              
413             1;
414              
415             =head1 NAME
416              
417             File::Valet - Utilities for file slurping, locking, and finding.
418              
419             =head1 SYNOPSIS
420              
421             use File::Valet;
422              
423             # Simple slurp and unslurp with rd_f, wr_f, ap_f:
424              
425             my $text = rd_f('some/file.txt');
426             die "slurp failure: $File::Valet::ERROR ($File::Valet::ERRNO)" unless ($File::Valet::OK eq 'OK');
427             # or, equivalently:
428             die "slurp failure: $File::Valet::ERROR ($File::Valet::ERRNO)" unless (defined($text));
429              
430             # Contents written will be same as that of "some/file.txt",
431             # plus two lines appended at the end:
432              
433             wr_f('another/file.txt', $text);
434             ap_f('another/file.txt', "Oh, and another thing:\n");
435             ap_f('another/file.txt', "STOP BREATHING IN MY CUP\n");
436              
437             # Find a place suited to temporary files:
438             my $tmp = find_temp(); # Likely /var/tmp or /tmp or C:\Windows\Temp
439              
440             # Find the full pathname of an executable:
441             my $shell = find_bin('sh'); # Likely /bin/sh
442              
443             # Use a lockfile for exclusive access to a shared resource:
444             lockafile("$tmp/shared.txt") or die "cannot obtain lock: $File::Valet::ERROR ($File::Valet::ERRNO)";
445             my $text = rd_f("$tmp/shared.txt");
446             unlockafile("$tmp/shared.txt") or die "unlock error: $File::Valet::ERROR ($File::Valet::ERRNO)";
447              
448             # Nested file locking:
449             lockafile("shared.txt") or die "cannot obtain first lock";
450             my $text = rd_f("$tmp/shared.txt");
451             ...
452             lockafile("shared.txt") or die "cannot obtain second lock";
453             ap_f("$tmp/shared.txt", $data);
454             unlockafile("$tmp/shared.txt");
455             ...
456             unlockafile("$tmp/shared.txt");
457              
458             # Your code has bugs, resulting in leaving lockfiles behind, but
459             # instead of debugging you'd rather just remove all your locks:
460             my ($n_errors, $n_locks, $n_files) = unlock_all_the_files();
461              
462             =head1 DESCRIPTION
463              
464             B contains a selection of easy-to-use subroutines for manipulating files and file content. Some effort has been made to establish cross-platform portability, and to make their behavior as unsurprising as possible.
465              
466             =head1 FUNCTIONS
467              
468             The following functions are available through this module for use in other applications. In keeping with the intent of minimizing user keystrokes, all of these functions are exported into the calling namespace.
469              
470             =over 4
471              
472             =item B
473              
474             my $string = rd_f($filename);
475              
476             C is similar to the well-known C, in that it reads the entire contents of the named file and returns it as a string. Its principle differences are a slightly shorter name and the insertion of diagnostic information into C<$File::Valet::OK>, C<$File::Valet::ERROR>, C<$File::Valet::ERRNO> when the operation failed to complete.
477              
478             The return value is either the contents of the file B (an empty string if the file had no contents), or undef on any error.
479              
480             =item B
481              
482             my $success = wr_f($filename, $string);
483              
484             C is conceptually the opposite of C, in that it overwrites the named file's contents with the given B.
485              
486             If the specified file does not exist, C will attempt to create it.
487              
488             Returns 1 on success, or 0 on any failure, and sets C<$File::Valet::OK>, C<$File::Valet::ERROR>, C<$File::Valet::ERRNO> appropriately.
489              
490             =item B
491              
492             my $success = ap_f($filename, $string);
493              
494             C is similar to C, differing in that the specified B is appended to the end of the file, rather than overwriting it.
495              
496             If the specified file does not exist, C will attempt to create it.
497              
498             Returns 1 on success, or 0 on any failure, and sets C<$File::Valet::OK>, C<$File::Valet::ERROR>, C<$File::Valet::ERRNO> appropriately.
499              
500             =item B
501              
502             my $path = find_home;
503             my $path = find_temp("/var/home", "/tmp/home");
504              
505             C performs a best-effort search for the effective user's home, returning a path-string or undef if none is found.
506              
507             If arguments are provided, it will return the first argument for which there is a directory for which the user has write permissions.
508              
509             if C<$ENV{HOME}> is set, C will check there for a writable directory after checking any arguments.
510              
511             Some effort has been made to make it cross-platform.
512              
513             =item B
514              
515             my $path = find_temp();
516             my $path = find_temp("/home/tmp", "/usr/tmp", ...);
517              
518             Intended for easy cross-platform programming, C checks in a number of likely, common filesystem locations for a valid directory for temporary files. It returns the first directory it finds for which the user has write permissions, or undef if none is found.
519              
520             If parameters are passed to C, it will check those locations first.
521              
522             If C<$ENV{TEMPDIR}>, C<$ENV{TEMP}> or C<$ENV{TMP}> are defined, C will check those locations after checking the locations provided as parameters.
523              
524             C is Windows-savvy enough to check such locations as "C:\Windows\Temp", but might try to open locations on network-mounted drives if it is unable to find a local alternative.
525              
526             =item B
527              
528             my $path = find_home();
529             my $path = find_home("/var/home/fred");
530              
531             Another function intended for easy cross-platform programming, C will first check $ENV{HOME} on *nix or $ENV{HOMEDIRVE} and $ENV{HOMEPATH (on Windows) if defined, then in the system's passwd database, and then in a number of other likely locations, for a writable home directory for the effective user.
532              
533             It will return the full absolute path of the home directory on success, or undef on failure.
534              
535             =item B
536              
537             my $pathname = find_bin("ls");
538             my $pathname = find_bin("ls", "/home/ttk/bin", "/opt/bin", ...);
539              
540             Another function intended for easy cross-platform programming, C will first check all of the directories in $ENV{PATH} (if defined), and then in a number of other likely, common locations, for an executable file whose name matches the first parameter. It will return the full absolute pathname of the executable file on success, or undef on failure.
541              
542             C is Windows-savvy, albeit does not search Windows systems as extensively as others.
543              
544             If directory paths are given as additional parameters, C will check those locations first.
545              
546             C is smart enough to only check any given directory once, even if it appears in the parameter list as well as in $ENV{PATH}, or appears multiple times in either.
547              
548             C also sets C<$File::Valet::OK>, C<$File::Valet::ERROR>, C<$File::Valet::ERRNO> appropriately.
549              
550             =item B
551              
552             my $success = lockafile("/tmp/foo", %options);
553             my $success = lockafile("/tmp/foo",
554             limit => 2.0, # keep retrying for 2.0 seconds before giving up
555             msg => 'in-channel update', # helpful message for troubleshooting
556             nsec => 0.5, # we expect to hold the lock for less than 0.5 seconds
557             );
558              
559             C applies an advisory lock on the named file, and attempts to be somewhat clever about it, automatically invalidating existing locks set by processes which no longer exist. or set a very long time ago.
560              
561             If the file is already locked by another process, C will linger and attempt to acquire the lock when the owner of the lock releases the file. This linger time defaults to thirty seconds, and may be overridden with the C parameter.
562              
563             The advisory lock takes the form of a file, which may be manually deleted to remove the lock, or may be inspected to learn something about the process which created the lock. To facilitate this, a message may be embedded in the lock file describing the reason the file is being locked. It defaults to "programmer is lazy", and may be set by passing the C parameter.
564              
565             Advisory locks will be respected by other invocations of C for up to some time before being assumed stale and forceably removed. This period may be increased by passing the C parameter (which becomes embedded in the lockfile).
566              
567             C attempts to manage nested advisory locks via C<%File::Valet::LOCKS_HASH>. C will keep track of which files the caller has locked, and how many times. Thus if the caller locks the same file two or more times, and unlocks it an equal number of times, the lock file will only be created on the first invocation of C, and removed only on the last invocation of C. See B for caveats regarding this.
568              
569             Returns 1 on success, or 0 on any failure, and sets C<$File::Valet::OK>, C<$File::Valet::ERROR>, C<$File::Valet::ERRNO> appropriately.
570              
571             =item B
572              
573             my $success = unlockafile("/tmp/foo", %options);
574              
575             C reverses the action of C, removing an advisory lock on a file (or reducing the count of locks on a multiply-locked file).
576              
577             C will fail if invoked on a file which is not locked, or has been locked by a different process.
578              
579             C returns 1 on success, and 0 on any failure, and sets C<$File::Valet::OK>, C<$File::Valet::ERROR>, C<$File::Valet::ERRNO> appropriately.
580              
581             =item B
582              
583             C is a convenience wrapper for walking C<%File::Valet::LOCKS_HASH> and safely removing all lockfiles.
584              
585             If your code has bugs which cause it to leave lockfiles behind, then calling C before exiting will help prevent that.
586              
587             Really, though, you should fix your bugs.
588              
589             Returns three values: A count of errors returned by C, a count of locks removed, and a count of lock files removed.
590              
591             The number of locks can differ from the number of lock files when locks are nested. A file which is locked twice counts as two locks but has only one lock file.
592              
593             =item B
594              
595             The lockfiles contain useful bits of information which help C figure out if it should override someone else's lock, and is also useful for gaining insight about the system's behavior, for troubleshooting purposes.
596              
597             Its fields are tab-delimited, and the file terminates with a newline. They appear in this order:
598              
599             * Process identifier of the process which created the lockfile (per "$$"),
600             * The number of seconds the lock should be considered valid (per "nsec" parameter),
601             * The helpful message provided by the programmer (per "msg" parameter),
602             * The name of the program which created the lockfile (per "$0")
603              
604             Example:
605              
606             "4873\t2.0\tThe programmer is lame\t/opt/simon/bin/simond\n"
607              
608             These fields may change in future versions of this module.
609              
610             =item B
611              
612             A recursive descent function similar to L is planned, since C is pretty horrible and unusable.
613              
614             The C implementation goes through considerable effort to avoid race conditions, but there is still a very short danger window where an overridden lock might get double-clobbered. If a contended lock expires just when two or more other processes call C on it, it is possible for one process to unlink the lock file, the other process to create a new lock file, and then the first process to overwrite that lock file with its own lock file, leaving both processes under the impression they have acquired the lock. Future implementations may remedy this. In the meantime the possibility can be avoided by setting a sufficiently large "nsec" value when acquiring a lock that it will not expire before the owning process is ready to release it.
615              
616             The nested lock management C and C implement is flawed, in that the lock on the file is only valid for as long specified by the first invocation of C. Thus if a file is locked for 3 seconds, and then subsequently locked for 30 seconds, other processes contending for the locked file will forceably acquire the lock after 3 seconds after the first lock, not 30 seconds after the second lock. Future implementations may overwrite the lockfile to reflect the parameters of subsequent (nested) locks.
617              
618             The file-slurping functions handle data explicitly as B and never as codepoints. This is intentional and unlikely to change. If codepoint handling (utf-8, utf-16, etc) is desired, see L.
619              
620             =item B
621              
622             L is considered the likely successor to C for CPAN's primary file-slurping implementation, with proper handling of multibyte-encoded characters (L in C). If C implemented an appending method, the slurp functions would likely be absent from C. Until then, C's slurping functions provide a simple, robust alternative.
623              
624             L - a different style for file handling, which some people might prefer.
625              
626             L - returns name and handle of a temporary file.
627              
628             L - searches an environment path for a file.
629              
630             L - file locker with an automatic out-of-scope unlocking mechanism.
631              
632             L - file locker with timeout, but no lock expiration.
633              
634             L - file locker with support for nested locks.
635              
636             L - a very easy to use file locker.
637              
638             L - a gaggle of useful functions, including a simple slurp().
639              
640             =back
641              
642             =head1 AUTHOR
643              
644             TTK Ciar
645              
646             =head1 LICENSE
647              
648             You can use and distribute this module under the same terms as Perl itself.
649              
650             =cut