@@ -0,0 +1,2 @@
+Tommy Butler - www.atrixnet.com/contact
+Others Wanted!
@@ -0,0 +1,75 @@
+
+use strict;
+use warnings;
+
+use Module::Build 0.3601;
+
+
+my %module_build_args = (
+ "build_requires" => {
+ "Module::Build" => "0.3601"
+ },
+ "configure_requires" => {
+ "ExtUtils::MakeMaker" => "6.30",
+ "Module::Build" => "0.3601"
+ },
+ "dist_abstract" => "Easy, versatile, portable file handling",
+ "dist_author" => [
+ "Tommy Butler"
+ ],
+ "dist_name" => "File-Util",
+ "dist_version" => "4.132140",
+ "license" => "perl",
+ "module_name" => "File::Util",
+ "recommends" => {
+ "Unicode::UTF8" => "0.58"
+ },
+ "recursive_test_files" => 1,
+ "requires" => {
+ "Config" => 0,
+ "Exporter" => 0,
+ "Fcntl" => 0,
+ "Scalar::Util" => 0,
+ "constant" => 0,
+ "perl" => "5.008001",
+ "strict" => 0,
+ "subs" => 0,
+ "vars" => 0,
+ "warnings" => 0
+ },
+ "script_files" => [],
+ "test_requires" => {
+ "AutoLoader" => 0,
+ "Config" => 0,
+ "Cwd" => 0,
+ "Exporter" => 0,
+ "ExtUtils::MakeMaker" => 0,
+ "Fcntl" => 0,
+ "File::Find" => 0,
+ "File::Temp" => 0,
+ "Module::Build" => 0,
+ "Scalar::Util" => 0,
+ "Test" => 0,
+ "Test::More" => "0.88",
+ "Test::NoWarnings" => 0,
+ "utf8" => 0
+ }
+);
+
+
+unless ( eval { Module::Build->VERSION(0.4004) } ) {
+ my $tr = delete $module_build_args{test_requires};
+ my $br = $module_build_args{build_requires};
+ for my $mod ( keys %$tr ) {
+ if ( exists $br->{$mod} ) {
+ $br->{$mod} = $tr->{$mod} if $tr->{$mod} > $br->{$mod};
+ }
+ else {
+ $br->{$mod} = $tr->{$mod};
+ }
+ }
+}
+
+my $build = Module::Build->new(%module_build_args);
+
+$build->create_build_script;
@@ -1,2 +1,10 @@
This library is free software, you may redistribute it and/or modify it
-under the same terms as Perl itself.
+under the same terms as Perl itself. For more details, see the full text of
+the LICENSE file that is included in this distribution.
+
+This software is distributed in the hope that it will be useful, but without
+any warranty; without even the implied warranty of merchantability or fitness
+for a particular purpose.
+
+The above statement applies to all source code and documentation within this
+distribution and is not specific to any single file.
@@ -1,482 +1,758 @@
Revision history for Perl extension File::Util.pm
- 2.27
- Sat Dec 6 13:10:00 CST 2008
- Fixed a bug that caused root directories using Micro$oft filesystem
- notation to be mis-read when using the '--dirs-only' flag for
- File::Util::list_dir()
-
- 3.26
- Tue Dec 2 20:07:09 CST 2008
- Added to test suite in order to avoid errant test failures
- when flock'ing on solaris. This is a big deal, since the point of
- File::Util is to be easy, and portable!
-
- Added some yet more extra examples in the documentation.
-
- 3.25
- Mon Dec 1 15:11:20 CST 2008
- Fixed a bug in File::Util::touch()
-
- Added some extra examples and corrected one minor error in the
- documentation.
-
- 3.24
- Wed May 23 16:27:20 CDT 2007
- Added method File::Util::last_changed (get inode change time for a file)
- Added method File::Util::touch (works like *nix touch command)
-
- Both touch and last_changed are autoloaded methods
-
- Applied patch from S. Muskiewicz that fixes the File::Util::last_modified
- method that was using a similar but incorrect "-" file test operator.
-
- 3.23
- Fri Feb 15 07:34:29 CST 2008
- No major code changes. Small bug fixes--
- Corrected syntax on package makefile that causes warnings to be
- generated in cases of older Perl versions. Also corrected a problem
- in the documentation where the section "Get the path preceeding a
- file name" was showing incorrect information.
-
- 3.22
- Wed May 23 16:27:20 CDT 2007
- Fixed windows-specific bugs associated with the handling of newlines
- and directory path separators. Now compatible with Strawberry Perl
- and once again Active$tate Perl for MSWin*.
-
- 3.21
- Mon May 21 18:22:11 CDT 2007
- Fixed solaris-specific bug in test suite causing a simple regular
- expression to fail. Previous changes up to this point merit a public
- release, pending the fixing of afforementioned bug, hence this release.
-
- 3.20_2
- Mon May 21 16:15:23 CDT 2007
- Fixed small but important incompatibility with some versions of
- Exception::Handler
-
- 3.20_1
- Fri May 18 15:42:01 CDT 2007
- Improved error handling mechanism even more, and created 31 new test
- scenarios to make sure that any failure events are handled correctly.
-
- Fixed some small latent bugs, for example, corrected file handle
- reference verification error handling--checking for validity of
- file handle references.
-
- 3.19
- Wed May 16 18:07:49 CDT 2007
- Documentation. Documentation. Documentation. Small corrections and
- several enhancements. More examples.
-
- Improved error-handling mechanism by adding cascading logic to prioritize
- fatality-handling rules of failed calls over the rules of the File::Util
- object, whether they be defaults or manually set up via File::Util::new()
-
- 3.18
- Tue Feb 27 15:54:51 CST 2007
- Finished documentation for ALL methods. Whew! That was a lot of
- writing. The documentation will continue to evolve.
-
- Implemented the --use-sysopen flag for File::Util::open_handle()
- and thereafter the following extra open modes for it (only valid if
- the --use-sysopen flag is used):
- rwcreate
- rwupdate
- rwclobber
- rwappend
-
- (See the documentation for more details about this new feature).
-
- Added new method File::Util::release_open_file() for the purpose
- of releasing file locks placed on file handles by the
- File::Util::open_file() method, that is, when file locking is
- NOT turned off. If file locking is disabled by the user, this new
- method has no effect.
-
- 3.17_*
- Fri Feb 23 - Mon Feb 26
- Developer's releases (testing); not released to the public.
-
- 3.16
- Tue Feb 20 14:16:45 CST 2007
- Fixed problem with method File::Util::make_dir() when used with
- absolute pathnames (path names starting with "/", for example).
-
- Fixed documentation error concerning the File::Util::list_dir method,
- specifically regarding the "--pattern" option flag.
-
- Method File::Util::make_dir() now enforces the policy of failing when
- asked to create a directory that already exists as a file of any kind.
- Use the "--if-not-exists" flag if you are counting on the old behavior
- or if you want to create directories which could possibly exist already.
-
- More documentation added.
-
-
- 3.15
- Fri Dec 22 14:12:45 CST 2006
- Fixed broken test suite that was causing `make test` to fail falsely.
- Revisited documentation, adding a little, and various small improvements.
-
- 3.14_8
- Thu Dec 14 20:13:03 CST 2006
- Fixed some error messages to be more clear. Tweaked the
- File::Util::readlimit() method to provide better error messages if
- called incorrectly. Modified File::Util::make_dir() to include
- the --if-not-exists option.
-
- More documentation added for various methods whose documentation had
- yet to be written.
-
- Fixed a broken test case in "make test" that was causing it to fail
- falsely.
-
- Releasing this version as an official release and NOT a developer's
- release only.
-
-
- 3.14_7
- Sat Jan 31 13:36:24 CST 2004
- Changes to method File::Util::flock_rules() to output helpful error
- message if specification of invalid file locking policy attempted.
-
- flock_rules parameter for File::Util::new() constructor method no
- longer accepted or recognized in the interest of speed and efficiency.
- If you want to change the default flock rules for the File::Util object,
- then call File::Util::flock_rules() with your desired ruleset as
- specified in the documentation for this method.
-
- Changed default max_dives number to 1000. (See documentation for the
- File::Util::max_dives() method.)
-
- Much more documentation added for various methods whose documentation
- had yet to be written.
-
- 3.14_6
- Mon Sep 22 11:10:46 CDT 2003
- Changes to methods File::Util::list_dir() and
- File::Util::escape_filename() increase efficiency and fix some bugs.
- Both methods retain the same interface and return values in the same
- manner.
-
- Added new method File::Util::return_path() (see documentation).
-
- Method File::Util::last_mod changed to File::Util::last_modified for
- clarity, better readability, and consistency with other similar methods
- in the File::Util namespace. (eg- File::Util::last_access, etc)
-
- Added the following methods to @EXPORT_OK
- File::Util::return_path()
- File::Util::created()
- File::Util::last_access()
- File::Util::last_modified()
-
- Much more documentation added. Test suite revisited to reflect changes
- to the methods mentioned above.
-
- 3.14_2
- 1/14/03, 12:05 am
- Much more documentation added. Various methods slightly altered to stay
- in keeping with the docs and with standard conventions. Test suite
- revisited somewhat.
-
- 3.14_1
- 1/2/03, 3:47 am
- Added a substantial amount of new documentation. Spelling errors in
- documentation files corrected.
+4.132140 Fri Aug 2 11:38:57 CDT 2013
- Previously available method, File::Util::os(), has been dropped from the
- namespace and is no longer part of the module.
-
- Method File::Util::file_type() no longer includes the 'tty' keyword among
- its list of recognized file types, as the native Perl file test for
- divining a TTY file can only be used on open file handles.
+ - Fixes RT bug #86963 wherein a call to list_dir() would previously
+ fail under certain circumstances.
- The keywords returned by this method are all upper case strings as of
- version 3.13_9, though the release notes for that version errantly did
- not include this statement. The list of keywords otherwise remains
- unchanged:
- PLAIN TEXT
- BINARY DIRECTORY
- SYMLINK PIPE
- SOCKET BLOCK
- CHARACTER
+ This is a high-priority fix with no security-related implications.
- 3.14_0
- 12/27/02, 5:50 pm
+ See also https://rt.cpan.org/Public/Bug/Display.html?id=86963
- File::Util no longer @ISA Handy::Dandy, and no longer includes it
- as a prerequisite dependency. Added a little more documentation,
- but it has a _long_ way to go as yet.
+4.131591 Fri Jun 7 22:19:05 CDT 2013
- 3.13_9
- 12/23/02, 3:22 pm
+ - POD (documentation) corrections.
- A few small changes; no longer lists Handy::Dandy::TimeTools as a
- prerequisite dependency.
-
- 3.13_8
- 12/22/02, 11:31 pm
+4.131570 Thu Jun 6 23:15:27 CDT 2013
- Method File::Util::file_type() now returns a list instead of a single
- string of concatenated keyword substrings, the file type keywords being:
- plain text
- binary directory
- symlink pipe
- socket block
- character tty
+ - Since Sat Mar 2 01:13:46 CST 2013, there has been an unofficial code
+ freeze in effect, during which time 580 test runs from the CPAN smoke
+ testers have had a 100% complete PASS rate.
- Methods File::Util::load_file() and File::Util::open_handle() both will
- truly guarantee the uniqueness of the underlying file handle which is
- auto-generated, whereas before measures to achieve the uniqueness of
- the file handles were taken, but not verified.
+ - So I'm pleased to announce that I'm releasing this code as-is, under
+ the "STABLE"/"MATURE" designation.
- POD documentation got a big update.
+ - There are important bug fixes since the last STABLE release, particularly
+ in making the File::Util::max_dives() method behave as documented. See
+ also https://rt.cpan.org/Ticket/Display.html?id=85141
- 3.13_7
- 12/6/02, 2:56 pm
- Almost ready for CPAN!
-
- License changed from the GNU LGPL to Perl's own licensing scheme.
-
- Various tweaks to compile-time sequences.
-
- Previously subroutines, SL and NL are now constants. This makes them
- easier to use when importing them to your main program. Instead of
- having to type "print('foo' . NL . NL)", you can type the more intuitive
- "print('foo' . NL x 2)". The same applies for SL, though it's not likely
- you'll be wanting to print out more than one SL character in sequence.
- This shouldn't break previous usage of these exported names.
-
- Small reference material section appended to the general documentation
- file contained in 'docs-basic.txt' (part of this distribution)
-
- 3.13_4
- 11/14/02, 1:22 pm
-
- Got rid of all variables in @EXPORT_OK, namely:
- $OS
- $EBCDIC
- $NL
- $SL
-
- I wanted to export only methods, seeing as exporting variables just isn't
- right, no matter how convenient it might be. There are two new methods,
- and they are both autoloaded, namely:
- File::Util::os()
- File::Util::ebcdic()
-
- These two methods take no arguments, and return only the value of the
- previously EXPORT_OK'ed "$OS" and "$EBCDIC"
-
- Added more thorough testing to distribution tests lineup, and an
- additional set of tests in an automated "empty subclass test" of the
- modules native methods and all those it inherits from its ancestral
- classes.
-
- More flock() related tweaking in private methods that implement
- File::Util's automatic, transparent file locking mechanism.
-
- 3.13_3
- 11/13/02, 9:41 pm
-
- Slightly optimized recursive directory listing features of package method
- File::Util::list_dir() and moved less-used method File::Util::load_dir()
- to AUTOLOAD.
-
- Got rid of stupid method File::Util::EB which was previously
- used for error bracketing around dynamic values quoted in error messages;
- this has nothing to do with file handling -the purpose of this module.
-
- Global vars $AUTOLOAD and $ATL are gone, since moving to the use of Perl's
- native AUTOLOAD extension from the old autoloading mechanism.
-
- Added/removed functionality tests in the distribution installer according
- to these changes.
-
- 3.13_1
- 11/13/02, 1:40 am
-
- Fixed problem that caused File::Util to not recognize its set flock
- usage policy, and flock failthrough rule set when either was manually
- set during runtime. Added more flock tests to distribution test scripts.
-
- 3.13_1
- 11/4/02, 12:28 pm
-
- Further preparations made to ready the module for PAUSE upload.
-
- 3.13_0
- Method 'list_dir()' now recognizes a new option, '--ignore-case'. When
- this option is included among the other arguments you pass in, the list
- of items returned will be sorted alphabetically from A to Z without
- respect to character case.
-
- Accordingly, when the '--ignore-case' option is used the contents of
- a directory that would normally appear ordered like the items in
- Example A would instead appear ordered like the items in the order of
- Example B.
-
- Example A. (default list order of directory contents)
- Changes COPYING MANIFEST Makefile.PL README test.pl
-
-
- Example B. (case insensitive order)
- COPYING Changes Makefile.PL MANIFEST README test.pl
-
- 3.12_9
- 10/27/02, 1:54 pm
- Various places where warnings were surfacing undesirably have been
- corrected. General preparations made to upload File::Util to PAUSE and
- ultimately be included in the CPAN.
-
- 3.12_7
- 10/10/02, 11:56 pm
- Method 'list_dir_a()' no longer suffixes directory items with the
- system path separator by force.
-
- 3.12_6
- 10/4/02, 4:22 am
- Fixed serious problem with flock() wrapper which was previously not
- working at all when global setting '--fatals-as-status' or global
- setting '--fatals-as-warning' were used. An upgrade to the present
- release of File::Util from versions predating this release (3.12_6) is
- seriously recommended!
-
- 3.12_5
- 10/1/02, 7:46 pm
- More performance improvements.
-
- New argument flags recognized by method 'new':
- '--fatals-as-warning' The new File::Util object will CORE::warn()
- about otherwise fatal errors instead of
- failing and exiting the process.
-
- '--fatals-as-status' The new File::Util object will return(undef)
- to method calls that would otherwise cause
- fatal errors.
-
- Method 'write_file' now recognizes the argument flag,
- '--empty-writes-OK', as an alternative means of allowing the
- creation of empty files without reaping a nasty fatal error. Up
- until now, setting $File::Util::empty_writes to a true value was the
- only way to accomplish this.
-
- 3.12_4
- 9/23/02, 2:30 pm
- Fixed 'deep recursion' problem in AUTOLOAD
-
- 3.12_3
- 9/23/02, 1:18 pm
- Added AUTOLOAD and moved lots of methods away into space. They get
- AUTOLOAD-ed when needed, but not compiled as routines in the module.
- This greatly improves compile-time and run-time performance now.
- Got rid of methods 'get()' and 'set()'; they're largely useless.
- Got rid of variable '$File::Util::canhackit'; no longer used.
-
- 3.12_2
- 9/11/02, 12:35 am
- Moved to OOorNO interface design in order to provide both an Object-
- Oriented and a Procedural (non-Object-Oriented) programming style
- interface to File::Util.
-
- 1.10
- Thursday, March 14, 2002, 1:29:55 AM
- Constants are now class attributes independent of the constructor method.
- File::Util objects should always get these constants regardless.
-
- Constants and OS identification extended upon code from CGI.pm v.2.78
- (go Lincoln, it's your birthday, get busy...) as such, File::Util got path
- separator help to better support a wider variety of platforms.
-
- Additionally, constants contributed to a major overhaul of how File::Util
- handles newlines.
-
- 1.09
- Thursday, March 14, 2002, 1:29:55 AM
- Error messages got their own place as predefined key-value pairs in an
- anonymous hash independent of any class methods. eg-they are committed to
- memory at compile time for speedy destruction of intentionally halted
- processes.
-
- 1.07
- Saturday, February 9, 2002, 3:32:57 PM
- new method: File::Util::open_handle. This method lets user pass a
- typeglob reference (eg- *TYPG) and in return the user will get back a new
- file handle which is opened to the filename of their specifications.
-
- 1.06
- Tuesday, February 5, 2002, 9:47:35 AM
- Fixed a bug in File::Util::stamp() which made times during the hour of
- 12:00 PM appear with the 'AM' suffix rather than the correct 'PM suffix.
-
- Added a new format type to File::Util::stamp() called 'file' or 'filename'
- which returns a timestamp suitable for placing into the name of a file
- in order to archive old files or versions of code with a time/date stamp
- embedded into the filename for easy lookup.
-
- 1.05
- Wednesday, December 5, 2001, 1:36:48 AM
- Added a few more methods of the same nature as File::Util::size(). Passing
- in a format keyword argument returns a formatted timestamp. Format
- keywords described in detail within the overview entry for previous
- version 1.02. Now an overview of new methods:
-
- File::Util::created([filename][format])
-
- returns the creation time of the file in seconds since the epoch. The
- value returned is then passed back in the same format as the value
- returned from a call to Perl's built-in function: time()
-
- consequently, the value returned is suitable for feeding to
- localtime, or any private methods and functions expecting the same
- type of input.
-
- As such, a call to this method on a file which was created at:
- Thursday, December 6, 2001, 4:27:57 PM
- ...would return the value: 1007684877
-
- File::Util::last_mod([filename][format])
-
- Returns the last modified time of the file you pass to it in seconds
- since the epoch. Just as with the new created() method described
- above, the value returned comes in the same format as the value
- returned from a call to time(), and is therefore suitable for feeding
- to localtime() or any other private function or method expecting input
- of the same type.
-
- As such, a call to this method on a file which was last modified at:
- Sunday, December 2, 2001, 12:05:21 AM
- ...would return the value: 1007280321
-
- File::Util::last_access([filename][format])
-
- Same as the two previously described methods, only this method returns
- the number of seconds since the epoch to the time when the specified
- file was last accessed.
-
- As such, a call to this method on a file which was last accessed at:
- Thursday, December 6, 2001, 12:00:00 AM
+ - Near future plans are laid out in the TODO documentation file also
+ included with this documentation.
+
+4.130610 Sat Mar 2 01:13:46 CST 2013
+
+ - TRIAL version, much polish on the quality of the distribution itself,
+ including extensive POD checks, fixes in documentation quality, and
+ overall tidiness. Reorganized the test suite so it remains correct to
+ "t" and "xt" test division conventions. Included a list of contributors.
+
+4.130590 Wed Feb 27 21:59:30 CST 2013
+
+ - TRIAL version, probably the final trial before release as a mature distro
+ in the 4.x series (the 3.x series is already "mature" status).
+
+ - This release introduces unicode support via UTF-8 strict. Naturally
+ the test suite and coverage had to be expanded to cover the new feature
+ set. Documentation has also been updated to include explanation of
+ how to make use UTF-8 encoding in File::Util.
+
+ - Minor bug fixes and polish.
+
+4.130560 Mon Feb 25 14:03:44 CST 2013
+
+ - TRIAL version, seventh trial in 4.x series. I am just about confident
+ enough to release this current code as an offical stable release to the
+ CPAN, but first I wanted to include the optimizations in this release.
+
+ - This release represents a vast number of optimizations that greatly
+ increase the performance of recursive calls.
+
+ - This release fixes some windows-specific bugs that have to deal with
+ recursively listing directories from a root volume, such as "C:\" for
+ example.
+
+ - Added performance measurement scripts that allow users to both benchmark
+ and profile File::Util, with Devel::NYTProf being a prerequisite to such
+ activities.
+
+4.130510 Tue Feb 19 18:10:12 CST 2013
+
+ - TRIAL version, sixth trial in 4.x series prior to first official release;
+ we're being very careful.
+
+ - Removed dependency for Exception::Handler and stole/improved code from it
+ so now there's no external dependencies whatsoever.
+
+ - Tests and documentation adjusted to reflect the change
+
+4.130500 Mon Feb 18 19:13:11 CST 2013
+
+ - TRIAL version, fifth trial in 4.x series prior to first official release;
+ we're being very careful.
+
+ - This release features mainly performance optimizations, and many
+ windows-specific bug-fixes for those new optimizations which were caught
+ during thorough testing.
+
+ - This new version features a "max_depth" option for list_dir, which works
+ the same as the -max_depth flag for GNU find.
+
+ - the max_dives() method has been renamed to abort_depth(), with back-compat
+ fully preserved; this is to avoid confusion with the new max_depth
+ option for list_dir()
+
+ - Documentation updated to show examples of the new feature.
+
+ - For operating systems that support it, list_dir() now keeps track of the
+ filesystem inodes it sees while walking directories to detect and avoid
+ filesystem loops. Sadly, Windows does not support the native stat/lstat
+ calls in Perl, and therefore this is feature is silently disabled on
+ any platform where it is detected that the stat/lstat calls don't work.
+
+ - New example script added to examples/ directory and to the Cookbook.
+
+ - Main perldoc manpage for File::Util updated
+
+4.130483 Sat Feb 16 23:07:29 CST 2013
+
+ - TRIAL version, fourth trial in the 4.x series.
+
+ - Tidied up documentation for main man page (perldoc).
+
+ - Increased test coverage, Devel::Cover scores are very much higher
+
+ - Fixed some bugs discovered while expanding test coverage and writing
+ new tests - this is the best way to find and fix bugs.
+
+4.130460 Thu Feb 14 22:24:50 CST 2013
+
+ - TRIAL version. The third trial release of the 4.x series. Removed a
+ few bits of code from the test suite that were causing false failures
+ in CPAN tester results. More importantly, this version includes
+ optimizations to the list_dir() regex pattern matching when recursing
+ through directory trees. Namely, the "pattern gathering" has been
+ memo-ized and stashed into the options passed to recursive calls.
+
+4.130425 Mon Feb 11 15:37:47 CST 2013
+
+ - TRIAL version. Released to CPAN after taking into account some changes
+ recommended by a few of the good folks at perlmonks, namely some method
+ name changes. The old method names still work fine and are completely
+ supported. The changes are shown below:
+ +-----------+-------------+
+ | OLD NAME | NEW NAME |
+ +-----------+-------------+
+ | can_read | is_readable |
+ | can_write | is_writable |
+ | readlimit | read_limit |
+ | isbin | is_bin |
+ +-----------+-------------+
+
+ - Some changes to the POD documentation have been made as well, both to
+ reflect the name changes as well as to clean things up even more in
+ terms of clarity and better formatting.
+
+ - Some test updates were needed to reflect the use of the new method names
+
+4.130420 Sun Feb 10 21:45:05 CST 2013
+
+ - TRIAL version. Released to CPAN for those who may want to test drive
+ it. The enhancements, improvements, feature additions, and bug fixes
+ in this release are far to great to be enumerated here in the changes
+ file. A git repository was set up for File::Util last December, and
+ the commit logs will tell the full story of all changes.
+
+ - The commit log can be read here:
+ https://github.com/tommybutler/file-util/commits/master
+
+ - A summary of new things would include the newer, more modern-style
+ call syntax, user-definable custom error handlers, list_dir()
+ callbacks plus advanced regular expression filtering features, much
+ more comprehensive documentation including a manual and a cookbook,
+ performance optimizations, the ability to enable/disable the
+ verbose diagnostics that have hitherto been the default error
+ mechanism, and much more. The quality of the distribution has also
+ been greatly improved.
+
+ - All new features are covered at length in the documentation, so
+ anything you don't see here will be mentioned and throughly covered
+ there. Full backward-compatibility with the 3.x series feature-set
+ and syntax has been preserved
+
+3.39 Sun Jan 6 15:54:10 CST 2013
+
+ - Significant improvements in test suite, but most importantly
+ eliminated a bug found in make_dir() where absolute paths caused
+ problems on some platforms.
+
+ - Fixed a bug that caused testing to fail on Solaris
+
+3.38 Fri Jan 4 12:26:53 CST 2013
+
+ - Have to abandon AutoLoader. It is simply causing too many problems
+ to continue using it on any level.
+
+4.37 Thu Jan 3 12:58:55 CST 2013
+
+ - Renamed atomize() to atomize_path() before anyone starts to use it;
+ the original name is not ideal and not descriptive of what it does.
+
+3.36 Thu Jan 3 11:38:00 CST 2013
+
+ - breakfix, Dist::Zilla failed to detect long-time prereq
+ Exception::Handler. This unfortunate problem broke v3.33 thru 3.35
+ which were taken down in short order.
+
+3.33 Mon Dec 31 23:37:40 CST 2012
+
+ - Moves everything out of autoloader that was previously in autoloader,
+ with the exception of the assisted error handling. In light of modern
+ computing, the optimizations are so minimal as to be negligible now.
+ There's more benefit to be had by having all methods available
+ at compile time.
+
+ - Documentation updates.
+
+ - Code cleanups. Package cleanup. Preparations to add new features.
+
+ - Working to make the distribution compliant with Fedora and Debian
+ packaging standards. File::Util already has a maintained package for
+ Ubuntu.
+
+3.32 Wed Nov 28 21:42:59 CST 2012
+
+ - Emergency break fix for abs paths on *nix which came about as a
+ regression bug introduced when abs paths were fixed for windows
+ platforms.
+
+3.31 Tue Nov 20 16:33:10 CST 2012
+
+ - Adds new method: File::Util::atomize() which explodes a fully-qualified
+ filename into it's root, path, and filename... which was necessary
+ to squish the long-standing bug in fully-qualified file names on
+ MS Windows... Also, the '--rpattern=^pat$' flag should works recursively
+ for you in File::Util::list_dir(), in order to provide you with patterns
+ that are applied at every level in your file tree, while preserving the
+ current behavior of the '--pattern=^pat$' flag, which is not applied
+ recursively. Another bug bites the dust.
+
+ - Fixes CPAN RT# 46368 and 64775, respectively
+
+ - Lots of code cleanup, and more documentation forthcoming in next release
+ will be here very soon, primarily to document the small additions here
+ and also to clean up the documentation itslef (particularly the code
+ examples which need style-fixes). This is a stable release.
+
+3.30_003 Thu Nov 15 17:59:38 CST 2012
+
+ - Development release. BETA. Do not use for production! This release
+ introduces new code optimizations and extensive cleanup. The previously
+ required module Class::OOorNO has been removed from the prerequisites
+ and any methods that it exported are no longer available for import to
+ your namespace(s). This shouldn't be a problem though, because that
+ module was almost never used at all, and no one ever even knew you
+ could get its methods from File::Util anyway. Onward and upward, we're
+ inching slowly but surely toward 3.31 final.
+
+ - There's been a lot of code refactoring and regex optimization. A lot
+ of planning and work will be going into 3.30, and this is the first
+ release candidate.
+
+3.30_001 Mon Nov 12 18:00:16 CST 2012
+
+ - Development release. BETA. Do not use for production! This release
+ attempts to fix MS Windows-related problems, and introduces bugfixes
+ for CPAN RT# 46368 and 67399. As a result, the test suite has been
+ slightly improved (and will continue to improve).
+
+ - There's been a lot of code refactoring and regex optimization. A lot
+ of planning and work will be going into 3.30, and this is the first
+ release candidate.
+
+2.29 Wed Oct 17 09:38:36 CDT 2012
+
+ - Fixed bug where list_dir() did not continue to recurse if it encountered
+ an error while running with the --fatals-as-warning flag. If running
+ in default mode, it is normal behavior for File::Util to abort execution
+ on error, but when running with --fatals-as-warning flag, such errors
+ should not have caused recursion to fail. (CPAN RT# 52319)
+
+ - Changed the brackets surrounding error messages to "<<" and ">>" so that
+ the glyphs display in most terminals.
+
+ - Modified/updated documentation and test suite to accomodate these new
+ changes.
+
+2.28 Sat Sep 29 17:38:47 CDT 2012
+
+ - Adding a patch to fix breakage under Perl 5.17 (CPAN RT#31013)
+
+ - Fix spelling error in documentation and code comments (CPAN RT# #64854)
+
+2.27 Sat Dec 6 13:10:00 CST 2008
+
+ - Fixed a bug that caused root directories using Micro$oft filesystem
+ notation to be mis-read when using the '--dirs-only' flag for
+ File::Util::list_dir()
+
+3.26 Tue Dec 2 20:07:09 CST 2008
+
+ - Added to test suite in order to avoid errant test failures
+ when flock'ing on solaris. This is a big deal, since the point of
+ File::Util is to be easy, and portable!
+
+ - Added some yet more extra examples in the documentation.
+
+3.25 Mon Dec 1 15:11:20 CST 2008
+
+ - Fixed a bug in File::Util::touch()
+
+ - Added some extra examples and corrected one minor error in the
+ documentation.
+
+3.24 Wed May 23 16:27:20 CDT 2007
+
+ - Added method File::Util::last_changed (get inode change time for a file)
+
+ - Added method File::Util::touch (works like *nix touch command)
+
+ - Both touch and last_changed are autoloaded methods
+
+ - Applied patch from S. Muskiewicz that fixes the File::Util::last_modified
+ method that was using a similar but incorrect "-" file test operator.
+
+3.23 Fri Feb 15 07:34:29 CST 2008
+
+ - No major code changes. Small bug fixes--
+
+ - Corrected syntax on package makefile that causes warnings to be
+ generated in cases of older Perl versions. Also corrected a problem
+ in the documentation where the section "Get the path preceeding a
+ file name" was showing incorrect information.
+
+3.22 Wed May 23 16:27:20 CDT 2007
+
+ - Fixed windows-specific bugs associated with the handling of newlines
+ and directory path separators. Now compatible with Strawberry Perl
+ and once again Active$tate Perl for MSWin*.
+
+3.21 Mon May 21 18:22:11 CDT 2007
+
+ - Fixed solaris-specific bug in test suite causing a simple regular
+ expression to fail. Previous changes up to this point merit a public
+ release, pending the fixing of afforementioned bug, hence this release.
+
+3.20_2 Mon May 21 16:15:23 CDT 2007
+
+ - Fixed small but important incompatibility with some versions of
+ Exception::Handler
+
+3.20_1 Fri May 18 15:42:01 CDT 2007
+
+ - Improved error handling mechanism even more, and created 31 new test
+ scenarios to make sure that any failure events are handled correctly.
+
+ - Fixed some small latent bugs, for example, corrected file handle
+ reference verification error handling--checking for validity of
+ file handle references.
+
+3.19 Wed May 16 18:07:49 CDT 2007
+
+ - Documentation. Documentation. Documentation. Small corrections and
+ several enhancements. More examples.
+
+ - Improved error-handling mechanism by adding cascading logic to prioritize
+ fatality-handling rules of failed calls over the rules of the File::Util
+ object, whether they be defaults or manually set up via File::Util::new()
+
+3.18 Tue Feb 27 15:54:51 CST 2007
+
+ - Finished documentation for ALL methods. Whew! That was a lot of
+ writing. The documentation will continue to evolve.
+
+ - Implemented the --use-sysopen flag for File::Util::open_handle()
+ and thereafter the following extra open modes for it (only valid if
+ the --use-sysopen flag is used):
+ rwcreate
+ rwupdate
+ rwclobber
+ rwappend
+
+ (See the documentation for more details about this new feature).
+
+ - Added new method File::Util::release_open_file() for the purpose
+ of releasing file locks placed on file handles by the
+ File::Util::open_file() method, that is, when file locking is
+ NOT turned off. If file locking is disabled by the user, this new
+ method has no effect.
+
+3.17 2007/02/26
+
+ - Developer's releases (testing); not released to the public.
+
+3.16 Tue Feb 20 14:16:45 CST 2007
+
+ - Fixed problem with method File::Util::make_dir() when used with
+ absolute pathnames (path names starting with "/", for example).
+
+ - Fixed documentation error concerning the File::Util::list_dir method,
+ specifically regarding the "--pattern" option flag.
+
+ - Method File::Util::make_dir() now enforces the policy of failing when
+ asked to create a directory that already exists as a file of any kind.
+ Use the "--if-not-exists" flag if you are counting on the old behavior
+ or if you want to create directories which could possibly exist already.
+
+ - More documentation added.
+
+3.15 Fri Dec 22 14:12:45 CST 2006
+
+ - Fixed broken test suite that was causing `make test` to fail falsely.
+
+ - Revisited documentation, adding a little, and various small improvements.
+
+3.14_8 Thu Dec 14 20:13:03 CST 2006
+
+ - Fixed some error messages to be more clear. Tweaked the
+ File::Util::readlimit() method to provide better error messages if
+ called incorrectly. Modified File::Util::make_dir() to include
+ the --if-not-exists option.
+
+ - More documentation added for various methods whose documentation had
+ yet to be written.
+
+ - Fixed a broken test case in "make test" that was causing it to fail
+ falsely.
+
+ - Releasing this version as an official release and NOT a developer's
+ release only.
+
+3.14_7 Sat Jan 31 13:36:24 CST 2004
+
+ - Changes to method File::Util::flock_rules() to output helpful error
+ message if specification of invalid file locking policy attempted.
+
+ - flock_rules parameter for File::Util::new() constructor method no
+ longer accepted or recognized in the interest of speed and efficiency.
+ If you want to change the default flock rules for the File::Util object,
+ then call File::Util::flock_rules() with your desired ruleset as
+ specified in the documentation for this method.
+
+ - Changed default max_dives number to 1000. (See documentation for the
+ File::Util::max_dives() method.)
+
+ - Much more documentation added for various methods whose documentation
+ had yet to be written.
+
+3.14_6 Mon Sep 22 11:10:46 CDT 2003
+
+ - Changes to methods File::Util::list_dir() and
+ File::Util::escape_filename() increase efficiency and fix some bugs.
+ Both methods retain the same interface and return values in the same
+ manner.
+
+ - Added new method File::Util::return_path() (see documentation).
+
+ - Method File::Util::last_mod changed to File::Util::last_modified for
+ clarity, better readability, and consistency with other similar methods
+ in the File::Util namespace. (eg- File::Util::last_access, etc)
+
+ - Added the following methods to @EXPORT_OK
+ File::Util::return_path()
+ File::Util::created()
+ File::Util::last_access()
+ File::Util::last_modified()
+
+ - Much more documentation added. Test suite revisited to reflect changes
+ to the methods mentioned above.
+
+3.14_2 2003/01/14
+
+ - Much more documentation added. Various methods slightly altered to stay
+ in keeping with the docs and with standard conventions. Test suite
+ revisited somewhat.
+
+3.14_1 2003/01/02
+
+ - Added a substantial amount of new documentation. Spelling errors in
+ documentation files corrected.
+
+ - Previously available method, File::Util::os(), has been dropped from the
+ namespace and is no longer part of the module.
+
+ - Method File::Util::file_type() no longer includes the 'tty' keyword among
+ its list of recognized file types, as the native Perl file test for
+ divining a TTY file can only be used on open file handles.
+
+ - The keywords returned by this method are all upper case strings as of
+ version 3.13_9, though the release notes for that version errantly did
+ not include this statement. The list of keywords otherwise remains
+ unchanged:
+ PLAIN TEXT
+ BINARY DIRECTORY
+ SYMLINK PIPE
+ SOCKET BLOCK
+ CHARACTER
+
+3.14_0 2002/12/27
+
+ - File::Util no longer @ISA Handy::Dandy, and no longer includes it
+ as a prerequisite dependency. Added a little more documentation,
+ but it has a _long_ way to go as yet.
+
+3.13_9 2002/12/23
+
+ - A few small changes; no longer lists Handy::Dandy::TimeTools as a
+ prerequisite dependency.
+
+3.13_8 2002/12/22
+
+ - Method File::Util::file_type() now returns a list instead of a single
+ string of concatenated keyword substrings, the file type keywords being:
+ plain text
+ binary directory
+ symlink pipe
+ socket block
+ character tty
+
+ - Methods File::Util::load_file() and File::Util::open_handle() both will
+ truly guarantee the uniqueness of the underlying file handle which is
+ auto-generated, whereas before measures to achieve the uniqueness of
+ the file handles were taken, but not verified.
+
+ - POD documentation got a big update.
+
+3.13_7 2002/12/6
+
+ - Almost ready for CPAN!
+
+ - License changed from the GNU LGPL to Perl's own licensing scheme.
+
+ - Various tweaks to compile-time sequences.
+
+ - Previously subroutines, SL and NL are now constants. This makes them
+ easier to use when importing them to your main program. Instead of
+ having to type "print('foo' . NL . NL)", you can type the more intuitive
+ "print('foo' . NL x 2)". The same applies for SL, though it's not likely
+ you'll be wanting to print out more than one SL character in sequence.
+ This shouldn't break previous usage of these exported names.
+
+ - Small reference material section appended to the general documentation
+ file contained in 'docs-basic.txt' (part of this distribution)
+
+3.13_4 2002/11/14
+
+ - Got rid of all variables in @EXPORT_OK, namely:
+ $OS
+ $EBCDIC
+ $NL
+ $SL
+
+ - I wanted to export only methods, seeing as exporting variables just isn't
+ right, no matter how convenient it might be. There are two new methods,
+ and they are both autoloaded, namely:
+ File::Util::os()
+ File::Util::ebcdic()
+
+ - These two methods take no arguments, and return only the value of the
+ previously EXPORT_OK'ed "$OS" and "$EBCDIC"
+
+ - Added more thorough testing to distribution tests lineup, and an
+ additional set of tests in an automated "empty subclass test" of the
+ modules native methods and all those it inherits from its ancestral
+ classes.
+
+ - More flock() related tweaking in private methods that implement
+ File::Util's automatic, transparent file locking mechanism.
+
+3.13_3 2002/11/13
+
+ - Slightly optimized recursive directory listing features of package method
+ File::Util::list_dir() and moved less-used method File::Util::load_dir()
+ to AUTOLOAD.
+
+ - Got rid of stupid method File::Util::EB which was previously
+ used for error bracketing around dynamic values quoted in error messages;
+ this has nothing to do with file handling -the purpose of this module.
+
+ - Global vars $AUTOLOAD and $ATL are gone, since moving to the use of Perl's
+ native AUTOLOAD extension from the old autoloading mechanism.
+
+ - Added/removed functionality tests in the distribution installer according
+ to these changes.
+
+3.13_1 2002/11/13
+
+ - Fixed problem that caused File::Util to not recognize its set flock
+ usage policy, and flock failthrough rule set when either was manually
+ set during runtime. Added more flock tests to distribution test scripts.
+
+3.13_1 2002/11/4
+
+ - Further preparations made to ready the module for PAUSE upload.
+
+3.13_0 2002/11/01
+
+ - Method 'list_dir()' now recognizes a new option, '--ignore-case'. When
+ this option is included among the other arguments you pass in, the list
+ of items returned will be sorted alphabetically from A to Z without
+ respect to character case.
+
+ - Accordingly, when the '--ignore-case' option is used the contents of
+ a directory that would normally appear ordered like the items in
+ Example A would instead appear ordered like the items in the order of
+ Example B.
+
+ Example A. (default list order of directory contents)
+ Changes COPYING MANIFEST Makefile.PL README test.pl
+
+
+ Example B. (case insensitive order)
+ COPYING Changes Makefile.PL MANIFEST README test.pl
+
+3.12_9 2002/10/27
+
+ - Various places where warnings were surfacing undesirably have been
+ corrected. General preparations made to upload File::Util to PAUSE and
+ ultimately be included in the CPAN.
+
+3.12_7 2002/10/02
+
+ - Method 'list_dir_a()' no longer suffixes directory items with the
+ system path separator by force.
+
+3.12_6 2002/10/04
+
+ - Fixed serious problem with flock() wrapper which was previously not
+ working at all when global setting '--fatals-as-status' or global
+ setting '--fatals-as-warning' were used. An upgrade to the present
+ release of File::Util from versions predating this release (3.12_6) is
+ seriously recommended!
+
+3.12_5 2002/10/01
+
+ - More performance improvements.
+
+ - New argument flags recognized by method 'new':
+ '--fatals-as-warning' The new File::Util object will CORE::warn()
+ about otherwise fatal errors instead of
+ failing and exiting the process.
+
+ '--fatals-as-status' The new File::Util object will return(undef)
+ to method calls that would otherwise cause
+ fatal errors.
+
+ - Method 'write_file' now recognizes the argument flag,
+ '--empty-writes-OK', as an alternative means of allowing the
+ creation of empty files without reaping a nasty fatal error. Up
+ until now, setting $File::Util::empty_writes to a true value was the
+ only way to accomplish this.
+
+3.12_4 2002/09/23
+
+ - Fixed 'deep recursion' problem in AUTOLOAD
+
+3.12_3 2002/09/23
+
+ - Added AUTOLOAD and moved lots of methods away into space. They get
+ AUTOLOAD-ed when needed, but not compiled as routines in the module.
+ This greatly improves compile-time and run-time performance now.
+
+ - Got rid of methods 'get()' and 'set()'; they're largely useless.
+
+ - Got rid of variable '$File::Util::canhackit'; no longer used.
+
+3.12_2 2002/09/11
+
+ - Moved to OOorNO interface design in order to provide both an Object-
+ Oriented and a Procedural (non-Object-Oriented) programming style
+ interface to File::Util.
+
+1.10 2002/03/14
+
+ - Constants are now class attributes independent of the constructor method.
+ File::Util objects should always get these constants regardless.
+
+ - Constants and OS identification extended upon code from CGI.pm v.2.78
+ (go Lincoln, it's your birthday, get busy...) as such, File::Util got path
+ separator help to better support a wider variety of platforms.
+
+ - Additionally, constants contributed to a major overhaul of how File::Util
+ handles newlines.
+
+1.09 2002/03/14
+
+ - Error messages got their own place as predefined key-value pairs in an
+ anonymous hash independent of any class methods. eg-they are committed to
+ memory at compile time for speedy destruction of intentionally halted
+ processes.
+
+1.07 2002/02/09
+
+ - new method: File::Util::open_handle. This method lets user pass a
+ typeglob reference (eg- *TYPG) and in return the user will get back a new
+ file handle which is opened to the filename of their specifications.
+
+1.06 2002/02/05
+
+ - Fixed a bug in File::Util::stamp() which made times during the hour of
+ 12:00 PM appear with the 'AM' suffix rather than the correct 'PM suffix.
+
+ - Added a new format type to File::Util::stamp() called 'file' or 'filename'
+ which returns a timestamp suitable for placing into the name of a file
+ in order to archive old files or versions of code with a time/date stamp
+ embedded into the filename for easy lookup.
+
+1.05 2001/12/05
+
+ - Added a few more methods of the same nature as File::Util::size(). Passing
+ in a format keyword argument returns a formatted timestamp. Format
+ keywords described in detail within the overview entry for previous
+ version 1.02. Now an overview of new methods:
+
+ - File::Util::created([filename][format])
+
+ returns the creation time of the file in seconds since the epoch. The
+ value returned is then passed back in the same format as the value
+ returned from a call to Perl's built-in function: time()
+
+ consequently, the value returned is suitable for feeding to
+ localtime, or any private methods and functions expecting the same
+ type of input.
+
+ As such, a call to this method on a file which was created at:
+ Thursday, December 6, 2001, 4:27:57 PM
+ ...would return the value: 1007684877
+
+ - File::Util::last_mod([filename][format])
+
+ Returns the last modified time of the file you pass to it in seconds
+ since the epoch. Just as with the new created() method described
+ above, the value returned comes in the same format as the value
+ returned from a call to time(), and is therefore suitable for feeding
+ to localtime() or any other private function or method expecting input
+ of the same type.
+
+ As such, a call to this method on a file which was last modified at:
+ Sunday, December 2, 2001, 12:05:21 AM
+ ...would return the value: 1007280321
+
+ - File::Util::last_access([filename][format])
+
+ Same as the two previously described methods, only this method returns
+ the number of seconds since the epoch to the time when the specified
+ file was last accessed.
+
+ As such, a call to this method on a file which was last accessed at:
+ Thursday, December 6, 2001, 12:00:00 AM
...would return the value: 1007625600
- 1.04
- Wednesday, December 5, 2001, 1:36:48 AM
- Fixed some of the checks on files for existence, added the
- File::Util::file_size([filename]) method which returns the size of the
- filename you pass as the only argument.
+1.04 2001/12/05
+
+ - Fixed some of the checks on files for existence, added the
+ File::Util::file_size([filename]) method which returns the size of the
+ filename you pass as the only argument.
- 1.03
- Thursday, November 29, 2001, 12:54:07 AM
- Re-visited the time/date methods to work out a bug which was causing file
- creation and last-modified times to be returned with incorrect values.
+1.03 2001/11/29
- 1.02
- Tuesday, November 27, 2001, 2:23:55 PM
- More directory listing options. Method File::Util::stamp() now takes
- optional format keyword argument; it lets you choose between different
- output formats for the returned time stamp. Format keywords are thus:
+ - Re-visited the time/date methods to work out a bug which was causing file
+ creation and last-modified times to be returned with incorrect values.
+
+1.02 2001/11/27
+
+ - More directory listing options. Method File::Util::stamp() now takes
+ optional format keyword argument; it lets you choose between different
+ output formats for the returned time stamp. Format keywords are thus:
--short 5/15/02, 4:22 pm
--formal Saturday, June 15, 2002, 4:22 pm
@@ -501,14 +777,13 @@ Revision history for Perl extension File::Util.pm
--hour 16 (0 - 24)
--second 43
- 1.01
- Wednesday, November 21, 2001, 4:00:00 PM
- All methods now include very detailed error messages and a stack trace
- to help quickly track down mistakes. You can fix mistakes now without
- having to decipher some cryptic error message which no one can understand
- and whose origin one can guess :o(
+1.01 2001/11/21
+
+ - All methods now include very detailed error messages and a stack trace
+ to help quickly track down mistakes. You can fix mistakes now without
+ having to decipher some cryptic error message which no one can understand
+ and whose origin one can guess :o(
- 1.00
- Sunday, September 23, 2001 4:18:30 PM
- Initial release of File::Util.pm
+1.00 2001/9/23
+ - Initial release of File::Util.pm
@@ -0,0 +1,8 @@
+INSTALLATION
+
+To install this module, run the following commands:
+
+ perl Build.PL
+ perl ./Build
+ perl ./Build test
+ sudo perl ./Build install
@@ -0,0 +1,379 @@
+This software is copyright (c) 2013 by Tommy Butler.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+Terms of the Perl programming language system itself
+
+a) the GNU General Public License as published by the Free
+ Software Foundation; either version 1, or (at your option) any
+ later version, or
+b) the "Artistic License"
+
+--- The GNU General Public License, Version 1, February 1989 ---
+
+This software is Copyright (c) 2013 by Tommy Butler.
+
+This is free software, licensed under:
+
+ The GNU General Public License, Version 1, February 1989
+
+ GNU GENERAL PUBLIC LICENSE
+ Version 1, February 1989
+
+ Copyright (C) 1989 Free Software Foundation, Inc.
+ 51 Franklin St, Suite 500, Boston, MA 02110-1335 USA
+
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+ Preamble
+
+ The license agreements of most software companies try to keep users
+at the mercy of those companies. By contrast, our General Public
+License is intended to guarantee your freedom to share and change free
+software--to make sure the software is free for all its users. The
+General Public License applies to the Free Software Foundation's
+software and to any other program whose authors commit to using it.
+You can use it for your programs, too.
+
+ When we speak of free software, we are referring to freedom, not
+price. Specifically, the General Public License is designed to make
+sure that you have the freedom to give away or sell copies of free
+software, that you receive source code or can get it if you want it,
+that you can change the software or use pieces of it in new free
+programs; and that you know you can do these things.
+
+ To protect your rights, we need to make restrictions that forbid
+anyone to deny you these rights or to ask you to surrender the rights.
+These restrictions translate to certain responsibilities for you if you
+distribute copies of the software, or if you modify it.
+
+ For example, if you distribute copies of a such a program, whether
+gratis or for a fee, you must give the recipients all the rights that
+you have. You must make sure that they, too, receive or can get the
+source code. And you must tell them their rights.
+
+ We protect your rights with two steps: (1) copyright the software, and
+(2) offer you this license which gives you legal permission to copy,
+distribute and/or modify the software.
+
+ Also, for each author's protection and ours, we want to make certain
+that everyone understands that there is no warranty for this free
+software. If the software is modified by someone else and passed on, we
+want its recipients to know that what they have is not the original, so
+that any problems introduced by others will not reflect on the original
+authors' reputations.
+
+ The precise terms and conditions for copying, distribution and
+modification follow.
+
+ GNU GENERAL PUBLIC LICENSE
+ TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
+
+ 0. This License Agreement applies to any program or other work which
+contains a notice placed by the copyright holder saying it may be
+distributed under the terms of this General Public License. The
+"Program", below, refers to any such program or work, and a "work based
+on the Program" means either the Program or any work containing the
+Program or a portion of it, either verbatim or with modifications. Each
+licensee is addressed as "you".
+
+ 1. You may copy and distribute verbatim copies of the Program's source
+code as you receive it, in any medium, provided that you conspicuously and
+appropriately publish on each copy an appropriate copyright notice and
+disclaimer of warranty; keep intact all the notices that refer to this
+General Public License and to the absence of any warranty; and give any
+other recipients of the Program a copy of this General Public License
+along with the Program. You may charge a fee for the physical act of
+transferring a copy.
+
+ 2. You may modify your copy or copies of the Program or any portion of
+it, and copy and distribute such modifications under the terms of Paragraph
+1 above, provided that you also do the following:
+
+ a) cause the modified files to carry prominent notices stating that
+ you changed the files and the date of any change; and
+
+ b) cause the whole of any work that you distribute or publish, that
+ in whole or in part contains the Program or any part thereof, either
+ with or without modifications, to be licensed at no charge to all
+ third parties under the terms of this General Public License (except
+ that you may choose to grant warranty protection to some or all
+ third parties, at your option).
+
+ c) If the modified program normally reads commands interactively when
+ run, you must cause it, when started running for such interactive use
+ in the simplest and most usual way, to print or display an
+ announcement including an appropriate copyright notice and a notice
+ that there is no warranty (or else, saying that you provide a
+ warranty) and that users may redistribute the program under these
+ conditions, and telling the user how to view a copy of this General
+ Public License.
+
+ d) You may charge a fee for the physical act of transferring a
+ copy, and you may at your option offer warranty protection in
+ exchange for a fee.
+
+Mere aggregation of another independent work with the Program (or its
+derivative) on a volume of a storage or distribution medium does not bring
+the other work under the scope of these terms.
+
+ 3. You may copy and distribute the Program (or a portion or derivative of
+it, under Paragraph 2) in object code or executable form under the terms of
+Paragraphs 1 and 2 above provided that you also do one of the following:
+
+ a) accompany it with the complete corresponding machine-readable
+ source code, which must be distributed under the terms of
+ Paragraphs 1 and 2 above; or,
+
+ b) accompany it with a written offer, valid for at least three
+ years, to give any third party free (except for a nominal charge
+ for the cost of distribution) a complete machine-readable copy of the
+ corresponding source code, to be distributed under the terms of
+ Paragraphs 1 and 2 above; or,
+
+ c) accompany it with the information you received as to where the
+ corresponding source code may be obtained. (This alternative is
+ allowed only for noncommercial distribution and only if you
+ received the program in object code or executable form alone.)
+
+Source code for a work means the preferred form of the work for making
+modifications to it. For an executable file, complete source code means
+all the source code for all modules it contains; but, as a special
+exception, it need not include source code for modules which are standard
+libraries that accompany the operating system on which the executable
+file runs, or for standard header files or definitions files that
+accompany that operating system.
+
+ 4. You may not copy, modify, sublicense, distribute or transfer the
+Program except as expressly provided under this General Public License.
+Any attempt otherwise to copy, modify, sublicense, distribute or transfer
+the Program is void, and will automatically terminate your rights to use
+the Program under this License. However, parties who have received
+copies, or rights to use copies, from you under this General Public
+License will not have their licenses terminated so long as such parties
+remain in full compliance.
+
+ 5. By copying, distributing or modifying the Program (or any work based
+on the Program) you indicate your acceptance of this license to do so,
+and all its terms and conditions.
+
+ 6. Each time you redistribute the Program (or any work based on the
+Program), the recipient automatically receives a license from the original
+licensor to copy, distribute or modify the Program subject to these
+terms and conditions. You may not impose any further restrictions on the
+recipients' exercise of the rights granted herein.
+
+ 7. The Free Software Foundation may publish revised and/or new versions
+of the General Public License from time to time. Such new versions will
+be similar in spirit to the present version, but may differ in detail to
+address new problems or concerns.
+
+Each version is given a distinguishing version number. If the Program
+specifies a version number of the license which applies to it and "any
+later version", you have the option of following the terms and conditions
+either of that version or of any later version published by the Free
+Software Foundation. If the Program does not specify a version number of
+the license, you may choose any version ever published by the Free Software
+Foundation.
+
+ 8. If you wish to incorporate parts of the Program into other free
+programs whose distribution conditions are different, write to the author
+to ask for permission. For software which is copyrighted by the Free
+Software Foundation, write to the Free Software Foundation; we sometimes
+make exceptions for this. Our decision will be guided by the two goals
+of preserving the free status of all derivatives of our free software and
+of promoting the sharing and reuse of software generally.
+
+ NO WARRANTY
+
+ 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
+FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
+OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
+PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED
+OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS
+TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE
+PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
+REPAIR OR CORRECTION.
+
+ 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
+REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
+INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING
+OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED
+TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY
+YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER
+PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
+POSSIBILITY OF SUCH DAMAGES.
+
+ END OF TERMS AND CONDITIONS
+
+ Appendix: How to Apply These Terms to Your New Programs
+
+ If you develop a new program, and you want it to be of the greatest
+possible use to humanity, the best way to achieve this is to make it
+free software which everyone can redistribute and change under these
+terms.
+
+ To do so, attach the following notices to the program. It is safest to
+attach them to the start of each source file to most effectively convey
+the exclusion of warranty; and each file should have at least the
+"copyright" line and a pointer to where the full notice is found.
+
+ <one line to give the program's name and a brief idea of what it does.>
+ Copyright (C) 19yy <name of author>
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 1, or (at your option)
+ any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston MA 02110-1301 USA
+
+
+Also add information on how to contact you by electronic and paper mail.
+
+If the program is interactive, make it output a short notice like this
+when it starts in an interactive mode:
+
+ Gnomovision version 69, Copyright (C) 19xx name of author
+ Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
+ This is free software, and you are welcome to redistribute it
+ under certain conditions; type `show c' for details.
+
+The hypothetical commands `show w' and `show c' should show the
+appropriate parts of the General Public License. Of course, the
+commands you use may be called something other than `show w' and `show
+c'; they could even be mouse-clicks or menu items--whatever suits your
+program.
+
+You should also get your employer (if you work as a programmer) or your
+school, if any, to sign a "copyright disclaimer" for the program, if
+necessary. Here a sample; alter the names:
+
+ Yoyodyne, Inc., hereby disclaims all copyright interest in the
+ program `Gnomovision' (a program to direct compilers to make passes
+ at assemblers) written by James Hacker.
+
+ <signature of Ty Coon>, 1 April 1989
+ Ty Coon, President of Vice
+
+That's all there is to it!
+
+
+--- The Artistic License 1.0 ---
+
+This software is Copyright (c) 2013 by Tommy Butler.
+
+This is free software, licensed under:
+
+ The Artistic License 1.0
+
+The Artistic License
+
+Preamble
+
+The intent of this document is to state the conditions under which a Package
+may be copied, such that the Copyright Holder maintains some semblance of
+artistic control over the development of the package, while giving the users of
+the package the right to use and distribute the Package in a more-or-less
+customary fashion, plus the right to make reasonable modifications.
+
+Definitions:
+
+ - "Package" refers to the collection of files distributed by the Copyright
+ Holder, and derivatives of that collection of files created through
+ textual modification.
+ - "Standard Version" refers to such a Package if it has not been modified,
+ or has been modified in accordance with the wishes of the Copyright
+ Holder.
+ - "Copyright Holder" is whoever is named in the copyright or copyrights for
+ the package.
+ - "You" is you, if you're thinking about copying or distributing this Package.
+ - "Reasonable copying fee" is whatever you can justify on the basis of media
+ cost, duplication charges, time of people involved, and so on. (You will
+ not be required to justify it to the Copyright Holder, but only to the
+ computing community at large as a market that must bear the fee.)
+ - "Freely Available" means that no fee is charged for the item itself, though
+ there may be fees involved in handling the item. It also means that
+ recipients of the item may redistribute it under the same conditions they
+ received it.
+
+1. You may make and give away verbatim copies of the source form of the
+Standard Version of this Package without restriction, provided that you
+duplicate all of the original copyright notices and associated disclaimers.
+
+2. You may apply bug fixes, portability fixes and other modifications derived
+from the Public Domain or from the Copyright Holder. A Package modified in such
+a way shall still be considered the Standard Version.
+
+3. You may otherwise modify your copy of this Package in any way, provided that
+you insert a prominent notice in each changed file stating how and when you
+changed that file, and provided that you do at least ONE of the following:
+
+ a) place your modifications in the Public Domain or otherwise make them
+ Freely Available, such as by posting said modifications to Usenet or an
+ equivalent medium, or placing the modifications on a major archive site
+ such as ftp.uu.net, or by allowing the Copyright Holder to include your
+ modifications in the Standard Version of the Package.
+
+ b) use the modified Package only within your corporation or organization.
+
+ c) rename any non-standard executables so the names do not conflict with
+ standard executables, which must also be provided, and provide a separate
+ manual page for each non-standard executable that clearly documents how it
+ differs from the Standard Version.
+
+ d) make other distribution arrangements with the Copyright Holder.
+
+4. You may distribute the programs of this Package in object code or executable
+form, provided that you do at least ONE of the following:
+
+ a) distribute a Standard Version of the executables and library files,
+ together with instructions (in the manual page or equivalent) on where to
+ get the Standard Version.
+
+ b) accompany the distribution with the machine-readable source of the Package
+ with your modifications.
+
+ c) accompany any non-standard executables with their corresponding Standard
+ Version executables, giving the non-standard executables non-standard
+ names, and clearly documenting the differences in manual pages (or
+ equivalent), together with instructions on where to get the Standard
+ Version.
+
+ d) make other distribution arrangements with the Copyright Holder.
+
+5. You may charge a reasonable copying fee for any distribution of this
+Package. You may charge any fee you choose for support of this Package. You
+may not charge a fee for this Package itself. However, you may distribute this
+Package in aggregate with other (possibly commercial) programs as part of a
+larger (possibly commercial) software distribution provided that you do not
+advertise this Package as a product of your own.
+
+6. The scripts and library files supplied as input to or produced as output
+from the programs of this Package do not automatically fall under the copyright
+of this Package, but belong to whomever generated them, and may be sold
+commercially, and may be aggregated with this Package.
+
+7. C or perl subroutines supplied by you and linked into this Package shall not
+be considered part of this Package.
+
+8. The name of the Copyright Holder may not be used to endorse or promote
+products derived from this software without specific prior written permission.
+
+9. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
+WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
+MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
+
+The End
+
@@ -1,10 +1,52 @@
+AUTHORS
+Build.PL
COPYING
Changes
+INSTALL
+LICENSE
MANIFEST
+MANIFEST.SKIP
+META.json
+META.yml
Makefile.PL
+NEWS
README
-Util.pm
-Util.pod
+SIGNATURE
+TODO
+dist.ini
+examples/batch_file_rename.pl
+examples/batch_search_and_replace.pl
+examples/get_an_open_file_handle.pl
+examples/increment_a_counter_file.pl
+examples/list_the_contents_of_a_directory.pl
+examples/list_the_contents_of_a_directory_recursively.pl
+examples/load_a_file_into_a_variable.pl
+examples/make_a_new_directory.pl
+examples/pretty_print_a_directory.pl
+examples/pretty_print_a_directory_using_as_tree.pl
+examples/pretty_print_a_directory_using_callbacks_fancy.pl
+examples/pretty_print_a_directory_using_callbacks_simple.pl
+examples/recursively_remove_a_directory_and_its_contents.pl
+examples/retry_open_handle.pl
+examples/wrap_the_lines_in_a_file.pl
+examples/write_or_append_to_a_file.pl
+lib/File/Util.pm
+lib/File/Util/Cookbook.pod
+lib/File/Util/Definitions.pm
+lib/File/Util/Exception.pm
+lib/File/Util/Exception/Diagnostic.pm
+lib/File/Util/Exception/Standard.pm
+lib/File/Util/Interface/Classic.pm
+lib/File/Util/Interface/Modern.pm
+lib/File/Util/Manual.pod
+lib/File/Util/Manual/Examples.pod
+performance/bench_listdir.pl
+performance/bench_load_time.pl
+performance/profile_listdir.pl
+performance/profile_listdir_vs_file-find-rule.pl
+perlcritic.rc
+t/00-compile.t
+t/000-report-versions-tiny.t
t/001_canuseit.t
t/002_isa.t
t/003_can.t
@@ -14,7 +56,42 @@ t/006_io.t
t/007_flock.t
t/008_export_ok.t
t/009_empty_subclass.t
-t/010_diesnice.t
+t/010_unicode.t
+t/011_abspaths.t
+t/012_atomize_path.t
+t/013_interface_classic.t
+t/014_interface_modern.t
+t/015_destroy.t
+t/016_new.t
+t/017_make_dir_list_dir.t
+t/018_list_dir_advancedmatch.t
+t/019_load_dir.t
+t/020_write_file.t
t/bin
t/txt
-META.yml Module meta-data (added by MakeMaker)
+xt/author/critic.t
+xt/author/pod-spell.t
+xt/release/cpan-changes.t
+xt/release/diesnice-fatalities.t
+xt/release/diesnice-messages.t
+xt/release/dist-manifest.t
+xt/release/dist-portable.t
+xt/release/distmeta.t
+xt/release/kwalitee.t
+xt/release/localbrew-perl-5.10.1.t
+xt/release/localbrew-perl-5.12.5.t
+xt/release/localbrew-perl-5.14.4.t
+xt/release/localbrew-perl-5.16.3.t
+xt/release/localbrew-perl-5.17.10.t
+xt/release/localbrew-perl-5.18.0.t
+xt/release/localbrew-perl-5.8.9.t
+xt/release/meta-json.t
+xt/release/mojibake.t
+xt/release/no-tabs.t
+xt/release/onfail.t
+xt/release/open_handle.t
+xt/release/pod-coverage.t
+xt/release/pod-syntax.t
+xt/release/synopsis.t
+xt/release/test-version.t
+xt/release/unused-vars.t
@@ -0,0 +1,20 @@
+^.*.swp
+^.*.swo
+^.*~
+^\.build/
+^\_build/
+^Build$
+^Makefile$
+^blib/
+^pm_to_blib/
+pm_to_blib
+^MYMETA.*
+^misc/
+^File-Util-\d+.*/
+^File-Util-\d+.*gz
+^.*vimsess$
+^cover_db/
+^.*CPANTS.txt$
+pod2htm*
+nytprof*
+^devlib/
@@ -0,0 +1,450 @@
+{
+ "abstract" : "Easy, versatile, portable file handling",
+ "author" : [
+ "Tommy Butler"
+ ],
+ "dynamic_config" : 0,
+ "generated_by" : "Dist::Zilla version 4.300034, CPAN::Meta::Converter version 2.120921",
+ "license" : [
+ "perl_5"
+ ],
+ "meta-spec" : {
+ "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
+ "version" : "2"
+ },
+ "name" : "File-Util",
+ "prereqs" : {
+ "build" : {
+ "requires" : {
+ "Module::Build" : "0.3601"
+ }
+ },
+ "configure" : {
+ "requires" : {
+ "ExtUtils::MakeMaker" : "6.30",
+ "Module::Build" : "0.3601"
+ }
+ },
+ "develop" : {
+ "requires" : {
+ "Devel::Cover" : "0",
+ "Dist::Zilla" : "0",
+ "Perl::Critic" : "0",
+ "Perl::Critic::Lax" : "0",
+ "Pod::Coverage::TrustPod" : "0",
+ "Test::CPAN::Changes" : "0.19",
+ "Test::CPAN::Meta" : "0",
+ "Test::Fatal" : "0",
+ "Test::Pod" : "1.41",
+ "Test::Pod::Coverage" : "1.08",
+ "version" : "0.9901"
+ }
+ },
+ "runtime" : {
+ "recommends" : {
+ "Unicode::UTF8" : "0.58"
+ },
+ "requires" : {
+ "Config" : "0",
+ "Exporter" : "0",
+ "Fcntl" : "0",
+ "Scalar::Util" : "0",
+ "constant" : "0",
+ "perl" : "5.008001",
+ "strict" : "0",
+ "subs" : "0",
+ "vars" : "0",
+ "warnings" : "0"
+ }
+ },
+ "test" : {
+ "requires" : {
+ "AutoLoader" : "0",
+ "Config" : "0",
+ "Cwd" : "0",
+ "Exporter" : "0",
+ "ExtUtils::MakeMaker" : "0",
+ "Fcntl" : "0",
+ "File::Find" : "0",
+ "File::Temp" : "0",
+ "Module::Build" : "0",
+ "Scalar::Util" : "0",
+ "Test" : "0",
+ "Test::More" : "0.88",
+ "Test::NoWarnings" : "0",
+ "utf8" : "0"
+ }
+ }
+ },
+ "provides" : {
+ "File::Util" : {
+ "file" : "lib/File/Util.pm",
+ "version" : "4.132140"
+ },
+ "File::Util::Cookbook" : {
+ "file" : "lib/File/Util/Cookbook.pod",
+ "version" : "4.132140"
+ },
+ "File::Util::Definitions" : {
+ "file" : "lib/File/Util/Definitions.pm",
+ "version" : "4.132140"
+ },
+ "File::Util::Exception" : {
+ "file" : "lib/File/Util/Exception.pm",
+ "version" : "4.132140"
+ },
+ "File::Util::Exception::Diagnostic" : {
+ "file" : "lib/File/Util/Exception/Diagnostic.pm",
+ "version" : "4.132140"
+ },
+ "File::Util::Exception::Standard" : {
+ "file" : "lib/File/Util/Exception/Standard.pm",
+ "version" : "4.132140"
+ },
+ "File::Util::Interface::Classic" : {
+ "file" : "lib/File/Util/Interface/Classic.pm",
+ "version" : "4.132140"
+ },
+ "File::Util::Interface::Modern" : {
+ "file" : "lib/File/Util/Interface/Modern.pm",
+ "version" : "4.132140"
+ },
+ "File::Util::Manual" : {
+ "file" : "lib/File/Util/Manual.pod",
+ "version" : "4.132140"
+ },
+ "File::Util::Manual::Examples" : {
+ "file" : "lib/File/Util/Manual/Examples.pod",
+ "version" : "4.132140"
+ }
+ },
+ "release_status" : "stable",
+ "resources" : {
+ "bugtracker" : {
+ "mailto" : "bug-File-Util@rt.cpan.org",
+ "web" : "https://rt.cpan.org/Dist/Display.html?Name=File%3A%3AUtil"
+ },
+ "homepage" : "https://github.com/tommybutler/file-util/wiki",
+ "repository" : {
+ "type" : "git",
+ "url" : "git://github.com/tommybutler/file-util.git",
+ "web" : "https://github.com/tommybutler/file-util"
+ }
+ },
+ "version" : "4.132140",
+ "x_Dist_Zilla" : {
+ "perl" : {
+ "version" : "5.017010"
+ },
+ "plugins" : [
+ {
+ "class" : "Dist::Zilla::Plugin::Meta::Contributors",
+ "name" : "Meta::Contributors",
+ "version" : "0.001"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::GatherDir",
+ "name" : "@Filter/GatherDir",
+ "version" : "4.300034"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::PruneCruft",
+ "name" : "@Filter/PruneCruft",
+ "version" : "4.300034"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::ManifestSkip",
+ "name" : "@Filter/ManifestSkip",
+ "version" : "4.300034"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::MetaYAML",
+ "name" : "@Filter/MetaYAML",
+ "version" : "4.300034"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::License",
+ "name" : "@Filter/License",
+ "version" : "4.300034"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::Readme",
+ "name" : "@Filter/Readme",
+ "version" : "4.300034"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::ExecDir",
+ "name" : "@Filter/ExecDir",
+ "version" : "4.300034"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::ShareDir",
+ "name" : "@Filter/ShareDir",
+ "version" : "4.300034"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::MakeMaker",
+ "name" : "@Filter/MakeMaker",
+ "version" : "4.300034"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::Manifest",
+ "name" : "@Filter/Manifest",
+ "version" : "4.300034"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::TestRelease",
+ "name" : "@Filter/TestRelease",
+ "version" : "4.300034"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::ConfirmRelease",
+ "name" : "@Filter/ConfirmRelease",
+ "version" : "4.300034"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::UploadToCPAN",
+ "name" : "@Filter/UploadToCPAN",
+ "version" : "4.300034"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::RunExtraTests",
+ "name" : "RunExtraTests",
+ "version" : "0.011"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::ModuleBuild",
+ "name" : "ModuleBuild",
+ "version" : "4.300034"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::AutoVersion",
+ "name" : "AutoVersion",
+ "version" : "4.300034"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::PkgVersion",
+ "name" : "PkgVersion",
+ "version" : "4.300034"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::PodVersion",
+ "name" : "PodVersion",
+ "version" : "4.300034"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::MetaProvides::Package",
+ "name" : "MetaProvides::Package",
+ "version" : "1.14000002"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::MinimumPerl",
+ "name" : "MinimumPerl",
+ "version" : "1.003"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::MetaConfig",
+ "name" : "MetaConfig",
+ "version" : "4.300034"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::MetaJSON",
+ "name" : "MetaJSON",
+ "version" : "4.300034"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::MetaResources",
+ "name" : "MetaResources",
+ "version" : "4.300034"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::ReportVersions::Tiny",
+ "name" : "ReportVersions::Tiny",
+ "version" : "1.08"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::Test::LocalBrew",
+ "name" : "Test::LocalBrew",
+ "version" : "0.05"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::PodSyntaxTests",
+ "name" : "@TestingMania/PodSyntaxTests",
+ "version" : "4.300034"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::NoTabsTests",
+ "name" : "@TestingMania/NoTabsTests",
+ "version" : "0.01"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::Test::CPAN::Changes",
+ "name" : "@TestingMania/Test::CPAN::Changes",
+ "version" : "0.008"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::MetaTests",
+ "name" : "@TestingMania/MetaTests",
+ "version" : "4.300034"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::Test::Compile",
+ "name" : "@TestingMania/Test::Compile",
+ "version" : "2.002"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::Test::Version",
+ "name" : "@TestingMania/Test::Version",
+ "version" : "0.002004"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::Test::Perl::Critic",
+ "name" : "@TestingMania/Test::Perl::Critic",
+ "version" : "2.112410"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::Test::UnusedVars",
+ "name" : "@TestingMania/Test::UnusedVars",
+ "version" : "2.000004"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::MojibakeTests",
+ "name" : "@TestingMania/MojibakeTests",
+ "version" : "0.5"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::Test::DistManifest",
+ "name" : "@TestingMania/Test::DistManifest",
+ "version" : "2.000003"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::Test::CPAN::Meta::JSON",
+ "name" : "@TestingMania/Test::CPAN::Meta::JSON",
+ "version" : "0.003"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::Test::Synopsis",
+ "name" : "@TestingMania/Test::Synopsis",
+ "version" : "2.000003"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::Test::Kwalitee",
+ "name" : "@TestingMania/Test::Kwalitee",
+ "version" : "2.03"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::PodCoverageTests",
+ "name" : "@TestingMania/PodCoverageTests",
+ "version" : "4.300034"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::Test::PodSpelling",
+ "name" : "Test::PodSpelling",
+ "version" : "2.004004"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::CheckChangesHasContent",
+ "name" : "CheckChangesHasContent",
+ "version" : "0.006"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::TestRelease",
+ "name" : "TestRelease",
+ "version" : "4.300034"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::ConfirmRelease",
+ "name" : "ConfirmRelease",
+ "version" : "4.300034"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::Signature",
+ "name" : "Signature",
+ "version" : "1.100930"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::AutoPrereqs",
+ "name" : "AutoPrereqs",
+ "version" : "4.300034"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::Prereqs",
+ "config" : {
+ "Dist::Zilla::Plugin::Prereqs" : {
+ "phase" : "test",
+ "type" : "requires"
+ }
+ },
+ "name" : "TestRequires",
+ "version" : "4.300034"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::Prereqs",
+ "config" : {
+ "Dist::Zilla::Plugin::Prereqs" : {
+ "phase" : "runtime",
+ "type" : "recommends"
+ }
+ },
+ "name" : "Recommends",
+ "version" : "4.300034"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::Prereqs",
+ "config" : {
+ "Dist::Zilla::Plugin::Prereqs" : {
+ "phase" : "develop",
+ "type" : "requires"
+ }
+ },
+ "name" : "DevelopRequires",
+ "version" : "4.300034"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::FinderCode",
+ "name" : ":InstallModules",
+ "version" : "4.300034"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::FinderCode",
+ "name" : ":IncModules",
+ "version" : "4.300034"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::FinderCode",
+ "name" : ":TestFiles",
+ "version" : "4.300034"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::FinderCode",
+ "name" : ":ExecFiles",
+ "version" : "4.300034"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::FinderCode",
+ "name" : ":ShareFiles",
+ "version" : "4.300034"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::FinderCode",
+ "name" : ":MainModule",
+ "version" : "4.300034"
+ }
+ ],
+ "zilla" : {
+ "class" : "Dist::Zilla::Dist::Builder",
+ "config" : {
+ "is_trial" : "0"
+ },
+ "version" : "4.300034"
+ }
+ },
+ "x_contributors" : [
+ "John Fields <jfields.cpan.org@spammenot.com>",
+ "Ricardo SIGNES <rjbs@cpan.org>",
+ "Matt S Trout <perl-stuff@trout.me.uk>",
+ "Nicholas Perez <nperez@cpan.org>",
+ "David Golden <dagolden@cpan.org>"
+ ]
+}
+
@@ -1,12 +1,325 @@
-# http://module-build.sourceforge.net/META-spec.html
-#XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX#
-name: File-Util
-version: 3.27
-version_from: Util.pm
-installdirs: site
+---
+abstract: 'Easy, versatile, portable file handling'
+author:
+ - 'Tommy Butler'
+build_requires:
+ AutoLoader: 0
+ Config: 0
+ Cwd: 0
+ Exporter: 0
+ ExtUtils::MakeMaker: 0
+ Fcntl: 0
+ File::Find: 0
+ File::Temp: 0
+ Module::Build: 0.3601
+ Scalar::Util: 0
+ Test: 0
+ Test::More: 0.88
+ Test::NoWarnings: 0
+ utf8: 0
+configure_requires:
+ ExtUtils::MakeMaker: 6.30
+ Module::Build: 0.3601
+dynamic_config: 0
+generated_by: 'Dist::Zilla version 4.300034, CPAN::Meta::Converter version 2.120921'
+license: perl
+meta-spec:
+ url: http://module-build.sourceforge.net/META-spec-v1.4.html
+ version: 1.4
+name: File-Util
+provides:
+ File::Util:
+ file: lib/File/Util.pm
+ version: 4.132140
+ File::Util::Cookbook:
+ file: lib/File/Util/Cookbook.pod
+ version: 4.132140
+ File::Util::Definitions:
+ file: lib/File/Util/Definitions.pm
+ version: 4.132140
+ File::Util::Exception:
+ file: lib/File/Util/Exception.pm
+ version: 4.132140
+ File::Util::Exception::Diagnostic:
+ file: lib/File/Util/Exception/Diagnostic.pm
+ version: 4.132140
+ File::Util::Exception::Standard:
+ file: lib/File/Util/Exception/Standard.pm
+ version: 4.132140
+ File::Util::Interface::Classic:
+ file: lib/File/Util/Interface/Classic.pm
+ version: 4.132140
+ File::Util::Interface::Modern:
+ file: lib/File/Util/Interface/Modern.pm
+ version: 4.132140
+ File::Util::Manual:
+ file: lib/File/Util/Manual.pod
+ version: 4.132140
+ File::Util::Manual::Examples:
+ file: lib/File/Util/Manual/Examples.pod
+ version: 4.132140
+recommends:
+ Unicode::UTF8: 0.58
requires:
- Class::OOorNO: 0.01
- Exception::Handler: 1
-
-distribution_type: module
-generated_by: ExtUtils::MakeMaker version 6.30
+ Config: 0
+ Exporter: 0
+ Fcntl: 0
+ Scalar::Util: 0
+ constant: 0
+ perl: 5.008001
+ strict: 0
+ subs: 0
+ vars: 0
+ warnings: 0
+resources:
+ bugtracker: https://rt.cpan.org/Dist/Display.html?Name=File%3A%3AUtil
+ homepage: https://github.com/tommybutler/file-util/wiki
+ repository: git://github.com/tommybutler/file-util.git
+version: 4.132140
+x_Dist_Zilla:
+ perl:
+ version: 5.017010
+ plugins:
+ -
+ class: Dist::Zilla::Plugin::Meta::Contributors
+ name: Meta::Contributors
+ version: 0.001
+ -
+ class: Dist::Zilla::Plugin::GatherDir
+ name: '@Filter/GatherDir'
+ version: 4.300034
+ -
+ class: Dist::Zilla::Plugin::PruneCruft
+ name: '@Filter/PruneCruft'
+ version: 4.300034
+ -
+ class: Dist::Zilla::Plugin::ManifestSkip
+ name: '@Filter/ManifestSkip'
+ version: 4.300034
+ -
+ class: Dist::Zilla::Plugin::MetaYAML
+ name: '@Filter/MetaYAML'
+ version: 4.300034
+ -
+ class: Dist::Zilla::Plugin::License
+ name: '@Filter/License'
+ version: 4.300034
+ -
+ class: Dist::Zilla::Plugin::Readme
+ name: '@Filter/Readme'
+ version: 4.300034
+ -
+ class: Dist::Zilla::Plugin::ExecDir
+ name: '@Filter/ExecDir'
+ version: 4.300034
+ -
+ class: Dist::Zilla::Plugin::ShareDir
+ name: '@Filter/ShareDir'
+ version: 4.300034
+ -
+ class: Dist::Zilla::Plugin::MakeMaker
+ name: '@Filter/MakeMaker'
+ version: 4.300034
+ -
+ class: Dist::Zilla::Plugin::Manifest
+ name: '@Filter/Manifest'
+ version: 4.300034
+ -
+ class: Dist::Zilla::Plugin::TestRelease
+ name: '@Filter/TestRelease'
+ version: 4.300034
+ -
+ class: Dist::Zilla::Plugin::ConfirmRelease
+ name: '@Filter/ConfirmRelease'
+ version: 4.300034
+ -
+ class: Dist::Zilla::Plugin::UploadToCPAN
+ name: '@Filter/UploadToCPAN'
+ version: 4.300034
+ -
+ class: Dist::Zilla::Plugin::RunExtraTests
+ name: RunExtraTests
+ version: 0.011
+ -
+ class: Dist::Zilla::Plugin::ModuleBuild
+ name: ModuleBuild
+ version: 4.300034
+ -
+ class: Dist::Zilla::Plugin::AutoVersion
+ name: AutoVersion
+ version: 4.300034
+ -
+ class: Dist::Zilla::Plugin::PkgVersion
+ name: PkgVersion
+ version: 4.300034
+ -
+ class: Dist::Zilla::Plugin::PodVersion
+ name: PodVersion
+ version: 4.300034
+ -
+ class: Dist::Zilla::Plugin::MetaProvides::Package
+ name: MetaProvides::Package
+ version: 1.14000002
+ -
+ class: Dist::Zilla::Plugin::MinimumPerl
+ name: MinimumPerl
+ version: 1.003
+ -
+ class: Dist::Zilla::Plugin::MetaConfig
+ name: MetaConfig
+ version: 4.300034
+ -
+ class: Dist::Zilla::Plugin::MetaJSON
+ name: MetaJSON
+ version: 4.300034
+ -
+ class: Dist::Zilla::Plugin::MetaResources
+ name: MetaResources
+ version: 4.300034
+ -
+ class: Dist::Zilla::Plugin::ReportVersions::Tiny
+ name: ReportVersions::Tiny
+ version: 1.08
+ -
+ class: Dist::Zilla::Plugin::Test::LocalBrew
+ name: Test::LocalBrew
+ version: 0.05
+ -
+ class: Dist::Zilla::Plugin::PodSyntaxTests
+ name: '@TestingMania/PodSyntaxTests'
+ version: 4.300034
+ -
+ class: Dist::Zilla::Plugin::NoTabsTests
+ name: '@TestingMania/NoTabsTests'
+ version: 0.01
+ -
+ class: Dist::Zilla::Plugin::Test::CPAN::Changes
+ name: '@TestingMania/Test::CPAN::Changes'
+ version: 0.008
+ -
+ class: Dist::Zilla::Plugin::MetaTests
+ name: '@TestingMania/MetaTests'
+ version: 4.300034
+ -
+ class: Dist::Zilla::Plugin::Test::Compile
+ name: '@TestingMania/Test::Compile'
+ version: 2.002
+ -
+ class: Dist::Zilla::Plugin::Test::Version
+ name: '@TestingMania/Test::Version'
+ version: 0.002004
+ -
+ class: Dist::Zilla::Plugin::Test::Perl::Critic
+ name: '@TestingMania/Test::Perl::Critic'
+ version: 2.112410
+ -
+ class: Dist::Zilla::Plugin::Test::UnusedVars
+ name: '@TestingMania/Test::UnusedVars'
+ version: 2.000004
+ -
+ class: Dist::Zilla::Plugin::MojibakeTests
+ name: '@TestingMania/MojibakeTests'
+ version: 0.5
+ -
+ class: Dist::Zilla::Plugin::Test::DistManifest
+ name: '@TestingMania/Test::DistManifest'
+ version: 2.000003
+ -
+ class: Dist::Zilla::Plugin::Test::CPAN::Meta::JSON
+ name: '@TestingMania/Test::CPAN::Meta::JSON'
+ version: 0.003
+ -
+ class: Dist::Zilla::Plugin::Test::Synopsis
+ name: '@TestingMania/Test::Synopsis'
+ version: 2.000003
+ -
+ class: Dist::Zilla::Plugin::Test::Kwalitee
+ name: '@TestingMania/Test::Kwalitee'
+ version: 2.03
+ -
+ class: Dist::Zilla::Plugin::PodCoverageTests
+ name: '@TestingMania/PodCoverageTests'
+ version: 4.300034
+ -
+ class: Dist::Zilla::Plugin::Test::PodSpelling
+ name: Test::PodSpelling
+ version: 2.004004
+ -
+ class: Dist::Zilla::Plugin::CheckChangesHasContent
+ name: CheckChangesHasContent
+ version: 0.006
+ -
+ class: Dist::Zilla::Plugin::TestRelease
+ name: TestRelease
+ version: 4.300034
+ -
+ class: Dist::Zilla::Plugin::ConfirmRelease
+ name: ConfirmRelease
+ version: 4.300034
+ -
+ class: Dist::Zilla::Plugin::Signature
+ name: Signature
+ version: 1.100930
+ -
+ class: Dist::Zilla::Plugin::AutoPrereqs
+ name: AutoPrereqs
+ version: 4.300034
+ -
+ class: Dist::Zilla::Plugin::Prereqs
+ config:
+ Dist::Zilla::Plugin::Prereqs:
+ phase: test
+ type: requires
+ name: TestRequires
+ version: 4.300034
+ -
+ class: Dist::Zilla::Plugin::Prereqs
+ config:
+ Dist::Zilla::Plugin::Prereqs:
+ phase: runtime
+ type: recommends
+ name: Recommends
+ version: 4.300034
+ -
+ class: Dist::Zilla::Plugin::Prereqs
+ config:
+ Dist::Zilla::Plugin::Prereqs:
+ phase: develop
+ type: requires
+ name: DevelopRequires
+ version: 4.300034
+ -
+ class: Dist::Zilla::Plugin::FinderCode
+ name: ':InstallModules'
+ version: 4.300034
+ -
+ class: Dist::Zilla::Plugin::FinderCode
+ name: ':IncModules'
+ version: 4.300034
+ -
+ class: Dist::Zilla::Plugin::FinderCode
+ name: ':TestFiles'
+ version: 4.300034
+ -
+ class: Dist::Zilla::Plugin::FinderCode
+ name: ':ExecFiles'
+ version: 4.300034
+ -
+ class: Dist::Zilla::Plugin::FinderCode
+ name: ':ShareFiles'
+ version: 4.300034
+ -
+ class: Dist::Zilla::Plugin::FinderCode
+ name: ':MainModule'
+ version: 4.300034
+ zilla:
+ class: Dist::Zilla::Dist::Builder
+ config:
+ is_trial: 0
+ version: 4.300034
+x_contributors:
+ - 'John Fields <jfields.cpan.org@spammenot.com>'
+ - 'Ricardo SIGNES <rjbs@cpan.org>'
+ - 'Matt S Trout <perl-stuff@trout.me.uk>'
+ - 'Nicholas Perez <nperez@cpan.org>'
+ - 'David Golden <dagolden@cpan.org>'
@@ -1,26 +1,91 @@
-use ExtUtils::MakeMaker;
-require 5.006;
-
-# See lib/ExtUtils/MakeMaker.pm for details of how to influence
-# the contents of the Makefile that is written.
-WriteMakefile
- (
- 'NAME' => 'File::Util',
- 'AUTHOR' => 'Tommy Butler <cpan@atrixnet.com>',
- 'ABSTRACT_FROM'=> 'Util.pod',
- 'VERSION_FROM' => 'Util.pm',
- 'INSTALLDIRS' => 'site',
- 'PREREQ_PM' =>
- {
- 'Class::OOorNO' => 0.01_0,
- 'Exception::Handler' => 1.00_0,
- },
- 'linkext' => { LINKTYPE => '' }, # no link needed
- 'dist' =>
- {
- 'COMPRESS' => 'gzip -9f',
- 'SUFFIX' => 'gz',
- 'ZIP' => '/usr/bin/zip',
- 'ZIPFLAGS' => '-rl',
- }
- );
+
+use strict;
+use warnings;
+
+use 5.008001;
+
+use ExtUtils::MakeMaker 6.30;
+
+
+
+my %WriteMakefileArgs = (
+ "ABSTRACT" => "Easy, versatile, portable file handling",
+ "AUTHOR" => "Tommy Butler",
+ "BUILD_REQUIRES" => {
+ "Module::Build" => "0.3601"
+ },
+ "CONFIGURE_REQUIRES" => {
+ "ExtUtils::MakeMaker" => "6.30",
+ "Module::Build" => "0.3601"
+ },
+ "DISTNAME" => "File-Util",
+ "EXE_FILES" => [],
+ "LICENSE" => "perl",
+ "NAME" => "File::Util",
+ "PREREQ_PM" => {
+ "Config" => 0,
+ "Exporter" => 0,
+ "Fcntl" => 0,
+ "Scalar::Util" => 0,
+ "constant" => 0,
+ "strict" => 0,
+ "subs" => 0,
+ "vars" => 0,
+ "warnings" => 0
+ },
+ "TEST_REQUIRES" => {
+ "AutoLoader" => 0,
+ "Config" => 0,
+ "Cwd" => 0,
+ "Exporter" => 0,
+ "ExtUtils::MakeMaker" => 0,
+ "Fcntl" => 0,
+ "File::Find" => 0,
+ "File::Temp" => 0,
+ "Module::Build" => 0,
+ "Scalar::Util" => 0,
+ "Test" => 0,
+ "Test::More" => "0.88",
+ "Test::NoWarnings" => 0,
+ "utf8" => 0
+ },
+ "VERSION" => "4.132140",
+ "test" => {
+ "TESTS" => "t/*.t"
+ }
+);
+
+
+unless ( eval { ExtUtils::MakeMaker->VERSION(6.63_03) } ) {
+ my $tr = delete $WriteMakefileArgs{TEST_REQUIRES};
+ my $br = $WriteMakefileArgs{BUILD_REQUIRES};
+ for my $mod ( keys %$tr ) {
+ if ( exists $br->{$mod} ) {
+ $br->{$mod} = $tr->{$mod} if $tr->{$mod} > $br->{$mod};
+ }
+ else {
+ $br->{$mod} = $tr->{$mod};
+ }
+ }
+}
+
+unless ( eval { ExtUtils::MakeMaker->VERSION(6.56) } ) {
+ my $br = delete $WriteMakefileArgs{BUILD_REQUIRES};
+ my $pp = $WriteMakefileArgs{PREREQ_PM};
+ for my $mod ( keys %$br ) {
+ if ( exists $pp->{$mod} ) {
+ $pp->{$mod} = $br->{$mod} if $br->{$mod} > $pp->{$mod};
+ }
+ else {
+ $pp->{$mod} = $br->{$mod};
+ }
+ }
+}
+
+delete $WriteMakefileArgs{CONFIGURE_REQUIRES}
+ unless eval { ExtUtils::MakeMaker->VERSION(6.52) };
+
+WriteMakefile(%WriteMakefileArgs);
+
+
+
@@ -0,0 +1,143 @@
+NEWS for File::Util
+
+Thu Jun 6 23:11:39 CDT 2013
+ Since Sat Mar 2 01:13:46 CST 2013, 580 test runs from the CPAN testers
+ have had 100% complete PASSes. I'm releasing the code as-is, as
+ "STABLE"/"MATURE"
+
+Wed Feb 27 21:55:28 CST 2013
+ Testing suite and documentation updated with information regarding the
+ support of UTF-8 in File::Util and how to use it. Minor bug fixes.
+
+Mon Feb 25 19:36:21 CST 2013
+ The latest version introduces unicode support for reading/writing/appending
+ via UTF-8 encoding. See the documentation for details.
+
+ The affected methods are:
+ * load_file()
+ * open_handle()
+ * write_file()
+
+Mon Feb 25 14:07:13 CST 2013
+ A vast number of optimizations have been applied to recursive calls in
+ methods like list_dir() which bring it more-than-up-to-par with mainstream
+ modules for directory searching and traversal in terms of performance.
+
+ Windows-specific bug fixes have been added, necessary in great part due
+ to the non-posix nature of its filesystems and its lack of support for
+ the CORE::stat() function.
+
+Sun Feb 10 21:32:36 CST 2013
+ More added to the TODO list since the last news update. We have now a
+ 4.x build that is CPAN ready (as a TRIAL). The manual has been combed
+ through and polished off, the test suite has been greatly improved thanks
+ to newer/better "diesnice" tests made possible by Test::Fatal. Several
+ bugs have been caught and put to rest due to the expanded testing,
+ because the improved tests revealed them where they had been hiding.
+
+Tue Jan 29 18:59:25 CST 2013
+ Most of the goals in the TODO list have been finished, or well on course
+ for completion. Stability of new features and design are sufficient
+ enough that I feel like we're ready for the first CPAN release of the 4.x
+ series in the next few days probably.
+
+ Remaining tasks will be the ongoing improvement of the test suite and the
+ documentation. Those are the kind of tasks that are seemingly "never done".
+
+ Everything is testing well, performing well, running well on all platforms
+ I have available for testing (which are many). Overall the state of
+ the File::Util distribution and code is better than ever.
+
+Tue Jan 22 00:28:30 CST 2013
+ Version 4.000000 has (and never will be) released to the CPAN, as it was
+ still in active development at the time it hit that mark. Development
+ continues, and the first formal release of the 4.x version distributions
+ is soon approaching. Documentation seems all that is left. There's a
+ whole slew of new features to document (higher order functions and the new
+ method invocation syntax are just two examples).
+
+ Much more has been done in the way of improving the test suite, and
+ the dist is being constantly tested on Windows, Solaris, and Unix so
+ future releases to the CPAN will never bring surprises like those that
+ happened when development first shifted to the use of Dist::Zilla.
+
+
+Thu Jan 10 22:44:45 CST 2013
+ The latest release (v 4.0) brings many fixes to the table. The fixes
+ affect nearly all platforms and architectures. Users are encouraged to
+ upgrade, as this is not merely a features-added release.
+
+ Fundamental changes in the internal layout of File::Util have been
+ made; it isn't a single module file anymore. This does NOT affect the
+ end user. To the user, this change is completely transparent and does
+ not affect their programs or libraries that use File::Util.
+
+ This change is a step forward in the stated goal of File::Util to bring
+ a more "modern" (as in Modern::Perl) interface to the user while
+ preserving compatibility with current syntax.
+
+ Also in this release we move to auto-versioning a la Dist::Zilla plugins
+ PkgVersion and AutoVersion (thank you to the authors of those plugins)
+
+ Further, the test suite has been updated to make use of Test::More and
+ Test::NoWarnings across the board, bringing better "kwalitee" (as in
+ CPANTS) to you and to OS package maintainers for various platforms out
+ there.
+
+ Since the new year and new goals for File::Util, CPANTS metrics for
+ kwalitee of the distribution have climbed from well below 100 to
+ almost 140. This will continue to improve. Onward and upward.
+
+ Finally, several code optimizations have been made for faster performance,
+ made possible by the increasingly rigorous test suite.
+
+ Re: flock() on Solaris -
+ Updates have been made to the test suite so flock() problems on
+ Solaris don't incorrectly cause test results to appear to have failed
+ on that single platform. Solaris users should be aware of the problems
+ with discretionary locks on their platform. It is not only Perl
+ that experiences issues, but Python, Ruby, and others. The problem
+ is specifically that Solaris will happily lock a file, but will very
+ often NOT unlock it until the process has exited. This causes all
+ kinds of problems. The documentation for File::Util will be updated
+ in order to advise Solaris users of opening the same file more than
+ once during the lifetime of a process.
+
+
+Mon Dec 31 23:25:00 CST 2012
+ This latest release (v 3.33) is not a feature release. It's a
+ documentation update, a few bug fixes, several code optimizations, and
+ code cleanup. Mostly, it is a great step forward in the CPAN package
+ itself. Read on for more details...
+
+ Please have a look at the CHANGES file, because there have been and will
+ continue to be big changes/improvements to File::Util both in terms of the
+ code itself and the CPAN distribution package releases.
+
+ File::Util is now migrated to git and uses Dist::Zilla to create a
+ build environment that works better in windows platforms. This
+ brought about the moving the content of Util.pod back into Util.pm
+ which does have its benefits, but makes the actual file size larger
+ than I want; I'll probably soon make a cookbook and slim down the main
+ documentation a bit, since it's very exhaustive, and bring things back
+ into the file sizes I like to see. Compile times and run times have
+ not been affected by the POD move.
+
+ File::Util now must pass Perl::Critic tests as well, therefore the
+ so-called CPANTS "kwalitee" of the code has been markedly increased.
+
+ File::Util will be signed with a Module::Signature from now on, as
+ long as this doesn't introduce failures in the build/test phases for
+ CPAN testers and end users alike.
+
+ These changes are part of an overall effort to "keep moving forward",
+ make things better, and also make the distribution compliant with
+ Fedora and Debian packaging standards. File::Util already has a
+ maintained package for Ubuntu.
+
+ There's a writeup of my most recent reflections on File::Util that I
+ posted on Perl Monks which explains some of my new goals for the
+ distribution, the code, and the future of File::Util. You can read it at
+ http://www.perlmonks.org/?node_id=1011110
+
+ Happy new year!
@@ -1,81 +1,13 @@
-File::Util
-=========================
-DESCRIPTION
-File::Util provides a comprehensive toolbox of utilities to automate all
-kinds of common tasks on file / directories. Its purpose is to do so
-in the most portable manner possible so that users of this module won't
-have to worry about whether their programs will work on other OSes
-and machines.
+This archive contains the distribution File-Util,
+version 4.132140:
-CHANGES IN LAST FEW RELEASES
-(listed in reverse chronological order by date and subversion)
+ Easy, versatile, portable file handling
- 2.27
- Sat Dec 6 13:10:00 CST 2008
- Fixed a bug that caused root directories using Micro$oft filesystem
- notation to be mis-read when using the '--dirs-only' flag for
- File::Util::list_dir()
+This software is copyright (c) 2013 by Tommy Butler.
- 3.26
- Tue Dec 2 20:07:09 CST 2008
- Added to test suite in order to avoid errant test failures
- when flock'ing on solaris. This is a big deal, since the point of
- File::Util is to be easy, and portable!
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
- Added some yet more extra examples in the documentation.
-
- 3.25
- Mon Dec 1 15:11:20 CST 2008
- Fixed a bug in File::Util::touch()
-
- Added some extra examples and corrected one minor error in the
- documentation.
-
- 3.24
- Wed May 23 16:27:20 CDT 2007
- **Don't use this version. It has a bug. Use 3.25 or greater.
-
- Added method File::Util::last_changed (get inode change time for a file)
- Added method File::Util::touch (works like *nix touch command)
-
- Both touch and last_changed are autoloaded methods
-
- Applied patch from S. Muskiewicz that fixes the File::Util::last_modified
- method that was using a similar but incorrect "-" file test operator.
-
-INSTALLATION
-To install this module type the following:
-
- perl Makefile.PL
- make
- make test
- make install
-
-On windows machines use nmake rather than make; those running cygwin don't have
-to worry about this. If you don't know what cygwin is, use nmake and check out
-<URL: http://cygwin.com/> after you're done installing this module if you want
-to find out.
-
-
-DEPENDENCIES
-This module requires these other modules and libraries:
-
- Class::OOorNO v0.01_0 or better
- Exception::Handler v1.00_0 or better
-
-
-AUTHOR
- Tommy Butler <cpan@atrixnet.com>
-
-
-COPYRIGHT
- Copyright (C) Tommy Butler 2001-2002, all rights reserved.
-
-
-LICENCE
-
- This library is free software, you may redistribute it and/or modify it
- under the same terms as Perl itself.
@@ -0,0 +1,129 @@
+This file contains message digests of all files listed in MANIFEST,
+signed via the Module::Signature module, version 0.70.
+
+To verify the content in this distribution, first make sure you have
+Module::Signature installed, then type:
+
+ % cpansign -v
+
+It will check each file's integrity, as well as the signature's
+validity. If "==> Signature verified OK! <==" is not displayed,
+the distribution may already have been compromised, and you should
+not run its Makefile.PL or Build.PL.
+
+-----BEGIN PGP SIGNED MESSAGE-----
+Hash: SHA1
+
+SHA1 76a08172c2a635f36337c548aa80600ef0346159 AUTHORS
+SHA1 b48f5705cb8dc5ffa5f9da7711033bdd37e4c519 Build.PL
+SHA1 bb2492d6fbfa8b7d456f2b8986db4533908dc097 COPYING
+SHA1 54fa0deac3b67fadc189657d93726d68a5c21e40 Changes
+SHA1 027631fb6bcf8560acb0ecd72b9af91145b9f73d INSTALL
+SHA1 08f08e03a26d925b5e5b438e47cc67b96fa6b338 LICENSE
+SHA1 846aedfb0e9e8a3ef38ec6b7a62bda711896149a MANIFEST
+SHA1 8dd8a3dfd3c3166f12bbb2cfff232bb6a0e55ff6 MANIFEST.SKIP
+SHA1 c66c507b68f44290ac024eeb861dd695ce9fb193 META.json
+SHA1 3992eee0c926aeb2c03944fd1a90175ef3bb9033 META.yml
+SHA1 481f706383e9f3d2802742ac87dde69ce41b2f0b Makefile.PL
+SHA1 f532dfd71c080d85c0acd1d5e7aff4209b32a839 NEWS
+SHA1 903d27cf5c2119842d64e3a19b2778a62094ad56 README
+SHA1 3061740499645ac61a900f7e9899513fa77faeb9 TODO
+SHA1 542779f214c14078f882ed73249052ac11ed1341 dist.ini
+SHA1 874ad198d5fd2f480c9449f7dc0359442f3ad7d5 examples/batch_file_rename.pl
+SHA1 e8f35b4a54bf70fa577923741316a39b7de1493b examples/batch_search_and_replace.pl
+SHA1 fa112d4da9a8bde9de6fef21be45196bc4fd789e examples/get_an_open_file_handle.pl
+SHA1 258eee9346725a17346a8b7a27069f4df529dc37 examples/increment_a_counter_file.pl
+SHA1 0f754b86d9e06a2025caf263cc52021ff355d961 examples/list_the_contents_of_a_directory.pl
+SHA1 9c721ffba2198c7f6e7ec3961ee1a9e6cf289bf4 examples/list_the_contents_of_a_directory_recursively.pl
+SHA1 d739d05d6010654003e0f8bae75c0cb652a6909b examples/load_a_file_into_a_variable.pl
+SHA1 fee036b6ffba2b73940d512d1ca08ce9bfd38c67 examples/make_a_new_directory.pl
+SHA1 73edfa635d681f06256c94f6003e938348bd2893 examples/pretty_print_a_directory.pl
+SHA1 7bc3b97adb2e5d74d6a0e72fd222d7dafcfd336d examples/pretty_print_a_directory_using_as_tree.pl
+SHA1 8e696d12f81c1fcae53a21325b4915ae1ec71fdb examples/pretty_print_a_directory_using_callbacks_fancy.pl
+SHA1 80922e73571def192f04c1784caebeadedf535ba examples/pretty_print_a_directory_using_callbacks_simple.pl
+SHA1 ae9afb8f97c188031c0e74ec60b627584e9fa383 examples/recursively_remove_a_directory_and_its_contents.pl
+SHA1 17a1a90b90e22fd0b5780fbef6026a16c448ff51 examples/retry_open_handle.pl
+SHA1 70177b252e54feeb078e5fab9c6de0ad43cba784 examples/wrap_the_lines_in_a_file.pl
+SHA1 3ef56e2a76269416d29b0640406bac70a2be0a51 examples/write_or_append_to_a_file.pl
+SHA1 5ba0050a541b0304a218e72a88c9d61a4a2ab23c lib/File/Util.pm
+SHA1 1febd71a8c1b82b688793afbfc9129a847aa89a2 lib/File/Util/Cookbook.pod
+SHA1 724ce0dcfa66eb19538b6ac9a0db8dedecdf5056 lib/File/Util/Definitions.pm
+SHA1 75515d893071b1e7ade7de724e52a2009fc8ddbf lib/File/Util/Exception.pm
+SHA1 3d4d3e1e1ea6d32057f22d34bbfa3313a3b9b0a9 lib/File/Util/Exception/Diagnostic.pm
+SHA1 fe4728763a629ad777642250e4932d0460852dcf lib/File/Util/Exception/Standard.pm
+SHA1 48118e6a872d65b9216fa641ac3a63fd68104cf2 lib/File/Util/Interface/Classic.pm
+SHA1 70eb349d949fce0d30c5439f8d42d73c79a0f349 lib/File/Util/Interface/Modern.pm
+SHA1 3e2007527622c1cd6126d1f1a3ad8e94f88bb5a3 lib/File/Util/Manual.pod
+SHA1 1b4343d68812b53878424790b49cf4c2b1225c7a lib/File/Util/Manual/Examples.pod
+SHA1 9d689f1a8aee3f115cd06b340f5557bdeac5a83f performance/bench_listdir.pl
+SHA1 07a1463fd7053e77e5b9d5b16bfe8de0cd0909b7 performance/bench_load_time.pl
+SHA1 0c6b2574d244e23d247400ecc0d4aedf2e940090 performance/profile_listdir.pl
+SHA1 54398261543845175dd21aeac50e3061ff50b08c performance/profile_listdir_vs_file-find-rule.pl
+SHA1 a15164047e311ba8f4f59d2a93079305278e2327 perlcritic.rc
+SHA1 becd1816dfa1e94e6520f88b82b4b4e000c9518d t/00-compile.t
+SHA1 f2761c12248379558215afb1dbbae10d15196995 t/000-report-versions-tiny.t
+SHA1 1b34fc2c2e6b8f80b219a9cba838dc413016695e t/001_canuseit.t
+SHA1 71a868482e05797d7e5299f3cb520d69379eea88 t/002_isa.t
+SHA1 135930ad08a066755296cc8990825eaf4365b025 t/003_can.t
+SHA1 3ad564d1f3b2271018e825f7d4b3cf00496eaa6c t/004_portable.t
+SHA1 885a069279b1961884deff7fe8be0d02851e4c93 t/005_ftests.t
+SHA1 334cda2cb052a38e36484df464a58f23ab482ef7 t/006_io.t
+SHA1 daf7d676765e7163ae5e98f6c44b127a13ab157a t/007_flock.t
+SHA1 1a0009da145fb28501ce6feaad5aa2935eaeea2b t/008_export_ok.t
+SHA1 9200be436c04e75fc832aa260e659a905daf2321 t/009_empty_subclass.t
+SHA1 869e721a1b9b11e6c054a72e01c888b4b4a834c4 t/010_unicode.t
+SHA1 c005e09ed57a45d8fb03dfe64ce533a24c0c4f2f t/011_abspaths.t
+SHA1 072aef8454daa3b3525d7f7d3d8edc181f64e786 t/012_atomize_path.t
+SHA1 fab3c64b0dba3454034251ef24b9f5c5717c3c06 t/013_interface_classic.t
+SHA1 7e52d358b5c4297938478e87e25eb545113d3619 t/014_interface_modern.t
+SHA1 19e8ca9d6dad89c57ebee2b69e4995eba03d9e07 t/015_destroy.t
+SHA1 3a5495bdb6a846f1fc43ec8f604159bff5a82523 t/016_new.t
+SHA1 2db082f0faa6713c70c1371ddad2c7a4516f2258 t/017_make_dir_list_dir.t
+SHA1 6be9177ea6cca93f1c28b956f25d90c3cc3d66c3 t/018_list_dir_advancedmatch.t
+SHA1 43309f57e58b9662c464b0e6ac3fd36ccd637032 t/019_load_dir.t
+SHA1 e9cc72017286700ecd33fd102ea0f572661d11b5 t/020_write_file.t
+SHA1 cac36f84f0db21cf6fa980a9b31ca3453a84f8e4 t/bin
+SHA1 65821dbdac86467eb04a9ad83dfad0600dfabdd9 t/txt
+SHA1 5bd500053b03b9a17b570fb39ca2e5ee959540dc xt/author/critic.t
+SHA1 503fd5e3eebe0bcfcf59b021d6489ad766e25149 xt/author/pod-spell.t
+SHA1 199b3d456352d36185a3f28aaf40efb0475dacab xt/release/cpan-changes.t
+SHA1 ac35210d46db63c99f0e390c1fe820c80c1cd705 xt/release/diesnice-fatalities.t
+SHA1 d9230f50f43aae985a08160b37877e42e9f12800 xt/release/diesnice-messages.t
+SHA1 cbc5b72710fb645c559b78c8ac8b879f62aff326 xt/release/dist-manifest.t
+SHA1 c591e1c2af60bc91cc86013f7dea9b6703eace1c xt/release/dist-portable.t
+SHA1 a90bf5754e9e6248bd691a819173efd9b0fdd86a xt/release/distmeta.t
+SHA1 c6cd63148d20bda841ee21381cd6e9a62b7e6863 xt/release/kwalitee.t
+SHA1 da2e4b496cc94b7e46cccf44c066dd6c0cc2d469 xt/release/localbrew-perl-5.10.1.t
+SHA1 199cd08e84c3a3145ab2c99a090cdf3a98d18715 xt/release/localbrew-perl-5.12.5.t
+SHA1 8f57e9aeb37c71865c4e67f9508d7372dde067f1 xt/release/localbrew-perl-5.14.4.t
+SHA1 8c68d637184a21e589f6a7f2960747e1db0c9de2 xt/release/localbrew-perl-5.16.3.t
+SHA1 b91d3bb2a9a5d6b154c98d404c25bdf57b54f814 xt/release/localbrew-perl-5.17.10.t
+SHA1 fe2b96f5248be4da26200542cfb5dadeb98c34b8 xt/release/localbrew-perl-5.18.0.t
+SHA1 9870aafd1d1573e37e72843b175ffdba5b17fed9 xt/release/localbrew-perl-5.8.9.t
+SHA1 7b52b909acf6cd52733f8f226f92147ed76a2717 xt/release/meta-json.t
+SHA1 c6c3c9f7fe12058b4771449dff874b1c450c982c xt/release/mojibake.t
+SHA1 c769b078112da535475284c9fe0cf6b1c047dbdd xt/release/no-tabs.t
+SHA1 289bc9a5e6e6fd50b1be0837eb224c8abe38811a xt/release/onfail.t
+SHA1 74bc7524c337d121b0781dd8c5bb623c6c659a1b xt/release/open_handle.t
+SHA1 4c599e8a4ebb7a899f90ee3c235a64fdbc7e2c06 xt/release/pod-coverage.t
+SHA1 9934d36e45e1143c1a54658bc48872e0591af41b xt/release/pod-syntax.t
+SHA1 7737dadb6441d9eaddc571caf03e6c114cd4a643 xt/release/synopsis.t
+SHA1 bbcd59d081d9940af5d43337ae85458075933829 xt/release/test-version.t
+SHA1 ec3f84bfd7a9ce3246e7592f4134100c6b5ce02b xt/release/unused-vars.t
+-----BEGIN PGP SIGNATURE-----
+Version: GnuPG v1.4.10 (GNU/Linux)
+
+iQIcBAEBAgAGBQJR++bXAAoJEGe9xj410/4dUOUQAJAuxPIZPGYhy2wMNRSh12oR
+NIb6w1PdJrXEYu34shJfESUie2i2IAuoA0HLDCE5h4bdccb3WPb2dgIsDysyESKF
+AqQRkya4sELqvRto25pjcdRJUKy1Bpyv+ZrEduo7x3DYBe85PuT885BXP/lcwbrN
++OMgzjGWm+8ypVcB9RAYKJYEQK3ahMJTG9M48ZQD1vhLXczjOiu0dtzfvUCPPPeh
+Mty066yWgWPc+dQ9C7OpTYpzoe+IARpChaQfEKXMp7XcW4cyQJ9UP7qPw6bjbAhP
+EJ6B15FOBFnDe+m2Uri4SpRDmEoOafgW/gEK8sVU5uLkjcwg6E5JC88TrEz4dwK/
+6ItB5VKYPvTeHwMRti8W5yTGiaG6m4EeGdCdx+FQXPmBm4QOM2AbA1V/bm6TGYpI
+wS3lwI7n/RPiHvlceWzb/k+c8rpsRy3Yyxv1DKezAl4/883k/53lxsEKYWKHzCe5
+QpcuREqD6IXoCmpGgpsjnOvXFHZodso63Q8TBYZ8FeEJC+Gs86yUfpz2CCtfrfRc
+Hf7RWRDrJbJ2G0JSAbA8Izcm7sE0dbW6r9nF1TrIRVBPXtn7gogUz9tfaKNzq+xU
+A7a/Jmo7VnAmTMYDae1IESFwJ07wat4x8Ew3ayzSzaHOQ7BEuPNO9FUWIiTIczmT
+Benv1VMwpU0tLQOs+wGH
+=nVaO
+-----END PGP SIGNATURE-----
@@ -0,0 +1,83 @@
+TODO List for File::Util
+
+Not necessarily listed in order of priority:
+
+1) [DONE] Set up formal (not just private) GIT repository
+
+2) [DONE] Separate documenation examples into a cookbook (POD)
+
+3) [DONE] Gradually transform methods to accept input parameters in a
+ *::Class-like style (hashrefs, etc) while preserving backward compatibility
+
+4) [DONE] Unicode support for reading/writing files, which just hasn't been
+ requested but is now there for completeness. This item has become an all-out
+ quest to introduce full unicode support for both file/directory names and
+ file encodings (on platforms where it is supported), but given the great
+ minefield of problems with unicode on windows regarding file names, and
+ directories, that may never become a reality until Perl itself "fixes" the
+ problem.
+
+5) [DONE] Transform (where useful) various methods to accept callbacks.
+ File::Util::list_dir() is the primary target
+
+6) [DONE] Set up File::Util::list_dir() to take a listref of regexes
+
+7) [DONE] Continue improving the distribution so as to make it compliant
+ with Fedora packaging standards; it is already a maintained package for
+ Ubuntu and ActiveState.
+
+8) [DONE] Code clean up in POD documentation examples.
+
+9) [DONE] Improve and simplify code examples in POD documentation.
+
+10) [IN PROGRESS] Constantly improve test suite until Devel::Cover
+ scores are something to be proud of. We're doing much better
+ than we used to only less than 1 month ago
+
+11) [DONE] Remove all traces of old invocation syntax from the POD
+
+12) [IN PROGRESS] Now that documentation has been divided into the ::Manual and
+ the ::Cookbook, I want to add more content to them. More examples,
+ More fully-functional programs (recipes).
+
+13) [DONE] Create a less-verbose Exception class (right now we only have
+ Exception::Diagnostic, which is overkill for power users and "experts" who
+ just want a quick, clean error message instead of a full-page printout of
+ what went wrong, how to fix it, and whose fault it was -- followed by a
+ callstack. We need the less verbose alternative now.
+
+14) [DONE WITH CAVEATS*] Create a benchmark suite, plot and publish metrics as
+ part of the documentation.
+
+ *Turns out it wasn't a completely good idea, given that benchmarking is of
+ little use without context, and that means comparing the performance of
+ File::Util to other distributions out there that do similar things. This
+ has two problems, the first is that distributions are constantly evolving
+ and benchmarks recorded on one day are inaccurate the next. The second
+ is that some of the numbers are NOT flattering. In some test scenarios
+ File::Util has out-performed File::Find::** by 400%.
+
+ Publishing things that are potentially embarrassing is rude and I won't
+ do it in the tone of tooting my own horn. Mentions made to the increased
+ performance of File::Util however are not out-of-bounds and so will be
+ included in the formal documentation in defense of any claims that it is
+ "slow" due to its perceived size and file modularity.
+
+ One of the best things to come out of this was that I was able to increase
+ the performance of list_dir() by about 400% with the help of Devel::NYTProf
+ and also identify other bugs that I wouldn't have otherwise discovered.
+
+15) [DONE] Memo-ize pattern "gathering" for recursive list_dir() calls for
+ greater efficiency. Right now there's a gather op for ever recursion, and
+ that just isn't necessary. That can be optimized out.
+
+16) Provide an option to follow symlinks in list_dir(),
+
+17) [DONE] keep track of inodes seen while traversing directories to avoid
+ filesystem loops
+
+18) Write even more unicode tests
+
+19) Create option to allow user to specify that atomic file operations should
+ be performed instead of regular IO. It's a handy feature that will be
+ added in soon
@@ -1,2511 +0,0 @@
-package File::Util;
-use 5.006;
-use strict;
-use vars qw(
- $VERSION @ISA @EXPORT_OK %EXPORT_TAGS
- $OS $MODES $READLIMIT $MAXDIVES $EMPTY_WRITES_OK
- $USE_FLOCK @ONLOCKFAIL $ILLEGAL_CHR $CAN_FLOCK
- $NEEDS_BINMODE $EBCDIC $DIRSPLIT $SL $NL $_LOCKS
-);
-use Exporter;
-use AutoLoader qw( AUTOLOAD );
-use Class::OOorNO qw( :all );
-$VERSION = 3.27; # Sat Dec 6 13:10:00 CST 2008
-@ISA = qw( Exporter Class::OOorNO );
-@EXPORT_OK = (
- @Class::OOorNO::EXPORT_OK, qw(
- can_flock ebcdic existent isbin bitmask NL SL
- strip_path can_read can_write file_type needs_binmode
- valid_filename size escape_filename return_path
- created last_access last_changed last_modified OS
- )
-);
-%EXPORT_TAGS = ( 'all' => [ @EXPORT_OK ] );
-
-BEGIN {
-
- # Some OS logic.
- unless ($OS = $^O) { require Config; eval(q[$OS=$Config::Config{osname}]) }
-
- if ($OS =~ /^darwin/i) { $OS = 'UNIX' }
- elsif ($OS =~ /^cygwin/i) { $OS = 'CYGWIN' }
- elsif ($OS =~ /^MSWin/i) { $OS = 'WINDOWS' }
- elsif ($OS =~ /^vms/i) { $OS = 'VMS' }
- elsif ($OS =~ /^bsdos/i) { $OS = 'UNIX' }
- elsif ($OS =~ /^dos/i) { $OS = 'DOS' }
- elsif ($OS =~ /^MacOS/i) { $OS = 'MACINTOSH' }
- elsif ($OS =~ /^epoc/) { $OS = 'EPOC' }
- elsif ($OS =~ /^os2/i) { $OS = 'OS2' }
- else { $OS = 'UNIX' }
-
-$EBCDIC = qq[\t] ne qq[\011] ? 1 : 0;
-$NEEDS_BINMODE = $OS =~ /WINDOWS|DOS|OS2|MSWin/ ? 1 : 0;
-$NL =
- $NEEDS_BINMODE ? qq[\015\012]
- : $EBCDIC || $OS eq 'VMS' ? qq[\n]
- : $OS eq 'MACINTOSH' ? qq[\015]
- : qq[\012];
-$SL =
- { 'DOS' => '\\', 'EPOC' => '/', 'MACINTOSH' => ':',
- 'OS2' => '\\', 'UNIX' => '/', 'WINDOWS' => chr(92),
- 'VMS' => '/', 'CYGWIN' => '/', }->{ $OS }||'/';
-
-$_LOCKS = {};
-
-} BEGIN {
- use constant NL => $NL;
- use constant SL => $SL;
- use constant OS => $OS;
-}
-
-$DIRSPLIT = qr/[\x5C\/\:]/;
-$ILLEGAL_CHR = qr/[\x5C\/\|$NL\r\n\t\013\*\"\?\<\:\>]/;
-
-$READLIMIT = 52428800; # set readlimit to a default of 50 megabytes
-$MAXDIVES = 1000; # maximum depth for recursive list_dir calls
-
-use Fcntl qw( );
-
-{ local($@); eval <<'__canflock__'; $CAN_FLOCK = $@ ? 0 : 1; }
-flock(STDOUT, &Fcntl::LOCK_SH);
-flock(STDOUT, &Fcntl::LOCK_UN);
-__canflock__
-
-# try to use file locking, define flock race conditions policy
-$USE_FLOCK = 1; @ONLOCKFAIL = qw( NOBLOCKEX FAIL );
-
-$MODES->{'popen'} = {
- 'write' => '>', 'trunc' => '>', 'rwupdate' => '+<',
- 'append' => '>>', 'read' => '<', 'rwclobber' => '+>',
- 'rwcreate' => '+>', 'rwappend' => '+>>',
-};
-
-$MODES->{'sysopen'} = {
- 'read' => '&Fcntl::O_RDONLY',
- 'write' => '&Fcntl::O_WRONLY | &Fcntl::O_CREAT',
- 'append' => '&Fcntl::O_WRONLY | &Fcntl::O_APPEND | &Fcntl::O_CREAT',
- 'trunc' => '&Fcntl::O_WRONLY | &Fcntl::O_CREAT | &Fcntl::O_TRUNC',
- 'rwcreate' => '&Fcntl::O_RDWR | &Fcntl::O_CREAT',
- 'rwupdate' => '&Fcntl::O_RDWR',
- 'rwclobber' => '&Fcntl::O_RDWR | &Fcntl::O_TRUNC | &Fcntl::O_CREAT',
- 'rwappend' => '&Fcntl::O_RDWR | &Fcntl::O_APPEND | &Fcntl::O_CREAT',
-};
-
-
-# --------------------------------------------------------
-# Constructor
-# --------------------------------------------------------
-sub new {
- my($this) = {}; bless($this, shift(@_));
- my($in) = $this->coerce_array(@_);
-
- my($opts) = $this->shave_opts(\@_); $this->{'opts'} = $opts || {};
-
- $USE_FLOCK = $in->{'use_flock'}
- if exists $in->{'use_flock'} && $in->{'use_flock'};
-
- $READLIMIT = $in->{'readlimit'}
- if defined $in->{'readlimit'}
- && $$in{'readlimit'} !~ /\D/;
-
- $MAXDIVES = $in->{'max_dives'}
- if defined $in->{'max_dives'}
- && $$in{'max_dives'} !~ /\D/;
-
- return $this;
-}
-
-
-# --------------------------------------------------------
-# File::Util::list_dir()
-# --------------------------------------------------------
-sub list_dir {
- my($this) = shift(@_);
- my($opts) = $this->shave_opts(\@_);
- my($dir) = shift(@_)||'.';
- my($path) = $dir;
- my($maxd) = $opts->{'--max-dives'} || $MAXDIVES;
- my($r) = 0;
- my(@dirs) = (); my(@files) = (); my(@items) = ();
-
- return
- $this->_throw
- (
- 'no input',
- {
- 'meth' => 'list_dir',
- 'missing' => 'a directory name',
- 'opts' => $opts,
- }
- )
- unless length($dir);
-
- return($this->_throw('no such file', {'filename' => $dir})) unless -e $dir;
-
- # whack off any trailing directory separator, except for root directories
- # -account for both posix filesystem AND micro$oft directory notation
- unless ( length($dir) == 1 || $dir =~ /^(?:[[:alpha:]]:)(?:\\|\/)$/o ) {
- # removes one or more dirsep at the end of $dir
- $dir =~ s/(?:$DIRSPLIT){1,}$//o;
- }
-
- return
- $this->_throw
- (
- 'called opendir on a file',
- {
- 'filename' => $dir,
- 'opts' => $opts,
- }
- )
- unless (-d $dir);
-
- # this directory recursion method keeps track of dives based on the parent
- # directory of $dir, rather than on $dir itself so that multiple
- # subdirectories within the same parent directory don't improperly increment
- # the number of dives made
- if ($opts->{'--recursing'}) {
-
- my($pdir) = $dir; $pdir =~ s/(^.*)$DIRSPLIT.*/$1/;
-
- $this->{'traversed'}{ $pdir } = $pdir;
- }
- else { $this->{'traversed'} = {} }
-
- if (scalar keys %{ $this->{'traversed'} } >= $maxd) {
-
- return $this->_throw
- (
- 'maxdives exceeded',
- {
- 'meth' => 'list_dir',
- 'maxdives' => $maxd,
- 'opts' => $opts,
- }
- )
- }
-
- $r = 1 if ($opts->{'--follow'} || $opts->{'--recurse'});
-
- local(*DIR);
-
- opendir(DIR, $dir) or
- return
- $this->_throw
- (
- 'bad opendir',
- {
- 'dirname' => $dir,
- 'exception' => $!,
- 'opts' => $opts,
- }
- );
-
- # read from beginning of the directory (doesn't seem necessary on any
- # platforms I've run code on, but just in case...)
- rewinddir(DIR);
-
- @files = exists($opts->{'--pattern'})
- ? grep(/$opts->{'--pattern'}/, readdir(DIR))
- : readdir(DIR);
-
- closedir(DIR) or return $this->_throw(
- 'close dir',
- {
- 'dir' => $dir,
- 'exception' => $!,
- 'opts' => $opts,
- }
- );
-
- if ($opts->{'--no-fsdots'}) {
-
- my(@shadow) = @files; @files = ();
-
- while (@shadow) {
-
- my($f) = shift(@shadow);
-
- push(@files,$f) unless (
- $this->strip_path($f) eq '.'
- or
- $this->strip_path($f) eq '..'
- );
- }
- }
-
- for (my($i) = 0; $i < @files; ++$i) {
-
- my($listing) = ($opts->{'--with-paths'} or ($r==1))
- ? $path . SL . $files[$i]
- : $files[$i];
-
- if (-d $path . SL . $files[$i]) { push(@dirs, $listing) }
- else { push(@items, $listing) }
- }
-
- if (($r) and (not $opts->{'--override-follow'})) {
-
- my(@shadow) = @dirs; @dirs = ();
-
- while (@shadow) {
-
- my($f) = shift(@shadow);
-
- push(@dirs,$f)
- unless
- (
- $this->strip_path($f) eq '.'
- or
- $this->strip_path($f) eq '..'
- );
- }
-
- for (my($i) = 0; $i < @dirs; ++$i) {
-
- my(@lsts) = $this->list_dir
- (
- $dirs[$i],
- '--with-paths', '--dirs-as-ref',
- '--files-as-ref', '--recursing',
- '--no-fsdots', '--max-dives=' . $maxd
- );
-
- push(@dirs,@{$lsts[0]}); push(@items,@{$lsts[1]});
- }
- }
-
- if ($opts->{'--sl-after-dirs'}) {
-
- @dirs = $this->_dropdots(@dirs,'--save-dots');
- my($dots) = shift(@dirs);
- @dirs = map ( ($_ .= SL), @dirs );
- @dirs = (@{$dots},@dirs);
- }
-
- my($reta) = []; my($retb) = [];
-
- if ($opts->{'--ignore-case'}) {
-
- $reta = [ sort {uc $a cmp uc $b} @dirs ];
- $retb = [ sort {uc $a cmp uc $b} @items ];
- }
- else {
-
- $reta = [ sort {$a cmp $b} @dirs ];
- $retb = [ sort {$a cmp $b} @items ];
- }
-
- return(scalar(@$reta))
- if $opts->{'--dirs-only'} && $opts->{'--count-only'};
-
- return(scalar(@$retb))
- if $opts->{'--files-only'} && $opts->{'--count-only'};
-
- return(scalar(@$reta) + scalar(@$retb)) if $opts->{'--count-only'};
-
- return($reta,$retb) if $opts->{'--as-ref'};
-
- $reta=[$reta] if $opts->{'--dirs-as-ref'};
- $retb=[$retb] if $opts->{'--files-as-ref'};
-
- return(@$reta) if $opts->{'--dirs-only'};
- return(@$retb) if $opts->{'--files-only'};
-
- return(@$reta,@$retb);
-}
-
-
-# --------------------------------------------------------
-# File::Util::_dropdots()
-# --------------------------------------------------------
-sub _dropdots {
- my($this) = shift(@_); my(@out) = (); my($opts) = $this->shave_opts(\@_);
- my(@shadow) = @_; my(@dots) = (); my($gottadot) = 0;
-
- while (@shadow) {
-
- if ($gottadot == 2){ push(@out,@shadow) and last }
-
- my($thing) = shift(@shadow);
-
- if ($thing eq '.') {++$gottadot;push(@dots,$thing);next}
- if ($thing eq '..') {++$gottadot;push(@dots,$thing);next}
-
- push(@out,$thing);
- }
-
- return([@dots],@out) if ($opts->{'--save-dots'}); @out;
-}
-
-
-# --------------------------------------------------------
-# File::Util::load_file()
-# --------------------------------------------------------
-sub load_file {
- my($this) = shift(@_); my($opts) = $this->shave_opts(\@_);
- my($in) = $this->coerce_array(@_); my(@dirs) = ();
- my($blocksize) = 1024; # 1.24 kb
- my($FH_passed) = 0; my($fh) = undef; my($file) = ''; my($path) = '';
- my($content) = ''; my($FHstatus) = ''; my($mode) = 'read';
-
- if (scalar(@_) == 1) {
-
- $file = shift(@_)||'';
-
- @dirs = split(/$DIRSPLIT/, $file);
-
- if (scalar(@dirs) > 0) {
-
- $file = pop(@dirs); $path = join(SL, @dirs);
- }
-
- if (length($path) > 0) {
-
- $path = '.' . SL . $path if ($path !~ /(?:^\/)|(?:^\w\:)/o);
- }
- else { $path = '.'; }
-
- return $this->_throw
- (
- 'no input',
- {
- 'meth' => 'load_file',
- 'missing' => 'a file name or file handle reference',
- 'opts' => $opts,
- }
- )
- if (length($path . SL . $file) == 0);
- }
- else {
- $fh = $in->{'FH'}||''; $FHstatus = $in->{'FH_status'}||'';
-
- # did we get a filehandle?
- if (length($fh) > 0) { $FH_passed = 1; } else {
- return $this->_throw(
- 'no input',
- {
- 'meth' => 'load_file',
- 'missing' => 'a file name or file handle reference',
- 'opts' => $opts,
- }
- );
- }
- }
-
- if ($FH_passed) {
- my($buff) = 0; my($bytes_read) = 0;
-
- while (<$fh>) {
- if ($buff < $READLIMIT) {
- $bytes_read = read($fh,$content,$blocksize); $buff += $bytes_read;
- }
- else {
- return $this->_throw(
- 'readlimit exceeded',
- {
- 'filename' => '<FH>',
- 'size' => qq[[truncated at $bytes_read]],
- 'opts' => $opts,
- }
- );
- }
- }
-
- # return an array of all lines in the file if the call to this method/
- # subroutine asked for an array eg- my(@file) = load_file('file');
- # otherwise, return a scalar value containing all of the file's content
- return(split(/$NL|\r|\n/o,$content)) if $opts->{'--as-list'};
-
- return($content);
- }
-
- # if the file doesn't exist, send back an error
- return $this->_throw(
- 'no such file',
- {
- 'filename' => $path . SL . $file,
- 'opts' => $opts,
- }
- ) unless -e $path . SL . $file;
-
- # it's good to know beforehand whether or not we have permission to open
- # and read from this file allowing us to handle such an exception before
- # it handles us.
-
- # first check the readability of the file's housing dir
- return $this->_throw(
- 'cant dread',
- {
- 'filename' => $path . SL . $file,
- 'dirname' => $path . SL,
- 'opts' => $opts,
- }
- ) unless (-r $path . SL);
-
- # now check the readability of the file itself
- return $this->_throw(
- 'cant fread',
- {
- 'filename' => $path . SL . $file,
- 'dirname' => $path . SL,
- 'opts' => $opts,
- }
- ) unless (-r $path . SL . $file);
-
- # if the file is a directory it will not be opened
- return $this->_throw(
- 'called open on a dir',
- {
- 'filename' => $path . SL . $file,
- 'opts' => $opts,
- }
- ) if -d $path . SL . $file;
-
- my($fsize) = -s $path . SL . $file;
-
- return $this->_throw(
- 'readlimit exceeded',
- {
- 'filename' => $path . SL . $file,
- 'size' => $fsize,
- 'opts' => $opts,
- }
- ) if ($fsize > $READLIMIT);
-
- # we need a unique filehandle
- do { $fh = int(rand(time)) . $$; $fh = eval('*' . 'LOAD_FILE' . $fh) }
- while fileno($fh);
-
- # localize the global output record separator so we can slurp it all
- # in one quick read. We fail if the filesize exceeds our limit.
- local($/);
-
- # open the file for reading (note the '<' syntax there) or fail with a
- # error message if our attempt to open the file was unsuccessful
- my($cmd) = '<' . $path . SL . $file;
-
- # lock file before I/O on platforms that support it
- if ($$opts{'--no-lock'} || $$this{'opts'}{'--no-lock'}) {
-
- # if you use the '--no-lock' option you are probably inefficient
- open($fh, $cmd) or return $this->_throw(
- 'bad open',
- {
- 'filename' => $path . SL . $file,
- 'mode' => $mode,
- 'exception' => $!,
- 'cmd' => $cmd,
- 'opts' => $opts,
- }
- );
- }
- else {
- open($fh, $cmd) or return $this->_throw(
- 'bad open',
- {
- 'filename' => $path . SL . $file,
- 'mode' => $mode,
- 'exception' => $!,
- 'cmd' => $cmd,
- 'opts' => $opts,
- }
- );
-
- $this->_seize($path . SL . $file, $fh);
- }
-
- # call binmode on binary files for portability accross platforms such
- # as MS flavor OS family
- CORE::binmode($fh) if (-B $path . SL . $file);
-
- # assign the content of the file to this lexically scoped scalar variable
- # (memory for *that* variable will be freed when execution leaves this
- # method / sub
- $content = <$fh>;
-
- if ($$opts{'--no-lock'} || $$this{'opts'}{'--no-lock'}) {
-
- # if execution gets here, you used the '--no-lock' option, and you
- # are probably inefficient
- close($fh) or return $this->_throw(
- 'bad close',
- {
- 'filename' => $path . SL . $file,
- 'mode' => $mode,
- 'exception' => $!,
- 'opts' => $opts,
- }
- );
- }
- else {
- # release shadow-ed locks on the file
- $this->_release($fh);
-
- close($fh) or return $this->_throw(
- 'bad close',
- {
- 'filename' => $path . SL . $file,
- 'mode' => $mode,
- 'exception' => $!,
- 'opts' => $opts,
- }
- );
- }
-
- # return an array of all lines in the file if the call to this method/
- # subroutine asked for an array eg- my(@file) = load_file('file');
- # otherwise, return a scalar value containing all of the file's content
- return(split(/$NL|\r|\n/o,$content)) if $opts->{'--as-lines'};
-
- $content;
-}
-
-
-# --------------------------------------------------------
-# File::Util::write_file()
-# --------------------------------------------------------
-sub write_file {
- my($this) = shift(@_);
- my($opts) = $this->shave_opts(\@_);
- my($in) = $this->coerce_array(@_);
- my($filename) = $in->{'file'} || $in->{'filename'} || '';
- my($content) = $in->{'content'} || '';
- my($mode) = $in->{'mode'} || 'write';
- my($bitmask) = _bitmaskify($in->{'bitmask'}) || 0777;
- my($path) = '';
- my(@dirs) = ();
-
- $path = $filename;
-
- local(*WRITE_FILE); $mode = 'trunc' if ($mode eq 'truncate');
-
- # if the call to this method didn't include a filename to which the caller
- # wants us to write, then complain about it
- return $this->_throw(
- 'no input',
- {
- 'meth' => 'write_file',
- 'missing' => 'a file name to create, write, or append',
- 'opts' => $opts,
- }
- ) unless length($filename);
-
- # if prospective filename contains 2+ dir separators in sequence then
- # this is a syntax error we need to whine about
- return $this->_throw(
- 'bad chars',
- {
- 'string' => $filename,
- 'purpose' => 'the name of a file or directory',
- 'opts' => $opts,
- }
- ) if ($filename =~ /(?:$DIRSPLIT){2,}/);
-
- # if the call to this method didn't include any data which the caller
- # wants us to write or append to the file, then complain about it
- return $this->_throw(
- 'no input',
- {
- 'meth' => 'write_file',
- 'missing' => 'the content you want to write or append',
- 'opts' => $opts,
- }
- ) if (
- (length($content) == 0)
- and
- ($mode ne 'trunc')
- and
- (!$EMPTY_WRITES_OK)
- and
- (!$opts->{'--empty-writes-OK'})
- );
-
- # remove any possible trailing directory seperator
- $filename =~ s/$DIRSPLIT$//;
-
- # check if file already exists in the form of a directory
- return $this->_throw(
- 'cant write_file on a dir',
- {
- 'filename' => $filename,
- 'opts' => $opts,
- }
- ) if (-d $filename);
-
- # determine existance of the file path, make directory(ies) for the
- # path if the full directory path doesn't exist
- @dirs = split(/$DIRSPLIT/, $filename);
-
- # if prospective file name has illegal chars then complain
- foreach (@dirs) {
- return $this->_throw(
- 'bad chars',
- {
- 'string' => $_,
- 'purpose' => 'the name of a file or directory',
- 'opts' => $opts,
- }
- ) if (!$this->valid_filename($_));
- }
-
- # make sure that open mode is a valid mode
- unless ($mode eq 'write' || $mode eq 'append' || $mode eq 'trunc') {
- return $this->_throw(
- 'bad openmode popen',
- {
- 'meth' => 'write_file',
- 'filename' => $filename,
- 'badmode' => $mode,
- 'opts' => $opts,
- }
- )
- }
-
- if (scalar(@dirs) > 0) { $filename = pop(@dirs); $path = join(SL, @dirs); }
-
- if (length($path) > 0) {
- $path = '.' . SL . $path if ($path !~ /(?:^\/)|(?:^\w\:)/o);
- }
- else { $path = '.'; }
-
- # create path preceding file if path doesn't exist
- $this->make_dir(
- $path,
- exists $in->{'dbitmask'} ? _bitmaskify($in->{'dbitmask'}) : 0777
- ) unless -e $path;
-
- my($openarg) = qq[$path$SL$filename];
-
- if (-e $openarg) {
- return $this->_throw(
- 'cant fwrite',
- {
- 'filename' => $openarg,
- 'dirname' => $path,
- 'opts' => $opts,
- }
- ) unless (-w $openarg);
- }
- else {
- # if file doesn't exist, the error is one of creation
- return $this->_throw(
- 'cant fcreate',
- {
- 'filename' => $openarg,
- 'dirname' => $path,
- 'opts' => $opts,
- }
- ) unless (-w $path . SL);
- }
-
- # if you use the '--no-lock' option you are probably inefficient
- if ($$opts{'--no-lock'} || !$USE_FLOCK) {
-
- # get open mode
- $mode = $$MODES{'popen'}{ $mode };
-
- # only non-existent files get bitmask arguments
- if (-e $openarg) {
- sysopen(WRITE_FILE, $openarg, eval($$MODES{'sysopen'}{ $mode })) or
- return $this->_throw(
- 'bad open',
- {
- 'filename' => $openarg,
- 'mode' => $mode,
- 'exception' => $!,
- 'cmd' => qq{$openarg, $$MODES{'sysopen'}{ $mode }},
- 'opts' => $opts,
- }
- );
- }
- else {
- sysopen(
- WRITE_FILE,
- $openarg,
- eval($$MODES{'sysopen'}{ $mode }),
- $bitmask
- ) or return $this->_throw(
- 'bad open',
- {
- 'filename' => $openarg,
- 'mode' => $mode,
- 'exception' => $!,
- 'cmd' => qq{$openarg, $$MODES{'sysopen'}{$mode}, $bitmask},
- 'opts' => $opts,
- }
- );
- }
- }
- else {
- # open read-only first to safely check if we can get a lock.
- if (-e $openarg) {
-
- open(WRITE_FILE, '<' . $openarg) or
- return $this->_throw(
- 'bad open',
- {
- 'filename' => $openarg,
- 'mode' => 'read',
- 'exception' => $!,
- 'cmd' => $mode . $openarg,
- 'opts' => $opts,
- }
- );
-
- # lock file before I/O on platforms that support it
- my($lockstat) = $this->_seize($openarg, *WRITE_FILE);
-
- return($lockstat) unless $lockstat;
-
- sysopen(WRITE_FILE, $openarg, eval($$MODES{'sysopen'}{ $mode }))
- or return $this->_throw(
- 'bad open',
- {
- 'filename' => $openarg,
- 'mode' => $mode,
- 'opts' => $opts,
- 'exception' => $!,
- 'cmd' => qq[$openarg, $$MODES{'sysopen'}{ $mode }],
- }
- );
- }
- else { # only non-existent files get bitmask arguments
- sysopen(
- WRITE_FILE,
- $openarg,
- eval($$MODES{'sysopen'}{ $mode }),
- $bitmask
- ) or return $this->_throw(
- 'bad open',
- {
- 'filename' => $openarg,
- 'mode' => $mode,
- 'opts' => $opts,
- 'exception' => $!,
- 'cmd' => qq{$openarg, $$MODES{'sysopen'}{$mode}, $bitmask},
- }
- );
-
- # lock file before I/O on platforms that support it
- my($lockstat) = $this->_seize($openarg, *WRITE_FILE);
-
- return($lockstat) unless $lockstat;
- }
-
- # now truncate
- if ($mode ne 'append') {
- truncate(WRITE_FILE,0) or return $this->_throw(
- 'bad systrunc',
- {
- 'filename' => $openarg,
- 'exception' => $!,
- 'opts' => $opts,
- }
- );
- }
- }
-
- CORE::binmode(WRITE_FILE) if $in->{'binmode'} || $opts->{'--binmode'};
-
- $in->{'content'}||=''; syswrite(WRITE_FILE, $in->{'content'});
-
- # release lock on the file
- unless ($$opts{'--no-lock'} || !$USE_FLOCK) { $this->_release(*WRITE_FILE) }
-
- close(WRITE_FILE) or
- return $this->_throw(
- 'bad close',
- {
- 'filename' => $openarg,
- 'mode' => $mode,
- 'exception' => $!,
- 'opts' => $opts,
- }
- );
-
- return(1);
-}
-
-
-# --------------------------------------------------------
-# %$File::Util::LOCKS
-# --------------------------------------------------------
-$_LOCKS->{'IGNORE'} = sub { $_[2] };
-$_LOCKS->{'ZERO'} = sub { 0 };
-$_LOCKS->{'UNDEF'} = sub { undef };
-$_LOCKS->{'NOBLOCKEX'} = sub {
- return $_[2] if flock($_[2], &Fcntl::LOCK_EX | &Fcntl::LOCK_NB); undef
-};
-$_LOCKS->{'NOBLOCKSH'} = sub {
- return $_[2] if flock($_[2], &Fcntl::LOCK_SH | &Fcntl::LOCK_NB); undef
-};
-$_LOCKS->{'BLOCKEX'} = sub {
- return $_[2] if flock($_[2], &Fcntl::LOCK_EX); undef
-};
-$_LOCKS->{'BLOCKSH'} = sub {
- return $_[2] if flock($_[2], &Fcntl::LOCK_SH); undef
-};
-$_LOCKS->{'WARN'} = sub {
- $_[0]->_throw(
- 'bad flock',
- {
- 'filename' => $_[1],
- 'exception' => $!,
- },
- '--as-warning',
- ); undef
-};
-$_LOCKS->{'FAIL'} = sub {
- $_[0]->_throw(
- 'bad flock',
- {
- 'filename' => $_[1],
- 'exception' => $!,
- },
- ); 0
-};
-
-
-# --------------------------------------------------------
-# File::Util::_seize()
-# --------------------------------------------------------
-sub _seize {
- my($this) = shift(@_); my($file) = shift(@_)||''; my($fh) = shift(@_)||'';
- my(@policy) = @ONLOCKFAIL;
- my($policy) = {};
-
- # seize filehandle, return it if lock is successful
-
- # forget seizing if system can't flock
- return($fh) if !$CAN_FLOCK;
-
- return($this->_throw(q{no file name passed to _seize.})) unless length $file;
- return($this->_throw(q{no handle passed to _seize.})) unless $fh;
-
- while (@policy) {
- my($fh) = &{ $_LOCKS->{ shift @policy } }($this,$file,$fh);
- return $fh if ($fh || !scalar @policy)
- }
-
- $fh;
-}
-
-
-# --------------------------------------------------------
-# File::Util::_release()
-# --------------------------------------------------------
-sub _release {
- my($this,$fh) = @_;
-
- return($this->_throw('not a filehandle.', {'argtype' => ref(\$fh||'')}))
- unless ($fh && ref(\$fh||'') eq 'GLOB');
-
- if ($CAN_FLOCK) { flock($fh, &Fcntl::LOCK_UN) } 1;
-}
-
-
-# --------------------------------------------------------
-# File::Util::valid_filename()
-# --------------------------------------------------------
-sub valid_filename {
- my($f) = myargs(@_);
-
- $f !~ /$ILLEGAL_CHR/ ? 1 : undef
-}
-
-
-# --------------------------------------------------------
-# File::Util::strip_path()
-# --------------------------------------------------------
-sub strip_path { my($f) = myargs(@_); pop @{['', split(/$DIRSPLIT/,$f)]}||'' }
-
-
-# --------------------------------------------------------
-# File::Util::line_count()
-# --------------------------------------------------------
-sub line_count {
- my($this,$file) = @_;
- my($buff) = '';
- my($lines) = 0;
- my($cmd) = '<' . $file;
-
- local(*LINES);
-
- open(LINES, $file) or
- return $this->_throw(
- 'bad open',
- {
- 'filename' => $file,
- 'mode' => 'read',
- 'exception' => $!,
- 'cmd' => $cmd,
- }
- );
-
- while (sysread(LINES, $buff, 4096)) {
- $lines += $buff =~ tr/\n//; $buff = '';
- }
-
- close(LINES); $lines;
-}
-
-
-# --------------------------------------------------------
-# File::Util::_bitmaskify()
-# --------------------------------------------------------
-sub _bitmaskify {
- # save users who mistakenly pass in string values when bitmasks are
- # required (bitmasks must always be octal numbers)
-
- my($bmsk) = @_;
-
- return unless (defined($bmsk) && length($bmsk));
-
- $bmsk == eval($bmsk) ? $bmsk : oct($bmsk);
-}
-
-
-# --------------------------------------------------------
-# File::Util::DESTROY(), end File::Util class definition
-# --------------------------------------------------------
-sub DESTROY {}
-1;
-
-__END__
-
-# --------------------------------------------------------
-# File::Util::bitmask()
-# --------------------------------------------------------
-sub bitmask {
- my($f) = myargs(@_);
-
- defined $f and -e $f ? sprintf('%04o',(stat($f))[2] & 0777) : undef
-}
-
-
-# --------------------------------------------------------
-# File::Util::can_flock()
-# --------------------------------------------------------
-sub can_flock { $CAN_FLOCK }
-
-
-# File::Util::--------------------------------------------
-# can_read(), can_write()
-# --------------------------------------------------------
-sub can_read { my($f) = myargs(@_); defined $f ? -r $f : undef }
-sub can_write { my($f) = myargs(@_); defined $f ? -w $f : undef }
-
-
-# --------------------------------------------------------
-# File::Util::created()
-# --------------------------------------------------------
-sub created {
- my($f) = myargs(@_);
-
- defined $f and -e $f ? $^T - ((-M $f) * 60 * 60 * 24) : undef
-}
-
-
-# --------------------------------------------------------
-# File::Util::ebcdic()
-# --------------------------------------------------------
-sub ebcdic { $EBCDIC }
-
-
-# --------------------------------------------------------
-# File::Util::escape_filename()
-# --------------------------------------------------------
-sub escape_filename {
- my($opts) = shave_opts(\@_);
- my($file,$escape,$also) = myargs(@_);
-
- return '' unless defined $file;
-
- $escape = '_' if !defined($escape);
-
- $file = strip_path($file) if $opts->{'--strip-path'};
-
- if ($also) { $file =~ s/\Q$also\E/$escape/g }
-
- $file =~ s/$ILLEGAL_CHR/$escape/g;
- $file =~ s/$DIRSPLIT/$escape/g;
-
- $file
-}
-
-
-# --------------------------------------------------------
-# File::Util::existent()
-# --------------------------------------------------------
-sub existent { my($f) = myargs(@_); defined $f ? -e $f : undef }
-
-
-# --------------------------------------------------------
-# File::Util::touch()
-# --------------------------------------------------------
-sub touch {
- my($this) = shift(@_); my($opts) = $this->shave_opts(\@_);
- my($in) = $this->coerce_array(@_); my(@dirs) = ();
- my($file) = ''; my($path) = '';
- my($mode) = 'read';
-
- $file = shift(@_)||'';
-
- @dirs = split(/$DIRSPLIT/, $file);
-
- if (scalar(@dirs) > 0) {
-
- $file = pop(@dirs); $path = join(SL, @dirs);
- }
-
- if (length($path) > 0) {
- $path = '.' . SL . $path if ($path !~ /(?:^\/)|(?:^\w\:)/o);
- }
- else { $path = '.'; }
-
- return $this->_throw(
- 'no input',
- {
- 'meth' => 'touch',
- 'missing' => 'a file name or file handle reference',
- 'opts' => $opts,
- }
- ) if (length($path . SL . $file) == 0);
-
- # see if the file exists already and is a directory
- return $this->_throw(
- 'cant touch on a dir',
- {
- 'filename' => $path . SL . $file,
- 'dirname' => $path . SL,
- 'opts' => $opts,
- }
- ) if (-e $path . SL . $file && -d $path . SL . $file);
-
- # if the path doesn't exist, make it
- $this->make_dir($path) unless -e $path . SL;
-
- # it's good to know beforehand whether or not we have permission to open
- # and read from this file allowing us to handle such an exception before
- # it handles us.
-
- # first check the readability of the file's housing dir
- return $this->_throw(
- 'cant dread',
- {
- 'filename' => $path . SL . $file,
- 'dirname' => $path . SL,
- 'opts' => $opts,
- }
- ) unless (-r $path . SL);
-
- # now check the writability of the file itself
- return $this->_throw(
- 'cant fwrite',
- {
- 'filename' => $path . SL . $file,
- 'dirname' => $path . SL,
- 'opts' => $opts,
- }
- ) if (-e $path . SL . $file && !-w $path . SL . $file);
-
- # create the file if it doesn't exist (like the *nix touch command does)
- $this->write_file(
- 'filename' => $path . SL . $file,
- 'content' => '',
- '--empty-writes-OK'
- ) if !-e $path . SL . $file;
-
- my($now) = time();
-
- # return
- return utime $now, $now, $path . SL . $file;
-}
-
-
-# --------------------------------------------------------
-# File::Util::file_type()
-# --------------------------------------------------------
-sub file_type {
- my($f) = myargs(@_);
-
- return undef unless defined $f and -e $f;
-
- my(@ret) = ();
-
- push @ret, 'PLAIN' if (-f $f); push @ret, 'TEXT' if (-T $f);
- push @ret, 'BINARY' if (-B $f); push @ret, 'DIRECTORY' if (-d $f);
- push @ret, 'SYMLINK' if (-l $f); push @ret, 'PIPE' if (-p $f);
- push @ret, 'SOCKET' if (-S $f); push @ret, 'BLOCK' if (-b $f);
- push @ret, 'CHARACTER' if (-c $f); push @ret, 'TTY' if (-t $f);
-
- push(@ret,'Error: cannot determine file type') unless @ret; @ret
-}
-
-
-# --------------------------------------------------------
-# File::Util::flock_rules()
-# --------------------------------------------------------
-sub flock_rules {
- my($this) = shift(@_);
- my(@rules) = myargs(@_);
-
- return @ONLOCKFAIL unless defined scalar @rules;
-
- my(%valid) = qw/
- NOBLOCKEX NOBLOCKEX
- NOBLOCKSH NOBLOCKSH
- BLOCKEX BLOCKEX
- BLOCKSH BLOCKSH
- FAIL FAIL
- WARN WARN
- IGNORE IGNORE
- UNDEF UNDEF
- ZERO ZERO /;
-
- map {
- return $this->_throw('bad flock rules', { 'bad' => $_, 'all' => \@rules })
- unless exists $valid{ $_ }
- } @rules;
-
- @ONLOCKFAIL = @rules;
-
- @ONLOCKFAIL
-}
-
-
-# --------------------------------------------------------
-# File::Util::isbin()
-# --------------------------------------------------------
-sub isbin { my($f) = myargs(@_); defined $f ? -B $f : undef }
-
-
-# --------------------------------------------------------
-# File::Util::last_access()
-# --------------------------------------------------------
-sub last_access {
- my($f) = myargs(@_); $f ||= '';
-
- return undef unless -e $f;
-
- # return the last accessed time of $f
- $^T - ((-A $f) * 60 * 60 * 24)
-}
-
-
-# --------------------------------------------------------
-# File::Util::last_modified()
-# --------------------------------------------------------
-sub last_modified {
- my($f) = myargs(@_); $f ||= '';
-
- return undef unless -e $f;
-
- # return the last modified time of $f
- $^T - ((-M $f) * 60 * 60 * 24)
-}
-
-
-# --------------------------------------------------------
-# File::Util::last_changed()
-# --------------------------------------------------------
-sub last_changed {
- my($f) = myargs(@_); $f ||= '';
-
- return undef unless -e $f;
-
- # return the last changed time of $f
- $^T - ((-C $f) * 60 * 60 * 24)
-}
-
-
-# --------------------------------------------------------
-# File::Util::load_dir()
-# --------------------------------------------------------
-sub load_dir {
- my($this) = shift(@_); my($opts) = $this->shave_opts(\@_);
- my($dir) = shift(@_)||''; my(@files) = ();
- my($dir_hash) = {}; my($dir_list) = [];
-
- return $this->_throw
- (
- 'no input',
- {
- 'meth' => 'load_dir',
- 'missing' => 'a directory name',
- 'opts' => $opts,
- }
- )
- unless length($dir);
-
- @files = $this->list_dir($dir,'--files-only');
-
- # map the content of each file into a hash key-value element where the
- # key name for each file is the name of the file
- if (!$opts->{'--as-list'} and !$opts->{'--as-listref'}) {
-
- foreach (@files) {
-
- $dir_hash->{ $_ } = $this->load_file( $dir . SL . $_ );
- }
-
- return($dir_hash);
- }
- else {
-
- foreach (@files) {
-
- push(@{$dir_list},$this->load_file( $dir . SL . $_ ));
- }
-
- return($dir_list) if ($opts->{'--as-listref'}); return(@{$dir_list});
- }
-
- $dir_hash;
-}
-
-
-# --------------------------------------------------------
-# File::Util::make_dir()
-# --------------------------------------------------------
-sub make_dir {
- my($this) = shift(@_);
- my($opts) = $this->shave_opts(\@_);
- my($dir,$bitmask) = @_; $bitmask = _bitmaskify($bitmask) || 0777;
-
- if ($$opts{'--if-not-exists'}) {
- if (-e $dir) {
- return $dir if -d $dir;
-
- return $this->_throw(
- 'called mkdir on a file',
- {
- 'filename' => $dir,
- 'dirname' => join(SL,(split(/$DIRSPLIT/,$dir))[0 .. -1]) . SL
- }
- );
- }
- }
- else {
- if (-e $dir) {
- return $this->_throw(
- 'called mkdir on a file',
- {
- 'filename' => $dir,
- 'dirname' => join(SL,(split(/$DIRSPLIT/,$dir))[0 .. -1]) . SL
- }
- ) unless -d $dir;
-
- return $this->_throw(
- 'make_dir target exists',
- {
- 'dirname' => $dir,
- 'filetype' => [ $this->file_type($dir) ],
- }
- );
- }
- }
-
- # if the call to this method didn't include a directory name to create,
- # then complain about it
- return $this->_throw(
- 'no input',
- {
- 'meth' => 'make_dir',
- 'missing' => 'a directory name',
- }
- ) unless (defined($dir) && length($dir));
-
- # if prospective directory name contains 2+ dir separators in sequence then
- # this is a syntax error we need to whine about
- return $this->_throw(
- 'bad chars',
- {
- 'string' => $dir,
- 'purpose' => 'the name of a directory',
- }
- ) if ($dir =~ /$DIRSPLIT{2,}/);
-
- $dir =~ s/$DIRSPLIT$// unless $dir eq $DIRSPLIT;
-
- my(@dirs_in_path) = split(/$DIRSPLIT/, $dir);
-
- # for absolute pathnames
- if (substr($dir,0,1) eq SL) {
- $dirs_in_path[0] = SL;
- }
-
- for (my($i) = 0; $i < scalar @dirs_in_path; ++$i) {
- next if $i == 0 && $dirs_in_path[$i] eq SL;
-
- # if prospective directory name contains illegal chars then complain
- return $this->_throw(
- 'bad chars',
- {
- 'string' => $dirs_in_path[$i],
- 'purpose' => 'the name of a directory',
- }
- ) unless $this->valid_filename($dirs_in_path[$i])
- }
-
- # qualify each subdir in @dirs_in_path by prepending its preceeding dir
- # names to it. Above, "/foo/bar/baz" becomes ("/", "foo", "bar", "baz")
- # and below it becomes ("/", "/foo", "/foo/bar", "/foo/bar/baz")
-
- if (scalar(@dirs_in_path) > 1) {
- for (my($depth) = 1; $depth < scalar @dirs_in_path; ++$depth) {
- if ($dirs_in_path[$depth-1] eq SL) {
- $dirs_in_path[$depth] = SL . $dirs_in_path[$depth]
- }
- else {
- $dirs_in_path[$depth] = join(SL, @dirs_in_path[($depth-1)..$depth])
- }
- }
- }
-
- my($i) = 0;
-
- foreach (@dirs_in_path) {
- my($dir) = $_;
- my($up) = ($i > 0) ? $dirs_in_path[$i-1] : '..';
-
- ++$i;
-
- if (-e $dir and !-d $dir) {
- return $this->_throw(
- 'called mkdir on a file',
- {
- 'filename' => $dir,
- 'dirname' => $up . SL,
- }
- );
- }
-
- next if -e $dir;
-
- # it's good to know beforehand whether or not we have permission to
- # create dirs here, which allows us to handle such an exception
- # before it handles us.
- return $this->_throw(
- 'cant dcreate',
- {
- 'dirname' => $dir,
- 'parentd' => $up,
- }
- ) unless -w $up;
-
- mkdir($dir, $bitmask) or
- return $this->_throw(
- 'bad make_dir',
- {
- 'exception' => $!,
- 'dirname' => $dir,
- 'bitmask' => $bitmask,
- }
- );
- }
-
- $dir;
-}
-
-
-# --------------------------------------------------------
-# File::Util::max_dives()
-# --------------------------------------------------------
-sub max_dives {
- my($arg) = myargs(@_);
-
- if (defined($arg)) {
- return $this->_throw('bad maxdives') if $arg !~ /\D/o;
- $MAXDIVES = $arg;
- }
-
- $MAXDIVES
-}
-
-
-# --------------------------------------------------------
-# File::Util::readlimt()
-# --------------------------------------------------------
-sub readlimit {
- my($arg) = myargs(@_);
-
- if (defined($arg)) {
- return $this->_throw
- (
- 'bad readlimit',
- {
- 'bad' => $arg,
- }
- ) if $arg !~ /\D/o;
-
- $READLIMIT = $arg;
- }
-
- $READLIMIT
-}
-
-
-# --------------------------------------------------------
-# File::Util::needs_binmode()
-# --------------------------------------------------------
-sub needs_binmode { $NEEDS_BINMODE }
-
-
-# --------------------------------------------------------
-# File::Util::open_handle()
-# --------------------------------------------------------
-sub open_handle {
- my($this) = shift(@_);
- my($opts) = $this->shave_opts(\@_);
- my($in) = $this->coerce_array(@_);
- my($filename) = $in->{'file'} || $in->{'filename'} || '';
- my($mode) = $in->{'mode'} || 'write';
- my($bitmask) = _bitmaskify($in->{'bitmask'}) || 0777;
- my($fh) = undef;
- my($path) = '';
- my(@dirs) = ();
-
- $path = $filename;
-
- # begin user input validation/sanitation sequence
-
- # if the call to this method didn't include a filename to which the caller
- # wants us to write, then complain about it
- return $this->_throw(
- 'no input',
- {
- 'meth' => 'open_handle',
- 'missing' => 'a file name to create, write, read/write, or append',
- 'opts' => $opts,
- }
- ) unless length($filename);
-
- # if prospective filename contains 2+ dir separators in sequence then
- # this is a syntax error we need to whine about
- return $this->_throw(
- 'bad chars',
- {
- 'string' => $filename,
- 'purpose' => 'the name of a file or directory',
- 'opts' => $opts,
- }
- ) if ($filename =~ /(?:$DIRSPLIT){2,}/);
-
- # remove trailing directory seperator
- $filename =~ s/$DIRSPLIT$//;
-
- # determine existance of the file path, make directory(ies) for the
- # path if the full directory path doesn't exist
- @dirs = split(/$DIRSPLIT/, $filename);
-
- # if prospective file name has illegal chars then complain
- foreach (@dirs) {
- return $this->_throw(
- 'bad chars',
- {
- 'string' => $_,
- 'purpose' => 'the name of a file or directory',
- 'opts' => $opts,
- }
- ) if (!$this->valid_filename($_));
- }
-
- # make sure that open mode is a valid mode
- if (
- !exists($opts->{'--use-sysopen'}) &&
- !defined($opts->{'--use-sysopen'})
- ) {
- # native Perl open modes
- unless (
- exists($$MODES{'popen'}{ $mode }) &&
- defined($$MODES{'popen'}{ $mode })
- ) {
- return $this->_throw(
- 'bad openmode popen',
- {
- 'meth' => 'open_handle',
- 'filename' => $filename,
- 'badmode' => $mode,
- 'opts' => $opts,
- }
- )
- }
- }
- else {
- # system open modes
- unless (
- exists($$MODES{'sysopen'}{ $mode }) &&
- defined($$MODES{'sysopen'}{ $mode })
- ) {
- return $this->_throw(
- 'bad openmode sysopen',
- {
- 'meth' => 'open_handle',
- 'filename' => $filename,
- 'badmode' => $mode,
- 'opts' => $opts,
- }
- )
- }
- }
-
- if (scalar(@dirs) > 0) { $filename = pop(@dirs); $path = join(SL, @dirs); }
-
- if (length($path) > 0) {
- $path = '.' . SL . $path if ($path !~ /(?:^\/)|(?:^\w\:)/o);
- }
- else { $path = '.'; }
-
- # create path preceding file if path doesn't exist
- $this->make_dir(
- $path,
- exists $in->{'dbitmask'} ? _bitmaskify($in->{'dbitmask'}) : 0777
- ) unless -e $path;
-
- my($openarg) = qq[$path$SL$filename];
-
- # sanity checks based on requested mode
- if (
- $mode eq 'write' ||
- $mode eq 'append' ||
- $mode eq 'rwcreate' ||
- $mode eq 'rwclobber' ||
- $mode eq 'rwappend'
- ) {
- # Check whether or not we have permission to open and perform writes
- # on this file.
-
- if (-e $openarg) {
- return $this->_throw(
- 'cant fwrite',
- {
- 'filename' => $openarg,
- 'dirname' => $path,
- 'opts' => $opts,
- }
- ) unless (-w $openarg);
- }
- else {
- # If file doesn't exist and the path isn't writable, the error is
- # one of unallowed creation.
- return $this->_throw(
- 'cant fcreate',
- {
- 'filename' => $openarg,
- 'dirname' => $path,
- 'opts' => $opts,
- }
- ) unless (-w $path . SL);
- }
- }
- elsif ($mode eq 'read' || $mode eq 'rwupdate') {
- # Check whether or not we have permission to open and perform reads
- # on this file, starting with file's housing directory.
- return $this->_throw(
- 'cant dread',
- {
- 'filename' => $path . SL . $filename,
- 'dirname' => $path,
- 'opts' => $opts,
- }
- ) unless (-r $path . SL);
-
- # Seems obvious, but we can't read non-existent files
- return $this->_throw(
- 'cant fread not found',
- {
- 'filename' => $path . SL . $filename,
- 'dirname' => $path,
- 'opts' => $opts,
- }
- ) unless (-e $path . SL . $filename);
-
- # Check the readability of the file itself
- return $this->_throw(
- 'cant fread',
- {
- 'filename' => $path . SL . $filename,
- 'dirname' => $path,
- 'opts' => $opts,
- }
- ) unless (-r $path . SL . $filename);
- }
- else {
- return $this->_throw(
- 'no input',
- {
- 'meth' => 'open_handle',
- 'missing' => q{a valid IO mode. (eg- 'read', 'write'...)},
- 'opts' => $opts,
- }
- )
- }
- # input validation sequence finished
-
- # we need a unique filehandle
- do { $fh = int(rand(time)) . $$; $fh = eval('*' . 'OPEN_TO_FH' . $fh) }
- while ( fileno($fh) );
-
- # if you use the '--no-lock' option you are probably inefficient
- if ($$opts{'--no-lock'} || !$USE_FLOCK) {
- if (
- !exists($opts->{'--use-sysopen'}) &&
- !defined($opts->{'--use-sysopen'})
- ) { # perl open
- # get open mode
- $mode = $$MODES{'popen'}{ $mode };
-
- open($fh, $mode . $openarg) or
- return $this->_throw(
- 'bad open',
- {
- 'filename' => $openarg,
- 'mode' => $mode,
- 'exception' => $!,
- 'cmd' => $mode . $openarg,
- 'opts' => $opts,
- }
- );
- }
- else { # sysopen
- # get open mode
- $mode = $$MODES{'sysopen'}{ $mode };
-
- sysopen($fh, $openarg, eval($$MODES{'sysopen'}{ $mode })) or
- return $this->_throw(
- 'bad open',
- {
- 'filename' => $openarg,
- 'mode' => $mode,
- 'exception' => $!,
- 'cmd' => qq{$openarg, $$MODES{'sysopen'}{ $mode }},
- 'opts' => $opts,
- }
- );
- }
- }
- else {
- if (
- !exists($opts->{'--use-sysopen'}) &&
- !defined($opts->{'--use-sysopen'})
- ) { # perl open
- # open read-only first to safely check if we can get a lock.
- if (-e $openarg) {
-
- open($fh, '<' . $openarg) or
- return $this->_throw(
- 'bad open',
- {
- 'filename' => $openarg,
- 'mode' => 'read',
- 'exception' => $!,
- 'cmd' => $mode . $openarg,
- 'opts' => $opts,
- }
- );
-
- # lock file before I/O on platforms that support it
- my($lockstat) = $this->_seize($openarg, $fh);
-
- return($lockstat) unless $lockstat;
-
- if ($mode ne 'read') {
- open($fh, $$MODES{'popen'}{ $mode } . $openarg) or
- return $this->_throw(
- 'bad open',
- {
- 'exception' => $!,
- 'filename' => $openarg,
- 'mode' => $mode,
- 'opts' => $opts,
- 'cmd' => $$MODES{'popen'}{ $mode } . $openarg,
- }
- );
- }
- }
- else {
- open($fh, $$MODES{'popen'}{ $mode } . $openarg) or
- return $this->_throw(
- 'bad open',
- {
- 'exception' => $!,
- 'filename' => $openarg,
- 'mode' => $mode,
- 'opts' => $opts,
- 'cmd' => $$MODES{'popen'}{ $mode } . $openarg,
- }
- );
-
- # lock file before I/O on platforms that support it
- my($lockstat) = $this->_seize($openarg, $fh);
-
- return($lockstat) unless $lockstat;
- }
- }
- else { # sysopen
- # open read-only first to safely check if we can get a lock.
- if (-e $openarg) {
-
- open($fh, '<' . $openarg) or
- return $this->_throw(
- 'bad open',
- {
- 'filename' => $openarg,
- 'mode' => 'read',
- 'exception' => $!,
- 'cmd' => $mode . $openarg,
- 'opts' => $opts,
- }
- );
-
- # lock file before I/O on platforms that support it
- my($lockstat) = $this->_seize($openarg, $fh);
-
- return($lockstat) unless $lockstat;
-
- sysopen($fh, $openarg, eval($$MODES{'sysopen'}{ $mode }))
- or return $this->_throw(
- 'bad open',
- {
- 'filename' => $openarg,
- 'mode' => $mode,
- 'opts' => $opts,
- 'exception' => $!,
- 'cmd' => qq{$openarg, $$MODES{'sysopen'}{ $mode }},
- }
- );
- }
- else { # only non-existent files get bitmask arguments
- sysopen(
- $fh,
- $openarg,
- eval($$MODES{'sysopen'}{ $mode }),
- $bitmask
- ) or return $this->_throw(
- 'bad open',
- {
- 'filename' => $openarg,
- 'mode' => $mode,
- 'opts' => $opts,
- 'exception' => $!,
- 'cmd' => qq{$openarg, $$MODES{'sysopen'}{$mode}, $bitmask},
- }
- );
-
- # lock file before I/O on platforms that support it
- my($lockstat) = $this->_seize($openarg, $fh);
-
- return($lockstat) unless $lockstat;
- }
- }
- }
-
- # call binmode on the filehandle if it was requested
- CORE::binmode($fh) if $in->{'binmode'} || $opts->{'--binmode'};
-
- # return file handle reference to the caller
- $fh;
-}
-
-
-# --------------------------------------------------------
-# File::Util::unlock_open_handle()
-# --------------------------------------------------------
-sub unlock_open_handle {
- my($this,$fh) = @_;
-
- return 1 if !$USE_FLOCK;
-
- return($this->_throw('not a filehandle.', {'argtype' => ref(\$fh||'')}))
- unless ($fh && ref(\$fh||'') eq 'GLOB');
-
- if ($CAN_FLOCK) { return flock($fh, &Fcntl::LOCK_UN) } 1;
-}
-
-
-# --------------------------------------------------------
-# File::Util::return_path()
-# --------------------------------------------------------
-sub return_path { my($f) = myargs(@_); $f =~ s/(^.*)$DIRSPLIT.*/$1/o; $f }
-
-
-# --------------------------------------------------------
-# File::Util::size()
-# --------------------------------------------------------
-sub size { my($f) = myargs(@_); $f ||= ''; return undef unless -e $f; -s $f }
-
-
-# --------------------------------------------------------
-# File::Util::trunc()
-# --------------------------------------------------------
-sub trunc { $_[0]->write_file('mode' => 'trunc', 'file' => $_[1]) }
-
-
-# --------------------------------------------------------
-# File::Util::use_flock()
-# --------------------------------------------------------
-sub use_flock {
- my($arg) = myargs(@_);
-
- if (defined($arg)) { $USE_FLOCK = $arg }
-
- $USE_FLOCK
-}
-
-
-# --------------------------------------------------------
-# File::Util::_throw
-# --------------------------------------------------------
-sub _throw {
- my($this) = shift(@_); my($opts) = $this->shave_opts(\@_);
- my(%fatal_rules) = ();
-
- # fatalality-handling rules passed to the failing caller trump the
- # rules set up in the attributes of the object; the mechanism below
- # also allows for the implicit handling of '--fatals-are-fatal'
- map { $fatal_rules{ $_ } = $_ }
- grep(/^--fatals/o, values %$opts);
-
- unless (scalar keys %fatal_rules) {
- map { $fatal_rules{ $_ } = $_ }
- grep(/^--fatals/o, keys %{ $this->{'opts'} })
- }
-
- return(0) if $fatal_rules{'--fatals-as-status'};
-
- $this->{'expt'}||={};
-
- unless (UNIVERSAL::isa($this->{'expt'},'Exception::Handler')) {
- require Exception::Handler;
- $this->{'expt'} = Exception::Handler->new();
- }
-
- my($error) = ''; my($in) = {};
-
- if (@_ == 1) {
-
- if (defined($_[0])) { $error = 'plain error'; goto PLAIN_ERRORS }
- }
- else { $error = shift(@_) || 'empty error' }
-
- $in = shift(@_)||{}; $in->{'_pak'} = __PACKAGE__;
-
- map { $_ = defined($_) ? $_ : 'undefined value' } keys(%$in);
-
- PLAIN_ERRORS:
-
- my($bad_news) =
- CORE::eval
- (
- q{<<__ERRORBLOCK__}
- . &NL . &_errors($error)
- . &NL . q{__ERRORBLOCK__}
- );
-
-## for debugging only
-# if ($@) { return $this->{'expt'}->trace($@) }
-
- if ($fatal_rules{'--fatals-as-warning'}) {
-
- warn($this->{'expt'}->trace(($@ || $bad_news))) and return
- }
- elsif ( $fatal_rules{'--fatals-as-errmsg'} || $opts->{'--return'}) {
-
- return($this->{'expt'}->trace(($@ || $bad_news)))
- }
-
- foreach (keys(%{$in})) {
-
- next if ($_ eq 'opts');
-
- $bad_news .= qq[ARG $_ = $in->{$_}] . $NL;
- }
-
- if ($in->{'opts'}) {
-
- foreach (keys(%{$$in{'opts'}})) {
-
- $_ = (defined($_)) ? $_ : 'empty value';
-
- $bad_news .= qq[OPT $_] . $NL;
- }
- }
-
- warn($this->{'expt'}->trace(($@ || $bad_news))) if ($opts->{'--warn-also'});
-
- $this->{'expt'}->fail(($@ || $bad_news));
-
- '';
-}
-
-
-#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#
-# ERROR MESSAGES
-#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#
-sub _errors {
- use vars qw($EBL $EBR);
- ($EBL,$EBR) = (chr(187), chr(171));
- ($EBL,$EBR) = ('{','}') if ($OS eq 'DOS');
- my($error_thrown) = shift(@_);
-
- # begin long table of helpful diag error messages
- my(%error_msg_table) = (
-# NO SUCH FILE
-'no such file' => <<'__bad_open__',
-$in->{'_pak'} can't open
- $EBL$in->{'filename'}$EBR
-because no such file or directory exists.
-
-Origin: This is *most likely* due to human error.
-Solution: Cannot diagnose. A human must investigate the problem.
-__bad_open__
-
-
-# BAD FLOCK RULE POLICY
-'bad flock rules' => <<'__bad_lockrules__',
-Invalid file locking policy can not be implemented. $in->{'_pak'}::flock_rules
-does not accept one or more of the policy keywords passed to this method.
-
- Invalid Policy specified: $EBL@{[
- join ' ', map { '[undef]' unless defined $_ } @{ $in->{'all'} } ]}$EBR
-
- flock_rules policy in effect before invalid policy failed:
- $EBL@ONLOCKFAIL$EBR
-
- Proper flock_rules policy includes one or more of the following recognized
- keywords specified in order of precedence:
- BLOCK waits to try getting an exclusive lock
- FAIL dies with stack trace
- WARN warn()s about the error with a stack trace
- IGNORE ignores the failure to get an exclusive lock
- UNDEF returns undef
- ZERO returns 0
-
-Origin: This is a human error.
-Solution: A human must fix the programming flaw.
-__bad_lockrules__
-
-
-# CAN'T READ FILE - PERMISSIONS
-'cant fread' => <<'__cant_read__',
-Permissions conflict. $in->{'_pak'} can't read the contents of this file:
- $EBL$in->{'filename'}$EBR
-
-Due to insufficient permissions, the system has denied Perl the right to
-view the contents of this file. It has a bitmask of: (octal number)
- $EBL@{[ sprintf('%04o',(stat($in->{'filename'}))[2] & 0777) ]}$EBR
-
- The directory housing it has a bitmask of: (octal number)
- $EBL@{[ sprintf('%04o',(stat($in->{'dirname'}))[2] & 0777) ]}$EBR
-
- Current flock_rules policy:
- $EBL@ONLOCKFAIL$EBR
-
-Origin: This is *most likely* due to human error. External system errors
- can occur however, but this doesn't have to do with $in->{'_pak'}.
-Solution: A human must fix the conflict by adjusting the file permissions
- of directories where a program asks $in->{'_pak'} to perform I/O.
- Try using Perl's chmod command, or the native system chmod()
- command from a shell.
-__cant_read__
-
-
-# CAN'T READ FILE - NOT EXISTENT
-'cant fread not found' => <<'__cant_read__',
-File not found. $in->{'_pak'} can't read the contents of this file:
- $EBL$in->{'filename'}$EBR
-
-The file specified does not exist. It can not be opened or read from.
-
-Origin: This is *most likely* due to human error. External system errors
- can occur however, but this doesn't have to do with $in->{'_pak'}.
-Solution: A human must investigate why the application tried to open a
- non-existent file, and/or why the file is expected to exist and
- is not found.
-__cant_read__
-
-
-# CAN'T CREATE FILE - PERMISSIONS
-'cant fcreate' => <<'__cant_write__',
-Permissions conflict. $in->{'_pak'} can't create this file:
- $EBL$in->{'filename'}$EBR
-
-$in->{'_pak'} can't create this file because the system has denied Perl
-the right to create files in the parent directory.
-
- The -e test returns $EBL@{[-e $in->{'dirname'} ]}$EBR for the directory.
- The -r test returns $EBL@{[-r $in->{'dirname'} ]}$EBR for the directory.
- The -R test returns $EBL@{[-R $in->{'dirname'} ]}$EBR for the directory.
- The -w test returns $EBL@{[-w $in->{'dirname'} ]}$EBR for the directory
- The -W test returns $EBL@{[-w $in->{'dirname'} ]}$EBR for the directory
-
- Parent directory: (path may be relative and/or redundant)
- $EBL$in->{'dirname'}$EBR
-
- Parent directory has a bitmask of: (octal number)
- $EBL@{[ sprintf('%04o',(stat($in->{'dirname'}))[2] & 0777) ]}$EBR
-
- Current flock_rules policy:
- $EBL@ONLOCKFAIL$EBR
-
-Origin: This is *most likely* due to human error. External system errors
- can occur however, but this doesn't have to do with $in->{'_pak'}.
-Solution: A human must fix the conflict by adjusting the file permissions
- of directories where a program asks $in->{'_pak'} to perform I/O.
- Try using Perl's chmod command, or the native system chmod()
- command from a shell.
-__cant_write__
-
-
-# CAN'T WRITE TO FILE - EXISTS AS DIRECTORY
-'cant write_file on a dir' => <<'__bad_writefile__',
-$in->{'_pak'} can't write to the specified file because it already exists
-as a directory.
- $EBL$in->{'filename'}$EBR
-
-Origin: This is a human error.
-Solution: Resolve naming issue between the existent directory and the file
- you wish to create/write/append.
-__bad_writefile__
-
-
-# CAN'T TOUCH A FILE - EXISTS AS DIRECTORY
-'cant touch on a dir' => <<'__bad_touchfile__',
-$in->{'_pak'} can't touch the specified file because it already exists
-as a directory.
- $EBL$in->{'filename'}$EBR
-
-Origin: This is a human error.
-Solution: Resolve naming issue between the existent directory and the file
- you wish to touch.
-__bad_touchfile__
-
-
-# CAN'T WRITE TO FILE
-'cant fwrite' => <<'__cant_write__',
-Permissions conflict. $in->{'_pak'} can't write to this file:
- $EBL$in->{'filename'}$EBR
-
-Due to insufficient permissions, the system has denied Perl the right
-to modify the contents of this file. It has a bitmask of: (octal number)
- $EBL@{[ sprintf('%04o',(stat($in->{'filename'}))[2] & 0777) ]}$EBR
-
- Parent directory has a bitmask of: (octal number)
- $EBL@{[ sprintf('%04o',(stat($in->{'dirname'}))[2] & 0777) ]}$EBR
-
- Current flock_rules policy:
- $EBL@ONLOCKFAIL$EBR
-
-Origin: This is *most likely* due to human error. External system errors
- can occur however, but this doesn't have to do with $in->{'_pak'}.
-Solution: A human must fix the conflict by adjusting the file permissions
- of directories where a program asks $in->{'_pak'} to perform I/O.
- Try using Perl's chmod command, or the native system chmod()
- command from a shell.
-__cant_write__
-
-
-# BAD OPEN MODE - PERL
-'bad openmode popen' => <<'__bad_openmode__',
-Illegal mode specified for file open. $in->{'_pak'} can't open this file:
- $EBL$in->{'filename'}$EBR
-
-When calling $in->{'_pak'}::$in->{'meth'}() you specified that the file
-opened in this I/O operation should be opened in $EBL$in->{'badmode'}$EBR
-but that is not a recognized open mode.
-
-Supported open modes for $in->{'_pak'}::write_file() are:
- write - open the file in write mode, creating it if necessary, and
- overwriting any existing contents of the file.
- append - open the file in append mode
-
-Supported open modes for $in->{'_pak'}::open_handle() are the same as above, but
-also include the following:
- read - open the file in read-only mode
-
- (and if the --use-sysopen flag is used):
- rwcreate - open the file for update (read+write), creating it if necessary
- rwupdate - open the file for update (read+write). Causes fatal error if
- the file doesn't yet exist
- rwappend - open the file for update in append mode
- rwclobber - open the file for update, erasing all contents (truncating,
- i.e- "clobbering" the file first)
-
-Origin: This is a human error.
-Solution: A human must fix the programming flaw by specifying the desired
- open mode from the list above.
-__bad_openmode__
-
-
-# BAD OPEN MODE - SYSOPEN
-'bad openmode sysopen' => <<'__bad_openmode__',
-Illegal mode specified for file sysopen. $in->{'_pak'} can't sysopen this file:
- $EBL$in->{'filename'}$EBR
-
-When calling $in->{'_pak'}::$in->{'meth'}() you specified that the file
-opened in this I/O operation should be sysopen()'d in $EBL$in->{'badmode'}$EBR
-but that is not a recognized open mode.
-
-Supported open modes for $in->{'_pak'}::write_file() are:
- write - open the file in write mode, creating it if necessary, and
- overwriting any existing contents of the file.
- append - open the file in append mode
-
-Supported open modes for $in->{'_pak'}::open_handle() are the same as above, but
-also include the following:
- read - open the file in read-only mode
-
- (and if the --use-sysopen flag is used, as the application JUST did):
- rwcreate - open the file for update (read+write), creating it if necessary
- rwupdate - open the file for update (read+write). Causes fatal error if
- the file doesn't yet exist
- rwappend - open the file for update in append mode
- rwclobber - open the file for update, erasing all contents (truncating,
- i.e- "clobbering" the file first)
-
-Origin: This is a human error.
-Solution: A human must fix the programming flaw by specifying the desired
- sysopen mode from the list above.
-__bad_openmode__
-
-
-# CAN'T LIST DIRECTORY
-'cant dread' => <<'__cant_read__',
-Permissions conflict. $in->{'_pak'} can't list the contents of this directory:
- $EBL$in->{'dirname'}$EBR
-
-Due to insufficient permissions, the system has denied Perl the right to
-view the contents of this directory. It has a bitmask of: (octal number)
- $EBL@{[ sprintf('%04o',(stat($in->{'dirname'}))[2] & 0777) ]}$EBR
-
-Origin: This is *most likely* due to human error. External system errors
- can occur however, but this doesn't have to do with $in->{'_pak'}.
-Solution: A human must fix the conflict by adjusting the file permissions
- of directories where a program asks $in->{'_pak'} to perform I/O.
- Try using Perl's chmod command, or the native system chmod()
- command from a shell.
-__cant_read__
-
-
-# CAN'T CREATE DIRECTORY - PERMISSIONS
-'cant dcreate' => <<'__cant_dcreate__',
-Permissions conflict. $in->{'_pak'} can't create:
- $EBL$in->{'dirname'}$EBR
-
- $in->{'_pak'} can't create this directory because the system has denied
- Perl the right to create files in the parent directory.
-
- Parent directory: (path may be relative and/or redundant)
- $EBL$in->{'parentd'}$EBR
-
- Parent directory has a bitmask of: (octal number)
- $EBL@{[ sprintf('%04o',(stat($in->{'parentd'}))[2] & 0777) ]}$EBR
-
-Origin: This is *most likely* due to human error. External system errors
- can occur however, but this doesn't have to do with $in->{'_pak'}.
-Solution: A human must fix the conflict by adjusting the file permissions
- of directories where a program asks $in->{'_pak'} to perform I/O.
- Try using Perl's chmod command, or the native system chmod()
- command from a shell.
-__cant_dcreate__
-
-
-# CAN'T CREATE DIRECTORY - TARGET EXISTS
-'make_dir target exists' => <<'__cant_dcreate__',
-make_dir target already exists.
- $EBL$in->{'dirname'}$EBR
-
-$in->{'_pak'} can't create the directory you specified because that
-directory already exists, with filetype attributes of
-@{[join(', ', @{ $in->{'filetype'} })]} and permissions
-set to $EBL@{[ sprintf('%04o',(stat($in->{'dirname'}))[2] & 0777) ]}$EBR
-
-Origin: This is *most likely* due to human error. The program has tried
- to make a directory where a directory already exists.
-Solution: Weaken the requirement somewhat by using the "--if-not-exists"
- flag when calling the make_dir object method. This option
- will cause $in->{'_pak'} to ignore attempts to create directories
- that already exist, while still creating the ones that don't.
-__cant_dcreate__
-
-
-# CAN'T OPEN
-'bad open' => <<'__bad_open__',
-$in->{'_pak'} can't open this file for $EBL$in->{'mode'}$EBR:
- $EBL$in->{'filename'}$EBR
-
- The system returned this error:
- $EBL$in->{'exception'}$EBR
-
- $in->{'_pak'} used this directive in its attempt to open the file
- $EBL$in->{'cmd'}$EBR
-
- Current flock_rules policy:
- $EBL@ONLOCKFAIL$EBR
-
-Origin: This is *most likely* due to human error.
-Solution: Cannot diagnose. A Human must investigate the problem.
-__bad_open__
-
-
-# BAD CLOSE
-'bad close' => <<'__bad_close__',
-$in->{'_pak'} couldn't close this file after $EBL$in->{'mode'}$EBR
- $EBL$in->{'filename'}$EBR
-
- The system returned this error:
- $EBL$in->{'exception'}$EBR
-
- Current flock_rules policy:
- $EBL@ONLOCKFAIL$EBR
-
-Origin: Could be either human _or_ system error.
-Solution: Cannot diagnose. A Human must investigate the problem.
-__bad_close__
-
-
-# CAN'T TRUNCATE
-'bad systrunc' => <<'__bad_systrunc__',
-$in->{'_pak'} couldn't truncate() on $EBL$in->{'filename'}$EBR after having
-successfully opened the file in write mode.
-
-The system returned this error:
- $EBL$in->{'exception'}$EBR
-
-Current flock_rules policy:
- $EBL@ONLOCKFAIL$EBR
-
-This is most likely _not_ a human error, but has to do with your system's
-support for the C truncate() function.
-__bad_systrunc__
-
-
-# CAN'T GET FLOCK AFTER BLOCKING
-'bad flock' => <<'__bad_lock__',
-$in->{'_pak'} can't get a lock on the file
- $EBL$in->{'filename'}$EBR
-
-The system returned this error:
- $EBL$in->{'exception'}$EBR
-
-Current flock_rules policy:
- $EBL@ONLOCKFAIL$EBR
-
-Origin: Could be either human _or_ system error.
-Solution: Investigate the reason why you can't get a lock on the file,
- it is usually because of improper programming which causes
- race conditions on one or more files.
-__bad_lock__
-
-
-# CAN'T OPEN ON A DIRECTORY
-'called open on a dir' => <<'__bad_open__',
-$in->{'_pak'} can't call open() on this file because it is a directory
- $EBL$in->{'filename'}$EBR
-
-Origin: This is a human error.
-Solution: Use $in->{'_pak'}::load_file() to load the contents of a file
- Use $in->{'_pak'}::list_dir() to list the contents of a directory
-__bad_open__
-
-
-# CAN'T OPENDIR ON A FILE
-'called opendir on a file' => <<'__bad_open__',
-$in->{'_pak'} can't opendir() on this file because it is not a directory.
- $EBL$in->{'filename'}$EBR
-
-Use $in->{'_pak'}::load_file() to load the contents of a file
-Use $in->{'_pak'}::list_dir() to list the contents of a directory
-
-Origin: This is a human error.
-Solution: Use $in->{'_pak'}::load_file() to load the contents of a file
- Use $in->{'_pak'}::list_dir() to list the contents of a directory
-__bad_open__
-
-
-# CAN'T MKDIR ON A FILE
-'called mkdir on a file' => <<'__bad_open__',
-$in->{'_pak'} can't auto-create a directory for this path name because it
-already exists as a file.
- $EBL$in->{'filename'}$EBR
-
-Origin: This is a human error.
-Solution: Resolve naming issue between the existent file and the directory
- you wish to create.
-__bad_open__
-
-
-# BAD CALL TO File::Util::readlimit
-'bad readlimit' => <<'__maxdives__',
-Bad call to $in->{'_pak'}::readlimit(). This method can only be called with
-a numeric value (bytes). Non-integer numbers will be converted to integer
-format if specified (numbers like 5.2), but don't do that, it's inefficient.
-
-This operation aborted.
-
-Origin: This is a human error.
-Solution: A human must fix the programming flaw.
-__maxdives__
-
-
-# EXCEEDED READLIMIT
-'readlimit exceeded' => <<'__readlimit__',
-$in->{'_pak'} can't load file: $EBL$in->{'filename'}$EBR
-into memory because its size exceeds the maximum file size allowed
-for a read.
-
-The size of this file is $EBL$in->{'size'}$EBR bytes.
-
-Currently the read limit is set at $EBL$READLIMIT$EBR bytes.
-
-Origin: This is a human error.
-Solution: Consider setting the limit to a higher number of bytes.
-__readlimit__
-
-
-# BAD CALL TO File::Util::max_dives
-'bad maxdives' => <<'__maxdives__',
-Bad call to $in->{'_pak'}::max_dives(). This method can only be called with
-a numeric value (bytes). Non-integer numbers will be converted to integer
-format if specified (numbers like 5.2), but don't do that, it's inefficient.
-
-This operation aborted.
-
-Origin: This is a human error.
-Solution: A human must fix the programming flaw.
-__maxdives__
-
-
-# EXCEEDED MAXDIVES
-'maxdives exceeded' => <<'__maxdives__',
-Recursion limit reached at $EBL${\ scalar(
- (exists $in->{'maxdives'} && defined $in->{'maxdives'}) ?
- $in->{'maxdives'} : $MAXDIVES) }$EBR dives. Maximum number of subdirectory dives is set to the value returned by
-$in->{'_pak'}::max_dives(). Try manually setting the value to a higher number
-before calling list_dir() with option --follow or --recurse (synonymous). Do
-so by calling $in->{'_pak'}::max_dives() with the numeric argument corresponding
-to the maximum number of subdirectory dives you want to allow when traversing
-directories recursively.
-
-This operation aborted.
-
-Origin: This is a human error.
-Solution: Consider setting the limit to a higher number.
-__maxdives__
-
-
-# BAD OPENDIR
-'bad opendir' => <<'__bad_opendir__',
-$in->{'_pak'} can't opendir on directory:
- $EBL$in->{'dirname'}$EBR
-
-The system returned this error:
- $EBL$in->{'exception'}$EBR
-
-Origin: Could be either human _or_ system error.
-Solution: Cannot diagnose. A Human must investigate the problem.
-__bad_opendir__
-
-
-# BAD MAKEDIR
-'bad make_dir' => <<'__bad_make_dir__',
-$in->{'_pak'} had a problem with the system while attempting to create the
-directory you specified with a bitmask of $EBL$in->{'bitmask'}$EBR
-
-directory: $EBL$in->{'dirname'}$EBR
-
-The system returned this error:
- $EBL$in->{'exception'}$EBR
-
-Origin: Could be either human _or_ system error.
-Solution: Cannot diagnose. A Human must investigate the problem.
-__bad_make_dir__
-
-
-# BAD CHARS
-'bad chars' => <<'__bad_chars__',
-$in->{'_pak'} can't use this string for $EBL$in->{'purpose'}$EBR.
- $EBL$in->{'string'}$EBR
-It contains illegal characters.
-
-Illegal characters are:
- \\ (backslash)
- / (forward slash)
- : (colon)
- | (pipe)
- * (asterisk)
- ? (question mark)
- " (double quote)
- < (less than)
- > (greater than)
- \\t (tab)
- \\ck (vertical tabulator)
- \\r (newline CR)
- \\n (newline LF)
-
-Origin: This is a human error.
-Solution: A human must remove the illegal characters from this string.
-__bad_chars__
-
-
-# NOT A VALID FILEHANDLE
-'not a filehandle' => <<'__bad_handle__',
-$in->{'_pak'} can't unlock file with an invalid file handle reference:
- $EBL$in->{'argtype'}$EBR is not a valid filehandle
-
-Origin: This is most likely a human error, although it is remotely possible
- that this message is the result of an internal error in the
- $in->{'_pak'} module, but this is not likely if you called
- $in->{'_pak'}'s internal ::_release() method directly on your own.
-Solution: A human must fix the programming flaw. Alternatively, in the
- second listed scenario, the package maintainer must investigate the
- problem. Please send a usenet post with this error message in its
- entirety to Tommy Butler <tommy\@atrixnet.com>, or to usenet group:
- $EBL news://comp.lang.perl.modules $EBR
-__bad_handle__
-
-
-# BAD CALL TO METHOD FOO
-'no input' => <<'__no_input__',
-$in->{'_pak'} can't honor your call to $EBL$in->{'_pak'}::$in->{'meth'}()$EBR
-because you didn't provide $EBL@{[$in->{'missing'}||'the required input']}$EBR
-
-Origin: This is a human error.
-Solution: A human must fix the programming flaw.
-__no_input__
-
-
-# PLAIN ERROR TYPE
-'plain error' => <<'__plain_error__',
-$in->{'_pak'} failed with the following message:
-${\ scalar ($_[0] || ((exists $in->{'error'} && defined $in->{'error'}) ?
- $in->{'error'} : '[error unspecified]')) }
-__plain_error__
-
-
-# INVALID ERROR TYPE
-'unknown error message' => <<'__foobar_input__',
-$in->{'_pak'} failed with an invalid error-type designation.
-
-Origin: This is a bug! Please inform Tommy Butler <tommy\@atrixnet.com>
-Solution: A human must fix the programming flaw.
-__foobar_input__
-
-
-# EMPTY ERROR TYPE
-'empty error' => <<'__no_input__',
-$in->{'_pak'} failed with an empty error-type designation.
-
-Origin: This is a human error.
-Solution: A human must fix the programming flaw.
-__no_input__
-
- ); # end of error message table
-
- exists $error_msg_table{ $error_thrown }
- ? $error_msg_table{ $error_thrown }
- : $error_msg_table{'unknown error message'}
-}
-
@@ -1,2000 +0,0 @@
-=head1 NAME
-
-File::Util - Easy, versatile, portable file handling
-
-=head1 DESCRIPTION
-
-File::Util provides a comprehensive toolbox of utilities to automate all
-kinds of common tasks on file / directories. Its purpose is to do so
-in the most portable manner possible so that users of this module won't
-have to worry about whether their programs will work on other OSes
-and machines.
-
-=head1 SYNOPSIS
-
- use File::Util;
- my($f) = File::Util->new();
-
- my($content) = $f->load_file('foo.txt');
-
- $content =~ s/this/that/g;
-
- $f->write_file(
- 'file' => 'bar.txt',
- 'content' => $content,
- 'bitmask' => 0644
- );
-
- $f->write_file(
- 'file' => 'file.bin', 'content' => $binary_content, '--binmode'
- );
-
- my(@lines) = $f->load_file('randomquote.txt', '--as-lines');
- my($line) = int(rand(scalar @lines));
-
- print $lines[$line];
-
- my(@files) = $f->list_dir('/var/tmp', qw/ --files-only --recurse /);
- my(@textfiles) = $f->list_dir('/var/tmp', '--pattern=\.txt$');
-
- if ($f->can_write('wibble.log')) {
-
- my($HANDLE) = $f->open_handle(
- 'file' => 'wibble.log',
- 'mode' => 'append'
- );
-
- print $HANDLE "Hello World! It's ", scalar localtime;
-
- close $HANDLE
- }
-
- my($log_line_count) = $f->line_count('/var/log/httpd/access_log');
-
- print "My file has a bitmask of " . $f->bitmask('my.file');
-
- print "My file is a " . join(', ', $f->file_type('my.file')) . " file."
-
- warn 'This file is binary!' if $f->isbin('my.file');
-
- print "My file was last modified on " .
- scalar localtime($f->last_modified('my.file'));
-
- # ...and _lots_ more
-
-=head1 INSTALLATION
-
-To install this module type the following at the command prompt:
-
- perl Makefile.PL
- make
- make test
- make install
-
-On windows machines use nmake rather than make; those running cygwin don't have
-to worry about this. If you don't know what cygwin is, use nmake and check out
-http://cygwin.com/ after you're done installing this module if you want to
-find out.
-
-=head1 ISA
-
-=over
-
-=item L<Exporter>
-
-=item L<Class::OOorNO>
-
-=back
-
-=head1 EXPORTED SYMBOLS
-
-Exports nothing by default.
-
-=head2 EXPORT_OK
-
-The following symbols comprise C<@File::Util::EXPORT_OK>), and as such are
-available for import to your namespace only upon request.
-
-C<bitmask> I<(see L<bitmask|/bitmask>)>
-
-C<can_flock> I<(see L<can_flock|/can_flock>)>
-
-C<can_read> I<(see L<can_read|/can_read>)>
-
-C<can_write> I<(see L<can_write|/can_write>)>
-
-C<created> I<(see L<created|/created>)>
-
-C<ebcdic> I<(see L<ebcdic|/ebcdic>)>
-
-C<escape_filename> I<(see L<escape_filename|/escape_filename>)>
-
-C<existent> I<(see L<existent|/existent>)>
-
-C<file_type> I<(see L<file_type|/file_type>)>
-
-C<isbin> I<(see L<isbin|/isbin>)>
-
-C<last_access> I<(see L<last_access|/last_access>)>
-
-C<last_changed> I<(see L<last_changed|/last_changed>)>
-
-C<last_modified> I<(see L<last_modified|/last_modified>)>
-
-C<NL> I<(see L<NL|/NL>)>
-
-C<needs_binmode> I<(see L<needs_binmode|/needs_binmode>)>
-
-C<return_path> I<(see L<return_path|/return_path>)>
-
-C<size> I<(see L<size|/size>)>
-
-C<SL> I<(see L<SL|/SL>)>
-
-C<strip_path> I<(see L<strip_path|/strip_path>)>
-
-C<valid_filename> I<(see L<valid_filename|/valid_filename>)>
-
-B<Note:> Symbols in C<@L<Class::OOorNO|Class::OOorNO>::EXPORT_OK> are also
-available for import.
-
-=head2 EXPORT_TAGS
-
- :all (exports all of @File::Util::EXPORT_OK)
-
-=head1 METHODS
-
-B<Note:> Some of the methods listed will state that they are autoloaded methods.
-Autloaded methods are not compiled at runtime as part of your process and only
-get created if called somewhere in your program. I<(see L<AutoLoader>.)>
-
-Methods listed in alphabetical order.
-
-=head2 C<bitmask>
-
-=over
-
-=item I<Syntax:> C<bitmask( [file name] )>
-
-Gets the bitmask of the named file, provided the file exists. If the file
-exists, the bitmask of the named file is returned in four digit octal
-notation e.g.- C<0644>. Otherwise, returns C<undef> if the file does I<not>
-exist. This is an autoloaded method.
-
-=back
-
-=head2 C<can_flock>
-
-=over
-
-=item I<Syntax:> C<can_flock>
-
-Returns 1 if the current system claims to support C<flock()> I<and> if the
-Perl process can successfully call it. I<(see L<perlfunc/flock>.)> Unless
-both of these conditions are true a zero value (0) is returned. This is
-an autoloaded method. This is a constant subroutine. It accepts no arguments
-and will always return the same value for the system on which it is executed.
-
-B<Note:> Perl will try to support or emulate flock whenever it can via
-available system calls, namely C<flock>; C<lockf>; or with C<fcntl>.
-
-=back
-
-=head2 C<can_read>
-
-=over
-
-=item I<Syntax:> C<can_read( [file name] )>
-
-Returns 1 if the named file (or directory) is B<readable> by your program
-according to the applied permissions of the file system on which the file
-resides. Otherwise a value of undef is returned.
-
-This works the same as Perl's built-in C<-r> file test operator,
-I<(see L<perlfunc/-X>)>, it's just easier for some people to remember. This
-is an autoloaded method.
-
-=back
-
-=head2 C<can_write>
-
-=over
-
-=item I<Syntax:> C<can_write( [file name] )>
-
-Returns 1 if the named file (or directory) is B<writable> by your program
-according to the applied permissions of the file system on which the file
-resides. Otherwise a value of undef is returned.
-
-This works the same as Perl's built-in C<-w> file test operator,
-I<(see L<perlfunc/-X>)>, it's just easier for some people to remember. This
-is an autoloaded method.
-
-=back
-
-=head2 C<created>
-
-=over
-
-=item I<Syntax:> C<created( [file name] )>
-
-Returns the time of creation for the named file in non-leap seconds since
-whatever your system considers to be the epoch. Suitable for feeding to
-Perl's built-in functions "gmtime" and "localtime". I<(see L<perlfunc/time>.)>
-This is an autoloaded method.
-
-=back
-
-=head2 C<ebcdic>
-
-=over
-
-=item I<Syntax:> C<ebcdic>
-
-Returns 1 if the machine on which the code is running uses EBCDIC, or returns
-0 if not. I<(see L<perlebcdic>.)> This is an autoloaded method. This is a
-constant subroutine. It accepts no arguments and will always return the same
-value for the system on which it is executed.
-
-=back
-
-=head2 C<escape_filename>
-
-=over
-
-=item I<Syntax:> C<escape_filename( [string], [escape char] )>
-
-Returns it's argument in an escaped form that is suitable for use as a filename.
-Illegal characters (i.e.- any type of newline character, tab, vtab, and the
-following C<< / | * " ? < : > \ >>), are replaced with [escape char] or
-"B<_>" if no [escape char] is specified. Returns an empty string if no
-arguments are provided. This is an autoloaded method.
-
-=back
-
-=head2 C<existent>
-
-=over
-
-=item I<Syntax:> C<existent( [file name] )>
-
-Returns 1 if the named file (or directory) exists. Otherwise a value of
-undef is returned.
-
-This works the same as Perl's built-in C<-e> file test operator,
-I<(see L<perlfunc/-X>)>, it's just easier for some people to remember. This
-is an autoloaded method.
-
-=back
-
-=head2 C<file_type>
-
-=over
-
-=item I<Syntax:> C<file_type( [file name] )>
-
-Returns a list of keywords corresponding to each of Perl's built in file tests
-(those specific to file types) for which the named file returns true.
-I<(see L<perlfunc/-X>.)> This is an autoloaded method.
-
-The keywords and their definitions appear below; the order of keywords returned
-is the same as the order in which the are listed here:
-
-=over
-
-=item C<PLAIN File is a plain file.>
-
-=item C<TEXT File is a text file.>
-
-=item C<BINARY File is a binary file.>
-
-=item C<DIRECTORY File is a directory.>
-
-=item C<SYMLINK File is a symbolic link.>
-
-=item C<PIPE File is a named pipe (FIFO).>
-
-=item C<SOCKET File is a socket.>
-
-=item C<BLOCK File is a block special file.>
-
-=item C<CHARACTER File is a character special file.>
-
-=back
-
-=back
-
-=head2 C<flock_rules>
-
-=over
-
-=item I<Syntax:> C<flock_rules( [keyword list] )>
-
-Sets I/O race condition policy, or tells File::Util how it should handle race
-conditions created when a file can't be locked because it is already locked
-somewhere else (usually by another process).
-
-An empty call to this method returns a list of keywords representing the rules
-that are currently in effect for the object.
-
-Otherwise, a call should include a list with array containing your chosen
-directive keywords in order of precedence. The rules will be applied in
-cascading order when a File::Util object attempts to lock a file, so if the
-actions specified by the first rule don't result in success, the second rule
-is applied, and so on.
-
-Recognized keywords:
-
-=over
-
-=item C<NOBLOCKEX>
-
-tries to get an exclusive lock on the file without blocking (waiting)
-
-=item C<NOBLOCKSH>
-
-tries to get a shared lock on the file without blocking
-
-=item C<BLOCKEX>
-
-waits to try getting an exclusive lock
-
-=item C<BLOCKSH>
-
-waits to try getting a shared lock
-
-=item C<FAIL>
-
-dies with stack trace
-
-=item C<WARN>
-
-warn()s about the error with a stack trace and returns undef
-
-=item C<IGNORE>
-
-ignores the failure to get an exclusive lock
-
-=item C<UNDEF>
-
-returns undef
-
-=item C<ZERO>
-
-returns 0
-
-=back
-
-Examples:
-
-=over
-
-=item ex- C<flock_rules( qw/ NOBLOCKEX FAIL / );>
-
-This is the default policy. When in effect, the File::Util object will first
-attempt to get a non-blocking exclusive lock on the file. If that attempt
-fails the File::Util object will call die() with a detailed error message and
-a stack trace.
-
-=item ex- C<flock_rules( qw/ NOBLOCKEX BLOCKEX FAIL / );>
-
-The File::Util object will first attempt to get a non-blocking exclusive lock
-on the file. If that attempt fails it falls back to the second policy rule
-"BLOCKEX" and tries again to get an exclusive lock on the file, but this time
-by blocking (waiting for its turn). If that second attempt fails, the
-File::Util object will fail with a detailed error message and a stack trace.
-
-=item ex- C<flock_rules( qw/ BLOCKEX IGNORE / );>
-
-The File::Util object will first attempt to get a file non-blocking lock on
-the file. If that attempt fails it will ignore the error, and go on to open
-the file anyway and no failures will occur or warings be issued.
-
-=back
-
-This is an autoloaded method.
-
-=back
-
-=head2 C<isbin>
-
-=over
-
-=item I<Syntax:> C<isbin( [file name] )>
-
-Returns 1 if the named file (or directory) exists. Otherwise a value of undef
-is returned, indicating that the named file either does not exist or is of
-another file type.
-
-This works the same as Perl's built-in C<-B> file test operator,
-I<(see L<perlfunc/-X>)>, it's just easier for some people to remember. This
-is an autoloaded method.
-
-=back
-
-=head2 C<last_access>
-
-=over
-
-=item I<Syntax:> C<last_access( [file name] )>
-
-Returns the last accessed time for the named file in non-leap seconds since
-whatever your system considers to be the epoch. Suitable for feeding to
-Perl's built-in functions "gmtime" and "localtime". I<(see L<perlfunc/time>.)>
-This is an autoloaded method.
-
-=back
-
-=head2 C<last_changed>
-
-=over
-
-=item I<Syntax:> C<last_changed( [file name] )>
-
-Returns the inode change time for the named file in non-leap seconds since
-whatever your system considers to be the epoch. Suitable for feeding to
-Perl's built-in functions "gmtime" and "localtime". I<(see L<perlfunc/time>.)>
-This is an autoloaded method.
-
-=back
-
-=head2 C<last_modified>
-
-=over
-
-=item I<Syntax:> C<last_modified( [file name] )>
-
-Returns the last modified time for the named file in non-leap seconds since
-whatever your system considers to be the epoch. Suitable for feeding to
-Perl's built-in functions "gmtime" and "localtime". I<(see L<perlfunc/time>.)>
-This is an autoloaded method.
-
-=back
-
-=head2 C<line_count>
-
-=over
-
-=item I<Syntax:> C<line_count( [file name] )>
-
-Returns the number of lines in the named file. Fails with an error if the
-named file does not exist.
-
-=back
-
-=head2 C<list_dir>
-
-=over
-
-=item I<Syntax:> C<list_dir( [directory name] , [--opts] )>
-
-Returns alphabetically sorted all file names in the directory specified if it
-exists. Fails with an error message if no such directory is found.
-
-=over
-
-=item B<Flags accepted by C<list_dir()>>
-
-=over
-
-=item C<--dirs-only>
-
-return only directory contents which are directories
-
-=item C<--files-only>
-
-return only directory contents which are files
-
-=item C<--no-fsdots>
-
-do not include "." and ".." in the list of directory contents
-
-=item C<--pattern>
-
-return only files/directories matching pattern provided. argument
-should be plain text string. It will be converted to a perl regex and passed
-to CORE::grep as the method scans through directory listings for a match.
-
-(ex- C<'--pattern=\.txt$'> returns all file/directory names ending in ".txt".
-It will match "foo.txt", but not "foo.txt.gz" because of the "$" anchor in the
-regular expression passed in.)
-
-or for the opposite effect, C<< '--pattern=.*(?<!\.txt)$' >> returns all
-file/directory names that don't end in ".txt"
-
-=item C<--with-paths>
-
-Include file paths with the contents of the directory list, relative
-to the directory named in the call.
-
-=item C<--recurse>
-
-Recurse subdirectories
-
-=item C<--follow>
-
-Recurse subdirectories, same as C<--recurse>
-
-=item C<--dirs-as-ref>
-
-When returning directory listing, include first a reference to the list
-of subdirectories found, followed by anything else returned by the call.
-
-=item C<--files-as-ref>
-
-When returning directory listing, include last a reference to the list
-of files found, preceded by a list of subdirectories found (or preceeded
-by a list reference to subdirectories found if C<--dirs-as-ref> was also used).
-
-=item C<--as-ref>
-
-Return a pair list references: the first is a reference to any subdirectories
-found by the call, the second is a reference to any files found by the call.
-
-=item C<--sl-after-dirs>
-
-Append a directory seperator ("/, "\", or ":" depending on your system)
-to all directories found by the call. Useful in visual displays for quick
-differentiation between subdirectories and files.
-
-=item C<--ignore-case>
-
-Items returned by the call to this method are sorted alphabetically by
-default, so "Zoo.txt" comes before "alligator.txt" because the alphabetical
-sort is case-sensitive. This is also the way directories are listed at the
-system level on most operating systems.
-
-If you'd like the directory contents returned by this method to be
-sorted without regard to case , use this flag.
-
-=item C<--count-only>
-
-Returns a single value: an integer reflecting the number of items
-found in the directory after applying the filter criteria specified by any
-other flags (ie- "--dirs-only", "--recurse", etc.) that may have been passed
-in as well.
-
-=back
-
-=back
-
-=back
-
-=head2 C<load_dir>
-
-=over
-
-=item I<Syntax:> C<load_dir( [directory name] , [--ds-type] )>
-
-Returns a data structure containing the contents of each file present in the
-named directory. This is an autoloaded method.
-
-The type of data structure returned is determined by the optional data-type
-switch. Only one option may be used for a given call to this method.
-Recognized options are listed below.
-
-=over
-
-=item B<Flags accepted by C<load_dir()>>
-
-=over
-
-=item C<--as-list>
-
-Causes the method to return a list comprised of the contents loaded from
-each file (in case-sensitive order) located in the named directory.
-
-=item C<--as-listref>
-
-Same as above, except an array reference to the list of items is returned
-rather than the list itself.
-
-=item C<--as-hashref> *(default)
-
-Implicit. If no option is passed in, the default behavior is to return a
-reference to an anonymous hash whose keys are the names of each file in the
-specified directory; the hash values for contain the contents of the file
-represented by its corresponding key.
-
-=back
-
-=back
-
-B<Note:> This method does not distinguish between plain files and other file
-types such as binaries, FIFOs, sockets, etc.
-
-Restrictions imposed by the current "read limit"
-I<(see the L<readlimit()|/readlimit>) entry below> will be applied to the
-files opened by this method as well. Adjust the readlimit as necessary.
-
- my($files) = $fu->load_dir('directory/to/load/');
-
-The above code creates an anonymous hash reference that is stored in the
-variable named "C<$files>". The keys and values of the hash referenced by
-"C<$files>" would resemble those of the following code snippet (given that
-the files in the named directory were the files 'a.txt', 'b.html', 'c.dat',
-and 'd.conf')
-
- my($files) =
- {
- 'a.txt' => "the contents of file a.txt",
- 'b.html' => "the contents of file b.html",
- 'c.dat' => "the contents of file c.dat",
- 'd.conf' => "the contents of file d.conf",
- };
-
-=back
-
-=head2 C<load_file>
-
-=over
-
-=item I<Syntax:> C<load_file( [file name] , [--opts] )>
-
-=item I<OR:> C<< load_file( 'FH' => [file handle reference] , [--opts] ) >>
-
-If [file name] is passed, returns the contents of [file name] in a string.
-If a [file handle reference] is passed instead, the filehandle will be
-C<CORE::read()> and the data obtained by the read will be returned in a string.
-
-If you desire the contents of the file (or file handle data) in a list of
-lines instead of a single string, this can be accomplished through the use
-of the C<--as-lines> flag (see below).
-
-=over
-
-=item B<Flags accepted by C<load_file()>>
-
-=over
-
-=item C<--as-lines>
-
-If this flag is passed then your call to C<load_file> will return an ordered
-list of strings, each of which is a line from the file [file name]. The lines
-are returned in the order they are read, from the beginning of the file to the
-end.
-
-This is not the default behavior. The default behavior is for C<load_file> to
-return a single string containing the entire contents of the file, including
-line break characters.
-
-=item C<--no-lock>
-
-By default this method will attempt to get a lock on the file while it is
-being read, following whatever rules are in place for the flock policy
-established either by default (implicitly) or changed by you in a call to
-File::Util::flock_rules()
-I<(see the L<flock_rules()|/flock_rules>) entry below>.
-
-This method will not try to get a lock on the file if the File::Util object was
-created with the option C<--no-lock> or if the method was called with the
-option C<--no-lock>.
-
-This method will automatically call binmode() on binary files for you. If you
-pass in a filehandle instead of a file name you do not get this automatic
-check performed for you. In such a case, you'll have to call binmode() on
-the filehandle yourself. Once you pass a filehandle to this method it has no
-way of telling if the file opened to that filehandle is binary or not.
-
-B<Notes:> This method does not distinguish between plain files and other file
-types such as binaries, FIFOs, sockets, etc.
-
-Restrictions imposed by the current "read limit"
-I<(see the L<readlimit()|/readlimit>) entry below> will be applied to the
-files opened by this method as well. Adjust the readlimit as necessary.
-
-=back
-
-=back
-
-=back
-
-=head2 C<make_dir>
-
-=over
-
-=item I<Syntax:> C<make_dir( [new directory name] , [bitmask], [--opts] )>
-
-Attempts to create (recursively) a directory as [new directory name] with
-the [bitmask] provided. The bitmask is an optional argument and defaults to
-0777. If specified, the bitmask must be supplied in the form required by the
-native perl umask function. I<see L<perlfunc/"umask">> for more information
-about the format of the bitmask argument.
-
-As mentioned above, the recursive creation of directories is transparently
-handled for you. This means that if the name of the directory you pass in
-contains a parent directory that does not exist, the parent directory(ies) will
-be created for you automatically and silently in order to create the final
-directory in the [new directory name].
-
-Simply put, if [new directory] is "/path/to/directory" and the directory
-"/path/to" does not exist, the directory "/path/to" will be created and the
-"/path/to/directory" directory will be created thereafter. All directories
-created will be created with the [bitmask] you specify, or with the default
-of 0777.
-
-Upon successful creation of the [new directory name], the [new directory name]
-is returned to the caller.
-
-=over
-
-=item B<Flags accepted by C<make_dir()>>
-
-=over
-
-=item C<--if-not-exists>
-
-If this flag is passed in then make_dir will not attempt to create the directory
-if it already exists. Rather it will return the name of the directory as it
-normally would if the directory did not exist previous to calling this method.
-
-If a call to this method is made without the C<--if-not-exists> flag and the
-directory specified as [new directory name] does in fact exist, an error will
-result as it is impossible to create a directory that already exists.
-
-=back
-
-=back
-
-This is an autoloaded method.
-
-=back
-
-=head2 C<max_dives>
-
-=over
-
-=item I<Syntax:> C<max_dives( [integer] )>
-
-When called without any arguments, this method returns an integer reflecting
-the current number of times the File::Util object will dive into the
-subdirectories it discovers when recursively listing directory contents from
-a call to C<File::Util::list_dir()>. The default is 1000. If the number is
-exceeded, the File::Util object will fail with a diagnostic error message.
-
-When called with an argument, it sets the maximum number of times a File::Util
-object will recurse into subdirectories before failing with an error message.
-
-This method can only be called with a numeric integer value. Passing a bad
-argument to this method will cause it to fail with an error message.
-
-I<(see L<list_dir|/list_dir>)>
-
-This is an autoloaded method.
-
-=back
-
-=head2 C<needs_binmode>
-
-=over
-
-=item I<Syntax:> C<needs_binmode>
-
-Returns 1 if the machine on which the code is running requires that C<binmode()>
-I<(a built-in function)> be called on open file handles, or returns 0 if not.
-I<(see L<perlfunc/binmode>.)> This is an autoloaded method. This is a constant
-subroutine. It accepts no arguments and will always return the same value for
-the system on which it is executed.
-
-=back
-
-=head2 C<new>
-
-=over
-
-=item I<Syntax:> C<< new( ['parameters' => 'values', etc], [--flags] ) >>
-
-This is the File::Util constructor method. eg- It returns a new File::Util
-object reference when you call it. It recognizes various parameters and flags
-that govern the behavior of the new File::Util object.
-
-=over
-
-=item B<Parameters accepted by C<new()>>
-
-=over
-
-=item use_flock => true/false value
-
-Optionally specify this option to the C<File::Util::new> method instruct the
-new object that it should never attempt to use C<flock()> in it's I/O
-operations. The default is to use C<flock()> when available on your system.
-Specify this option with a true or false value, true to use C<flock()>, false
-to not use it.
-
-=item readlimit => positive integer
-
-Optionally specify this option to the File::Util::new method to instruct the
-new object that it should never attempt to open and read in a file greater
-than the number of bytes you specify. Obviously this argument can only be
-a numeric integer value, otherwise it will be silently ignored. The default
-readlimit for File::Util objects is 52428800 bytes (50 megabytes).
-
-=item max_dives => positive integer
-
-Optionally specify this option to the File::Util::new method to instruct the
-new object to set the maximum number of times it will recurse into
-subdirectories while performing directory listing operations before failing
-with an error message. This argument can only be a numeric integer value,
-otherwise it will be silently ignored.
-
-=back
-
-=item B<Flags accepted by C<new()>>
-
-=over
-
-=item C<--fatals-as-warning>
-
-Directive to instruct the new File::Util object that when any call to one of
-its methods results in a fatal error that it should return B<C<undef>>
-instead of the value(s) that would normally be returned by the call, and to
-send an error message to STDERR as well.
-
-=item C<--fatals-as-status>
-
-Directive to instruct the new File::Util object that when any call to one of
-its methods results in a fatal error that it should return B<C<undef>>
-instead of the value(s) that would normally be returned by the call.
-
-=item C<--fatals-as-errmsg>
-
-Directive to instruct the new File::Util object that when any call to one of
-its methods results in a fatal error that it should return B<an error message>
-instead of the value(s) that would normally be returned by the call.
-
-=back
-
-=back
-
-=back
-
-=head2 C<open_handle>
-
-=over
-
-=item I<Syntax:> C<< open_handle('file' => [file name], [--opts]) >>
-
-=item I<OR:> C<< open_handle('file' => [file name], 'mode' => [mode], [--opts]) >>
-
-=item I<OR:> C<< open_handle('file' => [file name], 'mode' => [mode], 'bitmask' => [bitmask], [--opts]) >>
-
-=item I<OR:> C<< open_handle('file' => [file name], 'mode' => [mode], 'bitmask' => [bitmask], 'dbitmask' => [bitmask], [--opts]) >>
-
-Attempts to get a unique open file handle on [file name] in [mode] mode.
-Returns the file handle if successful or generates a fatal error with a
-diagnostic message if the operation fails.
-
-You will need to remember to call C<close()> on the filehandle yourself, at
-your own discretion. Leaving filehandles open is not a good practice, and
-is not recommended. I<see L<perlfunc/close>>).
-
-Once you have the file handle you would use it as you would use any file handle.
-Remember that unless you specifically turn file locking off when the
-C<File::Util> object is created (see I<(see L<new|/new>)> or by using the
-C<--no-lock> flag when calling C<open_handle>, that file locking is going to
-automagically be handled for you behind the scenes, so long as your OS supports
-file locking of any kind at all. Great! It's very convenient for you to not
-have to worry about portably taking care of file locking between one
-application and the next; by using C<File::Util> in all of them, you know
-that you're covered.
-
-A slight inconvenience for the price of a larger set of features (compare
-L<write_file|/write_file> to this method)
-I<B<you will have to release the file lock on the open handle yourself.>>
-C<File::Util> can't manage it for you anymore once it hands the handle over
-to you. At that point, it's all yours. In order to release the file lock
-on your file handle, call L<unlock_open_handle()|/unlock_open_handle> on it.
-Otherwise the lock will remain for the life of your process. If you don't
-want to use the free portable file locking, remember the C<--no-lock> flag,
-which will turn off file locking for your open handle. Seldom, however, should
-you ever opt to not use file locking unless you really know what you are doing.
-
-If the file does not yet exist it will be created, and it will be created
-with a bitmask of [bitmask] if you specify a file creation bitmask using
-the C<'bitmask'> option, otherwise the file will be created with the default
-bitmask of 0777.
-
-If specified, the bitmask must be supplied in the form required by the
-native perl umask function. I<see L<perlfunc/"umask">> for more information
-about the format of the bitmask argument. If the file [file name] already
-exists then the bitmask argument has no effect and is silently ignored.
-
-Any non-existent directories in the path preceeding the actual file name will
-be automatically (and silently - no warnings) created for you and any new
-directories will be created with a bitmask of [dbitmask], provided you specify
-a directory creation bitmask with the C<'dbitmask'> option.
-
-If specified, the directory creation bitmask [dbitmask] must be supplied in
-the form required by the native perl umask function.
-
-If there is an error while trying to create any preceeding directories, the
-failure results in a fatal error with a diagnostic error message. If all
-directories preceeding the name of the file already exist, the dbitmask
-argument has no effect and is silently ignored.
-
-=back
-
-=over
-
-=item B<Native Perl open modes>
-
-The default behavior of C<open_handle()> is to open file handles using Perl's
-native C<open()> I<(see L<perlfunc/open>)>. Unless you use the
-C<--use-sysopen> flag, the following modes and only these modes are valid.
-
-=over
-
-=item C<< 'mode' => 'read' >>
-
-[file name] is opened in read-only mode. If the file does not yet exist then
-a fatal error will occur with a diagnostic help message to help you troubleshoot
-the problem.
-
-=item C<< 'mode' => 'write' >> (this is the default mode)
-
-[file name] is created if it does not yet exist. If [file name] already exists
-then its contents are overwritten with the new content provided.
-
-=item C<< 'mode' => 'append' >>
-
-[file name] is created if it does not yet exist. If [file name] already exists
-its contents will be preserved and the new content you provide will be appended
-to the end of the file.
-
-=back
-
-=back
-
-=over
-
-=item B<System level open modes ("open a la C")>
-
-Optionally you can ask C<File::Util> to open your handle using C<CORE::sysopen>
-instead of using the native Perl C<CORE::open()>. This is accomplished by
-passing in the C<--use-sysopen> flag. Using this feature opens up more
-possibilities as far as the open modes you can choose from, but also carries
-with it a few caveats so you have to be careful, just as you'd have to be a
-little more careful when using C<sysopen()> anyway.
-
-Specifically you need to remember that when using this feature you must NOT
-mix different types of I/O when working with the file handle. You can't go
-opening file handles with C<sysopen()> and print to them as you normally
-would print to a file handle. You have to use C<syswrite()> instead. The
-same applies here. If you get a C<sysopen()>'d filehandle from C<open_handle()>
-it is imperative that you use C<syswrite()> on it. You'll also need to use
-C<sysseek()> and other type of C<sys>* commands on the filehandle instead of
-their native Perl equivalents.
-
-(see L<perlfunc/sysopen>, L<perlfunc/syswrite>, L<perlfunc/sysseek>,
-L<perlfunc/sysread>)
-
-That said, here are the different modes you can choose from to get a file handle
-when using the C<--use-sysopen> flag. Remember that these won't work unless
-you use the flag, and will generate an error if you try using them without it.
-The standard C<'read'>, C<'write'>, and C<'append'> modes are already available
-to you by default. These are the extended modes:
-
-=over
-
-=item C<< 'mode' => 'rwcreate' >>
-
-[file name] is opened in read-write mode, and will be created for you if it
-does not already exist.
-
-=item C<< 'mode' => 'rwupdate' >>
-
-[file name] is opened for you in read-write mode, but must already exist. If
-it does not exist, a fatal error will result and a diagnostic help message will
-be printed out to help you troubleshoot the problem.
-
-=item C<< 'mode' => 'rwclobber' >>
-
-[file name] is opened for you in read-write mode. If the file already exists
-it's contents will be "clobbered" or wiped out. The file will then be empty
-and you will be working with the then-truncated file. This can not be undone.
-Once you call C<open_handle()> using this option, your file WILL be wiped out.
-If the file does not exist yet, it will be created for you.
-
-=item C<< 'mode' => 'rwappend' >>
-
-[file name] will be opened for you in read-write mode ready for appending. The
-file's contents will not be wiped out; they will be preserved and you will be
-working in append fashion. You will only be able to write starting at the end
-of the file. If the file does not exist, it will be created for you.
-
-=back
-
-Remember to use C<sysread()> and not plain C<read()> when reading those
-C<sysopen()>'d filehandles!
-
-=back
-
-=over
-
-=item B<Flags accepted by C<open_handle()>>
-
-=over
-
-=item C<--binmode>
-
-Makes sure that CORE::binmode() is called on the filehandle when your content
-is written. This is useful for times when the content you are writing to file
-is a binary stream. I<(see L<perlfunc/binmode>)>.
-
-=item C<--no-lock>
-
-By default this method will attempt to get a lock on the file while it is
-being read, following whatever rules are in place for the flock policy
-established either by default (implicitly) or changed by you in a call to
-File::Util::flock_rules()
-I<(see the L<flock_rules()|/flock_rules>) entry below>.
-
-This method will not try to get a lock on the file if the File::Util object was
-created with the option C<--no-lock> or if this method is called with the
-option C<--no-lock>.
-
-=item C<--use-sysopen>
-
-Instead of opening the file using Perl's native C<open()> command, C<File::Util>
-will open the file with the C<sysopen()> command. You will have to remember
-that your filehandle is a C<sysopen()>'d one, and that you will not be able to
-use native Perl I/O functions on it. You will have to use the C<sys>*
-equivalents. See L<perlopentut> for a more in-depth explanation of why you
-can't mix native Perl I/O with system I/O.
-
-=back
-
-This is an autoloaded method.
-
-=back
-
-=head2 C<readlimit>
-
-=over
-
-=item I<Syntax:> C<readlimit( [integer] )>
-
-By default, the largest size file that File::Util will read into memory and
-return via the L<load_file|/load_file> is 52428800 byptes (50 megabytes).
-
-This value can be modified by calling this method with an integer value
-reflecting the new limit you want to impose, in bytes. For example, if you want
-to set the limit to 10 megabytes, call the method with an argument of 10485760.
-
-If this method is called without an argument, the read limit currently in force
-for the File::Util object will be returned.
-
-This is an autoloaded method.
-
-=back
-
-=head2 C<return_path>
-
-=over
-
-=item I<Syntax:> C<return_path( [string] )>
-
-Takes the file path from the file name provided and returns it such that
-"/foo/bar/baz.txt" is returned "/foo/bar".
-
-This is an autoloaded method.
-
-=back
-
-=head2 C<size>
-
-=over
-
-=item I<Syntax:> C<size( [file name] )>
-
-Returns the file size of [file name] in bytes. Returns C<0> if the file is
-empty, returns C<undef> if the file does not exist.
-
-This is an autoloaded method.
-
-=back
-
-=head2 C<strip_path>
-
-=over
-
-=item I<Syntax:> C<strip_path( [string] )>
-
-Strips the file path from the file name provided and returns the file name only.
-
-=back
-
-=head2 C<touch>
-
-=over
-
-=item I<Syntax:> C<touch( [file name] )>
-
-Behaves like the *nix C<touch> command; Updates the access and modification
-times of the specified file to the current time. If the file does not exist,
-C<File::Util> tries to create it empty. This method will fail with a fatal
-error if system permissions deny alterations to or creation of the file.
-
-Returns C<1> if successful. If unsuccessful, fails with a descriptive error
-message about what went wrong.
-
-This is an autoloaded method.
-
-=back
-
-=head2 C<trunc>
-
-=over
-
-=item I<Syntax:> C<trunc( [file name] )>
-
-Truncates [file name] (i.e.- wipes out, or "clobbers" the contents of the
-specified file. Returns C<1> if successful. If unsuccessful, fails with a
-descriptive error message about what went wrong.
-
-This is an autoloaded method.
-
-=back
-
-=head2 C<unlock_open_handle>
-
-=over
-
-=item I<Syntax:> C<unlock_open_handle([file handle])>
-
-Release the flock on a file handle you opened with L<open_handle|/open_handle>.
-
-Returns true on success, false on failure. Will not raise a fatal error if
-the unlock operation fails. You can capture the return value from your call
-to this method and C<die()> if you so desire. Failure is not ever very likely,
-or C<File::Util> wouldn't have been able to get a portable lock on the file
-in the first place.
-
-If C<File::Util> wasn't able to ever lock the file due to limitations of your
-operating system, a call to this method will return a true value.
-
-If file locking has been disabled on the file handle via the C<--no-lock> flag
-at the time L<open_handle|/open_handle> was called, or if file locking was
-disabled using the L<use_flock|/use_flock> method, or if file locking was
-disabled on the entire C<File::Util> object at the time of its creation
-I<(see L<new()|/new>)>, calling this method will have no effect and a true value
-will be returned.
-
-This is an autoloaded method, due to L<open_handle|open_handle> also being
-autoloaded.
-
-=back
-
-=head2 C<use_flock>
-
-=over
-
-=item I<Syntax:> C<use_flock( [true / false value] )>
-
-When called without any arguments, this method returns a true or false value
-to reflect the current use of C<flock()> within the File::Util object.
-
-When called with a true or false value as its single argument, this method
-will tell the File::Util object whether or not it should attempt to use
-C<flock()> in its I/O operations. A true value indicates that the File::Util
-object will use C<flock()> if available, a false value indicates that it will
-not. The default is to use C<flock()> when available on your system.
-
-This is an autoloaded method.
-
-=back
-
-=head2 C<write_file>
-
-=over
-
-=item I<Syntax:> C<< write_file('file' => [file name], 'content' => [string], [--opts]) >>
-
-=item I<OR:> C<< write_file('file' => [file name], 'content' => [string], 'mode' => [mode], [--opts]) >>
-
-=item I<OR:> C<< write_file('file' => [file name], 'content' => [string], 'mode' => [mode], 'bitmask' => [bitmask], [--opts]) >>
-
-=item I<OR:> C<< write_file('file' => [file name], 'content' => [string], 'mode' => [mode], 'bitmask' => [bitmask], 'dbitmask' => [bitmask], [--opts]) >>
-
-Attempts to write [string] to [file name] in mode [mode]. If the file does
-not yet exist it will be created, and it will be created with a bitmask of
-[bitmask] if you specify a file creation bitmask using the C<'bitmask'> option,
-otherwise the file will be created with the default bitmask of 0777.
-
-[string] should be a string or a scalar variable containing a string. The
-string can be any type of data, such as a binary stream, or ascii text with
-line breaks, etc. Be sure to pass in the C<--binmode> flag for binary streams.
-
-If specified, the bitmask must be supplied in the form required by the
-native perl umask function. I<see L<perlfunc/"umask">> for more information
-about the format of the bitmask argument. If the file [file name] already
-exists then the bitmask argument has no effect and is silently ignored.
-
-Returns 1 if successful or fails (fatal) with an error message if not
-successful.
-
-Any non-existent directories in the path preceeding the actual file name will
-be automatically (and silently - no warnings) created for you and any new
-directories will be created with a bitmask of [dbitmask], provided you specify
-a directory creation bitmask with the C<'dbitmask'> option.
-
-If specified, the directory creation bitmask [dbitmask] must be supplied in
-the form required by the native perl umask function.
-
-If there is an error while trying to create any preceeding directories, the
-failure results in a fatal error with a diagnostic error message. If all
-directories preceeding the name of the file already exist, the dbitmask
-argument has no effect and is silently ignored.
-
-=over
-
-=item C<< 'mode' => 'write' >> (this is the default mode)
-
-[file name] is created if it does not yet exist. If [file name] already exists
-then its contents are overwritten with the new content provided.
-
-=item C<< 'mode' => 'append' >>
-
-[file name] is created if it does not yet exist. If [file name] already exists
-its contents will be preserved and the new content you provide will be appended
-to the end of the file.
-
-=back
-
-=over
-
-=item B<Flags accepted by C<write_file()>>
-
-=over
-
-=item C<--binmode>
-
-Makes sure that CORE::binmode() is called on the filehandle when your content
-is written. This is useful for times when the content you are writing to file
-is a binary stream.
-
-=item C<--empty-writes-OK>
-
-Allows you to call this method without providing a content argument (it lets
-you create an empty file without warning you or failing. Be advised that
-if you use this flag, it will have the same effect as truncating a file
-that already has content in it (i.e.- it will "clobber" non-empty files)
-
-=item C<--no-lock>
-
-By default this method will attempt to get a lock on the file while it is
-being read, following whatever rules are in place for the flock policy
-established either by default (implicitly) or changed by you in a call to
-File::Util::flock_rules()
-I<(see the L<flock_rules()|/flock_rules>) entry below>.
-
-This method will not try to get a lock on the file if the File::Util object was
-created with the option C<--no-lock> or if this method is called with the
-option C<--no-lock>.
-
-=back
-
-=back
-
-=back
-
-=head2 C<valid_filename>
-
-=over
-
-=item I<Syntax:> C<valid_filename( [string] )>
-
-For the given string, returns 1 if the string is a legal file name for the
-system on which the program is running, or returns undef if it is not. This
-method does not test for the validity of file paths! It tests for the validity
-of file names only. (It is used internally to check beforehand if a file name
-is useable when creating new files, but is also a public method available for
-external use.)
-
-=back
-
-=head1 CONSTANTS
-
-=head2 C<NL>
-
-=over
-
-=item I<Syntax:> C<NL>
-
-Returns the correct new line character (or character sequence) for the system
-on which your program runs.
-
-=back
-
-=head2 C<SL>
-
-=over
-
-=item I<Syntax:> C<SL>
-
-Returns the correct directory path seperator for the system on which your
-program runs.
-
-=back
-
-=head2 C<OS>
-
-=over
-
-=item I<Syntax:> C<OS>
-
-Returns the File::Util keyword for the operating system FAMILY it detected. The
-keyword for the detected operating system will be one of the following, derived
-from the conents of C<$^O>, or if C<$^O> can not be found, from the contents of
-C<$Config::Config{osname}> (see native L<Config> library), or if that
-doesn't contain a recognizable value, finally falls back to C<UNIX>.
-
-Generally speaking, Linux operating systems are going to be detected as C<UNIX>.
-This isn't a bug. The OS FAMILY to which it belongs uses C<UNIX> style
-filesystem conventions and line endings, which are the relevant things to
-file handling operations.
-
-=over
-
-=item UNIX
-
-Specifics: OS name =~ /^(?:darwin|bsdos)/i
-
-=item CYGWIN
-
-Specifics: OS name =~ /^cygwin/i
-
-=item WINDOWS
-
-Specifics: OS name =~ /^MSWin/i
-
-=item VMS
-
-Specifics: OS name =~ /^vms/i
-
-=item DOS
-
-Specifics: OS name =~ /^dos/i
-
-=item MACINTOSH
-
-Specifics: OS name =~ /^MacOS/i
-
-=item EPOC
-
-Specifics: OS name =~ /^epoc/i
-
-=item OS2
-
-Specifics: OS name =~ /^os2/i
-
-=back
-
-=back
-
-=head1 PREREQUISITES
-
-=over
-
-=item L<Perl|perl> 5.006 or better
-
-=item L<Class::OOorNO> v0.01_1 or better
-
-=item L<Exception::Handler> v1.00_0 or better
-
-=back
-
-=head1 EXAMPLES
-
-=head2 Get the names of all files and subdirectories in a directory
-
- use File::Util;
- my($f) = File::Util->new();
- # option --no-fsdots excludes "." and ".." from the list
- my(@dirs_and_files) = $f->list_dir('/foo','--no-fsdots');
-
-=head2 Get the names of all files and subdirectories in a directory, recursively
-
- use File::Util;
- my($f) = File::Util->new();
- my(@dirs_and_files) = $f->list_dir('/foo','--recurse');
-
-=head2 Get the names of all files (no subdirectories) in a directory
-
- use File::Util;
- my($f) = File::Util->new();
- my(@dirs_and_files) = $f->list_dir('/foo','--files-only');
-
-=head2 Get the names of all subdirectories (no files) in a directory
-
- use File::Util;
- my($f) = File::Util->new();
- my(@dirs_and_files) = $f->list_dir('/foo','--dirs-only');
-
-=head2 Get the number of files and subdirectories in a directory
-
- use File::Util;
- my($f) = File::Util->new();
- my(@dirs_and_files) = $f->list_dir('/foo', qw/--no-fsdots --count-only/);
-
-=head2 Get the names of files and subdirs in a directory as seperate array refs
-
- use File::Util;
- my($f) = File::Util->new();
- my($dirs,$files) = $f->list_dir('/foo', '--as-ref');
-
- -OR-
- my($dirs,$files) = $f->list_dir('.', qw/--dirs-as-ref --files-as-ref/);
-
-=head2 Get the contents of a file in a string
-
- use File::Util;
- my($f) = File::Util->new();
- my($contents) = $f->load_file('filename');
-
-=head2 Get the contents of a file in an array of lines in the file
-
- use File::Util;
- my($f) = File::Util->new();
- my(@contents) = $f->load_file('filename','--as-lines');
-
-=head2 Get an open file handle for reading
-
- use File::Util;
- my($f) = File::Util->new();
- my($FH_REF) = $f->open_handle(
- 'file' => 'new_filename',
- 'mode' => 'read'
- );
-
-=head2 Get an open file handle for writing
-
- use File::Util;
- my($f) = File::Util->new();
- my($FH_REF) = $f->open_handle(
- 'file' => 'new_filename',
- 'mode' => 'write'
- );
-
-=head2 Write to a new or existing file
-
- use File::Util;
- my($content) = 'Pathelogically Eclectic Rubbish Lister';
- my($f) = File::Util->new();
- $f->write_file('file' => 'a new file.txt', 'content' => $content);
-
- # optionally specify a creation bitmask when writing to a new file
- $f->write_file(
- 'file' => 'a new file.txt',
- 'bitmask' => 0777,
- 'content' => $content
- );
-
-=head2 Append to a new or existing file
-
- use File::Util;
- my($content) = 'Pathelogically Eclectic Rubbish Lister';
- my($f) = File::Util->new();
- $f->write_file(
- 'file' => 'a new file.txt',
- 'mode' => 'append',
- 'content' => $content
- );
-
-=head2 Determine if something is a valid file name
-
- use File::Util qw( valid_filename );
-
- if (valid_filename("foo?+/bar~@/#baz.txt")) {
- print "file name is valid"
- else {
- print "file name contains illegal characters"
- }
-
- -OR-
- use File::Util;
- print File::Util->valid_filename("foo?+/bar~@/#baz.txt") ? 'ok' : 'bad';
-
- -OR-
- use File::Util;
- my($f) = File::Util->new();
- print $f->valid_filename("foo?+/bar~@/#baz.txt") ? 'ok' : 'bad';
-
-=head2 Get the number of lines in a file
-
- use File::Util;
- my($f) = File::Util->new();
- my($linecount) = $f->line_count('foo.txt');
-
-=head2 Strip the path from a file name
-
- use File::Util;
- my($f) = File::Util->new();
-
- # On Windows
- # (prints "hosts")
- my($path) = $f->strip_path('C:\WINDOWS\system32\drivers\etc\hosts');
-
- # On Linux/Unix
- # (prints "perl")
- print $f->strip_path('/usr/bin/perl');
-
- # On a Mac
- # (prints "baz")
- print $f->strip_path('foo:bar:baz');
-
-=head2 Get the path preceeding a file name
-
- use File::Util;
- my($f) = File::Util->new();
-
- # On Windows
- # (prints "C:\WINDOWS\system32\drivers\etc")
- my($path) = $f->return_path('C:\WINDOWS\system32\drivers\etc\hosts');
-
- # On Linux/Unix
- # (prints "/usr/bin")
- print $f->return_path('/usr/bin/perl');
-
- # On a Mac
- # (prints "foo:bar")
- print $f->return_path('foo:bar:baz');
-
-=head2 Find out if the host system can use flock
-
- use File::Util qw( can_flock );
- print can_flock;
-
- -OR-
- print File::Util->can_flock;
-
- -OR-
- my($f) = File::Util->new();
- print $f->can_flock;
-
-=head2 Find out if the host system needs to call binmode on binary files
-
- use File::Util qw( needs_binmode );
- print needs_binmode;
-
- -OR-
- use File::Util;
- print File::Util->needs_binmode;
-
- -OR-
- use File::Util;
- my($f) = File::Util->new();
- print $f->needs_binmode;
-
-=head2 Find out if a file can be opened for read (based on file permissions)
-
- use File::Util;
- my($f) = File::Util->new();
- my($is_readable) = $f->can_read('foo.txt');
-
-=head2 Find out if a file can be opened for write (based on file permissions)
-
- use File::Util;
- my($f) = File::Util->new();
- my($is_writable) = $f->can_write('foo.txt');
-
-=head2 Escape illegal characters in a potential file name (and its path)
-
- use File::Util;
- my($f) = File::Util->new();
-
- # prints "C__WINDOWS_system32_drivers_etc_hosts"
- print $f->escape_filename('C:\WINDOWS\system32\drivers\etc\hosts');
-
- # prints "baz)__@^"
- # (strips the file path from the file name, then escapes it
- print $f->escape_filename(
- '/foo/bar/baz)?*@^',
- '--strip-path'
- );
-
- # prints "_foo_!_@so~me#illegal$_file&(name"
- # (yes, that is a legal filename)
- print $f->escape_filename(q[\foo*!_@so~me#illegal$*file&(name]);
-
-=head2 Find out if the host system uses EBCDIC
-
- use File::Util qw( ebcdic );
- print ebcdic;
-
- -OR-
- use File::Util;
- print File::Util->ebcdic;
-
- -OR-
- use File::Util;
- my($f) = File::Util->new();
- print $f->ebcdic;
-
-=head2 Get the type(s) of an existent file
-
- use File::Util qw( file_type );
- print file_type('foo.exe');
-
- -OR-
- use File::Util;
- print File::Util->file_type('bar.txt');
-
- -OR-
- use File::Util;
- my($f) = File::Util->new();
- print $f->file_type('/dev/null');
-
-=head2 Get the bitmask of an existent file
-
- use File::Util qw( bitmask );
- print bitmask('/usr/sbin/sendmail');
-
- -OR-
- use File::Util;
- print File::Util->bitmask('C:\COMMAND.COM');
-
- -OR-
- use File::Util;
- my($f) = File::Util->new();
- print $f->bitmask('/dev/null');
-
-=head2 Get time of creation for a file
-
- use File::Util qw( created );
- print scalar localtime created('/usr/bin/exim');
-
- -OR-
- use File::Util;
- print scalar localtime File::Util->created('C:\COMMAND.COM');
-
- -OR-
- use File::Util;
- my($f) = File::Util->new();
- print scalar localtime $f->created('/bin/less');
-
-=head2 Get the last access time for a file
-
- use File::Util qw( last_access );
- print scalar localtime last_access('/usr/bin/exim');
-
- -OR-
- use File::Util;
- print scalar localtime File::Util->last_access('C:\COMMAND.COM');
-
- -OR-
- use File::Util;
- my($f) = File::Util->new();
- print scalar localtime $f->last_access('/bin/less');
-
-=head2 Get the inode change time for a file
-
- use File::Util qw( last_changed );
- print scalar localtime last_changed('/usr/bin/vim');
-
- -OR-
- use File::Util;
- print scalar localtime File::Util->last_changed('C:\COMMAND.COM');
-
- -OR-
- use File::Util;
- my($f) = File::Util->new();
- print scalar localtime $f->last_changed('/bin/cpio');
-
-=head2 Get the last modified time for a file
-
- use File::Util qw( last_modified );
- print scalar localtime last_modified('/usr/bin/exim');
-
- -OR-
- use File::Util;
- print scalar localtime File::Util->last_modified('C:\COMMAND.COM');
-
- -OR-
- use File::Util;
- my($f) = File::Util->new();
- print scalar localtime $f->last_modified('/bin/less');
-
-=head2 Make a new directory, recursively if neccessary
-
- use File::Util;
- my($f) = File::Util->new();
- $f->make_dir('/var/tmp/tempfiles/foo/bar/');
-
- # optionally specify a creation bitmask to be used in directory creations
- $f->make_dir('/var/tmp/tempfiles/foo/bar/',0755);
-
-=head2 Touch a file
-
- use File::Util qw( touch );
- touch('somefile.txt');
-
- -OR-
- use File::Util;
- my($f) = File::Util->new();
- $f->touch('/foo/bar/baz.tmp');
-
-=head2 Truncate a file
-
- use File::Util;
- my($f) = File::Util->new();
- $f->trunc('/wibble/wombat/noot.tmp');
-
-=head2 Get the correct path seperator for the host system
-
- use File::Util qw( SL );
- print SL;
-
- -OR-
- use File::Util;
- print File::Util->SL;
-
- -OR-
- use File::Util;
- my($f) = File::Util->new();
- print $f->SL;
-
-=head2 Get the correct newline character for the host system
-
- use File::Util qw( NL );
- print NL;
-
- -OR-
- use File::Util;
- print File::Util->NL;
-
- -OR-
- use File::Util;
- my($f) = File::Util->new();
- print $f->NL;
-
-=head1 EXAMPLES (Full Programs)
-
-=head2 Batch File Rename
-
- # Code changes the file suffix of all files in a directory ending in
- # *.foo so that they afterward end in *.bar
-
- use strict;
- use vars qw( $dir );
- use File::Util qw( NL SL );
-
- my($f) = File::Util->new();
- my($dir) = '../wibble';
- my($old) = 'foo';
- my($new) = 'bar';
- my(@files) = $f->list_dir($dir, '--files-only');
-
- foreach (@files) {
-
- # don't change the file suffix unless it is *.foo
- if ($_ =~ /\.$old$/o) {
-
- my($newname) = $_; $newname =~ s/\.$old/\.$new/;
-
- if (rename($dir . SL . $_, $dir . SL . $newname)) {
-
- print qq[$_ -> $newname], NL
- }
- else { warn <<__ERR__ }
- Couldn't rename "$_" to "$newname"!
- __ERR__
- }
- else { print <<__NOCHANGE__ }
- File retained as "$_"
- __NOCHANGE__
- }
-
-=head2 Recursively remove a directory and all its contents
-
- # This code removes a directory and everything in it
-
- use strict; # always
-
- use File::Util qw( NL );
-
- my($f) = File::Util->new();
- my($removedir) = '/path/to/directory/youwanttodelete';
-
- my(@gonners) = $f->list_dir($removedir, '--follow');
-
- # remove directory and everything in it
- my($a, $b);
- foreach (reverse(sort({ length($a) <=> length($b) } @gonners)), $removedir) {
- print "Removing $_ ..." . NL;
- -d $_ ? rmdir($_) || die $! : unlink($_) || die $!;
- }
-
- print 'Done. w00T!', NL x 2;
-
-
-=head2 Wrap the lines in a file at 72 columns, then save it
-
- # This code opens a file, wraps its lines, and saves the file with
- # the newly formatted content
-
- use strict; # always
-
- use File::Util qw( NL );
- use Text::Wrap qw( wrap );
-
- $Text::Wrap::columns = 72; # wrap text at this many columns
-
- my($f) = File::Util->new();
- my($textfile) = 'myreport.txt'; # file to wrap and save
-
- $f->write_file(
- 'filename' => $textfile,
- 'content' => wrap('', '', $f->load_file($textfile))
- );
-
- print 'Done.', NL x 2;
-
-=head2 Read and increment a counter file, then save it
-
- # This code opens a file, reads a number value, increments it,
- # then saves the newly incremented value back to the file
-
- use strict; # always
-
- use File::Util;
-
- my($f) = File::Util->new();
- my($counterfile) = 'counter.txt';
-
- # if the counter file doesn't exist, let's make one
- if (! $f->existent($counterfile)) {
- $f->touch($counterfile);
- }
-
- my($count) = $f->load_file($counterfile);
-
- # convert textual number to in-memory int type, -this will default
- # to a zero if it encounters non-numerical or empty content
- chomp($count); # strip off any trailing lines
- $count =~ s/[^[:digit:]]//g; # remove non-numeric data
- $count = 0 if "$count" eq ''; # set count to 0 if empty string
- $count = int($count); # numberify $count
-
- print 'Count value from file: ' . $f->load_file($counterfile), $f->NL;
-
- $count++; # increment the counter value by 1
-
- # save the incremented count back to the counter file
- $f->write_file( 'filename' => $counterfile, 'content' => $count);
-
- # verify that "it worked"
- print 'Count is now: ' . $f->load_file($counterfile), $f->NL;
- print 'Done.', $f->NL x 2;
-
-=head2 Batch Search & Replace
-
- # Code does a batch find or search and replace for all files in a given
- # directory, recursively or non-recursively based on choices set forth
- # in the code.
-
- use strict;
- use File::Util qw( NL SL );
-
- # will get search pattern from file named below
- use constant SFILE => './sr/searchfor';
-
- # will get replace pattern from file named below
- use constant RFILE => './sr/replacewith';
-
- # will perform batch operation in directory named below
- use constant INDIR => '/foo/bar/baz';
-
- # specify whether the operation will do a find or a search and replace
- use constant RMODE => [qw| read-only write |]->[1];
-
- # set the options for the search (will or will not recurse, etc)
- my(@opts) = [qw/ --files-only --with-paths --recurse /]->[0,1];
-
- # create new File::Util object, set File::Util to send a warning for
- # fatal errors instead of dieing
- my($f) = File::Util->new('--fatals-as-warning');
- my($rstr) = $f->load_file(RFILE);
- my($spat) = quotemeta($f->load_file(SFILE)); $spat = qr/$spat/;
- my($gsbt) = 0;
- my($action) = RMODE eq 'read-only' ? 'detections' : 'substitutions';
- my(@files) = $f->list_dir(INDIR, @opts);
-
- for (my($i) = 0; $i < @files; ++$i) {
-
- next if $f->isbin($files[$i]);
-
- my($sbt) = 0; my($file) = $f->load_file($files[$i]);
-
- $file =~ s/$spat/++$sbt;++$gsbt;$rstr/ge;
-
- $f->write_file('file' => $files[$i], 'content' => $file)
- if RMODE eq 'write';
-
- print $sbt ? (qq[$sbt $action in $files[$i]] . NL) : '';
- }
-
- print( NL . <<__DONE__ . NL x 2) and exit;
- $gsbt $action in ${\scalar(@files)} files.
- __DONE__
-
-=head2 Pretty-Print A Directory Recursively
-
- use strict;
- use vars qw( $a $b );
-
- use File::Util qw( NL );
- my($ind) = '';
- my($f) = File::Util->new();
- my(@o) = qw(
- --with-paths
- --sl-after-dirs
- --no-fsdots
- --files-as-ref
- --dirs-as-ref
- );
-
- my($filetree) = {};
- my($treetrunk) = '/var/';
- my($subdirs,$sfiles) = $f->list_dir($treetrunk, @o);
-
- $filetree = [{
- $treetrunk => [ sort({ uc $a cmp uc $b } @$subdirs, @$sfiles) ]
- }];
-
- descend($filetree->[0]{ $treetrunk },scalar(@$subdirs));
- walk(@$filetree);
-
- sub descend {
- my($parent,$dirnum) = @_;
- for (my($i) = 0; $i < $dirnum; ++$i) {
- my($current) = $parent->[$i]; next unless -d $current;
- my($subdirs,$sfiles) = $f->list_dir($current, @o);
- map { $_ = $f->strip_path($_) } @$sfiles;
- splice(@$parent,$i,1,{
- $current => [ sort({ uc $a cmp uc $b } @$subdirs, @$sfiles) ]
- });
- descend($parent->[$i]{ $current },scalar(@$subdirs));
- }
- $parent
- }
-
- sub walk {
- my($dir) = shift(@_);
- foreach (@{ [ %$dir ]->[1] }) {
- my($mem) = $_;
- if (ref($mem) eq 'HASH') {
- print($ind . $f->strip_path([ %$mem ]->[0]) . '/',NL);
- $ind .= ' ' x 3;
- walk($mem);
- $ind = substr($ind,3);
- } else { print($ind . $mem,NL) }
- }
- }
-
-=head1 BUGS
-
-Send bug reports to the AUTHOR. There are no known bugs at this time.
-
-=head1 TODO
-
-Add full support for PerlIO layers in C<File::Util::open_handle()> and possibly
-C<File::Util::write_file()>.
-
-=head1 AUTHOR
-
-Tommy Butler <L<cpan@atrixnet.com|mailto:cpan@atrixnet.com>>
-
-=head1 COPYRIGHT
-
-Copyright(C) 2001-2007, Tommy Butler. All rights reserved.
-
-=head1 LICENSE
-
-This library is free software, you may redistribute and/or modify it under
-the same terms as Perl itself.
-
-=head1 SEE ALSO
-
-L<File::Slurp>, L<Exception::Handler>, L<Class::OOorNO>
@@ -0,0 +1,141 @@
+name = File-Util
+author = Tommy Butler
+license = Perl_5
+copyright_holder = Tommy Butler
+is_trial = 0
+
+[Meta::Contributors]
+contributor = John Fields <jfields.cpan.org@spammenot.com>
+contributor = Ricardo SIGNES <rjbs@cpan.org>
+contributor = Matt S Trout <perl-stuff@trout.me.uk>
+contributor = Nicholas Perez <nperez@cpan.org>
+contributor = David Golden <dagolden@cpan.org>
+
+[@Filter]
+bundle = @Basic
+remove = ExtraTests
+
+[RunExtraTests]
+
+[ModuleBuild]
+
+[AutoVersion]
+major = 4
+
+[PkgVersion]
+[PodVersion]
+[MetaProvides::Package]
+[MinimumPerl]
+[MetaConfig]
+[MetaJSON]
+[MetaResources]
+homepage = https://github.com/tommybutler/file-util/wiki
+bugtracker.web = https://rt.cpan.org/Dist/Display.html?Name=File%3A%3AUtil
+bugtracker.mailto = bug-File-Util@rt.cpan.org
+repository.url = git://github.com/tommybutler/file-util.git
+repository.web = https://github.com/tommybutler/file-util
+repository.type = git
+
+[ReportVersions::Tiny]
+
+[Test::LocalBrew]
+brews = perl-5.8.9
+brews = perl-5.10.1
+brews = perl-5.12.5
+brews = perl-5.14.4
+brews = perl-5.16.3
+brews = perl-5.17.10
+brews = perl-5.18.0
+
+[@TestingMania]
+disable = Test::Portability ; won't accept options; wrote my own version instead
+disable = Test::EOL ; some of the tests fail their own EOL test; strange
+disable = Test::Pod::LinkCheck ; buggy, causes too many failures
+disable = Test::MinimumVersion ; I do this myself, via the Perlbrew testing
+
+[Test::PodSpelling]
+stopwords = AND'ed
+stopwords = ascii
+stopwords = bitmask
+stopwords = BrowserUk
+stopwords = BLOCKEX
+stopwords = CIFS
+stopwords = conf
+stopwords = dat
+stopwords = dbitmask
+stopwords = ebcdic
+stopwords = EBCDIC
+stopwords = EPOC
+stopwords = failsafe
+stopwords = FIFOs
+stopwords = Github
+stopwords = html
+stopwords = inodes
+stopwords = listrefs
+stopwords = NFS
+stopwords = oct
+stopwords = onfail
+stopwords = SIGNES
+stopwords = SMB
+stopwords = Solaris
+stopwords = SOLARIS
+stopwords = subpattern
+stopwords = subref
+stopwords = subrefs
+stopwords = syntaxes
+stopwords = trunc
+stopwords = txt
+stopwords = unicode
+stopwords = VMS
+stopwords = vtab
+stopwords = benchmarking
+stopwords = merchantability
+stopwords = lexically
+
+[CheckChangesHasContent]
+[TestRelease]
+[ConfirmRelease]
+
+[Signature]
+sign = always
+
+; The plugin below is ::Extra cool, but a little buggy; I only use it sometimes
+; and it can't be used at the same time as the more mainstream Test::Kwalitee
+; plugin from chromatic (above)
+;
+;[Test::Kwalitee::Extra]
+;arg = !valid_signature
+
+[AutoPrereqs]
+; reminder: double check that all prereqs have been detected!
+
+; regarding prereqs section syntax (taken from dzil source code) -
+; (Build|Test|Runtime|Configure|Develop)?(Requires|Recommends|Suggests|Conflicts)
+
+[Prereqs / TestRequires]
+AutoLoader = 0
+Config = 0
+Cwd = 0
+Exporter = 0
+ExtUtils::MakeMaker = 0
+Fcntl = 0
+File::Temp = 0
+Module::Build = 0
+Test = 0
+Test::More = 0
+Test::NoWarnings = 0
+Scalar::Util = 0
+
+[Prereqs / Recommends]
+Unicode::UTF8 = 0.58 ; this will eventually be utilized as an optimization
+
+[Prereqs / DevelopRequires]
+Dist::Zilla = 0
+Perl::Critic = 0
+Perl::Critic::Lax = 0
+Devel::Cover = 0
+Test::Fatal = 0
+
+;[Prereqs / DevelopRecommends]
+;Devel::NYTProf = 0
+
@@ -0,0 +1,38 @@
+# ABSTRACT: Batch-rename all files in a directory
+
+# This code changes the file suffix of all files in a directory
+# ending in *.log so that they end in *.txt
+#
+# Note - This example is NOT recursive.
+
+use strict;
+use warnings;
+use vars qw( $dir );
+
+# Regarding "SL" below: On Win/DOS, it is "\" and on Mac/BSD/Linux it is "/"
+# File::Util will automatically detect this for you.
+use File::Util qw( NL SL );
+
+my $ftl = File::Util->new();
+my $dir = 'some/log/directory';
+my @files = $ftl->list_dir( $dir, '--files-only' );
+
+foreach my $file ( @files ) {
+
+ # don't change the file suffix unless it is *.log
+ next unless $file =~ /log$/;
+
+ my $newname = $file;
+ $newname =~ s/\.log$/\.txt/;
+
+ if ( rename $dir . SL . $file, $dir . SL . $newname ) {
+
+ print qq($file -> $newname), NL
+ }
+ else {
+
+ warn qq(Couldn't rename "$_" to "$newname" - $!)
+ }
+}
+
+exit;
@@ -0,0 +1,48 @@
+# ABSTRACT: Recursively perform a search/replace on the file contents of a directory
+
+# Code does a recursive batch search/replace on the content of all files
+# in a given directory
+#
+# Note - this code skips binary files
+
+use strict;
+use warnings;
+use File::Util qw( NL SL );
+
+# will get search pattern from file named below
+use constant SFILE => './sr/searchfor';
+
+# will get replace pattern from file named below
+use constant RFILE => './sr/replacewith';
+
+# will perform batch operation in directory named below
+use constant INDIR => '/foo/bar/baz';
+
+
+# create new File::Util object, set File::Util to send a warning for
+# fatal errors instead of dieing
+my $ftl = File::Util->new( '--fatals-as-warning' );
+my $rstr = $ftl->load_file( RFILE );
+my $spat = quotemeta $ftl->load_file( SFILE ); $spat = qr/$spat/;
+my $gsbt = 0;
+my @opts = qw/ --files-only --with-paths --recurse /;
+my @files = $ftl->list_dir( INDIR, @opts );
+
+for (my $i = 0; $i < @files; ++$i) {
+
+ next if $ftl->is_bin( $files[$i] );
+
+ my $sbt = 0; my $file = $ftl->load_file( $files[$i] );
+
+ $file =~ s/$spat/++$sbt;++$gsbt;$rstr/ge;
+
+ $ftl->write_file( file => $files[$i], content => $file );
+
+ print $sbt ? qq($sbt replacements in $files[$i]) . NL : '';
+}
+
+print NL . <<__DONE__ . NL;
+$gsbt replacements in ${\ scalar @files } files.
+__DONE__
+
+exit;
@@ -0,0 +1,28 @@
+# ABSTRACT: Get an open file handle for reading or writing
+
+use strict;
+use warnings;
+use File::Util;
+
+my $ftl = File::Util->new();
+
+my $file = 'example.txt'; # in this example, this file must already exist
+
+# open the file for writing
+my $fh = $ftl->open_handle( file => $file );
+
+print $fh 'Hello World!';
+
+close $fh; # <-- the file won't be unlocked in this process unless we close it
+
+# open the file for reading now
+$fh = $ftl->open_handle( file => $file, mode => 'read' );
+
+while ( <$fh> ) {
+
+ print;
+}
+
+close $fh;
+
+exit;
@@ -0,0 +1,32 @@
+# ABSTRACT: Open a file, read a number value, increment it, save the file
+
+# For the sake of simplicity, this code assumes:
+# * the counter file already exist and is writeable
+# * the counter file has one line, which contains only numbers
+
+use strict; # always
+use warnings;
+
+use File::Util;
+
+my $ftl = File::Util->new();
+my $counterfile = 'counter.txt'; # the counter file needs to already exist
+
+my $count = $ftl->load_file( $counterfile );
+
+# convert textual number to in-memory int type, -this will default
+# to a zero if it encounters non-numerical or empty content
+chomp $count;
+$count = int $count;
+
+print "Count value from file: $count.";
+
+$count++; # increment the counter value by 1
+
+# save the incremented count back to the counter file
+$ftl->write_file( filename => $counterfile, content => $count );
+
+# verify that it worked
+print ' Count is now: ' . $ftl->load_file( $counterfile );
+
+exit;
@@ -0,0 +1,20 @@
+# ABSTRACT: List the contents of a directory
+
+use strict;
+use warnings;
+use File::Util qw( NL );
+
+my $ftl = File::Util->new();
+
+my $dir = '/tmp'; # in this example, this file must already exist
+
+# option --no-fsdots excludes "." and ".." from the list
+my @dirs_and_files = $f->list_dir( $dir, '--no-fsdots' );
+
+# The NL constant below will be the apropriate newline character sequence
+# for your operating system... "\n" or "\r\n"
+
+# print out the list of files, each on its own line
+print join NL, @dirs_and_files;
+
+exit;
@@ -0,0 +1,20 @@
+# ABSTRACT: List the contents of a directory and all its subdirectories (recursive)
+
+use strict;
+use warnings;
+use File::Util qw( NL );
+
+my $ftl = File::Util->new();
+
+my $dir = '/tmp'; # in this example, this file must already exist
+
+# option --no-fsdots excludes "." and ".." from the list
+my @dirs_and_files = $f->list_dir( $dir, '--recurse' );
+
+# The NL constant below will be the apropriate newline character sequence
+# for your operating system... "\n" or "\r\n"
+
+# print out the list of files, each on its own line
+print join NL, @dirs_and_files;
+
+exit;
@@ -0,0 +1,23 @@
+# ABSTRACT: Load the contents of a file into a string or array
+
+use strict;
+use warnings;
+use File::Util qw( NL );
+
+my $ftl = File::Util->new();
+
+my $file = 'example.txt'; # in this example, this file must already exist
+
+# get the whole file in one string
+my $content = $ftl->load_file( $file );
+
+print $content;
+
+# get the file in a list of lines
+my @content_lines = $ftl->load_file( $file, '--as-lines' );
+
+# The NL constant below will be the apropriate newline character sequence
+# for your operating system... "\n" or "\r\n"
+print join NL, @content_lines;
+
+exit;
@@ -0,0 +1,16 @@
+# ABSTRACT: Make a new directory, even if the parent directory doesn't exist
+
+use strict;
+use warnings;
+use File::Util;
+
+my $ftl = File::Util->new();
+
+$ftl->make_dir( '/tmp/myapp_tempfiles' );
+
+# optionally specify a creation bitmask to be used in directory creations.
+# the bitmask is combined with the user's current umask for the creation
+# mode of the file. (You should usually omit this.)
+$ftl->make_dir( '/tmp/a/b/c/foo/bar', oct 755 );
+
+exit;
@@ -0,0 +1,87 @@
+# ABSTRACT: manually pretty print a directory, recursively
+
+# This example shows a manual walker and descender. It is inferior
+# to the prety_print_a_directory_using_callbacks* scripts, and takes
+# more time/effort/code. This example script is limited: it can
+# only walk single top-level directories-- moral of the story: using
+# callbacks is the clearly superior option.
+#
+# This example is here less for exhibition as a good example, and
+# much more for exhibition about how not-to-walk directories. Take
+# a look at the other examples instead ;-)
+
+# set this to the name of the directory to pretty-print
+my $treetrunk = '/tmp';
+
+use strict;
+use warnings;
+
+use File::Util qw( NL );
+my $indent = '';
+my $ftl = File::Util->new();
+my $opts = {
+ with_paths => 1,
+ sl_after_dirs => 1,
+ no_fsdots => 1,
+ as_ref => 1,
+ onfail => 'zero'
+};
+
+my $filetree = {};
+my( $subdirs, $sfiles ) = $ftl->list_dir( $treetrunk => $opts );
+
+$filetree = [{
+ $treetrunk => [ sort { uc $a cmp uc $b } @$subdirs, @$sfiles ]
+}];
+
+descend( $filetree->[0]{ $treetrunk }, scalar @$subdirs );
+
+walk( @$filetree );
+
+exit;
+
+sub descend {
+
+ my( $parent, $dirnum ) = @_;
+
+ for ( my $i = 0; $i < $dirnum; ++$i ) {
+
+ my $current = $parent->[ $i ];
+
+ next unless -d $current;
+
+ my( $subdirs, $sfiles ) = $ftl->list_dir( $current => $opts );
+
+ map { $_ = $ftl->strip_path( $_ ) } @$sfiles;
+
+ splice @$parent, $i, 1,
+ { $current => [ sort { uc $a cmp uc $b } @$subdirs, @$sfiles ] };
+
+ descend( $parent->[$i]{ $current }, scalar @$subdirs );
+ }
+
+ return $parent;
+}
+
+sub walk {
+
+ my $dir = shift @_;
+
+ foreach ( @{ [ %$dir ]->[1] } ) {
+
+ my $mem = $_;
+
+ if ( ref $mem eq 'HASH' ) {
+
+ print $indent . $ftl->strip_path([ %$mem ]->[0]) . '/', NL;
+
+ $indent .= ' ' x 3; # increase indent
+
+ walk( $mem );
+
+ $indent = substr( $indent, 3 ); # decrease indent
+
+ } else { print $indent . $mem, NL }
+ }
+}
+
@@ -0,0 +1,46 @@
+# ABSTRACT: pretty print a directory, recursively, using list_dir( "as_tree" )
+
+# The fool-proof, dead-simple way to pretty-print a directory tree. Caveat:
+# This isn't a method for massive directory traversal, and is subject to the
+# limitations inherent in stuffing an entire directory tree into RAM. Go
+# back and use bare callbacks (see other examples) if you need a more efficient,
+# streaming (real-time) pretty-printer where top-level sorting is less
+# important than resource constraints and speed of execution.
+
+# set this to the name of the directory to pretty-print
+my $treetrunk = '.';
+
+use warnings;
+use strict;
+
+use lib './lib';
+use File::Util qw( NL SL );
+
+my $ftl = File::Util->new( { onfail => 'zero' } );
+
+walk( $ftl->list_dir( $treetrunk => { as_tree => 1, recurse => 1 } ) );
+
+exit;
+
+sub walk
+{
+ my ( $branch, $depth ) = @_;
+
+ $depth ||= 0;
+
+ talk( $depth - 1, $branch->{_DIR_SELF_} . SL ) if $branch->{_DIR_SELF_};
+
+ delete @$branch{ qw( _DIR_SELF_ _DIR_PARENT_ ) };
+
+ talk( $depth, $branch->{ $_ } ) for sort { uc $a cmp uc $b } keys %$branch;
+}
+
+sub talk
+{
+ my ( $indent, $item ) = @_;
+
+ return walk( $item, $indent + 1 ) if ref $item;
+
+ print( ( ' ' x ( $indent * 3 ) ) . ( $item || '' ) . NL );
+}
+
@@ -0,0 +1,56 @@
+# ABSTRACT: pretty print a directory, recursively, using callbacks, fancy
+
+# Subject to the limitations of alphabetical sorting. For the fool-proof
+# method, see pretty_print_a_directory_using_as_tree.pl (which also uses
+# callbacks behind the scenes) Hint: that callback is tucked away within the
+# guts of File::Util and externally exposed as the listdir "as_tree" option
+
+# set this to the name of the directory to pretty-print
+my $treetrunk = '.';
+
+use warnings;
+use strict;
+
+use lib './lib';
+use File::Util;
+
+my $ftl = File::Util->new( { onfail => 'zero' } );
+
+$ftl->list_dir( $treetrunk => { callback => \&callback, recurse => 1 } );
+
+exit;
+
+sub callback
+{
+ my ( $dir, $subdirs, $files, $depth ) = @_;
+
+ my $header = sprintf
+ '| IN %s - %d sub-directories | %d files | %d DEEP',
+ $dir,
+ scalar @$subdirs,
+ scalar @$files,
+ $depth;
+
+ pprint( $depth, '+' . ( '-' x 70 ) );
+ pprint( $depth, $header );
+ pprint( $depth, '+' . ( '-' x 70 ) );
+
+ pprint( $depth, " SUBDIRS IN $dir" );
+ pprint( $depth, " - none" ) unless @$subdirs;
+ pprint( $depth, " - $_" ) for @$subdirs;
+
+ pprint( $depth, " FILES in $dir" );
+ pprint( $depth, " - none" ) unless @$files;
+ pprint( $depth, " - $_" ) for @$files;
+
+ print "\n";
+
+ return;
+}
+
+sub pprint
+{
+ my ( $indent, $text ) = @_;
+ print( ( ' ' x ( $indent * 3 ) ) . $text . "\n" );
+}
+
@@ -0,0 +1,42 @@
+# ABSTRACT: pretty print a directory, recursively, using callbacks
+
+# Subject to the limitations of alphabetical sorting. For the fool-proof
+# method, see pretty_print_a_directory_using_as_tree.pl (which also uses
+# callbacks behind the scenes) Hint: that callback is tucked away within the
+# guts of File::Util and externally exposed as the listdir "as_tree" option
+
+# set this to the name of the directory to pretty-print
+my $treetrunk = '.';
+
+use warnings;
+use strict;
+
+use lib './lib';
+use File::Util qw( NL );
+
+my $ftl = File::Util->new( { onfail => 'zero' } );
+my @tree;
+
+$ftl->list_dir( $treetrunk => { callback => \&callback, recurse => 1 } );
+
+print for sort { uc ltrim( $a ) cmp uc ltrim( $b ) } @tree;
+
+exit;
+
+sub callback
+{
+ my ( $dir, $subdirs, $files, $depth ) = @_;
+
+ stash( $depth, $_ ) for sort { uc $a cmp uc $b } @$subdirs, @$files;
+
+ return;
+}
+
+sub stash
+{
+ my ( $indent, $text ) = @_;
+ push( @tree, ( ' ' x ( $indent * 3 ) ) . $text . NL );
+}
+
+sub ltrim { my $trim = shift @_; $trim =~ s/^\s+//; $trim }
+
@@ -0,0 +1,24 @@
+# ABSTRACT: This code removes a directory and everything in it
+
+use strict;
+use warnings;
+use File::Util qw( NL );
+
+my $ftl = File::Util->new();
+my $removedir = '/path/to/directory/youwanttodelete';
+
+my @gonners = $ftl->list_dir( $removedir, '--recurse' );
+
+# remove directory and everything in it
+@gonners = reverse sort { length $a <=> length $b } @gonners;
+
+foreach my $gonner ( @gonners, $removedir ) {
+
+ print "Removing $gonner ...", NL;
+
+ -d $gonner ? rmdir $gonner || die $! : unlink $gonner || die $!;
+ }
+
+print 'Done. w00T!', NL;
+
+exit;
@@ -0,0 +1,47 @@
+# ABSTRACT: Try opening a file, falling back to a failsafe file on error
+
+use strict;
+use warnings;
+
+use File::Util qw( NL );
+
+my $ftl = File::Util->new();
+
+my $might_not_work = '/this/might/not/work.txt';
+my $will_work_for_sure = '/tmp/file.txt';
+my $used_backup_plan = 0;
+
+my $file_handle = $ftl->open_handle
+(
+ $might_not_work =>
+ {
+ mode => 'write',
+ onfail => sub
+ {
+ my ( $err, $stack_trace ) = @_;
+
+ warn "Couldn't open first choice, trying a backup plan...";
+
+ $used_backup_plan = 1;
+
+ return $ftl->open_handle( $will_work_for_sure => { mode => 'write' } );
+ },
+ }
+);
+
+print $file_handle 'Hello World! The time is now ' . scalar localtime;
+
+print $file_handle NL; # portably add a new line to the end of the file
+
+close $file_handle or die $!;
+
+# print out whichever file we were able to successfully write
+print $ftl->load_file
+(
+ $used_backup_plan
+ ? $will_work_for_sure
+ : $might_not_work
+);
+
+exit;
+
@@ -0,0 +1,21 @@
+# ABSTRACT: open a file, wrap its lines, save the file with the newly formatted content
+
+use strict; # always
+use warnings;
+use File::Util qw( NL );
+use Text::Wrap qw( wrap );
+
+$Text::Wrap::columns = 72; # wrap text at this many columns
+
+my $ftl = File::Util->new();
+my $file = 'example.txt'; # file to wrap and save (must already exist)
+
+$ftl->write_file(
+ filename => $file,
+ content => wrap('', '', $ftl->load_file( $file ))
+);
+
+# display the newly formatted file
+print $ftl->load_file( $file );
+
+exit;
@@ -0,0 +1,30 @@
+# ABSTRACT: Easily write or append to a file in one go
+
+use strict;
+use warnings;
+use File::Util;
+
+my $ftl = File::Util->new();
+
+my $file = 'example.txt';
+
+# writing content to the file, creating it if it doesn't exist
+$ftl->write_file( file => $file, content => 'Hello World!' );
+
+# you optionally specify a bitmask for a file if it doesn't exist yet.
+# the bitmask is combined with the user's current umask for the creation
+# mode of the file. (You should usually omit this.)
+$ftl->write_file(
+ file => 'new.txt',
+ bitmask => oct 777,
+ content => 'Hello World!'
+);
+
+# append to the file you just created
+$ftl->write_file(
+ file => 'new.txt',
+ content => 'Goodbye cruel world',
+ mode => 'append'
+);
+
+exit;
@@ -0,0 +1,328 @@
+package File::Util::Cookbook;
+use strict; use warnings; # for kwalitee tests
+
+# ABSTRACT: File::Util in Action
+
+=pod
+
+=head1 NAME
+
+File::Util::Cookbook - File::Util in Action
+
+=head1 VERSION
+
+version 4.132140
+
+=head1 INTRODUCTION
+
+The following are fully functional programs using L<File::Util> to accomplish
+some common tasks. Note that not nearly everything helpful use of File::Util
+could be covered here, but the following are examples showing answers to the
+questions commonly asked.
+
+For a simple reference on File::Util, take a look at the manual at
+L<File::Util::Manual>.
+
+=head1 EXAMPLES
+
+These are included in the standalone scripts that come in the
+"examples" directory as part of this distribution.
+
+=head2 Batch File Rename
+
+ # This code changes the file suffix of all files in a directory
+ # ending in *.log so that they end in *.txt
+ #
+ # Note - This example is NOT recursive.
+
+ use strict;
+ use warnings;
+ use vars qw( $dir );
+
+ # Regarding "SL" below: On Win/DOS, it is "\" and on Mac/BSD/Linux it is "/"
+ # File::Util will automatically detect this for you.
+ use File::Util qw( NL SL );
+
+ my $ftl = File::Util->new();
+ my $dir = 'some/log/directory';
+ my @files = $ftl->list_dir( $dir => { files_only => 1 } );
+
+ foreach my $file ( @files ) {
+
+ # don't change the file suffix unless it is *.log
+ next unless $file =~ /log$/;
+
+ my $newname = $file;
+ $newname =~ s/\.log$/\.txt/;
+
+ if ( rename $dir . SL . $file, $dir . SL . $newname ) {
+
+ print qq($file -> $newname), NL
+ }
+ else {
+
+ warn qq(Couldn't rename "$_" to "$newname" - $!)
+ }
+ }
+
+ exit;
+
+=head2 Recursively remove a directory and all its contents
+
+ # This code removes a directory and everything in it
+
+ use strict;
+ use warnings;
+ use File::Util qw( NL );
+
+ my $ftl = File::Util->new();
+ my $removedir = '/path/to/directory/youwanttodelete';
+
+ my @gonners = $ftl->list_dir( $removedir => { recurse => 1 } );
+
+ # remove directory and everything in it
+ @gonners = reverse sort { length $a <=> length $b } @gonners;
+
+ foreach my $gonner ( @gonners, $removedir ) {
+
+ print "Removing $gonner ...", NL;
+
+ -d $gonner ? rmdir $gonner || die $! : unlink $gonner || die $!;
+ }
+
+ print 'Done!', NL;
+
+ exit;
+
+=head2 Try opening a file, falling back to a failsafe file if there's an error
+
+ use strict;
+ use warnings;
+
+ use File::Util qw( NL );
+
+ my $ftl = File::Util->new();
+
+ my $might_not_work = '/this/might/not/work.txt';
+ my $will_work_for_sure = '/tmp/file.txt';
+ my $used_backup_plan = 0;
+
+ my $file_handle = $ftl->open_handle
+ (
+ $might_not_work =>
+ {
+ mode => 'write',
+ onfail => sub
+ {
+ my ( $err, $stack_trace ) = @_;
+
+ warn "Couldn't open first choice, trying a backup plan...";
+
+ $used_backup_plan = 1;
+
+ return $ftl->open_handle
+ (
+ $will_work_for_sure => { mode => 'write' }
+ );
+ },
+ }
+ );
+
+ print $file_handle 'Hello World! The time is now ' . scalar localtime;
+
+ print $file_handle NL; # portably add a new line to the end of the file
+
+ close $file_handle or die $!;
+
+ # print out whichever file we were able to successfully write
+ print $ftl->load_file
+ (
+ $used_backup_plan
+ ? $will_work_for_sure
+ : $might_not_work
+ );
+
+ exit;
+
+=head2 Wrap the lines in a file at 72 columns, then save it
+
+ # This code opens a file, wraps its lines, and saves the file with
+ # the newly formatted content
+
+ use strict; # always
+ use warnings;
+
+ use File::Util qw( NL );
+ use Text::Wrap qw( wrap );
+
+ $Text::Wrap::columns = 72; # wrap text at this many columns
+
+ my $f = File::Util->new();
+ my $textfile = 'myreport.txt'; # file to wrap and save
+
+ $f->write_file(
+ filename => $textfile,
+ content => wrap('', '', $f->load_file($textfile))
+ );
+
+ print 'Done.', NL x 2;
+
+=head2 Read and increment a counter file, then save it
+
+ # This code opens a file, reads a number value, increments it,
+ # then saves the newly incremented value back to the file
+
+ # For the sake of simplicity, this code assumes:
+ # * the counter file already exist and is writeable
+ # * the counter file has one line, which contains only numbers
+
+ use strict; # always
+ use warnings;
+
+ use File::Util;
+
+ my $ftl = File::Util->new();
+ my $counterfile = 'counter.txt'; # the counter file needs to already exist
+
+ my $count = $ftl->load_file( $counterfile );
+
+ # convert textual number to in-memory int type, -this will default
+ # to a zero if it encounters non-numerical or empty content
+ chomp $count;
+ $count = int $count;
+
+ print "Count value from file: $count.";
+
+ $count++; # increment the counter value by 1
+
+ # save the incremented count back to the counter file
+ $ftl->write_file( filename => $counterfile, content => $count );
+
+ # verify that it worked
+ print ' Count is now: ' . $ftl->load_file( $counterfile );
+
+ exit;
+
+=head2 Batch Search & Replace
+
+ # Code does a recursive batch search/replace on the content of all files
+ # in a given directory
+ #
+ # Note - this code skips binary files
+
+ use strict;
+ use warnings;
+ use File::Util qw( NL SL );
+
+ # will get search pattern from file named below
+ use constant SFILE => './sr/searchfor';
+
+ # will get replace pattern from file named below
+ use constant RFILE => './sr/replacewith';
+
+ # will perform batch operation in directory named below
+ use constant INDIR => '/foo/bar/baz';
+
+
+ # create new File::Util object, set File::Util to send a warning for
+ # fatal errors instead of dying
+ my $ftl = File::Util->new( onfail => 'warn' );
+ my $rstr = $ftl->load_file( RFILE );
+ my $spat = quotemeta $ftl->load_file( SFILE ); $spat = qr/$spat/;
+ my $gsbt = 0;
+ my $opts = { files_only => 1, with_paths => 1, recurse => 1 };
+ my @files = $ftl->list_dir( INDIR => $opts );
+
+ for (my $i = 0; $i < @files; ++$i) {
+
+ next if $ftl->is_bin( $files[$i] );
+
+ my $sbt = 0; my $file = $ftl->load_file( $files[$i] );
+
+ $file =~ s/$spat/++$sbt;++$gsbt;$rstr/ge;
+
+ $ftl->write_file( file => $files[$i], content => $file );
+
+ print $sbt ? qq($sbt replacements in $files[$i]) . NL : '';
+ }
+
+ print NL . <<__DONE__ . NL;
+ $gsbt replacements in ${\ scalar @files } files.
+ __DONE__
+
+ exit;
+
+=head2 Pretty-Print A Directory Recursively
+
+This is the fool-proof, dead-simple way to pretty-print a directory tree.
+Caveat: This isn't a method for massive directory traversal, and is subject to
+the limitations inherent in stuffing an entire directory tree into RAM. Go
+back and use bare callbacks (see the other example scripts that came in the
+"examples" subdirectory of this distribution) if you need a more efficient,
+streaming (real-time) pretty-printer where top-level sorting is less important
+than resource constraints and speed of execution.
+
+ # set this to the name of the directory to pretty-print
+ my $treetrunk = '.';
+
+ use warnings;
+ use strict;
+
+ use lib './lib';
+ use File::Util qw( NL SL );
+
+ my $ftl = File::Util->new( { onfail => 'zero' } );
+
+ walk( $ftl->list_dir( $treetrunk => { as_tree => 1, recurse => 1 } ) );
+
+ exit;
+
+ sub walk
+ {
+ my ( $branch, $depth ) = @_;
+
+ $depth ||= 0;
+
+ talk( $depth - 1, $branch->{_DIR_SELF_} . SL ) if $branch->{_DIR_SELF_};
+
+ delete @$branch{ qw( _DIR_SELF_ _DIR_PARENT_ ) };
+
+ talk( $depth, $branch->{ $_ } ) for sort { uc $a cmp uc $b } keys %$branch;
+ }
+
+ sub talk
+ {
+ my ( $indent, $item ) = @_;
+
+ return walk( $item, $indent + 1 ) if ref $item;
+
+ print( ( ' ' x ( $indent * 3 ) ) . ( $item || '' ) . NL );
+ }
+
+=head1 AUTHORS
+
+Tommy Butler L<http://www.atrixnet.com/contact>
+
+=head1 COPYRIGHT
+
+Copyright(C) 2001-2013, Tommy Butler. All rights reserved.
+
+=head1 LICENSE
+
+This library is free software, you may redistribute it and/or modify it
+under the same terms as Perl itself. For more details, see the full text of
+the LICENSE file that is included in this distribution.
+
+=head1 LIMITATION OF WARRANTY
+
+This software is distributed in the hope that it will be useful, but without
+any warranty; without even the implied warranty of merchantability or fitness
+for a particular purpose.
+
+=head1 SEE ALSO
+
+L<File::Util::Cookbook>
+
+=cut
+
+__END__
@@ -0,0 +1,199 @@
+use strict;
+use warnings;
+
+package File::Util::Definitions;
+{
+ $File::Util::Definitions::VERSION = '4.132140';
+}
+
+# ABSTRACT: Global symbols and constants used in most File::Util classes
+
+use Fcntl qw( :flock );
+
+use vars qw(
+ @ISA @EXPORT_OK %EXPORT_TAGS
+ $OS $MODES $READ_LIMIT $ABORT_DEPTH
+ $USE_FLOCK @ONLOCKFAIL $ILLEGAL_CHR $CAN_FLOCK
+ $EBCDIC $DIRSPLIT $_LOCKS $NEEDS_BINMODE
+ $WINROOT $ATOMIZER $SL $NL $EMPTY_WRITES_OK
+ $FSDOTS $AUTHORITY $EBL $EBR $HAVE_UU
+);
+
+use Exporter;
+
+$AUTHORITY = 'cpan:TOMMY';
+@ISA = qw( Exporter );
+@EXPORT_OK = qw(
+ $OS OS $MODES $READ_LIMIT $ABORT_DEPTH
+ $USE_FLOCK @ONLOCKFAIL $ILLEGAL_CHR $CAN_FLOCK
+ $EBCDIC $DIRSPLIT $_LOCKS $NEEDS_BINMODE
+ $WINROOT $ATOMIZER $SL $NL $EMPTY_WRITES_OK
+ $FSDOTS $AUTHORITY SL NL $EBL $EBR
+ $HAVE_UU
+);
+
+%EXPORT_TAGS = ( all => [ @EXPORT_OK ] );
+
+BEGIN {
+
+ # Some OS logic.
+ unless ( $OS = $^O )
+ {
+ require Config;
+
+ { no warnings 'once'; $OS = $Config::Config{osname} }
+ };
+
+ { local $@; $HAVE_UU = eval { require 5.008001 } }
+
+ if ( $OS =~ /^darwin/i ) { $OS = 'UNIX' }
+ elsif ( $OS =~ /^cygwin/i ) { $OS = 'CYGWIN' }
+ elsif ( $OS =~ /^MSWin/i ) { $OS = 'WINDOWS' }
+ elsif ( $OS =~ /^vms/i ) { $OS = 'VMS' }
+ elsif ( $OS =~ /^bsdos/i ) { $OS = 'UNIX' }
+ elsif ( $OS =~ /^dos/i ) { $OS = 'DOS' }
+ elsif ( $OS =~ /^MacOS/i ) { $OS = 'MACINTOSH' }
+ elsif ( $OS =~ /^epoc/ ) { $OS = 'EPOC' }
+ elsif ( $OS =~ /^os2/i ) { $OS = 'OS2' }
+ else { $OS = 'UNIX' }
+
+$EBCDIC = qq[\t] ne qq[\011] ? 1 : 0;
+$NEEDS_BINMODE = $OS =~ /WINDOWS|DOS|OS2|MSWin/ ? 1 : 0;
+$NL =
+ $NEEDS_BINMODE ? qq[\015\012]
+ : $EBCDIC || $OS eq 'VMS' ? qq[\n]
+ : $OS eq 'MACINTOSH' ? qq[\015]
+ : qq[\012];
+$SL =
+ { DOS => '\\', EPOC => '/', MACINTOSH => ':',
+ OS2 => '\\', UNIX => '/', WINDOWS => chr(92),
+ VMS => '/', CYGWIN => '/', }->{ $OS } || '/';
+
+$_LOCKS = { };
+
+} BEGIN {
+ use constant NL => $NL;
+ use constant SL => $SL;
+ use constant OS => $OS;
+}
+
+$WINROOT = qr/^(?: [[:alpha:]]{1} ) : (?: \\{1,2} )/x;
+$DIRSPLIT = qr/$WINROOT | [\\:\/]/x;
+$ATOMIZER = qr/
+ (^ $DIRSPLIT ){0,1}
+ (?: (.*) $DIRSPLIT ){0,1}
+ (.*) /x;
+$ILLEGAL_CHR = qr/[\/\|\\$NL\r\n\t\013\*\"\?\<\:\>]/;
+$FSDOTS = qr/^\.{1,2}$/;
+$READ_LIMIT = 52428800; # set read_limit to a default of 50 megabytes
+$ABORT_DEPTH = 1000; # maximum depth for recursive list_dir calls
+
+{
+ local $@;
+
+ eval {
+ flock( STDOUT, &Fcntl::LOCK_SH );
+ flock( STDOUT, &Fcntl::LOCK_UN );
+ };
+
+ $CAN_FLOCK = $@ ? 0 : 1;
+}
+
+# try to use file locking, define flock race conditions policy
+$USE_FLOCK = 1;
+@ONLOCKFAIL = qw( NOBLOCKEX FAIL );
+
+$MODES->{popen} = {
+ write => '>', trunc => '>', rwupdate => '+<',
+ append => '>>', read => '<', rwclobber => '+>',
+ rwcreate => '+>', rwappend => '+>>',
+};
+
+$MODES->{sysopen} = {
+ read => &Fcntl::O_RDONLY,
+ write => &Fcntl::O_WRONLY | &Fcntl::O_CREAT,
+ append => &Fcntl::O_WRONLY | &Fcntl::O_APPEND | &Fcntl::O_CREAT,
+ trunc => &Fcntl::O_WRONLY | &Fcntl::O_CREAT | &Fcntl::O_TRUNC,
+ rwcreate => &Fcntl::O_RDWR | &Fcntl::O_CREAT,
+ rwclobber => &Fcntl::O_RDWR | &Fcntl::O_TRUNC | &Fcntl::O_CREAT,
+ rwappend => &Fcntl::O_RDWR | &Fcntl::O_APPEND | &Fcntl::O_CREAT,
+ rwupdate => &Fcntl::O_RDWR,
+};
+
+# --------------------------------------------------------
+# %$File::Util::Definitions::LOCKS
+# --------------------------------------------------------
+$_LOCKS->{IGNORE} = sub { $_[2] };
+$_LOCKS->{ZERO} = sub { 0 };
+$_LOCKS->{UNDEF} = sub { };
+$_LOCKS->{NOBLOCKEX} = sub {
+ return $_[2] if flock( $_[2], &Fcntl::LOCK_EX | &Fcntl::LOCK_NB ); return
+};
+$_LOCKS->{NOBLOCKSH} = sub {
+ return $_[2] if flock( $_[2], &Fcntl::LOCK_SH | &Fcntl::LOCK_NB ); return
+};
+$_LOCKS->{BLOCKEX} = sub {
+ return $_[2] if flock( $_[2], &Fcntl::LOCK_EX ); return
+};
+$_LOCKS->{BLOCKSH} = sub {
+ return $_[2] if flock( $_[2], &Fcntl::LOCK_SH ); return
+};
+$_LOCKS->{WARN} = sub {
+
+ my $this = shift;
+
+ return $this->_throw(
+ 'bad flock' =>
+ {
+ filename => shift,
+ exception => $!,
+ onfail => 'warn',
+ opts => $this->_remove_opts( \@_ ),
+ },
+ );
+};
+$_LOCKS->{FAIL} = sub {
+
+ my $this = shift;
+
+ return $this->_throw(
+ 'bad flock' =>
+ {
+ filename => shift,
+ exception => $!,
+ opts => $this->_remove_opts( \@_ ),
+ },
+ );
+};
+
+# (for use in error messages)
+( $EBL, $EBR ) = ('( ', ' )'); # error bracket left, error bracket right
+
+# --------------------------------------------------------
+# File::Util::Definitions::DESTROY()
+# --------------------------------------------------------
+sub DESTROY { }
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+File::Util::Definitions - Global symbols and constants used in most File::Util classes
+
+=head1 VERSION
+
+version 4.132140
+
+=head1 DESCRIPTION
+
+Defines constants and special variables that File::Util uses internally,
+many of which are calculated dynamically based on the platform where
+your program runs.
+
+Users, don't use this module by itself. It is for internal use only.
+
+=cut
@@ -0,0 +1,637 @@
+use strict;
+use warnings;
+
+use lib 'lib';
+
+package File::Util::Exception::Diagnostic;
+{
+ $File::Util::Exception::Diagnostic::VERSION = '4.132140';
+}
+
+# ABSTRACT: Diagnostic (verbose) error messages
+
+use File::Util::Definitions qw( :all );
+use File::Util::Exception qw( :all );
+
+use vars qw(
+ @ISA $AUTHORITY
+ @EXPORT_OK %EXPORT_TAGS
+);
+
+use Exporter;
+
+$AUTHORITY = 'cpan:TOMMY';
+@ISA = qw( Exporter File::Util::Exception );
+@EXPORT_OK = ( '_errors', @File::Util::Exception::EXPORT_OK );
+%EXPORT_TAGS = ( all => [ @EXPORT_OK ] );
+
+
+#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#
+# DIAGNOSTIC (VERBOSE) ERROR MESSAGES
+#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#
+sub _errors {
+ my ( $class, $error_thrown ) = @_;
+
+ $error_thrown ||= $class;
+
+ # begin long table of helpful diag error messages
+ my %error_msg_table = (
+# NO UNICODE SUPPORT
+'no unicode' => <<'__no_unicode__',
+$opts->{_pak} can't read/write with (binmode => 'utf8') because your version of
+Perl is not new enough to support unicode:
+ Your currently running Perl is $EBL$^V$EBR
+
+Origin: This is a human error.
+Solution: Upgrade to Perl version 5.008001 (5.8) or newer for unicode support
+ or do not use binmode => 'utf8' in your programs.
+__no_unicode__
+
+# NO SUCH FILE
+'no such file' => <<'__bad_open__',
+$opts->{_pak} can't open
+ $EBL$opts->{filename}$EBR
+because it is inaccessible or does not exist.
+
+Origin: This is *most likely* due to human error.
+Solution: Cannot diagnose. A human must investigate the problem.
+__bad_open__
+
+
+# BAD FLOCK RULE POLICY
+'bad flock rules' => <<'__bad_lockrules__',
+Invalid file locking policy can not be implemented. $opts->{_pak}::flock_rules
+does not accept one or more of the policy keywords passed to this method.
+
+ Invalid Policy specified: $EBL@{[
+ join ' ', map { '[undef]' unless defined $_ } @{ $opts->{all} } ]}$EBR
+
+ flock_rules policy in effect before invalid policy failed:
+ $EBL@ONLOCKFAIL$EBR
+
+ Proper flock_rules policy includes one or more of the following recognized
+ keywords specified in order of precedence:
+ BLOCK waits to try getting an exclusive lock
+ FAIL dies with stack trace
+ WARN warn()s about the error with a stack trace
+ IGNORE ignores the failure to get an exclusive lock
+ UNDEF returns undef
+ ZERO returns 0
+
+Origin: This is a human error.
+Solution: A human must fix the programming flaw.
+__bad_lockrules__
+
+
+# CAN'T READ FILE - PERMISSIONS
+'cant fread' => <<'__cant_read__',
+Permissions conflict. $opts->{_pak} can't read the contents of this file:
+ $EBL$opts->{filename}$EBR
+
+Due to insufficient permissions, the system has denied Perl the right to
+view the contents of this file. It has a bitmask of: (octal number)
+ $EBL@{[ sprintf('%04o',(stat($opts->{filename}))[2] & 0777) ]}$EBR
+
+ The directory housing it has a bitmask of: (octal number)
+ $EBL@{[ sprintf('%04o',(stat($opts->{dirname}))[2] & 0777) ]}$EBR
+
+ Current flock_rules policy:
+ $EBL@ONLOCKFAIL$EBR
+
+Origin: This is *most likely* due to human error. External system errors
+ can occur however, but this doesn't have to do with $opts->{_pak}.
+Solution: A human must fix the conflict by adjusting the file permissions
+ of directories where a program asks $opts->{_pak} to perform I/O.
+ Try using Perl's chmod command, or the native system chmod()
+ command from a shell.
+__cant_read__
+
+
+# CAN'T READ FILE - NOT EXISTENT
+'cant fread not found' => <<'__cant_read__',
+File not found. $opts->{_pak} can't read the contents of this file:
+ $EBL$opts->{filename}$EBR
+
+The file specified does not exist. It can not be opened or read from.
+
+Origin: This is *most likely* due to human error. External system errors
+ can occur however, but this doesn't have to do with $opts->{_pak}.
+Solution: A human must investigate why the application tried to open a
+ non-existent file, and/or why the file is expected to exist and
+ is not found.
+__cant_read__
+
+
+# CAN'T CREATE FILE - PERMISSIONS
+'cant fcreate' => <<'__cant_write__',
+Permissions conflict. $opts->{_pak} can't create this file:
+ $EBL$opts->{filename}$EBR
+
+$opts->{_pak} can't create this file because the system has denied Perl
+the right to create files in the parent directory.
+
+ The -e test returns $EBL@{[-e $opts->{dirname} ]}$EBR for the directory.
+ The -r test returns $EBL@{[-r $opts->{dirname} ]}$EBR for the directory.
+ The -R test returns $EBL@{[-R $opts->{dirname} ]}$EBR for the directory.
+ The -w test returns $EBL@{[-w $opts->{dirname} ]}$EBR for the directory
+ The -W test returns $EBL@{[-w $opts->{dirname} ]}$EBR for the directory
+
+ Parent directory: (path may be relative and/or redundant)
+ $EBL$opts->{dirname}$EBR
+
+ Parent directory has a bitmask of: (octal number)
+ $EBL@{[ sprintf('%04o',(stat($opts->{dirname}))[2] & 0777) ]}$EBR
+
+ Current flock_rules policy:
+ $EBL@ONLOCKFAIL$EBR
+
+Origin: This is *most likely* due to human error. External system errors
+ can occur however, but this doesn't have to do with $opts->{_pak}.
+Solution: A human must fix the conflict by adjusting the file permissions
+ of directories where a program asks $opts->{_pak} to perform I/O.
+ Try using Perl's chmod command, or the native system chmod()
+ command from a shell.
+__cant_write__
+
+
+# CAN'T WRITE TO FILE - EXISTS AS DIRECTORY
+'cant write_file on a dir' => <<'__bad_writefile__',
+$opts->{_pak} can't write to the specified file because it already exists
+as a directory.
+ $EBL$opts->{filename}$EBR
+
+Origin: This is a human error.
+Solution: Resolve naming issue between the existent directory and the file
+ you wish to create/write/append.
+__bad_writefile__
+
+
+# CAN'T TOUCH A FILE - EXISTS AS DIRECTORY
+'cant touch on a dir' => <<'__bad_touchfile__',
+$opts->{_pak} can't touch the specified file because it already exists
+as a directory.
+ $EBL$opts->{filename}$EBR
+
+Origin: This is a human error.
+Solution: Resolve naming issue between the existent directory and the file
+ you wish to touch.
+__bad_touchfile__
+
+
+# CAN'T WRITE TO FILE
+'cant fwrite' => <<'__cant_write__',
+Permissions conflict. $opts->{_pak} can't write to this file:
+ $EBL$opts->{filename}$EBR
+
+Due to insufficient permissions, the system has denied Perl the right
+to modify the contents of this file. It has a bitmask of: (octal number)
+ $EBL@{[ sprintf('%04o',(stat($opts->{filename}))[2] & 0777) ]}$EBR
+
+ Parent directory has a bitmask of: (octal number)
+ $EBL@{[ sprintf('%04o',(stat($opts->{dirname}))[2] & 0777) ]}$EBR
+
+ Current flock_rules policy:
+ $EBL@ONLOCKFAIL$EBR
+
+Origin: This is *most likely* due to human error. External system errors
+ can occur however, but this doesn't have to do with $opts->{_pak}.
+Solution: A human must fix the conflict by adjusting the file permissions
+ of directories where a program asks $opts->{_pak} to perform I/O.
+ Try using Perl's chmod command, or the native system chmod()
+ command from a shell.
+__cant_write__
+
+
+# BAD OPEN MODE - PERL
+'bad openmode popen' => <<'__bad_openmode__',
+Illegal mode specified for file open. $opts->{_pak} can't open this file:
+ $EBL$opts->{filename}$EBR
+
+When calling $opts->{_pak}::$opts->{meth}() you specified that the file
+opened in this I/O operation should be opened in $EBL$opts->{badmode}$EBR
+but that is not a recognized open mode.
+
+Supported open modes for $opts->{_pak}::write_file() are:
+ write - open the file in write mode, creating it if necessary, and
+ overwriting any existing contents of the file.
+ append - open the file in append mode
+
+Supported open modes for $opts->{_pak}::open_handle() are the same as above, but
+also include the following:
+ read - open the file in read-only mode
+
+ (and if the "use_sysopen => 1" flag is used):
+ rwcreate - open the file for update (read+write), creating it if necessary
+ rwupdate - open the file for update (read+write). Causes fatal error if
+ the file doesn't yet exist
+ rwappend - open the file for update in append mode
+ rwclobber - open the file for update, erasing all contents (truncating,
+ i.e- "clobbering" the file first)
+
+Origin: This is a human error.
+Solution: A human must fix the programming flaw by specifying the desired
+ open mode from the list above.
+__bad_openmode__
+
+
+# BAD OPEN MODE - SYSOPEN
+'bad openmode sysopen' => <<'__bad_openmode__',
+Illegal mode specified for file sysopen. $opts->{_pak} can't sysopen this file:
+ $EBL$opts->{filename}$EBR
+
+When calling $opts->{_pak}::$opts->{meth}() you specified that the file
+opened in this I/O operation should be sysopen()'d in $EBL$opts->{badmode}$EBR
+but that is not a recognized open mode.
+
+Supported open modes for $opts->{_pak}::write_file() are:
+ write - open the file in write mode, creating it if necessary, and
+ overwriting any existing contents of the file.
+ append - open the file in append mode
+
+Supported open modes for $opts->{_pak}::open_handle() are the same as above, but
+also include the following:
+ read - open the file in read-only mode
+
+ (and if the "use_sysopen => 1" flag is used, as the application JUST did):
+ rwcreate - open the file for update (read+write), creating it if necessary
+ rwupdate - open the file for update (read+write). Causes fatal error if
+ the file doesn't yet exist
+ rwappend - open the file for update in append mode
+ rwclobber - open the file for update, erasing all contents (truncating,
+ i.e- "clobbering" the file first)
+
+Origin: This is a human error.
+Solution: A human must fix the programming flaw by specifying the desired
+ sysopen mode from the list above.
+__bad_openmode__
+
+
+# CAN'T LIST DIRECTORY
+'cant dread' => <<'__cant_read__',
+Permissions conflict. $opts->{_pak} can't list the contents of this directory:
+ $EBL$opts->{dirname}$EBR
+
+Due to insufficient permissions, the system has denied Perl the right to
+view the contents of this directory. It has a bitmask of: (octal number)
+ $EBL@{[ sprintf('%04o',(stat($opts->{dirname}))[2] & 0777) ]}$EBR
+
+Origin: This is *most likely* due to human error. External system errors
+ can occur however, but this doesn't have to do with $opts->{_pak}.
+Solution: A human must fix the conflict by adjusting the file permissions
+ of directories where a program asks $opts->{_pak} to perform I/O.
+ Try using Perl's chmod command, or the native system chmod()
+ command from a shell.
+__cant_read__
+
+
+# CAN'T CREATE DIRECTORY - PERMISSIONS
+'cant dcreate' => <<'__cant_dcreate__',
+Permissions conflict. $opts->{_pak} can't create:
+ $EBL$opts->{dirname}$EBR
+
+ $opts->{_pak} can't create this directory because the system has denied
+ Perl the right to create files in the parent directory.
+
+ Parent directory: (path may be relative and/or redundant)
+ $EBL$opts->{parentd}$EBR
+
+ Parent directory has a bitmask of: (octal number)
+ $EBL@{[ sprintf('%04o',(stat($opts->{parentd}))[2] & 0777) ]}$EBR
+
+Origin: This is *most likely* due to human error. External system errors
+ can occur however, but this doesn't have to do with $opts->{_pak}.
+Solution: A human must fix the conflict by adjusting the file permissions
+ of directories where a program asks $opts->{_pak} to perform I/O.
+ Try using Perl's chmod command, or the native system chmod()
+ command from a shell.
+__cant_dcreate__
+
+
+# CAN'T CREATE DIRECTORY - TARGET EXISTS
+'make_dir target exists' => <<'__cant_dcreate__',
+make_dir target already exists.
+ $EBL$opts->{dirname}$EBR
+
+$opts->{_pak} can't create the directory you specified because that
+directory already exists, with filetype attributes of
+@{[join(', ', @{ $opts->{filetype} })]} and permissions
+set to $EBL@{[ sprintf('%04o',(stat($opts->{dirname}))[2] & 0777) ]}$EBR
+
+Origin: This is *most likely* due to human error. The program has tried
+ to make a directory where a directory already exists.
+Solution: Weaken the requirement somewhat by using the "if_not_exists => 1"
+ flag when calling the make_dir object method. This option
+ will cause $opts->{_pak} to ignore attempts to create directories
+ that already exist, while still creating the ones that don't.
+__cant_dcreate__
+
+
+# CAN'T OPEN
+'bad open' => <<'__bad_open__',
+$opts->{_pak} can't open this file for $EBL$opts->{mode}$EBR:
+ $EBL$opts->{filename}$EBR
+
+ The system returned this error:
+ $EBL$opts->{exception}$EBR
+
+ $opts->{_pak} used this directive in its attempt to open the file
+ $EBL$opts->{cmd}$EBR
+
+ Current flock_rules policy:
+ $EBL@ONLOCKFAIL$EBR
+
+Origin: This is *most likely* due to human error.
+Solution: Cannot diagnose. A Human must investigate the problem.
+__bad_open__
+
+
+# BAD CLOSE
+'bad close' => <<'__bad_close__',
+$opts->{_pak} couldn't close this file after $EBL$opts->{mode}$EBR
+ $EBL$opts->{filename}$EBR
+
+ The system returned this error:
+ $EBL$opts->{exception}$EBR
+
+ Current flock_rules policy:
+ $EBL@ONLOCKFAIL$EBR
+
+Origin: Could be either human _or_ system error.
+Solution: Cannot diagnose. A Human must investigate the problem.
+__bad_close__
+
+
+# CAN'T TRUNCATE
+'bad systrunc' => <<'__bad_systrunc__',
+$opts->{_pak} couldn't truncate() on $EBL$opts->{filename}$EBR after having
+successfully opened the file in write mode.
+
+The system returned this error:
+ $EBL$opts->{exception}$EBR
+
+Current flock_rules policy:
+ $EBL@ONLOCKFAIL$EBR
+
+This is most likely _not_ a human error, but has to do with your system's
+support for the C truncate() function.
+__bad_systrunc__
+
+
+# CAN'T GET FLOCK AFTER BLOCKING
+'bad flock' => <<'__bad_lock__',
+$opts->{_pak} can't get a lock on the file
+ $EBL$opts->{filename}$EBR
+
+The system returned this error:
+ $EBL$opts->{exception}$EBR
+
+Current flock_rules policy:
+ $EBL@ONLOCKFAIL$EBR
+
+Origin: Could be either human _or_ system error.
+Solution: Investigate the reason why you can't get a lock on the file,
+ it is usually because of improper programming which causes
+ race conditions on one or more files.
+__bad_lock__
+
+
+# CAN'T OPEN ON A DIRECTORY
+'called open on a dir' => <<'__bad_open__',
+$opts->{_pak} can't call open() on this file because it is a directory
+ $EBL$opts->{filename}$EBR
+
+Origin: This is a human error.
+Solution: Use $opts->{_pak}::load_file() to load the contents of a file
+ Use $opts->{_pak}::list_dir() to list the contents of a directory
+__bad_open__
+
+
+# CAN'T OPENDIR ON A FILE
+'called opendir on a file' => <<'__bad_open__',
+$opts->{_pak} can't opendir() on this file because it is not a directory.
+ $EBL$opts->{filename}$EBR
+
+Use $opts->{_pak}::load_file() to load the contents of a file
+Use $opts->{_pak}::list_dir() to list the contents of a directory
+
+Origin: This is a human error.
+Solution: Use $opts->{_pak}::load_file() to load the contents of a file
+ Use $opts->{_pak}::list_dir() to list the contents of a directory
+__bad_open__
+
+
+# CAN'T MKDIR ON A FILE
+'called mkdir on a file' => <<'__bad_open__',
+$opts->{_pak} can't auto-create a directory for this path name because it
+already exists as a file.
+ $EBL$opts->{filename}$EBR
+
+Origin: This is a human error.
+Solution: Resolve naming issue between the existent file and the directory
+ you wish to create.
+__bad_open__
+
+
+# BAD CALL TO File::Util::read_limit
+'bad read_limit' => <<'__read_limit__',
+Bad call to $opts->{_pak}::read_limit(). This method can only be called with
+a numeric value (bytes). Non-integer numbers will be converted to integer
+format if specified (numbers like 5.2), but don't do that, it's inefficient.
+
+This operation aborted.
+
+Origin: This is a human error.
+Solution: A human must fix the programming flaw.
+__read_limit__
+
+
+# EXCEEDED READ_LIMIT
+'read_limit exceeded' => <<'__read_limit__',
+$opts->{_pak} can't load file: $EBL$opts->{filename}$EBR
+into memory because its size exceeds the maximum file size allowed
+for a read.
+
+The size of this file is $EBL$opts->{size}$EBR bytes.
+
+Currently the read limit is set at $EBL$opts->{read_limit}$EBR bytes.
+
+Origin: This is a human error.
+Solution: Consider setting the limit to a higher number of bytes.
+__read_limit__
+
+
+# BAD CALL TO File::Util::abort_depth
+'bad abort_depth' => <<'__abort_depth__',
+Bad call to $opts->{_pak}::abort_depth(). This method can only be called with
+a numeric value (bytes). Non-integer numbers will be converted to integer
+format if specified (numbers like 5.2), but don't do that, it's inefficient.
+
+This operation aborted.
+
+Origin: This is a human error.
+Solution: A human must fix the programming flaw.
+__abort_depth__
+
+
+# EXCEEDED ABORT_DEPTH
+'abort_depth exceeded' => <<'__abort_depth__',
+Recursion limit reached at $EBL${\ scalar(
+ (exists $opts->{abort_depth} && defined $opts->{abort_depth}) ?
+ $opts->{abort_depth} : $ABORT_DEPTH)
+}$EBR dives. The maximum level of subdirectory depth is set to the value
+returned by $opts->{_pak}::abort_depth(). Try manually setting the value to a
+higher number by calling list_dir() with the "abort_depth => N" option where N
+is a positive integer value. To set the default abort_depth for all recursive
+list_dir() calls, invoke $opts->{_pak}::abort_depth() with the numeric argument
+corresponding to the maximum number of subdirectory dives you want to allow.
+
+This operation aborted.
+
+Origin: This is a human error.
+Solution: Consider setting the limit to a higher number.
+__abort_depth__
+
+
+# BAD OPENDIR
+'bad opendir' => <<'__bad_opendir__',
+$opts->{_pak} can't opendir on directory:
+ $EBL$opts->{dirname}$EBR
+
+The system returned this error:
+ $EBL$opts->{exception}$EBR
+
+Origin: Could be either human _or_ system error.
+Solution: Cannot diagnose. A Human must investigate the problem.
+__bad_opendir__
+
+
+# BAD MAKEDIR
+'bad make_dir' => <<'__bad_make_dir__',
+$opts->{_pak} had a problem with the system while attempting to create the
+directory you specified with a bitmask of $EBL$opts->{bitmask}$EBR
+
+directory: $EBL$opts->{dirname}$EBR
+
+The system returned this error:
+ $EBL$opts->{exception}$EBR
+
+Origin: Could be either human _or_ system error.
+Solution: Cannot diagnose. A Human must investigate the problem.
+__bad_make_dir__
+
+
+# BAD CHARS
+'bad chars' => <<'__bad_chars__',
+$opts->{_pak} can't use this string for $EBL$opts->{purpose}$EBR.
+ $EBL$opts->{string}$EBR
+It contains illegal characters.
+
+Illegal characters are:
+ \\ (backslash)
+ / (forward slash)
+ : (colon)
+ | (pipe)
+ * (asterisk)
+ ? (question mark)
+ " (double quote)
+ < (less than)
+ > (greater than)
+ \\t (tab)
+ \\ck (vertical tabulator)
+ \\r (newline CR)
+ \\n (newline LF)
+
+Origin: This is a human error.
+Solution: A human must remove the illegal characters from this string.
+__bad_chars__
+
+
+# NOT A VALID FILEHANDLE
+'not a filehandle' => <<'__bad_handle__',
+$opts->{_pak} can't unlock file with an invalid file handle reference:
+ $EBL$opts->{argtype}$EBR is not a valid filehandle
+
+Origin: This is most likely a human error, although it is remotely possible
+ that this message is the result of an internal error in the
+ $opts->{_pak} module, but this is not likely if you called
+ $opts->{_pak}'s internal ::_release() method directly on your own.
+Solution: A human must fix the programming flaw. Alternatively, in the second
+ listed scenario the package maintainer must investigate the problem.
+ Please submit a bug report with this error message in its entirety
+ at https://rt.cpan.org/Dist/Display.html?Name=File%3A%3AUtil
+__bad_handle__
+
+
+# BAD CALL TO METHOD FOO
+'no input' => <<'__no_input__',
+$opts->{_pak} can't honor your call to $EBL$opts->{_pak}::$opts->{meth}()$EBR
+because you didn't provide $EBL@{[$opts->{missing}||'the required input']}$EBR
+
+Origin: This is a human error.
+Solution: A human must fix the programming flaw.
+__no_input__
+
+
+# PLAIN ERROR TYPE
+'plain error' => <<'__plain_error__',
+$opts->{_pak} failed with the following message:
+${\ scalar ($_[0] || ((exists $opts->{error} && defined $opts->{error}) ?
+ $opts->{error} : '[error unspecified]')) }
+__plain_error__
+
+
+# INVALID ERROR TYPE
+'unknown error message' => <<'__foobar_input__',
+$opts->{_pak} failed with an invalid error-type designation.
+
+Origin: This is a bug! Please file a bug report at
+ https://rt.cpan.org/Dist/Display.html?Name=File%3A%3AUtil
+Solution: A human must fix the programming flaw.
+__foobar_input__
+
+
+# EMPTY ERROR TYPE
+'empty error' => <<'__no_input__',
+$opts->{_pak} failed with an empty error-type designation.
+
+Origin: This is a human error.
+Solution: A human must fix the programming flaw.
+__no_input__
+
+ ); # end of error message table
+
+ exists $error_msg_table{ $error_thrown }
+ ? $error_msg_table{ $error_thrown }
+ : $error_msg_table{'unknown error message'}
+}
+
+
+# --------------------------------------------------------
+# File::Util::Exception::Diagnostic::DESTROY()
+# --------------------------------------------------------
+sub DESTROY { }
+
+
+1;
+
+
+__END__
+
+=pod
+
+=head1 NAME
+
+File::Util::Exception::Diagnostic - Diagnostic (verbose) error messages
+
+=head1 VERSION
+
+version 4.132140
+
+=head1 DESCRIPTION
+
+Provides those super-helpful wordy error messages with built-in diagnostics
+to help users solve problems when things go wrong.
+
+Users, don't use this module by itself. It is for internal use only.
+
+=cut
@@ -0,0 +1,295 @@
+use strict;
+use warnings;
+
+use lib 'lib';
+
+package File::Util::Exception::Standard;
+{
+ $File::Util::Exception::Standard::VERSION = '4.132140';
+}
+
+# ABSTRACT: Standard (non-verbose) error messages
+
+use File::Util::Definitions qw( :all );
+use File::Util::Exception qw( :all );
+
+use vars qw(
+ @ISA $AUTHORITY
+ @EXPORT_OK %EXPORT_TAGS
+);
+
+use Exporter;
+
+$AUTHORITY = 'cpan:TOMMY';
+@ISA = qw( Exporter File::Util::Exception );
+@EXPORT_OK = ( '_errors', @File::Util::Exception::EXPORT_OK );
+%EXPORT_TAGS = ( all => [ @EXPORT_OK ] );
+
+
+#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#
+# STANDARD (NON-VERBOSE) ERROR MESSAGES
+#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#%#
+sub _errors {
+ my ( $this, $error_thrown ) = @_;
+
+ $error_thrown ||= $this;
+
+ # begin long table of helpful diag error messages
+ my %error_msg_table = (
+# NO UNICODE SUPPORT
+'no unicode' => <<'__no_unicode__',
+Your version of Perl is not new enough to support unicode: $EBL$^V$EBR
+__no_unicode__
+
+
+# NO SUCH FILE
+'no such file' => <<'__bad_open__',
+File inaccessible or does not exist: $EBL$opts->{filename}$EBR
+__bad_open__
+
+
+# BAD FLOCK RULE POLICY
+'bad flock rules' => <<'__bad_lockrules__',
+Invalid file locking policy can not be implemented.
+__bad_lockrules__
+
+
+# CAN'T READ FILE - PERMISSIONS
+'cant fread' => <<'__cant_read__',
+Permissions conflict. Can't read: $EBL$opts->{filename}$EBR
+__cant_read__
+
+
+# CAN'T READ FILE - NOT EXISTENT
+'cant fread not found' => <<'__cant_read__',
+File not found: $EBL$opts->{filename}$EBR
+__cant_read__
+
+
+# CAN'T CREATE FILE - PERMISSIONS
+'cant fcreate' => <<'__cant_write__',
+Permissions conflict. Can't create: $EBL$opts->{filename}$EBR
+__cant_write__
+
+
+# CAN'T WRITE TO FILE - EXISTS AS DIRECTORY
+'cant write_file on a dir' => <<'__bad_writefile__',
+File already exists as directory: $EBL$opts->{filename}$EBR
+__bad_writefile__
+
+
+# CAN'T TOUCH A FILE - EXISTS AS DIRECTORY
+'cant touch on a dir' => <<'__bad_touchfile__',
+File already exists as directory: $EBL$opts->{filename}$EBR
+__bad_touchfile__
+
+
+# CAN'T WRITE TO FILE
+'cant fwrite' => <<'__cant_write__',
+Permissions conflict. Can't write to: $EBL$opts->{filename}$EBR
+__cant_write__
+
+
+# BAD OPEN MODE - PERL
+'bad openmode popen' => <<'__bad_openmode__',
+Illegal mode specified for file open: $EBL$opts->{badmode}$EBR
+__bad_openmode__
+
+
+# BAD OPEN MODE - SYSOPEN
+'bad openmode sysopen' => <<'__bad_openmode__',
+Illegal mode specified for sysopen: $EBL$opts->{badmode}$EBR
+__bad_openmode__
+
+
+# CAN'T LIST DIRECTORY
+'cant dread' => <<'__cant_read__',
+Permissions conflict. Can't list directory: $EBL$opts->{dirname}$EBR
+__cant_read__
+
+
+# CAN'T CREATE DIRECTORY - PERMISSIONS
+'cant dcreate' => <<'__cant_dcreate__',
+Permissions conflict. Can't create directory: $EBL$opts->{dirname}$EBR
+__cant_dcreate__
+
+
+# CAN'T CREATE DIRECTORY - TARGET EXISTS
+'make_dir target exists' => <<'__cant_dcreate__',
+make_dir target already exists: $EBL$opts->{dirname}$EBR
+__cant_dcreate__
+
+
+# CAN'T OPEN
+'bad open' => <<'__bad_open__',
+Can't open: $EBL$opts->{filename}$EBR for: $EBL$opts->{mode}$EBR
+OS error if any: $EBL$!$EBR
+__bad_open__
+
+
+# BAD CLOSE
+'bad close' => <<'__bad_close__',
+Couldn't close: $EBL$opts->{filename}$EBR
+OS error if any: $EBL$!$EBR
+__bad_close__
+
+
+# CAN'T TRUNCATE
+'bad systrunc' => <<'__bad_systrunc__',
+Couldn't truncate() on $EBL$opts->{filename}$EBR
+OS error if any: $EBL$!$EBR
+__bad_systrunc__
+
+
+# CAN'T GET FLOCK AFTER BLOCKING
+'bad flock' => <<'__bad_lock__',
+Can't get a lock on the file: $EBL$opts->{filename}$EBR
+OS error if any: $EBL$!$EBR
+__bad_lock__
+
+
+# CAN'T OPEN ON A DIRECTORY
+'called open on a dir' => <<'__bad_open__',
+Can't call open() on a directory: $EBL$opts->{filename}$EBR
+__bad_open__
+
+
+# CAN'T OPENDIR ON A FILE
+'called opendir on a file' => <<'__bad_open__',
+Can't opendir() on non-directory: $EBL$opts->{filename}$EBR
+__bad_open__
+
+
+# CAN'T MKDIR ON A FILE
+'called mkdir on a file' => <<'__bad_open__',
+Can't make directory; already exists as a file. $EBL$opts->{filename}$EBR
+__bad_open__
+
+
+# BAD CALL TO File::Util::read_limit
+'bad read_limit' => <<'__read_limit__',
+Bad input provided to read_limit().
+__read_limit__
+
+
+# EXCEEDED READ_LIMIT
+'read_limit exceeded' => <<'__read_limit__',
+Stopped reading: $EBL$opts->{filename}$EBR Read limit exceeded: $opts->{read_limit} bytes
+__read_limit__
+
+
+# BAD CALL TO File::Util::abort_depth
+'bad abort_depth' => <<'__abort_depth__',
+Bad input provided to abort_depth()
+__abort_depth__
+
+
+# EXCEEDED ABORT_DEPTH
+'abort_depth exceeded' => <<'__abort_depth__',
+Recursion limit exceeded at $EBL${\ scalar(
+ (exists $opts->{abort_depth} && defined $opts->{abort_depth}) ?
+ $opts->{abort_depth} : $ABORT_DEPTH)
+}$EBR dives.
+__abort_depth__
+
+
+# BAD OPENDIR
+'bad opendir' => <<'__bad_opendir__',
+Can't opendir on directory: $EBL$opts->{dirname}$EBR
+OS error if any: $EBL$!$EBR
+__bad_opendir__
+
+
+# BAD MAKEDIR
+'bad make_dir' => <<'__bad_make_dir__',
+Can't create directory: $EBL$opts->{dirname}$EBR
+OS error if any: $EBL$!$EBR
+__bad_make_dir__
+
+
+# BAD CHARS
+'bad chars' => <<'__bad_chars__',
+String contains illegal characters: $EBL$opts->{string}$EBR
+__bad_chars__
+
+
+# NOT A VALID FILEHANDLE
+'not a filehandle' => <<'__bad_handle__',
+Can't unlock file with an invalid file handle reference
+__bad_handle__
+
+
+# BAD CALL TO METHOD FOO
+'no input' => <<'__no_input__',
+Call to $EBL$opts->{meth}()$EBR failed: @{[
+ $opts->{missing} ? $EBL . $opts->{missing} . $EBR : undef || 'Required input'
+]} missing
+__no_input__
+
+
+# PLAIN ERROR TYPE
+'plain error' => <<'__plain_error__',
+${\ scalar ($_[0] || ((exists $opts->{error} && defined $opts->{error}) ?
+ $opts->{error} : '[error unspecified]')) }
+__plain_error__
+
+
+# INVALID ERROR TYPE
+'unknown error message' => <<'__foobar_input__',
+Failed with an invalid error-type designation.
+This is a bug! Please File A Bug Report!
+__foobar_input__
+
+
+# EMPTY ERROR TYPE
+'empty error' => <<'__no_input__',
+Failed with an empty error-type designation.
+__no_input__
+
+ ); # end of error message table
+
+ exists $error_msg_table{ $error_thrown }
+ ? $error_msg_table{ $error_thrown }
+ : $error_msg_table{'unknown error message'}
+}
+
+
+# --------------------------------------------------------
+# File::Util::Exception::Standard::DESTROY()
+# --------------------------------------------------------
+sub DESTROY { }
+
+
+1;
+
+
+__END__
+
+=pod
+
+=head1 NAME
+
+File::Util::Exception::Standard - Standard (non-verbose) error messages
+
+=head1 VERSION
+
+version 4.132140
+
+=head1 DESCRIPTION
+
+Provides error messages when things go wrong. Use the
+C<L<File::Util::Exception::Diagnostic>> module if you want more helpful
+error messages.
+
+Standard use (without diagnostics):
+
+ use File::Util;
+
+Debug/troubleshooting use (with diagnostics):
+
+ use File::Util qw( :diag );
+
+Users, please don't use this module by itself (directly). It is for
+internal use only.
+
+=cut
@@ -0,0 +1,218 @@
+use strict;
+use warnings;
+
+use lib 'lib';
+
+package File::Util::Exception;
+{
+ $File::Util::Exception::VERSION = '4.132140';
+}
+
+# ABSTRACT: Base exception class for File::Util
+
+use File::Util::Definitions qw( :all );
+
+use vars qw(
+ @ISA $AUTHORITY
+ @EXPORT_OK %EXPORT_TAGS
+);
+
+use Exporter;
+
+$AUTHORITY = 'cpan:TOMMY';
+@ISA = qw( Exporter );
+@EXPORT_OK = qw( _throw );
+%EXPORT_TAGS = ( all => [ @EXPORT_OK ] );
+
+
+# --------------------------------------------------------
+# File::Util::Exception::_throw
+# --------------------------------------------------------
+sub _throw {
+
+ my @in = @_;
+ my ( $this, $error_class, $error ) = splice @_, 0 , 3;
+ my $opts = $this->_remove_opts( \@_ );
+ my %fatal_rules = ();
+
+ # here we handle support for the legacy error handling policy syntax,
+ # such as things like "fatals_as_status => 1"
+ #
+ # ...and we also handle support for the newer, more pretty error
+ # handling policy syntax using "onfail" keywords/subrefs
+
+ $opts->{onfail} ||=
+ $opts->{opts} && ref $opts->{opts} eq 'HASH'
+ ? $opts->{opts}->{onfail}
+ : '';
+
+ $opts->{onfail} ||= $this->{opts}->{onfail};
+
+ $opts->{onfail} ||= 'die';
+
+ # fatalality-handling rules passed to the failing caller trump the
+ # rules set up in the attributes of the object; the mechanism below
+ # also allows for the implicit handling of fatals_are_fatal => 1
+ map { $fatal_rules{ $_ } = $_ }
+ grep /^fatals/o, keys %$opts;
+
+ map { $fatal_rules{ $_ } = $_ }
+ grep /^fatals/o, keys %{ $opts->{opts} }
+ if $opts->{opts} && ref $opts->{opts} eq 'HASH';
+
+ unless ( scalar keys %fatal_rules ) {
+ map { $fatal_rules{ $_ } = $_ }
+ grep /^fatals/o, keys %{ $this->{opts} }
+ }
+
+ return 0 if $fatal_rules{fatals_as_status} || $opts->{onfail} eq 'zero';
+
+ return if $opts->{onfail} eq 'undefined';
+
+ my $is_plain;
+
+ if ( !scalar keys %$opts ) {
+
+ $opts->{_pak} = 'File::Util';
+
+ $opts->{error} = $error;
+
+ $error = $error ? 'plain error' : 'empty error';
+
+ $is_plain++;
+ }
+ else {
+
+ $opts->{_pak} = 'File::Util';
+
+ $error ||= 'empty error';
+
+ if ( $error eq 'plain error' ) {
+
+ $opts->{error} ||= shift @_;
+
+ $is_plain++;
+ }
+ }
+
+ my $bad_news = CORE::eval # tokenizing via stringy eval (is NOT evil)
+ (
+ '<<__ERRBLOCK__' . NL .
+ $error_class->_errors( $error ) . NL .
+ '__ERRBLOCK__'
+ );
+
+ if (
+ $opts->{onfail} eq 'warn' ||
+ $fatal_rules{fatals_as_warning}
+ ) {
+ warn _trace( $@ || $bad_news ) and return;
+ }
+ elsif (
+ $opts->{onfail} eq 'message' ||
+ $fatal_rules{fatals_as_errmsg} ||
+ $opts->{return}
+ ) {
+ return _trace( $@ || $bad_news );
+ }
+
+ warn _trace( $@ || $bad_news ) if $opts->{warn_also};
+
+ die _trace( $@ || $bad_news )
+ unless ref $opts->{onfail} eq 'CODE';
+
+ @_ = ( $bad_news, _trace() );
+
+ goto $opts->{onfail};
+}
+
+
+
+# --------------------------------------------------------
+# File::Util::Exception::_trace
+# --------------------------------------------------------
+sub _trace { # <<<<< this is not a class or object method!
+ my @errors = @_;
+
+ my
+ (
+ $pak, $file, $line, $sub,
+ $hasargs, $wantarray, $evaltext, $req_OR_use,
+ @stack, $i, $frame_no
+ );
+
+ $frame_no = 0;
+
+ while
+ (
+ ( $pak, $file, $line, $sub,
+ $hasargs, $wantarray, $evaltext, $req_OR_use
+ ) = caller( $i++ )
+ )
+ {
+ $frame_no = $i - 2;
+
+ next unless $frame_no > 0;
+
+ push @stack, <<__ERR__
+$frame_no. $sub
+ -called at line ($line) of $file
+ @{[ $hasargs
+ ? '-was called with args'
+ : '-was called without args' ]}
+ @{[ $evaltext
+ ? '-was called to evalate text'
+ : '-was not called to evaluate anything' ]}
+__ERR__
+ }
+
+ $i = 0;
+
+ for my $error ( @errors ) {
+
+ $error = '' unless defined $error;
+
+ if ( !length $error ) {
+
+ $error = qq{Something is wrong. Frame no. $frame_no...}
+ }
+
+ ++$i;
+ }
+
+ chomp for @errors;
+
+ return join NL, @errors, @stack;
+}
+
+
+# --------------------------------------------------------
+# File::Util::Exception::DESTROY()
+# --------------------------------------------------------
+sub DESTROY { }
+
+
+1;
+
+
+__END__
+
+=pod
+
+=head1 NAME
+
+File::Util::Exception - Base exception class for File::Util
+
+=head1 VERSION
+
+version 4.132140
+
+=head1 DESCRIPTION
+
+Base class for all File::Util::Exception subclasses. It's primarily
+responsible for error handling within File::Util, but hands certain
+work off to its subclasses, depending on how File::Util was use()'d.
+
+Users, don't use this module by itself. It is for internal use only.
+
+=cut
@@ -0,0 +1,152 @@
+use strict;
+use warnings;
+
+package File::Util::Interface::Classic;
+{
+ $File::Util::Interface::Classic::VERSION = '4.132140';
+}
+
+# ABSTRACT: Legacy call interface to File::Util
+
+use Scalar::Util qw( blessed );
+
+use lib 'lib';
+
+use File::Util::Definitions qw( :all );
+
+use vars qw(
+ @ISA $AUTHORITY
+ @EXPORT_OK %EXPORT_TAGS
+);
+
+use Exporter;
+
+$AUTHORITY = 'cpan:TOMMY';
+@ISA = qw( Exporter );
+@EXPORT_OK = qw(
+ _myargs
+ _remove_opts
+ _names_values
+);
+
+%EXPORT_TAGS = ( all => [ @EXPORT_OK ] );
+
+
+# --------------------------------------------------------
+# File::Util::Interface::Classic::_myargs()
+# --------------------------------------------------------
+sub _myargs {
+
+ shift @_ if ( blessed $_[0] || ( $_[0] && $_[0] =~ /^File::Util/ ) );
+
+ return wantarray ? @_ : $_[0]
+}
+
+
+# --------------------------------------------------------
+# File::Util::Interface::Classic::_remove_opts()
+# --------------------------------------------------------
+sub _remove_opts {
+
+ shift; # we don't need "$this" here
+
+ my $args = shift @_;
+
+ return unless ref $args eq 'ARRAY';
+
+ my @triage = @$args; @$args = ();
+ my $opts = { };
+
+ while ( @triage ) {
+
+ my $arg = shift @triage;
+
+ # if an argument is '', 0, or undef, it's obviously not an --option ...
+ push @$args, $arg and next unless $arg; # ...so give it back to the @$args
+
+ # hmmm. looks like an "--option" argument, if:
+ if ( $arg =~ /^--/ ) {
+
+ # it's either a bare "--option", or it's an "--option=value" pair
+ my ( $opt, $value ) = split /=/, $arg;
+
+ # bare version
+ $opts->{ $opt } = defined $value ? $value : 1;
+ # ^^^^^^^ if $value is undef, it was a --flag (true)
+
+ # sanitized version, remove leading "--" ...
+ my $clean_name = substr $opt, 2;
+
+ # ...and replace non-alnum chars with "_" so the names can be
+ # referenced as hash keys without superfluous quoting and escaping
+ $clean_name =~ s/[^[:alnum:]]/_/g;
+
+ $opts->{ $clean_name } = defined $value ? $value : 1;
+ }
+ else {
+
+ # but if it's not an "--option" type arg, give it back to the @$args
+ push @$args, $arg;
+ }
+ }
+
+ return $opts;
+}
+
+
+# --------------------------------------------------------
+# File::Util::Interface::Classic::_names_values()
+# --------------------------------------------------------
+sub _names_values {
+
+ shift; # we don't need "$this" here
+
+ my @in_pairs = @_;
+ my $out_pairs = { };
+
+ # this code no longer tries to catch foolishness such as names that are
+ # undef other than skipping over them, for lack of sane options to deal
+ # with such insane input ;-)
+ while ( my ( $name, $val ) = splice @in_pairs, 0, 2 ) {
+
+ next unless defined $name;
+
+ $out_pairs->{ $name } = $val;
+ }
+
+ return $out_pairs;
+}
+
+
+# --------------------------------------------------------
+# File::Util::Interface::Classic::DESTROY()
+# --------------------------------------------------------
+sub DESTROY { }
+
+1;
+
+
+__END__
+
+=pod
+
+=head1 NAME
+
+File::Util::Interface::Classic - Legacy call interface to File::Util
+
+=head1 VERSION
+
+version 4.132140
+
+=head1 DESCRIPTION
+
+Provides a classic interface for argument passing to and between the public
+and private methods of File::Util. It is as a subclass for File::Util
+developers that want to use it, and provides some base methods that are
+inherited by L<File::Util::Interface::Modern>, but the _remove_opts method
+is overridden in that namespace, whose more progressive version of that
+method supports both ::Classic and ::Modern call syntaxes.
+
+Users, don't use this module by itself. It is intended for internal use only.
+
+=cut
@@ -0,0 +1,174 @@
+use strict;
+use warnings;
+
+package File::Util::Interface::Modern;
+{
+ $File::Util::Interface::Modern::VERSION = '4.132140';
+}
+
+# ABSTRACT: Modern call interface to File::Util
+
+use lib 'lib';
+
+use File::Util::Interface::Classic qw( _myargs );
+use File::Util::Definitions qw( :all );
+
+use vars qw(
+ @ISA $AUTHORITY
+ @EXPORT_OK %EXPORT_TAGS
+);
+
+use Exporter;
+
+$AUTHORITY = 'cpan:TOMMY';
+@ISA = qw( Exporter File::Util::Interface::Classic );
+@EXPORT_OK = qw(
+ _remove_opts
+ _myargs
+ _names_values
+ _parse_in
+); # some of the symbols above come from File::Util::Interface::Classic but
+ # the _remove_opts/_names_values methods are specifically overriden in
+ # this package
+
+%EXPORT_TAGS = ( all => [ @EXPORT_OK ] );
+
+
+# --------------------------------------------------------
+# File::Util::Interface::Modern::_names_values()
+# --------------------------------------------------------
+sub _names_values {
+
+ # ignore $_[0] File::Util object reference
+
+ if ( ref $_[1] eq 'HASH' ) {
+
+ # method was called like $f->method( { name => val } )
+ return $_[1]
+ }
+
+ # ...method called like $f->methd( name => val );
+
+ goto \&File::Util::Interface::Classic::_names_values;
+}
+
+
+# --------------------------------------------------------
+# File::Util::Interface::Modern::_remove_opts()
+# --------------------------------------------------------
+sub _remove_opts {
+
+ shift; # we don't need "$this" here
+
+ my $args = shift @_;
+
+ return unless ref $args eq 'ARRAY';
+
+ my @triage = @$args; @$args = ();
+ my $opts = { };
+
+ while ( @triage ) {
+
+ my $arg = shift @triage;
+
+ # if an argument is '', 0, or undef, it's obviously not an --option ...
+ push @$args, $arg and next unless $arg; # ...so give it back to the @$args
+
+ if ( UNIVERSAL::isa( $arg, 'HASH' ) ) {
+
+ # if we got hashref, then we were called with the new & improved syntax:
+ # e.g.- $ftl->method( arg => { opt => foo, opt2 => bar } );
+ #
+ # ...as oppsed to the classic syntax:
+ # e.g.- $ftl->method( arg => value, --opt1=value, --flag )
+ #
+ # the bit of code below makes it possible to support both call syntaxes
+
+ @$opts{ keys %$arg } = values %$arg; # crane lower that rover (ahhhhh)
+ # err, Perl flatcopy that hashref
+ }
+ elsif ( $arg =~ /^--/ ) { # got old school "--option" argument?
+
+ # it's either a bare "--option", or it's an "--option=value" pair
+ my ( $opt, $value ) = split /=/, $arg;
+
+ # bare version
+ $opts->{ $opt } = defined $value ? $value : 1;
+ # ^^^^^^^ if $value is undef it's a --flag, and value=1
+
+ # sanitized version, remove leading "--" ...
+ my $clean_name = substr $opt, 2;
+
+ # ...and replace non-alnum chars with "_" so the names can be
+ # referenced as hash keys without superfluous quoting and escaping
+ $clean_name =~ s/[^[:alnum:]]/_/g;
+
+ $opts->{ $clean_name } = defined $value ? $value : 1;
+ }
+ else {
+
+ # but if it's not an "--option" type arg, or a hashref of options,
+ # then give it back to the caller's @$args arrayref
+ push @$args, $arg;
+ }
+ }
+
+ return $opts;
+}
+
+
+# --------------------------------------------------------
+# File::Util::Interface::Modern::_parse_in()
+# --------------------------------------------------------
+sub _parse_in {
+ my ( $this, @in ) = @_;
+
+ my $opts = $this->_remove_opts( \@in ); # always returns a hashref, given a listref
+ my $in = $this->_names_values( @in ); # always returns a hashref, given anything
+
+ # merge two hashrefs
+ @$in{ keys %$opts } = values %$opts;
+
+ return $in;
+}
+
+
+# --------------------------------------------------------
+# File::Util::Interface::Modern::DESTROY()
+# --------------------------------------------------------
+sub DESTROY { }
+
+1;
+
+
+__END__
+
+=pod
+
+=head1 NAME
+
+File::Util::Interface::Modern - Modern call interface to File::Util
+
+=head1 VERSION
+
+version 4.132140
+
+=head1 DESCRIPTION
+
+Provides a ::Modern-style interface for argument passing to and between the
+public and private methods of File::Util.
+
+Whereas call syntax used to only work like this:
+
+ some_method( main_arg => value, qw/ --opt=value --patern=^foo --flag / )
+
+This module allows File::Util to work with calls that are more consistent
+with current practices in Perl, like this:
+
+ some_method( main_arg => { arg => value, opt => value, flag => 1 } );
+ -or-
+ some_method( '/var/log' => { match => [ qr/.*\.log/, qr/access|error/ ] } )
+
+Users, don't use this module by itself. It is intended for internal use only.
+
+=cut
@@ -0,0 +1,716 @@
+package File::Util::Manual::Examples;
+use strict; use warnings; # for kwalitee tests
+
+# ABSTRACT: File::Util Examples
+
+=pod
+
+=head1 NAME
+
+File::Util::Manual::Examples - File::Util Examples
+
+=head1 VERSION
+
+version 4.132140
+
+=head1 INTRODUCTION
+
+This manual subsection is fully comprised of simple examples of L<File::Util>
+in greater depth than what you see in the main documentation, however to keep
+things simple, these examples are short, quick, and to the point.
+
+For examples of full Programs using File::Util, take a look at the Cookbook at
+the L<File::Util::Cookbook>.
+
+=head1 EXAMPLES
+
+Many of these are demonstrated in the standalone scripts that come in the
+"examples" directory as part of this distribution.
+
+Unless indicated otherwise, all of these short examples assume that you have
+started out with:
+
+ use File::Util;
+ my $f = File::Util->new();
+
+The variable C<$f> is used for simplicity here in the examples. In your actual
+programming you should refrain from using single-letter variables and use
+something more obvious instead, such as C<$ftl> or C<$futil>
+
+=head2 Get the contents of a file in a string
+
+ my $contents = $f->load_file( 'filename' );
+
+ -OR-
+
+ my $contents = $f->load_file( '/path/to/filename' );
+
+ -OR-
+
+ my $contents = $f->load_file( 'C:\path\to\filename' );
+
+=head2 Get the contents of a UTF-8 encoded file in a UTF-8 encoded string
+
+ my $encoded_data = $f->load_file( 'encoded.txt' => { binmode => 'utf8' } );
+
+=head2 Get the contents of a file in an array of lines in the file
+
+ my @contents = $f->load_file( 'filename' => { as_lines => 1 } );
+
+=head2 Get an open file handle for reading
+
+ my $fh = $f->open_handle(
+ file => '/some/existing/file',
+ mode => 'read'
+ );
+
+ -OR-
+
+ # ... you can also use the shorter syntax:
+ my $fh = $f->open_handle( '/some/existing/file' => 'read' );
+
+ # ... you can open a file handle to a UTF-8 encoded file too
+ my $fh = $f->open_handle( 'encoded.txt' => 'read' => { binmode => 'utf8' } );
+
+ # then use the filehandle like you would use any other file handle:
+ while ( my $line = <$fh> ) {
+
+ # ... do stuff with $line
+ }
+
+ close $fh or die $!;
+
+=head2 Get an open file handle for writing
+
+Opening a file for writing (write mode) will create the file if it doesn't
+already exist. The file handle is automatically locked for you with flock()
+if your system supports it.
+
+ my $fh = $f->open_handle(
+ file => '/some/file',
+ mode => 'write'
+ );
+
+ -OR-
+
+ # ... you can also use the shorter syntax:
+ my $fh = $f->open_handle( '/some/file' => 'write' );
+
+ # ... you can open a file handle with UTF-8 encoding support
+ my $fh = $f->open_handle( '/some/file' => 'write' => { binmode => 'utf8' } );
+
+ print $fh 'Hello world!';
+
+ close $fh or die $!;
+
+=head2 Write to a new or existing file
+
+ my $content = 'Pathelogically Eclectic Rubbish Lister';
+
+ $f->write_file( file => 'a new file.txt', content => $content );
+
+ -OR-
+
+ # you can use the shorter syntax:
+ $f->write_file( 'a new file.txt' => $content );
+
+ -OR-
+
+ # write UTF-8 encoded data also. the file will have UTF-8 encoding:
+ $f->write_file( 'encoded.txt' => $encoded_data => { binmode => 'utf8' } );
+
+You can optionally specify a bitmask for a file if it doesn't exist yet.
+The bitmask is combined with the user's current umask for the creation
+mode of the file. (You should usually omit this.)
+
+ $f->write_file(
+ file => 'C:\some\new\file.txt',
+ content => $content
+ bitmask => oct 777,
+ );
+
+ -OR-
+
+ $f->write_file( 'file.txt' => $content => { bitmask => oct 777 } );
+
+=head2 Warn if the file couldn't be written, instead of dying by default
+
+ $f->write_file(
+ 'file.txt' => $content,
+ {
+ onfail => 'warn',
+ bitmask => oct 777
+ }
+ );
+
+=head2 Conceal the error if the file couldn't be written (secure), but log it too
+
+ # define a custom (secure) error handler
+
+ $f->write_file(
+ 'file.txt' => $content =>
+ {
+ bitmask => oct 777
+ onfail => sub {
+ my ( $err, $stack ) = @_;
+
+ # send the error message and stack trace to a logger of some kind...
+ $logger->log( $err . $stack );
+
+ # or send an email alert?
+ send_email_alert_to_admin( $err ); #<< you'll have to write that sub
+
+ # return undef to indicate a problem (or you could die/exit too)
+ return;
+ }
+ }
+ );
+
+=head2 Why not first check if the file is writeable/can be created
+
+ if ( $f->is_writable( '/root/some/file.txt' ) ) {
+
+ # ... now create/write to the file
+ }
+
+=head2 Append to a new or existing file
+
+ my $content = 'The fastest hunk of junk in the galaxy';
+
+ $f->write_file(
+ file => 'mfalcon.spec',
+ mode => 'append',
+ content => $content
+ );
+
+ -OR-
+
+ $f->write_file( 'mfalcon.spec' => $content => { mode => 'append' } );
+
+=head2 Get the names of all files and subdirectories in a directory
+
+ # option no_fsdots excludes "." and ".." from the list
+ my @dirs_and_files = $f->list_dir( '/foo' => { no_fsdots => 1 } );
+
+=head2 Get the names of all files and subdirectories in a directory, recursively
+
+ my @dirs_and_files = $f->list_dir( '/foo' => { recurse => 1 } );
+
+=head2 Do the same as above, but only to a certain maximum depth
+
+ my @dirs_and_files =
+ $f->list_dir( '/foo' => { recurse => 1, max_depth => 3 } );
+
+=head2 Do the same, but ignore potential filesystem loops for a speed boost
+
+ my @dirs_and_files =
+ $f->list_dir( '/foo' => { recurse_fast => 1, max_depth => 3 } );
+
+=head2 Get the names of all files (no subdirectories) in a directory
+
+ my @dirs_and_files = $f->list_dir( '/foo' => { files_only => } );
+
+=head2 Get the names of all subdirectories (no files) in a directory
+
+ my @dirs_and_files = $f->list_dir( '/foo' => { dirs_only => 1 } );
+
+=head2 Get the number of files and subdirectories in a directory
+
+ my @dirs_and_files = $f->list_dir(
+ '/foo' => { no_fsdots => 1, count_only => 1 }
+ );
+
+=head2 Get the names of files and subdirs in a directory as separate array refs
+
+ my( $dirs, $files ) = $f->list_dir( '/foo' => { as_ref => 1 } );
+
+ -OR-
+
+ my( $dirs, $files ) = $f->list_dir(
+ '/foo' => { dirs_as_ref => 1, files_as_ref => 1 }
+ );
+
+=head2 Load all the files in a directory into a hashref
+
+ my $templates = $f->load_dir( '/var/www/mysite/templates' );
+
+ # $templates now contains something like:
+ # {
+ # 'header.html' => '...file contents...',
+ # 'body.html' => '...file contents...',
+ # 'footer.html' => '...file contents...',
+ # }
+
+ print $templates->{'header.html'};
+
+=head2 Recursively Get the names of all files that end in '.pl'
+
+ my @perl_files = $f->list_dir(
+ '/home/scripts' => { files_match => qr/\.pl$/, recurse => 1 }
+ }
+
+=head2 Recursively get the names of all files that do NOT end in '.pl'
+
+File::Util's C<list_dir()> method doesn't have a "not_matches" counterpart
+to the "files_match" parameter. This is because it doesn't need one. Perl
+already provides native support for negation in regular expressions. The
+example below shows you how to make sure a file does NOT match the pattern
+you provide as a subexpression in a "negative zero width assertion".
+
+It might sound complicated for a beginner, but it's really not that hard.
+
+See the L<perlre> documentation for more about negation in regular expressions.
+
+ # find all files that don't end in ".pl"
+ my @other_files = $f->list_dir(
+ '/home/scripts' => { files_match => qr/^(?!.*\.pl$)/, recurse => 1 }
+ }
+
+=head2 Combine several options for list_dir() and be awesome
+
+Find all files (not directories) that matches *any* number of given patterns
+(OR), whose parent directory matches *every* pattern in a list of given
+patterns (AND). Also make sure that the path to the files matches a list
+of patterns (AND).
+
+ # find the droids I'm looking for...
+ my @files = $f->list_dir(
+ '/home/anakin' => {
+ files_match => { or => [ qr/droid/, qr/3p(o|O)$/i, qr/^R2/ },
+ parent_matches => { and => [ qr/vader/i, qr/darth/i ] },
+ path_matches => { and => [ qr/obi-wan/i, qr/^(?!.*Qui-Gon)/ ] },
+ recursive => 1,
+ files_only => 1,
+ max_depth => 8,
+ }
+ );
+
+The above example would find and return files like:
+
+ /home/anakin/mentors/obi-wan/villains/darth-vader/R2.png
+ /home/anakin/mentors/obi-wan/villains/darth-vader/C3P0.dict
+ /home/anakin/mentors/obi-wan/villains/darth-vader/my_droids.list
+
+But would not return files like:
+
+ /home/anakin/mentors/Qui-Gon Jinn/villains/darth-vader/my_droids.list
+
+=head2 Use a callback to descend through (walk) a directory tree
+
+This is a really powerful feature. Because File::Util::list_dir() is a higher
+order function, it can take other functions as arguments. We often refer to
+these as "callbacks".
+
+Any time you specify a callback, File::Util will make sure it's first argument
+is the name if the directory it's in (recursion), and then the second and third
+arguments are listrefs. The first is a list reference containing the names of
+all subdirectories, and the second list ref contains the names of all the files.
+
+Below is a very simple example that doesn't really do much other than
+demonstrate the syntax. You can see more full-blown examples of callbacks in
+the L<File::Util::Cookbook>
+
+ # print all subdirectories under /home/larry/
+ $f->list_dir(
+ '/home/larry' => {
+ callback => sub { print shift @_, "\n" },
+ recurse => 1,
+ }
+ }
+
+=head2 Get a directory tree in a hierarchical hashref
+
+ my $tree = $f->list_dir( '/tmp' => { as_tree => 1, recurse => 1 } );
+
+ Gives you a datastructure like:
+ {
+ '/' => {
+ '_DIR_PARENT_' => undef,
+ '_DIR_SELF_' => '/',
+ 'tmp' => {
+ '_DIR_PARENT_' => '/',
+ '_DIR_SELF_' => '/tmp',
+ 'hJMOsoGuEb' => {
+ '_DIR_PARENT_' => '/tmp',
+ '_DIR_SELF_' => '/tmp/hJMOsoGuEb',
+ 'a.txt' => '/tmp/hJMOsoGuEb/a.txt',
+ 'b.log' => '/tmp/hJMOsoGuEb/b.log',
+ 'c.ini' => '/tmp/hJMOsoGuEb/c.ini',
+ 'd.bat' => '/tmp/hJMOsoGuEb/d.bat',
+ 'e.sh' => '/tmp/hJMOsoGuEb/e.sh',
+ 'f.conf' => '/tmp/hJMOsoGuEb/f.conf',
+ 'g.bin' => '/tmp/hJMOsoGuEb/g.bin',
+ 'h.rc' => '/tmp/hJMOsoGuEb/h.rc',
+ }
+ }
+ }
+ }
+
+*You can add the C<dirmeta> option, set to 0 (false), to remove the special
+entries C<_DIR_PARENT_> and C<_DIR_SELF_> from each subdirectory branch.
+
+Example:
+
+ my $tree = $f->list_dir(
+ '/tmp' => { as_tree => 1, dirmeta => 0, recurse => 1 }
+ );
+
+*You can still combine the C<as_tree> option with other options, such as the
+regex pattern matching options covered above, or options like C<recurse>, or
+C<files_only>.
+
+*You should be careful using this feature with very large directory trees, due
+to the memory it might consume. Memory usage is generally low, but will grow
+when you use this feature for larger and larger directory trees. Bear in mind
+that the C<$ABORT_DEPTH> limit applies here too (see L<File::Util>
+documentation), which you can override manually by setting the C<abort_depth>
+option:
+
+ # set max recursion limit to an integer value as shown below
+ $f->list_dir( '/tmp' => { as_tree => 1, recurse => 1, abort_depth => 123 } );
+
+=head2 Determine if something is a valid file name
+
+NOTE: This method is for determining if a B<file name> is valid. It does
+not determine if a full path is valid.
+
+ print $f->valid_filename( 'foo?+/bar~@/#baz.txt' ) ? 'ok' : 'bad';
+
+ -OR-
+
+ print File::Util->valid_filename( 'foo?+/bar~@/#baz.txt' ) ? 'ok' : 'bad';
+
+Like many other methods in File::Util, you can import this into your
+own namespace so you can call it like any other function, avoid the
+object-oriented syntax when you don't want or need it: (This manual doesn't
+duplicate the main documentation by telling you every method you can import --
+see the C<@EXPORT_OK> section of the L<File::Util> documentation)
+
+ use File::Util qw( valid_filename );
+
+ if ( valid_filename( 'foo?+/bar~@/#baz.txt' ) )
+ {
+ print 'file name is valid';
+ }
+ else
+ {
+ print 'That file name contains illegal characters';
+ }
+
+=head2 Get the number of lines in a file
+
+ my $linecount = $f->line_count( 'foo.txt' );
+
+=head2 Split a file path into its parts
+
+This method works differently than atomize_path(). With this method, you
+get not just the components of the path, but each element in the form of
+a list. The path will be split into the following pieces: (path root, if it
+exists, each subdirectory in the path, and the final file/directory )
+
+ use File::Util qw( split_path );
+
+ print "$_\n" for split_path( q{C:\foo\bar\baz\flarp.pl} )
+
+ -OR-
+
+ print "$_\n" for $f->split_path( q{C:\foo\bar\baz\flarp.pl} )
+
+ -OR-
+
+ print "$_\n" for File::Util->split_path( q{C:\foo\bar\baz\flarp.pl} )
+
+ The output of all of the above commands is:
+ C:\
+ foo
+ bar
+ baz
+ flarp.pl
+
+Above you see examples working on Windows-type paths. Below are some
+examples using *nix-style paths:
+
+ print "$_\n" for split_path( '/I/am/your/father/NOOOO' )
+
+ The output of all of the above commands is:
+ /
+ I
+ am
+ your
+ father
+ NOOOO
+
+=head2 Strip the path from a file name
+
+ # On Windows
+ # (prints "hosts")
+ my $path = $f->strip_path( 'C:\WINDOWS\system32\drivers\etc\hosts' );
+
+ # On Linux/Unix
+ # (prints "perl")
+ print $f->strip_path( '/usr/bin/perl' );
+
+ # On a Mac
+ # (prints "baz")
+ print $f->strip_path( 'foo:bar:baz' );
+
+ -OR-
+
+ use File::Util qw( strip_path );
+
+ print strip_path( '/some/file/name' ); # prints "name"
+
+=head2 Get the path preceding a file name
+
+ # On Windows
+ # (prints "C:\WINDOWS\system32\drivers\etc")
+ my $path = $f->return_path( 'C:\WINDOWS\system32\drivers\etc\hosts' );
+
+ # On Linux/Unix
+ # (prints "/usr/bin")
+ print $f->return_path( '/usr/bin/perl' );
+
+ # On a Mac
+ # (prints "foo:bar")
+ print $f->return_path( 'foo:bar:baz' );
+
+=head2 Find out if the host system can use flock
+
+ use File::Util qw( can_flock );
+ print can_flock;
+
+ -OR-
+
+ print File::Util->can_flock;
+
+ -OR-
+
+ print $f->can_flock;
+
+=head2 Find out if the host system needs to call binmode on binary files
+
+ use File::Util qw( needs_binmode );
+ print needs_binmode;
+
+ -OR-
+
+ print File::Util->needs_binmode;
+
+ -OR-
+
+ print $f->needs_binmode;
+
+=head2 Find out if a file can be opened for read (based on file permissions)
+
+ my $is_readable = $f->is_readable( 'foo.txt' );
+
+=head2 Find out if a file can be opened for write (based on file permissions)
+
+ my $is_writable = $f->is_writable( 'foo.txt' );
+
+=head2 Escape illegal characters in a potential file name (and its path)
+
+ # prints "C__WINDOWS_system32_drivers_etc_hosts"
+ print $f->escape_filename( 'C:\WINDOWS\system32\drivers\etc\hosts' );
+
+ # prints "baz)__@^"
+ # (strips the file path from the file name, then escapes it
+ print $f->escape_filename( '/foo/bar/baz)?*@^' => { strip_path => 1 } );
+
+ # prints "_foo_!_@so~me#illegal$_file&(name"
+ # (yes, technically that is a legal filename)
+ print $f->escape_filename( q{\foo*!_@so~me#illegal$*file&(name} );
+
+=head2 Find out if the host system uses EBCDIC
+
+ use File::Util qw( ebcdic );
+ print ebcdic;
+
+ -OR-
+
+ print File::Util->ebcdic;
+
+ -OR-
+
+ print $f->ebcdic;
+
+=head2 Get the type(s) of an existent file
+
+ use File::Util qw( file_type );
+ print file_type( 'foo.exe' );
+
+ -OR-
+
+ print File::Util->file_type( 'bar.txt' );
+
+ -OR-
+
+ print $f->file_type( '/dev/null' );
+
+=head2 Get the bitmask of an existent file
+
+ use File::Util qw( bitmask );
+ print bitmask( '/usr/sbin/sendmail' );
+
+ -OR-
+
+ print File::Util->bitmask( 'C:\COMMAND.COM' );
+
+ -OR-
+
+ print $f->bitmask( '/dev/null' );
+
+=head2 Get time of creation for a file
+
+ use File::Util qw( created );
+ print scalar localtime created( '/usr/bin/exim' );
+
+ -OR-
+
+ print scalar localtime File::Util->created( 'C:\COMMAND.COM' );
+
+ -OR-
+
+ print scalar localtime $f->created( '/bin/less' );
+
+=head2 Get the last access time for a file
+
+ use File::Util qw( last_access );
+ print scalar localtime last_access( '/usr/bin/exim' );
+
+ -OR-
+
+ print scalar localtime File::Util->last_access( 'C:\COMMAND.COM' );
+
+ -OR-
+
+ print scalar localtime $f->last_access( '/bin/less' );
+
+=head2 Get the inode change time for a file
+
+ use File::Util qw( last_changed );
+ print scalar localtime last_changed( '/usr/bin/vim' );
+
+ -OR-
+
+ print scalar localtime File::Util->last_changed( 'C:\COMMAND.COM' );
+
+ -OR-
+
+ print scalar localtime $f->last_changed( '/bin/cpio' );
+
+=head2 Get the last modified time for a file
+
+ use File::Util qw( last_modified );
+ print scalar localtime last_modified( '/usr/bin/exim' );
+
+ -OR-
+
+ print scalar localtime File::Util->last_modified( 'C:\COMMAND.COM' );
+
+ -OR-
+
+ print scalar localtime $f->last_modified( '/bin/less' );
+
+=head2 Make a new directory, recursively if necessary
+
+ $f->make_dir( '/var/tmp/tempfiles/foo/bar/' );
+
+ # you can optionally specify a bitmask for the new directory.
+ # the bitmask is combined with the user's current umask for the creation
+ # mode of the directory. (You should usually omit this.)
+
+ $f->make_dir( '/var/tmp/tempfiles/foo/bar/', 0755 );
+
+=head2 Touch a file
+
+ use File::Util qw( touch );
+ touch( 'somefile.txt' );
+
+ -OR-
+
+ $f->touch( '/foo/bar/baz.tmp' );
+
+=head2 Truncate a file
+
+ $f->trunc( '/wibble/wombat/noot.tmp' );
+
+=head2 Get the correct path separator for the host system
+
+ use File::Util qw( SL );
+ print SL;
+
+ -OR-
+
+ print File::Util->SL;
+
+ -OR-
+
+ print $f->SL;
+
+=head2 Get the correct newline character for the host system
+
+ use File::Util qw( NL );
+
+ print NL;
+
+ -OR-
+
+ print File::Util->NL;
+
+ -OR-
+
+ print $f->NL;
+
+=head2 Choose what to do if there's a problem (die, warn, zero, undefined, subref)
+
+ # When doing things with IO that might fail, set up good error handlers
+
+ # "Fail, these examples will..."
+
+ # If this call fails, die with an error message (*default*)
+ $f->write_file( 'bobafett.txt' => $content => { onfail => 'die' } );
+
+ # If this call fails, issue a warning to STDERR, but don't die/exit
+ $f->list_dir( '/home/greivous' => { onfail => 'warn' } );
+
+ # If this call fails, return a zero value (0), and don't die/exit
+ $f->open_handle( '/home/ventress/.emacs' => { onfail => 'zero' } );
+
+ # If this call fails, return undef, and don't die/exit
+ $f->load_file( '/home/vader/darkside.manual' => { onfail => 'undefined' } );
+
+ # If this call fails, execute the subroutine code and do whatever it says
+ # This code tries to load one directory, and failing that, loads another
+ $f->load_dir( '/home/palpatine/lofty_plans/' => {
+ onfail => sub { return $f->load_dir( '/home/sidious/evil_plots/' ) }
+ }
+ );
+
+=head1 AUTHORS
+
+Tommy Butler L<http://www.atrixnet.com/contact>
+
+=head1 COPYRIGHT
+
+Copyright(C) 2001-2013, Tommy Butler. All rights reserved.
+
+=head1 LICENSE
+
+This library is free software, you may redistribute it and/or modify it
+under the same terms as Perl itself. For more details, see the full text of
+the LICENSE file that is included in this distribution.
+
+=head1 LIMITATION OF WARRANTY
+
+This software is distributed in the hope that it will be useful, but without
+any warranty; without even the implied warranty of merchantability or fitness
+for a particular purpose.
+
+=head1 SEE ALSO
+
+L<File::Util::Manual>, L<File::Util::Cookbook>
+
+=cut
+
+__END__
@@ -0,0 +1,2204 @@
+package File::Util::Manual;
+use strict; use warnings; # for kwalitee tests
+
+# ABSTRACT: File::Util Reference
+
+=pod
+
+=head1 NAME
+
+File::Util::Manual - File::Util Reference
+
+=head1 VERSION
+
+version 4.132140
+
+=head1 INTRODUCTION
+
+This manual is is the complete reference to all available public methods for use
+in L<File::Util>. It also touches on a few other topics as set forth below.
+
+For a "nutshell"-type reference full of actual small example code snippets, take
+a look at the L<File::Util::Manual::Examples>
+
+For examples of full Programs using File::Util, take a look at the
+L<File::Util::Cookbook>.
+
+=head2 The layout of the Manual
+
+Now we'll start out with some brief notes about what File::Util is (and isn't),
+then we'll talk about the syntax used in File::Util. After that we discuss
+custom error handling and diagnostics in File::Util. Finally, the rest of this
+document will cover File::Util's object methods, one by one, with brief usage
+examples.
+
+=head2 What File::Util Is
+
+File::Util is a "Pure Perl" library that provides you with several easy-to-use
+tools to wrangle files and directories. It has higher order methods
+(that's fancy talk for saying that you can feed subroutine references to some
+of File::Util's object methods and they will be treated like "callbacks").
+
+File::Util is mainly Object-Oriented Perl, but strives to be gentle and
+accommodating to those who do not know about or who do not like "OO" interfaces.
+As such, many of the object methods available in File::Util can also be
+imported into your namespace and I<used like regular subroutines> to make
+short work of simple tasks.
+
+For more advanced tasks and features, you will need to use File::Util's
+object-oriented interface. Don't worry, it's easy, and there are plenty of
+examples here in the documentation to get you off to a great and productive
+start. If you run into trouble, L<help is available|File::Util/SUPPORT>.
+
+File::Util tries its best to adhere to these guiding principles:
+
+=over
+
+=item B<Be easy>
+
+Make hard things easier and safer to do while avoiding common mistakes
+associated with file handling in Perl. Code using File::Util will
+automatically be abiding by best practices with regard to Perl IO.
+
+File::Util makes the right decisions for you with regard to all the little
+details involved in the vast majority of file-related tasks. File locking
+is automatically performed for you! File handles are always lexically
+scoped. Safe reads and writes are performed with hard limits on the amount
+of RAM you are allowed to consume in your process per file read. (You can
+adjust the limits.)
+
+=item B<Be portable>
+
+We make sure that File::Util is going to work on your computer or virtual
+machine. If you run Windows, Mac, Linux, BSD, some flavor of Unix, etc...
+File::Util should work right out of the box. There are currently no platforms
+where Perl runs that we do not support. If Perl can run on it, File::Util
+can run on it. If you want unicode support, however, you need to at least
+be running Perl 5.8 or better.
+
+=item B<Be compatible>
+
+File::Util has been around for a long time, and so has Perl. We'd like to
+think that this is because they are good things! This means there is a lot
+of backward-compatibility to account for, even within File::Util itself.
+
+In the last several years, there has never been a release of File::Util that
+intentionally broke code running a previous version. We are unaware of that
+even happening. File::Util is written to support both old and new features,
+syntaxes, and interfaces with full backward-compatibility.
+
+=item B<Be helpful>
+
+If requested, File::Util outputs extremely detailed error messages when
+something goes wrong in a File::Util operation. The diagnostic error
+messages not only provide information about what went wrong, but also hints
+on how to fix the problem.
+
+These error messages can easily be turned on and off.
+See L<DIAGNOSTICS|/DIAGNOSTICS> for the details.
+
+=item B<Be Pure>
+
+File::Util uses no XS or C underpinnings that require you to have a compiler
+or make utility on your system in order to use it. Simply follow standard
+installation procedures (L<INSTALLATION|File::Util/INSTALLATION>) and you're
+done. No compiling required.
+
+=back
+
+=head2 What File::Util Is NOT
+
+File::Util offers significant performance increases over other modules for
+most directory-walking and searching, whether doing so in a single
+directory or in many directories recursively. I<(See also the benchmarking>
+I<and profiling scripts included in the performance subdirectory as part of>
+I<this distribution)*>
+
+However File::Util is B<NOT> a single-purpose file-finding/searching utility
+like File::Find::Rule which offers a handful of extra built-in search features
+that File::Util does not give you out of the box, such as searching for files by
+owner/group or size. It is possible to accomplish the same things by
+taking advantage of File::Util's callbacks if you want to, but this isn't
+the "one thing" File::Util was built to do.
+
+I<*Sometimes it doesn't matter how fast you can search through a directory 1000>
+I<times. Performance alone isn't the best criteria for choosing a module.>
+
+=head1 SYNTAX
+
+In the past, File::Util relied on an older method invocation syntax that
+was not robust enough to support the newer features that have been added
+since version 4.0. In addition to making new features possible, the new
+syntax is more in keeping with what the Perl community has come to expect
+from its favorite modules, like Moose and DBIx::Class.
+
+=head2 OLD Syntax Example
+
+ # this legacy syntax looks clunky and kind of smells like shell script
+ $f->list_dir( '/some/dir', '--recurse', '--as-ref', '--pattern=[^\d]' );
+
+=head2 NEW Syntax Example (Does Much More)
+
+ # This syntax is much more robust, and supports new features
+ $f->list_dir(
+ '/some/dir' => {
+ files_match => { or => [ qr/bender$/, qr/^flexo/ ] },
+ parent_matches => { and => [ qr/^Planet/, qr/Express$/ ] },
+ callback => \&deliver_interstellar_shipment,
+ files_only => 1,
+ recurse => 1,
+ as_ref => 1,
+ }
+ )
+
+If you already have code that uses the old syntax, DON'T WORRY -- it's still
+fully supported behind the scenes. However, for new code that takes advantage
+of new features like higher order functions (callbacks), or advanced matching
+for directory listings, you'll need to use the syntax as set forth in this
+document. The old syntax isn't covered here, because you shouldn't use it
+anymore.
+
+=head3 I<An Explanation Of The "Options Hashref">
+
+As shown in the code example above, the new syntax uses hash references to
+specify options for calls to File::Util methods. This documentation refers to
+these as the "options hashref". The code examples below illustrates what they
+are and how they are used. Advanced Perl programmers will recognize these
+right away.
+
+NOTE: I<"hashref" is short for "hash reference".> Hash references use curly
+brackets and look like this:
+
+ my $hashref = { name => 'Larry', language => 'Perl', pet => 'Velociraptor' };
+
+File::Util uses these hash references as argument modifiers that allow you to
+enable or disable certain features or behaviors, so you get the output you
+want, like this:
+
+ my $result = $ftl->some_method_call( arg1, arg2, { options hashref } );
+ # ^^^^^^^^^^^^^^^ #
+
+A couple of real examples would look like this:
+
+ $ftl->write_file( '/some/file.txt', 'Hello World!', { mode => 'append' } );
+ # ^^^^^^^^^^^^^^^^ #
+
+ $ftl->list_dir( '/home/dangerian' => { recurse => 1, files_only => 1 } );
+ # ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ #
+
+
+=head1 ERROR HANDLING
+
+=head2 Feature Summary
+
+Managing potential errors is a big part of Perl IO. File::Util gives you
+several options. In fact, every single call to a File::Util method which
+accepts an "options hashref" can also include an error handling directive.
+File::Util has some pre-defined error handling behaviors that you can choose
+from, or you can supply your own error handler routine. This is accomplished
+via the B<C<onfail>> option.
+
+As an added convenience, when you use this option with the
+L<File::Util constructor method|/new>, it sets the default error handling
+policy for all failures; in other words, you can set up one error handler
+for everything and never have to worry about it after that.
+
+ # Set every error to cause a warning instead of dying by default
+ my $ftl = File::Util->new( { onfail => 'warn' } );
+
+ $ftl->write_file( 'C:\\' => 'woof!' ); # now this call will warn and not die
+
+=head2 Details
+
+The predefined B<C<onfail>> behaviors and their syntaxes are covered below.
+
+=over
+
+=item keyword: B<C<die>>
+
+This is what File::Util already does: it calls C<CORE::die()> with an error
+message when it encounters a fatal error, and your program terminates.
+
+Example:
+
+ my $ftl = File::Util->new( ... { onfail => 'die' } );
+
+=item keyword: B<C<zero>>
+
+When you use the predefined B<C<zero>> behavior as the C<onfail> handler,
+File::Util will return a zero value (the integer C<0>) if it encounters a fatal
+error, instead of dying. File::Util won't warn about the error or abort
+execution. You will just get a zero back instead of what you would have
+gotten otherwise, and execution will continue as if no error happened.
+
+Example:
+
+ my $content = File::Util->load_file( ... { onfail => 'zero' } );
+
+=item keyword: B<C<undefined>>
+
+When you use the predefined B<C<undefined>> behavior as the C<onfail> handler,
+if File::Util runs into a fatal error it will return C<undef>. Execution will
+not be aborted, and no warnings will be issued. A value of undef will just
+get sent back to the caller instead of what you would have gotten otherwise.
+Execution will then continue on as if no error happened.
+
+Note: This option usually makes more practical sense than
+C<< onfail => 'zero' >>
+
+Example:
+
+ my $handle = File::Util->open_handle( ... { onfail => 'undefined' } );
+
+=item keyword: B<C<warn>>
+
+When you use the predefined B<C<warn>> behavior as the C<onfail> handler,
+File::Util will return C<undef> if it encounters a fatal error, instead of
+dying. Then File::Util will emit a B<warning> with details about the error,
+but will not abort execution. You will just get a warning message sent to
+STDERR and C<undef> gets sent back to the caller instead of what you would have
+gotten otherwise. Other than the warning, execution will continue as if no
+error ever happened.
+
+Example:
+
+ my $write_ok = File::Util->write_file( ... { onfail => 'warn' } );
+
+=item keyword: B<C<message>>
+
+When you use the predefined B<C<message>> behavior as the C<onfail> handler,
+if File::Util runs into a fatal error it will return an error message in the
+form of a string containing details about the problem. Execution will not
+be aborted, and no warnings will be issued. You will just get an error message
+sent back to the caller instead of what you would have gotten otherwise.
+Execution will then continue on as if no error happened.
+
+Example:
+
+ my @files = File::Util->list_dir( ... { onfail => 'message' } );
+
+=item B<C<subroutine reference>>
+
+If you supply a code reference to the C<onfail> option in a File::Util method
+call, it will execute that code if it encounters a fatal error. You must
+supply a true code reference, as shown in the examples below, either to a
+named or anonymous subroutine.
+
+The subroutine you specify will receive two arguments as its input in "C<@_>".
+The first will be the text of the error message, and the second will be a
+stack trace in text format. You can send them to a logger, to your
+sysadmin in an email alert, or whatever you like-- because it is B<*your*>
+error handler.
+
+B<WARNING! >
+B<If you do not call C<die> or C<exit> at the end of your error handler,>
+B<File::Util will NOT exit, but continue to execute.> When you opt to use
+this feature, you are fully responsible for your process' error handling
+and post-error execution.
+
+Examples using the constructor:
+
+ # step 1) define your custom error handler
+ sub politician_error_handler {
+
+ my ( $err, $stack ) = @_;
+
+ # do stuff like ...
+
+ $logger->debug( $stack );
+
+ die 'We neither confirm nor deny that an IO error has happened.';
+ }
+
+ # step 2) apply your error handler
+ my $ftl = File::Util->new( { onfail => \&politician_error_handler } );
+
+ -OR-
+
+ # Define and apply your error handler in one step:
+
+ my $ftl = File::Util->new(
+ {
+ onfail => sub {
+ my ( $err, $stack ) = @_;
+
+ # do stuff ...
+ }
+ }
+ );
+
+Examples in individual method calls:
+
+ $ftl->write_file( 'greedo' => 'try bargain' => { onfail => \&shoot_first } );
+
+ my $file_handle = $ftl->open_handle(
+ '/this/might/not/work' => {
+ onfail => sub {
+ warn "Couldn't open first choice, trying a backup plan...";
+ return $ftl->open_handle( '/this/one/should/work' );
+ }
+ }
+ );
+
+=back
+
+
+=head1 DIAGNOSTICS
+
+When things go wrong, sometimes it's nice to get as much information as
+possible about the error. In C<File::Util>, you incur no performance penalties
+by enabling more verbose error messages. In fact, you're encouraged to do so.
+
+You can globally enable diagnostic messages (for every C<File::Util> object you
+create), or on a per-object basis, or even on a per-call basis when you just
+want to diagnose a problem with a single method invocation. Here's how:
+
+=over 8
+
+=item Enable Diagnostics Globally
+
+ use File::Util qw( :diag );
+
+=item Enable Diagnostics Per-Object
+
+ my $ftl = File::Util->new( diag => 1 );
+
+=item Enable Diagnostics Temporarily
+
+ $ftl->diagnostic( 1 ); # turn diagnostic mode on
+
+ # ... do some troubleshooting ...
+
+ $ftl->diagnostic( 0 ); # turn diagnostic mode off
+
+=item Enable Diagnostics per-call
+
+ $ftl->load_file( 'abc.txt' => { diag => 1 } );
+
+=back
+
+
+=head1 METHODS
+
+B<Note:> In the past, some of the methods listed would state that they were
+autoloaded methods. This mechanism has been changed in favor of more
+modern practices, in step with the evolution of computing over the last decade
+since File::Util was first released.
+
+Methods listed in alphabetical order.
+
+=head2 C<atomize_path>
+
+=over
+
+=item I<Syntax:> C<atomize_path( [/file/path or file_name] )>
+
+This method is used internally by File::Util to handle absolute filenames on
+different platforms in a portable manner, but it can be a useful tool for you
+as well.
+
+This method takes a single string as its argument. The string is expected
+to be a fully-qualified (absolute) or relative path to a file or directory.
+It carefully splits the string into three parts: The root of the path, the
+rest of the path, and the final file/directory named in the string.
+
+Depending on the input, the root and/or path may be empty strings. The
+following table can serve as a guide in what to expect from C<atomize_path()>
+
+ +-------------------------+----------+--------------------+----------------+
+ | INPUT | ROOT | PATH-COMPONENT | FILE/DIR |
+ +-------------------------+----------+--------------------+----------------+
+ | C:\foo\bar\baz.txt | C:\ | foo\bar | baz.txt |
+ | /foo/bar/baz.txt | / | foo/bar | baz.txt |
+ | ./a/b/c/d/e/f/g.txt | | ./a/b/c/d/e/f | g.txt |
+ | :a:b:c:d:e:f:g.txt | : | a:b:c:d:e:f | g.txt |
+ | ../wibble/wombat.ini | | ../wibble | wombat.ini |
+ | ..\woot\noot.doc | | ..\woot | noot.doc |
+ | ../../zoot.conf | | ../.. | zoot.conf |
+ | /root | / | | root |
+ | /etc/sudoers | / | etc | sudoers |
+ | / | / | | |
+ | D:\ | D:\ | | |
+ | D:\autorun.inf | D:\ | | autorun.inf |
+ +-------------------------+----------+--------------------+----------------+
+
+=back
+
+=head2 C<bitmask>
+
+=over
+
+=item I<Syntax:> C<bitmask( [file name] )>
+
+Gets the bitmask of the named file, provided the file exists. If the file
+exists and is accessible, the bitmask of the named file is returned in four
+digit octal notation e.g.- C<0644>. Otherwise, returns C<undef> if the file
+does I<not> exist or could not be accessed.
+
+=back
+
+=head2 C<can_flock>
+
+=over
+
+=item I<Syntax:> C<can_flock>
+
+Returns 1 if the current system claims to support C<flock()> I<and> if the
+Perl process can successfully call it. I<(see L<perlfunc/flock>.)> Unless
+both of these conditions are true, a zero value (0) is returned. This is a
+constant method. It accepts no arguments and will always return the same
+value for the system on which it is executed.
+
+B<Note:> Perl tries to support or emulate flock whenever it can via
+available system calls, namely C<flock>; C<lockf>; or with C<fcntl>.
+
+=back
+
+=head2 C<created>
+
+=over
+
+=item I<Syntax:> C<created( [file name] )>
+
+Returns the time of creation for the named file in non-leap seconds since
+whatever your system considers to be the epoch. Suitable for feeding to
+Perl's built-in functions "gmtime" and "localtime". I<(see L<perlfunc/time>.)>
+
+=back
+
+=head2 C<diagnostic>
+
+=over
+
+=item I<Syntax:> C<diagnostic( [true / false value] )>
+
+When called without any arguments, this method returns a true or false value
+to reflect the current setting for the use of diagnostic (verbose) error
+messages when a File::Util object encounters errors.
+
+When called with a true or false value as its single argument, this tells
+the File::Util object whether or not it should enable diagnostic
+error messages in the event of a failure. A true value indicates that the
+File::Util object will enable diagnostic mode, and a false value indicates
+that it will not. The default setting for C<diagnostic()> is C<0>
+(NOT enabled.)
+
+I<see also L<DIAGNOSTICS|/DIAGNOSTICS>>
+
+=back
+
+
+=head2 C<ebcdic>
+
+=over
+
+=item I<Syntax:> C<ebcdic>
+
+Returns 1 if the machine on which the code is running uses EBCDIC, or returns
+0 if not. I<(see L<perlebcdic>.)> This is a constant method. It accepts
+no arguments and will always return the same value for the system on which it
+is executed.
+
+=back
+
+=head2 C<escape_filename>
+
+=over
+
+=item I<Syntax:> C<escape_filename( [string], [escape char] )>
+
+Returns it's argument in an escaped form that is suitable for use as a filename.
+Illegal characters (i.e.- any type of newline character, tab, vtab, and the
+following C<< / | * " ? < : > \ >>), are replaced with [escape char] or
+"B<_>" if no [escape char] is specified. Returns an empty string if no
+arguments are provided.
+
+=back
+
+=head2 C<existent>
+
+=over
+
+=item I<Syntax:> C<existent( [file name] )>
+
+Returns 1 if the named file (or directory) exists. Otherwise a value of
+undef is returned.
+
+This works the same as Perl's built-in C<-e> file test operator,
+I<(see L<perlfunc/-X>)>, it's just easier for some people to remember.
+
+=back
+
+=head2 C<file_type>
+
+=over
+
+=item I<Syntax:> C<file_type( [file name] )>
+
+Returns a list of keywords corresponding to each of Perl's built in file tests
+(those specific to file types) for which the named file returns true.
+I<(see L<perlfunc/-X>.)>
+
+The keywords and their definitions appear below; the order of keywords returned
+is the same as the order in which the are listed here:
+
+=over
+
+=item C<PLAIN File is a plain file.>
+
+=item C<TEXT File is a text file.>
+
+=item C<BINARY File is a binary file.>
+
+=item C<DIRECTORY File is a directory.>
+
+=item C<SYMLINK File is a symbolic link.>
+
+=item C<PIPE File is a named pipe (FIFO).>
+
+=item C<SOCKET File is a socket.>
+
+=item C<BLOCK File is a block special file.>
+
+=item C<CHARACTER File is a character special file.>
+
+=back
+
+=back
+
+=head2 C<flock_rules>
+
+=over
+
+=item I<Syntax:> C<flock_rules( [keyword list] )>
+
+Sets I/O race condition policy, or tells File::Util how it should handle race
+conditions created when a file can't be locked because it is already locked
+somewhere else (usually by another process).
+
+An empty call to this method returns a list of keywords representing the rules
+that are currently in effect for the object.
+
+Otherwise, a call should include a list containing your chosen
+directive keywords in order of precedence. The rules will be applied in
+cascading order when a File::Util object attempts to lock a file, so if the
+actions specified by the first rule don't result in success, the second rule
+is applied, and so on.
+
+This setting can be dynamically changed at any point in your code by calling
+this method as desired.
+
+B<The default behavior of File::Util is to try and obtain an exclusive lock>
+B<on all file opens (if supported by your operating system). If a lock cannot>
+B<be obtained, File::Util will throw an exception and exit.>
+
+If you want to change that behavior, this method is the way to do it. One
+common situation is for someone to want their code to first try for a lock,
+and failing that, to wait until one can be obtained. If that's what you
+want, see the examples after the keywords list below.
+
+Recognized keywords:
+
+=over
+
+=item C<NOBLOCKEX>
+
+tries to get an exclusive lock on the file without blocking (waiting)
+
+=item C<NOBLOCKSH>
+
+tries to get a shared lock on the file without blocking
+
+=item C<BLOCKEX>
+
+waits to get an exclusive lock
+
+=item C<BLOCKSH>
+
+waits to get a shared lock
+
+=item C<FAIL>
+
+dies with stack trace
+
+=item C<WARN>
+
+warn()s about the error and returns undef
+
+=item C<IGNORE>
+
+ignores the failure to get an exclusive lock
+
+=item C<UNDEF>
+
+returns undef
+
+=item C<ZERO>
+
+returns 0
+
+=back
+
+Examples:
+
+=over
+
+=item ex- C<flock_rules( qw( NOBLOCKEX FAIL ) );>
+
+This is the default policy. When in effect, the File::Util object will first
+attempt to get a non-blocking exclusive lock on the file. If that attempt
+fails the File::Util object will call die() with an error.
+
+=item ex- C<flock_rules( qw( NOBLOCKEX BLOCKEX FAIL ) );>
+
+The File::Util object will first attempt to get a non-blocking exclusive lock
+on the file. If that attempt fails it falls back to the second policy rule
+"BLOCKEX" and tries again to get an exclusive lock on the file, but this time
+by blocking (waiting for its turn). If that second attempt fails, the
+File::Util object will fail with an error.
+
+=item ex- C<flock_rules( qw( BLOCKEX IGNORE ) );>
+
+The File::Util object will first attempt to get a file non-blocking lock on
+the file. If that attempt fails it will ignore the error, and go on to open
+the file anyway and no failures or warnings will occur.
+
+=back
+
+=back
+
+=head2 C<is_bin>
+
+=over
+
+=item I<Syntax:> C<is_bin( [file name] )>
+
+Returns 1 if the named file (or directory) exists. Otherwise a value of undef
+is returned, indicating that the named file either does not exist or is of
+another file type.
+
+This works the same as Perl's built-in C<-B> file test operator,
+I<(see L<perlfunc/-X>)>, it's just easier for some people to remember.
+
+=back
+
+=head2 C<is_readable>
+
+=over
+
+=item I<Syntax:> C<is_readable( [file name] )>
+
+Returns 1 if the named file (or directory) is B<readable> by your program
+according to the applied permissions of the file system on which the file
+resides. Otherwise a value of undef is returned.
+
+This works the same as Perl's built-in C<-r> file test operator,
+I<(see L<perlfunc/-X>)>, it's just easier for some people to remember.
+
+=back
+
+=head2 C<is_writable>
+
+=over
+
+=item I<Syntax:> C<is_writable( [file name] )>
+
+Returns 1 if the named file (or directory) is B<writable> by your program
+according to the applied permissions of the file system on which the file
+resides. Otherwise a value of undef is returned.
+
+This works the same as Perl's built-in C<-w> file test operator,
+I<(see L<perlfunc/-X>)>, it's just easier for some people to remember.
+
+=back
+
+=head2 C<last_access>
+
+=over
+
+=item I<Syntax:> C<last_access( [file name] )>
+
+Returns the last accessed time for the named file in non-leap seconds since
+whatever your system considers to be the epoch. Suitable for feeding to
+Perl's built-in functions "gmtime" and "localtime". I<(see L<perlfunc/time>.)>
+
+=back
+
+=head2 C<last_changed>
+
+=over
+
+=item I<Syntax:> C<last_changed( [file name] )>
+
+Returns the inode change time for the named file in non-leap seconds since
+whatever your system considers to be the epoch. Suitable for feeding to
+Perl's built-in functions "gmtime" and "localtime". I<(see L<perlfunc/time>.)>
+
+=back
+
+=head2 C<last_modified>
+
+=over
+
+=item I<Syntax:> C<last_modified( [file name] )>
+
+Returns the last modified time for the named file in non-leap seconds since
+whatever your system considers to be the epoch. Suitable for feeding to
+Perl's built-in functions "gmtime" and "localtime". I<(see L<perlfunc/time>.)>
+
+=back
+
+=head2 C<line_count>
+
+=over
+
+=item I<Syntax:> C<line_count( [file name] )>
+
+Returns the number of lines in the named file. Fails with an error if the
+named file does not exist.
+
+=back
+
+=head2 C<list_dir>
+
+=over
+
+=item I<Syntax:> C<< list_dir( [directory name] => { option => value, ... } ) >>
+
+Returns all file names in the specified directory, sorted in alphabetical
+order. Fails with an error if no such directory is found, or if the
+directory is inaccessible.
+
+Note that this is one of File::Util's most robust methods, and can be very
+useful. It can be used as a higher order function (accepting callback
+subrefs), and can be used for advanced pattern matching against files.
+It can also return a hierarchical data structure of the file tree you ask it to
+walk.
+
+See the L<File::Util::Manual::Examples> for several useful ways to use
+C<list_dir()>.
+
+Syntax example to recursively return a list of subdirectories in
+directory "dir_name":
+
+ my @dirs = $f->list_dir( 'dir_name' => { dirs_only => 1, recurse => 1 } );
+
+=over
+
+=item B<Options accepted by C<list_dir()>>
+
+=over
+
+=item C<< callback => subroutine reference >>
+
+C<list_dir()> can accept references to subroutines of your own. If you
+pass it a code reference using this option, File::Util will execute your
+code every time list_dir() enters a directory. This is particularly useful
+when combined with the C<recurse> option which is explained below.
+
+When you create a callback function, the File::Util will pass it four
+arguments in this order: The name of the current directory, a reference to a
+list of subdirectories in the current directory, a reference to a list of files
+in the current directory, and the depth (positive integer) relative to the
+directory you provided as your first argument to C<list_dir()>.
+I<This means if you pass in a path such as> C</var/tmp>,
+I<that "/var/tmp" is at a depth of 0, "/var/tmp/foo" is 1 deep, and so on>
+I<down through the "/var/tmp" directory.>
+
+Remember that the code in your callback gets executed in real time,
+I<as list_dir() is walking the directory tree>. Consider this example:
+
+ # Define a subroutine to print the byte size and depth of all files in a
+ # directory, designed to be used as a callback function to list_dir()
+
+ sub filesize {
+ my ( $selfdir, $subdirs, $files, $depth ) = @_;
+
+ print( "$_ | " . ( -s $_ ) . " | $depth levels deep\n" for @$files;
+ }
+
+ # Now list directory recursively, invoking the callback on every recursion
+
+ $f->list_dir( './droids' => { recurse => 1, callback => \&filesize } );
+
+ # Output would look something like
+ #
+ # ./droids/by-owner/luke/R2.spec | 1024 | 3 deep
+ # ./droids/by-owner/luke/C2P0.spec | 2048 | 3 deep
+ # ./droids/by-boss/dooku/Grievous.spec | 4096 | 3 deep
+ # ./droids/by-series/imperial/sentries/R5.spec | 1024 | 4 deep
+ #
+ # Depth breakdown
+ #
+ # level 0 => ./droids/
+ # level 1 => ./droids/by-owner/
+ # level 1 => ./droids/by-boss/
+ # level 1 => ./droids/by-series/
+ # level 2 => ./droids/by-owner/luke/
+ # level 2 => ./droids/by-boss/dooku/
+ # level 2 => ./droids/by-series/imperial/
+ # level 3 => ./droids/by-series/imperial/sentries/
+
+Another way to use callbacks is in combination with closures, to "close around"
+a variable or variables defined in the same scope as the callback. A demonstration
+of this technique is shown below:
+
+ {
+ my $size_total;
+ my $dir = 'C:\Users\superman\projects\scripts_and_binaries';
+
+ # how many total bytes are in all of the executable files in $dir
+
+ $f->list_dir(
+ $dir => {
+ callback => sub {
+ my ( $selfdir, $subdirs, $files, $depth ) = @_;
+
+ $size_total += -s $_ for grep { -B $_ } @$files;
+ }
+ }
+ );
+
+ print "There's $size_total bytes of binary files in my projects dir.";
+ }
+
+=item C<< d_callback => subroutine reference >>
+
+A C<d_callback> is just like a C<callback>, except it is only executed
+on directories encountered in the file tree, not files, and its input
+is slightly different. C<@_> is comprised of (in order) the name of the
+current directory, a reference to a list of all subdirectories in that
+directory, and the depth (positive integer) relative to the B<top level>
+directory in the path you provided as your first argument to C<list_dir>.
+
+=item C<< f_callback => subroutine reference >>
+
+Similarly an C<f_callback> is just like a C<callback>, except it is only
+concerned with files encountered in the file tree, not directories. It's input
+is also slightly different. C<@_> is comprised of (in order) the name of the
+current directory, a reference to a list of all files present in that
+directory, and the depth (positive integer) relative to the B<top level>
+directory in the path you provided as your first argument to C<list_dir>.
+
+=item C<< dirs_only => boolean >>
+
+return only directory contents which are also directories
+
+=item C<< files_only => boolean >>
+
+return only directory contents which are files
+
+=item C<< max_depth => positive integer >>
+
+Works just like the C<-maxdepth> flag in the GNU find command. This option
+tells C<list_dir()> to limit results to directories at no more than the maximum
+depth you specify. This only works in tandem with the C<recurse> option
+(or the C<recurse_fast> option which is similar).
+
+For compatibility reasons, you can use "C<maxdepth>" without the underscore
+instead, and get the same functionality.
+
+=item C<< no_fsdots => boolean >>
+
+do not include "." and ".." in the list of directory contents returned
+
+=item C<< abort_depth => positive integer >>
+
+Override the global limit on L<abort_depth|/abort_depth> recursions for
+directory listings, on a per-listing basis with this option. Just like the
+main C<abort_depth()> object method, this option takes a positive integer. The
+default is 1000. Sometimes it is useful to increase this number by quite a lot
+when walking directories with callbacks.
+
+=item C<< with_paths => boolean >>
+
+Return results with the preceding file paths intact, relative
+to the directory named in the call.
+
+=item C<< recurse => boolean >>
+
+Recurse into subdirectories. In other words, open up subdirectories and
+continue to descend into the directory tree either as far as it goes, or until
+the C<abort_depth> limit is reached. I<See L<abort_depth()|/abort_depth>>
+
+=item C<< recurse_fast => boolean >>
+
+Recurse into subdirectories, without checking for filesystem loops. This
+works exactly like the C<recurse> option, except it turns off internal
+checking for duplicate inodes while descending through a file tree.
+
+You get a performance boost at the sacrifice of a little "safety checking".
+
+The bigger your file tree, the more performance gains you see.
+
+This option has no effect on Windows. I<(see perldoc -f stat)>
+
+=item C<< dirs_as_ref => boolean >>
+
+When returning directory listing, include first a reference to the list
+of subdirectories found, followed by anything else returned by the call.
+
+=item C<< files_as_ref => boolean >>
+
+When returning directory listing, include last a reference to the list
+of files found, preceded by a list of subdirectories found (or preceded
+by a list reference to subdirectories found if C<dirs_as_ref> was also used).
+
+=item C<< as_ref => boolean >>
+
+Return a pair list references: the first is a reference to any subdirectories
+found by the call, the second is a reference to any files found by the call.
+
+=item C<< sl_after_dirs => boolean >>
+
+Append a directory separator ("/, "\", or ":" depending on your system)
+to all directories found by the call. Useful in visual displays for quick
+differentiation between subdirectories and files.
+
+=item C<< ignore_case => boolean >>
+
+Return items in a case-insensitive alphabetic sort order, as opposed to the
+default.
+
+**By default, items returned by the call to this method are alphabetically
+sorted in a case-insensitive manner, such that "Zoo.txt" comes before
+"alligator.txt". This is also the way files are listed at the system
+level on most operating systems.
+
+However, if you'd like the directory contents returned by this method to be
+sorted without regard to case, use this option. That way, "alligator.txt"
+will come before "Zoo.txt".
+
+=item C<< count_only => boolean >>
+
+Returns a single value: an integer reflecting the number of items found in
+the directory after applying any filter criteria that may also have been
+specified by other options (i.e.- "dirs_only", "recurse", etc.)
+
+=item C<< as_tree => boolean >>
+
+Returns a hierarchical data structure (hashref) of the file tree in the directory
+you specify as the first argument to C<list_dir()>. Use in combination with
+other options to get the exact results you want in the data structure.
+
+*Note: When using this option, the C<"files_only"> and C<"dirs_only"> options
+are ignored, but you can still specify things like a C<"max_depth"> argument,
+however. Note also that you need to specifically call this with the
+C<"recurse"> or C<"recurse_fast"> option or you will only get a single-level
+tree structure.
+
+One quick example:
+
+ my $tree = $ftl->list_dir(
+ '/tmp' => {
+ as_tree => 1,
+ recurse => 1,
+ }
+ );
+
+ # output would look something like this if you Data::Dumper'd it
+ {
+ '/' => {
+ '_DIR_PARENT_' => undef,
+ '_DIR_SELF_' => '/',
+ 'tmp' => {
+ '_DIR_PARENT_' => '/',
+ '_DIR_SELF_' => '/tmp',
+ 'hJMOsoGuEb' => {
+ '_DIR_PARENT_' => '/tmp',
+ '_DIR_SELF_' => '/tmp/hJMOsoGuEb',
+ 'a.txt' => '/tmp/hJMOsoGuEb/a.txt',
+ 'b.log' => '/tmp/hJMOsoGuEb/b.log',
+ 'c.ini' => '/tmp/hJMOsoGuEb/c.ini',
+ 'd.bat' => '/tmp/hJMOsoGuEb/d.bat',
+ 'e.sh' => '/tmp/hJMOsoGuEb/e.sh',
+ 'f.conf' => '/tmp/hJMOsoGuEb/f.conf',
+ 'g.bin' => '/tmp/hJMOsoGuEb/g.bin',
+ 'h.rc' => '/tmp/hJMOsoGuEb/h.rc',
+ }
+ }
+ }
+ }
+
+
+When using this option, the hashref you get back will have certain metadata
+entries at each level of the hierarchy, namely there will be two special
+keys: "_DIR_SELF", and "_DIR_PARENT_". Their values will be the name of
+the directory itself, and the name of its parent, respectively.
+
+That metadata can be extremely helpful when iterating over and parsing the
+hashref later on, but if you don't want the metadata, include the
+C<dirmeta> option and set it to a zero (false) value as shown below:
+
+ my $tree = $ftl->list_dir(
+ '/some/dir' => {
+ as_tree => 1,
+ recurse => 1,
+ dirmeta => 0,
+ }
+ );
+
+**Remember: the C<as_tree> doesn't recurse into subdirectories unless you tell
+it to with C<< recurse => 1 >>
+
+=back
+
+=item B<Filtering and Matching with C<list_dir()>>
+
+C<list_dir()> can use Perl L<Regular Expressions|perlre> to match against
+and thereby filter the results it returns. It can match based on file name,
+directory name, the path preceding results, and the parent directory of
+results. The matching arguments you use must be real regular expression
+references as shown (i.e.- NOT strings).
+
+Regular expressions can be provided as a single argument value, or a
+specifically crafted hashref designating a list of patterns to match against
+in either an "or" manner, or an "and"ed cumulative manner.
+
+Some short examples of proper syntax will be provided after the list of
+matching options below.
+
+I<**If you experience a big slowdown in directory listings while>
+I<using regular expressions, check to make sure your regular expressions are>
+I<properly written and optimized. In general, directory listings should>
+I<not be slow or resource-intensive. Badly-written regular expressions will>
+I<result in considerable slowdowns and bottlenecks in any application.>
+
+=over
+
+=item C<< files_match => qr/regexp/ >>
+
+=item I<OR:> C<< files_match => { and/or => [ qr/listref of/, qr/regexps/ ] } >>
+
+Return only file names matching the regex(es). Preceding directories are
+included in the results; for technical reasons they are not excluded (if they
+were excluded, C<list_dir()> would not be able to "cascade" or recurse into
+subdirectories in search of matching files.
+
+Use the C<files_only> option in combination with this matching parameter to
+exclude the preceding directory names.
+
+=item C<< dirs_match => qr/regexp/ >>
+
+=item I<OR:> C<< dirs_match => { and/or => [ qr/listref of/, qr/regexps/ ] } >>
+
+Return only files and subdirectory names in directories that match the
+regex(es) you specify. B<BE CAREFUL> with this one!! It doesn't "cascade"
+the way you might expect; for technical reasons, it won't descend into
+directories that don't match the regex(es) you provide. For example, if you
+want to match a directory name that is three levels deep against a given
+pattern, but don't know (or don't care about) the names of the intermediate
+directories-- THIS IS NOT THE OPTION YOU ARE LOOKING FOR. Use the
+C<path_matches> option instead.
+
+B<*NOTE:> Bear in mind that just because you tell C<list_dir()> to match each
+directory against the regex(es) you specify here, that doesn't mean you are
+telling it to only show directories in its results. You will get file names
+in matching directories included in the results as well, unless you combine
+this with the C<dirs_only> option.
+
+=item C<< path_matches => qr/regexp/ >>
+
+=item I<OR:> C<< path_matches => { and/or => [ qr/listref of/, qr/regexps/ ] } >>
+
+Return only files and subdirectory names with preceding paths that match the
+regex(es) you specify.
+
+=item C<< parent_matches => qr/regexp reference/ >>
+
+=item I<OR:> C<< parent_matches => { and/or => [ qr/listref of/, qr/regexps/ ] } >>
+
+Return only files and subdirectory names whose parent directory matches the
+regex(es) you specify.
+
+=back
+
+=item Examples of matching and filtering results in C<listdir()>
+
+Single-argument matching examples
+
+ my @files = $f->list_dir(
+ '../notes' => { files_match => qr/\.txt$/i, files_only => 1 }
+ );
+
+ my @dirs = $f->list_dir(
+ '/var' => {
+ dirs_match => qr/log|spool/i,
+ recurse => 1,
+ dirs_only => 1,
+ }
+ );
+
+ my @dirs = $f->list_dir(
+ '/home' => {
+ path_matches => qr/Desktop/,
+ recurse => 1,
+ dirs_only => 1,
+ }
+ );
+
+ my @files = $f->list_dir(
+ '/home/tommy/projects' => {
+ parent_matches => qr/^\.git$/,
+ recurse => 1,
+ }
+ );
+
+A multiple-argument matching examples with B<OR>
+
+ my @files = $f->list_dir(
+ 'C:\Users\Billy G' => {
+ parent_matches => { or => [ qr/Desktop/, qr/Pictures/ ] }
+ recurse => 1,
+ }
+ );
+
+ # ... same concepts apply to "files_match", "dirs_match",
+ # and "parent_matches" filtering
+
+Multiple-argument matching examples with B<AND>
+
+ my @files = $f->list_dir(
+ '/home/leia' => {
+ parent_matches => { and => [ qr/Anakin/, qr/Amidala/ ] }
+ recurse => 1,
+ }
+ );
+
+ my @files = $f->list_dir(
+ '/home/mace' => {
+ path_matches => { and => [ qr/^(?!.*dark.side)/i, qr/[Ff]orce/ ] }
+ recurse => 1,
+ }
+ );
+
+ # ... same concepts apply to "files_match" and "dirs_match" filtering
+
+B<**When you specify regexes for more than one filter type parameter>, the
+patterns are I<AND'ed> together, as you'd expect, and all matching criteria must
+be satisfied for a successful overall match.
+
+ my @files = $f->list_dir(
+ '/var' => {
+ dirs_match => { or => [ qr/^log$/, qr/^lib$/ ] },
+ files_match => { or => [ qr/^syslog/, qr/\.isam$/i ] },
+ parent_matches => qr/[[:alpha:]]+/
+ path_matches => qr/^(?!.*home)/,
+ recurse => 1,
+ files_only => 1,
+ }
+
+B<Negative matches> (when you want to NOT match something) - use Perl!
+
+As shown in the L<File::Util::Manual::Examples>, Perl already provides
+support for negated matching in the form of "zero-width negative assertions".
+(See L<perlre> for details on how they work). Use syntax like the regular
+expressions below to match anything that is NOT part of the subpattern.
+
+ # match all files with names that do NOT contain "apple" (case sensitive)
+ my @no_apples = $f->list_dir(
+ 'Pictures/fruit' => { files_match => qr/^(?!.*apple)/ }
+ );
+
+ # match all files that that do NOT end in *.mp3 (case INsensitive)
+ # also, don't match files that end in *.wav either
+ my @no_music = $f->list_dir(
+ '/opt/music' => {
+ files_match => { and => [ qr/^(?!.*mp3$)/i, qr/^(?!.*wav$)/i ]
+ }
+ );
+
+=back
+
+=back
+
+=head2 C<load_dir>
+
+=over
+
+=item I<Syntax:> C<< load_dir( [directory name] => { options } ) >>
+
+Returns a data structure containing the contents of each file present in the
+named directory.
+
+The type of data structure returned is determined by the optional data-type
+option parameter. Only one option at a time may be used for a given call
+to this method. Recognized options are listed below.
+
+ my $files_hash_ref = $f->load_dir( $dirname ); # default (hashref)
+
+ -OR-
+
+ my $files_list_ref = $f->load_dir( $dirname => { as_listref => 1 } );
+
+ -OR-
+
+ my @files = $f->load_dir( $dirname => { as_list => 1 } );
+
+=over
+
+=item B<Options accepted by C<load_dir()>>
+
+=over
+
+=item C<< as_hashref => boolean >> *(default)
+
+Implicit. If no option is passed in, the default behavior is to return a
+reference to an anonymous hash whose keys are the names of each file in the
+specified directory; the hash values for contain the contents of the file
+represented by its corresponding key.
+
+=item C<< as_list => boolean >>
+
+Causes the method to return a list comprised of the contents loaded from
+each file (in case-sensitive order) located in the named directory.
+
+This is useful in situations where you don't care what the filenames were
+and you just want a list of file contents.
+
+=item C<< as_listref => boolean >>
+
+Same as above, except an array reference to the list of items is returned
+rather than the list itself. This is more efficient than the above,
+particularly when dealing with large lists.
+
+=back
+
+C<load_dir()> does not recurse or accept matching parameters, etc. It's an
+effective tool for loading up things like a directory of template files on
+a web server, or to store binary data streams in memory. Use it however you
+like.
+
+However, if you do want to load files into a hashref/listref or array while
+using the advanced features of C<list_dir()>, just use list_dir to return the
+files and map the contents into your variable:
+
+ my $hash_ref = {};
+
+ %$hash_ref = map { $_ => $ftl->load_file( $_ ) }
+ $ftl->list_dir( $dir_name => { advanced options... } );
+
+=back
+
+B<Note:> This method does not distinguish between plain files and other file
+types such as binaries, FIFOs, sockets, etc.
+
+Restrictions imposed by the current "read limit"
+I<(see the L<read_limit()|/read_limit>) entry below> will be applied to the
+individual files opened by this method as well. Adjust the read limit as
+necessary.
+
+Example usage:
+
+ my $templates = $f->load_dir( 'templates/stock-ticker' );
+
+The above code creates an anonymous hash reference that is stored in the
+variable named "C<$files>". The keys and values of the hash referenced by
+"C<$files>" would resemble those of the following code snippet (given that
+the files in the named directory were the files 'a.txt', 'b.html', 'c.dat',
+and 'd.conf')
+
+ my $files =
+ {
+ 'a.txt' => 'the contents of file a.txt',
+ 'b.html' => 'the contents of file b.html',
+ 'c.dat' => 'the contents of file c.dat',
+ 'd.conf' => 'the contents of file d.conf',
+ };
+
+=back
+
+=head2 C<load_file>
+
+=over
+
+=item I<Syntax:> C<< load_file( [file name] => { options } ) >>
+
+=item I<OR:> C<< load_file( file_handle => [file handle reference] => { options } ) >>
+
+If [file name] is passed, returns the contents of [file name] in a string.
+If a [file handle reference] is passed instead, the filehandle will be
+C<CORE::read()> and the data obtained by the read will be returned in a string.
+
+If you desire the contents of the file (or file handle data) in a list of
+lines instead of a single string, this can be accomplished through the use
+of the C<as_lines> option (see below).
+
+=over
+
+=item B<Options accepted by C<load_file()>>
+
+=over
+
+=item C<< as_lines => boolean >>
+
+If this option is enabled then your call to C<load_file> will return a list of
+strings, each one of which is a line as it was read from the file [file name].
+The lines are returned in the order they are read, from the beginning of the
+file to the end.
+
+This is not the default behavior. The default behavior is for C<load_file> to
+return a single string containing the entire contents of the file.
+
+=item C<< no_lock => boolean >>
+
+By default this method will attempt to get a lock on the file while it is
+being read, following whatever rules are in place for the flock policy
+established either by default (implicitly) or changed by you in a call to
+File::Util::flock_rules()
+I<(see the L<flock_rules()|/flock_rules>) entry below>.
+
+This method will not try to get a lock on the file if the File::Util object was
+created with the option C<no_lock> or if the method was called with the
+option C<no_lock>.
+
+This method will automatically call binmode() on binary files for you. If you
+pass in a filehandle instead of a file name you do not get this automatic
+check performed for you. In such a case, you'll have to call binmode() on
+the filehandle yourself. Once you pass a filehandle to this method it has no
+way of telling if the file opened to that filehandle is binary or not.
+
+=item C<< binmode => [ boolean or 'utf8' ] >>
+
+Tell File::Util to read the file in binmode (if set to a true boolean: B<C<1>>),
+or to read the file as UTF-8 encoded data, specify a value of B<C<utf8>> to this
+option. I<(see L<perlfunc/binmode>)>.
+
+You need Perl 5.8 or better to use C<'utf8'> or your program will fail with
+an error message.
+
+Example Usage:
+
+ my $encoded_data = $ftl->load_file( 'encoded.txt' => { binmode => 'utf8' } );
+
+=item C<< read_limit => positive integer >>
+
+Override the global read limit setting for the File::Util object you are working
+with, on a one time basis. By specifying a this option with a positive integer
+value (representing the maximum number of bytes to allow for your C<load_file()>
+call), you are telling C<load_file()> to ignore the global/default setting for
+I<just that call>, and to apply your one-time limit of [ positive integer ]
+bytes on the file while it is read into memory.
+
+B<Notes:> This method does not distinguish between plain files and other file
+types such as binaries, FIFOs, sockets, etc.
+
+Restrictions imposed by the current "read limit"
+I<(see the L<read_limit()|/read_limit>) entry below> will be applied to the
+files opened by this method. Adjust the read limit as necessary either
+by overriding (using the C<'read_limit'> option above), or by adjusting the
+global value for your File::Util object with the provided
+L<read_limit() object method|/read_limit>.
+
+=back
+
+=back
+
+=back
+
+=head2 C<make_dir>
+
+=over
+
+=item I<Syntax:> C<< make_dir( [new directory name], [bitmask] => { options } ) >>
+
+Attempts to create (recursively) a directory as [new directory name] with
+the [bitmask] provided. The bitmask is an optional argument and defaults to
+oct 777, B<combined with the current user's umask>. If specified, the bitmask
+must be supplied in the form required by the native perl umask function (as
+an octal number). I<see L<perlfunc/"umask">> for more information about the
+format of the bitmask argument.
+
+As mentioned above, the recursive creation of directories is transparently
+handled for you. This means that if the name of the directory you pass in
+contains a parent directory that does not exist, the parent directory(ies) will
+be created for you automatically and silently in order to create the final
+directory in the [new directory name].
+
+Simply put, if [new directory] is "/path/to/directory" and the directory
+"/path/to" does not exist, the directory "/path/to" will be created and the
+"/path/to/directory" directory will be created thereafter. All directories
+created will be created with the [bitmask] you specify, or with the default
+of oct 777, B<combined with the current user's umask>.
+
+Upon successful creation of the [new directory name], the [new directory name]
+is returned to the caller.
+
+=over
+
+=item B<Options accepted by C<make_dir()>>
+
+=over
+
+=item C<< if_not_exists => boolean >>
+
+Example:
+
+ $f->make_dir( '/home/jspice' => oct 755 => { if_not_exists => 1 } );
+
+If this option is enabled then make_dir will not attempt to create the directory
+if it already exists. Rather it will return the name of the directory as it
+normally would if the directory did not exist previous to calling this method.
+
+If a call to this method is made without the C<if_not_exists> option and the
+directory specified as [new directory name] does in fact exist, an error will
+result as it is impossible to create a directory that already exists.
+
+=back
+
+=back
+
+=back
+
+=head2 C<abort_depth>
+
+=over
+
+=item I<Syntax:> C<abort_depth( [positive integer] )>
+
+When called without any arguments, this method returns an integer reflecting
+the current number of times the File::Util object will dive into the
+subdirectories it discovers when recursively listing directory contents from
+a call to C<File::Util::list_dir()>. The default is 1000. If the number is
+exceeded, the File::Util object will fail with an error.
+
+When called with an argument, it sets the maximum number of times a File::Util
+object will recurse into subdirectories before failing with an error message.
+
+This method can only be called with a numeric integer value. Passing a bad
+argument to this method will cause it to fail with an error.
+
+I<(see also: L<list_dir|/list_dir>)>
+
+=back
+
+=head2 C<needs_binmode>
+
+=over
+
+=item I<Syntax:> C<needs_binmode>
+
+Returns 1 if the machine on which the code is running requires that C<binmode()>
+I<(a built-in function)> be called on open file handles, or returns 0 if not.
+I<(see L<perlfunc/binmode>.)> This is a constant method. It accepts no
+arguments and will always return the same value for the system on which it
+is executed.
+
+=back
+
+=head2 C<new>
+
+=over
+
+=item I<Syntax:> C<< new( { options } ) >>
+
+This is the File::Util constructor method. It returns a new File::Util
+object reference when you call it. It recognizes various options that govern
+the behavior of the new File::Util object.
+
+=over
+
+=item B<Parameters accepted by C<new()>>
+
+=over
+
+=item C<< use_flock => boolean >>
+
+Optionally specify this option to the C<File::Util::new> method to instruct the
+new object that it should never attempt to use C<flock()> in it's I/O
+operations. The default is to use C<flock()> if available on your system.
+Specify this option with a true or false value ( 1 or 0 ), true to use
+C<flock()>, false to not use it.
+
+=item C<< read_limit => positive integer >>
+
+Optionally specify this option to the File::Util::new method to instruct the
+new object that it should never attempt to open and read in a file greater
+than the number of bytes you specify. This argument can only be
+a numeric integer value, otherwise it will be I<silently ignored.> The default
+read limit for File::Util objects is 52428800 bytes (50 megabytes).
+
+=item C<< abort_depth => positive integer >>
+
+Optionally specify this option to the File::Util::new method to instruct the
+new object to set the maximum number of times it will recurse into
+subdirectories while performing directory listing operations before failing
+with an error message. This argument can only be a numeric integer value,
+otherwise it will be I<silently ignored.>
+
+I<(see also: L<abort_depth()|/abort_depth>)>
+
+=item B<C<< onfail => designated handler >>>
+
+Set the I<default> policy for how the new File::Util object handles fatal
+errors. This option takes any one of a list of predefined keywords, or a
+reference to a named or anonymous error handling subroutine of your own.
+
+You can supply an C<onfail> handler to nearly any function in File::Util, but
+when you do so for the C<new()> constructor, you are setting the I<default>.
+
+Acceptable values are all covered in the B<L<ERROR HANDLING|/ERROR HANDLING>>
+section (above), along with proper syntax and example usage.
+
+=back
+
+=back
+
+=back
+
+=head2 C<onfail>
+
+=over
+
+=item I<Syntax:> C<onfail( [keyword or code reference] )>
+
+Dynamically set/change the default error handling policy for an object.
+
+This works exactly the same as it does when you specify an "onfail"
+handler to the constructor method (I<see also C<L<new|/new>>>).
+
+The syntax and keywords available to use for this method are already discussed
+above in the L<ERROR HANDLING|/ERROR HANDLING> section, so refer to that for
+in-depth details.
+
+Here are some examples:
+
+ $ftl->onfail( 'die' );
+
+ $ftl->onfail( 'zero' );
+
+ $ftl->onfail( 'undefined' );
+
+ $ftl->onfail( 'message' );
+
+ $ftl->onfail( \&subroutine_reference );
+
+ $ftl->onfail( sub { my ( $error, $stack_trace ) = @_; ... } );
+
+=back
+
+=head2 C<open_handle>
+
+=over
+
+=item I<Syntax:> C<< open_handle( [file name] => [mode] => { options } ) >>
+
+=item I<OR:> C<< open_handle( file => [file name] => mode => [mode] => { options } ) >>
+
+Attempts to get a lexically scoped open file handle on [file name] in [mode]
+mode. Returns the file handle if successful or generates a fatal error with a
+diagnostic message if the operation fails.
+
+You will need to remember to call C<close()> on the filehandle yourself, at
+your own discretion. Leaving filehandles open is not a good practice, and
+is not recommended. I<see L<perlfunc/close>>).
+
+Once you have the file handle you would use it as you would use any file handle.
+Remember that unless you specifically turn file locking off when the
+C<File::Util> object is created I<(see L<new|/new>)> or by using the
+C<no_lock> option when calling C<open_handle>, that file locking is going to
+automagically be handled for you behind the scenes, so long as your OS supports
+file locking of any kind at all. Great! It's very convenient for you to not
+have to worry about portability in taking care of file locking between one
+application and the next; by using C<File::Util> in all of them, you know
+that you're covered.
+
+A slight inconvenience for the price of a larger set of features (compare
+L<write_file|/write_file> to this method)
+I<B<you will have to release the file lock on the open handle yourself.>>
+C<File::Util> can't manage it for you anymore once it turns the handle over
+to you. At that point, it's all yours. In order to release the file lock
+on your file handle, call L<unlock_open_handle()|/unlock_open_handle> on it.
+Otherwise the lock will remain for the life of your process. If you don't
+want to use the free portable file locking, remember the C<no_lock> option,
+which will turn off file locking for your open handle. Seldom, however, should
+you ever opt to not use file locking unless you really know what you are doing.
+The only obvious exception would be if you are working with files on a
+network-mounted filesystem like NFS or SMB (CIFS), in which case locking can
+be buggy.
+
+If the file does not yet exist it will be created, and it will be created
+with a bitmask of [bitmask] if you specify a file creation bitmask using
+the C<'bitmask'> option, otherwise the file will be created with the default
+bitmask of oct 777. The bitmask is combined with the current user's umask,
+whether you specify a value or not. This is a function of Perl,
+not File::Util.
+
+If specified, the bitmask must be supplied in the form of an octal number as
+required by the native perl umask function. I<See L<perlfunc/"umask">> for
+more information about the format of the bitmask argument. If the file
+[file name] already exists then the bitmask argument has no effect and is
+silently ignored.
+
+Any non-existent directories in the path preceding the actual file name will
+be automatically (and silently - no warnings) created for you and any new
+directories will be created with a bitmask of [dbitmask], provided you specify
+a directory creation bitmask with the C<'dbitmask'> option.
+
+If specified, the directory creation bitmask [dbitmask] must be supplied in
+the form required by the native perl umask function.
+
+If there is an error while trying to create any preceding directories, the
+failure results in a fatal error with an error. If all
+directories preceding the name of the file already exist, the dbitmask
+argument has no effect and is silently ignored.
+
+=back
+
+=over
+
+=item B<Native Perl open modes>
+
+The default behavior of C<open_handle()> is to open file handles using Perl's
+native C<open()> I<(see L<perlfunc/open>)>. Unless you use the
+C<use_sysopen> option, only then are the following modes valid:
+
+=over
+
+=item C<< mode => 'read' >> (this is the default mode)
+
+[file name] is opened in read-only mode. If the file does not yet exist then
+a fatal error will occur.
+
+=item C<< mode => 'write' >>
+
+[file name] is created if it does not yet exist. If [file name] already exists
+then its contents are overwritten with the new content provided.
+
+=item C<< mode => 'append' >>
+
+[file name] is created if it does not yet exist. If [file name] already exists
+its contents will be preserved and the new content you provide will be appended
+to the end of the file.
+
+=back
+
+=back
+
+=over
+
+=item B<System level open modes ("open a la C")>
+
+Optionally you can ask C<File::Util> to open your handle using C<CORE::sysopen>
+instead of using the native Perl C<CORE::open()>. This is accomplished by
+enabling the C<use_sysopen> option. Using this feature opens up more
+possibilities as far as the open modes you can choose from, but also carries
+with it a few caveats so you have to be careful, just as you'd have to be a
+little more careful when using C<sysopen()> anyway.
+
+Specifically you need to remember that when using this feature you must NOT
+mix different types of I/O when working with the file handle. You can't go
+opening file handles with C<sysopen()> and print to them as you normally
+would print to a file handle. You have to use C<syswrite()> instead. The
+same applies here. If you get a C<sysopen()>'d filehandle from C<open_handle()>
+it is imperative that you use C<syswrite()> on it. You'll also need to use
+C<sysseek()> and other type of C<sys>* commands on the filehandle instead of
+their native Perl equivalents.
+
+(see L<perlfunc/sysopen>, L<perlfunc/syswrite>, L<perlfunc/sysseek>,
+L<perlfunc/sysread>)
+
+That said, here are the different modes you can choose from to get a file handle
+when using the C<use_sysopen> option. Remember that these won't work unless
+you use that option, and will generate an error if you try using them without it.
+The standard C<'read'>, C<'write'>, and C<'append'> modes are already available
+to you by default. These are the extended modes:
+
+=over
+
+=item C<< mode => 'rwcreate' >>
+
+[file name] is opened in read-write mode, and will be created for you if it
+does not already exist.
+
+=item C<< mode => 'rwupdate' >>
+
+[file name] is opened for you in read-write mode, but must already exist. If
+it does not exist, a fatal error will result.
+
+=item C<< mode => 'rwclobber' >>
+
+[file name] is opened for you in read-write mode. If the file already exists
+it's contents will be "clobbered" or wiped out. The file will then be empty
+and you will be working with the then-truncated file. This can not be undone.
+Once you call C<open_handle()> using this option, your file WILL be wiped out.
+If the file does not exist yet, it will be created for you.
+
+=item C<< mode => 'rwappend' >>
+
+[file name] will be opened for you in read-write mode ready for appending. The
+file's contents will not be wiped out; they will be preserved and you will be
+working in append fashion. If the file does not exist, it will be created
+for you.
+
+=back
+
+Remember to use C<sysread()> and not plain C<read()> when reading those
+C<sysopen()>'d filehandles!
+
+=back
+
+=over
+
+=item B<Options accepted by C<open_handle()>>
+
+=over
+
+=item C<< binmode => [ boolean or 'utf8' ] >>
+
+Tell File::Util to open the file in binmode (if set to a true boolean: B<C<1>>),
+or to open the file with UTF-8 encoding, specify a value of B<C<utf8>> to this
+option. I<(see L<perlfunc/binmode>)>.
+
+You need Perl 5.8 or better to use C<"utf8"> or your program will fail with
+an error message.
+
+Example Usage:
+
+ $ftl->open_handle( 'encoded.txt' => { binmode => 'utf8' } );
+
+=item C<< no_lock => boolean >>
+
+By default this method will attempt to get a lock on the file while it is
+being read, following whatever rules are in place for the flock policy
+established either by default (implicitly) or changed by you in a call to
+File::Util::flock_rules()
+I<(see L<flock_rules()|/flock_rules>)>.
+
+This method will not try to get a lock on the file if the File::Util object was
+created with the option C<no_lock> or if this method is called with the
+option C<no_lock>.
+
+=item C<< use_sysopen => boolean >>
+
+Instead of opening the file using Perl's native C<open()> command, C<File::Util>
+will open the file with the C<sysopen()> command. You will have to remember
+that your filehandle is a C<sysopen()>'d one, and that you will not be able to
+use native Perl I/O functions on it. You will have to use the C<sys>*
+equivalents. See L<perlopentut> for a more in-depth explanation of why you
+can't mix native Perl I/O with system I/O.
+
+=back
+
+=back
+
+=head2 C<read_limit>
+
+=over
+
+=item I<Syntax:> C<read_limit( [positive integer] )>
+
+By default, the largest size file that File::Util will read into memory and
+return via the L<load_file|/load_file> is 52428800 bytes (50 megabytes).
+
+This value can be modified by calling this method with an integer value
+reflecting the new limit you want to impose, in bytes. For example, if you want
+to set the limit to 10 megabytes, call the method with an argument of 10485760.
+
+If this method is called without an argument, the read limit currently in force
+for the File::Util object will be returned.
+
+=back
+
+=head2 C<return_path>
+
+=over
+
+=item I<Syntax:> C<return_path( [string] )>
+
+Takes the file path from the file name provided and returns it such that
+C</who/you/callin/scruffy.txt> is returned as C</who/you/callin>.
+
+=back
+
+=head2 C<size>
+
+=over
+
+=item I<Syntax:> C<size( [file name] )>
+
+Returns the file size of [file name] in bytes. Returns C<0> if the file is
+empty. Returns C<undef> if the file does not exist.
+
+=back
+
+=head2 C<split_path>
+
+=over
+
+=item I<Syntax:> C<split_path( [string] )>
+
+Takes a path/filename, fully-qualified or relative (it doesn't matter), and it
+returns a list comprising the root of the path (if any), each directory in
+the path, and the final part of the path (be it a file, a directory, or
+otherwise)
+
+This method doesn't divine or detect any information about the path, it simply
+manipulates the string value. It doesn't map it to any real filesystem object.
+It doesn't matter whether or not the file/path named in the input string
+exists or not.
+
+=back
+
+=head2 C<strip_path>
+
+=over
+
+=item I<Syntax:> C<strip_path( [string] )>
+
+Strips the file path from the file name provided and returns the file name only.
+
+Given C</kessel/run/12/parsecs>, it returns C<parsecs>
+
+Given C<C:\you\scoundrel>, it returns C<scoundrel>
+
+=back
+
+=head2 C<touch>
+
+=over
+
+=item I<Syntax:> C<touch( [file name] )>
+
+Behaves like the *nix C<touch> command; Updates the access and modification
+times of the specified file to the current time. If the file does not exist,
+C<File::Util> tries to create it empty. This method will fail with a fatal
+error if system permissions deny alterations to or creation of the file.
+
+Returns C<1> if successful. If unsuccessful, fails with an error.
+
+=back
+
+=head2 C<trunc>
+
+=over
+
+=item I<Syntax:> C<trunc( [file name] )>
+
+Truncates [file name] (i.e.- wipes out, or "clobbers" the contents of the
+specified file.) Returns C<1> if successful. If unsuccessful, fails with a
+descriptive error message about what went wrong.
+
+=back
+
+=head2 C<unlock_open_handle>
+
+=over
+
+=item I<Syntax:> C<unlock_open_handle([file handle])>
+
+Release the flock on a file handle you opened with L<open_handle|/open_handle>.
+
+Returns true on success, false on failure. Will not raise a fatal error if
+the unlock operation fails. You can capture the return value from your call
+to this method and C<die()> if you so desire. Failure is not ever very likely,
+or C<File::Util> wouldn't have been able to get a portable lock on the file
+in the first place.
+
+If C<File::Util> wasn't able to ever lock the file due to limitations of your
+operating system, a call to this method will return a true value.
+
+If file locking has been disabled on the file handle via the C<no_lock> option
+at the time L<open_handle|/open_handle> was called, or if file locking was
+disabled using the L<use_flock|/use_flock> method, or if file locking was
+disabled on the entire C<File::Util> object at the time of its creation
+I<(see L<new()|/new>)>, calling this method will have no effect and a true value
+will be returned.
+
+=back
+
+=head2 C<use_flock>
+
+=over
+
+=item I<Syntax:> C<use_flock( [true / false value] )>
+
+When called without any arguments, this method returns a true or false value
+to reflect the current use of C<flock()> within the File::Util object.
+
+When called with a true or false value as its single argument, this method
+will tell the File::Util object whether or not it should attempt to use
+C<flock()> in its I/O operations. A true value indicates that the File::Util
+object will use C<flock()> if available, a false value indicates that it will
+not. The default is to use C<flock()> when available on your system.
+
+=over
+
+=item I<B<DON'T USE FLOCK ON NETWORK FILESYSTEMS>>
+
+If you are working with files on an NFS mount, or a Windows file share, it
+is quite likely that using flock will be buggy and cause unexpected failures
+in your program. You should not use flock in such situations.
+
+=item I<B<A WORD OF CAUTION FOR SOLARIS USERS>>
+
+File locking has known issues on B<SOLARIS>. Solaris claims to offer
+a native C<flock()> implementation, but after obtaining a lock on a file,
+Solaris will very often just silently refuse to unlock it again until
+your process has completely exited. This is not an issue with File::Util or
+even with Perl itself. Other programming languages encounter the same
+problems; it is a system-level issue. So please be aware of this if you are
+a Solaris user and want to use file locking on your OS.
+
+You may have to explicitly disable file locking completely.
+
+=back
+
+=back
+
+=head2 C<write_file>
+
+=over
+
+=item I<Syntax:> C<< write_file( [file name] => [string] => { other_options } ) >>
+
+=item I<OR:> C<< write_file( { file => [file name], content => [string], mode => [mode], other_options } ) >>
+
+Syntax Examples:
+
+ # get some content (a string returned from a function call, perhaps)
+ my $answer = ask_commissioner( 'Can he be trusted?' );
+
+ $ftl->write_file( 'Harvey_Dent.txt' => $answer );
+
+ -OR-
+
+ # get some binary content, maybe a picture...
+ my $binary_data = get_mugshot( alias => 'twoface' );
+
+ $ftl->write_file( 'suspect.png' => $binary_data => { binmode => 1 } );
+
+ -OR-
+
+ # write a file with UTF-8 encoding (unicode character support)
+ $ftl->write_file( 'encoded.txt' => $encoded_data => { binmode => 'utf8' } );
+
+ -OR-
+
+ $ftl->write_file(
+ {
+ file => '/gotham/city/ballots/Bruce_Wayne.txt',
+ content => 'Vote for Harvey!',
+ bitmask => oct 600, # <- secret ballot file permissions
+ }
+ );
+
+Attempts to write [string] to [file name] in mode [mode]. If the file does
+not yet exist it will be created, and it will be created with a bitmask of
+[bitmask] if you specify a file creation bitmask using the C<'bitmask'> option,
+otherwise the file will be created with the default bitmask of oct 777.
+The bitmask is combined with the current user's umask, whether you specify a
+value or not. This is a function of Perl, not File::Util.
+
+[string] should be a string or a scalar variable containing a string. The
+string can be any type of data, such as a binary stream, or ascii text with
+line breaks, etc. Be sure to enable the C<< binmode => 1 >> option for binary
+streams, and be sure to specify a value of C<< binmode => 'utf8' >> for UTF-8
+encoded data.
+
+NOTE: that you will need Perl version 5.8 or better to use the C<'utf8'>
+feature, or your program will fail with an error.
+
+If specified, the bitmask must be supplied in the form of an octal number,
+as required by the native perl umask function. I<see L<perlfunc/"umask">>
+for more information about the format of the bitmask argument. If the file
+[file name] already exists then the bitmask argument has no effect and is
+silently ignored.
+
+Returns 1 if successful or fails with an error if not successful.
+
+Any non-existent directories in the path preceding the actual file name will
+be automatically (and silently - no warnings) created for you and new
+directories will be created with a bitmask of [dbitmask], provided you specify
+a directory creation bitmask with the C<'dbitmask'> option.
+
+If specified, the directory creation bitmask [dbitmask] must be supplied in
+the form required by the native perl umask function.
+
+If there is a problem while trying to create any preceding directories, the
+failure results in a fatal error. If all directories preceding the name of
+the file already exist, the dbitmask argument has no effect and is silently
+ignored.
+
+=over
+
+=item C<< mode => 'write' >> (this is the default mode)
+
+[file name] is created if it does not yet exist. If [file name] already exists
+then its contents are overwritten with the new content provided.
+
+=item C<< mode => 'append' >>
+
+[file name] is created if it does not yet exist. If [file name] already exists
+its contents will be preserved and the new content you provide will be appended
+to the end of the file.
+
+=back
+
+=over
+
+=item B<Options accepted by C<write_file()>>
+
+=over
+
+=item C<< binmode => [ boolean or 'utf8' ] >>
+
+Tell File::Util to write the file in binmode (if set to a true boolean: B<C<1>>),
+or to write the file with UTF-8 encoding, specify a value of B<C<utf8>> to this
+option. I<(see L<perlfunc/binmode>)>.
+
+You need Perl 5.8 or better to use C<"utf8"> or your program will fail with
+an error message.
+
+Example Usage:
+
+ $ftl->write_file( 'encoded.txt' => $encoded_data => { binmode => 'utf8' } );
+
+=item C<< empty_writes_OK => boolean >>
+
+Allows you to call this method without providing a content argument (it lets
+you create an empty file without warning you or failing. Be advised that
+if you enable this option, it will have the same effect as truncating a file
+that already has content in it (i.e.- it will "clobber" non-empty files)
+
+=item C<< no_lock => boolean >>
+
+By default this method will attempt to get a lock on the file while it is
+being read, following whatever rules are in place for the flock policy
+established either by default (implicitly) or changed by you in a call to
+File::Util::flock_rules()
+I<(see L<flock_rules()|/flock_rules>)>.
+
+This method will not try to get a lock on the file if the File::Util object was
+created with the option C<no_lock> or if this method is called with the
+option C<no_lock> enabled.
+
+=back
+
+=back
+
+=back
+
+=head2 C<valid_filename>
+
+=over
+
+=item I<Syntax:> C<valid_filename( [string] )>
+
+For the given string, returns 1 if the string is a legal file name for the
+system on which the program is running, or returns undef if it is not. This
+method does not test for the validity of file paths! It tests for the validity
+of file names only. (It is used internally to check beforehand if a file name
+is usable when creating new files, but is also a public method available for
+external use.)
+
+=back
+
+=head1 CONSTANTS
+
+=head2 C<NL>
+
+=over
+
+=item I<Syntax:> C<NL>
+
+Short for "B<N>ew B<L>ine". Returns the correct new line character (or character
+sequence) for the system on which your program runs.
+
+=back
+
+=head2 C<SL>
+
+=over
+
+=item I<Syntax:> C<SL>
+
+Short for "B<Sl>ash". Returns the correct directory path separator for the system on
+which your program runs.
+
+=back
+
+=head2 C<OS>
+
+=over
+
+=item I<Syntax:> C<OS>
+
+Returns the File::Util keyword for the operating system B<FAMILY> it detected.
+The keyword for the detected operating system will be one of the following,
+derived from the contents of C<$^O>, or if C<$^O> can not be found, from the
+contents of C<$Config::Config{osname}> (see native L<Config> library), or if
+that doesn't contain a recognizable value, finally falls back to C<UNIX>.
+
+Generally speaking, Linux operating systems are going to be detected as C<UNIX>.
+This isn't a bug. The OS FAMILY to which it belongs uses C<UNIX> style
+filesystem conventions and line endings, which are the relevant things to
+file handling operations.
+
+=over
+
+=item UNIX
+
+Specifics: OS name =~ /^(?:darwin|bsdos)/i
+
+=item CYGWIN
+
+Specifics: OS name =~ /^cygwin/i
+
+=item WINDOWS
+
+Specifics: OS name =~ /^MSWin/i
+
+=item VMS
+
+Specifics: OS name =~ /^vms/i
+
+=item DOS
+
+Specifics: OS name =~ /^dos/i
+
+=item MACINTOSH
+
+Specifics: OS name =~ /^MacOS/i
+
+=item EPOC
+
+Specifics: OS name =~ /^epoc/i
+
+=item OS2
+
+Specifics: OS name =~ /^os2/i
+
+=back
+
+=back
+
+
+
+=head1 AUTHORS
+
+Tommy Butler L<http://www.atrixnet.com/contact>
+
+=head1 COPYRIGHT
+
+Copyright(C) 2001-2013, Tommy Butler. All rights reserved.
+
+=head1 LICENSE
+
+This library is free software, you may redistribute it and/or modify it
+under the same terms as Perl itself. For more details, see the full text of
+the LICENSE file that is included in this distribution.
+
+=head1 LIMITATION OF WARRANTY
+
+This software is distributed in the hope that it will be useful, but without
+any warranty; without even the implied warranty of merchantability or fitness
+for a particular purpose.
+
+=head1 SEE ALSO
+
+L<File::Util::Cookbook>, L<File::Util::Manual::Examples>, L<File::Util>
+
+=cut
+
+__END__
@@ -0,0 +1,3339 @@
+use 5.006;
+use strict;
+use warnings;
+
+use lib 'lib';
+
+package File::Util;
+{
+ $File::Util::VERSION = '4.132140';
+}
+
+use File::Util::Definitions qw( :all );
+use File::Util::Interface::Modern qw( :all );
+
+use Scalar::Util qw( blessed );
+use Exporter;
+
+our $AUTHORITY = 'cpan:TOMMY';
+our @ISA = qw( Exporter );
+
+# some of the symbols below come from File::Util::Definitions
+our @EXPORT_OK = qw(
+ NL can_flock ebcdic existent needs_binmode
+ SL strip_path is_readable is_writable valid_filename
+ OS bitmask return_path file_type escape_filename
+ is_bin created last_access last_changed last_modified
+ isbin split_path atomize_path diagnostic abort_depth
+ size can_read can_write read_limit can_utf8
+);
+
+our %EXPORT_TAGS = ( all => [ @EXPORT_OK ], diag => [ ] );
+
+our $WANT_DIAGNOSTICS = 0;
+
+# --------------------------------------------------------
+# LEGACY methods (which get replaced in AUTOLOAD)
+# --------------------------------------------------------
+use subs qw( can_read can_write isbin readlimit );
+
+# --------------------------------------------------------
+# Constructor
+# --------------------------------------------------------
+sub new {
+ my $this = { };
+
+ bless $this, shift @_;
+
+ my $in = $this->_parse_in( @_ ) || { };
+
+ $this->{opts} = $in || { };
+
+ $this->{opts}->{onfail} ||= 'die';
+
+ # let constructor argument override globals, but set
+ # constructor opts to global values if they have not
+ # overridden them...
+
+ $USE_FLOCK = $in->{use_flock}
+ if exists $in->{use_flock}
+ && defined $in->{use_flock};
+
+ $this->{opts}->{use_flock} = $USE_FLOCK;
+
+ $WANT_DIAGNOSTICS = $in->{diag}
+ if exists $in->{diag}
+ && defined $in->{diag};
+
+ $this->{opts}->{diag} = $WANT_DIAGNOSTICS;
+
+ $in->{read_limit} = defined $in->{read_limit}
+ ? $in->{read_limit}
+ : defined $in->{readlimit}
+ ? $in->{readlimit}
+ : undef;
+
+ delete $in->{readlimit};
+ delete $in->{read_limit} if !defined $in->{read_limit};
+
+ $READ_LIMIT = $in->{read_limit}
+ if exists $in->{read_limit}
+ && defined $in->{read_limit}
+ && $in->{read_limit} !~ /\D/;
+
+ $this->{opts}->{read_limit} = $READ_LIMIT;
+
+ $ABORT_DEPTH = $in->{abort_depth}
+ if exists $in->{abort_depth}
+ && defined $in->{abort_depth}
+ && $in->{abort_depth} !~ /\D/;
+
+ $this->{opts}->{abort_depth} = $ABORT_DEPTH;
+
+ return $this;
+}
+
+
+# --------------------------------------------------------
+# File::Util::import()
+# --------------------------------------------------------
+sub import {
+
+ my ( $class, @wanted_symbols ) = @_;
+
+ ++$WANT_DIAGNOSTICS if grep { /(?<!!):diag/ } @wanted_symbols;
+
+ $class->export_to_level( 1, @_ );
+}
+
+
+# --------------------------------------------------------
+# File::Util::list_dir()
+# --------------------------------------------------------
+sub list_dir {
+ my $this = shift @_;
+ my $dir = shift @_;
+ my $opts = ref $_[0] eq 'REF' ? ${ shift @_ } : $this->_remove_opts( \@_ );
+
+ my ( @dir_contents, $subdirs, $files );
+
+ my $abort_depth = $opts->{abort_depth};
+
+ # We can bypass all this extra checking/validation when we are recursing
+ # because we know we called ourself correctly--
+
+# INPUT VALIDATION AND DEFAULT VALUES
+
+ if ( !$opts->{_recursing} ) { # bypass all this if recursing
+
+ return $this->_throw(
+ 'no input' => {
+ meth => 'list_dir',
+ missing => 'a directory name',
+ opts => $opts,
+ }
+ ) unless defined $dir && length $dir;
+
+ $abort_depth =
+ defined $opts->{abort_depth}
+ ? $opts->{abort_depth}
+ : defined $this->{opts}->{abort_depth}
+ ? $this->{opts}->{abort_depth}
+ : $ABORT_DEPTH;
+
+ # in case somebody wants to list_dir( "/tmp////" ) which is legal!
+ $dir =~ s/(?<=.)[\/\\:]+$// unless $dir =~ /^$WINROOT$/o;
+
+ # recurse_fast implies recurse, and so does the legacy opt "follow"
+ $opts->{recurse} = 1 if $opts->{recurse_fast} || $opts->{follow};
+
+ # "." and ".." make no sense (and cause infinite loops) when recursing...
+ $opts->{no_fsdots} = 1 if $opts->{recurse}; # ...so skip them
+
+ # be compatible with GNU find
+ $opts->{max_depth} = delete $opts->{maxdepth} if $opts->{maxdepth};
+
+ # break off immediately to helper function if asked to make a ref-tree
+ return $this->_as_tree( $dir => $opts ) if $opts->{as_tree};
+
+ return $this->_throw( 'no such file' => { opts => $opts, filename => $dir } )
+ unless -e $dir;
+
+ return $this->_throw (
+ 'called opendir on a file' => {
+ filename => $dir,
+ opts => $opts,
+ }
+ ) unless -d $dir;
+ }
+
+# RUNAWAY RECURSION PREVENTION...
+
+ # We have to keep an eye on recursion; we do it with a shared-reference.
+ # scalar references didn't work for me, so I'm using a hashref with a
+ # single key-value and it works beautifully
+ $opts->{_recursion} = {
+ _fast => $opts->{recurse_fast},
+ _base => $dir,
+ _isroot => ( $dir eq '/' || $dir =~ /^$WINROOT/ ) ? 1 : 0,
+ _depth => 0,
+ _inodes => {},
+ } unless defined $opts->{_recursion};
+
+# ...AND FILESYSTEM LOOPING PREVENTION ARE TIED TOGETHER...
+
+ if ( !$opts->{_recursion}->{_fast} )
+ {
+ my ( $dev, $inode ) = lstat $dir;
+
+ if ( $inode ) { # noop on windows which always returns zero (0) for inode
+
+ # keep track of dir inodes or we're going to get stuck in filesystem
+ # loops the following bit of code incrementally populates (with each
+ # recursion) a hash table with keys named for the dev ID and inode of
+ # the directory, for every directory found
+
+ warn sprintf
+ qq(*WARNING! Filesystem loop detected at %s, dev %s, inode %s\n),
+ $dir, $dev, $inode
+ and return( () )
+ if exists $opts->{_recursion}{_inodes}{ $dev, $inode };
+
+ $opts->{_recursion}{_inodes}{ $dev, $inode } = undef;
+ }
+ }
+
+# DETERMINE DEPTH AND BAIL IF TOO DEEP
+
+ # this is highly dependent on OS platform, and also whether or not we are
+ # listing a root directory, which makes optimizations harder ( / or C:\ )
+ # *note - $SL comes from File::Util::Definitions
+
+ my $trailing_dirs;
+
+ if ( $opts->{_recursion}{_isroot} )
+ {
+ ( $trailing_dirs ) =
+ $dir =~ /^ \Q$opts->{_recursion}{_base}\E (.+) /x;
+ }
+ else
+ {
+ ( $trailing_dirs ) =
+ $dir =~ /^ \Q$opts->{_recursion}{_base}$SL\E (.+) /x;
+ }
+
+ if ( $SL eq '/' )
+ {
+ $opts->{_recursion}{_depth} = $trailing_dirs =~ tr/\/// + 1
+ if defined $trailing_dirs;
+ }
+ else
+ {
+ $opts->{_recursion}{_depth} = $trailing_dirs =~ tr/[\\:]// + 1
+ if defined $trailing_dirs;
+ }
+
+ return( () ) if
+ $opts->{max_depth} &&
+ $opts->{_recursion}{_depth} >= $opts->{max_depth};
+
+ # fail if the shared reference indicates we're to deep
+ return $this->_throw(
+ 'abort_depth exceeded' => {
+ meth => 'list_dir',
+ abort_depth => $abort_depth,
+ opts => $opts,
+ dir => $dir,
+ }
+ ) if $opts->{_recursion}{_depth} == $abort_depth && $abort_depth != 0;
+
+# ACTUAL READING OF THE DIRECTORY
+
+ opendir my $dir_fh, $dir
+ or return $this->_throw
+ (
+ 'bad opendir' => {
+ dirname => $dir,
+ exception => $!,
+ opts => $opts,
+ }
+ );
+
+# LEGACY_MATCHING
+
+ # this form of matching is deprecated and is not robust. backward compat
+ # is preserved here, but it will soon no longer even be mentioned in the
+ # documentation, becoming useful only to the legacy code that relies on it
+
+ # primitive pattern matching at top level only, applied to both files & dirs
+ @dir_contents = defined $opts->{pattern}
+ ? grep /$opts->{pattern}/, readdir $dir_fh
+ : readdir $dir_fh;
+
+ # primitive pattern matching applied recursively to only files; if it were
+ # applied to both files AND dirs, recursion would often break unexpectedly
+ # for users unaware that they couldn't recurse into dirs that didn't match
+ # the pattern they probably intended only for files
+ @dir_contents = defined $opts->{rpattern}
+ ? grep { -d $dir . SL . $_ || /$opts->{rpattern}/ } @dir_contents
+ : @dir_contents;
+
+ closedir $dir_fh
+ or return $this->_throw(
+ 'close dir' => {
+ dir => $dir,
+ exception => $!,
+ opts => $opts,
+ }
+ );
+
+ # get rid of "." and ".." if they are unwanted, and try to do it as fast
+ # as possible for large directories; Devel::NYTprof says this is faster
+ if ( $opts->{no_fsdots} )
+ {
+ if ( $dir_contents[0] eq '.' && $dir_contents[1] eq '..' )
+ {
+ @dir_contents = splice @dir_contents, 2;
+ }
+ else
+ {
+ @dir_contents = grep { !/$FSDOTS/ } @dir_contents;
+ }
+ }
+
+# SEPARATION OF DIRS FROM FILES
+
+ my $dir_base = # << we use this further down
+ ( $dir ne '/' && $dir !~ /^$WINROOT$/ )
+ ? $dir . SL
+ : $dir;
+
+ while ( @dir_contents ) # !! don't do: while my $foo = shift !!
+ {
+ my $dir_entry = shift @dir_contents;
+
+ if ( -d $dir_base . $dir_entry && !-l $dir_base . $dir_entry )
+ {
+ push @$subdirs, $dir_entry
+ }
+ else { push @$files, $dir_entry }
+ }
+
+# ADVANCED MATCHING
+ if ( !defined $opts->{_matching} )
+ {
+ $opts->{_matching} =
+ $opts->{files_match} ||
+ $opts->{dirs_match} ||
+ $opts->{parent_matches} ||
+ $opts->{path_matches} || 0;
+
+ $opts->{_matching} = !!$opts->{_matching};
+ }
+
+ if ( $opts->{_matching} )
+ {
+ ( $subdirs, $files ) =
+ _list_dir_matching( $opts, $dir, $subdirs, $files );
+ }
+
+ $subdirs = ref $subdirs && @$subdirs ? $subdirs : [];
+ $files = ref $files && @$files ? $files : [];
+
+ # prepend full path information to each file name if paths were
+ # requested, or if we are recursing. Then separate the directories
+ # and files off into @dirs and @itmes, respectively
+ if ( $opts->{recurse} || $opts->{with_paths} )
+ {
+ @$subdirs = map { $dir_base . $_ } @$subdirs;
+ @$files = map { $dir_base . $_ } @$files;
+ }
+
+# CALLBACKS (HIGHER ORDER FUNCTIONS)
+
+ # here below is where we invoke the callbacks on dirs, files, or both.
+
+ if ( my $cb = $opts->{callback} ) {
+
+ $this->throw( qq(callback "$cb" not a coderef), $opts )
+ unless ref $cb eq 'CODE';
+
+ $cb->( $dir, \@$subdirs, \@$files, $opts->{_recursion}{_depth} );
+ }
+
+ if ( my $cb = $opts->{d_callback} ) {
+
+ $this->throw( qq(d_callback "$cb" not a coderef), $opts )
+ unless ref $cb eq 'CODE';
+
+ $cb->( $dir, \@$subdirs, $opts->{_recursion}{_depth} );
+ }
+
+ if ( my $cb = $opts->{f_callback} ) {
+
+ $this->throw( qq(f_callback "$cb" not a coderef), $opts )
+ unless ref $cb eq 'CODE';
+
+ $cb->( $dir, \@$files, $opts->{_recursion}{_depth} );
+ }
+
+# RECURSION
+ if
+ (
+ $opts->{recurse} && !
+ (
+ $opts->{max_depth} && # don't recurse if we will then be at max depth
+ $opts->{_recursion}{_depth} == $opts->{max_depth} - 1
+ )
+ ) {
+ # recurse into all subdirs
+ for my $subdir ( @$subdirs ) {
+
+ # certain opts need to be defined, overridden, added, or removed
+ # completely before recursing. That's why we redefine everything
+ # here below, eliminating potential user-error where incompatible
+ # options would otherwise break recursion and/or cause confusion
+
+ my $recurse_opts = {
+ as_ref => 1,
+ with_paths => 1,
+ no_fsdots => 1,
+ abort_depth => $abort_depth,
+ max_depth => $opts->{max_depth},
+ onfail => $opts->{onfail},
+ diag => $opts->{diag},
+ rpattern => $opts->{rpattern},
+ files_match => $opts->{files_match},
+ dirs_match => $opts->{dirs_match},
+ parent_matches => $opts->{parent_matches},
+ path_matches => $opts->{path_matches},
+ callback => $opts->{callback},
+ d_callback => $opts->{d_callback},
+ f_callback => $opts->{f_callback},
+ _matching => $opts->{_matching},
+ _patterns => $opts->{_patterns} || {},
+ _recursion => $opts->{_recursion},
+ _recursing => 1,
+ };
+
+ my ( $dirs_ref, $files_ref ) =
+ $this->list_dir( $subdir => \$recurse_opts );
+
+ push @$subdirs, @$dirs_ref
+ if ref $dirs_ref && ref $dirs_ref eq 'ARRAY';
+
+ push @$files, @$files_ref
+ if ref $files_ref && ref $files_ref eq 'ARRAY';
+ }
+ }
+
+# FINAL PREPARATIONS before returning results
+
+ if (
+ !$opts->{_recursing} &&
+ (
+ $opts->{path_matches} || $opts->{parent_matches}
+ )
+ ) {
+ @$subdirs = _list_dir_lastround_dirmatch( $opts, $subdirs );
+ }
+
+ # cosmetic formatting for directories/
+ if ( $opts->{sl_after_dirs} ) {
+
+ # append directory separator to everything but the "dots"
+ $_ .= SL for grep { !/$FSDOTS/ } @$subdirs;
+ }
+
+ # sorting
+ if ( $opts->{ignore_case} ) {
+
+ $subdirs = [ sort { uc $a cmp uc $b } @$subdirs ];
+ $files = [ sort { uc $a cmp uc $b } @$files ];
+ }
+ else {
+
+ $subdirs = [ sort { $a cmp $b } @$subdirs ];
+ $files = [ sort { $a cmp $b } @$files ];
+ }
+
+# RETURN based on selected opts
+
+ return scalar @$subdirs
+ if $opts->{dirs_only} && $opts->{count_only};
+
+ return scalar @$files
+ if $opts->{files_only} && $opts->{count_only};
+
+ return scalar @$subdirs + scalar @$files
+ if $opts->{count_only};
+
+ return $subdirs, $files
+ if $opts->{as_ref};
+
+ $subdirs = [ $subdirs ] if $opts->{dirs_as_ref};
+ $files = [ $files ] if $opts->{files_as_ref};
+
+ return @$subdirs if $opts->{dirs_only};
+ return @$files if $opts->{files_only};
+
+ return @$subdirs, @$files;
+}
+
+
+# --------------------------------------------------------
+# File::Util::_list_dir_matching()
+# --------------------------------------------------------
+sub _list_dir_matching {
+ my ( $opts, $path, $dirs, $files ) = @_;
+
+# COLLECT PATTERN(S) TO BE APPLIED
+
+ { # memo-ize these patterns
+
+ # FILES AND
+ $opts->{_patterns}->{_files_match_and} =
+ [ _gather_and_patterns( $opts->{files_match} ) ]
+ unless defined $opts->{_patterns}->{_files_match_and};
+
+ # FILES OR
+ $opts->{_patterns}->{_files_match_or} =
+ [ _gather_or_patterns( $opts->{files_match} ) ]
+ unless defined $opts->{_patterns}->{_files_match_or};
+
+ # DIRS AND
+ $opts->{_patterns}->{_dirs_match_and} =
+ [ _gather_and_patterns( $opts->{dirs_match} ) ]
+ unless defined $opts->{_patterns}->{_dirs_match_and};
+
+ # DIRS OR
+ $opts->{_patterns}->{_dirs_match_or} =
+ [ _gather_or_patterns( $opts->{dirs_match} ) ]
+ unless defined $opts->{_patterns}->{_dirs_match_or};
+
+ # PARENT AND
+ $opts->{_patterns}->{_parent_matches_and} =
+ [ _gather_and_patterns( $opts->{parent_matches} ) ]
+ unless defined $opts->{_patterns}->{_parent_matches_and};
+
+ # PARENT OR
+ $opts->{_patterns}->{_parent_matches_or} =
+ [ _gather_or_patterns( $opts->{parent_matches} ) ]
+ unless defined $opts->{_patterns}->{_parent_matches_or};
+
+ # PATH AND
+ $opts->{_patterns}->{_path_matches_and} =
+ [ _gather_and_patterns( $opts->{path_matches} ) ]
+ unless defined $opts->{_patterns}->{_path_matches_and};
+
+ # PATH OR
+ $opts->{_patterns}->{_path_matches_or} =
+ [ _gather_or_patterns( $opts->{path_matches} ) ]
+ unless defined $opts->{_patterns}->{_path_matches_or};
+ }
+
+# FILE MATCHING
+
+ for my $pattern ( @{ $opts->{_patterns}->{_files_match_and} } ) {
+
+ @$files = grep { /$pattern/ } @$files;
+ }
+
+ @$files = _match_and( $opts->{_patterns}->{_files_match_and}, $files )
+ if @{ $opts->{_patterns}->{_files_match_and} };
+
+ @$files = _match_or( $opts->{_patterns}->{_files_match_or}, $files )
+ if @{ $opts->{_patterns}->{_files_match_or} };
+
+# DIRECTORY MATCHING
+
+ @$dirs = _match_and( $opts->{_patterns}->{_dirs_match_and}, $dirs )
+ if @{ $opts->{_patterns}->{_dirs_match_and} };
+
+ @$dirs = _match_or( $opts->{_patterns}->{_dirs_match_or}, $dirs )
+ if @{ $opts->{_patterns}->{_dirs_match_or} };
+
+# FILE &'ed DIRECTORY MATCHING
+
+ if ( $opts->{files_match} && $opts->{dirs_match} ) {
+
+ $files = [ ]
+ unless _match_and
+ (
+ $opts->{_patterns}->{_dirs_match_and},
+ [ strip_path( $path ) ]
+ );
+ }
+
+# MATCHING FILES BY PARENT DIR
+
+ if ( $opts->{parent_matches} ) {
+
+ if ( @{ $opts->{_patterns}->{_parent_matches_and} } ) {
+
+ $files = [ ]
+ unless _match_and
+ (
+ $opts->{_patterns}->{_parent_matches_and},
+ [ strip_path( $path ) ]
+ );
+ }
+ elsif ( @{ $opts->{_patterns}->{_parent_matches_or} } ) {
+
+ $files = [ ]
+ unless _match_or
+ (
+ $opts->{_patterns}->{_parent_matches_or},
+ [ strip_path( $path ) ]
+ );
+ }
+ }
+
+# MATCHING FILES BY PATH
+
+ if ( $opts->{path_matches} ) {
+
+ if ( @{ $opts->{_patterns}->{_path_matches_and} } ) {
+
+ $files = [ ]
+ unless _match_and
+ (
+ $opts->{_patterns}->{_path_matches_and}, [ $path ]
+ );
+ }
+ elsif ( @{ $opts->{_patterns}->{_path_matches_or} } ) {
+
+ $files = [ ]
+ unless _match_or
+ (
+ $opts->{_patterns}->{_path_matches_or}, [ $path ]
+ );
+ }
+ }
+
+ return ( $dirs, $files );
+}
+
+
+# --------------------------------------------------------
+# File::Util::_list_dir_lastround_dirmatch()
+# --------------------------------------------------------
+sub _list_dir_lastround_dirmatch {
+ my ( $opts, $dirs ) = @_;
+
+ my @return_dirs;
+
+# LAST ROUND MATCHING DIRS BY PARENT DIR
+
+ if ( $opts->{parent_matches} ) {
+
+ my %return_dirs;
+
+ if ( @{ $opts->{_patterns}->{_parent_matches_and} } ) {
+
+ for my $qfd_dir ( @$dirs ) {
+
+ my ( $root, $in_path ) = atomize_path( $qfd_dir );
+
+ $in_path = $root . $in_path if $root;
+
+ $return_dirs{ $in_path } = $in_path
+ if _match_and
+ (
+ $opts->{_patterns}->{_parent_matches_and},
+ [ strip_path( $in_path ) ]
+ );
+ }
+ }
+ elsif ( @{ $opts->{_patterns}->{_parent_matches_or} } ) {
+
+ for my $qfd_dir ( @$dirs ) {
+
+ my ( $root, $in_path ) = atomize_path( $qfd_dir );
+
+ $in_path = $root . $in_path if $root;
+
+ $return_dirs{ $in_path } = $in_path
+ if _match_or
+ (
+ $opts->{_patterns}->{_parent_matches_or},
+ [ strip_path( $in_path ) ]
+ );
+ }
+ }
+
+ push @return_dirs, keys %return_dirs;
+ }
+
+# LAST ROUND MATCHING DIRS BY PATH
+
+ if ( $opts->{path_matches} ) {
+
+ my %return_dirs;
+
+ if ( @{ $opts->{_patterns}->{_path_matches_and} } ) {
+
+ for my $qfd_dir ( @$dirs ) {
+
+ my ( $root, $in_path ) = atomize_path( $qfd_dir );
+
+ $in_path = $root . $in_path if $root;
+
+ $return_dirs{ $in_path } = $in_path
+ if _match_and
+ (
+ $opts->{_patterns}->{_path_matches_and}, [ $in_path ]
+ );
+
+ $return_dirs{ $qfd_dir } = $qfd_dir
+ if _match_and
+ (
+ $opts->{_patterns}->{_path_matches_and}, [ $qfd_dir ]
+ );
+ }
+ }
+ elsif ( @{ $opts->{_patterns}->{_path_matches_or} } ) {
+
+ for my $qfd_dir ( @$dirs ) {
+
+ my ( $root, $in_path ) = atomize_path( $qfd_dir );
+
+ $in_path = $root . $in_path if $root;
+
+ $return_dirs{ $in_path } = $in_path
+ if _match_or
+ (
+ $opts->{_patterns}->{_path_matches_or}, [ $in_path ]
+ );
+
+ $return_dirs{ $qfd_dir } = $qfd_dir
+ if _match_or
+ (
+ $opts->{_patterns}->{_path_matches_or}, [ $qfd_dir ]
+ );
+ }
+ }
+
+ push @return_dirs, keys %return_dirs;
+ }
+
+ return @return_dirs;
+}
+
+
+# --------------------------------------------------------
+# File::Util::_gather_and_patterns()
+# --------------------------------------------------------
+sub _gather_and_patterns {
+
+ my $pattern_ref = shift @_;
+
+ return
+ defined $pattern_ref &&
+ ref $pattern_ref eq 'HASH' &&
+ defined $pattern_ref->{and} &&
+ ref $pattern_ref->{and} eq 'ARRAY'
+ ? @{ $pattern_ref->{and} }
+ : defined $pattern_ref &&
+ ref $pattern_ref eq 'Regexp'
+ ? ( $pattern_ref )
+ : ( );
+}
+
+
+# --------------------------------------------------------
+# File::Util::_gather_or_patterns()
+# --------------------------------------------------------
+sub _gather_or_patterns {
+
+ my $pattern_ref = shift @_;
+
+ return
+ defined $pattern_ref &&
+ ref $pattern_ref eq 'HASH' &&
+ defined $pattern_ref->{or} &&
+ ref $pattern_ref->{or} eq 'ARRAY'
+ ? @{ $pattern_ref->{or} }
+ : ( );
+}
+
+
+# --------------------------------------------------------
+# File::Util::_match_and()
+# --------------------------------------------------------
+sub _match_and {
+
+ my ( $patterns, $items ) = @_;
+
+ for my $pattern ( @$patterns ) {
+
+ @$items = grep { /$pattern/ } @$items;
+ }
+
+ return @$items;
+}
+
+
+# --------------------------------------------------------
+# File::Util::_match_or()
+# --------------------------------------------------------
+sub _match_or {
+
+ my ( $patterns, $items ) = @_;
+
+ my $or_pattern;
+
+ for my $pattern ( @$patterns ) {
+
+ $or_pattern = $or_pattern
+ ? qr/$pattern|$or_pattern/
+ : $pattern;
+ }
+
+ @$items = grep { /$or_pattern/ } @$items;
+
+ return @$items;
+}
+
+
+# --------------------------------------------------------
+# File::Util::_as_tree()
+# --------------------------------------------------------
+sub _as_tree {
+ my $this = shift @_;
+ my $opts = $this->_remove_opts( \@_ );
+ my $dir = shift @_;
+ my $tree = {};
+
+ my $treeify = sub
+ {
+ my ( $dirname, $subdirs, $files ) = @_;
+
+ # find root of tree (if path was absolute)
+ my ( $root, $branch, $leaf ) = atomize_path( $dirname );
+
+ my @path_dirs = split /$DIRSPLIT/o, $branch;
+
+ # find place in tree
+ my @lineage = ( @path_dirs, $leaf );
+
+ unshift @lineage, $root if $root;
+
+ my $ancestory = $tree;
+
+ # recursively create hashref tree
+
+ for ( my $i = 0; $i < @lineage; $i++ )
+ {
+ my $self = $lineage[ $i ];
+
+ my $parent = $i > 0 ? $i - 1 : undef;
+
+ if ( defined $parent )
+ {
+ my @predecessors = @lineage[ 0 .. $parent ];
+
+ # for abs paths on *nix
+ shift @predecessors if
+ @predecessors > 1 &&
+ $predecessors[0] eq SL;
+
+ $parent = join SL, @predecessors;
+
+ $parent = $root . $parent if $root && $parent ne $root;
+ }
+
+ $ancestory->{ $self } ||= { };
+
+ unless (
+ exists $opts->{dirmeta} &&
+ defined $opts->{dirmeta} &&
+ $opts->{dirmeta} == 0
+ ) {
+ $ancestory->{ $self }{ _DIR_PARENT_ } = $parent;
+
+ $ancestory->{ $self }{ _DIR_SELF_ } =
+ !defined $parent
+ ? $self
+ : $parent eq $root
+ ? $parent . $self
+ : $parent . SL . $self;
+ }
+
+ $ancestory = $ancestory->{ $self };
+ }
+
+ # the next two loops populate the tree
+
+ my $parent = $ancestory;
+
+ for my $subdir ( @$subdirs )
+ {
+ $parent->{ strip_path( $subdir ) } ||= { };
+ }
+
+ for my $file ( @$files )
+ {
+ $parent->{ strip_path( $file ) } = $file;
+ }
+ };
+
+ $opts->{callback} = $treeify;
+
+ delete $opts->{as_tree};
+
+ $this->list_dir( $dir => $opts );
+
+ return $tree;
+}
+
+
+# --------------------------------------------------------
+# File::Util::_dropdots()
+# --------------------------------------------------------
+sub _dropdots {
+ my $this = shift @_;
+ my $opts = $this->_remove_opts( \@_ );
+ my @copy = @_;
+ my @out = ();
+ my @dots = ();
+ my $gottadot = 0;
+
+ while ( @copy ) {
+
+ if ( $gottadot == 2 ) { push @out, @copy and last }
+
+ my $dir_item = shift @copy;
+
+ if ( $dir_item =~ /$FSDOTS/ ) {
+
+ ++$gottadot;
+
+ push @dots, $dir_item;
+
+ next;
+ }
+
+ push @out, $dir_item;
+ }
+
+ return( \@dots, @out ) if $opts->{save_dots};
+
+ return @out;
+}
+
+
+# --------------------------------------------------------
+# File::Util::load_file()
+# --------------------------------------------------------
+sub load_file {
+ my $this = shift @_;
+ my $in = $this->_parse_in( @_ );
+ my @dirs = ();
+ my $blocksize = 1024; # 1.24 kb
+ my $fh_passed = 0;
+ my $fh;
+
+ my ( $file, $root, $path, $clean_name, $content, $mode ) =
+ ( '', '', '', '', '', 'read' );
+
+ # all of this logic branching is to cover the possibilities in the way
+ # this method could have been called. we try to support as many methods
+ # as make at least some amount of sense
+
+ $in->{read_limit} = defined $in->{read_limit}
+ ? $in->{read_limit}
+ : defined $in->{readlimit}
+ ? $in->{readlimit}
+ : undef;
+
+ delete $in->{readlimit};
+ delete $in->{read_limit} if !defined $in->{read_limit};
+
+ my $read_limit =
+ defined $in->{read_limit}
+ ? $in->{read_limit}
+ : defined $this->{opts}->{read_limit}
+ ? $this->{opts}->{read_limit}
+ : defined $READ_LIMIT
+ ? $READ_LIMIT
+ : 0;
+
+ return $this->_throw(
+ 'bad read_limit' => { opts => $in, bad => $read_limit }
+ ) if $read_limit =~ /\D/;
+
+ # support old-school "FH" option, *and* the new, more sensible "file_handle"
+ $in->{FH} = $in->{file_handle} if defined $in->{file_handle};
+
+ if ( !defined $in->{FH} ) { # unless we were passed a file handle...
+
+ $file = defined $in->{file}
+ ? $in->{file}
+ : defined $in->{filename}
+ ? $in->{filename}
+ : shift @_ || '';
+
+ return $this->_throw(
+ 'no input',
+ {
+ meth => 'load_file',
+ missing => 'a file name or file handle reference',
+ opts => $in,
+ }
+ ) unless length $file;
+
+ ( $root, $path, $file ) = atomize_path( $file );
+
+ @dirs = split /$DIRSPLIT/, $path;
+
+ unshift @dirs, $root if $root;
+
+ # cleanup file name - if path is relative, normalize it
+ # - /foo/bar/baz.txt stays as /foo/bar/baz.txt
+ # - foo/bar/baz.txt becomes ./foo/bar/baz.txt
+ # - baz.txt stays as baz.txt
+ if ( !length $root && !length $path ) {
+
+ $path = '.' . SL;
+ }
+ else { # otherwise path normalized at end
+
+ $path .= SL;
+ }
+
+ # final clean filename assembled
+ $clean_name = $root . $path . $file;
+ }
+ else {
+
+ # did we get a filehandle?
+ if ( ref $in->{FH} eq 'GLOB' ) {
+
+ $fh_passed++;
+ }
+ else {
+
+ return $this->_throw(
+ 'no input',
+ {
+ meth => 'load_file',
+ missing => 'a true file handle reference (not a string)',
+ opts => $in,
+ }
+ );
+ }
+ }
+
+ if ( $fh_passed ) {
+
+ my $buffer = 0;
+ my $bytes_read = 0;
+ $fh = $in->{FH};
+
+ while ( <$fh> ) {
+
+ if ( $buffer < $read_limit ) {
+
+ $bytes_read = read( $fh, $content, $blocksize );
+
+ $buffer += $bytes_read;
+ }
+ else {
+
+ return $this->_throw(
+ 'read_limit exceeded',
+ {
+ filename => '<filehandle>',
+ size => qq{[truncated at $bytes_read]},
+ read_limit => $read_limit,
+ opts => $in,
+ }
+ );
+ }
+ }
+
+ # return an array of all lines in the file if the call to this method/
+ # subroutine asked for an array eg- my @file = load_file('file');
+ # otherwise, return a scalar value containing all of the file's content
+ return split /$NL|\r|\n/o, $content
+ if $in->{as_list};
+
+ return $content;
+ }
+
+ # if the file doesn't exist, send back an error
+ return $this->_throw(
+ 'no such file',
+ {
+ filename => $clean_name,
+ opts => $in,
+ }
+ ) unless -e $clean_name;
+
+ # it's good to know beforehand whether or not we have permission to open
+ # and read from this file allowing us to handle such an exception before
+ # it handles us.
+
+ # first check the readability of the file's housing dir
+ return $this->_throw(
+ 'cant dread',
+ {
+ filename => $clean_name,
+ dirname => $root . $path,
+ opts => $in,
+ }
+ ) unless -r $root . $path;
+
+ # now check the readability of the file itself
+ return $this->_throw(
+ 'cant fread',
+ {
+ filename => $clean_name,
+ dirname => $root . $path,
+ opts => $in,
+ }
+ ) unless -r $clean_name;
+
+ # if the file is a directory it will not be opened
+ return $this->_throw(
+ 'called open on a dir',
+ {
+ filename => $clean_name,
+ opts => $in,
+ }
+ ) if -d $clean_name;
+
+ my $fsize = -s $clean_name;
+
+ return $this->_throw(
+ 'read_limit exceeded',
+ {
+ filename => $clean_name,
+ size => $fsize,
+ opts => $in,
+ read_limit => $read_limit,
+ }
+ ) if $fsize > $read_limit;
+
+ # localize the global output record separator so we can slurp it all
+ # in one quick read. We fail if the filesize exceeds our limit.
+ local $/;
+
+ # open the file for reading (note the '<' syntax there) or fail with a
+ # error message if our attempt to open the file was unsuccessful
+
+ # lock file before I/O on platforms that support it
+ if (
+ $in->{no_lock} ||
+ $this->{opts}->{no_lock} ||
+ !$this->use_flock()
+ ) {
+
+ # if you use the 'no_lock' option you are probably inefficient
+ open $fh, '<', $clean_name or
+ return $this->_throw(
+ 'bad open',
+ {
+ filename => $clean_name,
+ mode => $mode,
+ exception => $!,
+ cmd => qq(< $clean_name),
+ opts => $in,
+ }
+ );
+ }
+ else {
+ open $fh, '<', $clean_name or
+ return $this->_throw(
+ 'bad open',
+ {
+ filename => $clean_name,
+ mode => $mode,
+ exception => $!,
+ cmd => qq(< $clean_name),
+ opts => $in,
+ }
+ );
+
+ $this->_seize( $clean_name, $fh, $in );
+ }
+
+ # call binmode on binary files for portability accross platforms such
+ # as MS flavor OS family
+
+ binmode $fh if -B $clean_name;
+
+ # call binmode on the filehandle if it was requested or UTF-8
+ if ( $in->{binmode} )
+ {
+ if ( lc $in->{binmode} eq 'utf8' )
+ {
+ if ( $HAVE_UU )
+ {
+ binmode $fh, ':unix:encoding(UTF-8)';
+ }
+ else
+ {
+ close $fh;
+
+ return $this->_throw( 'no unicode' => $in );
+ }
+ }
+ else
+ {
+ binmode $fh;
+ }
+ }
+
+ # assign the content of the file to this lexically scoped scalar variable
+ # (memory for *that* variable will be freed when execution leaves this
+ # method / sub
+
+ $content = <$fh>;
+
+ if ( $in->{no_lock} || $this->{opts}->{no_lock} ) {
+
+ # if execution gets here, you used the 'no_lock' option, and you
+ # are probably inefficient
+
+ close $fh or return $this->_throw(
+ 'bad close',
+ {
+ filename => $clean_name,
+ mode => $mode,
+ exception => $!,
+ opts => $in,
+ }
+ );
+ }
+ else {
+ # release shadow-ed locks on the file
+ $this->_release( $fh, $in );
+
+ close $fh or return $this->_throw(
+ 'bad close',
+ {
+ filename => $clean_name,
+ mode => $mode,
+ exception => $!,
+ opts => $in,
+ }
+ );
+ }
+
+ # return an array of all lines in the file if the call to this method/
+ # subroutine asked for an array eg- my @file = load_file('file');
+ # otherwise, return a scalar value containing all of the file's content
+ return split /$NL|\r|\n/o, $content
+ if $in->{as_lines};
+
+ return $content;
+}
+
+
+# --------------------------------------------------------
+# File::Util::write_file()
+# --------------------------------------------------------
+sub write_file {
+ my $this = shift @_;
+ my $in = $this->_parse_in( @_ );
+ my $content = '';
+ my $raw_name = '';
+ my $file = '';
+ my $mode = $in->{mode} || 'write';
+ my $bitmask = $in->{bitmask} || oct 777;
+ my $write_fh; # will be the lexical file handle local to this block
+ my ( $root, $path, $clean_name, @dirs ) =
+ ( '', '', '', () );
+
+ # get name of file when passed in as a name/value pair...
+
+ $file =
+ exists $in->{filename} &&
+ defined $in->{filename} &&
+ length $in->{filename}
+ ? $in->{filename}
+ : exists $in->{file} &&
+ defined $in->{file} &&
+ length $in->{file}
+ ? $in->{file}
+ : '';
+
+ # ...or fall back to support of two-argument form of invocation
+
+ my $maybe_file = shift @_; $maybe_file = '' if !defined $maybe_file;
+ my $maybe_content = shift @_; $maybe_content = '' if !defined $maybe_content;
+
+ $file = $maybe_file if !ref $maybe_file && $file eq '';
+ $content =
+ !ref $maybe_content &&
+ !exists $in->{content}
+ ? $maybe_content
+ : $in->{content};
+
+ my ( $winroot ) = $file =~ /^($WINROOT)/;
+
+ $file =~ s/^($WINROOT)//;
+ $file =~ s/$DIRSPLIT{2,}/$SL/o;
+ $file =~ s/$DIRSPLIT+$//o unless $file eq SL;
+ $file = $winroot . $file if $winroot;
+
+ $raw_name = $file; # preserve original filename input before line below:
+
+ ( $root, $path, $file ) = atomize_path( $file );
+
+ $mode = 'trunc' if $mode eq 'truncate';
+ $content = '' if $mode eq 'trunc';
+
+ # if the call to this method didn't include a filename to which the caller
+ # wants us to write, then complain about it
+ return $this->_throw(
+ 'no input' => {
+ meth => 'write_file',
+ missing => 'a file name to create, write, or append',
+ opts => $in,
+ }
+ ) unless length $file;
+
+ # if the call to this method didn't include any data which the caller
+ # wants us to write or append to the file, then complain about it
+ return $this->_throw(
+ 'no input' => {
+ meth => 'write_file',
+ missing => 'the content you want to write or append',
+ opts => $in,
+ }
+ ) if (
+ ( !defined $content ||
+ length $content == 0 )
+ &&
+ $mode ne 'trunc'
+ &&
+ !$EMPTY_WRITES_OK
+ &&
+ !$in->{empty_writes_OK}
+ &&
+ !$in->{empty_writes_ok}
+ );
+
+ # check if file already exists in the form of a directory
+ return $this->_throw(
+ 'cant write_file on a dir' => {
+ filename => $raw_name,
+ opts => $in,
+ }
+ ) if -d $raw_name;
+
+ # determine existance of the file path, make directory(ies) for the
+ # path if the full directory path doesn't exist
+ @dirs = split /$DIRSPLIT/, $path;
+
+ # if prospective file name has illegal chars then complain
+ foreach ( @dirs ) {
+
+ return $this->_throw(
+ 'bad chars' => {
+ string => $_,
+ purpose => 'the name of a file or directory',
+ opts => $in,
+ }
+ ) if !$this->valid_filename( $_ );
+ }
+
+ # do this AFTER the above check!!
+ unshift @dirs, $root if $root;
+
+ # make sure that open mode is a valid mode
+ unless ( $mode eq 'write' || $mode eq 'append' || $mode eq 'trunc' ) {
+
+ return $this->_throw(
+ 'bad openmode popen' => {
+ meth => 'write_file',
+ filename => $raw_name,
+ badmode => $mode,
+ opts => $in,
+ }
+ )
+ }
+
+ # cleanup file name - if path is relative, normalize it
+ # - /foo/bar/baz.txt stays as /foo/bar/baz.txt
+ # - foo/bar/baz.txt becomes ./foo/bar/baz.txt
+ # - baz.txt stays as baz.txt
+ if ( !length $root && !length $path ) {
+
+ $path = '.' . SL;
+ }
+ else { # otherwise path normalized at end
+
+ $path .= SL;
+ }
+
+ # final clean filename assembled
+ $clean_name = $root . $path . $file;
+
+ # create path preceding file if path doesn't exist
+ if ( !-e $root . $path ) {
+
+ my $make_dir_ok = 1;
+
+ my $make_dir_return = $this->make_dir(
+ $root . $path,
+ exists $in->{dbitmask} &&
+ defined $in->{dbitmask}
+ ? $in->{dbitmask}
+ : oct 777,
+ {
+ diag => $in->{diag},
+ onfail => sub {
+ my ( $err, $trace ) = @_;
+
+ return $in->{onfail}
+ if ref $in->{onfail} &&
+ ref $in->{onfail} eq 'CODE';
+
+ $make_dir_ok = 0;
+
+ return $err . $trace;
+ }
+ }
+ );
+
+ die $make_dir_return unless $make_dir_ok;
+ }
+
+ # if file already exists, check if we can write to it
+ if ( -e $clean_name ) {
+
+ return $this->_throw(
+ 'cant fwrite' => {
+ filename => $clean_name,
+ dirname => $root . $path,
+ opts => $in,
+ }
+ ) unless -w $clean_name;
+ }
+ else {
+
+ # if file doesn't exist, see if we can create it
+ return $this->_throw(
+ 'cant fcreate' => {
+ filename => $clean_name,
+ dirname => $root . $path,
+ opts => $in,
+ }
+ ) unless -w $root . $path;
+ }
+
+ # if you use the no_lock option, please consider the risks
+
+ if ( $in->{no_lock} || !$USE_FLOCK ) {
+
+ # only non-existent files get bitmask arguments
+ if ( -e $clean_name ) {
+
+ sysopen
+ $write_fh,
+ $clean_name,
+ $$MODES{sysopen}{ $mode }
+ or return $this->_throw(
+ 'bad open' => {
+ filename => $clean_name,
+ mode => $mode,
+ exception => $!,
+ cmd => qq($clean_name, $$MODES{sysopen}{ $mode }),
+ opts => $in,
+ }
+ );
+ }
+ else {
+
+ sysopen
+ $write_fh,
+ $clean_name,
+ $$MODES{sysopen}{ $mode },
+ $bitmask
+ or return $this->_throw(
+ 'bad open' => {
+ filename => $clean_name,
+ mode => $mode,
+ exception => $!,
+ cmd => qq($clean_name, $$MODES{sysopen}{$mode}, $bitmask),
+ opts => $in,
+ }
+ );
+ }
+ }
+ else {
+ # open read-only first to safely check if we can get a lock.
+ if ( -e $clean_name ) {
+
+ open $write_fh, '<', $clean_name or
+ return $this->_throw(
+ 'bad open' => {
+ filename => $clean_name,
+ mode => 'read',
+ exception => $!,
+ cmd => $mode . $clean_name,
+ opts => $in,
+ }
+ );
+
+ # lock file before I/O on platforms that support it
+ my $lockstat = $this->_seize( $clean_name, $write_fh, $in );
+
+ return unless $lockstat;
+
+ sysopen
+ $write_fh,
+ $clean_name,
+ $$MODES{sysopen}{ $mode }
+ or return $this->_throw(
+ 'bad open' => {
+ filename => $clean_name,
+ mode => $mode,
+ opts => $in,
+ exception => $!,
+ cmd => qq($clean_name, $$MODES{sysopen}{ $mode }),
+ }
+ );
+ }
+ else { # only non-existent files get bitmask arguments
+
+ sysopen
+ $write_fh,
+ $clean_name,
+ $$MODES{sysopen}{ $mode },
+ $bitmask
+ or return $this->_throw(
+ 'bad open' => {
+ filename => $clean_name,
+ mode => $mode,
+ opts => $in,
+ exception => $!,
+ cmd => qq($clean_name, $$MODES{sysopen}{$mode}, $bitmask),
+ }
+ );
+
+ # lock file before I/O on platforms that support it
+ my $lockstat = $this->_seize( $clean_name, $write_fh, $in );
+
+ return unless $lockstat;
+ }
+
+ # now truncate
+ if ( $mode ne 'append' ) {
+
+ truncate( $write_fh, 0 ) or return $this->_throw(
+ 'bad systrunc' => {
+ filename => $clean_name,
+ exception => $!,
+ opts => $in,
+ }
+ );
+ }
+ }
+
+ if ( $in->{binmode} )
+ {
+ if ( lc $in->{binmode} eq 'utf8' )
+ {
+ if ( $HAVE_UU )
+ {
+ binmode $write_fh, ':unix:encoding(UTF-8)';
+ }
+ else
+ {
+ close $write_fh;
+
+ return $this->_throw( 'no unicode' => $in );
+ }
+ }
+ else
+ {
+ binmode $write_fh;
+ }
+ }
+
+ syswrite( $write_fh, $content );
+
+ # release lock on the file
+
+ $this->_release( $write_fh, $in ) unless $$in{no_lock} || !$USE_FLOCK;
+
+ close $write_fh or
+ return $this->_throw(
+ 'bad close' => {
+ filename => $clean_name,
+ mode => $mode,
+ exception => $!,
+ opts => $in,
+ }
+ );
+
+ return 1;
+}
+
+
+# --------------------------------------------------------
+# File::Util::_seize()
+# --------------------------------------------------------
+sub _seize {
+ my ( $this, $file, $fh, $opts ) = @_;
+
+ return $this->_throw( 'no handle passed to _seize.' => $opts )
+ unless $fh;
+
+ $file = defined $file ? $file : ''; # yes, even files named "0" are allowed
+
+ return $this->_throw( 'no file name passed to _seize.' => $opts )
+ unless length $file;
+
+ # forget seizing if system can't flock
+ return $fh if !$CAN_FLOCK;
+
+ my @policy = @ONLOCKFAIL;
+
+ # seize filehandle, return it if lock is successful
+
+ while ( @policy ) {
+
+ my $fh = &{ $_LOCKS->{ shift @policy } }( $this, $file, $fh, $opts );
+
+ return $fh if $fh || !scalar @policy;
+ }
+
+ return $fh;
+}
+
+
+# --------------------------------------------------------
+# File::Util::_release()
+# --------------------------------------------------------
+sub _release {
+
+ my ( $this, $fh, $opts ) = @_;
+
+ return $this->_throw(
+ 'not a filehandle.' => { opts => $opts, argtype => ref $fh } )
+ unless $fh && ref $fh eq 'GLOB';
+
+ if ( $CAN_FLOCK ) { flock $fh, &Fcntl::LOCK_UN }
+ return 1;
+}
+
+
+# --------------------------------------------------------
+# File::Util::valid_filename()
+# --------------------------------------------------------
+sub valid_filename {
+ my $f = _myargs( @_ );
+
+ $f =~ s/$WINROOT//; # windows abs paths would throw this off
+
+ $f !~ /$ILLEGAL_CHR/ ? 1 : undef;
+}
+
+
+# --------------------------------------------------------
+# File::Util::strip_path()
+# --------------------------------------------------------
+sub strip_path {
+ my $arg = _myargs( @_ );
+
+ my ( $stripped ) = $arg =~ /^.*$DIRSPLIT(.+)/o;
+
+ return $stripped if defined $stripped;
+
+ return $arg;
+}
+
+
+# --------------------------------------------------------
+# File::Util::atomize_path()
+# --------------------------------------------------------
+sub atomize_path {
+ my $fqfn = _myargs( @_ );
+
+ $fqfn =~ m/$ATOMIZER/o;
+
+ # root = $1
+ # path = $2
+ # file = $3
+
+ return( $1||'', $2||'', $3||'' );
+}
+
+
+# --------------------------------------------------------
+# File::Util::atomize_path()
+# --------------------------------------------------------
+sub split_path {
+ my $path = _myargs( @_ );
+
+ # find root of tree (if path was absolute)
+ my ( $root, $branch, $leaf ) = atomize_path( $path );
+
+ my @path_dirs = split /$DIRSPLIT/o, $branch;
+
+ unshift @path_dirs, $root if $root;
+ push @path_dirs, $leaf if $leaf;
+
+ return @path_dirs;
+}
+
+
+# --------------------------------------------------------
+# File::Util::line_count()
+# --------------------------------------------------------
+sub line_count {
+ my( $this, $file ) = @_;
+ my $buff = '';
+ my $lines = 0;
+ my $cmd = '<' . $file;
+
+ open my $fh, '<', $file or
+ return $this->_throw(
+ 'bad open',
+ {
+ 'filename' => $file,
+ 'mode' => 'read',
+ 'exception' => $!,
+ 'cmd' => $cmd,
+ }
+ );
+
+ while ( sysread( $fh, $buff, 4096 ) ) {
+
+ $lines += $buff =~ tr/\n//;
+
+ $buff = '';
+ }
+
+ close $fh;
+
+ return $lines;
+}
+
+
+# --------------------------------------------------------
+# File::Util::bitmask()
+# --------------------------------------------------------
+sub bitmask {
+ my $f = _myargs( @_ );
+
+ defined $f and -e $f ? sprintf('%04o',(stat($f))[2] & oct 777) : undef
+}
+
+
+# --------------------------------------------------------
+# File::Util::can_flock()
+# --------------------------------------------------------
+sub can_flock { $CAN_FLOCK }
+
+
+# --------------------------------------------------------
+# File::Util::can_utf8()
+# --------------------------------------------------------
+sub can_utf8 { $HAVE_UU }
+
+
+# File::Util::--------------------------------------------
+# is_readable(), is_writable() -- was: can_read(), can_write()
+# --------------------------------------------------------
+sub is_readable { my $f = _myargs( @_ ); defined $f ? -r $f : undef }
+sub is_writable { my $f = _myargs( @_ ); defined $f ? -w $f : undef }
+
+
+# --------------------------------------------------------
+# File::Util::created()
+# --------------------------------------------------------
+sub created {
+ my $f = _myargs( @_ );
+
+ defined $f and -e $f ? $^T - ((-M $f) * 60 * 60 * 24) : undef
+}
+
+
+# --------------------------------------------------------
+# File::Util::ebcdic()
+# --------------------------------------------------------
+sub ebcdic { $EBCDIC }
+
+
+# --------------------------------------------------------
+# File::Util::escape_filename()
+# --------------------------------------------------------
+sub escape_filename {
+ my( $file, $escape, $also ) = _myargs( @_ );
+
+ return '' unless defined $file;
+
+ $escape = '_' if !defined $escape;
+
+ if ( $also ) { $file =~ s/\Q$also\E/$escape/g }
+
+ $file =~ s/$ILLEGAL_CHR/$escape/g;
+ $file =~ s/$DIRSPLIT/$escape/g;
+
+ $file
+}
+
+
+# --------------------------------------------------------
+# File::Util::existent()
+# --------------------------------------------------------
+sub existent { my $f = _myargs( @_ ); defined $f ? -e $f : undef }
+
+
+# --------------------------------------------------------
+# File::Util::touch()
+# --------------------------------------------------------
+sub touch {
+ my $this = shift @_;
+ my $file = shift @_ || '';
+ my $opts = $this->_remove_opts( \@_ );
+ my $path;
+
+ return $this->_throw(
+ 'no input',
+ {
+ meth => 'touch',
+ missing => 'a file name or file handle reference',
+ opts => $opts,
+ }
+ ) unless defined $file && length $file;
+
+ $path = $this->return_path( $file );
+
+ # see if the file exists already and is a directory
+ return $this->_throw(
+ 'cant touch on a dir',
+ {
+ filename => $file,
+ dirname => $path || '',
+ opts => $opts,
+ }
+ ) if -e $file && -d $file;
+
+ # it's good to know beforehand whether or not we have permission to open
+ # and read from this file allowing us to handle such an exception before
+ # it handles us.
+
+ # first check the readability of the file's housing dir
+ return $this->_throw(
+ 'cant dread',
+ {
+ filename => $file,
+ dirname => $path,
+ opts => $opts,
+ }
+ ) if ( -e $path && !-r $path );
+
+ $this->make_dir( $path ) unless -e $path;
+
+ # create the file if it doesn't exist (like the *nix touch command does)
+ # except we'll create it in binmode or with UTF-8 encoding if requested
+ $this->write_file(
+ $file => '' => { empty_writes_OK => 1, binmode => $opts->{binmode} }
+ ) unless -e $file;
+
+ my $now = time();
+
+ # return
+ return utime $now, $now, $file;
+}
+
+
+# --------------------------------------------------------
+# File::Util::file_type()
+# --------------------------------------------------------
+sub file_type {
+ my $f = _myargs( @_ );
+
+ return unless defined $f and -e $f;
+
+ my @ret;
+
+ push @ret, 'PLAIN' if -f $f; push @ret, 'TEXT' if -T $f;
+ push @ret, 'BINARY' if -B $f; push @ret, 'DIRECTORY' if -d $f;
+ push @ret, 'SYMLINK' if -l $f; push @ret, 'PIPE' if -p $f;
+ push @ret, 'SOCKET' if -S $f; push @ret, 'BLOCK' if -b $f;
+ push @ret, 'CHARACTER' if -c $f;
+
+ ## no critic
+ push @ret, 'TTY' if -t $f;
+ ## use critic
+
+ push @ret, 'ERROR: Cannot determine file type' unless scalar @ret;
+
+ return @ret;
+}
+
+
+# --------------------------------------------------------
+# File::Util::flock_rules()
+# --------------------------------------------------------
+sub flock_rules {
+ my $this = shift(@_);
+ my @rules = _myargs( @_ );
+
+ return @ONLOCKFAIL unless scalar @rules;
+
+ my %valid = qw/
+ NOBLOCKEX NOBLOCKEX
+ NOBLOCKSH NOBLOCKSH
+ BLOCKEX BLOCKEX
+ BLOCKSH BLOCKSH
+ FAIL FAIL
+ WARN WARN
+ IGNORE IGNORE
+ UNDEF UNDEF
+ ZERO ZERO /;
+
+ map {
+ return $this->_throw('bad flock rules', { 'bad' => $_, 'all' => \@rules })
+ unless exists $valid{ $_ }
+ } @rules;
+
+ @ONLOCKFAIL = @rules;
+
+ @ONLOCKFAIL
+}
+
+
+# --------------------------------------------------------
+# File::Util::is_bin()
+# --------------------------------------------------------
+sub is_bin { my $f = _myargs( @_ ); defined $f ? -B $f : undef }
+
+
+# --------------------------------------------------------
+# File::Util::last_access()
+# --------------------------------------------------------
+sub last_access {
+ my $f = _myargs( @_ ); $f ||= '';
+
+ return unless -e $f;
+
+ # return the last accessed time of $f
+ $^T - ((-A $f) * 60 * 60 * 24)
+}
+
+
+# --------------------------------------------------------
+# File::Util::last_modified()
+# --------------------------------------------------------
+sub last_modified {
+ my $f = _myargs( @_ ); $f ||= '';
+
+ return unless -e $f;
+
+ # return the last modified time of $f
+ $^T - ((-M $f) * 60 * 60 * 24)
+}
+
+
+# --------------------------------------------------------
+# File::Util::last_changed()
+# --------------------------------------------------------
+sub last_changed {
+ my $f = _myargs( @_ ); $f ||= '';
+
+ return unless -e $f;
+
+ # return the last changed time of $f
+ $^T - ((-C $f) * 60 * 60 * 24)
+}
+
+
+# --------------------------------------------------------
+# File::Util::load_dir()
+# --------------------------------------------------------
+sub load_dir {
+ my $this = shift @_;
+ my $opts = $this->_remove_opts( \@_ );
+ my $dir = shift @_;
+
+ my @files = ( );
+ my $dir_hash = { };
+ my $dir_list = [ ];
+
+ $dir ||= '';
+
+ return $this->_throw(
+ 'no input' => {
+ meth => 'load_dir',
+ missing => 'a directory name',
+ opts => $opts,
+ }
+ ) unless length $dir;
+
+ @files = $this->list_dir( $dir => { files_only => 1 } );
+
+ # map the content of each file into a hash key-value element where the
+ # key name for each file is the name of the file
+ if ( !$opts->{as_list} && !$opts->{as_listref} ) {
+
+ foreach ( @files ) {
+
+ $dir_hash->{ $_ } = $this->load_file( $dir . SL . $_ );
+ }
+
+ return $dir_hash;
+ }
+ else {
+
+ foreach ( @files ) {
+
+ push @$dir_list, $this->load_file( $dir . SL . $_ );
+ }
+
+ return $dir_list if $opts->{as_listref};
+
+ return @$dir_list;
+ }
+
+ return $dir_hash;
+}
+
+
+# --------------------------------------------------------
+# File::Util::make_dir()
+# --------------------------------------------------------
+sub make_dir {
+ my $this = shift @_;
+ my $opts = $this->_remove_opts( \@_ );
+ my( $dir, $bitmask ) = @_;
+
+ $bitmask = defined $bitmask ? $bitmask : $opts->{bitmask};
+ $bitmask ||= oct 777;
+
+ # if the call to this method didn't include a directory name to create,
+ # then complain about it
+ return $this->_throw(
+ 'no input',
+ {
+ meth => 'make_dir',
+ missing => 'a directory name',
+ opts => $opts,
+ }
+ ) unless defined $dir && length $dir;
+
+ if ( $opts->{if_not_exists} ) {
+
+ if ( -e $dir ) {
+
+ return $dir if -d $dir;
+
+ return $this->_throw(
+ 'called mkdir on a file',
+ {
+ filename => $dir,
+ dirname => join( SL, split /$DIRSPLIT/, $dir ) . SL,
+ opts => $opts,
+ }
+ );
+ }
+ }
+ else {
+
+ if ( -e $dir ) {
+
+ return $this->_throw(
+ 'called mkdir on a file',
+ {
+ filename => $dir,
+ dirname => join( SL, split /$DIRSPLIT/, $dir ) . SL,
+ opts => $opts,
+ }
+ ) unless -d $dir;
+
+ return $this->_throw(
+ 'make_dir target exists',
+ {
+ dirname => $dir,
+ filetype => [ $this->file_type( $dir ) ],
+ opts => $opts,
+ }
+ );
+ }
+ }
+
+ my ( $winroot ) = $dir =~ /^($WINROOT)/;
+
+ $dir =~ s/^($WINROOT)//;
+ $dir =~ s/$DIRSPLIT{2,}/$SL/o;
+ $dir =~ s/$DIRSPLIT+$//o unless $dir eq SL;
+ $dir = $winroot . $dir if $winroot;
+
+ my ( $root, $path ) = atomize_path( $dir . SL );
+
+ my @dirs_in_path = split /$DIRSPLIT/, $path;
+
+ # if prospective file name has illegal chars then complain
+ foreach ( @dirs_in_path ) {
+
+ return $this->_throw(
+ 'bad chars',
+ {
+ string => $_,
+ purpose => 'the name of a file or directory',
+ opts => $opts,
+ }
+ ) if !$this->valid_filename( $_ );
+ }
+
+ # do this AFTER the above check!!
+ unshift @dirs_in_path, $root if $root;
+
+ # qualify each subdir in @dirs_in_path by prepending its preceeding dir
+ # names to it. Above, "/foo/bar/baz" becomes ("/", "foo", "bar", "baz")
+ # and below it becomes ("/", "/foo", "/foo/bar", "/foo/bar/baz")
+
+ if ( @dirs_in_path > 1 ) {
+ for ( my $depth = 1; $depth < @dirs_in_path; ++$depth ) {
+
+ if ( $dirs_in_path[ $depth-1 ] eq SL ) {
+
+ $dirs_in_path[ $depth ] = SL . $dirs_in_path[ $depth ]
+ }
+ else {
+
+ $dirs_in_path[ $depth ] =
+ join SL, @dirs_in_path[ ( $depth - 1 ) .. $depth ]
+ }
+ }
+ }
+
+ my $i = 0;
+
+ foreach ( @dirs_in_path ) {
+ my $dir = $_;
+ my $up = ( $i > 0 ) ? $dirs_in_path[ $i - 1 ] : '..';
+
+ ++$i;
+
+ if ( -e $dir && !-d $dir ) {
+
+ return $this->_throw(
+ 'called mkdir on a file',
+ {
+ filename => $dir,
+ dirname => $up . SL,
+ opts => $opts,
+ }
+ );
+ }
+
+ next if -e $dir;
+
+ # it's good to know beforehand whether or not we have permission to
+ # create dirs here, which allows us to handle such an exception
+ # before it handles us.
+ return $this->_throw(
+ 'cant dcreate',
+ {
+ dirname => $dir,
+ parentd => $up,
+ opts => $opts,
+ }
+ ) unless -w $up;
+
+ mkdir( $dir, $bitmask ) or
+ return $this->_throw(
+ 'bad make_dir',
+ {
+ exception => $!,
+ dirname => $dir,
+ bitmask => $bitmask,
+ opts => $opts,
+ }
+ );
+ }
+
+ return $dir;
+}
+
+
+# --------------------------------------------------------
+# File::Util::abort_depth()
+# --------------------------------------------------------
+sub abort_depth {
+ my $arg = _myargs( @_ );
+ my $this = shift @_;
+
+ if ( defined $arg ) {
+
+ return File::Util->new->_throw( 'bad abort_depth' => { bad => $arg } )
+ if $arg =~ /\D/;
+
+ $ABORT_DEPTH = $arg;
+
+ $this->{opts}->{abort_depth} = $arg
+ if blessed $this && $this->{opts};
+ }
+
+ return $ABORT_DEPTH;
+}
+
+# --------------------------------------------------------
+# File::Util::onfail()
+# --------------------------------------------------------
+sub onfail {
+ my ( $this, $arg ) = @_;
+
+ return unless blessed $this;
+
+ $this->{opts}->{onfail} = $arg if $arg;
+
+ return $this->{opts}->{onfail};
+}
+
+
+# --------------------------------------------------------
+# File::Util::read_limit()
+# --------------------------------------------------------
+sub read_limit {
+ my $arg = _myargs( @_ );
+ my $this = shift @_;
+
+ if ( defined $arg ) {
+
+ return File::Util->new->_throw ( 'bad read_limit' => { bad => $arg } )
+ if $arg =~ /\D/;
+
+ $READ_LIMIT = $arg;
+
+ $this->{opts}->{read_limit} = $arg
+ if blessed $this && $this->{opts};
+ }
+
+ return $READ_LIMIT;
+}
+
+
+# --------------------------------------------------------
+# File::Util::diagnostic()
+# --------------------------------------------------------
+sub diagnostic {
+ my $arg = _myargs( @_ );
+ my $this = shift @_;
+
+ if ( defined $arg ) {
+
+ $WANT_DIAGNOSTICS = $arg ? 1 : 0;
+
+ $this->{opts}->{diag} = $arg ? 1 : 0
+ if blessed $this && $this->{opts};
+ }
+
+ return $WANT_DIAGNOSTICS;
+}
+
+
+# --------------------------------------------------------
+# File::Util::needs_binmode()
+# --------------------------------------------------------
+sub needs_binmode { $NEEDS_BINMODE }
+
+
+# --------------------------------------------------------
+# File::Util::open_handle()
+# --------------------------------------------------------
+sub open_handle {
+ my $this = shift @_;
+ my $in = $this->_parse_in( @_ );
+ my $file = '';
+ my $mode = '';
+ my $bitmask = $in->{bitmask} || oct 777;
+ my $raw_name = $file;
+ my $fh; # will be the lexical file handle scoped to this method
+ my ( $root, $path, $clean_name, @dirs ) =
+ ( '', '', '', () );
+
+ # get name of file when passed in as a name/value pair...
+
+ $file =
+ exists $in->{filename} &&
+ defined $in->{filename} &&
+ length $in->{filename}
+ ? $in->{filename}
+ : exists $in->{file} &&
+ defined $in->{file} &&
+ length $in->{file}
+ ? $in->{file}
+ : '';
+
+ # ...or fall back to support of two-argument form of invocation
+
+ my $maybe_file = shift @_; $maybe_file = '' if !defined $maybe_file;
+ my $maybe_mode = shift @_; $maybe_mode = '' if !defined $maybe_mode;
+
+ $file = $maybe_file if !ref $maybe_file && $file eq '';
+ $mode =
+ !ref $maybe_mode &&
+ !exists $in->{mode}
+ ? $maybe_mode
+ : $in->{mode};
+
+ $mode ||= 'read';
+
+
+ my ( $winroot ) = $file =~ /^($WINROOT)/;
+
+ $file =~ s/^($WINROOT)//;
+ $file =~ s/$DIRSPLIT{2,}/$SL/o;
+ $file =~ s/$DIRSPLIT+$//o unless $file eq SL;
+ $file = $winroot . $file if $winroot;
+
+ $raw_name = $file; # preserve original filename input before line below:
+
+ ( $root, $path, $file ) = atomize_path( $file );
+
+ # begin user input validation/sanitation sequence
+
+ # if the call to this method didn't include a filename to which the caller
+ # wants us to write, then complain about it
+ return $this->_throw(
+ 'no input',
+ {
+ meth => 'open_handle',
+ missing => 'a file name to create, write, read/write, or append',
+ opts => $in,
+ }
+ ) unless length $file;
+
+ if ( $mode eq 'read' && !-e $raw_name ) {
+
+ # if the file doesn't exist, send back an error
+ return $this->_throw(
+ 'no such file',
+ {
+ filename => $raw_name,
+ opts => $in,
+ }
+ ) unless -e $clean_name;
+ }
+
+ # if prospective filename contains 2+ dir separators in sequence then
+ # this is a syntax error we need to whine about
+ {
+ my $try_filename = $raw_name;
+
+ $try_filename =~ s/$WINROOT//; # windows abs paths would throw this off
+
+ return $this->_throw(
+ 'bad chars',
+ {
+ string => $raw_name,
+ purpose => 'the name of a file or directory',
+ opts => $in,
+ }
+ ) if $try_filename =~ /(?:$DIRSPLIT){2,}/;
+ }
+
+ # determine existance of the file path, make directory(ies) for the
+ # path if the full directory path doesn't exist
+ @dirs = split /$DIRSPLIT/, $path;
+
+ # if prospective file name has illegal chars then complain
+ foreach ( @dirs ) {
+
+ return $this->_throw(
+ 'bad chars',
+ {
+ string => $_,
+ purpose => 'the name of a file or directory',
+ opts => $in,
+ }
+ ) if !$this->valid_filename( $_ );
+ }
+
+ # do this AFTER the above check!!
+ unshift @dirs, $root if $root;
+
+ # make sure that open mode is a valid mode
+ if (
+ !exists $in->{use_sysopen} &&
+ !defined $in->{use_sysopen}
+ ) {
+ # native Perl open modes
+ unless (
+ exists $$MODES{popen}{ $mode } &&
+ defined $$MODES{popen}{ $mode }
+ ) {
+ return $this->_throw(
+ 'bad openmode popen',
+ {
+ meth => 'open_handle',
+ filename => $raw_name,
+ badmode => $mode,
+ opts => $in,
+ }
+ )
+ }
+ }
+ else {
+ # system open modes
+ unless (
+ exists $$MODES{sysopen}{ $mode } &&
+ defined $$MODES{sysopen}{ $mode }
+ ) {
+ return $this->_throw(
+ 'bad openmode sysopen',
+ {
+ meth => 'open_handle',
+ filename => $raw_name,
+ badmode => $mode,
+ opts => $in,
+ }
+ )
+ }
+ }
+
+ # cleanup file name - if path is relative, normalize it
+ # - /foo/bar/baz.txt stays as /foo/bar/baz.txt
+ # - foo/bar/baz.txt becomes ./foo/bar/baz.txt
+ # - baz.txt stays as baz.txt
+ if ( !length $root && !length $path ) {
+
+ $path = '.' . SL;
+ }
+ else { # otherwise path normalized at end
+
+ $path .= SL;
+ }
+
+ # final clean filename assembled
+ $clean_name = $root . $path . $file;
+
+ # create path preceding file if path doesn't exist and not in read mode
+ if ( $mode ne 'read' && !-e $root . $path ) {
+
+ my $make_dir_ok = 1;
+
+ my $make_dir_return = $this->make_dir(
+ $root . $path,
+ exists $in->{dbitmask} &&
+ defined $in->{dbitmask}
+ ? $in->{dbitmask}
+ : oct 777,
+ {
+ diag => $in->{diag},
+ onfail => sub {
+ my ( $err, $trace ) = @_;
+
+ return $in->{onfail}
+ if ref $in->{onfail} &&
+ ref $in->{onfail} eq 'CODE';
+
+ $make_dir_ok = 0;
+
+ return $err . $trace;
+ }
+ }
+ );
+
+ die $make_dir_return unless $make_dir_ok;
+ }
+
+ # sanity checks based on requested mode
+ if (
+ $mode eq 'write' ||
+ $mode eq 'append' ||
+ $mode eq 'rwcreate' ||
+ $mode eq 'rwclobber' ||
+ $mode eq 'rwappend'
+ ) {
+ # Check whether or not we have permission to open and perform writes
+ # on this file.
+
+ if ( -e $clean_name ) {
+
+ return $this->_throw(
+ 'cant fwrite',
+ {
+ filename => $clean_name,
+ dirname => $root . $path,
+ opts => $in,
+ }
+ ) unless -w $clean_name;
+ }
+ else {
+ # If file doesn't exist and the path isn't writable, the error is
+ # one of unallowed creation.
+ return $this->_throw(
+ 'cant fcreate',
+ {
+ filename => $clean_name,
+ dirname => $root . $path,
+ opts => $in,
+ }
+ ) unless -w $root . $path;
+ }
+ }
+ elsif ( $mode eq 'read' || $mode eq 'rwupdate' ) {
+ # Check whether or not we have permission to open and perform reads
+ # on this file, starting with file's housing directory.
+ return $this->_throw(
+ 'cant dread',
+ {
+ filename => $clean_name,
+ dirname => $root . $path,
+ opts => $in,
+ }
+ ) unless -r $root . $path;
+
+ # Seems obvious, but we can't read non-existent files
+ return $this->_throw(
+ 'cant fread not found',
+ {
+ filename => $clean_name,
+ dirname => $root . $path,
+ opts => $in,
+ }
+ ) unless -e $clean_name;
+
+ # Check the readability of the file itself
+ return $this->_throw(
+ 'cant fread',
+ {
+ filename => $clean_name,
+ dirname => $root . $path,
+ opts => $in,
+ }
+ ) unless -r $clean_name;
+ }
+ else {
+ return $this->_throw(
+ 'no input',
+ {
+ meth => 'open_handle',
+ missing => q{a valid IO mode. (eg- 'read', 'write'...)},
+ opts => $in,
+ }
+ );
+ }
+ # input validation sequence finished
+
+ if ( $$in{no_lock} || !$USE_FLOCK ) {
+ if (
+ !exists $in->{use_sysopen} &&
+ !defined $in->{use_sysopen}
+ ) { # perl open
+ # get open mode
+ $mode = $$MODES{popen}{ $mode };
+
+ open $fh, $mode, $clean_name or
+ return $this->_throw(
+ 'bad open',
+ {
+ filename => $clean_name,
+ mode => $mode,
+ exception => $!,
+ cmd => $mode . $clean_name,
+ opts => $in,
+ }
+ );
+ }
+ else { # sysopen
+ # get open mode
+ $mode = $$MODES{sysopen}{ $mode };
+
+ sysopen( $fh, $clean_name, $$MODES{sysopen}{ $mode } ) or
+ return $this->_throw(
+ 'bad open',
+ {
+ filename => $clean_name,
+ mode => $mode,
+ exception => $!,
+ cmd => qq($clean_name, $$MODES{sysopen}{ $mode }),
+ opts => $in,
+ }
+ );
+ }
+ }
+ else {
+ if (
+ !exists $in->{use_sysopen} &&
+ !defined $in->{use_sysopen}
+ ) { # perl open
+ # open read-only first to safely check if we can get a lock.
+ if ( -e $clean_name ) {
+
+ open $fh, '<', $clean_name or
+ return $this->_throw(
+ 'bad open',
+ {
+ filename => $clean_name,
+ mode => 'read',
+ exception => $!,
+ cmd => $mode . $clean_name,
+ opts => $in,
+ }
+ );
+
+ # lock file before I/O on platforms that support it
+ my $lockstat = $this->_seize( $clean_name, $fh, $in );
+
+ warn "returning $lockstat" && return $lockstat unless fileno $lockstat;
+
+ if ( $mode ne 'read' ) {
+
+ open $fh, $$MODES{popen}{ $mode }, $clean_name or
+ return $this->_throw(
+ 'bad open',
+ {
+ exception => $!,
+ filename => $clean_name,
+ mode => $mode,
+ opts => $in,
+ cmd => $$MODES{popen}{ $mode } . $clean_name,
+ }
+ );
+ }
+ }
+ else {
+ open $fh, $$MODES{popen}{ $mode }, $clean_name or
+ return $this->_throw(
+ 'bad open',
+ {
+ exception => $!,
+ filename => $clean_name,
+ mode => $mode,
+ opts => $in,
+ cmd => $$MODES{popen}{ $mode } . $clean_name,
+ }
+ );
+
+ # lock file before I/O on platforms that support it
+ my $lockstat = $this->_seize( $clean_name, $fh, $in );
+
+ return $lockstat unless $lockstat;
+ }
+ }
+ else { # sysopen
+ # open read-only first to safely check if we can get a lock.
+ if ( -e $clean_name ) {
+
+ open $fh, '<', $clean_name or
+ return $this->_throw(
+ 'bad open',
+ {
+ filename => $clean_name,
+ mode => 'read',
+ exception => $!,
+ cmd => $mode . $clean_name,
+ opts => $in,
+ }
+ );
+
+ # lock file before I/O on platforms that support it
+ my $lockstat = $this->_seize( $clean_name, $fh, $in );
+
+ return $lockstat unless $lockstat;
+
+ sysopen( $fh, $clean_name, $$MODES{sysopen}{ $mode } )
+ or return $this->_throw(
+ 'bad open',
+ {
+ filename => $clean_name,
+ mode => $mode,
+ opts => $in,
+ exception => $!,
+ cmd => qq($clean_name, $$MODES{sysopen}{ $mode }),
+ }
+ );
+ }
+ else { # only non-existent files get bitmask arguments
+ sysopen(
+ $fh,
+ $clean_name,
+ $$MODES{sysopen}{ $mode },
+ $bitmask
+ ) or return $this->_throw(
+ 'bad open',
+ {
+ filename => $clean_name,
+ mode => $mode,
+ opts => $in,
+ exception => $!,
+ cmd => qq($clean_name, $$MODES{sysopen}{$mode}, $bitmask),
+ }
+ );
+
+ # lock file before I/O on platforms that support it
+ my $lockstat = $this->_seize( $clean_name, $fh, $in );
+
+ return $lockstat unless $lockstat;
+ }
+ }
+ }
+
+ # call binmode on the filehandle if it was requested or UTF-8
+ if ( $in->{binmode} )
+ {
+ if ( lc $in->{binmode} eq 'utf8' )
+ {
+ if ( $HAVE_UU )
+ {
+ binmode $fh, ':unix:encoding(UTF-8)';
+ }
+ else
+ {
+ close $fh;
+
+ return $this->_throw( 'no unicode' => $in );
+ }
+ }
+ else
+ {
+ binmode $fh;
+ }
+ }
+
+ # return file handle reference to the caller
+ return $fh;
+}
+
+
+# --------------------------------------------------------
+# File::Util::unlock_open_handle()
+# --------------------------------------------------------
+sub unlock_open_handle {
+ my( $this, $fh ) = @_;
+
+ return 1 unless $USE_FLOCK;
+
+ return $this->_throw(
+ 'not a filehandle' => {
+ opts => $this->_remove_opts( \@_ ),
+ argtype => ref $fh,
+ }
+ ) unless $fh && fileno $fh;
+
+ return flock( $fh, &Fcntl::LOCK_UN ) if $CAN_FLOCK;
+
+ return 0;
+}
+
+
+# --------------------------------------------------------
+# File::Util::return_path()
+# --------------------------------------------------------
+sub return_path { my $f = _myargs( @_ ); $f =~ s/(^.*)$DIRSPLIT.*/$1/o; $f }
+
+
+# --------------------------------------------------------
+# File::Util::size()
+# --------------------------------------------------------
+sub size { my $f = _myargs( @_ ); $f ||= ''; return unless -e $f; -s $f }
+
+
+# --------------------------------------------------------
+# File::Util::trunc()
+# --------------------------------------------------------
+sub trunc { $_[0]->write_file( { mode => trunc => file => $_[1] } ) }
+
+
+# --------------------------------------------------------
+# File::Util::use_flock()
+# --------------------------------------------------------
+sub use_flock {
+ my $arg = _myargs( @_ );
+
+ $USE_FLOCK = !!$arg if defined $arg;
+
+ return $USE_FLOCK;
+}
+
+# --------------------------------------------------------
+# File::Util::AUTOLOAD()
+# --------------------------------------------------------
+sub AUTOLOAD {
+
+ # The main purpose of using autoload here is to avoid compiling in
+ # copious amounts of error handling code at compile time, when in
+ # the majority of cases and in production code-- such errors should
+ # have already been debugged and the error handling mechanism will
+ # end up getting invoked seldom if ever. There's no reason to pay
+ # the performance penalty when it's not necessary.
+ # The other purpose is to support legacy method names.
+
+ ( my $name = our $AUTOLOAD ) =~ s/.*:://;
+
+ # These are legacy method names, and their current replacements. In order
+ # to future-proof things, this hashref is used as a dispatch table further
+ # down in the code in lieu of potentially-growing if/else block, which
+ # would ugly to maintain
+
+ my $redirect_methods = {
+ can_write => \&is_writable,
+ can_read => \&is_readable,
+ isbin => \&is_bin,
+ readlimit => \&read_limit,
+ max_dives => \&abort_depth,
+ };
+
+ if ( $name eq '_throw' )
+ {
+ *_throw = sub
+ {
+ my $this = shift @_;
+ my $in = $this->_parse_in( @_ ) || { };
+ my $error_class;
+
+ # direct input can override object-global diag default, otherwise
+ # the object's "want diagnostics" setting is inherited
+
+ $in->{diag} = defined $in->{diag} && !$in->{diag}
+ ? 0
+ : $in->{diag}
+ ? $in->{diag}
+ : $this->{opts}->{diag};
+
+ if
+ (
+ $in->{diag} ||
+ ( $in->{opts} &&
+ ref $in->{opts} &&
+ ref $in->{opts} eq 'HASH' &&
+ $in->{opts}->{diag}
+ )
+ )
+ {
+ require File::Util::Exception::Diagnostic;
+
+ $error_class = 'File::Util::Exception::Diagnostic';
+
+ unshift @_, $this, $error_class;
+
+ goto \&File::Util::Exception::Diagnostic::_throw;
+ }
+ else
+ {
+ require File::Util::Exception::Standard;
+
+ $error_class = 'File::Util::Exception::Standard';
+
+ unshift @_, $this, $error_class;
+
+ goto \&File::Util::Exception::Standard::_throw;
+
+ }
+ };
+
+ goto \&_throw;
+ }
+ elsif ( exists $redirect_methods->{ $name } ) {
+
+ { no strict 'refs'; *{ $name } = $redirect_methods->{ $name } }
+
+ goto \&$name;
+ }
+
+ die qq(Unknown method: File::Util::$name\n);
+}
+
+
+# --------------------------------------------------------
+# File::Util::DESTROY()
+# --------------------------------------------------------
+sub DESTROY { }
+
+1;
+
+
+__END__
+
+=pod
+
+=head1 NAME
+
+File::Util - Easy, versatile, portable file handling
+
+=head1 VERSION
+
+version 4.132140
+
+=head1 DESCRIPTION
+
+File::Util provides a comprehensive toolbox of utilities to automate all
+kinds of common tasks on files and directories. Its purpose is to do so
+in the most B<portable> manner possible so that users of this module won't
+have to worry about whether their programs will work on other operating systems
+and/or architectures. It works on Linux, Windows, Mac, BSD, Unix and others.
+
+File::Util is written B<purely in Perl>, and requires no compiler or make
+utility on your system in order to install and run it.
+
+File::Util also aims to be as backward compatible as possible, running without
+problems on Perl installations as old as 5.006. You are encouraged to run
+File::Util on Perl version 5.8 and above.
+
+After browsing this document, please have a look at the other documentation.
+I<(See L<DOCUMENTATION|/DOCUMENTATION> section below.)>
+
+=head1 SYNOPSIS
+
+ # use File::Util in your program
+ use File::Util;
+
+ # create a new File::Util object
+ my $f = File::Util->new();
+
+ # read file into a variable
+ my $content = $f->load_file( 'some_file.txt' );
+
+ # write content to a file
+ $f->write_file( 'some_other_file.txt' => 'Hello world!' );
+
+ # get the contents of a directory, 3 levels deep
+ my @songs = $f->list_dir( '~/Music' => { recurse => 1, max_depth => 3 } );
+
+=head1 DOCUMENTATION
+
+You can do much more with File::Util than the examples above. For an
+explanation of all the features available to you, take a look at these other
+reference materials:
+
+=over
+
+=item B<The "Nutshell">
+
+The L<File::Util::Manual::Examples> document has a long list of small, reusable
+code snippets and techniques to use in your own programs. This is the "cheat
+sheet", and is a great place to get started quickly. Almost everything you
+need is here.
+
+=item B<The Manual>
+
+The L<File::Util::Manual> is the complete reference document explaining every
+available feature and object method. Use this to look up the full information
+on any given feature when the examples aren't enough.
+
+=item B<The Cookbook>
+
+The L<File::Util::Cookbook> contains examples of complete, working programs
+that use File::Util to easily accomplish tasks which require file handling.
+
+=back
+
+=head1 BASIC USAGE
+
+=head2 Getting Started
+
+ # use File::Util in your program
+ use File::Util;
+
+ # ...you can optionally enable File::Util's diagnostic error messages:
+ # (see File::Util::Manual section regarding diagnostics)
+ use File::Util qw( :diag );
+
+ # create a new File::Util object
+ my $f = File::Util->new();
+
+ # ...you can enable diagnostics for individual objects:
+ $f = File::Util->new( diag => 1 );
+
+=head2 File Operations
+
+ # load content into a variable, be it text, or binary, either works
+ my $content = $f->load_file( 'data.txt' );
+
+ # wrangle some text
+ $content =~ s/this/that/g;
+
+ # write a file with your changes
+ $f->write_file( 'new_data.txt' => $content );
+
+ # try binary this time
+ my $binary_content = $f->load_file( 'barking-cat.avi' );
+
+ # get some image data from somewhere...
+ my $picture_data = get_image_upload();
+
+ # ...and write a binary image file, using some other options as well
+ $f->write_file(
+ 'llama.jpg' => $picture_data => { binmode => 1, bitmask => oct 644 }
+ );
+
+ # ...or write a file with UTF-8 encoding (unicode support)
+ $f->write_file( 'encoded.txt' => qq(\x{c0}) => { binmode => 'utf8' } );
+
+ # load a file into an array, line by line
+ my @lines = $f->load_file( 'file.txt' => { as_lines => 1 } );
+
+ # see if you have permission to write to a file, then append to it
+ if ( $f->is_writable( 'captains.log' ) ) {
+
+ my $fh = $f->open_handle( 'captains.log' => 'append' );
+
+ print $fh "Captain's log, stardate 41153.7. Our destination is...";
+
+ close $fh or die $!;
+ }
+ else { # ...or warn the crew
+
+ warn "Trouble on the bridge, the Captain can't access his log!";
+ }
+
+ # get the number of lines in a file
+ my $log_line_count = $f->line_count( '/var/log/messages' );
+
+=head2 File Handles
+
+ # get an open file handle for reading
+ my $fh = $f->open_handle( 'Ian likes cats.txt' => 'read' );
+
+ while ( my $line = <$fh> ) { # read the file, line by line
+ # ... do stuff
+ }
+
+ # get an open file handle for writing the same way
+ $fh = $f->open_handle( 'John prefers dachshunds.txt' => 'write' );
+
+ # You add the option to turn on UTF-8 strict encoding for your reads/writes
+ $fh = $f->open_handle(
+ 'John prefers dachshunds.txt' => 'write' => { binmode => 'utf8' }
+ );
+
+ print $fh "Bob is happy! \N{U+263A}"; # << unicode smiley face!
+
+ # you can use sysopen to get low-level with your file handles if needed
+ $fh = $f->open_handle(
+ 'alderaan.txt' => 'rwclobber' => { use_sysopen => 1 }
+ );
+
+ syswrite $fh, "that's no moon";
+
+ # ...you can use any of these syswrite modes, also with { binmode => 'utf8' }
+ # read, write, append, rwcreate, rwclobber, rwappend, rwupdate, and trunc
+
+=head2 Directories
+
+ # get a listing of files, recursively, skipping directories
+ my @files = $f->list_dir( '/var/tmp' => { files_only => 1, recurse => 1 } );
+
+ # get a listing of text files, recursively
+ my @textfiles = $f->list_dir(
+ '/var/tmp' => {
+ files_match => qr/\.txt$/,
+ files_only => 1,
+ recurse => 1,
+ }
+ );
+
+ # walk a directory, using an anonymous function or function ref as a callback
+ $f->list_dir( '/home/larry' => {
+ recurse => 1,
+ callback => sub {
+ my ( $selfdir, $subdirs, $files ) = @_;
+ # do stuff ...
+ },
+ } );
+
+ # get an entire directory tree as a hierarchal datastructure reference
+ my $tree = $f->list_dir( '/my/podcasts' => { as_tree => 1 } );
+
+=head2 Getting Information About Files
+
+ print 'My file has a bitmask of ' . $f->bitmask( 'my.file' );
+
+ print 'My file is a ' . join(', ', $f->file_type( 'my.file' )) . " file.";
+
+ warn 'This file is binary!' if $f->is_bin( 'my.file' );
+
+ print 'My file was last modified on ' .
+ scalar localtime $f->last_modified( 'my.file' );
+
+=head2 Getting Information About Your System's IO Capabilities
+
+ # Does your running Perl support unicode?
+ print 'I support unicode' if $f->can_utf8;
+
+ # Can your system use file locking?
+ print 'I can use flock' if $f->can_flock;
+
+ # The correct directory separator for your system
+ print 'The correct directory separator for this system is ' . $f->SL;
+
+ # Does your platform require binmode for all IO?
+ print 'I always need binmode' if $f->needs_binmode;
+
+ # Is your system an EBCDIC platform? (see perldoc perlebcdic)
+ print 'This is an EBCDIC platform, so be careful!' if $f->EBCDIC;
+
+...See the L<File::Util::Manual> for more details and features like advanced
+pattern matching in directories, callbacks, directory walking, user-definable
+error handlers, and more.
+
+=head1 PERFORMANCE
+
+File::Util consists of several modules, but only loads the ones it needs when
+it needs them and also offers a comparatively fast load-up time, so using
+File::Util doesn't bloat your code footprint.
+
+Additionally, File::Util has been optimized to run fast. In many scenarios
+it does more and still out-performs other popular IO modules from anywhere
+from 100%-400%, although L<Path::Tiny> is also extremely fast at what it is
+designed to do.
+
+I<(See the benchmarking and profiling scripts>
+I<that are included as part of this distribution.)>
+
+=head1 METHODS
+
+File::Util exposes the following public methods.
+
+B<Each of which are covered in the L<File::Util::Manual>>, which has more room for
+the detailed explanation that is provided there.
+
+This is just an itemized table of contents for HTML POD readers. For those viewing
+this document in a text terminal, open perldoc to the C<File::Util::Manual>.
+
+=over
+
+=item atomize_path I<(see L<atomize_path|File::Util::Manual/atomize_path>)>
+
+=item bitmask I<(see L<bitmask|File::Util::Manual/bitmask>)>
+
+=item can_flock I<(see L<can_flock|File::Util::Manual/can_flock>)>
+
+=item can_utf8 I<(see L<can_utf8|File::Util::Manual/can_utf8>)>
+
+=item created I<(see L<created|File::Util::Manual/created>)>
+
+=item diagnostic I<(see L<diagnostic|File::Util::Manual/diagnostic>)>
+
+=item ebcdic I<(see L<ebcdic|File::Util::Manual/ebcdic>)>
+
+=item escape_filename I<(see L<escape_filename|File::Util::Manual/escape_filename>)>
+
+=item existent I<(see L<existent|File::Util::Manual/existent>)>
+
+=item file_type I<(see L<file_type|File::Util::Manual/file_type>)>
+
+=item flock_rules I<(see L<flock_rules|File::Util::Manual/flock_rules>)>
+
+=item is_bin I<(see L<is_bin|File::Util::Manual/is_bin>)>
+
+=item is_readable I<(see L<is_readable|File::Util::Manual/is_readable>)>
+
+=item is_writable I<(see L<is_writable|File::Util::Manual/is_writable>)>
+
+=item last_access I<(see L<last_access|File::Util::Manual/last_access>)>
+
+=item last_changed I<(see L<last_changed|File::Util::Manual/last_changed>)>
+
+=item last_modified I<(see L<last_modified|File::Util::Manual/last_modified>)>
+
+=item line_count I<(see L<line_count|File::Util::Manual/line_count>)>
+
+=item list_dir I<(see L<list_dir|File::Util::Manual/list_dir>)>
+
+=item load_dir I<(see L<load_dir|File::Util::Manual/load_dir>)>
+
+=item load_file I<(see L<load_file|File::Util::Manual/load_file>)>
+
+=item make_dir I<(see L<make_dir|File::Util::Manual/make_dir>)>
+
+=item abort_depth I<(see L<abort_depth|File::Util::Manual/abort_depth>)>
+
+=item needs_binmode I<(see L<needs_binmode|File::Util::Manual/needs_binmode>)>
+
+=item new I<(see L<new|File::Util::Manual/new>)>
+
+=item onfail I<(see L<onfail|File::Util::Manual/onfail>)>
+
+=item open_handle I<(see L<open_handle|File::Util::Manual/open_handle>)>
+
+=item read_limit I<(see L<read_limit|File::Util::Manual/read_limit>)>
+
+=item return_path I<(see L<return_path|File::Util::Manual/return_path>)>
+
+=item size I<(see L<size|File::Util::Manual/size>)>
+
+=item split_path I<(see L<split_path|File::Util::Manual/split_path>)>
+
+=item strip_path I<(see L<strip_path|File::Util::Manual/strip_path>)>
+
+=item touch I<(see L<touch|File::Util::Manual/touch>)>
+
+=item trunc I<(see L<trunc|File::Util::Manual/trunc>)>
+
+=item unlock_open_handle I<(see L<unlock_open_handle|File::Util::Manual/unlock_open_handle>)>
+
+=item use_flock I<(see L<use_flock|File::Util::Manual/use_flock>)>
+
+=item valid_filename I<(see L<valid_filename|File::Util::Manual/valid_filename>)>
+
+=item write_file I<(see L<write_file|File::Util::Manual/write_file>)>
+
+=back
+
+=head1 EXPORTED SYMBOLS
+
+Exports nothing by default. File::Util fully respects your namespace.
+You can, however, ask it for certain things (below).
+
+=head2 EXPORT_OK
+
+The following symbols comprise C<@File::Util::EXPORT_OK>, and as such are
+available for import to your namespace only upon request. They can be
+used either as object methods or like regular subroutines in your program.
+
+ - atomize_path - can_flock - can_utf8
+ - created - diagnostic - ebcdic
+ - escape_filename - existent - file_type
+ - is_bin - is_readable - is_writable
+ - last_access - last_changed - last_modified
+ - needs_binmode - return_path - size
+ - split_path - strip_path - valid_filename
+ - NL and S L
+
+To get any of these functions/symbols into your namespace without having
+to use them as object methods, use this kind of syntax:
+
+ use File::Util qw( strip_path return_path existent size );
+
+ my $file = $ARGV[0];
+ my $fname = strip_path( $file );
+ my $path = return_path( $file );
+ my $size = size( $file );
+
+ print qq(File "$fname" exists in "$path", and is $size bytes in size)
+ if existent( $file );
+
+=head2 EXPORT_TAGS
+
+ :all (imports all of @File::Util::EXPORT_OK to your namespace)
+
+ :diag (imports nothing to your namespace, it just enables diagnostics)
+
+You can use these tags alone, or in combination with other symbols as
+shown above.
+
+=head1 PREREQUISITES
+
+=over
+
+=item None. There are no external prerequisite modules.
+
+File::Util only depends on modules that are part of the Core Perl distribution,
+and you don't need a compiler on your system to install it.
+
+=item File::Util recommends L<Perl|perl> 5.8.1 or better ...
+
+You can technically run File::Util on older versions of Perl 5, but it isn't
+recommended, especially if you want unicode support and wish to take advantage
+of File::Util's ability to read and write files using UTF-8 encoding.
+
+=back
+
+=head1 INSTALLATION
+
+To install this module type the following at the command prompt:
+
+ perl Build.PL
+ perl Build
+ perl Build test
+ sudo perl Build install
+
+On Windows systems, the "sudo" part of the command may be omitted, but you
+will need to run the rest of the install command with Administrative privileges
+
+=head1 BUGS
+
+Send bug reports and patches to the CPAN Bug Tracker for File::Util at
+L<rt.cpan.org|https://rt.cpan.org/Dist/Display.html?Name=File%3A%3AUtil>
+
+=head1 SUPPORT
+
+If you want to get help, contact the authors (links below in AUTHORS section)
+
+I fully endorse L<http://www.perlmonks.org> as an excellent source of help
+with Perl in general.
+
+=head1 CONTRIBUTING
+
+The project website for File::Util is at
+L<https://github.com/tommybutler/file-util/wiki>
+
+The git repository for File::Util is on Github at
+L<https://github.com/tommybutler/file-util>
+
+Clone it at L<git://github.com/tommybutler/file-util.git>
+
+This project was a private endeavor for too long so don't hesitate to pitch in.
+
+=head1 CONTRIBUTORS
+
+The following people have contributed to File::Util in the form of feedback,
+encouragement, recommendations, testing, or assistance with problems either
+on or offline in one form or another. Listed in no particular order:
+
+=over
+
+=item *
+
+John Fields <jfields.cpan.org@spammenot.com>
+
+=item *
+
+BrowserUk <browseruk@cpan.org>
+
+=item *
+
+Ricardo SIGNES <rjbs@cpan.org>
+
+=item *
+
+Matt S Trout <perl-stuff@trout.me.uk>
+
+=item *
+
+Nicholas Perez <nperez@cpan.org>
+
+=item *
+
+David Golden <dagolden@cpan.org>
+
+=back
+
+=head1 AUTHORS
+
+Tommy Butler L<http://www.atrixnet.com/contact>
+
+Others Welcome!
+
+=head1 COPYRIGHT
+
+Copyright(C) 2001-2013, Tommy Butler. All rights reserved.
+
+=head1 LICENSE
+
+This library is free software, you may redistribute it and/or modify it
+under the same terms as Perl itself. For more details, see the full text of
+the LICENSE file that is included in this distribution.
+
+=head1 LIMITATION OF WARRANTY
+
+This software is distributed in the hope that it will be useful, but without
+any warranty; without even the implied warranty of merchantability or fitness
+for a particular purpose.
+
+This disclaimer applies to every part of the File::Util distribution.
+
+=head1 SEE ALSO
+
+The rest of the documentation:
+L<File::Util::Manual>, L<File::Util::Manual::Examples>, L<File::Util::Cookbook>
+
+Other Useful Modules that do similar things:
+L<File::Slurp>, L<File::Spec>, L<File::Find::Rule>, L<Path::Class>,
+L<Path::Tiny>
+
+=cut
@@ -0,0 +1,80 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Time::HiRes;
+use Benchmark::Forking qw( :all );
+
+use lib './lib';
+use lib '../lib';
+
+use File::Util;
+use File::Find::Rule;
+
+my $f = File::Util->new();
+
+# some dir with several subdirs (and .pod files preferably)
+my $dir = shift @ARGV || '.';
+
+print "\nNON-RECURSIVE\n";
+cmpthese
+ 10_000,
+ {
+ 'File::Util' => sub { $f->list_dir( $dir => { files_only => 1 } ) },
+ 'File::Find::Rule' => sub { File::Find::Rule->maxdepth(1)->file->in( $dir ) },
+ };
+
+print "\nNON-RECURSIVE WITH REGEXES\n";
+cmpthese
+ 10_000,
+ {
+ 'File::Util' => sub { $f->list_dir( $dir => { files_only => 1, files_match => qr/\.pod$/ } ) },
+ 'File::Find::Rule' => sub { File::Find::Rule->maxdepth(1)->file->name( qr/\.pod$/ )->in( $dir ) },
+ };
+
+print "\nRECURSIVE\n";
+cmpthese
+ 400,
+ {
+ 'File::Util' => sub { $f->list_dir( $dir => { recurse => 1, files_only => 1 } ) },
+ 'File::Find::Rule' => sub { File::Find::Rule->file->in( $dir ) },
+ };
+
+print "\nRECURSIVE WITH REGEXES\n";
+cmpthese
+ 400,
+ {
+ 'File::Util' => sub { $f->list_dir( $dir => { recurse => 1, files_only => 1, files_match => qr/\.pod$/ } ) },
+ 'File::Find::Rule' => sub { File::Find::Rule->file->name( qr/\.pod$/ )->in( $dir ) },
+ };
+
+__END__
+
+----------------------------------------------------------------------
+Mon Feb 25 12:30:03 CST 2013
+----------------------------------------------------------------------
+TEST - 1045 files, 32 directories varying from one to 4 levels deep
+----------------------------------------------------------------------
+
+NON-RECURSIVE
+ Rate File::Find::Rule File::Util
+File::Find::Rule 2128/s -- -80%
+File::Util 10753/s 405% --
+
+NON-RECURSIVE WITH REGEXES
+ Rate File::Find::Rule File::Util
+File::Find::Rule 2375/s -- -70%
+File::Util 7937/s 234% --
+
+RECURSIVE
+ Rate File::Find::Rule File::Util
+File::Find::Rule 72.2/s -- -55%
+File::Util 160/s 122% --
+
+RECURSIVE WITH REGEXES
+ Rate File::Find::Rule File::Util
+File::Find::Rule 87.9/s -- -42%
+File::Util 153/s 74% --
+
+
@@ -0,0 +1,52 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use lib './lib';
+use lib '../lib';
+
+BEGIN {
+
+use Benchmark::Forking qw( :all );
+
+cmpthese
+ 50_000_000,
+ {
+ 'File::Util' => sub { eval {require File::Util} },
+ 'File::Spec' => sub { eval {require File::Spec} },
+ 'Path::Tiny' => sub { eval {require Path::Tiny} },
+ 'Path::Class' => sub { eval {require Path::Class} },
+ 'File::Slurp' => sub { eval {require File::Slurp} },
+ 'File::Find' => sub { eval {require File::Find} },
+ 'File::Find::Rule' => sub { eval {require File::Find::Rule} },
+ 'Moose' => sub { eval {require Moose} },
+ };
+}
+
+__END__
+
+BARE EVAL IN RUNTIME
+
+ Rate Moose File::Find::Rule Path::Tiny Path::Class File::Slurp File::Spec File::Find File::Util
+Moose 5102041/s -- -2% -3% -7% -10% -11% -11% -13%
+File::Find::Rule 5208333/s 2% -- -1% -5% -8% -9% -9% -11%
+Path::Tiny 5263158/s 3% 1% -- -4% -7% -8% -8% -11%
+Path::Class 5494505/s 8% 5% 4% -- -3% -4% -4% -7%
+File::Slurp 5681818/s 11% 9% 8% 3% -- -1% -1% -3%
+File::Spec 5747126/s 13% 10% 9% 5% 1% -- 0% -2%
+File::Find 5747126/s 13% 10% 9% 5% 1% 0% -- -2%
+File::Util 5882353/s 15% 13% 12% 7% 4% 2% 2% --
+
+
+BARE EVAL IN COMPILE STAGE
+
+ Rate File::Find::Rule File::Slurp File::Find Path::Class File::Spec File::Util Path::Tiny Moose
+File::Find::Rule 5138746/s -- -8% -9% -9% -9% -11% -12% -16%
+File::Slurp 5561735/s 8% -- -1% -1% -2% -4% -5% -9%
+File::Find 5624297/s 9% 1% -- -0% -0% -2% -4% -8%
+Path::Class 5643341/s 10% 1% 0% -- -0% -2% -3% -7%
+File::Spec 5649718/s 10% 2% 0% 0% -- -2% -3% -7%
+File::Util 5767013/s 12% 4% 3% 2% 2% -- -1% -5%
+Path::Tiny 5841121/s 14% 5% 4% 4% 3% 1% -- -4%
+Moose 6097561/s 19% 10% 8% 8% 8% 6% 4% --
@@ -0,0 +1,22 @@
+#!/usr/bin/perl
+
+# perl -d:NYTProf performance/profile_listdir.pl
+
+use strict;
+use warnings;
+
+use lib './lib';
+use lib '../lib';
+
+use File::Util;
+
+my $f = File::Util->new();
+my $dir = shift @ARGV || '.';
+
+for ( 0 .. 99 )
+{
+ $f->list_dir( $dir => { recurse => 1, files_only => 1, files_match => qr/\.pod$/ } );
+}
+
+__END__
+
@@ -0,0 +1,28 @@
+#!/usr/bin/perl
+
+# perl -d:NYTProf misc/profile_listdir_vs_file-find-rule.pl
+
+use strict;
+use warnings;
+
+use lib './lib';
+use lib '../lib';
+
+use File::Util;
+use File::Find::Rule;
+
+my $f = File::Util->new();
+
+# some dir with several subdirs (and .pod files preferably)
+my $dir = shift @ARGV || '.';
+
+for ( 1 .. 100 ) {
+
+ print "$_\n";
+
+ $f->list_dir( $dir => { recurse => 1, files_only => 1, files_match => qr/\.pod/ } );
+
+ File::Find::Rule->file->name( qr/\.pod$/ )->in( $dir );
+}
+
+exit;
@@ -0,0 +1,14 @@
+severity = 5
+verbose = 8
+
+[Variables::ProhibitPunctuationVars]
+allow = $@ $!
+
+[TestingAndDebugging::ProhibitNoStrict]
+allow = refs
+
+# Turn these off
+[-BuiltinFunctions::ProhibitStringyEval]
+
+# Turn this on
+[Lax::ProhibitStringyEval::ExceptForRequire]
@@ -0,0 +1,74 @@
+#!perl
+
+use strict;
+use warnings;
+
+use Test::More;
+
+
+
+use File::Find;
+use File::Temp qw{ tempdir };
+
+my @modules;
+find(
+ sub {
+ return if $File::Find::name !~ /\.pm\z/;
+ my $found = $File::Find::name;
+ $found =~ s{^lib/}{};
+ $found =~ s{[/\\]}{::}g;
+ $found =~ s/\.pm$//;
+ # nothing to skip
+ push @modules, $found;
+ },
+ 'lib',
+);
+
+sub _find_scripts {
+ my $dir = shift @_;
+
+ my @found_scripts = ();
+ find(
+ sub {
+ return unless -f;
+ my $found = $File::Find::name;
+ # nothing to skip
+ open my $FH, '<', $_ or do {
+ note( "Unable to open $found in ( $! ), skipping" );
+ return;
+ };
+ my $shebang = <$FH>;
+ return unless $shebang =~ /^#!.*?\bperl\b\s*$/;
+ push @found_scripts, $found;
+ },
+ $dir,
+ );
+
+ return @found_scripts;
+}
+
+my @scripts;
+do { push @scripts, _find_scripts($_) if -d $_ }
+ for qw{ bin script scripts };
+
+my $plan = scalar(@modules) + scalar(@scripts);
+$plan ? (plan tests => $plan) : (plan skip_all => "no tests to run");
+
+{
+ # fake home for cpan-testers
+ # no fake requested ## local $ENV{HOME} = tempdir( CLEANUP => 1 );
+
+ like( qx{ $^X -Ilib -e "require $_; print '$_ ok'" }, qr/^\s*$_ ok/s, "$_ loaded ok" )
+ for sort @modules;
+
+ SKIP: {
+ eval "use Test::Script 1.05; 1;";
+ skip "Test::Script needed to test script compilation", scalar(@scripts) if $@;
+ foreach my $file ( @scripts ) {
+ my $script = $file;
+ $script =~ s!.*/!!;
+ script_compiles( $file, "$script script compiles" );
+ }
+ }
+
+}
@@ -0,0 +1,100 @@
+use strict;
+use warnings;
+use Test::More 0.88;
+# This is a relatively nice way to avoid Test::NoWarnings breaking our
+# expectations by adding extra tests, without using no_plan. It also helps
+# avoid any other test module that feels introducing random tests, or even
+# test plans, is a nice idea.
+our $success = 0;
+END { $success && done_testing; }
+
+# List our own version used to generate this
+my $v = "\nGenerated by Dist::Zilla::Plugin::ReportVersions::Tiny v1.08\n";
+
+eval { # no excuses!
+ # report our Perl details
+ my $want = '5.008001';
+ $v .= "perl: $] (wanted $want) on $^O from $^X\n\n";
+};
+defined($@) and diag("$@");
+
+# Now, our module version dependencies:
+sub pmver {
+ my ($module, $wanted) = @_;
+ $wanted = " (want $wanted)";
+ my $pmver;
+ eval "require $module;";
+ if ($@) {
+ if ($@ =~ m/Can't locate .* in \@INC/) {
+ $pmver = 'module not found.';
+ } else {
+ diag("${module}: $@");
+ $pmver = 'died during require.';
+ }
+ } else {
+ my $version;
+ eval { $version = $module->VERSION; };
+ if ($@) {
+ diag("${module}: $@");
+ $pmver = 'died during VERSION check.';
+ } elsif (defined $version) {
+ $pmver = "$version";
+ } else {
+ $pmver = '<undef>';
+ }
+ }
+
+ # So, we should be good, right?
+ return sprintf('%-45s => %-10s%-15s%s', $module, $pmver, $wanted, "\n");
+}
+
+eval { $v .= pmver('AutoLoader','any version') };
+eval { $v .= pmver('Config','any version') };
+eval { $v .= pmver('Cwd','any version') };
+eval { $v .= pmver('Devel::Cover','any version') };
+eval { $v .= pmver('Dist::Zilla','any version') };
+eval { $v .= pmver('Exporter','any version') };
+eval { $v .= pmver('ExtUtils::MakeMaker','6.30') };
+eval { $v .= pmver('Fcntl','any version') };
+eval { $v .= pmver('File::Find','any version') };
+eval { $v .= pmver('File::Temp','any version') };
+eval { $v .= pmver('Module::Build','0.3601') };
+eval { $v .= pmver('Perl::Critic','any version') };
+eval { $v .= pmver('Perl::Critic::Lax','any version') };
+eval { $v .= pmver('Pod::Coverage::TrustPod','any version') };
+eval { $v .= pmver('Scalar::Util','any version') };
+eval { $v .= pmver('Test','any version') };
+eval { $v .= pmver('Test::CPAN::Changes','0.19') };
+eval { $v .= pmver('Test::CPAN::Meta','any version') };
+eval { $v .= pmver('Test::Fatal','any version') };
+eval { $v .= pmver('Test::More','0.88') };
+eval { $v .= pmver('Test::NoWarnings','any version') };
+eval { $v .= pmver('Test::Pod','1.41') };
+eval { $v .= pmver('Test::Pod::Coverage','1.08') };
+eval { $v .= pmver('Unicode::UTF8','0.58') };
+eval { $v .= pmver('constant','any version') };
+eval { $v .= pmver('strict','any version') };
+eval { $v .= pmver('subs','any version') };
+eval { $v .= pmver('utf8','any version') };
+eval { $v .= pmver('vars','any version') };
+eval { $v .= pmver('version','0.9901') };
+eval { $v .= pmver('warnings','any version') };
+
+
+# All done.
+$v .= <<'EOT';
+
+Thanks for using my code. I hope it works for you.
+If not, please try and include this output in the bug report.
+That will help me reproduce the issue and solve your problem.
+
+EOT
+
+diag($v);
+ok(1, "we really didn't test anything, just reporting data");
+$success = 1;
+
+# Work around another nasty module on CPAN. :/
+no warnings 'once';
+$Template::Test::NO_FLUSH = 1;
+exit 0;
@@ -1,15 +1,18 @@
use strict;
-use Test;
+use warnings;
-# use a BEGIN block so we print our plan before MyModule is loaded
-BEGIN { plan tests => 1, todo => [] }
+use Test::More tests => 2;
+use Test::NoWarnings;
-# load your module...
-use lib './';
+use lib './lib';
use File::Util;
# check object constructor
-ok(ref(File::Util->new()),'File::Util');
+ok
+(
+ ref File::Util->new() eq 'File::Util',
+ 'New bare File::Util instantiation'
+);
-exit;
\ No newline at end of file
+exit;
@@ -1,19 +1,20 @@
use strict;
-use Test;
+use warnings;
-# use a BEGIN block so we print our plan before MyModule is loaded
-BEGIN { plan tests => 2, todo => [] }
-BEGIN { $| = 1 }
+use Test::More tests => 2;
+use Test::NoWarnings;
-# load your module...
-use lib './';
+use lib './lib';
use File::Util;
-my($f) = File::Util->new();
+my $ftl = File::Util->new();
# check to see if File::Util ISA [foo, etc.]
-ok(UNIVERSAL::isa($f,'File::Util'));
-ok(UNIVERSAL::isa($f,'Class::OOorNO'));
+ok
+(
+ UNIVERSAL::isa( $ftl, 'File::Util' ),
+ 'ISA File::Util bless matches namespace'
+);
-exit;
\ No newline at end of file
+exit;
@@ -1,35 +1,37 @@
use strict;
-use Test;
+use warnings;
-# use a BEGIN block so we print our plan before MyModule is loaded
-BEGIN { plan tests => 37, todo => [] }
-BEGIN { $| = 1 }
+use Test::More tests => 41;
+use Test::NoWarnings;
# load your module...
-use lib './';
+use lib './lib';
use File::Util;
-my($f) = File::Util->new();
+my $ftl = File::Util->new();
# check to see if non-autoloaded File::Util methods are can-able ;O)
-map { ok(ref(UNIVERSAL::can($f,$_)),'CODE') } qw
+map { ok( ref( $ftl->can( $_ ) ) eq 'CODE', "can $_" ) } qw
(
_dropdots
- _errors
_release
_seize
- _throw
+ atomize_path
bitmask
can_flock
can_read
can_write
created
+ diagnostic
ebcdic
escape_filename
existent
file_type
isbin
+ is_bin
+ is_readable
+ is_writable
last_access
last_modified
line_count
@@ -38,11 +40,12 @@ map { ok(ref(UNIVERSAL::can($f,$_)),'CODE') } qw
load_file
flock_rules
make_dir
- max_dives
+ abort_depth
needs_binmode
new
open_handle
readlimit
+ read_limit
size
strip_path
trunc
@@ -51,7 +54,6 @@ map { ok(ref(UNIVERSAL::can($f,$_)),'CODE') } qw
valid_filename
VERSION
DESTROY
- AUTOLOAD
);
exit;
@@ -1,106 +1,103 @@
use strict;
-use Test;
+use warnings;
-# use a BEGIN block so we print our plan before MyModule is loaded
-BEGIN { plan tests => 46, todo => [] }
-BEGIN { $| = 1 }
+use Test::More tests => 50;
+use Test::NoWarnings;
+
+use lib './lib';
-# load your module...
-use lib './';
use File::Util qw
- (
- SL NL escape_filename
- valid_filename strip_path needs_binmode
- );
+(
+ SL NL escape_filename ebcdic
+ valid_filename strip_path needs_binmode
+);
-my($f) = File::Util->new();
+my $f = File::Util->new();
# check asignability
-my($NL) = NL; my($SL) = SL;
+my $NL = NL; my $SL = SL;
# newlines
-ok(NL eq $NL); # test 1
-
-# binmode necessary?
-ok(needs_binmode, NL eq qq[\015\012] ? 1 : 0); # test 2
+ok NL eq $NL, 'NL constant matches variable';
# path seperator
-ok(SL eq $SL); # test 3
+ok SL eq $SL, 'SL constant matches variable';
# test file escaping with substitute escape char
# with additional char to escape as well.
-ok # test 4
- (
- escape_filename(q[./foo/bar/baz.t/], '+','.'),
- '++foo+bar+baz+t+'
- );
+ok escape_filename( q[./foo/bar/baz.t/], '+', '.' ) eq '++foo+bar+baz+t+',
+ 'escaped filename with custom escape';
# test file escaping with defaults
-ok # test 5
- (
- escape_filename(q[.\foo\bar\baz.t]),
- '._foo_bar_baz.t'
- );
-
-# test file escaping with option "--strip-path"
-ok # test 6
- (
- escape_filename
- (
- q[.:foo:bar:baz.t],
- '--strip-path'
- ),
- 'baz.t'
- );
+ok escape_filename(q[.\foo\bar\baz.t]) eq '._foo_bar_baz.t',
+ 'escaped filename with defaults';
# path stripping in general
-ok(strip_path(__FILE__),'004_portable.t'); # test 7
+is strip_path(__FILE__), '004_portable.t', 'stripped path to this file OK';
+is strip_path('C:\foo'), 'foo', 'stripped path to abs win path OK';
+is strip_path('C:\foo\bar\baz.txt'), 'baz.txt',
+ 'stripped path to deeper abs win path OK';
# illegal filename character intolerance
-ok(!valid_filename(qq[?foo])); # question mark
-ok(!valid_filename(qq[>foo])); # greater than
-ok(!valid_filename(qq[<foo])); # less than
-ok(!valid_filename(qq[<foo])); # less than
-ok(!valid_filename(qq[<foo])); # less than
-ok(!valid_filename(qq[<foo])); # less than
-ok(!valid_filename(qq[:foo])); # colon
-ok(!valid_filename(qq[*foo])); # asterisk
-ok(!valid_filename(qq[/foo])); # forward slash
-ok(!valid_filename(qq[\\foo])); # back slash
-ok(!valid_filename(qq["foo])); # double quotation mark
-ok(!valid_filename(qq[\tfoo])); # tab
-ok(!valid_filename(qq[\013foo])); # vertical tab
-ok(!valid_filename(qq[\012foo])); # newline
-ok(!valid_filename(qq[\015foo])); # form feed
+ok !valid_filename(qq[?foo]), qq[?foo is NOT a valid filename];
+ok !valid_filename(qq[>foo]), qq[>foo is NOT a valid filename];
+ok !valid_filename(qq[<foo]), qq[<foo is NOT a valid filename];
+ok !valid_filename(qq[<foo]), qq[<foo is NOT a valid filename];
+ok !valid_filename(qq[<foo]), qq[<foo is NOT a valid filename];
+ok !valid_filename(qq[<foo]), qq[<foo is NOT a valid filename];
+ok !valid_filename(qq[:foo]), qq[:foo is NOT a valid filename];
+ok !valid_filename(qq[*foo]), qq[*foo is NOT a valid filename];
+ok !valid_filename(qq[/foo]), qq[/foo is NOT a valid filename];
+ok !valid_filename(qq[\\foo]), qq[\\foo is NOT a valid filename];
+ok !valid_filename(qq["foo]), qq["foo is NOT a valid filename];
+ok !valid_filename(qq[\tfoo]), qq[\\tfoo is NOT a valid filename];
+ok !valid_filename(qq[\013foo]), qq[\\013foo is NOT a valid filename];
+ok !valid_filename(qq[\012foo]), qq[\\012foo is NOT a valid filename];
+ok !valid_filename(qq[\015foo]), qq[\\015foo is NOT a valid filename];
# strange but legal filename character tolerance
-ok(valid_filename(q['foo]));
-ok(valid_filename(';foo'));
-ok(valid_filename('$foo'));
-ok(valid_filename('%foo'));
-ok(valid_filename('`foo'));
-ok(valid_filename('!foo'));
-ok(valid_filename('@foo'));
-ok(valid_filename('#foo'));
-ok(valid_filename('^foo'));
-ok(valid_filename('&foo'));
-ok(valid_filename('-foo'));
-ok(valid_filename('_foo'));
-ok(valid_filename('+foo'));
-ok(valid_filename('=foo'));
-ok(valid_filename('(foo'));
-ok(valid_filename(')foo'));
-ok(valid_filename('{foo'));
-ok(valid_filename('}foo'));
-ok(valid_filename('[foo'));
-ok(valid_filename(']foo'));
-ok(valid_filename('~foo'));
-ok(valid_filename('.foo'));
-ok(valid_filename(q/;$%`!@#^&-_+=(){}[]~baz.foo'/));
+ok valid_filename(q['foo]), q['foo is a valid filename] ;
+ok valid_filename(';foo'), ';foo is a valid filename' ;
+ok valid_filename('$foo'), '$foo is a valid filename' ;
+ok valid_filename('%foo'), '%foo is a valid filename' ;
+ok valid_filename('`foo'), '`foo is a valid filename' ;
+ok valid_filename('!foo'), '!foo is a valid filename' ;
+ok valid_filename('@foo'), '@foo is a valid filename' ;
+ok valid_filename('#foo'), '#foo is a valid filename' ;
+ok valid_filename('^foo'), '^foo is a valid filename' ;
+ok valid_filename('&foo'), '&foo is a valid filename' ;
+ok valid_filename('-foo'), '-foo is a valid filename' ;
+ok valid_filename('_foo'), '_foo is a valid filename' ;
+ok valid_filename('+foo'), '+foo is a valid filename' ;
+ok valid_filename('=foo'), '=foo is a valid filename' ;
+ok valid_filename('(foo'), '(foo is a valid filename' ;
+ok valid_filename(')foo'), ')foo is a valid filename' ;
+ok valid_filename('{foo'), '{foo is a valid filename' ;
+ok valid_filename('}foo'), '}foo is a valid filename' ;
+ok valid_filename('[foo'), '[foo is a valid filename' ;
+ok valid_filename(']foo'), ']foo is a valid filename' ;
+ok valid_filename('~foo'), '~foo is a valid filename' ;
+ok valid_filename('.foo'), '.foo is a valid filename' ;
+ok valid_filename( q/;$%`!@#^&-_+=(){}[]~baz.foo'/ ),
+ q/;$%`!@#^&-_+=(){}[]~baz.foo' is a valid filename/;
+
+ok valid_filename('C:\foo'), 'C:\foo is a valid filename';
+
+# these tests are here for coverage purposes. Since they are more or less
+# constants, based only on the host OS, there's no point in testing them
+# against anything other than the testing File::Util already did in order
+# to determine the values of these constants. We just test to make sure
+# the value is either 1 or 0
+ok needs_binmode =~ /^[10]$/, 'needs_binmode is 1 or 0';
+ok ebcdic =~ /^[10]$/, 'ebcdic is 1 or 0';
# directory listing tests...
# remove '.' and '..' directory entries
-ok(length(join('',$f->_dropdots(qw(. .. foo bar baz)))),9);
+ok( sub{
+ ( $f->_dropdots( qw/. .. foo/ ) )[0] eq 'foo'
+ ? 'dots removed'
+ : 'failed to remove dots'
+}->() eq 'dots removed', 'removed fsdots OK' );
exit;
@@ -1,57 +1,83 @@
use strict;
-use Test;
+use warnings;
+use Test::More tests => 36;
+use Test::NoWarnings;
-# use a BEGIN block so we print our plan before MyModule is loaded
-BEGIN { plan tests => 35, todo => [] }
-BEGIN { $| = 1 }
-
-# load your module...
-use lib './';
+use lib './lib';
use File::Util qw( SL OS );
-my($f) = File::Util->new();
+my $f = File::Util->new();
-my(@fls) = ( qq[t${\SL}txt], qq[t${\SL}bin], 't', '.', '..' );
-my($skip) = (OS eq 'WINDOWS') ? 'Running on window$' : 0;
+my @fls = ( qq[t${\SL}txt], qq[t${\SL}bin], 't', '.', '..' );
# types
-ok(join('',@{[$f->file_type($fls[0])]}), 'PLAINTEXT');
-ok(join('',@{[$f->file_type($fls[1])]}), 'PLAINBINARY');
-
-# skip if windows
-skip($skip, join('',@{[$f->file_type($fls[2])]}), 'BINARYDIRECTORY', $skip);
-skip($skip, join('',@{[$f->file_type($fls[3])]}), 'BINARYDIRECTORY', $skip);
-skip($skip, join('',@{[$f->file_type($fls[4])]}), 'BINARYDIRECTORY', $skip);
-
-# chk these on windows
-skip(!$skip, join('',@{[$f->file_type($fls[2])]}), 'DIRECTORY');
-skip(!$skip, join('',@{[$f->file_type($fls[3])]}), 'DIRECTORY');
-skip(!$skip, join('',@{[$f->file_type($fls[4])]}), 'DIRECTORY');
+is_deeply
+ [ $f->file_type( $fls[0] ) ],
+ [ qw( PLAIN TEXT ) ],
+ 'text file detected as PLAIN TEXT OK';
+is_deeply
+ [ $f->file_type( $fls[1] ) ],
+ [ qw( PLAIN BINARY ) ],
+ 'bin file detected as PLAIN BINARY OK';
# file is/isn't binary
-ok($f->isbin($fls[1], 1));
-ok(!$f->isbin(__FILE__));
+ok $f->is_bin( $fls[1], 1 ), 'detects binary file is binary';
+ok !$f->is_bin( __FILE__ ), 'detects source file is NOT binary';
-foreach (@fls) {
-
- my($file) = $_;
+for my $file ( @fls ) {
# get file size
- ok($f->size($file), -s $file);
+ ok $f->size( $file ) == -s $file,
+ 'File::Util correctly calculates a file\'s size';
# get file creation time
- ok($f->created($file),$^T - ((-M $file) * 60 * 60 * 24));
+ ok $f->created( $file ) == $^T - ((-M $file) * 60 * 60 * 24),
+ 'and gets correct file creation time OK';
# get file last access time
- ok($f->last_access($file),$^T - ((-A $file) * 60 * 60 * 24));
+ ok $f->last_access( $file ) == $^T - ((-A $file) * 60 * 60 * 24),
+ 'and gets last access time OK';
# get file last modified time
- ok($f->last_modified($file),$^T - ((-M $file) * 60 * 60 * 24));
+ ok $f->last_modified( $file ) == $^T - ((-M $file) * 60 * 60 * 24),
+ 'and gets lastmod time OK';
# get file's bitmask
- ok($f->bitmask($file),sprintf('%04o',(stat($file))[2] & 0777));
+ ok $f->bitmask( $file ) eq sprintf('%04o',(stat($file))[2] & 0777),
+ 'and gets bitmask OK';
+}
+
+SKIP: {
+ skip 'these tests not performed on window$', 3 if OS eq 'WINDOWS';
+
+ is_deeply
+ [ $f->file_type( $fls[2] ) ],
+ [ qw( BINARY DIRECTORY ) ],
+ 'detects directory filetype OK';
+
+ is_deeply
+ [ $f->file_type( $fls[3] ) ],
+ [ qw( BINARY DIRECTORY ) ],
+ 'detects directory filetype OK';
+
+ is_deeply
+ [ $f->file_type( $fls[4] ) ],
+ [ qw( BINARY DIRECTORY ) ],
+ 'detects directory filetype OK';
}
+is +( $f->file_type( $fls[2] ) )[-1],
+ 'DIRECTORY',
+ 'detects file is a directory OK';
+
+is +( $f->file_type( $fls[3] ) )[-1],
+ 'DIRECTORY',
+ 'detects file is a directory OK';
+
+is +( $f->file_type( $fls[4] ) )[-1],
+ 'DIRECTORY',
+ 'detects file is a directory OK';
+
exit;
@@ -1,150 +1,156 @@
use strict;
-use Test;
-
-# use a BEGIN block so we print our plan before File::Util is loaded
-BEGIN { plan tests => 13, todo => [] }
-BEGIN { $| = 1 }
-
-# load your module...
-use lib './';
-use File::Util qw( SL NL existent );
-
-my($f) = File::Util->new('--fatals-as-status');
-my($fh) = undef;
-my($testbed) = 't' . SL . $$;
-my($skip) = !$f->can_write('.') ||
- !$f->can_write('t');
-
-$skip = $skip ? &skipmsg() : $skip;
-
-sub skipmsg { <<'__WHYSKIP__' }
-Insufficient permissions to perform IO in this directory. Can't perform tests!
-__WHYSKIP__
-
-# 1
-# make a temporary testbed directory
-skip($skip, sub { $f->make_dir($testbed, '--if-not-exists') }, $testbed);
-
-# 2
-# see if it's there
-skip($skip, -e $testbed, 1, $skip);
-
-# 3
-# ...again
-skip($skip, sub { $f->existent($testbed) }, 1, $skip);
-
-# 4
-# make a temporary file
-my($tmpf) = $testbed . SL . 'tmptst';
-skip(
- $skip,
- sub {
- $f->write_file('file' => $tmpf, 'content' => $$ . NL),
- }, 1, $skip
-);
-
-# 5
-# File::Util::touch() a file, and see if it was created ok
-skip(
- $skip,
- sub {
- my($tmpf) = $testbed . SL . 'touched';
- $f->touch($tmpf);
- my($return) = $f->existent($tmpf);
- unlink($tmpf);
- return($return);
- }, 1, $skip
-);
-
-# 6
-# get an open file handle
-$fh = '';
-skip(
- $skip,
- sub {
- $fh = $f->open_handle(
- 'file' => $tmpf,
- 'mode' => 'append',
- qw(--fatals-as-errmsg --warn-also)
- );
- $skip = &skipmsg() unless ($fh && length($fh) > 1);
- return 1; # stupid solaris testers won't play fair
- },
- 1,
- $skip
-);
-
-# 7
-# make sure it's still open
-skip($skip, eval(q{fileno($fh)}), '/^\d/', $skip);
-
-# write to it, close it, write to it in append mode
-unless ($skip) { print( $fh 'Hello world!' . NL ); close($fh); }
-
-# 8
-# load file
-skip($skip, sub { $f->load_file($tmpf),$f->load_file($tmpf) });
-
-# 9
-# write to it with method File::Util::write_file(), compare file contents
-# with the returned value
-skip (
- $skip,
- sub {
- $f->write_file(
- 'filename' => $tmpf,
- 'content' => ( $^O || 'foo' ) . NL,
- 'mode' => 'append',
- )
- }, 1, $skip
-);
-
-# 10
-# get line count of file
-skip($skip, sub { $f->line_count($tmpf) }, 3, $skip);
-
-# 11
-# truncate file
-skip($skip, sub { $f->trunc($tmpf); -s $tmpf }, 0, $skip);
-
-# 12
-# get line count of file
-skip($skip, sub { $f->line_count($tmpf)}, 0, $skip);
-
-# big directory creation / removal sequence
-my($newdir) =
- $testbed
- . SL . int(rand(time))
- . SL . int(rand(time))
- . SL . int(rand(time))
- . SL . int(rand(time));
-
-# 13
-# make directories
-skip($skip, sub { $f->make_dir($newdir, '--if-not-exists') }, $newdir, $skip);
-
-# read directories
-unless ($skip) {
- my(@items) = $f->list_dir($testbed, '--follow');
-
- # remove directories, temp file, testbed.
- foreach (reverse(sort({ length($a) <=> length($b) } @items)), $testbed) {
-
- -d $_ ? rmdir($_) || &_rmdie($!) : unlink($_) || &_uldie($!);
- }
+use warnings;
+use Test::More tests => 17;
+use Test::NoWarnings;
+
+use File::Temp qw( tempdir );
+
+use lib './lib';
+use File::Util qw( SL NL existent OS );
+
+my $f = File::Util->new();
+my $tempdir = tempdir( CLEANUP => 1 );
+my $testbed = $tempdir . SL . $$ . SL . time;
+my $tmpf = $testbed . SL . 'tmptest';
+my $have_perms = $f->is_writable( $tempdir );
+my $testfh;
+
+SKIP: {
+
+ if ( !$have_perms ) {
+
+ skip 'Insufficient permissions to perform IO in tempdir' => 16;
+ }
+ elsif ( !solaris_cooperates() ) {
+
+ skip 'Testing with an incooperative Solaris installation' => 16;
+ }
+
+ is $f->is_readable( $tempdir ),
+ -r '.',
+ 'File::Util can tell if something is readable';
+
+ is $f->is_writable( $tempdir ),
+ -w '.',
+ 'File::Util can tell if something is writable';
+
+ # this method "just is"... there's nothing to test; here for test coverage
+ is $f->last_changed( $tempdir ),
+ $f->last_changed( $tempdir ),
+ 'File::Util can tell when a file was last changed';
+
+ # make a temporary testbed directory
+ is $f->make_dir( $testbed => { if_not_exists => 1 } ),
+ $testbed,
+ "make temp testbed in $testbed";
+
+ # see if it's there
+ is -e $testbed, 1, 'testbed created OK';
+
+ # ...again
+ is $f->existent( $testbed ), 1, 'File::Util agrees it exists';
+
+ # make a temporary file
+ is $f->write_file( file => $tmpf, content => 'LARRY' ), 1,
+ 'write to a new text file' ;
+
+ # File::Util::touch() a file, and see if it was created ok
+ is(
+ sub {
+ my $tmpf = $testbed . SL . 'touched';
+
+ $f->touch( $tmpf );
+
+ my $result = $f->existent( $tmpf );
+
+ unlink $tmpf;
+
+ return $result;
+ }->(), 1, 'create an empty file via File::Util::touch()'
+ );
+
+ # get an open file handle
+ is(
+ sub {
+ $testfh = $f->open_handle(
+ file => $tmpf,
+ mode => 'append',
+ onfail => 'message',
+ warn_also => 1,
+ );
+
+ return ref $testfh
+ }->(), 'GLOB', 'get open file handle for appending'
+ );
+
+ # make sure it's still open
+ ok defined fileno $testfh, 'check if it has a fileno';
+
+ # write to it, close it, write to it in append mode
+ print $testfh 'WALL' and close $testfh;
+
+ # load file
+ is $f->load_file( $tmpf ), 'LARRYWALL', 'wrote to file OK';
+
+ # write to it with method File::Util::write_file(), compare file contents
+ # with the returned value
+ is(
+ sub {
+ $f->trunc( $tmpf ); # again, a solaris workaround
+
+ $f->write_file(
+ filename => $tmpf,
+ content => OS . NL
+ );
+
+ return $f->load_file( $tmpf );
+ }->(), OS . NL, 'write to a file with File::Util->write_file'
+ );
+
+ # get line count of file
+ is $f->line_count( $tmpf ), 1, 'line count of new file is right';
+
+ # truncate file
+ is sub { $f->trunc( $tmpf ); return -s $tmpf }->(), 0,
+ 'truncate file, then make sure it is zero bytes';
+
+ # get line count of file
+ is $f->line_count( $tmpf ), 0, 'truncated file linecount is zero';
+
+ # big directory creation / removal sequence
+ my $newdir = $testbed
+ . SL . int( rand time )
+ . SL . int( rand time )
+ . SL . int( rand time )
+ . SL . int( rand time );
+
+ # 13
+ # make directories
+ is $f->make_dir( $newdir, '--if-not-exists' ),
+ $newdir, 'make a deep directory tree';
}
exit;
-# ---- SUBS -----------------------------------------------
+sub solaris_cooperates {
+
+ # we're only probing for solaris here, which has known issues
+ return 1 if $^O !~ /solaris|sunos/i;
+
+ my $tmpf = $tempdir . SL . 'solaris';
+
+ my $sf = File::Util->new( fatals_as_status => 1 );
+
+ my $fh = $sf->open_handle( file => $tmpf );
-sub _uldie { die(<<__BADUNLINK__) }
-Can't unlink recently created temp file used in testing process.
-$!
-__BADUNLINK__
+ my $ok = fileno $fh ? 1 : 0;
-sub _rmdie { die(<<__BADRMDIR__) }
-Can't remove recently created temporary directory used in testing process.
-$!
-__BADRMDIR__
+ close $fh if $ok;
+
+ unlink $tmpf if $ok;
+
+ $f->use_flock(0); # solaris flock is so broken, it might as well not exist
+
+ return $ok;
+}
@@ -1,121 +1,108 @@
use strict;
-use Test;
+use warnings;
+use Test::More tests => 10;
+use Test::NoWarnings;
-# use a BEGIN block so we print our plan before MyModule is loaded
-BEGIN { plan tests => 12, todo => [] }
-BEGIN { $| = 1 }
-
-# load your module...
-use lib './';
use Fcntl qw( );
+use File::Temp qw( tmpnam );
-use File::Util qw( SL NL );
-my($f) = File::Util->new();
-my($tmpf) = 'flock_test';
-my($probe_flock) = sub { local($@); eval(<<'__canflock__'); $@ ? 0 : 1 };
-flock(STDIN, &Fcntl::LOCK_SH);
-flock(STDIN, &Fcntl::LOCK_UN);
-__canflock__
-my($skip) = !$f->can_write('.') || !$f->can_write('t');
-
-$skip = $skip ? &skipmsg() : $skip;
+use lib './lib';
+use File::Util qw( SL NL OS );
-# using flock? get/set flock-ing usage toggle
-ok($f->use_flock( ),1); # test 1
-ok($f->use_flock(1),1); # test 2
-ok($f->use_flock(0),0); # test 3
-ok($f->use_flock( ),0); # test 4
-ok($f->use_flock(1),1); # test 5
+my $f = File::Util->new( { onfail => 'zero' } );
-# get/set flock-ing failure policy
-ok(qq[@{[$f->flock_rules()]}],'NOBLOCKEX FAIL'); # test 6
-ok(join(' ', $f->flock_rules(qw/ NOBLOCKEX ZERO /)),q[NOBLOCKEX ZERO]);# test 7
+my ( $tfh, $tmpf ) = tmpnam();
-# can the system lock file IO? does it?
-skip(!$probe_flock, $f->can_flock, 1); # test 8
+close $tfh; # I didn't want it opened!
+unlink $tmpf; # ^^ our auto-flock won't work on duped FH
-# does it really work?
-skip(!$probe_flock, &test_flock()); # test 9
+my $have_flock = sub {
-exit;
-
-# put flock to the "test"
-sub test_flock {
+ local $@;
- # lock file, keep open handle on it
- my($fh);
+ eval {
+ flock( STDIN, &Fcntl::LOCK_SH );
+ flock( STDIN, &Fcntl::LOCK_UN );
+ };
- unless ($skip) {
- $fh = $f->open_handle('file' => $tmpf);
+ return $@ ? 0 : 1;
+}->();
- # write something into the file
- my($tstr) = 'Hello world!' . NL;
- print($fh $tstr x 50);
+my $have_perms = $f->is_writable( $f->return_path( $tmpf ) );
- }
+SKIP: {
- # try to $f->trunc locked file (should fail)
- skip(
- $skip,
- sub { # test 10
+ if ( !$have_flock ) {
- # FORKING!!
- my($pid) = fork; $| = 1; die(qq{Can't fork: $!}) unless defined($pid);
-
- if (!$pid) { $f->trunc($tmpf); exit } else { waitpid($pid, 0) }
-
- # DONE WITH THAT NOW.
- -s $tmpf
- });
-
- # test 11 - try to $f->write_file on locked file (should fail)
- skip(
- $skip,
- sub {
+ skip 'Your system cannot flock' => 9;
+ }
+ elsif ( !$have_perms ) {
- # FORKING!!
- my($pid) = fork; $| = 1; die(qq{Can't fork: $!}) unless defined($pid);
+ skip 'Insufficient permissions' => 9;
+ }
+ elsif ( $^O =~ /solaris|sunos/i ) {
- if (!$pid) {
+ skip 'Solaris flock has issues' => 9;
+ }
- $f->write_file(
- 'file' => $tmpf,
- 'content' => '',
- '--empty-writes-OK'
- );
+ ok $f->can_flock( ) == $have_flock,
+ 'File::Util correctly detects flock() support';
+
+ # flock-ing usage toggles
+ ok $f->use_flock( ) == 1, 'test flock on' ; # test 1
+ ok $f->use_flock(1) == 1, 'test on toggle' ; # test 2
+ ok $f->use_flock(0) == 0, 'test off toggle' ; # test 3
+ ok $f->use_flock( ) == 0, 'test toggled off' ; # test 4
+ ok $f->use_flock(1) == 1, 'test toggle back on' ; # test 5
+
+ # get/set flock-ing failure policy
+ ok( # test 6
+ join( ' ', $f->flock_rules() ) eq 'NOBLOCKEX FAIL',
+ 'expecting ' . join( ' ', $f->flock_rules() )
+ );
+
+ ok( # test 7
+ join( ' ', $f->flock_rules( qw/ NOBLOCKEX ZERO / ) ) eq 'NOBLOCKEX ZERO',
+ 'expecting ' . join( ' ', $f->flock_rules( qw/ NOBLOCKEX ZERO / ) )
+ );
+
+ # actual flock test
+ is fight_for_lock(),
+ 'failed correctly',
+ 'contending flock OPs must fail' ; # test 8
+
+ last;
+
+ my $fh = $f->open_handle
+ (
+ $tmpf, 'write' => { onfail => warn => diag => 1 }
+ );
+
+ is $f->unlock_open_handle
+ (
+ $fh => { onfail => warn => diag => 1 }
+ ), 1, 'File::Util can un-flock OK';
+
+ close $fh;
+}
- exit
- }
- else { waitpid($pid, 0) }
+unlink $tmpf;
- # DONE WITH THAT NOW.
- -s $tmpf
- });
+exit;
- # unlock file
- close($fh) unless $skip;
+# put flock to the "test"
+sub fight_for_lock {
- # test 12 - try to trunc the file; should succeed
- # - skip this on solaris...
- if ($^O =~ /solaris/i) {
- skip(&skip_trunc_solaris(), 0, 0);
- }
- else {
- skip($skip, sub { $f->trunc($tmpf); return -s $tmpf }, 0);
- }
+ $f->flock_rules( qw( NOBLOCKEX FAIL ) );
- # try to delete the file; should succeed
- unlink($tmpf) unless $skip;
+ # auto-locks file, keep open handle on it
+ my $fh = $f->open_handle( $tmpf => 'write' );
- !-e $tmpf;
+ # this should fail, and return a "0" instead of a filehandle
+ return $f->open_handle
+ (
+ $tmpf => write => { onfail => sub { 'failed correctly' } }
+ );
}
-sub skipmsg { <<'__WHYSKIP__' }
-Insufficient permissions to perform IO in this directory. Can't perform tests!
-__WHYSKIP__
-
-sub skip_trunc_solaris { <<'__WHYSKIP__' }
-Solaris can flock, but won't let go of discretionary lock yet.
-__WHYSKIP__
-
@@ -1,26 +1,19 @@
use strict;
-use Test;
+use warnings;
+use Test::More;
+use Test::NoWarnings;
-# use a BEGIN block so we print our plan before module is loaded
-BEGIN { use File::Util }
-BEGIN { plan tests => scalar(@File::Util::EXPORT_OK), todo => [] }
-BEGIN { $| = 1 }
+use lib './lib';
-# load your module...
-use lib './';
+use File::Util;
-# we gonna see if'n it cun export wut itz 'pose ta. this checks the
-# @EXPORT_OK of all packages in the inheritance cascade, which is the
-# only reason we're doing this. we already know that it UNIVERSAL::can do
-# all its own methods if this test is being run. test 3 ensures that.
-# this is just an automated non-empty superclass test
-use File::Util @File::Util::EXPORT_OK;
-
-map {
-
- ok ref(UNIVERSAL::can('File::Util', $_)) eq 'CODE'
+plan tests => ( scalar @File::Util::EXPORT_OK ) + 1;
+map
+{
+ ok ref UNIVERSAL::can('File::Util', $_) eq 'CODE',
+ "can do exported $_"
} @File::Util::EXPORT_OK;
exit;
@@ -1,14 +1,14 @@
use strict;
-use Test;
+use warnings;
+
+use Test::More;
+use Test::NoWarnings;
-# use a BEGIN block so we print our plan before module is loaded
-BEGIN { use File::Util }
-BEGIN { plan tests => scalar(@File::Util::EXPORT_OK), todo => [] }
-BEGIN { $| = 1 }
+use lib './lib';
+use File::Util;
-# load your module...
-use lib './';
+plan tests => ( scalar @File::Util::EXPORT_OK ) + 1;
# automated empty subclass test
@@ -27,9 +27,9 @@ package main;
# see if _Foo can do everything that File::Util can do
map {
- ok ref(UNIVERSAL::can('_Foo', $_)) eq 'CODE'
+ ok ref UNIVERSAL::can('_Foo', $_) eq 'CODE',
+ "Empty subclass can $_"
} @File::Util::EXPORT_OK;
-
exit;
@@ -1,274 +0,0 @@
-
-use strict;
-use Test;
-
-# use a BEGIN block so we print our plan before MyModule is loaded
-BEGIN { plan tests => 31, todo => [] }
-BEGIN { $| = 1 }
-
-# load your module...
-use lib './';
-use File::Util qw( SL NL existent );
-
-my($f) = File::Util->new('--fatals-as-errmsg');
-
-# start testing failure sequence
-ok($f->_throw('no such file' => { 'filename' => __FILE__ }, '--fatals-as-errmsg' ),
- q{/no such file or directory exists/},
- q{Bad failure return code for error: "no such file"}
-);
-
-ok(
- $f->_throw(
- 'bad flock rules' => {
- 'bad' => __FILE__,
- 'all' => [ $f->flock_rules() ],
- }
- ),
- q{/Invalid file locking policy/},
- q{Bad failure return code for error: "bad flock rules"}
-);
-
-ok(
- $f->_throw(
- 'cant fread' => {
- 'filename' => __FILE__,
- 'dirname' => '.',
- }
- ),
- q{/Permissions conflict\..+?can't read the contents of this file:/},
- q{Bad failure return code for error: "cant fread"}
-);
-
-ok($f->_throw('cant fread not found' => { 'filename' => __FILE__, }),
- q{/File not found\. .+?can't read the contents of this file\:/},
- q{Bad failure return code for error: "cant fread no exists"}
-);
-
-ok(
- $f->_throw(
- 'cant fcreate' => {
- 'filename' => __FILE__,
- 'dirname' => '.',
- }
- ),
- q{/Permissions conflict\..+?can't create this file:/},
- q{Bad failure return code for error: "cant fcreate"}
-);
-
-ok($f->_throw('cant write_file on a dir' => { 'filename' => __FILE__, }),
- q{/can't write to the specified file/},
- q{Bad failure return code for error: "cant write_file on a dir"}
-);
-
-ok(
- $f->_throw(
- 'cant fwrite' => {
- 'filename' => __FILE__,
- 'dirname' => '.',
- }
- ),
- q{/Permissions conflict\..+?can't write to this file:/},
- q{Bad failure return code for error: "cant fwrite"}
-);
-
-ok(
- $f->_throw(
- 'bad openmode popen' => {
- 'filename' => __FILE__,
- 'badmode' => 'illegal',
- 'meth' => 'anonymous',
- }
- ),
- q{/Illegal mode specified for file open\./},
- q{Bad failure return code for error: "bad openmode popen"}
-);
-
-ok(
- $f->_throw(
- 'bad openmode sysopen' => {
- 'filename' => __FILE__,
- 'badmode' => 'illegal',
- 'meth' => 'anonymous',
- }
- ),
- q{/Illegal mode specified for file sysopen/},
- q{Bad failure return code for error: "bad openmode sysopen"}
-);
-
-ok($f->_throw('cant dread' => { 'dirname' => '.' } ),
- q{/Permissions conflict\..+?can't list the contents of this/},
- q{Bad failure return code for error: "cant dread"}
-);
-
-ok(
- $f->_throw(
- 'cant dcreate' => {
- 'dirname' => '.',
- 'parentd' => '..',
- }
- ),
- q{/Permissions conflict\..+?can't create:/},
- q{Bad failure return code for error: "cant dcreate"}
-);
-
-ok(
- $f->_throw(
- 'make_dir target exists' => {
- 'dirname' => '.',
- 'filetype' => qq{@{[$f->file_type('.')]}},
- }
- ),
- q{/make_dir target already exists\./},
- q{Bad failure return code for error: "make_dir target exists"}
-);
-
-ok(
- $f->_throw(
- 'bad open' => {
- 'mode' => 'illegal mode',
- 'filename' => __FILE__,
- 'exception' => 'dummy',
- 'cmd' => 'illegal cmd',
- }
- ),
- q{/can't open this file for .illegal mode.:/},
- q{Bad failure return code for error: "bad open"}
-);
-
-ok(
- $f->_throw(
- 'bad close' => {
- 'mode' => 'illegal mode',
- 'filename' => __FILE__,
- 'exception' => 'dummy',
- }
- ),
- q{/couldn't close this file after .illegal mode./},
- q{Bad failure return code for error: "bad close"}
-);
-
-ok(
- $f->_throw(
- 'bad systrunc' => {
- 'filename' => __FILE__,
- 'exception' => 'dummy',
- }
- ),
- q{/couldn't truncate\(\) on.+?after having/},
- q{Bad failure return code for error: "bad systrunc"}
-);
-
-ok(
- $f->_throw(
- 'bad flock' => {
- 'filename' => __FILE__,
- 'exception' => 'illegal',
- }
- ),
- q{/can't get a lock on the file/},
- q{Bad failure return code for error: "bad flock"}
-);
-
-ok($f->_throw('called open on a dir' => { 'filename' => __FILE__ }),
- q{/can't call open\(\) on this file because it is a directory/},
- q{Bad failure return code for error: "called open on a dir"}
-);
-
-ok($f->_throw('called opendir on a file' => { 'filename' => __FILE__ }),
- q{/can't opendir\(\) on this file because it is not a directory/},
- q{Bad failure return code for error: "called opendir on a file"}
-);
-
-ok($f->_throw('called mkdir on a file' => { 'filename' => __FILE__ }),
- q{/can't auto-create a directory for this path name because/},
- q{Bad failure return code for error: "called mkdir on a file"}
-);
-
-ok($f->_throw('bad readlimit' => {}),
- q{/Bad call to .+?\:\:readlimit\(\)\. This method can only be/},
- q{Bad failure return code for error: "bad readlimit"}
-);
-ok(
- $f->_throw(
- 'readlimit exceeded' => {
- 'filename' => __FILE__,
- 'size' => 'testtesttest',
- }
- ),
- q{/(?sm)can't load file.+?into memory because its size exceeds/},
- q{Bad failure return code for error: "readlimit exceeded"}
-);
-
-ok($f->_throw('bad maxdives' => {}),
- q{/Bad call to .+?\:\:max_dives\(\)\. This method can only be/},
- q{Bad failure return code for error: "bad maxdives"}
-);
-
-ok($f->_throw('maxdives exceeded' => {}),
- q{/Recursion limit reached at .+?dives\. Maximum number of/},
- q{Bad failure return code for error: "maxdives exceeded"}
-);
-
-ok(
- $f->_throw(
- 'bad opendir' => {
- 'dirname' => '.',
- 'exception' => 'illegal',
- }
- ),
- q{/can't opendir on directory\:/},
- q{Bad failure return code for error: "bad opendir"}
-);
-
-ok(
- $f->_throw(
- 'bad make_dir' => {
- 'dirname' => '.',
- 'bitmask' => 0777,
- 'exception' => 'illegal',
- 'meth' => 'anonymous',
- }
- ),
- q{/had a problem with the system while attempting to create/},
- q{Bad failure return code for error: "bad make_dir"}
-);
-
-ok(
- $f->_throw(
- 'bad chars' => {
- 'string' => 'illegal characters',
- 'purpose' => 'testing',
- }
- ),
- q{/(?sm)can't use this string.+?It contains illegal characters\./},
- q{Bad failure return code for error: "bad chars"}
-);
-
-ok($f->_throw('not a filehandle' => { 'argtype' => 'illegal', }),
- q{/can't unlock file with an invalid file handle reference\:/},
- q{Bad failure return code for error: "not a filehandle"}
-);
-
-ok($f->_throw('no input' => { 'meth' => 'anonymous' }),
- q{/(?sm)can't honor your call to.+?because you didn't provide/},
- q{Bad failure return code for error: "no input"}
-);
-
-ok($f->_throw('plain error' => 'testtesttest'),
- q{/failed with the following message\:/},
- q{Bad failure return code for error: "plain error"}
-);
-
-ok($f->_throw('unknown error message', => {}),
- q{/failed with an invalid error-type designation\./},
- q{Bad failure return code for error: "unknown error message"}
-);
-
-ok($f->_throw('empty error', => {}),
- q{/failed with an empty error-type designation\./},
- q{Bad failure return code for error: "empty error"}
-);
-
-exit;
-
@@ -0,0 +1,101 @@
+
+use strict;
+use warnings;
+
+use Test::More;
+use File::Temp qw( tempfile );
+
+use lib './lib';
+
+use File::Util qw( NL );
+
+BEGIN # determine if we can run these unicode tests, or skip_all
+{
+ $|++;
+
+ {
+ local $@;
+
+ my $have_uu = eval { require 5.008001; use utf8; };
+
+ sub have_unicode { $have_uu }
+ }
+
+ unless ( have_unicode() )
+ {
+ plan skip_all => 'your Perl does not appear to support unicode';
+ }
+ else
+ {
+ plan tests => 8;
+
+ CORE::eval <<'__TEST_NOWARNINGS__';
+use Test::NoWarnings;
+__TEST_NOWARNINGS__
+ }
+}
+
+my $ftl = File::Util->new();
+
+$ftl->use_flock( 0 ) if $^O =~ /solaris|sunos/i;
+
+my ( $tempfh, $tempfile ) = tempfile; close $tempfh;
+
+$ftl->touch( $tempfile => { binmode => 'utf8' } );
+
+is utf8::is_utf8( $ftl->load_file( $tempfile => { binmode => 'utf8' } ) ),
+ 1, 'file touched and read as UTF-8 strict';
+
+( $tempfh, $tempfile ) = tempfile; close $tempfh;
+
+$ftl->write_file( $tempfile => "\N{U+263A}" => { binmode => 'utf8' } );
+
+is utf8::is_utf8( $ftl->load_file( $tempfile => { binmode => 'utf8' } ) ),
+ 1, 'file written and read as UTF-8 strict';
+
+( $tempfh, $tempfile ) = tempfile; close $tempfh;
+
+my $utf8fh = $ftl->open_handle( $tempfile => 'write' => { binmode => 'utf8' } );
+
+print $utf8fh "\N{U+263A}" . NL;
+
+$ftl->unlock_open_handle( $utf8fh );
+
+close $utf8fh;
+
+is utf8::is_utf8( $ftl->load_file( $tempfile => { binmode => 'utf8' } ) ),
+ 1, 'file written via file handle API and read as UTF-8 strict';
+
+( $tempfh, $tempfile ) = tempfile; close $tempfh;
+
+{
+ local $@;
+
+ eval { $ftl->write_file( $tempfile => "\N{U+263A}" ) };
+
+ like $@,
+ qr/wide character/mi,
+ 'writing unicode to a ":raw" filehandle fails';
+}
+
+isnt utf8::is_utf8( $ftl->load_file( $tempfile ) ),
+ 1, 'unicode written and read in :raw mode returns non-UTF-8 string';
+
+is utf8::is_utf8( $ftl->load_file( $tempfile => { binmode => 'utf8' } ) ),
+ 1, 'unicode written in :raw and read in UTF-8 strict still treated as UTF-8';
+
+$ftl->write_file( $tempfile => "\N{U+263A}" => { binmode => 'utf8' } );
+
+$utf8fh = $ftl->open_handle( $tempfile => 'read' => { binmode => 'utf8' } );
+
+is utf8::is_utf8( readline $utf8fh ),
+ 1, 'filehandle opened in UTF-8 strict, then lines read as UTF-8 strings';
+
+$ftl->unlock_open_handle( $utf8fh );
+
+close $utf8fh;
+
+# XXX ... more tests coming
+
+exit;
+
@@ -0,0 +1,38 @@
+
+use strict;
+use warnings;
+use Test::More tests => 3;
+use Test::NoWarnings;
+use File::Temp qw( tmpnam );
+
+use lib './lib';
+use File::Util;
+
+# check object constructor
+my $f = File::Util->new();
+
+my $fn = tmpnam(); # get absolute filename
+
+my $have_perms = $f->is_writable( $f->return_path( $fn ) );
+
+SKIP: {
+
+ if ( !$have_perms ) {
+
+ skip 'Insufficient permissions to perform IO' => 2;
+ }
+ elsif ( $^O =~ /solaris|sunos/i ) {
+
+ skip 'Solaris flock is broken' => 2;
+ }
+
+ # test write
+ is $f->write_file( file => $fn, content => 'JAPH' ), 1,
+ 'write file with abs path' ;
+
+ is $f->load_file( $fn ), 'JAPH', 'file content matches' ;
+}
+
+unlink $fn;
+
+exit;
@@ -0,0 +1,64 @@
+
+use strict;
+use warnings;
+use Test::NoWarnings;
+use Test::More tests => 37;
+
+# load your module...
+use lib './lib';
+use File::Util qw( atomize_path );
+
+# automated empty subclass test
+my $atomized = {
+ 'C:\foo\bar\baz.txt' => { root => 'C:\\', path => 'foo\bar', file => 'baz.txt' },
+ '/foo/bar/baz.txt' => { root => '/', path => 'foo/bar', file => 'baz.txt' },
+ ':a:b:c:d:e:f:g.txt' => { root => ':', path => 'a:b:c:d:e:f', file => 'g.txt' },
+ './a/b/c/d/e/f/g.txt' => { root => '', path => './a/b/c/d/e/f', file => 'g.txt' },
+ '../wibble/wombat.ini' => { root => '', path => '../wibble', file => 'wombat.ini' },
+ '..\woot\noot.doc' => { root => '', path => '..\woot', file => 'noot.doc' },
+ '../../zoot.conf' => { root => '', path => '../..', file => 'zoot.conf' },
+ '/root' => { root => '/', path => '', file => 'root' },
+ '/etc/sudoers' => { root => '/', path => 'etc', file => 'sudoers' },
+ '/' => { root => '/', path => '', file => '', },
+ 'D:\\' => { root => 'D:\\', path => '', file => '', },
+ 'D:\autorun.inf' => { root => 'D:\\', path => '', file => 'autorun.inf' },
+};
+
+for my $path ( keys %$atomized ) {
+
+ my @atoms = atomize_path( $path );
+
+ is shift @atoms,
+ $atomized->{ $path }{root},
+ qq(atomized root matches "$atomized->{ $path }{root}") ;
+
+ is shift @atoms,
+ $atomized->{ $path }{path},
+ qq(atomized path matches "$atomized->{ $path }{path}") ;
+
+ is shift @atoms,
+ $atomized->{ $path }{file},
+ qq(atomized filename matches "$atomized->{ $path }{file}") ;
+}
+
+exit;
+
+__END__
+
+Expected (correct) output from atomize_path()
+
+-------------------------------------------------------------------------------
+INPUT ROOT PATH-COMPONENT FILE/DIR
+-------------------------------------------------------------------------------
+C:\foo\bar\baz.txt C:\ foo\bar baz.txt
+/foo/bar/baz.txt / foo/bar baz.txt
+:a:b:c:d:e:f:g.txt : a:b:c:d:e:f g.txt
+./a/b/c/d/e/f/g.txt ./a/b/c/d/e/f g.txt
+../wibble/wombat.ini ../wibble wombat.ini
+..\woot\noot.doc ..\woot noot.doc
+../../zoot.conf ../.. zoot.conf
+/root / root
+/etc/sudoers / etc sudoers
+/ /
+D:\ D:\
+D:\autorun.inf D:\ autorun.inf
@@ -0,0 +1,91 @@
+
+use strict;
+use warnings;
+use Test::NoWarnings;
+use Test::More tests => 14;
+
+use lib './lib';
+use File::Util;
+
+my $ftl = File::Util->new();
+
+# testing _myargs()
+is_deeply [ $ftl->_myargs( qw/ a b c / ) ],
+ [ qw/ a b c / ],
+ '_myargs() understands a flat list';
+
+is $ftl->_myargs( 'a' ),
+ 'a',
+ '...and knows what to do in list context' ;
+
+is scalar $ftl->_myargs( qw/ a b c / ),
+ 'a',
+ '...and knows what to do in scalar context';
+
+# testing _remove_opts()
+is $ftl->_remove_opts( 'a' ),
+ undef,
+ '_remove_opts() ignores non-opts type single arg, and returns undef';
+
+is $ftl->_remove_opts( undef ), undef, '...and returns undef if given undef';
+
+is $ftl->_remove_opts( qw/ a b c / ),
+ undef,
+ '...and ignores non-opts type multi arg list, and returns undef';
+
+is_deeply
+ $ftl->_remove_opts( [ qw/ --name=Larry --lang=Perl --recurse --empty= / ] ),
+ {
+ '--name' => 'Larry',
+ 'name' => 'Larry',
+ '--lang' => 'Perl',
+ 'lang' => 'Perl',
+ '--recurse' => 1,
+ 'recurse' => 1,
+ '--empty' => '',
+ 'empty' => '',
+ },
+ '...and recognizes + returns --name=value pairs, --flags, and --empty=';
+
+is_deeply
+ $ftl->_remove_opts(
+ [
+ qw/ --verbose --8-ball=black --empty= /,
+ ]
+ ),
+ {
+ '--verbose' => 1,
+ 'verbose' => 1,
+ '--8-ball' => 'black',
+ '8_ball' => 'black',
+ '--empty' => '',
+ 'empty' => '',
+ },
+ '...same test as above, with different input';
+
+is_deeply
+ $ftl->_remove_opts( [ 0, '', undef, '--mcninja', undef ] ),
+ { qw/ mcninja 1 --mcninja 1 / },
+ '...and recognizes args-as-listref, works right even with some bad args';
+
+
+
+# testing _names_values
+is_deeply
+ $ftl->_names_values( qw/ a a b b c c d d e e / ),
+ { a => a => b => b => c => c => d => d => e => e => },
+ '_names_values() converts even-numbered args list to balanced hashref';
+
+is_deeply
+ $ftl->_names_values( a => 'a', 'b' ),
+ { a => a => b => undef },
+ '...and sets final name-value pair to value=undef for unbalanced lists';
+
+is_deeply
+ $ftl->_names_values( a => 'a', b => 'b', ( undef, 'u' ), c => 'c' ), # foolishness
+ { a => a => b => b => c => c => }, # ...should go ignored (at least here)
+ '...and ignores name-value pair in balanced list when name itself is undef';
+
+is File::Util::Interface::Classic::DESTROY(), undef, '::DESTROY() returns undef';
+
+exit;
@@ -0,0 +1,220 @@
+
+use strict;
+use warnings;
+use Test::NoWarnings;
+use Test::More tests => 29;
+
+use lib './lib';
+use File::Util;
+
+my $ftl = File::Util->new();
+
+# ::Modern should be able to do everthing ::Classic does, so we're going to
+# run all the same tests on ::Modern that we do on ::Classic, and after
+# that we are going to target the things that only ::Modern can do.
+
+# BEGIN BACK-COMPAT TESTS
+
+# testing _myargs() with back-compat
+is_deeply [ $ftl->_myargs( qw/ a b c / ) ],
+ [ qw/ a b c / ],
+ '_myargs() understands a flat list';
+
+is $ftl->_myargs( 'a' ),
+ 'a',
+ '...and knows what to do in list context' ;
+
+is scalar $ftl->_myargs( qw/ a b c / ),
+ 'a',
+ '...and knows what to do in scalar context';
+
+# testing $ftl->_remove_opts() with back-compat
+is $ftl->_remove_opts( 'a' ),
+ undef,
+ '$ftl->_remove_opts() ignores non-opts type single arg, and returns undef';
+
+is $ftl->_remove_opts( qw/ a b c / ),
+ undef,
+ '...and ignores non-opts type multi arg list, and returns undef';
+
+is_deeply
+ $ftl->_remove_opts( [ qw/ --name=Larry --lang=Perl --recurse --empty= / ] ),
+ {
+ '--name' => 'Larry',
+ 'name' => 'Larry',
+ '--lang' => 'Perl',
+ 'lang' => 'Perl',
+ '--recurse' => 1,
+ 'recurse' => 1,
+ '--empty' => '',
+ 'empty' => '',
+ },
+ '...and recognizes + returns --name=value pairs, --flags, and --empty=';
+
+is_deeply
+ $ftl->_remove_opts(
+ [
+ qw/ --verbose --8-ball=black --empty= /,
+ ]
+ ),
+ {
+ '--verbose' => 1,
+ 'verbose' => 1,
+ '--8-ball' => 'black',
+ '8_ball' => 'black',
+ '--empty' => '',
+ 'empty' => '',
+ },
+ '...and still does the same with some slightly different input';
+
+is_deeply
+ $ftl->_remove_opts( [ 0, '', undef, '--mcninja', undef ] ),
+ { qw/ mcninja 1 --mcninja 1 / },
+ '...and works right even with some bad args';
+
+
+# testing $ftl->_names_values() with back-compat
+is_deeply
+ $ftl->_names_values( qw/ a a b b c c d d e e / ),
+ { a => a => b => b => c => c => d => d => e => e => },
+ '$ftl->_names_values() converts even-numbered args list to balanced hashref';
+
+is_deeply
+ $ftl->_names_values( a => 'a', 'b' ),
+ { a => a => b => undef },
+ '...and sets final name-value pair to value=undef for unbalanced lists';
+
+is_deeply
+ $ftl->_names_values( a => 'a', b => 'b', ( undef, 'u' ), c => 'c' ), # foolishness
+ { a => a => b => b => c => c => }, # ...should go ignored (at least here)
+ '...and ignores name-value pair in balanced list when name itself is undef';
+
+
+# BACK COMPAT TESTS DONE. Now test ::Modern interface
+
+# testing _myargs() - no testing needed because it works the same in ::Modern
+# since it is imported from ::Classic
+
+# testing $ftl->_remove_opts()
+is_deeply
+ $ftl->_remove_opts(
+ [
+ { name => 'Larry', lang => 'Perl', recurse => 1, empty => undef }
+ ]
+ ),
+ {
+ name => 'Larry',
+ lang => 'Perl',
+ recurse => 1,
+ empty => undef,
+ },
+ '$ftl->_remove_opts() recognizes + returns { name => value } pairs, and flags';
+
+is_deeply
+ $ftl->_remove_opts(
+ [
+ { verbose => 1, '8_ball' => 'black', empty => '' },
+ ]
+ ),
+ {
+ verbose => 1,
+ '8_ball' => 'black',
+ empty => '',
+ },
+ '...and does the same with slightly different input';
+
+is $ftl->_remove_opts( ), undef, '...and returns undef if given no args';
+
+is $ftl->_remove_opts( undef ), undef, '...and returns undef if given undef';
+
+is_deeply $ftl->_remove_opts( [ undef, 0, '' ] ),
+ { },
+ '...and returns empty hashref if given listref of falsies';
+
+is_deeply
+ $ftl->_remove_opts( [ ] ),
+ { },
+ '...and returns an empty hashref if given an empty listref of args';
+
+is_deeply
+ $ftl->_remove_opts(
+ [
+ { verbose => 1, '8_ball' => 'black' }, { empty => '' },
+ ]
+ ),
+ {
+ verbose => 1,
+ '8_ball' => 'black',
+ empty => '',
+ },
+ '...and still does the same if args list contains multiple hashrefs';
+
+is_deeply
+ $ftl->_remove_opts(
+ [
+ { verbose => 1, '8_ball' => 'black' }, undef, { empty => '' },
+ ]
+ ),
+ {
+ verbose => 1,
+ '8_ball' => 'black',
+ empty => '',
+ },
+ '...and still does the same if args list is interspersed with undef\'s';
+
+
+# testing $ftl->_names_values()
+is_deeply
+ $ftl->_names_values( { qw/ a a b b c c d d e e / } ),
+ { a => a => b => b => c => c => d => d => e => e => },
+ '$ftl->_names_values() compares perfectly from input hashref to args hashref';
+
+is_deeply
+ $ftl->_names_values( ),
+ { },
+ '...and returns an empty hashref if given no args';
+
+is_deeply
+ $ftl->_names_values( { } ),
+ { },
+ '...and returns an empty hashref if given an empty hashref as only arg';
+
+is_deeply
+ $ftl->_parse_in(
+ { qw/ a a b b c c d d e e / }
+ ),
+ { a => a => b => b => c => c => d => d => e => e => },
+ '$ftl->_parse_in() and understands a hashref';
+
+is_deeply $ftl->_parse_in( ), { },
+ '...and returns an empty hashref if given no args';
+
+is_deeply $ftl->_parse_in( { } ), { },
+ '...and does the same if given an empty hashref';
+
+is_deeply
+ $ftl->_parse_in(
+ { qw/ a a / }, { qw/ b b / }, { qw/ c c / }, { qw/ d d e e / }
+ ),
+ { a => a => b => b => c => c => d => d => e => e => },
+ '...and understands and amalgamates a list of hashrefs';
+
+is_deeply
+ $ftl->_parse_in(
+ { qw/ a a / }, b => 'b', '--c=c', { qw/ d d e e / }, '--f'
+ ),
+ {
+ a => 'a',
+ b => 'b',
+ c => 'c',
+ d => 'd',
+ e => 'e',
+ f => 1,
+ '--c' => 'c',
+ '--f' => 1,
+ },
+ '...and understands a mixture of old and new style input args';
+
+is File::Util::Interface::Modern::DESTROY(), undef, '::DESTROY() returns undef';
+
+exit;
@@ -0,0 +1,45 @@
+
+use strict;
+use warnings;
+use Test::NoWarnings;
+use Test::More tests => 8;
+
+use lib './lib';
+
+use File::Util;
+use File::Util::Definitions;
+use File::Util::Interface::Classic;
+use File::Util::Interface::Modern;
+use File::Util::Exception;
+use File::Util::Exception::Standard;
+use File::Util::Exception::Diagnostic;
+
+is File::Util::DESTROY(),
+ undef,
+ 'File::Util::DESTROY() returns as expected';
+
+is File::Util::Definitions::DESTROY(),
+ undef,
+ 'File::Util::Definitions::DESTROY() returns as expected';
+
+is File::Util::Interface::Classic::DESTROY(),
+ undef,
+ 'File::Util::Interface::Classic::DESTROY() returns as expected';
+
+is File::Util::Interface::Modern::DESTROY(),
+ undef,
+ 'File::Util::Interface::Modern::DESTROY() returns as expected';
+
+is File::Util::Exception::DESTROY(),
+ undef,
+ 'File::Util::Exception::DESTROY() returns as expected';
+
+is File::Util::Exception::Standard::DESTROY(),
+ undef,
+ 'File::Util::Exception::Standard::DESTROY() returns as expected';
+
+is File::Util::Exception::Diagnostic::DESTROY(),
+ undef,
+ 'File::Util::Exception::Diagnostic::DESTROY() returns as expected';
+
+exit;
@@ -0,0 +1,132 @@
+
+use strict;
+use warnings;
+
+use Test::More tests => 30;
+use Test::NoWarnings;
+
+use lib './lib';
+use File::Util;
+
+my $ftl;
+
+# one recognized instantiation setting
+$ftl = File::Util->new( use_flock => 0 );
+is ref $ftl, 'File::Util',
+ 'new() is blessed correctly after flock toggle invocation';
+
+is $ftl->use_flock() , 0,
+ 'flock off-toggle sticks after blessing';
+
+# another recognized instantiation setting
+$ftl = File::Util->new( readlimit => 1234567890 );
+is ref $ftl, 'File::Util',
+ 'new() is blessed correctly after readlimit-set invocation';
+
+cmp_ok $ftl->readlimit , '==', 1234567890,
+ 'readlimit (legacy) setting sticks after blessing';
+
+cmp_ok $ftl->read_limit , '==', 1234567890,
+ 'read_limit (new-style) setting sticks after blessing';
+
+# yet another recognized instantiation setting
+$ftl = File::Util->new( abort_depth => 9876543210 );
+is ref $ftl, 'File::Util',
+ 'new() is blessed right after abort_depth-set invocation';
+
+cmp_ok $ftl->abort_depth, '==', 9876543210,
+ 'abort_depth toggle sticks after abort_depth-set invocation';
+
+# all recognized per-instantiation settings
+$ftl = File::Util->new
+(
+ use_flock => 1,
+ read_limit => 1111111,
+ abort_depth => 2222222
+);
+
+is ref $ftl, 'File::Util',
+ 'new() blessed right with multi-toggle';
+
+is $ftl->use_flock() , 1,
+ 'use_flock sticks after multi-toggle';
+
+cmp_ok $ftl->readlimit, '==', 1111111,
+ 'readlimit (legacy) sticks after multi-toggle blessing';
+
+cmp_ok $ftl->read_limit, '==', 1111111,
+ 'read_limit (new-style) sticks after multi-toggle blessing';
+
+cmp_ok $ftl->abort_depth, '==', 2222222,
+ 'abort_depth sticks after multi-toggle blessing';
+
+# one recognized flag
+$ftl = File::Util->new( '--fatals-as-warning' );
+
+is ref $ftl, 'File::Util',
+ 'new() blessed right with fatals toggle';
+
+cmp_ok $ftl->{opts}{fatals_as_warning}, '==', 1,
+ 'modern internal setting matches toggle';
+
+cmp_ok $ftl->{opts}{'--fatals-as-warning'}, '==', 1,
+ 'classic internal setting matches toggle';
+
+# another recognized flag
+$ftl = File::Util->new( '--fatals-as-status' );
+
+is ref $ftl, 'File::Util', 'blessed ok after classic instantiation';
+
+is $ftl->{opts}{fatals_as_status}, 1,
+ 'peek at internals looks good for "fatals_as_status"';
+
+is $ftl->{opts}{'--fatals-as-status'}, 1,
+ 'peek at internals looks good for "--fatals_as_status"';
+
+# yet another recognized flag
+$ftl = File::Util->new( '--fatals-as-errmsg' );
+
+is ref $ftl, 'File::Util', 'blessed ok after classic instantiation';
+
+is $ftl->{opts}{fatals_as_errmsg}, 1,
+ 'peek at internals looks good for "fatals_as_errmsg"';
+
+is $ftl->{opts}{'--fatals-as-errmsg'}, 1,
+ 'peek at internals looks good for "--fatals-as-errmsg"';
+
+# all settings and one recognized flag, using ::Modern syntax
+$ftl = File::Util->new(
+ {
+ use_flock => 0,
+ readlimit => 1111111,
+ abort_depth => 2222222,
+ fatals_as_status => 1,
+ warn_also => 1
+ }
+);
+
+is ref $ftl, 'File::Util',
+ 'blessed ok after modern instantiation with multiple opts';
+
+is $ftl->use_flock(), 0,
+ 'flock toggle correct after modern multi-opt instantiation';
+
+cmp_ok $ftl->readlimit(), '==', 1111111,
+ 'readlimit setting correct after modern multi-opt instantiation';
+
+cmp_ok $ftl->abort_depth(), '==', 2222222,
+ 'abort_depth setting correct after modern multi-opt instantiation';
+
+is $ftl->{opts}{fatals_as_status}, 1,
+ 'peek at internals ok for "fatals_as_status"';
+
+is $ftl->{opts}{warn_also}, 1,
+ 'peek at internals ok for "warn_also"';
+
+is $ftl->{opts}{fatals_as_warning}, undef,
+ 'peek at internals ok for !defined "fatals_as_warning"';
+
+is $ftl->{opts}{fatals_as_errmsg}, undef,
+ 'peek at internals ok for !defined "fatals_as_errmsg"';
+
+exit;
@@ -0,0 +1,237 @@
+
+use strict;
+use warnings;
+
+# the original intent of this test was to isolate and test solely the
+# list_dir method, but it became immediatley apparent that you can't
+# very well test list_dir() unless you have a good directory tree first;
+# this led to the combining of the make_dir and list_dir testing routines
+
+use Test::More tests => 26;
+use Test::NoWarnings;
+
+use Cwd;
+use File::Temp qw( tempdir );
+
+use lib './lib';
+use File::Util qw( SL NL OS );
+
+# one recognized instantiation setting
+my $ftl = File::Util->new( );
+
+my $tempdir = tempdir( CLEANUP => 1 );
+my $testbed = $tempdir . SL . $$ . SL . time;
+my $tmpf = $testbed . SL . 'tmptest';
+my $have_perms = $ftl->is_writable( $tempdir );
+my @test_files = qw/
+ a.txt b.log
+ c.ini d.bat
+ e.sh f.conf
+ g.bin h.rc
+/;
+
+for my $tfile ( @test_files )
+{
+ ok(
+ $ftl->touch( $testbed . SL . $tfile ) == 1,
+ 'create files in a directory that does not exist beforehand'
+ );
+}
+
+is_deeply
+(
+ [ sort $ftl->list_dir( $testbed, '--recurse' ) ],
+ [ sort map { $testbed . SL . $_ } @test_files ],
+ 'test recursive listing with classic call style arguments'
+);
+
+my $deeper = $testbed . SL . 'foo' . SL . 'bar';
+
+# make a deeper directory
+is
+(
+ $ftl->make_dir( $deeper ), $deeper,
+ 'make a deeper directory'
+);
+
+for my $tfile ( @test_files )
+{
+ ok
+ (
+ $ftl->touch( $deeper . SL . $tfile ) == 1,
+ 'create files in a abs path directory that already exists'
+ );
+}
+
+is_deeply
+(
+ [ sort $ftl->list_dir( $deeper => { recurse => 1 } ) ],
+ [ sort map { $deeper . SL . $_ } @test_files ],
+ 'test recursive file listing with modern call style'
+);
+
+is_deeply
+(
+ [ sort $ftl->list_dir( $deeper, '--recurse' ) ],
+ [ sort map { $deeper . SL . $_ } @test_files ],
+ 'test recursive file listing with classic call style'
+);
+
+is_deeply
+(
+ [
+ sort map { $ftl->strip_path( $_ ) } $ftl->list_dir
+ (
+ $testbed => { recurse => 1, files_only => 1 }
+ )
+ ],
+ [ sort @test_files, @test_files ],
+ 'same, but using modern call style, ' .
+ 'stripped of fully qualified paths'
+);
+
+is_deeply
+(
+ [
+ sort map { $ftl->strip_path( $_ ) } $ftl->list_dir
+ (
+ $testbed => { recurse => 1 }, { files_only => 1 }
+ )
+ ],
+ [ sort @test_files, @test_files ],
+ 'same, but using intentionally wrong modern call style, ' .
+ 'stripped of fully qualified paths'
+);
+
+my @cbstack;
+
+sub callback
+{
+ my ( $currdir, $subdirs, $files, $depth ) = @_;
+
+ push @cbstack, @$subdirs;
+ push @cbstack, @$files;
+
+ return;
+}
+
+$ftl->list_dir( $tempdir => { callback => \&callback, recurse => 1 } );
+
+my @list_as_lines = $ftl->list_dir( $tempdir => { recurse => 1 } );
+
+is_deeply
+ [ sort { uc $a cmp uc $b } @cbstack ],
+ [ sort { uc $a cmp uc $b } @list_as_lines ],
+ 'compare recursive listing to recursive callback return';
+
+
+# setup test dir with no subdirs
+{
+ my $tempdir = tempdir( CLEANUP => 1 );
+ my $ftl = File::Util->new( );
+
+ $ftl->touch( $tempdir . SL . 'batman.robin' );
+ $ftl->touch( $tempdir . SL . 'superman.lex' );
+
+ is_deeply
+ [
+ $ftl->list_dir(
+ $tempdir => {
+ files_only => 1,
+ no_fsdots => 1,
+ files_match => qr/\.robin|lex$/,
+ }
+ )
+ ],
+ [ 'batman.robin', 'superman.lex' ],
+ 'regression test ensuring list_dir on dir with no subdirs is error free';
+}
+
+
+SKIP: {
+
+ # this would work on windows except it's directory separator is not "/"
+ # so we wouldn't get an exact match on each hash key's value.
+ skip 'these tests are for testing by the author and only run on Unix/Linux', 1
+ unless
+ (
+ (
+ $ENV{RELEASE_TESTING} || $ENV{AUTHOR_TESTING} || $ENV{AUTHOR_TESTS}
+ ) && ( $^O =~ /bsd|linux|cygwin|solaris|aix/i || OS eq 'UNIX' )
+ );
+
+ my $tree = setup_test_tree();
+ my $indir = getcwd;
+ chdir $tree;
+
+ is_deeply $ftl->list_dir( '.' => { recurse => 1, as_tree => 1 } ),
+ {
+ '.' => {
+ '_DIR_PARENT_' => undef,
+ '_DIR_SELF_' => '.',
+ 'a.txt' => './a.txt',
+ 'b.log' => './b.log',
+ 'c.ini' => './c.ini',
+ 'd.bat' => './d.bat',
+ 'e.sh' => './e.sh',
+ 'f.conf' => './f.conf',
+ 'g.bin' => './g.bin',
+ 'h.rc' => './h.rc',
+ 'xfoo' => {
+ '_DIR_PARENT_' => '.',
+ '_DIR_SELF_' => './xfoo',
+ 'zbar' => {
+ '_DIR_PARENT_' => './xfoo',
+ '_DIR_SELF_' => './xfoo/zbar',
+ 'i.jpg' => './xfoo/zbar/i.jpg',
+ 'j.xls' => './xfoo/zbar/j.xls',
+ 'k.ppt' => './xfoo/zbar/k.ppt',
+ 'l.scr' => './xfoo/zbar/l.scr',
+ 'm.html' => './xfoo/zbar/m.html',
+ 'n.js' => './xfoo/zbar/n.js',
+ 'o.css' => './xfoo/zbar/o.css',
+ 'p.avi' => './xfoo/zbar/p.avi',
+ },
+ },
+ }
+ }, 'list_dir( "." => { recurse => 1, as_tree => 1 } ) - works OK';
+
+ chdir $indir;
+}
+
+exit;
+
+sub setup_test_tree {
+
+ my $tempdir = tempdir( CLEANUP => 1 );
+
+ my @test_files = qw(
+ a.txt b.log
+ c.ini d.bat
+ e.sh f.conf
+ g.bin h.rc
+ );
+
+ for my $tfile ( @test_files )
+ {
+ $ftl->touch( $tempdir . SL . $tfile );
+ }
+
+ my $deeper = $tempdir . SL . 'xfoo' . SL . 'zbar';
+
+ $ftl->make_dir( $deeper );
+
+ @test_files = qw(
+ i.jpg j.xls
+ k.ppt l.scr
+ m.html n.js
+ o.css p.avi
+ );
+
+ for my $tfile ( @test_files )
+ {
+ $ftl->write_file( { file => $deeper . SL . $tfile, content => rand } );
+ }
+
+ return $tempdir;
+}
@@ -0,0 +1,251 @@
+
+use strict;
+use warnings;
+
+use Test::More tests => 19;
+use Test::NoWarnings;
+
+use File::Temp qw( tempdir );
+
+use lib './lib';
+use File::Util qw( SL NL strip_path );
+
+# one recognized instantiation setting
+my $ftl = File::Util->new( );
+
+my $tempdir = tempdir( CLEANUP => 1 );
+
+setup_test_tree();
+
+is_deeply [
+ map { strip_path( $_ ) } $ftl->list_dir(
+ $tempdir => {
+ rpattern => '\.sh$|\.js$',
+ files_only => 1,
+ recurse => 1,
+ }
+ )
+], [ qw( e.sh n.js ) ], 'legacy recursive file match (rpattern="...")';
+
+is_deeply [
+ map { strip_path( $_ ) } $ftl->list_dir(
+ $tempdir => {
+ files_match => qr/\.sh$|\.js$/,
+ files_only => 1,
+ recurse => 1,
+ }
+ )
+], [ qw( e.sh n.js ) ], 'recursive files_match';
+
+is_deeply [
+ map { strip_path( $_ ) } $ftl->list_dir(
+ $tempdir => {
+ files_match => { or => [ qr/\.sh$/, qr/\.js$/ ] },
+ files_only => 1,
+ recurse => 1,
+ }
+ )
+], [ qw( e.sh n.js ) ], 'recursive OR files_match';
+
+is_deeply [
+ map { strip_path( $_ ) } $ftl->list_dir(
+ $tempdir => {
+ files_match => { and => [ qr/\.sh$/, qr/[[:alpha:]]\.\w\w/ ] },
+ files_only => 1,
+ recurse => 1,
+ }
+ )
+], [ qw( e.sh ) ], 'recursive AND files_match';
+
+is_deeply [
+ map { strip_path( $_ ) } $ftl->list_dir(
+ $tempdir => {
+ dirs_match => qr/[xyz](?:foo|bar)/,
+ dirs_only => 1,
+ recurse => 1,
+ }
+ )
+], [ qw( xfoo zbar ) ], 'recursive dirs_match';
+
+is_deeply [
+ map { strip_path( $_ ) } $ftl->list_dir(
+ $tempdir => {
+ dirs_match => qr/[xyz](?:foo|bar)/,
+ files_match => qr/^[ijk]/,
+ recurse => 1,
+ }
+ )
+], [ qw( xfoo zbar i.jpg j.xls k.ppt ) ],
+ 'recursive dirs_match + files_match';
+
+is_deeply [
+ map { strip_path( $_ ) } $ftl->list_dir(
+ $tempdir => {
+ dirs_match => { or => [ qr/foo$/, qr/^zba/ ] },
+ files_match => { and => [ qr/^[ab]/, qr/\.\w+/ ] },
+ recurse => 1,
+ }
+ )
+], [ qw( xfoo zbar a.txt b.log ) ],
+ 'recursive OR dirs_match + AND files_match';
+
+is_deeply [
+ map { strip_path( $_ ) } $ftl->list_dir(
+ $tempdir => {
+ dirs_match => { or => [ qr/^.foo/, qr/ar$/ ] },
+ files_match => { and => [ qr/^[ij]/, qr/\.\w+/ ] },
+ recurse => 1,
+ files_only => 1,
+ }
+ )
+], [ qw( i.jpg j.xls ) ],
+ 'a different recursive OR dirs_match + AND files_match';
+
+is_deeply [
+ map { strip_path( $_ ) } $ftl->list_dir(
+ $tempdir => {
+ parent_matches => { and => [ qr/^.b/, qr/ar$/ ] },
+ files_match => { and => [ qr/^[ij]/, qr/\.\w{3}/ ] },
+ recurse => 1,
+ files_only => 1,
+ }
+ )
+], [ qw( i.jpg j.xls ) ],
+ 'recursive AND parent_matches + AND files_match';
+
+is_deeply [
+ map { strip_path( $_ ) } $ftl->list_dir(
+ $tempdir => {
+ parent_matches => qr/^[[:alnum:]\-_\.]+$/,
+ files_match => qr/^[def]/,
+ recurse => 1,
+ files_only => 1,
+ }
+ )
+], [ qw( d.bat e.sh f.conf ) ],
+ 'recursive single arg parent_matches + single arg files_match';
+
+is_deeply [
+ map { strip_path( $_ ) } $ftl->list_dir(
+ $tempdir => {
+ parent_matches => qr/^.bar$/,
+ files_match => qr/^[jkl]/,
+ recurse => 1,
+ files_only => 1,
+ }
+ )
+], [ qw( j.xls k.ppt l.scr ) ],
+ 'a different recursive single arg parent_matches + single arg files_match';
+
+is_deeply [
+ map { strip_path( $_ ) } $ftl->list_dir(
+ $tempdir => {
+ parent_matches => qr/^.bar$/,
+ rpattern => '^[jk]',
+ recurse => 1,
+ files_only => 1,
+ }
+ )
+], [ qw( j.xls k.ppt ) ],
+ 'recursive single arg parent_matches + legacy files match (rpattern="...")';
+
+is_deeply [
+ map { strip_path( $_ ) } $ftl->list_dir(
+ $tempdir => {
+ parent_matches => { or => [ qr/^[[:alnum:]\-_\.]+$/, qr/bar$/ ] },
+ files_match => qr/^[ak]/,
+ recurse => 1,
+ files_only => 1,
+ }
+ )
+], [ qw( a.txt k.ppt ) ],
+ 'recursive OR parent_matches + single arg files_match';
+
+is_deeply [
+ map { strip_path( $_ ) } $ftl->list_dir(
+ $tempdir => {
+ path_matches => { and => [ qr/foo/, qr/bar$/ ] },
+ recurse => 1,
+ }
+ )
+], [ qw( zbar i.jpg j.xls k.ppt l.scr m.html n.js o.css p.avi ) ],
+ 'recursive AND path_matches';
+
+is_deeply [
+ map { strip_path( $_ ) } $ftl->list_dir(
+ $tempdir => {
+ path_matches => { or => [ qr/foo$/, qr/bar$/ ] },
+ recurse => 1,
+ }
+ )
+], [ qw( xfoo zbar i.jpg j.xls k.ppt l.scr m.html n.js o.css p.avi ) ],
+ 'recursive OR path_matches';
+
+is_deeply [
+ map { strip_path( $_ ) } $ftl->list_dir(
+ $tempdir => {
+ path_matches => { and => [ qr/foo$/, qr/bar$/ ] },
+ recurse => 1,
+ }
+ )
+], [ ],
+ 'recursive AND path_matches that should return an empty list';
+
+is_deeply [
+ map { strip_path( $_ ) } $ftl->list_dir(
+ $tempdir => {
+ path_matches => { or => [ qr/foo$/, qr/bar$/ ] },
+ dirs_only => 1,
+ recurse => 1,
+ }
+ )
+], [ qw( xfoo zbar ) ],
+ 'recursive OR path_matches returning only directories';
+
+is_deeply [
+ map { strip_path( $_ ) } $ftl->list_dir(
+ $tempdir => {
+ path_matches => qr/bar$/,
+ dirs_only => 1,
+ recurse => 1,
+ }
+ )
+], [ qw( zbar ) ],
+ 'recursive single arg path_matches returning only directories';
+
+exit;
+
+sub setup_test_tree {
+
+ my @test_files = qw(
+ a.txt b.log
+ c.ini d.bat
+ e.sh f.conf
+ g.bin h.rc
+ );
+
+ for my $tfile ( @test_files )
+ {
+ $ftl->touch( $tempdir . SL . $tfile );
+ }
+
+ my $deeper = $tempdir . SL . 'xfoo' . SL . 'zbar';
+
+ $ftl->make_dir( $deeper );
+
+ @test_files = qw(
+ i.jpg j.xls
+ k.ppt l.scr
+ m.html n.js
+ o.css p.avi
+ );
+
+ for my $tfile ( @test_files )
+ {
+ $ftl->write_file( { file => $deeper . SL . $tfile, content => rand } );
+ }
+
+ return;
+}
+
+
@@ -0,0 +1,71 @@
+
+use strict;
+use warnings;
+
+use Test::More tests => 4;
+use Test::NoWarnings;
+
+use File::Temp qw( tempdir );
+
+use lib './lib';
+use File::Util qw( SL );
+
+# one recognized instantiation setting
+my $ftl = File::Util->new( );
+
+$ftl->use_flock( 0 ) if $^O =~ /solaris|sunos/i;
+
+my $tempdir = tempdir( CLEANUP => 1 );
+
+my $testbed = setup_test_tree();
+
+my $dir_ref = $ftl->load_dir( $testbed );
+
+is_deeply $dir_ref => {
+ 'o.css' => 'JAPH',
+ 'l.scr' => 'JAPH',
+ 'i.jpg' => 'JAPH',
+ 'm.html' => 'JAPH',
+ 'k.ppt' => 'JAPH',
+ 'j.xls' => 'JAPH',
+ 'p.avi' => 'JAPH',
+ 'n.js' => 'JAPH'
+} => 'load_dir() loads directory into hashref';
+
+$dir_ref = $ftl->load_dir( $testbed => { as_listref => 1 } );
+
+is_deeply $dir_ref => [
+ ( 'JAPH' ) x 8
+] => 'load_dir() loads directory into listref';
+
+$dir_ref = [ $ftl->load_dir( $testbed => { as_list => 1 } ) ];
+
+is_deeply $dir_ref => [
+ ( 'JAPH' ) x 8
+] => 'load_dir() loads directory into list';
+
+exit;
+
+sub setup_test_tree {
+
+ my $deeper = $tempdir . SL . 'xfoo' . SL . 'zbar';
+
+ $ftl->make_dir( $deeper );
+
+ my @test_files = qw(
+ i.jpg j.xls
+ k.ppt l.scr
+ m.html n.js
+ o.css p.avi
+ );
+
+ for my $tfile ( @test_files )
+ {
+ $ftl->write_file( { file => $deeper . SL . $tfile, content => 'JAPH' } );
+ }
+
+ return $deeper;
+}
+
+
+
@@ -0,0 +1,86 @@
+
+use strict;
+use warnings;
+
+use Test::More tests => 4;
+use Test::NoWarnings;
+
+use File::Temp qw( tempdir );
+
+use lib './lib';
+use File::Util qw( SL OS );
+
+# one recognized instantiation setting
+my $ftl = File::Util->new( );
+
+$ftl->use_flock( 0 ) if $^O =~ /solaris|sunos/i;
+
+my $tempdir = tempdir( CLEANUP => 1 );
+
+my @test_files = qw(
+ i.jpg j.xls
+ k.ppt l.scr
+ m.html n.js
+ o.css p.avi
+);
+
+write_ref_args();
+
+my $dir_ref = $ftl->load_dir( $tempdir => { as_listref => 1 } );
+
+is_deeply $dir_ref => [
+ ( 'PeRl' ) x 8
+] => 'write_file writes right w/ ref args';
+
+write_two_args();
+
+$dir_ref = $ftl->load_dir( $tempdir => { as_listref => 1 } );
+
+is_deeply $dir_ref => [
+ ( 'JAPH' ) x 8
+] => 'write_file writes right w/ 2 args';
+
+write_hybrid();
+
+$dir_ref = $ftl->load_dir( $tempdir => { as_listref => 1 } );
+
+is_deeply $dir_ref => [
+ ( 'JAPHRaptor' ) x 8
+] => 'write_file appends right w/ 2 args + opts hashref';
+
+exit;
+
+sub write_ref_args {
+
+ for my $tfile ( @test_files )
+ {
+ $ftl->write_file(
+ { file => $tempdir . SL . $tfile, content => 'PeRl' }
+ );
+ }
+
+ return;
+}
+
+sub write_two_args {
+
+ for my $tfile ( @test_files )
+ {
+ $ftl->write_file( $tempdir . SL . $tfile => 'JAPH' );
+ }
+
+ return;
+}
+
+sub write_hybrid {
+
+ for my $tfile ( @test_files )
+ {
+ $ftl->write_file(
+ $tempdir . SL . $tfile => 'Raptor' => { mode => 'append' }
+ );
+ }
+
+ return;
+}
+
diff --git a/var/tmp/source/TOMMY/File-Util-3.27/File-Util-3.27/t/bin b/var/tmp/source/TOMMY/File-Util-4.132140/File-Util-4.132140/t/bin
old mode 100755
new mode 100644
diff --git a/var/tmp/source/TOMMY/File-Util-3.27/File-Util-3.27/t/txt b/var/tmp/source/TOMMY/File-Util-4.132140/File-Util-4.132140/t/txt
old mode 100755
new mode 100644
@@ -0,0 +1,12 @@
+#!perl
+
+use strict;
+use warnings;
+
+use Test::More;
+use English qw(-no_match_vars);
+
+eval "use Test::Perl::Critic";
+plan skip_all => 'Test::Perl::Critic required to criticise code' if $@;
+Test::Perl::Critic->import( -profile => "perlcritic.rc" ) if -e "perlcritic.rc";
+all_critic_ok();
@@ -0,0 +1,63 @@
+use strict;
+use warnings;
+use Test::More;
+
+# generated by Dist::Zilla::Plugin::Test::PodSpelling 2.004004
+eval "use Test::Spelling 0.12; use Pod::Wordlist::hanekomu; 1" or die $@;
+
+
+add_stopwords(<DATA>);
+all_pod_files_spelling_ok( qw( bin lib ) );
+__DATA__
+AND'ed
+ascii
+bitmask
+BrowserUk
+BLOCKEX
+CIFS
+conf
+dat
+dbitmask
+ebcdic
+EBCDIC
+EPOC
+failsafe
+FIFOs
+Github
+html
+inodes
+listrefs
+NFS
+oct
+onfail
+SIGNES
+SMB
+Solaris
+SOLARIS
+subpattern
+subref
+subrefs
+syntaxes
+trunc
+txt
+unicode
+VMS
+vtab
+benchmarking
+merchantability
+lexically
+Tommy
+Butler
+lib
+File
+Util
+Interface
+Modern
+Definitions
+Cookbook
+Exception
+Diagnostic
+Standard
+Classic
+Manual
+Examples
@@ -0,0 +1,11 @@
+#!perl
+
+use strict;
+use warnings;
+
+use Test::More 0.96 tests => 2;
+use_ok('Test::CPAN::Changes');
+subtest 'changes_ok' => sub {
+ changes_file_ok('Changes');
+};
+done_testing();
@@ -0,0 +1,386 @@
+
+use strict;
+use warnings;
+
+use Test::More;
+use File::Temp qw( tempdir );
+
+use lib './lib';
+
+use File::Util qw( SL NL existent );
+
+# ----------------------------------------------------------------------
+# determine if we can run these fatal tests
+# ----------------------------------------------------------------------
+BEGIN {
+
+ if ( $^O !~ /bsd|linux|cygwin/i )
+ {
+ plan skip_all => 'this OS doesn\'t fail reliably - chmod() issues';
+ }
+ # the tests in this file have a higher probability of failing in the
+ # wild, and so are reserved for the author/maintainers as release tests.
+ # these tests also won't reliably run on platforms that can't run or
+ # can't respect chmod()... e.g.- windows (and even cygwin to some extent)
+ elsif ( $ENV{RELEASE_TESTING} || $ENV{AUTHOR_TESTING} || $ENV{AUTHOR_TESTS} )
+ {
+ {
+ local $@;
+
+ CORE::eval 'use Test::Fatal';
+
+ if ( $@ )
+ {
+ plan skip_all => 'Need Test::Fatal to run these tests';
+ }
+ else
+ {
+ require Test::Fatal;
+
+ Test::Fatal->import( qw( exception dies_ok lives_ok ) );
+
+ plan tests => 36;
+
+ CORE::eval <<'__TEST_NOWARNINGS__';
+use Test::NoWarnings;
+__TEST_NOWARNINGS__
+ }
+ }
+ }
+ else
+ {
+ plan skip_all => 'these tests are for testing by the author';
+ }
+}
+
+my $ftl = File::Util->new();
+my $tempdir = tempdir( CLEANUP => 1 );
+my $exception;
+
+# ----------------------------------------------------------------------
+# set ourselves up for failure
+# ----------------------------------------------------------------------
+
+# list of methods that will throw a special exception unless they get
+# the input that they require
+my @methods_that_need_input = qw(
+ list_dir load_file write_file touch
+ load_dir make_dir open_handle
+);
+
+# make an inaccessible file
+my $noaccess_file = make_inaccessible_file( 'noaccess.txt' );
+
+# make a directory, inaccessible
+my $noaccess_dir = make_inaccessible_dir( 'noaccess/' );
+
+# make a somewhat-deep temp dir structure
+$ftl->make_dir( $tempdir . SL . 'a' . SL . 'b' . SL . 'c' );
+
+# ----------------------------------------------------------------------
+# let the fail begin
+# ----------------------------------------------------------------------
+
+# just test the onfail toggle for all recognized key words. This needs
+# to be revisited to test the actual effect of a given call on a File::Util
+# object, and not merely whether or not they return as expected.
+is $ftl->onfail(), 'die', 'onfail "die" is default OK';
+
+$ftl->onfail( 'zero' );
+is $ftl->onfail(), 'zero', 'onfail "zero" setting toggled OK';
+
+$ftl->onfail( 'warn' );
+is $ftl->onfail(), 'warn', 'onfail "warn" setting toggled OK';
+
+$ftl->onfail( 'message' );
+is $ftl->onfail(), 'message', 'onfail "message" setting toggled OK';
+
+$ftl->onfail( sub { } );
+is ref $ftl->onfail(), 'CODE', 'onfail "callback" setting toggled OK';
+
+$ftl->onfail( 'die' );
+is $ftl->onfail(), 'die', 'onfail "die" setting toggled OK';
+
+# the first of our real tests are several simple failure scenarios wherein
+# no input is sent to a given method that requires it.
+for my $method ( @methods_that_need_input )
+{
+ # send no input to $method
+ $exception = exception { $ftl->$method() };
+
+ like $exception,
+ qr/(?m)^Call to \( $method\(\) \) failed:/,
+ sprintf 'send no input to %s()', $method;
+}
+
+# try to read-open a file that doesn't exist
+$exception = exception { $ftl->load_file( get_nonexistent_file() ) };
+
+like $exception,
+ qr/(?m)^File inaccessible or does not exist:/,
+ 'attempt to read non-existant file';
+
+# try to set a bad flock policy
+$exception = exception { $ftl->flock_rules( 'dummy' ) };
+
+like $exception,
+ qr/(?m)^Invalid file locking policy/,
+ 'make a call to flock_rules() with improper input';
+
+# try to read an inaccessible file
+$exception = exception { $ftl->load_file( $noaccess_file ) };
+
+like $exception,
+ qr/(?m)^Permissions conflict\. Can't read:/,
+ 'attempt to read an inaccessible file';
+
+# try to write to an inaccessible file
+$exception = exception { $ftl->write_file( $noaccess_file => 'dummycontent' ) };
+
+like $exception,
+ qr/(?m)^Permissions conflict\. Can't write to:/,
+ 'attempt to write to an inaccessible file';
+
+# try to access a file in an inaccessible directory
+$exception = exception { $ftl->load_file( $noaccess_dir . SL . 'dummyfile' ) };
+
+like $exception,
+ qr/(?m)^File inaccessible|^Permissions conflict/,
+ 'attempt to read a file in a restricted directory';
+
+# try to create a file in the inaccessible directory
+$exception = exception
+{
+ $ftl->write_file( $noaccess_dir . SL . 'dummyfile' => 'dummycontent' )
+};
+
+like $exception,
+ qr/(?m)^Permissions conflict. Can't (?:create|write)/, # cygwin differs
+ 'attempt to create a file in a restricted directory';
+
+# try to open a directory as a file for reading
+$exception = exception { $ftl->load_file( '.' ) };
+
+like $exception,
+ qr/(?m)^Can't call open\(\) on a directory:/,
+ 'attempt to do file open() on a directory (read)';
+
+# try to open a directory as a file for writing
+$exception = exception { $ftl->write_file( '.' => 'dummycontent' ) };
+
+like $exception,
+ qr/(?m)^File already exists as directory:/,
+ 'attempt to do file open() on a directory (write)';
+
+# try to open a file with a bad "mode" argument
+$exception = exception
+{
+ $ftl->write_file(
+ {
+ filename => 'dummyfile',
+ content => 'dummycontent',
+ mode => 'chuck norris', # << invalid
+ onfail => 'roundhouse', # << invalid
+ }
+ )
+};
+
+like $exception,
+ qr/(?m)^Illegal mode specified for file open:/,
+ 'provide illegal open "mode" to write_file()';
+
+# try to SYSopen a file with a bad "mode" argument
+$exception = exception
+{
+ $ftl->open_handle
+ (
+ {
+ use_sysopen => 1,
+ filename => 'dummyfile',
+ mode => 'stealth monkey', # << invalid
+ }
+ )
+};
+
+like $exception,
+ qr/(?m)^Illegal mode specified for sysopen:/,
+ 'provide illegal SYSopen "mode" to write_file()';
+
+# try to opendir on an inaccessible directory
+$exception = exception { $ftl->list_dir( $noaccess_dir ) };
+
+like $exception,
+ qr/(?m)^Can't opendir on directory:/,
+ 'attempt list_dir() on an inaccessible directory';
+
+# try to makedir in an inaccessible directory
+$exception = exception
+{ $ftl->make_dir( $noaccess_dir . SL . 'snowballs_chance/' ) };
+
+like $exception,
+ qr/(?m)^Permissions conflict\. Can't create directory:/,
+ 'attempt make_dir() in an inaccessible directory';
+
+# try to makedir for an existent directory
+$exception = exception { $ftl->make_dir( '.' ) };
+
+like $exception,
+ qr/(?m)^make_dir target already exists:/,
+ 'attempt make_dir() for a directory that already esists';
+
+# try to makedir on a file
+$exception = exception { $ftl->make_dir( __FILE__ ) };
+
+like $exception,
+ qr/(?m)^Can't make directory; already exists as a file/,
+ 'attempt make_dir() on a file';
+
+# try to list_dir() on a file
+$exception = exception { $ftl->list_dir( __FILE__ ) };
+
+like $exception,
+ qr/(?m)^Can't opendir\(\) on non-directory:/,
+ 'attempt to list_dir() on a file';
+
+# try to read more data from a file than the enforced read_limit amount
+# ...we set the read_limit purposely low to induce the error
+$exception = exception { $ftl->load_file( __FILE__, { read_limit => 0 } ) };
+
+like $exception,
+ qr/(?m)^Stopped reading:/,
+ 'attempt to read a file that\'s bigger than the set read_limit';
+
+# send bad input to abort_depth()
+$exception = exception { $ftl->abort_depth( 'cheezburger' ) };
+
+like $exception,
+ qr/(?m)^Bad input provided to abort_depth/,
+ 'make a call to abort_depth() with improper input';
+
+# send bad input to read_limit()
+$exception = exception { $ftl->read_limit( 'woof!' ) };
+
+like $exception,
+ qr/(?m)^Bad input provided to read_limit/,
+ 'make a call to read_limit() with improper input';
+
+# intentionally exceed abort_depth
+$exception = exception
+{
+ $ftl->list_dir( $tempdir => { recurse => 1, abort_depth => 1 } )
+};
+
+like $exception,
+ qr/(?m)^Recursion limit exceeded/,
+ 'attempt to list_dir recursively past abort_depth limit';
+
+# call write_file() with an invalid file handle
+$exception = exception
+{
+ $ftl->load_file( file_handle => 'not a file handle at all' )
+};
+
+like $exception,
+ qr/a true file handle reference/,
+ 'call write_file with a file handle that is invalid (not a real FH ref)';
+
+# Knowing that the two tests below call File::Util methods with built-in
+# onfail callbacks to handle issues when they can't create leading directories,
+# and knowing that we're calling the methods in a way they will fail, we
+# know that our own onfail callbacks (below) should return what we expect
+# as long as the built-in onfail callbacks fire them off (repeater-style).
+# The built-in onfail callbacks wrap around the callbacks we define below
+# and make sure that those custom callbacks get invoked properly.
+
+is $ftl->write_file(
+ $noaccess_dir . SL . 'my' . SL . 'dog' . SL . 'rover', 'woof!' => {
+ onfail => sub { return 'lassie' }
+ }
+), 'lassie', 'test native onfail callback repeater mechanism in write_file()';
+
+is $ftl->open_handle(
+ $noaccess_dir . SL . 'my' . SL . 'friend' . SL . 'john' => {
+ onfail => sub { return 'ian' }
+ }
+), 'ian', 'test native onfail callback repeater mechanism in open_handle()';
+
+# ----------------------------------------------------------------------
+# clean up restricted-access files/dirs, and exit
+# ----------------------------------------------------------------------
+
+remove_inaccessible_file( $noaccess_file );
+remove_inaccessible_dir( $noaccess_dir );
+
+exit;
+
+
+# ----------------------------------------------------------------------
+# supporting subroutines
+# ----------------------------------------------------------------------
+
+sub make_inaccessible_file
+{
+ my $filename = $ftl->strip_path( shift @_ );
+
+ $filename = $tempdir . SL . $filename;
+
+ $ftl->touch( $filename );
+
+ chmod oct 0, $filename or die $!;
+
+ return $filename;
+}
+
+sub remove_inaccessible_file
+{
+ my $filename = $ftl->strip_path( shift @_ );
+
+ $filename = $tempdir . SL . $filename;
+
+ chmod oct 777, $filename or die $!;
+
+ unlink $filename or die $!;
+}
+
+sub make_inaccessible_dir
+{
+ my $dirname = shift @_;
+
+ $dirname = $tempdir . SL . $dirname;
+
+ $ftl->make_dir( $dirname );
+
+ $ftl->touch( $dirname . SL . 'dummyfile' );
+
+ chmod oct 0, $dirname . SL . 'dummyfile' or die $!;
+ chmod oct 0, $dirname or die $!;
+
+ return $dirname;
+}
+
+sub remove_inaccessible_dir
+{
+ my $dirname = $ftl->strip_path( shift @_ );
+
+ $dirname = $tempdir . SL . $dirname;
+
+ chmod oct 777, $dirname or die $!;
+ chmod oct 777, $dirname . SL . 'dummyfile' or die $!;
+
+ unlink $dirname . SL . 'dummyfile' or die $!;
+
+ rmdir $dirname or die $!;
+}
+
+sub get_nonexistent_file
+{
+ my $file = ( rand 100 ) . time . $$;
+
+ while ( -e $file )
+ {
+ $file = get_nonexistent_file();
+ }
+
+ return $file;
+}
+
@@ -0,0 +1,668 @@
+
+use strict;
+use warnings;
+
+use Test::More;
+
+if ( $ENV{RELEASE_TESTING} || $ENV{AUTHOR_TESTING} || $ENV{AUTHOR_TESTS} )
+{ # the tests in this file have a higher probability
+ plan tests => 68; # of failing in the wild, and so are reserved for
+ # the author/maintainers as release tests
+ CORE::eval # hide the eval...
+ '
+use Test::NoWarnings;
+ '; # ...from dist parsers
+}
+else
+{
+ plan skip_all => 'these tests are for testing by the author';
+}
+
+use lib './lib';
+use File::Util qw( SL NL existent );
+
+my $f = File::Util->new( fatals_as_errmsg => 1 );
+
+# start testing failure sequence
+# 1
+like(
+ $f->_throw(
+ 'no such file' =>
+ {
+ filename => __FILE__,
+ fatals_as_errmsg => 1,
+ diag => 1,
+ }
+ ), qr/inaccessible or does not exist/,
+ 'no such file (diagnostic mode)'
+);
+
+# 1.5
+like(
+ $f->_throw(
+ 'no such file' =>
+ {
+ filename => __FILE__,
+ fatals_as_errmsg => 1,
+ }
+ ), qr/inaccessible or does not exist/,
+ 'no such file'
+);
+
+# 2
+like(
+ $f->_throw(
+ 'bad flock rules' => {
+ bad => __FILE__,
+ all => [ $f->flock_rules() ],
+ diag => 1,
+ }
+ ),
+ qr/Invalid file locking policy/,
+ 'bad flock rules (diagnostic mode)'
+);
+
+is $f->diagnostic( 1 ), 1,
+ 'manually toggle on diagnostic mode for entire object';
+
+# 2.25
+like(
+ $f->_throw(
+ 'bad flock rules' => {
+ bad => __FILE__,
+ all => [ $f->flock_rules() ],
+ }
+ ),
+ qr/Invalid file locking policy/,
+ 'bad flock rules (diagnostic mode) after manual object-wide diag toggle'
+);
+
+# 2.5
+like(
+ $f->_throw(
+ 'bad flock rules' => {
+ bad => __FILE__,
+ all => [ $f->flock_rules() ],
+ }
+ ),
+ qr/(?sm)^Invalid file locking policy/,
+ 'bad flock rules'
+);
+
+is $f->diagnostic( 0 ), 0,
+ 'manually toggle off diagnostic mode for entire object';
+
+# 3
+like(
+ $f->_throw(
+ 'cant fread' => {
+ filename => __FILE__,
+ dirname => '.',
+ diag => 1,
+ }
+ ),
+ qr/Permissions conflict\..+?can't read the contents of this file:/,
+ 'cant fread (diagnostic mode)'
+);
+
+# 3.5
+like(
+ $f->_throw(
+ 'cant fread' => {
+ filename => __FILE__,
+ dirname => '.',
+ }
+ ),
+ qr/(?sm)^Permissions conflict\. Can't read:/,
+ 'cant fread'
+);
+
+# 4
+like(
+ $f->_throw( 'cant fread not found' => { diag => 1, filename => __FILE__ } ),
+ qr/File not found\. .+?can't read the contents of this file\:/,
+ 'cant fread no exists (diagnostic mode)'
+);
+
+# 4.5
+like(
+ $f->_throw( 'cant fread not found' => { filename => __FILE__ } ),
+ qr/(?sm)^File not found:/,
+ 'cant fread no exists'
+);
+
+# 5
+like(
+ $f->_throw(
+ 'cant fcreate' => {
+ filename => __FILE__,
+ dirname => '.',
+ diag => 1,
+ }
+ ),
+ qr/Permissions conflict\..+?can't create this file:/,
+ 'cant fcreate (diagnostic mode)'
+);
+
+# 5.5
+like(
+ $f->_throw(
+ 'cant fcreate' => {
+ filename => __FILE__,
+ dirname => '.',
+ }
+ ),
+ qr/(?sm)^Permissions conflict\. Can't create:/,
+ 'cant fcreate'
+);
+
+# 6
+like( $f->_throw( 'cant write_file on a dir' => { diag => 1, filename => __FILE__ } ),
+ qr/can't write to the specified file/,
+ 'cant write_file on a dir (diagnostic mode)'
+);
+
+# 6.5
+like( $f->_throw( 'cant write_file on a dir' => { filename => __FILE__ } ),
+ qr/(?sm)^File already exists as directory:/,
+ 'cant write_file on a dir'
+);
+
+# 7
+like(
+ $f->_throw(
+ 'cant fwrite' => {
+ filename => __FILE__,
+ dirname => '.',
+ diag => 1,
+ }
+ ),
+ qr/Permissions conflict\..+?can't write to this file:/,
+ 'cant fwrite (diagnostic mode)'
+);
+
+# 7.5
+like(
+ $f->_throw(
+ 'cant fwrite' => {
+ filename => __FILE__,
+ dirname => '.',
+ }
+ ),
+ qr/(?sm)^Permissions conflict\. Can't write to:/,
+ 'cant fwrite'
+);
+
+# 8
+like(
+ $f->_throw(
+ 'bad openmode popen' => {
+ filename => __FILE__,
+ badmode => 'illegal',
+ meth => 'anonymous',
+ diag => 1,
+ }
+ ),
+ qr/Illegal mode specified for file open\./,
+ 'bad openmode popen (diagnostic mode)'
+);
+
+# 8.5
+like(
+ $f->_throw(
+ 'bad openmode popen' => {
+ filename => __FILE__,
+ badmode => 'illegal',
+ meth => 'anonymous',
+ }
+ ),
+ qr/(?sm)^Illegal mode specified for file open:/,
+ 'bad openmode popen'
+);
+
+# 9
+like(
+ $f->_throw(
+ 'bad openmode sysopen' => {
+ filename => __FILE__,
+ badmode => 'illegal',
+ meth => 'anonymous',
+ diag => 1,
+ }
+ ),
+ qr/Illegal mode specified for file sysopen/,
+ 'bad openmode sysopen (diagnostic mode)'
+);
+
+# 9.5
+like(
+ $f->_throw(
+ 'bad openmode sysopen' => {
+ filename => __FILE__,
+ badmode => 'illegal',
+ meth => 'anonymous',
+ }
+ ),
+ qr/(?sm)^Illegal mode specified for sysopen:/,
+ 'bad openmode sysopen'
+);
+
+# 10
+like( $f->_throw( 'cant dread' => { diag => 1, dirname => '.' } ),
+ qr/Permissions conflict\..+?can't list the contents of this/,
+ 'cant dread (diagnostic mode)'
+);
+
+# 10.5
+like( $f->_throw( 'cant dread' => { dirname => '.' } ),
+ qr/(?sm)^Permissions conflict\. Can't list directory:/,
+ 'cant dread'
+);
+
+# 11
+like(
+ $f->_throw(
+ 'cant dcreate' => {
+ dirname => '.',
+ parentd => '..',
+ diag => 1,
+ }
+ ),
+ qr/Permissions conflict\..+?can't create:/,
+ 'cant dcreate (diagnostic mode)'
+);
+
+# 11.5
+like(
+ $f->_throw(
+ 'cant dcreate' => {
+ dirname => '.',
+ parentd => '..',
+ }
+ ),
+ qr/(?sm)^Permissions conflict\. Can't create directory:/,
+ 'cant dcreate'
+);
+
+# 12
+like(
+ $f->_throw(
+ 'make_dir target exists' => {
+ dirname => '.',
+ filetype => [ $f->file_type('.') ],
+ diag => '.',
+ }
+ ),
+ qr/make_dir target already exists\./,
+ 'make_dir target exists (diagnostic mode)'
+);
+
+# 12.5
+like(
+ $f->_throw(
+ 'make_dir target exists' => {
+ dirname => '.',
+ filetype => [ $f->file_type('.') ],
+ }
+ ),
+ qr/(?sm)^make_dir target already exists:/,
+ 'make_dir target exists'
+);
+
+# 13
+like(
+ $f->_throw(
+ 'bad open' => {
+ mode => 'illegal mode',
+ filename => __FILE__,
+ exception => 'dummy',
+ cmd => 'illegal cmd',
+ diag => 1,
+ }
+ ),
+ qr/can't open this file for.+?illegal mode/,
+ 'bad open (diagnostic mode)'
+);
+
+# 13.5
+like(
+ $f->_throw(
+ 'bad open' => {
+ mode => 'illegal mode',
+ filename => __FILE__,
+ exception => 'dummy',
+ cmd => 'illegal cmd',
+ }
+ ),
+ qr/(?sm)^Can't open:/,
+ 'bad open'
+);
+
+# 14
+like(
+ $f->_throw(
+ 'bad close' => {
+ mode => 'illegal mode',
+ filename => __FILE__,
+ exception => 'dummy',
+ diag => 1,
+ }
+ ),
+ qr/couldn't close this file after.+?illegal mode/,
+ 'bad close (diagnostic mode)'
+);
+
+# 14.5
+like(
+ $f->_throw(
+ 'bad close' => {
+ mode => 'illegal mode',
+ filename => __FILE__,
+ exception => 'dummy',
+ }
+ ),
+ qr/(?sm)^Couldn't close:/,
+ 'bad close'
+);
+
+# 15
+like(
+ $f->_throw(
+ 'bad systrunc' => {
+ filename => __FILE__,
+ exception => 'dummy',
+ diag => 1,
+ }
+ ),
+ qr/couldn't truncate\(\) on.+?after having/,
+ 'bad systrunc (diagnostic mode)'
+);
+
+# 15.5
+like(
+ $f->_throw(
+ 'bad systrunc' => {
+ filename => __FILE__,
+ exception => 'dummy',
+ }
+ ),
+ qr/(?sm)^Couldn't truncate\(\) on/,
+ 'bad systrunc'
+);
+
+# 16
+like(
+ $f->_throw(
+ 'bad flock' => {
+ filename => __FILE__,
+ exception => 'illegal',
+ diag => 1
+ }
+ ),
+ qr/can't get a lock on the file/,
+ 'bad flock (diagnostic mode)'
+);
+
+# 16.5
+like(
+ $f->_throw(
+ 'bad flock' => {
+ filename => __FILE__,
+ exception => 'illegal',
+ }
+ ),
+ qr/(?sm)^Can't get a lock on the file:/,
+ 'bad flock'
+);
+
+# 17
+like( $f->_throw( 'called open on a dir' => { diag => 1, filename => __FILE__ } ),
+ qr/can't call open\(\) on this file because it is a directory/,
+ 'called open on a dir (diagnostic mode)'
+);
+
+# 17.5
+like( $f->_throw( 'called open on a dir' => { filename => __FILE__ } ),
+ qr/(?sm)^Can't call open\(\) on a directory:/,
+ 'called open on a dir'
+);
+
+# 18
+like( $f->_throw( 'called opendir on a file' => { diag => 1, filename => __FILE__ } ),
+ qr/can't opendir\(\) on this file because it is not a directory/,
+ 'called opendir on a file (diagnostic mode)'
+);
+
+# 18.5
+like( $f->_throw( 'called opendir on a file' => { filename => __FILE__ } ),
+ qr/(?sm)^Can't opendir\(\) on non-directory:/,
+ 'called opendir on a file'
+);
+
+# 19
+like( $f->_throw( 'called mkdir on a file' => { diag => 1, filename => __FILE__ } ),
+ qr/can't auto-create a directory for this path name because/,
+ 'called mkdir on a file (diagnostic mode)'
+);
+
+# 19.5
+like( $f->_throw( 'called mkdir on a file' => { filename => __FILE__ } ),
+ qr/(?sm)^Can't make directory; already exists as a file\./,
+ 'called mkdir on a file'
+);
+
+# 20
+like( $f->_throw( 'bad read_limit' => { read_limit => 42, diag => 1 } ),
+ qr/Bad call to .+?\:\:read_limit\(\)\. This method can only be/,
+ 'bad read_limit (diagnostic mode)'
+);
+
+# 20.5
+like( $f->_throw( 'bad read_limit' => { read_limit => 42 } ),
+ qr/(?sm)^Bad input provided to read_limit\(\)/,
+ 'bad read_limit'
+);
+
+# 21
+like(
+ $f->_throw(
+ 'read_limit exceeded' => {
+ filename => __FILE__,
+ size => 'testtesttest',
+ read_limit => 42,
+ diag => 1,
+ }
+ ),
+ qr/(?sm)can't load file.+?into memory because its size exceeds/,
+ 'read_limit exceeded (diagnostic mode)'
+);
+
+# 21.5
+like(
+ $f->_throw(
+ 'read_limit exceeded' => {
+ filename => __FILE__,
+ size => 'testtesttest',
+ read_limit => 42,
+ }
+ ),
+ qr/(?sm)^Stopped reading:.+?Read limit exceeded:/,
+ 'read_limit exceeded'
+);
+
+# 22
+like( $f->_throw( 'bad abort_depth' => { diag => 1 } ),
+ qr/Bad call to .+?\:\:abort_depth\(\)\. This method can only be/,
+ 'bad abort_depth (diagnostic mode)'
+);
+
+# 22.5
+like( $f->_throw( 'bad abort_depth' => { } ),
+ qr/(?sm)^Bad input provided to abort_depth\(\)/,
+ 'bad abort_depth'
+);
+
+# 23
+like( $f->_throw( 'abort_depth exceeded' => { diag => 1 } ),
+ qr/Recursion limit reached at .+?dives\. The maximum level of/,
+ 'abort_depth exceeded (diagnostic mode)'
+);
+
+# 23.5
+like( $f->_throw( 'abort_depth exceeded' => { } ),
+ qr/(?sm)^Recursion limit exceeded at/,
+ 'abort_depth exceeded'
+);
+
+# 24
+like(
+ $f->_throw(
+ 'bad opendir' => {
+ dirname => '.',
+ exception => 'illegal',
+ diag => 1,
+ }
+ ),
+ qr/can't opendir on directory\:/,
+ 'bad opendir (diagnostic mode)'
+);
+
+# 24.5
+like(
+ $f->_throw(
+ 'bad opendir' => {
+ dirname => '.',
+ exception => 'illegal',
+ }
+ ),
+ qr/(?sm)^Can't opendir on directory:/,
+ 'bad opendir'
+);
+
+# 25
+like(
+ $f->_throw(
+ 'bad make_dir' => {
+ dirname => '.',
+ bitmask => 0777,
+ exception => 'illegal',
+ meth => 'anonymous',
+ diag => 1,
+ }
+ ),
+ qr/had a problem with the system while attempting to create/,
+ 'bad make_dir (diagnostic mode)'
+);
+
+# 25.5
+like(
+ $f->_throw(
+ 'bad make_dir' => {
+ dirname => '.',
+ bitmask => 0777,
+ exception => 'illegal',
+ meth => 'anonymous',
+ }
+ ),
+ qr/(?sm)^Can't create directory:/,
+ 'bad make_dir'
+);
+
+# 26
+like(
+ $f->_throw(
+ 'bad chars' => {
+ string => 'illegal characters',
+ purpose => 'testing',
+ diag => 1,
+ }
+ ),
+ qr/(?sm)can't use this string.+?It contains illegal characters\./,
+ 'bad chars (diagnostic mode)'
+);
+
+# 26.5
+like(
+ $f->_throw(
+ 'bad chars' => {
+ string => 'illegal characters',
+ purpose => 'testing',
+ }
+ ),
+ qr/(?sm)^String contains illegal characters:/,
+ 'bad chars'
+);
+
+# 27
+like( $f->_throw( 'not a filehandle' => { diag => 1, argtype => 'illegal' } ),
+ qr/can't unlock file with an invalid file handle reference\:/,
+ 'not a filehandle (diagnostic mode)'
+);
+
+# 27.5
+like( $f->_throw( 'not a filehandle' => { argtype => 'illegal' } ),
+ qr/(?sm)^Can't unlock file with an invalid file handle reference/,
+ 'not a filehandle'
+);
+
+# 28
+like( $f->_throw( 'no input' => { diag => 1, meth => 'anonymous' } ),
+ qr/(?sm)can't honor your call to.+?because you didn't provide/,
+ 'no input (diagnostic mode)'
+);
+
+# 28.5
+like( $f->_throw( 'no input' => { meth => 'anonymous' } ),
+ qr/(?sm)^Call to.+?failed: Required input missing/,
+ 'no input'
+);
+
+# 29
+like( $f->_throw( 'plain error' => 'testtesttest', diag => 1 ),
+ qr/failed with the following message\:/,
+ 'plain error (diagnostic mode)'
+);
+
+# 29.5
+like( $f->_throw( 'plain error' => 'testtesttest' ),
+ qr/(?sm)^testtesttest/,
+ 'plain error'
+);
+
+# 30
+like( $f->_throw( 'unknown error message' => { diag => 1 } ),
+ qr/failed with an invalid error-type designation\./,
+ 'unknown error message (diagnostic mode)'
+);
+
+# 30.5
+like( $f->_throw( 'unknown error message' => { } ),
+ qr/(?sm)^Failed with an invalid error-type designation\./,
+ 'unknown error message'
+);
+
+# 31
+like( $f->_throw( 'empty error' => { diag => 1 } ),
+ qr/failed with an empty error-type designation\./,
+ 'empty error (diagnostic mode)'
+);
+
+# 31.5
+like( $f->_throw( 'empty error' => { } ),
+ qr/(?sm)^Failed with an empty error-type designation\./,
+ 'empty error'
+);
+
+# 32
+like( $f->_throw( 'no unicode' => { diag => 1 } ),
+ qr/(?sm)can't read\/write with \(binmode => 'utf8'\)/,
+ 'no unicode support (diagnostic mode)'
+);
+
+# 32.5
+like( $f->_throw( 'no unicode' => { } ),
+ qr/(?sm)^Your version of Perl is not new enough/,
+ 'no unicode support'
+);
+
+exit;
@@ -0,0 +1,8 @@
+#!perl
+
+use Test::More;
+
+eval "use Test::DistManifest";
+plan skip_all => "Test::DistManifest required for testing the manifest"
+ if $@;
+manifest_ok();
@@ -0,0 +1,29 @@
+
+use strict;
+use warnings;
+
+use Test::More;
+
+use lib './lib';
+
+if ( !( $ENV{RELEASE_TESTING} || $ENV{AUTHOR_TESTING} || $ENV{AUTHOR_TESTS} ) )
+{
+ plan skip_all => 'these tests are for testing by the author';
+}
+else
+{
+ plan skip_all => 'Test::Portability::Files needed'
+ and last unless eval 'use Test::Portability::Files; 1';
+}
+
+options
+(
+ test_dos_length => 0,
+ test_amiga_length => 0,
+ test_vms_length => 0,
+ test_one_dot => 0,
+);
+
+run_tests();
+
+exit;
@@ -0,0 +1,7 @@
+#!perl
+
+use Test::More;
+
+eval "use Test::CPAN::Meta";
+plan skip_all => "Test::CPAN::Meta required for testing META.yml" if $@;
+meta_yaml_ok();
@@ -0,0 +1,9 @@
+#!perl
+
+# This test is generated by Dist::Zilla::Plugin::Test::Kwalitee
+use strict;
+use warnings;
+use Test::More; # needed to provide plan.
+eval "use Test::Kwalitee";
+
+plan skip_all => "Test::Kwalitee required for testing kwalitee" if $@;
@@ -0,0 +1,112 @@
+#!perl
+
+use strict;
+use warnings;
+
+use FindBin;
+use File::Copy qw(copy);
+use File::Spec;
+use File::Temp;
+use Test::More;
+
+sub copy_log_file {
+ my ( $home ) = @_;
+ my $log_file = File::Spec->catfile($home, '.cpanm', 'build.log');
+ my $tempfile = File::Temp->new(
+ SUFFIX => '.log',
+ UNLINK => 0,
+ );
+ copy($log_file, $tempfile->filename);
+ diag("For details, please consult $tempfile")
+}
+
+sub is_dist_root {
+ my ( @path ) = @_;
+
+ return -e File::Spec->catfile(@path, 'Makefile.PL') ||
+ -e File::Spec->catfile(@path, 'Build.PL');
+}
+
+delete @ENV{qw/AUTHOR_TESTING RELEASE_TESTING/};
+
+unless($ENV{'PERLBREW_ROOT'}) {
+ plan skip_all => "Environment variable 'PERLBREW_ROOT' not found";
+ exit;
+}
+
+my $brew = q[perl-5.10.1];
+
+my $cpanm_path = qx(which cpanm 2>/dev/null);
+unless($cpanm_path) {
+ plan skip_all => "The 'cpanm' program is required to run this test";
+ exit;
+}
+chomp $cpanm_path;
+
+my $perlbrew_bin = File::Spec->catdir($ENV{'PERLBREW_ROOT'}, 'perls',
+ $brew, 'bin');
+
+my ( $env, $status ) = do {
+ local $ENV{'SHELL'} = '/bin/bash'; # fool perlbrew
+ ( scalar(qx(perlbrew env $brew)), $? )
+};
+
+unless($status == 0) {
+ plan skip_all => "No such perlbrew environment '$brew'";
+ exit;
+}
+
+my @lines = split /\n/, $env;
+
+foreach my $line (@lines) {
+ if($line =~ /^\s*export\s+([0-9a-zA-Z_]+)=(.*)$/) {
+ my ( $k, $v ) = ( $1, $2 );
+ if($v =~ /^("|')(.*)\1$/) {
+ $v = $2;
+ $v =~ s!\\(.)!$1!ge;
+ }
+ $ENV{$k} = $v;
+ } elsif($line =~ /^unset\s+([0-9a-zA-Z_]+)/) {
+ delete $ENV{$1};
+ }
+}
+
+my $pristine_path = qx(perlbrew display-pristine-path);
+chomp $pristine_path;
+$ENV{'PATH'} = join(':', $ENV{'PERLBREW_PATH'}, $pristine_path);
+
+plan tests => 1;
+
+my $tmpdir = File::Temp->newdir;
+my $tmphome = File::Temp->newdir;
+
+my $pid = fork;
+if(!defined $pid) {
+ fail "Forking failed!";
+ exit 1;
+} elsif($pid) {
+ waitpid $pid, 0;
+ ok !$?, "cpanm should successfully install your dist with no issues" or copy_log_file($tmphome->dirname);
+} else {
+ close STDOUT;
+ close STDERR;
+
+ my @path = File::Spec->splitdir($FindBin::Bin);
+
+ while(@path && !is_dist_root(@path)) {
+ pop @path;
+ }
+ unless(@path) {
+ die "Unable to find dist root\n";
+ }
+ chdir File::Spec->catdir(@path); # exit test directory
+
+ # override where cpanm puts its log file
+ $ENV{'HOME'} = $tmphome->dirname;
+
+
+
+ delete $ENV{'PERL5LIB'};
+ system 'perl', $cpanm_path, '-L', $tmpdir->dirname, '.';
+ exit($? >> 8);
+}
@@ -0,0 +1,112 @@
+#!perl
+
+use strict;
+use warnings;
+
+use FindBin;
+use File::Copy qw(copy);
+use File::Spec;
+use File::Temp;
+use Test::More;
+
+sub copy_log_file {
+ my ( $home ) = @_;
+ my $log_file = File::Spec->catfile($home, '.cpanm', 'build.log');
+ my $tempfile = File::Temp->new(
+ SUFFIX => '.log',
+ UNLINK => 0,
+ );
+ copy($log_file, $tempfile->filename);
+ diag("For details, please consult $tempfile")
+}
+
+sub is_dist_root {
+ my ( @path ) = @_;
+
+ return -e File::Spec->catfile(@path, 'Makefile.PL') ||
+ -e File::Spec->catfile(@path, 'Build.PL');
+}
+
+delete @ENV{qw/AUTHOR_TESTING RELEASE_TESTING/};
+
+unless($ENV{'PERLBREW_ROOT'}) {
+ plan skip_all => "Environment variable 'PERLBREW_ROOT' not found";
+ exit;
+}
+
+my $brew = q[perl-5.12.5];
+
+my $cpanm_path = qx(which cpanm 2>/dev/null);
+unless($cpanm_path) {
+ plan skip_all => "The 'cpanm' program is required to run this test";
+ exit;
+}
+chomp $cpanm_path;
+
+my $perlbrew_bin = File::Spec->catdir($ENV{'PERLBREW_ROOT'}, 'perls',
+ $brew, 'bin');
+
+my ( $env, $status ) = do {
+ local $ENV{'SHELL'} = '/bin/bash'; # fool perlbrew
+ ( scalar(qx(perlbrew env $brew)), $? )
+};
+
+unless($status == 0) {
+ plan skip_all => "No such perlbrew environment '$brew'";
+ exit;
+}
+
+my @lines = split /\n/, $env;
+
+foreach my $line (@lines) {
+ if($line =~ /^\s*export\s+([0-9a-zA-Z_]+)=(.*)$/) {
+ my ( $k, $v ) = ( $1, $2 );
+ if($v =~ /^("|')(.*)\1$/) {
+ $v = $2;
+ $v =~ s!\\(.)!$1!ge;
+ }
+ $ENV{$k} = $v;
+ } elsif($line =~ /^unset\s+([0-9a-zA-Z_]+)/) {
+ delete $ENV{$1};
+ }
+}
+
+my $pristine_path = qx(perlbrew display-pristine-path);
+chomp $pristine_path;
+$ENV{'PATH'} = join(':', $ENV{'PERLBREW_PATH'}, $pristine_path);
+
+plan tests => 1;
+
+my $tmpdir = File::Temp->newdir;
+my $tmphome = File::Temp->newdir;
+
+my $pid = fork;
+if(!defined $pid) {
+ fail "Forking failed!";
+ exit 1;
+} elsif($pid) {
+ waitpid $pid, 0;
+ ok !$?, "cpanm should successfully install your dist with no issues" or copy_log_file($tmphome->dirname);
+} else {
+ close STDOUT;
+ close STDERR;
+
+ my @path = File::Spec->splitdir($FindBin::Bin);
+
+ while(@path && !is_dist_root(@path)) {
+ pop @path;
+ }
+ unless(@path) {
+ die "Unable to find dist root\n";
+ }
+ chdir File::Spec->catdir(@path); # exit test directory
+
+ # override where cpanm puts its log file
+ $ENV{'HOME'} = $tmphome->dirname;
+
+
+
+ delete $ENV{'PERL5LIB'};
+ system 'perl', $cpanm_path, '-L', $tmpdir->dirname, '.';
+ exit($? >> 8);
+}
@@ -0,0 +1,112 @@
+#!perl
+
+use strict;
+use warnings;
+
+use FindBin;
+use File::Copy qw(copy);
+use File::Spec;
+use File::Temp;
+use Test::More;
+
+sub copy_log_file {
+ my ( $home ) = @_;
+ my $log_file = File::Spec->catfile($home, '.cpanm', 'build.log');
+ my $tempfile = File::Temp->new(
+ SUFFIX => '.log',
+ UNLINK => 0,
+ );
+ copy($log_file, $tempfile->filename);
+ diag("For details, please consult $tempfile")
+}
+
+sub is_dist_root {
+ my ( @path ) = @_;
+
+ return -e File::Spec->catfile(@path, 'Makefile.PL') ||
+ -e File::Spec->catfile(@path, 'Build.PL');
+}
+
+delete @ENV{qw/AUTHOR_TESTING RELEASE_TESTING/};
+
+unless($ENV{'PERLBREW_ROOT'}) {
+ plan skip_all => "Environment variable 'PERLBREW_ROOT' not found";
+ exit;
+}
+
+my $brew = q[perl-5.14.4];
+
+my $cpanm_path = qx(which cpanm 2>/dev/null);
+unless($cpanm_path) {
+ plan skip_all => "The 'cpanm' program is required to run this test";
+ exit;
+}
+chomp $cpanm_path;
+
+my $perlbrew_bin = File::Spec->catdir($ENV{'PERLBREW_ROOT'}, 'perls',
+ $brew, 'bin');
+
+my ( $env, $status ) = do {
+ local $ENV{'SHELL'} = '/bin/bash'; # fool perlbrew
+ ( scalar(qx(perlbrew env $brew)), $? )
+};
+
+unless($status == 0) {
+ plan skip_all => "No such perlbrew environment '$brew'";
+ exit;
+}
+
+my @lines = split /\n/, $env;
+
+foreach my $line (@lines) {
+ if($line =~ /^\s*export\s+([0-9a-zA-Z_]+)=(.*)$/) {
+ my ( $k, $v ) = ( $1, $2 );
+ if($v =~ /^("|')(.*)\1$/) {
+ $v = $2;
+ $v =~ s!\\(.)!$1!ge;
+ }
+ $ENV{$k} = $v;
+ } elsif($line =~ /^unset\s+([0-9a-zA-Z_]+)/) {
+ delete $ENV{$1};
+ }
+}
+
+my $pristine_path = qx(perlbrew display-pristine-path);
+chomp $pristine_path;
+$ENV{'PATH'} = join(':', $ENV{'PERLBREW_PATH'}, $pristine_path);
+
+plan tests => 1;
+
+my $tmpdir = File::Temp->newdir;
+my $tmphome = File::Temp->newdir;
+
+my $pid = fork;
+if(!defined $pid) {
+ fail "Forking failed!";
+ exit 1;
+} elsif($pid) {
+ waitpid $pid, 0;
+ ok !$?, "cpanm should successfully install your dist with no issues" or copy_log_file($tmphome->dirname);
+} else {
+ close STDOUT;
+ close STDERR;
+
+ my @path = File::Spec->splitdir($FindBin::Bin);
+
+ while(@path && !is_dist_root(@path)) {
+ pop @path;
+ }
+ unless(@path) {
+ die "Unable to find dist root\n";
+ }
+ chdir File::Spec->catdir(@path); # exit test directory
+
+ # override where cpanm puts its log file
+ $ENV{'HOME'} = $tmphome->dirname;
+
+
+
+ delete $ENV{'PERL5LIB'};
+ system 'perl', $cpanm_path, '-L', $tmpdir->dirname, '.';
+ exit($? >> 8);
+}
@@ -0,0 +1,112 @@
+#!perl
+
+use strict;
+use warnings;
+
+use FindBin;
+use File::Copy qw(copy);
+use File::Spec;
+use File::Temp;
+use Test::More;
+
+sub copy_log_file {
+ my ( $home ) = @_;
+ my $log_file = File::Spec->catfile($home, '.cpanm', 'build.log');
+ my $tempfile = File::Temp->new(
+ SUFFIX => '.log',
+ UNLINK => 0,
+ );
+ copy($log_file, $tempfile->filename);
+ diag("For details, please consult $tempfile")
+}
+
+sub is_dist_root {
+ my ( @path ) = @_;
+
+ return -e File::Spec->catfile(@path, 'Makefile.PL') ||
+ -e File::Spec->catfile(@path, 'Build.PL');
+}
+
+delete @ENV{qw/AUTHOR_TESTING RELEASE_TESTING/};
+
+unless($ENV{'PERLBREW_ROOT'}) {
+ plan skip_all => "Environment variable 'PERLBREW_ROOT' not found";
+ exit;
+}
+
+my $brew = q[perl-5.16.3];
+
+my $cpanm_path = qx(which cpanm 2>/dev/null);
+unless($cpanm_path) {
+ plan skip_all => "The 'cpanm' program is required to run this test";
+ exit;
+}
+chomp $cpanm_path;
+
+my $perlbrew_bin = File::Spec->catdir($ENV{'PERLBREW_ROOT'}, 'perls',
+ $brew, 'bin');
+
+my ( $env, $status ) = do {
+ local $ENV{'SHELL'} = '/bin/bash'; # fool perlbrew
+ ( scalar(qx(perlbrew env $brew)), $? )
+};
+
+unless($status == 0) {
+ plan skip_all => "No such perlbrew environment '$brew'";
+ exit;
+}
+
+my @lines = split /\n/, $env;
+
+foreach my $line (@lines) {
+ if($line =~ /^\s*export\s+([0-9a-zA-Z_]+)=(.*)$/) {
+ my ( $k, $v ) = ( $1, $2 );
+ if($v =~ /^("|')(.*)\1$/) {
+ $v = $2;
+ $v =~ s!\\(.)!$1!ge;
+ }
+ $ENV{$k} = $v;
+ } elsif($line =~ /^unset\s+([0-9a-zA-Z_]+)/) {
+ delete $ENV{$1};
+ }
+}
+
+my $pristine_path = qx(perlbrew display-pristine-path);
+chomp $pristine_path;
+$ENV{'PATH'} = join(':', $ENV{'PERLBREW_PATH'}, $pristine_path);
+
+plan tests => 1;
+
+my $tmpdir = File::Temp->newdir;
+my $tmphome = File::Temp->newdir;
+
+my $pid = fork;
+if(!defined $pid) {
+ fail "Forking failed!";
+ exit 1;
+} elsif($pid) {
+ waitpid $pid, 0;
+ ok !$?, "cpanm should successfully install your dist with no issues" or copy_log_file($tmphome->dirname);
+} else {
+ close STDOUT;
+ close STDERR;
+
+ my @path = File::Spec->splitdir($FindBin::Bin);
+
+ while(@path && !is_dist_root(@path)) {
+ pop @path;
+ }
+ unless(@path) {
+ die "Unable to find dist root\n";
+ }
+ chdir File::Spec->catdir(@path); # exit test directory
+
+ # override where cpanm puts its log file
+ $ENV{'HOME'} = $tmphome->dirname;
+
+
+
+ delete $ENV{'PERL5LIB'};
+ system 'perl', $cpanm_path, '-L', $tmpdir->dirname, '.';
+ exit($? >> 8);
+}
@@ -0,0 +1,112 @@
+#!perl
+
+use strict;
+use warnings;
+
+use FindBin;
+use File::Copy qw(copy);
+use File::Spec;
+use File::Temp;
+use Test::More;
+
+sub copy_log_file {
+ my ( $home ) = @_;
+ my $log_file = File::Spec->catfile($home, '.cpanm', 'build.log');
+ my $tempfile = File::Temp->new(
+ SUFFIX => '.log',
+ UNLINK => 0,
+ );
+ copy($log_file, $tempfile->filename);
+ diag("For details, please consult $tempfile")
+}
+
+sub is_dist_root {
+ my ( @path ) = @_;
+
+ return -e File::Spec->catfile(@path, 'Makefile.PL') ||
+ -e File::Spec->catfile(@path, 'Build.PL');
+}
+
+delete @ENV{qw/AUTHOR_TESTING RELEASE_TESTING/};
+
+unless($ENV{'PERLBREW_ROOT'}) {
+ plan skip_all => "Environment variable 'PERLBREW_ROOT' not found";
+ exit;
+}
+
+my $brew = q[perl-5.17.10];
+
+my $cpanm_path = qx(which cpanm 2>/dev/null);
+unless($cpanm_path) {
+ plan skip_all => "The 'cpanm' program is required to run this test";
+ exit;
+}
+chomp $cpanm_path;
+
+my $perlbrew_bin = File::Spec->catdir($ENV{'PERLBREW_ROOT'}, 'perls',
+ $brew, 'bin');
+
+my ( $env, $status ) = do {
+ local $ENV{'SHELL'} = '/bin/bash'; # fool perlbrew
+ ( scalar(qx(perlbrew env $brew)), $? )
+};
+
+unless($status == 0) {
+ plan skip_all => "No such perlbrew environment '$brew'";
+ exit;
+}
+
+my @lines = split /\n/, $env;
+
+foreach my $line (@lines) {
+ if($line =~ /^\s*export\s+([0-9a-zA-Z_]+)=(.*)$/) {
+ my ( $k, $v ) = ( $1, $2 );
+ if($v =~ /^("|')(.*)\1$/) {
+ $v = $2;
+ $v =~ s!\\(.)!$1!ge;
+ }
+ $ENV{$k} = $v;
+ } elsif($line =~ /^unset\s+([0-9a-zA-Z_]+)/) {
+ delete $ENV{$1};
+ }
+}
+
+my $pristine_path = qx(perlbrew display-pristine-path);
+chomp $pristine_path;
+$ENV{'PATH'} = join(':', $ENV{'PERLBREW_PATH'}, $pristine_path);
+
+plan tests => 1;
+
+my $tmpdir = File::Temp->newdir;
+my $tmphome = File::Temp->newdir;
+
+my $pid = fork;
+if(!defined $pid) {
+ fail "Forking failed!";
+ exit 1;
+} elsif($pid) {
+ waitpid $pid, 0;
+ ok !$?, "cpanm should successfully install your dist with no issues" or copy_log_file($tmphome->dirname);
+} else {
+ close STDOUT;
+ close STDERR;
+
+ my @path = File::Spec->splitdir($FindBin::Bin);
+
+ while(@path && !is_dist_root(@path)) {
+ pop @path;
+ }
+ unless(@path) {
+ die "Unable to find dist root\n";
+ }
+ chdir File::Spec->catdir(@path); # exit test directory
+
+ # override where cpanm puts its log file
+ $ENV{'HOME'} = $tmphome->dirname;
+
+
+
+ delete $ENV{'PERL5LIB'};
+ system 'perl', $cpanm_path, '-L', $tmpdir->dirname, '.';
+ exit($? >> 8);
+}
@@ -0,0 +1,112 @@
+#!perl
+
+use strict;
+use warnings;
+
+use FindBin;
+use File::Copy qw(copy);
+use File::Spec;
+use File::Temp;
+use Test::More;
+
+sub copy_log_file {
+ my ( $home ) = @_;
+ my $log_file = File::Spec->catfile($home, '.cpanm', 'build.log');
+ my $tempfile = File::Temp->new(
+ SUFFIX => '.log',
+ UNLINK => 0,
+ );
+ copy($log_file, $tempfile->filename);
+ diag("For details, please consult $tempfile")
+}
+
+sub is_dist_root {
+ my ( @path ) = @_;
+
+ return -e File::Spec->catfile(@path, 'Makefile.PL') ||
+ -e File::Spec->catfile(@path, 'Build.PL');
+}
+
+delete @ENV{qw/AUTHOR_TESTING RELEASE_TESTING/};
+
+unless($ENV{'PERLBREW_ROOT'}) {
+ plan skip_all => "Environment variable 'PERLBREW_ROOT' not found";
+ exit;
+}
+
+my $brew = q[perl-5.18.0];
+
+my $cpanm_path = qx(which cpanm 2>/dev/null);
+unless($cpanm_path) {
+ plan skip_all => "The 'cpanm' program is required to run this test";
+ exit;
+}
+chomp $cpanm_path;
+
+my $perlbrew_bin = File::Spec->catdir($ENV{'PERLBREW_ROOT'}, 'perls',
+ $brew, 'bin');
+
+my ( $env, $status ) = do {
+ local $ENV{'SHELL'} = '/bin/bash'; # fool perlbrew
+ ( scalar(qx(perlbrew env $brew)), $? )
+};
+
+unless($status == 0) {
+ plan skip_all => "No such perlbrew environment '$brew'";
+ exit;
+}
+
+my @lines = split /\n/, $env;
+
+foreach my $line (@lines) {
+ if($line =~ /^\s*export\s+([0-9a-zA-Z_]+)=(.*)$/) {
+ my ( $k, $v ) = ( $1, $2 );
+ if($v =~ /^("|')(.*)\1$/) {
+ $v = $2;
+ $v =~ s!\\(.)!$1!ge;
+ }
+ $ENV{$k} = $v;
+ } elsif($line =~ /^unset\s+([0-9a-zA-Z_]+)/) {
+ delete $ENV{$1};
+ }
+}
+
+my $pristine_path = qx(perlbrew display-pristine-path);
+chomp $pristine_path;
+$ENV{'PATH'} = join(':', $ENV{'PERLBREW_PATH'}, $pristine_path);
+
+plan tests => 1;
+
+my $tmpdir = File::Temp->newdir;
+my $tmphome = File::Temp->newdir;
+
+my $pid = fork;
+if(!defined $pid) {
+ fail "Forking failed!";
+ exit 1;
+} elsif($pid) {
+ waitpid $pid, 0;
+ ok !$?, "cpanm should successfully install your dist with no issues" or copy_log_file($tmphome->dirname);
+} else {
+ close STDOUT;
+ close STDERR;
+
+ my @path = File::Spec->splitdir($FindBin::Bin);
+
+ while(@path && !is_dist_root(@path)) {
+ pop @path;
+ }
+ unless(@path) {
+ die "Unable to find dist root\n";
+ }
+ chdir File::Spec->catdir(@path); # exit test directory
+
+ # override where cpanm puts its log file
+ $ENV{'HOME'} = $tmphome->dirname;
+
+
+
+ delete $ENV{'PERL5LIB'};
+ system 'perl', $cpanm_path, '-L', $tmpdir->dirname, '.';
+ exit($? >> 8);
+}
@@ -0,0 +1,112 @@
+#!perl
+
+use strict;
+use warnings;
+
+use FindBin;
+use File::Copy qw(copy);
+use File::Spec;
+use File::Temp;
+use Test::More;
+
+sub copy_log_file {
+ my ( $home ) = @_;
+ my $log_file = File::Spec->catfile($home, '.cpanm', 'build.log');
+ my $tempfile = File::Temp->new(
+ SUFFIX => '.log',
+ UNLINK => 0,
+ );
+ copy($log_file, $tempfile->filename);
+ diag("For details, please consult $tempfile")
+}
+
+sub is_dist_root {
+ my ( @path ) = @_;
+
+ return -e File::Spec->catfile(@path, 'Makefile.PL') ||
+ -e File::Spec->catfile(@path, 'Build.PL');
+}
+
+delete @ENV{qw/AUTHOR_TESTING RELEASE_TESTING/};
+
+unless($ENV{'PERLBREW_ROOT'}) {
+ plan skip_all => "Environment variable 'PERLBREW_ROOT' not found";
+ exit;
+}
+
+my $brew = q[perl-5.8.9];
+
+my $cpanm_path = qx(which cpanm 2>/dev/null);
+unless($cpanm_path) {
+ plan skip_all => "The 'cpanm' program is required to run this test";
+ exit;
+}
+chomp $cpanm_path;
+
+my $perlbrew_bin = File::Spec->catdir($ENV{'PERLBREW_ROOT'}, 'perls',
+ $brew, 'bin');
+
+my ( $env, $status ) = do {
+ local $ENV{'SHELL'} = '/bin/bash'; # fool perlbrew
+ ( scalar(qx(perlbrew env $brew)), $? )
+};
+
+unless($status == 0) {
+ plan skip_all => "No such perlbrew environment '$brew'";
+ exit;
+}
+
+my @lines = split /\n/, $env;
+
+foreach my $line (@lines) {
+ if($line =~ /^\s*export\s+([0-9a-zA-Z_]+)=(.*)$/) {
+ my ( $k, $v ) = ( $1, $2 );
+ if($v =~ /^("|')(.*)\1$/) {
+ $v = $2;
+ $v =~ s!\\(.)!$1!ge;
+ }
+ $ENV{$k} = $v;
+ } elsif($line =~ /^unset\s+([0-9a-zA-Z_]+)/) {
+ delete $ENV{$1};
+ }
+}
+
+my $pristine_path = qx(perlbrew display-pristine-path);
+chomp $pristine_path;
+$ENV{'PATH'} = join(':', $ENV{'PERLBREW_PATH'}, $pristine_path);
+
+plan tests => 1;
+
+my $tmpdir = File::Temp->newdir;
+my $tmphome = File::Temp->newdir;
+
+my $pid = fork;
+if(!defined $pid) {
+ fail "Forking failed!";
+ exit 1;
+} elsif($pid) {
+ waitpid $pid, 0;
+ ok !$?, "cpanm should successfully install your dist with no issues" or copy_log_file($tmphome->dirname);
+} else {
+ close STDOUT;
+ close STDERR;
+
+ my @path = File::Spec->splitdir($FindBin::Bin);
+
+ while(@path && !is_dist_root(@path)) {
+ pop @path;
+ }
+ unless(@path) {
+ die "Unable to find dist root\n";
+ }
+ chdir File::Spec->catdir(@path); # exit test directory
+
+ # override where cpanm puts its log file
+ $ENV{'HOME'} = $tmphome->dirname;
+
+
+
+ delete $ENV{'PERL5LIB'};
+ system 'perl', $cpanm_path, '-L', $tmpdir->dirname, '.';
+ exit($? >> 8);
+}
@@ -0,0 +1,6 @@
+#!perl
+
+use Test::More;
+eval 'use Test::CPAN::Meta::JSON';
+plan skip_all => 'Test::CPAN::Meta::JSON required for testing META.json' if $@;
+meta_json_ok();
@@ -0,0 +1,12 @@
+#!perl
+
+use strict;
+use warnings qw(all);
+
+use Test::More;
+
+## no critic (ProhibitStringyEval, RequireCheckingReturnValueOfEval)
+eval q(use Test::Mojibake);
+plan skip_all => q(Test::Mojibake required for source encoding testing) if $@;
+
+all_files_encoding_ok();
@@ -0,0 +1,8 @@
+use strict;
+use warnings;
+use Test::More;
+
+eval 'use Test::NoTabs';
+plan skip_all => 'Test::NoTabs required' if $@;
+
+all_perl_files_ok();
@@ -0,0 +1,102 @@
+
+use strict;
+use warnings;
+
+use Test::More;
+
+if ( $ENV{RELEASE_TESTING} || $ENV{AUTHOR_TESTING} || $ENV{AUTHOR_TESTS} )
+{ # the tests in this file have a higher probability
+ plan tests => 8; # of failing in the wild, and so are reserved for
+ # the author/maintainers as release tests
+ CORE::eval # hide the eval...
+ '
+use Test::NoWarnings;
+ '; # ...from dist parsers
+}
+else
+{
+ plan skip_all => 'these tests are for release candidate testing';
+}
+
+use lib './lib';
+use File::Util;
+
+use vars qw( $stderr_str $callback_err $sig_warn );
+
+# one recognized instantiation setting
+my $ftl = File::Util->new( );
+
+my $err_msg = $ftl->write_file( undef, { onfail => 'message' } );
+
+steal_stderr();
+
+$ftl->write_file( undef, { onfail => 'warn' } );
+
+return_stderr();
+
+$ftl->write_file( undef, { onfail => \&fail_callback } );
+
+my $die_err = '';
+
+{
+ local $@;
+
+ eval { $ftl->write_file( undef, { onfail => 'die' } ); };
+
+ $die_err = $@;
+}
+
+clean_err( \$stderr_str );
+clean_err( \$err_msg );
+clean_err( \$callback_err );
+clean_err( \$die_err );
+
+like $stderr_str, qr/File::Util/,
+ 'warning message captured';
+
+like $err_msg, qr/File::Util/,
+ 'error message captured';
+
+is $stderr_str, $err_msg,
+ 'warning message is the same as error message';
+
+is $stderr_str, $callback_err,
+ 'callback error is the same as error message';
+
+is $stderr_str, $die_err,
+ 'die() message is the same as error message';
+
+is $ftl->write_file( undef, { onfail => 'zero' } ),
+ 0, 'onfail => "zero" returns 0';
+
+is $ftl->write_file( undef, { onfail => 'undefined' } ),
+ undef, 'onfail => "undefined" returns undef';
+
+exit;
+
+sub fail_callback {
+ my ( $err, $stack ) = @_;
+ $callback_err = "\n" . $err . $stack;
+ return;
+};
+
+sub steal_stderr {
+ $sig_warn = $SIG{__WARN__};
+ $SIG{__WARN__} = sub { $stderr_str .= join '', @_; return };
+ return;
+}
+
+sub return_stderr {
+ $SIG{__WARN__} = $sig_warn;
+ return;
+}
+
+sub clean_err {
+ my $err = shift @_;
+ $$err =~ s/^\n+//;
+ $$err =~ s/^.*called at line.*$//mg;
+ $$err =~ s/\n2\. .*//sm; # delete everything after stack frame 1
+ chomp $$err;
+ return;
+}
+
@@ -0,0 +1,294 @@
+
+use strict;
+use warnings;
+
+# This test structure is completely procedural and serial. I'm sorry, it's
+# a little ugly. It makes sense if you just read it though, one open/close
+# at a time. We're just testing Perl IO and C IO on filehandles from the
+# open_handle() method.
+#
+# Also, because the C IO ops are not as portable as Perl IO, this is a
+# developer-only release test so we can avoid bad test reports for platforms
+# that have troublesome C libraries, which isn't our fault.
+
+use Test::More;
+
+if ( $ENV{RELEASE_TESTING} || $ENV{AUTHOR_TESTING} || $ENV{AUTHOR_TESTS} )
+{ # the tests in this file have a higher probability
+ plan tests => 39; # of failing in the wild, and so are reserved for
+ # the author/maintainers as release tests
+ CORE::eval # hide the eval...
+ '
+use Test::NoWarnings;
+ '; # ...from dist parsers
+}
+else
+{
+ plan skip_all => 'these tests are for release candidate testing';
+}
+
+use File::Temp qw( tempfile );
+
+use lib './lib';
+use File::Util qw( NL );
+
+# one recognized instantiation setting
+my $ftl = File::Util->new( );
+
+my ( $tempfh, $tempfile ) = tempfile;
+
+close $tempfh;
+
+BEGIN { ++$| }
+
+################################################################################
+# TEST PERL IO (READ/WRITE/APPEND)
+################################################################################
+
+# ------------------------------------
+# Perl IO (write)
+# ------------------------------------
+
+my $fh = $ftl->open_handle( $tempfile => 'write' );
+
+is ref $fh, 'GLOB', 'got file handle for write';
+is !!fileno( $fh ), 1, 'file handle open to a file descriptor for write';
+
+print $fh 'dangerian' . NL . 'jspice' . NL . 'codizzle' . NL;
+
+close $fh;
+
+is fileno( $fh ), undef, 'closed file handle after write';
+
+undef $fh;
+
+# ------------------------------------
+# Perl IO (read)
+# ------------------------------------
+
+$fh = $ftl->open_handle( $tempfile => 'read' );
+
+is ref $fh, 'GLOB', 'got file handle for read';
+is !!fileno( $fh ), 1, 'file handle open to a file descriptor for read';
+
+my @lines = <$fh>;
+
+chomp for @lines;
+
+is_deeply
+ \@lines,
+ [ qw( dangerian jspice codizzle ) ],
+ 'read the lines just previously written';
+
+close $fh;
+
+is fileno( $fh ), undef, 'closed file handle after read';
+
+undef $fh;
+undef @lines;
+
+# ------------------------------------
+# Perl IO (append)
+# ------------------------------------
+
+$fh = $ftl->open_handle( $tempfile => 'append' );
+
+is ref $fh, 'GLOB', 'got file handle for append';
+is !!fileno( $fh ), 1, 'file handle open to a file descriptor for append';
+
+print $fh 'redbeard' . NL . 'tbone' . NL;
+
+close $fh;
+
+is fileno( $fh ), undef, 'closed file handle after append';
+
+undef $fh;
+
+# ------------------------------------
+# Perl IO (read)
+# ------------------------------------
+
+$fh = $ftl->open_handle( $tempfile ); # implicit mode => 'read'
+
+is ref $fh, 'GLOB', 'got file handle for read using implicit read mode';
+is !!fileno( $fh ), 1, 'file handle open to a file descriptor for read';
+
+@lines = <$fh>;
+
+chomp for @lines;
+
+is_deeply
+ \@lines,
+ [ qw( dangerian jspice codizzle redbeard tbone ) ],
+ 'read the lines just previously appended';
+
+close $fh;
+
+is fileno( $fh ), undef, 'closed file handle after read';
+
+undef $fh;
+undef @lines;
+
+################################################################################
+# TEST C IO (SYSREAD/SYSWRITE/ETC)
+################################################################################
+use Fcntl qw( SEEK_SET SEEK_CUR SEEK_END );
+
+# ------------------------------------
+# System IO (sysread)
+# ------------------------------------
+
+$fh = $ftl->open_handle( # make sure old-school still works
+ file => $tempfile, # otherwise, this "null" test would
+ mode => 'read', # make everything else fail when it die()d
+ { use_sysopen => 1 }
+);
+
+$fh = $ftl->open_handle( $tempfile => 'read' => { use_sysopen => 1 } );
+
+is ref $fh, 'GLOB', 'got file handle for sysread';
+is !!fileno( $fh ), 1, 'file handle open to a file descriptor for sysread';
+
+my ( $buffer, $string );
+
+$string .= $buffer while sysread( $fh, $buffer, 4096 );
+
+is_deeply
+ [ split( /\r|\n|\r\n/, $string ) ],
+ [ qw( dangerian jspice codizzle redbeard tbone ) ],
+ 'SYS-read the lines just previously PERLIO-appended';
+
+close $fh;
+
+is fileno( $fh ), undef, 'closed file handle after sysread';
+
+undef $fh;
+undef $buffer;
+undef $string;
+
+unlink $tempfile or die $!;
+
+is -e $tempfile,
+ undef,
+ 'removed tempfile in preparation for syswrite (rwcreate)';
+
+# ------------------------------------
+# System IO (rwcreate)
+# ------------------------------------
+
+$fh = $ftl->open_handle( $tempfile => 'rwcreate' => { use_sysopen => 1 } );
+
+is ref $fh, 'GLOB', 'got file handle for syswrite (rwcreate)';
+is !!fileno( $fh ), 1, 'file handle open to a file descriptor for rwcreate';
+
+syswrite $fh, 'llama';
+sysseek $fh, 0, 0;
+
+$string .= $buffer while sysread( $fh, $buffer, 4096 );
+
+is $string,
+ 'llama',
+ 'string is a llama (I just sysread what I just syswrote (rwcreate))';
+
+close $fh;
+
+is fileno( $fh ), undef, 'closed file handle after rwcreate';
+
+undef $fh;
+undef $buffer;
+undef $string;
+
+is -e $tempfile, 1, 'successfully rwcreate-ed tempfile with syswrite';
+
+# ------------------------------------
+# System IO (rwupdate)
+# ------------------------------------
+
+$fh = $ftl->open_handle( $tempfile => 'rwupdate' => { use_sysopen => 1 } );
+
+is ref $fh, 'GLOB', 'got file handle for syswrite (rwupdate)';
+is !!fileno( $fh ), 1, 'file handle open to a file descriptor for rwupdate';
+
+syswrite $fh, 'LL';
+sysseek $fh, 0, 0;
+
+$string .= $buffer while sysread( $fh, $buffer, 4096 );
+
+is $string,
+ 'LLama',
+ 'string is a LLama (I just sysread what I just syswrote (rwupdate))';
+
+close $fh;
+
+is fileno( $fh ), undef, 'closed file handle after syswrite (rwupdate)';
+
+undef $fh;
+undef $buffer;
+undef $string;
+
+# ------------------------------------
+# System IO (rwappend)
+# ------------------------------------
+
+$fh = $ftl->open_handle( $tempfile => 'rwappend' => { use_sysopen => 1 } );
+
+is ref $fh, 'GLOB', 'got file handle for syswrite (rwappend)';
+is !!fileno( $fh ), 1, 'file handle open to a file descriptor for rwappend';
+
+syswrite $fh, 's are seldom thirsty';
+sysseek $fh, 0, 0;
+
+$string .= $buffer while sysread( $fh, $buffer, 4096 );
+
+is $string,
+ 'LLamas are seldom thirsty',
+ 'LLamas are seldom thirsty (I just sysread what I just syswrote (rwappend))';
+
+close $fh;
+
+is fileno( $fh ), undef, 'closed file handle after syswrite (rwupdate)';
+
+undef $fh;
+undef $buffer;
+undef $string;
+
+# ------------------------------------
+# System IO (rwclobber)
+# ------------------------------------
+
+$fh = $ftl->open_handle( $tempfile => 'rwclobber' => { use_sysopen => 1 } );
+
+is ref $fh, 'GLOB', 'got file handle for syswrite (rwclobber)';
+is !!fileno( $fh ), 1, 'file handle open to a file descriptor for rwclobber';
+
+syswrite $fh, 'Han shot first!';
+sysseek $fh, 0, 0;
+
+$string .= $buffer while sysread( $fh, $buffer, 4096 );
+
+is $string,
+ 'Han shot first!',
+ 'Han shot first! (I just sysread what I just syswrote (rwclobber))';
+
+close $fh;
+
+is fileno( $fh ), undef, 'closed file handle after syswrite (rwclobber)';
+
+undef $fh;
+undef $buffer;
+undef $string;
+
+################################################################################
+# TEST SOME FAILURE SCENARIOS
+################################################################################
+
+$fh = $ftl->open_handle( undef, { onfail => 'zero' } );
+
+is $fh, 0, 'failed open with onfail => 0 handler returns 0';
+
+$fh = $ftl->open_handle( undef, { onfail => 'undefined' } );
+
+is $fh, undef, 'failed open with onfail => undefined handler returns undef';
+
+exit;
+
@@ -0,0 +1,13 @@
+#!perl
+
+use Test::More;
+
+eval "use Test::Pod::Coverage 1.08";
+plan skip_all => "Test::Pod::Coverage 1.08 required for testing POD coverage"
+ if $@;
+
+eval "use Pod::Coverage::TrustPod";
+plan skip_all => "Pod::Coverage::TrustPod required for testing POD coverage"
+ if $@;
+
+all_pod_coverage_ok({ coverage_class => 'Pod::Coverage::TrustPod' });
@@ -0,0 +1,7 @@
+#!perl
+use Test::More;
+
+eval "use Test::Pod 1.41";
+plan skip_all => "Test::Pod 1.41 required for testing POD" if $@;
+
+all_pod_files_ok();
@@ -0,0 +1,8 @@
+#!perl
+
+use Test::More;
+
+eval "use Test::Synopsis";
+plan skip_all => "Test::Synopsis required for testing synopses"
+ if $@;
+all_synopsis_ok('lib');
@@ -0,0 +1,22 @@
+use strict;
+use warnings;
+use Test::More;
+
+# generated by Dist::Zilla::Plugin::Test::Version 0.002004
+BEGIN { eval "use Test::Version; 1;" or die $@; }
+
+my @imports = ( 'version_all_ok' );
+
+my $params = {
+ is_strict => 0,
+ has_version => 1,
+};
+
+push @imports, $params
+ if version->parse( $Test::Version::VERSION ) >= version->parse('1.002');
+
+
+Test::Version->import(@imports);
+
+version_all_ok;
+done_testing;
@@ -0,0 +1,8 @@
+#!perl
+
+use Test::More;
+
+eval "use Test::Vars";
+plan skip_all => "Test::Vars required for testing unused vars"
+ if $@;
+all_vars_ok();