[libfile-flat-perl] 01/02: Imported Upstream version 1.04
Jonas Genannt
jonas at brachium-system.net
Tue Aug 12 16:21:10 UTC 2014
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 <jonas at 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 <adamk at 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 <adamk at 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;
+ at 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", 'anonymous at 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>adamk at 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" );
+ at content = File::Flat->read( $f{null} );
+ok( ! scalar @content, "Static ->read (array context) returns error on bad file" );
+ at 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
More information about the Pkg-perl-cvs-commits
mailing list