From 26bf30452b170e132f578bd9dbd200aac074e153 Mon Sep 17 00:00:00 2001 From: Packit Date: Sep 16 2020 12:13:37 +0000 Subject: perl-File-Find-Object-Rule-0.0306 base --- diff --git a/Build.PL b/Build.PL new file mode 100644 index 0000000..f62a4d0 --- /dev/null +++ b/Build.PL @@ -0,0 +1,66 @@ +# This file is under the MIT X11 License: +# http://www.opensource.org/licenses/mit-license.php + +use strict; +use warnings; + +use lib "./inc"; + +use Test::Run::Builder; + +my $build = Test::Run::Builder->new( + module_name => "File::Find::Object::Rule", + license => 'perl', + script_files => [ 'scripts/findorule' ], + configure_requires => { + 'Module::Build' => '0.36', + }, + requires => { + 'Carp' => 0, + 'Class::XSAccessor' => 0, + 'Cwd' => 0, + 'File::Basename' => 0, + 'File::Find::Object' => '0.2.1', + 'File::Spec' => 0, + 'Number::Compare' => 0, + 'perl' => '5.008', + 'strict' => 0, + 'Text::Glob' => 0, + 'vars' => 0, + 'warnings' => 0, + }, + build_requires => { + 'Test::More' => 0, + }, + meta_merge => + { + resources => + { + repository => "http://bitbucket.org/shlomif/perl-file-find-object-rule", + homepage => "http://www.shlomifish.org/open-source/projects/File-Find-Object/", + }, + keywords => + [ + "directories", + "directory", + "directory-traversal", + "directory-tree", + "file", + "file-find-rule", + "find", + "instance", + "instantiated", + "instantiation", + "interface", + "iterative", + "object", + "rule", + "traversal", + "tree", + "wrapper", + ], + }, + + ); + +$build->create_build_script; diff --git a/Changes b/Changes new file mode 100644 index 0000000..b7c7f07 --- /dev/null +++ b/Changes @@ -0,0 +1,187 @@ +Changes Log for File-Find-Object-Rule: +-------------------------------------- + +0.0306 Sun 11 Sep 15:58:23 IDT 2016 + - Made the trailing space tests AUTHOR_TESTING only. + - We received a report that there was a circular dependency on + Test::TrailingSpace and while this is not an issue and was caused by + the reporter's use-case (that was irrational in my opinion), this change + was done to avoid future reports like that. + +0.0305 Sun 18 May 14:10:09 IDT 2014 + - Made the tests succeed if run in parallel (e.g: + HARNESS_OPTIONS="j4:c" ). + +0.0304 Wed 29 Jan 13:24:04 IST 2014 + - Add a separate LICENSE file (CPANTS Kwalitee). + - Specify minimal version of Perl as 5.8.x (CPANTS Kwalitee). + +0.0303 Mon 27 May 17:52:15 IDT 2013 + - Remove trailing space. + - Remove Makefile.PL - use Build.PL from now on. + +0.0302 Tue 25 Dec 22:35:01 IST 2012 + - Update the repository URL. + - Link to the Path::Class::Rule overview of directory traversal + modules on the POD. + - The “Evil Reindeer Evil Christmas Evil Conspiracy” Release. ;-) + +0.0301 Mon Apr 23 10:31:45 IDT 2012 + - Made ->start() return itself. Bug was reported here: + - http://www.nntp.perl.org/group/perl.beginners/2012/04/msg120670.html + - it previously returned only 1. + - Add a test for ->start() for the next time. + +0.0300 Fri Jun 26 01:12:27 IDT 2009 + - Adapted the README to File-Find-Object-Rule. + - Added POD tests and got to full POD coverage. + - Converted many direct $self->{$field} accesses to Class::XSAccessor + accessors. + - Now ->start() and ->match() are iteration-enabled. + - ->start() no longer calls ->in() but the other way around, making + use of File::Find::Object's power. + - Added resources and keywords information to the Build.PL + - Updated lib/File/Find/Object/Rule/Extending.pod for + File-Find-Object-Rule . + +0.0200 Sun Mar 1 22:24:21 IST 2009 + - hopefully got rid of all UNIXisms (and incompatibilities with Win32), and + problems such as running when having temporary files (*~) in the test + files: + - now holding a pristine copy of the test tree under + ./t/sample-data/to-copy-from/ + and copying it and processing it using File::Find::Object::TreeCreate + which was borrowed from the File::Find::Object code. + - Converted all the paths constant to variables, which are generated + using $tree_creator->get_path(). + - Removed some non-portable assertions or ones that are hard to + reproduce with File::Spec. + - Added Test::Count annotations to the tests' code. + +0.0101 Sun Feb 22 14:29:06 IST 2009 + - fixed the dependencies in Build.PL (especially File::Find::Object) + - moved findrule to scripts/findorule + +0.0100 Wed Feb 18 17:09:01 IST 2009 + - first release on CPAN - a direct port of File-Find-Rule-0.30 + to File::Find::Object. + +ChangeLog for File-Find-Rule: +----------------------------- + +0.30 Wednesday 1st June, 2006 + Made './//././././///.//././/////./blah' be treated the same + as './blah' (it gets turned into 'blah') + +0.29 Tuesday 16th May, 2006 + Kludged around {min,max}depth and trailing slashes in path + names. + +0.28 Tuesday 18th May, 2004 + exposed %X_tests and @stat_tests as package variables, and make a + _call_find method for File::Find::Rule::Filesys::Virtual + +0.27 Wednesday 25th February, 2004 + Changed to write_makefile_pl to 'traditional' from + 'passthrough'. Fixes INDIRECTLY REPORTED install problems + caused by new Module::Build being backwards incompatible. + +0.26 Monday 10th November, 2003 + Typo/thinko in File::Find::Rule::Extending corrected (spotted + by Jim Cromie) + + Optimization to the stat-based tests. They now compile to code + fragments saving much subroutine dispatch. + +0.25 Wednesday 22nd October, 2003 + applied a patch from Leon Brocard to make the tests ignore CVS dirs + as well as .svn dirs. + + reworked part of t/File-Find-Rule.t to not assume that t/foobar will + always be 10 bytes in size. (rt.cpan.org #3838) + + now we install the findrule script + +0.24 Monday 6th October, 2003 + when you specify an extra of C<{ follow => 1 }> File::Find stops + populating $File::Find::topdir. This leads to warnings noise so + instead we now track $topdir ourselves. + +0.23 Friday 3rd October, 2003 + make the extras hash work and add a proper test for it. (Doh!) + +0.22 Friday 3rd October, 2003 + add in ->extras hash for passing things through to File::Find::find + +0.21 Monday 15th September, 2003 + pod glitch in File::Find::Rule::Procedural spotted and fixed + by Tom Hukins + +0.20 8th September, 2003 + - relative flag + + - Fix maxdepth? - this is undertested. + + - MANIFEST fixes (thanks to the cpan smokers) + + - split the documentation of the procedural interface out to + File::Find::Rule::Procedural, as people often seem to get + confused that the method calls don't take anonymous arrays + after seeing the procedural code that did + + - Chunky internal restructure. Now we compile a match sub + from code fragments. Though more complex, this is a big + speed win as it eliminates a lot of the subroutine dispatch. + + - During the restructure we lost the ->test method. I hope + that it's not missed, since maintining it through a + deprecation cycle would be fiddly with the current _compile code. + + - Split the findrule tests into their own file, and just skip + the tricky ones on Win32. + +0.11 29th July, 2003 + - Fix Win32 test failures (rt.cpan.org #3047) + +0.10 10th March 2003 + - fixup an accidental warning in the stat-based tests. Caught + by Alex Gough (rt.cpan.org #2138) + - make the findrule tests more win32 safe/shell independent (picked + up by Philip Newton) + - autogenerate READMEs from bits and pieces + +0.09 21st January 2003 + - Fix to the stat-based tests (spotted by Randal L. Schwartz) + - implemented our own import sub so we can bootstrap + extensions more easily + - added some documentation about using extensions. + +0.08 28th October, 2002 + - ->not_* and implicit s#^\./## (based on suggestions by Tony + Bowden) + - Sketchy first cut of findrule (suggestion from Tatsuhiko Miyagawa) + +0.07 25th October, 2002 + - Tweaks required to let extensions work + +0.06 22nd October, 2002 + -> Fix the code example for the ->grep clause (again from + Douglas Wilson) + +0.05 21st October, 2002 + - ->grep clause - from original code from Douglas Wilson + - Bugfix the demo code in the synopsis - pointed out by Barbie + +0.04 10th September, 2002 + - create a correctly spelled writable rule (thanks to Iain + Truskett for this one) + +0.03 24th August, 2002 + - backport to 5.00503 (hadn't tested before this point) + +0.02 14th August, 2002 + - bugfix ->exec subrule invocation (thanks to Chris Carline + for pointing this out) + +0.01 26th July, 2002 + - Inital release diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..0ba8d2b --- /dev/null +++ b/LICENSE @@ -0,0 +1,396 @@ +Terms of Perl 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" + +---------------------------------------------------------------------------- + + GNU GENERAL PUBLIC LICENSE + Version 2, June 1991 + + Copyright (C) 1989, 1991 Free Software Foundation, Inc., + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU 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. This +General Public License applies to most of the Free Software +Foundation's software and to any other program whose authors commit to +using it. (Some other Free Software Foundation software is covered by +the GNU Lesser General Public License instead.) You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +this service if you wish), 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 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 show them these terms so they know 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. + + Finally, any free program is threatened constantly by software +patents. We wish to avoid the danger that redistributors of a free +program will individually obtain patent licenses, in effect making the +program proprietary. To prevent this, we have made it clear that any +patent must be licensed for everyone's free use or not licensed at all. + + 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 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 derivative work under copyright law: +that is to say, a work containing the Program or a portion of it, +either verbatim or with modifications and/or translated into another +language. (Hereinafter, translation is included without limitation in +the term "modification".) Each licensee is addressed as "you". + +Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running the Program is not restricted, and the output from the Program +is covered only if its contents constitute a work based on the +Program (independent of having been made by running the Program). +Whether that is true depends on what the Program does. + + 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 License and to the absence of any warranty; +and give any other recipients of the Program a copy of this License +along with the Program. + +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. + + 2. You may modify your copy or copies of the Program or any portion +of it, thus forming a work based on the Program, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) You must cause the modified files to carry prominent notices + stating that you changed the files and the date of any change. + + b) You must cause any work that you distribute or publish, that in + whole or in part contains or is derived from the Program or any + part thereof, to be licensed as a whole at no charge to all third + parties under the terms of this License. + + c) If the modified program normally reads commands interactively + when run, you must cause it, when started running for such + interactive use in the most ordinary 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 + License. (Exception: if the Program itself is interactive but + does not normally print such an announcement, your work based on + the Program is not required to print an announcement.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Program, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Program, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Program. + +In addition, mere aggregation of another work not based on the Program +with the Program (or with a work based on the Program) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may copy and distribute the Program (or a work based on it, +under Section 2) in object code or executable form under the terms of +Sections 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 Sections + 1 and 2 above on a medium customarily used for software interchange; or, + + b) Accompany it with a written offer, valid for at least three + years, to give any third party, for a charge no more than your + cost of physically performing source distribution, a complete + machine-readable copy of the corresponding source code, to be + distributed under the terms of Sections 1 and 2 above on a medium + customarily used for software interchange; or, + + c) Accompany it with the information you received as to the offer + to distribute corresponding source code. (This alternative is + allowed only for noncommercial distribution and only if you + received the program in object code or executable form with such + an offer, in accord with Subsection b above.) + +The source code for a work means the preferred form of the work for +making modifications to it. For an executable work, complete source +code means all the source code for all modules it contains, plus any +associated interface definition files, plus the scripts used to +control compilation and installation of the executable. However, as a +special exception, the source code distributed need not include +anything that is normally distributed (in either source or binary +form) with the major components (compiler, kernel, and so on) of the +operating system on which the executable runs, unless that component +itself accompanies the executable. + +If distribution of executable or object code is made by offering +access to copy from a designated place, then offering equivalent +access to copy the source code from the same place counts as +distribution of the source code, even though third parties are not +compelled to copy the source along with the object code. + + 4. You may not copy, modify, sublicense, or distribute the Program +except as expressly provided under this License. Any attempt +otherwise to copy, modify, sublicense or distribute the Program is +void, and will automatically terminate your rights under this License. +However, parties who have received copies, or rights, from you under +this License will not have their licenses terminated so long as such +parties remain in full compliance. + + 5. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Program or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing 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 for copying, distributing or modifying +the Program or works based on it. + + 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. +You are not responsible for enforcing compliance by third parties to +this License. + + 7. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Program at all. For example, if a patent +license would not permit royalty-free redistribution of the Program by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Program. + +If any portion of this section is held invalid or unenforceable under +any particular circumstance, the balance of the section is intended to +apply and the section as a whole is intended to apply in other +circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system, which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 8. If the distribution and/or use of the Program is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Program under this License +may add an explicit geographical distribution limitation excluding +those countries, so that distribution is permitted only in or among +countries not thus excluded. In such case, this License incorporates +the limitation as if written in the body of this License. + + 9. 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 this 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 +this License, you may choose any version ever published by the Free Software +Foundation. + + 10. 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 + + 11. 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. + + 12. 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 + + +---------------------------------------------------------------------------- + +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..5ff4749 --- /dev/null +++ b/MANIFEST @@ -0,0 +1,25 @@ +Build.PL +Changes +inc/Test/Run/Builder.pm +lib/File/Find/Object/Rule/Extending.pod +lib/File/Find/Object/Rule.pm +lib/File/Find/Object/Rule/Procedural.pod +LICENSE +MANIFEST +META.yml +README +scripts/findorule +t/File-Find-Rule.t +t/findorule.t +t/foobar +t/lib/File/Find/Object/Rule/Test/ATeam.pm +t/lib/File/Find/Object/TreeCreate.pm +t/pod-coverage.t +t/pod.t +t/readme-pod.t +t/release-trailing-space.t +t/sample-data/to-copy-from/File-Find-Rule.t +t/sample-data/to-copy-from/findorule.t +t/sample-data/to-copy-from/foobar +t/sample-data/to-copy-from/lib/File/Find/Object/Rule/Test/ATeam.pm +META.json diff --git a/META.json b/META.json new file mode 100644 index 0000000..06ed1e1 --- /dev/null +++ b/META.json @@ -0,0 +1,82 @@ +{ + "abstract" : "Alternative interface to File::Find::Object", + "author" : [ + "Richard Clamp with input gained from this", + "and Andy Lester andy@petdance.com." + ], + "dynamic_config" : 1, + "generated_by" : "Module::Build version 0.4218", + "keywords" : [ + "directories", + "directory", + "directory-traversal", + "directory-tree", + "file", + "file-find-rule", + "find", + "instance", + "instantiated", + "instantiation", + "interface", + "iterative", + "object", + "rule", + "traversal", + "tree", + "wrapper" + ], + "license" : [ + "perl_5" + ], + "meta-spec" : { + "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", + "version" : "2" + }, + "name" : "File-Find-Object-Rule", + "prereqs" : { + "build" : { + "requires" : { + "Test::More" : "0" + } + }, + "configure" : { + "requires" : { + "Module::Build" : "0.36" + } + }, + "runtime" : { + "requires" : { + "Carp" : "0", + "Class::XSAccessor" : "0", + "Cwd" : "0", + "File::Basename" : "0", + "File::Find::Object" : "v0.2.1", + "File::Spec" : "0", + "Number::Compare" : "0", + "Text::Glob" : "0", + "perl" : "5.008", + "strict" : "0", + "vars" : "0", + "warnings" : "0" + } + } + }, + "provides" : { + "File::Find::Object::Rule" : { + "file" : "lib/File/Find/Object/Rule.pm", + "version" : "0.0306" + } + }, + "release_status" : "stable", + "resources" : { + "homepage" : "http://www.shlomifish.org/open-source/projects/File-Find-Object/", + "license" : [ + "http://dev.perl.org/licenses/" + ], + "repository" : { + "url" : "http://bitbucket.org/shlomif/perl-file-find-object-rule" + } + }, + "version" : "0.0306", + "x_serialization_backend" : "JSON::PP version 2.27300" +} diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..7fbe208 --- /dev/null +++ b/META.yml @@ -0,0 +1,57 @@ +--- +abstract: 'Alternative interface to File::Find::Object' +author: + - 'Richard Clamp with input gained from this' + - 'and Andy Lester andy@petdance.com.' +build_requires: + Test::More: '0' +configure_requires: + Module::Build: '0.36' +dynamic_config: 1 +generated_by: 'Module::Build version 0.4218, CPAN::Meta::Converter version 2.150005' +keywords: + - directories + - directory + - directory-traversal + - directory-tree + - file + - file-find-rule + - find + - instance + - instantiated + - instantiation + - interface + - iterative + - object + - rule + - traversal + - tree + - wrapper +license: perl +meta-spec: + url: http://module-build.sourceforge.net/META-spec-v1.4.html + version: '1.4' +name: File-Find-Object-Rule +provides: + File::Find::Object::Rule: + file: lib/File/Find/Object/Rule.pm + version: '0.0306' +requires: + Carp: '0' + Class::XSAccessor: '0' + Cwd: '0' + File::Basename: '0' + File::Find::Object: v0.2.1 + File::Spec: '0' + Number::Compare: '0' + Text::Glob: '0' + perl: '5.008' + strict: '0' + vars: '0' + warnings: '0' +resources: + homepage: http://www.shlomifish.org/open-source/projects/File-Find-Object/ + license: http://dev.perl.org/licenses/ + repository: http://bitbucket.org/shlomif/perl-file-find-object-rule +version: '0.0306' +x_serialization_backend: 'CPAN::Meta::YAML version 0.012' diff --git a/README b/README new file mode 100644 index 0000000..33a8ea1 --- /dev/null +++ b/README @@ -0,0 +1,75 @@ +README for File::Find::Object::Rule + +=head1 NAME + +File::Find::Object::Rule - Alternative interface to File::Find::Object + +=head1 SYNOPSIS + + use File::Find::Object::Rule; + # find all the subdirectories of a given directory + my @subdirs = File::Find::Object::Rule->directory->in( $directory ); + + # find all the .pm files in @INC + my @files = File::Find::Object::Rule->file() + ->name( '*.pm' ) + ->in( @INC ); + + # as above, but without method chaining + my $rule = File::Find::Object::Rule->new; + $rule->file; + $rule->name( '*.pm' ); + my @files = $rule->in( @INC ); + + +=head1 DEPENDENCIES + +This module has external dependencies on the following modules: + + Cwd + File::Find::Object + File::Spec + Number::Compare + Test::More + Text::Glob + +=head1 INSTALLATION + + perl Build.PL + perl Build test + +and if all goes well + + perl Build install + +=head1 AUTHOR + +=head2 File::Find::Rule + +Richard Clamp with input gained from this +use.perl discussion: http://use.perl.org/~richardc/journal/6467 + +Additional proofreading and input provided by Kake, Greg McCarroll, +and Andy Lester andy@petdance.com. + +=head2 File::Find::Object::Rule + +Shlomi Fish converted the code to use L instead. All +copyrights disclaimed. + +=head1 COPYRIGHT + +Copyright (C) 2002, 2003, 2004, 2006 Richard Clamp. All Rights Reserved. + +This module is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +=head1 SEE ALSO + +L, L, L, +L, find(1) + +If you want to know about the procedural interface, see +L, and if you have an idea for a neat +extension L + diff --git a/inc/Test/Run/Builder.pm b/inc/Test/Run/Builder.pm new file mode 100644 index 0000000..504490b --- /dev/null +++ b/inc/Test/Run/Builder.pm @@ -0,0 +1,76 @@ +package Test::Run::Builder; + +use strict; +use warnings; + +use Module::Build; + +use vars qw(@ISA); + +@ISA = (qw(Module::Build)); + +sub ACTION_runtest +{ + my ($self) = @_; + my $p = $self->{properties}; + + $self->depends_on('code'); + + local @INC = @INC; + + # Make sure we test the module in blib/ + unshift @INC, (File::Spec->catdir($p->{base_dir}, $self->blib, 'lib'), + File::Spec->catdir($p->{base_dir}, $self->blib, 'arch')); + + $self->do_test_run_tests; +} + +sub ACTION_distruntest { + my ($self) = @_; + + $self->depends_on('distdir'); + + my $start_dir = $self->cwd; + my $dist_dir = $self->dist_dir; + chdir $dist_dir or die "Cannot chdir to $dist_dir: $!"; + # XXX could be different names for scripts + + $self->run_perl_script('Build.PL') # XXX Should this be run w/ --nouse-rcfile + or die "Error executing 'Build.PL' in dist directory: $!"; + $self->run_perl_script('Build') + or die "Error executing 'Build' in dist directory: $!"; + $self->run_perl_script('Build', [], ['runtest']) + or die "Error executing 'Build test' in dist directory"; + chdir $start_dir; +} + +sub do_test_run_tests +{ + my $self = shift; + + require Test::Run::CmdLine::Iface; + + my $test_run = + Test::Run::CmdLine::Iface->new( + { + 'test_files' => [glob("t/*.t")], + } + # 'backend_params' => $self->_get_backend_params(), + ); + + return $test_run->run(); +} + +sub ACTION_tags +{ + return + system(qw( + ctags -f tags --recurse --totals + --exclude=blib/ --exclude=t/lib + --exclude=.svn --exclude='*~' + --languages=Perl --langmap=Perl:+.t + )); +} + +1; + diff --git a/lib/File/Find/Object/Rule.pm b/lib/File/Find/Object/Rule.pm new file mode 100644 index 0000000..bd877f2 --- /dev/null +++ b/lib/File/Find/Object/Rule.pm @@ -0,0 +1,1093 @@ +# $Id: /mirror/lab/perl/File-Find-Rule/lib/File/Find/Rule.pm 2102 2006-06-01T15:39:03.942922Z richardc $ + +package File::Find::Object::Rule; + +use strict; +use warnings; + +use 5.008; + +use vars qw/$VERSION $AUTOLOAD/; +use File::Spec; +use Text::Glob 'glob_to_regex'; +use Number::Compare; +use Carp qw/croak/; +use File::Find::Object; # we're only wrapping for now +use File::Basename; +use Cwd; # 5.00503s File::Find goes screwy with max_depth == 0 + +$VERSION = '0.0306'; + +use Class::XSAccessor + accessors => { + "extras" => "extras", + "finder" => "finder", + "_match_cb" => "_match_cb", + "rules" => "rules", + "_relative" => "_relative", + "_subs" => "_subs", + "_maxdepth" => "_maxdepth", + "_mindepth" => "_mindepth", + } + ; + +# we'd just inherit from Exporter, but I want the colon +sub import { + my $pkg = shift; + my $to = caller; + for my $sym ( qw( find rule ) ) { + no strict 'refs'; + *{"$to\::$sym"} = \&{$sym}; + } + for (grep /^:/, @_) { + my ($extension) = /^:(.*)/; + eval "require File::Find::Object::Rule::$extension"; + croak "couldn't bootstrap File::Find::Object::Rule::$extension: $@" if $@; + } +} + +=encoding utf8 + +=head1 NAME + +File::Find::Object::Rule - Alternative interface to File::Find::Object + +=head1 SYNOPSIS + + use File::Find::Object::Rule; + # find all the subdirectories of a given directory + my @subdirs = File::Find::Object::Rule->directory->in( $directory ); + + # find all the .pm files in @INC + my @files = File::Find::Object::Rule->file() + ->name( '*.pm' ) + ->in( @INC ); + + # as above, but without method chaining + my $rule = File::Find::Object::Rule->new; + $rule->file; + $rule->name( '*.pm' ); + my @files = $rule->in( @INC ); + +=head1 DESCRIPTION + +File::Find::Object::Rule is a friendlier interface to L . +It allows you to build rules which specify the desired files and directories. + +B : This module is a fork of version 0.30 of L +(which has been unmaintained for several years as of February, 2009), and may +still have some bugs due to its reliance on File::Find'isms. As such it is +considered Alpha software. Please report any problems with +L to its RT CPAN Queue. + +=cut + +# the procedural shim + +*rule = \&find; +sub find { + my $object = __PACKAGE__->new(); + my $not = 0; + + while (@_) { + my $method = shift; + my @args; + + if ($method =~ s/^\!//) { + # jinkies, we're really negating this + unshift @_, $method; + $not = 1; + next; + } + unless (defined prototype $method) { + my $args = shift; + @args = ref $args eq 'ARRAY' ? @$args : $args; + } + if ($not) { + $not = 0; + @args = ref($object)->new->$method(@args); + $method = "not"; + } + + my @return = $object->$method(@args); + return @return if $method eq 'in'; + } + $object; +} + + +=head1 METHODS + +=over + +=item C + +A constructor. You need not invoke C manually unless you wish +to, as each of the rule-making methods will auto-create a suitable +object if called as class methods. + +=cut + +sub new { + # We need this to maintain compatibility with File-Find-Object. + # However, Randal Schwartz recommends against this practice in general: + # http://www.stonehenge.com/merlyn/UnixReview/col52.html + my $referent = shift; + my $class = ref $referent || $referent; + + return + bless { + rules => [], # [0] + _subs => [], # [1] + iterator => [], + extras => {}, + _maxdepth => undef, + _mindepth => undef, + _relative => 0, + }, $class; +} + +sub _force_object { + my $object = shift; + if (! ref($object)) + { + $object = $object->new(); + } + return $object; +} + +=back + +=head2 finder + +The L finder instance itself. + +=head2 my @rules = @{$ffor->rules()}; + +The rules to match against. For internal use only. + +=head2 Matching Rules + +=over + +=item C + +Specifies names that should match. May be globs or regular +expressions. + + $set->name( '*.mp3', '*.ogg' ); # mp3s or oggs + $set->name( qr/\.(mp3|ogg)$/ ); # the same as a regex + $set->name( 'foo.bar' ); # just things named foo.bar + +=cut + +sub _flatten { + my @flat; + while (@_) { + my $item = shift; + ref $item eq 'ARRAY' ? push @_, @{ $item } : push @flat, $item; + } + return @flat; +} + +sub _add_rule { + my $self = shift; + my $new_rule = shift; + + push @{$self->rules()}, $new_rule; + + return; +} + +sub name { + my $self = _force_object shift; + my @names = map { ref $_ eq "Regexp" ? $_ : glob_to_regex $_ } _flatten( @_ ); + + $self->_add_rule( + { + rule => 'name', + code => join( ' || ', map { "m($_)" } @names ), + args => \@_, + } + ); + + $self; +} + +=item -X tests + +Synonyms are provided for each of the -X tests. See L for +details. None of these methods take arguments. + + Test | Method Test | Method + ------|------------- ------|---------------- + -r | readable -R | r_readable + -w | writeable -W | r_writeable + -w | writable -W | r_writable + -x | executable -X | r_executable + -o | owned -O | r_owned + | | + -e | exists -f | file + -z | empty -d | directory + -s | nonempty -l | symlink + | -p | fifo + -u | setuid -S | socket + -g | setgid -b | block + -k | sticky -c | character + | -t | tty + -M | modified | + -A | accessed -T | ascii + -C | changed -B | binary + +Though some tests are fairly meaningless as binary flags (C, +C, C), they have been included for completeness. + + # find nonempty files + $rule->file, + ->nonempty; + +=cut + +use vars qw( %X_tests ); +%X_tests = ( + -r => readable => -R => r_readable => + -w => writeable => -W => r_writeable => + -w => writable => -W => r_writable => + -x => executable => -X => r_executable => + -o => owned => -O => r_owned => + + -e => exists => -f => file => + -z => empty => -d => directory => + -s => nonempty => -l => symlink => + => -p => fifo => + -u => setuid => -S => socket => + -g => setgid => -b => block => + -k => sticky => -c => character => + => -t => tty => + -M => modified => + -A => accessed => -T => ascii => + -C => changed => -B => binary => + ); + +for my $test (keys %X_tests) { + my $sub = eval 'sub () { + my $self = _force_object shift; + $self->_add_rule({ + code => "' . $test . ' \$path", + rule => "'.$X_tests{$test}.'", + }); + $self; + } '; + no strict 'refs'; + *{ $X_tests{$test} } = $sub; +} + + +=item stat tests + +The following C based methods are provided: C, C, +C, C, C, C, C, C, C, +C, C, C, and C. See L +for details. + +Each of these can take a number of targets, which will follow +L semantics. + + $rule->size( 7 ); # exactly 7 + $rule->size( ">7Ki" ); # larger than 7 * 1024 * 1024 bytes + $rule->size( ">=7" ) + ->size( "<=90" ); # between 7 and 90, inclusive + $rule->size( 7, 9, 42 ); # 7, 9 or 42 + +=cut + +use vars qw( @stat_tests ); +@stat_tests = qw( dev ino mode nlink uid gid rdev + size atime mtime ctime blksize blocks ); +{ + my $i = 0; + for my $test (@stat_tests) { + my $index = $i++; # to close over + my $sub = sub { + my $self = _force_object shift; + + my @tests = map { Number::Compare->parse_to_perl($_) } @_; + + $self->_add_rule({ + rule => $test, + args => \@_, + code => 'do { my $val = (stat $path)['.$index.'] || 0;'. + join ('||', map { "(\$val $_)" } @tests ).' }', + }); + $self; + }; + no strict 'refs'; + *$test = $sub; + } +} + +=item C + +=item C + +Allows shortcircuiting boolean evaluation as an alternative to the +default and-like nature of combined rules. C and C are +interchangeable. + + # find avis, movs, things over 200M and empty files + $rule->any( File::Find::Object::Rule->name( '*.avi', '*.mov' ), + File::Find::Object::Rule->size( '>200M' ), + File::Find::Object::Rule->file->empty, + ); + +=cut + +sub any { + my $self = _force_object shift; + my @rulesets = @_; + + $self->_add_rule({ + rule => 'any', + code => '(' . join( ' || ', map { + "( " . $_->_compile($self->_subs()) . " )" + } @rulesets ) . ")", + args => \@rulesets, + }); + $self; +} + +*or = \&any; + +=item C + +=item C + +Negates a rule. (The inverse of C.) C and C are +interchangeable. + + # files that aren't 8.3 safe + $rule->file + ->not( $rule->new->name( qr/^[^.]{1,8}(\.[^.]{0,3})?$/ ) ); + +=cut + +sub not { + my $self = _force_object shift; + my @rulesets = @_; + + $self->_add_rule({ + rule => 'not', + args => \@rulesets, + code => '(' . join ( ' && ', map { + "!(". $_->_compile($self->_subs()) . ")" + } @_ ) . ")", + }); + $self; +} + +*none = \¬ + +=item C + +Traverse no further. This rule always matches. + +=cut + +sub prune () { + my $self = _force_object shift; + + $self->_add_rule( + { + rule => 'prune', + code => 'do { $self->finder->prune(); 1 }' + }, + ); + + return $self; +} + +=item C + +Don't keep this file. This rule always matches. + +=cut + +sub discard () { + my $self = _force_object shift; + + $self->_add_rule({ + rule => 'discard', + code => '$discarded = 1', + }); + + return $self; +} + +=item C + +Allows user-defined rules. Your subroutine will be invoked with parameters of +the name, the path you're in, and the full relative filename. +In addition, C<$_> is set to the current short name, but its use is +discouraged since as opposed to File::Find::Rule, File::Find::Object::Rule +does not cd to the containing directory. + +Return a true value if your rule matched. + + # get things with long names + $rules->exec( sub { length > 20 } ); + +=cut + +sub exec { + my $self = _force_object shift; + my $code = shift; + + $self->_add_rule( + { + rule => 'exec', + code => $code, + } + ); + + return $self; +} + +=item ->grep( @specifiers ); + +Opens a file and tests it each line at a time. + +For each line it evaluates each of the specifiers, stopping at the +first successful match. A specifier may be a regular expression or a +subroutine. The subroutine will be invoked with the same parameters +as an ->exec subroutine. + +It is possible to provide a set of negative specifiers by enclosing +them in anonymous arrays. Should a negative specifier match the +iteration is aborted and the clause is failed. For example: + + $rule->grep( qr/^#!.*\bperl/, [ sub { 1 } ] ); + +Is a passing clause if the first line of a file looks like a perl +shebang line. + +=cut + +sub grep { + my $self = _force_object shift; + my @pattern = map { + ref $_ + ? ref $_ eq 'ARRAY' + ? map { [ ( ref $_ ? $_ : qr/$_/ ) => 0 ] } @$_ + : [ $_ => 1 ] + : [ qr/$_/ => 1 ] + } @_; + + $self->exec( sub { + local *FILE; + open FILE, $self->finder->item() or return; + local ($_, $.); + while () { + for my $p (@pattern) { + my ($rule, $ret) = @$p; + return $ret + if ref $rule eq 'Regexp' + ? /$rule/ + : $rule->(@_); + } + } + return; + } ); +} + +=item C + +Descend at most C<$level> (a non-negative integer) levels of directories +below the starting point. + +May be invoked many times per rule, but only the most recent value is +used. + +=item C + +Do not apply any tests at levels less than C<$level> (a non-negative +integer). + +=item C + +Specifies extra values to pass through to C as part +of the options hash. + +For example this allows you to specify following of symlinks like so: + + my $rule = File::Find::Object::Rule->extras({ follow => 1 }); + +May be invoked many times per rule, but only the most recent value is +used. + +=cut + +sub maxdepth { + my $self = _force_object shift; + $self->_maxdepth(shift); + return $self; +} + +sub mindepth { + my $self = _force_object shift; + $self->_mindepth(shift); + return $self; +} + +=item C + +Trim the leading portion of any path found + +=cut + +sub relative () { + my $self = _force_object shift; + $self->_relative(1); + + return $self; +} + +=item C + +Negated version of the rule. An effective shortand related to ! in +the procedural interface. + + $foo->not_name('*.pl'); + + $foo->not( $foo->new->name('*.pl' ) ); + +=cut + +sub DESTROY {} +sub AUTOLOAD { + $AUTOLOAD =~ /::not_([^:]*)$/ + or croak "Can't locate method $AUTOLOAD"; + my $method = $1; + + my $sub = sub { + my $self = _force_object shift; + $self->not( $self->new->$method(@_) ); + }; + { + no strict 'refs'; + *$AUTOLOAD = $sub; + } + &$sub; +} + +=back + +=head2 Query Methods + +=over + +=item C + +Evaluates the rule, returns a list of paths to matching files and +directories. + +=cut + + +sub _call_find { + my $self = shift; + my $paths = shift; + + my $finder = File::Find::Object->new( $self->extras(), @$paths); + + $self->finder($finder); + + return; +} + +sub _compile { + my $self = shift; + my $subs = shift; + + return '1' unless @{ $self->rules() }; + + my $code = join " && ", map { + if (ref $_->{code}) { + push @$subs, $_->{code}; + "\$subs->[$#{$subs}]->(\@args) # $_->{rule}\n"; + } + else { + "( $_->{code} ) # $_->{rule}\n"; + } + } @{ $self->rules() }; + + return $code; +} + +sub in { + my $self = _force_object shift; + my @paths = @_; + + $self->start(@paths); + + my @results; + + while (defined(my $match = $self->match())) + { + push @results, $match; + } + + return @results; +} + +=item C + +Starts a find across the specified directories. Matching items may +then be queried using L. This allows you to use a rule as an +iterator. + + my $rule = File::Find::Object::Rule->file->name("*.jpeg")->start( "/web" ); + while ( my $image = $rule->match ) { + ... + } + +=cut + + +sub start { + my $self = _force_object shift; + my @paths = @_; + + my $fragment = $self->_compile($self->_subs()); + + my $subs = $self->_subs(); + + warn "relative mode handed multiple paths - that's a bit silly\n" + if $self->_relative() && @paths > 1; + + my $code = 'sub { + my $path_obj = shift; + my $path = shift; + + if (!defined($path_obj)) + { + return; + } + + $path =~ s#^(?:\./+)+##; + my $path_dir = dirname($path); + my $path_base = fileparse($path); + my @args = ($path_base, $path_dir, $path); + local $_ = $path_base; + my $maxdepth = $self->_maxdepth; + my $mindepth = $self->_mindepth; + + my $comps = $path_obj->full_components(); + + my $depth = scalar(@$comps); + + defined $maxdepth && $depth >= $maxdepth + and $self->finder->prune(); + + defined $mindepth && $depth < $mindepth + and return; + + #print "Testing \'$_\'\n"; + + my $discarded; + return unless ' . $fragment . '; + return if $discarded; + return $path; + }'; + + #use Data::Dumper; + #print Dumper \@subs; + #warn "Compiled sub: '$code'\n"; + + my $callback = eval "$code" or die "compile error '$code' $@"; + + $self->_match_cb($callback); + $self->_call_find(\@paths); + + return $self; +} + + +=item C + +Returns the next file which matches, false if there are no more. + +=cut + +sub match { + my $self = _force_object shift; + + my $finder = $self->finder(); + + my $match_cb = $self->_match_cb(); + my $preproc_cb = $self->extras()->{'preprocess'}; + + while(defined(my $next_obj = $finder->next_obj())) + { + if (defined($preproc_cb) && $next_obj->is_dir()) + { + $finder->set_traverse_to( + $preproc_cb->( + $self, + [ @{$finder->get_current_node_files_list()} ] + ) + ); + } + + if (defined(my $path = $match_cb->($next_obj, $next_obj->path()))) + { + if ($self->_relative) + { + my $comps = $next_obj->full_components(); + if (@$comps) + { + return + ($next_obj->is_dir() + ? File::Spec->catdir(@$comps) + : File::Spec->catfile(@$comps) + ) + ; + } + } + else + { + return $path; + } + } + + } + + return; +} + +1; + +__END__ + +=back + +=head2 Extensions + +Extension modules are available from CPAN in the File::Find::Object::Rule +namespace. In order to use these extensions either use them directly: + + use File::Find::Object::Rule::ImageSize; + use File::Find::Object::Rule::MMagic; + + # now your rules can use the clauses supplied by the ImageSize and + # MMagic extension + +or, specify that File::Find::Object::Rule should load them for you: + + use File::Find::Object::Rule qw( :ImageSize :MMagic ); + +For notes on implementing your own extensions, consult +L + +=head2 Further examples + +=over + +=item Finding perl scripts + + my $finder = File::Find::Object::Rule->or + ( + File::Find::Object::Rule->name( '*.pl' ), + File::Find::Object::Rule->exec( + sub { + if (open my $fh, $_) { + my $shebang = <$fh>; + close $fh; + return $shebang =~ /^#!.*\bperl/; + } + return 0; + } ), + ); + +Based upon this message http://use.perl.org/comments.pl?sid=7052&cid=10842 + +=item ignore CVS directories + + my $rule = File::Find::Object::Rule->new; + $rule->or($rule->new + ->directory + ->name('CVS') + ->prune + ->discard, + $rule->new); + +Note here the use of a null rule. Null rules match anything they see, +so the effect is to match (and discard) directories called 'CVS' or to +match anything. + +=back + +=head1 TWO FOR THE PRICE OF ONE + +File::Find::Object::Rule also gives you a procedural interface. This is +documented in L + +=head1 EXPORTS + +=head2 find + +=head2 rule + +=head1 Tests + +=head2 accessed + +Corresponds to C<-A>. + +=head2 ascii + +Corresponds to C<-T>. + +=head2 atime + +See "stat tests". + +=head2 binary + +Corresponds to C<-b>. + +=head2 blksize + +See "stat tests". + +=head2 block + +Corresponds to C<-b>. + +=head2 blocks + +See "stat tests". + +=head2 changed + +Corresponds to C<-C>. + +=head2 character + +Corresponds to C<-c>. + +=head2 ctime + +See "stat tests". + +=head2 dev + +See "stat tests". + +=head2 directory + +Corresponds to C<-d>. + +=head2 empty + +Corresponds to C<-z>. + +=head2 executable + +Corresponds to C<-x>. + +=head2 exists + +Corresponds to C<-e>. + +=head2 fifo + +Corresponds to C<-p>. + +=head2 file + +Corresponds to C<-f>. + +=head2 gid + +See "stat tests". + +=head2 ino + +See "stat tests". + +=head2 mode + +See "stat tests". + +=head2 modified + +Corresponds to C<-M>. + +=head2 mtime + +See "stat tests". + +=head2 nlink + +See "stat tests". + +=head2 r_executable + +Corresponds to C<-X>. + +=head2 r_owned + +Corresponds to C<-O>. + +=head2 nonempty + +A predicate that determines if the file is empty. Uses C<-s>. + +=head2 owned + +Corresponds to C<-o>. + +=head2 r_readable + +Corresponds to C<-R>. + +=head2 r_writeable + +=head2 r_writable + +Corresponds to C<-W>. + +=head2 rdev + +See "stat tests". + +=head2 readable + +Corresponds to C<-r>. + +=head2 setgid + +Corresponds to C<-g>. + +=head2 setuid + +Corresponds to C<-u>. + +=head2 size + +See stat tests. + +=head2 socket + +Corresponds to C<-S>. + +=head2 sticky + +Corresponds to C<-k>. + +=head2 symlink + +Corresponds to C<-l>. + +=head2 uid + +See "stat tests". + +=head2 tty + +Corresponds to C<-t>. + +=head2 writable() + +Corresponds to C<-w>. + +=head1 BUGS + +The code relies on qr// compiled regexes, therefore this module +requires perl version 5.005_03 or newer. + +Currently it isn't possible to remove a clause from a rule object. If +this becomes a significant issue it will be addressed. + +=head1 AUTHOR + +Richard Clamp with input gained from this +use.perl discussion: http://use.perl.org/~richardc/journal/6467 + +Additional proofreading and input provided by Kake, Greg McCarroll, +and Andy Lester andy@petdance.com. + +Ported to use L as File::Find::Object::Rule by +Shlomi Fish. + +=head1 COPYRIGHT + +Copyright (C) 2002, 2003, 2004, 2006 Richard Clamp. All Rights Reserved. + +This module is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +=head1 SEE ALSO + +L, L, L, find(1) + +If you want to know about the procedural interface, see +L, and if you have an idea for a neat +extension, see L . + +L ’s SEE ALSO contains a review of many directory traversal +modules on CPAN, including L and L +(on which this module is based). + +=head1 KNOWN BUGS + +The tests don't run successfully when directly inside an old Subversion +checkout, due to the presence of C<.svn> directories. C<./Build disttest> or +C<./Build distruntest> run fine. + +=cut + +=begin Developers + +Implementation notes: + +[0] Currently we use an array of anonymous subs, and call those +repeatedly from match. It'll probably be way more effecient to +instead eval-string compile a dedicated matching sub, and call that to +avoid the repeated sub dispatch. + +[1] Though [0] isn't as true as it once was, I'm not sure that the +subs stack is exposed in quite the right way. Maybe it'd be better as +a private global hash. Something like $subs{$self} = []; and in +C, delete $subs{$self}. + +That'd make compiling subrules really much easier (no need to pass +@subs in for context), and things that work via a mix of callbacks and +code fragments are possible (you'd probably want this for the stat +tests). + +Need to check this currently working version in before I play with +that though. + +[*] There's probably a win to be made with the current model in making +stat calls use C<_>. For + + find( file => size => "> 20M" => size => "< 400M" ); + +up to 3 stats will happen for each candidate. Adding a priming _ +would be a bit blind if the first operation was C< name => 'foo' >, +since that can be tested by a single regex. Simply checking what the +next type of operation doesn't work since any arbritary exec sub may +or may not stat. Potentially worse, they could stat something else +like so: + + # extract from the worlds stupidest make(1) + find( exec => sub { my $f = $_; $f =~ s/\.c$/.o/ && !-e $f } ); + +Maybe the best way is to treat C<_> as invalid after calling an exec, +and doc that C<_> will only be meaningful after stat and -X tests if +they're wanted in exec blocks. + +=end Developers + +=cut diff --git a/lib/File/Find/Object/Rule/Extending.pod b/lib/File/Find/Object/Rule/Extending.pod new file mode 100644 index 0000000..4510361 --- /dev/null +++ b/lib/File/Find/Object/Rule/Extending.pod @@ -0,0 +1,94 @@ +=head1 NAME + +File::Find::Object::Rule::Extending - the mini-guide to extending File::Find::Object::Rule + +=head1 SYNOPSIS + + package File::Find::Object::Rule::Random; + + use strict; + use warnings; + + # take useful things from File::Find::Object::Rule + use base 'File::Find::Object::Rule'; + + # and force our crack into the main namespace + sub File::Find::Object::Rule::random () { + my $self = shift()->_force_object; + $self->exec( sub { rand > 0.5 } ); + } + + 1; + +=head1 DESCRIPTION + +L inherits L's extensibility. It +is now possibile to extend it, using the following conventions. + +=head2 Declare your package + + package File::Find::Object::Rule::Random; + + use strict; + use warnings; + +=head2 Inherit methods from File::Find::Object::Rule + + # take useful things from File::Find::Object::Rule + use base 'File::Find::Object::Rule'; + +=head3 Force your madness into the main package + + # and force our crack into the main namespace + sub File::Find::Object::Rule::random () { + my $self = shift()->_force_object; + $self->exec( sub { rand > 0.5 } ); + } + +Yes, we're being very cavalier here and defining things into the main +File::Find::Object::Rule namespace. This is due to lack of imaginiation on my +part - I simply can't find a way for the functional and oo interface +to work without doing this or some kind of inheritance, and +inheritance stops you using two File::Find::Object::Rule::Foo modules +together. + +For this reason try and pick distinct names for your extensions. If +this becomes a problem then I may institute a semi-official registry +of taken names. + +=head2 Taking no arguments. + +Note the null prototype on random. This is a cheat for the procedural +interface to know that your sub takes no arguments, and so allows this +to happen: + + find( random => in => '.' ); + +If you hadn't declared C with a null prototype it would have +consumed C as a parameter to it, then got all confused as it +doesn't know about a C<'.'> rule. + +=head1 NOTES ABOUT THE CALLBACK + +The callback can access the L using +C<<< $self->finder->item_obj() >>>. + +=head1 AUTHOR + +Richard Clamp + +=head1 COPYRIGHT + +Copyright (C) 2002 Richard Clamp. All Rights Reserved. + +This module is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +=head1 SEE ALSO + +L + +L was the first extension module for +L, so maybe check that out. + +=cut diff --git a/lib/File/Find/Object/Rule/Procedural.pod b/lib/File/Find/Object/Rule/Procedural.pod new file mode 100644 index 0000000..3b0636a --- /dev/null +++ b/lib/File/Find/Object/Rule/Procedural.pod @@ -0,0 +1,72 @@ +=head1 NAME + +File::Find::Object::Rule::Procedural - File::Find::Object::Rule's procedural interface + +=head1 SYNOPSIS + + use File::Find::Object::Rule; + + # find all .pm files, procedurally + my @files = find(file => name => '*.pm', in => \@INC); + +=head1 DESCRIPTION + +In addition to the regular object-oriented interface, +L provides two subroutines for you to use. + +=over + +=item C + +=item C + +C and C can be used to invoke any methods available to the +OO version. C is a synonym for C + +=back + +Passing more than one value to a clause is done with an anonymous +array: + + my $finder = find( name => [ '*.mp3', '*.ogg' ] ); + +C and C both return a File::Find::Object::Rule instance, unless +one of the arguments is C, in which case it returns a list of +things that match the rule. + + my @files = find( name => [ '*.mp3', '*.ogg' ], in => $ENV{HOME} ); + +Please note that C will be the last clause evaluated, and so this +code will search for mp3s regardless of size. + + my @files = find( name => '*.mp3', in => $ENV{HOME}, size => '<2k' ); + ^ + | + Clause processing stopped here ------/ + +It is also possible to invert a single rule by prefixing it with C +like so: + + # large files that aren't videos + my @files = find( file => + '!name' => [ '*.avi', '*.mov' ], + size => '>20M', + in => $ENV{HOME} ); + + +=head1 AUTHOR + +Richard Clamp + +=head1 COPYRIGHT + +Copyright (C) 2003 Richard Clamp. All Rights Reserved. + +This module is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +=head1 SEE ALSO + +L + +=cut diff --git a/scripts/findorule b/scripts/findorule new file mode 100644 index 0000000..f973fbf --- /dev/null +++ b/scripts/findorule @@ -0,0 +1,141 @@ +#!perl -w +use strict; +use File::Find::Object::Rule; +use File::Spec::Functions qw(catdir); + +# bootstrap extensions +for (@INC) { + my $dir = catdir($_, qw( File Find Rule ) ); + next unless -d $dir; + my @pm = find( name => '*.pm', maxdepth => 1, + exec => sub { my $name = $_[0]; $name =~ s/\.pm$//; + eval "require File::Find::Object::Rule::$name"; }, + in => $dir ); +} + +# what directories are we searching in? +my @where; +while (@ARGV) { + local $_ = shift @ARGV; + if (/^-/) { + unshift @ARGV, $_; + last; + } + push @where, $_; +} + +# parse arguments, build a rule object +my $rule = new File::Find::Object::Rule; +while (@ARGV) { + my $clause = shift @ARGV; + + unless ( $clause =~ s/^-// && $rule->can( $clause ) ) { + # not a known rule - complain about this + die "unknown option '$clause'\n" + } + + # it was the last switch + unless (@ARGV) { + $rule->$clause(); + next; + } + + # consume the parameters + my $param = shift @ARGV; + + if ($param =~ /^-/) { + # it's the next switch - put it back, and add one with no params + unshift @ARGV, $param; + $rule->$clause(); + next; + } + + if ($param eq '(') { + # multiple values - just look for the closing parenthesis + my @p; + while (@ARGV) { + my $val = shift @ARGV; + last if $val eq ')'; + push @p, $val; + } + $rule->$clause( @p ); + next; + } + + # a single argument + $rule->$clause( $param ); +} + +# add a print rule so things happen faster +$rule->exec( sub { print "$_[2]\n"; return; } ); + +# profit +$rule->in( @where ? @where : '.' ); +exit 0; + +__END__ + +=head1 NAME + +findorule - command line wrapper to File::Find::Object::Rule + +=head1 USAGE + + findorule [path...] [expression] + +=head1 DESCRIPTION + +C mostly borrows the interface from GNU find(1) to provide a +command-line interface onto the File::Find::Object::Rule heirarchy of modules. + +The syntax for expressions is the rule name, preceded by a dash, +followed by an optional argument. If the argument is an opening +parenthesis it is taken as a list of arguments, terminated by a +closing parenthesis. + +Some examples: + + find -file -name ( foo bar ) + +files named C or C, below the current directory. + + find -file -name foo -bar + +files named C, that have pubs (for this is what our ficticious +C clause specifies), below the current directory. + + find -file -name ( -bar ) + +files named C<-bar>, below the current directory. In this case if +we'd have omitted the parenthesis it would have parsed as a call to +name with no arguments, followed by a call to -bar. + +=head2 Supported switches + +I'm very slack. Please consult the File::Find::Object::Rule manpage for now, +and prepend - to the commands that you want. + +=head2 Extra bonus switches + +findorule automatically loads all of your installed File::Find::Object::Rule::* +extension modules, so check the documentation to see what those would be. + +=head1 AUTHOR + +Richard Clamp from a suggestion by Tatsuhiko Miyagawa + +Adapted to L by Shlomi Fish (all copyrights +disclaimed). + +=head1 COPYRIGHT + +Copyright (C) 2002 Richard Clamp. All Rights Reserved. + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +=head1 SEE ALSO + +L + +=cut diff --git a/t/File-Find-Rule.t b/t/File-Find-Rule.t new file mode 100644 index 0000000..0303362 --- /dev/null +++ b/t/File-Find-Rule.t @@ -0,0 +1,477 @@ +#!perl +# $Id: /mirror/lab/perl/File-Find-Rule/t/File-Find-Rule.t 2100 2006-05-28T16:06:50.725367Z richardc $ + +use strict; +use warnings; + +use Test::More tests => 42; + +use lib './t/lib'; + +use File::Find::Object::TreeCreate; + +use File::Path; + +my $tree_creator = File::Find::Object::TreeCreate->new(); + +{ + my $tree = + { + 'name' => "FFRt-to/", + 'subs' => + [ + { + 'name' => "File-Find-Rule.t", + 'contents' => $tree_creator->cat( + "./t/sample-data/to-copy-from/File-Find-Rule.t" + ), + }, + { + 'name' => "findorule.t", + 'contents' => $tree_creator->cat( + "./t/sample-data/to-copy-from/findorule.t" + ), + }, + { + 'name' => "foobar", + 'contents' => $tree_creator->cat( + "./t/sample-data/to-copy-from/foobar" + ), + + }, + { + 'name' => "lib/", + 'subs' => + [ + { + 'name' => "File/", + 'subs' => + [ + { + name => "Find/", + subs => + [ + { + name => "Object/", + subs => + [ + { + name => "Rule/", + subs => + [ + { + name => "Test/", + subs => + [ + { + name => "ATeam.pm", +content => $tree_creator->cat( + "./t/sample-data/to-copy-from/lib/File/Find/Object/Rule/Test/ATeam.pm" + +), +} + ], + }, + ], + } + ], + }, + ], + }, + ], + }, + ], + }, + ], + }; + + $tree_creator->create_tree("./t/sample-data/", $tree); +} + +my $class; +my $copy_fn = $tree_creator->get_path( + "./t/sample-data/FFRt-to/" +); + +my $lib_fn = $tree_creator->get_path( + "./t/sample-data/FFRt-to/lib/" +); + +my $FFR_t = $tree_creator->get_path( + "./t/sample-data/FFRt-to/File-Find-Rule.t" +); +my $findorule_t = $tree_creator->get_path( + "./t/sample-data/FFRt-to/findorule.t" +); +my $foobar_fn = $tree_creator->get_path( + "./t/sample-data/FFRt-to/foobar" +); + +my @tests = ($FFR_t, $findorule_t); + +my @ateam_path = + map { $tree_creator->get_path("./t/sample-data/FFRt-to/$_") } + qw( + lib + lib/File + lib/File/Find + lib/File/Find/Object + lib/File/Find/Object/Rule + lib/File/Find/Object/Rule/Test + lib/File/Find/Object/Rule/Test/ATeam.pm + ); + +my $ATeam_pm_fn = $ateam_path[-1]; + +BEGIN { + $class = 'File::Find::Object::Rule'; + # TEST + use_ok($class) +} + + +# on win32 systems the t/foobar file isn't 10 bytes it's 11, so the +# previous tests on the magic number 10 failed. rt.cpan.org #3838 +my $foobar_size = -s $foobar_fn; + +my $f = $class->new; +# TEST +isa_ok($f, $class); + +sub _run_find +{ + my $finder = shift; + return [ sort $finder->in($copy_fn) ]; +} + +# name +$f = $class->name( qr/\.t$/ ); +# TEST +is_deeply( _run_find($f), + [ @tests ], + "name( qr/\\.t\$/ )" ); + +{ + # This test that starts returns the rule object. + # See: http://www.nntp.perl.org/group/perl.beginners/2012/04/msg120670.html + my $rule = $class->name( qr/\.t$/ )->start($copy_fn); + + my @results; + while (my $item = $rule->match()) { + push @results, $item; + } + # TEST + is_deeply( + [ @results ], + [ @tests ], + "->start() Test." + ); +} + +$f = $class->name( 'foobar' ); +# TEST +is_deeply( _run_find($f), + [ $foobar_fn ], + "name( 'foobar' )" ); + +$f = $class->name( '*.t' ); +# TEST +is_deeply( _run_find($f), + \@tests, + "name( '*.t' )" ); + +$f = $class->name( 'foobar', '*.t' ); +# TEST +is_deeply( _run_find($f), + [ @tests, $foobar_fn ], + "name( 'foobar', '*.t' )" ); + +$f = $class->name( [ 'foobar', '*.t' ] ); +# TEST +is_deeply( _run_find($f), + [ @tests, $foobar_fn ], + "name( [ 'foobar', '*.t' ] )" ); + + + +# exec +$f = $class->exec(sub { length($_[0]) == 6 })->maxdepth(1); +# TEST +is_deeply( _run_find($f), + [ $foobar_fn ], + "exec (short)" ); + +$f = $class->exec(sub { length($_[0]) > $foobar_size })->maxdepth(1); +# TEST +is_deeply( _run_find($f), + [ $FFR_t ], + "exec (long)" ); + +# TEST +is_deeply( [ find( maxdepth => 1, exec => sub { $_[2] eq $foobar_fn }, in => $copy_fn ) ], + [ $foobar_fn ], + "exec (check arg 2)" ); + +# name and exec, chained +$f = $class + ->exec(sub { length > $foobar_size }) + ->name( qr/\.t$/ ); + +# TEST +is_deeply( _run_find($f), + [ $FFR_t ], + "exec(match) and name(match)" ); + +$f = $class + ->exec(sub { length > $foobar_size }) + ->name( qr/foo/ ) + ->maxdepth(1); + +# TEST +is_deeply( _run_find($f), + [ ], + "exec(match) and name(fail)" ); + + +# directory +$f = $class + ->directory + ->maxdepth(1) + ->exec(sub { $_ !~ /(\.svn|CVS)/ }); # ignore .svn/CVS dirs + +# TEST +is_deeply( _run_find($f), + [ $copy_fn,$lib_fn,], + "directory autostub" ); + + +# any/or +$f = $class->any( $class->exec( sub { length == 6 } ), + $class->name( qr/\.t$/ ) + ->exec( sub { length > $foobar_size } ) + )->maxdepth(1); + +# TEST +is_deeply( _run_find($f), + [ $FFR_t, $foobar_fn ], + "any" ); + +$f = $class->or( $class->exec( sub { length == 6 } ), + $class->name( qr/\.t$/ ) + ->exec( sub { length > $foobar_size } ) + )->maxdepth(1); + +# TEST +is_deeply( _run_find($f), + [ $FFR_t, $foobar_fn ], + "or" ); + + +# not/none +$f = $class + ->file + ->not( $class->name( qr/^[^.]{1,8}(\.[^.]{0,3})?$/ ) ) + ->maxdepth(1) + ->exec(sub { length == 6 || length > 11 }); +# TEST +is_deeply( _run_find($f), + [ $FFR_t ], + "not" ); + +# not as not_* +$f = $class + ->file + ->not_name( qr/^[^.]{1,8}(\.[^.]{0,3})?$/ ) + ->maxdepth(1) + ->exec(sub { length == 6 || length > 11 }); +# TEST +is_deeply( _run_find($f), + [ $FFR_t ], + "not_*" ); + +# prune/discard (.svn demo) +# this test may be a little meaningless for a cpan release, but it +# fires perfectly in my dev sandbox +$f = $class->or( $class->directory + ->name(qr/(\.svn|CVS)/) + ->prune + ->discard, + $class->new->file ); + +# TEST +is_deeply( _run_find($f), + [ @tests, $foobar_fn, $ATeam_pm_fn ], + "prune/discard .svn" + ); + + +# procedural form of the CVS demo +$f = find(or => [ find( directory => + name => qr/(\.svn|CVS)/, + prune => + discard => ), + find( file => ) ]); + +# TEST +is_deeply( _run_find($f), + [ @tests, $foobar_fn, $ATeam_pm_fn ], + "procedural prune/discard .svn" + ); + +# size (stat test) +# TEST +is_deeply( [ find( maxdepth => 1, file => size => $foobar_size, in => $copy_fn, ) ], + [ $foobar_fn ], + "size $foobar_size (stat)" ); + +# TEST +is_deeply( [ find( maxdepth => 1, file => size => "<= $foobar_size", + in => $copy_fn ) ], + [ $foobar_fn ], + "size <= $foobar_size (stat)" ); +# TEST +is_deeply( [ find( maxdepth => 1, file => size => "<".($foobar_size + 1), + in => $copy_fn ) ], + [ $foobar_fn ], + "size <($foobar_size + 1) (stat)" ); + +# TEST +is_deeply( [ find( maxdepth => 1, file => size => "<1K", + exec => sub { length == 6 }, + in => $copy_fn ) ], + [ $foobar_fn ], + "size <1K (stat)" ); + +# TEST +is_deeply( [ find( maxdepth => 1, file => size => ">3K", in => $copy_fn ) ], + [ $FFR_t ], + "size >3K (stat)" ); + +# these next two should never fail. if they do then the testing fairy +# went mad +# TEST +is_deeply( [ find( file => size => ">3M", in => $copy_fn ) ], + [ ], + "size >3M (stat)" ); + +# TEST +is_deeply( [ find( file => size => ">3G", in => $copy_fn ) ], + [ ], + "size >3G (stat)" ); + + +#min/maxdepth + +# TEST +is_deeply( [ find( maxdepth => 0, in => $copy_fn ) ], + [ $copy_fn ], + "maxdepth == 0" ); + + + +my $rule = find( or => [ find( name => qr/(\.svn|CVS)/, + discard =>), + find(), + ], + maxdepth => 1 ); + +# TEST +is_deeply( _run_find($rule), + [ $copy_fn, @tests, $foobar_fn, $lib_fn ], + "maxdepth == 1" ); +# TEST +is_deeply( _run_find($rule), + [ $copy_fn, @tests, $foobar_fn, $lib_fn ], + "maxdepth == 1, trailing slash on the path" ); + +# TEST +is_deeply( _run_find($rule), + [ $copy_fn, @tests, $foobar_fn, $lib_fn ], + "maxdepth == 1, ./t" ); +# TEST +is_deeply( _run_find($rule), + [ $copy_fn, @tests, $foobar_fn, $lib_fn ], + "maxdepth == 1, ./././///./t" ); + +# TEST +is_deeply( [ sort +find( or => [ find( name => qr/(\.svn|CVS)/, + prune => + discard =>), + find( ), + ], + mindepth => 1, + in => $copy_fn, ) ], + [ @tests, $foobar_fn, @ateam_path ], + "mindepth == 1" ); + + +# TEST +is_deeply( [ sort +find( or => [ find( name => qr/(\.svn|CVS)/, + discard =>), + find(), + ], + maxdepth => 1, + mindepth => 1, + in => $copy_fn, ) ], + [ @tests, $foobar_fn, $lib_fn ], + "maxdepth = 1 mindepth == 1" ); + +# extras +my $ok = 0; +find( extras => { preprocess => sub { my ($self, $list) = @_; $ok = 1; return $list; } }, in => $copy_fn ); +# TEST +ok( $ok, "extras preprocess fired" ); + +#iterator +$f = find( or => [ find( name => qr/(\.svn|CVS)/, + prune => + discard =>), + find(), + ], + start => $copy_fn ); + +{ +my @found; +while ($_ = $f->match) { push @found, $_ } +# TEST +is_deeply( [ sort @found ], [ $copy_fn, @tests, $foobar_fn, @ateam_path ], "iterator" ); +} + +# negating in the procedural interface +# TEST +is_deeply( [ find( file => '!name' => qr/^[^.]{1,9}(\.[^.]{0,3})?$/, + maxdepth => 1, + in => $copy_fn ) ], + [ $FFR_t ], + "negating in the procedural interface" ); + +# grep +# TEST +is_deeply( [ find( maxdepth => 1, file => grep => [ qr/bytes./, [ qr/.?/ ] ], in => $copy_fn ) ], + [ $foobar_fn ], + "grep" ); + + + +# relative +# TEST +is_deeply( [ find( 'relative', maxdepth => 1, name => 'foobar', in => $copy_fn ) ], + [ 'foobar' ], + 'relative' ); + + + +# bootstrapping extensions via import + +eval { $class->import(':Test::Elusive') }; +# TEST +like( $@, qr/^couldn't bootstrap File::Find::Object::Rule::Test::Elusive/, + "couldn't find the Elusive extension" ); + +eval { $class->import(':Test::ATeam') }; +# TEST +is ($@, "", "if you can find them, maybe you can hire the A-Team" ); +# TEST +can_ok( $class, 'ba' ); + +rmtree($tree_creator->get_path("./t/sample-data/FFRt-to")); diff --git a/t/findorule.t b/t/findorule.t new file mode 100644 index 0000000..a170112 --- /dev/null +++ b/t/findorule.t @@ -0,0 +1,147 @@ +#!perl + +use strict; +use warnings; + +use lib './t/lib'; + +use Test::More tests => 5; +use File::Spec; + +use File::Path; +use File::Find::Object::TreeCreate; + +my $tree_creator = File::Find::Object::TreeCreate->new(); + +{ + my $tree = + { + 'name' => "findorule-t-copy-to/", + 'subs' => + [ + { + 'name' => "File-Find-Rule.t", + 'contents' => $tree_creator->cat( + "./t/sample-data/to-copy-from/File-Find-Rule.t" + ), + }, + { + 'name' => "findorule.t", + 'contents' => $tree_creator->cat( + "./t/sample-data/to-copy-from/findorule.t" + ), + }, + { + 'name' => "foobar", + 'contents' => $tree_creator->cat( + "./t/sample-data/to-copy-from/foobar" + ), + + }, + { + 'name' => "lib/", + 'subs' => + [ + { + 'name' => "File/", + 'subs' => + [ + { + name => "Find/", + subs => + [ + { + name => "Object/", + subs => + [ + { + name => "Rule/", + subs => + [ + { + name => "Test/", + subs => + [ + { + name => "ATeam.pm", +content => $tree_creator->cat( + "./t/sample-data/to-copy-from/lib/File/Find/Object/Rule/Test/ATeam.pm" + +), +} + ], + }, + ], + } + ], + }, + ], + }, + ], + }, + ], + }, + ], + }; + + $tree_creator->create_tree("./t/sample-data/", $tree); +} + +# extra tests for findorule. these are more for testing the parsing code. + +sub run ($) { + my $expr = shift; + my $script = File::Spec->catfile( + File::Spec->curdir(), "scripts", "findorule" + ); + + [ sort split /\n/, `$^X -Mblib $script $expr` ]; +} + +my $copy_fn = $tree_creator->get_path( + "./t/sample-data/findorule-t-copy-to/" +); + +my $FFR_t = $tree_creator->get_path( + "./t/sample-data/findorule-t-copy-to/File-Find-Rule.t" +); +my $findorule_t = $tree_creator->get_path( + "./t/sample-data/findorule-t-copy-to/findorule.t" +); +my $foobar_fn = $tree_creator->get_path( + "./t/sample-data/findorule-t-copy-to/foobar" +); + +# TEST +is_deeply(run $copy_fn . ' -file -name foobar', [ $foobar_fn ], + '-file -name foobar'); + +# TEST +is_deeply(run $copy_fn . ' -maxdepth 0 -directory', + [ $copy_fn ], 'last clause has no args'); + + +{ + local $TODO = "Win32 cmd.exe hurts my brane" + if ($^O =~ m/Win32/ || $^O eq 'dos'); + + # TEST + is_deeply(run $copy_fn . ' -file -name \( foobar \*.t \)', + [ $FFR_t, $findorule_t, $foobar_fn ], + 'grouping ()'); + + # TEST + is_deeply(run $copy_fn . ' -name \( -foo foobar \)', + [ $foobar_fn ], 'grouping ( -literal )'); +} + +# Remming out due to capturing STDERR using unixisms. In the future, we +# may implement this using Test::Trap. +# is_deeply(run $copy_fn . ' -file -name foobar baz', +# [ "unknown option 'baz'" ], 'no implicit grouping'); + +# TEST +is_deeply(run $copy_fn . ' -maxdepth 0 -name -file', + [], 'terminate at next -'); + +rmtree($copy_fn); diff --git a/t/foobar b/t/foobar new file mode 100644 index 0000000..088de27 --- /dev/null +++ b/t/foobar @@ -0,0 +1 @@ +10 bytess. diff --git a/t/lib/File/Find/Object/Rule/Test/ATeam.pm b/t/lib/File/Find/Object/Rule/Test/ATeam.pm new file mode 100644 index 0000000..06a0aa5 --- /dev/null +++ b/t/lib/File/Find/Object/Rule/Test/ATeam.pm @@ -0,0 +1,11 @@ +package File::Find::Object::Rule::Test::ATeam; +use strict; +use File::Find::Object::Rule; +use base 'File::Find::Object::Rule'; + +sub File::Find::Object::Rule::ba { + my $self = shift()->_force_object; + $self->exec( sub { die "I pity the fool who uses this in production" }); +} + +1; diff --git a/t/lib/File/Find/Object/TreeCreate.pm b/t/lib/File/Find/Object/TreeCreate.pm new file mode 100644 index 0000000..81b8589 --- /dev/null +++ b/t/lib/File/Find/Object/TreeCreate.pm @@ -0,0 +1,122 @@ +package File::Find::Object::TreeCreate; + +use strict; +use warnings; + +use File::Spec; + +sub new +{ + my $class = shift; + my $self = {}; + bless $self, $class; + $self->_initialize(@_); + return $self; +} + +sub _initialize +{ +} + +sub get_path +{ + my $self = shift; + my $path = shift; + + my @components; + + if ($path =~ s{^\./}{}) + { + push @components, File::Spec->curdir(); + } + + my $is_dir = ($path =~ s{/$}{}); + push @components, split(/\//, $path); + if ($is_dir) + { + return File::Spec->catdir(@components); + } + else + { + return File::Spec->catfile(@components); + } +} + +sub exist +{ + my $self = shift; + return (-e $self->get_path(@_)); +} + +sub is_file +{ + my $self = shift; + return (-f $self->get_path(@_)); +} + +sub is_dir +{ + my $self = shift; + return (-d $self->get_path(@_)); +} + +sub cat +{ + my $self = shift; + open my $in, "<", $self->get_path(@_) or + return 0; + my $data; + { + local $/; + $data = <$in>; + } + close($in); + return $data; +} + +sub ls +{ + my $self = shift; + opendir my $dir, $self->get_path(@_) or + return undef; + my @files = + sort { $a cmp $b } + grep { !(($_ eq ".") || ($_ eq "..")) } + readdir($dir); + closedir($dir); + return \@files; +} + +sub create_tree +{ + my ($self, $unix_init_path, $tree) = @_; + my $real_init_path = $self->get_path($unix_init_path); + return $self->_real_create_tree($real_init_path, $tree); +} + +sub _real_create_tree +{ + my ($self, $init_path, $tree) = @_; + my $name = $tree->{'name'}; + if ($name =~ s{/$}{}) + { + my $dir_name = File::Spec->catfile($init_path, $name); + mkdir($dir_name); + if (exists($tree->{'subs'})) + { + foreach my $sub (@{$tree->{'subs'}}) + { + $self->_real_create_tree($dir_name, $sub); + } + } + } + else + { + open my $out, ">", File::Spec->catfile($init_path, $name); + print {$out} +(exists($tree->{'contents'}) ? $tree->{'contents'} : ""); + close($out); + } + return 0; +} +1; + diff --git a/t/pod-coverage.t b/t/pod-coverage.t new file mode 100644 index 0000000..703f91d --- /dev/null +++ b/t/pod-coverage.t @@ -0,0 +1,6 @@ +#!perl -T + +use Test::More; +eval "use Test::Pod::Coverage 1.04"; +plan skip_all => "Test::Pod::Coverage 1.04 required for testing POD coverage" if $@; +all_pod_coverage_ok(); diff --git a/t/pod.t b/t/pod.t new file mode 100644 index 0000000..976d7cd --- /dev/null +++ b/t/pod.t @@ -0,0 +1,6 @@ +#!perl -T + +use Test::More; +eval "use Test::Pod 1.14"; +plan skip_all => "Test::Pod 1.14 required for testing POD" if $@; +all_pod_files_ok(); diff --git a/t/readme-pod.t b/t/readme-pod.t new file mode 100644 index 0000000..3e531fb --- /dev/null +++ b/t/readme-pod.t @@ -0,0 +1,7 @@ +#!perl -T + +use Test::More; +eval "use Test::Pod 1.14"; +plan skip_all => "Test::Pod 1.14 required for testing POD" if $@; +plan tests => 1; +pod_file_ok("README", "README is Valid POD"); diff --git a/t/release-trailing-space.t b/t/release-trailing-space.t new file mode 100644 index 0000000..55df58a --- /dev/null +++ b/t/release-trailing-space.t @@ -0,0 +1,38 @@ +#!perl + +BEGIN { + unless ($ENV{RELEASE_TESTING}) { + require Test::More; + Test::More::plan(skip_all => 'these tests are for release candidate testing'); + } +} + + +use strict; +use warnings; + +use Test::More; + +eval "use Test::TrailingSpace"; +if ($@) +{ + plan skip_all => "Test::TrailingSpace required for trailing space test."; +} +else +{ + plan tests => 1; +} + +# TODO: add .pod, .PL, the README/Changes/TODO/etc. documents and possibly +# some other stuff. +my $finder = Test::TrailingSpace->new( + { + root => '.', + filename_regex => qr#(?:\.(?:t|pm|pl|xs|c|h|txt|pod|PL)|README|Changes|TODO|LICENSE)\z#, + }, +); + +# TEST +$finder->no_trailing_space( + "No trailing space was found." +); diff --git a/t/sample-data/to-copy-from/File-Find-Rule.t b/t/sample-data/to-copy-from/File-Find-Rule.t new file mode 100644 index 0000000..233aa80 --- /dev/null +++ b/t/sample-data/to-copy-from/File-Find-Rule.t @@ -0,0 +1,305 @@ +#!perl -w +# $Id: /mirror/lab/perl/File-Find-Rule/t/File-Find-Rule.t 2100 2006-05-28T16:06:50.725367Z richardc $ + +use strict; +use Test::More tests => 41; + +my $class; +my @tests = qw( t/File-Find-Rule.t t/findorule.t ); +BEGIN { + $class = 'File::Find::Object::Rule'; + use_ok($class) +} + +# on win32 systems the t/foobar file isn't 10 bytes it's 11, so the +# previous tests on the magic number 10 failed. rt.cpan.org #3838 +my $foobar_size = -s 't/foobar'; + +my $f = $class->new; +isa_ok($f, $class); + + +# name +$f = $class->name( qr/\.t$/ ); +is_deeply( [ sort $f->in('t') ], + [ @tests ], + "name( qr/\\.t\$/ )" ); + +$f = $class->name( 'foobar' ); +is_deeply( [ $f->in('t') ], + [ 't/foobar' ], + "name( 'foobar' )" ); + +$f = $class->name( '*.t' ); +is_deeply( [ sort $f->in('t') ], + \@tests, + "name( '*.t' )" ); + +$f = $class->name( 'foobar', '*.t' ); +is_deeply( [ sort $f->in('t') ], + [ @tests, 't/foobar' ], + "name( 'foobar', '*.t' )" ); + +$f = $class->name( [ 'foobar', '*.t' ] ); +is_deeply( [ sort $f->in('t') ], + [ @tests, 't/foobar' ], + "name( [ 'foobar', '*.t' ] )" ); + + + +# exec +$f = $class->exec(sub { length($_[0]) == 6 })->maxdepth(1); +is_deeply( [ $f->in('t') ], + [ 't/foobar' ], + "exec (short)" ); + +$f = $class->exec(sub { length($_[0]) > $foobar_size })->maxdepth(1); +is_deeply( [ $f->in('t') ], + [ 't/File-Find-Rule.t' ], + "exec (long)" ); + +is_deeply( [ find( maxdepth => 1, exec => sub { $_[2] eq 't/foobar' }, in => 't' ) ], + [ 't/foobar' ], + "exec (check arg 2)" ); + +# name and exec, chained +$f = $class + ->exec(sub { length > $foobar_size }) + ->name( qr/\.t$/ ); + +is_deeply( [ $f->in('t') ], + [ 't/File-Find-Rule.t' ], + "exec(match) and name(match)" ); + +$f = $class + ->exec(sub { length > $foobar_size }) + ->name( qr/foo/ ) + ->maxdepth(1); + +is_deeply( [ $f->in('t') ], + [ ], + "exec(match) and name(fail)" ); + + +# directory +$f = $class + ->directory + ->maxdepth(1) + ->exec(sub { $_ !~ /(\.svn|CVS)/ }); # ignore .svn/CVS dirs + +is_deeply( [ $f->in('t') ], + [ qw( t t/lib ) ], + "directory autostub" ); + + +# any/or +$f = $class->any( $class->exec( sub { length == 6 } ), + $class->name( qr/\.t$/ ) + ->exec( sub { length > $foobar_size } ) + )->maxdepth(1); + +is_deeply( [ sort $f->in('t') ], + [ 't/File-Find-Rule.t', 't/foobar' ], + "any" ); + +$f = $class->or( $class->exec( sub { length == 6 } ), + $class->name( qr/\.t$/ ) + ->exec( sub { length > $foobar_size } ) + )->maxdepth(1); + +is_deeply( [ sort $f->in('t') ], + [ 't/File-Find-Rule.t', 't/foobar' ], + "or" ); + + +# not/none +$f = $class + ->file + ->not( $class->name( qr/^[^.]{1,8}(\.[^.]{0,3})?$/ ) ) + ->maxdepth(1) + ->exec(sub { length == 6 || length > 11 }); +is_deeply( [ $f->in('t') ], + [ 't/File-Find-Rule.t' ], + "not" ); + +# not as not_* +$f = $class + ->file + ->not_name( qr/^[^.]{1,8}(\.[^.]{0,3})?$/ ) + ->maxdepth(1) + ->exec(sub { length == 6 || length > 11 }); +is_deeply( [ $f->in('t') ], + [ 't/File-Find-Rule.t' ], + "not_*" ); + +# prune/discard (.svn demo) +# this test may be a little meaningless for a cpan release, but it +# fires perfectly in my dev sandbox +$f = $class->or( $class->directory + ->name(qr/(\.svn|CVS)/) + ->prune + ->discard, + $class->new->file ); + +is_deeply( [ sort $f->in('t') ], + [ @tests, 't/foobar', 't/lib/File/Find/Object/Rule/Test/ATeam.pm' ], + "prune/discard .svn" + ); + + +# procedural form of the CVS demo +$f = find(or => [ find( directory => + name => qr/(\.svn|CVS)/, + prune => + discard => ), + find( file => ) ]); + +is_deeply( [ sort $f->in('t') ], + [ @tests, 't/foobar', 't/lib/File/Find/Object/Rule/Test/ATeam.pm' ], + "procedural prune/discard .svn" + ); + +# size (stat test) +is_deeply( [ find( maxdepth => 1, file => size => $foobar_size, in => 't' ) ], + [ 't/foobar' ], + "size $foobar_size (stat)" ); + +is_deeply( [ find( maxdepth => 1, file => size => "<= $foobar_size", + in => 't' ) ], + [ 't/foobar' ], + "size <= $foobar_size (stat)" ); + +is_deeply( [ find( maxdepth => 1, file => size => "<".($foobar_size + 1), + in => 't' ) ], + [ 't/foobar' ], + "size <($foobar_size + 1) (stat)" ); + +is_deeply( [ find( maxdepth => 1, file => size => "<1K", + exec => sub { length == 6 }, + in => 't' ) ], + [ 't/foobar' ], + "size <1K (stat)" ); + +is_deeply( [ find( maxdepth => 1, file => size => ">3K", in => 't' ) ], + [ 't/File-Find-Rule.t' ], + "size >3K (stat)" ); + +# these next two should never fail. if they do then the testing fairy +# went mad +is_deeply( [ find( file => size => ">3M", in => 't' ) ], + [ ], + "size >3M (stat)" ); + +is_deeply( [ find( file => size => ">3G", in => 't' ) ], + [ ], + "size >3G (stat)" ); + + +#min/maxdepth + +is_deeply( [ find( maxdepth => 0, in => 't' ) ], + [ 't' ], + "maxdepth == 0" ); + + + +my $rule = find( or => [ find( name => qr/(\.svn|CVS)/, + discard =>), + find(), + ], + maxdepth => 1 ); + +is_deeply( [ sort $rule->in( 't' ) ], + [ 't', @tests, 't/foobar', 't/lib' ], + "maxdepth == 1" ); +is_deeply( [ sort $rule->in( 't/' ) ], + [ 't', @tests, 't/foobar', 't/lib' ], + "maxdepth == 1, trailing slash on the path" ); + +is_deeply( [ sort $rule->in( './t' ) ], + [ 't', @tests, 't/foobar', 't/lib' ], + "maxdepth == 1, ./t" ); +is_deeply( [ sort $rule->in( './././///./t' ) ], + [ 't', @tests, 't/foobar', 't/lib' ], + "maxdepth == 1, ./././///./t" ); + +my @ateam_path = qw( t/lib + t/lib/File + t/lib/File/Find + t/lib/File/Find/Object + t/lib/File/Find/Object/Rule + t/lib/File/Find/Object/Rule/Test + t/lib/File/Find/Object/Rule/Test/ATeam.pm ); + +is_deeply( [ sort +find( or => [ find( name => qr/(\.svn|CVS)/, + prune => + discard =>), + find( ), + ], + mindepth => 1, + in => 't' ) ], + [ @tests, 't/foobar', @ateam_path ], + "mindepth == 1" ); + + +is_deeply( [ sort +find( or => [ find( name => qr/(\.svn|CVS)/, + discard =>), + find(), + ], + maxdepth => 1, + mindepth => 1, + in => 't' ) ], + [ @tests, 't/foobar', 't/lib' ], + "maxdepth = 1 mindepth == 1" ); + +# extras +my $ok = 0; +find( extras => { preprocess => sub { my ($self, $list) = @_; $ok = 1; return $list; } }, in => 't' ); +ok( $ok, "extras preprocess fired" ); + +#iterator +$f = find( or => [ find( name => qr/(\.svn|CVS)/, + prune => + discard =>), + find(), + ], + start => 't' ); + +{ +my @found; +while ($_ = $f->match) { push @found, $_ } +is_deeply( [ sort @found ], [ 't', @tests, 't/foobar', @ateam_path ], "iterator" ); +} + +# negating in the procedural interface +is_deeply( [ find( file => '!name' => qr/^[^.]{1,9}(\.[^.]{0,3})?$/, + maxdepth => 1, + in => 't' ) ], + [ 't/File-Find-Rule.t' ], + "negating in the procedural interface" ); + +# grep +is_deeply( [ find( maxdepth => 1, file => grep => [ qr/bytes./, [ qr/.?/ ] ], in => 't' ) ], + [ 't/foobar' ], + "grep" ); + + + +# relative +is_deeply( [ find( 'relative', maxdepth => 1, name => 'foobar', in => 't' ) ], + [ 'foobar' ], + 'relative' ); + + + +# bootstrapping extensions via import + +use lib qw(t/lib); + +eval { $class->import(':Test::Elusive') }; +like( $@, qr/^couldn't bootstrap File::Find::Object::Rule::Test::Elusive/, + "couldn't find the Elusive extension" ); + +eval { $class->import(':Test::ATeam') }; +is ($@, "", "if you can find them, maybe you can hire the A-Team" ); +can_ok( $class, 'ba' ); diff --git a/t/sample-data/to-copy-from/findorule.t b/t/sample-data/to-copy-from/findorule.t new file mode 100644 index 0000000..54267f8 --- /dev/null +++ b/t/sample-data/to-copy-from/findorule.t @@ -0,0 +1,43 @@ +#!perl + +use strict; +use warnings; + +use Test::More tests => 6; +use File::Spec; + +# extra tests for findorule. these are more for testing the parsing code. + +sub run ($) { + my $expr = shift; + my $script = File::Spec->catfile( + File::Spec->curdir(), "scripts", "findorule" + ); + + [ sort split /\n/, `$^X -Mblib $script $expr 2>&1` ]; +} + +is_deeply(run 't -file -name foobar', [ 't/foobar' ], + '-file -name foobar'); + +is_deeply(run 't -maxdepth 0 -directory', + [ 't' ], 'last clause has no args'); + + +{ + local $TODO = "Win32 cmd.exe hurts my brane" + if ($^O =~ m/Win32/ || $^O eq 'dos'); + + is_deeply(run 't -file -name \( foobar \*.t \)', + [ qw( t/File-Find-Rule.t t/findorule.t t/foobar ) ], + 'grouping ()'); + + is_deeply(run 't -name \( -foo foobar \)', + [ 't/foobar' ], 'grouping ( -literal )'); +} + +is_deeply(run 't -file -name foobar baz', + [ "unknown option 'baz'" ], 'no implicit grouping'); + +is_deeply(run 't -maxdepth 0 -name -file', + [], 'terminate at next -'); diff --git a/t/sample-data/to-copy-from/foobar b/t/sample-data/to-copy-from/foobar new file mode 100644 index 0000000..088de27 --- /dev/null +++ b/t/sample-data/to-copy-from/foobar @@ -0,0 +1 @@ +10 bytess. diff --git a/t/sample-data/to-copy-from/lib/File/Find/Object/Rule/Test/ATeam.pm b/t/sample-data/to-copy-from/lib/File/Find/Object/Rule/Test/ATeam.pm new file mode 100644 index 0000000..06a0aa5 --- /dev/null +++ b/t/sample-data/to-copy-from/lib/File/Find/Object/Rule/Test/ATeam.pm @@ -0,0 +1,11 @@ +package File::Find::Object::Rule::Test::ATeam; +use strict; +use File::Find::Object::Rule; +use base 'File::Find::Object::Rule'; + +sub File::Find::Object::Rule::ba { + my $self = shift()->_force_object; + $self->exec( sub { die "I pity the fool who uses this in production" }); +} + +1;