File-Util-4.201720000755001750001750 013673264062 13251 5ustar00tommytommy000000000000TODO100644001750001750 1010013673264062 14032 0ustar00tommytommy000000000000File-Util-4.201720TODO 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) [DONE] 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) [DONE] 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 20) [DONE] Allow users to specify custom IO layers for reads/writes/opens 21) Revisit documentation structure to see if improvements can't be made 22) Create convenience methods for UTF8 reads/writes/opens NEWS100644001750001750 1627513673264062 14064 0ustar00tommytommy000000000000File-Util-4.201720NEWS for File::Util Fri Jun 19 20:27:48 CDT 2020 Releasing to CPAN with bugfix, details in Changes file. Tue Jul 12 18:37:17 CDT 2016 Releasing this bug fix to CPAN immediately. Having changed only one line of code, and knowing the criticality of the bug, I'm releasing this as GA and skipping the ...-TRIAL dist formalities. Regression test also added. 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! t000755001750001750 013673264062 13435 5ustar00tommytommy000000000000File-Util-4.201720bin100644001750001750 201113673264062 14262 0ustar00tommytommy000000000000File-Util-4.201720/tPNG  IHDRn,tEXtCreation TimeMon 28 Oct 2002 23:38:44 -0600^tIME *'K; pHYs  ~gAMA aPLTEyypp~~ffmmkkhh֊Ӭwwrr㈈怀||tt߃٘볳̤ÿ珏人Ѹϑh'IDATx떚0b"8ed:xQ;NoU.1Z˶#Bq:8!g^'nwK$UnGhlFDQ8,&Y'/&Aw6Mzځ, A=/eCBY*\I,EyjThEh=M` kG}?\(KK%0KDxK#0]llK8;RMWN:$yJ8 /S|óynf\j >ɦ488X{0>PGA$J8HkyO U'MnwgRBpr煃K> ϯ^0 !v վ w:2:;IENDB`txt100644001750001750 3013673264062 14270 0ustar00tommytommy000000000000File-Util-4.201720/tJust Another Perl HackerREADME100644001750001750 56513673264062 14200 0ustar00tommytommy000000000000File-Util-4.201720This archive contains the distribution File-Util, version 4.201720: Easy, versatile, portable file handling This software is copyright (c) 2020 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. This README file was generated by Dist::Zilla::Plugin::Readme v6.015. Changes100644001750001750 7405313673264062 14656 0ustar00tommytommy000000000000File-Util-4.201720Revision history for Perl extension File::Util.pm 4.201720 2020-06-19 - Bugfix for issue where @INC was being disrupted, detailed at https://rt.cpan.org/Ticket/Display.html?id=132060 Sorry for the delay in fixing it - coronavirus happened to the world :( Good luck everyone and please stay safe. 4.161950 2016-07-12 - This release fixes a critical bug in the list_dir() method, detailed at https://rt.cpan.org/Public/Bug/Display.html?id=115511 - Regression test added to catch the failure condition - NOTE: No major code or featureset changes included as part of this release, therefore it is still deemed "stable", as no significant changes to the code have been made beyond a two line bugfix that remedies the problem that caused the list_dir() method to fail under certain conditions. 4.161200 2016-04-29 - The previous TRIAL release passes muster by cpantesters. This is now released as a STABLE dist, although more features are planned in coming releases. See also: TODO 4.160630 2016-03-03 - TRIAL RELEASE - Fix for bug https://rt.cpan.org/Ticket/Display.html?id=106771 - Added tests - Added documentation regarding the bug fix, namely the now-unsupported (because Perl 5.23 deprecates) the combination of sysread/write/seek on filehandles in :utf8 binmode. - Added the ability for users to specify their own IO layers via the { binmode => ':layerspec' } option to ::load_file(), ::write_file(), and ::open_handle() 4.131591 2013-06-07 - POD (documentation) corrections. 4.131570 2013-06-06 - 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. - So I'm pleased to announce that I'm releasing this code as-is, under the "STABLE"/"MATURE" designation. - 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 - Near future plans are laid out in the TODO documentation file also included with this documentation. 4.130610 2013-03-02 - 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 2013-02-27 - 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 2013-02-25 - 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 2013-02-19 - 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 2013-02-18 - 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 2013-02-16 - 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 2013-02-14 - 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 2013-02-11 - 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 2013-02-10 - 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 2013-01-06 - 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 2013-01-04 - Have to abandon AutoLoader. It is simply causing too many problems to continue using it on any level. 4.37 2013-01-03 - 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 2013-01-03 - 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 2012-12-31 - 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 2012-11-28 - 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 2012-11-20 - 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 2012-11-15 - 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 2012-11-12 - 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 2012-10-17 - 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 2012-09-29 - 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 2008-12-06 - 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 2008-12-02 - 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 2008-12-01 - Fixed a bug in File::Util::touch() - Added some extra examples and corrected one minor error in the documentation. 3.24 2007-05-23 - 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 2008-02-15 - 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 2007-05-23 - 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 2007-05-21 - 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 2007-05-21 - Fixed small but important incompatibility with some versions of Exception::Handler 3.20_1 2007-05-18 - 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 2007-05-16 - 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 2007-02-27 - 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 2007-02-20 - 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 2006-12-22 - Fixed broken test suite that was causing `make test` to fail falsely. - Revisited documentation, adding a little, and various small improvements. 3.14_8 2006-12-14 - 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 2004-01-31 - 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 2003-09-22 - 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-06 - 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-04 - 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 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 2001-11-29 - 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 --long same as '--formal' --succinct Sat 5/15/02 16:22:43 --ISO Sat, 15 Jun 2002 16.22.43 GMT --filename -June-15-2002-16.22.43 --file same as '--filename' --mdy 5/15/02 --hm 4:22 pm --hms 4:22:43 pm --24hms 16:22:43 --dayofmonth 15 --dayofyear 134 (1 - 365) --dayofweek Saturday --dayofweek, --num 7 --month June --month, --num 6 --year 2002 --shortyear 02 --minute 22 --hour 16 (0 - 24) --second 43 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 2001-09-23 - Initial release of File::Util.pm INSTALL100644001750001750 23213673264062 14340 0ustar00tommytommy000000000000File-Util-4.201720INSTALLATION To install this module, run the following commands: perl Build.PL perl ./Build perl ./Build test sudo perl ./Build install AUTHORS100644001750001750 6713673264062 14345 0ustar00tommytommy000000000000File-Util-4.201720Tommy Butler - www.atrixnet.com/contact Others Wanted! COPYING100644001750001750 100513673264062 14361 0ustar00tommytommy000000000000File-Util-4.201720This 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. 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. LICENSE100644001750001750 4365513673264062 14374 0ustar00tommytommy000000000000File-Util-4.201720This software is copyright (c) 2020 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) 2020 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, Fifth Floor, Boston, MA 02110-1301 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. Copyright (C) 19yy 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. , 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) 2020 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 dist.ini100644001750001750 713113673264062 15000 0ustar00tommytommy000000000000File-Util-4.201720name = File-Util author = Tommy Butler license = Perl_5 copyright_holder = Tommy Butler is_trial = 0 [Meta::Contributors] contributor = John Fields contributor = Ricardo SIGNES contributor = Matt S Trout contributor = Nicholas Perez contributor = David Golden [Encoding] filename = t/bin encoding = bytes [@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 [Test::ReportPrereqs] [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.18.4 brews = perl-5.20.3 brews = perl-5.22.1 brews = perl-5.23.6 [@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 ; problematic for me, causes spurious failures disable = Test::MinimumVersion ; I do this myself, via the Perlbrew testing disable = Test::UnusedVars ; causes spurious failures [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 = SL 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 stopwords = cpan stopwords = CPAN stopwords = filename stopwords = filenames stopwords = metadata stopwords = namespace stopwords = OO stopwords = POSIX stopwords = pre stopwords = STDERR stopwords = subclasses stopwords = subdirectories stopwords = subdirectory stopwords = UTF stopwords = shiftjis stopwords = iso [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 inc::latest = 0 ;[Prereqs / DevelopRecommends] ;Devel::NYTProf = 0 META.yml100644001750001750 3006313673264062 14625 0ustar00tommytommy000000000000File-Util-4.201720--- 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::Spec: '0' File::Temp: '0' IO::Handle: '0' IPC::Open3: '0' Module::Build: '0.28' Scalar::Util: '0' Test: '0' Test::More: '0' Test::NoWarnings: '0' lib: '0' perl: '5.008001' utf8: '0' configure_requires: ExtUtils::MakeMaker: '0' Module::Build: '0.28' perl: '5.008001' dynamic_config: 0 generated_by: 'Dist::Zilla version 6.015, CPAN::Meta::Converter version 2.150010' 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.201720' File::Util::Definitions: file: lib/File/Util/Definitions.pm version: '4.201720' File::Util::Exception: file: lib/File/Util/Exception.pm version: '4.201720' File::Util::Exception::Diagnostic: file: lib/File/Util/Exception/Diagnostic.pm version: '4.201720' File::Util::Exception::Standard: file: lib/File/Util/Exception/Standard.pm version: '4.201720' File::Util::Interface::Classic: file: lib/File/Util/Interface/Classic.pm version: '4.201720' File::Util::Interface::Modern: file: lib/File/Util/Interface/Modern.pm version: '4.201720' recommends: Unicode::UTF8: '0.58' requires: 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.201720' x_Dist_Zilla: perl: version: '5.030003' plugins: - class: Dist::Zilla::Plugin::Meta::Contributors name: Meta::Contributors version: '0.003' - class: Dist::Zilla::Plugin::Encoding name: Encoding version: '6.015' - class: Dist::Zilla::Plugin::GatherDir config: Dist::Zilla::Plugin::GatherDir: exclude_filename: [] exclude_match: [] follow_symlinks: 0 include_dotfiles: 0 prefix: '' prune_directory: [] root: . name: '@Filter/GatherDir' version: '6.015' - class: Dist::Zilla::Plugin::PruneCruft name: '@Filter/PruneCruft' version: '6.015' - class: Dist::Zilla::Plugin::ManifestSkip name: '@Filter/ManifestSkip' version: '6.015' - class: Dist::Zilla::Plugin::MetaYAML name: '@Filter/MetaYAML' version: '6.015' - class: Dist::Zilla::Plugin::License name: '@Filter/License' version: '6.015' - class: Dist::Zilla::Plugin::Readme name: '@Filter/Readme' version: '6.015' - class: Dist::Zilla::Plugin::ExecDir name: '@Filter/ExecDir' version: '6.015' - class: Dist::Zilla::Plugin::ShareDir name: '@Filter/ShareDir' version: '6.015' - class: Dist::Zilla::Plugin::MakeMaker config: Dist::Zilla::Role::TestRunner: default_jobs: 1 name: '@Filter/MakeMaker' version: '6.015' - class: Dist::Zilla::Plugin::Manifest name: '@Filter/Manifest' version: '6.015' - class: Dist::Zilla::Plugin::TestRelease name: '@Filter/TestRelease' version: '6.015' - class: Dist::Zilla::Plugin::ConfirmRelease name: '@Filter/ConfirmRelease' version: '6.015' - class: Dist::Zilla::Plugin::UploadToCPAN name: '@Filter/UploadToCPAN' version: '6.015' - class: Dist::Zilla::Plugin::RunExtraTests config: Dist::Zilla::Role::TestRunner: default_jobs: 1 name: RunExtraTests version: '0.029' - class: Dist::Zilla::Plugin::ModuleBuild config: Dist::Zilla::Role::TestRunner: default_jobs: 1 name: ModuleBuild version: '6.015' - class: Dist::Zilla::Plugin::AutoVersion name: AutoVersion version: '6.015' - class: Dist::Zilla::Plugin::PkgVersion name: PkgVersion version: '6.015' - class: Dist::Zilla::Plugin::PodVersion name: PodVersion version: '6.015' - class: Dist::Zilla::Plugin::MetaProvides::Package config: Dist::Zilla::Plugin::MetaProvides::Package: finder_objects: - class: Dist::Zilla::Plugin::FinderCode name: MetaProvides::Package/AUTOVIV/:InstallModulesPM version: '6.015' include_underscores: 0 Dist::Zilla::Role::MetaProvider::Provider: $Dist::Zilla::Role::MetaProvider::Provider::VERSION: '2.002004' inherit_missing: '1' inherit_version: '1' meta_noindex: '1' Dist::Zilla::Role::ModuleMetadata: Module::Metadata: '1.000036' version: '0.006' name: MetaProvides::Package version: '2.004003' - class: Dist::Zilla::Plugin::MinimumPerl name: MinimumPerl version: '1.006' - class: Dist::Zilla::Plugin::MetaConfig name: MetaConfig version: '6.015' - class: Dist::Zilla::Plugin::MetaJSON name: MetaJSON version: '6.015' - class: Dist::Zilla::Plugin::MetaResources name: MetaResources version: '6.015' - class: Dist::Zilla::Plugin::Test::ReportPrereqs name: Test::ReportPrereqs version: '0.027' - class: Dist::Zilla::Plugin::Test::LocalBrew name: Test::LocalBrew version: '0.08' - class: Dist::Zilla::Plugin::Test::Version name: '@TestingMania/Test::Version' version: '1.09' - class: Dist::Zilla::Plugin::Test::CPAN::Changes config: Dist::Zilla::Plugin::Test::CPAN::Changes: changelog: Changes name: '@TestingMania/Test::CPAN::Changes' version: '0.012' - class: Dist::Zilla::Plugin::Test::DistManifest name: '@TestingMania/Test::DistManifest' version: '2.000005' - class: Dist::Zilla::Plugin::Test::Kwalitee config: Dist::Zilla::Plugin::Test::Kwalitee: filename: xt/release/kwalitee.t skiptest: [] name: '@TestingMania/Test::Kwalitee' version: '2.12' - class: Dist::Zilla::Plugin::MojibakeTests name: '@TestingMania/MojibakeTests' version: '0.8' - class: Dist::Zilla::Plugin::Test::Perl::Critic name: '@TestingMania/Test::Perl::Critic' version: '3.001' - class: Dist::Zilla::Plugin::Test::CPAN::Meta::JSON name: '@TestingMania/Test::CPAN::Meta::JSON' version: '0.004' - class: Dist::Zilla::Plugin::MetaTests name: '@TestingMania/MetaTests' version: '6.015' - class: Dist::Zilla::Plugin::PodCoverageTests name: '@TestingMania/PodCoverageTests' version: '6.015' - class: Dist::Zilla::Plugin::PodSyntaxTests name: '@TestingMania/PodSyntaxTests' version: '6.015' - class: Dist::Zilla::Plugin::Test::Synopsis name: '@TestingMania/Test::Synopsis' version: '2.000007' - class: Dist::Zilla::Plugin::Test::NoTabs config: Dist::Zilla::Plugin::Test::NoTabs: filename: xt/author/no-tabs.t finder: - ':InstallModules' - ':ExecFiles' - ':TestFiles' name: '@TestingMania/Test::NoTabs' version: '0.15' - class: Dist::Zilla::Plugin::Test::Compile config: Dist::Zilla::Plugin::Test::Compile: bail_out_on_fail: '0' fail_on_warning: author fake_home: 0 filename: t/00-compile.t module_finder: - ':InstallModules' needs_display: 0 phase: test script_finder: - ':PerlExecFiles' skips: [] switch: [] name: '@TestingMania/Test::Compile' version: '2.058' - class: Dist::Zilla::Plugin::Test::PodSpelling config: Dist::Zilla::Plugin::Test::PodSpelling: directories: - bin - lib spell_cmd: '' stopwords: - "AND'ed" - BLOCKEX - BrowserUk - CIFS - CPAN - EBCDIC - EPOC - FIFOs - Github - NFS - OO - POSIX - SIGNES - SL - SMB - SOLARIS - STDERR - Solaris - UTF - VMS - ascii - benchmarking - bitmask - conf - cpan - dat - dbitmask - ebcdic - failsafe - filename - filenames - html - inodes - iso - lexically - listrefs - merchantability - metadata - namespace - oct - onfail - pre - shiftjis - subclasses - subdirectories - subdirectory - subpattern - subref - subrefs - syntaxes - trunc - txt - unicode - vtab wordlist: Pod::Wordlist name: Test::PodSpelling version: '2.007005' - class: Dist::Zilla::Plugin::CheckChangesHasContent name: CheckChangesHasContent version: '0.011' - class: Dist::Zilla::Plugin::TestRelease name: TestRelease version: '6.015' - class: Dist::Zilla::Plugin::ConfirmRelease name: ConfirmRelease version: '6.015' - class: Dist::Zilla::Plugin::Signature name: Signature version: '1.100930' - class: Dist::Zilla::Plugin::AutoPrereqs name: AutoPrereqs version: '6.015' - class: Dist::Zilla::Plugin::Prereqs config: Dist::Zilla::Plugin::Prereqs: phase: test type: requires name: TestRequires version: '6.015' - class: Dist::Zilla::Plugin::Prereqs config: Dist::Zilla::Plugin::Prereqs: phase: runtime type: recommends name: Recommends version: '6.015' - class: Dist::Zilla::Plugin::Prereqs config: Dist::Zilla::Plugin::Prereqs: phase: develop type: requires name: DevelopRequires version: '6.015' - class: Dist::Zilla::Plugin::FinderCode name: ':InstallModules' version: '6.015' - class: Dist::Zilla::Plugin::FinderCode name: ':IncModules' version: '6.015' - class: Dist::Zilla::Plugin::FinderCode name: ':TestFiles' version: '6.015' - class: Dist::Zilla::Plugin::FinderCode name: ':ExtraTestFiles' version: '6.015' - class: Dist::Zilla::Plugin::FinderCode name: ':ExecFiles' version: '6.015' - class: Dist::Zilla::Plugin::FinderCode name: ':PerlExecFiles' version: '6.015' - class: Dist::Zilla::Plugin::FinderCode name: ':ShareFiles' version: '6.015' - class: Dist::Zilla::Plugin::FinderCode name: ':MainModule' version: '6.015' - class: Dist::Zilla::Plugin::FinderCode name: ':AllFiles' version: '6.015' - class: Dist::Zilla::Plugin::FinderCode name: ':NoFiles' version: '6.015' - class: Dist::Zilla::Plugin::FinderCode name: MetaProvides::Package/AUTOVIV/:InstallModulesPM version: '6.015' zilla: class: Dist::Zilla::Dist::Builder config: is_trial: '0' version: '6.015' x_contributors: - 'John Fields ' - 'Ricardo SIGNES ' - 'Matt S Trout ' - 'Nicholas Perez ' - 'David Golden ' x_generated_by_perl: v5.30.3 x_serialization_backend: 'YAML::Tiny version 1.73' x_spdx_expression: 'Artistic-1.0-Perl OR GPL-1.0-or-later' MANIFEST100644001750001750 501613673264062 14465 0ustar00tommytommy000000000000File-Util-4.201720# This file was automatically generated by Dist::Zilla::Plugin::Manifest v6.015. AUTHORS Build.PL COPYING Changes INSTALL LICENSE MANIFEST MANIFEST.SKIP META.json META.yml Makefile.PL NEWS README 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/00-report-prereqs.dd t/00-report-prereqs.t t/001_canuseit.t t/002_isa.t t/003_can.t t/004_portable.t t/005_ftests.t t/006_io.t t/007_flock.t t/008_export_ok.t t/009_empty_subclass.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/021_list_dir_regression.t t/bin t/txt xt/author/critic.t xt/author/mojibake.t xt/author/no-tabs.t xt/author/pod-coverage.t xt/author/pod-spell.t xt/author/pod-syntax.t xt/author/synopsis.t xt/author/test-version.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.18.4.t xt/release/localbrew-perl-5.20.3.t xt/release/localbrew-perl-5.22.1.t xt/release/localbrew-perl-5.23.6.t xt/release/localbrew-perl-5.8.9.t xt/release/meta-json.t xt/release/onfail.t xt/release/open_handle.t Build.PL100644001750001750 364213673264062 14633 0ustar00tommytommy000000000000File-Util-4.201720 # This file was automatically generated by Dist::Zilla::Plugin::ModuleBuild v6.015. use strict; use warnings; use Module::Build 0.28; my %module_build_args = ( "build_requires" => { "Module::Build" => "0.28" }, "configure_requires" => { "ExtUtils::MakeMaker" => 0, "Module::Build" => "0.28", "perl" => "5.008001" }, "dist_abstract" => "Easy, versatile, portable file handling", "dist_author" => [ "Tommy Butler" ], "dist_name" => "File-Util", "dist_version" => "4.201720", "license" => "perl", "module_name" => "File::Util", "recommends" => { "Unicode::UTF8" => "0.58" }, "recursive_test_files" => 1, "requires" => { "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::Spec" => 0, "File::Temp" => 0, "IO::Handle" => 0, "IPC::Open3" => 0, "Module::Build" => "0.28", "Scalar::Util" => 0, "Test" => 0, "Test::More" => 0, "Test::NoWarnings" => 0, "lib" => 0, "perl" => "5.008001", "utf8" => 0 } ); my %fallback_build_requires = ( "AutoLoader" => 0, "Config" => 0, "Cwd" => 0, "Exporter" => 0, "ExtUtils::MakeMaker" => 0, "Fcntl" => 0, "File::Spec" => 0, "File::Temp" => 0, "IO::Handle" => 0, "IPC::Open3" => 0, "Module::Build" => "0.28", "Scalar::Util" => 0, "Test" => 0, "Test::More" => 0, "Test::NoWarnings" => 0, "lib" => 0, "perl" => "5.008001", "utf8" => 0 ); unless ( eval { Module::Build->VERSION(0.4004) } ) { delete $module_build_args{test_requires}; $module_build_args{build_requires} = \%fallback_build_requires; } my $build = Module::Build->new(%module_build_args); $build->create_build_script; META.json100644001750001750 4700613673264062 15002 0ustar00tommytommy000000000000File-Util-4.201720{ "abstract" : "Easy, versatile, portable file handling", "author" : [ "Tommy Butler" ], "dynamic_config" : 0, "generated_by" : "Dist::Zilla version 6.015, CPAN::Meta::Converter version 2.150010", "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.28" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0", "Module::Build" : "0.28", "perl" : "5.008001" } }, "develop" : { "requires" : { "Devel::Cover" : "0", "Dist::Zilla" : "0", "File::Copy" : "0", "File::Spec" : "0", "File::Temp" : "0", "FindBin" : "0", "Perl::Critic" : "0", "Perl::Critic::Lax" : "0", "Pod::Coverage::TrustPod" : "0", "Pod::Wordlist" : "0", "Test::CPAN::Changes" : "0.19", "Test::CPAN::Meta" : "0", "Test::CPAN::Meta::JSON" : "0.16", "Test::Fatal" : "0", "Test::Kwalitee" : "1.21", "Test::Mojibake" : "0", "Test::More" : "0.96", "Test::NoTabs" : "0", "Test::Perl::Critic" : "0", "Test::Pod" : "1.41", "Test::Pod::Coverage" : "1.08", "Test::Spelling" : "0.12", "Test::Synopsis" : "0", "Test::Version" : "1", "inc::latest" : "0", "lib" : "0" } }, "runtime" : { "recommends" : { "Unicode::UTF8" : "0.58" }, "requires" : { "Exporter" : "0", "Fcntl" : "0", "Scalar::Util" : "0", "constant" : "0", "perl" : "5.008001", "strict" : "0", "subs" : "0", "vars" : "0", "warnings" : "0" } }, "test" : { "recommends" : { "CPAN::Meta" : "2.120900" }, "requires" : { "AutoLoader" : "0", "Config" : "0", "Cwd" : "0", "Exporter" : "0", "ExtUtils::MakeMaker" : "0", "Fcntl" : "0", "File::Spec" : "0", "File::Temp" : "0", "IO::Handle" : "0", "IPC::Open3" : "0", "Module::Build" : "0.28", "Scalar::Util" : "0", "Test" : "0", "Test::More" : "0", "Test::NoWarnings" : "0", "lib" : "0", "perl" : "5.008001", "utf8" : "0" } } }, "provides" : { "File::Util" : { "file" : "lib/File/Util.pm", "version" : "4.201720" }, "File::Util::Definitions" : { "file" : "lib/File/Util/Definitions.pm", "version" : "4.201720" }, "File::Util::Exception" : { "file" : "lib/File/Util/Exception.pm", "version" : "4.201720" }, "File::Util::Exception::Diagnostic" : { "file" : "lib/File/Util/Exception/Diagnostic.pm", "version" : "4.201720" }, "File::Util::Exception::Standard" : { "file" : "lib/File/Util/Exception/Standard.pm", "version" : "4.201720" }, "File::Util::Interface::Classic" : { "file" : "lib/File/Util/Interface/Classic.pm", "version" : "4.201720" }, "File::Util::Interface::Modern" : { "file" : "lib/File/Util/Interface/Modern.pm", "version" : "4.201720" } }, "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.201720", "x_Dist_Zilla" : { "perl" : { "version" : "5.030003" }, "plugins" : [ { "class" : "Dist::Zilla::Plugin::Meta::Contributors", "name" : "Meta::Contributors", "version" : "0.003" }, { "class" : "Dist::Zilla::Plugin::Encoding", "name" : "Encoding", "version" : "6.015" }, { "class" : "Dist::Zilla::Plugin::GatherDir", "config" : { "Dist::Zilla::Plugin::GatherDir" : { "exclude_filename" : [], "exclude_match" : [], "follow_symlinks" : 0, "include_dotfiles" : 0, "prefix" : "", "prune_directory" : [], "root" : "." } }, "name" : "@Filter/GatherDir", "version" : "6.015" }, { "class" : "Dist::Zilla::Plugin::PruneCruft", "name" : "@Filter/PruneCruft", "version" : "6.015" }, { "class" : "Dist::Zilla::Plugin::ManifestSkip", "name" : "@Filter/ManifestSkip", "version" : "6.015" }, { "class" : "Dist::Zilla::Plugin::MetaYAML", "name" : "@Filter/MetaYAML", "version" : "6.015" }, { "class" : "Dist::Zilla::Plugin::License", "name" : "@Filter/License", "version" : "6.015" }, { "class" : "Dist::Zilla::Plugin::Readme", "name" : "@Filter/Readme", "version" : "6.015" }, { "class" : "Dist::Zilla::Plugin::ExecDir", "name" : "@Filter/ExecDir", "version" : "6.015" }, { "class" : "Dist::Zilla::Plugin::ShareDir", "name" : "@Filter/ShareDir", "version" : "6.015" }, { "class" : "Dist::Zilla::Plugin::MakeMaker", "config" : { "Dist::Zilla::Role::TestRunner" : { "default_jobs" : 1 } }, "name" : "@Filter/MakeMaker", "version" : "6.015" }, { "class" : "Dist::Zilla::Plugin::Manifest", "name" : "@Filter/Manifest", "version" : "6.015" }, { "class" : "Dist::Zilla::Plugin::TestRelease", "name" : "@Filter/TestRelease", "version" : "6.015" }, { "class" : "Dist::Zilla::Plugin::ConfirmRelease", "name" : "@Filter/ConfirmRelease", "version" : "6.015" }, { "class" : "Dist::Zilla::Plugin::UploadToCPAN", "name" : "@Filter/UploadToCPAN", "version" : "6.015" }, { "class" : "Dist::Zilla::Plugin::RunExtraTests", "config" : { "Dist::Zilla::Role::TestRunner" : { "default_jobs" : 1 } }, "name" : "RunExtraTests", "version" : "0.029" }, { "class" : "Dist::Zilla::Plugin::ModuleBuild", "config" : { "Dist::Zilla::Role::TestRunner" : { "default_jobs" : 1 } }, "name" : "ModuleBuild", "version" : "6.015" }, { "class" : "Dist::Zilla::Plugin::AutoVersion", "name" : "AutoVersion", "version" : "6.015" }, { "class" : "Dist::Zilla::Plugin::PkgVersion", "name" : "PkgVersion", "version" : "6.015" }, { "class" : "Dist::Zilla::Plugin::PodVersion", "name" : "PodVersion", "version" : "6.015" }, { "class" : "Dist::Zilla::Plugin::MetaProvides::Package", "config" : { "Dist::Zilla::Plugin::MetaProvides::Package" : { "finder_objects" : [ { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : "MetaProvides::Package/AUTOVIV/:InstallModulesPM", "version" : "6.015" } ], "include_underscores" : 0 }, "Dist::Zilla::Role::MetaProvider::Provider" : { "$Dist::Zilla::Role::MetaProvider::Provider::VERSION" : "2.002004", "inherit_missing" : 1, "inherit_version" : 1, "meta_noindex" : 1 }, "Dist::Zilla::Role::ModuleMetadata" : { "Module::Metadata" : "1.000036", "version" : "0.006" } }, "name" : "MetaProvides::Package", "version" : "2.004003" }, { "class" : "Dist::Zilla::Plugin::MinimumPerl", "name" : "MinimumPerl", "version" : "1.006" }, { "class" : "Dist::Zilla::Plugin::MetaConfig", "name" : "MetaConfig", "version" : "6.015" }, { "class" : "Dist::Zilla::Plugin::MetaJSON", "name" : "MetaJSON", "version" : "6.015" }, { "class" : "Dist::Zilla::Plugin::MetaResources", "name" : "MetaResources", "version" : "6.015" }, { "class" : "Dist::Zilla::Plugin::Test::ReportPrereqs", "name" : "Test::ReportPrereqs", "version" : "0.027" }, { "class" : "Dist::Zilla::Plugin::Test::LocalBrew", "name" : "Test::LocalBrew", "version" : "0.08" }, { "class" : "Dist::Zilla::Plugin::Test::Version", "name" : "@TestingMania/Test::Version", "version" : "1.09" }, { "class" : "Dist::Zilla::Plugin::Test::CPAN::Changes", "config" : { "Dist::Zilla::Plugin::Test::CPAN::Changes" : { "changelog" : "Changes" } }, "name" : "@TestingMania/Test::CPAN::Changes", "version" : "0.012" }, { "class" : "Dist::Zilla::Plugin::Test::DistManifest", "name" : "@TestingMania/Test::DistManifest", "version" : "2.000005" }, { "class" : "Dist::Zilla::Plugin::Test::Kwalitee", "config" : { "Dist::Zilla::Plugin::Test::Kwalitee" : { "filename" : "xt/release/kwalitee.t", "skiptest" : [] } }, "name" : "@TestingMania/Test::Kwalitee", "version" : "2.12" }, { "class" : "Dist::Zilla::Plugin::MojibakeTests", "name" : "@TestingMania/MojibakeTests", "version" : "0.8" }, { "class" : "Dist::Zilla::Plugin::Test::Perl::Critic", "name" : "@TestingMania/Test::Perl::Critic", "version" : "3.001" }, { "class" : "Dist::Zilla::Plugin::Test::CPAN::Meta::JSON", "name" : "@TestingMania/Test::CPAN::Meta::JSON", "version" : "0.004" }, { "class" : "Dist::Zilla::Plugin::MetaTests", "name" : "@TestingMania/MetaTests", "version" : "6.015" }, { "class" : "Dist::Zilla::Plugin::PodCoverageTests", "name" : "@TestingMania/PodCoverageTests", "version" : "6.015" }, { "class" : "Dist::Zilla::Plugin::PodSyntaxTests", "name" : "@TestingMania/PodSyntaxTests", "version" : "6.015" }, { "class" : "Dist::Zilla::Plugin::Test::Synopsis", "name" : "@TestingMania/Test::Synopsis", "version" : "2.000007" }, { "class" : "Dist::Zilla::Plugin::Test::NoTabs", "config" : { "Dist::Zilla::Plugin::Test::NoTabs" : { "filename" : "xt/author/no-tabs.t", "finder" : [ ":InstallModules", ":ExecFiles", ":TestFiles" ] } }, "name" : "@TestingMania/Test::NoTabs", "version" : "0.15" }, { "class" : "Dist::Zilla::Plugin::Test::Compile", "config" : { "Dist::Zilla::Plugin::Test::Compile" : { "bail_out_on_fail" : 0, "fail_on_warning" : "author", "fake_home" : 0, "filename" : "t/00-compile.t", "module_finder" : [ ":InstallModules" ], "needs_display" : 0, "phase" : "test", "script_finder" : [ ":PerlExecFiles" ], "skips" : [], "switch" : [] } }, "name" : "@TestingMania/Test::Compile", "version" : "2.058" }, { "class" : "Dist::Zilla::Plugin::Test::PodSpelling", "config" : { "Dist::Zilla::Plugin::Test::PodSpelling" : { "directories" : [ "bin", "lib" ], "spell_cmd" : "", "stopwords" : [ "AND'ed", "BLOCKEX", "BrowserUk", "CIFS", "CPAN", "EBCDIC", "EPOC", "FIFOs", "Github", "NFS", "OO", "POSIX", "SIGNES", "SL", "SMB", "SOLARIS", "STDERR", "Solaris", "UTF", "VMS", "ascii", "benchmarking", "bitmask", "conf", "cpan", "dat", "dbitmask", "ebcdic", "failsafe", "filename", "filenames", "html", "inodes", "iso", "lexically", "listrefs", "merchantability", "metadata", "namespace", "oct", "onfail", "pre", "shiftjis", "subclasses", "subdirectories", "subdirectory", "subpattern", "subref", "subrefs", "syntaxes", "trunc", "txt", "unicode", "vtab" ], "wordlist" : "Pod::Wordlist" } }, "name" : "Test::PodSpelling", "version" : "2.007005" }, { "class" : "Dist::Zilla::Plugin::CheckChangesHasContent", "name" : "CheckChangesHasContent", "version" : "0.011" }, { "class" : "Dist::Zilla::Plugin::TestRelease", "name" : "TestRelease", "version" : "6.015" }, { "class" : "Dist::Zilla::Plugin::ConfirmRelease", "name" : "ConfirmRelease", "version" : "6.015" }, { "class" : "Dist::Zilla::Plugin::Signature", "name" : "Signature", "version" : "1.100930" }, { "class" : "Dist::Zilla::Plugin::AutoPrereqs", "name" : "AutoPrereqs", "version" : "6.015" }, { "class" : "Dist::Zilla::Plugin::Prereqs", "config" : { "Dist::Zilla::Plugin::Prereqs" : { "phase" : "test", "type" : "requires" } }, "name" : "TestRequires", "version" : "6.015" }, { "class" : "Dist::Zilla::Plugin::Prereqs", "config" : { "Dist::Zilla::Plugin::Prereqs" : { "phase" : "runtime", "type" : "recommends" } }, "name" : "Recommends", "version" : "6.015" }, { "class" : "Dist::Zilla::Plugin::Prereqs", "config" : { "Dist::Zilla::Plugin::Prereqs" : { "phase" : "develop", "type" : "requires" } }, "name" : "DevelopRequires", "version" : "6.015" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":InstallModules", "version" : "6.015" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":IncModules", "version" : "6.015" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":TestFiles", "version" : "6.015" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":ExtraTestFiles", "version" : "6.015" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":ExecFiles", "version" : "6.015" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":PerlExecFiles", "version" : "6.015" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":ShareFiles", "version" : "6.015" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":MainModule", "version" : "6.015" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":AllFiles", "version" : "6.015" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":NoFiles", "version" : "6.015" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : "MetaProvides::Package/AUTOVIV/:InstallModulesPM", "version" : "6.015" } ], "zilla" : { "class" : "Dist::Zilla::Dist::Builder", "config" : { "is_trial" : 0 }, "version" : "6.015" } }, "x_contributors" : [ "John Fields ", "Ricardo SIGNES ", "Matt S Trout ", "Nicholas Perez ", "David Golden " ], "x_generated_by_perl" : "v5.30.3", "x_serialization_backend" : "Cpanel::JSON::XS version 4.19", "x_spdx_expression" : "Artistic-1.0-Perl OR GPL-1.0-or-later" } SIGNATURE100644001750001750 2532413673264062 14644 0ustar00tommytommy000000000000File-Util-4.201720This file contains message digests of all files listed in MANIFEST, signed via the Module::Signature module, version 0.83. 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 SHA256 536697d8c9347c65bed88b33d9dacf465e1f9b834402002da0d7794642eb068d AUTHORS SHA256 828ce6b69a4792791453574f51d6a7629daff447b110699407b7ae766f172cb4 Build.PL SHA256 5f3732812570654ba911e45ec4e5f7353f4b63747ebfc506c543e8fb1ccf797f COPYING SHA256 76783706c91b1b47e793488b4ba39cec5fcc8f7f59c05f02fc20729f0893323a Changes SHA256 7aef6115d46c490ed39dcdbf08336704b9cad6588774d724f5134253d1cf5fb0 INSTALL SHA256 996b77ca668f16a443ed14758fce492bddd9f55fe831ee8353274c89191b8544 LICENSE SHA256 918b4bf4bac2ae8b804074b72ae7af026d141190c82f94df93eb873d38daf489 MANIFEST SHA256 b68efeafa67bab334f7765aceab280a900b060e14e3480b1a7ebfb1a2aa3d631 MANIFEST.SKIP SHA256 28c5e4188551cf21d9d7bf731b1c49e2cd9ce1bfeb23746bef4881032ff930a8 META.json SHA256 5d32e887905525e8792ba6fd3350ce43c87413251407f16e82b689fa24bb28be META.yml SHA256 7a602863cd44e6fd5b7d66ee1463a82a8e61547f54c4b8c645ad2192fbcb75b0 Makefile.PL SHA256 66b1dbf93f601ee0bb1fce85951f5c1a4ffd8609160380f30b302d476103aa58 NEWS SHA256 a6e6f2fdc26298cba000345073c135bba6de94fcadee7a220f7279e550081d97 README SHA256 580f1f6bbcb5102c66514a3be5749c5db80425a4fb01354324ba3dd29b2f3a0e TODO SHA256 1b690abdc9e920938858526b0e191c606be35ba1bbd07d0f662557bfc01ffb84 dist.ini SHA256 a9e337a15e417a18dd5ebbcec46124fffe46bfe0ce3716f6cdcf474d9920246a examples/batch_file_rename.pl SHA256 838664ee95b0b3efd8184783e62376eec92190004b6108b57ec74b1035062e3a examples/batch_search_and_replace.pl SHA256 72a8321e1a08b1d9d42c34212a1489960582604aab4644e0598d4f5ecbcf64c2 examples/get_an_open_file_handle.pl SHA256 e60fde7c19f5d3f26a3c1c0945d06953721c300c4919644fca6d95003374b43a examples/increment_a_counter_file.pl SHA256 6a669de4c581ebace3f941c96b3484a420f0ab044eaf9ff539fff6e4d02c8c4b examples/list_the_contents_of_a_directory.pl SHA256 e62ce409a1159f4a9556abbe21720981eece5ebcba427b6a3adfb30288740b73 examples/list_the_contents_of_a_directory_recursively.pl SHA256 125655522c100aac9d81fda747570d92ed3e7a610e88ea6452ac52fd3deb730f examples/load_a_file_into_a_variable.pl SHA256 7b7bfbe2de99775dba3208aef361538a03d82c832de18a39b98c8d3d3d26d91f examples/make_a_new_directory.pl SHA256 c9cb1d0456f7a91f9e792c5a24cf301122a5ba3c08a63c92f2b0918c0e3f26b9 examples/pretty_print_a_directory.pl SHA256 e2bdca37bf291ecdad03c1a3f611b1560a4b1209d0e5c328c309bf8ac2ecdf6d examples/pretty_print_a_directory_using_as_tree.pl SHA256 6341fdb0ca36a0366de857199b54a50f2be585242c914ef7d00e37edd9fa867a examples/pretty_print_a_directory_using_callbacks_fancy.pl SHA256 811011e6840d0cc7dd2967c2568e302b627fb6ff8ddc5e982fe3d8cbf75a548c examples/pretty_print_a_directory_using_callbacks_simple.pl SHA256 23cfcaeb2f2ec7d02809d1f4df118ec8006540bd3e77bd3231cf05811b2c93f5 examples/recursively_remove_a_directory_and_its_contents.pl SHA256 3dd20963d5de2fb1190cd9e4ebb99766332cc5bfbf8d79d210187a0fa7cae367 examples/retry_open_handle.pl SHA256 8695f84c94bbb6ac87c512086a063d5b2f977b99f97eb4648829885b29854086 examples/wrap_the_lines_in_a_file.pl SHA256 a9b1a657670101c2b4d60a1733cb854186c2c9556deef5726b762aec2eff8aa0 examples/write_or_append_to_a_file.pl SHA256 83d3294b64a4019a5547921f58a04233232aa12bf1e9fba8a5bc586dc31309ee lib/File/Util.pm SHA256 8bf470ca2784a9f8bb46ac9b013126b9d2733d72d0c10de941b95d831fb97c18 lib/File/Util/Cookbook.pod SHA256 3a49f6211b0820eaae1fbad5267b4ce681c44dcac54ceb793ad6002e7be26550 lib/File/Util/Definitions.pm SHA256 c963f001a6666d84f9a6909ed2605b0de8b82c87dbf5ea7dd240c69890f7cc0a lib/File/Util/Exception.pm SHA256 daba4ae858209463fafe49aa2d0d3d62cb92389b8460ae38699082ee1fef7788 lib/File/Util/Exception/Diagnostic.pm SHA256 da987f3fe55e1449b8b130d6d46fc5b4da02cd08fe66e4b909fddac593f3dbfd lib/File/Util/Exception/Standard.pm SHA256 d53901900da6e499b54776b2c1b1b4f13d8110de43cd420587306fd6ec26981c lib/File/Util/Interface/Classic.pm SHA256 6b47e250ac55a8752760c31b9d08f244a7df188a15a14a86b3c73b6a0215e154 lib/File/Util/Interface/Modern.pm SHA256 bfe334c815a905c1df36368a0108f8c251f733d7856221e45eff16634fda90c9 lib/File/Util/Manual.pod SHA256 68be0c0f687fd6043c8fe375a9a2a4eebd287a08b7b3d697c1ec00f46b9e0e28 lib/File/Util/Manual/Examples.pod SHA256 49d6f7a2b6466d2345b28487f6d7b72b82c6057a356e3426ecb3ae11e28bcae3 performance/bench_listdir.pl SHA256 cf16394c0b32292637452818779f91c6052b72e31558ab4bb3778d7082e5f3e1 performance/bench_load_time.pl SHA256 59472cf3f4e691080ee2040d33e5718b1751d68e902daf9e2bcb4188fda6fe9f performance/profile_listdir.pl SHA256 795e79fc4c9e129c239c14eeaadc60c996350c43ce2325adb70555d889e28d83 performance/profile_listdir_vs_file-find-rule.pl SHA256 3f3319ced39387324d058d59f4f04533957e77041acf7be2c954c15b4999e1b3 perlcritic.rc SHA256 6baa69e47c97cd623b13a8bf8af5bdc37788e7b2815133e4b81cea8df8de01bd t/00-compile.t SHA256 6af6e060868da96fdbd393cc12f1287a4844814b9828178280b2154b70c951cb t/00-report-prereqs.dd SHA256 32862ed3cdb28367324e2dd1f20af158acc637de8e0487bb296157634e12e08c t/00-report-prereqs.t SHA256 203644c0e9c38bf00274ae01a44a7c85f5f6c062b9bbd9364d60fc499d71bacc t/001_canuseit.t SHA256 0e4b20d308c7be5b81e5c972cba50fecac0f0d837baf6adb787d7b952d2024fa t/002_isa.t SHA256 40844c987030b0548160b22fd9e686c597513d51f806ea722d6d8b620ea683af t/003_can.t SHA256 84840481efb79052fca7b6bf22b87706c9a3a670b9bdcd7dd9f03cba70bbe822 t/004_portable.t SHA256 afe656ae54c203238cf0669ce8dfa9ecbfa169d06a3ac676afcc84a56bfd3785 t/005_ftests.t SHA256 b4b4753f3406d7b59d6fee0d368dee4689711f3516604f510275c86a374b4f03 t/006_io.t SHA256 6765f0272b9adb817c1c4671e191f6463a4de287704f2e1b8579ad2810bfef26 t/007_flock.t SHA256 b2579b798b7879801651886acf3a8c4de3147b7c0a3d7cad1a9bed006a891362 t/008_export_ok.t SHA256 66845b8357892579da6f675ef64707fb392ebb29e1a21144ae7f86f50ff7ce2e t/009_empty_subclass.t SHA256 c86cafc63ff7b99936b0d63987c65b96a05b6e1bb6563a932021a989a2fe2605 t/010_unicode.t SHA256 221ec4e2d84e4fdd060d0e5eab2a4bd8aea76c6c155a0cc1414ea288792492be t/011_abspaths.t SHA256 0bdd91d6f3908d4cc67cf47ee47b78b3397179428f70fd7c97a79160b050dac1 t/012_atomize_path.t SHA256 76b70029e6f11a38fee15dc0b3ad6300105a2cdd07ab214e7276efd22f143ca4 t/013_interface_classic.t SHA256 322bd7f01af1f2b259d8fbd20ba615755de358ae6cc7de466845a341f0f9fb47 t/014_interface_modern.t SHA256 8a81928b9709ee6243be56fdb0a09f68b551bc041870dcc878521725dd9125f0 t/015_destroy.t SHA256 c0e8b664fbf6b40aa81fc3433dde2e2fb8add4cbb8d5aa21d64345db59b1a971 t/016_new.t SHA256 f62bdc3b0e8ca0f49e6a6a3e409835fc2a1360842b1b969dee29c79e2ecd20fd t/017_make_dir_list_dir.t SHA256 9d2eb1f2de5a1d359c863a010d69b6f1a3939a24dbc2f1a71e4acb3814eeb561 t/018_list_dir_advancedmatch.t SHA256 583a9831941bb10f9de4391fb8b6f002a0b1a13723e25522ecd5264cdc5e4c11 t/019_load_dir.t SHA256 4ad80d500aa0dc1ebdf47ec031466e57618ca5055cfed0dfc576c571c2ed4139 t/020_write_file.t SHA256 45a30aafe759cf1e57d1ffab6ba18eb769eb736a816dd393939c529a2d73ac9f t/021_list_dir_regression.t SHA256 3ec98a060fa6a9fb132f094cb7e01163c7bbf2b43bbd6ebc67df0355e978ba36 t/bin SHA256 277c8ebb49935f08203305db02308fef8a3a57d052decd7b5c913d648eb3eacb t/txt SHA256 acd82eb3924901ad78ccd5951bc5e2b4ebfe7ec6f8c210318b62f3842881b317 xt/author/critic.t SHA256 89f6335b90cbedf340afef47053adab386d8b38faded020e58c76beda202e14f xt/author/mojibake.t SHA256 5981477d156c24708693061ae89f6b4e2d2c0ebf28bc6fcf0b1d5f515e248d12 xt/author/no-tabs.t SHA256 8036be88c2eaf3e7dc5e870df19b9d82e7ede9da6ed400a112ce70b335a9902d xt/author/pod-coverage.t SHA256 8b4220672a763e337d63dfc5782210f88da87d8cd49861489e0339262b64e414 xt/author/pod-spell.t SHA256 01c189b60dbbc17780700c3d394ebe0930b9802329799f968dcce40436484111 xt/author/pod-syntax.t SHA256 e0f7231f875bb7b8a5f22ea4104ce06a2e6824fa4367846d7d2e02200073904e xt/author/synopsis.t SHA256 aa25d3dc3ed499cce2f80e827aa3743b52424ea4f98abe8a389b8dd94b9f3e35 xt/author/test-version.t SHA256 f01b1c021d2a667978e559521daf1fa74723886bd94febabb8f3d3bfffb41e52 xt/release/cpan-changes.t SHA256 22b30ccef8256c849bbff57b07902d14836bbe5c0936a1f109529b1e9c48f7e2 xt/release/diesnice-fatalities.t SHA256 cca96410fe6a4ddba52b664adfdd763df8f41c9d1165b7b2a5e4903fe8d9b3f1 xt/release/diesnice-messages.t SHA256 de660a227d463958ac7590e2925e919bbc9b38df4063dcc51539dbd07a34e46e xt/release/dist-manifest.t SHA256 6b7786be0cbfe45a704f8ad96fbedde86f2a6da9839c9e5085e91b450dd14692 xt/release/dist-portable.t SHA256 2e9b021ebd8bc92130968364df790af1e366ad49da0f03dd6eac19d95e09a549 xt/release/distmeta.t SHA256 d37a5da6ee4b9d268fb9e1ade2bc1ba3668a74878e5f467027bb25377d354589 xt/release/kwalitee.t SHA256 64fd76103c4c043e3107a340afd92ee36cde0f89e7543cc328e7f71908794b2f xt/release/localbrew-perl-5.10.1.t SHA256 21875c92bc6485a7dfdb436b30e59a094b61292022ec71b7b2f5545e1400ba3c xt/release/localbrew-perl-5.12.5.t SHA256 fa89bca5d7c423bcbcb3b78eac1d6458bc1b2d03693b90e4a5b4744aff185990 xt/release/localbrew-perl-5.14.4.t SHA256 2a01bb67b02f781e58e5db3b285ccc83e853d72ddfeef5f36f0c29c1eb492c18 xt/release/localbrew-perl-5.16.3.t SHA256 c0dd267e2e60d0980f3687a3f6d7a3aa6e7d3ac2955e1c2823426e337112d107 xt/release/localbrew-perl-5.18.4.t SHA256 50435509b976d434bdcfafbeb156be88b30e7c753b67899326daba0fd648ef18 xt/release/localbrew-perl-5.20.3.t SHA256 e216c45b067923fb54f73d57486b86198c116a07c86d7e1f4759d51e361c07ea xt/release/localbrew-perl-5.22.1.t SHA256 4f8bb6ea58a4862ec678e2342547cc36f75098a28d4f718f2583df79775f5d0a xt/release/localbrew-perl-5.23.6.t SHA256 72ae7c48a46bb9f0bcbb0241cd87b83995fe627dfa28577780caff37f38dfccc xt/release/localbrew-perl-5.8.9.t SHA256 7345a2b379aa2398c681237b33b5abcf2355de28c2f3d1ca7e5441d5b6b42867 xt/release/meta-json.t SHA256 cd60914aeb0a9bdae80c2da4932f4c5be71484590794c42a217917791dd63994 xt/release/onfail.t SHA256 d3c93e4185289e911a7cb8fea055b4fb038a3486ee7ef121b8e8bb2aee4d5496 xt/release/open_handle.t -----BEGIN PGP SIGNATURE----- Version: GnuPG v1 iQIbBAEBAgAGBQJe7WgyAAoJEGe9xj410/4dLy4P9ju0fucMp0O9H2W7tdb2g5Bm BXcXJw4dOTIOVHGil39pJ9dveUntPaAdrE9Vz6pe5I1u4dDyrzyFVWXFyhGZTfDO zyZnhi5QoVsPpsFamBpNuL1kT3v0swjIfTIx7d1Xof5UWZOHgQxjPV3bCEW9g0wo sjNF7N4gbKRuIj0Ww48KKoZRf//glcaUgBIoZPz5oCwdVPpaNkHCjb99mpIeUNt3 Pscbe0cn3REF78LkGZ1nLdJ/3aE5uSbcNqX0DWtD1Ykn11RwZJ1D+V/05g6+JHK4 tL6rOCDxbgS1EQCryiTt9Xl8fcawPbcggspMDISUB7I3gmBTcvNjV2U8CKd/EVoL 41qrziMGh4jSRI2EB0sCBt9zb+2R/72fnFPiAjuJ1fpdGJQNFVJve0M4zExnO9Ip xfpLi6BcdgdMLiMUxYsJd0dcMMja7DaMUAPeBsEEfCDfh9lvPZa91UDcrC1SqElC y06JTPw0ZpPJF7fpj4OeZYxsxc5ydStiQOAF0xX2MLLrMm706xtOgOGDA3mA4yQd i1A99madpkhTzSybY2A+6rpvOJ/HwE08XnCKeNsNqDzw6SBpnEpPFEAZ+wLrDw34 7gLtniXjLOCn1NOqdb3FzWeQPCAMlbAmCulwgO1yly/eaMxYMOUsh6OWaj6Qq9a/ BWdXPOe3azES9aCaB84= =d7eW -----END PGP SIGNATURE----- 006_io.t100644001750001750 746013673264062 14765 0ustar00tommytommy000000000000File-Util-4.201720/t use strict; 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; 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 ); my $ok = fileno $fh ? 1 : 0; 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; } 016_new.t100644001750001750 715213673264062 15146 0ustar00tommytommy000000000000File-Util-4.201720/t 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; 002_isa.t100644001750001750 43713673264062 15103 0ustar00tommytommy000000000000File-Util-4.201720/t use strict; use warnings; use Test::More tests => 2; use Test::NoWarnings; use lib './lib'; use File::Util; my $ftl = File::Util->new(); # check to see if File::Util ISA [foo, etc.] ok ( UNIVERSAL::isa( $ftl, 'File::Util' ), 'ISA File::Util bless matches namespace' ); exit; 003_can.t100644001750001750 166513673264062 15115 0ustar00tommytommy000000000000File-Util-4.201720/t use strict; use warnings; use Test::More tests => 41; use Test::NoWarnings; # load your module... use lib './lib'; use File::Util; my $ftl = File::Util->new(); # check to see if non-autoloaded File::Util methods are can-able ;O) map { ok( ref( $ftl->can( $_ ) ) eq 'CODE', "can $_" ) } qw ( _dropdots _release _seize 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 list_dir load_dir load_file flock_rules make_dir abort_depth needs_binmode new open_handle readlimit read_limit size strip_path trunc use_flock write_file valid_filename VERSION DESTROY ); exit; Makefile.PL100644001750001750 371113673264062 15306 0ustar00tommytommy000000000000File-Util-4.201720# This file was automatically generated by Dist::Zilla::Plugin::MakeMaker v6.015. use strict; use warnings; use 5.008001; use ExtUtils::MakeMaker; my %WriteMakefileArgs = ( "ABSTRACT" => "Easy, versatile, portable file handling", "AUTHOR" => "Tommy Butler", "BUILD_REQUIRES" => { "Module::Build" => "0.28" }, "CONFIGURE_REQUIRES" => { "ExtUtils::MakeMaker" => 0, "Module::Build" => "0.28" }, "DISTNAME" => "File-Util", "LICENSE" => "perl", "MIN_PERL_VERSION" => "5.008001", "NAME" => "File::Util", "PREREQ_PM" => { "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::Spec" => 0, "File::Temp" => 0, "IO::Handle" => 0, "IPC::Open3" => 0, "Module::Build" => "0.28", "Scalar::Util" => 0, "Test" => 0, "Test::More" => 0, "Test::NoWarnings" => 0, "lib" => 0, "utf8" => 0 }, "VERSION" => "4.201720", "test" => { "TESTS" => "t/*.t" } ); my %FallbackPrereqs = ( "AutoLoader" => 0, "Config" => 0, "Cwd" => 0, "Exporter" => 0, "ExtUtils::MakeMaker" => 0, "Fcntl" => 0, "File::Spec" => 0, "File::Temp" => 0, "IO::Handle" => 0, "IPC::Open3" => 0, "Module::Build" => "0.28", "Scalar::Util" => 0, "Test" => 0, "Test::More" => 0, "Test::NoWarnings" => 0, "constant" => 0, "lib" => 0, "strict" => 0, "subs" => 0, "utf8" => 0, "vars" => 0, "warnings" => 0 ); unless ( eval { ExtUtils::MakeMaker->VERSION(6.63_03) } ) { delete $WriteMakefileArgs{TEST_REQUIRES}; delete $WriteMakefileArgs{BUILD_REQUIRES}; $WriteMakefileArgs{PREREQ_PM} = \%FallbackPrereqs; } delete $WriteMakefileArgs{CONFIGURE_REQUIRES} unless eval { ExtUtils::MakeMaker->VERSION(6.52) }; WriteMakefile(%WriteMakefileArgs); perlcritic.rc100644001750001750 37313673264062 16003 0ustar00tommytommy000000000000File-Util-4.201720severity = 5 verbose = 8 [Variables::ProhibitPunctuationVars] allow = $@ $! [TestingAndDebugging::ProhibitNoStrict] allow = refs # Turn these off [-BuiltinFunctions::ProhibitStringyEval] # Turn this on [Lax::ProhibitStringyEval::ExceptForRequire] MANIFEST.SKIP100644001750001750 32213673264062 15205 0ustar00tommytommy000000000000File-Util-4.201720^.*.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/ 007_flock.t100644001750001750 463013673264062 15451 0ustar00tommytommy000000000000File-Util-4.201720/t use strict; use warnings; use Test::More tests => 10; use Test::NoWarnings; use Fcntl qw( ); use File::Temp qw( tmpnam ); use lib './lib'; use File::Util qw( SL NL OS ); my $f = File::Util->new( { onfail => 'zero' } ); my ( $tfh, $tmpf ) = tmpnam(); close $tfh; # I didn't want it opened! unlink $tmpf; # ^^ our auto-flock won't work on duped FH my $have_flock = sub { local $@; eval { flock( STDIN, &Fcntl::LOCK_SH ); flock( STDIN, &Fcntl::LOCK_UN ); }; return $@ ? 0 : 1; }->(); my $have_perms = $f->is_writable( $f->return_path( $tmpf ) ); SKIP: { if ( !$have_flock ) { skip 'Your system cannot flock' => 9; } elsif ( !$have_perms ) { skip 'Insufficient permissions' => 9; } elsif ( $^O =~ /solaris|sunos/i ) { skip 'Solaris flock has issues' => 9; } 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; } unlink $tmpf; exit; # put flock to the "test" sub fight_for_lock { $f->flock_rules( qw( NOBLOCKEX FAIL ) ); # auto-locks file, keep open handle on it my $fh = $f->open_handle( $tmpf => 'write' ); # this should fail, and return a "0" instead of a filehandle return $f->open_handle ( $tmpf => write => { onfail => sub { 'failed correctly' } } ); } 005_ftests.t100644001750001750 374013673264062 15662 0ustar00tommytommy000000000000File-Util-4.201720/t use strict; use warnings; use Test::More tests => 36; use Test::NoWarnings; use lib './lib'; use File::Util qw( SL OS ); my $f = File::Util->new(); my @fls = ( qq[t${\SL}txt], qq[t${\SL}bin], 't', '.', '..' ); # types 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->is_bin( $fls[1], 1 ), 'detects binary file is binary'; ok !$f->is_bin( __FILE__ ), 'detects source file is NOT binary'; for my $file ( @fls ) { # get file size 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), 'and gets correct file creation time OK'; # get file last access time 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), 'and gets lastmod time OK'; # get file's bitmask 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; 00-compile.t100644001750001750 316313673264062 15632 0ustar00tommytommy000000000000File-Util-4.201720/tuse 5.006; use strict; use warnings; # this test was generated with Dist::Zilla::Plugin::Test::Compile 2.058 use Test::More; plan tests => 7 + ($ENV{AUTHOR_TESTING} ? 1 : 0); my @module_files = ( 'File/Util.pm', 'File/Util/Definitions.pm', 'File/Util/Exception.pm', 'File/Util/Exception/Diagnostic.pm', 'File/Util/Exception/Standard.pm', 'File/Util/Interface/Classic.pm', 'File/Util/Interface/Modern.pm' ); # no fake home requested my @switches = ( -d 'blib' ? '-Mblib' : '-Ilib', ); use File::Spec; use IPC::Open3; use IO::Handle; open my $stdin, '<', File::Spec->devnull or die "can't open devnull: $!"; my @warnings; for my $lib (@module_files) { # see L my $stderr = IO::Handle->new; diag('Running: ', join(', ', map { my $str = $_; $str =~ s/'/\\'/g; q{'} . $str . q{'} } $^X, @switches, '-e', "require q[$lib]")) if $ENV{PERL_COMPILE_TEST_DEBUG}; my $pid = open3($stdin, '>&STDERR', $stderr, $^X, @switches, '-e', "require q[$lib]"); binmode $stderr, ':crlf' if $^O eq 'MSWin32'; my @_warnings = <$stderr>; waitpid($pid, 0); is($?, 0, "$lib loaded ok"); shift @_warnings if @_warnings and $_warnings[0] =~ /^Using .*\bblib/ and not eval { +require blib; blib->VERSION('1.01') }; if (@_warnings) { warn @_warnings; push @warnings, @_warnings; } } is(scalar(@warnings), 0, 'no warnings found') or diag 'got warnings: ', ( Test::More->can('explain') ? Test::More::explain(\@warnings) : join("\n", '', @warnings) ) if $ENV{AUTHOR_TESTING}; 010_unicode.t100644001750001750 444613673264062 16000 0ustar00tommytommy000000000000File-Util-4.201720/t 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; 015_destroy.t100644001750001750 215213673264062 16040 0ustar00tommytommy000000000000File-Util-4.201720/t 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; File000755001750001750 013673264062 14617 5ustar00tommytommy000000000000File-Util-4.201720/libUtil.pm100644001750001750 27777413673264062 16322 0ustar00tommytommy000000000000File-Util-4.201720/lib/Fileuse 5.006; use strict; use warnings; package File::Util; $File::Util::VERSION = '4.201720'; 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 default_path strict_path ); 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 { /(?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; my ( $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 ); } # 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 => '', 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 across 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 ); } } elsif ( $in->{binmode} == 1 ) { binmode $fh; } else { binmode $fh, $in->{binmode} # apply user-specified IO layer(s) } } # 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 ) { # you can't use UTF8 'mode' on system IO, so if a user requests # UTF8, we have to use PerlIO if ( $in->{binmode} && lc $in->{binmode} eq 'utf8' ) { open $write_fh, $$MODES{popen}{ $mode }, $clean_name or return $this->_throw( 'bad open' => { filename => $clean_name, mode => $mode, opts => $in, exception => $!, cmd => $mode . $clean_name, } ); } else { 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 { 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; # you can't use UTF8 'mode' on system IO, so if a user requests # UTF8, we have to use PerlIO if ( $in->{binmode} && lc $in->{binmode} eq 'utf8' ) { open $write_fh, $$MODES{popen}{ $mode }, $clean_name or return $this->_throw( 'bad open' => { filename => $clean_name, mode => $mode, opts => $in, exception => $!, cmd => $mode . $clean_name, } ); } else { 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 # ...unless doing utf8 business, in which case it's irrelevant # you can't use UTF8 'mode' on system IO, so if a user requests # UTF8, we have to use PerlIO if ( $in->{binmode} && lc $in->{binmode} eq 'utf8' ) { open $write_fh, $$MODES{popen}{ $mode }, $clean_name or return $this->_throw( 'bad open' => { filename => $clean_name, mode => $mode, opts => $in, exception => $!, cmd => $mode . $clean_name, } ); } else { 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)'; print $write_fh $content; # utf8 filehandles use PerlIO } else { close $write_fh; return $this->_throw( 'no unicode' => $in ); } } elsif ( $in->{binmode} == 1 ) { binmode $write_fh; syswrite( $write_fh, $content ); } else { binmode $write_fh, $in->{binmode}; # apply user-specified IO layer(s) syswrite( $write_fh, $content ); } } else { 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::split_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, } ); } # Final bit of input validation made necessary by the would-be perils # of IO encoding while using sys(open,read,write,seek,tell,etc) - # Basically, using :utf8 encoding with syswrite is deprecated if ( ( exists $in->{use_sysopen} && defined $in->{use_sysopen} ) && ( $in->{binmode} && lc $in->{binmode} eq 'utf8' ) ) { return $this->_throw( 'bad binmode', { meth => 'open_handle', filename => $clean_name, dirname => $root . $path, 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, $mode ) or return $this->_throw( 'bad open', { filename => $clean_name, mode => $mode, exception => $!, cmd => qq($clean_name, $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 ); } } elsif ( $in->{binmode} == 1 ) { binmode $fh; } else { binmode $fh, $in->{binmode} # apply user-specified IO layer(s) } } # 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/; $f } # -------------------------------------------------------- # File::Util::strict_path() # -------------------------------------------------------- sub strict_path { my $path = _myargs( @_ ); my $copy = $path; ( $path ) = $path =~ /(^.*$DIRSPLIT)/; ( $path ) = $copy =~ /(^\.{1,2}$)/ if !defined $path; return unless defined $path; $path .= SL unless substr $path, -1, 1 =~ /$DIRSPLIT/; return $path =~ /$DIRSPLIT/ ? $path : undef; } # -------------------------------------------------------- # File::Util::default_path() # -------------------------------------------------------- sub default_path { my ( $path, $dflt ) = _myargs( @_ ); $dflt = defined $dflt ? $dflt : '.' . SL; $path = strict_path( $path ); return defined $path ? $path : $dflt; } # -------------------------------------------------------- # 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.201720 =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 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, and requires no compiler or make utility on your system in order to install and run it. It loads a minimal amount of code when used, only pulling in support for lesser-used methods on demand. It has no dependencies other than what comes installed with Perl itself. 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 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 L 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 L 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 L 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 file content into a scalar variable as raw text my $content = $f->load_file( 'somefile.txt' ); # read a binary file the same way my $binary_content = $f->load_file( 'barking-cat.mp4' ); # write a raw text file $f->write_file( 'somefile.txt' => $content ); # ...and write a binary 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 with open_handle(): # read, write, append, rwcreate, rwclobber, rwappend, rwupdate, and trunc PLEASE NOTE that as of Perl 5.23, it is deprecated to mix system IO (sysopen/syswrite/sysread/sysseek) with utf8 binmode (see perldoc perlport). As such, File::Util will no longer allow you to do this after version 4.132140. Please see notes on UTF-8 and encoding further below. # ...THIS WILL NOW FAIL! $f->open_handle( 'somefile.txt' => 'write' => { use_sysopen => 1, binmode => 'utf8' } ); =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 for more details and features like advanced pattern matching in directories, callbacks, directory walking, user-definable error handlers, and more. =head2 File Encoding and UTF-8 If you want to read/write in UTF-8, you can do that: $ftl->load_file( 'file.txt' => $content => { binmode => 'utf8' } ); $ftl->write_file( 'file.txt' => $content => { binmode => 'utf8' } ); $ftl->open_handle( 'file.txt' => 'read' => { binmode => 'utf8' } ); # ...and so on Only use C 'utf8'> for text. Encoding and IO layers (sometimes called disciplines) can become complex. It's not something you usually need to worry about unless you wish to really fine tune File::Util's behavior beyond what are very suitable, portable defaults, or accomplish very specific tasks like encoding conversions. You're free to specify any binmode you like, or allow File::Util to use the system's default IO layering. It will automatically use the ":raw" pseudo layer when reading files that are binary, unless specifically told to use something different. You can control things as shown in the examples below: $ftl->load_file( 'file.txt' => $content => { binmode => SPEC } ); $ftl->write_file( 'file.txt' => $content => { binmode => SPEC } ); $ftl->open_handle( 'file.txt' => 'read' => { binmode => SPEC } ); ...where C is one or more of any supported IO layers on your system. Examples might include: =over =item * C<':raw'> =item * C<':unix'> =item * C<':crlf'> =item * C<':stdio'> =item * C<':encoding(ENCODING)'> I =item * ...and much more =back You can learn about the IO layers available to you and what they do in the L perldoc. Available options have increased over the years, and are likely subject to continued evolution. Consult the L and L documentation as your authoritative source of info on what layers to use. =head1 PERFORMANCE File::Util consists of a set of smaller modules, but only loads the ones it needs when it needs them. It offers a comparatively fast load-up time, so using File::Util doesn't bloat your code's resource footprint. Additionally, File::Util has been optimized to run fast. In many scenarios it does more and still out-performs other popular IO modules. Benchmarking tools are included as part of the File::Util installation package. I<(See the benchmarking and profiling scripts> I =head1 METHODS File::Util exposes the following public methods. B>, 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. =over =item atomize_path I<(see L)> =item bitmask I<(see L)> =item can_flock I<(see L)> =item can_utf8 I<(see L)> =item created I<(see L)> =item default_path I<(see L)> =item diagnostic I<(see L)> =item ebcdic I<(see L)> =item escape_filename I<(see L)> =item existent I<(see L)> =item file_type I<(see L)> =item flock_rules I<(see L)> =item is_bin I<(see L)> =item is_readable I<(see L)> =item is_writable I<(see L)> =item last_access I<(see L)> =item last_changed I<(see L)> =item last_modified I<(see L)> =item line_count I<(see L)> =item list_dir I<(see L)> =item load_dir I<(see L)> =item load_file I<(see L)> =item make_dir I<(see L)> =item abort_depth I<(see L)> =item needs_binmode I<(see L)> =item new I<(see L)> =item onfail I<(see L)> =item open_handle I<(see L)> =item read_limit I<(see L)> =item return_path I<(see L)> =item size I<(see L)> =item split_path I<(see L)> =item strict_path I<(see L)> =item strip_path I<(see L)> =item touch I<(see L)> =item trunc I<(see L)> =item unlock_open_handle I<(see L)> =item use_flock I<(see L)> =item valid_filename I<(see L)> =item write_file I<(see L)> =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 - default_path - diagnostic - ebcdic - escape_filename - existent - file_type - is_bin - is_readable - is_writable - last_access - last_changed - last_modified - needs_binmode - strict_path - 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 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. L is also recommended and helps speed things up in several places where you might choose to use unicode as described elsewhere in the L. =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 =head1 SUPPORT If you want to get help, contact the authors (links below in AUTHORS section) I fully endorse L as an excellent source of help with Perl in general. =head1 CONTRIBUTING The project website for File::Util is at L The git repository for File::Util is on Github at L Clone it at L 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 =item * BrowserUk =item * Ricardo SIGNES =item * Matt S Trout =item * Nicholas Perez =item * David Golden =back =head1 AUTHORS Tommy Butler L 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, L, L Other Useful Modules that do similar things: L, L, L, L, L =cut 011_abspaths.t100644001750001750 125213673264062 16150 0ustar00tommytommy000000000000File-Util-4.201720/t 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; 019_load_dir.t100644001750001750 244313673264062 16133 0ustar00tommytommy000000000000File-Util-4.201720/t 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; } 004_portable.t100644001750001750 1010713673264062 16174 0ustar00tommytommy000000000000File-Util-4.201720/t use strict; use warnings; use Test::More tests => 50; use Test::NoWarnings; use lib './lib'; use File::Util qw ( SL NL escape_filename ebcdic valid_filename strip_path needs_binmode ); my $f = File::Util->new(); # check asignability my $NL = NL; my $SL = SL; # newlines ok NL eq $NL, 'NL constant matches variable'; # path seperator ok SL eq $SL, 'SL constant matches variable'; # test file escaping with substitute escape char # with additional char to escape as well. ok escape_filename( q[./foo/bar/baz.t/], '+', '.' ) eq '++foo+bar+baz+t+', 'escaped filename with custom escape'; # test file escaping with defaults ok escape_filename(q[.\foo\bar\baz.t]) eq '._foo_bar_baz.t', 'escaped filename with defaults'; # path stripping in general 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]), qq[?foo is NOT a valid filename]; ok !valid_filename(qq[>foo]), qq[>foo is NOT a valid filename]; ok !valid_filename(qq[_dropdots( qw/. .. foo/ ) )[0] eq 'foo' ? 'dots removed' : 'failed to remove dots' }->() eq 'dots removed', 'removed fsdots OK' ); exit; 001_canuseit.t100644001750001750 35313673264062 16136 0ustar00tommytommy000000000000File-Util-4.201720/t use strict; use warnings; use Test::More tests => 2; use Test::NoWarnings; use lib './lib'; use File::Util; # check object constructor ok ( ref File::Util->new() eq 'File::Util', 'New bare File::Util instantiation' ); exit; 008_export_ok.t100644001750001750 42313673264062 16342 0ustar00tommytommy000000000000File-Util-4.201720/t use strict; use warnings; use Test::More; use Test::NoWarnings; use lib './lib'; use File::Util; 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; 020_write_file.t100644001750001750 263013673264062 16475 0ustar00tommytommy000000000000File-Util-4.201720/t 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; } author000755001750001750 013673264062 15127 5ustar00tommytommy000000000000File-Util-4.201720/xtcritic.t100644001750001750 20113673264062 16702 0ustar00tommytommy000000000000File-Util-4.201720/xt/author#!perl use strict; use warnings; use Test::Perl::Critic (-profile => "perlcritic.rc") x!! -e "perlcritic.rc"; all_critic_ok(); release000755001750001750 013673264062 15245 5ustar00tommytommy000000000000File-Util-4.201720/xtonfail.t100644001750001750 420213673264062 17040 0ustar00tommytommy000000000000File-Util-4.201720/xt/release 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; } no-tabs.t100644001750001750 226513673264062 17024 0ustar00tommytommy000000000000File-Util-4.201720/xt/authoruse strict; use warnings; # this test was generated with Dist::Zilla::Plugin::Test::NoTabs 0.15 use Test::More 0.88; use Test::NoTabs; my @files = ( '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', 't/00-compile.t', 't/00-report-prereqs.dd', 't/00-report-prereqs.t', 't/001_canuseit.t', 't/002_isa.t', 't/003_can.t', 't/004_portable.t', 't/005_ftests.t', 't/006_io.t', 't/007_flock.t', 't/008_export_ok.t', 't/009_empty_subclass.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/021_list_dir_regression.t', 't/txt' ); notabs_ok($_) foreach @files; done_testing; 012_atomize_path.t100644001750001750 546713673264062 17044 0ustar00tommytommy000000000000File-Util-4.201720/t 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 mojibake.t100644001750001750 15113673264062 17212 0ustar00tommytommy000000000000File-Util-4.201720/xt/author#!perl use strict; use warnings qw(all); use Test::More; use Test::Mojibake; all_files_encoding_ok(); synopsis.t100644001750001750 6013673264062 17277 0ustar00tommytommy000000000000File-Util-4.201720/xt/author#!perl use Test::Synopsis; all_synopsis_ok(); 00-report-prereqs.t100644001750001750 1342613673264062 17217 0ustar00tommytommy000000000000File-Util-4.201720/t#!perl use strict; use warnings; # This test was generated by Dist::Zilla::Plugin::Test::ReportPrereqs 0.027 use Test::More tests => 1; use ExtUtils::MakeMaker; use File::Spec; # from $version::LAX my $lax_version_re = qr/(?: undef | (?: (?:[0-9]+) (?: \. | (?:\.[0-9]+) (?:_[0-9]+)? )? | (?:\.[0-9]+) (?:_[0-9]+)? ) | (?: v (?:[0-9]+) (?: (?:\.[0-9]+)+ (?:_[0-9]+)? )? | (?:[0-9]+)? (?:\.[0-9]+){2,} (?:_[0-9]+)? ) )/x; # hide optional CPAN::Meta modules from prereq scanner # and check if they are available my $cpan_meta = "CPAN::Meta"; my $cpan_meta_pre = "CPAN::Meta::Prereqs"; my $HAS_CPAN_META = eval "require $cpan_meta; $cpan_meta->VERSION('2.120900')" && eval "require $cpan_meta_pre"; ## no critic # Verify requirements? my $DO_VERIFY_PREREQS = 1; sub _max { my $max = shift; $max = ( $_ > $max ) ? $_ : $max for @_; return $max; } sub _merge_prereqs { my ($collector, $prereqs) = @_; # CPAN::Meta::Prereqs object if (ref $collector eq $cpan_meta_pre) { return $collector->with_merged_prereqs( CPAN::Meta::Prereqs->new( $prereqs ) ); } # Raw hashrefs for my $phase ( keys %$prereqs ) { for my $type ( keys %{ $prereqs->{$phase} } ) { for my $module ( keys %{ $prereqs->{$phase}{$type} } ) { $collector->{$phase}{$type}{$module} = $prereqs->{$phase}{$type}{$module}; } } } return $collector; } my @include = qw( ); my @exclude = qw( ); # Add static prereqs to the included modules list my $static_prereqs = do './t/00-report-prereqs.dd'; # Merge all prereqs (either with ::Prereqs or a hashref) my $full_prereqs = _merge_prereqs( ( $HAS_CPAN_META ? $cpan_meta_pre->new : {} ), $static_prereqs ); # Add dynamic prereqs to the included modules list (if we can) my ($source) = grep { -f } 'MYMETA.json', 'MYMETA.yml'; my $cpan_meta_error; if ( $source && $HAS_CPAN_META && (my $meta = eval { CPAN::Meta->load_file($source) } ) ) { $full_prereqs = _merge_prereqs($full_prereqs, $meta->prereqs); } else { $cpan_meta_error = $@; # capture error from CPAN::Meta->load_file($source) $source = 'static metadata'; } my @full_reports; my @dep_errors; my $req_hash = $HAS_CPAN_META ? $full_prereqs->as_string_hash : $full_prereqs; # Add static includes into a fake section for my $mod (@include) { $req_hash->{other}{modules}{$mod} = 0; } for my $phase ( qw(configure build test runtime develop other) ) { next unless $req_hash->{$phase}; next if ($phase eq 'develop' and not $ENV{AUTHOR_TESTING}); for my $type ( qw(requires recommends suggests conflicts modules) ) { next unless $req_hash->{$phase}{$type}; my $title = ucfirst($phase).' '.ucfirst($type); my @reports = [qw/Module Want Have/]; for my $mod ( sort keys %{ $req_hash->{$phase}{$type} } ) { next if $mod eq 'perl'; next if grep { $_ eq $mod } @exclude; my $file = $mod; $file =~ s{::}{/}g; $file .= ".pm"; my ($prefix) = grep { -e File::Spec->catfile($_, $file) } @INC; my $want = $req_hash->{$phase}{$type}{$mod}; $want = "undef" unless defined $want; $want = "any" if !$want && $want == 0; my $req_string = $want eq 'any' ? 'any version required' : "version '$want' required"; if ($prefix) { my $have = MM->parse_version( File::Spec->catfile($prefix, $file) ); $have = "undef" unless defined $have; push @reports, [$mod, $want, $have]; if ( $DO_VERIFY_PREREQS && $HAS_CPAN_META && $type eq 'requires' ) { if ( $have !~ /\A$lax_version_re\z/ ) { push @dep_errors, "$mod version '$have' cannot be parsed ($req_string)"; } elsif ( ! $full_prereqs->requirements_for( $phase, $type )->accepts_module( $mod => $have ) ) { push @dep_errors, "$mod version '$have' is not in required range '$want'"; } } } else { push @reports, [$mod, $want, "missing"]; if ( $DO_VERIFY_PREREQS && $type eq 'requires' ) { push @dep_errors, "$mod is not installed ($req_string)"; } } } if ( @reports ) { push @full_reports, "=== $title ===\n\n"; my $ml = _max( map { length $_->[0] } @reports ); my $wl = _max( map { length $_->[1] } @reports ); my $hl = _max( map { length $_->[2] } @reports ); if ($type eq 'modules') { splice @reports, 1, 0, ["-" x $ml, "", "-" x $hl]; push @full_reports, map { sprintf(" %*s %*s\n", -$ml, $_->[0], $hl, $_->[2]) } @reports; } else { splice @reports, 1, 0, ["-" x $ml, "-" x $wl, "-" x $hl]; push @full_reports, map { sprintf(" %*s %*s %*s\n", -$ml, $_->[0], $wl, $_->[1], $hl, $_->[2]) } @reports; } push @full_reports, "\n"; } } } if ( @full_reports ) { diag "\nVersions for all modules listed in $source (including optional ones):\n\n", @full_reports; } if ( $cpan_meta_error || @dep_errors ) { diag "\n*** WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING ***\n"; } if ( $cpan_meta_error ) { my ($orig_source) = grep { -f } 'MYMETA.json', 'MYMETA.yml'; diag "\nCPAN::Meta->load_file('$orig_source') failed with: $cpan_meta_error\n"; } if ( @dep_errors ) { diag join("\n", "\nThe following REQUIRED prerequisites were not satisfied:\n", @dep_errors, "\n" ); } pass; # vim: ts=4 sts=4 sw=4 et: kwalitee.t100644001750001750 27513673264062 17363 0ustar00tommytommy000000000000File-Util-4.201720/xt/release# this test was generated with Dist::Zilla::Plugin::Test::Kwalitee 2.12 use strict; use warnings; use Test::More 0.88; use Test::Kwalitee 1.21 'kwalitee_ok'; kwalitee_ok(); done_testing; distmeta.t100644001750001750 17213673264062 17364 0ustar00tommytommy000000000000File-Util-4.201720/xt/release#!perl # This file was automatically generated by Dist::Zilla::Plugin::MetaTests. use Test::CPAN::Meta; meta_yaml_ok(); pod-spell.t100644001750001750 150213673264062 17351 0ustar00tommytommy000000000000File-Util-4.201720/xt/authoruse strict; use warnings; use Test::More; # generated by Dist::Zilla::Plugin::Test::PodSpelling 2.007005 use Test::Spelling 0.12; use Pod::Wordlist; add_stopwords(); all_pod_files_spelling_ok( qw( bin lib ) ); __DATA__ AND'ed BLOCKEX BrowserUk Butler CIFS CPAN Classic Cookbook David Definitions Diagnostic EBCDIC EPOC Examples Exception FIFOs Fields File Github Golden Interface John Manual Matt Modern NFS Nicholas OO POSIX Perez Ricardo SIGNES SL SMB SOLARIS STDERR Solaris Standard Tommy Trout UTF Util VMS ascii benchmarking bitmask conf cpan dagolden dat dbitmask ebcdic failsafe filename filenames html inodes iso jfields lexically lib listrefs merchantability metadata namespace nperez oct onfail perl pre rjbs shiftjis subclasses subdirectories subdirectory subpattern subref subrefs syntaxes trunc txt unicode vtab 009_empty_subclass.t100644001750001750 107313673264062 17410 0ustar00tommytommy000000000000File-Util-4.201720/t use strict; use warnings; use Test::More; use Test::NoWarnings; use lib './lib'; use File::Util; plan tests => ( scalar @File::Util::EXPORT_OK ) + 1; # automated empty subclass test # subclass File::Util in package _Foo package _Foo; use strict; use warnings; use File::Util qw( :all ); $Foo::VERSION = 0.00_0; @_Foo::ISA = qw( File::Util ); 1; # switch back to main package package main; # see if _Foo can do everything that File::Util can do map { ok ref UNIVERSAL::can('_Foo', $_) eq 'CODE', "Empty subclass can $_" } @File::Util::EXPORT_OK; exit; 00-report-prereqs.dd100644001750001750 1032313673264062 17334 0ustar00tommytommy000000000000File-Util-4.201720/tdo { my $x = { 'build' => { 'requires' => { 'Module::Build' => '0.28' } }, 'configure' => { 'requires' => { 'ExtUtils::MakeMaker' => '0', 'Module::Build' => '0.28', 'perl' => '5.008001' } }, 'develop' => { 'requires' => { 'Devel::Cover' => '0', 'Dist::Zilla' => '0', 'File::Copy' => '0', 'File::Spec' => '0', 'File::Temp' => '0', 'FindBin' => '0', 'Perl::Critic' => '0', 'Perl::Critic::Lax' => '0', 'Pod::Coverage::TrustPod' => '0', 'Pod::Wordlist' => '0', 'Test::CPAN::Changes' => '0.19', 'Test::CPAN::Meta' => '0', 'Test::CPAN::Meta::JSON' => '0.16', 'Test::Fatal' => '0', 'Test::Kwalitee' => '1.21', 'Test::Mojibake' => '0', 'Test::More' => '0.96', 'Test::NoTabs' => '0', 'Test::Perl::Critic' => '0', 'Test::Pod' => '1.41', 'Test::Pod::Coverage' => '1.08', 'Test::Spelling' => '0.12', 'Test::Synopsis' => '0', 'Test::Version' => '1', 'inc::latest' => '0', 'lib' => '0' } }, 'runtime' => { 'recommends' => { 'Unicode::UTF8' => '0.58' }, 'requires' => { 'Exporter' => '0', 'Fcntl' => '0', 'Scalar::Util' => '0', 'constant' => '0', 'perl' => '5.008001', 'strict' => '0', 'subs' => '0', 'vars' => '0', 'warnings' => '0' } }, 'test' => { 'recommends' => { 'CPAN::Meta' => '2.120900' }, 'requires' => { 'AutoLoader' => '0', 'Config' => '0', 'Cwd' => '0', 'Exporter' => '0', 'ExtUtils::MakeMaker' => '0', 'Fcntl' => '0', 'File::Spec' => '0', 'File::Temp' => '0', 'IO::Handle' => '0', 'IPC::Open3' => '0', 'Module::Build' => '0.28', 'Scalar::Util' => '0', 'Test' => '0', 'Test::More' => '0', 'Test::NoWarnings' => '0', 'lib' => '0', 'perl' => '5.008001', 'utf8' => '0' } } }; $x; }meta-json.t100644001750001750 6413673264062 17427 0ustar00tommytommy000000000000File-Util-4.201720/xt/release#!perl use Test::CPAN::Meta::JSON; meta_json_ok(); pod-syntax.t100644001750001750 25213673264062 17541 0ustar00tommytommy000000000000File-Util-4.201720/xt/author#!perl # This file was automatically generated by Dist::Zilla::Plugin::PodSyntaxTests. use strict; use warnings; use Test::More; use Test::Pod 1.41; all_pod_files_ok(); Util000755001750001750 013673264062 15534 5ustar00tommytommy000000000000File-Util-4.201720/lib/FileManual.pod100644001750001750 22675713673264062 17700 0ustar00tommytommy000000000000File-Util-4.201720/lib/File/Utilpackage 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.201720 =head1 INTRODUCTION This manual is is the complete reference to all available public methods for use in L. 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 For examples of full Programs using File::Util, take a look at the L. =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 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. File::Util tries its best to adhere to these guiding principles: =over =item B 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 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 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 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 for the details. =item B 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) 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 I However File::Util is B 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 =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 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> option. As an added convenience, when you use this option with the L, 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> behaviors and their syntaxes are covered below. =over =item keyword: B> This is what File::Util already does: it calls C 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> When you use the predefined B> behavior as the C 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> When you use the predefined B> behavior as the C handler, if File::Util runs into a fatal error it will return C. 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> When you use the predefined B> behavior as the C handler, File::Util will return C if it encounters a fatal error, instead of dying. Then File::Util will emit a B with details about the error, but will not abort execution. You will just get a warning message sent to STDERR and C 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> When you use the predefined B> behavior as the C 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> If you supply a code reference to the C 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 B or C at the end of your error handler,> B 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, 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 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 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 =over =item I C 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 +-------------------------+----------+--------------------+----------------+ | 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 =over =item I C 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 if the file does I exist or could not be accessed. =back =head2 C =over =item I C Returns 1 if the current system claims to support C I if the Perl process can successfully call it. I<(see L.)> 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 Perl tries to support or emulate flock whenever it can via available system calls, namely C; C; or with C. =back =head2 C =over =item I C 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.)> =back =head2 C =over =item I C 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 is C<0> (NOT enabled.) I> =back =head2 C =over =item I C The second string argument is optional. Works just like C>, except that instead of returning C when the argument passed in doesn't look like a path, it will return a default string instead. The default string returned will either be the built-in default path, or the string you specify as a second argument to this method. The default string returned by this method is '.' . SL I<(see L)> This means that on windows, the built-in default would be C<.\> whereas on a POSIX-compliant system (Linux, UNIX, Mac, etc) you would get C<./> I)> =back =head2 C =over =item I C Returns 1 if the machine on which the code is running uses EBCDIC, or returns 0 if not. I<(see L.)> 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 =over =item I C 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 =over =item I C 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)>, it's just easier for some people to remember. =back =head2 C =over =item I C 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.)> 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 =item C =item C =item C =item C =item C =item C =item C =item C =back =back =head2 C =over =item I C 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 B B 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 tries to get an exclusive lock on the file without blocking (waiting) =item C tries to get a shared lock on the file without blocking =item C waits to get an exclusive lock =item C waits to get a shared lock =item C dies with stack trace =item C warn()s about the error and returns undef =item C ignores the failure to get an exclusive lock =item C returns undef =item C returns 0 =back Examples: =over =item ex- C 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 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 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 =over =item I C 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)>, it's just easier for some people to remember. =back =head2 C =over =item I C Returns 1 if the named file (or directory) is B 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)>, it's just easier for some people to remember. =back =head2 C =over =item I C Returns 1 if the named file (or directory) is B 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)>, it's just easier for some people to remember. =back =head2 C =over =item I C 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.)> =back =head2 C =over =item I C 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.)> =back =head2 C =over =item I C 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.)> =back =head2 C =over =item I C Returns the number of lines in the named file. Fails with an error if the named file does not exist. =back =head2 C =over =item I 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 for several useful ways to use C. 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> =over =item C<< callback => subroutine reference >> C 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 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. I C, I I Remember that the code in your callback gets executed in real time, I. 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 is just like a C, 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 directory in the path you provided as your first argument to C. =item C<< f_callback => subroutine reference >> Similarly an C is just like a C, 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 directory in the path you provided as your first argument to C. =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 to limit results to directories at no more than the maximum depth you specify. This only works in tandem with the C option (or the C option which is similar). For compatibility reasons, you can use "C" 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 recursions for directory listings, on a per-listing basis with this option. Just like the main C 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 limit is reached. I> =item C<< recurse_fast => boolean >> Recurse into subdirectories, without checking for filesystem loops. This works exactly like the C 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 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. 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 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 doesn't recurse into subdirectories unless you tell it to with C<< recurse => 1 >> =back =item B> C can use Perl L 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 I I I =over =item C<< files_match => qr/regexp/ >> =item I 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 would not be able to "cascade" or recurse into subdirectories in search of matching files. Use the C option in combination with this matching parameter to exclude the preceding directory names. =item C<< dirs_match => qr/regexp/ >> =item I 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 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 option instead. B<*NOTE:> Bear in mind that just because you tell C 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 option. =item C<< path_matches => qr/regexp/ >> =item I 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 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 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 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 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 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 (when you want to NOT match something) - use Perl! As shown in the L, Perl already provides support for negated matching in the form of "zero-width negative assertions". (See L 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 =over =item I 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> =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 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, 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 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) 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 =over =item I C<< load_file( [file name] => { options } ) >> =item I 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 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 option (see below). =over =item B> =over =item C<< as_lines => boolean >> If this option is enabled then your call to C 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 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) 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 or if the method was called with the option C. 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>), or to read the file as UTF-8 encoded data, specify a value of B> to this option. I<(see L)>. 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 call), you are telling C to ignore the global/default setting for I, and to apply your one-time limit of [ positive integer ] bytes on the file while it is read into memory. B 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) 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. =back =back =back =head2 C =over =item I 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. If specified, the bitmask must be supplied in the form required by the native perl umask function (as an octal number). I> 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. Upon successful creation of the [new directory name], the [new directory name] is returned to the caller. =over =item B> =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 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 =over =item I C 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. 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)> =back =head2 C =over =item I C Returns 1 if the machine on which the code is running requires that C I<(a built-in function)> be called on open file handles, or returns 0 if not. I<(see L.)> 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 =over =item I 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> =over =item C<< use_flock => boolean >> Optionally specify this option to the C method to instruct the new object that it should never attempt to use C in it's I/O operations. The default is to use C if available on your system. Specify this option with a true or false value ( 1 or 0 ), true to use C, 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 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 I<(see also: L)> =item B designated handler >>> Set the I 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 handler to nearly any function in File::Util, but when you do so for the C constructor, you are setting the I. Acceptable values are all covered in the B> section (above), along with proper syntax and example usage. =back =back =back =head2 C =over =item I C 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>>). The syntax and keywords available to use for this method are already discussed above in the L 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 =over =item I C<< open_handle( [file name] => [mode] => { options } ) >> =item I 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 on the filehandle yourself, at your own discretion. Leaving filehandles open is not a good practice, and is not recommended. I>). 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 object is created I<(see L)> or by using the C option when calling C, 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 in all of them, you know that you're covered. A slight inconvenience for the price of a larger set of features (compare L to this method) I> C 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 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 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> 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 The default behavior of C is to open file handles using Perl's native C I<(see L)>. Unless you use the C 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 Optionally you can ask C to open your handle using C instead of using the native Perl C. This is accomplished by enabling the C 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 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 and print to them as you normally would print to a file handle. You have to use C instead. The same applies here. If you get a C'd filehandle from C it is imperative that you use C on it. You'll also need to use C and other type of C* commands on the filehandle instead of their native Perl equivalents. (see L, L, L, L) That said, here are the different modes you can choose from to get a file handle when using the C 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 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 and not plain C when reading those C'd filehandles! =back =over =item B> =over =item C<< binmode => [ boolean or 'utf8' ] >> Tell File::Util to open the file in binmode (if set to a true boolean: B>), or to open the file with UTF-8 encoding, specify a value of B> to this option. I<(see L)>. 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)>. This method will not try to get a lock on the file if the File::Util object was created with the option C or if this method is called with the option C. =item C<< use_sysopen => boolean >> Instead of opening the file using Perl's native C command, C will open the file with the C command. You will have to remember that your filehandle is a C'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* equivalents. See L for a more in-depth explanation of why you can't mix native Perl I/O with system I/O. =back =back =head2 C =over =item I C By default, the largest size file that File::Util will read into memory and return via the L 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 =over =item I C Takes the file path from the file name provided and returns it such that C is returned as C. This method is optimized for speed and returns anything that could possibly be a file path, even if that means the path is actually C if you passed it such an argument. Technically, you could indeed have a directory named C, so this method doesn't distinguish between strings that look like file names and ones that don't. If you want one that does, you need to use C instead. I<(see L)> =back =head2 C =over =item I C Returns the file size of [file name] in bytes. Returns C<0> if the file is empty. Returns C if the file does not exist. =back =head2 C =over =item I C 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 =over =item I C Works just like C> except that it is more strict in what it returns. If you pass it a string that does not "look" like a path (a string with no directory separators or that is not C<.> or C<..>), then this method will return C. If you'd like to get a default path string returned instead of C, then you want to use the C> method instead. I<(see also L and L)> =back =head2 C =over =item I C Strips the file path from the file name provided and returns the file name only. Given C, it returns C Given C, it returns C =back =head2 C =over =item I C Behaves like the *nix C command; Updates the access and modification times of the specified file to the current time. If the file does not exist, C 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 =over =item I C 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 =over =item I C Release the flock on a file handle you opened with L. 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 if you so desire. Failure is not ever very likely, or C wouldn't have been able to get a portable lock on the file in the first place. If C 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 option at the time L was called, or if file locking was disabled using the L method, or if file locking was disabled on the entire C object at the time of its creation I<(see L)>, calling this method will have no effect and a true value will be returned. =back =head2 C =over =item I C When called without any arguments, this method returns a true or false value to reflect the current use of C 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 in its I/O operations. A true value indicates that the File::Util object will use C if available, a false value indicates that it will not. The default is to use C when available on your system. =over =item I> 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> File locking has known issues on B. Solaris claims to offer a native C 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 =over =item I C<< write_file( [file name] => [string] => { other_options } ) >> =item I 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> 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> =over =item C<< binmode => [ boolean or 'utf8' ] >> Tell File::Util to write the file in binmode (if set to a true boolean: B>), or to write the file with UTF-8 encoding, specify a value of B> to this option. I<(see L)>. 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)>. This method will not try to get a lock on the file if the File::Util object was created with the option C or if this method is called with the option C enabled. =back =back =back =head2 C =over =item I C 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 =over =item I C Short for "Bew Bine". Returns the correct new line character (or character sequence) for the system on which your program runs. =back =head2 C =over =item I C Short for "Bash". Returns the correct directory path separator for the system on which your program runs. =back =head2 C =over =item I C Returns the File::Util keyword for the operating system B 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 library), or if that doesn't contain a recognizable value, finally falls back to C. Generally speaking, Linux operating systems are going to be detected as C. This isn't a bug. The OS FAMILY to which it belongs uses C 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 =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, L, L =cut __END__ 014_interface_modern.t100644001750001750 1325713673264062 17702 0ustar00tommytommy000000000000File-Util-4.201720/t 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; open_handle.t100644001750001750 1703313673264062 20072 0ustar00tommytommy000000000000File-Util-4.201720/xt/release 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; test-version.t100644001750001750 63713673264062 20104 0ustar00tommytommy000000000000File-Util-4.201720/xt/authoruse strict; use warnings; use Test::More; # generated by Dist::Zilla::Plugin::Test::Version 1.09 use Test::Version; my @imports = qw( version_all_ok ); my $params = { is_strict => 0, has_version => 1, multiple => 0, }; push @imports, $params if version->parse( $Test::Version::VERSION ) >= version->parse('1.002'); Test::Version->import(@imports); version_all_ok; done_testing; pod-coverage.t100644001750001750 33413673264062 20007 0ustar00tommytommy000000000000File-Util-4.201720/xt/author#!perl # This file was automatically generated by Dist::Zilla::Plugin::PodCoverageTests. use Test::Pod::Coverage 1.08; use Pod::Coverage::TrustPod; all_pod_coverage_ok({ coverage_class => 'Pod::Coverage::TrustPod' }); 013_interface_classic.t100644001750001750 457513673264062 20021 0ustar00tommytommy000000000000File-Util-4.201720/t 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; 017_make_dir_list_dir.t100644001750001750 1271013673264062 20036 0ustar00tommytommy000000000000File-Util-4.201720/t 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 => 25; 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'; 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; } cpan-changes.t100644001750001750 34413673264062 20102 0ustar00tommytommy000000000000File-Util-4.201720/xt/releaseuse strict; use warnings; # this test was generated with Dist::Zilla::Plugin::Test::CPAN::Changes 0.012 use Test::More 0.96 tests => 1; use Test::CPAN::Changes; subtest 'changes_ok' => sub { changes_file_ok('Changes'); }; Cookbook.pod100644001750001750 2036213673264062 20171 0ustar00tommytommy000000000000File-Util-4.201720/lib/File/Utilpackage 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.201720 =head1 INTRODUCTION The following are fully functional programs using L 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. =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 =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 =cut __END__ Exception.pm100644001750001750 1120413673264062 20206 0ustar00tommytommy000000000000File-Util-4.201720/lib/File/Utiluse strict; use warnings; package File::Util::Exception; $File::Util::Exception::VERSION = '4.201720'; # 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.201720 =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 dist-portable.t100644001750001750 73613673264062 20331 0ustar00tommytommy000000000000File-Util-4.201720/xt/release 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; dist-manifest.t100644001750001750 23013673264062 20314 0ustar00tommytommy000000000000File-Util-4.201720/xt/release#!perl use Test::More; eval "use Test::DistManifest"; plan skip_all => "Test::DistManifest required for testing the manifest" if $@; manifest_ok(); 021_list_dir_regression.t100644001750001750 160213673264062 20414 0ustar00tommytommy000000000000File-Util-4.201720/t 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 => 2; use Test::NoWarnings; 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 @test_dirs = qw/ Fin Rey Kylo Poe /; for my $tdir ( @test_dirs ) { $ftl->make_dir( $testbed . SL . $tdir ) } is_deeply ( [ sort $ftl->list_dir( $testbed ) ], [ sort qw( . .. ), @test_dirs ], 'regression: plain dir listing with only subdirs present (no files)' ); exit; Definitions.pm100644001750001750 1240313673264062 20525 0ustar00tommytommy000000000000File-Util-4.201720/lib/File/Utiluse strict; use warnings; package File::Util::Definitions; $File::Util::Definitions::VERSION = '4.201720'; # 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.201720 =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 performance000755001750001750 013673264062 15473 5ustar00tommytommy000000000000File-Util-4.201720bench_listdir.pl100644001750001750 453513673264062 21010 0ustar00tommytommy000000000000File-Util-4.201720/performance#!/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% -- examples000755001750001750 013673264062 15010 5ustar00tommytommy000000000000File-Util-4.201720batch_file_rename.pl100644001750001750 156713673264062 21125 0ustar00tommytommy000000000000File-Util-4.201720/examples# 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; retry_open_handle.pl100644001750001750 173613673264062 21215 0ustar00tommytommy000000000000File-Util-4.201720/examples# 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; 018_list_dir_advancedmatch.t100644001750001750 1377413673264062 21061 0ustar00tommytommy000000000000File-Util-4.201720/t 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; } profile_listdir.pl100644001750001750 50613673264062 21343 0ustar00tommytommy000000000000File-Util-4.201720/performance#!/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__ bench_load_time.pl100644001750001750 544713673264062 21276 0ustar00tommytommy000000000000File-Util-4.201720/performance#!/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% -- diesnice-messages.t100644001750001750 3427713673264062 21217 0ustar00tommytommy000000000000File-Util-4.201720/xt/release 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 => 70; # 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' ); # 33 like( $f->_throw( 'bad binmode' => { filename => __FILE__, meth => 'anonymous', diag => 1, } ), qr/(?m)^IO discipline conflict/, 'cant mix syswrite with :utf8 (diagnostic mode)' ); # 33.5 like( $f->_throw( 'bad binmode' => { } ), qr/(?m)^The use of system IO.+?on utf8 file handles is deprecated/, 'cant mix syswrite with :utf8' ); exit; make_a_new_directory.pl100644001750001750 70313673264062 21637 0ustar00tommytommy000000000000File-Util-4.201720/examples# 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; diesnice-fatalities.t100644001750001750 2641013673264062 21523 0ustar00tommytommy000000000000File-Util-4.201720/xt/release 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 => 37; 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 SYSopen a file with a utf8 binmode $exception = exception { $ftl->open_handle ( { use_sysopen => 1, filename => 'dummyfile', mode => 'write', binmode => 'utf8', } ) }; like $exception, qr/(?m)^The use of system IO.+?on utf8 file handles is deprecated/, 'try to open_handle with mixed utf8 and systemIO options'; # 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; } Interface000755001750001750 013673264062 17434 5ustar00tommytommy000000000000File-Util-4.201720/lib/File/UtilModern.pm100644001750001750 1112313673264062 21374 0ustar00tommytommy000000000000File-Util-4.201720/lib/File/Util/Interfaceuse strict; use warnings; package File::Util::Interface::Modern; $File::Util::Interface::Modern::VERSION = '4.201720'; # ABSTRACT: Modern call interface to File::Util 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.201720 =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 Manual000755001750001750 013673264062 16751 5ustar00tommytommy000000000000File-Util-4.201720/lib/File/UtilExamples.pod100644001750001750 4746313673264062 21431 0ustar00tommytommy000000000000File-Util-4.201720/lib/File/Util/Manualpackage 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.201720 =head1 INTRODUCTION This manual subsection is fully comprised of simple examples of L 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. =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 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 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 # 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 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 option with other options, such as the regex pattern matching options covered above, or options like C, or C. *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 documentation), which you can override manually by setting the C 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 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 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 (very, very old) 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 =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, L =cut __END__ localbrew-perl-5.8.9.t100644001750001750 614413673264062 21170 0ustar00tommytommy000000000000File-Util-4.201720/xt/release#!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 PERL5LIB/}; 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 $perlbrew_path = $ENV{'PATH'}; if(my $local_lib_root = $ENV{'PERL_LOCAL_LIB_ROOT'}) { my @path = File::Spec->path; while(@path && $path[0] =~ /^$local_lib_root/) { shift @path; } if($^O eq 'MSWin32') { $perlbrew_path = join(';', @path); } else { $perlbrew_path = join(':', @path); } } my ( $env, $status ) = do { local $ENV{'PATH'} = $perlbrew_path; 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 = do { local $ENV{'PATH'} = $perlbrew_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 { open STDIN, '<', File::Spec->devnull; open STDOUT, '>', File::Spec->devnull; open STDERR, '>', File::Spec->devnull; 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; # We use system here instead of exec so that $tmpdir gets cleaned up # after cpanm finishes system 'perl', $cpanm_path, '-L', $tmpdir->dirname, '.'; exit($? >> 8); } Classic.pm100644001750001750 716413673264062 21523 0ustar00tommytommy000000000000File-Util-4.201720/lib/File/Util/Interfaceuse strict; use warnings; package File::Util::Interface::Classic; $File::Util::Interface::Classic::VERSION = '4.201720'; # ABSTRACT: Legacy call interface to File::Util use Scalar::Util qw( blessed ); 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.201720 =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, 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 localbrew-perl-5.10.1.t100644001750001750 614513673264062 21232 0ustar00tommytommy000000000000File-Util-4.201720/xt/release#!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 PERL5LIB/}; 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 $perlbrew_path = $ENV{'PATH'}; if(my $local_lib_root = $ENV{'PERL_LOCAL_LIB_ROOT'}) { my @path = File::Spec->path; while(@path && $path[0] =~ /^$local_lib_root/) { shift @path; } if($^O eq 'MSWin32') { $perlbrew_path = join(';', @path); } else { $perlbrew_path = join(':', @path); } } my ( $env, $status ) = do { local $ENV{'PATH'} = $perlbrew_path; 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 = do { local $ENV{'PATH'} = $perlbrew_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 { open STDIN, '<', File::Spec->devnull; open STDOUT, '>', File::Spec->devnull; open STDERR, '>', File::Spec->devnull; 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; # We use system here instead of exec so that $tmpdir gets cleaned up # after cpanm finishes system 'perl', $cpanm_path, '-L', $tmpdir->dirname, '.'; exit($? >> 8); } localbrew-perl-5.12.5.t100644001750001750 614513673264062 21240 0ustar00tommytommy000000000000File-Util-4.201720/xt/release#!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 PERL5LIB/}; 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 $perlbrew_path = $ENV{'PATH'}; if(my $local_lib_root = $ENV{'PERL_LOCAL_LIB_ROOT'}) { my @path = File::Spec->path; while(@path && $path[0] =~ /^$local_lib_root/) { shift @path; } if($^O eq 'MSWin32') { $perlbrew_path = join(';', @path); } else { $perlbrew_path = join(':', @path); } } my ( $env, $status ) = do { local $ENV{'PATH'} = $perlbrew_path; 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 = do { local $ENV{'PATH'} = $perlbrew_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 { open STDIN, '<', File::Spec->devnull; open STDOUT, '>', File::Spec->devnull; open STDERR, '>', File::Spec->devnull; 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; # We use system here instead of exec so that $tmpdir gets cleaned up # after cpanm finishes system 'perl', $cpanm_path, '-L', $tmpdir->dirname, '.'; exit($? >> 8); } localbrew-perl-5.14.4.t100644001750001750 614513673264062 21241 0ustar00tommytommy000000000000File-Util-4.201720/xt/release#!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 PERL5LIB/}; 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 $perlbrew_path = $ENV{'PATH'}; if(my $local_lib_root = $ENV{'PERL_LOCAL_LIB_ROOT'}) { my @path = File::Spec->path; while(@path && $path[0] =~ /^$local_lib_root/) { shift @path; } if($^O eq 'MSWin32') { $perlbrew_path = join(';', @path); } else { $perlbrew_path = join(':', @path); } } my ( $env, $status ) = do { local $ENV{'PATH'} = $perlbrew_path; 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 = do { local $ENV{'PATH'} = $perlbrew_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 { open STDIN, '<', File::Spec->devnull; open STDOUT, '>', File::Spec->devnull; open STDERR, '>', File::Spec->devnull; 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; # We use system here instead of exec so that $tmpdir gets cleaned up # after cpanm finishes system 'perl', $cpanm_path, '-L', $tmpdir->dirname, '.'; exit($? >> 8); } localbrew-perl-5.16.3.t100644001750001750 614513673264062 21242 0ustar00tommytommy000000000000File-Util-4.201720/xt/release#!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 PERL5LIB/}; 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 $perlbrew_path = $ENV{'PATH'}; if(my $local_lib_root = $ENV{'PERL_LOCAL_LIB_ROOT'}) { my @path = File::Spec->path; while(@path && $path[0] =~ /^$local_lib_root/) { shift @path; } if($^O eq 'MSWin32') { $perlbrew_path = join(';', @path); } else { $perlbrew_path = join(':', @path); } } my ( $env, $status ) = do { local $ENV{'PATH'} = $perlbrew_path; 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 = do { local $ENV{'PATH'} = $perlbrew_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 { open STDIN, '<', File::Spec->devnull; open STDOUT, '>', File::Spec->devnull; open STDERR, '>', File::Spec->devnull; 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; # We use system here instead of exec so that $tmpdir gets cleaned up # after cpanm finishes system 'perl', $cpanm_path, '-L', $tmpdir->dirname, '.'; exit($? >> 8); } localbrew-perl-5.18.4.t100644001750001750 614513673264062 21245 0ustar00tommytommy000000000000File-Util-4.201720/xt/release#!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 PERL5LIB/}; unless($ENV{'PERLBREW_ROOT'}) { plan skip_all => "Environment variable 'PERLBREW_ROOT' not found"; exit; } my $brew = q[perl-5.18.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 $perlbrew_path = $ENV{'PATH'}; if(my $local_lib_root = $ENV{'PERL_LOCAL_LIB_ROOT'}) { my @path = File::Spec->path; while(@path && $path[0] =~ /^$local_lib_root/) { shift @path; } if($^O eq 'MSWin32') { $perlbrew_path = join(';', @path); } else { $perlbrew_path = join(':', @path); } } my ( $env, $status ) = do { local $ENV{'PATH'} = $perlbrew_path; 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 = do { local $ENV{'PATH'} = $perlbrew_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 { open STDIN, '<', File::Spec->devnull; open STDOUT, '>', File::Spec->devnull; open STDERR, '>', File::Spec->devnull; 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; # We use system here instead of exec so that $tmpdir gets cleaned up # after cpanm finishes system 'perl', $cpanm_path, '-L', $tmpdir->dirname, '.'; exit($? >> 8); } localbrew-perl-5.20.3.t100644001750001750 614513673264062 21235 0ustar00tommytommy000000000000File-Util-4.201720/xt/release#!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 PERL5LIB/}; unless($ENV{'PERLBREW_ROOT'}) { plan skip_all => "Environment variable 'PERLBREW_ROOT' not found"; exit; } my $brew = q[perl-5.20.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 $perlbrew_path = $ENV{'PATH'}; if(my $local_lib_root = $ENV{'PERL_LOCAL_LIB_ROOT'}) { my @path = File::Spec->path; while(@path && $path[0] =~ /^$local_lib_root/) { shift @path; } if($^O eq 'MSWin32') { $perlbrew_path = join(';', @path); } else { $perlbrew_path = join(':', @path); } } my ( $env, $status ) = do { local $ENV{'PATH'} = $perlbrew_path; 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 = do { local $ENV{'PATH'} = $perlbrew_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 { open STDIN, '<', File::Spec->devnull; open STDOUT, '>', File::Spec->devnull; open STDERR, '>', File::Spec->devnull; 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; # We use system here instead of exec so that $tmpdir gets cleaned up # after cpanm finishes system 'perl', $cpanm_path, '-L', $tmpdir->dirname, '.'; exit($? >> 8); } localbrew-perl-5.22.1.t100644001750001750 614513673264062 21235 0ustar00tommytommy000000000000File-Util-4.201720/xt/release#!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 PERL5LIB/}; unless($ENV{'PERLBREW_ROOT'}) { plan skip_all => "Environment variable 'PERLBREW_ROOT' not found"; exit; } my $brew = q[perl-5.22.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 $perlbrew_path = $ENV{'PATH'}; if(my $local_lib_root = $ENV{'PERL_LOCAL_LIB_ROOT'}) { my @path = File::Spec->path; while(@path && $path[0] =~ /^$local_lib_root/) { shift @path; } if($^O eq 'MSWin32') { $perlbrew_path = join(';', @path); } else { $perlbrew_path = join(':', @path); } } my ( $env, $status ) = do { local $ENV{'PATH'} = $perlbrew_path; 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 = do { local $ENV{'PATH'} = $perlbrew_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 { open STDIN, '<', File::Spec->devnull; open STDOUT, '>', File::Spec->devnull; open STDERR, '>', File::Spec->devnull; 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; # We use system here instead of exec so that $tmpdir gets cleaned up # after cpanm finishes system 'perl', $cpanm_path, '-L', $tmpdir->dirname, '.'; exit($? >> 8); } localbrew-perl-5.23.6.t100644001750001750 614513673264062 21243 0ustar00tommytommy000000000000File-Util-4.201720/xt/release#!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 PERL5LIB/}; unless($ENV{'PERLBREW_ROOT'}) { plan skip_all => "Environment variable 'PERLBREW_ROOT' not found"; exit; } my $brew = q[perl-5.23.6]; 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 $perlbrew_path = $ENV{'PATH'}; if(my $local_lib_root = $ENV{'PERL_LOCAL_LIB_ROOT'}) { my @path = File::Spec->path; while(@path && $path[0] =~ /^$local_lib_root/) { shift @path; } if($^O eq 'MSWin32') { $perlbrew_path = join(';', @path); } else { $perlbrew_path = join(':', @path); } } my ( $env, $status ) = do { local $ENV{'PATH'} = $perlbrew_path; 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 = do { local $ENV{'PATH'} = $perlbrew_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 { open STDIN, '<', File::Spec->devnull; open STDOUT, '>', File::Spec->devnull; open STDERR, '>', File::Spec->devnull; 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; # We use system here instead of exec so that $tmpdir gets cleaned up # after cpanm finishes system 'perl', $cpanm_path, '-L', $tmpdir->dirname, '.'; exit($? >> 8); } Exception000755001750001750 013673264062 17472 5ustar00tommytommy000000000000File-Util-4.201720/lib/File/UtilStandard.pm100644001750001750 1574713673264062 21766 0ustar00tommytommy000000000000File-Util-4.201720/lib/File/Util/Exceptionuse strict; use warnings; package File::Util::Exception::Standard; $File::Util::Exception::Standard::VERSION = '4.201720'; # 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__ # CAN'T USE UTF8 WITH SYSOPEN 'bad binmode' => <<'__bad_binmode__', The use of system IO (sysread/syswrite/etc) on utf8 file handles is deprecated. Please don't specify { use_sysopen => 1 } together with { binmode => 'utf8' } __bad_binmode__ # 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.201720 =head1 DESCRIPTION Provides error messages when things go wrong. Use the C> 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 get_an_open_file_handle.pl100644001750001750 102313673264062 22271 0ustar00tommytommy000000000000File-Util-4.201720/examples# 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; pretty_print_a_directory.pl100644001750001750 371313673264062 22640 0ustar00tommytommy000000000000File-Util-4.201720/examples# 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 } } } increment_a_counter_file.pl100644001750001750 161413673264062 22531 0ustar00tommytommy000000000000File-Util-4.201720/examples# 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; batch_search_and_replace.pl100644001750001750 246713673264062 22441 0ustar00tommytommy000000000000File-Util-4.201720/examples# 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; wrap_the_lines_in_a_file.pl100644001750001750 77513673264062 22466 0ustar00tommytommy000000000000File-Util-4.201720/examples# 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; Diagnostic.pm100644001750001750 5450013673264062 22300 0ustar00tommytommy000000000000File-Util-4.201720/lib/File/Util/Exceptionuse strict; use warnings; package File::Util::Exception::Diagnostic; $File::Util::Exception::Diagnostic::VERSION = '4.201720'; # 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__ # CAN'T USE UTF8 WITH SYSOPEN 'bad binmode' => <<'__bad_binmode__', IO discipline conflict. $opts->{_pak} can't properly perform IO to this file while using the options you specified: $EBL$opts->{filename}$EBR The use of system IO (sysread/syswrite/etc) on utf8 file handles is deprecated, and causes portability/reliability problems. To learn more, you can read the notes regarding binmode in `perldoc perlport`. In short, please don't use these conflicting options together: use_sysopen => 1 binmode => 'utf8' Origin: This is a human error. Solution: A human must make a change to the code which calls $opts->{_pak}::$opts->{meth}(), so that it does not contain conflicting options. Either use binmode => 'utf8' without the use_sysopen option, or don't direct $opts->{_pak}::$opts->{meth}() to 'use_sysopen'. __bad_binmode__ # 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.201720 =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 write_or_append_to_a_file.pl100644001750001750 133213673264062 22666 0ustar00tommytommy000000000000File-Util-4.201720/examples# 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; load_a_file_into_a_variable.pl100644001750001750 106713673264062 23125 0ustar00tommytommy000000000000File-Util-4.201720/examples# 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; list_the_contents_of_a_directory.pl100644001750001750 101313673264062 24300 0ustar00tommytommy000000000000File-Util-4.201720/examples# 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; profile_listdir_vs_file-find-rule.pl100644001750001750 75613673264062 24744 0ustar00tommytommy000000000000File-Util-4.201720/performance#!/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; pretty_print_a_directory_using_as_tree.pl100644001750001750 233313673264062 25544 0ustar00tommytommy000000000000File-Util-4.201720/examples# 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 ); } list_the_contents_of_a_directory_recursively.pl100644001750001750 106013673264062 26736 0ustar00tommytommy000000000000File-Util-4.201720/examples# 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; pretty_print_a_directory_using_callbacks_fancy.pl100644001750001750 256013673264062 27223 0ustar00tommytommy000000000000File-Util-4.201720/examples# 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" ); } pretty_print_a_directory_using_callbacks_simple.pl100644001750001750 201613673264062 27410 0ustar00tommytommy000000000000File-Util-4.201720/examples# 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 } recursively_remove_a_directory_and_its_contents.pl100644001750001750 104713673264062 27442 0ustar00tommytommy000000000000File-Util-4.201720/examples# 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;