This is an automated email from the git hooks/post-receive script. hggh-guest pushed a commit to branch master in repository libfile-flat-perl.
commit ad1408e54ac28c85b5816f5e5be9d2c415544397 Author: Jonas Genannt <jo...@brachium-system.net> Date: Tue Aug 12 18:20:42 2014 +0200 Imported Upstream version 1.04 --- Changes | 87 +++ LICENSE | 378 +++++++++++++ MANIFEST | 24 + META.yml | 30 ++ Makefile.PL | 25 + README | 283 ++++++++++ inc/Module/Install.pm | 343 ++++++++++++ inc/Module/Install/Base.pm | 70 +++ inc/Module/Install/Can.pm | 82 +++ inc/Module/Install/Fetch.pm | 93 ++++ inc/Module/Install/Makefile.pm | 245 +++++++++ inc/Module/Install/Metadata.pm | 371 +++++++++++++ inc/Module/Install/Win32.pm | 64 +++ inc/Module/Install/WriteAll.pm | 40 ++ lib/File/Flat.pm | 1152 ++++++++++++++++++++++++++++++++++++++++ t/01_compile.t | 13 + t/02_api.t | 60 +++ t/03_main.t | 786 +++++++++++++++++++++++++++ t/97_meta.t | 27 + t/98_pod.t | 72 +++ t/99_pmv.t | 27 + t/ff_binary | Bin 0 -> 5613 bytes t/ff_content | 4 + t/ff_text | 4 + 24 files changed, 4280 insertions(+) diff --git a/Changes b/Changes new file mode 100644 index 0000000..076c71a --- /dev/null +++ b/Changes @@ -0,0 +1,87 @@ +Revision history for Perl extension File::Flat. + +1.04 Mon 24 Mar 2008 + - Removing dependency on File::Slurp + +1.03 Sat 1 Mar 2008 + - Incremental release to clear out some CPAN Testers failures + - No need to upgrade + +1.02 Tue 11 Dec 2007 + - Cygwin is clearly insane, skip root and win32 test sets + - More aggressive dependencies, particularly on Win32 + +1.01 Tue 11 Dec 2007 + - No functional changes + - Correcting dependency + - Updating to Module::Install 0.68 + - Updating bundled tests + +1.00 Sun 14 Jan 2007 + - FINALLY completed full functionality on Win32 + +0.96 Wed 19 Jul 2006 + - Moving from CVS to new SVN repository + - Upgrading to Module::Install + +0.95 Sat Nov 7 2004 + - More cached stats + - Using prefork.pm to preload File:: modules in forking scenarios + +0.94 Tue Sep 5 2004 + - After discovering CVS Monitor was using a private method, and now + breaks, added an alias back in. No user-visible changes. + +0.93 Tue Sep 29 2004 + - Broke out API tests to use proper Test::ClassAPI testing + - Removed use of, bundling of, and direct dependency on Class::Inspector + - Added general support for pruning + - Added File::Flat::prune static method + - Added File::Flat::Object::prune instance method + - Added full unit testing for the prune methods + - Added full POD for the methods, and $AUTO_PRUNE + - Added fixes or workarounds to resolve a number of warnings + - Moved Makefile.PL to a Module::Install-based one + +0.92 Mon Jul 26 2004 + - Converting to use File::Slurp where appropriate + - Upgraded dependencies to the new File::Spec version of File::Remove + - Updated dependency list + +0.91 Tue Oct 14 19:31 2003 + - Instead of letting File::Spec->rel2abs contantly do slow forking + Cwd::_backtick_pwd calls constantly. Use the faster Cwd::getcwd + FIRST, and pass it to rel2abs as the $base value. + +0.9 Fri Jul 25 21:00:12 2003 + - Following prompting from Schwern, implemented a bunch of + test related changes, to try and get File::Flat to build/test/run + on non-Unix platforms. + +0.8 Wed May 07 00:56:21 2003 + - Bug in the test script, fixed + +0.7 Tue May 06 23:58:54 2003 + - IO::File cannot be autoloaded. Always load it + +0.6 Sun Dec 08 23:24:15 2002 + - Fixes a bug where the tests will fail is run as root + +0.5 Thu Nov 28 15:19:32 2002 + - Fixed a bug that caused large amounts of warnings to be + generated when ->canWrite, ->write, ->makeDirectory was used. + +0.4 Fri Nov 22 14:38:23 2002 + - Fixed a significant bug in makeDirectory + +0.3 Wed Nov 20 14:21:54 2002 + - Added Class::Autouse to Makefile + +0.2 Mon Nov 18 15:37:23 2002 + - Completed main method set + - Added full testing suite ( 73% coverage ) + - Added documentation + +0.1 Thu May 23 21:01:52 2002 + - original version + diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..05e86e0 --- /dev/null +++ b/LICENSE @@ -0,0 +1,378 @@ + +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" + +---------------------------------------------------------------------------- + +The General Public License (GPL) +Version 2, June 1991 + +Copyright (C) 1989, 1991 Free Software Foundation, Inc. 675 Mass Ave, +Cambridge, MA 02139, 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 Library 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..ed6a274 --- /dev/null +++ b/MANIFEST @@ -0,0 +1,24 @@ +Changes +inc/Module/Install.pm +inc/Module/Install/Base.pm +inc/Module/Install/Can.pm +inc/Module/Install/Fetch.pm +inc/Module/Install/Makefile.pm +inc/Module/Install/Metadata.pm +inc/Module/Install/Win32.pm +inc/Module/Install/WriteAll.pm +lib/File/Flat.pm +LICENSE +Makefile.PL +MANIFEST This list of files +META.yml +README +t/01_compile.t +t/02_api.t +t/03_main.t +t/97_meta.t +t/98_pod.t +t/99_pmv.t +t/ff_binary +t/ff_content +t/ff_text diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..904e294 --- /dev/null +++ b/META.yml @@ -0,0 +1,30 @@ +--- +abstract: 'Implements a flat filesystem' +author: + - 'Adam Kennedy <ad...@cpan.org>' +build_requires: + File::Find: 0 + Test::ClassAPI: 1.04 + Test::More: 0.47 +distribution_type: module +generated_by: 'Module::Install version 0.71' +license: perl +meta-spec: + url: http://module-build.sourceforge.net/META-spec-v1.3.html + version: 1.3 +name: File-Flat +no_index: + directory: + - inc + - t +requires: + Cwd: 0 + File::Copy: 0 + File::Copy::Recursive: 0.35 + File::Remove: 0.38 + File::Spec: 0.85 + File::Temp: 0.17 + IO::File: 0 + perl: 5.005 + prefork: 0.02 +version: 1.04 diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..48bef31 --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,25 @@ +use strict; +use inc::Module::Install; + +# Because many filesystem modules are buggier +# on Windows, we're going to push for more aggressive +# dependencies to get the most current bug fixes. +my $WIN32 = ($^O eq 'MSWin32' or $^O eq 'cygwin'); + +name 'File-Flat'; +all_from 'lib/File/Flat.pm'; +requires 'Cwd' => 0; +requires 'prefork' => '0.02'; +requires 'File::Spec' => ($WIN32 ? '3.24' : '0.85'); +requires 'File::Copy' => 0; +requires 'File::Copy::Recursive' => '0.35'; +requires 'File::Remove' => '0.38'; +requires 'File::Temp' => '0.17'; +requires 'IO::File' => 0; +build_requires 'Test::More' => '0.47'; +build_requires 'Test::ClassAPI' => '1.04'; + +# Avoid use of system chmod -R in test script +build_requires 'File::Find' => 0; + +WriteAll; diff --git a/README b/README new file mode 100644 index 0000000..c0fe9e0 --- /dev/null +++ b/README @@ -0,0 +1,283 @@ +NAME + File::Flat - Implements a flat filesystem + +SYNOPSIS +DESCRIPTION + File::Flat implements a flat filesystem. A flat filesystem is a + filesystem in which directories do not exist. It provides an abstraction + over any normal filesystem which makes it appear as if directories do + not exist. In effect, it will automatically create directories as + needed. This is create for things like install scripts and such, as you + never need to worry about the existance of directories, just write to a + file, no matter where it is. + + Comprehensive Implementation + The implementation of File::Flat is extremely comprehensive in scope. It + has methods for all stardard file interaction taks, the -X series of + tests, and some other things, such as slurp. + + All methods are statically called, for example, to write some stuff to a + file. + + use File::Flat; + File::Flat->write( 'filename', 'file contents' ); + + Use of other modules + File::Flat tries to use more task orientated modules wherever possible. + This includes the use of File::Copy, File::Copy::Recursive, File::Remove + and others. These are mostly loaded on-demand. + + Pruning and $AUTO_PRUNE + "Pruning" is a technique where empty directories are assumed to be + useless, and thus empty removed whenever one is created. Thus, when some + other task has the potential to leave an empty directory, it is checked + and deleted if it is empty. + + By default File::Flat does not prune, and pruning must be done + explicitly, via either the "prune" in File::Flat method, or by setting + the second argument to the "remove" in File::Flat method to be true. + + However by setting the global $AUTO_PRUNE variable to true, File::Flat + will automatically prune directories at all times. You should generally + use this locally, such as in the following example. + + #!/usr/bin/perl + + use strict; + use File::Flat; + + delete_files(@ARGV); + exit(); + + # Recursively delete and prune all files provided on the command line + sub delete_files { + local $File::Flat::AUTO_PRUNE = 1; + foreach my $file ( @_ ) { + File::Flat->remove( $file ) or die "Failed to delete $file"; + } + } + + Non-Unix platforms + As of version 0.97 File::Flat should work correctly on Win32. Other + platforms (such as VMS) are believed to work, but require confirmation. + +METHODS + exists $filename + Tests for the existance of the file. This is an exact duplicate of the + -e function. + + isaFile $filename + Tests whether "filename" is a file. This is an exact duplicate of the -f + function. + + isaDirectory $filename + Test whether "filename" is a directory. This is an exact duplicate of + the -d function. + + canRead $filename + Does the file or directory exist, and can we read from it. + + canWrite $filename + Does the file or directory exist, and can we write to it OR can we + create the file or directory. + + canReadWrite $filename + Does a file or directory exist, and can we both read and write it. + + canExecute $filename + Does a file or directory exist, and can we execute it. + + canOpen $filename + Is this something we can open a filehandle to. Returns true if filename + exists, is a file, and we can read from it. + + canRemove $filename + Can we remove the file or directory. + + isaText $filename + Does the file "filename" exist, and is it a text file. + + isaBinary $filename + Does the file "filename" exist, and is it a binary file. + + fileSize $filename + If the file exists, returns its size in bytes. Returns undef if the file + does not exist. + + open [ $mode, ] $filename + Rough analogue of the open function, but creates directories on demand + as needed. Supports most of the normal options to the normal open + function. + + In the single argument form, it takes modes in the form [mode]filename. + For example, all the following are valid. + + File::Flat->open( 'filename' ); + File::Flat->open( '<filename' ); + File::Flat->open( '>filename' ); + File::Flat->open( '>>filename' ); + File::Flat->open( '+<filename' ); + + In the two argument form, it takes the following + + File::Flat->open( '<', 'filename' ); + File::Flat->open( '>', 'filename' ); + File::Flat->open( '>>', 'filename' ); + File::Flat->open( '+<', 'filename' ); + + It does not support the more esoteric forms of open, such us opening to + a pipe or other such things. + + On successfully opening the file, it returns it as an IO::File object. + Returns undef on error. + + getReadHandle $filename + The same as File::Flat->open( '<', 'filename' ) + + getWriteHandle $filename + The same as File::Flat->open( '>', 'filename' ) + + getAppendHandle $filename + The same as File::Flat->open( '>>', 'filename' ) + + getReadWriteHandle $filename + The same as File::Flat->open( '+<', 'filename' ) + + read $filename + Opens and reads in an entire file, chomping as needed. + + In array context, it returns an array containing each line of the file. + In scalar context, it returns a reference to an array containing each + line of the file. It returns undef on error. + + slurp $filename + The "slurp" method 'slurps' a file in. That is it attempts to read the + entire file into a variable in as quick and memory efficient method as + possible. + + On success, returns a reference to a scalar, containing the entire file. + Returns undef on error. + + write $filename, ( $content | \$content | \@content ) + The "write" method is the main method for writing content to a file. It + takes two arguments, the location to write to, and the content to write, + in several forms. + + If the file already exists, it will be clobered before writing starts. + If the file doesn't exists, the file and any directories will be created + as needed. + + Content can be provided in three forms. The contents of a scalar + argument will be written directly to the file. You can optionally pass a + reference to the scalar. This is recommended when the file size is + bigger than a few thousand characters, is it does not duplicate the file + contents in memory. Alternatively, you can pass the content as a + reference to an array containing the contents. To ensure uniformity, + "write" will add a newline to each line, replacing any existing newline + as needed. + + Returns true on success, and undef on error. + + append $filename, ( $content | \$content | \@content ) + This method is the same as "write", except that it appends to the end of + an existing file ( or creates the file as needed ). + + This is the method you should be using to write to log files, etc. + + overwrite $filename, ( $content | \$content | \@content ) + Performs an atomic write over a file. It does this by writing to a + temporary file, and moving the completed file over the top of the + existing file ( or creating a new file as needed ). When writing to a + file that is on the same partition as /tmp, this should always be + atomic. + + This method otherwise acts the same as "write". + + copy $source, $target + The "copy" method attempts to copy a file or directory from the source + to the target. New directories to contain the target will be created as + needed. + + For example "<File::Flat-"( './this', './a/b/c/d/that' );>> will create + the directory structure required as needed. + + In the file copy case, if the target already exists, and is a writable + file, we replace the existing file, retaining file mode and owners. If + the target is a directory, we do NOT copy into that directory, unlike + with the 'cp' unix command. And error is instead returned. + + "copy" will also do limited recursive copying or directories. If source + is a directory, and target does not exists, a recursive copy of source + will be made to target. If target already exists ( file or directory ), + "copy" will returns with an error. + + move $source, $target + The "move" method follows the conventions of the 'mv' command, with the + exception that the directories containing target will of course be + created on demand. + + remove $filename [, $prune ] + The "remove" method will remove a file, or recursively remove a + directory. + + If a second (true) argument is provided, then once the file or directory + has been deleted, the method will the automatically work its way upwards + pruning (deleting) empty and thus assumably useless directories. + + Returns true if the deletion (and pruning if requested) was a success, + or "undef" otherwise. + + prune $filename + For a file that has already been delete, "prune" will work upwards, + removing any empty directories it finds. + + For anyone familiar with CVS, it is similar to the "update -P" flag. + + Returns true, or "undef" on error. + + truncate $filename [, $size ] + The "truncate" method will truncate an existing file to partular size. A + size of 0 ( zero ) is used if no size is provided. If the file does not + exists, it will be created, and set to 0. Attempting to truncate a + directory will fail. + + Returns true on success, or undef on error. + + makeDirectory $directory [, mode ] + In the case where you do actually have to create a directory only, the + "makeDirectory" method can be used to create a directory or any depth. + + An optional file mode ( default 0755 ) can be provided. + + Returns true on success, returns undef on error. + +TO DO + Function interface to be written, like File::Spec::Functions, to provide + importable functions. + + There's something bigger here too, I'm not exactly sure what it is, but + I think there might be the beginings of a unified filesystem interface + here... FSI.pm + +SUPPORT + Bugs should be filed at via the CPAN bug tracker at: + + <http://rt.cpan.org/NoAuth/ReportBug.html?Queue=File-Flat> + + For other issues or comments, contact the author + +AUTHORS + Adam Kennedy <ad...@cpan.org> + +SEE ALSO + File::Spec, <http://ali.as/> + +COPYRIGHT + Copyright 2002 - 2008 Adam Kennedy. + + This program is free software; you can redistribute it and/or modify it + under the same terms as Perl itself. + + The full text of the license can be found in the LICENSE file included + with this module. + diff --git a/inc/Module/Install.pm b/inc/Module/Install.pm new file mode 100644 index 0000000..760da11 --- /dev/null +++ b/inc/Module/Install.pm @@ -0,0 +1,343 @@ +#line 1 +package Module::Install; + +# For any maintainers: +# The load order for Module::Install is a bit magic. +# It goes something like this... +# +# IF ( host has Module::Install installed, creating author mode ) { +# 1. Makefile.PL calls "use inc::Module::Install" +# 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install +# 3. The installed version of inc::Module::Install loads +# 4. inc::Module::Install calls "require Module::Install" +# 5. The ./inc/ version of Module::Install loads +# } ELSE { +# 1. Makefile.PL calls "use inc::Module::Install" +# 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install +# 3. The ./inc/ version of Module::Install loads +# } + +BEGIN { + require 5.004; +} +use strict 'vars'; + +use vars qw{$VERSION}; +BEGIN { + # All Module::Install core packages now require synchronised versions. + # This will be used to ensure we don't accidentally load old or + # different versions of modules. + # This is not enforced yet, but will be some time in the next few + # releases once we can make sure it won't clash with custom + # Module::Install extensions. + $VERSION = '0.71'; +} + + + + + +# Whether or not inc::Module::Install is actually loaded, the +# $INC{inc/Module/Install.pm} is what will still get set as long as +# the caller loaded module this in the documented manner. +# If not set, the caller may NOT have loaded the bundled version, and thus +# they may not have a MI version that works with the Makefile.PL. This would +# result in false errors or unexpected behaviour. And we don't want that. +my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; +unless ( $INC{$file} ) { die <<"END_DIE" } + +Please invoke ${\__PACKAGE__} with: + + use inc::${\__PACKAGE__}; + +not: + + use ${\__PACKAGE__}; + +END_DIE + + + + + +# If the script that is loading Module::Install is from the future, +# then make will detect this and cause it to re-run over and over +# again. This is bad. Rather than taking action to touch it (which +# is unreliable on some platforms and requires write permissions) +# for now we should catch this and refuse to run. +if ( -f $0 and (stat($0))[9] > time ) { die <<"END_DIE" } + +Your installer $0 has a modification time in the future. + +This is known to create infinite loops in make. + +Please correct this, then run $0 again. + +END_DIE + + + + + +# Build.PL was formerly supported, but no longer is due to excessive +# difficulty in implementing every single feature twice. +if ( $0 =~ /Build.PL$/i or -f 'Build.PL' ) { die <<"END_DIE" } + +Module::Install no longer supports Build.PL. + +It was impossible to maintain duel backends, and has been deprecated. + +Please remove all Build.PL files and only use the Makefile.PL installer. + +END_DIE + + + + + +use Cwd (); +use File::Find (); +use File::Path (); +use FindBin; + +*inc::Module::Install::VERSION = *VERSION; +@inc::Module::Install::ISA = __PACKAGE__; + +sub autoload { + my $self = shift; + my $who = $self->_caller; + my $cwd = Cwd::cwd(); + my $sym = "${who}::AUTOLOAD"; + $sym->{$cwd} = sub { + my $pwd = Cwd::cwd(); + if ( my $code = $sym->{$pwd} ) { + # delegate back to parent dirs + goto &$code unless $cwd eq $pwd; + } + $$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym"; + unshift @_, ( $self, $1 ); + goto &{$self->can('call')} unless uc($1) eq $1; + }; +} + +sub import { + my $class = shift; + my $self = $class->new(@_); + my $who = $self->_caller; + + unless ( -f $self->{file} ) { + require "$self->{path}/$self->{dispatch}.pm"; + File::Path::mkpath("$self->{prefix}/$self->{author}"); + $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); + $self->{admin}->init; + @_ = ($class, _self => $self); + goto &{"$self->{name}::import"}; + } + + *{"${who}::AUTOLOAD"} = $self->autoload; + $self->preload; + + # Unregister loader and worker packages so subdirs can use them again + delete $INC{"$self->{file}"}; + delete $INC{"$self->{path}.pm"}; + + return 1; +} + +sub preload { + my $self = shift; + unless ( $self->{extensions} ) { + $self->load_extensions( + "$self->{prefix}/$self->{path}", $self + ); + } + + my @exts = @{$self->{extensions}}; + unless ( @exts ) { + my $admin = $self->{admin}; + @exts = $admin->load_all_extensions; + } + + my %seen; + foreach my $obj ( @exts ) { + while (my ($method, $glob) = each %{ref($obj) . '::'}) { + next unless $obj->can($method); + next if $method =~ /^_/; + next if $method eq uc($method); + $seen{$method}++; + } + } + + my $who = $self->_caller; + foreach my $name ( sort keys %seen ) { + *{"${who}::$name"} = sub { + ${"${who}::AUTOLOAD"} = "${who}::$name"; + goto &{"${who}::AUTOLOAD"}; + }; + } +} + +sub new { + my ($class, %args) = @_; + + # ignore the prefix on extension modules built from top level. + my $base_path = Cwd::abs_path($FindBin::Bin); + unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) { + delete $args{prefix}; + } + + return $args{_self} if $args{_self}; + + $args{dispatch} ||= 'Admin'; + $args{prefix} ||= 'inc'; + $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); + $args{bundle} ||= 'inc/BUNDLES'; + $args{base} ||= $base_path; + $class =~ s/^\Q$args{prefix}\E:://; + $args{name} ||= $class; + $args{version} ||= $class->VERSION; + unless ( $args{path} ) { + $args{path} = $args{name}; + $args{path} =~ s!::!/!g; + } + $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; + $args{wrote} = 0; + + bless( \%args, $class ); +} + +sub call { + my ($self, $method) = @_; + my $obj = $self->load($method) or return; + splice(@_, 0, 2, $obj); + goto &{$obj->can($method)}; +} + +sub load { + my ($self, $method) = @_; + + $self->load_extensions( + "$self->{prefix}/$self->{path}", $self + ) unless $self->{extensions}; + + foreach my $obj (@{$self->{extensions}}) { + return $obj if $obj->can($method); + } + + my $admin = $self->{admin} or die <<"END_DIE"; +The '$method' method does not exist in the '$self->{prefix}' path! +Please remove the '$self->{prefix}' directory and run $0 again to load it. +END_DIE + + my $obj = $admin->load($method, 1); + push @{$self->{extensions}}, $obj; + + $obj; +} + +sub load_extensions { + my ($self, $path, $top) = @_; + + unless ( grep { lc $_ eq lc $self->{prefix} } @INC ) { + unshift @INC, $self->{prefix}; + } + + foreach my $rv ( $self->find_extensions($path) ) { + my ($file, $pkg) = @{$rv}; + next if $self->{pathnames}{$pkg}; + + local $@; + my $new = eval { require $file; $pkg->can('new') }; + unless ( $new ) { + warn $@ if $@; + next; + } + $self->{pathnames}{$pkg} = delete $INC{$file}; + push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); + } + + $self->{extensions} ||= []; +} + +sub find_extensions { + my ($self, $path) = @_; + + my @found; + File::Find::find( sub { + my $file = $File::Find::name; + return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; + my $subpath = $1; + return if lc($subpath) eq lc($self->{dispatch}); + + $file = "$self->{path}/$subpath.pm"; + my $pkg = "$self->{name}::$subpath"; + $pkg =~ s!/!::!g; + + # If we have a mixed-case package name, assume case has been preserved + # correctly. Otherwise, root through the file to locate the case-preserved + # version of the package name. + if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { + my $content = Module::Install::_read($subpath . '.pm'); + my $in_pod = 0; + foreach ( split //, $content ) { + $in_pod = 1 if /^=\w/; + $in_pod = 0 if /^=cut/; + next if ($in_pod || /^=cut/); # skip pod text + next if /^\s*#/; # and comments + if ( m/^\s*package\s+($pkg)\s*;/i ) { + $pkg = $1; + last; + } + } + } + + push @found, [ $file, $pkg ]; + }, $path ) if -d $path; + + @found; +} + + + + + +##################################################################### +# Utility Functions + +sub _caller { + my $depth = 0; + my $call = caller($depth); + while ( $call eq __PACKAGE__ ) { + $depth++; + $call = caller($depth); + } + return $call; +} + +sub _read { + local *FH; + open FH, "< $_[0]" or die "open($_[0]): $!"; + my $str = do { local $/; <FH> }; + close FH or die "close($_[0]): $!"; + return $str; +} + +sub _write { + local *FH; + open FH, "> $_[0]" or die "open($_[0]): $!"; + foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!" } + close FH or die "close($_[0]): $!"; +} + +sub _version { + my $s = shift || 0; + $s =~ s/^(\d+)\.?//; + my $l = $1 || 0; + my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g; + $l = $l . '.' . join '', @v if @v; + return $l + 0; +} + +1; + +# Copyright 2008 Adam Kennedy. diff --git a/inc/Module/Install/Base.pm b/inc/Module/Install/Base.pm new file mode 100644 index 0000000..f07878d --- /dev/null +++ b/inc/Module/Install/Base.pm @@ -0,0 +1,70 @@ +#line 1 +package Module::Install::Base; + +$VERSION = '0.71'; + +# Suspend handler for "redefined" warnings +BEGIN { + my $w = $SIG{__WARN__}; + $SIG{__WARN__} = sub { $w }; +} + +### This is the ONLY module that shouldn't have strict on +# use strict; + +#line 41 + +sub new { + my ($class, %args) = @_; + + foreach my $method ( qw(call load) ) { + *{"$class\::$method"} = sub { + shift()->_top->$method(@_); + } unless defined &{"$class\::$method"}; + } + + bless( \%args, $class ); +} + +#line 61 + +sub AUTOLOAD { + my $self = shift; + local $@; + my $autoload = eval { $self->_top->autoload } or return; + goto &$autoload; +} + +#line 76 + +sub _top { $_[0]->{_top} } + +#line 89 + +sub admin { + $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new; +} + +sub is_admin { + $_[0]->admin->VERSION; +} + +sub DESTROY {} + +package Module::Install::Base::FakeAdmin; + +my $Fake; +sub new { $Fake ||= bless(\@_, $_[0]) } + +sub AUTOLOAD {} + +sub DESTROY {} + +# Restore warning handler +BEGIN { + $SIG{__WARN__} = $SIG{__WARN__}->(); +} + +1; + +#line 138 diff --git a/inc/Module/Install/Can.pm b/inc/Module/Install/Can.pm new file mode 100644 index 0000000..410a0fc --- /dev/null +++ b/inc/Module/Install/Can.pm @@ -0,0 +1,82 @@ +#line 1 +package Module::Install::Can; + +use strict; +use Module::Install::Base; +use Config (); +### This adds a 5.005 Perl version dependency. +### This is a bug and will be fixed. +use File::Spec (); +use ExtUtils::MakeMaker (); + +use vars qw{$VERSION $ISCORE @ISA}; +BEGIN { + $VERSION = '0.71'; + $ISCORE = 1; + @ISA = qw{Module::Install::Base}; +} + +# check if we can load some module +### Upgrade this to not have to load the module if possible +sub can_use { + my ($self, $mod, $ver) = @_; + $mod =~ s{::|\\}{/}g; + $mod .= '.pm' unless $mod =~ /\.pm$/i; + + my $pkg = $mod; + $pkg =~ s{/}{::}g; + $pkg =~ s{\.pm$}{}i; + + local $@; + eval { require $mod; $pkg->VERSION($ver || 0); 1 }; +} + +# check if we can run some command +sub can_run { + my ($self, $cmd) = @_; + + my $_cmd = $cmd; + return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); + + for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { + my $abs = File::Spec->catfile($dir, $_[1]); + return $abs if (-x $abs or $abs = MM->maybe_command($abs)); + } + + return; +} + +# can we locate a (the) C compiler +sub can_cc { + my $self = shift; + my @chunks = split(/ /, $Config::Config{cc}) or return; + + # $Config{cc} may contain args; try to find out the program part + while (@chunks) { + return $self->can_run("@chunks") || (pop(@chunks), next); + } + + return; +} + +# Fix Cygwin bug on maybe_command(); +if ( $^O eq 'cygwin' ) { + require ExtUtils::MM_Cygwin; + require ExtUtils::MM_Win32; + if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) { + *ExtUtils::MM_Cygwin::maybe_command = sub { + my ($self, $file) = @_; + if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) { + ExtUtils::MM_Win32->maybe_command($file); + } else { + ExtUtils::MM_Unix->maybe_command($file); + } + } + } +} + +1; + +__END__ + +#line 157 diff --git a/inc/Module/Install/Fetch.pm b/inc/Module/Install/Fetch.pm new file mode 100644 index 0000000..f7cd58e --- /dev/null +++ b/inc/Module/Install/Fetch.pm @@ -0,0 +1,93 @@ +#line 1 +package Module::Install::Fetch; + +use strict; +use Module::Install::Base; + +use vars qw{$VERSION $ISCORE @ISA}; +BEGIN { + $VERSION = '0.71'; + $ISCORE = 1; + @ISA = qw{Module::Install::Base}; +} + +sub get_file { + my ($self, %args) = @_; + my ($scheme, $host, $path, $file) = + $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; + + if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) { + $args{url} = $args{ftp_url} + or (warn("LWP support unavailable!\n"), return); + ($scheme, $host, $path, $file) = + $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; + } + + $|++; + print "Fetching '$file' from $host... "; + + unless (eval { require Socket; Socket::inet_aton($host) }) { + warn "'$host' resolve failed!\n"; + return; + } + + return unless $scheme eq 'ftp' or $scheme eq 'http'; + + require Cwd; + my $dir = Cwd::getcwd(); + chdir $args{local_dir} or return if exists $args{local_dir}; + + if (eval { require LWP::Simple; 1 }) { + LWP::Simple::mirror($args{url}, $file); + } + elsif (eval { require Net::FTP; 1 }) { eval { + # use Net::FTP to get past firewall + my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600); + $ftp->login("anonymous", 'anonym...@example.com'); + $ftp->cwd($path); + $ftp->binary; + $ftp->get($file) or (warn("$!\n"), return); + $ftp->quit; + } } + elsif (my $ftp = $self->can_run('ftp')) { eval { + # no Net::FTP, fallback to ftp.exe + require FileHandle; + my $fh = FileHandle->new; + + local $SIG{CHLD} = 'IGNORE'; + unless ($fh->open("|$ftp -n")) { + warn "Couldn't open ftp: $!\n"; + chdir $dir; return; + } + + my @dialog = split(/\n/, <<"END_FTP"); +open $host +user anonymous anonymous\@example.com +cd $path +binary +get $file $file +quit +END_FTP + foreach (@dialog) { $fh->print("$_\n") } + $fh->close; + } } + else { + warn "No working 'ftp' program available!\n"; + chdir $dir; return; + } + + unless (-f $file) { + warn "Fetching failed: $@\n"; + chdir $dir; return; + } + + return if exists $args{size} and -s $file != $args{size}; + system($args{run}) if exists $args{run}; + unlink($file) if $args{remove}; + + print(((!exists $args{check_for} or -e $args{check_for}) + ? "done!" : "failed! ($!)"), "\n"); + chdir $dir; return !$?; +} + +1; diff --git a/inc/Module/Install/Makefile.pm b/inc/Module/Install/Makefile.pm new file mode 100644 index 0000000..3bfaf4c --- /dev/null +++ b/inc/Module/Install/Makefile.pm @@ -0,0 +1,245 @@ +#line 1 +package Module::Install::Makefile; + +use strict 'vars'; +use Module::Install::Base; +use ExtUtils::MakeMaker (); + +use vars qw{$VERSION $ISCORE @ISA}; +BEGIN { + $VERSION = '0.71'; + $ISCORE = 1; + @ISA = qw{Module::Install::Base}; +} + +sub Makefile { $_[0] } + +my %seen = (); + +sub prompt { + shift; + + # Infinite loop protection + my @c = caller(); + if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) { + die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])"; + } + + # In automated testing, always use defaults + if ( $ENV{AUTOMATED_TESTING} and ! $ENV{PERL_MM_USE_DEFAULT} ) { + local $ENV{PERL_MM_USE_DEFAULT} = 1; + goto &ExtUtils::MakeMaker::prompt; + } else { + goto &ExtUtils::MakeMaker::prompt; + } +} + +sub makemaker_args { + my $self = shift; + my $args = ($self->{makemaker_args} ||= {}); + %$args = ( %$args, @_ ) if @_; + $args; +} + +# For mm args that take multiple space-seperated args, +# append an argument to the current list. +sub makemaker_append { + my $self = sShift; + my $name = shift; + my $args = $self->makemaker_args; + $args->{name} = defined $args->{$name} + ? join( ' ', $args->{name}, @_ ) + : join( ' ', @_ ); +} + +sub build_subdirs { + my $self = shift; + my $subdirs = $self->makemaker_args->{DIR} ||= []; + for my $subdir (@_) { + push @$subdirs, $subdir; + } +} + +sub clean_files { + my $self = shift; + my $clean = $self->makemaker_args->{clean} ||= {}; + %$clean = ( + %$clean, + FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_), + ); +} + +sub realclean_files { + my $self = shift; + my $realclean = $self->makemaker_args->{realclean} ||= {}; + %$realclean = ( + %$realclean, + FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_), + ); +} + +sub libs { + my $self = shift; + my $libs = ref $_[0] ? shift : [ shift ]; + $self->makemaker_args( LIBS => $libs ); +} + +sub inc { + my $self = shift; + $self->makemaker_args( INC => shift ); +} + +my %test_dir = (); + +sub _wanted_t { + /\.t$/ and -f $_ and $test_dir{$File::Find::dir} = 1; +} + +sub tests_recursive { + my $self = shift; + if ( $self->tests ) { + die "tests_recursive will not work if tests are already defined"; + } + my $dir = shift || 't'; + unless ( -d $dir ) { + die "tests_recursive dir '$dir' does not exist"; + } + %test_dir = (); + require File::Find; + File::Find::find( \&_wanted_t, $dir ); + $self->tests( join ' ', map { "$_/*.t" } sort keys %test_dir ); +} + +sub write { + my $self = shift; + die "&Makefile->write() takes no arguments\n" if @_; + + # Make sure we have a new enough + require ExtUtils::MakeMaker; + $self->configure_requires( 'ExtUtils::MakeMaker' => $ExtUtils::MakeMaker::VERSION ); + + # Generate the + my $args = $self->makemaker_args; + $args->{DISTNAME} = $self->name; + $args->{NAME} = $self->module_name || $self->name; + $args->{VERSION} = $self->version; + $args->{NAME} =~ s/-/::/g; + if ( $self->tests ) { + $args->{test} = { TESTS => $self->tests }; + } + if ($] >= 5.005) { + $args->{ABSTRACT} = $self->abstract; + $args->{AUTHOR} = $self->author; + } + if ( eval($ExtUtils::MakeMaker::VERSION) >= 6.10 ) { + $args->{NO_META} = 1; + } + if ( eval($ExtUtils::MakeMaker::VERSION) > 6.17 and $self->sign ) { + $args->{SIGN} = 1; + } + unless ( $self->is_admin ) { + delete $args->{SIGN}; + } + + # merge both kinds of requires into prereq_pm + my $prereq = ($args->{PREREQ_PM} ||= {}); + %$prereq = ( %$prereq, + map { @$_ } + map { @$_ } + grep $_, + ($self->configure_requires, $self->build_requires, $self->requires) + ); + + # Remove any reference to perl, PREREQ_PM doesn't support it + delete $args->{PREREQ_PM}->{perl}; + + # merge both kinds of requires into prereq_pm + my $subdirs = ($args->{DIR} ||= []); + if ($self->bundles) { + foreach my $bundle (@{ $self->bundles }) { + my ($file, $dir) = @$bundle; + push @$subdirs, $dir if -d $dir; + delete $prereq->{$file}; + } + } + + if ( my $perl_version = $self->perl_version ) { + eval "use $perl_version; 1" + or die "ERROR: perl: Version $] is installed, " + . "but we need version >= $perl_version"; + } + + $args->{INSTALLDIRS} = $self->installdirs; + + my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_})} keys %$args; + + my $user_preop = delete $args{dist}->{PREOP}; + if (my $preop = $self->admin->preop($user_preop)) { + $args{dist} = $preop; + } + + my $mm = ExtUtils::MakeMaker::WriteMakefile(%args); + $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile'); +} + +sub fix_up_makefile { + my $self = shift; + my $makefile_name = shift; + my $top_class = ref($self->_top) || ''; + my $top_version = $self->_top->VERSION || ''; + + my $preamble = $self->preamble + ? "# Preamble by $top_class $top_version\n" + . $self->preamble + : ''; + my $postamble = "# Postamble by $top_class $top_version\n" + . ($self->postamble || ''); + + local *MAKEFILE; + open MAKEFILE, "< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; + my $makefile = do { local $/; <MAKEFILE> }; + close MAKEFILE or die $!; + + $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; + $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; + $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g; + $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m; + $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m; + + # Module::Install will never be used to build the Core Perl + # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks + # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist + $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m; + #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m; + + # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well. + $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g; + + # XXX - This is currently unused; not sure if it breaks other MM-users + # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg; + + open MAKEFILE, "> $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; + print MAKEFILE "$preamble$makefile$postamble" or die $!; + close MAKEFILE or die $!; + + 1; +} + +sub preamble { + my ($self, $text) = @_; + $self->{preamble} = $text . $self->{preamble} if defined $text; + $self->{preamble}; +} + +sub postamble { + my ($self, $text) = @_; + $self->{postamble} ||= $self->admin->postamble; + $self->{postamble} .= $text if defined $text; + $self->{postamble} +} + +1; + +__END__ + +#line 371 diff --git a/inc/Module/Install/Metadata.pm b/inc/Module/Install/Metadata.pm new file mode 100644 index 0000000..3552f86 --- /dev/null +++ b/inc/Module/Install/Metadata.pm @@ -0,0 +1,371 @@ +#line 1 +package Module::Install::Metadata; + +use strict 'vars'; +use Module::Install::Base; + +use vars qw{$VERSION $ISCORE @ISA}; +BEGIN { + $VERSION = '0.71'; + $ISCORE = 1; + @ISA = qw{Module::Install::Base}; +} + +my @scalar_keys = qw{ + name + module_name + abstract + author + version + license + distribution_type + perl_version + tests + installdirs +}; + +my @tuple_keys = qw{ + configure_requires + build_requires + requires + recommends + bundles +}; + +sub Meta { shift } +sub Meta_ScalarKeys { @scalar_keys } +sub Meta_TupleKeys { @tuple_keys } + +foreach my $key (@scalar_keys) { + *$key = sub { + my $self = shift; + return $self->{values}{$key} if defined wantarray and !@_; + $self->{values}{$key} = shift; + return $self; + }; +} + +sub requires { + my $self = shift; + while ( @_ ) { + my $module = shift or last; + my $version = shift || 0; + push @{ $self->{values}->{requires} }, [ $module, $version ]; + } + $self->{values}{requires}; +} + +sub build_requires { + my $self = shift; + while ( @_ ) { + my $module = shift or last; + my $version = shift || 0; + push @{ $self->{values}->{build_requires} }, [ $module, $version ]; + } + $self->{values}{build_requires}; +} + +sub configure_requires { + my $self = shift; + while ( @_ ) { + my $module = shift or last; + my $version = shift || 0; + push @{ $self->{values}->{configure_requires} }, [ $module, $version ]; + } + $self->{values}{configure_requires}; +} + +sub recommends { + my $self = shift; + while ( @_ ) { + my $module = shift or last; + my $version = shift || 0; + push @{ $self->{values}->{recommends} }, [ $module, $version ]; + } + $self->{values}{recommends}; +} + +sub bundles { + my $self = shift; + while ( @_ ) { + my $module = shift or last; + my $version = shift || 0; + push @{ $self->{values}->{bundles} }, [ $module, $version ]; + } + $self->{values}{bundles}; +} + +# Aliases for build_requires that will have alternative +# meanings in some future version of META.yml. +sub test_requires { shift->build_requires(@_) } +sub install_requires { shift->build_requires(@_) } + +# Aliases for installdirs options +sub install_as_core { $_[0]->installdirs('perl') } +sub install_as_cpan { $_[0]->installdirs('site') } +sub install_as_site { $_[0]->installdirs('site') } +sub install_as_vendor { $_[0]->installdirs('vendor') } + +sub sign { + my $self = shift; + return $self->{'values'}{'sign'} if defined wantarray and ! @_; + $self->{'values'}{'sign'} = ( @_ ? $_[0] : 1 ); + return $self; +} + +sub dynamic_config { + my $self = shift; + unless ( @_ ) { + warn "You MUST provide an explicit true/false value to dynamic_config, skipping\n"; + return $self; + } + $self->{values}{dynamic_config} = $_[0] ? 1 : 0; + return $self; +} + +sub all_from { + my ( $self, $file ) = @_; + + unless ( defined($file) ) { + my $name = $self->name + or die "all_from called with no args without setting name() first"; + $file = join('/', 'lib', split(/-/, $name)) . '.pm'; + $file =~ s{.*/}{} unless -e $file; + die "all_from: cannot find $file from $name" unless -e $file; + } + + # Some methods pull from POD instead of code. + # If there is a matching .pod, use that instead + my $pod = $file; + $pod =~ s/\.pm$/.pod/i; + $pod = $file unless -e $pod; + + # Pull the different values + $self->name_from($file) unless $self->name; + $self->version_from($file) unless $self->version; + $self->perl_version_from($file) unless $self->perl_version; + $self->author_from($pod) unless $self->author; + $self->license_from($pod) unless $self->license; + $self->abstract_from($pod) unless $self->abstract; + + return 1; +} + +sub provides { + my $self = shift; + my $provides = ( $self->{values}{provides} ||= {} ); + %$provides = (%$provides, @_) if @_; + return $provides; +} + +sub auto_provides { + my $self = shift; + return $self unless $self->is_admin; + unless (-e 'MANIFEST') { + warn "Cannot deduce auto_provides without a MANIFEST, skipping\n"; + return $self; + } + # Avoid spurious warnings as we are not checking manifest here. + local $SIG{__WARN__} = sub {1}; + require ExtUtils::Manifest; + local *ExtUtils::Manifest::manicheck = sub { return }; + + require Module::Build; + my $build = Module::Build->new( + dist_name => $self->name, + dist_version => $self->version, + license => $self->license, + ); + $self->provides( %{ $build->find_dist_packages || {} } ); +} + +sub feature { + my $self = shift; + my $name = shift; + my $features = ( $self->{values}{features} ||= [] ); + my $mods; + + if ( @_ == 1 and ref( $_[0] ) ) { + # The user used ->feature like ->features by passing in the second + # argument as a reference. Accomodate for that. + $mods = $_[0]; + } else { + $mods = \@_; + } + + my $count = 0; + push @$features, ( + $name => [ + map { + ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_ + } @$mods + ] + ); + + return @$features; +} + +sub features { + my $self = shift; + while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) { + $self->feature( $name, @$mods ); + } + return $self->{values}->{features} + ? @{ $self->{values}->{features} } + : (); +} + +sub no_index { + my $self = shift; + my $type = shift; + push @{ $self->{values}{no_index}{$type} }, @_ if $type; + return $self->{values}{no_index}; +} + +sub read { + my $self = shift; + $self->include_deps( 'YAML::Tiny', 0 ); + + require YAML::Tiny; + my $data = YAML::Tiny::LoadFile('META.yml'); + + # Call methods explicitly in case user has already set some values. + while ( my ( $key, $value ) = each %$data ) { + next unless $self->can($key); + if ( ref $value eq 'HASH' ) { + while ( my ( $module, $version ) = each %$value ) { + $self->can($key)->($self, $module => $version ); + } + } else { + $self->can($key)->($self, $value); + } + } + return $self; +} + +sub write { + my $self = shift; + return $self unless $self->is_admin; + $self->admin->write_meta; + return $self; +} + +sub version_from { + require ExtUtils::MM_Unix; + my ( $self, $file ) = @_; + $self->version( ExtUtils::MM_Unix->parse_version($file) ); +} + +sub abstract_from { + require ExtUtils::MM_Unix; + my ( $self, $file ) = @_; + $self->abstract( + bless( + { DISTNAME => $self->name }, + 'ExtUtils::MM_Unix' + )->parse_abstract($file) + ); +} + +sub name_from { + my $self = shift; + if ( + Module::Install::_read($_[0]) =~ m/ + ^ \s + package \s* + ([\w:]+) + \s* ; + /ixms + ) { + my $name = $1; + $name =~ s{::}{-}g; + $self->name($name); + } else { + die "Cannot determine name from $_[0]\n"; + return; + } +} + +sub perl_version_from { + my $self = shift; + if ( + Module::Install::_read($_[0]) =~ m/ + ^ + use \s* + v? + ([\d_\.]+) + \s* ; + /ixms + ) { + my $perl_version = $1; + $perl_version =~ s{_}{}g; + $self->perl_version($perl_version); + } else { + warn "Cannot determine perl version info from $_[0]\n"; + return; + } +} + +sub author_from { + my $self = shift; + my $content = Module::Install::_read($_[0]); + if ($content =~ m/ + =head \d \s+ (?:authors?)\b \s* + ([^\n]*) + | + =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s* + .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s* + ([^\n]*) + /ixms) { + my $author = $1 || $2; + $author =~ s{E<lt>}{<}g; + $author =~ s{E<gt>}{>}g; + $self->author($author); + } else { + warn "Cannot determine author info from $_[0]\n"; + } +} + +sub license_from { + my $self = shift; + if ( + Module::Install::_read($_[0]) =~ m/ + ( + =head \d \s+ + (?:licen[cs]e|licensing|copyright|legal)\b + .*? + ) + (=head\\d.*|=cut.*|) + \z + /ixms ) { + my $license_text = $1; + my @phrases = ( + 'under the same (?:terms|license) as perl itself' => 'perl', 1, + 'GNU public license' => 'gpl', 1, + 'GNU lesser public license' => 'lgpl', 1, + 'BSD license' => 'bsd', 1, + 'Artistic license' => 'artistic', 1, + 'GPL' => 'gpl', 1, + 'LGPL' => 'lgpl', 1, + 'BSD' => 'bsd', 1, + 'Artistic' => 'artistic', 1, + 'MIT' => 'mit', 1, + 'proprietary' => 'proprietary', 0, + ); + while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { + $pattern =~ s{\s+}{\\s+}g; + if ( $license_text =~ /\b$pattern\b/i ) { + if ( $osi and $license_text =~ /All rights reserved/i ) { + warn "LEGAL WARNING: 'All rights reserved' may invalidate Open Source licenses. Consider removing it."; + } + $self->license($license); + return 1; + } + } + } + + warn "Cannot determine license info from $_[0]\n"; + return 'unknown'; +} + +1; diff --git a/inc/Module/Install/Win32.pm b/inc/Module/Install/Win32.pm new file mode 100644 index 0000000..dcc6f57 --- /dev/null +++ b/inc/Module/Install/Win32.pm @@ -0,0 +1,64 @@ +#line 1 +package Module::Install::Win32; + +use strict; +use Module::Install::Base; + +use vars qw{$VERSION @ISA $ISCORE}; +BEGIN { + $VERSION = '0.71'; + @ISA = qw{Module::Install::Base}; + $ISCORE = 1; +} + +# determine if the user needs nmake, and download it if needed +sub check_nmake { + my $self = shift; + $self->load('can_run'); + $self->load('get_file'); + + require Config; + return unless ( + $^O eq 'MSWin32' and + $Config::Config{make} and + $Config::Config{make} =~ /^nmake\b/i and + ! $self->can_run('nmake') + ); + + print "The required 'nmake' executable not found, fetching it...\n"; + + require File::Basename; + my $rv = $self->get_file( + url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe', + ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe', + local_dir => File::Basename::dirname($^X), + size => 51928, + run => 'Nmake15.exe /o > nul', + check_for => 'Nmake.exe', + remove => 1, + ); + + die <<'END_MESSAGE' unless $rv; + +------------------------------------------------------------------------------- + +Since you are using Microsoft Windows, you will need the 'nmake' utility +before installation. It's available at: + + http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe + or + ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe + +Please download the file manually, save it to a directory in %PATH% (e.g. +C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to +that directory, and run "Nmake15.exe" from there; that will create the +'nmake.exe' file needed by this module. + +You may then resume the installation process described in README. + +------------------------------------------------------------------------------- +END_MESSAGE + +} + +1; diff --git a/inc/Module/Install/WriteAll.pm b/inc/Module/Install/WriteAll.pm new file mode 100644 index 0000000..13437e6 --- /dev/null +++ b/inc/Module/Install/WriteAll.pm @@ -0,0 +1,40 @@ +#line 1 +package Module::Install::WriteAll; + +use strict; +use Module::Install::Base; + +use vars qw{$VERSION @ISA $ISCORE}; +BEGIN { + $VERSION = '0.71'; + @ISA = qw{Module::Install::Base}; + $ISCORE = 1; +} + +sub WriteAll { + my $self = shift; + my %args = ( + meta => 1, + sign => 0, + inline => 0, + check_nmake => 1, + @_, + ); + + $self->sign(1) if $args{sign}; + $self->Meta->write if $args{meta}; + $self->admin->WriteAll(%args) if $self->is_admin; + + $self->check_nmake if $args{check_nmake}; + unless ( $self->makemaker_args->{PL_FILES} ) { + $self->makemaker_args( PL_FILES => {} ); + } + + if ( $args{inline} ) { + $self->Inline->write; + } else { + $self->Makefile->write; + } +} + +1; diff --git a/lib/File/Flat.pm b/lib/File/Flat.pm new file mode 100644 index 0000000..e9459bb --- /dev/null +++ b/lib/File/Flat.pm @@ -0,0 +1,1152 @@ +package File::Flat; + +# The File::Flat is a static class that provides a unified interface +# to the filesystem in a way such that directories are abstracted away. + +# This should work on non-Unix platforms, but there may be some +# minor remaining bugs. + +use 5.005; +use strict; +use Cwd (); +use File::Spec (); +use IO::File (); +use prefork 'File::Temp'; +use prefork 'File::Copy'; +use prefork 'File::Copy::Recursive'; +use prefork 'File::Remove'; + +use vars qw{$VERSION $errstr %modes $AUTO_PRUNE}; +BEGIN { + $VERSION = '1.04'; + + # The main error string + $errstr = ''; + + # Create a map of all file open modes we support, + # and which ones will create a new file if needed. + %modes = ( + '<' => 0, 'r' => 0, # Read + '+<' => 1, 'r+' => 1, # ReadWrite + '>' => 1, 'w' => 1, # Write + '+>' => 1, 'w+' => 1, # ReadWrite + '>>' => 1, 'a' => 1 # Append + ); + + $AUTO_PRUNE = ''; +} + + + + + +##################################################################### +# Examining the file system + +# Does a filesystem entity exist. +sub exists { defined $_[1] and -e $_[1] } + +# Is a filesystem object a file. +sub isaFile { defined $_[1] and -f $_[1] } + +# Is a filesystem object a directory. +sub isaDirectory { defined $_[1] and -d $_[1] } + +# Do we have permission to read a filesystem object. +sub canRead { defined $_[1] and -e $_[1] and -r _ } + +# Do we have permission to write to a filesystem object. +# If it doesn't exist, can we create it. +sub canWrite { + # If it already exists, check normally + return -w $_[1] if -e $_[1]; + + # Can we create it + my $Object = File::Flat::Object->new( $_[1] ) or return undef; + $Object->_canCreate; +} + +# Can we both read and write to a filesystem object +sub canReadWrite { defined $_[1] and -r $_[1] and -w _ } + +# Do we have permission to execute a filesystem object +sub canExecute { defined $_[1] and -x $_[1] } + +# Could we open this as a file +sub canOpen { defined $_[1] and -f $_[1] and -r _ } + +# Could a file or directory be removed, were we to try +sub canRemove { + # Pass through to the object class + my $Object = File::Flat::Object->new( $_[1] ) or return undef; + $Object->canRemove; +} + +# Is the file a text file +sub isText { defined $_[1] and -f $_[1] and -T $_[1] } + +# Is a file a binary file. +sub isBinary { defined $_[1] and -f $_[1] and -B $_[1] } + +# Stat based methods. +# I've included only the most usefull one I can think of. +sub fileSize { + my $class = shift; + my $file = shift or return undef; + + # Check the file + return $class->_error( 'File does not exist' ) unless -e $file; + return $class->_error( 'Cannot get the file size for a directory' ) unless -f _; + + # A file's size is contained in element 7 + (stat $file)[7]; +} + + + + + +##################################################################### +# Opening Files. + +# Note: Files are closed conventionally using the IO::Handle's methods. + +# Open a file. +# Takes as arguments either a ">filepath" style file name, or the two argument +# form of "mode", "filename". Supports perl '<' type modes, and fopen 'rw' +# type modes. Pipes and more advanced things are not supported. +# Both the 1 and 2 argument modes are supported. +# Returns an IO::File for the filesystem object. +sub open { + my $class = shift; + + # One or two argument form + my ($file, $mode) = (); + if ( @_ == 1 ) { + $file = shift; + + # Read by default + $mode = $file =~ s/^([<>+]{1,2})\s*// ? $1 : '<'; + + } elsif ( @_ == 2 ) { + $mode = shift; + $file = shift; + + } else { + return $class->_error( "Invalid argument count to ->open" ); + } + + # Check the mode + unless ( exists $modes{$mode} ) { + return $class->_error( "Unknown or unsupported mode '$mode'" ); + } + + # Ensure the directory exists for those that need it + my $remove_on_fail = ''; + if ( $modes{$mode} and ! -e $file ) { + $remove_on_fail = $class->_makePath( $file ); + return undef unless defined $remove_on_fail; + } + + # Try to get the IO::File + IO::File->new( $file, $mode ) + or $class->_andRemove( $remove_on_fail ); +} + +# Provide creation mode specific methods +sub getReadHandle { $_[0]->open( '<', $_[1] ) } +sub getWriteHandle { $_[0]->open( '>', $_[1] ) } +sub getAppendHandle { $_[0]->open( '>>', $_[1] ) } +sub getReadWriteHandle { $_[0]->open( '+<', $_[1] ) } + + + + + +##################################################################### +# Quick File Methods + +# Slurp quickly reads in an entire file in a memory efficient manner. +# Reads and file and returns a reference to a scalar containing the file. +# Returns 0 if the file does not exist. +# Returns undef on error. +sub slurp { + my $class = shift; + my $file = shift or return undef; + + # Check the file + $class->canOpen( $file ) + or return $class->_error( "Unable to open file '$file'" ); + + # Use idiomatic slurp instead of File::Slurp + _slurp($file) or $class->_error( "Error opening file '$file'", $! ); +} + +# Provide a simple _slurp implementation +sub _slurp { + my $file = shift; + local $/ = undef; + local *SLURP; + CORE::open( SLURP, "<$file" ) or return undef; + my $source = <SLURP>; + CORE::close( SLURP ) or return undef; + \$source; +} + +# read reads in an entire file, returning it as an array or a reference to it. +# depending on the calling context. Returns undef or () on error, depending on +# the calling context. +sub read { + my $class = shift; + my $file = shift or return; + + # Check the file + unless ( $class->canOpen( $file ) ) { + $class->_error( "Unable to open file '$file'" ); + return; + } + + # Load the file + unless ( CORE::open(FILE, $file) ) { + $class->_error( "Unable to open file '$file'" ); + return; + } + my @content = <FILE>; + chomp @content; + CORE::close(FILE); + + wantarray ? @content : \@content; +} + +# writeFile writes a file to the filesystem, replacing the existing file +# if needed. Existing files will be clobbered before starting to write to +# the file, as per a typical write file handle. +sub write { + my $class = shift; + my $file = shift or return undef; + unless ( defined $_[0] ) { + return $class->_error( "Did not pass anything to write to file" ); + } + + # Get a ref to the contents. + # This looks messy, but it avoids copying potentially large amounts + # of data in memory, bloating the RAM usage. + # This also makes sure the stuff we are going to write is ok. + my $contents; + if ( ref $_[0] ) { + unless ( UNIVERSAL::isa($_[0], 'SCALAR') or UNIVERSAL::isa($_[0], 'ARRAY') ) { + return $class->_error( "Unknown or invalid argument to ->write" ); + } + + $contents = $_[0]; + } else { + $contents = \$_[0]; + } + + # Get an opened write file handle if we weren't passed a handle already. + # When this falls out of context, it will close itself. + # Since there are many things that act like file handles, don't check + # specifically for IO::Handle or anything, just for a reference. + my $dontclose = 0; + if ( ref $file ) { + # Don't close is someone passes us a handle. + # They might want to write other things. + $dontclose = 1; + } else { + $file = $class->getWriteHandle( $file ) or return undef; + } + + # Write the contents to the handle + if ( UNIVERSAL::isa($contents, 'SCALAR') ) { + $file->print( $$contents ) or return undef; + } else { + foreach ( @$contents ) { + # When printing the lines to the file, + # fix any possible newline problems. + chomp $_; + $file->print( $_ . "\n" ) or return undef; + } + } + + # Close the file if needed + $file->close unless $dontclose; + + 1; +} + +# overwrite() writes a file to the filesystem, replacing the existing file +# if needed. Existing files will be clobbered at the end of writing the file, +# essentially allowing you to write the file to disk atomically. +sub overwrite { + my $class = shift; + my $file = shift or return undef; + return undef unless defined $_[0]; + + # Make sure we will be able to write over the file + unless ( $class->canWrite($file) ) { + return $class->_error( "Will not be able to create the file '$file'" ); + } + + # Load in the two libraries we need. + # It's a fair chunk of overhead, so we do it here instead of up + # the top so it only loads in if we need to do overwriting. + # Not as good as Class::Autouse, but these arn't OO modules. + require File::Temp; + require File::Copy; + + # Get a temp file + my ($handle, $tempfile) = File::Temp::tempfile( SUFFIX => '.tmp', UNLINK => 0 ); + + # Write the content to it. + # Pass the argument by reference if it isn't already, + # to avoid copying large scalars. + unless ( $class->write( $handle, ref $_[0] ? $_[0] : \$_[0] ) ) { + # Clean up and return an error + $handle->close; + unlink $tempfile; + return $class->_error( "Error while writing file" ); + } + + # We are finished with the handle + $handle->close; + + # Now move the finished file to the final location + unless ( File::Copy::move( $tempfile, $file ) ) { + # Clean up the tempfile and return an error + unlink $tempfile; + return $class->_error( "Failed to copy file into final location" ); + } + + 1; +} + +# appendFile writes content to the end of an existing file, or creating the +# file if needed. +sub append { + my $class = shift; + my $file = shift or return undef; + return undef unless defined $_[0]; + + # Get the appending handle, and write to it + my $handle = $class->getAppendHandle( $file ) or return undef; + unless ( $class->write( $handle, ref $_[0] ? $_[0] : \$_[0] ) ) { + # Clean up and return an error + $handle->close; + return $class->_error( "Error while writing file" ); + } + $handle->close; + + 1; +} + +# Copy a file or directory from one place to another. +# We apply our own copy semantics. +sub copy { + my $class = shift; + return undef unless defined($_[0]) && defined($_[1]); + my $source = File::Spec->canonpath( shift ) or return undef; + my $target = File::Spec->canonpath( shift ) or return undef; + + # Check the source and target + return $class->_error( "No such file or directory '$source'" ) unless -e $source; + if ( -e $target ) { + unless ( -f $source and -f $target ) { + return $class->_error( "Won't overwrite " + . (-f $target ? 'file' : 'directory') + . " '$target' with " + . (-f $source ? 'file' : 'directory') + . " '$source'" ); + } + } + unless ( $class->canWrite( $target ) ) { + return $class->_error( "Insufficient permissions to create '$target'" ); + } + + # Make sure the directory for the target exists + my $remove_on_fail = $class->_makePath( $target ); + return undef unless defined $remove_on_fail; + + if ( -f $source ) { + # Copy a file to the new location + require File::Copy; + return File::Copy::copy( $source, $target ) ? 1 + : $class->_andRemove( $remove_on_fail ); + } + + # Create the target directory + my $tocopy = File::Spec->catfile( $source, '*' ) or return undef; + unless ( mkdir $target, 0755 ) { + return $class->_andRemove( $remove_on_fail, + "Failed to create directory '$target'" ); + } + + # Hand off to File::Copy::Recursive + require File::Copy::Recursive; + my $rv = File::Copy::Recursive::dircopy( $tocopy, $target ); + defined $rv ? $rv : $class->_andRemove( $remove_on_fail ); +} + +# Move a file from one place to another. +sub move { + my $class = shift; + my $source = shift or return undef; + my $target = shift or return undef; + + # Check the source and target + return $class->_error( "Copy source '$source' does not exist" ) unless -e $source; + if ( -d $source and -f $target ) { + return $class->_error( "Cannot overwrite non-directory '$source' with directory '$target'" ); + } + + # Check permissions + unless ( $class->canWrite( $target ) ) { + return $class->_error( "Insufficient permissions to write to '$target'" ); + } + + # Make sure the directory for the target exists + my $remove_on_fail = $class->_makePath( $target ); + return undef unless defined $remove_on_fail; + + # Do the file move + require File::Copy; + my $rv = File::Copy::move( $source, $target ); + unless ( $rv ) { + # Clean up after ourselves + File::Flat->remove( $remove_on_fail ) if $remove_on_fail; + return $class->_error( "Error moveing '$source' to '$target'" ); + } + + 1; +} + +# Remove a file or directory ( safely ) +sub remove { + my $class = shift; + my $file = shift or return undef; + + # Does the file exist + unless ( -e $file ) { + return $class->_error( "File or directory does not exist" ); + } + + # Use File::Remove to remove it + require File::Remove; + File::Remove::remove( \1, $file ) or return undef; + ($AUTO_PRUNE or $_[0]) ? $class->prune( $file ) : 1; # Optionally prune +} + +# For a given path, remove any empty directories left behind +sub prune { + my $Object = File::Flat::Object->new( $_[1] ) or return undef; + $Object->prune; +} + +# Truncate a file. That is, leave the file in place, +# but reduce its size to a certain size, default 0. +sub truncate { + my $class = shift; + my $file = shift or return undef; + my $bytes = defined $_[0] ? shift : 0; # Beginning unless otherwise specified + + # Check the file + return $class->_error( "Cannot truncate a directory" ) if -d $file; + unless ( $class->canWrite( $file ) ) { + return $class->_error( "Insufficient permissions to truncate file" ); + } + + # Get a handle to the file and truncate it + my $handle = $class->open( '>', $file ) + or return $class->_error( 'Failed to open write file handle' ); + $handle->truncate( $bytes ) + or return $class->_error( "Failed to truncate file handle: $!" ); + $handle->close; + + 1; +} + + + + + +##################################################################### +# Directory Methods + +# Pass these through to the object version. It should be +# better at this sort of thing. + +# Create a directory. +# Returns true on success, undef on error. +sub makeDirectory { + my $Object = File::Flat::Object->new( $_[1] ) or return undef; + $Object->makeDirectory; +} + +# Make sure that everything above our path exists +sub _makePath { + my $Object = File::Flat::Object->new( $_[1] ) or return undef; + $Object->_makePath; +} + +# Legacy, kept around for CVS Monitor +*_ensureDirectory = *_makePath; + + + + +##################################################################### +# Error handling + +sub errstr { $errstr } +sub _error { $errstr = $_[1]; undef } +sub _andRemove { + my $self = shift; + my $to_remove = shift; + if ( length $to_remove ) { + require File::Remove; + File::Remove::remove( $to_remove ); + } + + @_ ? $self->_error(@_) : undef; +} + +1; + + + + + + + + +package File::Flat::Object; + +# Instantiatable version of File::Flat. +# +# The methods are the same as for File::Flat, where applicable. + +use strict; +use File::Spec (); + +sub new { + my $class = shift; + my $filename = shift or return undef; + + bless { + type => undef, + original => $filename, + absolute => undef, + volume => undef, + directories => undef, + file => undef, + }, $class; +} + +sub _init { + my $self = shift; + + # Get the current working directory. + # If we don't pass it ourselves to File::Spec->rel2abs, + # it might use a backtick `pwd`, which is horribly slow. + my $base = Cwd::getcwd(); + + # Populate the other properties + $self->{absolute} = File::Spec->rel2abs( $self->{original}, $base ); + my ($v, $d, $f) = File::Spec->splitpath( $self->{absolute} ); + my @dirs = File::Spec->splitdir( $d ); + $self->{volume} = $v; + $self->{directories} = \@dirs; + $self->{file} = $f; + $self->{type} = $self->{file} eq '' ? 'directory' : 'file'; + + 1; +} + +# Define the basics +sub exists { -e $_[0]->{original} } +sub isaFile { -f $_[0]->{original} } +sub isaDirectory { -d $_[0]->{original} } +sub canRead { -e $_[0]->{original} and -r _ } +sub canWrite { -e $_[0]->{original} and -w _ } +sub canReadWrite { -e $_[0]->{original} and -r _ and -w _ } +sub canExecute { -e $_[0]->{original} and -x _ } +sub canOpen { -f $_[0]->{original} and -r _ } +sub fileSize { File::Flat->fileSize( $_[0]->{original} ) } + +# Can we create this file/directory, if it doesn't exist. +# Returns 2 if yes, but we need to create directories +# Returns 1 if yes, and we won't need to create any directories. +# Returns 0 if no. +sub _canCreate { + my $self = shift; + $self->_init unless defined $self->{type}; + + # It it already exists, check for writable instead + return $self->canWrite if -e $self->{original}; + + # Go up the directories and find the last one that exists + my $dir_known = ''; + my $dir_unknown = ''; + my @dirs = @{$self->{directories}}; + pop @dirs if $self->{file} eq ''; + while ( defined( my $dir = shift @dirs ) ) { + $dir_unknown = File::Spec->catdir( $dir_known, $dir ); + + # Does the filesystem object exist. + # We use '' for the file part, because not specifying it at + # all throws a warning. + my $fullpath = File::Spec->catpath( $self->{volume}, $dir_unknown, '' ); + last unless -e $fullpath; + + # This should be a directory + if ( -d $fullpath ) { + $dir_known = $dir_unknown; + next; + } + + # A file is where we think a directory should be + 0; + } + + # $dir_known now contains the last directory that exists. + # Can we create filesystem objects under this? + return 0 unless -w $dir_known; + + # If @dirs is empty, we don't need to create + # any directories when we create the file + @dirs ? 2 : 1; +} + +### FIXME - Implement this. +# Should check the we can delete the file. +# If it's a directory, should check that we can +# recursively delete everything in it. +sub canRemove { die "The ->canRemove method has not been implemented yet" } + +# Is the file a text file. +sub isText { -e $_[0]->{original} and -f _ and -T $_[0]->{original} } + +# Is a file a binary file. +sub isBinary { -e $_[0]->{original} and -f _ and -B $_[0]->{original} } + + + + + +##################################################################### +# Opening File + +# Pass these down to the static methods + +sub open { + my $self = shift; + defined $_[0] + ? File::Flat->open( $self->{original}, $_[0] ) + : File::Flat->open( $self->{original} ) +} + +sub getReadHandle { File::Flat->open( '<', $_[0]->{original} ) } +sub getWriteHandle { File::Flat->open( '>', $_[0]->{original} ) } +sub getAppendHandle { File::Flat->open( '>>', $_[0]->{original} ) } +sub getReadWriteHandle { File::Flat->open( '+<', $_[0]->{original} ) } + + + + + +##################################################################### +# Quick File Methods + +sub slurp { File::Flat->slurp( $_[0]->{original} ) } +sub read { File::Flat->read( $_[0]->{original} ) } +sub write { File::Flat->write( $_[0]->{original} ) } +sub overwrite { File::Flat->overwrite( $_[0]->{original} ) } +sub append { File::Flat->append( $_[0]->{original} ) } +sub copy { File::Flat->copy( $_[0]->{original}, $_[1] ) } + +sub move { + my $self = shift; + my $moveTo = shift; + File::Flat->move( $self->{original}, $moveTo ) or return undef; + + # Since the file is moving, once we actually + # move the file, update the object information so + # it refers to the new location. + $self->{original} = $moveTo; + + # Re-initialise if we have already + $self->init if $self->{type}; + + 1; +} + +sub remove { + File::Flat->remove( $_[0]->{original} ); +} + +# For a given path, remove all empty files that were left behind +# by previously deleting it. +sub prune { + my $self = shift; + $self->_init unless defined $self->{type}; + + # We don't actually delete anything that currently exists + if ( -e $self->{original} ) { + return $self->_error('Bad use of ->prune, to try to delete a file'); + } + + # Get the list of directories, fully resolved + ### TO DO - Might be able to do this smaller or more efficiently + ### by using List::Util::reduce + my @dirs = @{$self->{directories}}; + my @potential = ( + File::Spec->catpath( $self->{volume}, shift(@dirs), '' ) + ); + while ( @dirs ) { + push @potential, File::Spec->catdir( $potential[-1], shift(@dirs), '' ); + } + + # Go backwards though this list + foreach my $dir ( reverse @potential ) { + # Not existing is good... it fulfils the intent + next unless -e $dir; + + # This should also definately be a file + unless ( -d $dir ) { + return $self->_error('Found file where a directory was expected while pruning'); + } + + # Does it contain anything, other that (possibly) curdir and updir entries + opendir( PRUNEDIR, $dir ) + or return $self->_error("opendir failed while pruning: $!"); + my @files = readdir PRUNEDIR; + closedir PRUNEDIR; + foreach ( @files ) { + next if $_ eq File::Spec->curdir; + next if $_ eq File::Spec->updir; + + # Found something, we don't need to prune this, + # or anything else for that matter. + return 1; + } + + # Nothing in the directory, we can delete it + File::Flat->remove( $dir ) or return undef; + } + + 1; +} + +sub truncate { + File::Flat->truncate( $_[0]->{original} ); +} + + + + + +##################################################################### +# Directory methods + +# Create a directory. +# Returns true on success, undef on error. +sub makeDirectory { + my $self = shift; + my $mode = shift || 0755; + if ( -e $self->{original} ) { + return 1 if -d $self->{original}; + return $self->_error( "'$self->{original}' already exists, and is a file" ); + } + $self->_init unless defined $self->{type}; + + # Ensure the directory below ours exists + my $remove_on_fail = $self->_makePath( $mode ); + return undef unless defined $remove_on_fail; + + # Create the directory + unless ( mkdir $self->{original}, $mode ) { + return $self->_andRemove( $remove_on_fail, + "Failed to create directory '$self->{original}': $!" ); + } + + 1; +} + +# Make sure the directory that this file/directory is in exists. +# Returns the root of the creation dirs if created. +# Returns '' if nothing required. +# Returns undef on error. +sub _makePath { + my $self = shift; + my $mode = shift || 0755; + return '' if -e $self->{original}; + $self->_init unless defined $self->{type}; + + # Go up the directories and find the last one that exists + my $dir_known = ''; + my $dir_unknown = ''; + my $creation_root = ''; + my @dirs = @{$self->{directories}}; + pop @dirs if $self->{file} eq ''; + while ( defined( my $dir = shift @dirs ) ) { + $dir_unknown = File::Spec->catdir( $dir_known, $dir ); + + # Does the filesystem object exist + # We use '' for the file part, because not specifying it at + # all throws a warning. + my $fullpath = File::Spec->catpath( $self->{volume}, $dir_unknown, '' ); + if ( -e $fullpath ) { + # This should be a directory + return undef unless -d $fullpath; + } else { + # Try to create the directory + unless ( mkdir $dir_unknown, $mode ) { + return $self->_error( $! ); + } + + # Set the base of our creations to return + $creation_root = $dir_unknown unless $creation_root; + } + + $dir_known = $dir_unknown; + } + + $creation_root; +} + +# Legacy, kept around for CVS Monitor +*_ensureDirectory = *_makePath; + + + + + +##################################################################### +# Error handling + +sub errstr { $File::Flat::errstr } +sub _error { $File::Flat::errstr = $_[1]; undef } +sub _andRemove { shift; File::Flat->_andRemove(@_) } + +1; + +__END__ + +=pod + +=head1 NAME + +File::Flat - Implements a flat filesystem + +=head1 SYNOPSIS + +=head1 DESCRIPTION + +File::Flat implements a flat filesystem. A flat filesystem is a filesystem in +which directories do not exist. It provides an abstraction over any normal +filesystem which makes it appear as if directories do not exist. In effect, +it will automatically create directories as needed. This is create for things +like install scripts and such, as you never need to worry about the existance +of directories, just write to a file, no matter where it is. + +=head2 Comprehensive Implementation + +The implementation of File::Flat is extremely comprehensive in scope. It has +methods for all stardard file interaction taks, the -X series of tests, and +some other things, such as slurp. + +All methods are statically called, for example, to write some stuff to a file. + + use File::Flat; + File::Flat->write( 'filename', 'file contents' ); + +=head2 Use of other modules + +File::Flat tries to use more task orientated modules wherever possible. This +includes the use of L<File::Copy>, L<File::Copy::Recursive>, L<File::Remove> +and others. These are mostly loaded on-demand. + +=head2 Pruning and $AUTO_PRUNE + +"Pruning" is a technique where empty directories are assumed to be useless, +and thus empty removed whenever one is created. Thus, when some other task +has the potential to leave an empty directory, it is checked and deleted if +it is empty. + +By default File::Flat does not prune, and pruning must be done explicitly, +via either the L<File::Flat/prune> method, or by setting the second +argument to the L<File::Flat/remove> method to be true. + +However by setting the global C<$AUTO_PRUNE> variable to true, File::Flat +will automatically prune directories at all times. You should generally use +this locally, such as in the following example. + + #!/usr/bin/perl + + use strict; + use File::Flat; + + delete_files(@ARGV); + exit(); + + # Recursively delete and prune all files provided on the command line + sub delete_files { + local $File::Flat::AUTO_PRUNE = 1; + foreach my $file ( @_ ) { + File::Flat->remove( $file ) or die "Failed to delete $file"; + } + } + +=head2 Non-Unix platforms + +As of version 0.97 File::Flat should work correctly on Win32. Other +platforms (such as VMS) are believed to work, but require confirmation. + +=head1 METHODS + +=head2 exists $filename + +Tests for the existance of the file. +This is an exact duplicate of the -e function. + +=head2 isaFile $filename + +Tests whether C<filename> is a file. +This is an exact duplicate of the -f function. + +=head2 isaDirectory $filename + +Test whether C<filename> is a directory. +This is an exact duplicate of the -d function. + +=head2 canRead $filename + +Does the file or directory exist, and can we read from it. + +=head2 canWrite $filename + +Does the file or directory exist, and can we write to it +B<OR> can we create the file or directory. + +=head2 canReadWrite $filename + +Does a file or directory exist, and can we both read and write it. + +=head2 canExecute $filename + +Does a file or directory exist, and can we execute it. + +=head2 canOpen $filename + +Is this something we can open a filehandle to. Returns true if filename +exists, is a file, and we can read from it. + +=head2 canRemove $filename + +Can we remove the file or directory. + +=head2 isaText $filename + +Does the file C<filename> exist, and is it a text file. + +=head2 isaBinary $filename + +Does the file C<filename> exist, and is it a binary file. + +=head2 fileSize $filename + +If the file exists, returns its size in bytes. +Returns undef if the file does not exist. + +=head2 open [ $mode, ] $filename + +Rough analogue of the open function, but creates directories on demand +as needed. Supports most of the normal options to the normal open function. + +In the single argument form, it takes modes in the form [mode]filename. For +example, all the following are valid. + + File::Flat->open( 'filename' ); + File::Flat->open( '<filename' ); + File::Flat->open( '>filename' ); + File::Flat->open( '>>filename' ); + File::Flat->open( '+<filename' ); + +In the two argument form, it takes the following + + File::Flat->open( '<', 'filename' ); + File::Flat->open( '>', 'filename' ); + File::Flat->open( '>>', 'filename' ); + File::Flat->open( '+<', 'filename' ); + +It does not support the more esoteric forms of open, such us opening to a pipe +or other such things. + +On successfully opening the file, it returns it as an IO::File object. +Returns undef on error. + +=head2 getReadHandle $filename + +The same as File::Flat->open( '<', 'filename' ) + +=head2 getWriteHandle $filename + +The same as File::Flat->open( '>', 'filename' ) + +=head2 getAppendHandle $filename + +The same as File::Flat->open( '>>', 'filename' ) + +=head2 getReadWriteHandle $filename + +The same as File::Flat->open( '+<', 'filename' ) + +=head2 read $filename + +Opens and reads in an entire file, chomping as needed. + +In array context, it returns an array containing each line of the file. +In scalar context, it returns a reference to an array containing each line of +the file. It returns undef on error. + +=head2 slurp $filename + +The C<slurp> method 'slurps' a file in. That is it attempts to read the entire +file into a variable in as quick and memory efficient method as possible. + +On success, returns a reference to a scalar, containing the entire file. +Returns undef on error. + +=head2 write $filename, ( $content | \$content | \@content ) + +The C<write> method is the main method for writing content to a file. +It takes two arguments, the location to write to, and the content to write, +in several forms. + +If the file already exists, it will be clobered before writing starts. +If the file doesn't exists, the file and any directories will be created as +needed. + +Content can be provided in three forms. The contents of a scalar argument will +be written directly to the file. You can optionally pass a reference to the +scalar. This is recommended when the file size is bigger than a few thousand +characters, is it does not duplicate the file contents in memory. +Alternatively, you can pass the content as a reference to an array containing +the contents. To ensure uniformity, C<write> will add a newline to each line, +replacing any existing newline as needed. + +Returns true on success, and undef on error. + +=head2 append $filename, ( $content | \$content | \@content ) + +This method is the same as C<write>, except that it appends to the end of +an existing file ( or creates the file as needed ). + +This is the method you should be using to write to log files, etc. + +=head2 overwrite $filename, ( $content | \$content | \@content ) + +Performs an atomic write over a file. It does this by writing to a temporary +file, and moving the completed file over the top of the existing file ( or +creating a new file as needed ). When writing to a file that is on the same +partition as /tmp, this should always be atomic. + +This method otherwise acts the same as C<write>. + +=head2 copy $source, $target + +The C<copy> method attempts to copy a file or directory from the source to +the target. New directories to contain the target will be created as needed. + +For example C<<File::Flat->( './this', './a/b/c/d/that' );>> will create the +directory structure required as needed. + +In the file copy case, if the target already exists, and is a writable file, +we replace the existing file, retaining file mode and owners. If the target +is a directory, we do NOT copy into that directory, unlike with the 'cp' +unix command. And error is instead returned. + +C<copy> will also do limited recursive copying or directories. If source +is a directory, and target does not exists, a recursive copy of source will +be made to target. If target already exists ( file or directory ), C<copy> +will returns with an error. + +=head2 move $source, $target + +The C<move> method follows the conventions of the 'mv' command, with the +exception that the directories containing target will of course be created +on demand. + +=head2 remove $filename [, $prune ] + +The C<remove> method will remove a file, or recursively remove a directory. + +If a second (true) argument is provided, then once the file or directory +has been deleted, the method will the automatically work its way upwards +pruning (deleting) empty and thus assumably useless directories. + +Returns true if the deletion (and pruning if requested) was a success, or +C<undef> otherwise. + +=head2 prune $filename + +For a file that has already been delete, C<prune> will work upwards, +removing any empty directories it finds. + +For anyone familiar with CVS, it is similar to the C<update -P> flag. + +Returns true, or C<undef> on error. + +=head2 truncate $filename [, $size ] + +The C<truncate> method will truncate an existing file to partular size. +A size of 0 ( zero ) is used if no size is provided. If the file does not +exists, it will be created, and set to 0. Attempting to truncate a +directory will fail. + +Returns true on success, or undef on error. + +=head2 makeDirectory $directory [, mode ] + +In the case where you do actually have to create a directory only, the +C<makeDirectory> method can be used to create a directory or any depth. + +An optional file mode ( default 0755 ) can be provided. + +Returns true on success, returns undef on error. + +=head1 TO DO + +Function interface to be written, like +L<File::Spec::Functions>, to provide importable functions. + +There's something bigger here too, I'm not exactly sure what it is, +but I think there might be the beginings of a unified filesystem +interface here... FSI.pm + +=head1 SUPPORT + +Bugs should be filed at via the CPAN bug tracker at: + +L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=File-Flat> + +For other issues or comments, contact the author + +=head1 AUTHORS + +Adam Kennedy E<lt>ad...@cpan.orge<gt> + +=head1 SEE ALSO + +L<File::Spec>, L<http://ali.as/> + +=head1 COPYRIGHT + +Copyright 2002 - 2008 Adam Kennedy. + +This program is free software; you can redistribute +it and/or modify it under the same terms as Perl itself. + +The full text of the license can be found in the +LICENSE file included with this module. + +=cut diff --git a/t/01_compile.t b/t/01_compile.t new file mode 100644 index 0000000..f7827af --- /dev/null +++ b/t/01_compile.t @@ -0,0 +1,13 @@ +#!/usr/bin/perl + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use Test::More tests => 2; + +ok( $] >= 5.005, 'Perl version is new enough' ); + +use_ok( 'File::Flat' ); diff --git a/t/02_api.t b/t/02_api.t new file mode 100644 index 0000000..ef0e4d2 --- /dev/null +++ b/t/02_api.t @@ -0,0 +1,60 @@ +#!/usr/bin/perl + +# Basic first pass API testing for File::Flat + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +# Execute the tests +use Test::More 'tests' => 63; +use File::Flat; + +# Execute the tests +use Test::ClassAPI; +Test::ClassAPI->execute('complete'); +exit(0); + +# Define the API +__DATA__ +File::Flat=class +File::Flat::Object=class + +[File::Flat] +exists=method +isaFile=method +isaDirectory=method +canRead=method +canWrite=method +canReadWrite=method +canExecute=method +canOpen=method +canRemove=method +isText=method +isBinary=method +fileSize=method + +open=method +getReadHandle=method +getWriteHandle=method +getAppendHandle=method +getReadWriteHandle=method +slurp=method +read=method +write=method +overwrite=method +append=method +truncate=method + +copy=method +move=method +remove=method +prune=method +makeDirectory=method +errstr=method + +[File::Flat::Object] +File::Flat=implements +new=method diff --git a/t/03_main.t b/t/03_main.t new file mode 100644 index 0000000..2f24119 --- /dev/null +++ b/t/03_main.t @@ -0,0 +1,786 @@ +#!/usr/bin/perl + +# Formal testing for File::Flat + +use strict; +use File::Spec::Functions ':ALL'; +BEGIN { + $| = 1; + $^W = 1; +} + +use File::Copy 'copy'; +use File::Remove 'remove'; +use File::Find 'find'; + +# If we are root, some things we WANT to fail won't, +# and we'll have to skip some tests. +use vars qw{$root $win32}; +BEGIN { + $root = ($> == 0) ? 1 : 0; + $win32 = ($^O eq 'MSWin32') ? 1 : 0; +} + +# cygwin permissions are insane, so lets treat everyone like +# root and skip all the relevant tests. +# we ALSO want to skip all the tests (mostly related to canExecute) +# that fail on Win32. +BEGIN { + if ( $^O eq 'cygwin' ) { + $root = 1; + $win32 = 1; + } +} + +use Test::More tests => 269; + +# Set up any needed globals +use vars qw{$loaded $ci $bad}; +use vars qw{$content_string @content_array $content_length}; +use vars qw{$curdir %f}; +BEGIN { + $loaded = 0; + $| = 1; + $content_string = "one\ntwo\nthree\n\n"; + @content_array = ( 'one', 'two', 'three', '' ); + $content_length = length $content_string; + + # Define all the paths we are going to need in advance + $curdir = curdir(); + %f = ( + null => catfile( $curdir, 'null' ), + something => catfile( $curdir, 'something' ), + + rwx => catfile( $curdir, '0000' ), + Rwx => catfile( $curdir, '0400' ), + rWx => catfile( $curdir, '0200' ), + rwX => catfile( $curdir, '0100' ), + RWx => catfile( $curdir, '0600' ), + RwX => catfile( $curdir, '0500' ), + rWX => catfile( $curdir, '0300' ), + RWX => catfile( $curdir, '0700' ), + gooddir => catdir( $curdir, 'gooddir' ), + baddir => catdir( $curdir, 'baddir' ), + + ff_handle => catfile( $curdir, 't', 'ff_handle' ), + ff_binary => catfile( $curdir, 't', 'ff_binary' ), + ff_text => catfile( $curdir, 't', 'ff_text' ), + ff_content => catfile( $curdir, 't', 'ff_content' ), + + ff_content2 => catfile( $curdir, 'ff_content2' ), + a_ff_text3 => catfile( $curdir, 'a', 'ff_text3' ), + abcde_ff_text3 => catfile( $curdir, 'a', 'b', 'c', 'd', 'e', 'ff_text3' ), + abdde_ff_text3 => catfile( $curdir, 'a', 'b', 'd', 'd', 'e', 'ff_text3' ), + abc => catdir( $curdir, 'a', 'b', 'c' ), + abd => catdir( $curdir, 'a', 'b', 'd' ), + a => catdir( $curdir, 'a' ), + b => catdir( $curdir, 'b' ), + + moved_1 => catfile( $curdir, 'moved_1' ), + moved_2 => catfile( $curdir, 'b', 'c', 'd', 'e', 'moved_2' ), + + write_1 => catfile( $curdir, 'write_1' ), + write_2 => catfile( $curdir, 'write_2' ), + write_3 => catfile( $curdir, 'write_3' ), + write_4 => catfile( $curdir, 'write_4' ), + write_5 => catfile( $curdir, 'write_5' ), + write_6 => catfile( $curdir, 'write_6' ), + + over_1 => catfile( $curdir, 'over_1' ), + over_2 => catfile( $curdir, 'over_2' ), + over_3 => catfile( $curdir, 'over_3' ), + over_4 => catfile( $curdir, 'over_4' ), + + append_1 => catfile( $curdir, 'append_1' ), + append_2 => catfile( $curdir, 'append_2' ), + append_3 => catfile( $curdir, 'append_3' ), + append_4 => catfile( $curdir, 'append_4' ), + + size_1 => catfile( $curdir, 'size_1' ), + size_2 => catfile( $curdir, 'size_2' ), + size_3 => catfile( $curdir, 'size_3' ), + + trunc_1 => catfile( $curdir, 'trunc_1' ), + + prune => catdir( $curdir, 'prunedir' ), + prune_1 => catdir( $curdir, 'prunedir', 'single' ), + prune_2 => catdir( $curdir, 'prunedir', 'multiple', 'lots', 'of', 'dirs' ), + prune_2a => catdir( $curdir, 'prunedir', 'multiple' ), + prune_3 => catdir( $curdir, 'prunedir', 'onlyone', 'thisone' ), + prune_4 => catdir( $curdir, 'prunedir', 'onlyone', 'notthis' ), + prune_4a => catdir( $curdir, 'prunedir', 'onlyone' ), + prune_5 => catdir( $curdir, 'prunedir', 'onlyone', 'notthis', 'orthis' ), + + remove_prune_1 => catfile( $curdir, 'prunedir', 'remove', 'prune_1' ), + remove_prune_2 => catfile( $curdir, 'prunedir', 'remove', 'prune_2' ), + remove_prune_3 => catfile( $curdir, 'prunedir', 'remove', 'prune_3' ), + remove_prune_4 => catfile( $curdir, 'prunedir', 'remove', 'prune_4' ), + remove_prune_5 => catfile( $curdir, 'prunedir', 'remove', 'prune_5' ), + remove_prune_6 => catfile( $curdir, 'prunedir', 'remove', 'prune_6' ), + ); + + # Avoid some 'only used once' warnings + $File::Flat::errstr = $File::Flat::errstr; + $File::Flat::AUTO_PRUNE = $File::Flat::AUTO_PRUNE; +} + +# Convenience functions to avoid system calls +sub touch_test_file($) { + # Do the 'touch' part + my $file = catfile( $curdir, $_[0] ); + open FILE, ">>$file" or return undef; + close FILE; + + # And now the chmod part + my $mask = oct($_[0]); + chmod $mask, $file or return undef; + + 1; +} + +sub chmod_R($$) { + my($mask, $dir) = @_; + chmod $mask, $dir; + find( sub { chmod $mask, $File::Find::name }, $dir ); +} + +# Check their perl version, and that modules are installed +ok( $] >= 5.005, "Your perl is new enough" ); +use_ok( 'File::Flat' ); + + + + +# Check for the three files that should already exist +ok( -f $f{ff_text}, 'ff_text exists' ); +ok( -f $f{ff_binary}, 'ff_binary exists' ); +ok( -f $f{ff_content}, 'ff_content exists' ); + +# Create the files for the file test section +touch_test_file('0000') or die "Failed to create file we can do anything to"; +touch_test_file('0400') or die "Failed to create file we can only read"; +touch_test_file('0200') or die "Failed to create file we can only write"; +touch_test_file('0100') or die "Failed to create file we can only execute"; +touch_test_file('0600') or die "Failed to create file we can read and write"; +touch_test_file('0500') or die "Failed to create file we can read and execute"; +touch_test_file('0300') or die "Failed to create file we can write and execute"; +touch_test_file('0700') or die "Failed to create file we can read, write and execute"; + +unless ( chmod 0777, $curdir ) { + die "Failed to set current directory to mode 777"; +} +unless ( -e $f{gooddir} ) { + unless ( mkdir $f{gooddir}, 0755 ) { + die "Failed to create mode 0755 directory"; + } +} +unless ( -e $f{baddir} ) { + unless ( mkdir $f{baddir}, 0000 ) { + die "Failed to create mode 0000 directory"; + } +} + +# We are also going to use a file called "./null" to represent +# a file that doesn't exist. + + + +### Test Section 1 +# Here we will test all the static methods that are handled directly, and +# not passed on to the object form of the methods. + +# Test the error message handling +my $error_message = 'foo'; +my $rv = File::Flat->_error( $error_message ); +ok( ! defined $rv, "->_error returns undef" ); +ok( $File::Flat::errstr eq $error_message, "->_error sets error message" ); +ok( File::Flat->errstr eq $error_message, "->errstr retrieves error message" ); + +# Test the static ->exists method +ok( ! File::Flat->exists( $f{null} ), "Static ->exists doesn't see missing file" ); +ok( File::Flat->exists( $f{rwx} ), "Static ->exists sees mode 000 file" ); +ok( File::Flat->exists( $f{Rwx} ), "Static ->exists sees mode 400 file" ); +ok( File::Flat->exists( $f{RWX} ), "Static ->exists sees mode 700 file" ); +ok( File::Flat->exists( $curdir ), "Static ->exists sees . directory" ); +ok( File::Flat->exists( $f{baddir} ), "Static ->exists sees mode 000 directory" ); + +# Test the static ->isaFile method +ok( ! File::Flat->isaFile( $f{null} ), "Static ->isaFile returns false for missing file" ); +ok( File::Flat->isaFile( $f{rwx} ), "Static ->isaFile returns true for mode 000 file" ); +ok( File::Flat->isaFile( $f{RWX} ), "Static ->isaFile returns true for mode 700 file" ); +ok( ! File::Flat->isaFile( $curdir ), "Static ->isaFile returns false for current directory" ); +ok( ! File::Flat->isaFile( $f{gooddir} ), "Static ->isaFile returns false for subdirectory" ); + +# Test the static ->isaDirectory method +ok( ! File::Flat->isaDirectory( $f{null} ), "Static ->isaDirectory returns false for missing directory" ); +ok( ! File::Flat->isaDirectory( $f{rwx} ), "Static ->isaDirectory returns false for mode 000 file" ); +ok( ! File::Flat->isaDirectory( $f{RWX} ), "Static ->isaDirectory returns false for mode 700 file" ); +ok( File::Flat->isaDirectory( $curdir ), "Static ->isaDirectory returns true for current directory" ); +ok( File::Flat->isaDirectory( $f{gooddir} ), "Static ->isaDirectory returns true for readable subdirectory" ); +ok( File::Flat->isaDirectory( $f{baddir} ), "Static ->isaDirectory return true for unreadable subdirectory" ); + +# Test the static ->canRead method +ok( ! File::Flat->canRead( $f{null} ), "Static ->canRead returns false for missing file" ); +SKIP: { + skip "Skipping tests known to fail for root", 1 if $root; + ok( ! File::Flat->canRead( $f{rwx} ), "Static ->canRead returns false for mode 000 file" ); +} +ok( File::Flat->canRead( $f{Rwx} ), "Static ->canRead returns true for mode 400 file" ); +SKIP: { + skip "Skipping tests known to fail for root", 2 if $root; + ok( ! File::Flat->canRead( $f{rWx} ), "Static ->canRead returns false for mode 200 file" ); + ok( ! File::Flat->canRead( $f{rwX} ), "Static ->canRead returns false for mode 100 file" ); +} +ok( File::Flat->canRead( $f{RWx} ), "Static ->canRead returns true for mode 500 file" ); +ok( File::Flat->canRead( $f{RwX} ), "Static ->canRead returns true for mode 300 file" ); +ok( File::Flat->canRead( $f{RWX} ), "Static ->canRead returns true for mode 700 file" ); +ok( File::Flat->canRead( $curdir ), "Static ->canRead returns true for current directory" ); +ok( File::Flat->canRead( $f{gooddir} ), "Static ->canRead returns true for readable subdirectory" ); +SKIP: { + skip "Skipping tests known to fail for root", 1 if $root; + ok( ! File::Flat->canRead( $f{baddir} ), "Static ->canRead returns false for unreadable subdirectory" ); +} + + +# Test the static ->canWrite method +ok( File::Flat->canWrite( $f{null} ), "Static ->canWrite returns true for missing, creatable, file" ); +SKIP: { + skip "Skipping tests known to fail for root", 2 if $root; + ok( ! File::Flat->canWrite( $f{rwx} ), "Static ->canWrite returns false for mode 000 file" ); + ok( ! File::Flat->canWrite( $f{Rwx} ), "Static ->canWrite returns false for mode 400 file" ); +} +ok( File::Flat->canWrite( $f{rWx} ), "Static ->canWrite returns true for mode 200 file" ); +SKIP: { + skip "Skipping tests known to fail for root", 1 if $root; + ok( ! File::Flat->canWrite( $f{rwX} ), "Static ->canWrite returns false for mode 100 file" ); +} +ok( File::Flat->canWrite( $f{RWx} ), "Static ->canWrite returns true for mode 500 file" ); +SKIP: { + skip "Skipping tests known to fail for root", 1 if $root; + ok( ! File::Flat->canWrite( $f{RwX} ), "Static ->canWrite returns false for mode 300 file" ); +} +ok( File::Flat->canWrite( $f{RWX} ), "Static ->canWrite returns true for mode 700 file" ); +ok( File::Flat->canWrite( $curdir ), "Static ->canWrite returns true for current directory" ); +ok( File::Flat->canWrite( $f{gooddir} ), "Static ->canWrite returns true for writable subdirectory" ); +SKIP: { + skip "Skipping tests known to fail for root", 2 if $root; + ok( ! File::Flat->canWrite( $f{baddir} ), "Static ->canWrite returns false for unwritable subdirectory" ); + ok( ! File::Flat->canWrite( catfile($f{baddir}, 'file') ), "Static ->canWrite returns false for missing, non-creatable file" ); +} + +# Test the static ->canReadWrite method +ok( ! File::Flat->canReadWrite( $f{null} ), "Static ->canReadWrite returns false for missing file" ); +SKIP: { + skip "Skipping tests known to fail for root", 4 if $root; + ok( ! File::Flat->canReadWrite( $f{rwx} ), "Static ->canReadWrite returns false for mode 000 file" ); + ok( ! File::Flat->canReadWrite( $f{Rwx} ), "Static ->canReadWrite returns false for mode 400 file" ); + ok( ! File::Flat->canReadWrite( $f{rWx} ), "Static ->canReadWrite returns false for mode 200 file" ); + ok( ! File::Flat->canReadWrite( $f{rwX} ), "Static ->canReadWrite returns false for mode 100 file" ); +} +ok( File::Flat->canReadWrite( $f{RWx} ), "Static ->canReadWrite returns true for mode 500 file" ); +SKIP: { + skip "Skipping tests known to fail for root", 1 if $root; + ok( ! File::Flat->canReadWrite( $f{RwX} ), "Static ->canReadWrite returns false for mode 300 file" ); +} +ok( File::Flat->canReadWrite( $f{RWX} ), "Static ->canReadWrite returns true for mode 700 file" ); +ok( File::Flat->canReadWrite( $curdir ), "Static ->canReadWrite returns true for current directory" ); +ok( File::Flat->canReadWrite( $f{gooddir} ), "Static ->canReadWrite returns true for readwritable subdirectory" ); +SKIP: { + skip "Skipping tests known to fail for root", 1 if $root; + ok( ! File::Flat->canReadWrite( $f{baddir} ), "Static ->canReadWrite returns false for unreadwritable subdirectory" ); +} + +# Test the static ->canExecute method +SKIP: { + skip( "Skipping tests known to falsely fail on Win32", 11 ) if $win32; + + ok( ! File::Flat->canExecute( $f{null} ), "Static ->canExecute returns false for missing file" ); + ok( ! File::Flat->canExecute( $f{rwx} ), "Static ->canExecute returns false for mode 000 file" ); + ok( ! File::Flat->canExecute( $f{Rwx} ), "Static ->canExecute returns false for mode 400 file" ); + ok( ! File::Flat->canExecute( $f{rWx} ), "Static ->canExecute returns false for mode 200 file" ); + ok( File::Flat->canExecute( $f{rwX} ), "Static ->canExecute returns true for mode 100 file" ); + ok( ! File::Flat->canExecute( $f{RWx} ), "Static ->canExecute returns false for mode 500 file" ); + ok( File::Flat->canExecute( $f{RwX} ), "Static ->canExecute returns true for mode 300 file" ); + ok( File::Flat->canExecute( $f{RWX} ), "Static ->canExecute returns true for mode 700 file" ); + ok( File::Flat->canExecute( $curdir ), "Static ->canExecute returns true for current directory" ); + ok( File::Flat->canExecute( $f{gooddir} ), "Static ->canExecute returns true for executable subdirectory" ); + + skip( "Skipping tests known to falsely fail for root", 1 ) if $root; + ok( ! File::Flat->canExecute( $f{baddir} ), "Static ->canExecute returns false for unexecutable subdirectory" ); +} + +# Test the static ->canOpen method +ok( ! File::Flat->canOpen( $f{null} ), "Static ->canOpen returns false for missing file" ); +SKIP: { + skip "Skipping tests known to fail for root", 1 if $root; + ok( ! File::Flat->canOpen( $f{rwx} ), "Static ->canOpen returns false for mode 000 file" ); +} +ok( File::Flat->canOpen( $f{Rwx} ), "Static ->canOpen returns true for mode 400 file" ); +SKIP: { + skip "Skipping tests known to fail for root", 2 if $root; + ok( ! File::Flat->canOpen( $f{rWx} ), "Static ->canOpen returns false for mode 200 file" ); + ok( ! File::Flat->canOpen( $f{rwX} ), "Static ->canOpen returns false for mode 100 file" ); +} +ok( File::Flat->canOpen( $f{RWx} ), "Static ->canOpen returns true for mode 500 file" ); +ok( File::Flat->canOpen( $f{RwX} ), "Static ->canOpen returns true for mode 300 file" ); +ok( File::Flat->canOpen( $f{RWX} ), "Static ->canOpen returns true for mode 700 file" ); +ok( ! File::Flat->canOpen( $curdir ), "Static ->canOpen returns false for current directory" ); +ok( ! File::Flat->canOpen( $f{gooddir} ), "Static ->canOpen returns false for readable subdirectory" ); +ok( ! File::Flat->canOpen( $f{baddir} ), "Static ->canOpen returns false for unreadable subdirectory" ); + +# Test the existance of normal and/or binary files +ok( ! File::Flat->isText( $f{null} ), "Static ->isText returns false for missing file" ); +ok( ! File::Flat->isText( $f{ff_binary} ), "Static ->isText returns false for binary file" ); +ok( File::Flat->isText( $f{ff_text} ), "Static ->isText returns true for text file" ); +ok( ! File::Flat->isText( $f{gooddir} ), "Static ->isText returns false for good subdirectory" ); +ok( ! File::Flat->isText( $f{baddir} ), "Static ->isText returns false for bad subdirectory" ); +ok( ! File::Flat->isBinary( $f{null} ), "Static ->isBinary returns false for missing file" ); +ok( File::Flat->isBinary( $f{ff_binary} ), "Static ->isBinary returns true for binary file" ); +ok( ! File::Flat->isBinary( $f{ff_text} ), "Static ->isBinary returns false for text file" ); +ok( ! File::Flat->isBinary( $f{gooddir} ), "Static ->isBinary return false for good subdirectory" ); +ok( ! File::Flat->isBinary( $f{baddir} ), "Static ->isBinary returns false for bad subdirectory" ); + +my %handle = (); + +# Do open handle methods return false for bad values +$handle{generic} = File::Flat->open( $f{null} ); +$handle{readhandle} = File::Flat->open( $f{null} ); +$handle{writehandle} = File::Flat->open( $f{null} ); +$handle{appendhandle} = File::Flat->open( $f{null} ); +$handle{readwritehandle} = File::Flat->open( $f{null} ); +ok( ! defined $handle{generic}, "Static ->open call returns undef on bad file name" ); +ok( ! defined $handle{readhandle}, "Static ->getReadHandle returns undef on bad file name" ); +ok( ! defined $handle{writehandle}, "Static ->getWriteHandle returns undef on bad file name" ); +ok( ! defined $handle{appendhandle}, "Static ->getAppendHandle returns undef on bad file name" ); +ok( ! defined $handle{readwritehandle}, "Static ->getReadWriteHandle returns undef on bad file name" ); + +# Do the open methods at least return a file handle +copy( $f{ff_text}, $f{ff_handle} ) or die "Failed to copy file in preperation for test"; +$handle{generic} = File::Flat->open( $f{ff_handle} ); +$handle{readhandle} = File::Flat->getReadHandle( $f{ff_handle} ); +$handle{writehandle} = File::Flat->getWriteHandle( $f{ff_handle} ); +$handle{appendhandle} = File::Flat->getAppendHandle( $f{ff_handle} ); +$handle{readwritehandle} = File::Flat->getReadWriteHandle( $f{ff_handle} ); +isa_ok( $handle{generic}, 'IO::File' ); # Static ->open call returns IO::File object +isa_ok( $handle{readhandle}, 'IO::File' ); # Static ->getReadHandle returns IO::File object +isa_ok( $handle{writehandle}, 'IO::File' ); # Static ->getWriteHandle returns IO::File object +isa_ok( $handle{appendhandle}, 'IO::File' ); # Static ->getAppendHandle returns IO::File object +isa_ok( $handle{readwritehandle}, 'IO::File' ); # Static ->getReadWriteHandle returns IO::File object + + + + + + +# Test the static ->copy method +ok( ! defined File::Flat->copy(), '->copy() returns error' ); +ok( ! defined File::Flat->copy( $f{ff_content} ), '->copy( file ) returns error' ); + +$rv = File::Flat->copy( $f{ff_content}, $f{ff_content2} ); +ok( $rv, "Static ->copy returns true correctly for same directory copy" ); +ok( -e $f{ff_content2}, "Static ->copy actually created the file for same directory copy" ); +ok( check_content_file( $f{ff_content2} ), "Static ->copy copies the file without breaking it" ); + +$rv = File::Flat->copy( $f{ff_text}, $f{a_ff_text3} ); +ok( $rv, "Static ->copy returns true correctly for single sub-directory copy" ); +ok( -e $f{a_ff_text3}, "Static ->copy actually created the file for single sub-directory copy" ); + +$rv = File::Flat->copy( $f{ff_text}, $f{abcde_ff_text3} ); +ok( $rv, "Static ->copy returns true correctly for multiple sub-directory copy" ); +ok( -e $f{abcde_ff_text3}, "Static ->copy actually created the file for multiple sub-directory copy" ); + +$rv = File::Flat->copy( $f{null}, $f{something} ); +ok( ! $rv, "Static ->copy return undef when file does not exist" ); + +# Directory copying +$rv = File::Flat->copy( $f{abc}, $f{abd} ); +SKIP: { + skip "Skipping tests known to fail for root", 1 if $root; + ok( $rv, '->copy( dir, dir ) returns true' ); +} +ok( -d $f{abd}, '->copy( dir, dir ): New dir exists' ); +ok( -f $f{abdde_ff_text3}, '->copy( dir, dir ): Files within directory were copied' ); + +# Test the static ->move method +$rv = File::Flat->move( $f{abcde_ff_text3}, $f{moved_1} ); +ok( $rv, "Static ->move for move to existing directory returns true " ); +ok( ! -e $f{abcde_ff_text3}, "Static ->move for move to existing directory actually removes the old file" ); +ok( -e $f{moved_1}, "Static ->move for move to existing directory actually creates the new file" ); + +$rv = File::Flat->move( $f{ff_content2}, $f{moved_2} ); +ok( $rv, "Static ->move for move to new directory returns true " ); +ok( ! -e $f{ff_content2}, "Static ->move for move to new directory actually removes the old file" ); +ok( -e $f{moved_2}, "Static ->move for move to new directory actually creates the new file" ); +ok( check_content_file( $f{moved_2} ), "Static ->move moved the file without breaking it" ); + + + + + + +# Test the static ->slurp method +ok( check_content_file( $f{ff_content} ), "Content tester works" ); +my $content = File::Flat->slurp(); +ok( ! defined $content, "Static ->slurp returns error on no arguments" ); +$content = File::Flat->slurp( $f{null} ); +ok( ! defined $content, "Static ->slurp returns error on bad file" ); +$content = File::Flat->slurp( $f{ff_content} ); +ok( defined $content, "Static ->slurp returns defined" ); +ok( defined $content, "Static ->slurp returns something" ); +ok( UNIVERSAL::isa( $content, 'SCALAR' ), "Static ->slurp returns a scalar reference" ); +ok( length $$content, "Static ->slurp returns content" ); +ok( $$content eq $content_string, "Static ->slurp returns the correct file contents" ); + +# Test the static ->read +$content = File::Flat->read(); +ok( ! defined $content, "Static ->read returns error on no arguments" ); +$content = File::Flat->read( $f{null} ); +ok( ! defined $content, "Static ->read returns error on bad file" ); +$content = File::Flat->read( $f{ff_content} ); +ok( defined $content, "Static ->read doesn't error on good file" ); +ok( $content, "Static ->read returns true on good file" ); +ok( ref $content, "Static ->read returns a reference on good file" ); +ok( UNIVERSAL::isa( $content, 'ARRAY' ), "Static ->read returns an array ref on good file" ); +ok( scalar @$content == 4, "Static ->read returns the correct length of data" ); +my $matches = ( + $content->[0] eq 'one' + and $content->[1] eq 'two' + and $content->[2] eq 'three' + and $content->[3] eq '' + ) ? 1 : 0; +ok( $matches, "Static ->read returns the expected content" ); + +# And again in an array context +my @content = File::Flat->read(); +ok( ! scalar @content, "Static ->read (array context) returns error on no arguments" ); +@content = File::Flat->read( $f{null} ); +ok( ! scalar @content, "Static ->read (array context) returns error on bad file" ); +@content = File::Flat->read( $f{ff_content} ); +ok( scalar @content, "Static ->read (array context) doesn't error on good file" ); +ok( scalar @content == 4, "Static ->read (array context) returns the correct length of data" ); +$matches = ( + $content[0] eq 'one' + and $content[1] eq 'two' + and $content[2] eq 'three' + and $content[3] eq '' + ) ? 1 : 0; +ok( $matches, "Static ->read (array context) returns the expected content" ); + + + + + +# Test the many and varies write() options. +ok( ! File::Flat->write(), "->write() fails correctly" ); +ok( ! File::Flat->write( $f{write_1} ), "->write( file ) fails correctly" ); +ok( ! -e $f{write_1}, "->write( file ) doesn't actually create a file" ); + +$rv = File::Flat->write( $f{write_1}, $content_string ); +ok( $rv, "->File::Flat->write( file, string ) returns true" ); +ok( -e $f{write_1}, "->write( file, string ) actually creates a file" ); +ok( check_content_file( $f{write_1} ), "->write( file, string ) writes the correct content" ); + +$rv = File::Flat->write( $f{write_2}, $content_string ); +ok( $rv, "->File::Flat->write( file, string_ref ) returns true" ); +ok( -e $f{write_2}, "->write( file, string_ref ) actually creates a file" ); +ok( check_content_file( $f{write_2} ), "->write( file, string_ref ) writes the correct content" ); + +$rv = File::Flat->write( $f{write_3}, \@content_array ); +ok( $rv, "->write( file, array_ref ) returns true" ); +ok( -e $f{write_3}, "->write( file, array_ref ) actually creates a file" ); +ok( check_content_file( $f{write_3} ), "->write( file, array_ref ) writes the correct content" ); + +# Repeat with a handle first argument +my $handle = File::Flat->getWriteHandle( $f{write_4} ); +ok( ! File::Flat->write( $handle ), "->write( handle ) fails correctly" ); +ok( UNIVERSAL::isa( $handle, 'IO::Handle' ), 'Got write handle for test' ); +$rv = File::Flat->write( $handle, $content_string ); +$handle->close(); +ok( $rv, "->write( handle, string ) returns true" ); +ok( -e $f{write_4}, "->write( handle, string ) actually creates a file" ); +ok( check_content_file( $f{write_1} ), "->write( handle, string ) writes the correct content" ); + +$handle = File::Flat->getWriteHandle( $f{write_5} ); +ok( UNIVERSAL::isa( $handle, 'IO::Handle' ), 'Got write handle for test' ); +$rv = File::Flat->write( $handle, $content_string ); +$handle->close(); +ok( $rv, "->File::Flat->write( handle, string_ref ) returns true" ); +ok( -e $f{write_5}, "->write( handle, string_ref ) actually creates a file" ); +ok( check_content_file( $f{write_5} ), "->write( handle, string_ref ) writes the correct content" ); + +$handle = File::Flat->getWriteHandle( $f{write_6} ); +ok( UNIVERSAL::isa( $handle, 'IO::Handle' ), 'Got write handle for test' ); +$rv = File::Flat->write( $handle, \@content_array ); +$handle->close(); +ok( $rv, "->File::Flat->write( handle, array_ref ) returns true" ); +ok( -e $f{write_6}, "->write( handle, array_ref ) actually creates a file" ); +ok( check_content_file( $f{write_6} ), "->write( handle, array_ref ) writes the correct content" ); + + + + + + +# Check the ->overwrite method +ok( ! File::Flat->overwrite(), "->overwrite() fails correctly" ); +ok( ! File::Flat->overwrite( $f{over_1} ), "->overwrite( file ) fails correctly" ); +ok( ! -e $f{over_1}, "->overwrite( file ) doesn't actually create a file" ); + +$rv = File::Flat->overwrite( $f{over_1}, $content_string ); +ok( $rv, "->File::Flat->overwrite( file, string ) returns true" ); +ok( -e $f{over_1}, "->overwrite( file, string ) actually creates a file" ); +ok( check_content_file( $f{over_1} ), "->overwrite( file, string ) writes the correct content" ); + +$rv = File::Flat->overwrite( $f{over_2}, $content_string ); +ok( $rv, "->File::Flat->overwrite( file, string_ref ) returns true" ); +ok( -e $f{over_2}, "->overwrite( file, string_ref ) actually creates a file" ); +ok( check_content_file( $f{over_2} ), "->overwrite( file, string_ref ) writes the correct content" ); + +$rv = File::Flat->overwrite( $f{over_3}, \@content_array ); +ok( $rv, "->overwrite( file, array_ref ) returns true" ); +ok( -e $f{over_3}, "->overwrite( file, array_ref ) actually creates a file" ); +ok( check_content_file( $f{over_3} ), "->overwrite( file, array_ref ) writes the correct content" ); + +# Check actually overwriting a file +ok ( File::Flat->copy( $f{ff_text}, $f{over_4} ), "Preparing for overwrite test" ); +$rv = File::Flat->overwrite( $f{over_4}, \$content_string ); +ok( $rv, "->overwrite( file, array_ref ) returns true" ); +ok( -e $f{over_4}, "->overwrite( file, array_ref ) actually creates a file" ); +ok( check_content_file( $f{over_4} ), "->overwrite( file, array_ref ) writes the correct content" ); + + + + + +# Check the basics of the ->remove method +ok( ! File::Flat->remove(), "->remove() correctly return an error" ); +ok( ! File::Flat->remove( $f{null} ), "->remove( file ) returns an error for a nonexistant file" ); +ok( File::Flat->remove( $f{over_4} ), "->remove( file ) returns true for existing file" ); +ok( ! -e $f{over_4}, "->remove( file ) actually removes the file" ); +ok( File::Flat->remove( $f{a} ), "->remove( directory ) returns true for existing directory" ); +ok( ! -e $f{a}, "->remove( directory ) actually removes the directory" ); + + + + + +# Check the append method +ok( ! File::Flat->append(), "->append() correctly returns an error" ); +ok( ! File::Flat->append( $f{append_1} ), "->append( file ) correctly returns an error" ); +ok( ! -e $f{append_1}, "->append( file ) doesn't actually create a file" ); + +$rv = File::Flat->append( $f{append_1}, $content_string ); +ok( $rv, "->File::Flat->append( file, string ) returns true" ); +ok( -e $f{append_1}, "->append( file, string ) actually creates a file" ); +ok( check_content_file( $f{append_1} ), "->append( file, string ) writes the correct content" ); + +$rv = File::Flat->append( $f{append_2}, $content_string ); +ok( $rv, "->File::Flat->append( file, string_ref ) returns true" ); +ok( -e $f{append_2}, "->append( file, string_ref ) actually creates a file" ); +ok( check_content_file( $f{append_2} ), "->append( file, string_ref ) writes the correct content" ); + +$rv = File::Flat->append( $f{append_3}, \@content_array ); +ok( $rv, "->append( file, array_ref ) returns true" ); +ok( -e $f{append_3}, "->append( file, array_ref ) actually creates a file" ); +ok( check_content_file( $f{append_3} ), "->append( file, array_ref ) writes the correct content" ); + +# Now let's try an actual append +ok( File::Flat->append( $f{append_4}, "one\ntwo\n" ), "Preparing for real append" ); +$rv = File::Flat->append( $f{append_4}, "three\n\n" ); +ok( $rv, "->append( file, array_ref ) for an actual append returns true" ); +ok( -e $f{append_4}, "->append( file, array_ref ): File still exists" ); +ok( check_content_file( $f{append_4} ), "->append( file, array_ref ) results in the correct file contents" ); + + + + + +# Test the ->fileSize method +ok( File::Flat->write( $f{size_1}, 'abcdefg' ) + && File::Flat->write( $f{size_2}, join '', ( 'd' x 100000 ) ) + && File::Flat->write( $f{size_3}, '' ), + "Preparing for file size tests" + ); +ok( ! defined File::Flat->fileSize(), "->fileSize() correctly returns error" ); +ok( ! defined File::Flat->fileSize( $f{null} ), '->fileSize( file ) returns error for nonexistant file' ); +ok( ! defined File::Flat->fileSize( $f{a} ), '->fileSize( directory ) returns error' ); +$rv = File::Flat->fileSize( $f{size_1} ); +ok( defined $rv, "->fileSize( file ) returns true for small file" ); +ok( $rv == 7, "->fileSize( file ) returns the correct size for small file" ); +$rv = File::Flat->fileSize( $f{size_2} ); +ok( defined $rv, "->fileSize( file ) returns true for big file" ); +ok( $rv == 100000, "->fileSize( file ) returns the correct size for big file" ); +$rv = File::Flat->fileSize( $f{size_3} ); +ok( defined $rv, "->fileSize( file ) returns true for empty file" ); +ok( $rv == 0, "->fileSize( file ) returns the correct size for empty file" ); + + + + + + + +# Test the ->truncate method. Use the append files +ok( ! defined File::Flat->truncate(), '->truncate() correctly returns error' ); +SKIP: { + skip "Skipping tests known to fail for root", 1 if $root; + ok( ! defined File::Flat->truncate( $f{rwx} ), '->truncate( file ) returns error when no permissions' ); +} +ok( ! defined File::Flat->truncate( './b' ), '->truncate( directory ) returns error' ); +$rv = File::Flat->truncate( $f{trunc_1} ); +ok( $rv, '->truncate( file ) returns true for non-existant file' ); +ok( -e $f{trunc_1}, '->truncate( file ) creates new file' ); +ok( File::Flat->fileSize( $f{trunc_1} ) == 0, '->truncate( file ) creates file of 0 bytes' ); + +$rv = File::Flat->truncate( $f{append_1} ); +ok( $rv, '->truncate( file ) returns true for existing file' ); +ok( -e $f{append_1}, '->truncate( file ): File still exists' ); +ok( File::Flat->fileSize( $f{append_1} ) == 0, '->truncate( file ) truncates to 0 bytes' ); + +$rv = File::Flat->truncate( $f{append_2}, 0 ); +ok( $rv, '->truncate( file, 0 ) returns true for existing file' ); +ok( -e $f{append_2}, '->truncate( file, 0 ): File still exists' ); +ok( File::Flat->fileSize( $f{append_2} ) == 0, '->truncate( file, 0 ) truncates to 0 bytes' ); + +$rv = File::Flat->truncate( $f{append_3}, 5 ); +ok( $rv, '->truncate( file, 5 ) returns true for existing file' ); +ok( -e $f{append_3}, '->truncate( file, 5 ): File still exists' ); +ok( File::Flat->fileSize( $f{append_3} ) == 5, '->truncate( file, 5 ) truncates to 5 bytes' ); + + + + + +##################################################################### +# Test the prune method + +# Create the test directories +foreach ( 1 .. 5 ) { + my $directory = $f{"prune_$_"}; + ok( File::Flat->makeDirectory( $directory ), "Created test directory '$directory'" ); +} + +# Prune beneath the single dir +$rv = File::Flat->prune( catfile($f{prune_1}, 'file.txt') ); +ok( $rv, '->prune(single) returned true' ); +ok( ! -e $f{prune_1}, '->prune(single) removed the single' ); +ok( -d $f{prune}, '->prune(single) didn\'t remove the master prunedir' ); + +# Prune beneath the multiple dir +$rv = File::Flat->prune( catfile($f{prune_2}, 'here') ); +ok( $rv, '->prune(multiple) returned true' ); +ok( ! -e $f{prune_2}, '->prune(multiple) removed the top dir' ); +ok( ! -e $f{prune_2a}, '->prune(multiple) removed all the dirs' ); +ok( -d $f{prune}, '->prune(multiple) didn\'t remove the master prunedir' ); + +# Prune stops correctly +$rv = File::Flat->prune( catfile($f{prune_3}, 'foo') ); +ok( $rv, '->prune(branched) returned true' ); +ok( ! -e $f{prune_3}, '->prune(branched) removed the correct directory' ); +ok( -d $f{prune_4}, '->prune(branched) doesn\'t remove side directory' ); +ok( -d $f{prune}, '->prune(branched) didn\'t remove the master prunedir' ); + +# Don't prune anything +$rv = File::Flat->prune( catfile($f{prune_4a}, 'blah') ); +ok( $rv, '->prune(nothing) returned true' ); +ok( -d $f{prune_4}, '->prune(nothing) doesn\'t remove side directory' ); +ok( -d $f{prune}, '->prune(nothing) didn\'t remove the master prunedir' ); + +# Error when used as delete +$rv = File::Flat->prune( $f{prune_5} ); +is( $rv, undef, '->prune(existing) returns an error' ); +ok( File::Flat->errstr, '->prune(existing) sets ->errstr' ); + +# Test remove, with the prune option. + +# Start by copying in some files to work with. +# We'll use the last of the untouched append files +foreach ( 1 .. 6 ) { + ok( File::Flat->copy( $f{append_4}, catdir( $f{"remove_prune_$_"}, 'file' ) ), 'Copied in delete/prune test file' ); +} + +# By default, AUTOPRUNE is off and we don't tell ->remove to prune +ok( File::Flat->remove( catdir( $f{remove_prune_1}, 'file' ) ), '->remove(default) returns true' ); +ok( -d $f{remove_prune_1}, '->remove(default) leaves dir intact' ); + +# Try with AUTOPRUNE on +AUTOPRUNE: { + local $File::Flat::AUTO_PRUNE = 1; + ok( File::Flat->remove( catdir( $f{remove_prune_2}, 'file' ) ), '->remove(AUTO_PRUNE) returns true' ); + ok( ! -e $f{remove_prune_2}, '->remove(AUTO_PRUNE) prunes directory' ); +} + +# By default, AUTOPRUNE is off +ok( File::Flat->remove( catdir( $f{remove_prune_3}, 'file' ) ), '->remove(default) returns true' ); +ok( -d $f{remove_prune_3}, '->remove(default) leaves dir intact (AUTO_PRUNE used locally localises correctly)' ); + +# Tell ->remove to prune +ok( File::Flat->remove( catdir( $f{remove_prune_4}, 'file' ), 1 ), '->remove(prune) returns true' ); +ok( ! -e $f{remove_prune_4}, '->remove(AUTO_PRUNE) prunes directory' ); + +# Tell ->remove explicitly not to prune +ok( File::Flat->remove( catdir( $f{remove_prune_5}, 'file' ), '' ), '->remove(noprune) returns true' ); +ok( -d $f{remove_prune_5}, '->remove(noprune) leaves dir intact' ); + +# Make sure there's no warning with undef false value +ok( File::Flat->remove( catdir( $f{remove_prune_6}, 'file' ), undef ), '->remove(noprune) returns true' ); +ok( -d $f{remove_prune_6}, '->remove(noprune) leaves dir intact' ); + +exit(); + + + + + +sub check_content_file { + my $file = shift; + return undef unless -e $file; + return undef unless -r $file; + + open( FILE, $file ) or return undef; + @content = <FILE>; + chomp @content; + close FILE; + + return undef unless scalar @content == 4; + return undef unless $content[0] eq 'one'; + return undef unless $content[1] eq 'two'; + return undef unless $content[2] eq 'three'; + return undef unless $content[3] eq ''; + + return 1; +} + +END { + # When we finish there are going to be some pretty fucked up files. + # Make them less so. + foreach my $clean1 ( qw{ + 0000 0100 0200 0300 0400 0500 0600 0700 + ff_handle moved_1 + write_1 write_2 write_3 write_4 write_5 write_6 + over_1 over_2 over_3 over_4 + append_1 append_2 append_3 append_4 + size_1 size_2 size_3 + trunc_1 + } ) { + if ( -e $clean1 ) { + chmod 0600, $clean1; + unlink $clean1; + next; + } + my $clean2 = catfile( 't', $clean1 ); + if ( -e $clean2 ) { + chmod 0600, $clean2; + unlink $clean2; + next; + } + } + + foreach my $dir ( qw{a b baddir gooddir} ) { + next unless -e $f{$dir}; + chmod_R( 0700, $f{$dir} ); + remove \1, $f{$dir}; + } + + remove \1, $f{prune}; +} diff --git a/t/97_meta.t b/t/97_meta.t new file mode 100644 index 0000000..8059fe1 --- /dev/null +++ b/t/97_meta.t @@ -0,0 +1,27 @@ +#!/usr/bin/perl + +# Test that our META.yml file matches the current specification. + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +my $MODULE = 'Test::CPAN::Meta 0.07'; + +# Don't run tests for installs +use Test::More; +unless ( $ENV{AUTOMATED_TESTING} or $ENV{RELEASE_TESTING} ) { + plan( skip_all => "Author tests not required for installation" ); +} + +# Load the testing module +eval "use $MODULE"; +if ( $@ ) { + $ENV{RELEASE_TESTING} + ? die( "Failed to load required release-testing module $MODULE" ) + : plan( skip_all => "$MODULE not available for testing" ); +} + +meta_yaml_ok(); diff --git a/t/98_pod.t b/t/98_pod.t new file mode 100644 index 0000000..b146b15 --- /dev/null +++ b/t/98_pod.t @@ -0,0 +1,72 @@ +#!/usr/bin/perl + +# Test that the syntax of our POD documentation is valid + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +my $MODULE = 'Test::Pod 1.00'; + +# Don't run tests for installs +use Test::More; +unless ( $ENV{AUTOMATED_TESTING} or $ENV{RELEASE_TESTING} ) { + plan( skip_all => "Author tests not required for installation" ); +} + +# Load the testing module +eval "use $MODULE"; +if ( $@ ) { + $ENV{RELEASE_TESTING} + ? die( "Failed to load required release-testing module $MODULE" ) + : plan( skip_all => "$MODULE not available for testing" ); +} + +all_pod_files_ok(); + + + + + + +##################################################################### +# WARNING: INSANE BLACK MAGIC +##################################################################### + +# Hack Pod::Simple::BlackBox to ignore the Test::Inline +# "Extended Begin" syntax. +# For example, "=begin has more than one word errors" +my $begin; +if ( $Test::Pod::VERSION ) { + $begin = \&Pod::Simple::BlackBox::_ponder_begin; +} +sub mybegin { + my $para = $_[1]; + my $content = join ' ', splice @$para, 2; + $content =~ s/^\s+//s; + $content =~ s/\s+$//s; + my @words = split /\s+/, $content; + if ( $words[0] =~ /^test(?:ing)?\z/s ) { + foreach ( 2 .. $#$para ) { + $para->[$_] = ''; + } + $para->[2] = $words[0]; + } + + # Continue as normal + push @$para, @words; + return &$begin(@_); +} + +SCOPE: { + local $^W = 0; + if ( $Test::Pod::VERSION ) { + *Pod::Simple::BlackBox::_ponder_begin = \&mybegin; + } +} + +##################################################################### +# END BLACK MAGIC +##################################################################### diff --git a/t/99_pmv.t b/t/99_pmv.t new file mode 100644 index 0000000..d989ebf --- /dev/null +++ b/t/99_pmv.t @@ -0,0 +1,27 @@ +#!/usr/bin/perl + +# Test that our declared minimum Perl version matches our syntax + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +my $MODULE = 'Test::MinimumVersion 0.007'; + +# Don't run tests for installs +use Test::More; +unless ( $ENV{AUTOMATED_TESTING} or $ENV{RELEASE_TESTING} ) { + plan( skip_all => "Author tests not required for installation" ); +} + +# Load the testing module +eval "use $MODULE"; +if ( $@ ) { + $ENV{RELEASE_TESTING} + ? die( "Failed to load required release-testing module $MODULE" ) + : plan( skip_all => "$MODULE not available for testing" ); +} + +all_minimum_version_from_metayml_ok(); diff --git a/t/ff_binary b/t/ff_binary new file mode 100644 index 0000000..344f385 Binary files /dev/null and b/t/ff_binary differ diff --git a/t/ff_content b/t/ff_content new file mode 100644 index 0000000..f3fcc92 --- /dev/null +++ b/t/ff_content @@ -0,0 +1,4 @@ +one +two +three + diff --git a/t/ff_text b/t/ff_text new file mode 100644 index 0000000..c54d775 --- /dev/null +++ b/t/ff_text @@ -0,0 +1,4 @@ +This is a test file + +It contains just plain simple text, with none of those annoying null bytes + -- Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/libfile-flat-perl.git _______________________________________________ Pkg-perl-cvs-commits mailing list Pkg-perl-cvs-commits@lists.alioth.debian.org http://lists.alioth.debian.org/cgi-bin/mailman/listinfo/pkg-perl-cvs-commits