Codebase list libfile-util-perl / 1a3d965
[svn-inject] Installing original source of libfile-util-perl (3.27) Takaki Taniguchi 13 years ago
20 changed file(s) with 6027 addition(s) and 0 deletion(s). Raw diff Collapse all Expand all
+2
-0
COPYING less more
0 This library is free software, you may redistribute it and/or modify it
1 under the same terms as Perl itself.
+514
-0
Changes less more
0 Revision history for Perl extension File::Util.pm
1
2 2.27
3 Sat Dec 6 13:10:00 CST 2008
4 Fixed a bug that caused root directories using Micro$oft filesystem
5 notation to be mis-read when using the '--dirs-only' flag for
6 File::Util::list_dir()
7
8 3.26
9 Tue Dec 2 20:07:09 CST 2008
10 Added to test suite in order to avoid errant test failures
11 when flock'ing on solaris. This is a big deal, since the point of
12 File::Util is to be easy, and portable!
13
14 Added some yet more extra examples in the documentation.
15
16 3.25
17 Mon Dec 1 15:11:20 CST 2008
18 Fixed a bug in File::Util::touch()
19
20 Added some extra examples and corrected one minor error in the
21 documentation.
22
23 3.24
24 Wed May 23 16:27:20 CDT 2007
25 Added method File::Util::last_changed (get inode change time for a file)
26 Added method File::Util::touch (works like *nix touch command)
27
28 Both touch and last_changed are autoloaded methods
29
30 Applied patch from S. Muskiewicz that fixes the File::Util::last_modified
31 method that was using a similar but incorrect "-" file test operator.
32
33 3.23
34 Fri Feb 15 07:34:29 CST 2008
35 No major code changes. Small bug fixes--
36 Corrected syntax on package makefile that causes warnings to be
37 generated in cases of older Perl versions. Also corrected a problem
38 in the documentation where the section "Get the path preceeding a
39 file name" was showing incorrect information.
40
41 3.22
42 Wed May 23 16:27:20 CDT 2007
43 Fixed windows-specific bugs associated with the handling of newlines
44 and directory path separators. Now compatible with Strawberry Perl
45 and once again Active$tate Perl for MSWin*.
46
47 3.21
48 Mon May 21 18:22:11 CDT 2007
49 Fixed solaris-specific bug in test suite causing a simple regular
50 expression to fail. Previous changes up to this point merit a public
51 release, pending the fixing of afforementioned bug, hence this release.
52
53 3.20_2
54 Mon May 21 16:15:23 CDT 2007
55 Fixed small but important incompatibility with some versions of
56 Exception::Handler
57
58 3.20_1
59 Fri May 18 15:42:01 CDT 2007
60 Improved error handling mechanism even more, and created 31 new test
61 scenarios to make sure that any failure events are handled correctly.
62
63 Fixed some small latent bugs, for example, corrected file handle
64 reference verification error handling--checking for validity of
65 file handle references.
66
67 3.19
68 Wed May 16 18:07:49 CDT 2007
69 Documentation. Documentation. Documentation. Small corrections and
70 several enhancements. More examples.
71
72 Improved error-handling mechanism by adding cascading logic to prioritize
73 fatality-handling rules of failed calls over the rules of the File::Util
74 object, whether they be defaults or manually set up via File::Util::new()
75
76 3.18
77 Tue Feb 27 15:54:51 CST 2007
78 Finished documentation for ALL methods. Whew! That was a lot of
79 writing. The documentation will continue to evolve.
80
81 Implemented the --use-sysopen flag for File::Util::open_handle()
82 and thereafter the following extra open modes for it (only valid if
83 the --use-sysopen flag is used):
84 rwcreate
85 rwupdate
86 rwclobber
87 rwappend
88
89 (See the documentation for more details about this new feature).
90
91 Added new method File::Util::release_open_file() for the purpose
92 of releasing file locks placed on file handles by the
93 File::Util::open_file() method, that is, when file locking is
94 NOT turned off. If file locking is disabled by the user, this new
95 method has no effect.
96
97 3.17_*
98 Fri Feb 23 - Mon Feb 26
99 Developer's releases (testing); not released to the public.
100
101 3.16
102 Tue Feb 20 14:16:45 CST 2007
103 Fixed problem with method File::Util::make_dir() when used with
104 absolute pathnames (path names starting with "/", for example).
105
106 Fixed documentation error concerning the File::Util::list_dir method,
107 specifically regarding the "--pattern" option flag.
108
109 Method File::Util::make_dir() now enforces the policy of failing when
110 asked to create a directory that already exists as a file of any kind.
111 Use the "--if-not-exists" flag if you are counting on the old behavior
112 or if you want to create directories which could possibly exist already.
113
114 More documentation added.
115
116
117 3.15
118 Fri Dec 22 14:12:45 CST 2006
119 Fixed broken test suite that was causing `make test` to fail falsely.
120 Revisited documentation, adding a little, and various small improvements.
121
122 3.14_8
123 Thu Dec 14 20:13:03 CST 2006
124 Fixed some error messages to be more clear. Tweaked the
125 File::Util::readlimit() method to provide better error messages if
126 called incorrectly. Modified File::Util::make_dir() to include
127 the --if-not-exists option.
128
129 More documentation added for various methods whose documentation had
130 yet to be written.
131
132 Fixed a broken test case in "make test" that was causing it to fail
133 falsely.
134
135 Releasing this version as an official release and NOT a developer's
136 release only.
137
138
139 3.14_7
140 Sat Jan 31 13:36:24 CST 2004
141 Changes to method File::Util::flock_rules() to output helpful error
142 message if specification of invalid file locking policy attempted.
143
144 flock_rules parameter for File::Util::new() constructor method no
145 longer accepted or recognized in the interest of speed and efficiency.
146 If you want to change the default flock rules for the File::Util object,
147 then call File::Util::flock_rules() with your desired ruleset as
148 specified in the documentation for this method.
149
150 Changed default max_dives number to 1000. (See documentation for the
151 File::Util::max_dives() method.)
152
153 Much more documentation added for various methods whose documentation
154 had yet to be written.
155
156 3.14_6
157 Mon Sep 22 11:10:46 CDT 2003
158 Changes to methods File::Util::list_dir() and
159 File::Util::escape_filename() increase efficiency and fix some bugs.
160 Both methods retain the same interface and return values in the same
161 manner.
162
163 Added new method File::Util::return_path() (see documentation).
164
165 Method File::Util::last_mod changed to File::Util::last_modified for
166 clarity, better readability, and consistency with other similar methods
167 in the File::Util namespace. (eg- File::Util::last_access, etc)
168
169 Added the following methods to @EXPORT_OK
170 File::Util::return_path()
171 File::Util::created()
172 File::Util::last_access()
173 File::Util::last_modified()
174
175 Much more documentation added. Test suite revisited to reflect changes
176 to the methods mentioned above.
177
178 3.14_2
179 1/14/03, 12:05 am
180 Much more documentation added. Various methods slightly altered to stay
181 in keeping with the docs and with standard conventions. Test suite
182 revisited somewhat.
183
184 3.14_1
185 1/2/03, 3:47 am
186 Added a substantial amount of new documentation. Spelling errors in
187 documentation files corrected.
188
189 Previously available method, File::Util::os(), has been dropped from the
190 namespace and is no longer part of the module.
191
192 Method File::Util::file_type() no longer includes the 'tty' keyword among
193 its list of recognized file types, as the native Perl file test for
194 divining a TTY file can only be used on open file handles.
195
196 The keywords returned by this method are all upper case strings as of
197 version 3.13_9, though the release notes for that version errantly did
198 not include this statement. The list of keywords otherwise remains
199 unchanged:
200 PLAIN TEXT
201 BINARY DIRECTORY
202 SYMLINK PIPE
203 SOCKET BLOCK
204 CHARACTER
205
206 3.14_0
207 12/27/02, 5:50 pm
208
209 File::Util no longer @ISA Handy::Dandy, and no longer includes it
210 as a prerequisite dependency. Added a little more documentation,
211 but it has a _long_ way to go as yet.
212
213 3.13_9
214 12/23/02, 3:22 pm
215
216 A few small changes; no longer lists Handy::Dandy::TimeTools as a
217 prerequisite dependency.
218
219 3.13_8
220 12/22/02, 11:31 pm
221
222 Method File::Util::file_type() now returns a list instead of a single
223 string of concatenated keyword substrings, the file type keywords being:
224 plain text
225 binary directory
226 symlink pipe
227 socket block
228 character tty
229
230 Methods File::Util::load_file() and File::Util::open_handle() both will
231 truly guarantee the uniqueness of the underlying file handle which is
232 auto-generated, whereas before measures to achieve the uniqueness of
233 the file handles were taken, but not verified.
234
235 POD documentation got a big update.
236
237 3.13_7
238 12/6/02, 2:56 pm
239 Almost ready for CPAN!
240
241 License changed from the GNU LGPL to Perl's own licensing scheme.
242
243 Various tweaks to compile-time sequences.
244
245 Previously subroutines, SL and NL are now constants. This makes them
246 easier to use when importing them to your main program. Instead of
247 having to type "print('foo' . NL . NL)", you can type the more intuitive
248 "print('foo' . NL x 2)". The same applies for SL, though it's not likely
249 you'll be wanting to print out more than one SL character in sequence.
250 This shouldn't break previous usage of these exported names.
251
252 Small reference material section appended to the general documentation
253 file contained in 'docs-basic.txt' (part of this distribution)
254
255 3.13_4
256 11/14/02, 1:22 pm
257
258 Got rid of all variables in @EXPORT_OK, namely:
259 $OS
260 $EBCDIC
261 $NL
262 $SL
263
264 I wanted to export only methods, seeing as exporting variables just isn't
265 right, no matter how convenient it might be. There are two new methods,
266 and they are both autoloaded, namely:
267 File::Util::os()
268 File::Util::ebcdic()
269
270 These two methods take no arguments, and return only the value of the
271 previously EXPORT_OK'ed "$OS" and "$EBCDIC"
272
273 Added more thorough testing to distribution tests lineup, and an
274 additional set of tests in an automated "empty subclass test" of the
275 modules native methods and all those it inherits from its ancestral
276 classes.
277
278 More flock() related tweaking in private methods that implement
279 File::Util's automatic, transparent file locking mechanism.
280
281 3.13_3
282 11/13/02, 9:41 pm
283
284 Slightly optimized recursive directory listing features of package method
285 File::Util::list_dir() and moved less-used method File::Util::load_dir()
286 to AUTOLOAD.
287
288 Got rid of stupid method File::Util::EB which was previously
289 used for error bracketing around dynamic values quoted in error messages;
290 this has nothing to do with file handling -the purpose of this module.
291
292 Global vars $AUTOLOAD and $ATL are gone, since moving to the use of Perl's
293 native AUTOLOAD extension from the old autoloading mechanism.
294
295 Added/removed functionality tests in the distribution installer according
296 to these changes.
297
298 3.13_1
299 11/13/02, 1:40 am
300
301 Fixed problem that caused File::Util to not recognize its set flock
302 usage policy, and flock failthrough rule set when either was manually
303 set during runtime. Added more flock tests to distribution test scripts.
304
305 3.13_1
306 11/4/02, 12:28 pm
307
308 Further preparations made to ready the module for PAUSE upload.
309
310 3.13_0
311 Method 'list_dir()' now recognizes a new option, '--ignore-case'. When
312 this option is included among the other arguments you pass in, the list
313 of items returned will be sorted alphabetically from A to Z without
314 respect to character case.
315
316 Accordingly, when the '--ignore-case' option is used the contents of
317 a directory that would normally appear ordered like the items in
318 Example A would instead appear ordered like the items in the order of
319 Example B.
320
321 Example A. (default list order of directory contents)
322 Changes COPYING MANIFEST Makefile.PL README test.pl
323
324
325 Example B. (case insensitive order)
326 COPYING Changes Makefile.PL MANIFEST README test.pl
327
328 3.12_9
329 10/27/02, 1:54 pm
330 Various places where warnings were surfacing undesirably have been
331 corrected. General preparations made to upload File::Util to PAUSE and
332 ultimately be included in the CPAN.
333
334 3.12_7
335 10/10/02, 11:56 pm
336 Method 'list_dir_a()' no longer suffixes directory items with the
337 system path separator by force.
338
339 3.12_6
340 10/4/02, 4:22 am
341 Fixed serious problem with flock() wrapper which was previously not
342 working at all when global setting '--fatals-as-status' or global
343 setting '--fatals-as-warning' were used. An upgrade to the present
344 release of File::Util from versions predating this release (3.12_6) is
345 seriously recommended!
346
347 3.12_5
348 10/1/02, 7:46 pm
349 More performance improvements.
350
351 New argument flags recognized by method 'new':
352 '--fatals-as-warning' The new File::Util object will CORE::warn()
353 about otherwise fatal errors instead of
354 failing and exiting the process.
355
356 '--fatals-as-status' The new File::Util object will return(undef)
357 to method calls that would otherwise cause
358 fatal errors.
359
360 Method 'write_file' now recognizes the argument flag,
361 '--empty-writes-OK', as an alternative means of allowing the
362 creation of empty files without reaping a nasty fatal error. Up
363 until now, setting $File::Util::empty_writes to a true value was the
364 only way to accomplish this.
365
366 3.12_4
367 9/23/02, 2:30 pm
368 Fixed 'deep recursion' problem in AUTOLOAD
369
370 3.12_3
371 9/23/02, 1:18 pm
372 Added AUTOLOAD and moved lots of methods away into space. They get
373 AUTOLOAD-ed when needed, but not compiled as routines in the module.
374 This greatly improves compile-time and run-time performance now.
375 Got rid of methods 'get()' and 'set()'; they're largely useless.
376 Got rid of variable '$File::Util::canhackit'; no longer used.
377
378 3.12_2
379 9/11/02, 12:35 am
380 Moved to OOorNO interface design in order to provide both an Object-
381 Oriented and a Procedural (non-Object-Oriented) programming style
382 interface to File::Util.
383
384 1.10
385 Thursday, March 14, 2002, 1:29:55 AM
386 Constants are now class attributes independent of the constructor method.
387 File::Util objects should always get these constants regardless.
388
389 Constants and OS identification extended upon code from CGI.pm v.2.78
390 (go Lincoln, it's your birthday, get busy...) as such, File::Util got path
391 separator help to better support a wider variety of platforms.
392
393 Additionally, constants contributed to a major overhaul of how File::Util
394 handles newlines.
395
396 1.09
397 Thursday, March 14, 2002, 1:29:55 AM
398 Error messages got their own place as predefined key-value pairs in an
399 anonymous hash independent of any class methods. eg-they are committed to
400 memory at compile time for speedy destruction of intentionally halted
401 processes.
402
403 1.07
404 Saturday, February 9, 2002, 3:32:57 PM
405 new method: File::Util::open_handle. This method lets user pass a
406 typeglob reference (eg- *TYPG) and in return the user will get back a new
407 file handle which is opened to the filename of their specifications.
408
409 1.06
410 Tuesday, February 5, 2002, 9:47:35 AM
411 Fixed a bug in File::Util::stamp() which made times during the hour of
412 12:00 PM appear with the 'AM' suffix rather than the correct 'PM suffix.
413
414 Added a new format type to File::Util::stamp() called 'file' or 'filename'
415 which returns a timestamp suitable for placing into the name of a file
416 in order to archive old files or versions of code with a time/date stamp
417 embedded into the filename for easy lookup.
418
419 1.05
420 Wednesday, December 5, 2001, 1:36:48 AM
421 Added a few more methods of the same nature as File::Util::size(). Passing
422 in a format keyword argument returns a formatted timestamp. Format
423 keywords described in detail within the overview entry for previous
424 version 1.02. Now an overview of new methods:
425
426 File::Util::created([filename][format])
427
428 returns the creation time of the file in seconds since the epoch. The
429 value returned is then passed back in the same format as the value
430 returned from a call to Perl's built-in function: time()
431
432 consequently, the value returned is suitable for feeding to
433 localtime, or any private methods and functions expecting the same
434 type of input.
435
436 As such, a call to this method on a file which was created at:
437 Thursday, December 6, 2001, 4:27:57 PM
438 ...would return the value: 1007684877
439
440 File::Util::last_mod([filename][format])
441
442 Returns the last modified time of the file you pass to it in seconds
443 since the epoch. Just as with the new created() method described
444 above, the value returned comes in the same format as the value
445 returned from a call to time(), and is therefore suitable for feeding
446 to localtime() or any other private function or method expecting input
447 of the same type.
448
449 As such, a call to this method on a file which was last modified at:
450 Sunday, December 2, 2001, 12:05:21 AM
451 ...would return the value: 1007280321
452
453 File::Util::last_access([filename][format])
454
455 Same as the two previously described methods, only this method returns
456 the number of seconds since the epoch to the time when the specified
457 file was last accessed.
458
459 As such, a call to this method on a file which was last accessed at:
460 Thursday, December 6, 2001, 12:00:00 AM
461 ...would return the value: 1007625600
462
463 1.04
464 Wednesday, December 5, 2001, 1:36:48 AM
465 Fixed some of the checks on files for existence, added the
466 File::Util::file_size([filename]) method which returns the size of the
467 filename you pass as the only argument.
468
469 1.03
470 Thursday, November 29, 2001, 12:54:07 AM
471 Re-visited the time/date methods to work out a bug which was causing file
472 creation and last-modified times to be returned with incorrect values.
473
474 1.02
475 Tuesday, November 27, 2001, 2:23:55 PM
476 More directory listing options. Method File::Util::stamp() now takes
477 optional format keyword argument; it lets you choose between different
478 output formats for the returned time stamp. Format keywords are thus:
479
480 --short 5/15/02, 4:22 pm
481 --formal Saturday, June 15, 2002, 4:22 pm
482 --long same as '--formal'
483 --succinct Sat 5/15/02 16:22:43
484 --ISO Sat, 15 Jun 2002 16.22.43 GMT
485 --filename -June-15-2002-16.22.43
486 --file same as '--filename'
487 --mdy 5/15/02
488 --hm 4:22 pm
489 --hms 4:22:43 pm
490 --24hms 16:22:43
491 --dayofmonth 15
492 --dayofyear 134 (1 - 365)
493 --dayofweek Saturday
494 --dayofweek, --num 7
495 --month June
496 --month, --num 6
497 --year 2002
498 --shortyear 02
499 --minute 22
500 --hour 16 (0 - 24)
501 --second 43
502
503 1.01
504 Wednesday, November 21, 2001, 4:00:00 PM
505 All methods now include very detailed error messages and a stack trace
506 to help quickly track down mistakes. You can fix mistakes now without
507 having to decipher some cryptic error message which no one can understand
508 and whose origin one can guess :o(
509
510 1.00
511 Sunday, September 23, 2001 4:18:30 PM
512 Initial release of File::Util.pm
513
+20
-0
MANIFEST less more
0 COPYING
1 Changes
2 MANIFEST
3 Makefile.PL
4 README
5 Util.pm
6 Util.pod
7 t/001_canuseit.t
8 t/002_isa.t
9 t/003_can.t
10 t/004_portable.t
11 t/005_ftests.t
12 t/006_io.t
13 t/007_flock.t
14 t/008_export_ok.t
15 t/009_empty_subclass.t
16 t/010_diesnice.t
17 t/bin
18 t/txt
19 META.yml Module meta-data (added by MakeMaker)
+12
-0
META.yml less more
0 # http://module-build.sourceforge.net/META-spec.html
1 #XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX#
2 name: File-Util
3 version: 3.27
4 version_from: Util.pm
5 installdirs: site
6 requires:
7 Class::OOorNO: 0.01
8 Exception::Handler: 1
9
10 distribution_type: module
11 generated_by: ExtUtils::MakeMaker version 6.30
+26
-0
Makefile.PL less more
0 use ExtUtils::MakeMaker;
1 require 5.006;
2
3 # See lib/ExtUtils/MakeMaker.pm for details of how to influence
4 # the contents of the Makefile that is written.
5 WriteMakefile
6 (
7 'NAME' => 'File::Util',
8 'AUTHOR' => 'Tommy Butler <cpan@atrixnet.com>',
9 'ABSTRACT_FROM'=> 'Util.pod',
10 'VERSION_FROM' => 'Util.pm',
11 'INSTALLDIRS' => 'site',
12 'PREREQ_PM' =>
13 {
14 'Class::OOorNO' => 0.01_0,
15 'Exception::Handler' => 1.00_0,
16 },
17 'linkext' => { LINKTYPE => '' }, # no link needed
18 'dist' =>
19 {
20 'COMPRESS' => 'gzip -9f',
21 'SUFFIX' => 'gz',
22 'ZIP' => '/usr/bin/zip',
23 'ZIPFLAGS' => '-rl',
24 }
25 );
+81
-0
README less more
0 File::Util
1 =========================
2
3 DESCRIPTION
4 File::Util provides a comprehensive toolbox of utilities to automate all
5 kinds of common tasks on file / directories. Its purpose is to do so
6 in the most portable manner possible so that users of this module won't
7 have to worry about whether their programs will work on other OSes
8 and machines.
9
10
11 CHANGES IN LAST FEW RELEASES
12 (listed in reverse chronological order by date and subversion)
13
14 2.27
15 Sat Dec 6 13:10:00 CST 2008
16 Fixed a bug that caused root directories using Micro$oft filesystem
17 notation to be mis-read when using the '--dirs-only' flag for
18 File::Util::list_dir()
19
20 3.26
21 Tue Dec 2 20:07:09 CST 2008
22 Added to test suite in order to avoid errant test failures
23 when flock'ing on solaris. This is a big deal, since the point of
24 File::Util is to be easy, and portable!
25
26 Added some yet more extra examples in the documentation.
27
28 3.25
29 Mon Dec 1 15:11:20 CST 2008
30 Fixed a bug in File::Util::touch()
31
32 Added some extra examples and corrected one minor error in the
33 documentation.
34
35 3.24
36 Wed May 23 16:27:20 CDT 2007
37 **Don't use this version. It has a bug. Use 3.25 or greater.
38
39 Added method File::Util::last_changed (get inode change time for a file)
40 Added method File::Util::touch (works like *nix touch command)
41
42 Both touch and last_changed are autoloaded methods
43
44 Applied patch from S. Muskiewicz that fixes the File::Util::last_modified
45 method that was using a similar but incorrect "-" file test operator.
46
47 INSTALLATION
48 To install this module type the following:
49
50 perl Makefile.PL
51 make
52 make test
53 make install
54
55 On windows machines use nmake rather than make; those running cygwin don't have
56 to worry about this. If you don't know what cygwin is, use nmake and check out
57 <URL: http://cygwin.com/> after you're done installing this module if you want
58 to find out.
59
60
61 DEPENDENCIES
62 This module requires these other modules and libraries:
63
64 Class::OOorNO v0.01_0 or better
65 Exception::Handler v1.00_0 or better
66
67
68 AUTHOR
69 Tommy Butler <cpan@atrixnet.com>
70
71
72 COPYRIGHT
73 Copyright (C) Tommy Butler 2001-2002, all rights reserved.
74
75
76 LICENCE
77
78 This library is free software, you may redistribute it and/or modify it
79 under the same terms as Perl itself.
80
+2511
-0
Util.pm less more
0 package File::Util;
1 use 5.006;
2 use strict;
3 use vars qw(
4 $VERSION @ISA @EXPORT_OK %EXPORT_TAGS
5 $OS $MODES $READLIMIT $MAXDIVES $EMPTY_WRITES_OK
6 $USE_FLOCK @ONLOCKFAIL $ILLEGAL_CHR $CAN_FLOCK
7 $NEEDS_BINMODE $EBCDIC $DIRSPLIT $SL $NL $_LOCKS
8 );
9 use Exporter;
10 use AutoLoader qw( AUTOLOAD );
11 use Class::OOorNO qw( :all );
12 $VERSION = 3.27; # Sat Dec 6 13:10:00 CST 2008
13 @ISA = qw( Exporter Class::OOorNO );
14 @EXPORT_OK = (
15 @Class::OOorNO::EXPORT_OK, qw(
16 can_flock ebcdic existent isbin bitmask NL SL
17 strip_path can_read can_write file_type needs_binmode
18 valid_filename size escape_filename return_path
19 created last_access last_changed last_modified OS
20 )
21 );
22 %EXPORT_TAGS = ( 'all' => [ @EXPORT_OK ] );
23
24 BEGIN {
25
26 # Some OS logic.
27 unless ($OS = $^O) { require Config; eval(q[$OS=$Config::Config{osname}]) }
28
29 if ($OS =~ /^darwin/i) { $OS = 'UNIX' }
30 elsif ($OS =~ /^cygwin/i) { $OS = 'CYGWIN' }
31 elsif ($OS =~ /^MSWin/i) { $OS = 'WINDOWS' }
32 elsif ($OS =~ /^vms/i) { $OS = 'VMS' }
33 elsif ($OS =~ /^bsdos/i) { $OS = 'UNIX' }
34 elsif ($OS =~ /^dos/i) { $OS = 'DOS' }
35 elsif ($OS =~ /^MacOS/i) { $OS = 'MACINTOSH' }
36 elsif ($OS =~ /^epoc/) { $OS = 'EPOC' }
37 elsif ($OS =~ /^os2/i) { $OS = 'OS2' }
38 else { $OS = 'UNIX' }
39
40 $EBCDIC = qq[\t] ne qq[\011] ? 1 : 0;
41 $NEEDS_BINMODE = $OS =~ /WINDOWS|DOS|OS2|MSWin/ ? 1 : 0;
42 $NL =
43 $NEEDS_BINMODE ? qq[\015\012]
44 : $EBCDIC || $OS eq 'VMS' ? qq[\n]
45 : $OS eq 'MACINTOSH' ? qq[\015]
46 : qq[\012];
47 $SL =
48 { 'DOS' => '\\', 'EPOC' => '/', 'MACINTOSH' => ':',
49 'OS2' => '\\', 'UNIX' => '/', 'WINDOWS' => chr(92),
50 'VMS' => '/', 'CYGWIN' => '/', }->{ $OS }||'/';
51
52 $_LOCKS = {};
53
54 } BEGIN {
55 use constant NL => $NL;
56 use constant SL => $SL;
57 use constant OS => $OS;
58 }
59
60 $DIRSPLIT = qr/[\x5C\/\:]/;
61 $ILLEGAL_CHR = qr/[\x5C\/\|$NL\r\n\t\013\*\"\?\<\:\>]/;
62
63 $READLIMIT = 52428800; # set readlimit to a default of 50 megabytes
64 $MAXDIVES = 1000; # maximum depth for recursive list_dir calls
65
66 use Fcntl qw( );
67
68 { local($@); eval <<'__canflock__'; $CAN_FLOCK = $@ ? 0 : 1; }
69 flock(STDOUT, &Fcntl::LOCK_SH);
70 flock(STDOUT, &Fcntl::LOCK_UN);
71 __canflock__
72
73 # try to use file locking, define flock race conditions policy
74 $USE_FLOCK = 1; @ONLOCKFAIL = qw( NOBLOCKEX FAIL );
75
76 $MODES->{'popen'} = {
77 'write' => '>', 'trunc' => '>', 'rwupdate' => '+<',
78 'append' => '>>', 'read' => '<', 'rwclobber' => '+>',
79 'rwcreate' => '+>', 'rwappend' => '+>>',
80 };
81
82 $MODES->{'sysopen'} = {
83 'read' => '&Fcntl::O_RDONLY',
84 'write' => '&Fcntl::O_WRONLY | &Fcntl::O_CREAT',
85 'append' => '&Fcntl::O_WRONLY | &Fcntl::O_APPEND | &Fcntl::O_CREAT',
86 'trunc' => '&Fcntl::O_WRONLY | &Fcntl::O_CREAT | &Fcntl::O_TRUNC',
87 'rwcreate' => '&Fcntl::O_RDWR | &Fcntl::O_CREAT',
88 'rwupdate' => '&Fcntl::O_RDWR',
89 'rwclobber' => '&Fcntl::O_RDWR | &Fcntl::O_TRUNC | &Fcntl::O_CREAT',
90 'rwappend' => '&Fcntl::O_RDWR | &Fcntl::O_APPEND | &Fcntl::O_CREAT',
91 };
92
93
94 # --------------------------------------------------------
95 # Constructor
96 # --------------------------------------------------------
97 sub new {
98 my($this) = {}; bless($this, shift(@_));
99 my($in) = $this->coerce_array(@_);
100
101 my($opts) = $this->shave_opts(\@_); $this->{'opts'} = $opts || {};
102
103 $USE_FLOCK = $in->{'use_flock'}
104 if exists $in->{'use_flock'} && $in->{'use_flock'};
105
106 $READLIMIT = $in->{'readlimit'}
107 if defined $in->{'readlimit'}
108 && $$in{'readlimit'} !~ /\D/;
109
110 $MAXDIVES = $in->{'max_dives'}
111 if defined $in->{'max_dives'}
112 && $$in{'max_dives'} !~ /\D/;
113
114 return $this;
115 }
116
117
118 # --------------------------------------------------------
119 # File::Util::list_dir()
120 # --------------------------------------------------------
121 sub list_dir {
122 my($this) = shift(@_);
123 my($opts) = $this->shave_opts(\@_);
124 my($dir) = shift(@_)||'.';
125 my($path) = $dir;
126 my($maxd) = $opts->{'--max-dives'} || $MAXDIVES;
127 my($r) = 0;
128 my(@dirs) = (); my(@files) = (); my(@items) = ();
129
130 return
131 $this->_throw
132 (
133 'no input',
134 {
135 'meth' => 'list_dir',
136 'missing' => 'a directory name',
137 'opts' => $opts,
138 }
139 )
140 unless length($dir);
141
142 return($this->_throw('no such file', {'filename' => $dir})) unless -e $dir;
143
144 # whack off any trailing directory separator, except for root directories
145 # -account for both posix filesystem AND micro$oft directory notation
146 unless ( length($dir) == 1 || $dir =~ /^(?:[[:alpha:]]:)(?:\\|\/)$/o ) {
147 # removes one or more dirsep at the end of $dir
148 $dir =~ s/(?:$DIRSPLIT){1,}$//o;
149 }
150
151 return
152 $this->_throw
153 (
154 'called opendir on a file',
155 {
156 'filename' => $dir,
157 'opts' => $opts,
158 }
159 )
160 unless (-d $dir);
161
162 # this directory recursion method keeps track of dives based on the parent
163 # directory of $dir, rather than on $dir itself so that multiple
164 # subdirectories within the same parent directory don't improperly increment
165 # the number of dives made
166 if ($opts->{'--recursing'}) {
167
168 my($pdir) = $dir; $pdir =~ s/(^.*)$DIRSPLIT.*/$1/;
169
170 $this->{'traversed'}{ $pdir } = $pdir;
171 }
172 else { $this->{'traversed'} = {} }
173
174 if (scalar keys %{ $this->{'traversed'} } >= $maxd) {
175
176 return $this->_throw
177 (
178 'maxdives exceeded',
179 {
180 'meth' => 'list_dir',
181 'maxdives' => $maxd,
182 'opts' => $opts,
183 }
184 )
185 }
186
187 $r = 1 if ($opts->{'--follow'} || $opts->{'--recurse'});
188
189 local(*DIR);
190
191 opendir(DIR, $dir) or
192 return
193 $this->_throw
194 (
195 'bad opendir',
196 {
197 'dirname' => $dir,
198 'exception' => $!,
199 'opts' => $opts,
200 }
201 );
202
203 # read from beginning of the directory (doesn't seem necessary on any
204 # platforms I've run code on, but just in case...)
205 rewinddir(DIR);
206
207 @files = exists($opts->{'--pattern'})
208 ? grep(/$opts->{'--pattern'}/, readdir(DIR))
209 : readdir(DIR);
210
211 closedir(DIR) or return $this->_throw(
212 'close dir',
213 {
214 'dir' => $dir,
215 'exception' => $!,
216 'opts' => $opts,
217 }
218 );
219
220 if ($opts->{'--no-fsdots'}) {
221
222 my(@shadow) = @files; @files = ();
223
224 while (@shadow) {
225
226 my($f) = shift(@shadow);
227
228 push(@files,$f) unless (
229 $this->strip_path($f) eq '.'
230 or
231 $this->strip_path($f) eq '..'
232 );
233 }
234 }
235
236 for (my($i) = 0; $i < @files; ++$i) {
237
238 my($listing) = ($opts->{'--with-paths'} or ($r==1))
239 ? $path . SL . $files[$i]
240 : $files[$i];
241
242 if (-d $path . SL . $files[$i]) { push(@dirs, $listing) }
243 else { push(@items, $listing) }
244 }
245
246 if (($r) and (not $opts->{'--override-follow'})) {
247
248 my(@shadow) = @dirs; @dirs = ();
249
250 while (@shadow) {
251
252 my($f) = shift(@shadow);
253
254 push(@dirs,$f)
255 unless
256 (
257 $this->strip_path($f) eq '.'
258 or
259 $this->strip_path($f) eq '..'
260 );
261 }
262
263 for (my($i) = 0; $i < @dirs; ++$i) {
264
265 my(@lsts) = $this->list_dir
266 (
267 $dirs[$i],
268 '--with-paths', '--dirs-as-ref',
269 '--files-as-ref', '--recursing',
270 '--no-fsdots', '--max-dives=' . $maxd
271 );
272
273 push(@dirs,@{$lsts[0]}); push(@items,@{$lsts[1]});
274 }
275 }
276
277 if ($opts->{'--sl-after-dirs'}) {
278
279 @dirs = $this->_dropdots(@dirs,'--save-dots');
280 my($dots) = shift(@dirs);
281 @dirs = map ( ($_ .= SL), @dirs );
282 @dirs = (@{$dots},@dirs);
283 }
284
285 my($reta) = []; my($retb) = [];
286
287 if ($opts->{'--ignore-case'}) {
288
289 $reta = [ sort {uc $a cmp uc $b} @dirs ];
290 $retb = [ sort {uc $a cmp uc $b} @items ];
291 }
292 else {
293
294 $reta = [ sort {$a cmp $b} @dirs ];
295 $retb = [ sort {$a cmp $b} @items ];
296 }
297
298 return(scalar(@$reta))
299 if $opts->{'--dirs-only'} && $opts->{'--count-only'};
300
301 return(scalar(@$retb))
302 if $opts->{'--files-only'} && $opts->{'--count-only'};
303
304 return(scalar(@$reta) + scalar(@$retb)) if $opts->{'--count-only'};
305
306 return($reta,$retb) if $opts->{'--as-ref'};
307
308 $reta=[$reta] if $opts->{'--dirs-as-ref'};
309 $retb=[$retb] if $opts->{'--files-as-ref'};
310
311 return(@$reta) if $opts->{'--dirs-only'};
312 return(@$retb) if $opts->{'--files-only'};
313
314 return(@$reta,@$retb);
315 }
316
317
318 # --------------------------------------------------------
319 # File::Util::_dropdots()
320 # --------------------------------------------------------
321 sub _dropdots {
322 my($this) = shift(@_); my(@out) = (); my($opts) = $this->shave_opts(\@_);
323 my(@shadow) = @_; my(@dots) = (); my($gottadot) = 0;
324
325 while (@shadow) {
326
327 if ($gottadot == 2){ push(@out,@shadow) and last }
328
329 my($thing) = shift(@shadow);
330
331 if ($thing eq '.') {++$gottadot;push(@dots,$thing);next}
332 if ($thing eq '..') {++$gottadot;push(@dots,$thing);next}
333
334 push(@out,$thing);
335 }
336
337 return([@dots],@out) if ($opts->{'--save-dots'}); @out;
338 }
339
340
341 # --------------------------------------------------------
342 # File::Util::load_file()
343 # --------------------------------------------------------
344 sub load_file {
345 my($this) = shift(@_); my($opts) = $this->shave_opts(\@_);
346 my($in) = $this->coerce_array(@_); my(@dirs) = ();
347 my($blocksize) = 1024; # 1.24 kb
348 my($FH_passed) = 0; my($fh) = undef; my($file) = ''; my($path) = '';
349 my($content) = ''; my($FHstatus) = ''; my($mode) = 'read';
350
351 if (scalar(@_) == 1) {
352
353 $file = shift(@_)||'';
354
355 @dirs = split(/$DIRSPLIT/, $file);
356
357 if (scalar(@dirs) > 0) {
358
359 $file = pop(@dirs); $path = join(SL, @dirs);
360 }
361
362 if (length($path) > 0) {
363
364 $path = '.' . SL . $path if ($path !~ /(?:^\/)|(?:^\w\:)/o);
365 }
366 else { $path = '.'; }
367
368 return $this->_throw
369 (
370 'no input',
371 {
372 'meth' => 'load_file',
373 'missing' => 'a file name or file handle reference',
374 'opts' => $opts,
375 }
376 )
377 if (length($path . SL . $file) == 0);
378 }
379 else {
380 $fh = $in->{'FH'}||''; $FHstatus = $in->{'FH_status'}||'';
381
382 # did we get a filehandle?
383 if (length($fh) > 0) { $FH_passed = 1; } else {
384 return $this->_throw(
385 'no input',
386 {
387 'meth' => 'load_file',
388 'missing' => 'a file name or file handle reference',
389 'opts' => $opts,
390 }
391 );
392 }
393 }
394
395 if ($FH_passed) {
396 my($buff) = 0; my($bytes_read) = 0;
397
398 while (<$fh>) {
399 if ($buff < $READLIMIT) {
400 $bytes_read = read($fh,$content,$blocksize); $buff += $bytes_read;
401 }
402 else {
403 return $this->_throw(
404 'readlimit exceeded',
405 {
406 'filename' => '<FH>',
407 'size' => qq[[truncated at $bytes_read]],
408 'opts' => $opts,
409 }
410 );
411 }
412 }
413
414 # return an array of all lines in the file if the call to this method/
415 # subroutine asked for an array eg- my(@file) = load_file('file');
416 # otherwise, return a scalar value containing all of the file's content
417 return(split(/$NL|\r|\n/o,$content)) if $opts->{'--as-list'};
418
419 return($content);
420 }
421
422 # if the file doesn't exist, send back an error
423 return $this->_throw(
424 'no such file',
425 {
426 'filename' => $path . SL . $file,
427 'opts' => $opts,
428 }
429 ) unless -e $path . SL . $file;
430
431 # it's good to know beforehand whether or not we have permission to open
432 # and read from this file allowing us to handle such an exception before
433 # it handles us.
434
435 # first check the readability of the file's housing dir
436 return $this->_throw(
437 'cant dread',
438 {
439 'filename' => $path . SL . $file,
440 'dirname' => $path . SL,
441 'opts' => $opts,
442 }
443 ) unless (-r $path . SL);
444
445 # now check the readability of the file itself
446 return $this->_throw(
447 'cant fread',
448 {
449 'filename' => $path . SL . $file,
450 'dirname' => $path . SL,
451 'opts' => $opts,
452 }
453 ) unless (-r $path . SL . $file);
454
455 # if the file is a directory it will not be opened
456 return $this->_throw(
457 'called open on a dir',
458 {
459 'filename' => $path . SL . $file,
460 'opts' => $opts,
461 }
462 ) if -d $path . SL . $file;
463
464 my($fsize) = -s $path . SL . $file;
465
466 return $this->_throw(
467 'readlimit exceeded',
468 {
469 'filename' => $path . SL . $file,
470 'size' => $fsize,
471 'opts' => $opts,
472 }
473 ) if ($fsize > $READLIMIT);
474
475 # we need a unique filehandle
476 do { $fh = int(rand(time)) . $$; $fh = eval('*' . 'LOAD_FILE' . $fh) }
477 while fileno($fh);
478
479 # localize the global output record separator so we can slurp it all
480 # in one quick read. We fail if the filesize exceeds our limit.
481 local($/);
482
483 # open the file for reading (note the '<' syntax there) or fail with a
484 # error message if our attempt to open the file was unsuccessful
485 my($cmd) = '<' . $path . SL . $file;
486
487 # lock file before I/O on platforms that support it
488 if ($$opts{'--no-lock'} || $$this{'opts'}{'--no-lock'}) {
489
490 # if you use the '--no-lock' option you are probably inefficient
491 open($fh, $cmd) or return $this->_throw(
492 'bad open',
493 {
494 'filename' => $path . SL . $file,
495 'mode' => $mode,
496 'exception' => $!,
497 'cmd' => $cmd,
498 'opts' => $opts,
499 }
500 );
501 }
502 else {
503 open($fh, $cmd) or return $this->_throw(
504 'bad open',
505 {
506 'filename' => $path . SL . $file,
507 'mode' => $mode,
508 'exception' => $!,
509 'cmd' => $cmd,
510 'opts' => $opts,
511 }
512 );
513
514 $this->_seize($path . SL . $file, $fh);
515 }
516
517 # call binmode on binary files for portability accross platforms such
518 # as MS flavor OS family
519 CORE::binmode($fh) if (-B $path . SL . $file);
520
521 # assign the content of the file to this lexically scoped scalar variable
522 # (memory for *that* variable will be freed when execution leaves this
523 # method / sub
524 $content = <$fh>;
525
526 if ($$opts{'--no-lock'} || $$this{'opts'}{'--no-lock'}) {
527
528 # if execution gets here, you used the '--no-lock' option, and you
529 # are probably inefficient
530 close($fh) or return $this->_throw(
531 'bad close',
532 {
533 'filename' => $path . SL . $file,
534 'mode' => $mode,
535 'exception' => $!,
536 'opts' => $opts,
537 }
538 );
539 }
540 else {
541 # release shadow-ed locks on the file
542 $this->_release($fh);
543
544 close($fh) or return $this->_throw(
545 'bad close',
546 {
547 'filename' => $path . SL . $file,
548 'mode' => $mode,
549 'exception' => $!,
550 'opts' => $opts,
551 }
552 );
553 }
554
555 # return an array of all lines in the file if the call to this method/
556 # subroutine asked for an array eg- my(@file) = load_file('file');
557 # otherwise, return a scalar value containing all of the file's content
558 return(split(/$NL|\r|\n/o,$content)) if $opts->{'--as-lines'};
559
560 $content;
561 }
562
563
564 # --------------------------------------------------------
565 # File::Util::write_file()
566 # --------------------------------------------------------
567 sub write_file {
568 my($this) = shift(@_);
569 my($opts) = $this->shave_opts(\@_);
570 my($in) = $this->coerce_array(@_);
571 my($filename) = $in->{'file'} || $in->{'filename'} || '';
572 my($content) = $in->{'content'} || '';
573 my($mode) = $in->{'mode'} || 'write';
574 my($bitmask) = _bitmaskify($in->{'bitmask'}) || 0777;
575 my($path) = '';
576 my(@dirs) = ();
577
578 $path = $filename;
579
580 local(*WRITE_FILE); $mode = 'trunc' if ($mode eq 'truncate');
581
582 # if the call to this method didn't include a filename to which the caller
583 # wants us to write, then complain about it
584 return $this->_throw(
585 'no input',
586 {
587 'meth' => 'write_file',
588 'missing' => 'a file name to create, write, or append',
589 'opts' => $opts,
590 }
591 ) unless length($filename);
592
593 # if prospective filename contains 2+ dir separators in sequence then
594 # this is a syntax error we need to whine about
595 return $this->_throw(
596 'bad chars',
597 {
598 'string' => $filename,
599 'purpose' => 'the name of a file or directory',
600 'opts' => $opts,
601 }
602 ) if ($filename =~ /(?:$DIRSPLIT){2,}/);
603
604 # if the call to this method didn't include any data which the caller
605 # wants us to write or append to the file, then complain about it
606 return $this->_throw(
607 'no input',
608 {
609 'meth' => 'write_file',
610 'missing' => 'the content you want to write or append',
611 'opts' => $opts,
612 }
613 ) if (
614 (length($content) == 0)
615 and
616 ($mode ne 'trunc')
617 and
618 (!$EMPTY_WRITES_OK)
619 and
620 (!$opts->{'--empty-writes-OK'})
621 );
622
623 # remove any possible trailing directory seperator
624 $filename =~ s/$DIRSPLIT$//;
625
626 # check if file already exists in the form of a directory
627 return $this->_throw(
628 'cant write_file on a dir',
629 {
630 'filename' => $filename,
631 'opts' => $opts,
632 }
633 ) if (-d $filename);
634
635 # determine existance of the file path, make directory(ies) for the
636 # path if the full directory path doesn't exist
637 @dirs = split(/$DIRSPLIT/, $filename);
638
639 # if prospective file name has illegal chars then complain
640 foreach (@dirs) {
641 return $this->_throw(
642 'bad chars',
643 {
644 'string' => $_,
645 'purpose' => 'the name of a file or directory',
646 'opts' => $opts,
647 }
648 ) if (!$this->valid_filename($_));
649 }
650
651 # make sure that open mode is a valid mode
652 unless ($mode eq 'write' || $mode eq 'append' || $mode eq 'trunc') {
653 return $this->_throw(
654 'bad openmode popen',
655 {
656 'meth' => 'write_file',
657 'filename' => $filename,
658 'badmode' => $mode,
659 'opts' => $opts,
660 }
661 )
662 }
663
664 if (scalar(@dirs) > 0) { $filename = pop(@dirs); $path = join(SL, @dirs); }
665
666 if (length($path) > 0) {
667 $path = '.' . SL . $path if ($path !~ /(?:^\/)|(?:^\w\:)/o);
668 }
669 else { $path = '.'; }
670
671 # create path preceding file if path doesn't exist
672 $this->make_dir(
673 $path,
674 exists $in->{'dbitmask'} ? _bitmaskify($in->{'dbitmask'}) : 0777
675 ) unless -e $path;
676
677 my($openarg) = qq[$path$SL$filename];
678
679 if (-e $openarg) {
680 return $this->_throw(
681 'cant fwrite',
682 {
683 'filename' => $openarg,
684 'dirname' => $path,
685 'opts' => $opts,
686 }
687 ) unless (-w $openarg);
688 }
689 else {
690 # if file doesn't exist, the error is one of creation
691 return $this->_throw(
692 'cant fcreate',
693 {
694 'filename' => $openarg,
695 'dirname' => $path,
696 'opts' => $opts,
697 }
698 ) unless (-w $path . SL);
699 }
700
701 # if you use the '--no-lock' option you are probably inefficient
702 if ($$opts{'--no-lock'} || !$USE_FLOCK) {
703
704 # get open mode
705 $mode = $$MODES{'popen'}{ $mode };
706
707 # only non-existent files get bitmask arguments
708 if (-e $openarg) {
709 sysopen(WRITE_FILE, $openarg, eval($$MODES{'sysopen'}{ $mode })) or
710 return $this->_throw(
711 'bad open',
712 {
713 'filename' => $openarg,
714 'mode' => $mode,
715 'exception' => $!,
716 'cmd' => qq{$openarg, $$MODES{'sysopen'}{ $mode }},
717 'opts' => $opts,
718 }
719 );
720 }
721 else {
722 sysopen(
723 WRITE_FILE,
724 $openarg,
725 eval($$MODES{'sysopen'}{ $mode }),
726 $bitmask
727 ) or return $this->_throw(
728 'bad open',
729 {
730 'filename' => $openarg,
731 'mode' => $mode,
732 'exception' => $!,
733 'cmd' => qq{$openarg, $$MODES{'sysopen'}{$mode}, $bitmask},
734 'opts' => $opts,
735 }
736 );
737 }
738 }
739 else {
740 # open read-only first to safely check if we can get a lock.
741 if (-e $openarg) {
742
743 open(WRITE_FILE, '<' . $openarg) or
744 return $this->_throw(
745 'bad open',
746 {
747 'filename' => $openarg,
748 'mode' => 'read',
749 'exception' => $!,
750 'cmd' => $mode . $openarg,
751 'opts' => $opts,
752 }
753 );
754
755 # lock file before I/O on platforms that support it
756 my($lockstat) = $this->_seize($openarg, *WRITE_FILE);
757
758 return($lockstat) unless $lockstat;
759
760 sysopen(WRITE_FILE, $openarg, eval($$MODES{'sysopen'}{ $mode }))
761 or return $this->_throw(
762 'bad open',
763 {
764 'filename' => $openarg,
765 'mode' => $mode,
766 'opts' => $opts,
767 'exception' => $!,
768 'cmd' => qq[$openarg, $$MODES{'sysopen'}{ $mode }],
769 }
770 );
771 }
772 else { # only non-existent files get bitmask arguments
773 sysopen(
774 WRITE_FILE,
775 $openarg,
776 eval($$MODES{'sysopen'}{ $mode }),
777 $bitmask
778 ) or return $this->_throw(
779 'bad open',
780 {
781 'filename' => $openarg,
782 'mode' => $mode,
783 'opts' => $opts,
784 'exception' => $!,
785 'cmd' => qq{$openarg, $$MODES{'sysopen'}{$mode}, $bitmask},
786 }
787 );
788
789 # lock file before I/O on platforms that support it
790 my($lockstat) = $this->_seize($openarg, *WRITE_FILE);
791
792 return($lockstat) unless $lockstat;
793 }
794
795 # now truncate
796 if ($mode ne 'append') {
797 truncate(WRITE_FILE,0) or return $this->_throw(
798 'bad systrunc',
799 {
800 'filename' => $openarg,
801 'exception' => $!,
802 'opts' => $opts,
803 }
804 );
805 }
806 }
807
808 CORE::binmode(WRITE_FILE) if $in->{'binmode'} || $opts->{'--binmode'};
809
810 $in->{'content'}||=''; syswrite(WRITE_FILE, $in->{'content'});
811
812 # release lock on the file
813 unless ($$opts{'--no-lock'} || !$USE_FLOCK) { $this->_release(*WRITE_FILE) }
814
815 close(WRITE_FILE) or
816 return $this->_throw(
817 'bad close',
818 {
819 'filename' => $openarg,
820 'mode' => $mode,
821 'exception' => $!,
822 'opts' => $opts,
823 }
824 );
825
826 return(1);
827 }
828
829
830 # --------------------------------------------------------
831 # %$File::Util::LOCKS
832 # --------------------------------------------------------
833 $_LOCKS->{'IGNORE'} = sub { $_[2] };
834 $_LOCKS->{'ZERO'} = sub { 0 };
835 $_LOCKS->{'UNDEF'} = sub { undef };
836 $_LOCKS->{'NOBLOCKEX'} = sub {
837 return $_[2] if flock($_[2], &Fcntl::LOCK_EX | &Fcntl::LOCK_NB); undef
838 };
839 $_LOCKS->{'NOBLOCKSH'} = sub {
840 return $_[2] if flock($_[2], &Fcntl::LOCK_SH | &Fcntl::LOCK_NB); undef
841 };
842 $_LOCKS->{'BLOCKEX'} = sub {
843 return $_[2] if flock($_[2], &Fcntl::LOCK_EX); undef
844 };
845 $_LOCKS->{'BLOCKSH'} = sub {
846 return $_[2] if flock($_[2], &Fcntl::LOCK_SH); undef
847 };
848 $_LOCKS->{'WARN'} = sub {
849 $_[0]->_throw(
850 'bad flock',
851 {
852 'filename' => $_[1],
853 'exception' => $!,
854 },
855 '--as-warning',
856 ); undef
857 };
858 $_LOCKS->{'FAIL'} = sub {
859 $_[0]->_throw(
860 'bad flock',
861 {
862 'filename' => $_[1],
863 'exception' => $!,
864 },
865 ); 0
866 };
867
868
869 # --------------------------------------------------------
870 # File::Util::_seize()
871 # --------------------------------------------------------
872 sub _seize {
873 my($this) = shift(@_); my($file) = shift(@_)||''; my($fh) = shift(@_)||'';
874 my(@policy) = @ONLOCKFAIL;
875 my($policy) = {};
876
877 # seize filehandle, return it if lock is successful
878
879 # forget seizing if system can't flock
880 return($fh) if !$CAN_FLOCK;
881
882 return($this->_throw(q{no file name passed to _seize.})) unless length $file;
883 return($this->_throw(q{no handle passed to _seize.})) unless $fh;
884
885 while (@policy) {
886 my($fh) = &{ $_LOCKS->{ shift @policy } }($this,$file,$fh);
887 return $fh if ($fh || !scalar @policy)
888 }
889
890 $fh;
891 }
892
893
894 # --------------------------------------------------------
895 # File::Util::_release()
896 # --------------------------------------------------------
897 sub _release {
898 my($this,$fh) = @_;
899
900 return($this->_throw('not a filehandle.', {'argtype' => ref(\$fh||'')}))
901 unless ($fh && ref(\$fh||'') eq 'GLOB');
902
903 if ($CAN_FLOCK) { flock($fh, &Fcntl::LOCK_UN) } 1;
904 }
905
906
907 # --------------------------------------------------------
908 # File::Util::valid_filename()
909 # --------------------------------------------------------
910 sub valid_filename {
911 my($f) = myargs(@_);
912
913 $f !~ /$ILLEGAL_CHR/ ? 1 : undef
914 }
915
916
917 # --------------------------------------------------------
918 # File::Util::strip_path()
919 # --------------------------------------------------------
920 sub strip_path { my($f) = myargs(@_); pop @{['', split(/$DIRSPLIT/,$f)]}||'' }
921
922
923 # --------------------------------------------------------
924 # File::Util::line_count()
925 # --------------------------------------------------------
926 sub line_count {
927 my($this,$file) = @_;
928 my($buff) = '';
929 my($lines) = 0;
930 my($cmd) = '<' . $file;
931
932 local(*LINES);
933
934 open(LINES, $file) or
935 return $this->_throw(
936 'bad open',
937 {
938 'filename' => $file,
939 'mode' => 'read',
940 'exception' => $!,
941 'cmd' => $cmd,
942 }
943 );
944
945 while (sysread(LINES, $buff, 4096)) {
946 $lines += $buff =~ tr/\n//; $buff = '';
947 }
948
949 close(LINES); $lines;
950 }
951
952
953 # --------------------------------------------------------
954 # File::Util::_bitmaskify()
955 # --------------------------------------------------------
956 sub _bitmaskify {
957 # save users who mistakenly pass in string values when bitmasks are
958 # required (bitmasks must always be octal numbers)
959
960 my($bmsk) = @_;
961
962 return unless (defined($bmsk) && length($bmsk));
963
964 $bmsk == eval($bmsk) ? $bmsk : oct($bmsk);
965 }
966
967
968 # --------------------------------------------------------
969 # File::Util::DESTROY(), end File::Util class definition
970 # --------------------------------------------------------
971 sub DESTROY {}
972 1;
973
974 __END__
975
976 # --------------------------------------------------------
977 # File::Util::bitmask()
978 # --------------------------------------------------------
979 sub bitmask {
980 my($f) = myargs(@_);
981
982 defined $f and -e $f ? sprintf('%04o',(stat($f))[2] & 0777) : undef
983 }
984
985
986 # --------------------------------------------------------
987 # File::Util::can_flock()
988 # --------------------------------------------------------
989 sub can_flock { $CAN_FLOCK }
990
991
992 # File::Util::--------------------------------------------
993 # can_read(), can_write()
994 # --------------------------------------------------------
995 sub can_read { my($f) = myargs(@_); defined $f ? -r $f : undef }
996 sub can_write { my($f) = myargs(@_); defined $f ? -w $f : undef }
997
998
999 # --------------------------------------------------------
1000 # File::Util::created()
1001 # --------------------------------------------------------
1002 sub created {
1003 my($f) = myargs(@_);
1004
1005 defined $f and -e $f ? $^T - ((-M $f) * 60 * 60 * 24) : undef
1006 }
1007
1008
1009 # --------------------------------------------------------
1010 # File::Util::ebcdic()
1011 # --------------------------------------------------------
1012 sub ebcdic { $EBCDIC }
1013
1014
1015 # --------------------------------------------------------
1016 # File::Util::escape_filename()
1017 # --------------------------------------------------------
1018 sub escape_filename {
1019 my($opts) = shave_opts(\@_);
1020 my($file,$escape,$also) = myargs(@_);
1021
1022 return '' unless defined $file;
1023
1024 $escape = '_' if !defined($escape);
1025
1026 $file = strip_path($file) if $opts->{'--strip-path'};
1027
1028 if ($also) { $file =~ s/\Q$also\E/$escape/g }
1029
1030 $file =~ s/$ILLEGAL_CHR/$escape/g;
1031 $file =~ s/$DIRSPLIT/$escape/g;
1032
1033 $file
1034 }
1035
1036
1037 # --------------------------------------------------------
1038 # File::Util::existent()
1039 # --------------------------------------------------------
1040 sub existent { my($f) = myargs(@_); defined $f ? -e $f : undef }
1041
1042
1043 # --------------------------------------------------------
1044 # File::Util::touch()
1045 # --------------------------------------------------------
1046 sub touch {
1047 my($this) = shift(@_); my($opts) = $this->shave_opts(\@_);
1048 my($in) = $this->coerce_array(@_); my(@dirs) = ();
1049 my($file) = ''; my($path) = '';
1050 my($mode) = 'read';
1051
1052 $file = shift(@_)||'';
1053
1054 @dirs = split(/$DIRSPLIT/, $file);
1055
1056 if (scalar(@dirs) > 0) {
1057
1058 $file = pop(@dirs); $path = join(SL, @dirs);
1059 }
1060
1061 if (length($path) > 0) {
1062 $path = '.' . SL . $path if ($path !~ /(?:^\/)|(?:^\w\:)/o);
1063 }
1064 else { $path = '.'; }
1065
1066 return $this->_throw(
1067 'no input',
1068 {
1069 'meth' => 'touch',
1070 'missing' => 'a file name or file handle reference',
1071 'opts' => $opts,
1072 }
1073 ) if (length($path . SL . $file) == 0);
1074
1075 # see if the file exists already and is a directory
1076 return $this->_throw(
1077 'cant touch on a dir',
1078 {
1079 'filename' => $path . SL . $file,
1080 'dirname' => $path . SL,
1081 'opts' => $opts,
1082 }
1083 ) if (-e $path . SL . $file && -d $path . SL . $file);
1084
1085 # if the path doesn't exist, make it
1086 $this->make_dir($path) unless -e $path . SL;
1087
1088 # it's good to know beforehand whether or not we have permission to open
1089 # and read from this file allowing us to handle such an exception before
1090 # it handles us.
1091
1092 # first check the readability of the file's housing dir
1093 return $this->_throw(
1094 'cant dread',
1095 {
1096 'filename' => $path . SL . $file,
1097 'dirname' => $path . SL,
1098 'opts' => $opts,
1099 }
1100 ) unless (-r $path . SL);
1101
1102 # now check the writability of the file itself
1103 return $this->_throw(
1104 'cant fwrite',
1105 {
1106 'filename' => $path . SL . $file,
1107 'dirname' => $path . SL,
1108 'opts' => $opts,
1109 }
1110 ) if (-e $path . SL . $file && !-w $path . SL . $file);
1111
1112 # create the file if it doesn't exist (like the *nix touch command does)
1113 $this->write_file(
1114 'filename' => $path . SL . $file,
1115 'content' => '',
1116 '--empty-writes-OK'
1117 ) if !-e $path . SL . $file;
1118
1119 my($now) = time();
1120
1121 # return
1122 return utime $now, $now, $path . SL . $file;
1123 }
1124
1125
1126 # --------------------------------------------------------
1127 # File::Util::file_type()
1128 # --------------------------------------------------------
1129 sub file_type {
1130 my($f) = myargs(@_);
1131
1132 return undef unless defined $f and -e $f;
1133
1134 my(@ret) = ();
1135
1136 push @ret, 'PLAIN' if (-f $f); push @ret, 'TEXT' if (-T $f);
1137 push @ret, 'BINARY' if (-B $f); push @ret, 'DIRECTORY' if (-d $f);
1138 push @ret, 'SYMLINK' if (-l $f); push @ret, 'PIPE' if (-p $f);
1139 push @ret, 'SOCKET' if (-S $f); push @ret, 'BLOCK' if (-b $f);
1140 push @ret, 'CHARACTER' if (-c $f); push @ret, 'TTY' if (-t $f);
1141
1142 push(@ret,'Error: cannot determine file type') unless @ret; @ret
1143 }
1144
1145
1146 # --------------------------------------------------------
1147 # File::Util::flock_rules()
1148 # --------------------------------------------------------
1149 sub flock_rules {
1150 my($this) = shift(@_);
1151 my(@rules) = myargs(@_);
1152
1153 return @ONLOCKFAIL unless defined scalar @rules;
1154
1155 my(%valid) = qw/
1156 NOBLOCKEX NOBLOCKEX
1157 NOBLOCKSH NOBLOCKSH
1158 BLOCKEX BLOCKEX
1159 BLOCKSH BLOCKSH
1160 FAIL FAIL
1161 WARN WARN
1162 IGNORE IGNORE
1163 UNDEF UNDEF
1164 ZERO ZERO /;
1165
1166 map {
1167 return $this->_throw('bad flock rules', { 'bad' => $_, 'all' => \@rules })
1168 unless exists $valid{ $_ }
1169 } @rules;
1170
1171 @ONLOCKFAIL = @rules;
1172
1173 @ONLOCKFAIL
1174 }
1175
1176
1177 # --------------------------------------------------------
1178 # File::Util::isbin()
1179 # --------------------------------------------------------
1180 sub isbin { my($f) = myargs(@_); defined $f ? -B $f : undef }
1181
1182
1183 # --------------------------------------------------------
1184 # File::Util::last_access()
1185 # --------------------------------------------------------
1186 sub last_access {
1187 my($f) = myargs(@_); $f ||= '';
1188
1189 return undef unless -e $f;
1190
1191 # return the last accessed time of $f
1192 $^T - ((-A $f) * 60 * 60 * 24)
1193 }
1194
1195
1196 # --------------------------------------------------------
1197 # File::Util::last_modified()
1198 # --------------------------------------------------------
1199 sub last_modified {
1200 my($f) = myargs(@_); $f ||= '';
1201
1202 return undef unless -e $f;
1203
1204 # return the last modified time of $f
1205 $^T - ((-M $f) * 60 * 60 * 24)
1206 }
1207
1208
1209 # --------------------------------------------------------
1210 # File::Util::last_changed()
1211 # --------------------------------------------------------
1212 sub last_changed {
1213 my($f) = myargs(@_); $f ||= '';
1214
1215 return undef unless -e $f;
1216
1217 # return the last changed time of $f
1218 $^T - ((-C $f) * 60 * 60 * 24)
1219 }
1220
1221
1222 # --------------------------------------------------------
1223 # File::Util::load_dir()
1224 # --------------------------------------------------------
1225 sub load_dir {
1226 my($this) = shift(@_); my($opts) = $this->shave_opts(\@_);
1227 my($dir) = shift(@_)||''; my(@files) = ();
1228 my($dir_hash) = {}; my($dir_list) = [];
1229
1230 return $this->_throw
1231 (
1232 'no input',
1233 {
1234 'meth' => 'load_dir',
1235 'missing' => 'a directory name',
1236 'opts' => $opts,
1237 }
1238 )
1239 unless length($dir);
1240
1241 @files = $this->list_dir($dir,'--files-only');
1242
1243 # map the content of each file into a hash key-value element where the
1244 # key name for each file is the name of the file
1245 if (!$opts->{'--as-list'} and !$opts->{'--as-listref'}) {
1246
1247 foreach (@files) {
1248
1249 $dir_hash->{ $_ } = $this->load_file( $dir . SL . $_ );
1250 }
1251
1252 return($dir_hash);
1253 }
1254 else {
1255
1256 foreach (@files) {
1257
1258 push(@{$dir_list},$this->load_file( $dir . SL . $_ ));
1259 }
1260
1261 return($dir_list) if ($opts->{'--as-listref'}); return(@{$dir_list});
1262 }
1263
1264 $dir_hash;
1265 }
1266
1267
1268 # --------------------------------------------------------
1269 # File::Util::make_dir()
1270 # --------------------------------------------------------
1271 sub make_dir {
1272 my($this) = shift(@_);
1273 my($opts) = $this->shave_opts(\@_);
1274 my($dir,$bitmask) = @_; $bitmask = _bitmaskify($bitmask) || 0777;
1275
1276 if ($$opts{'--if-not-exists'}) {
1277 if (-e $dir) {
1278 return $dir if -d $dir;
1279
1280 return $this->_throw(
1281 'called mkdir on a file',
1282 {
1283 'filename' => $dir,
1284 'dirname' => join(SL,(split(/$DIRSPLIT/,$dir))[0 .. -1]) . SL
1285 }
1286 );
1287 }
1288 }
1289 else {
1290 if (-e $dir) {
1291 return $this->_throw(
1292 'called mkdir on a file',
1293 {
1294 'filename' => $dir,
1295 'dirname' => join(SL,(split(/$DIRSPLIT/,$dir))[0 .. -1]) . SL
1296 }
1297 ) unless -d $dir;
1298
1299 return $this->_throw(
1300 'make_dir target exists',
1301 {
1302 'dirname' => $dir,
1303 'filetype' => [ $this->file_type($dir) ],
1304 }
1305 );
1306 }
1307 }
1308
1309 # if the call to this method didn't include a directory name to create,
1310 # then complain about it
1311 return $this->_throw(
1312 'no input',
1313 {
1314 'meth' => 'make_dir',
1315 'missing' => 'a directory name',
1316 }
1317 ) unless (defined($dir) && length($dir));
1318
1319 # if prospective directory name contains 2+ dir separators in sequence then
1320 # this is a syntax error we need to whine about
1321 return $this->_throw(
1322 'bad chars',
1323 {
1324 'string' => $dir,
1325 'purpose' => 'the name of a directory',
1326 }
1327 ) if ($dir =~ /$DIRSPLIT{2,}/);
1328
1329 $dir =~ s/$DIRSPLIT$// unless $dir eq $DIRSPLIT;
1330
1331 my(@dirs_in_path) = split(/$DIRSPLIT/, $dir);
1332
1333 # for absolute pathnames
1334 if (substr($dir,0,1) eq SL) {
1335 $dirs_in_path[0] = SL;
1336 }
1337
1338 for (my($i) = 0; $i < scalar @dirs_in_path; ++$i) {
1339 next if $i == 0 && $dirs_in_path[$i] eq SL;
1340
1341 # if prospective directory name contains illegal chars then complain
1342 return $this->_throw(
1343 'bad chars',
1344 {
1345 'string' => $dirs_in_path[$i],
1346 'purpose' => 'the name of a directory',
1347 }
1348 ) unless $this->valid_filename($dirs_in_path[$i])
1349 }
1350
1351 # qualify each subdir in @dirs_in_path by prepending its preceeding dir
1352 # names to it. Above, "/foo/bar/baz" becomes ("/", "foo", "bar", "baz")
1353 # and below it becomes ("/", "/foo", "/foo/bar", "/foo/bar/baz")
1354
1355 if (scalar(@dirs_in_path) > 1) {
1356 for (my($depth) = 1; $depth < scalar @dirs_in_path; ++$depth) {
1357 if ($dirs_in_path[$depth-1] eq SL) {
1358 $dirs_in_path[$depth] = SL . $dirs_in_path[$depth]
1359 }
1360 else {
1361 $dirs_in_path[$depth] = join(SL, @dirs_in_path[($depth-1)..$depth])
1362 }
1363 }
1364 }
1365
1366 my($i) = 0;
1367
1368 foreach (@dirs_in_path) {
1369 my($dir) = $_;
1370 my($up) = ($i > 0) ? $dirs_in_path[$i-1] : '..';
1371
1372 ++$i;
1373
1374 if (-e $dir and !-d $dir) {
1375 return $this->_throw(
1376 'called mkdir on a file',
1377 {
1378 'filename' => $dir,
1379 'dirname' => $up . SL,
1380 }
1381 );
1382 }
1383
1384 next if -e $dir;
1385
1386 # it's good to know beforehand whether or not we have permission to
1387 # create dirs here, which allows us to handle such an exception
1388 # before it handles us.
1389 return $this->_throw(
1390 'cant dcreate',
1391 {
1392 'dirname' => $dir,
1393 'parentd' => $up,
1394 }
1395 ) unless -w $up;
1396
1397 mkdir($dir, $bitmask) or
1398 return $this->_throw(
1399 'bad make_dir',
1400 {
1401 'exception' => $!,
1402 'dirname' => $dir,
1403 'bitmask' => $bitmask,
1404 }
1405 );
1406 }
1407
1408 $dir;
1409 }
1410
1411
1412 # --------------------------------------------------------
1413 # File::Util::max_dives()
1414 # --------------------------------------------------------
1415 sub max_dives {
1416 my($arg) = myargs(@_);
1417
1418 if (defined($arg)) {
1419 return $this->_throw('bad maxdives') if $arg !~ /\D/o;
1420 $MAXDIVES = $arg;
1421 }
1422
1423 $MAXDIVES
1424 }
1425
1426
1427 # --------------------------------------------------------
1428 # File::Util::readlimt()
1429 # --------------------------------------------------------
1430 sub readlimit {
1431 my($arg) = myargs(@_);
1432
1433 if (defined($arg)) {
1434 return $this->_throw
1435 (
1436 'bad readlimit',
1437 {
1438 'bad' => $arg,
1439 }
1440 ) if $arg !~ /\D/o;
1441
1442 $READLIMIT = $arg;
1443 }
1444
1445 $READLIMIT
1446 }
1447
1448
1449 # --------------------------------------------------------
1450 # File::Util::needs_binmode()
1451 # --------------------------------------------------------
1452 sub needs_binmode { $NEEDS_BINMODE }
1453
1454
1455 # --------------------------------------------------------
1456 # File::Util::open_handle()
1457 # --------------------------------------------------------
1458 sub open_handle {
1459 my($this) = shift(@_);
1460 my($opts) = $this->shave_opts(\@_);
1461 my($in) = $this->coerce_array(@_);
1462 my($filename) = $in->{'file'} || $in->{'filename'} || '';
1463 my($mode) = $in->{'mode'} || 'write';
1464 my($bitmask) = _bitmaskify($in->{'bitmask'}) || 0777;
1465 my($fh) = undef;
1466 my($path) = '';
1467 my(@dirs) = ();
1468
1469 $path = $filename;
1470
1471 # begin user input validation/sanitation sequence
1472
1473 # if the call to this method didn't include a filename to which the caller
1474 # wants us to write, then complain about it
1475 return $this->_throw(
1476 'no input',
1477 {
1478 'meth' => 'open_handle',
1479 'missing' => 'a file name to create, write, read/write, or append',
1480 'opts' => $opts,
1481 }
1482 ) unless length($filename);
1483
1484 # if prospective filename contains 2+ dir separators in sequence then
1485 # this is a syntax error we need to whine about
1486 return $this->_throw(
1487 'bad chars',
1488 {
1489 'string' => $filename,
1490 'purpose' => 'the name of a file or directory',
1491 'opts' => $opts,
1492 }
1493 ) if ($filename =~ /(?:$DIRSPLIT){2,}/);
1494
1495 # remove trailing directory seperator
1496 $filename =~ s/$DIRSPLIT$//;
1497
1498 # determine existance of the file path, make directory(ies) for the
1499 # path if the full directory path doesn't exist
1500 @dirs = split(/$DIRSPLIT/, $filename);
1501
1502 # if prospective file name has illegal chars then complain
1503 foreach (@dirs) {
1504 return $this->_throw(
1505 'bad chars',
1506 {
1507 'string' => $_,
1508 'purpose' => 'the name of a file or directory',
1509 'opts' => $opts,
1510 }
1511 ) if (!$this->valid_filename($_));
1512 }
1513
1514 # make sure that open mode is a valid mode
1515 if (
1516 !exists($opts->{'--use-sysopen'}) &&
1517 !defined($opts->{'--use-sysopen'})
1518 ) {
1519 # native Perl open modes
1520 unless (
1521 exists($$MODES{'popen'}{ $mode }) &&
1522 defined($$MODES{'popen'}{ $mode })
1523 ) {
1524 return $this->_throw(
1525 'bad openmode popen',
1526 {
1527 'meth' => 'open_handle',
1528 'filename' => $filename,
1529 'badmode' => $mode,
1530 'opts' => $opts,
1531 }
1532 )
1533 }
1534 }
1535 else {
1536 # system open modes
1537 unless (
1538 exists($$MODES{'sysopen'}{ $mode }) &&
1539 defined($$MODES{'sysopen'}{ $mode })
1540 ) {
1541 return $this->_throw(
1542 'bad openmode sysopen',
1543 {
1544 'meth' => 'open_handle',
1545 'filename' => $filename,
1546 'badmode' => $mode,
1547 'opts' => $opts,
1548 }
1549 )
1550 }
1551 }
1552
1553 if (scalar(@dirs) > 0) { $filename = pop(@dirs); $path = join(SL, @dirs); }
1554
1555 if (length($path) > 0) {
1556 $path = '.' . SL . $path if ($path !~ /(?:^\/)|(?:^\w\:)/o);
1557 }
1558 else { $path = '.'; }
1559
1560 # create path preceding file if path doesn't exist
1561 $this->make_dir(
1562 $path,
1563 exists $in->{'dbitmask'} ? _bitmaskify($in->{'dbitmask'}) : 0777
1564 ) unless -e $path;
1565
1566 my($openarg) = qq[$path$SL$filename];
1567
1568 # sanity checks based on requested mode
1569 if (
1570 $mode eq 'write' ||
1571 $mode eq 'append' ||
1572 $mode eq 'rwcreate' ||
1573 $mode eq 'rwclobber' ||
1574 $mode eq 'rwappend'
1575 ) {
1576 # Check whether or not we have permission to open and perform writes
1577 # on this file.
1578
1579 if (-e $openarg) {
1580 return $this->_throw(
1581 'cant fwrite',
1582 {
1583 'filename' => $openarg,
1584 'dirname' => $path,
1585 'opts' => $opts,
1586 }
1587 ) unless (-w $openarg);
1588 }
1589 else {
1590 # If file doesn't exist and the path isn't writable, the error is
1591 # one of unallowed creation.
1592 return $this->_throw(
1593 'cant fcreate',
1594 {
1595 'filename' => $openarg,
1596 'dirname' => $path,
1597 'opts' => $opts,
1598 }
1599 ) unless (-w $path . SL);
1600 }
1601 }
1602 elsif ($mode eq 'read' || $mode eq 'rwupdate') {
1603 # Check whether or not we have permission to open and perform reads
1604 # on this file, starting with file's housing directory.
1605 return $this->_throw(
1606 'cant dread',
1607 {
1608 'filename' => $path . SL . $filename,
1609 'dirname' => $path,
1610 'opts' => $opts,
1611 }
1612 ) unless (-r $path . SL);
1613
1614 # Seems obvious, but we can't read non-existent files
1615 return $this->_throw(
1616 'cant fread not found',
1617 {
1618 'filename' => $path . SL . $filename,
1619 'dirname' => $path,
1620 'opts' => $opts,
1621 }
1622 ) unless (-e $path . SL . $filename);
1623
1624 # Check the readability of the file itself
1625 return $this->_throw(
1626 'cant fread',
1627 {
1628 'filename' => $path . SL . $filename,
1629 'dirname' => $path,
1630 'opts' => $opts,
1631 }
1632 ) unless (-r $path . SL . $filename);
1633 }
1634 else {
1635 return $this->_throw(
1636 'no input',
1637 {
1638 'meth' => 'open_handle',
1639 'missing' => q{a valid IO mode. (eg- 'read', 'write'...)},
1640 'opts' => $opts,
1641 }
1642 )
1643 }
1644 # input validation sequence finished
1645
1646 # we need a unique filehandle
1647 do { $fh = int(rand(time)) . $$; $fh = eval('*' . 'OPEN_TO_FH' . $fh) }
1648 while ( fileno($fh) );
1649
1650 # if you use the '--no-lock' option you are probably inefficient
1651 if ($$opts{'--no-lock'} || !$USE_FLOCK) {
1652 if (
1653 !exists($opts->{'--use-sysopen'}) &&
1654 !defined($opts->{'--use-sysopen'})
1655 ) { # perl open
1656 # get open mode
1657 $mode = $$MODES{'popen'}{ $mode };
1658
1659 open($fh, $mode . $openarg) or
1660 return $this->_throw(
1661 'bad open',
1662 {
1663 'filename' => $openarg,
1664 'mode' => $mode,
1665 'exception' => $!,
1666 'cmd' => $mode . $openarg,
1667 'opts' => $opts,
1668 }
1669 );
1670 }
1671 else { # sysopen
1672 # get open mode
1673 $mode = $$MODES{'sysopen'}{ $mode };
1674
1675 sysopen($fh, $openarg, eval($$MODES{'sysopen'}{ $mode })) or
1676 return $this->_throw(
1677 'bad open',
1678 {
1679 'filename' => $openarg,
1680 'mode' => $mode,
1681 'exception' => $!,
1682 'cmd' => qq{$openarg, $$MODES{'sysopen'}{ $mode }},
1683 'opts' => $opts,
1684 }
1685 );
1686 }
1687 }
1688 else {
1689 if (
1690 !exists($opts->{'--use-sysopen'}) &&
1691 !defined($opts->{'--use-sysopen'})
1692 ) { # perl open
1693 # open read-only first to safely check if we can get a lock.
1694 if (-e $openarg) {
1695
1696 open($fh, '<' . $openarg) or
1697 return $this->_throw(
1698 'bad open',
1699 {
1700 'filename' => $openarg,
1701 'mode' => 'read',
1702 'exception' => $!,
1703 'cmd' => $mode . $openarg,
1704 'opts' => $opts,
1705 }
1706 );
1707
1708 # lock file before I/O on platforms that support it
1709 my($lockstat) = $this->_seize($openarg, $fh);
1710
1711 return($lockstat) unless $lockstat;
1712
1713 if ($mode ne 'read') {
1714 open($fh, $$MODES{'popen'}{ $mode } . $openarg) or
1715 return $this->_throw(
1716 'bad open',
1717 {
1718 'exception' => $!,
1719 'filename' => $openarg,
1720 'mode' => $mode,
1721 'opts' => $opts,
1722 'cmd' => $$MODES{'popen'}{ $mode } . $openarg,
1723 }
1724 );
1725 }
1726 }
1727 else {
1728 open($fh, $$MODES{'popen'}{ $mode } . $openarg) or
1729 return $this->_throw(
1730 'bad open',
1731 {
1732 'exception' => $!,
1733 'filename' => $openarg,
1734 'mode' => $mode,
1735 'opts' => $opts,
1736 'cmd' => $$MODES{'popen'}{ $mode } . $openarg,
1737 }
1738 );
1739
1740 # lock file before I/O on platforms that support it
1741 my($lockstat) = $this->_seize($openarg, $fh);
1742
1743 return($lockstat) unless $lockstat;
1744 }
1745 }
1746 else { # sysopen
1747 # open read-only first to safely check if we can get a lock.
1748 if (-e $openarg) {
1749
1750 open($fh, '<' . $openarg) or
1751 return $this->_throw(
1752 'bad open',
1753 {
1754 'filename' => $openarg,
1755 'mode' => 'read',
1756 'exception' => $!,
1757 'cmd' => $mode . $openarg,
1758 'opts' => $opts,
1759 }
1760 );
1761
1762 # lock file before I/O on platforms that support it
1763 my($lockstat) = $this->_seize($openarg, $fh);
1764
1765 return($lockstat) unless $lockstat;
1766
1767 sysopen($fh, $openarg, eval($$MODES{'sysopen'}{ $mode }))
1768 or return $this->_throw(
1769 'bad open',
1770 {
1771 'filename' => $openarg,
1772 'mode' => $mode,
1773 'opts' => $opts,
1774 'exception' => $!,
1775 'cmd' => qq{$openarg, $$MODES{'sysopen'}{ $mode }},
1776 }
1777 );
1778 }
1779 else { # only non-existent files get bitmask arguments
1780 sysopen(
1781 $fh,
1782 $openarg,
1783 eval($$MODES{'sysopen'}{ $mode }),
1784 $bitmask
1785 ) or return $this->_throw(
1786 'bad open',
1787 {
1788 'filename' => $openarg,
1789 'mode' => $mode,
1790 'opts' => $opts,
1791 'exception' => $!,
1792 'cmd' => qq{$openarg, $$MODES{'sysopen'}{$mode}, $bitmask},
1793 }
1794 );
1795
1796 # lock file before I/O on platforms that support it
1797 my($lockstat) = $this->_seize($openarg, $fh);
1798
1799 return($lockstat) unless $lockstat;
1800 }
1801 }
1802 }
1803
1804 # call binmode on the filehandle if it was requested
1805 CORE::binmode($fh) if $in->{'binmode'} || $opts->{'--binmode'};
1806
1807 # return file handle reference to the caller
1808 $fh;
1809 }
1810
1811
1812 # --------------------------------------------------------
1813 # File::Util::unlock_open_handle()
1814 # --------------------------------------------------------
1815 sub unlock_open_handle {
1816 my($this,$fh) = @_;
1817
1818 return 1 if !$USE_FLOCK;
1819
1820 return($this->_throw('not a filehandle.', {'argtype' => ref(\$fh||'')}))
1821 unless ($fh && ref(\$fh||'') eq 'GLOB');
1822
1823 if ($CAN_FLOCK) { return flock($fh, &Fcntl::LOCK_UN) } 1;
1824 }
1825
1826
1827 # --------------------------------------------------------
1828 # File::Util::return_path()
1829 # --------------------------------------------------------
1830 sub return_path { my($f) = myargs(@_); $f =~ s/(^.*)$DIRSPLIT.*/$1/o; $f }
1831
1832
1833 # --------------------------------------------------------
1834 # File::Util::size()
1835 # --------------------------------------------------------
1836 sub size { my($f) = myargs(@_); $f ||= ''; return undef unless -e $f; -s $f }
1837
1838
1839 # --------------------------------------------------------
1840 # File::Util::trunc()
1841 # --------------------------------------------------------
1842 sub trunc { $_[0]->write_file('mode' => 'trunc', 'file' => $_[1]) }
1843
1844
1845 # --------------------------------------------------------
1846 # File::Util::use_flock()
1847 # --------------------------------------------------------
1848 sub use_flock {
1849 my($arg) = myargs(@_);
1850
1851 if (defined($arg)) { $USE_FLOCK = $arg }
1852
1853 $USE_FLOCK
1854 }
1855
1856
1857 # --------------------------------------------------------
1858 # File::Util::_throw
1859 # --------------------------------------------------------
1860 sub _throw {
1861 my($this) = shift(@_); my($opts) = $this->shave_opts(\@_);
1862 my(%fatal_rules) = ();
1863
1864 # fatalality-handling rules passed to the failing caller trump the
1865 # rules set up in the attributes of the object; the mechanism below
1866 # also allows for the implicit handling of '--fatals-are-fatal'
1867 map { $fatal_rules{ $_ } = $_ }
1868 grep(/^--fatals/o, values %$opts);
1869
1870 unless (scalar keys %fatal_rules) {
1871 map { $fatal_rules{ $_ } = $_ }
1872 grep(/^--fatals/o, keys %{ $this->{'opts'} })
1873 }
1874
1875 return(0) if $fatal_rules{'--fatals-as-status'};
1876
1877 $this->{'expt'}||={};
1878
1879 unless (UNIVERSAL::isa($this->{'expt'},'Exception::Handler')) {
1880 require Exception::Handler;
1881 $this->{'expt'} = Exception::Handler->new();
1882 }
1883
1884 my($error) = ''; my($in) = {};
1885
1886 if (@_ == 1) {
1887
1888 if (defined($_[0])) { $error = 'plain error'; goto PLAIN_ERRORS }
1889 }
1890 else { $error = shift(@_) || 'empty error' }
1891
1892 $in = shift(@_)||{}; $in->{'_pak'} = __PACKAGE__;
1893
1894 map { $_ = defined($_) ? $_ : 'undefined value' } keys(%$in);
1895
1896 PLAIN_ERRORS:
1897
1898 my($bad_news) =
1899 CORE::eval
1900 (
1901 q{<<__ERRORBLOCK__}
1902 . &NL . &_errors($error)
1903 . &NL . q{__ERRORBLOCK__}
1904 );
1905
1906 ## for debugging only
1907 # if ($@) { return $this->{'expt'}->trace($@) }
1908
1909 if ($fatal_rules{'--fatals-as-warning'}) {
1910
1911 warn($this->{'expt'}->trace(($@ || $bad_news))) and return
1912 }
1913 elsif ( $fatal_rules{'--fatals-as-errmsg'} || $opts->{'--return'}) {
1914
1915 return($this->{'expt'}->trace(($@ || $bad_news)))
1916 }
1917
1918 foreach (keys(%{$in})) {
1919
1920 next if ($_ eq 'opts');
1921
1922 $bad_news .= qq[ARG $_ = $in->{$_}] . $NL;
1923 }
1924
1925 if ($in->{'opts'}) {
1926
1927 foreach (keys(%{$$in{'opts'}})) {
1928
1929 $_ = (defined($_)) ? $_ : 'empty value';
1930
1931 $bad_news .= qq[OPT $_] . $NL;
1932 }
1933 }
1934
1935 warn($this->{'expt'}->trace(($@ || $bad_news))) if ($opts->{'--warn-also'});
1936
1937 $this->{'expt'}->fail(($@ || $bad_news));
1938
1939 '';
1940 }
1941
1942
1943 #%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#
1944 # ERROR MESSAGES
1945 #%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#
1946 sub _errors {
1947 use vars qw($EBL $EBR);
1948 ($EBL,$EBR) = (chr(187), chr(171));
1949 ($EBL,$EBR) = ('{','}') if ($OS eq 'DOS');
1950 my($error_thrown) = shift(@_);
1951
1952 # begin long table of helpful diag error messages
1953 my(%error_msg_table) = (
1954 # NO SUCH FILE
1955 'no such file' => <<'__bad_open__',
1956 $in->{'_pak'} can't open
1957 $EBL$in->{'filename'}$EBR
1958 because no such file or directory exists.
1959
1960 Origin: This is *most likely* due to human error.
1961 Solution: Cannot diagnose. A human must investigate the problem.
1962 __bad_open__
1963
1964
1965 # BAD FLOCK RULE POLICY
1966 'bad flock rules' => <<'__bad_lockrules__',
1967 Invalid file locking policy can not be implemented. $in->{'_pak'}::flock_rules
1968 does not accept one or more of the policy keywords passed to this method.
1969
1970 Invalid Policy specified: $EBL@{[
1971 join ' ', map { '[undef]' unless defined $_ } @{ $in->{'all'} } ]}$EBR
1972
1973 flock_rules policy in effect before invalid policy failed:
1974 $EBL@ONLOCKFAIL$EBR
1975
1976 Proper flock_rules policy includes one or more of the following recognized
1977 keywords specified in order of precedence:
1978 BLOCK waits to try getting an exclusive lock
1979 FAIL dies with stack trace
1980 WARN warn()s about the error with a stack trace
1981 IGNORE ignores the failure to get an exclusive lock
1982 UNDEF returns undef
1983 ZERO returns 0
1984
1985 Origin: This is a human error.
1986 Solution: A human must fix the programming flaw.
1987 __bad_lockrules__
1988
1989
1990 # CAN'T READ FILE - PERMISSIONS
1991 'cant fread' => <<'__cant_read__',
1992 Permissions conflict. $in->{'_pak'} can't read the contents of this file:
1993 $EBL$in->{'filename'}$EBR
1994
1995 Due to insufficient permissions, the system has denied Perl the right to
1996 view the contents of this file. It has a bitmask of: (octal number)
1997 $EBL@{[ sprintf('%04o',(stat($in->{'filename'}))[2] & 0777) ]}$EBR
1998
1999 The directory housing it has a bitmask of: (octal number)
2000 $EBL@{[ sprintf('%04o',(stat($in->{'dirname'}))[2] & 0777) ]}$EBR
2001
2002 Current flock_rules policy:
2003 $EBL@ONLOCKFAIL$EBR
2004
2005 Origin: This is *most likely* due to human error. External system errors
2006 can occur however, but this doesn't have to do with $in->{'_pak'}.
2007 Solution: A human must fix the conflict by adjusting the file permissions
2008 of directories where a program asks $in->{'_pak'} to perform I/O.
2009 Try using Perl's chmod command, or the native system chmod()
2010 command from a shell.
2011 __cant_read__
2012
2013
2014 # CAN'T READ FILE - NOT EXISTENT
2015 'cant fread not found' => <<'__cant_read__',
2016 File not found. $in->{'_pak'} can't read the contents of this file:
2017 $EBL$in->{'filename'}$EBR
2018
2019 The file specified does not exist. It can not be opened or read from.
2020
2021 Origin: This is *most likely* due to human error. External system errors
2022 can occur however, but this doesn't have to do with $in->{'_pak'}.
2023 Solution: A human must investigate why the application tried to open a
2024 non-existent file, and/or why the file is expected to exist and
2025 is not found.
2026 __cant_read__
2027
2028
2029 # CAN'T CREATE FILE - PERMISSIONS
2030 'cant fcreate' => <<'__cant_write__',
2031 Permissions conflict. $in->{'_pak'} can't create this file:
2032 $EBL$in->{'filename'}$EBR
2033
2034 $in->{'_pak'} can't create this file because the system has denied Perl
2035 the right to create files in the parent directory.
2036
2037 The -e test returns $EBL@{[-e $in->{'dirname'} ]}$EBR for the directory.
2038 The -r test returns $EBL@{[-r $in->{'dirname'} ]}$EBR for the directory.
2039 The -R test returns $EBL@{[-R $in->{'dirname'} ]}$EBR for the directory.
2040 The -w test returns $EBL@{[-w $in->{'dirname'} ]}$EBR for the directory
2041 The -W test returns $EBL@{[-w $in->{'dirname'} ]}$EBR for the directory
2042
2043 Parent directory: (path may be relative and/or redundant)
2044 $EBL$in->{'dirname'}$EBR
2045
2046 Parent directory has a bitmask of: (octal number)
2047 $EBL@{[ sprintf('%04o',(stat($in->{'dirname'}))[2] & 0777) ]}$EBR
2048
2049 Current flock_rules policy:
2050 $EBL@ONLOCKFAIL$EBR
2051
2052 Origin: This is *most likely* due to human error. External system errors
2053 can occur however, but this doesn't have to do with $in->{'_pak'}.
2054 Solution: A human must fix the conflict by adjusting the file permissions
2055 of directories where a program asks $in->{'_pak'} to perform I/O.
2056 Try using Perl's chmod command, or the native system chmod()
2057 command from a shell.
2058 __cant_write__
2059
2060
2061 # CAN'T WRITE TO FILE - EXISTS AS DIRECTORY
2062 'cant write_file on a dir' => <<'__bad_writefile__',
2063 $in->{'_pak'} can't write to the specified file because it already exists
2064 as a directory.
2065 $EBL$in->{'filename'}$EBR
2066
2067 Origin: This is a human error.
2068 Solution: Resolve naming issue between the existent directory and the file
2069 you wish to create/write/append.
2070 __bad_writefile__
2071
2072
2073 # CAN'T TOUCH A FILE - EXISTS AS DIRECTORY
2074 'cant touch on a dir' => <<'__bad_touchfile__',
2075 $in->{'_pak'} can't touch the specified file because it already exists
2076 as a directory.
2077 $EBL$in->{'filename'}$EBR
2078
2079 Origin: This is a human error.
2080 Solution: Resolve naming issue between the existent directory and the file
2081 you wish to touch.
2082 __bad_touchfile__
2083
2084
2085 # CAN'T WRITE TO FILE
2086 'cant fwrite' => <<'__cant_write__',
2087 Permissions conflict. $in->{'_pak'} can't write to this file:
2088 $EBL$in->{'filename'}$EBR
2089
2090 Due to insufficient permissions, the system has denied Perl the right
2091 to modify the contents of this file. It has a bitmask of: (octal number)
2092 $EBL@{[ sprintf('%04o',(stat($in->{'filename'}))[2] & 0777) ]}$EBR
2093
2094 Parent directory has a bitmask of: (octal number)
2095 $EBL@{[ sprintf('%04o',(stat($in->{'dirname'}))[2] & 0777) ]}$EBR
2096
2097 Current flock_rules policy:
2098 $EBL@ONLOCKFAIL$EBR
2099
2100 Origin: This is *most likely* due to human error. External system errors
2101 can occur however, but this doesn't have to do with $in->{'_pak'}.
2102 Solution: A human must fix the conflict by adjusting the file permissions
2103 of directories where a program asks $in->{'_pak'} to perform I/O.
2104 Try using Perl's chmod command, or the native system chmod()
2105 command from a shell.
2106 __cant_write__
2107
2108
2109 # BAD OPEN MODE - PERL
2110 'bad openmode popen' => <<'__bad_openmode__',
2111 Illegal mode specified for file open. $in->{'_pak'} can't open this file:
2112 $EBL$in->{'filename'}$EBR
2113
2114 When calling $in->{'_pak'}::$in->{'meth'}() you specified that the file
2115 opened in this I/O operation should be opened in $EBL$in->{'badmode'}$EBR
2116 but that is not a recognized open mode.
2117
2118 Supported open modes for $in->{'_pak'}::write_file() are:
2119 write - open the file in write mode, creating it if necessary, and
2120 overwriting any existing contents of the file.
2121 append - open the file in append mode
2122
2123 Supported open modes for $in->{'_pak'}::open_handle() are the same as above, but
2124 also include the following:
2125 read - open the file in read-only mode
2126
2127 (and if the --use-sysopen flag is used):
2128 rwcreate - open the file for update (read+write), creating it if necessary
2129 rwupdate - open the file for update (read+write). Causes fatal error if
2130 the file doesn't yet exist
2131 rwappend - open the file for update in append mode
2132 rwclobber - open the file for update, erasing all contents (truncating,
2133 i.e- "clobbering" the file first)
2134
2135 Origin: This is a human error.
2136 Solution: A human must fix the programming flaw by specifying the desired
2137 open mode from the list above.
2138 __bad_openmode__
2139
2140
2141 # BAD OPEN MODE - SYSOPEN
2142 'bad openmode sysopen' => <<'__bad_openmode__',
2143 Illegal mode specified for file sysopen. $in->{'_pak'} can't sysopen this file:
2144 $EBL$in->{'filename'}$EBR
2145
2146 When calling $in->{'_pak'}::$in->{'meth'}() you specified that the file
2147 opened in this I/O operation should be sysopen()'d in $EBL$in->{'badmode'}$EBR
2148 but that is not a recognized open mode.
2149
2150 Supported open modes for $in->{'_pak'}::write_file() are:
2151 write - open the file in write mode, creating it if necessary, and
2152 overwriting any existing contents of the file.
2153 append - open the file in append mode
2154
2155 Supported open modes for $in->{'_pak'}::open_handle() are the same as above, but
2156 also include the following:
2157 read - open the file in read-only mode
2158
2159 (and if the --use-sysopen flag is used, as the application JUST did):
2160 rwcreate - open the file for update (read+write), creating it if necessary
2161 rwupdate - open the file for update (read+write). Causes fatal error if
2162 the file doesn't yet exist
2163 rwappend - open the file for update in append mode
2164 rwclobber - open the file for update, erasing all contents (truncating,
2165 i.e- "clobbering" the file first)
2166
2167 Origin: This is a human error.
2168 Solution: A human must fix the programming flaw by specifying the desired
2169 sysopen mode from the list above.
2170 __bad_openmode__
2171
2172
2173 # CAN'T LIST DIRECTORY
2174 'cant dread' => <<'__cant_read__',
2175 Permissions conflict. $in->{'_pak'} can't list the contents of this directory:
2176 $EBL$in->{'dirname'}$EBR
2177
2178 Due to insufficient permissions, the system has denied Perl the right to
2179 view the contents of this directory. It has a bitmask of: (octal number)
2180 $EBL@{[ sprintf('%04o',(stat($in->{'dirname'}))[2] & 0777) ]}$EBR
2181
2182 Origin: This is *most likely* due to human error. External system errors
2183 can occur however, but this doesn't have to do with $in->{'_pak'}.
2184 Solution: A human must fix the conflict by adjusting the file permissions
2185 of directories where a program asks $in->{'_pak'} to perform I/O.
2186 Try using Perl's chmod command, or the native system chmod()
2187 command from a shell.
2188 __cant_read__
2189
2190
2191 # CAN'T CREATE DIRECTORY - PERMISSIONS
2192 'cant dcreate' => <<'__cant_dcreate__',
2193 Permissions conflict. $in->{'_pak'} can't create:
2194 $EBL$in->{'dirname'}$EBR
2195
2196 $in->{'_pak'} can't create this directory because the system has denied
2197 Perl the right to create files in the parent directory.
2198
2199 Parent directory: (path may be relative and/or redundant)
2200 $EBL$in->{'parentd'}$EBR
2201
2202 Parent directory has a bitmask of: (octal number)
2203 $EBL@{[ sprintf('%04o',(stat($in->{'parentd'}))[2] & 0777) ]}$EBR
2204
2205 Origin: This is *most likely* due to human error. External system errors
2206 can occur however, but this doesn't have to do with $in->{'_pak'}.
2207 Solution: A human must fix the conflict by adjusting the file permissions
2208 of directories where a program asks $in->{'_pak'} to perform I/O.
2209 Try using Perl's chmod command, or the native system chmod()
2210 command from a shell.
2211 __cant_dcreate__
2212
2213
2214 # CAN'T CREATE DIRECTORY - TARGET EXISTS
2215 'make_dir target exists' => <<'__cant_dcreate__',
2216 make_dir target already exists.
2217 $EBL$in->{'dirname'}$EBR
2218
2219 $in->{'_pak'} can't create the directory you specified because that
2220 directory already exists, with filetype attributes of
2221 @{[join(', ', @{ $in->{'filetype'} })]} and permissions
2222 set to $EBL@{[ sprintf('%04o',(stat($in->{'dirname'}))[2] & 0777) ]}$EBR
2223
2224 Origin: This is *most likely* due to human error. The program has tried
2225 to make a directory where a directory already exists.
2226 Solution: Weaken the requirement somewhat by using the "--if-not-exists"
2227 flag when calling the make_dir object method. This option
2228 will cause $in->{'_pak'} to ignore attempts to create directories
2229 that already exist, while still creating the ones that don't.
2230 __cant_dcreate__
2231
2232
2233 # CAN'T OPEN
2234 'bad open' => <<'__bad_open__',
2235 $in->{'_pak'} can't open this file for $EBL$in->{'mode'}$EBR:
2236 $EBL$in->{'filename'}$EBR
2237
2238 The system returned this error:
2239 $EBL$in->{'exception'}$EBR
2240
2241 $in->{'_pak'} used this directive in its attempt to open the file
2242 $EBL$in->{'cmd'}$EBR
2243
2244 Current flock_rules policy:
2245 $EBL@ONLOCKFAIL$EBR
2246
2247 Origin: This is *most likely* due to human error.
2248 Solution: Cannot diagnose. A Human must investigate the problem.
2249 __bad_open__
2250
2251
2252 # BAD CLOSE
2253 'bad close' => <<'__bad_close__',
2254 $in->{'_pak'} couldn't close this file after $EBL$in->{'mode'}$EBR
2255 $EBL$in->{'filename'}$EBR
2256
2257 The system returned this error:
2258 $EBL$in->{'exception'}$EBR
2259
2260 Current flock_rules policy:
2261 $EBL@ONLOCKFAIL$EBR
2262
2263 Origin: Could be either human _or_ system error.
2264 Solution: Cannot diagnose. A Human must investigate the problem.
2265 __bad_close__
2266
2267
2268 # CAN'T TRUNCATE
2269 'bad systrunc' => <<'__bad_systrunc__',
2270 $in->{'_pak'} couldn't truncate() on $EBL$in->{'filename'}$EBR after having
2271 successfully opened the file in write mode.
2272
2273 The system returned this error:
2274 $EBL$in->{'exception'}$EBR
2275
2276 Current flock_rules policy:
2277 $EBL@ONLOCKFAIL$EBR
2278
2279 This is most likely _not_ a human error, but has to do with your system's
2280 support for the C truncate() function.
2281 __bad_systrunc__
2282
2283
2284 # CAN'T GET FLOCK AFTER BLOCKING
2285 'bad flock' => <<'__bad_lock__',
2286 $in->{'_pak'} can't get a lock on the file
2287 $EBL$in->{'filename'}$EBR
2288
2289 The system returned this error:
2290 $EBL$in->{'exception'}$EBR
2291
2292 Current flock_rules policy:
2293 $EBL@ONLOCKFAIL$EBR
2294
2295 Origin: Could be either human _or_ system error.
2296 Solution: Investigate the reason why you can't get a lock on the file,
2297 it is usually because of improper programming which causes
2298 race conditions on one or more files.
2299 __bad_lock__
2300
2301
2302 # CAN'T OPEN ON A DIRECTORY
2303 'called open on a dir' => <<'__bad_open__',
2304 $in->{'_pak'} can't call open() on this file because it is a directory
2305 $EBL$in->{'filename'}$EBR
2306
2307 Origin: This is a human error.
2308 Solution: Use $in->{'_pak'}::load_file() to load the contents of a file
2309 Use $in->{'_pak'}::list_dir() to list the contents of a directory
2310 __bad_open__
2311
2312
2313 # CAN'T OPENDIR ON A FILE
2314 'called opendir on a file' => <<'__bad_open__',
2315 $in->{'_pak'} can't opendir() on this file because it is not a directory.
2316 $EBL$in->{'filename'}$EBR
2317
2318 Use $in->{'_pak'}::load_file() to load the contents of a file
2319 Use $in->{'_pak'}::list_dir() to list the contents of a directory
2320
2321 Origin: This is a human error.
2322 Solution: Use $in->{'_pak'}::load_file() to load the contents of a file
2323 Use $in->{'_pak'}::list_dir() to list the contents of a directory
2324 __bad_open__
2325
2326
2327 # CAN'T MKDIR ON A FILE
2328 'called mkdir on a file' => <<'__bad_open__',
2329 $in->{'_pak'} can't auto-create a directory for this path name because it
2330 already exists as a file.
2331 $EBL$in->{'filename'}$EBR
2332
2333 Origin: This is a human error.
2334 Solution: Resolve naming issue between the existent file and the directory
2335 you wish to create.
2336 __bad_open__
2337
2338
2339 # BAD CALL TO File::Util::readlimit
2340 'bad readlimit' => <<'__maxdives__',
2341 Bad call to $in->{'_pak'}::readlimit(). This method can only be called with
2342 a numeric value (bytes). Non-integer numbers will be converted to integer
2343 format if specified (numbers like 5.2), but don't do that, it's inefficient.
2344
2345 This operation aborted.
2346
2347 Origin: This is a human error.
2348 Solution: A human must fix the programming flaw.
2349 __maxdives__
2350
2351
2352 # EXCEEDED READLIMIT
2353 'readlimit exceeded' => <<'__readlimit__',
2354 $in->{'_pak'} can't load file: $EBL$in->{'filename'}$EBR
2355 into memory because its size exceeds the maximum file size allowed
2356 for a read.
2357
2358 The size of this file is $EBL$in->{'size'}$EBR bytes.
2359
2360 Currently the read limit is set at $EBL$READLIMIT$EBR bytes.
2361
2362 Origin: This is a human error.
2363 Solution: Consider setting the limit to a higher number of bytes.
2364 __readlimit__
2365
2366
2367 # BAD CALL TO File::Util::max_dives
2368 'bad maxdives' => <<'__maxdives__',
2369 Bad call to $in->{'_pak'}::max_dives(). This method can only be called with
2370 a numeric value (bytes). Non-integer numbers will be converted to integer
2371 format if specified (numbers like 5.2), but don't do that, it's inefficient.
2372
2373 This operation aborted.
2374
2375 Origin: This is a human error.
2376 Solution: A human must fix the programming flaw.
2377 __maxdives__
2378
2379
2380 # EXCEEDED MAXDIVES
2381 'maxdives exceeded' => <<'__maxdives__',
2382 Recursion limit reached at $EBL${\ scalar(
2383 (exists $in->{'maxdives'} && defined $in->{'maxdives'}) ?
2384 $in->{'maxdives'} : $MAXDIVES) }$EBR dives. Maximum number of subdirectory dives is set to the value returned by
2385 $in->{'_pak'}::max_dives(). Try manually setting the value to a higher number
2386 before calling list_dir() with option --follow or --recurse (synonymous). Do
2387 so by calling $in->{'_pak'}::max_dives() with the numeric argument corresponding
2388 to the maximum number of subdirectory dives you want to allow when traversing
2389 directories recursively.
2390
2391 This operation aborted.
2392
2393 Origin: This is a human error.
2394 Solution: Consider setting the limit to a higher number.
2395 __maxdives__
2396
2397
2398 # BAD OPENDIR
2399 'bad opendir' => <<'__bad_opendir__',
2400 $in->{'_pak'} can't opendir on directory:
2401 $EBL$in->{'dirname'}$EBR
2402
2403 The system returned this error:
2404 $EBL$in->{'exception'}$EBR
2405
2406 Origin: Could be either human _or_ system error.
2407 Solution: Cannot diagnose. A Human must investigate the problem.
2408 __bad_opendir__
2409
2410
2411 # BAD MAKEDIR
2412 'bad make_dir' => <<'__bad_make_dir__',
2413 $in->{'_pak'} had a problem with the system while attempting to create the
2414 directory you specified with a bitmask of $EBL$in->{'bitmask'}$EBR
2415
2416 directory: $EBL$in->{'dirname'}$EBR
2417
2418 The system returned this error:
2419 $EBL$in->{'exception'}$EBR
2420
2421 Origin: Could be either human _or_ system error.
2422 Solution: Cannot diagnose. A Human must investigate the problem.
2423 __bad_make_dir__
2424
2425
2426 # BAD CHARS
2427 'bad chars' => <<'__bad_chars__',
2428 $in->{'_pak'} can't use this string for $EBL$in->{'purpose'}$EBR.
2429 $EBL$in->{'string'}$EBR
2430 It contains illegal characters.
2431
2432 Illegal characters are:
2433 \\ (backslash)
2434 / (forward slash)
2435 : (colon)
2436 | (pipe)
2437 * (asterisk)
2438 ? (question mark)
2439 " (double quote)
2440 < (less than)
2441 > (greater than)
2442 \\t (tab)
2443 \\ck (vertical tabulator)
2444 \\r (newline CR)
2445 \\n (newline LF)
2446
2447 Origin: This is a human error.
2448 Solution: A human must remove the illegal characters from this string.
2449 __bad_chars__
2450
2451
2452 # NOT A VALID FILEHANDLE
2453 'not a filehandle' => <<'__bad_handle__',
2454 $in->{'_pak'} can't unlock file with an invalid file handle reference:
2455 $EBL$in->{'argtype'}$EBR is not a valid filehandle
2456
2457 Origin: This is most likely a human error, although it is remotely possible
2458 that this message is the result of an internal error in the
2459 $in->{'_pak'} module, but this is not likely if you called
2460 $in->{'_pak'}'s internal ::_release() method directly on your own.
2461 Solution: A human must fix the programming flaw. Alternatively, in the
2462 second listed scenario, the package maintainer must investigate the
2463 problem. Please send a usenet post with this error message in its
2464 entirety to Tommy Butler <tommy\@atrixnet.com>, or to usenet group:
2465 $EBL news://comp.lang.perl.modules $EBR
2466 __bad_handle__
2467
2468
2469 # BAD CALL TO METHOD FOO
2470 'no input' => <<'__no_input__',
2471 $in->{'_pak'} can't honor your call to $EBL$in->{'_pak'}::$in->{'meth'}()$EBR
2472 because you didn't provide $EBL@{[$in->{'missing'}||'the required input']}$EBR
2473
2474 Origin: This is a human error.
2475 Solution: A human must fix the programming flaw.
2476 __no_input__
2477
2478
2479 # PLAIN ERROR TYPE
2480 'plain error' => <<'__plain_error__',
2481 $in->{'_pak'} failed with the following message:
2482 ${\ scalar ($_[0] || ((exists $in->{'error'} && defined $in->{'error'}) ?
2483 $in->{'error'} : '[error unspecified]')) }
2484 __plain_error__
2485
2486
2487 # INVALID ERROR TYPE
2488 'unknown error message' => <<'__foobar_input__',
2489 $in->{'_pak'} failed with an invalid error-type designation.
2490
2491 Origin: This is a bug! Please inform Tommy Butler <tommy\@atrixnet.com>
2492 Solution: A human must fix the programming flaw.
2493 __foobar_input__
2494
2495
2496 # EMPTY ERROR TYPE
2497 'empty error' => <<'__no_input__',
2498 $in->{'_pak'} failed with an empty error-type designation.
2499
2500 Origin: This is a human error.
2501 Solution: A human must fix the programming flaw.
2502 __no_input__
2503
2504 ); # end of error message table
2505
2506 exists $error_msg_table{ $error_thrown }
2507 ? $error_msg_table{ $error_thrown }
2508 : $error_msg_table{'unknown error message'}
2509 }
2510
+2000
-0
Util.pod less more
0 =head1 NAME
1
2 File::Util - Easy, versatile, portable file handling
3
4 =head1 DESCRIPTION
5
6 File::Util provides a comprehensive toolbox of utilities to automate all
7 kinds of common tasks on file / directories. Its purpose is to do so
8 in the most portable manner possible so that users of this module won't
9 have to worry about whether their programs will work on other OSes
10 and machines.
11
12 =head1 SYNOPSIS
13
14 use File::Util;
15 my($f) = File::Util->new();
16
17 my($content) = $f->load_file('foo.txt');
18
19 $content =~ s/this/that/g;
20
21 $f->write_file(
22 'file' => 'bar.txt',
23 'content' => $content,
24 'bitmask' => 0644
25 );
26
27 $f->write_file(
28 'file' => 'file.bin', 'content' => $binary_content, '--binmode'
29 );
30
31 my(@lines) = $f->load_file('randomquote.txt', '--as-lines');
32 my($line) = int(rand(scalar @lines));
33
34 print $lines[$line];
35
36 my(@files) = $f->list_dir('/var/tmp', qw/ --files-only --recurse /);
37 my(@textfiles) = $f->list_dir('/var/tmp', '--pattern=\.txt$');
38
39 if ($f->can_write('wibble.log')) {
40
41 my($HANDLE) = $f->open_handle(
42 'file' => 'wibble.log',
43 'mode' => 'append'
44 );
45
46 print $HANDLE "Hello World! It's ", scalar localtime;
47
48 close $HANDLE
49 }
50
51 my($log_line_count) = $f->line_count('/var/log/httpd/access_log');
52
53 print "My file has a bitmask of " . $f->bitmask('my.file');
54
55 print "My file is a " . join(', ', $f->file_type('my.file')) . " file."
56
57 warn 'This file is binary!' if $f->isbin('my.file');
58
59 print "My file was last modified on " .
60 scalar localtime($f->last_modified('my.file'));
61
62 # ...and _lots_ more
63
64 =head1 INSTALLATION
65
66 To install this module type the following at the command prompt:
67
68 perl Makefile.PL
69 make
70 make test
71 make install
72
73 On windows machines use nmake rather than make; those running cygwin don't have
74 to worry about this. If you don't know what cygwin is, use nmake and check out
75 http://cygwin.com/ after you're done installing this module if you want to
76 find out.
77
78 =head1 ISA
79
80 =over
81
82 =item L<Exporter>
83
84 =item L<Class::OOorNO>
85
86 =back
87
88 =head1 EXPORTED SYMBOLS
89
90 Exports nothing by default.
91
92 =head2 EXPORT_OK
93
94 The following symbols comprise C<@File::Util::EXPORT_OK>), and as such are
95 available for import to your namespace only upon request.
96
97 C<bitmask> I<(see L<bitmask|/bitmask>)>
98
99 C<can_flock> I<(see L<can_flock|/can_flock>)>
100
101 C<can_read> I<(see L<can_read|/can_read>)>
102
103 C<can_write> I<(see L<can_write|/can_write>)>
104
105 C<created> I<(see L<created|/created>)>
106
107 C<ebcdic> I<(see L<ebcdic|/ebcdic>)>
108
109 C<escape_filename> I<(see L<escape_filename|/escape_filename>)>
110
111 C<existent> I<(see L<existent|/existent>)>
112
113 C<file_type> I<(see L<file_type|/file_type>)>
114
115 C<isbin> I<(see L<isbin|/isbin>)>
116
117 C<last_access> I<(see L<last_access|/last_access>)>
118
119 C<last_changed> I<(see L<last_changed|/last_changed>)>
120
121 C<last_modified> I<(see L<last_modified|/last_modified>)>
122
123 C<NL> I<(see L<NL|/NL>)>
124
125 C<needs_binmode> I<(see L<needs_binmode|/needs_binmode>)>
126
127 C<return_path> I<(see L<return_path|/return_path>)>
128
129 C<size> I<(see L<size|/size>)>
130
131 C<SL> I<(see L<SL|/SL>)>
132
133 C<strip_path> I<(see L<strip_path|/strip_path>)>
134
135 C<valid_filename> I<(see L<valid_filename|/valid_filename>)>
136
137 B<Note:> Symbols in C<@L<Class::OOorNO|Class::OOorNO>::EXPORT_OK> are also
138 available for import.
139
140 =head2 EXPORT_TAGS
141
142 :all (exports all of @File::Util::EXPORT_OK)
143
144 =head1 METHODS
145
146 B<Note:> Some of the methods listed will state that they are autoloaded methods.
147 Autloaded methods are not compiled at runtime as part of your process and only
148 get created if called somewhere in your program. I<(see L<AutoLoader>.)>
149
150 Methods listed in alphabetical order.
151
152 =head2 C<bitmask>
153
154 =over
155
156 =item I<Syntax:> C<bitmask( [file name] )>
157
158 Gets the bitmask of the named file, provided the file exists. If the file
159 exists, the bitmask of the named file is returned in four digit octal
160 notation e.g.- C<0644>. Otherwise, returns C<undef> if the file does I<not>
161 exist. This is an autoloaded method.
162
163 =back
164
165 =head2 C<can_flock>
166
167 =over
168
169 =item I<Syntax:> C<can_flock>
170
171 Returns 1 if the current system claims to support C<flock()> I<and> if the
172 Perl process can successfully call it. I<(see L<perlfunc/flock>.)> Unless
173 both of these conditions are true a zero value (0) is returned. This is
174 an autoloaded method. This is a constant subroutine. It accepts no arguments
175 and will always return the same value for the system on which it is executed.
176
177 B<Note:> Perl will try to support or emulate flock whenever it can via
178 available system calls, namely C<flock>; C<lockf>; or with C<fcntl>.
179
180 =back
181
182 =head2 C<can_read>
183
184 =over
185
186 =item I<Syntax:> C<can_read( [file name] )>
187
188 Returns 1 if the named file (or directory) is B<readable> by your program
189 according to the applied permissions of the file system on which the file
190 resides. Otherwise a value of undef is returned.
191
192 This works the same as Perl's built-in C<-r> file test operator,
193 I<(see L<perlfunc/-X>)>, it's just easier for some people to remember. This
194 is an autoloaded method.
195
196 =back
197
198 =head2 C<can_write>
199
200 =over
201
202 =item I<Syntax:> C<can_write( [file name] )>
203
204 Returns 1 if the named file (or directory) is B<writable> by your program
205 according to the applied permissions of the file system on which the file
206 resides. Otherwise a value of undef is returned.
207
208 This works the same as Perl's built-in C<-w> file test operator,
209 I<(see L<perlfunc/-X>)>, it's just easier for some people to remember. This
210 is an autoloaded method.
211
212 =back
213
214 =head2 C<created>
215
216 =over
217
218 =item I<Syntax:> C<created( [file name] )>
219
220 Returns the time of creation for the named file in non-leap seconds since
221 whatever your system considers to be the epoch. Suitable for feeding to
222 Perl's built-in functions "gmtime" and "localtime". I<(see L<perlfunc/time>.)>
223 This is an autoloaded method.
224
225 =back
226
227 =head2 C<ebcdic>
228
229 =over
230
231 =item I<Syntax:> C<ebcdic>
232
233 Returns 1 if the machine on which the code is running uses EBCDIC, or returns
234 0 if not. I<(see L<perlebcdic>.)> This is an autoloaded method. This is a
235 constant subroutine. It accepts no arguments and will always return the same
236 value for the system on which it is executed.
237
238 =back
239
240 =head2 C<escape_filename>
241
242 =over
243
244 =item I<Syntax:> C<escape_filename( [string], [escape char] )>
245
246 Returns it's argument in an escaped form that is suitable for use as a filename.
247 Illegal characters (i.e.- any type of newline character, tab, vtab, and the
248 following C<< / | * " ? < : > \ >>), are replaced with [escape char] or
249 "B<_>" if no [escape char] is specified. Returns an empty string if no
250 arguments are provided. This is an autoloaded method.
251
252 =back
253
254 =head2 C<existent>
255
256 =over
257
258 =item I<Syntax:> C<existent( [file name] )>
259
260 Returns 1 if the named file (or directory) exists. Otherwise a value of
261 undef is returned.
262
263 This works the same as Perl's built-in C<-e> file test operator,
264 I<(see L<perlfunc/-X>)>, it's just easier for some people to remember. This
265 is an autoloaded method.
266
267 =back
268
269 =head2 C<file_type>
270
271 =over
272
273 =item I<Syntax:> C<file_type( [file name] )>
274
275 Returns a list of keywords corresponding to each of Perl's built in file tests
276 (those specific to file types) for which the named file returns true.
277 I<(see L<perlfunc/-X>.)> This is an autoloaded method.
278
279 The keywords and their definitions appear below; the order of keywords returned
280 is the same as the order in which the are listed here:
281
282 =over
283
284 =item C<PLAIN File is a plain file.>
285
286 =item C<TEXT File is a text file.>
287
288 =item C<BINARY File is a binary file.>
289
290 =item C<DIRECTORY File is a directory.>
291
292 =item C<SYMLINK File is a symbolic link.>
293
294 =item C<PIPE File is a named pipe (FIFO).>
295
296 =item C<SOCKET File is a socket.>
297
298 =item C<BLOCK File is a block special file.>
299
300 =item C<CHARACTER File is a character special file.>
301
302 =back
303
304 =back
305
306 =head2 C<flock_rules>
307
308 =over
309
310 =item I<Syntax:> C<flock_rules( [keyword list] )>
311
312 Sets I/O race condition policy, or tells File::Util how it should handle race
313 conditions created when a file can't be locked because it is already locked
314 somewhere else (usually by another process).
315
316 An empty call to this method returns a list of keywords representing the rules
317 that are currently in effect for the object.
318
319 Otherwise, a call should include a list with array containing your chosen
320 directive keywords in order of precedence. The rules will be applied in
321 cascading order when a File::Util object attempts to lock a file, so if the
322 actions specified by the first rule don't result in success, the second rule
323 is applied, and so on.
324
325 Recognized keywords:
326
327 =over
328
329 =item C<NOBLOCKEX>
330
331 tries to get an exclusive lock on the file without blocking (waiting)
332
333 =item C<NOBLOCKSH>
334
335 tries to get a shared lock on the file without blocking
336
337 =item C<BLOCKEX>
338
339 waits to try getting an exclusive lock
340
341 =item C<BLOCKSH>
342
343 waits to try getting a shared lock
344
345 =item C<FAIL>
346
347 dies with stack trace
348
349 =item C<WARN>
350
351 warn()s about the error with a stack trace and returns undef
352
353 =item C<IGNORE>
354
355 ignores the failure to get an exclusive lock
356
357 =item C<UNDEF>
358
359 returns undef
360
361 =item C<ZERO>
362
363 returns 0
364
365 =back
366
367 Examples:
368
369 =over
370
371 =item ex- C<flock_rules( qw/ NOBLOCKEX FAIL / );>
372
373 This is the default policy. When in effect, the File::Util object will first
374 attempt to get a non-blocking exclusive lock on the file. If that attempt
375 fails the File::Util object will call die() with a detailed error message and
376 a stack trace.
377
378 =item ex- C<flock_rules( qw/ NOBLOCKEX BLOCKEX FAIL / );>
379
380 The File::Util object will first attempt to get a non-blocking exclusive lock
381 on the file. If that attempt fails it falls back to the second policy rule
382 "BLOCKEX" and tries again to get an exclusive lock on the file, but this time
383 by blocking (waiting for its turn). If that second attempt fails, the
384 File::Util object will fail with a detailed error message and a stack trace.
385
386 =item ex- C<flock_rules( qw/ BLOCKEX IGNORE / );>
387
388 The File::Util object will first attempt to get a file non-blocking lock on
389 the file. If that attempt fails it will ignore the error, and go on to open
390 the file anyway and no failures will occur or warings be issued.
391
392 =back
393
394 This is an autoloaded method.
395
396 =back
397
398 =head2 C<isbin>
399
400 =over
401
402 =item I<Syntax:> C<isbin( [file name] )>
403
404 Returns 1 if the named file (or directory) exists. Otherwise a value of undef
405 is returned, indicating that the named file either does not exist or is of
406 another file type.
407
408 This works the same as Perl's built-in C<-B> file test operator,
409 I<(see L<perlfunc/-X>)>, it's just easier for some people to remember. This
410 is an autoloaded method.
411
412 =back
413
414 =head2 C<last_access>
415
416 =over
417
418 =item I<Syntax:> C<last_access( [file name] )>
419
420 Returns the last accessed time for the named file in non-leap seconds since
421 whatever your system considers to be the epoch. Suitable for feeding to
422 Perl's built-in functions "gmtime" and "localtime". I<(see L<perlfunc/time>.)>
423 This is an autoloaded method.
424
425 =back
426
427 =head2 C<last_changed>
428
429 =over
430
431 =item I<Syntax:> C<last_changed( [file name] )>
432
433 Returns the inode change time for the named file in non-leap seconds since
434 whatever your system considers to be the epoch. Suitable for feeding to
435 Perl's built-in functions "gmtime" and "localtime". I<(see L<perlfunc/time>.)>
436 This is an autoloaded method.
437
438 =back
439
440 =head2 C<last_modified>
441
442 =over
443
444 =item I<Syntax:> C<last_modified( [file name] )>
445
446 Returns the last modified time for the named file in non-leap seconds since
447 whatever your system considers to be the epoch. Suitable for feeding to
448 Perl's built-in functions "gmtime" and "localtime". I<(see L<perlfunc/time>.)>
449 This is an autoloaded method.
450
451 =back
452
453 =head2 C<line_count>
454
455 =over
456
457 =item I<Syntax:> C<line_count( [file name] )>
458
459 Returns the number of lines in the named file. Fails with an error if the
460 named file does not exist.
461
462 =back
463
464 =head2 C<list_dir>
465
466 =over
467
468 =item I<Syntax:> C<list_dir( [directory name] , [--opts] )>
469
470 Returns alphabetically sorted all file names in the directory specified if it
471 exists. Fails with an error message if no such directory is found.
472
473 =over
474
475 =item B<Flags accepted by C<list_dir()>>
476
477 =over
478
479 =item C<--dirs-only>
480
481 return only directory contents which are directories
482
483 =item C<--files-only>
484
485 return only directory contents which are files
486
487 =item C<--no-fsdots>
488
489 do not include "." and ".." in the list of directory contents
490
491 =item C<--pattern>
492
493 return only files/directories matching pattern provided. argument
494 should be plain text string. It will be converted to a perl regex and passed
495 to CORE::grep as the method scans through directory listings for a match.
496
497 (ex- C<'--pattern=\.txt$'> returns all file/directory names ending in ".txt".
498 It will match "foo.txt", but not "foo.txt.gz" because of the "$" anchor in the
499 regular expression passed in.)
500
501 or for the opposite effect, C<< '--pattern=.*(?<!\.txt)$' >> returns all
502 file/directory names that don't end in ".txt"
503
504 =item C<--with-paths>
505
506 Include file paths with the contents of the directory list, relative
507 to the directory named in the call.
508
509 =item C<--recurse>
510
511 Recurse subdirectories
512
513 =item C<--follow>
514
515 Recurse subdirectories, same as C<--recurse>
516
517 =item C<--dirs-as-ref>
518
519 When returning directory listing, include first a reference to the list
520 of subdirectories found, followed by anything else returned by the call.
521
522 =item C<--files-as-ref>
523
524 When returning directory listing, include last a reference to the list
525 of files found, preceded by a list of subdirectories found (or preceeded
526 by a list reference to subdirectories found if C<--dirs-as-ref> was also used).
527
528 =item C<--as-ref>
529
530 Return a pair list references: the first is a reference to any subdirectories
531 found by the call, the second is a reference to any files found by the call.
532
533 =item C<--sl-after-dirs>
534
535 Append a directory seperator ("/, "\", or ":" depending on your system)
536 to all directories found by the call. Useful in visual displays for quick
537 differentiation between subdirectories and files.
538
539 =item C<--ignore-case>
540
541 Items returned by the call to this method are sorted alphabetically by
542 default, so "Zoo.txt" comes before "alligator.txt" because the alphabetical
543 sort is case-sensitive. This is also the way directories are listed at the
544 system level on most operating systems.
545
546 If you'd like the directory contents returned by this method to be
547 sorted without regard to case , use this flag.
548
549 =item C<--count-only>
550
551 Returns a single value: an integer reflecting the number of items
552 found in the directory after applying the filter criteria specified by any
553 other flags (ie- "--dirs-only", "--recurse", etc.) that may have been passed
554 in as well.
555
556 =back
557
558 =back
559
560 =back
561
562 =head2 C<load_dir>
563
564 =over
565
566 =item I<Syntax:> C<load_dir( [directory name] , [--ds-type] )>
567
568 Returns a data structure containing the contents of each file present in the
569 named directory. This is an autoloaded method.
570
571 The type of data structure returned is determined by the optional data-type
572 switch. Only one option may be used for a given call to this method.
573 Recognized options are listed below.
574
575 =over
576
577 =item B<Flags accepted by C<load_dir()>>
578
579 =over
580
581 =item C<--as-list>
582
583 Causes the method to return a list comprised of the contents loaded from
584 each file (in case-sensitive order) located in the named directory.
585
586 =item C<--as-listref>
587
588 Same as above, except an array reference to the list of items is returned
589 rather than the list itself.
590
591 =item C<--as-hashref> *(default)
592
593 Implicit. If no option is passed in, the default behavior is to return a
594 reference to an anonymous hash whose keys are the names of each file in the
595 specified directory; the hash values for contain the contents of the file
596 represented by its corresponding key.
597
598 =back
599
600 =back
601
602 B<Note:> This method does not distinguish between plain files and other file
603 types such as binaries, FIFOs, sockets, etc.
604
605 Restrictions imposed by the current "read limit"
606 I<(see the L<readlimit()|/readlimit>) entry below> will be applied to the
607 files opened by this method as well. Adjust the readlimit as necessary.
608
609 my($files) = $fu->load_dir('directory/to/load/');
610
611 The above code creates an anonymous hash reference that is stored in the
612 variable named "C<$files>". The keys and values of the hash referenced by
613 "C<$files>" would resemble those of the following code snippet (given that
614 the files in the named directory were the files 'a.txt', 'b.html', 'c.dat',
615 and 'd.conf')
616
617 my($files) =
618 {
619 'a.txt' => "the contents of file a.txt",
620 'b.html' => "the contents of file b.html",
621 'c.dat' => "the contents of file c.dat",
622 'd.conf' => "the contents of file d.conf",
623 };
624
625 =back
626
627 =head2 C<load_file>
628
629 =over
630
631 =item I<Syntax:> C<load_file( [file name] , [--opts] )>
632
633 =item I<OR:> C<< load_file( 'FH' => [file handle reference] , [--opts] ) >>
634
635 If [file name] is passed, returns the contents of [file name] in a string.
636 If a [file handle reference] is passed instead, the filehandle will be
637 C<CORE::read()> and the data obtained by the read will be returned in a string.
638
639 If you desire the contents of the file (or file handle data) in a list of
640 lines instead of a single string, this can be accomplished through the use
641 of the C<--as-lines> flag (see below).
642
643 =over
644
645 =item B<Flags accepted by C<load_file()>>
646
647 =over
648
649 =item C<--as-lines>
650
651 If this flag is passed then your call to C<load_file> will return an ordered
652 list of strings, each of which is a line from the file [file name]. The lines
653 are returned in the order they are read, from the beginning of the file to the
654 end.
655
656 This is not the default behavior. The default behavior is for C<load_file> to
657 return a single string containing the entire contents of the file, including
658 line break characters.
659
660 =item C<--no-lock>
661
662 By default this method will attempt to get a lock on the file while it is
663 being read, following whatever rules are in place for the flock policy
664 established either by default (implicitly) or changed by you in a call to
665 File::Util::flock_rules()
666 I<(see the L<flock_rules()|/flock_rules>) entry below>.
667
668 This method will not try to get a lock on the file if the File::Util object was
669 created with the option C<--no-lock> or if the method was called with the
670 option C<--no-lock>.
671
672 This method will automatically call binmode() on binary files for you. If you
673 pass in a filehandle instead of a file name you do not get this automatic
674 check performed for you. In such a case, you'll have to call binmode() on
675 the filehandle yourself. Once you pass a filehandle to this method it has no
676 way of telling if the file opened to that filehandle is binary or not.
677
678 B<Notes:> This method does not distinguish between plain files and other file
679 types such as binaries, FIFOs, sockets, etc.
680
681 Restrictions imposed by the current "read limit"
682 I<(see the L<readlimit()|/readlimit>) entry below> will be applied to the
683 files opened by this method as well. Adjust the readlimit as necessary.
684
685 =back
686
687 =back
688
689 =back
690
691 =head2 C<make_dir>
692
693 =over
694
695 =item I<Syntax:> C<make_dir( [new directory name] , [bitmask], [--opts] )>
696
697 Attempts to create (recursively) a directory as [new directory name] with
698 the [bitmask] provided. The bitmask is an optional argument and defaults to
699 0777. If specified, the bitmask must be supplied in the form required by the
700 native perl umask function. I<see L<perlfunc/"umask">> for more information
701 about the format of the bitmask argument.
702
703 As mentioned above, the recursive creation of directories is transparently
704 handled for you. This means that if the name of the directory you pass in
705 contains a parent directory that does not exist, the parent directory(ies) will
706 be created for you automatically and silently in order to create the final
707 directory in the [new directory name].
708
709 Simply put, if [new directory] is "/path/to/directory" and the directory
710 "/path/to" does not exist, the directory "/path/to" will be created and the
711 "/path/to/directory" directory will be created thereafter. All directories
712 created will be created with the [bitmask] you specify, or with the default
713 of 0777.
714
715 Upon successful creation of the [new directory name], the [new directory name]
716 is returned to the caller.
717
718 =over
719
720 =item B<Flags accepted by C<make_dir()>>
721
722 =over
723
724 =item C<--if-not-exists>
725
726 If this flag is passed in then make_dir will not attempt to create the directory
727 if it already exists. Rather it will return the name of the directory as it
728 normally would if the directory did not exist previous to calling this method.
729
730 If a call to this method is made without the C<--if-not-exists> flag and the
731 directory specified as [new directory name] does in fact exist, an error will
732 result as it is impossible to create a directory that already exists.
733
734 =back
735
736 =back
737
738 This is an autoloaded method.
739
740 =back
741
742 =head2 C<max_dives>
743
744 =over
745
746 =item I<Syntax:> C<max_dives( [integer] )>
747
748 When called without any arguments, this method returns an integer reflecting
749 the current number of times the File::Util object will dive into the
750 subdirectories it discovers when recursively listing directory contents from
751 a call to C<File::Util::list_dir()>. The default is 1000. If the number is
752 exceeded, the File::Util object will fail with a diagnostic error message.
753
754 When called with an argument, it sets the maximum number of times a File::Util
755 object will recurse into subdirectories before failing with an error message.
756
757 This method can only be called with a numeric integer value. Passing a bad
758 argument to this method will cause it to fail with an error message.
759
760 I<(see L<list_dir|/list_dir>)>
761
762 This is an autoloaded method.
763
764 =back
765
766 =head2 C<needs_binmode>
767
768 =over
769
770 =item I<Syntax:> C<needs_binmode>
771
772 Returns 1 if the machine on which the code is running requires that C<binmode()>
773 I<(a built-in function)> be called on open file handles, or returns 0 if not.
774 I<(see L<perlfunc/binmode>.)> This is an autoloaded method. This is a constant
775 subroutine. It accepts no arguments and will always return the same value for
776 the system on which it is executed.
777
778 =back
779
780 =head2 C<new>
781
782 =over
783
784 =item I<Syntax:> C<< new( ['parameters' => 'values', etc], [--flags] ) >>
785
786 This is the File::Util constructor method. eg- It returns a new File::Util
787 object reference when you call it. It recognizes various parameters and flags
788 that govern the behavior of the new File::Util object.
789
790 =over
791
792 =item B<Parameters accepted by C<new()>>
793
794 =over
795
796 =item use_flock => true/false value
797
798 Optionally specify this option to the C<File::Util::new> method instruct the
799 new object that it should never attempt to use C<flock()> in it's I/O
800 operations. The default is to use C<flock()> when available on your system.
801 Specify this option with a true or false value, true to use C<flock()>, false
802 to not use it.
803
804 =item readlimit => positive integer
805
806 Optionally specify this option to the File::Util::new method to instruct the
807 new object that it should never attempt to open and read in a file greater
808 than the number of bytes you specify. Obviously this argument can only be
809 a numeric integer value, otherwise it will be silently ignored. The default
810 readlimit for File::Util objects is 52428800 bytes (50 megabytes).
811
812 =item max_dives => positive integer
813
814 Optionally specify this option to the File::Util::new method to instruct the
815 new object to set the maximum number of times it will recurse into
816 subdirectories while performing directory listing operations before failing
817 with an error message. This argument can only be a numeric integer value,
818 otherwise it will be silently ignored.
819
820 =back
821
822 =item B<Flags accepted by C<new()>>
823
824 =over
825
826 =item C<--fatals-as-warning>
827
828 Directive to instruct the new File::Util object that when any call to one of
829 its methods results in a fatal error that it should return B<C<undef>>
830 instead of the value(s) that would normally be returned by the call, and to
831 send an error message to STDERR as well.
832
833 =item C<--fatals-as-status>
834
835 Directive to instruct the new File::Util object that when any call to one of
836 its methods results in a fatal error that it should return B<C<undef>>
837 instead of the value(s) that would normally be returned by the call.
838
839 =item C<--fatals-as-errmsg>
840
841 Directive to instruct the new File::Util object that when any call to one of
842 its methods results in a fatal error that it should return B<an error message>
843 instead of the value(s) that would normally be returned by the call.
844
845 =back
846
847 =back
848
849 =back
850
851 =head2 C<open_handle>
852
853 =over
854
855 =item I<Syntax:> C<< open_handle('file' => [file name], [--opts]) >>
856
857 =item I<OR:> C<< open_handle('file' => [file name], 'mode' => [mode], [--opts]) >>
858
859 =item I<OR:> C<< open_handle('file' => [file name], 'mode' => [mode], 'bitmask' => [bitmask], [--opts]) >>
860
861 =item I<OR:> C<< open_handle('file' => [file name], 'mode' => [mode], 'bitmask' => [bitmask], 'dbitmask' => [bitmask], [--opts]) >>
862
863 Attempts to get a unique open file handle on [file name] in [mode] mode.
864 Returns the file handle if successful or generates a fatal error with a
865 diagnostic message if the operation fails.
866
867 You will need to remember to call C<close()> on the filehandle yourself, at
868 your own discretion. Leaving filehandles open is not a good practice, and
869 is not recommended. I<see L<perlfunc/close>>).
870
871 Once you have the file handle you would use it as you would use any file handle.
872 Remember that unless you specifically turn file locking off when the
873 C<File::Util> object is created (see I<(see L<new|/new>)> or by using the
874 C<--no-lock> flag when calling C<open_handle>, that file locking is going to
875 automagically be handled for you behind the scenes, so long as your OS supports
876 file locking of any kind at all. Great! It's very convenient for you to not
877 have to worry about portably taking care of file locking between one
878 application and the next; by using C<File::Util> in all of them, you know
879 that you're covered.
880
881 A slight inconvenience for the price of a larger set of features (compare
882 L<write_file|/write_file> to this method)
883 I<B<you will have to release the file lock on the open handle yourself.>>
884 C<File::Util> can't manage it for you anymore once it hands the handle over
885 to you. At that point, it's all yours. In order to release the file lock
886 on your file handle, call L<unlock_open_handle()|/unlock_open_handle> on it.
887 Otherwise the lock will remain for the life of your process. If you don't
888 want to use the free portable file locking, remember the C<--no-lock> flag,
889 which will turn off file locking for your open handle. Seldom, however, should
890 you ever opt to not use file locking unless you really know what you are doing.
891
892 If the file does not yet exist it will be created, and it will be created
893 with a bitmask of [bitmask] if you specify a file creation bitmask using
894 the C<'bitmask'> option, otherwise the file will be created with the default
895 bitmask of 0777.
896
897 If specified, the bitmask must be supplied in the form required by the
898 native perl umask function. I<see L<perlfunc/"umask">> for more information
899 about the format of the bitmask argument. If the file [file name] already
900 exists then the bitmask argument has no effect and is silently ignored.
901
902 Any non-existent directories in the path preceeding the actual file name will
903 be automatically (and silently - no warnings) created for you and any new
904 directories will be created with a bitmask of [dbitmask], provided you specify
905 a directory creation bitmask with the C<'dbitmask'> option.
906
907 If specified, the directory creation bitmask [dbitmask] must be supplied in
908 the form required by the native perl umask function.
909
910 If there is an error while trying to create any preceeding directories, the
911 failure results in a fatal error with a diagnostic error message. If all
912 directories preceeding the name of the file already exist, the dbitmask
913 argument has no effect and is silently ignored.
914
915 =back
916
917 =over
918
919 =item B<Native Perl open modes>
920
921 The default behavior of C<open_handle()> is to open file handles using Perl's
922 native C<open()> I<(see L<perlfunc/open>)>. Unless you use the
923 C<--use-sysopen> flag, the following modes and only these modes are valid.
924
925 =over
926
927 =item C<< 'mode' => 'read' >>
928
929 [file name] is opened in read-only mode. If the file does not yet exist then
930 a fatal error will occur with a diagnostic help message to help you troubleshoot
931 the problem.
932
933 =item C<< 'mode' => 'write' >> (this is the default mode)
934
935 [file name] is created if it does not yet exist. If [file name] already exists
936 then its contents are overwritten with the new content provided.
937
938 =item C<< 'mode' => 'append' >>
939
940 [file name] is created if it does not yet exist. If [file name] already exists
941 its contents will be preserved and the new content you provide will be appended
942 to the end of the file.
943
944 =back
945
946 =back
947
948 =over
949
950 =item B<System level open modes ("open a la C")>
951
952 Optionally you can ask C<File::Util> to open your handle using C<CORE::sysopen>
953 instead of using the native Perl C<CORE::open()>. This is accomplished by
954 passing in the C<--use-sysopen> flag. Using this feature opens up more
955 possibilities as far as the open modes you can choose from, but also carries
956 with it a few caveats so you have to be careful, just as you'd have to be a
957 little more careful when using C<sysopen()> anyway.
958
959 Specifically you need to remember that when using this feature you must NOT
960 mix different types of I/O when working with the file handle. You can't go
961 opening file handles with C<sysopen()> and print to them as you normally
962 would print to a file handle. You have to use C<syswrite()> instead. The
963 same applies here. If you get a C<sysopen()>'d filehandle from C<open_handle()>
964 it is imperative that you use C<syswrite()> on it. You'll also need to use
965 C<sysseek()> and other type of C<sys>* commands on the filehandle instead of
966 their native Perl equivalents.
967
968 (see L<perlfunc/sysopen>, L<perlfunc/syswrite>, L<perlfunc/sysseek>,
969 L<perlfunc/sysread>)
970
971 That said, here are the different modes you can choose from to get a file handle
972 when using the C<--use-sysopen> flag. Remember that these won't work unless
973 you use the flag, and will generate an error if you try using them without it.
974 The standard C<'read'>, C<'write'>, and C<'append'> modes are already available
975 to you by default. These are the extended modes:
976
977 =over
978
979 =item C<< 'mode' => 'rwcreate' >>
980
981 [file name] is opened in read-write mode, and will be created for you if it
982 does not already exist.
983
984 =item C<< 'mode' => 'rwupdate' >>
985
986 [file name] is opened for you in read-write mode, but must already exist. If
987 it does not exist, a fatal error will result and a diagnostic help message will
988 be printed out to help you troubleshoot the problem.
989
990 =item C<< 'mode' => 'rwclobber' >>
991
992 [file name] is opened for you in read-write mode. If the file already exists
993 it's contents will be "clobbered" or wiped out. The file will then be empty
994 and you will be working with the then-truncated file. This can not be undone.
995 Once you call C<open_handle()> using this option, your file WILL be wiped out.
996 If the file does not exist yet, it will be created for you.
997
998 =item C<< 'mode' => 'rwappend' >>
999
1000 [file name] will be opened for you in read-write mode ready for appending. The
1001 file's contents will not be wiped out; they will be preserved and you will be
1002 working in append fashion. You will only be able to write starting at the end
1003 of the file. If the file does not exist, it will be created for you.
1004
1005 =back
1006
1007 Remember to use C<sysread()> and not plain C<read()> when reading those
1008 C<sysopen()>'d filehandles!
1009
1010 =back
1011
1012 =over
1013
1014 =item B<Flags accepted by C<open_handle()>>
1015
1016 =over
1017
1018 =item C<--binmode>
1019
1020 Makes sure that CORE::binmode() is called on the filehandle when your content
1021 is written. This is useful for times when the content you are writing to file
1022 is a binary stream. I<(see L<perlfunc/binmode>)>.
1023
1024 =item C<--no-lock>
1025
1026 By default this method will attempt to get a lock on the file while it is
1027 being read, following whatever rules are in place for the flock policy
1028 established either by default (implicitly) or changed by you in a call to
1029 File::Util::flock_rules()
1030 I<(see the L<flock_rules()|/flock_rules>) entry below>.
1031
1032 This method will not try to get a lock on the file if the File::Util object was
1033 created with the option C<--no-lock> or if this method is called with the
1034 option C<--no-lock>.
1035
1036 =item C<--use-sysopen>
1037
1038 Instead of opening the file using Perl's native C<open()> command, C<File::Util>
1039 will open the file with the C<sysopen()> command. You will have to remember
1040 that your filehandle is a C<sysopen()>'d one, and that you will not be able to
1041 use native Perl I/O functions on it. You will have to use the C<sys>*
1042 equivalents. See L<perlopentut> for a more in-depth explanation of why you
1043 can't mix native Perl I/O with system I/O.
1044
1045 =back
1046
1047 This is an autoloaded method.
1048
1049 =back
1050
1051 =head2 C<readlimit>
1052
1053 =over
1054
1055 =item I<Syntax:> C<readlimit( [integer] )>
1056
1057 By default, the largest size file that File::Util will read into memory and
1058 return via the L<load_file|/load_file> is 52428800 byptes (50 megabytes).
1059
1060 This value can be modified by calling this method with an integer value
1061 reflecting the new limit you want to impose, in bytes. For example, if you want
1062 to set the limit to 10 megabytes, call the method with an argument of 10485760.
1063
1064 If this method is called without an argument, the read limit currently in force
1065 for the File::Util object will be returned.
1066
1067 This is an autoloaded method.
1068
1069 =back
1070
1071 =head2 C<return_path>
1072
1073 =over
1074
1075 =item I<Syntax:> C<return_path( [string] )>
1076
1077 Takes the file path from the file name provided and returns it such that
1078 "/foo/bar/baz.txt" is returned "/foo/bar".
1079
1080 This is an autoloaded method.
1081
1082 =back
1083
1084 =head2 C<size>
1085
1086 =over
1087
1088 =item I<Syntax:> C<size( [file name] )>
1089
1090 Returns the file size of [file name] in bytes. Returns C<0> if the file is
1091 empty, returns C<undef> if the file does not exist.
1092
1093 This is an autoloaded method.
1094
1095 =back
1096
1097 =head2 C<strip_path>
1098
1099 =over
1100
1101 =item I<Syntax:> C<strip_path( [string] )>
1102
1103 Strips the file path from the file name provided and returns the file name only.
1104
1105 =back
1106
1107 =head2 C<touch>
1108
1109 =over
1110
1111 =item I<Syntax:> C<touch( [file name] )>
1112
1113 Behaves like the *nix C<touch> command; Updates the access and modification
1114 times of the specified file to the current time. If the file does not exist,
1115 C<File::Util> tries to create it empty. This method will fail with a fatal
1116 error if system permissions deny alterations to or creation of the file.
1117
1118 Returns C<1> if successful. If unsuccessful, fails with a descriptive error
1119 message about what went wrong.
1120
1121 This is an autoloaded method.
1122
1123 =back
1124
1125 =head2 C<trunc>
1126
1127 =over
1128
1129 =item I<Syntax:> C<trunc( [file name] )>
1130
1131 Truncates [file name] (i.e.- wipes out, or "clobbers" the contents of the
1132 specified file. Returns C<1> if successful. If unsuccessful, fails with a
1133 descriptive error message about what went wrong.
1134
1135 This is an autoloaded method.
1136
1137 =back
1138
1139 =head2 C<unlock_open_handle>
1140
1141 =over
1142
1143 =item I<Syntax:> C<unlock_open_handle([file handle])>
1144
1145 Release the flock on a file handle you opened with L<open_handle|/open_handle>.
1146
1147 Returns true on success, false on failure. Will not raise a fatal error if
1148 the unlock operation fails. You can capture the return value from your call
1149 to this method and C<die()> if you so desire. Failure is not ever very likely,
1150 or C<File::Util> wouldn't have been able to get a portable lock on the file
1151 in the first place.
1152
1153 If C<File::Util> wasn't able to ever lock the file due to limitations of your
1154 operating system, a call to this method will return a true value.
1155
1156 If file locking has been disabled on the file handle via the C<--no-lock> flag
1157 at the time L<open_handle|/open_handle> was called, or if file locking was
1158 disabled using the L<use_flock|/use_flock> method, or if file locking was
1159 disabled on the entire C<File::Util> object at the time of its creation
1160 I<(see L<new()|/new>)>, calling this method will have no effect and a true value
1161 will be returned.
1162
1163 This is an autoloaded method, due to L<open_handle|open_handle> also being
1164 autoloaded.
1165
1166 =back
1167
1168 =head2 C<use_flock>
1169
1170 =over
1171
1172 =item I<Syntax:> C<use_flock( [true / false value] )>
1173
1174 When called without any arguments, this method returns a true or false value
1175 to reflect the current use of C<flock()> within the File::Util object.
1176
1177 When called with a true or false value as its single argument, this method
1178 will tell the File::Util object whether or not it should attempt to use
1179 C<flock()> in its I/O operations. A true value indicates that the File::Util
1180 object will use C<flock()> if available, a false value indicates that it will
1181 not. The default is to use C<flock()> when available on your system.
1182
1183 This is an autoloaded method.
1184
1185 =back
1186
1187 =head2 C<write_file>
1188
1189 =over
1190
1191 =item I<Syntax:> C<< write_file('file' => [file name], 'content' => [string], [--opts]) >>
1192
1193 =item I<OR:> C<< write_file('file' => [file name], 'content' => [string], 'mode' => [mode], [--opts]) >>
1194
1195 =item I<OR:> C<< write_file('file' => [file name], 'content' => [string], 'mode' => [mode], 'bitmask' => [bitmask], [--opts]) >>
1196
1197 =item I<OR:> C<< write_file('file' => [file name], 'content' => [string], 'mode' => [mode], 'bitmask' => [bitmask], 'dbitmask' => [bitmask], [--opts]) >>
1198
1199 Attempts to write [string] to [file name] in mode [mode]. If the file does
1200 not yet exist it will be created, and it will be created with a bitmask of
1201 [bitmask] if you specify a file creation bitmask using the C<'bitmask'> option,
1202 otherwise the file will be created with the default bitmask of 0777.
1203
1204 [string] should be a string or a scalar variable containing a string. The
1205 string can be any type of data, such as a binary stream, or ascii text with
1206 line breaks, etc. Be sure to pass in the C<--binmode> flag for binary streams.
1207
1208 If specified, the bitmask must be supplied in the form required by the
1209 native perl umask function. I<see L<perlfunc/"umask">> for more information
1210 about the format of the bitmask argument. If the file [file name] already
1211 exists then the bitmask argument has no effect and is silently ignored.
1212
1213 Returns 1 if successful or fails (fatal) with an error message if not
1214 successful.
1215
1216 Any non-existent directories in the path preceeding the actual file name will
1217 be automatically (and silently - no warnings) created for you and any new
1218 directories will be created with a bitmask of [dbitmask], provided you specify
1219 a directory creation bitmask with the C<'dbitmask'> option.
1220
1221 If specified, the directory creation bitmask [dbitmask] must be supplied in
1222 the form required by the native perl umask function.
1223
1224 If there is an error while trying to create any preceeding directories, the
1225 failure results in a fatal error with a diagnostic error message. If all
1226 directories preceeding the name of the file already exist, the dbitmask
1227 argument has no effect and is silently ignored.
1228
1229 =over
1230
1231 =item C<< 'mode' => 'write' >> (this is the default mode)
1232
1233 [file name] is created if it does not yet exist. If [file name] already exists
1234 then its contents are overwritten with the new content provided.
1235
1236 =item C<< 'mode' => 'append' >>
1237
1238 [file name] is created if it does not yet exist. If [file name] already exists
1239 its contents will be preserved and the new content you provide will be appended
1240 to the end of the file.
1241
1242 =back
1243
1244 =over
1245
1246 =item B<Flags accepted by C<write_file()>>
1247
1248 =over
1249
1250 =item C<--binmode>
1251
1252 Makes sure that CORE::binmode() is called on the filehandle when your content
1253 is written. This is useful for times when the content you are writing to file
1254 is a binary stream.
1255
1256 =item C<--empty-writes-OK>
1257
1258 Allows you to call this method without providing a content argument (it lets
1259 you create an empty file without warning you or failing. Be advised that
1260 if you use this flag, it will have the same effect as truncating a file
1261 that already has content in it (i.e.- it will "clobber" non-empty files)
1262
1263 =item C<--no-lock>
1264
1265 By default this method will attempt to get a lock on the file while it is
1266 being read, following whatever rules are in place for the flock policy
1267 established either by default (implicitly) or changed by you in a call to
1268 File::Util::flock_rules()
1269 I<(see the L<flock_rules()|/flock_rules>) entry below>.
1270
1271 This method will not try to get a lock on the file if the File::Util object was
1272 created with the option C<--no-lock> or if this method is called with the
1273 option C<--no-lock>.
1274
1275 =back
1276
1277 =back
1278
1279 =back
1280
1281 =head2 C<valid_filename>
1282
1283 =over
1284
1285 =item I<Syntax:> C<valid_filename( [string] )>
1286
1287 For the given string, returns 1 if the string is a legal file name for the
1288 system on which the program is running, or returns undef if it is not. This
1289 method does not test for the validity of file paths! It tests for the validity
1290 of file names only. (It is used internally to check beforehand if a file name
1291 is useable when creating new files, but is also a public method available for
1292 external use.)
1293
1294 =back
1295
1296 =head1 CONSTANTS
1297
1298 =head2 C<NL>
1299
1300 =over
1301
1302 =item I<Syntax:> C<NL>
1303
1304 Returns the correct new line character (or character sequence) for the system
1305 on which your program runs.
1306
1307 =back
1308
1309 =head2 C<SL>
1310
1311 =over
1312
1313 =item I<Syntax:> C<SL>
1314
1315 Returns the correct directory path seperator for the system on which your
1316 program runs.
1317
1318 =back
1319
1320 =head2 C<OS>
1321
1322 =over
1323
1324 =item I<Syntax:> C<OS>
1325
1326 Returns the File::Util keyword for the operating system FAMILY it detected. The
1327 keyword for the detected operating system will be one of the following, derived
1328 from the conents of C<$^O>, or if C<$^O> can not be found, from the contents of
1329 C<$Config::Config{osname}> (see native L<Config> library), or if that
1330 doesn't contain a recognizable value, finally falls back to C<UNIX>.
1331
1332 Generally speaking, Linux operating systems are going to be detected as C<UNIX>.
1333 This isn't a bug. The OS FAMILY to which it belongs uses C<UNIX> style
1334 filesystem conventions and line endings, which are the relevant things to
1335 file handling operations.
1336
1337 =over
1338
1339 =item UNIX
1340
1341 Specifics: OS name =~ /^(?:darwin|bsdos)/i
1342
1343 =item CYGWIN
1344
1345 Specifics: OS name =~ /^cygwin/i
1346
1347 =item WINDOWS
1348
1349 Specifics: OS name =~ /^MSWin/i
1350
1351 =item VMS
1352
1353 Specifics: OS name =~ /^vms/i
1354
1355 =item DOS
1356
1357 Specifics: OS name =~ /^dos/i
1358
1359 =item MACINTOSH
1360
1361 Specifics: OS name =~ /^MacOS/i
1362
1363 =item EPOC
1364
1365 Specifics: OS name =~ /^epoc/i
1366
1367 =item OS2
1368
1369 Specifics: OS name =~ /^os2/i
1370
1371 =back
1372
1373 =back
1374
1375 =head1 PREREQUISITES
1376
1377 =over
1378
1379 =item L<Perl|perl> 5.006 or better
1380
1381 =item L<Class::OOorNO> v0.01_1 or better
1382
1383 =item L<Exception::Handler> v1.00_0 or better
1384
1385 =back
1386
1387 =head1 EXAMPLES
1388
1389 =head2 Get the names of all files and subdirectories in a directory
1390
1391 use File::Util;
1392 my($f) = File::Util->new();
1393 # option --no-fsdots excludes "." and ".." from the list
1394 my(@dirs_and_files) = $f->list_dir('/foo','--no-fsdots');
1395
1396 =head2 Get the names of all files and subdirectories in a directory, recursively
1397
1398 use File::Util;
1399 my($f) = File::Util->new();
1400 my(@dirs_and_files) = $f->list_dir('/foo','--recurse');
1401
1402 =head2 Get the names of all files (no subdirectories) in a directory
1403
1404 use File::Util;
1405 my($f) = File::Util->new();
1406 my(@dirs_and_files) = $f->list_dir('/foo','--files-only');
1407
1408 =head2 Get the names of all subdirectories (no files) in a directory
1409
1410 use File::Util;
1411 my($f) = File::Util->new();
1412 my(@dirs_and_files) = $f->list_dir('/foo','--dirs-only');
1413
1414 =head2 Get the number of files and subdirectories in a directory
1415
1416 use File::Util;
1417 my($f) = File::Util->new();
1418 my(@dirs_and_files) = $f->list_dir('/foo', qw/--no-fsdots --count-only/);
1419
1420 =head2 Get the names of files and subdirs in a directory as seperate array refs
1421
1422 use File::Util;
1423 my($f) = File::Util->new();
1424 my($dirs,$files) = $f->list_dir('/foo', '--as-ref');
1425
1426 -OR-
1427 my($dirs,$files) = $f->list_dir('.', qw/--dirs-as-ref --files-as-ref/);
1428
1429 =head2 Get the contents of a file in a string
1430
1431 use File::Util;
1432 my($f) = File::Util->new();
1433 my($contents) = $f->load_file('filename');
1434
1435 =head2 Get the contents of a file in an array of lines in the file
1436
1437 use File::Util;
1438 my($f) = File::Util->new();
1439 my(@contents) = $f->load_file('filename','--as-lines');
1440
1441 =head2 Get an open file handle for reading
1442
1443 use File::Util;
1444 my($f) = File::Util->new();
1445 my($FH_REF) = $f->open_handle(
1446 'file' => 'new_filename',
1447 'mode' => 'read'
1448 );
1449
1450 =head2 Get an open file handle for writing
1451
1452 use File::Util;
1453 my($f) = File::Util->new();
1454 my($FH_REF) = $f->open_handle(
1455 'file' => 'new_filename',
1456 'mode' => 'write'
1457 );
1458
1459 =head2 Write to a new or existing file
1460
1461 use File::Util;
1462 my($content) = 'Pathelogically Eclectic Rubbish Lister';
1463 my($f) = File::Util->new();
1464 $f->write_file('file' => 'a new file.txt', 'content' => $content);
1465
1466 # optionally specify a creation bitmask when writing to a new file
1467 $f->write_file(
1468 'file' => 'a new file.txt',
1469 'bitmask' => 0777,
1470 'content' => $content
1471 );
1472
1473 =head2 Append to a new or existing file
1474
1475 use File::Util;
1476 my($content) = 'Pathelogically Eclectic Rubbish Lister';
1477 my($f) = File::Util->new();
1478 $f->write_file(
1479 'file' => 'a new file.txt',
1480 'mode' => 'append',
1481 'content' => $content
1482 );
1483
1484 =head2 Determine if something is a valid file name
1485
1486 use File::Util qw( valid_filename );
1487
1488 if (valid_filename("foo?+/bar~@/#baz.txt")) {
1489 print "file name is valid"
1490 else {
1491 print "file name contains illegal characters"
1492 }
1493
1494 -OR-
1495 use File::Util;
1496 print File::Util->valid_filename("foo?+/bar~@/#baz.txt") ? 'ok' : 'bad';
1497
1498 -OR-
1499 use File::Util;
1500 my($f) = File::Util->new();
1501 print $f->valid_filename("foo?+/bar~@/#baz.txt") ? 'ok' : 'bad';
1502
1503 =head2 Get the number of lines in a file
1504
1505 use File::Util;
1506 my($f) = File::Util->new();
1507 my($linecount) = $f->line_count('foo.txt');
1508
1509 =head2 Strip the path from a file name
1510
1511 use File::Util;
1512 my($f) = File::Util->new();
1513
1514 # On Windows
1515 # (prints "hosts")
1516 my($path) = $f->strip_path('C:\WINDOWS\system32\drivers\etc\hosts');
1517
1518 # On Linux/Unix
1519 # (prints "perl")
1520 print $f->strip_path('/usr/bin/perl');
1521
1522 # On a Mac
1523 # (prints "baz")
1524 print $f->strip_path('foo:bar:baz');
1525
1526 =head2 Get the path preceeding a file name
1527
1528 use File::Util;
1529 my($f) = File::Util->new();
1530
1531 # On Windows
1532 # (prints "C:\WINDOWS\system32\drivers\etc")
1533 my($path) = $f->return_path('C:\WINDOWS\system32\drivers\etc\hosts');
1534
1535 # On Linux/Unix
1536 # (prints "/usr/bin")
1537 print $f->return_path('/usr/bin/perl');
1538
1539 # On a Mac
1540 # (prints "foo:bar")
1541 print $f->return_path('foo:bar:baz');
1542
1543 =head2 Find out if the host system can use flock
1544
1545 use File::Util qw( can_flock );
1546 print can_flock;
1547
1548 -OR-
1549 print File::Util->can_flock;
1550
1551 -OR-
1552 my($f) = File::Util->new();
1553 print $f->can_flock;
1554
1555 =head2 Find out if the host system needs to call binmode on binary files
1556
1557 use File::Util qw( needs_binmode );
1558 print needs_binmode;
1559
1560 -OR-
1561 use File::Util;
1562 print File::Util->needs_binmode;
1563
1564 -OR-
1565 use File::Util;
1566 my($f) = File::Util->new();
1567 print $f->needs_binmode;
1568
1569 =head2 Find out if a file can be opened for read (based on file permissions)
1570
1571 use File::Util;
1572 my($f) = File::Util->new();
1573 my($is_readable) = $f->can_read('foo.txt');
1574
1575 =head2 Find out if a file can be opened for write (based on file permissions)
1576
1577 use File::Util;
1578 my($f) = File::Util->new();
1579 my($is_writable) = $f->can_write('foo.txt');
1580
1581 =head2 Escape illegal characters in a potential file name (and its path)
1582
1583 use File::Util;
1584 my($f) = File::Util->new();
1585
1586 # prints "C__WINDOWS_system32_drivers_etc_hosts"
1587 print $f->escape_filename('C:\WINDOWS\system32\drivers\etc\hosts');
1588
1589 # prints "baz)__@^"
1590 # (strips the file path from the file name, then escapes it
1591 print $f->escape_filename(
1592 '/foo/bar/baz)?*@^',
1593 '--strip-path'
1594 );
1595
1596 # prints "_foo_!_@so~me#illegal$_file&(name"
1597 # (yes, that is a legal filename)
1598 print $f->escape_filename(q[\foo*!_@so~me#illegal$*file&(name]);
1599
1600 =head2 Find out if the host system uses EBCDIC
1601
1602 use File::Util qw( ebcdic );
1603 print ebcdic;
1604
1605 -OR-
1606 use File::Util;
1607 print File::Util->ebcdic;
1608
1609 -OR-
1610 use File::Util;
1611 my($f) = File::Util->new();
1612 print $f->ebcdic;
1613
1614 =head2 Get the type(s) of an existent file
1615
1616 use File::Util qw( file_type );
1617 print file_type('foo.exe');
1618
1619 -OR-
1620 use File::Util;
1621 print File::Util->file_type('bar.txt');
1622
1623 -OR-
1624 use File::Util;
1625 my($f) = File::Util->new();
1626 print $f->file_type('/dev/null');
1627
1628 =head2 Get the bitmask of an existent file
1629
1630 use File::Util qw( bitmask );
1631 print bitmask('/usr/sbin/sendmail');
1632
1633 -OR-
1634 use File::Util;
1635 print File::Util->bitmask('C:\COMMAND.COM');
1636
1637 -OR-
1638 use File::Util;
1639 my($f) = File::Util->new();
1640 print $f->bitmask('/dev/null');
1641
1642 =head2 Get time of creation for a file
1643
1644 use File::Util qw( created );
1645 print scalar localtime created('/usr/bin/exim');
1646
1647 -OR-
1648 use File::Util;
1649 print scalar localtime File::Util->created('C:\COMMAND.COM');
1650
1651 -OR-
1652 use File::Util;
1653 my($f) = File::Util->new();
1654 print scalar localtime $f->created('/bin/less');
1655
1656 =head2 Get the last access time for a file
1657
1658 use File::Util qw( last_access );
1659 print scalar localtime last_access('/usr/bin/exim');
1660
1661 -OR-
1662 use File::Util;
1663 print scalar localtime File::Util->last_access('C:\COMMAND.COM');
1664
1665 -OR-
1666 use File::Util;
1667 my($f) = File::Util->new();
1668 print scalar localtime $f->last_access('/bin/less');
1669
1670 =head2 Get the inode change time for a file
1671
1672 use File::Util qw( last_changed );
1673 print scalar localtime last_changed('/usr/bin/vim');
1674
1675 -OR-
1676 use File::Util;
1677 print scalar localtime File::Util->last_changed('C:\COMMAND.COM');
1678
1679 -OR-
1680 use File::Util;
1681 my($f) = File::Util->new();
1682 print scalar localtime $f->last_changed('/bin/cpio');
1683
1684 =head2 Get the last modified time for a file
1685
1686 use File::Util qw( last_modified );
1687 print scalar localtime last_modified('/usr/bin/exim');
1688
1689 -OR-
1690 use File::Util;
1691 print scalar localtime File::Util->last_modified('C:\COMMAND.COM');
1692
1693 -OR-
1694 use File::Util;
1695 my($f) = File::Util->new();
1696 print scalar localtime $f->last_modified('/bin/less');
1697
1698 =head2 Make a new directory, recursively if neccessary
1699
1700 use File::Util;
1701 my($f) = File::Util->new();
1702 $f->make_dir('/var/tmp/tempfiles/foo/bar/');
1703
1704 # optionally specify a creation bitmask to be used in directory creations
1705 $f->make_dir('/var/tmp/tempfiles/foo/bar/',0755);
1706
1707 =head2 Touch a file
1708
1709 use File::Util qw( touch );
1710 touch('somefile.txt');
1711
1712 -OR-
1713 use File::Util;
1714 my($f) = File::Util->new();
1715 $f->touch('/foo/bar/baz.tmp');
1716
1717 =head2 Truncate a file
1718
1719 use File::Util;
1720 my($f) = File::Util->new();
1721 $f->trunc('/wibble/wombat/noot.tmp');
1722
1723 =head2 Get the correct path seperator for the host system
1724
1725 use File::Util qw( SL );
1726 print SL;
1727
1728 -OR-
1729 use File::Util;
1730 print File::Util->SL;
1731
1732 -OR-
1733 use File::Util;
1734 my($f) = File::Util->new();
1735 print $f->SL;
1736
1737 =head2 Get the correct newline character for the host system
1738
1739 use File::Util qw( NL );
1740 print NL;
1741
1742 -OR-
1743 use File::Util;
1744 print File::Util->NL;
1745
1746 -OR-
1747 use File::Util;
1748 my($f) = File::Util->new();
1749 print $f->NL;
1750
1751 =head1 EXAMPLES (Full Programs)
1752
1753 =head2 Batch File Rename
1754
1755 # Code changes the file suffix of all files in a directory ending in
1756 # *.foo so that they afterward end in *.bar
1757
1758 use strict;
1759 use vars qw( $dir );
1760 use File::Util qw( NL SL );
1761
1762 my($f) = File::Util->new();
1763 my($dir) = '../wibble';
1764 my($old) = 'foo';
1765 my($new) = 'bar';
1766 my(@files) = $f->list_dir($dir, '--files-only');
1767
1768 foreach (@files) {
1769
1770 # don't change the file suffix unless it is *.foo
1771 if ($_ =~ /\.$old$/o) {
1772
1773 my($newname) = $_; $newname =~ s/\.$old/\.$new/;
1774
1775 if (rename($dir . SL . $_, $dir . SL . $newname)) {
1776
1777 print qq[$_ -> $newname], NL
1778 }
1779 else { warn <<__ERR__ }
1780 Couldn't rename "$_" to "$newname"!
1781 __ERR__
1782 }
1783 else { print <<__NOCHANGE__ }
1784 File retained as "$_"
1785 __NOCHANGE__
1786 }
1787
1788 =head2 Recursively remove a directory and all its contents
1789
1790 # This code removes a directory and everything in it
1791
1792 use strict; # always
1793
1794 use File::Util qw( NL );
1795
1796 my($f) = File::Util->new();
1797 my($removedir) = '/path/to/directory/youwanttodelete';
1798
1799 my(@gonners) = $f->list_dir($removedir, '--follow');
1800
1801 # remove directory and everything in it
1802 my($a, $b);
1803 foreach (reverse(sort({ length($a) <=> length($b) } @gonners)), $removedir) {
1804 print "Removing $_ ..." . NL;
1805 -d $_ ? rmdir($_) || die $! : unlink($_) || die $!;
1806 }
1807
1808 print 'Done. w00T!', NL x 2;
1809
1810
1811 =head2 Wrap the lines in a file at 72 columns, then save it
1812
1813 # This code opens a file, wraps its lines, and saves the file with
1814 # the newly formatted content
1815
1816 use strict; # always
1817
1818 use File::Util qw( NL );
1819 use Text::Wrap qw( wrap );
1820
1821 $Text::Wrap::columns = 72; # wrap text at this many columns
1822
1823 my($f) = File::Util->new();
1824 my($textfile) = 'myreport.txt'; # file to wrap and save
1825
1826 $f->write_file(
1827 'filename' => $textfile,
1828 'content' => wrap('', '', $f->load_file($textfile))
1829 );
1830
1831 print 'Done.', NL x 2;
1832
1833 =head2 Read and increment a counter file, then save it
1834
1835 # This code opens a file, reads a number value, increments it,
1836 # then saves the newly incremented value back to the file
1837
1838 use strict; # always
1839
1840 use File::Util;
1841
1842 my($f) = File::Util->new();
1843 my($counterfile) = 'counter.txt';
1844
1845 # if the counter file doesn't exist, let's make one
1846 if (! $f->existent($counterfile)) {
1847 $f->touch($counterfile);
1848 }
1849
1850 my($count) = $f->load_file($counterfile);
1851
1852 # convert textual number to in-memory int type, -this will default
1853 # to a zero if it encounters non-numerical or empty content
1854 chomp($count); # strip off any trailing lines
1855 $count =~ s/[^[:digit:]]//g; # remove non-numeric data
1856 $count = 0 if "$count" eq ''; # set count to 0 if empty string
1857 $count = int($count); # numberify $count
1858
1859 print 'Count value from file: ' . $f->load_file($counterfile), $f->NL;
1860
1861 $count++; # increment the counter value by 1
1862
1863 # save the incremented count back to the counter file
1864 $f->write_file( 'filename' => $counterfile, 'content' => $count);
1865
1866 # verify that "it worked"
1867 print 'Count is now: ' . $f->load_file($counterfile), $f->NL;
1868 print 'Done.', $f->NL x 2;
1869
1870 =head2 Batch Search & Replace
1871
1872 # Code does a batch find or search and replace for all files in a given
1873 # directory, recursively or non-recursively based on choices set forth
1874 # in the code.
1875
1876 use strict;
1877 use File::Util qw( NL SL );
1878
1879 # will get search pattern from file named below
1880 use constant SFILE => './sr/searchfor';
1881
1882 # will get replace pattern from file named below
1883 use constant RFILE => './sr/replacewith';
1884
1885 # will perform batch operation in directory named below
1886 use constant INDIR => '/foo/bar/baz';
1887
1888 # specify whether the operation will do a find or a search and replace
1889 use constant RMODE => [qw| read-only write |]->[1];
1890
1891 # set the options for the search (will or will not recurse, etc)
1892 my(@opts) = [qw/ --files-only --with-paths --recurse /]->[0,1];
1893
1894 # create new File::Util object, set File::Util to send a warning for
1895 # fatal errors instead of dieing
1896 my($f) = File::Util->new('--fatals-as-warning');
1897 my($rstr) = $f->load_file(RFILE);
1898 my($spat) = quotemeta($f->load_file(SFILE)); $spat = qr/$spat/;
1899 my($gsbt) = 0;
1900 my($action) = RMODE eq 'read-only' ? 'detections' : 'substitutions';
1901 my(@files) = $f->list_dir(INDIR, @opts);
1902
1903 for (my($i) = 0; $i < @files; ++$i) {
1904
1905 next if $f->isbin($files[$i]);
1906
1907 my($sbt) = 0; my($file) = $f->load_file($files[$i]);
1908
1909 $file =~ s/$spat/++$sbt;++$gsbt;$rstr/ge;
1910
1911 $f->write_file('file' => $files[$i], 'content' => $file)
1912 if RMODE eq 'write';
1913
1914 print $sbt ? (qq[$sbt $action in $files[$i]] . NL) : '';
1915 }
1916
1917 print( NL . <<__DONE__ . NL x 2) and exit;
1918 $gsbt $action in ${\scalar(@files)} files.
1919 __DONE__
1920
1921 =head2 Pretty-Print A Directory Recursively
1922
1923 use strict;
1924 use vars qw( $a $b );
1925
1926 use File::Util qw( NL );
1927 my($ind) = '';
1928 my($f) = File::Util->new();
1929 my(@o) = qw(
1930 --with-paths
1931 --sl-after-dirs
1932 --no-fsdots
1933 --files-as-ref
1934 --dirs-as-ref
1935 );
1936
1937 my($filetree) = {};
1938 my($treetrunk) = '/var/';
1939 my($subdirs,$sfiles) = $f->list_dir($treetrunk, @o);
1940
1941 $filetree = [{
1942 $treetrunk => [ sort({ uc $a cmp uc $b } @$subdirs, @$sfiles) ]
1943 }];
1944
1945 descend($filetree->[0]{ $treetrunk },scalar(@$subdirs));
1946 walk(@$filetree);
1947
1948 sub descend {
1949 my($parent,$dirnum) = @_;
1950 for (my($i) = 0; $i < $dirnum; ++$i) {
1951 my($current) = $parent->[$i]; next unless -d $current;
1952 my($subdirs,$sfiles) = $f->list_dir($current, @o);
1953 map { $_ = $f->strip_path($_) } @$sfiles;
1954 splice(@$parent,$i,1,{
1955 $current => [ sort({ uc $a cmp uc $b } @$subdirs, @$sfiles) ]
1956 });
1957 descend($parent->[$i]{ $current },scalar(@$subdirs));
1958 }
1959 $parent
1960 }
1961
1962 sub walk {
1963 my($dir) = shift(@_);
1964 foreach (@{ [ %$dir ]->[1] }) {
1965 my($mem) = $_;
1966 if (ref($mem) eq 'HASH') {
1967 print($ind . $f->strip_path([ %$mem ]->[0]) . '/',NL);
1968 $ind .= ' ' x 3;
1969 walk($mem);
1970 $ind = substr($ind,3);
1971 } else { print($ind . $mem,NL) }
1972 }
1973 }
1974
1975 =head1 BUGS
1976
1977 Send bug reports to the AUTHOR. There are no known bugs at this time.
1978
1979 =head1 TODO
1980
1981 Add full support for PerlIO layers in C<File::Util::open_handle()> and possibly
1982 C<File::Util::write_file()>.
1983
1984 =head1 AUTHOR
1985
1986 Tommy Butler <L<cpan@atrixnet.com|mailto:cpan@atrixnet.com>>
1987
1988 =head1 COPYRIGHT
1989
1990 Copyright(C) 2001-2007, Tommy Butler. All rights reserved.
1991
1992 =head1 LICENSE
1993
1994 This library is free software, you may redistribute and/or modify it under
1995 the same terms as Perl itself.
1996
1997 =head1 SEE ALSO
1998
1999 L<File::Slurp>, L<Exception::Handler>, L<Class::OOorNO>
+15
-0
t/001_canuseit.t less more
0
1 use strict;
2 use Test;
3
4 # use a BEGIN block so we print our plan before MyModule is loaded
5 BEGIN { plan tests => 1, todo => [] }
6
7 # load your module...
8 use lib './';
9 use File::Util;
10
11 # check object constructor
12 ok(ref(File::Util->new()),'File::Util');
13
14 exit;⏎
+19
-0
t/002_isa.t less more
0
1 use strict;
2 use Test;
3
4 # use a BEGIN block so we print our plan before MyModule is loaded
5 BEGIN { plan tests => 2, todo => [] }
6 BEGIN { $| = 1 }
7
8 # load your module...
9 use lib './';
10 use File::Util;
11
12 my($f) = File::Util->new();
13
14 # check to see if File::Util ISA [foo, etc.]
15 ok(UNIVERSAL::isa($f,'File::Util'));
16 ok(UNIVERSAL::isa($f,'Class::OOorNO'));
17
18 exit;⏎
+57
-0
t/003_can.t less more
0
1 use strict;
2 use Test;
3
4 # use a BEGIN block so we print our plan before MyModule is loaded
5 BEGIN { plan tests => 37, todo => [] }
6 BEGIN { $| = 1 }
7
8 # load your module...
9 use lib './';
10 use File::Util;
11
12 my($f) = File::Util->new();
13
14 # check to see if non-autoloaded File::Util methods are can-able ;O)
15 map { ok(ref(UNIVERSAL::can($f,$_)),'CODE') } qw
16 (
17 _dropdots
18 _errors
19 _release
20 _seize
21 _throw
22 bitmask
23 can_flock
24 can_read
25 can_write
26 created
27 ebcdic
28 escape_filename
29 existent
30 file_type
31 isbin
32 last_access
33 last_modified
34 line_count
35 list_dir
36 load_dir
37 load_file
38 flock_rules
39 make_dir
40 max_dives
41 needs_binmode
42 new
43 open_handle
44 readlimit
45 size
46 strip_path
47 trunc
48 use_flock
49 write_file
50 valid_filename
51 VERSION
52 DESTROY
53 AUTOLOAD
54 );
55
56 exit;
+106
-0
t/004_portable.t less more
0
1 use strict;
2 use Test;
3
4 # use a BEGIN block so we print our plan before MyModule is loaded
5 BEGIN { plan tests => 46, todo => [] }
6 BEGIN { $| = 1 }
7
8 # load your module...
9 use lib './';
10 use File::Util qw
11 (
12 SL NL escape_filename
13 valid_filename strip_path needs_binmode
14 );
15
16 my($f) = File::Util->new();
17
18 # check asignability
19 my($NL) = NL; my($SL) = SL;
20
21 # newlines
22 ok(NL eq $NL); # test 1
23
24 # binmode necessary?
25 ok(needs_binmode, NL eq qq[\015\012] ? 1 : 0); # test 2
26
27 # path seperator
28 ok(SL eq $SL); # test 3
29
30 # test file escaping with substitute escape char
31 # with additional char to escape as well.
32 ok # test 4
33 (
34 escape_filename(q[./foo/bar/baz.t/], '+','.'),
35 '++foo+bar+baz+t+'
36 );
37
38 # test file escaping with defaults
39 ok # test 5
40 (
41 escape_filename(q[.\foo\bar\baz.t]),
42 '._foo_bar_baz.t'
43 );
44
45 # test file escaping with option "--strip-path"
46 ok # test 6
47 (
48 escape_filename
49 (
50 q[.:foo:bar:baz.t],
51 '--strip-path'
52 ),
53 'baz.t'
54 );
55
56 # path stripping in general
57 ok(strip_path(__FILE__),'004_portable.t'); # test 7
58
59 # illegal filename character intolerance
60 ok(!valid_filename(qq[?foo])); # question mark
61 ok(!valid_filename(qq[>foo])); # greater than
62 ok(!valid_filename(qq[<foo])); # less than
63 ok(!valid_filename(qq[<foo])); # less than
64 ok(!valid_filename(qq[<foo])); # less than
65 ok(!valid_filename(qq[<foo])); # less than
66 ok(!valid_filename(qq[:foo])); # colon
67 ok(!valid_filename(qq[*foo])); # asterisk
68 ok(!valid_filename(qq[/foo])); # forward slash
69 ok(!valid_filename(qq[\\foo])); # back slash
70 ok(!valid_filename(qq["foo])); # double quotation mark
71 ok(!valid_filename(qq[\tfoo])); # tab
72 ok(!valid_filename(qq[\013foo])); # vertical tab
73 ok(!valid_filename(qq[\012foo])); # newline
74 ok(!valid_filename(qq[\015foo])); # form feed
75
76 # strange but legal filename character tolerance
77 ok(valid_filename(q['foo]));
78 ok(valid_filename(';foo'));
79 ok(valid_filename('$foo'));
80 ok(valid_filename('%foo'));
81 ok(valid_filename('`foo'));
82 ok(valid_filename('!foo'));
83 ok(valid_filename('@foo'));
84 ok(valid_filename('#foo'));
85 ok(valid_filename('^foo'));
86 ok(valid_filename('&foo'));
87 ok(valid_filename('-foo'));
88 ok(valid_filename('_foo'));
89 ok(valid_filename('+foo'));
90 ok(valid_filename('=foo'));
91 ok(valid_filename('(foo'));
92 ok(valid_filename(')foo'));
93 ok(valid_filename('{foo'));
94 ok(valid_filename('}foo'));
95 ok(valid_filename('[foo'));
96 ok(valid_filename(']foo'));
97 ok(valid_filename('~foo'));
98 ok(valid_filename('.foo'));
99 ok(valid_filename(q/;$%`!@#^&-_+=(){}[]~baz.foo'/));
100
101 # directory listing tests...
102 # remove '.' and '..' directory entries
103 ok(length(join('',$f->_dropdots(qw(. .. foo bar baz)))),9);
104
105 exit;
+57
-0
t/005_ftests.t less more
0
1 use strict;
2 use Test;
3
4 # use a BEGIN block so we print our plan before MyModule is loaded
5 BEGIN { plan tests => 35, todo => [] }
6 BEGIN { $| = 1 }
7
8 # load your module...
9 use lib './';
10 use File::Util qw( SL OS );
11
12 my($f) = File::Util->new();
13
14 my(@fls) = ( qq[t${\SL}txt], qq[t${\SL}bin], 't', '.', '..' );
15 my($skip) = (OS eq 'WINDOWS') ? 'Running on window$' : 0;
16
17 # types
18 ok(join('',@{[$f->file_type($fls[0])]}), 'PLAINTEXT');
19 ok(join('',@{[$f->file_type($fls[1])]}), 'PLAINBINARY');
20
21 # skip if windows
22 skip($skip, join('',@{[$f->file_type($fls[2])]}), 'BINARYDIRECTORY', $skip);
23 skip($skip, join('',@{[$f->file_type($fls[3])]}), 'BINARYDIRECTORY', $skip);
24 skip($skip, join('',@{[$f->file_type($fls[4])]}), 'BINARYDIRECTORY', $skip);
25
26 # chk these on windows
27 skip(!$skip, join('',@{[$f->file_type($fls[2])]}), 'DIRECTORY');
28 skip(!$skip, join('',@{[$f->file_type($fls[3])]}), 'DIRECTORY');
29 skip(!$skip, join('',@{[$f->file_type($fls[4])]}), 'DIRECTORY');
30
31
32 # file is/isn't binary
33 ok($f->isbin($fls[1], 1));
34 ok(!$f->isbin(__FILE__));
35
36 foreach (@fls) {
37
38 my($file) = $_;
39
40 # get file size
41 ok($f->size($file), -s $file);
42
43 # get file creation time
44 ok($f->created($file),$^T - ((-M $file) * 60 * 60 * 24));
45
46 # get file last access time
47 ok($f->last_access($file),$^T - ((-A $file) * 60 * 60 * 24));
48
49 # get file last modified time
50 ok($f->last_modified($file),$^T - ((-M $file) * 60 * 60 * 24));
51
52 # get file's bitmask
53 ok($f->bitmask($file),sprintf('%04o',(stat($file))[2] & 0777));
54 }
55
56 exit;
+150
-0
t/006_io.t less more
0
1 use strict;
2 use Test;
3
4 # use a BEGIN block so we print our plan before File::Util is loaded
5 BEGIN { plan tests => 13, todo => [] }
6 BEGIN { $| = 1 }
7
8 # load your module...
9 use lib './';
10 use File::Util qw( SL NL existent );
11
12 my($f) = File::Util->new('--fatals-as-status');
13 my($fh) = undef;
14 my($testbed) = 't' . SL . $$;
15 my($skip) = !$f->can_write('.') ||
16 !$f->can_write('t');
17
18 $skip = $skip ? &skipmsg() : $skip;
19
20 sub skipmsg { <<'__WHYSKIP__' }
21 Insufficient permissions to perform IO in this directory. Can't perform tests!
22 __WHYSKIP__
23
24 # 1
25 # make a temporary testbed directory
26 skip($skip, sub { $f->make_dir($testbed, '--if-not-exists') }, $testbed);
27
28 # 2
29 # see if it's there
30 skip($skip, -e $testbed, 1, $skip);
31
32 # 3
33 # ...again
34 skip($skip, sub { $f->existent($testbed) }, 1, $skip);
35
36 # 4
37 # make a temporary file
38 my($tmpf) = $testbed . SL . 'tmptst';
39 skip(
40 $skip,
41 sub {
42 $f->write_file('file' => $tmpf, 'content' => $$ . NL),
43 }, 1, $skip
44 );
45
46 # 5
47 # File::Util::touch() a file, and see if it was created ok
48 skip(
49 $skip,
50 sub {
51 my($tmpf) = $testbed . SL . 'touched';
52 $f->touch($tmpf);
53 my($return) = $f->existent($tmpf);
54 unlink($tmpf);
55 return($return);
56 }, 1, $skip
57 );
58
59 # 6
60 # get an open file handle
61 $fh = '';
62 skip(
63 $skip,
64 sub {
65 $fh = $f->open_handle(
66 'file' => $tmpf,
67 'mode' => 'append',
68 qw(--fatals-as-errmsg --warn-also)
69 );
70 $skip = &skipmsg() unless ($fh && length($fh) > 1);
71 return 1; # stupid solaris testers won't play fair
72 },
73 1,
74 $skip
75 );
76
77 # 7
78 # make sure it's still open
79 skip($skip, eval(q{fileno($fh)}), '/^\d/', $skip);
80
81 # write to it, close it, write to it in append mode
82 unless ($skip) { print( $fh 'Hello world!' . NL ); close($fh); }
83
84 # 8
85 # load file
86 skip($skip, sub { $f->load_file($tmpf),$f->load_file($tmpf) });
87
88 # 9
89 # write to it with method File::Util::write_file(), compare file contents
90 # with the returned value
91 skip (
92 $skip,
93 sub {
94 $f->write_file(
95 'filename' => $tmpf,
96 'content' => ( $^O || 'foo' ) . NL,
97 'mode' => 'append',
98 )
99 }, 1, $skip
100 );
101
102 # 10
103 # get line count of file
104 skip($skip, sub { $f->line_count($tmpf) }, 3, $skip);
105
106 # 11
107 # truncate file
108 skip($skip, sub { $f->trunc($tmpf); -s $tmpf }, 0, $skip);
109
110 # 12
111 # get line count of file
112 skip($skip, sub { $f->line_count($tmpf)}, 0, $skip);
113
114 # big directory creation / removal sequence
115 my($newdir) =
116 $testbed
117 . SL . int(rand(time))
118 . SL . int(rand(time))
119 . SL . int(rand(time))
120 . SL . int(rand(time));
121
122 # 13
123 # make directories
124 skip($skip, sub { $f->make_dir($newdir, '--if-not-exists') }, $newdir, $skip);
125
126 # read directories
127 unless ($skip) {
128 my(@items) = $f->list_dir($testbed, '--follow');
129
130 # remove directories, temp file, testbed.
131 foreach (reverse(sort({ length($a) <=> length($b) } @items)), $testbed) {
132
133 -d $_ ? rmdir($_) || &_rmdie($!) : unlink($_) || &_uldie($!);
134 }
135 }
136
137 exit;
138
139 # ---- SUBS -----------------------------------------------
140
141 sub _uldie { die(<<__BADUNLINK__) }
142 Can't unlink recently created temp file used in testing process.
143 $!
144 __BADUNLINK__
145
146 sub _rmdie { die(<<__BADRMDIR__) }
147 Can't remove recently created temporary directory used in testing process.
148 $!
149 __BADRMDIR__
+121
-0
t/007_flock.t less more
0
1 use strict;
2 use Test;
3
4 # use a BEGIN block so we print our plan before MyModule is loaded
5 BEGIN { plan tests => 12, todo => [] }
6 BEGIN { $| = 1 }
7
8 # load your module...
9 use lib './';
10 use Fcntl qw( );
11
12 use File::Util qw( SL NL );
13 my($f) = File::Util->new();
14 my($tmpf) = 'flock_test';
15 my($probe_flock) = sub { local($@); eval(<<'__canflock__'); $@ ? 0 : 1 };
16 flock(STDIN, &Fcntl::LOCK_SH);
17 flock(STDIN, &Fcntl::LOCK_UN);
18 __canflock__
19 my($skip) = !$f->can_write('.') || !$f->can_write('t');
20
21 $skip = $skip ? &skipmsg() : $skip;
22
23 # using flock? get/set flock-ing usage toggle
24 ok($f->use_flock( ),1); # test 1
25 ok($f->use_flock(1),1); # test 2
26 ok($f->use_flock(0),0); # test 3
27 ok($f->use_flock( ),0); # test 4
28 ok($f->use_flock(1),1); # test 5
29
30 # get/set flock-ing failure policy
31 ok(qq[@{[$f->flock_rules()]}],'NOBLOCKEX FAIL'); # test 6
32 ok(join(' ', $f->flock_rules(qw/ NOBLOCKEX ZERO /)),q[NOBLOCKEX ZERO]);# test 7
33
34 # can the system lock file IO? does it?
35 skip(!$probe_flock, $f->can_flock, 1); # test 8
36
37 # does it really work?
38 skip(!$probe_flock, &test_flock()); # test 9
39
40 exit;
41
42 # put flock to the "test"
43 sub test_flock {
44
45 # lock file, keep open handle on it
46 my($fh);
47
48 unless ($skip) {
49 $fh = $f->open_handle('file' => $tmpf);
50
51 # write something into the file
52 my($tstr) = 'Hello world!' . NL;
53 print($fh $tstr x 50);
54
55 }
56
57 # try to $f->trunc locked file (should fail)
58 skip(
59 $skip,
60 sub { # test 10
61
62 # FORKING!!
63 my($pid) = fork; $| = 1; die(qq{Can't fork: $!}) unless defined($pid);
64
65 if (!$pid) { $f->trunc($tmpf); exit } else { waitpid($pid, 0) }
66
67 # DONE WITH THAT NOW.
68 -s $tmpf
69 });
70
71 # test 11 - try to $f->write_file on locked file (should fail)
72 skip(
73 $skip,
74 sub {
75
76 # FORKING!!
77 my($pid) = fork; $| = 1; die(qq{Can't fork: $!}) unless defined($pid);
78
79 if (!$pid) {
80
81 $f->write_file(
82 'file' => $tmpf,
83 'content' => '',
84 '--empty-writes-OK'
85 );
86
87 exit
88 }
89 else { waitpid($pid, 0) }
90
91 # DONE WITH THAT NOW.
92 -s $tmpf
93 });
94
95 # unlock file
96 close($fh) unless $skip;
97
98 # test 12 - try to trunc the file; should succeed
99 # - skip this on solaris...
100 if ($^O =~ /solaris/i) {
101 skip(&skip_trunc_solaris(), 0, 0);
102 }
103 else {
104 skip($skip, sub { $f->trunc($tmpf); return -s $tmpf }, 0);
105 }
106
107 # try to delete the file; should succeed
108 unlink($tmpf) unless $skip;
109
110 !-e $tmpf;
111 }
112
113 sub skipmsg { <<'__WHYSKIP__' }
114 Insufficient permissions to perform IO in this directory. Can't perform tests!
115 __WHYSKIP__
116
117 sub skip_trunc_solaris { <<'__WHYSKIP__' }
118 Solaris can flock, but won't let go of discretionary lock yet.
119 __WHYSKIP__
120
+26
-0
t/008_export_ok.t less more
0
1 use strict;
2 use Test;
3
4 # use a BEGIN block so we print our plan before module is loaded
5 BEGIN { use File::Util }
6 BEGIN { plan tests => scalar(@File::Util::EXPORT_OK), todo => [] }
7 BEGIN { $| = 1 }
8
9 # load your module...
10 use lib './';
11
12 # we gonna see if'n it cun export wut itz 'pose ta. this checks the
13 # @EXPORT_OK of all packages in the inheritance cascade, which is the
14 # only reason we're doing this. we already know that it UNIVERSAL::can do
15 # all its own methods if this test is being run. test 3 ensures that.
16 # this is just an automated non-empty superclass test
17 use File::Util @File::Util::EXPORT_OK;
18
19 map {
20
21 ok ref(UNIVERSAL::can('File::Util', $_)) eq 'CODE'
22
23 } @File::Util::EXPORT_OK;
24
25 exit;
+35
-0
t/009_empty_subclass.t less more
0
1 use strict;
2 use Test;
3
4 # use a BEGIN block so we print our plan before module is loaded
5 BEGIN { use File::Util }
6 BEGIN { plan tests => scalar(@File::Util::EXPORT_OK), todo => [] }
7 BEGIN { $| = 1 }
8
9 # load your module...
10 use lib './';
11
12 # automated empty subclass test
13
14 # subclass File::Util in package _Foo
15 package _Foo;
16 use strict;
17 use warnings;
18 use File::Util qw( :all );
19 $Foo::VERSION = 0.00_0;
20 @_Foo::ISA = qw( File::Util );
21 1;
22
23 # switch back to main package
24 package main;
25
26 # see if _Foo can do everything that File::Util can do
27 map {
28
29 ok ref(UNIVERSAL::can('_Foo', $_)) eq 'CODE'
30
31 } @File::Util::EXPORT_OK;
32
33
34 exit;
+274
-0
t/010_diesnice.t less more
0
1 use strict;
2 use Test;
3
4 # use a BEGIN block so we print our plan before MyModule is loaded
5 BEGIN { plan tests => 31, todo => [] }
6 BEGIN { $| = 1 }
7
8 # load your module...
9 use lib './';
10 use File::Util qw( SL NL existent );
11
12 my($f) = File::Util->new('--fatals-as-errmsg');
13
14 # start testing failure sequence
15 ok($f->_throw('no such file' => { 'filename' => __FILE__ }, '--fatals-as-errmsg' ),
16 q{/no such file or directory exists/},
17 q{Bad failure return code for error: "no such file"}
18 );
19
20 ok(
21 $f->_throw(
22 'bad flock rules' => {
23 'bad' => __FILE__,
24 'all' => [ $f->flock_rules() ],
25 }
26 ),
27 q{/Invalid file locking policy/},
28 q{Bad failure return code for error: "bad flock rules"}
29 );
30
31 ok(
32 $f->_throw(
33 'cant fread' => {
34 'filename' => __FILE__,
35 'dirname' => '.',
36 }
37 ),
38 q{/Permissions conflict\..+?can't read the contents of this file:/},
39 q{Bad failure return code for error: "cant fread"}
40 );
41
42 ok($f->_throw('cant fread not found' => { 'filename' => __FILE__, }),
43 q{/File not found\. .+?can't read the contents of this file\:/},
44 q{Bad failure return code for error: "cant fread no exists"}
45 );
46
47 ok(
48 $f->_throw(
49 'cant fcreate' => {
50 'filename' => __FILE__,
51 'dirname' => '.',
52 }
53 ),
54 q{/Permissions conflict\..+?can't create this file:/},
55 q{Bad failure return code for error: "cant fcreate"}
56 );
57
58 ok($f->_throw('cant write_file on a dir' => { 'filename' => __FILE__, }),
59 q{/can't write to the specified file/},
60 q{Bad failure return code for error: "cant write_file on a dir"}
61 );
62
63 ok(
64 $f->_throw(
65 'cant fwrite' => {
66 'filename' => __FILE__,
67 'dirname' => '.',
68 }
69 ),
70 q{/Permissions conflict\..+?can't write to this file:/},
71 q{Bad failure return code for error: "cant fwrite"}
72 );
73
74 ok(
75 $f->_throw(
76 'bad openmode popen' => {
77 'filename' => __FILE__,
78 'badmode' => 'illegal',
79 'meth' => 'anonymous',
80 }
81 ),
82 q{/Illegal mode specified for file open\./},
83 q{Bad failure return code for error: "bad openmode popen"}
84 );
85
86 ok(
87 $f->_throw(
88 'bad openmode sysopen' => {
89 'filename' => __FILE__,
90 'badmode' => 'illegal',
91 'meth' => 'anonymous',
92 }
93 ),
94 q{/Illegal mode specified for file sysopen/},
95 q{Bad failure return code for error: "bad openmode sysopen"}
96 );
97
98 ok($f->_throw('cant dread' => { 'dirname' => '.' } ),
99 q{/Permissions conflict\..+?can't list the contents of this/},
100 q{Bad failure return code for error: "cant dread"}
101 );
102
103 ok(
104 $f->_throw(
105 'cant dcreate' => {
106 'dirname' => '.',
107 'parentd' => '..',
108 }
109 ),
110 q{/Permissions conflict\..+?can't create:/},
111 q{Bad failure return code for error: "cant dcreate"}
112 );
113
114 ok(
115 $f->_throw(
116 'make_dir target exists' => {
117 'dirname' => '.',
118 'filetype' => qq{@{[$f->file_type('.')]}},
119 }
120 ),
121 q{/make_dir target already exists\./},
122 q{Bad failure return code for error: "make_dir target exists"}
123 );
124
125 ok(
126 $f->_throw(
127 'bad open' => {
128 'mode' => 'illegal mode',
129 'filename' => __FILE__,
130 'exception' => 'dummy',
131 'cmd' => 'illegal cmd',
132 }
133 ),
134 q{/can't open this file for .illegal mode.:/},
135 q{Bad failure return code for error: "bad open"}
136 );
137
138 ok(
139 $f->_throw(
140 'bad close' => {
141 'mode' => 'illegal mode',
142 'filename' => __FILE__,
143 'exception' => 'dummy',
144 }
145 ),
146 q{/couldn't close this file after .illegal mode./},
147 q{Bad failure return code for error: "bad close"}
148 );
149
150 ok(
151 $f->_throw(
152 'bad systrunc' => {
153 'filename' => __FILE__,
154 'exception' => 'dummy',
155 }
156 ),
157 q{/couldn't truncate\(\) on.+?after having/},
158 q{Bad failure return code for error: "bad systrunc"}
159 );
160
161 ok(
162 $f->_throw(
163 'bad flock' => {
164 'filename' => __FILE__,
165 'exception' => 'illegal',
166 }
167 ),
168 q{/can't get a lock on the file/},
169 q{Bad failure return code for error: "bad flock"}
170 );
171
172 ok($f->_throw('called open on a dir' => { 'filename' => __FILE__ }),
173 q{/can't call open\(\) on this file because it is a directory/},
174 q{Bad failure return code for error: "called open on a dir"}
175 );
176
177 ok($f->_throw('called opendir on a file' => { 'filename' => __FILE__ }),
178 q{/can't opendir\(\) on this file because it is not a directory/},
179 q{Bad failure return code for error: "called opendir on a file"}
180 );
181
182 ok($f->_throw('called mkdir on a file' => { 'filename' => __FILE__ }),
183 q{/can't auto-create a directory for this path name because/},
184 q{Bad failure return code for error: "called mkdir on a file"}
185 );
186
187 ok($f->_throw('bad readlimit' => {}),
188 q{/Bad call to .+?\:\:readlimit\(\)\. This method can only be/},
189 q{Bad failure return code for error: "bad readlimit"}
190 );
191 ok(
192 $f->_throw(
193 'readlimit exceeded' => {
194 'filename' => __FILE__,
195 'size' => 'testtesttest',
196 }
197 ),
198 q{/(?sm)can't load file.+?into memory because its size exceeds/},
199 q{Bad failure return code for error: "readlimit exceeded"}
200 );
201
202 ok($f->_throw('bad maxdives' => {}),
203 q{/Bad call to .+?\:\:max_dives\(\)\. This method can only be/},
204 q{Bad failure return code for error: "bad maxdives"}
205 );
206
207 ok($f->_throw('maxdives exceeded' => {}),
208 q{/Recursion limit reached at .+?dives\. Maximum number of/},
209 q{Bad failure return code for error: "maxdives exceeded"}
210 );
211
212 ok(
213 $f->_throw(
214 'bad opendir' => {
215 'dirname' => '.',
216 'exception' => 'illegal',
217 }
218 ),
219 q{/can't opendir on directory\:/},
220 q{Bad failure return code for error: "bad opendir"}
221 );
222
223 ok(
224 $f->_throw(
225 'bad make_dir' => {
226 'dirname' => '.',
227 'bitmask' => 0777,
228 'exception' => 'illegal',
229 'meth' => 'anonymous',
230 }
231 ),
232 q{/had a problem with the system while attempting to create/},
233 q{Bad failure return code for error: "bad make_dir"}
234 );
235
236 ok(
237 $f->_throw(
238 'bad chars' => {
239 'string' => 'illegal characters',
240 'purpose' => 'testing',
241 }
242 ),
243 q{/(?sm)can't use this string.+?It contains illegal characters\./},
244 q{Bad failure return code for error: "bad chars"}
245 );
246
247 ok($f->_throw('not a filehandle' => { 'argtype' => 'illegal', }),
248 q{/can't unlock file with an invalid file handle reference\:/},
249 q{Bad failure return code for error: "not a filehandle"}
250 );
251
252 ok($f->_throw('no input' => { 'meth' => 'anonymous' }),
253 q{/(?sm)can't honor your call to.+?because you didn't provide/},
254 q{Bad failure return code for error: "no input"}
255 );
256
257 ok($f->_throw('plain error' => 'testtesttest'),
258 q{/failed with the following message\:/},
259 q{Bad failure return code for error: "plain error"}
260 );
261
262 ok($f->_throw('unknown error message', => {}),
263 q{/failed with an invalid error-type designation\./},
264 q{Bad failure return code for error: "unknown error message"}
265 );
266
267 ok($f->_throw('empty error', => {}),
268 q{/failed with an empty error-type designation\./},
269 q{Bad failure return code for error: "empty error"}
270 );
271
272 exit;
273
t/bin less more
Binary diff not shown
+1
-0
t/txt less more
0 Just Another Perl Hacker⏎