diff options
| -rw-r--r-- | Build.PL | 67 | ||||
| -rw-r--r-- | Changes | 369 | ||||
| -rw-r--r-- | INSTALL | 44 | ||||
| -rw-r--r-- | LICENSE | 379 | ||||
| -rw-r--r-- | MANIFEST | 24 | ||||
| -rw-r--r-- | META.yml | 39 | ||||
| -rw-r--r-- | Makefile.PL | 89 | ||||
| -rw-r--r-- | README | 13 | ||||
| -rw-r--r-- | README.pod | 165 | ||||
| -rw-r--r-- | SIGNATURE | 47 | ||||
| -rw-r--r-- | cpanfile | 30 | ||||
| -rw-r--r-- | dist.ini | 50 | ||||
| -rw-r--r-- | lib/Path/Class.pm | 198 | ||||
| -rw-r--r-- | lib/Path/Class/Dir.pm | 830 | ||||
| -rw-r--r-- | lib/Path/Class/Entity.pm | 117 | ||||
| -rw-r--r-- | lib/Path/Class/File.pm | 539 | ||||
| -rw-r--r-- | t/01-basic.t | 152 | ||||
| -rw-r--r-- | t/02-foreign.t | 73 | ||||
| -rw-r--r-- | t/03-filesystem.t | 372 | ||||
| -rw-r--r-- | t/04-subclass.t | 36 | ||||
| -rw-r--r-- | t/05-traverse.t | 51 | ||||
| -rw-r--r-- | t/06-traverse_filt.t | 77 | ||||
| -rw-r--r-- | t/07-recurseprune.t | 92 | ||||
| -rw-r--r-- | t/author-critic.t | 20 |
24 files changed, 3873 insertions, 0 deletions
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 <kwilliams\@cpan.org>" + ], + "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; @@ -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 <Andrew Gregory> + + +0.34 Thu Aug 28 22:27:03 CDT 2014 + + - df23e17 - Add a new spew_lines() method <William Stevenson> + + - 3ffef39 - Don't convert file into directory in subsumes() <Dagfinn Ilmari Mannsåker> + + - 9a01a71 - Updated POD for copy_to and move_to methods <Robert Rothenberg> + + - 210a7ef - Stringify destination for copy_to method <Robert Rothenberg> + + - 9f83723 - Stringify destination for move_to method <Robert Rothenberg> + + - 5e2cb26, d5c7e62 - Add Continuous Integration with Travis CI <Ken Williams> + + - d372be1 - Change bugtracker to github's <Ken Williams> + + +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 <EDENC@cpan.org>] + + - Fixed the heading for the is_relative() POD section. [CUB <cub.uanic@gmail.com>] + +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 @@ -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 @@ -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. + + <one line to give the program's name and a brief idea of what it does.> + Copyright (C) 19yy <name of author> + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 1, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston MA 02110-1301 USA + + +Also add information on how to contact you by electronic and paper mail. + +If the program is interactive, make it output a short notice like this +when it starts in an interactive mode: + + Gnomovision version 69, Copyright (C) 19xx name of author + Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the +appropriate parts of the General Public License. Of course, the +commands you use may be called something other than `show w' and `show +c'; they could even be mouse-clicks or menu items--whatever suits your +program. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the program, if +necessary. Here a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the + program `Gnomovision' (a program to direct compilers to make passes + at assemblers) written by James Hacker. + + <signature of Ty Coon>, 1 April 1989 + Ty Coon, President of Vice + +That's all there is to it! + + +--- The Artistic License 1.0 --- + +This software is Copyright (c) 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 <kwilliams@cpan.org>' +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 <kwilliams\@cpan.org>", + "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); + + + @@ -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<Path::Class> 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<File::Spec> 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<Path::Class> uses C<File::Spec> internally, wrapping all +the unsightly details so you can concentrate on your application code. +Whereas C<File::Spec> provides functions for some common path +manipulations, C<Path::Class> provides an object-oriented model of the +world of path specifications and their underlying semantics. +C<File::Spec> 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<Path::Class> creates +objects representing files and directories, and provides methods that +relate them to each other. For instance, the following C<File::Spec> +code: + + my $absolute = File::Spec->file_name_is_absolute( + File::Spec->catfile( @dirs, $file ) + ); + +can be written using C<Path::Class> 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<Path::Class>. + +Using C<Path::Class> can help solve real problems in your code too - +for instance, how many people actually take the "volume" (like C<C:> +on Windows) into account when writing C<File::Spec>-using code? I +thought not. But if you use C<Path::Class>, your file and directory objects +will know what volumes they refer to and do the right thing. + +The guts of the C<Path::Class> code live in the L<Path::Class::File> +and L<Path::Class::Dir> 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<use>, i.e. C<use Path::Class ()>. + +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<File::Spec>, 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<foo/bar> and then ask for a list of files in the directory +F<foo>, you may find a file called F<bar.> instead of the F<bar> 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<Path::Class::Dir>, L<Path::Class::File>, L<File::Spec> + +=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 <kwilliams@cpan.org> +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<Path::Class> 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<File::Spec> 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<Path::Class> uses C<File::Spec> internally, wrapping all +the unsightly details so you can concentrate on your application code. +Whereas C<File::Spec> provides functions for some common path +manipulations, C<Path::Class> provides an object-oriented model of the +world of path specifications and their underlying semantics. +C<File::Spec> 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<Path::Class> creates +objects representing files and directories, and provides methods that +relate them to each other. For instance, the following C<File::Spec> +code: + + my $absolute = File::Spec->file_name_is_absolute( + File::Spec->catfile( @dirs, $file ) + ); + +can be written using C<Path::Class> 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<Path::Class>. + +Using C<Path::Class> can help solve real problems in your code too - +for instance, how many people actually take the "volume" (like C<C:> +on Windows) into account when writing C<File::Spec>-using code? I +thought not. But if you use C<Path::Class>, your file and directory objects +will know what volumes they refer to and do the right thing. + +The guts of the C<Path::Class> code live in the L<Path::Class::File> +and L<Path::Class::Dir> 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<use>, i.e. C<use Path::Class ()>. + +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<File::Spec>, 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<foo/bar> and then ask for a list of files in the directory +F<foo>, you may find a file called F<bar.> instead of the F<bar> 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<Path::Class::Dir>, L<Path::Class::File>, L<File::Spec> + +=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<Path::Class::Dir> class contains functionality for manipulating +directory names in a cross-platform way. + +=head1 METHODS + +=over 4 + +=item $dir = Path::Class::Dir->new( <dir1>, <dir2>, ... ) + +=item $dir = dir( <dir1>, <dir2>, ... ) + +Creates a new C<Path::Class::Dir> 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</var/tmp> 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<dir()>) 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<dir(undef)> 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<Path::Class::Dir> 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<C:> on Windows, C<Macintosh HD:> 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<Path::Class::File> objects always +return false, and C<Path::Class::Dir> 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</usr/local> or C<\Windows>). + +=item $dir->is_relative + +Returns true or false depending on whether the directory refers to a +relative path specifier (like C<lib/foo> 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( <dir1>, <dir2>, ..., <file> ) + +Returns a L<Path::Class::File> 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( <dir1>, <dir2>, ... ) + +Returns a new C<Path::Class::Dir> object representing a subdirectory +of C<$dir>. + +=item $parent = $dir->parent + +Returns the parent directory of C<$dir>. Note that this is the +I<logical> 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<Path::Class::File> and/or C<Path::Class::Dir> +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<foo> will be F<foo/bar> and F<foo/baz>, not +F<bar> and F<baz>. + +Ordinarily C<children()> will not include the I<self> and I<parent> +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<all> parameter: + + @c = $dir->children(); # Just the children + @c = $dir->children(all => 1); # All entries + +In addition, there's a C<no_hidden> 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<Path::Class::Dir> object representing C<$dir> as an +absolute path. An optional argument, given as either a string or a +C<Path::Class::Dir> 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<Path::Class::Dir> object representing C<$dir> as a +relative path. An optional argument, given as either a string or a +C<Path::Class::Dir> 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<specs>, not whether C<$dir> actually contains C<$other> on the +filesystem. + +The C<$other> argument may be a C<Path::Class::Dir> object, a +L<Path::Class::File> 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<Path::Class::Dir> object representing C<$dir> as it would +be specified on a system of type C<$type>. Known types include +C<Unix>, C<Win32>, C<Mac>, C<VMS>, and C<OS2>, i.e. anything for which +there is a subclass of C<File::Spec>. + +Any generated objects (subdirectories, files, parents, etc.) will also +retain this type. + +=item $foreign = Path::Class::Dir->new_foreign($type, @args) + +Returns a C<Path::Class::Dir> object representing C<$dir> as it would +be specified on a system of type C<$type>. Known types include +C<Unix>, C<Win32>, C<Mac>, C<VMS>, and C<OS2>, i.e. anything for which +there is a subclass of C<File::Spec>. + +The arguments in C<@args> are the same as they would be specified in +C<new()>. + +=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<splice> or +C<substr> functions; they return C<LENGTH> elements starting at +C<OFFSET>. If C<LENGTH> is omitted, returns all the elements starting +at C<OFFSET> up to the end of the list. If C<LENGTH> is negative, +returns the elements from C<OFFSET> onward except for C<-LENGTH> +elements at the end. If C<OFFSET> is negative, it counts backward +C<OFFSET> elements from the end of the list. If C<OFFSET> and +C<LENGTH> are both omitted, the entire list is returned. + +In a scalar context, C<dir_list()> with no arguments returns the +number of entries in the directory list; C<dir_list(OFFSET)> returns +the single element at that offset; C<dir_list(OFFSET, LENGTH)> returns +the final element that would have been returned in a list context. + +=item $dir->components + +Identical to c<dir_list()>. It exists because there's an analogous +method C<dir_list()> in the C<Path::Class::File> class that also +returns the basename string, so this method lets someone call +C<components()> 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<IO::Dir> object. If the opening fails, C<undef> 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<Path::Class::File>'s C<remove()> method. + +=item $dir->tempfile(...) + +An interface to L<File::Temp>'s C<tempfile()> function. Just like +that function, if you call this in a scalar context, the return value +is the filehandle and the file is C<unlink>ed 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<DIR> 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<fork>: + + 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<next()> is called, it will C<open()> the directory and read the +first item from it, returning the result as a C<Path::Class::Dir> or +L<Path::Class::File> object (depending, of course, on its actual +type). Each subsequent call to C<next()> 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<next()> 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<traverse_if(callback, sub { 1 }, @args> is equivalent to +C<traverse(callback, @args)>. + +=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<callback> subroutine for +each entry. This is a lot like what the L<File::Find> module does, +and of course C<File::Find> will work fine on L<Path::Class> objects, +but the advantage of the C<recurse()> method is that it will also feed +your callback routine C<Path::Class> objects rather than just pathname +strings. + +The C<recurse()> method requires a C<callback> parameter specifying +the subroutine to invoke for each entry. It will be passed the +C<Path::Class> object as its first argument. + +C<recurse()> also accepts two boolean parameters, C<depthfirst> and +C<preorder> 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<except> C<< depthfirst => 0, preorder => 0 >>. + +C<callback> is normally not required to return any value. If it +returns special constant C<Path::Class::Entity::PRUNE()> (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<preorder>, in postorder return value +has no effect. + +=item $st = $file->stat() + +Invokes C<< File::stat::stat() >> on this directory and returns a +C<File::stat> object representing the result. + +=item $st = $file->lstat() + +Same as C<stat()>, but if C<$file> is a symbolic link, C<lstat()> +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<Path::Class>, L<Path::Class::File>, L<File::Spec> + +=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<Path::Class::File> and +C<Path::Class::Dir>, 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<Path::Class::File> class contains functionality for manipulating +file names in a cross-platform way. + +=head1 METHODS + +=over 4 + +=item $file = Path::Class::File->new( <dir1>, <dir2>, ..., <file> ) + +=item $file = file( <dir1>, <dir2>, ..., <file> ) + +Creates a new C<Path::Class::File> 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</var/tmp> 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<Path::Class::File> 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<C:> on Windows, C<Macintosh HD:> 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<Path::Class::File> objects always +return false, and L<Path::Class::Dir> 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</usr/local/foo.txt> 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<lib/foo.txt> 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<Path::Class::Dir> object representing the directory +containing this file. + +=item $dir = $file->parent + +A synonym for the C<dir()> method. + +=item $abs = $file->absolute + +Returns a C<Path::Class::File> object representing C<$file> as an +absolute path. An optional argument, given as either a string or a +L<Path::Class::Dir> 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<Path::Class::File> object representing C<$file> as a +relative path. An optional argument, given as either a string or a +C<Path::Class::Dir> 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<Path::Class::File> object representing C<$file> as it would +be specified on a system of type C<$type>. Known types include +C<Unix>, C<Win32>, C<Mac>, C<VMS>, and C<OS2>, i.e. anything for which +there is a subclass of C<File::Spec>. + +Any generated objects (subdirectories, files, parents, etc.) will also +retain this type. + +=item $foreign = Path::Class::File->new_foreign($type, @args) + +Returns a C<Path::Class::File> object representing a file as it would +be specified on a system of type C<$type>. Known types include +C<Unix>, C<Win32>, C<Mac>, C<VMS>, and C<OS2>, i.e. anything for which +there is a subclass of C<File::Spec>. + +The arguments in C<@args> are the same as they would be specified in +C<new()>. + +=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<IO::File> object. If the opening +fails, C<undef> 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<touch()> will I<make> 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<chomp()> run on each line of the file, pass a true value +for the C<chomp> or C<chomped> parameters: + + my @lines = $file->slurp(chomp => 1); + +You may also use the C<iomode> 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<open()> is accepted here). Just make sure it's +a I<reading> mode. + + my @lines = $file->slurp(iomode => ':crlf'); + my $lines = $file->slurp(iomode => '<:encoding(UTF-8)'); + +The default C<iomode> is C<r>. + +Lines can also be automatically split, mimicking the perl command-line +option C<-a> by using the C<split> 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<split> parameter can only be used in a list context. + +=item $file->spew( $content ); + +The opposite of L</slurp>, 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<iomode> parameter to pass in an IO mode to use when +opening the file, just like L</slurp> supports. + + $file->spew(iomode => '>:raw', $content); + +The default C<iomode> is C<w>. + +=item $file->spew_lines( $content ); + +Just like C<spew>, 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<iomode> parameter like C<spew>. Again, the +default C<iomode> is C<w>. + +=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<Path::Class::Dir>. + +=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<remove()> is better than simply calling Perl's C<unlink()> function, +because on some platforms (notably VMS) you actually may need to call +C<unlink()> several times before all versions of the file are gone - +the C<remove()> method handles this process for you. + +=item $st = $file->stat() + +Invokes C<< File::stat::stat() >> on this file and returns a +L<File::stat> object representing the result. + +=item $st = $file->lstat() + +Same as C<stat()>, but if C<$file> is a symbolic link, C<lstat()> +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<Path::Class::File> +object when successful, C<undef> 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<undef> otherwise. + +=back + +=head1 AUTHOR + +Ken Williams, kwilliams@cpan.org + +=head1 SEE ALSO + +L<Path::Class>, L<Path::Class::Dir>, L<File::Spec> + +=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(); |