From 5f549fcb4056f8b314c7f7336a020ef9735fb384 Mon Sep 17 00:00:00 2001 From: Lorry Tar Creator Date: Mon, 15 Sep 2014 02:32:09 +0000 Subject: Path-Class-0.35 --- Build.PL | 67 ++++ Changes | 369 +++++++++++++++++++++ INSTALL | 44 +++ LICENSE | 379 ++++++++++++++++++++++ MANIFEST | 24 ++ META.yml | 39 +++ Makefile.PL | 89 +++++ README | 13 + README.pod | 165 ++++++++++ SIGNATURE | 47 +++ cpanfile | 30 ++ dist.ini | 50 +++ lib/Path/Class.pm | 198 +++++++++++ lib/Path/Class/Dir.pm | 830 +++++++++++++++++++++++++++++++++++++++++++++++ lib/Path/Class/Entity.pm | 117 +++++++ lib/Path/Class/File.pm | 539 ++++++++++++++++++++++++++++++ t/01-basic.t | 152 +++++++++ t/02-foreign.t | 73 +++++ t/03-filesystem.t | 372 +++++++++++++++++++++ t/04-subclass.t | 36 ++ t/05-traverse.t | 51 +++ t/06-traverse_filt.t | 77 +++++ t/07-recurseprune.t | 92 ++++++ t/author-critic.t | 20 ++ 24 files changed, 3873 insertions(+) create mode 100644 Build.PL create mode 100644 Changes create mode 100644 INSTALL create mode 100644 LICENSE create mode 100644 MANIFEST create mode 100644 META.yml create mode 100644 Makefile.PL create mode 100644 README create mode 100644 README.pod create mode 100644 SIGNATURE create mode 100644 cpanfile create mode 100644 dist.ini create mode 100644 lib/Path/Class.pm create mode 100644 lib/Path/Class/Dir.pm create mode 100644 lib/Path/Class/Entity.pm create mode 100644 lib/Path/Class/File.pm create mode 100644 t/01-basic.t create mode 100644 t/02-foreign.t create mode 100644 t/03-filesystem.t create mode 100644 t/04-subclass.t create mode 100644 t/05-traverse.t create mode 100644 t/06-traverse_filt.t create mode 100644 t/07-recurseprune.t create mode 100644 t/author-critic.t diff --git a/Build.PL b/Build.PL new file mode 100644 index 0000000..b4b5885 --- /dev/null +++ b/Build.PL @@ -0,0 +1,67 @@ + +use strict; +use warnings; + +use Module::Build 0.3601; + + +my %module_build_args = ( + "build_requires" => { + "Module::Build" => "0.3601" + }, + "configure_requires" => { + "ExtUtils::MakeMaker" => "6.30", + "Module::Build" => "0.3601" + }, + "dist_abstract" => "Cross-platform path specification manipulation", + "dist_author" => [ + "Ken Williams " + ], + "dist_name" => "Path-Class", + "dist_version" => "0.35", + "license" => "perl", + "module_name" => "Path::Class", + "recommends" => {}, + "recursive_test_files" => 1, + "requires" => { + "Carp" => 0, + "Cwd" => 0, + "Exporter" => 0, + "File::Copy" => 0, + "File::Path" => 0, + "File::Spec" => "3.26", + "File::Temp" => 0, + "File::stat" => 0, + "IO::Dir" => 0, + "IO::File" => 0, + "Perl::OSType" => 0, + "Scalar::Util" => 0, + "overload" => 0, + "parent" => 0, + "strict" => 0 + }, + "script_files" => [], + "test_requires" => { + "Test" => 0, + "Test::More" => 0, + "warnings" => 0 + } +); + + +my %fallback_build_requires = ( + "Module::Build" => "0.3601", + "Test" => 0, + "Test::More" => 0, + "warnings" => 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; diff --git a/Changes b/Changes new file mode 100644 index 0000000..4b05cb1 --- /dev/null +++ b/Changes @@ -0,0 +1,369 @@ +Revision history for Perl extension Path::Class. + +0.35 Sun Sep 14 21:29:07 CDT 2014 + + - fce4b8e - Fixed a t/03-filesystem.t test error on Windows + + +0.34 Thu Aug 28 22:27:03 CDT 2014 + + - df23e17 - Add a new spew_lines() method + + - 3ffef39 - Don't convert file into directory in subsumes() + + - 9a01a71 - Updated POD for copy_to and move_to methods + + - 210a7ef - Stringify destination for copy_to method + + - 9f83723 - Stringify destination for move_to method + + - 5e2cb26, d5c7e62 - Add Continuous Integration with Travis CI + + - d372be1 - Change bugtracker to github's + + +0.33 Wed Dec 11 21:30:35 CST 2013 + + - New copy_to() and move_to() methods. [Robert Rothenberg & Ken Williams] + + - As advised in the utime() docs, pass undef as the time for touch(). + + - Do a better job cleaning up temp files in the tests. + + - Optimization: use parent.pm instead of base.pm. [Olivier Mengué] + + - Changed the docs to show that file() and dir() are exported by + default. + + - Fixed spelling error in POD. [Salvatore Bonaccorso] + +0.32 Mon Mar 18 20:53:00 CDT 2013 + + - Updated dependency on File::Spec to 3.26, fixing RT #83143. + + - Fixed bug with leading empty string in dir() - became unintentional + UNC path on Cygwin. [David Golden and MITHUN@cpan.org] + + - Fixed "Unterminated C<...> sequence" in Pod. [Olaf Alders] + +0.31 Tue Feb 5 11:51:59 CST 2013 + + - Optimization: stringify variables passed to canonpath [David Golden] + + - Optimization: Use internal guts when constructing Dirs from + Dirs, instead of concatenating and splitting them again with + File::Spec. [David Golden] + + - Fix grammar error in docs. [Karen Etheridge] + + - Implement a 'split' parameter for the slurp() method [suggested by Yanick Champoux] + + - In docs, replace unicode MINUS SIGN with ascii HYPHEN-MINUS [Randy Stauner] + +0.29 Mon Dec 17 23:55:07 CST 2012 + + - Add components() method, which returns directory names (and + filename, if this is a File object) as a list. + + - Fix a test failure on non-Unix platforms, the 07-recurseprune.t + test was written in a Unix-specific way. + +0.28 Sat Dec 15 21:40:17 CST 2012 + + - Fix test failures when run as root - they were relying on + permissions failures, but permissions never fail as root. [Spotted + by AAR and Chris Williams] + + - Add links in docs to the other modules we rely on & talk about in + the docs. Makes for easier viewing through search.cpan.org / + MetaCPAN. [David Precious] + + - Fixed some misleading variable names in docs. [RT#81795] [Pau Amma] + +0.27 Sat Dec 8 19:24:15 CST 2012 + + - Added pruning support in dir->recurse(). If recurse callback + returns $item->PRUNE, no children of this item will be + analyzed. [Marcin Kasperski] + + - Documented 'basename' method for directories. [Fabrice Gabolde] + + - Added traverse_if() function, which allows one to filter children + before processing them. [Marcin Kasperski] + + - Added tempdir() function. [cho45] + +0.26 Thu Jun 14 21:52:38 CDT 2012 + + - resolve() now includes the name of the non-existent file in the error + message. [Karen Etheridge] + + - new shortcut opena(), to open a file for appending. [Karen Etheridge] + + - new spew() method that does the inverse of the slurp() method. [Aran Deltac] + + - Fixed a typo in a class name in the docs for Path::Class::Entity. [Toby Inkster] + +0.25 Wed Feb 15 20:55:30 CST 2012 + + - resolve() now croak()s instead of die()s on non-existent file. [Danijel Tašov] + + - Added a traverse() method for directories, based on the fmap_cont() + method of Forest::Tree::Pure. It's an alternative to ->recurse, + which allows for more control over how the recursion + happens. [Jesse Luehrs] + + - Fixed a grammar error in the docs. [Shlomi Fish] + + - Moved from Google Code (SVN) to GitHub (Git). + +0.24 Sat May 28 20:52:39 CDT 2011 + + - Added a tempfile() method for Dir objects, which provides an + interface to File::Temp. [RT#60485] + + - Fixed a non-helpful fatal error message when calling resolve() on a + path that doesn't exist. Now dies with the proper "No such file or + directory" message & exit status. [GRAF] + +0.23 - Sun Dec 26 13:35:53 CST 2010 + + - Fixed a bunch of problems with the distribution (e.g. in META.yml) + that I introduced in the switch to Dist::Zilla. No code changes + from 0.22. + +0.22 - Sat Dec 25 22:59:20 CST 2010 + + - Added a basename() method for directory objects. [CLKAO, jloverso, + THEPLER, ZUMMO] + +0.21 - Tue Aug 17 19:13:13 CDT 2010 + + - Don't test the 'iomode' option under 5.6, because layers aren't + supported yet. + + - Fixes to spelling errors in the docmuentatino. [Ansgar Burchardt + and Debian patchers] + +0.19 - Sun Jun 6 20:50:27 CDT 2010 + + - slurp() now accepts an 'iomode' option to control how the file is + opened. [Graham Barr] + + - In the openr() and openw() file methods, we now croak() instead of + die() so that the error messages are more useful. [Ian Sillitoe] + + - Allow subclassing, by adding dir_class() and file_class() static + methods, allowing them to be overridden. [Matt Trout & John LoVerso + & Michael Schwern] + + - Fixed a testing failure that could occur whenever testing in a + directory path that contains symlinks (e.g. /tmp on Mac OS X). + + - Added a 'no_hidden' parameter for children() [EDENC ] + + - Fixed the heading for the is_relative() POD section. [CUB ] + +0.18 - Sun Dec 20 10:11:02 CST 2009 + + - Similar to the next() bug for files/directories named "0" or "0.0" + in the previous release, the children() and recurse() methods have + now been fixed in the same way. [spotted by ARTHAS, MSISK] + +0.17 - Sun Jun 14 21:42:16 2009 + + - dir(undef) now returns undef rather than the rootdir, because undef + was probably a mistake by the caller, and the rootdir is too scary + a default. [Suggested by John Goulah] + + - Temporary files during testing are now created in the system temp + directory, rather than somewhere in t/ . See RT #31382. [Suggested + by Alex Page] + + - Added is_relative() as the obvious complement to the existing + is_absolute() method. + + - Added a resolve() method to clean up paths much more thoroughly + than cleanup(), e.g. resolving symlinks, collapsing foo/../bar + sections, etc. [Suggested by David Garamond] + + - Fixed a problem in which a file/directory called "0" or "0.0" would + end a loop prematurely when using the idiom 'while($x = + $dir->next) {...}'. See http://rt.cpan.org/Ticket/Display.html?id=29374 + [Spotted by Daniel Lo] + + - Fixed an exists($array[$i]) that prevented compatibility with perl + 5.005. + + - Moved the repository from my personal CVS repo to Google Code. + +0.16 - Sun Dec 24 20:29:40 2006 + + - Added a $dir->contains($thing) method that indicates whether $dir + actually contains $thing on the filesystem. + + - Fixed a typo in the synopsis for Path::Class::Dir - 'MacOS' should + have been 'Mac' in the example for foreign_dir(). [Chris Dolan] + + - subsumes() was not respecting the 'foreign'-ness of its arguments, + now it does. [Chia-liang Kao] + + - Added a couple of TODO tests (currently failing) for translating + MacOS paths to Unix + (http://rt.cpan.org/Ticket/Display.html?id=16613) + +0.15 Thu Dec 15 20:11:38 CST 2005 + + - Fixed an important edge case in subsumes() - subsumes('/', '/foo') + (and its equivalent on other platforms) was returning false, but + should have been true. [Reported by Chia-liang Kao] + +0.14 Thu Nov 17 22:16:13 CST 2005 + + - Silence a warning caused by $dir1->subsumes($dir2) when $dir2 + subsumes $dir1. [Chia-liang Kao] + + - Work around a File::Spec->abs2rel bug when its two arguments are + the same. It returns an empty string rather than curdir(), so in + Path::Class, dir()->absolute->relative returned '/' rather than '.' + (or their equivalent on non-unix platforms. [Spotted by David Golden] + +0.13 Mon Aug 22 22:36:15 CDT 2005 + + - Added a recurse() method to Path::Class::Dir, which provides a nice + alternative to using File::Find. + + - Added a children() method to Path::Class::Dir, which returns the + entries of a directory as Path::Class objects. + + - Added touch() to Path::Class::File. + +0.12 Tue Jun 28 16:27:38 EDT 2005 + + - You can now chomp while you slurp. [Suggested by Smylers] + + - Added some notes about how to use Path::Class in a cross-platform + way. + + - Added a remove() method for both files and directories. + + - Added a subsumes() method to Path::Class::Dir. + + - We now require File::Spec version 0.87 (previously we required + 0.86), because it fixes a few important bugs. + + - Fixed some VMS testing bugs. [Abe Timmerman] + + - Corrected a couple typos in the documentation for Path::Class::File + where it mistakenly listed the package as Path::Class::Dir. [Ron + Savage] + +0.11 Mon May 16 20:06:38 CDT 2005 + + - Fixed a documentation bug in Path::Class::File - open() calls + IO::File->new(), not IO::File->open(). [Smylers] + + - Improved the semantics for dir_list() in a scalar context. It now + has a much higher DWIM coefficient. [Suggested by Smylers] + + - Added the stat() and lstat() methods to the Path::Class::Dir class; + previously they were only in the Path::Class::File class. + [Suggested by Smylers] + + - We now require at least version 0.87 of File::Spec, rather than + 0.86, because 0.87 fixed some bugs and idiosyncracies in how Windows + path names are handled. [Chris Dolan] + +0.10 Wed Apr 6 17:04:45 CDT 2005 + + - Fixed a bug in relative() that would ignore the optional argument + if the given file/dir was already specified as relative. + + - Fixed a typo in the documentation - I wrote Path::Class::mkdir() + and Path::Class::rmtree() where I meant File::Path::mkdir() and + File::Path::rmtree(). + +0.09 Tue Apr 5 20:42:20 CDT 2005 + + - Added the dir_list() method, which gives the user direct access to + the list of directories that makes up a Path::Class::Dir object + (NEEDS DOCUMENTATION). [Suggested by Smylers] + + - Documented the behavior of $dir->next() when the directory doesn't + exist or is unreadable (it dies). [Smylers] + + - Fixed a bug that could result in extra backslashes between the + volume and path (such as C:\\Foo\Bar). [Smylers] + + - Added the is_dir() method, which is a simple way to tell the + difference between a file and a directory. [Suggested by Smylers] + +0.08 Tue Dec 28 08:26:56 CST 2004 + + - Fixed a typo in the module name in the docs. [Chris Dolan] + + - Added a copyright statement to the docs, for some reason it was + missing. [Spotted by Chris Dolan] + +0.07 Wed Jun 30 15:31:35 CDT 2004 + + - Fixed a bug in dir("foo/")->parent and + file("foo/bar")->dir. [Spotted by Sterling Hanenkamp] + +0.06 Fri Mar 26 22:20:32 CST 2004 + + - Added documentation for $dir->next(), which was for some reason + missing. + + - Simplified a little internal code in $dir->next(). + + - Added the slurp(), openr(), and openw() methods to + Path::Class::File. + +0.05 Mon Jan 19 22:36:29 CST 2004 + + - Added a parent() method to Path::Class::File, which helps in those + cases where the distinction between a file and a directory isn't + significant. [Paul Hoffman] + + - Added a basename() method to Path::Class::File. [Richard Evans] + +0.04 Thu Jan 1 22:47:18 CST 2004 + + - Added several useful methods for interacting with the filesystem, + such as $file->open(), or $dir->mkpath(). + + - file() and dir() are now exported by default when loading + Path::Class. [Michael Schwern] + + - Fixed a problem that happened when interacting with the File::Spec + that comes with perl 5.6.0. Names weren't being stringified + properly. [Michael Schwern] + + - Fixed a test failure on Win32 (from line 71 of t/01-basic.t). + [reported by Murat Ünalan] + + - Rewrote general description of Path::Class in the documentation + [suggested by Joshua Keroes] + +0.03 Wed Jul 9 09:32:52 CDT 2003 + + - D'oh! Forgot to add the t/02-foreign.t test to the MANIFEST. + + - The way I was faking out File::Spec to pretend it's on a Unix + system during testing wasn't working. [Reported by DH] + +0.02 Tue Jul 8 14:51:24 CDT 2003 + + - Added the capability to work with paths from other systems, see + 'foreign' in the docs. + + - Now depends on File::Spec::Mac 1.3, since 1.2 was pretty broken. + + - relative() and absolute() methods can now take an optional argument + to use as the base of relativity. + +0.01 Wed Mar 12 18:17:04 CST 2003 + + - original version; created by h2xs 1.21 with options + -XA -n Path::Class diff --git a/INSTALL b/INSTALL new file mode 100644 index 0000000..1f08b29 --- /dev/null +++ b/INSTALL @@ -0,0 +1,44 @@ + +This is the Perl distribution Path-Class. + +Installing Path-Class is straightforward. + +## Installation with cpanm + +If you have cpanm, you only need one line: + + % cpanm Path::Class + +If you are installing into a system-wide directory, you may need to pass the +"-S" flag to cpanm, which uses sudo to install the module: + + % cpanm -S Path::Class + +## Installing with the CPAN shell + +Alternatively, if your CPAN shell is set up, you should just be able to do: + + % cpan Path::Class + +## Manual installation + +As a last resort, you can manually install it. Download the tarball, untar it, +then build it: + + % perl Build.PL + % ./Build && ./Build test + +Then install it: + + % ./Build install + +If you are installing into a system-wide directory, you may need to run: + + % sudo ./Build install + +## Documentation + +Path-Class documentation is available as POD. +You can run perldoc from a shell to read the documentation: + + % perldoc Path::Class diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..99e37c9 --- /dev/null +++ b/LICENSE @@ -0,0 +1,379 @@ +This software is copyright (c) 2014 by Ken Williams. + +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) 2014 by Ken Williams. + +This is free software, licensed under: + + The GNU General Public License, Version 1, February 1989 + + GNU GENERAL PUBLIC LICENSE + Version 1, February 1989 + + Copyright (C) 1989 Free Software Foundation, Inc. + 51 Franklin St, Suite 500, Boston, MA 02110-1335 USA + + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The license agreements of most software companies try to keep users +at the mercy of those companies. By contrast, our General Public +License is intended to guarantee your freedom to share and change free +software--to make sure the software is free for all its users. The +General Public License applies to the Free Software Foundation's +software and to any other program whose authors commit to using it. +You can use it for your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Specifically, the General Public License is designed to make +sure that you have the freedom to give away or sell copies of free +software, that you receive source code or can get it if you want it, +that you can change the software or use pieces of it in new free +programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if you +distribute copies of the software, or if you modify it. + + For example, if you distribute copies of a such a program, whether +gratis or for a fee, you must give the recipients all the rights that +you have. You must make sure that they, too, receive or can get the +source code. And you must tell them their rights. + + We protect your rights with two steps: (1) copyright the software, and +(2) offer you this license which gives you legal permission to copy, +distribute and/or modify the software. + + Also, for each author's protection and ours, we want to make certain +that everyone understands that there is no warranty for this free +software. If the software is modified by someone else and passed on, we +want its recipients to know that what they have is not the original, so +that any problems introduced by others will not reflect on the original +authors' reputations. + + The precise terms and conditions for copying, distribution and +modification follow. + + GNU GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License Agreement applies to any program or other work which +contains a notice placed by the copyright holder saying it may be +distributed under the terms of this General Public License. The +"Program", below, refers to any such program or work, and a "work based +on the Program" means either the Program or any work containing the +Program or a portion of it, either verbatim or with modifications. Each +licensee is addressed as "you". + + 1. You may copy and distribute verbatim copies of the Program's source +code as you receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice and +disclaimer of warranty; keep intact all the notices that refer to this +General Public License and to the absence of any warranty; and give any +other recipients of the Program a copy of this General Public License +along with the Program. You may charge a fee for the physical act of +transferring a copy. + + 2. You may modify your copy or copies of the Program or any portion of +it, and copy and distribute such modifications under the terms of Paragraph +1 above, provided that you also do the following: + + a) cause the modified files to carry prominent notices stating that + you changed the files and the date of any change; and + + b) cause the whole of any work that you distribute or publish, that + in whole or in part contains the Program or any part thereof, either + with or without modifications, to be licensed at no charge to all + third parties under the terms of this General Public License (except + that you may choose to grant warranty protection to some or all + third parties, at your option). + + c) If the modified program normally reads commands interactively when + run, you must cause it, when started running for such interactive use + in the simplest and most usual way, to print or display an + announcement including an appropriate copyright notice and a notice + that there is no warranty (or else, saying that you provide a + warranty) and that users may redistribute the program under these + conditions, and telling the user how to view a copy of this General + Public License. + + d) You may charge a fee for the physical act of transferring a + copy, and you may at your option offer warranty protection in + exchange for a fee. + +Mere aggregation of another independent work with the Program (or its +derivative) on a volume of a storage or distribution medium does not bring +the other work under the scope of these terms. + + 3. You may copy and distribute the Program (or a portion or derivative of +it, under Paragraph 2) in object code or executable form under the terms of +Paragraphs 1 and 2 above provided that you also do one of the following: + + a) accompany it with the complete corresponding machine-readable + source code, which must be distributed under the terms of + Paragraphs 1 and 2 above; or, + + b) accompany it with a written offer, valid for at least three + years, to give any third party free (except for a nominal charge + for the cost of distribution) a complete machine-readable copy of the + corresponding source code, to be distributed under the terms of + Paragraphs 1 and 2 above; or, + + c) accompany it with the information you received as to where the + corresponding source code may be obtained. (This alternative is + allowed only for noncommercial distribution and only if you + received the program in object code or executable form alone.) + +Source code for a work means the preferred form of the work for making +modifications to it. For an executable file, complete source code means +all the source code for all modules it contains; but, as a special +exception, it need not include source code for modules which are standard +libraries that accompany the operating system on which the executable +file runs, or for standard header files or definitions files that +accompany that operating system. + + 4. You may not copy, modify, sublicense, distribute or transfer the +Program except as expressly provided under this General Public License. +Any attempt otherwise to copy, modify, sublicense, distribute or transfer +the Program is void, and will automatically terminate your rights to use +the Program under this License. However, parties who have received +copies, or rights to use copies, from you under this General Public +License will not have their licenses terminated so long as such parties +remain in full compliance. + + 5. By copying, distributing or modifying the Program (or any work based +on the Program) you indicate your acceptance of this license to do so, +and all its terms and conditions. + + 6. Each time you redistribute the Program (or any work based on the +Program), the recipient automatically receives a license from the original +licensor to copy, distribute or modify the Program subject to these +terms and conditions. You may not impose any further restrictions on the +recipients' exercise of the rights granted herein. + + 7. The Free Software Foundation may publish revised and/or new versions +of the General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + +Each version is given a distinguishing version number. If the Program +specifies a version number of the license which applies to it and "any +later version", you have the option of following the terms and conditions +either of that version or of any later version published by the Free +Software Foundation. If the Program does not specify a version number of +the license, you may choose any version ever published by the Free Software +Foundation. + + 8. If you wish to incorporate parts of the Program into other free +programs whose distribution conditions are different, write to the author +to ask for permission. For software which is copyrighted by the Free +Software Foundation, write to the Free Software Foundation; we sometimes +make exceptions for this. Our decision will be guided by the two goals +of preserving the free status of all derivatives of our free software and +of promoting the sharing and reuse of software generally. + + NO WARRANTY + + 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY +FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN +OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES +PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED +OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS +TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE +PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, +REPAIR OR CORRECTION. + + 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, +INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING +OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED +TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY +YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER +PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGES. + + END OF TERMS AND CONDITIONS + + Appendix: How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to humanity, the best way to achieve this is to make it +free software which everyone can redistribute and change under these +terms. + + To do so, attach the following notices to the program. It is safest to +attach them to the start of each source file to most effectively convey +the exclusion of warranty; and each file should have at least the +"copyright" line and a pointer to where the full notice is found. + + + 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) 2014 by Ken Williams. + +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 + diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..2e39095 --- /dev/null +++ b/MANIFEST @@ -0,0 +1,24 @@ +Build.PL +Changes +INSTALL +LICENSE +MANIFEST +META.yml +Makefile.PL +README +README.pod +SIGNATURE +cpanfile +dist.ini +lib/Path/Class.pm +lib/Path/Class/Dir.pm +lib/Path/Class/Entity.pm +lib/Path/Class/File.pm +t/01-basic.t +t/02-foreign.t +t/03-filesystem.t +t/04-subclass.t +t/05-traverse.t +t/06-traverse_filt.t +t/07-recurseprune.t +t/author-critic.t diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..0790c06 --- /dev/null +++ b/META.yml @@ -0,0 +1,39 @@ +--- +abstract: 'Cross-platform path specification manipulation' +author: + - 'Ken Williams ' +build_requires: + Module::Build: 0.3601 + Test: 0 + Test::More: 0 + warnings: 0 +configure_requires: + ExtUtils::MakeMaker: 6.30 + Module::Build: 0.3601 +dynamic_config: 0 +generated_by: 'Dist::Zilla version 5.006, CPAN::Meta::Converter version 2.132830' +license: perl +meta-spec: + url: http://module-build.sourceforge.net/META-spec-v1.4.html + version: 1.4 +name: Path-Class +requires: + Carp: 0 + Cwd: 0 + Exporter: 0 + File::Copy: 0 + File::Path: 0 + File::Spec: 3.26 + File::Temp: 0 + File::stat: 0 + IO::Dir: 0 + IO::File: 0 + Perl::OSType: 0 + Scalar::Util: 0 + overload: 0 + parent: 0 + strict: 0 +resources: + bugtracker: http://github.com/kenahoo/Path-Class/issues + repository: git://github.com/kenahoo/Path-Class.git +version: 0.35 diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..38f4678 --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,89 @@ + +use strict; +use warnings; + + + +use ExtUtils::MakeMaker 6.30; + + + +my %WriteMakefileArgs = ( + "ABSTRACT" => "Cross-platform path specification manipulation", + "AUTHOR" => "Ken Williams ", + "BUILD_REQUIRES" => { + "Module::Build" => "0.3601" + }, + "CONFIGURE_REQUIRES" => { + "ExtUtils::MakeMaker" => "6.30", + "Module::Build" => "0.3601" + }, + "DISTNAME" => "Path-Class", + "EXE_FILES" => [], + "LICENSE" => "perl", + "NAME" => "Path::Class", + "PREREQ_PM" => { + "Carp" => 0, + "Cwd" => 0, + "Exporter" => 0, + "File::Copy" => 0, + "File::Path" => 0, + "File::Spec" => "3.26", + "File::Temp" => 0, + "File::stat" => 0, + "IO::Dir" => 0, + "IO::File" => 0, + "Perl::OSType" => 0, + "Scalar::Util" => 0, + "overload" => 0, + "parent" => 0, + "strict" => 0 + }, + "TEST_REQUIRES" => { + "Test" => 0, + "Test::More" => 0, + "warnings" => 0 + }, + "VERSION" => "0.35", + "test" => { + "TESTS" => "t/*.t" + } +); + + +my %FallbackPrereqs = ( + "Carp" => 0, + "Cwd" => 0, + "Exporter" => 0, + "File::Copy" => 0, + "File::Path" => 0, + "File::Spec" => "3.26", + "File::Temp" => 0, + "File::stat" => 0, + "IO::Dir" => 0, + "IO::File" => 0, + "Module::Build" => "0.3601", + "Perl::OSType" => 0, + "Scalar::Util" => 0, + "Test" => 0, + "Test::More" => 0, + "overload" => 0, + "parent" => 0, + "strict" => 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); + + + diff --git a/README b/README new file mode 100644 index 0000000..0632e3d --- /dev/null +++ b/README @@ -0,0 +1,13 @@ + + +This archive contains the distribution Path-Class, +version 0.35: + + Cross-platform path specification manipulation + +This software is copyright (c) 2014 by Ken Williams. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + + diff --git a/README.pod b/README.pod new file mode 100644 index 0000000..14b839a --- /dev/null +++ b/README.pod @@ -0,0 +1,165 @@ + +=head1 NAME + +Path::Class - Cross-platform path specification manipulation for Perl + +=head1 SYNOPSIS + + use Path::Class; + + my $dir = dir('foo', 'bar'); # Path::Class::Dir object + my $file = file('bob', 'file.txt'); # Path::Class::File object + + # Stringifies to 'foo/bar' on Unix, 'foo\bar' on Windows, etc. + print "dir: $dir\n"; + + # Stringifies to 'bob/file.txt' on Unix, 'bob\file.txt' on Windows + print "file: $file\n"; + + my $subdir = $dir->subdir('baz'); # foo/bar/baz + my $parent = $subdir->parent; # foo/bar + my $parent2 = $parent->parent; # foo + + my $dir2 = $file->dir; # bob + + # Work with foreign paths + use Path::Class qw(foreign_file foreign_dir); + my $file = foreign_file('Mac', ':foo:file.txt'); + print $file->dir; # :foo: + print $file->as_foreign('Win32'); # foo\file.txt + + # Interact with the underlying filesystem: + + # $dir_handle is an IO::Dir object + my $dir_handle = $dir->open or die "Can't read $dir: $!"; + + # $file_handle is an IO::File object + my $file_handle = $file->open($mode) or die "Can't read $file: $!"; + +=head1 DESCRIPTION + +C is a module for manipulation of file and directory +specifications (strings describing their locations, like +C<'/home/ken/foo.txt'> or C<'C:\Windows\Foo.txt'>) in a cross-platform +manner. It supports pretty much every platform Perl runs on, +including Unix, Windows, Mac, VMS, Epoc, Cygwin, OS/2, and NetWare. + +The well-known module L also provides this service, but +it's sort of awkward to use well, so people sometimes avoid it, or use +it in a way that won't actually work properly on platforms +significantly different than the ones they've tested their code on. + +In fact, C uses C internally, wrapping all +the unsightly details so you can concentrate on your application code. +Whereas C provides functions for some common path +manipulations, C provides an object-oriented model of the +world of path specifications and their underlying semantics. +C doesn't create any objects, and its classes represent +the different ways in which paths must be manipulated on various +platforms (not a very intuitive concept). C creates +objects representing files and directories, and provides methods that +relate them to each other. For instance, the following C +code: + + my $absolute = File::Spec->file_name_is_absolute( + File::Spec->catfile( @dirs, $file ) + ); + +can be written using C as + + my $absolute = Path::Class::File->new( @dirs, $file )->is_absolute; + +or even as + + my $absolute = file( @dirs, $file )->is_absolute; + +Similar readability improvements should happen all over the place when +using C. + +Using C can help solve real problems in your code too - +for instance, how many people actually take the "volume" (like C +on Windows) into account when writing C-using code? I +thought not. But if you use C, your file and directory objects +will know what volumes they refer to and do the right thing. + +The guts of the C code live in the L +and L modules, so please see those +modules' documentation for more details about how to use them. + +=head2 EXPORT + +The following functions are exported by default. + +=over 4 + +=item file + +A synonym for C<< Path::Class::File->new >>. + +=item dir + +A synonym for C<< Path::Class::Dir->new >>. + +=back + +If you would like to prevent their export, you may explicitly pass an +empty list to perl's C, i.e. C. + +The following are exported only on demand. + +=over 4 + +=item foreign_file + +A synonym for C<< Path::Class::File->new_foreign >>. + +=item foreign_dir + +A synonym for C<< Path::Class::Dir->new_foreign >>. + +=item tempdir + +Create a new Path::Class::Dir instance pointed to temporary directory. + + my $temp = Path::Class::tempdir(CLEANUP => 1); + +A synonym for C<< Path::Class::Dir->new(File::Temp::tempdir(@_)) >>. + +=back + +=head1 Notes on Cross-Platform Compatibility + +Although it is much easier to write cross-platform-friendly code with +this module than with C, there are still some issues to be +aware of. + +=over 4 + +=item * + +On some platforms, notably VMS and some older versions of DOS (I think), +all filenames must have an extension. Thus if you create a file +called F and then ask for a list of files in the directory +F, you may find a file called F instead of the F you +were expecting. Thus it might be a good idea to use an extension in +the first place. + +=back + +=head1 AUTHOR + +Ken Williams, KWILLIAMS@cpan.org + +=head1 COPYRIGHT + +Copyright (c) Ken Williams. All rights reserved. + +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + + +=head1 SEE ALSO + +L, L, L + +=cut diff --git a/SIGNATURE b/SIGNATURE new file mode 100644 index 0000000..d0e8bfd --- /dev/null +++ b/SIGNATURE @@ -0,0 +1,47 @@ +This file contains message digests of all files listed in MANIFEST, +signed via the Module::Signature module, version 0.73. + +To verify the content in this distribution, first make sure you have +Module::Signature installed, then type: + + % cpansign -v + +It will check each file's integrity, as well as the signature's +validity. If "==> Signature verified OK! <==" is not displayed, +the distribution may already have been compromised, and you should +not run its Makefile.PL or Build.PL. + +-----BEGIN PGP SIGNED MESSAGE----- +Hash: SHA1 + +SHA1 251efa678f8a84675eac8d0584e757b472ed35d8 Build.PL +SHA1 5ba036a7d7e871ca8903bd8806f0c7c69b513b34 Changes +SHA1 771edd8859e502c500ae883cd9ebb7105c1b453d INSTALL +SHA1 3435fed6ff44a424d628bb95c7f69b2f536cd892 LICENSE +SHA1 78bde2759290c5e4b12079578f187a024e11dd16 MANIFEST +SHA1 aaa3716276ccd7841e2d5511aa6af878250fe4b3 META.yml +SHA1 d159030591912fb61ee6bacb857aaacc94202080 Makefile.PL +SHA1 914f9acd84676f28eabb708c68f31235675aa6e6 README +SHA1 767e92b9cc035fc40c62a7deda816efddd4c14f2 README.pod +SHA1 18788b0ba358db9fe04c981452039f3bd62bcdb2 cpanfile +SHA1 b59d7dbc33a1ea679b47ac462be15558c5b788a0 dist.ini +SHA1 e1c966a8eef1892574ca3f4e49d82bbb55ef7b1b lib/Path/Class.pm +SHA1 0a47d807085c39b384a75ac6701168bac070b051 lib/Path/Class/Dir.pm +SHA1 e3d51c703ac215b25409b75424e1e550cbabc061 lib/Path/Class/Entity.pm +SHA1 6710252344b164ad91f2834832ee5c1d2dcab5e8 lib/Path/Class/File.pm +SHA1 1984dc68cf6d60e09510af962e56f63c42c0b706 t/01-basic.t +SHA1 2dc6abce3b4c4601fe22bce9b0d58cb9484bcd0f t/02-foreign.t +SHA1 adc77bc8513166b9ee1ceca92497ec80de56670a t/03-filesystem.t +SHA1 d18a55c06da766987268ad541578a03a17ecee41 t/04-subclass.t +SHA1 a154070d2cb1369f6cebf4228742edea39c43c63 t/05-traverse.t +SHA1 c71c41e78012d9577c47aa71b6d962e2c70d0e0e t/06-traverse_filt.t +SHA1 108772f2ba8c196345adf814a39a03401031651c t/07-recurseprune.t +SHA1 fa45d6e6ab1cd421349dea4ef527bfd5cdc8a09e t/author-critic.t +-----BEGIN PGP SIGNATURE----- +Version: GnuPG v1 +Comment: GPGTools - http://gpgtools.org + +iEYEARECAAYFAlQWT6QACgkQgrvMBLfvlHYujgCfc5Uujo7Qqrkp0WF9rJJF68/D +v7IAoOVeREvngdENutm3UbM/7LsHiYPC +=ebAU +-----END PGP SIGNATURE----- diff --git a/cpanfile b/cpanfile new file mode 100644 index 0000000..ab2d6d7 --- /dev/null +++ b/cpanfile @@ -0,0 +1,30 @@ +requires "Carp" => "0"; +requires "Cwd" => "0"; +requires "Exporter" => "0"; +requires "File::Copy" => "0"; +requires "File::Path" => "0"; +requires "File::Spec" => "3.26"; +requires "File::Temp" => "0"; +requires "File::stat" => "0"; +requires "IO::Dir" => "0"; +requires "IO::File" => "0"; +requires "Perl::OSType" => "0"; +requires "Scalar::Util" => "0"; +requires "overload" => "0"; +requires "parent" => "0"; +requires "strict" => "0"; + +on 'build' => sub { + requires "Module::Build" => "0.3601"; +}; + +on 'test' => sub { + requires "Test" => "0"; + requires "Test::More" => "0"; + requires "warnings" => "0"; +}; + +on 'configure' => sub { + requires "ExtUtils::MakeMaker" => "6.30"; + requires "Module::Build" => "0.3601"; +}; diff --git a/dist.ini b/dist.ini new file mode 100644 index 0000000..a31affa --- /dev/null +++ b/dist.ini @@ -0,0 +1,50 @@ +name = Path-Class +version = 0.35 +author = Ken Williams +license = Perl_5 +copyright_holder = Ken Williams + +[GatherDir] + exclude_filename = cpanfile +[PruneCruft] +[ManifestSkip] +[MetaYAML] +[License] +[Readme] +[ExtraTests] +[ExecDir] +[ShareDir] +[MakeMaker] +[Manifest] +[TestRelease] +[ConfirmRelease] +[UploadToCPAN] + + +[PkgVersion] +[PodVersion] + +[PruneFiles] +match = ~$ +match = ^Path-Class + +[Signature] +[Bugtracker] +web = http://github.com/kenahoo/%s/issues +[Repository] +[ModuleBuild] +[InstallGuide] + +[Test::Perl::Critic] +;[PodCoverageTests] + +[AutoPrereqs] +skip = ^English$ + +[Git::Tag] + +;; TravisCI integration, see +;; http://blogs.perl.org/users/neilb/2014/08/try-travis-ci-with-your-cpan-distributions.html +[CPANFile] +[CopyFilesFromBuild] +copy = cpanfile diff --git a/lib/Path/Class.pm b/lib/Path/Class.pm new file mode 100644 index 0000000..102b765 --- /dev/null +++ b/lib/Path/Class.pm @@ -0,0 +1,198 @@ +use strict; + +package Path::Class; +{ + $Path::Class::VERSION = '0.35'; +} + +{ + ## no critic + no strict 'vars'; + @ISA = qw(Exporter); + @EXPORT = qw(file dir); + @EXPORT_OK = qw(file dir foreign_file foreign_dir tempdir); +} + +use Exporter; +use Path::Class::File; +use Path::Class::Dir; +use File::Temp (); + +sub file { Path::Class::File->new(@_) } +sub dir { Path::Class::Dir ->new(@_) } +sub foreign_file { Path::Class::File->new_foreign(@_) } +sub foreign_dir { Path::Class::Dir ->new_foreign(@_) } +sub tempdir { Path::Class::Dir->new(File::Temp::tempdir(@_)) } + + +1; +__END__ + +=head1 NAME + +Path::Class - Cross-platform path specification manipulation + +=head1 VERSION + +version 0.35 + +=head1 SYNOPSIS + + use Path::Class; + + my $dir = dir('foo', 'bar'); # Path::Class::Dir object + my $file = file('bob', 'file.txt'); # Path::Class::File object + + # Stringifies to 'foo/bar' on Unix, 'foo\bar' on Windows, etc. + print "dir: $dir\n"; + + # Stringifies to 'bob/file.txt' on Unix, 'bob\file.txt' on Windows + print "file: $file\n"; + + my $subdir = $dir->subdir('baz'); # foo/bar/baz + my $parent = $subdir->parent; # foo/bar + my $parent2 = $parent->parent; # foo + + my $dir2 = $file->dir; # bob + + # Work with foreign paths + use Path::Class qw(foreign_file foreign_dir); + my $file = foreign_file('Mac', ':foo:file.txt'); + print $file->dir; # :foo: + print $file->as_foreign('Win32'); # foo\file.txt + + # Interact with the underlying filesystem: + + # $dir_handle is an IO::Dir object + my $dir_handle = $dir->open or die "Can't read $dir: $!"; + + # $file_handle is an IO::File object + my $file_handle = $file->open($mode) or die "Can't read $file: $!"; + +=head1 DESCRIPTION + +C is a module for manipulation of file and directory +specifications (strings describing their locations, like +C<'/home/ken/foo.txt'> or C<'C:\Windows\Foo.txt'>) in a cross-platform +manner. It supports pretty much every platform Perl runs on, +including Unix, Windows, Mac, VMS, Epoc, Cygwin, OS/2, and NetWare. + +The well-known module L also provides this service, but +it's sort of awkward to use well, so people sometimes avoid it, or use +it in a way that won't actually work properly on platforms +significantly different than the ones they've tested their code on. + +In fact, C uses C internally, wrapping all +the unsightly details so you can concentrate on your application code. +Whereas C provides functions for some common path +manipulations, C provides an object-oriented model of the +world of path specifications and their underlying semantics. +C doesn't create any objects, and its classes represent +the different ways in which paths must be manipulated on various +platforms (not a very intuitive concept). C creates +objects representing files and directories, and provides methods that +relate them to each other. For instance, the following C +code: + + my $absolute = File::Spec->file_name_is_absolute( + File::Spec->catfile( @dirs, $file ) + ); + +can be written using C as + + my $absolute = Path::Class::File->new( @dirs, $file )->is_absolute; + +or even as + + my $absolute = file( @dirs, $file )->is_absolute; + +Similar readability improvements should happen all over the place when +using C. + +Using C can help solve real problems in your code too - +for instance, how many people actually take the "volume" (like C +on Windows) into account when writing C-using code? I +thought not. But if you use C, your file and directory objects +will know what volumes they refer to and do the right thing. + +The guts of the C code live in the L +and L modules, so please see those +modules' documentation for more details about how to use them. + +=head2 EXPORT + +The following functions are exported by default. + +=over 4 + +=item file + +A synonym for C<< Path::Class::File->new >>. + +=item dir + +A synonym for C<< Path::Class::Dir->new >>. + +=back + +If you would like to prevent their export, you may explicitly pass an +empty list to perl's C, i.e. C. + +The following are exported only on demand. + +=over 4 + +=item foreign_file + +A synonym for C<< Path::Class::File->new_foreign >>. + +=item foreign_dir + +A synonym for C<< Path::Class::Dir->new_foreign >>. + +=item tempdir + +Create a new Path::Class::Dir instance pointed to temporary directory. + + my $temp = Path::Class::tempdir(CLEANUP => 1); + +A synonym for C<< Path::Class::Dir->new(File::Temp::tempdir(@_)) >>. + +=back + +=head1 Notes on Cross-Platform Compatibility + +Although it is much easier to write cross-platform-friendly code with +this module than with C, there are still some issues to be +aware of. + +=over 4 + +=item * + +On some platforms, notably VMS and some older versions of DOS (I think), +all filenames must have an extension. Thus if you create a file +called F and then ask for a list of files in the directory +F, you may find a file called F instead of the F you +were expecting. Thus it might be a good idea to use an extension in +the first place. + +=back + +=head1 AUTHOR + +Ken Williams, KWILLIAMS@cpan.org + +=head1 COPYRIGHT + +Copyright (c) Ken Williams. All rights reserved. + +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + + +=head1 SEE ALSO + +L, L, L + +=cut diff --git a/lib/Path/Class/Dir.pm b/lib/Path/Class/Dir.pm new file mode 100644 index 0000000..2a2ddaf --- /dev/null +++ b/lib/Path/Class/Dir.pm @@ -0,0 +1,830 @@ +use strict; + +package Path::Class::Dir; +{ + $Path::Class::Dir::VERSION = '0.35'; +} + +use Path::Class::File; +use Carp(); +use parent qw(Path::Class::Entity); + +use IO::Dir (); +use File::Path (); +use File::Temp (); +use Scalar::Util (); + +# updir & curdir on the local machine, for screening them out in +# children(). Note that they don't respect 'foreign' semantics. +my $Updir = __PACKAGE__->_spec->updir; +my $Curdir = __PACKAGE__->_spec->curdir; + +sub new { + my $self = shift->SUPER::new(); + + # If the only arg is undef, it's probably a mistake. Without this + # special case here, we'd return the root directory, which is a + # lousy thing to do to someone when they made a mistake. Return + # undef instead. + return if @_==1 && !defined($_[0]); + + my $s = $self->_spec; + + my $first = (@_ == 0 ? $s->curdir : + $_[0] eq '' ? (shift, $s->rootdir) : + shift() + ); + + $self->{dirs} = []; + if ( Scalar::Util::blessed($first) && $first->isa("Path::Class::Dir") ) { + $self->{volume} = $first->{volume}; + push @{$self->{dirs}}, @{$first->{dirs}}; + } + else { + ($self->{volume}, my $dirs) = $s->splitpath( $s->canonpath("$first") , 1); + push @{$self->{dirs}}, $dirs eq $s->rootdir ? "" : $s->splitdir($dirs); + } + + push @{$self->{dirs}}, map { + Scalar::Util::blessed($_) && $_->isa("Path::Class::Dir") + ? @{$_->{dirs}} + : $s->splitdir($_) + } @_; + + + return $self; +} + +sub file_class { "Path::Class::File" } + +sub is_dir { 1 } + +sub as_foreign { + my ($self, $type) = @_; + + my $foreign = do { + local $self->{file_spec_class} = $self->_spec_class($type); + $self->SUPER::new; + }; + + # Clone internal structure + $foreign->{volume} = $self->{volume}; + my ($u, $fu) = ($self->_spec->updir, $foreign->_spec->updir); + $foreign->{dirs} = [ map {$_ eq $u ? $fu : $_} @{$self->{dirs}}]; + return $foreign; +} + +sub stringify { + my $self = shift; + my $s = $self->_spec; + return $s->catpath($self->{volume}, + $s->catdir(@{$self->{dirs}}), + ''); +} + +sub volume { shift()->{volume} } + +sub file { + local $Path::Class::Foreign = $_[0]->{file_spec_class} if $_[0]->{file_spec_class}; + return $_[0]->file_class->new(@_); +} + +sub basename { shift()->{dirs}[-1] } + +sub dir_list { + my $self = shift; + my $d = $self->{dirs}; + return @$d unless @_; + + my $offset = shift; + if ($offset < 0) { $offset = $#$d + $offset + 1 } + + return wantarray ? @$d[$offset .. $#$d] : $d->[$offset] unless @_; + + my $length = shift; + if ($length < 0) { $length = $#$d + $length + 1 - $offset } + return @$d[$offset .. $length + $offset - 1]; +} + +sub components { + my $self = shift; + return $self->dir_list(@_); +} + +sub subdir { + my $self = shift; + return $self->new($self, @_); +} + +sub parent { + my $self = shift; + my $dirs = $self->{dirs}; + my ($curdir, $updir) = ($self->_spec->curdir, $self->_spec->updir); + + if ($self->is_absolute) { + my $parent = $self->new($self); + pop @{$parent->{dirs}} if @$dirs > 1; + return $parent; + + } elsif ($self eq $curdir) { + return $self->new($updir); + + } elsif (!grep {$_ ne $updir} @$dirs) { # All updirs + return $self->new($self, $updir); # Add one more + + } elsif (@$dirs == 1) { + return $self->new($curdir); + + } else { + my $parent = $self->new($self); + pop @{$parent->{dirs}}; + return $parent; + } +} + +sub relative { + # File::Spec->abs2rel before version 3.13 returned the empty string + # when the two paths were equal - work around it here. + my $self = shift; + my $rel = $self->_spec->abs2rel($self->stringify, @_); + return $self->new( length $rel ? $rel : $self->_spec->curdir ); +} + +sub open { IO::Dir->new(@_) } +sub mkpath { File::Path::mkpath(shift()->stringify, @_) } +sub rmtree { File::Path::rmtree(shift()->stringify, @_) } + +sub remove { + rmdir( shift() ); +} + +sub traverse { + my $self = shift; + my ($callback, @args) = @_; + my @children = $self->children; + return $self->$callback( + sub { + my @inner_args = @_; + return map { $_->traverse($callback, @inner_args) } @children; + }, + @args + ); +} + +sub traverse_if { + my $self = shift; + my ($callback, $condition, @args) = @_; + my @children = grep { $condition->($_) } $self->children; + return $self->$callback( + sub { + my @inner_args = @_; + return map { $_->traverse_if($callback, $condition, @inner_args) } @children; + }, + @args + ); +} + +sub recurse { + my $self = shift; + my %opts = (preorder => 1, depthfirst => 0, @_); + + my $callback = $opts{callback} + or Carp::croak( "Must provide a 'callback' parameter to recurse()" ); + + my @queue = ($self); + + my $visit_entry; + my $visit_dir = + $opts{depthfirst} && $opts{preorder} + ? sub { + my $dir = shift; + my $ret = $callback->($dir); + unless( ($ret||'') eq $self->PRUNE ) { + unshift @queue, $dir->children; + } + } + : $opts{preorder} + ? sub { + my $dir = shift; + my $ret = $callback->($dir); + unless( ($ret||'') eq $self->PRUNE ) { + push @queue, $dir->children; + } + } + : sub { + my $dir = shift; + $visit_entry->($_) foreach $dir->children; + $callback->($dir); + }; + + $visit_entry = sub { + my $entry = shift; + if ($entry->is_dir) { $visit_dir->($entry) } # Will call $callback + else { $callback->($entry) } + }; + + while (@queue) { + $visit_entry->( shift @queue ); + } +} + +sub children { + my ($self, %opts) = @_; + + my $dh = $self->open or Carp::croak( "Can't open directory $self: $!" ); + + my @out; + while (defined(my $entry = $dh->read)) { + next if !$opts{all} && $self->_is_local_dot_dir($entry); + next if ($opts{no_hidden} && $entry =~ /^\./); + push @out, $self->file($entry); + $out[-1] = $self->subdir($entry) if -d $out[-1]; + } + return @out; +} + +sub _is_local_dot_dir { + my $self = shift; + my $dir = shift; + + return ($dir eq $Updir or $dir eq $Curdir); +} + +sub next { + my $self = shift; + unless ($self->{dh}) { + $self->{dh} = $self->open or Carp::croak( "Can't open directory $self: $!" ); + } + + my $next = $self->{dh}->read; + unless (defined $next) { + delete $self->{dh}; + ## no critic + return undef; + } + + # Figure out whether it's a file or directory + my $file = $self->file($next); + $file = $self->subdir($next) if -d $file; + return $file; +} + +sub subsumes { + my ($self, $other) = @_; + die "No second entity given to subsumes()" unless $other; + + $other = $self->new($other) unless UNIVERSAL::isa($other, "Path::Class::Entity"); + $other = $other->dir unless $other->is_dir; + + if ($self->is_absolute) { + $other = $other->absolute; + } elsif ($other->is_absolute) { + $self = $self->absolute; + } + + $self = $self->cleanup; + $other = $other->cleanup; + + if ($self->volume) { + return 0 unless $other->volume eq $self->volume; + } + + # The root dir subsumes everything (but ignore the volume because + # we've already checked that) + return 1 if "@{$self->{dirs}}" eq "@{$self->new('')->{dirs}}"; + + my $i = 0; + while ($i <= $#{ $self->{dirs} }) { + return 0 if $i > $#{ $other->{dirs} }; + return 0 if $self->{dirs}[$i] ne $other->{dirs}[$i]; + $i++; + } + return 1; +} + +sub contains { + my ($self, $other) = @_; + return !!(-d $self and (-e $other or -l $other) and $self->subsumes($other)); +} + +sub tempfile { + my $self = shift; + return File::Temp::tempfile(@_, DIR => $self->stringify); +} + +1; +__END__ + +=head1 NAME + +Path::Class::Dir - Objects representing directories + +=head1 VERSION + +version 0.35 + +=head1 SYNOPSIS + + use Path::Class; # Exports dir() by default + + my $dir = dir('foo', 'bar'); # Path::Class::Dir object + my $dir = Path::Class::Dir->new('foo', 'bar'); # Same thing + + # Stringifies to 'foo/bar' on Unix, 'foo\bar' on Windows, etc. + print "dir: $dir\n"; + + if ($dir->is_absolute) { ... } + if ($dir->is_relative) { ... } + + my $v = $dir->volume; # Could be 'C:' on Windows, empty string + # on Unix, 'Macintosh HD:' on Mac OS + + $dir->cleanup; # Perform logical cleanup of pathname + $dir->resolve; # Perform physical cleanup of pathname + + my $file = $dir->file('file.txt'); # A file in this directory + my $subdir = $dir->subdir('george'); # A subdirectory + my $parent = $dir->parent; # The parent directory, 'foo' + + my $abs = $dir->absolute; # Transform to absolute path + my $rel = $abs->relative; # Transform to relative path + my $rel = $abs->relative('/foo'); # Relative to /foo + + print $dir->as_foreign('Mac'); # :foo:bar: + print $dir->as_foreign('Win32'); # foo\bar + + # Iterate with IO::Dir methods: + my $handle = $dir->open; + while (my $file = $handle->read) { + $file = $dir->file($file); # Turn into Path::Class::File object + ... + } + + # Iterate with Path::Class methods: + while (my $file = $dir->next) { + # $file is a Path::Class::File or Path::Class::Dir object + ... + } + + +=head1 DESCRIPTION + +The C class contains functionality for manipulating +directory names in a cross-platform way. + +=head1 METHODS + +=over 4 + +=item $dir = Path::Class::Dir->new( , , ... ) + +=item $dir = dir( , , ... ) + +Creates a new C object and returns it. The +arguments specify names of directories which will be joined to create +a single directory object. A volume may also be specified as the +first argument, or as part of the first argument. You can use +platform-neutral syntax: + + my $dir = dir( 'foo', 'bar', 'baz' ); + +or platform-native syntax: + + my $dir = dir( 'foo/bar/baz' ); + +or a mixture of the two: + + my $dir = dir( 'foo/bar', 'baz' ); + +All three of the above examples create relative paths. To create an +absolute path, either use the platform native syntax for doing so: + + my $dir = dir( '/var/tmp' ); + +or use an empty string as the first argument: + + my $dir = dir( '', 'var', 'tmp' ); + +If the second form seems awkward, that's somewhat intentional - paths +like C or C<\Windows> aren't cross-platform concepts in the +first place (many non-Unix platforms don't have a notion of a "root +directory"), so they probably shouldn't appear in your code if you're +trying to be cross-platform. The first form is perfectly natural, +because paths like this may come from config files, user input, or +whatever. + +As a special case, since it doesn't otherwise mean anything useful and +it's convenient to define this way, C<< Path::Class::Dir->new() >> (or +C) refers to the current directory (C<< File::Spec->curdir >>). +To get the current directory as an absolute path, do C<< +dir()->absolute >>. + +Finally, as another special case C will return undef, +since that's usually an accident on the part of the caller, and +returning the root directory would be a nasty surprise just asking for +trouble a few lines later. + +=item $dir->stringify + +This method is called internally when a C object is +used in a string context, so the following are equivalent: + + $string = $dir->stringify; + $string = "$dir"; + +=item $dir->volume + +Returns the volume (e.g. C on Windows, C on Mac OS, +etc.) of the directory object, if any. Otherwise, returns the empty +string. + +=item $dir->basename + +Returns the last directory name of the path as a string. + +=item $dir->is_dir + +Returns a boolean value indicating whether this object represents a +directory. Not surprisingly, L objects always +return false, and C objects always return true. + +=item $dir->is_absolute + +Returns true or false depending on whether the directory refers to an +absolute path specifier (like C or C<\Windows>). + +=item $dir->is_relative + +Returns true or false depending on whether the directory refers to a +relative path specifier (like C or C<./dir>). + +=item $dir->cleanup + +Performs a logical cleanup of the file path. For instance: + + my $dir = dir('/foo//baz/./foo')->cleanup; + # $dir now represents '/foo/baz/foo'; + +=item $dir->resolve + +Performs a physical cleanup of the file path. For instance: + + my $dir = dir('/foo//baz/../foo')->resolve; + # $dir now represents '/foo/foo', assuming no symlinks + +This actually consults the filesystem to verify the validity of the +path. + +=item $file = $dir->file( , , ..., ) + +Returns a L object representing an entry in C<$dir> +or one of its subdirectories. Internally, this just calls C<< +Path::Class::File->new( @_ ) >>. + +=item $subdir = $dir->subdir( , , ... ) + +Returns a new C object representing a subdirectory +of C<$dir>. + +=item $parent = $dir->parent + +Returns the parent directory of C<$dir>. Note that this is the +I parent, not necessarily the physical parent. It really +means we just chop off entries from the end of the directory list +until we cain't chop no more. If the directory is relative, we start +using the relative forms of parent directories. + +The following code demonstrates the behavior on absolute and relative +directories: + + $dir = dir('/foo/bar'); + for (1..6) { + print "Absolute: $dir\n"; + $dir = $dir->parent; + } + + $dir = dir('foo/bar'); + for (1..6) { + print "Relative: $dir\n"; + $dir = $dir->parent; + } + + ########### Output on Unix ################ + Absolute: /foo/bar + Absolute: /foo + Absolute: / + Absolute: / + Absolute: / + Absolute: / + Relative: foo/bar + Relative: foo + Relative: . + Relative: .. + Relative: ../.. + Relative: ../../.. + +=item @list = $dir->children + +Returns a list of L and/or C +objects listed in this directory, or in scalar context the number of +such objects. Obviously, it is necessary for C<$dir> to +exist and be readable in order to find its children. + +Note that the children are returned as subdirectories of C<$dir>, +i.e. the children of F will be F and F, not +F and F. + +Ordinarily C will not include the I and I +entries C<.> and C<..> (or their equivalents on non-Unix systems), +because that's like I'm-my-own-grandpa business. If you do want all +directory entries including these special ones, pass a true value for +the C parameter: + + @c = $dir->children(); # Just the children + @c = $dir->children(all => 1); # All entries + +In addition, there's a C parameter that will exclude all +normally "hidden" entries - on Unix this means excluding all entries +that begin with a dot (C<.>): + + @c = $dir->children(no_hidden => 1); # Just normally-visible entries + + +=item $abs = $dir->absolute + +Returns a C object representing C<$dir> as an +absolute path. An optional argument, given as either a string or a +C object, specifies the directory to use as the base +of relativity - otherwise the current working directory will be used. + +=item $rel = $dir->relative + +Returns a C object representing C<$dir> as a +relative path. An optional argument, given as either a string or a +C object, specifies the directory to use as the base +of relativity - otherwise the current working directory will be used. + +=item $boolean = $dir->subsumes($other) + +Returns true if this directory spec subsumes the other spec, and false +otherwise. Think of "subsumes" as "contains", but we only look at the +I, not whether C<$dir> actually contains C<$other> on the +filesystem. + +The C<$other> argument may be a C object, a +L object, or a string. In the latter case, we +assume it's a directory. + + # Examples: + dir('foo/bar' )->subsumes(dir('foo/bar/baz')) # True + dir('/foo/bar')->subsumes(dir('/foo/bar/baz')) # True + dir('foo/bar' )->subsumes(dir('bar/baz')) # False + dir('/foo/bar')->subsumes(dir('foo/bar')) # False + + +=item $boolean = $dir->contains($other) + +Returns true if this directory actually contains C<$other> on the +filesystem. C<$other> doesn't have to be a direct child of C<$dir>, +it just has to be subsumed. + +=item $foreign = $dir->as_foreign($type) + +Returns a C object representing C<$dir> as it would +be specified on a system of type C<$type>. Known types include +C, C, C, C, and C, i.e. anything for which +there is a subclass of C. + +Any generated objects (subdirectories, files, parents, etc.) will also +retain this type. + +=item $foreign = Path::Class::Dir->new_foreign($type, @args) + +Returns a C object representing C<$dir> as it would +be specified on a system of type C<$type>. Known types include +C, C, C, C, and C, i.e. anything for which +there is a subclass of C. + +The arguments in C<@args> are the same as they would be specified in +C. + +=item @list = $dir->dir_list([OFFSET, [LENGTH]]) + +Returns the list of strings internally representing this directory +structure. Each successive member of the list is understood to be an +entry in its predecessor's directory list. By contract, C<< +Path::Class->new( $dir->dir_list ) >> should be equivalent to C<$dir>. + +The semantics of this method are similar to Perl's C or +C functions; they return C elements starting at +C. If C is omitted, returns all the elements starting +at C up to the end of the list. If C is negative, +returns the elements from C onward except for C<-LENGTH> +elements at the end. If C is negative, it counts backward +C elements from the end of the list. If C and +C are both omitted, the entire list is returned. + +In a scalar context, C with no arguments returns the +number of entries in the directory list; C returns +the single element at that offset; C returns +the final element that would have been returned in a list context. + +=item $dir->components + +Identical to c. It exists because there's an analogous +method C in the C class that also +returns the basename string, so this method lets someone call +C without caring whether the object is a file or a +directory. + +=item $fh = $dir->open() + +Passes C<$dir> to C<< IO::Dir->open >> and returns the result as an +L object. If the opening fails, C is returned and +C<$!> is set. + +=item $dir->mkpath($verbose, $mode) + +Passes all arguments, including C<$dir>, to C<< File::Path::mkpath() +>> and returns the result (a list of all directories created). + +=item $dir->rmtree($verbose, $cautious) + +Passes all arguments, including C<$dir>, to C<< File::Path::rmtree() +>> and returns the result (the number of files successfully deleted). + +=item $dir->remove() + +Removes the directory, which must be empty. Returns a boolean value +indicating whether or not the directory was successfully removed. +This method is mainly provided for consistency with +C's C method. + +=item $dir->tempfile(...) + +An interface to L's C function. Just like +that function, if you call this in a scalar context, the return value +is the filehandle and the file is Ced as soon as possible +(which is immediately on Unix-like platforms). If called in a list +context, the return values are the filehandle and the filename. + +The given directory is passed as the C parameter. + +Here's an example of pretty good usage which doesn't allow race +conditions, won't leave yucky tempfiles around on your filesystem, +etc.: + + my $fh = $dir->tempfile; + print $fh "Here's some data...\n"; + seek($fh, 0, 0); + while (<$fh>) { do something... } + +Or in combination with a C: + + my $fh = $dir->tempfile; + print $fh "Here's some more data...\n"; + seek($fh, 0, 0); + if ($pid=fork()) { + wait; + } else { + something($_) while <$fh>; + } + + +=item $dir_or_file = $dir->next() + +A convenient way to iterate through directory contents. The first +time C is called, it will C the directory and read the +first item from it, returning the result as a C or +L object (depending, of course, on its actual +type). Each subsequent call to C will simply iterate over the +directory's contents, until there are no more items in the directory, +and then the undefined value is returned. For example, to iterate +over all the regular files in a directory: + + while (my $file = $dir->next) { + next unless -f $file; + my $fh = $file->open('r') or die "Can't read $file: $!"; + ... + } + +If an error occurs when opening the directory (for instance, it +doesn't exist or isn't readable), C will throw an exception +with the value of C<$!>. + +=item $dir->traverse( sub { ... }, @args ) + +Calls the given callback for the root, passing it a continuation +function which, when called, will call this recursively on each of its +children. The callback function should be of the form: + + sub { + my ($child, $cont, @args) = @_; + # ... + } + +For instance, to calculate the number of files in a directory, you +can do this: + + my $nfiles = $dir->traverse(sub { + my ($child, $cont) = @_; + return sum($cont->(), ($child->is_dir ? 0 : 1)); + }); + +or to calculate the maximum depth of a directory: + + my $depth = $dir->traverse(sub { + my ($child, $cont, $depth) = @_; + return max($cont->($depth + 1), $depth); + }, 0); + +You can also choose not to call the callback in certain situations: + + $dir->traverse(sub { + my ($child, $cont) = @_; + return if -l $child; # don't follow symlinks + # do something with $child + return $cont->(); + }); + +=item $dir->traverse_if( sub { ... }, sub { ... }, @args ) + +traverse with additional "should I visit this child" callback. +Particularly useful in case examined tree contains inaccessible +directories. + +Canonical example: + + $dir->traverse_if( + sub { + my ($child, $cont) = @_; + # do something with $child + return $cont->(); + }, + sub { + my ($child) = @_; + # Process only readable items + return -r $child; + }); + +Second callback gets single parameter: child. Only children for +which it returns true will be processed by the first callback. + +Remaining parameters are interpreted as in traverse, in particular +C is equivalent to +C. + +=item $dir->recurse( callback => sub {...} ) + +Iterates through this directory and all of its children, and all of +its children's children, etc., calling the C subroutine for +each entry. This is a lot like what the L module does, +and of course C will work fine on L objects, +but the advantage of the C method is that it will also feed +your callback routine C objects rather than just pathname +strings. + +The C method requires a C parameter specifying +the subroutine to invoke for each entry. It will be passed the +C object as its first argument. + +C also accepts two boolean parameters, C and +C that control the order of recursion. The default is a +preorder, breadth-first search, i.e. C<< depthfirst => 0, preorder => 1 >>. +At the time of this writing, all combinations of these two parameters +are supported I C<< depthfirst => 0, preorder => 0 >>. + +C is normally not required to return any value. If it +returns special constant C (more easily +available as C<$item->PRUNE>), no children of analyzed +item will be analyzed (mostly as if you set C<$File::Find::prune=1>). Of course +pruning is available only in C, in postorder return value +has no effect. + +=item $st = $file->stat() + +Invokes C<< File::stat::stat() >> on this directory and returns a +C object representing the result. + +=item $st = $file->lstat() + +Same as C, but if C<$file> is a symbolic link, C +stats the link instead of the directory the link points to. + +=item $class = $file->file_class() + +Returns the class which should be used to create file objects. + +Generally overridden whenever this class is subclassed. + +=back + +=head1 AUTHOR + +Ken Williams, kwilliams@cpan.org + +=head1 SEE ALSO + +L, L, L + +=cut diff --git a/lib/Path/Class/Entity.pm b/lib/Path/Class/Entity.pm new file mode 100644 index 0000000..0f9fae2 --- /dev/null +++ b/lib/Path/Class/Entity.pm @@ -0,0 +1,117 @@ +use strict; + +package Path::Class::Entity; +{ + $Path::Class::Entity::VERSION = '0.35'; +} + +use File::Spec 3.26; +use File::stat (); +use Cwd; +use Carp(); + +use overload + ( + q[""] => 'stringify', + 'bool' => 'boolify', + fallback => 1, + ); + +sub new { + my $from = shift; + my ($class, $fs_class) = (ref($from) + ? (ref $from, $from->{file_spec_class}) + : ($from, $Path::Class::Foreign)); + return bless {file_spec_class => $fs_class}, $class; +} + +sub is_dir { 0 } + +sub _spec_class { + my ($class, $type) = @_; + + die "Invalid system type '$type'" unless ($type) = $type =~ /^(\w+)$/; # Untaint + my $spec = "File::Spec::$type"; + ## no critic + eval "require $spec; 1" or die $@; + return $spec; +} + +sub new_foreign { + my ($class, $type) = (shift, shift); + local $Path::Class::Foreign = $class->_spec_class($type); + return $class->new(@_); +} + +sub _spec { (ref($_[0]) && $_[0]->{file_spec_class}) || 'File::Spec' } + +sub boolify { 1 } + +sub is_absolute { + # 5.6.0 has a bug with regexes and stringification that's ticked by + # file_name_is_absolute(). Help it along with an explicit stringify(). + $_[0]->_spec->file_name_is_absolute($_[0]->stringify) +} + +sub is_relative { ! $_[0]->is_absolute } + +sub cleanup { + my $self = shift; + my $cleaned = $self->new( $self->_spec->canonpath("$self") ); + %$self = %$cleaned; + return $self; +} + +sub resolve { + my $self = shift; + Carp::croak($! . " $self") unless -e $self; # No such file or directory + my $cleaned = $self->new( scalar Cwd::realpath($self->stringify) ); + + # realpath() always returns absolute path, kind of annoying + $cleaned = $cleaned->relative if $self->is_relative; + + %$self = %$cleaned; + return $self; +} + +sub absolute { + my $self = shift; + return $self if $self->is_absolute; + return $self->new($self->_spec->rel2abs($self->stringify, @_)); +} + +sub relative { + my $self = shift; + return $self->new($self->_spec->abs2rel($self->stringify, @_)); +} + +sub stat { File::stat::stat("$_[0]") } +sub lstat { File::stat::lstat("$_[0]") } + +sub PRUNE { return \&PRUNE; } + +1; +__END__ + +=head1 NAME + +Path::Class::Entity - Base class for files and directories + +=head1 VERSION + +version 0.35 + +=head1 DESCRIPTION + +This class is the base class for C and +C, it is not used directly by callers. + +=head1 AUTHOR + +Ken Williams, kwilliams@cpan.org + +=head1 SEE ALSO + +Path::Class + +=cut diff --git a/lib/Path/Class/File.pm b/lib/Path/Class/File.pm new file mode 100644 index 0000000..c0eb684 --- /dev/null +++ b/lib/Path/Class/File.pm @@ -0,0 +1,539 @@ +use strict; + +package Path::Class::File; +{ + $Path::Class::File::VERSION = '0.35'; +} + +use Path::Class::Dir; +use parent qw(Path::Class::Entity); +use Carp; + +use IO::File (); +use Perl::OSType (); +use File::Copy (); + +sub new { + my $self = shift->SUPER::new; + my $file = pop(); + my @dirs = @_; + + my ($volume, $dirs, $base) = $self->_spec->splitpath($file); + + if (length $dirs) { + push @dirs, $self->_spec->catpath($volume, $dirs, ''); + } + + $self->{dir} = @dirs ? $self->dir_class->new(@dirs) : undef; + $self->{file} = $base; + + return $self; +} + +sub dir_class { "Path::Class::Dir" } + +sub as_foreign { + my ($self, $type) = @_; + local $Path::Class::Foreign = $self->_spec_class($type); + my $foreign = ref($self)->SUPER::new; + $foreign->{dir} = $self->{dir}->as_foreign($type) if defined $self->{dir}; + $foreign->{file} = $self->{file}; + return $foreign; +} + +sub stringify { + my $self = shift; + return $self->{file} unless defined $self->{dir}; + return $self->_spec->catfile($self->{dir}->stringify, $self->{file}); +} + +sub dir { + my $self = shift; + return $self->{dir} if defined $self->{dir}; + return $self->dir_class->new($self->_spec->curdir); +} +BEGIN { *parent = \&dir; } + +sub volume { + my $self = shift; + return '' unless defined $self->{dir}; + return $self->{dir}->volume; +} + +sub components { + my $self = shift; + die "Arguments are not currently supported by File->components()" if @_; + return ($self->dir->components, $self->basename); +} + +sub basename { shift->{file} } +sub open { IO::File->new(@_) } + +sub openr { $_[0]->open('r') or croak "Can't read $_[0]: $!" } +sub openw { $_[0]->open('w') or croak "Can't write to $_[0]: $!" } +sub opena { $_[0]->open('a') or croak "Can't append to $_[0]: $!" } + +sub touch { + my $self = shift; + if (-e $self) { + utime undef, undef, $self; + } else { + $self->openw; + } +} + +sub slurp { + my ($self, %args) = @_; + my $iomode = $args{iomode} || 'r'; + my $fh = $self->open($iomode) or croak "Can't read $self: $!"; + + if (wantarray) { + my @data = <$fh>; + chomp @data if $args{chomped} or $args{chomp}; + + if ( my $splitter = $args{split} ) { + @data = map { [ split $splitter, $_ ] } @data; + } + + return @data; + } + + + croak "'split' argument can only be used in list context" + if $args{split}; + + + if ($args{chomped} or $args{chomp}) { + chomp( my @data = <$fh> ); + return join '', @data; + } + + + local $/; + return <$fh>; +} + +sub spew { + my $self = shift; + my %args = splice( @_, 0, @_-1 ); + + my $iomode = $args{iomode} || 'w'; + my $fh = $self->open( $iomode ) or croak "Can't write to $self: $!"; + + if (ref($_[0]) eq 'ARRAY') { + # Use old-school for loop to avoid copying. + for (my $i = 0; $i < @{ $_[0] }; $i++) { + print $fh $_[0]->[$i]; + } + } + else { + print $fh $_[0]; + } + + return; +} + +sub spew_lines { + my $self = shift; + my %args = splice( @_, 0, @_-1 ); + + my $content = $_[0]; + + # If content is an array ref, appends $/ to each element of the array. + # Otherwise, if it is a simple scalar, just appends $/ to that scalar. + + $content + = ref( $content ) eq 'ARRAY' + ? [ map { $_, $/ } @$content ] + : "$content$/"; + + return $self->spew( %args, $content ); +} + +sub remove { + my $file = shift->stringify; + return unlink $file unless -e $file; # Sets $! correctly + 1 while unlink $file; + return not -e $file; +} + +sub copy_to { + my ($self, $dest) = @_; + if ( UNIVERSAL::isa($dest, Path::Class::File::) ) { + $dest = $dest->stringify; + die "Can't copy to file $dest: it is a directory" if -d $dest; + } elsif ( UNIVERSAL::isa($dest, Path::Class::Dir::) ) { + $dest = $dest->stringify; + die "Can't copy to directory $dest: it is a file" if -f $dest; + die "Can't copy to directory $dest: no such directory" unless -d $dest; + } elsif ( ref $dest ) { + die "Don't know how to copy files to objects of type '".ref($self)."'"; + } + + if ( !Perl::OSType::is_os_type('Unix') ) { + + return unless File::Copy::cp($self->stringify, "${dest}"); + + } else { + + return unless (system('cp', $self->stringify, "${dest}") == 0); + + } + + return $self->new($dest); +} + +sub move_to { + my ($self, $dest) = @_; + if (File::Copy::move($self->stringify, "${dest}")) { + + my $new = $self->new($dest); + + $self->{$_} = $new->{$_} foreach (qw/ dir file /); + + return $self; + + } else { + + return; + + } +} + +sub traverse { + my $self = shift; + my ($callback, @args) = @_; + return $self->$callback(sub { () }, @args); +} + +sub traverse_if { + my $self = shift; + my ($callback, $condition, @args) = @_; + return $self->$callback(sub { () }, @args); +} + +1; +__END__ + +=head1 NAME + +Path::Class::File - Objects representing files + +=head1 VERSION + +version 0.35 + +=head1 SYNOPSIS + + use Path::Class; # Exports file() by default + + my $file = file('foo', 'bar.txt'); # Path::Class::File object + my $file = Path::Class::File->new('foo', 'bar.txt'); # Same thing + + # Stringifies to 'foo/bar.txt' on Unix, 'foo\bar.txt' on Windows, etc. + print "file: $file\n"; + + if ($file->is_absolute) { ... } + if ($file->is_relative) { ... } + + my $v = $file->volume; # Could be 'C:' on Windows, empty string + # on Unix, 'Macintosh HD:' on Mac OS + + $file->cleanup; # Perform logical cleanup of pathname + $file->resolve; # Perform physical cleanup of pathname + + my $dir = $file->dir; # A Path::Class::Dir object + + my $abs = $file->absolute; # Transform to absolute path + my $rel = $file->relative; # Transform to relative path + +=head1 DESCRIPTION + +The C class contains functionality for manipulating +file names in a cross-platform way. + +=head1 METHODS + +=over 4 + +=item $file = Path::Class::File->new( , , ..., ) + +=item $file = file( , , ..., ) + +Creates a new C object and returns it. The +arguments specify the path to the file. Any volume may also be +specified as the first argument, or as part of the first argument. +You can use platform-neutral syntax: + + my $file = file( 'foo', 'bar', 'baz.txt' ); + +or platform-native syntax: + + my $file = file( 'foo/bar/baz.txt' ); + +or a mixture of the two: + + my $file = file( 'foo/bar', 'baz.txt' ); + +All three of the above examples create relative paths. To create an +absolute path, either use the platform native syntax for doing so: + + my $file = file( '/var/tmp/foo.txt' ); + +or use an empty string as the first argument: + + my $file = file( '', 'var', 'tmp', 'foo.txt' ); + +If the second form seems awkward, that's somewhat intentional - paths +like C or C<\Windows> aren't cross-platform concepts in the +first place, so they probably shouldn't appear in your code if you're +trying to be cross-platform. The first form is perfectly fine, +because paths like this may come from config files, user input, or +whatever. + +=item $file->stringify + +This method is called internally when a C object is +used in a string context, so the following are equivalent: + + $string = $file->stringify; + $string = "$file"; + +=item $file->volume + +Returns the volume (e.g. C on Windows, C on Mac OS, +etc.) of the object, if any. Otherwise, returns the empty string. + +=item $file->basename + +Returns the name of the file as a string, without the directory +portion (if any). + +=item $file->components + +Returns a list of the directory components of this file, followed by +the basename. + +Note: unlike C<< $dir->components >>, this method currently does not +accept any arguments to select which elements of the list will be +returned. It may do so in the future. Currently it throws an +exception if such arguments are present. + + +=item $file->is_dir + +Returns a boolean value indicating whether this object represents a +directory. Not surprisingly, C objects always +return false, and L objects always return true. + +=item $file->is_absolute + +Returns true or false depending on whether the file refers to an +absolute path specifier (like C or C<\Windows\Foo.txt>). + +=item $file->is_relative + +Returns true or false depending on whether the file refers to a +relative path specifier (like C or C<.\Foo.txt>). + +=item $file->cleanup + +Performs a logical cleanup of the file path. For instance: + + my $file = file('/foo//baz/./foo.txt')->cleanup; + # $file now represents '/foo/baz/foo.txt'; + +=item $dir->resolve + +Performs a physical cleanup of the file path. For instance: + + my $file = file('/foo/baz/../foo.txt')->resolve; + # $file now represents '/foo/foo.txt', assuming no symlinks + +This actually consults the filesystem to verify the validity of the +path. + +=item $dir = $file->dir + +Returns a C object representing the directory +containing this file. + +=item $dir = $file->parent + +A synonym for the C method. + +=item $abs = $file->absolute + +Returns a C object representing C<$file> as an +absolute path. An optional argument, given as either a string or a +L object, specifies the directory to use as the base +of relativity - otherwise the current working directory will be used. + +=item $rel = $file->relative + +Returns a C object representing C<$file> as a +relative path. An optional argument, given as either a string or a +C object, specifies the directory to use as the base +of relativity - otherwise the current working directory will be used. + +=item $foreign = $file->as_foreign($type) + +Returns a C object representing C<$file> as it would +be specified on a system of type C<$type>. Known types include +C, C, C, C, and C, i.e. anything for which +there is a subclass of C. + +Any generated objects (subdirectories, files, parents, etc.) will also +retain this type. + +=item $foreign = Path::Class::File->new_foreign($type, @args) + +Returns a C object representing a file as it would +be specified on a system of type C<$type>. Known types include +C, C, C, C, and C, i.e. anything for which +there is a subclass of C. + +The arguments in C<@args> are the same as they would be specified in +C. + +=item $fh = $file->open($mode, $permissions) + +Passes the given arguments, including C<$file>, to C<< IO::File->new >> +(which in turn calls C<< IO::File->open >> and returns the result +as an L object. If the opening +fails, C is returned and C<$!> is set. + +=item $fh = $file->openr() + +A shortcut for + + $fh = $file->open('r') or croak "Can't read $file: $!"; + +=item $fh = $file->openw() + +A shortcut for + + $fh = $file->open('w') or croak "Can't write to $file: $!"; + +=item $fh = $file->opena() + +A shortcut for + + $fh = $file->open('a') or croak "Can't append to $file: $!"; + +=item $file->touch + +Sets the modification and access time of the given file to right now, +if the file exists. If it doesn't exist, C will I it +exist, and - YES! - set its modification and access time to now. + +=item $file->slurp() + +In a scalar context, returns the contents of C<$file> in a string. In +a list context, returns the lines of C<$file> (according to how C<$/> +is set) as a list. If the file can't be read, this method will throw +an exception. + +If you want C run on each line of the file, pass a true value +for the C or C parameters: + + my @lines = $file->slurp(chomp => 1); + +You may also use the C parameter to pass in an IO mode to use +when opening the file, usually IO layers (though anything accepted by +the MODE argument of C is accepted here). Just make sure it's +a I mode. + + my @lines = $file->slurp(iomode => ':crlf'); + my $lines = $file->slurp(iomode => '<:encoding(UTF-8)'); + +The default C is C. + +Lines can also be automatically split, mimicking the perl command-line +option C<-a> by using the C parameter. If this parameter is used, +each line will be returned as an array ref. + + my @lines = $file->slurp( chomp => 1, split => qr/\s*,\s*/ ); + +The C parameter can only be used in a list context. + +=item $file->spew( $content ); + +The opposite of L, this takes a list of strings and prints them +to the file in write mode. If the file can't be written to, this method +will throw an exception. + +The content to be written can be either an array ref or a plain scalar. +If the content is an array ref then each entry in the array will be +written to the file. + +You may use the C parameter to pass in an IO mode to use when +opening the file, just like L supports. + + $file->spew(iomode => '>:raw', $content); + +The default C is C. + +=item $file->spew_lines( $content ); + +Just like C, but, if $content is a plain scalar, appends $/ +to it, or, if $content is an array ref, appends $/ to each element +of the array. + +Can also take an C parameter like C. Again, the +default C is C. + +=item $file->traverse(sub { ... }, @args) + +Calls the given callback on $file. This doesn't do much on its own, +but see the associated documentation in L. + +=item $file->remove() + +This method will remove the file in a way that works well on all +platforms, and returns a boolean value indicating whether or not the +file was successfully removed. + +C is better than simply calling Perl's C function, +because on some platforms (notably VMS) you actually may need to call +C several times before all versions of the file are gone - +the C method handles this process for you. + +=item $st = $file->stat() + +Invokes C<< File::stat::stat() >> on this file and returns a +L object representing the result. + +=item $st = $file->lstat() + +Same as C, but if C<$file> is a symbolic link, C +stats the link instead of the file the link points to. + +=item $class = $file->dir_class() + +Returns the class which should be used to create directory objects. + +Generally overridden whenever this class is subclassed. + +=item $copy = $file->copy_to( $dest ); + +Copies the C<$file> to C<$dest>. It returns a L +object when successful, C otherwise. + +=item $moved = $file->move_to( $dest ); + +Moves the C<$file> to C<$dest>, and updates C<$file> accordingly. + +It returns C<$file> is successful, C otherwise. + +=back + +=head1 AUTHOR + +Ken Williams, kwilliams@cpan.org + +=head1 SEE ALSO + +L, L, L + +=cut diff --git a/t/01-basic.t b/t/01-basic.t new file mode 100644 index 0000000..bb0d0c5 --- /dev/null +++ b/t/01-basic.t @@ -0,0 +1,152 @@ +BEGIN { + $^O = 'Unix'; # Test in Unix mode +} + +use Test; +use strict; +use Path::Class; +use Cwd; + +plan tests => 70; +ok(1); + +my $file1 = Path::Class::File->new('foo.txt'); +ok $file1, 'foo.txt'; +ok $file1->is_absolute, ''; +ok $file1->dir, '.'; +ok $file1->basename, 'foo.txt'; + +my $file2 = file('dir', 'bar.txt'); +ok $file2, 'dir/bar.txt'; +ok $file2->is_absolute, ''; +ok $file2->dir, 'dir'; +ok $file2->basename, 'bar.txt'; + +my $dir = dir('tmp'); +ok $dir, 'tmp'; +ok $dir->is_absolute, ''; +ok $dir->basename, 'tmp'; + +my $dir2 = dir('/tmp'); +ok $dir2, '/tmp'; +ok $dir2->is_absolute, 1; + +my $cat = file($dir, 'foo'); +ok $cat, 'tmp/foo'; +$cat = $dir->file('foo'); +ok $cat, 'tmp/foo'; +ok $cat->dir, 'tmp'; +ok $cat->basename, 'foo'; + +$cat = file($dir2, 'foo'); +ok $cat, '/tmp/foo'; +$cat = $dir2->file('foo'); +ok $cat, '/tmp/foo'; +ok $cat->isa('Path::Class::File'); +ok $cat->dir, '/tmp'; + +$cat = $dir2->subdir('foo'); +ok $cat, '/tmp/foo'; +ok $cat->isa('Path::Class::Dir'); +ok $cat->basename, 'foo'; + +my $file = file('/foo//baz/./foo')->cleanup; +ok $file, '/foo/baz/foo'; +ok $file->dir, '/foo/baz'; +ok $file->parent, '/foo/baz'; + +{ + my $dir = dir('/foo/bar/baz'); + ok $dir->parent, '/foo/bar'; + ok $dir->parent->parent, '/foo'; + ok $dir->parent->parent->parent, '/'; + ok $dir->parent->parent->parent->parent, '/'; + + $dir = dir('foo/bar/baz'); + ok $dir->parent, 'foo/bar'; + ok $dir->parent->parent, 'foo'; + ok $dir->parent->parent->parent, '.'; + ok $dir->parent->parent->parent->parent, '..'; + ok $dir->parent->parent->parent->parent->parent, '../..'; +} + +{ + my $dir = dir("foo/"); + ok $dir, 'foo'; + ok $dir->parent, '.'; +} + +{ + # Special cases + ok dir(''), '/'; + ok dir(), '.'; + ok dir('', 'var', 'tmp'), '/var/tmp'; + ok dir()->absolute->resolve, dir(Cwd::cwd())->resolve; + ok dir(undef), undef; +} + +{ + my $file = file('/tmp/foo/bar.txt'); + ok $file->relative('/tmp'), 'foo/bar.txt'; + ok $file->relative('/tmp/foo'), 'bar.txt'; + ok $file->relative('/tmp/'), 'foo/bar.txt'; + ok $file->relative('/tmp/foo/'), 'bar.txt'; + + $file = file('one/two/three'); + ok $file->relative('one'), 'two/three'; +} + +{ + # Try out the dir_list() method + my $dir = dir('one/two/three/four/five'); + my @d = $dir->dir_list(); + ok "@d", "one two three four five"; + + @d = $dir->dir_list(2); + ok "@d", "three four five"; + + @d = $dir->dir_list(-2); + ok "@d", "four five"; + + @d = $dir->dir_list(2, 2); + ok "@d", "three four", "dir_list(2, 2)"; + + @d = $dir->dir_list(-3, 2); + ok "@d", "three four", "dir_list(-3, 2)"; + + @d = $dir->dir_list(-3, -2); + ok "@d", "three", "dir_list(-3, -2)"; + + @d = $dir->dir_list(-3, -1); + ok "@d", "three four", "dir_list(-3, -1)"; + + my $d = $dir->dir_list(); + ok $d, 5, "scalar dir_list()"; + + $d = $dir->dir_list(2); + ok $d, "three", "scalar dir_list(2)"; + + $d = $dir->dir_list(-2); + ok $d, "four", "scalar dir_list(-2)"; + + $d = $dir->dir_list(2, 2); + ok $d, "four", "scalar dir_list(2, 2)"; +} + +{ + # Test is_dir() + ok dir('foo')->is_dir, 1; + ok file('foo')->is_dir, 0; +} + +{ + # subsumes() + ok dir('foo/bar')->subsumes('foo/bar/baz'), 1; + ok dir('/foo/bar')->subsumes('/foo/bar/baz'), 1; + ok dir('foo/bar')->subsumes('bar/baz'), 0; + ok dir('/foo/bar')->subsumes('foo/bar'), 0; + ok dir('/foo/bar')->subsumes('/foo/baz'), 0; + ok dir('/')->subsumes('/foo/bar'), 1; + ok dir('/')->subsumes(file('/foo')), 1; + ok dir('/foo')->subsumes(file('/foo')), 0; +} diff --git a/t/02-foreign.t b/t/02-foreign.t new file mode 100644 index 0000000..b9cac50 --- /dev/null +++ b/t/02-foreign.t @@ -0,0 +1,73 @@ +use Test; +use strict; +BEGIN { plan tests => 29 }; +use Path::Class qw(file dir foreign_file foreign_dir); +ok(1); + + +my $file = Path::Class::File->new_foreign('Unix', 'dir', 'foo.txt'); +ok $file, 'dir/foo.txt'; + +ok $file->as_foreign('Win32'), 'dir\foo.txt'; +ok $file->as_foreign('Mac'), ':dir:foo.txt'; +ok $file->as_foreign('OS2'), 'dir/foo.txt'; + +if ($^O eq 'VMS') { + ok $file->as_foreign('VMS'), '[.dir]foo.txt'; +} else { + skip "skip Can't test VMS code on other platforms", 1; +} + +$file = foreign_file('Mac', ':dir:foo.txt'); +ok $file, ':dir:foo.txt'; +ok $file->as_foreign('Unix'), 'dir/foo.txt'; +ok $file->dir, ':dir:'; + + +my $dir = Path::Class::Dir->new_foreign('Unix', 'dir/subdir'); +ok $dir, 'dir/subdir'; +ok $dir->as_foreign('Win32'), 'dir\subdir'; +ok $dir->as_foreign('Mac'), ':dir:subdir:'; +ok $dir->as_foreign('OS2'), 'dir/subdir'; + +if ($^O eq 'VMS') { + ok $dir->as_foreign('VMS'), '[.dir.subdir]'; +} else { + skip "skip Can't test VMS code on other platforms", 1; +} + +{ + # subsumes() should respect foreignness + my ($me, $other) = map { Path::Class::Dir->new_foreign('Unix', $_) } qw(/ /Foo); + ok($me->subsumes($other)); + + ($me, $other) = map { Path::Class::Dir->new_foreign('Win32', $_) } qw(C:\ C:\Foo); + ok($me->subsumes($other)); +} + +# Note that "\\" and '\\' are each a single backslash +$dir = foreign_dir('Win32', 'C:\\'); +ok $dir, 'C:\\'; +$dir = foreign_dir('Win32', 'C:/'); +ok $dir, 'C:\\'; +ok $dir->subdir('Program Files'), 'C:\\Program Files'; + +$dir = foreign_dir('Mac', ':dir:subdir:'); +ok $dir, ':dir:subdir:'; +ok $dir->subdir('foo'), ':dir:subdir:foo:'; +ok $dir->file('foo.txt'), ':dir:subdir:foo.txt'; +ok $dir->parent, ':dir:'; +ok $dir->is_relative, 1; + +$dir = foreign_dir('Mac', ':dir::dir2:subdir'); +ok $dir, ':dir::dir2:subdir:'; +ok $dir->as_foreign('Unix'), 'dir/../dir2/subdir'; + +$dir = foreign_dir('Mac', 'Volume:dir:subdir:'); +ok $dir, 'Volume:dir:subdir:'; +ok $dir->is_absolute; +# TODO ok $dir->as_foreign('Unix'), '/dir/subdir'; +# TODO ok $dir->as_foreign('Unix')->is_absolute, 1; + +$dir = foreign_dir('Cygwin', '', 'tmp', 'foo'); +ok $dir, '/tmp/foo'; diff --git a/t/03-filesystem.t b/t/03-filesystem.t new file mode 100644 index 0000000..f9fe625 --- /dev/null +++ b/t/03-filesystem.t @@ -0,0 +1,372 @@ +use strict; +use Test::More; +use File::Temp qw(tmpnam tempdir); + +plan tests => 103; + +use_ok 'Path::Class'; + + +my $file = file(scalar tmpnam()); +ok $file, "Got a filename via tmpnam()"; + +{ + my $fh = $file->open('w'); + ok $fh, "Opened $file for writing"; + + ok print( $fh "Foo\n"), "Printed to $file"; +} + +ok -e $file, "$file should exist"; + +{ + my $fh = $file->open; + is scalar <$fh>, "Foo\n", "Read contents of $file correctly"; +} + +{ + my $stat = $file->stat; + ok $stat; + cmp_ok $stat->mtime, '>', time() - 20; # Modified within last 20 seconds + + $stat = $file->dir->stat; + ok $stat; +} + +1 while unlink $file; +ok not -e $file; + + +my $dir = dir(tempdir(CLEANUP => 1)); +ok $dir; +ok -d $dir; + +$file = $dir->file('foo.x'); +$file->touch; +ok -e $file; + +{ + my $dh = $dir->open; + ok $dh, "Opened $dir for reading"; + + my @files = readdir $dh; + is scalar @files, 3; + ok scalar grep { $_ eq 'foo.x' } @files; +} + +ok $dir->rmtree, "Removed $dir"; +ok !-e $dir, "$dir no longer exists"; + +{ + $dir = dir('t', 'foo', 'bar'); + $dir->parent->rmtree if -e $dir->parent; + + ok $dir->mkpath, "Created $dir"; + ok -d $dir, "$dir is a directory"; + + # Use a Unix sample path to test cleaning it up + my $ugly = Path::Class::Dir->new_foreign(Unix => 't/foo/..//foo/bar'); + $ugly->resolve; + is $ugly->as_foreign('Unix'), 't/foo/bar'; + + $dir = $dir->parent; + ok $dir->rmtree; + ok !-e $dir; +} + +{ + $dir = dir('t', 'foo'); + ok $dir->mkpath; + ok $dir->subdir('dir')->mkpath; + ok -d $dir->subdir('dir'); + + ok $dir->file('file.x')->touch; + ok $dir->file('0')->touch; + my @contents; + while (my $file = $dir->next) { + push @contents, $file; + } + is scalar @contents, 5; + + my $joined = join ' ', sort map $_->basename, grep {-f $_} @contents; + is $joined, '0 file.x'; + + my ($subdir) = grep {$_ eq $dir->subdir('dir')} @contents; + ok $subdir; + is -d $subdir, 1; + + my ($file) = grep {$_ eq $dir->file('file.x')} @contents; + ok $file; + is -d $file, ''; + + ok $dir->rmtree; + ok !-e $dir; + + + # Try again with directory called '0', in curdir + my $orig = dir()->absolute; + + ok $dir->mkpath; + ok chdir($dir); + my $dir2 = dir(); + ok $dir2->subdir('0')->mkpath; + ok -d $dir2->subdir('0'); + + @contents = (); + while (my $file = $dir2->next) { + push @contents, $file; + } + ok grep {$_ eq '0'} @contents; + + ok chdir($orig); + ok $dir->rmtree; + ok !-e $dir; +} + +{ + my $file = file('t', 'slurp'); + ok $file; + + my $fh = $file->open('w') or die "Can't create $file: $!"; + print $fh "Line1\nLine2\n"; + close $fh; + ok -e $file; + + my $content = $file->slurp; + is $content, "Line1\nLine2\n"; + + my @content = $file->slurp; + is_deeply \@content, ["Line1\n", "Line2\n"]; + + @content = $file->slurp(chomp => 1); + is_deeply \@content, ["Line1", "Line2"]; + + is_deeply [ $file->slurp( chomp => 1, split => qr/n/ ) ] + => [ [ 'Li', 'e1' ], [ 'Li', 'e2' ] ], + "regex split with chomp"; + + is_deeply [ $file->slurp( chomp => 1, split => 'n' ) ] + => [ [ 'Li', 'e1' ], [ 'Li', 'e2' ] ], + "string split with chomp"; + + $file->remove; + ok not -e $file; +} + +SKIP: { + my $file = file('t', 'slurp'); + ok $file; + + skip "IO modes not available until perl 5.7.1", 5 + unless $^V ge v5.7.1; + + my $fh = $file->open('>:raw') or die "Can't create $file: $!"; + print $fh "Line1\r\nLine2\r\n\302\261\r\n"; + close $fh; + ok -e $file; + + my $content = $file->slurp(iomode => '<:raw'); + is $content, "Line1\r\nLine2\r\n\302\261\r\n"; + + my $line3 = "\302\261\n"; + utf8::decode($line3); + my @content = $file->slurp(iomode => '<:crlf:utf8'); + is_deeply \@content, ["Line1\n", "Line2\n", $line3]; + + chop($line3); + @content = $file->slurp(chomp => 1, iomode => '<:crlf:utf8'); + is_deeply \@content, ["Line1", "Line2", $line3]; + + $file->remove; + ok not -e $file; +} + +{ + my $file = file('t', 'spew'); + $file->remove() if -e $file; + $file->spew( iomode => '>:raw', "Line1\r\n" ); + $file->spew( iomode => '>>', "Line2" ); + + my $content = $file->slurp( iomode => '<:raw'); + + is( $content, "Line1\r\nLine2" ); + + $file->remove; + ok not -e $file; +} + +{ + my $file = file('t', 'spew_lines'); + $file->remove() if -e $file; + $file->spew_lines( iomode => '>:raw', "Line1" ); + $file->spew_lines( iomode => '>>:raw', [qw/Line2 Line3/] ); + + my $content = $file->slurp( iomode => '<:raw'); + + is( $content, "Line1$/Line2$/Line3$/" ); + + $file->remove; + ok not -e $file; +} + +{ + # Make sure we can make an absolute/relative roundtrip + my $cwd = dir(); + is $cwd, $cwd->absolute->relative, "from $cwd to ".$cwd->absolute." to ".$cwd->absolute->relative; +} + +{ + my $t = dir('t'); + my $foo_bar = $t->subdir('foo','bar'); + $foo_bar->rmtree; # Make sure it doesn't exist + + ok $t->subsumes($foo_bar), "t subsumes t/foo/bar"; + ok !$t->contains($foo_bar), "t doesn't contain t/foo/bar"; + + $foo_bar->mkpath; + ok $t->subsumes($foo_bar), "t still subsumes t/foo/bar"; + ok $t->contains($foo_bar), "t now contains t/foo/bar"; + + $t->subdir('foo')->rmtree; +} + +{ + # Test recursive iteration through the following structure: + # a + # / \ + # b c + # / \ \ + # d e f + # / \ \ + # g h i + (my $abe = dir(qw(a b e)))->mkpath; + (my $acf = dir(qw(a c f)))->mkpath; + file($acf, 'i')->touch; + file($abe, 'h')->touch; + file($abe, 'g')->touch; + file('a', 'b', 'd')->touch; + + my $a = dir('a'); + + # Make sure the children() method works ok + my @children = sort map $_->as_foreign('Unix'), $a->children; + is_deeply \@children, ['a/b', 'a/c']; + + { + recurse_test( $a, + preorder => 1, depthfirst => 0, # The default + precedence => [qw(a a/b + a a/c + a/b a/b/e/h + a/b a/c/f/i + a/c a/b/e/h + a/c a/c/f/i + )], + ); + } + + { + my $files = + recurse_test( $a, + preorder => 1, depthfirst => 1, + precedence => [qw(a a/b + a a/c + a/b a/b/e/h + a/c a/c/f/i + )], + ); + is_depthfirst($files); + } + + { + my $files = + recurse_test( $a, + preorder => 0, depthfirst => 1, + precedence => [qw(a/b a + a/c a + a/b/e/h a/b + a/c/f/i a/c + )], + ); + is_depthfirst($files); + } + + + $a->rmtree; + + sub is_depthfirst { + my $files = shift; + if ($files->{'a/b'} < $files->{'a/c'}) { + cmp_ok $files->{'a/b/e'}, '<', $files->{'a/c'}, "Ensure depth-first search"; + } else { + cmp_ok $files->{'a/c/f'}, '<', $files->{'a/b'}, "Ensure depth-first search"; + } + } + + sub recurse_test { + my ($dir, %args) = @_; + my $precedence = delete $args{precedence}; + my ($i, %files) = (0); + $a->recurse( callback => sub {$files{shift->as_foreign('Unix')->stringify} = ++$i}, + %args ); + while (my ($pre, $post) = splice @$precedence, 0, 2) { + cmp_ok $files{$pre}, '<', $files{$post}, "$pre should come before $post"; + } + return \%files; + } +} + +{ + $dir = Path::Class::tempdir(); + isa_ok $dir, 'Path::Class::Dir'; + + $dir = Path::Class::tempdir(CLEANUP => 1); + isa_ok $dir, 'Path::Class::Dir'; +} + +# copy_to() +{ + my $file1 = file('t', 'file1'); + my $file2 = file('t', 'file2'); + $file1->spew("some contents"); + ok -e $file1; + + my $copy = $file1->copy_to($file2); + + isa_ok $copy, "Path::Class::File"; + is($copy->stringify, $file2->stringify, "same file"); + + ok -e $file2; + is($file2->slurp, "some contents"); + + my $dir = dir('t', 'dir'); + $dir->mkpath; + $file1->copy_to($dir); + my $dest = $dir->file($file1->basename); + ok -e $dest; + is($dest->slurp, "some contents"); + + $_->remove for ($file1, $file2); + $dir->rmtree; + ok( ! -e $_, "$_ should be removed") for ($file1, $file2, $dir); +} + +# move_to() +{ + my $file1 = file('t', 'file1'); + my $src = file('t', 'file1'); + + my $file2 = file('t', 'file2'); + $file1->spew("some contents"); + ok -e $file1; + + my $move = $file1->move_to($file2); + ok -e $file2; + is($file2->slurp, "some contents"); + ok ! -e $src; + + is($file1->stringify, $file2->stringify); + + $file2->remove; + ok( ! -e $_, "$_ should be gone") for ($file1, $file2); +} diff --git a/t/04-subclass.t b/t/04-subclass.t new file mode 100644 index 0000000..f28b388 --- /dev/null +++ b/t/04-subclass.t @@ -0,0 +1,36 @@ +#!/usr/bin/perl + +# Test subclassing of Path::Class + +use strict; +use warnings; + +use Test::More tests => 6; + +{ + package My::File; + use parent qw(Path::Class::File); + + sub dir_class { return "My::Dir" } +} + +{ + package My::Dir; + use parent qw(Path::Class::Dir); + + sub file_class { return "My::File" } +} + +{ + my $file = My::File->new("/path/to/some/file"); + isa_ok $file, "My::File"; + is $file->as_foreign("Unix"), "/path/to/some/file"; + + my $dir = $file->dir; + isa_ok $dir, "My::Dir"; + is $dir->as_foreign("Unix"), "/path/to/some"; + + my $file_again = $dir->file("bar"); + isa_ok $file_again, "My::File"; + is $file_again->as_foreign("Unix"), "/path/to/some/bar"; +} diff --git a/t/05-traverse.t b/t/05-traverse.t new file mode 100644 index 0000000..e29f7cc --- /dev/null +++ b/t/05-traverse.t @@ -0,0 +1,51 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Cwd; +use Test::More; +use File::Temp qw(tempdir); + +plan tests => 4; + +use_ok 'Path::Class'; + +my $cwd = getcwd; +my $tmp = dir(tempdir(CLEANUP => 1)); + +# Test recursive iteration through the following structure: +# a +# / \ +# b c +# / \ \ +# d e f +# / \ \ +# g h i +(my $abe = $tmp->subdir(qw(a b e)))->mkpath; +(my $acf = $tmp->subdir(qw(a c f)))->mkpath; +$acf->file('i')->touch; +$abe->file('h')->touch; +$abe->file('g')->touch; +$tmp->file(qw(a b d))->touch; + +my $a = $tmp->subdir('a'); + +my $nnodes = $a->traverse(sub { + my ($child, $cont) = @_; + return sum($cont->(), 1); +}); +is($nnodes, 9); + +my $ndirs = $a->traverse(sub { + my ($child, $cont) = @_; + return sum($cont->(), ($child->is_dir ? 1 : 0)); +}); +is($ndirs, 5); + +my $max_depth = $a->traverse(sub { + my ($child, $cont, $depth) = @_; + return max($cont->($depth + 1), $depth); +}, 0); +is($max_depth, 3); + +sub sum { my $total = 0; $total += $_ for @_; $total } +sub max { my $max = 0; for (@_) { $max = $_ if $_ > $max } $max } diff --git a/t/06-traverse_filt.t b/t/06-traverse_filt.t new file mode 100644 index 0000000..fa6c440 --- /dev/null +++ b/t/06-traverse_filt.t @@ -0,0 +1,77 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Cwd; +use Test::More; +use File::Temp qw(tempdir); + +plan tests => 4; + +use_ok 'Path::Class'; + +my $cwd = getcwd; +my $tmp = dir(tempdir(CLEANUP => 1)); + +# Test ability to filter children before navigating down to them +# a +# / \ +# b* c * → inaccessible +# / \ \ +# d e f +# / \ \ +# g h i* +(my $abe = $tmp->subdir(qw(a b e)))->mkpath; +(my $acf = $tmp->subdir(qw(a c f)))->mkpath; +$acf->file('i')->touch; +$abe->file('h')->touch; +$abe->file('g')->touch; +$tmp->file(qw(a b d))->touch; + +# Simulate permissions failures by just keeping a 'bad' list. We +# can't use actual permissions failures, because some people run tests +# as root, and then permissions always succeed. +my %bad = ( b => 1, i => 1); + + +my $a = $tmp->subdir('a'); + +my $nnodes = $a->traverse_if( + sub { + my ($child, $cont) = @_; + #diag("I am in $child"); + return sum($cont->(), 1); + }, + sub { + my $child = shift; + #diag("Checking whether to use $child: " . -r $child); + return !$bad{$child->basename}; + } +); +is($nnodes, 3); + +my $ndirs = $a->traverse_if( + sub { + my ($child, $cont) = @_; + return sum($cont->(), ($child->is_dir ? 1 : 0)); + }, + sub { + my $child = shift; + return !$bad{$child->basename}; + } + ); +is($ndirs, 3); + +my $max_depth = $a->traverse_if( + sub { + my ($child, $cont, $depth) = @_; + return max($cont->($depth + 1), $depth); + }, + sub { + my $child = shift; + return !$bad{$child->basename}; + }, + 0); +is($max_depth, 2); + +sub sum { my $total = 0; $total += $_ for @_; $total } +sub max { my $max = 0; for (@_) { $max = $_ if $_ > $max } $max } diff --git a/t/07-recurseprune.t b/t/07-recurseprune.t new file mode 100644 index 0000000..16f9447 --- /dev/null +++ b/t/07-recurseprune.t @@ -0,0 +1,92 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Cwd; +use Test::More; +use File::Temp qw(tempdir); + +plan tests => 8; + +use_ok 'Path::Class'; + +my $cwd = getcwd; +my $tmp = dir(tempdir(CLEANUP => 1)); + +# Test recursive iteration through the following structure: +# a +# / \ +# b c +# / \ \ +# d e f +# / \ \ +# g h i +(my $abe = $tmp->subdir(qw(a b e)))->mkpath; +(my $acf = $tmp->subdir(qw(a c f)))->mkpath; +$acf->file('i')->touch; +$abe->file('h')->touch; +$abe->file('g')->touch; +$tmp->file(qw(a b d))->touch; + +my $a = $tmp->subdir('a'); + +# Warmup without pruning +{ + my %visited; + $a->recurse( + callback => sub{ + my $item = shift; + my $rel_item = $item->relative($tmp); + my $tag = join '|', $rel_item->components; + $visited{$tag} = 1; + }); + + is_deeply(\%visited, { + "a" => 1, "a|b" => 1, "a|c" => 1, + "a|b|d" => 1, "a|b|e" => 1, "a|b|e|g" => 1, "a|b|e|h" => 1, + "a|c|f" => 1, "a|c|f|i" => 1, }); +} + +# Prune constant +ok( $a->PRUNE ); + +# Prune no 1 +{ + my %visited; + $a->recurse( + callback => sub{ + my $item = shift; + my $rel_item = $item->relative($tmp); + my $tag = join '|', $rel_item->components; + $visited{$tag} = 1; + return $item->PRUNE if $tag eq 'a|b'; + }); + + is_deeply(\%visited, { + "a" => 1, "a|b" => 1, "a|c" => 1, + "a|c|f" => 1, "a|c|f|i" => 1, }); +} + +# Prune constant alternative way +use_ok("Path::Class::Entity"); +ok( Path::Class::Entity::PRUNE() ); +is( $a->PRUNE, Path::Class::Entity::PRUNE() ); + +# Prune no 2 +{ + my %visited; + $a->recurse( + callback => sub{ + my $item = shift; + my $rel_item = $item->relative($tmp); + my $tag = join '|', $rel_item->components; + $visited{$tag} = 1; + return Path::Class::Entity::PRUNE() if $tag eq 'a|c'; + }); + + is_deeply(\%visited, { + "a" => 1, "a|b" => 1, "a|c" => 1, + "a|b|d" => 1, "a|b|e" => 1, "a|b|e|g" => 1, "a|b|e|h" => 1, + }); +} + +#diag("PRUNE constant value: " . $a->PRUNE); diff --git a/t/author-critic.t b/t/author-critic.t new file mode 100644 index 0000000..af7f7ea --- /dev/null +++ b/t/author-critic.t @@ -0,0 +1,20 @@ +#!perl + +BEGIN { + unless ($ENV{AUTHOR_TESTING}) { + require Test::More; + Test::More::plan(skip_all => 'these tests are for testing by the author'); + } +} + + +use strict; +use warnings; + +use Test::More; +use English qw(-no_match_vars); + +eval "use Test::Perl::Critic"; +plan skip_all => 'Test::Perl::Critic required to criticise code' if $@; +Test::Perl::Critic->import( -profile => "perlcritic.rc" ) if -e "perlcritic.rc"; +all_critic_ok(); -- cgit v1.2.1