@@ -0,0 +1,60 @@
+Contributing
+============
+
+The "Module-Compile" Project needs your help!
+
+Please consider being a contributor. This file contains instructions that will
+help you be an effective contributor to the Project.
+
+GitHub
+------
+
+The code for this Project is hosted at GitHub. The URL is:
+
+ https://github.com/ingydotnet/module-compile-pm
+
+You can get the code with this command:
+
+ git clone https://github.com/ingydotnet/module-compile-pm
+
+If you've found a bug or a missing feature that you would like the author to
+know about, report it here:
+
+ https://github.com/ingydotnet/module-compile-pm/issues
+
+or fix it and submit a pull request here:
+
+ https://github.com/ingydotnet/module-compile-pm/pulls
+
+See these links for help on interacting with GitHub:
+
+* https://help.github.com/
+* https://help.github.com/articles/creating-a-pull-request
+
+Zilla::Dist
+-----------
+
+This Project uses Zilla::Dist to prepare it for publishing to CPAN. Read:
+
+ https://metacpan.org/pod/Zilla::Dist::Contributing
+
+for up-to-date instructions on what contributors like yourself need to know to
+use it.
+
+IRC
+---
+
+Module-Compile has an IRC channel where you can find real people to help you:
+
+ irc.perl.org#pkg
+
+Join the channel. Join the team!
+
+
+ Thanks in advance, Ingy döt Net
+
+
+
+
+
+# This file generated by Zilla-Dist-0.0.179
@@ -1,94 +1,93 @@
----
-version: 0.23
-date: Tue Jun 14 00:09:03 EST 2011
-changes:
-- Release with Module::Package 0.25 to fix previous issues.
----
-version: 0.22
-date: Sun Jun 12 03:46:23 EST 2011
-changes:
-- Add Digest::SHA1 to deps
----
-version: 0.21
-date: Fri Jun 10 22:04:26 EST 2011
-changes:
-- Make modern
-- Switch to Module::Package
-- Use Stardoc
-- Move out of Kwiki repo
----
-version: 0.20
-date: Tue Oct 17 02:16:18 PDT 2006
-changes:
-- Removed a leftover 'use XXX;' that made tests fail.
----
-version: 0.19
-date: Sun Oct 1 10:05:13 CST 2006
-changes:
-- Recognize whitespace after the heredoc marker, e.g. "<< 'FOO'"
-- Don't treat a literal '<<' string by itself as a heredoc marker.
-- Don't treat '<<=' as a heredoc marker.
-- Support 'use_means_now'.
-
----
-version: 0.18
-date: Mon Jul 17 14:33:39 PDT 2006
-changes:
-- Patch from ruoso to make Makefile .pmc targets dep on .pm files.
-- Refactor caller stack number into a method.
-
----
-version: 0.17
-date: Sun Jul 2 22:36:34 CDT 2006
-changes:
-- Support for compiling non-module files.
-
----
-version: 0.16
-date: Mon Jun 26 11:50:46 CDT 2006
-changes:
-- Pugs tree changes
-- Support v6
-
----
-version: 0.15
-date: Sun Mar 26 12:34:58 PST 2006
-changes:
-- Added ability to fold out potentially conflicting code.
-- Added a context block to pass more info to compilers.
-
----
-version: 0.14
-date: Tue Mar 14 13:02:11 PST 2006
-changes:
-- Added Module::Install support for pmc
-- Lots of nice changes by audreyt
-
----
-version: 0.13
-date: Mon Mar 13 06:49:18 PST 2006
-changes:
-- Applied a freshness_check patch from audreyt
-- Added a ToDo list
-- Apostrophe is a package delimiter.
-
----
-version: 0.12
-date: Sun Mar 12 10:56:26 PST 2006
-changes:
-- Don't allow .pl -> .plc
-
----
-version: 0.11
-date: Sun Mar 12 10:05:47 PST 2006
-changes:
-- Fixed API bugs
-- Fixed Doc
-- Applied changes from audreyt
-- Added stub for freshness check
-
----
-version: 0.10
-date: Sun Mar 12 05:47:06 PST 2006
-changes:
-- Maiden voyage
+0.35 Wed Dec 24 13:10:28 PST 2014
+ - Remove Module::Install::PMC from dist
+
+0.34 Sat Aug 16 16:09:53 PDT 2014
+ - Fix strict/warnings
+
+0.33 Sat Aug 16 15:31:37 PDT 2014
+ - Fix comments
+
+0.32 Sat Aug 16 15:26:25 PDT 2014
+ - Change pod to swim
+
+0.31 Sat Aug 16 14:07:04 PDT 2014
+ - Remove =travis section
+
+0.30 Sat Aug 16 11:32:59 PDT 2014
+ - Meta 0.0.2
+
+0.29 Sat Aug 16 03:49:25 PDT 2014
+ - Eliminate spurious trailing whitespace
+
+0.28 Sat Aug 16 02:19:16 PDT 2014
+ - Eliminate File::Basename
+
+0.27 Fri Aug 15 18:45:31 PDT 2014
+ - Add t/000-compile-modules.t
+
+0.26 Wed Aug 13 12:13:45 PDT 2014
+ - Fix tests to use `inc` for Test::Base
+
+0.25 Wed Aug 13 11:23:45 PDT 2014
+ - Fix indexing by not splitting VERSION lines (Module::Install modules)
+
+0.24 Tue Aug 12 12:29:12 PDT 2014
+ - Switch to Zilla::Dist
+
+0.23 Tue Jun 14 00:09:03 EST 2011
+ - Release with Module::Package 0.25 to fix previous issues.
+
+0.22 Sun Jun 12 03:46:23 EST 2011
+ - Add Digest::SHA1 to deps
+
+0.21 Fri Jun 10 22:04:26 EST 2011
+ - Make modern
+ - Switch to Module::Package
+ - Use Stardoc
+ - Move out of Kwiki repo
+
+0.20 Tue Oct 17 02:16:18 PDT 2006
+ - Removed a leftover 'use XXX;' that made tests fail.
+
+0.19 Sun Oct 1 10:05:13 CST 2006
+ - Recognize whitespace after the heredoc marker, e.g. "<< 'FOO'"
+ - Don't treat a literal '<<' string by itself as a heredoc marker.
+ - Don't treat '<<=' as a heredoc marker.
+ - Support 'use_means_now'.
+
+0.18 Mon Jul 17 14:33:39 PDT 2006
+ - Patch from ruoso to make Makefile .pmc targets dep on .pm files.
+ - Refactor caller stack number into a method.
+
+0.17 Sun Jul 2 22:36:34 CDT 2006
+ - Support for compiling non-module files.
+
+0.16 Mon Jun 26 11:50:46 CDT 2006
+ - Pugs tree changes
+ - Support v6
+
+0.15 Sun Mar 26 12:34:58 PST 2006
+ - Added ability to fold out potentially conflicting code.
+ - Added a context block to pass more info to compilers.
+
+0.14 Tue Mar 14 13:02:11 PST 2006
+ - Added Module::Install support for pmc
+ - Lots of nice changes by audreyt
+
+0.13 Mon Mar 13 06:49:18 PST 2006
+ - Applied a freshness_check patch from audreyt
+ - Added a ToDo list
+ - Apostrophe is a package delimiter.
+
+0.12 Sun Mar 12 10:56:26 PST 2006
+ - Don't allow .pl -> .plc
+
+0.11 Sun Mar 12 10:05:47 PST 2006
+ - Fixed API bugs
+ - Fixed Doc
+ - Applied changes from audreyt
+ - Added stub for freshness check
+
+0.10 Sun Mar 12 05:47:06 PST 2006
+ - Maiden voyage
+
@@ -1,76 +0,0 @@
-=== Possible Compilers
-
-- Switch (prefer 5.10's feature qw(switch))
-- Inline
-- Indented
-- Spiffy
-- Perl6::Subs
-- Params::Validate
-
-
-=== Concerns
-
-- It should be easy to turn off specific compilers lexically
-
-For instance:
-
- use Indented;
-
- sub foo:
- print "Hello\n"
-
- use Inline C;
- ...
- no Inline;
-
- sub bar:
- 1
-
-I don't want my Inline code to be filtered.
-
-=== Parse and Dispatch Algorithm
-
-Module::Compile breaks source code into blocks and the dispatches
-compilers on those blocks. This section discusses how the code is broken
-down and then what order the compilers are invoked.
-
-Note, all boundaries are specified in terms of lines. This makes the
-process easier to grok and get right, because then granularity is not
-that fine.
-
-The code parsing and dispatch is determined by the first 'use MyCompiler'
-statement in the program. Although that compiler might choose any scheme it
-wishes, this document describes the default process.
-
-First the file is broken up into a tree of blocks:
-
- Global Code:
- Subs
- Blocks
- Heredocs
- Comments
- Pod
- DATA Section
-
-Next all the code is scanned for 'use/no Compiler' lines. No use statement
-can go past the end of it's containing block.
-
-An event stack is built such that innermost compilers are called first.
-
-Dispatch proceeds. When a section is about to be comiled, the class is asked
-which parts of the source it wishes to see. Code, strings, comments, etc.
-Pieces that are not to be seen are turned into tokens that will likely not be
-reparsed.
-
-After the compilation the result is saved. The class is asked whether it want
-other classes to be able to reparse it. If not it is turned into a token.
-
-A token is a Hexadecimal MD5 sum of the original text, perhaps in quotes.
-
-After compilation, the parsing steps should be rerun on the result. Maybe.
-This is a very edge case.
-
-The next outer scope compiler is called until everything is parsed. Then the
-tree is walked and results are substituted back in for the tokens.
-
-Done.
@@ -1,4 +1,4 @@
-This software is copyright (c) 2011 by Ingy döt Net <ingy@ingy.net>.
+This software is copyright (c) 2014 by Ingy döt Net.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
@@ -12,21 +12,22 @@ b) the "Artistic License"
--- The GNU General Public License, Version 1, February 1989 ---
-This software is Copyright (c) 2011 by Ingy döt Net <ingy@ingy.net>.
+This software is Copyright (c) 2014 by Ingy döt Net.
This is free software, licensed under:
The GNU General Public License, Version 1, February 1989
- GNU GENERAL PUBLIC LICENSE
- Version 1, February 1989
+ GNU GENERAL PUBLIC LICENSE
+ Version 1, February 1989
Copyright (C) 1989 Free Software Foundation, Inc.
- 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA
+ 51 Franklin St, Suite 500, Boston, MA 02110-1335 USA
+
Everyone is permitted to copy and distribute verbatim copies
of this license document, but changing it is not allowed.
- Preamble
+ Preamble
The license agreements of most software companies try to keep users
at the mercy of those companies. By contrast, our General Public
@@ -67,7 +68,7 @@ authors' reputations.
The precise terms and conditions for copying, distribution and
modification follow.
- GNU GENERAL PUBLIC LICENSE
+ GNU GENERAL PUBLIC LICENSE
TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
0. This License Agreement applies to any program or other work which
@@ -185,7 +186,7 @@ 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
+ NO WARRANTY
9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
@@ -207,9 +208,9 @@ 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
+ END OF TERMS AND CONDITIONS
- Appendix: How to Apply These Terms to Your New Programs
+ Appendix: How to Apply These Terms to Your New Programs
If you develop a new program, and you want it to be of the greatest
possible use to humanity, the best way to achieve this is to make it
@@ -235,8 +236,9 @@ the exclusion of warranty; and each file should have at least the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
- along with this program; if not, write to the Free Software Foundation,
- Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA.
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston MA 02110-1301 USA
+
Also add information on how to contact you by electronic and paper mail.
@@ -270,7 +272,7 @@ That's all there is to it!
--- The Artistic License 1.0 ---
-This software is Copyright (c) 2011 by Ingy döt Net <ingy@ingy.net>.
+This software is Copyright (c) 2014 by Ingy döt Net.
This is free software, licensed under:
@@ -1,38 +1,24 @@
+# This file was automatically generated by Dist::Zilla::Plugin::Manifest v5.019.
+CONTRIBUTING
Changes
-DESIGN
-inc/Module/Install.pm
-inc/Module/Install/Base.pm
-inc/Module/Install/Can.pm
-inc/Module/Install/Fetch.pm
-inc/Module/Install/GithubMeta.pm
-inc/Module/Install/Include.pm
-inc/Module/Install/Makefile.pm
-inc/Module/Install/Metadata.pm
-inc/Module/Install/Package.pm
-inc/Module/Install/Win32.pm
-inc/Module/Install/WriteAll.pm
-inc/Module/Package.pm
+LICENSE
+MANIFEST
+META.json
+META.yml
+Makefile.PL
+README
inc/Spiffy.pm
inc/Test/Base.pm
inc/Test/Base/Filter.pm
-inc/Test/Builder.pm
-inc/Test/Builder/Module.pm
-inc/Test/More.pm
lib/Module/Compile.pm
lib/Module/Compile.pod
lib/Module/Compile/Opt.pm
lib/Module/Compile/Opt.pod
-lib/Module/Install/Admin/PMC.pm
-lib/Module/Install/Admin/PMC.pod
-lib/Module/Install/PMC.pm
-lib/Module/Install/PMC.pod
+lib/Module/Compile/Optimize.pod
lib/Module/Optimize.pm
-lib/Module/Optimize.pod
-LICENSE
-Makefile.PL
-MANIFEST This list of files
-META.yml
-README
+t/000-compile-modules.t
+t/TestModuleCompile.pm
+t/Testorz.pm
t/compile.t
t/data1.t
t/data2.t
@@ -47,5 +33,4 @@ t/orz.t
t/parse.t
t/pm.t
t/pmc.t
-t/TestModuleCompile.pm
-t/Testorz.pm
+t/release-pod-syntax.t
@@ -0,0 +1,56 @@
+{
+ "abstract" : "Perl Module Compilation",
+ "author" : [
+ "Ingy döt Net <ingy@cpan.org>"
+ ],
+ "dynamic_config" : 0,
+ "generated_by" : "Dist::Zilla version 5.019, CPAN::Meta::Converter version 2.132830",
+ "license" : [
+ "perl_5"
+ ],
+ "meta-spec" : {
+ "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
+ "version" : "2"
+ },
+ "name" : "Module-Compile",
+ "no_index" : {
+ "directory" : [
+ "inc",
+ "t",
+ "xt",
+ "example"
+ ]
+ },
+ "prereqs" : {
+ "configure" : {
+ "requires" : {
+ "ExtUtils::MakeMaker" : "6.30"
+ }
+ },
+ "develop" : {
+ "requires" : {
+ "Test::Pod" : "1.41"
+ }
+ },
+ "runtime" : {
+ "requires" : {
+ "Digest::SHA1" : "2.13",
+ "perl" : "v5.8.1"
+ }
+ }
+ },
+ "release_status" : "stable",
+ "resources" : {
+ "bugtracker" : {
+ "web" : "https://github.com/ingydotnet/module-compile-pm/issues"
+ },
+ "homepage" : "https://github.com/ingydotnet/module-compile-pm",
+ "repository" : {
+ "type" : "git",
+ "url" : "https://github.com/ingydotnet/module-compile-pm.git",
+ "web" : "https://github.com/ingydotnet/module-compile-pm"
+ }
+ },
+ "version" : "0.35"
+}
+
@@ -1,29 +1,28 @@
---
abstract: 'Perl Module Compilation'
author:
- - 'Ingy döt Net <ingy@ingy.net>'
-build_requires:
- ExtUtils::MakeMaker: 6.42
+ - 'Ingy döt Net <ingy@cpan.org>'
+build_requires: {}
configure_requires:
- ExtUtils::MakeMaker: 6.42
-distribution_type: module
-generated_by: 'Module::Install version 1.01'
+ ExtUtils::MakeMaker: '6.30'
+dynamic_config: 0
+generated_by: 'Dist::Zilla version 5.019, CPAN::Meta::Converter version 2.132830'
license: perl
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
- version: 1.4
-module_name: Module::Compile
+ version: '1.4'
name: Module-Compile
no_index:
directory:
- inc
- t
+ - xt
+ - example
requires:
- Digest::SHA1: 2.13
- Filter::Util::Call: 0
- perl: 5.8.3
+ Digest::SHA1: '2.13'
+ perl: v5.8.1
resources:
- homepage: http://github.com/ingydotnet/module-compile-pm/tree
- license: http://dev.perl.org/licenses/
- repository: git://github.com/ingydotnet/module-compile-pm.git
-version: 0.23
+ bugtracker: https://github.com/ingydotnet/module-compile-pm/issues
+ homepage: https://github.com/ingydotnet/module-compile-pm
+ repository: https://github.com/ingydotnet/module-compile-pm.git
+version: '0.35'
@@ -1,11 +1,49 @@
-use inc::Module::Package 'Ingy:modern 0.12';
-clean_files 't/lib/*.pmc';
-clean_files 't/*.tc';
+# This file was automatically generated by Dist::Zilla::Plugin::MakeMaker v5.019.
+use strict;
+use warnings;
+
+use 5.008001;
+
+use ExtUtils::MakeMaker 6.30;
+
+
+
+my %WriteMakefileArgs = (
+ "ABSTRACT" => "Perl Module Compilation",
+ "AUTHOR" => "Ingy d\x{f6}t Net <ingy\@cpan.org>",
+ "CONFIGURE_REQUIRES" => {
+ "ExtUtils::MakeMaker" => "6.30"
+ },
+ "DISTNAME" => "Module-Compile",
+ "EXE_FILES" => [],
+ "LICENSE" => "perl",
+ "NAME" => "Module::Compile",
+ "PREREQ_PM" => {
+ "Digest::SHA1" => "2.13"
+ },
+ "VERSION" => "0.35",
+ "test" => {
+ "TESTS" => "t/*.t"
+ }
+);
+
+
+my %FallbackPrereqs = (
+ "Digest::SHA1" => "2.13"
+);
+
+
+unless ( eval { ExtUtils::MakeMaker->VERSION(6.63_03) } ) {
+ delete $WriteMakefileArgs{TEST_REQUIRES};
+ delete $WriteMakefileArgs{BUILD_REQUIRES};
+ $WriteMakefileArgs{PREREQ_PM} = \%FallbackPrereqs;
+}
+
+delete $WriteMakefileArgs{CONFIGURE_REQUIRES}
+ unless eval { ExtUtils::MakeMaker->VERSION(6.52) };
+
+WriteMakefile(%WriteMakefileArgs);
-__END__
-# Deps list generated by:
-author_requires 'Module::Package' => '0.25';
-author_requires 'Module::Install::TestBase' => '0.60';
@@ -11,10 +11,10 @@ SYNOPSIS
return $compiled_output;
}
- In Bar.pm:
+ In "Bar.pm":
package Bar;
-
+
use Foo;
...
no Foo
@@ -22,13 +22,13 @@ SYNOPSIS
or (implied "no Foo;"):
package Bar;
-
+
{
use Foo;
...
}
- To compile Bar.pm into Bar.pmc:
+ To compile "Bar.pm" into "Bar.pmc":
perl -c Bar.pm
@@ -48,7 +48,7 @@ EXAMPLE
package v6;
use Module::Compile -base;
-
+
sub pmc_compile {
my ($class, $source) = @_;
# ... some way to invoke pugs and give p5 code back ...
@@ -65,14 +65,14 @@ EXAMPLE
On the first time this module is loaded, it will compile Perl 6 blocks
into Perl 5 (as soon as the "no v6" line is seen), and merge it with the
- Perl 5 blocks, saving the result into a MyModule.pmc file.
+ Perl 5 blocks, saving the result into a "MyModule.pmc" file.
- The next time around, Perl 5 will automatically load MyModule.pmc when
+ The next time around, Perl 5 will automatically load "MyModule.pmc" when
someone says "use MyModule". On the other hand, Perl 6 can run
MyModule.pm s a Perl 6 module just fine, as "use v6-pugs" and "no v6"
both works in a Perl 6 setting.
- The v6.pm module will also check if MyModule.pmc is up to date. If it
+ The v6.pm module will also check if "MyModule.pmc" is up to date. If it
is, then it will touch its timestamp so the ".pmc" is loaded on the next
time.
@@ -110,27 +110,45 @@ PARSING AND DISPATCH
Next, the source module is divided into a shallow tree of blocks:
PREAMBLE:
- (SUBROUTINE | BAREBLOCK | POD | PLAIN)S
+ (SUBROUTINE | BAREBLOCK | POD | PLAIN)S
PACKAGES:
- PREFACE
- (SUBROUTINE | BAREBLOCK | POD | PLAIN)S
+ PREFACE
+ (SUBROUTINE | BAREBLOCK | POD | PLAIN)S
DATA
All of these blocks begin and end on line boundaries. They are described
as follows:
- PREAMBLE - Lines before the first C<package> statement.
- PACKAGES - Lines beginning with a C<package statement and continuing
- until the next C<package> or C<DATA> section.
- DATA - The DATA section. Begins with the line C<__DATA__> or
- C<__END__>.
- SUBROUTINE - A top level (not nested) subroutine. Ending '}' must be
- on its own line in the first column.
- BAREBLOCK - A top level (not nested) code block. Ending '}' must be
- on its own line in the first column.
- POD - Pod sections beginning with C<^=\w+> and ending with C<=cut>.
- PLAIN - Lines not in SUBROUTINE, BAREBLOCK or POD.
- PREFACE - Lines before the first block in a package.
+ PREAMBLE
+ Lines before the first "package" statement.
+
+ PACKAGES
+ Lines beginning with a `package statement and continuing
+
+ until the next `package` or `DATA` section.
+
+ DATA
+ The DATA section. Begins with the line "__DATA__" or
+
+ "__END__".
+
+ SUBROUTINE
+ A top level (not nested) subroutine. Ending '}' must be
+
+ on its own line in the first column.
+
+ BAREBLOCK
+ A top level (not nested) code block. Ending '}' must be
+
+ on its own line in the first column.
+
+ POD Pod sections beginning with "^=\w+" and ending with "=cut".
+
+ PLAIN
+ Lines not in SUBROUTINE, BAREBLOCK or POD.
+
+ PREFACE
+ Lines before the first block in a package.
Next, all the blocks are scanned for lines like:
@@ -147,8 +165,10 @@ PARSING AND DISPATCH
After all the code has been parsed into blocks and the blocks have been
marked for various compilers, Module::Compile dispatches the code blocks
- to the compilers. It does so in a most specific to most general order.
- So inner blocks get compiled first, then outer blocks.
+ to the
+
+ compilers. It does so in a most specific to most general order. So inner
+ blocks get compiled first, then outer blocks.
A compiler may choose to declare that its result not be recompiled by
some other containing parser. In this case the result of the compilation
@@ -166,9 +186,8 @@ PARSING AND DISPATCH
DISTRIBUTION SUPPORT
Module::Install makes it terribly easy to prepare a module distribution
- with compiled .pmc files. Module::Compile installs a
- Module::Install::PMC plugin. All you need to do is add this line to your
- Makefile.PL:
+ with compiled .pmc files. See Module::Install::PMC. All you need to do
+ is add this line to your Makefile.PL:
pmc_support;
@@ -180,16 +199,20 @@ DISTRIBUTION SUPPORT
prerequisites.
SEE ALSO
- Module::Install
+ * Module::Install
+
+ * Module::Install::PMC
+
+AUTHORS
+ * Ingy döt Net <ingy@cpan.org>
-AUTHOR
- Ingy döt Net <ingy@ingy.net>
+ * Audrey Tang <audreyt@audreyt.org>
-COPYRIGHT AND LICENSE
- Copyright (c) 2006, 2011. Ingy döt Net.
+COPYRIGHT
+ Copyright 2006-2014. Ingy döt Net.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
- See http://www.perl.com/perl/misc/Artistic.html
+ See <http://www.perl.com/perl/misc/Artistic.html>
@@ -1,83 +0,0 @@
-#line 1
-package Module::Install::Base;
-
-use strict 'vars';
-use vars qw{$VERSION};
-BEGIN {
- $VERSION = '1.01';
-}
-
-# Suspend handler for "redefined" warnings
-BEGIN {
- my $w = $SIG{__WARN__};
- $SIG{__WARN__} = sub { $w };
-}
-
-#line 42
-
-sub new {
- my $class = shift;
- unless ( defined &{"${class}::call"} ) {
- *{"${class}::call"} = sub { shift->_top->call(@_) };
- }
- unless ( defined &{"${class}::load"} ) {
- *{"${class}::load"} = sub { shift->_top->load(@_) };
- }
- bless { @_ }, $class;
-}
-
-#line 61
-
-sub AUTOLOAD {
- local $@;
- my $func = eval { shift->_top->autoload } or return;
- goto &$func;
-}
-
-#line 75
-
-sub _top {
- $_[0]->{_top};
-}
-
-#line 90
-
-sub admin {
- $_[0]->_top->{admin}
- or
- Module::Install::Base::FakeAdmin->new;
-}
-
-#line 106
-
-sub is_admin {
- ! $_[0]->admin->isa('Module::Install::Base::FakeAdmin');
-}
-
-sub DESTROY {}
-
-package Module::Install::Base::FakeAdmin;
-
-use vars qw{$VERSION};
-BEGIN {
- $VERSION = $Module::Install::Base::VERSION;
-}
-
-my $fake;
-
-sub new {
- $fake ||= bless(\@_, $_[0]);
-}
-
-sub AUTOLOAD {}
-
-sub DESTROY {}
-
-# Restore warning handler
-BEGIN {
- $SIG{__WARN__} = $SIG{__WARN__}->();
-}
-
-1;
-
-#line 159
@@ -1,81 +0,0 @@
-#line 1
-package Module::Install::Can;
-
-use strict;
-use Config ();
-use File::Spec ();
-use ExtUtils::MakeMaker ();
-use Module::Install::Base ();
-
-use vars qw{$VERSION @ISA $ISCORE};
-BEGIN {
- $VERSION = '1.01';
- @ISA = 'Module::Install::Base';
- $ISCORE = 1;
-}
-
-# 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}), '.') {
- next if $dir eq '';
- 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 156
@@ -1,93 +0,0 @@
-#line 1
-package Module::Install::Fetch;
-
-use strict;
-use Module::Install::Base ();
-
-use vars qw{$VERSION @ISA $ISCORE};
-BEGIN {
- $VERSION = '1.01';
- @ISA = 'Module::Install::Base';
- $ISCORE = 1;
-}
-
-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@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;
@@ -1,50 +0,0 @@
-#line 1
-package Module::Install::GithubMeta;
-
-use strict;
-use warnings;
-use Cwd;
-use base qw(Module::Install::Base);
-use vars qw($VERSION);
-
-$VERSION = '0.10';
-
-sub githubmeta {
- my $self = shift;
- return unless $Module::Install::AUTHOR;
- return unless _under_git();
- return unless $self->can_run('git');
- return unless my ($git_url) = `git remote show -n origin` =~ /URL: (.*)$/m;
- return unless $git_url =~ /github\.com/; # Not a Github repository
- my $http_url = $git_url;
- $git_url =~ s![\w\-]+\@([^:]+):!git://$1/!;
- $http_url =~ s![\w\-]+\@([^:]+):!http://$1/!;
- $http_url =~ s!\.git$!/tree!;
- $self->repository( $git_url );
- $self->homepage( $http_url ) unless $self->homepage();
- return 1;
-}
-
-sub _under_git {
- return 1 if -e '.git';
- my $cwd = getcwd;
- my $last = $cwd;
- my $found = 0;
- while (1) {
- chdir '..' or last;
- my $current = getcwd;
- last if $last eq $current;
- $last = $current;
- if ( -e '.git' ) {
- $found = 1;
- last;
- }
- }
- chdir $cwd;
- return $found;
-}
-
-'Github';
-__END__
-
-#line 108
@@ -1,34 +0,0 @@
-#line 1
-package Module::Install::Include;
-
-use strict;
-use Module::Install::Base ();
-
-use vars qw{$VERSION @ISA $ISCORE};
-BEGIN {
- $VERSION = '1.01';
- @ISA = 'Module::Install::Base';
- $ISCORE = 1;
-}
-
-sub include {
- shift()->admin->include(@_);
-}
-
-sub include_deps {
- shift()->admin->include_deps(@_);
-}
-
-sub auto_include {
- shift()->admin->auto_include(@_);
-}
-
-sub auto_include_deps {
- shift()->admin->auto_include_deps(@_);
-}
-
-sub auto_include_dependent_dists {
- shift()->admin->auto_include_dependent_dists(@_);
-}
-
-1;
@@ -1,415 +0,0 @@
-#line 1
-package Module::Install::Makefile;
-
-use strict 'vars';
-use ExtUtils::MakeMaker ();
-use Module::Install::Base ();
-use Fcntl qw/:flock :seek/;
-
-use vars qw{$VERSION @ISA $ISCORE};
-BEGIN {
- $VERSION = '1.01';
- @ISA = 'Module::Install::Base';
- $ISCORE = 1;
-}
-
-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 or non-interactive session, always use defaults
- if ( ($ENV{AUTOMATED_TESTING} or -! -t STDIN) and ! $ENV{PERL_MM_USE_DEFAULT} ) {
- local $ENV{PERL_MM_USE_DEFAULT} = 1;
- goto &ExtUtils::MakeMaker::prompt;
- } else {
- goto &ExtUtils::MakeMaker::prompt;
- }
-}
-
-# Store a cleaned up version of the MakeMaker version,
-# since we need to behave differently in a variety of
-# ways based on the MM version.
-my $makemaker = eval $ExtUtils::MakeMaker::VERSION;
-
-# If we are passed a param, do a "newer than" comparison.
-# Otherwise, just return the MakeMaker version.
-sub makemaker {
- ( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0
-}
-
-# Ripped from ExtUtils::MakeMaker 6.56, and slightly modified
-# as we only need to know here whether the attribute is an array
-# or a hash or something else (which may or may not be appendable).
-my %makemaker_argtype = (
- C => 'ARRAY',
- CONFIG => 'ARRAY',
-# CONFIGURE => 'CODE', # ignore
- DIR => 'ARRAY',
- DL_FUNCS => 'HASH',
- DL_VARS => 'ARRAY',
- EXCLUDE_EXT => 'ARRAY',
- EXE_FILES => 'ARRAY',
- FUNCLIST => 'ARRAY',
- H => 'ARRAY',
- IMPORTS => 'HASH',
- INCLUDE_EXT => 'ARRAY',
- LIBS => 'ARRAY', # ignore ''
- MAN1PODS => 'HASH',
- MAN3PODS => 'HASH',
- META_ADD => 'HASH',
- META_MERGE => 'HASH',
- PL_FILES => 'HASH',
- PM => 'HASH',
- PMLIBDIRS => 'ARRAY',
- PMLIBPARENTDIRS => 'ARRAY',
- PREREQ_PM => 'HASH',
- CONFIGURE_REQUIRES => 'HASH',
- SKIP => 'ARRAY',
- TYPEMAPS => 'ARRAY',
- XS => 'HASH',
-# VERSION => ['version',''], # ignore
-# _KEEP_AFTER_FLUSH => '',
-
- clean => 'HASH',
- depend => 'HASH',
- dist => 'HASH',
- dynamic_lib=> 'HASH',
- linkext => 'HASH',
- macro => 'HASH',
- postamble => 'HASH',
- realclean => 'HASH',
- test => 'HASH',
- tool_autosplit => 'HASH',
-
- # special cases where you can use makemaker_append
- CCFLAGS => 'APPENDABLE',
- DEFINE => 'APPENDABLE',
- INC => 'APPENDABLE',
- LDDLFLAGS => 'APPENDABLE',
- LDFROM => 'APPENDABLE',
-);
-
-sub makemaker_args {
- my ($self, %new_args) = @_;
- my $args = ( $self->{makemaker_args} ||= {} );
- foreach my $key (keys %new_args) {
- if ($makemaker_argtype{$key}) {
- if ($makemaker_argtype{$key} eq 'ARRAY') {
- $args->{$key} = [] unless defined $args->{$key};
- unless (ref $args->{$key} eq 'ARRAY') {
- $args->{$key} = [$args->{$key}]
- }
- push @{$args->{$key}},
- ref $new_args{$key} eq 'ARRAY'
- ? @{$new_args{$key}}
- : $new_args{$key};
- }
- elsif ($makemaker_argtype{$key} eq 'HASH') {
- $args->{$key} = {} unless defined $args->{$key};
- foreach my $skey (keys %{ $new_args{$key} }) {
- $args->{$key}{$skey} = $new_args{$key}{$skey};
- }
- }
- elsif ($makemaker_argtype{$key} eq 'APPENDABLE') {
- $self->makemaker_append($key => $new_args{$key});
- }
- }
- else {
- if (defined $args->{$key}) {
- warn qq{MakeMaker attribute "$key" is overriden; use "makemaker_append" to append values\n};
- }
- $args->{$key} = $new_args{$key};
- }
- }
- return $args;
-}
-
-# For mm args that take multiple space-seperated args,
-# append an argument to the current list.
-sub makemaker_append {
- my $self = shift;
- 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 );
-}
-
-sub _wanted_t {
-}
-
-sub tests_recursive {
- my $self = shift;
- my $dir = shift || 't';
- unless ( -d $dir ) {
- die "tests_recursive dir '$dir' does not exist";
- }
- my %tests = map { $_ => 1 } split / /, ($self->tests || '');
- require File::Find;
- File::Find::find(
- sub { /\.t$/ and -f $_ and $tests{"$File::Find::dir/*.t"} = 1 },
- $dir
- );
- $self->tests( join ' ', sort keys %tests );
-}
-
-sub write {
- my $self = shift;
- die "&Makefile->write() takes no arguments\n" if @_;
-
- # Check the current Perl version
- my $perl_version = $self->perl_version;
- if ( $perl_version ) {
- eval "use $perl_version; 1"
- or die "ERROR: perl: Version $] is installed, "
- . "but we need version >= $perl_version";
- }
-
- # Make sure we have a new enough MakeMaker
- require ExtUtils::MakeMaker;
-
- if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) {
- # MakeMaker can complain about module versions that include
- # an underscore, even though its own version may contain one!
- # Hence the funny regexp to get rid of it. See RT #35800
- # for details.
- my $v = $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/;
- $self->build_requires( 'ExtUtils::MakeMaker' => $v );
- $self->configure_requires( 'ExtUtils::MakeMaker' => $v );
- } else {
- # Allow legacy-compatibility with 5.005 by depending on the
- # most recent EU:MM that supported 5.005.
- $self->build_requires( 'ExtUtils::MakeMaker' => 6.42 );
- $self->configure_requires( 'ExtUtils::MakeMaker' => 6.42 );
- }
-
- # Generate the MakeMaker params
- my $args = $self->makemaker_args;
- $args->{DISTNAME} = $self->name;
- $args->{NAME} = $self->module_name || $self->name;
- $args->{NAME} =~ s/-/::/g;
- $args->{VERSION} = $self->version or die <<'EOT';
-ERROR: Can't determine distribution version. Please specify it
-explicitly via 'version' in Makefile.PL, or set a valid $VERSION
-in a module, and provide its file path via 'version_from' (or
-'all_from' if you prefer) in Makefile.PL.
-EOT
-
- $DB::single = 1;
- if ( $self->tests ) {
- my @tests = split ' ', $self->tests;
- my %seen;
- $args->{test} = {
- TESTS => (join ' ', grep {!$seen{$_}++} @tests),
- };
- } elsif ( $Module::Install::ExtraTests::use_extratests ) {
- # Module::Install::ExtraTests doesn't set $self->tests and does its own tests via harness.
- # So, just ignore our xt tests here.
- } elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) {
- $args->{test} = {
- TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ),
- };
- }
- if ( $] >= 5.005 ) {
- $args->{ABSTRACT} = $self->abstract;
- $args->{AUTHOR} = join ', ', @{$self->author || []};
- }
- if ( $self->makemaker(6.10) ) {
- $args->{NO_META} = 1;
- #$args->{NO_MYMETA} = 1;
- }
- if ( $self->makemaker(6.17) and $self->sign ) {
- $args->{SIGN} = 1;
- }
- unless ( $self->is_admin ) {
- delete $args->{SIGN};
- }
- if ( $self->makemaker(6.31) and $self->license ) {
- $args->{LICENSE} = $self->license;
- }
-
- my $prereq = ($args->{PREREQ_PM} ||= {});
- %$prereq = ( %$prereq,
- map { @$_ } # flatten [module => version]
- map { @$_ }
- grep $_,
- ($self->requires)
- );
-
- # Remove any reference to perl, PREREQ_PM doesn't support it
- delete $args->{PREREQ_PM}->{perl};
-
- # Merge both kinds of requires into BUILD_REQUIRES
- my $build_prereq = ($args->{BUILD_REQUIRES} ||= {});
- %$build_prereq = ( %$build_prereq,
- map { @$_ } # flatten [module => version]
- map { @$_ }
- grep $_,
- ($self->configure_requires, $self->build_requires)
- );
-
- # Remove any reference to perl, BUILD_REQUIRES doesn't support it
- delete $args->{BUILD_REQUIRES}->{perl};
-
- # Delete bundled dists from prereq_pm, add it to Makefile DIR
- my $subdirs = ($args->{DIR} || []);
- if ($self->bundles) {
- my %processed;
- foreach my $bundle (@{ $self->bundles }) {
- my ($mod_name, $dist_dir) = @$bundle;
- delete $prereq->{$mod_name};
- $dist_dir = File::Basename::basename($dist_dir); # dir for building this module
- if (not exists $processed{$dist_dir}) {
- if (-d $dist_dir) {
- # List as sub-directory to be processed by make
- push @$subdirs, $dist_dir;
- }
- # Else do nothing: the module is already present on the system
- $processed{$dist_dir} = undef;
- }
- }
- }
-
- unless ( $self->makemaker('6.55_03') ) {
- %$prereq = (%$prereq,%$build_prereq);
- delete $args->{BUILD_REQUIRES};
- }
-
- 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";
-
- if ( $self->makemaker(6.48) ) {
- $args->{MIN_PERL_VERSION} = $perl_version;
- }
- }
-
- if ($self->installdirs) {
- warn qq{old INSTALLDIRS (probably set by makemaker_args) is overriden by installdirs\n} if $args->{INSTALLDIRS};
- $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) ) {
- foreach my $key ( keys %$preop ) {
- $args{dist}->{$key} = $preop->{$key};
- }
- }
-
- 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: $!";
- eval { flock MAKEFILE, LOCK_EX };
- my $makefile = do { local $/; <MAKEFILE> };
-
- $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;
-
- seek MAKEFILE, 0, SEEK_SET;
- truncate MAKEFILE, 0;
- 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 541
@@ -1,716 +0,0 @@
-#line 1
-package Module::Install::Metadata;
-
-use strict 'vars';
-use Module::Install::Base ();
-
-use vars qw{$VERSION @ISA $ISCORE};
-BEGIN {
- $VERSION = '1.01';
- @ISA = 'Module::Install::Base';
- $ISCORE = 1;
-}
-
-my @boolean_keys = qw{
- sign
-};
-
-my @scalar_keys = qw{
- name
- module_name
- abstract
- version
- distribution_type
- tests
- installdirs
-};
-
-my @tuple_keys = qw{
- configure_requires
- build_requires
- requires
- recommends
- bundles
- resources
-};
-
-my @resource_keys = qw{
- homepage
- bugtracker
- repository
-};
-
-my @array_keys = qw{
- keywords
- author
-};
-
-*authors = \&author;
-
-sub Meta { shift }
-sub Meta_BooleanKeys { @boolean_keys }
-sub Meta_ScalarKeys { @scalar_keys }
-sub Meta_TupleKeys { @tuple_keys }
-sub Meta_ResourceKeys { @resource_keys }
-sub Meta_ArrayKeys { @array_keys }
-
-foreach my $key ( @boolean_keys ) {
- *$key = sub {
- my $self = shift;
- if ( defined wantarray and not @_ ) {
- return $self->{values}->{$key};
- }
- $self->{values}->{$key} = ( @_ ? $_[0] : 1 );
- return $self;
- };
-}
-
-foreach my $key ( @scalar_keys ) {
- *$key = sub {
- my $self = shift;
- return $self->{values}->{$key} if defined wantarray and !@_;
- $self->{values}->{$key} = shift;
- return $self;
- };
-}
-
-foreach my $key ( @array_keys ) {
- *$key = sub {
- my $self = shift;
- return $self->{values}->{$key} if defined wantarray and !@_;
- $self->{values}->{$key} ||= [];
- push @{$self->{values}->{$key}}, @_;
- return $self;
- };
-}
-
-foreach my $key ( @resource_keys ) {
- *$key = sub {
- my $self = shift;
- unless ( @_ ) {
- return () unless $self->{values}->{resources};
- return map { $_->[1] }
- grep { $_->[0] eq $key }
- @{ $self->{values}->{resources} };
- }
- return $self->{values}->{resources}->{$key} unless @_;
- my $uri = shift or die(
- "Did not provide a value to $key()"
- );
- $self->resources( $key => $uri );
- return 1;
- };
-}
-
-foreach my $key ( grep { $_ ne "resources" } @tuple_keys) {
- *$key = sub {
- my $self = shift;
- return $self->{values}->{$key} unless @_;
- my @added;
- while ( @_ ) {
- my $module = shift or last;
- my $version = shift || 0;
- push @added, [ $module, $version ];
- }
- push @{ $self->{values}->{$key} }, @added;
- return map {@$_} @added;
- };
-}
-
-# Resource handling
-my %lc_resource = map { $_ => 1 } qw{
- homepage
- license
- bugtracker
- repository
-};
-
-sub resources {
- my $self = shift;
- while ( @_ ) {
- my $name = shift or last;
- my $value = shift or next;
- if ( $name eq lc $name and ! $lc_resource{$name} ) {
- die("Unsupported reserved lowercase resource '$name'");
- }
- $self->{values}->{resources} ||= [];
- push @{ $self->{values}->{resources} }, [ $name, $value ];
- }
- $self->{values}->{resources};
-}
-
-# 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 dynamic_config {
- my $self = shift;
- unless ( @_ ) {
- warn "You MUST provide an explicit true/false value to dynamic_config\n";
- return $self;
- }
- $self->{values}->{dynamic_config} = $_[0] ? 1 : 0;
- return 1;
-}
-
-sub perl_version {
- my $self = shift;
- return $self->{values}->{perl_version} unless @_;
- my $version = shift or die(
- "Did not provide a value to perl_version()"
- );
-
- # Normalize the version
- $version = $self->_perl_version($version);
-
- # We don't support the really old versions
- unless ( $version >= 5.005 ) {
- die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n";
- }
-
- $self->{values}->{perl_version} = $version;
-}
-
-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;
- unless ( -e $file ) {
- die("all_from cannot find $file from $name");
- }
- }
- unless ( -f $file ) {
- die("The path '$file' does not exist, or is not a file");
- }
-
- $self->{values}{all_from} = $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) );
-
- # for version integrity check
- $self->makemaker_args( VERSION_FROM => $file );
-}
-
-sub abstract_from {
- require ExtUtils::MM_Unix;
- my ( $self, $file ) = @_;
- $self->abstract(
- bless(
- { DISTNAME => $self->name },
- 'ExtUtils::MM_Unix'
- )->parse_abstract($file)
- );
-}
-
-# Add both distribution and module name
-sub name_from {
- my ($self, $file) = @_;
- if (
- Module::Install::_read($file) =~ m/
- ^ \s*
- package \s*
- ([\w:]+)
- \s* ;
- /ixms
- ) {
- my ($name, $module_name) = ($1, $1);
- $name =~ s{::}{-}g;
- $self->name($name);
- unless ( $self->module_name ) {
- $self->module_name($module_name);
- }
- } else {
- die("Cannot determine name from $file\n");
- }
-}
-
-sub _extract_perl_version {
- if (
- $_[0] =~ m/
- ^\s*
- (?:use|require) \s*
- v?
- ([\d_\.]+)
- \s* ;
- /ixms
- ) {
- my $perl_version = $1;
- $perl_version =~ s{_}{}g;
- return $perl_version;
- } else {
- return;
- }
-}
-
-sub perl_version_from {
- my $self = shift;
- my $perl_version=_extract_perl_version(Module::Install::_read($_[0]));
- if ($perl_version) {
- $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;
-
- # XXX: ugly but should work anyway...
- if (eval "require Pod::Escapes; 1") {
- # Pod::Escapes has a mapping table.
- # It's in core of perl >= 5.9.3, and should be installed
- # as one of the Pod::Simple's prereqs, which is a prereq
- # of Pod::Text 3.x (see also below).
- $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> }
- {
- defined $2
- ? chr($2)
- : defined $Pod::Escapes::Name2character_number{$1}
- ? chr($Pod::Escapes::Name2character_number{$1})
- : do {
- warn "Unknown escape: E<$1>";
- "E<$1>";
- };
- }gex;
- }
- elsif (eval "require Pod::Text; 1" && $Pod::Text::VERSION < 3) {
- # Pod::Text < 3.0 has yet another mapping table,
- # though the table name of 2.x and 1.x are different.
- # (1.x is in core of Perl < 5.6, 2.x is in core of
- # Perl < 5.9.3)
- my $mapping = ($Pod::Text::VERSION < 2)
- ? \%Pod::Text::HTML_Escapes
- : \%Pod::Text::ESCAPES;
- $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> }
- {
- defined $2
- ? chr($2)
- : defined $mapping->{$1}
- ? $mapping->{$1}
- : do {
- warn "Unknown escape: E<$1>";
- "E<$1>";
- };
- }gex;
- }
- else {
- $author =~ s{E<lt>}{<}g;
- $author =~ s{E<gt>}{>}g;
- }
- $self->author($author);
- } else {
- warn "Cannot determine author info from $_[0]\n";
- }
-}
-
-#Stolen from M::B
-my %license_urls = (
- perl => 'http://dev.perl.org/licenses/',
- apache => 'http://apache.org/licenses/LICENSE-2.0',
- apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1',
- artistic => 'http://opensource.org/licenses/artistic-license.php',
- artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php',
- lgpl => 'http://opensource.org/licenses/lgpl-license.php',
- lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php',
- lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html',
- bsd => 'http://opensource.org/licenses/bsd-license.php',
- gpl => 'http://opensource.org/licenses/gpl-license.php',
- gpl2 => 'http://opensource.org/licenses/gpl-2.0.php',
- gpl3 => 'http://opensource.org/licenses/gpl-3.0.html',
- mit => 'http://opensource.org/licenses/mit-license.php',
- mozilla => 'http://opensource.org/licenses/mozilla1.1.php',
- open_source => undef,
- unrestricted => undef,
- restrictive => undef,
- unknown => undef,
-);
-
-sub license {
- my $self = shift;
- return $self->{values}->{license} unless @_;
- my $license = shift or die(
- 'Did not provide a value to license()'
- );
- $license = __extract_license($license) || lc $license;
- $self->{values}->{license} = $license;
-
- # Automatically fill in license URLs
- if ( $license_urls{$license} ) {
- $self->resources( license => $license_urls{$license} );
- }
-
- return 1;
-}
-
-sub _extract_license {
- my $pod = shift;
- my $matched;
- return __extract_license(
- ($matched) = $pod =~ m/
- (=head \d \s+ L(?i:ICEN[CS]E|ICENSING)\b.*?)
- (=head \d.*|=cut.*|)\z
- /xms
- ) || __extract_license(
- ($matched) = $pod =~ m/
- (=head \d \s+ (?:C(?i:OPYRIGHTS?)|L(?i:EGAL))\b.*?)
- (=head \d.*|=cut.*|)\z
- /xms
- );
-}
-
-sub __extract_license {
- my $license_text = shift or return;
- my @phrases = (
- '(?:under )?the same (?:terms|license) as (?:perl|the perl (?:\d )?programming language)' => 'perl', 1,
- '(?:under )?the terms of (?:perl|the perl programming language) itself' => 'perl', 1,
- 'Artistic and GPL' => 'perl', 1,
- 'GNU general public license' => 'gpl', 1,
- 'GNU public license' => 'gpl', 1,
- 'GNU lesser general public license' => 'lgpl', 1,
- 'GNU lesser public license' => 'lgpl', 1,
- 'GNU library general public license' => 'lgpl', 1,
- 'GNU library public license' => 'lgpl', 1,
- 'GNU Free Documentation license' => 'unrestricted', 1,
- 'GNU Affero General Public License' => 'open_source', 1,
- '(?:Free)?BSD license' => 'bsd', 1,
- 'Artistic license 2\.0' => 'artistic_2', 1,
- 'Artistic license' => 'artistic', 1,
- 'Apache (?:Software )?license' => 'apache', 1,
- 'GPL' => 'gpl', 1,
- 'LGPL' => 'lgpl', 1,
- 'BSD' => 'bsd', 1,
- 'Artistic' => 'artistic', 1,
- 'MIT' => 'mit', 1,
- 'Mozilla Public License' => 'mozilla', 1,
- 'Q Public License' => 'open_source', 1,
- 'OpenSSL License' => 'unrestricted', 1,
- 'SSLeay License' => 'unrestricted', 1,
- 'zlib License' => 'open_source', 1,
- 'proprietary' => 'proprietary', 0,
- );
- while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) {
- $pattern =~ s#\s+#\\s+#gs;
- if ( $license_text =~ /\b$pattern\b/i ) {
- return $license;
- }
- }
- return '';
-}
-
-sub license_from {
- my $self = shift;
- if (my $license=_extract_license(Module::Install::_read($_[0]))) {
- $self->license($license);
- } else {
- warn "Cannot determine license info from $_[0]\n";
- return 'unknown';
- }
-}
-
-sub _extract_bugtracker {
- my @links = $_[0] =~ m#L<(
- https?\Q://rt.cpan.org/\E[^>]+|
- https?\Q://github.com/\E[\w_]+/[\w_]+/issues|
- https?\Q://code.google.com/p/\E[\w_\-]+/issues/list
- )>#gx;
- my %links;
- @links{@links}=();
- @links=keys %links;
- return @links;
-}
-
-sub bugtracker_from {
- my $self = shift;
- my $content = Module::Install::_read($_[0]);
- my @links = _extract_bugtracker($content);
- unless ( @links ) {
- warn "Cannot determine bugtracker info from $_[0]\n";
- return 0;
- }
- if ( @links > 1 ) {
- warn "Found more than one bugtracker link in $_[0]\n";
- return 0;
- }
-
- # Set the bugtracker
- bugtracker( $links[0] );
- return 1;
-}
-
-sub requires_from {
- my $self = shift;
- my $content = Module::Install::_readperl($_[0]);
- my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+(v?[\d\.]+)/mg;
- while ( @requires ) {
- my $module = shift @requires;
- my $version = shift @requires;
- $self->requires( $module => $version );
- }
-}
-
-sub test_requires_from {
- my $self = shift;
- my $content = Module::Install::_readperl($_[0]);
- my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg;
- while ( @requires ) {
- my $module = shift @requires;
- my $version = shift @requires;
- $self->test_requires( $module => $version );
- }
-}
-
-# Convert triple-part versions (eg, 5.6.1 or 5.8.9) to
-# numbers (eg, 5.006001 or 5.008009).
-# Also, convert double-part versions (eg, 5.8)
-sub _perl_version {
- my $v = $_[-1];
- $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e;
- $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e;
- $v =~ s/(\.\d\d\d)000$/$1/;
- $v =~ s/_.+$//;
- if ( ref($v) ) {
- # Numify
- $v = $v + 0;
- }
- return $v;
-}
-
-sub add_metadata {
- my $self = shift;
- my %hash = @_;
- for my $key (keys %hash) {
- warn "add_metadata: $key is not prefixed with 'x_'.\n" .
- "Use appopriate function to add non-private metadata.\n" unless $key =~ /^x_/;
- $self->{values}->{$key} = $hash{$key};
- }
-}
-
-
-######################################################################
-# MYMETA Support
-
-sub WriteMyMeta {
- die "WriteMyMeta has been deprecated";
-}
-
-sub write_mymeta_yaml {
- my $self = shift;
-
- # We need YAML::Tiny to write the MYMETA.yml file
- unless ( eval { require YAML::Tiny; 1; } ) {
- return 1;
- }
-
- # Generate the data
- my $meta = $self->_write_mymeta_data or return 1;
-
- # Save as the MYMETA.yml file
- print "Writing MYMETA.yml\n";
- YAML::Tiny::DumpFile('MYMETA.yml', $meta);
-}
-
-sub write_mymeta_json {
- my $self = shift;
-
- # We need JSON to write the MYMETA.json file
- unless ( eval { require JSON; 1; } ) {
- return 1;
- }
-
- # Generate the data
- my $meta = $self->_write_mymeta_data or return 1;
-
- # Save as the MYMETA.yml file
- print "Writing MYMETA.json\n";
- Module::Install::_write(
- 'MYMETA.json',
- JSON->new->pretty(1)->canonical->encode($meta),
- );
-}
-
-sub _write_mymeta_data {
- my $self = shift;
-
- # If there's no existing META.yml there is nothing we can do
- return undef unless -f 'META.yml';
-
- # We need Parse::CPAN::Meta to load the file
- unless ( eval { require Parse::CPAN::Meta; 1; } ) {
- return undef;
- }
-
- # Merge the perl version into the dependencies
- my $val = $self->Meta->{values};
- my $perl = delete $val->{perl_version};
- if ( $perl ) {
- $val->{requires} ||= [];
- my $requires = $val->{requires};
-
- # Canonize to three-dot version after Perl 5.6
- if ( $perl >= 5.006 ) {
- $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e
- }
- unshift @$requires, [ perl => $perl ];
- }
-
- # Load the advisory META.yml file
- my @yaml = Parse::CPAN::Meta::LoadFile('META.yml');
- my $meta = $yaml[0];
-
- # Overwrite the non-configure dependency hashs
- delete $meta->{requires};
- delete $meta->{build_requires};
- delete $meta->{recommends};
- if ( exists $val->{requires} ) {
- $meta->{requires} = { map { @$_ } @{ $val->{requires} } };
- }
- if ( exists $val->{build_requires} ) {
- $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } };
- }
-
- return $meta;
-}
-
-1;
@@ -1,273 +0,0 @@
-#line 1
-##
-# name: Module::Install::Package
-# abstract: Module::Install support for Module::Package
-# author: Ingy döt Net <ingy@cpan.org>
-# license: perl
-# copyright: 2011
-# see:
-# - Module::Package
-
-# This module contains the Module::Package logic that must be available to
-# both the Author and the End User. Author-only logic goes in a
-# Module::Package::Plugin subclass.
-package Module::Install::Package;
-use strict;
-use Module::Install::Base;
-use vars qw'@ISA $VERSION';
-@ISA = 'Module::Install::Base';
-$VERSION = '0.25';
-
-#-----------------------------------------------------------------------------#
-# XXX BOOTBUGHACK
-# This is here to try to get us out of Module-Package-0.11 cpantesters hell...
-# Remove this when the situation has blown over.
-sub pkg {
- *inc::Module::Package::VERSION = sub { $VERSION };
- my $self = shift;
- $self->module_package_internals_init($@);
-}
-
-#-----------------------------------------------------------------------------#
-# We allow the author to specify key/value options after the plugin. These
-# options need to be available both at author time and install time.
-#-----------------------------------------------------------------------------#
-# OO accessor for command line options:
-sub package_options {
- @_>1?($_[0]->{package_options}=$_[1]):$_[0]->{package_options}}
-
-my $default_options = {
- deps_list => 1,
- install_bin => 1,
- install_share => 1,
- manifest_skip => 1,
- requires_from => 1,
-};
-
-#-----------------------------------------------------------------------------#
-# Module::Install plugin directives. Use long, ugly names to not pollute the
-# Module::Install plugin namespace. These are only intended to be called from
-# Module::Package.
-#-----------------------------------------------------------------------------#
-
-# Module::Package starts off life as a normal call to this Module::Install
-# plugin directive:
-my $module_install_plugin;
-my $module_package_plugin;
-# XXX ARGVHACK This @argv thing is a temporary fix for an ugly bug somewhere in the
-# Wikitext module usage.
-my @argv;
-sub module_package_internals_init {
- my $self = $module_install_plugin = shift;
- my ($plugin_spec, %options) = @_;
- $self->package_options({%$default_options, %options});
-
- if ($module_install_plugin->is_admin) {
- $module_package_plugin = $self->_load_plugin($plugin_spec);
- $module_package_plugin->mi($module_install_plugin);
- $module_package_plugin->version_check($VERSION);
- }
- # NOTE - This is the point in time where the body of Makefile.PL runs...
- return;
-
- sub INIT {
- return unless $module_install_plugin;
- return if $Module::Package::ERROR;
- eval {
- if ($module_install_plugin->is_admin) {
- $module_package_plugin->initial();
- $module_package_plugin->main();
- }
- else {
- $module_install_plugin->_initial();
- $module_install_plugin->_main();
- }
- };
- if ($@) {
- $Module::Package::ERROR = $@;
- die $@;
- }
- @argv = @ARGV; # XXX ARGVHACK
- }
-
- # If this Module::Install plugin was used (by Module::Package) then wrap
- # up any loose ends. This will get called after Makefile.PL has completed.
- sub END {
- @ARGV = @argv; # XXX ARGVHACK
- return unless $module_install_plugin;
- return if $Module::Package::ERROR;
- $module_package_plugin
- ? do {
- $module_package_plugin->final;
- $module_package_plugin->replicate_module_package;
- }
- : $module_install_plugin->_final;
- }
-}
-
-# Module::Package, Module::Install::Package and Module::Package::Plugin
-# must all have the same version. Seems wise.
-sub module_package_internals_version_check {
- my ($self, $version) = @_;
- return if $version < 0.1800001; # XXX BOOTBUGHACK!!
- die <<"..." unless $version == $VERSION;
-
-Error! Something has gone awry:
- Module::Package version=$version is using
- Module::Install::Package version=$VERSION
-If you are the author of this module, try upgrading Module::Package.
-Otherwise, please notify the author of this error.
-
-...
-}
-
-# Find and load the author side plugin:
-sub _load_plugin {
- my ($self, $spec) = @_;
- $spec ||= '';
- my $version = '';
- $Module::Package::plugin_version = 0;
- if ($spec =~ s/\s+(\S+)\s*//) {
- $version = $1;
- $Module::Package::plugin_version = $version;
- }
- my ($module, $plugin) =
- not($spec) ? ('Plugin', "Plugin::basic") :
- ($spec =~ /^\w(\w|::)*$/) ? ($spec, $spec) :
- ($spec =~ /^:(\w+)$/) ? ('Plugin', "Plugin::$1") :
- ($spec =~ /^(\S*\w):(\w+)$/) ? ($1, "$1::$2") :
- die "$spec is invalid";
- $module = "Module::Package::$module";
- $plugin = "Module::Package::$plugin";
- eval "use $module $version (); 1" or die $@;
- return $plugin->new();
-}
-
-#-----------------------------------------------------------------------------#
-# These are the user side analogs to the author side plugin API calls.
-# Prefix with '_' to not pollute Module::Install plugin space.
-#-----------------------------------------------------------------------------#
-sub _initial {
- my ($self) = @_;
-}
-
-sub _main {
- my ($self) = @_;
-}
-
-# NOTE These must match Module::Package::Plugin::final.
-sub _final {
- my ($self) = @_;
- $self->_all_from;
- $self->_requires_from;
- $self->_install_bin;
- $self->_install_share;
- $self->_WriteAll;
-}
-
-#-----------------------------------------------------------------------------#
-# This section is where all the useful code bits go. These bits are needed by
-# both Author and User side runs.
-#-----------------------------------------------------------------------------#
-
-my $all_from = 0;
-sub _all_from {
- my $self = shift;
- return if $all_from++;
- return if $self->name;
- my $file = shift || "$main::PM" or die "all_from has no file";
- $self->all_from($file);
-}
-
-my $requires_from = 0;
-sub _requires_from {
- my $self = shift;
- return if $requires_from++;
- return unless $self->package_options->{requires_from};
- my $file = shift || "$main::PM" or die "requires_from has no file";
- $self->requires_from($main::PM)
-}
-
-my $install_bin = 0;
-sub _install_bin {
- my $self = shift;
- return if $install_bin++;
- return unless $self->package_options->{install_bin};
- return unless -d 'bin';
- my @bin;
- File::Find::find(sub {
- return unless -f $_;
- push @bin, $File::Find::name;
- }, 'bin');
- $self->install_script($_) for @bin;
-}
-
-my $install_share = 0;
-sub _install_share {
- my $self = shift;
- return if $install_share++;
- return unless $self->package_options->{install_share};
- return unless -d 'share';
- $self->install_share;
-}
-
-my $WriteAll = 0;
-sub _WriteAll {
- my $self = shift;
- return if $WriteAll++;
- $self->WriteAll(@_);
-}
-
-#-----------------------------------------------------------------------------#
-# Take a guess at the primary .pm and .pod files for 'all_from', and friends.
-# Put them in global magical vars in the main:: namespace.
-#-----------------------------------------------------------------------------#
-package Module::Package::PM;
-use overload '""' => sub {
- $_[0]->guess_pm unless @{$_[0]};
- return $_[0]->[0];
-};
-sub set { $_[0]->[0] = $_[1] }
-sub guess_pm {
- my $pm = '';
- my $self = shift;
- if (-e 'META.yml') {
- open META, 'META.yml' or die "Can't open 'META.yml' for input:\n$!";
- my $meta = do { local $/; <META> };
- close META;
- $meta =~ /^module_name: (\S+)$/m
- or die "Can't get module_name from META.yml";
- $pm = $1;
- $pm =~ s!::!/!g;
- $pm = "lib/$pm.pm";
- }
- else {
- require File::Find;
- my @array = ();
- File::Find::find(sub {
- return unless /\.pm$/;
- my $name = $File::Find::name;
- my $num = ($name =~ s!/+!/!g);
- my $ary = $array[$num] ||= [];
- push @$ary, $name;
- }, 'lib');
- shift @array while @array and not defined $array[0];
- die "Can't guess main module" unless @array;
- (($pm) = sort @{$array[0]}) or
- die "Can't guess main module";
- }
- $self->set($pm);
-}
-$main::PM = bless [$main::PM ? ($main::PM) : ()], __PACKAGE__;
-
-package Module::Package::POD;
-use overload '""' => sub {
- return $_[0]->[0] if @{$_[0]};
- (my $pod = "$main::PM") =~ s/\.pm/.pod/ or die;
- return -e $pod ? $pod : '';
-};
-sub set { $_[0][0] = $_[1] }
-$main::POD = bless [$main::POD ? ($main::POD) : ()], __PACKAGE__;
-
-1;
-
@@ -1,64 +0,0 @@
-#line 1
-package Module::Install::Win32;
-
-use strict;
-use Module::Install::Base ();
-
-use vars qw{$VERSION @ISA $ISCORE};
-BEGIN {
- $VERSION = '1.01';
- @ISA = '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;
@@ -1,63 +0,0 @@
-#line 1
-package Module::Install::WriteAll;
-
-use strict;
-use Module::Install::Base ();
-
-use vars qw{$VERSION @ISA $ISCORE};
-BEGIN {
- $VERSION = '1.01';
- @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->admin->WriteAll(%args) if $self->is_admin;
-
- $self->check_nmake if $args{check_nmake};
- unless ( $self->makemaker_args->{PL_FILES} ) {
- # XXX: This still may be a bit over-defensive...
- unless ($self->makemaker(6.25)) {
- $self->makemaker_args( PL_FILES => {} ) if -f 'Build.PL';
- }
- }
-
- # Until ExtUtils::MakeMaker support MYMETA.yml, make sure
- # we clean it up properly ourself.
- $self->realclean_files('MYMETA.yml');
-
- if ( $args{inline} ) {
- $self->Inline->write;
- } else {
- $self->Makefile->write;
- }
-
- # The Makefile write process adds a couple of dependencies,
- # so write the META.yml files after the Makefile.
- if ( $args{meta} ) {
- $self->Meta->write;
- }
-
- # Experimental support for MYMETA
- if ( $ENV{X_MYMETA} ) {
- if ( $ENV{X_MYMETA} eq 'JSON' ) {
- $self->Meta->write_mymeta_json;
- } else {
- $self->Meta->write_mymeta_yaml;
- }
- }
-
- return 1;
-}
-
-1;
@@ -1,470 +0,0 @@
-#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
-# }
-
-use 5.005;
-use strict 'vars';
-use Cwd ();
-use File::Find ();
-use File::Path ();
-
-use vars qw{$VERSION $MAIN};
-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 = '1.01';
-
- # Storage for the pseudo-singleton
- $MAIN = undef;
-
- *inc::Module::Install::VERSION = *VERSION;
- @inc::Module::Install::ISA = __PACKAGE__;
-
-}
-
-sub import {
- my $class = shift;
- my $self = $class->new(@_);
- my $who = $self->_caller;
-
- #-------------------------------------------------------------
- # all of the following checks should be included in import(),
- # to allow "eval 'require Module::Install; 1' to test
- # installation of Module::Install. (RT #51267)
- #-------------------------------------------------------------
-
- # 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
-
- # This reportedly fixes a rare Win32 UTC file time issue, but
- # as this is a non-cross-platform XS module not in the core,
- # we shouldn't really depend on it. See RT #24194 for detail.
- # (Also, this module only supports Perl 5.6 and above).
- eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006;
-
- # 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 ) {
- my $s = (stat($0))[9];
-
- # If the modification time is only slightly in the future,
- # sleep briefly to remove the problem.
- my $a = $s - time;
- if ( $a > 0 and $a < 5 ) { sleep 5 }
-
- # Too far in the future, throw an error.
- my $t = time;
- if ( $s > $t ) { die <<"END_DIE" }
-
-Your installer $0 has a modification time in the future ($s > $t).
-
-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 ) { 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
-
- #-------------------------------------------------------------
-
- # To save some more typing in Module::Install installers, every...
- # use inc::Module::Install
- # ...also acts as an implicit use strict.
- $^H |= strict::bits(qw(refs subs vars));
-
- #-------------------------------------------------------------
-
- unless ( -f $self->{file} ) {
- foreach my $key (keys %INC) {
- delete $INC{$key} if $key =~ /Module\/Install/;
- }
-
- local $^W;
- 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"};
- }
-
- local $^W;
- *{"${who}::AUTOLOAD"} = $self->autoload;
- $self->preload;
-
- # Unregister loader and worker packages so subdirs can use them again
- delete $INC{'inc/Module/Install.pm'};
- delete $INC{'Module/Install.pm'};
-
- # Save to the singleton
- $MAIN = $self;
-
- return 1;
-}
-
-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;
- }
- unless ($$sym =~ s/([^:]+)$//) {
- # XXX: it looks like we can't retrieve the missing function
- # via $$sym (usually $main::AUTOLOAD) in this case.
- # I'm still wondering if we should slurp Makefile.PL to
- # get some context or not ...
- my ($package, $file, $line) = caller;
- die <<"EOT";
-Unknown function is found at $file line $line.
-Execution of $file aborted due to runtime errors.
-
-If you're a contributor to a project, you may need to install
-some Module::Install extensions from CPAN (or other repository).
-If you're a user of a module, please contact the author.
-EOT
- }
- my $method = $1;
- if ( uc($method) eq $method ) {
- # Do nothing
- return;
- } elsif ( $method =~ /^_/ and $self->can($method) ) {
- # Dispatch to the root M:I class
- return $self->$method(@_);
- }
-
- # Dispatch to the appropriate plugin
- unshift @_, ( $self, $1 );
- goto &{$self->can('call')};
- };
-}
-
-sub preload {
- my $self = shift;
- unless ( $self->{extensions} ) {
- $self->load_extensions(
- "$self->{prefix}/$self->{path}", $self
- );
- }
-
- my @exts = @{$self->{extensions}};
- unless ( @exts ) {
- @exts = $self->{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 ) {
- local $^W;
- *{"${who}::$name"} = sub {
- ${"${who}::AUTOLOAD"} = "${who}::$name";
- goto &{"${who}::AUTOLOAD"};
- };
- }
-}
-
-sub new {
- my ($class, %args) = @_;
-
- delete $INC{'FindBin.pm'};
- {
- # to suppress the redefine warning
- local $SIG{__WARN__} = sub {};
- require FindBin;
- }
-
- # 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) = @_;
-
- my $should_reload = 0;
- unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) {
- unshift @INC, $self->{prefix};
- $should_reload = 1;
- }
-
- foreach my $rv ( $self->find_extensions($path) ) {
- my ($file, $pkg) = @{$rv};
- next if $self->{pathnames}{$pkg};
-
- local $@;
- my $new = eval { local $^W; require $file; $pkg->can('new') };
- unless ( $new ) {
- warn $@ if $@;
- next;
- }
- $self->{pathnames}{$pkg} =
- $should_reload ? delete $INC{$file} : $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;
-}
-
-
-
-
-
-#####################################################################
-# Common Utility Functions
-
-sub _caller {
- my $depth = 0;
- my $call = caller($depth);
- while ( $call eq __PACKAGE__ ) {
- $depth++;
- $call = caller($depth);
- }
- return $call;
-}
-
-# Done in evals to avoid confusing Perl::MinimumVersion
-eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@;
-sub _read {
- local *FH;
- open( FH, '<', $_[0] ) or die "open($_[0]): $!";
- my $string = do { local $/; <FH> };
- close FH or die "close($_[0]): $!";
- return $string;
-}
-END_NEW
-sub _read {
- local *FH;
- open( FH, "< $_[0]" ) or die "open($_[0]): $!";
- my $string = do { local $/; <FH> };
- close FH or die "close($_[0]): $!";
- return $string;
-}
-END_OLD
-
-sub _readperl {
- my $string = Module::Install::_read($_[0]);
- $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg;
- $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s;
- $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg;
- return $string;
-}
-
-sub _readpod {
- my $string = Module::Install::_read($_[0]);
- $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg;
- return $string if $_[0] =~ /\.pod\z/;
- $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg;
- $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg;
- $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg;
- $string =~ s/^\n+//s;
- return $string;
-}
-
-# Done in evals to avoid confusing Perl::MinimumVersion
-eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@;
-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]): $!";
-}
-END_NEW
-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]): $!";
-}
-END_OLD
-
-# _version is for processing module versions (eg, 1.03_05) not
-# Perl versions (eg, 5.8.1).
-sub _version ($) {
- my $s = shift || 0;
- my $d =()= $s =~ /(\.)/g;
- if ( $d >= 2 ) {
- # Normalise multipart versions
- $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg;
- }
- $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;
-}
-
-sub _cmp ($$) {
- _version($_[0]) <=> _version($_[1]);
-}
-
-# Cloned from Params::Util::_CLASS
-sub _CLASS ($) {
- (
- defined $_[0]
- and
- ! ref $_[0]
- and
- $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s
- ) ? $_[0] : undef;
-}
-
-1;
-
-# Copyright 2008 - 2011 Adam Kennedy.
@@ -1,71 +0,0 @@
-#line 1
-##
-# name: Module::Package
-# abstract: Postmodern Perl Module Packaging
-# author: Ingy döt Net <ingy@cpan.org>
-# license: perl
-# copyright: 2011
-# see:
-# - Module::Package::Plugin
-# - Module::Install::Package
-# - Module::Package::Tutorial
-
-package Module::Package;
-use 5.005;
-use strict;
-
-BEGIN {
- $Module::Package::VERSION = '0.25';
- $inc::Module::Package::VERSION ||= $Module::Package::VERSION;
- @inc::Module::Package::ISA = __PACKAGE__;
-}
-
-sub import {
- my $class = shift;
- $INC{'inc/Module/Install.pm'} = __FILE__;
- unshift @INC, 'inc' unless $INC[0] eq 'inc';
- eval "use Module::Install 1.01 (); 1" or $class->error($@);
-
- package main;
- Module::Install->import();
- eval {
- module_package_internals_version_check($Module::Package::VERSION);
- module_package_internals_init(@_);
- };
- if ($@) {
- $Module::Package::ERROR = $@;
- die $@;
- }
-}
-
-# XXX Remove this when things are stable.
-sub error {
- my ($class, $error) = @_;
- if (-e 'inc' and not -e 'inc/.author') {
- require Data::Dumper;
- $Data::Dumper::Sortkeys = 1;
- my $dump1 = Data::Dumper::Dumper(\%INC);
- my $dump2 = Data::Dumper::Dumper(\@INC);
- die <<"...";
-This should not have happened. Hopefully this dump will explain the problem:
-
-inc::Module::Package: $inc::Module::Package::VERSION
-Module::Package: $Module::Package::VERSION
-inc::Module::Install: $inc::Module::Install::VERSION
-Module::Install: $Module::Install::VERSION
-
-Error: $error
-
-%INC:
-$dump1
-\@INC:
-$dump2
-...
- }
- else {
- die $error;
- }
-}
-
-1;
-
@@ -1,17 +1,15 @@
-#line 1
+use strict; use warnings;
package Spiffy;
-use strict;
-use 5.006001;
-use warnings;
+our $VERSION = '0.40';
+
use Carp;
require Exporter;
-our $VERSION = '0.30';
our @EXPORT = ();
our @EXPORT_BASE = qw(field const stub super);
our @EXPORT_OK = (@EXPORT_BASE, qw(id WWW XXX YYY ZZZ));
our %EXPORT_TAGS = (XXX => [qw(WWW XXX YYY ZZZ)]);
-my $stack_frame = 0;
+my $stack_frame = 0;
my $dump = 'yaml';
my $bases_map = {};
@@ -38,7 +36,7 @@ sub new {
my $method = shift;
$self->$method(shift);
}
- return $self;
+ return $self;
}
my $filtered_files = {};
@@ -46,7 +44,7 @@ my $filter_dump = 0;
my $filter_save = 0;
our $filter_result = '';
sub import {
- no strict 'refs';
+ no strict 'refs';
no warnings;
my $self_package = shift;
@@ -54,12 +52,12 @@ sub import {
# subclass's boolean_arguments and paired_arguments can conflict, causing
# difficult debugging. Consider using something truly local.
my ($args, @export_list) = do {
- local *boolean_arguments = sub {
+ local *boolean_arguments = sub {
qw(
- -base -Base -mixin -selfless
- -XXX -dumper -yaml
+ -base -Base -mixin -selfless
+ -XXX -dumper -yaml
-filter_dump -filter_save
- )
+ )
};
local *paired_arguments = sub { qw(-package) };
$self_package->parse_arguments(@_);
@@ -79,8 +77,8 @@ sub import {
unless grep /^XXX$/, @EXPORT_BASE;
}
- spiffy_filter()
- if ($args->{-selfless} or $args->{-Base}) and
+ spiffy_filter()
+ if ($args->{-selfless} or $args->{-Base}) and
not $filtered_files->{(caller($stack_frame))[1]}++;
my $caller_package = $args->{-package} || caller($stack_frame);
@@ -91,7 +89,7 @@ sub import {
next unless $class->isa('Spiffy');
my @export = grep {
not defined &{"$caller_package\::$_"};
- } ( @{"$class\::EXPORT"},
+ } ( @{"$class\::EXPORT"},
($args->{-Base} or $args->{-base})
? @{"$class\::EXPORT_BASE"} : (),
);
@@ -99,7 +97,7 @@ sub import {
not defined &{"$caller_package\::$_"};
} @{"$class\::EXPORT_OK"};
- # Avoid calling the expensive Exporter::export
+ # Avoid calling the expensive Exporter::export
# if there is nothing to do (optimization)
my %exportable = map { ($_, 1) } @export, @export_ok;
next unless keys %exportable;
@@ -163,7 +161,7 @@ sub base {
sub all_my_bases {
my $class = shift;
- return $bases_map->{$class}
+ return $bases_map->{$class}
if defined $bases_map->{$class};
my @bases = ($class);
@@ -175,10 +173,10 @@ sub all_my_bases {
$bases_map->{$class} = [grep {not $used->{$_}++} @bases];
}
-my %code = (
- sub_start =>
+my %code = (
+ sub_start =>
"sub {\n",
- set_default =>
+ set_default =>
" \$_[0]->{%s} = %s\n unless exists \$_[0]->{%s};\n",
init =>
" return \$_[0]->{%s} = do { my \$self = \$_[0]; %s }\n" .
@@ -189,13 +187,13 @@ my %code = (
" Scalar::Util::weaken(\$_[0]->{%s}) if ref \$_[0]->{%s};\n" .
" \$_[0]->{%s};\n" .
" } unless \$#_ > 0 or defined \$_[0]->{%s};\n",
- return_if_get =>
+ return_if_get =>
" return \$_[0]->{%s} unless \$#_ > 0;\n",
- set =>
+ set =>
" \$_[0]->{%s} = \$_[1];\n",
- weaken =>
+ weaken =>
" Scalar::Util::weaken(\$_[0]->{%s}) if ref \$_[0]->{%s};\n",
- sub_end =>
+ sub_end =>
" return \$_[0]->{%s};\n}\n",
);
@@ -223,13 +221,14 @@ sub field {
my $code = $code{sub_start};
if ($args->{-init}) {
my $fragment = $args->{-weak} ? $code{weak_init} : $code{init};
- $code .= sprintf $fragment, $field, $args->{-init}, ($field) x 4;
+ my @count = ($fragment =~ /(%s)/g);
+ $code .= sprintf $fragment, $field, $args->{-init}, ($field) x (@count - 2);
}
$code .= sprintf $code{set_default}, $field, $default_string, $field
if defined $default;
$code .= sprintf $code{return_if_get}, $field;
$code .= sprintf $code{set}, $field;
- $code .= sprintf $code{weaken}, $field, $field
+ $code .= sprintf $code{weaken}, $field, $field
if $args->{-weak};
$code .= sprintf $code{sub_end}, $field;
@@ -274,10 +273,10 @@ sub stub {
$package = $args->{-package} if defined $args->{-package};
no strict 'refs';
return if defined &{"${package}::$field"};
- *{"${package}::$field"} =
- sub {
+ *{"${package}::$field"} =
+ sub {
require Carp;
- Carp::confess
+ Carp::confess
"Method $field in package $package must be subclassed";
}
}
@@ -301,7 +300,7 @@ sub parse_arguments {
push @values, $elem;
}
}
- return wantarray ? ($args, @values) : $args;
+ return wantarray ? ($args, @values) : $args;
}
sub boolean_arguments { () }
@@ -325,8 +324,8 @@ sub id {
package DB;
{
no warnings 'redefine';
- sub super_args {
- my @dummy = caller(@_ ? $_[0] : 2);
+ sub super_args {
+ my @dummy = caller(@_ ? $_[0] : 2);
return @DB::args;
}
}
@@ -397,7 +396,7 @@ sub spiffy_base_import {
my $inheritor = caller(0);
for my $base_class (@base_classes) {
next if $inheritor->isa($base_class);
- croak "Can't mix Spiffy and non-Spiffy classes in 'use base'.\n",
+ croak "Can't mix Spiffy and non-Spiffy classes in 'use base'.\n",
"See the documentation of Spiffy.pm for details\n "
unless $base_class->isa('Spiffy');
$stack_frame = 1; # tell import to use different caller
@@ -439,7 +438,7 @@ sub spiffy_mixin_methods {
$methods{$_}
? ($_, \ &{"$methods{$_}\::$_"})
: ($_, \ &{"$mixin_class\::$_"})
- } @_
+ } @_
? (get_roles($mixin_class, @_))
: (keys %methods);
}
@@ -450,12 +449,12 @@ sub get_roles {
while (grep /^!*:/, @roles) {
@roles = map {
s/!!//g;
- /^!:(.*)/ ? do {
- my $m = "_role_$1";
+ /^!:(.*)/ ? do {
+ my $m = "_role_$1";
map("!$_", $mixin_class->$m);
} :
/^:(.*)/ ? do {
- my $m = "_role_$1";
+ my $m = "_role_$1";
($mixin_class->$m);
} :
($_)
@@ -533,7 +532,3 @@ sub ZZZ {
}
1;
-
-__END__
-
-#line 1066
@@ -1,4 +1,3 @@
-#line 1
#===============================================================================
# This is the default class for handling Test::Base data filtering.
#===============================================================================
@@ -336,6 +335,4 @@ sub _write_to {
or die "Couldn't close $filename: $!\n";
}
-__DATA__
-
-#line 636
+1;
@@ -1,9 +1,21 @@
-#line 1
package Test::Base;
-use 5.006001;
-use Spiffy 0.30 -Base;
+our $VERSION = '0.88';
+
+use Spiffy -Base;
use Spiffy ':XXX';
-our $VERSION = '0.60';
+
+my $HAS_PROVIDER;
+BEGIN {
+ $HAS_PROVIDER = eval "require Test::Builder::Provider; 1";
+
+ if ($HAS_PROVIDER) {
+ Test::Builder::Provider->import('provides');
+ }
+ else {
+ *provides = sub { 1 };
+ }
+}
+
my @test_more_exports;
BEGIN {
@@ -24,9 +36,9 @@ our @EXPORT = (@test_more_exports, qw(
is no_diff
blocks next_block first_block
- delimiters spec_file spec_string
+ delimiters spec_file spec_string
filters filters_delay filter_arguments
- run run_compare run_is run_is_deeply run_like run_unlike
+ run run_compare run_is run_is_deeply run_like run_unlike
skip_all_unless_require is_deep run_is_deep
WWW XXX YYY ZZZ
tie_output no_diag_on_only
@@ -59,7 +71,7 @@ my $default_class;
my $default_object;
my $reserved_section_names = {};
-sub default_object {
+sub default_object {
$default_object ||= $default_class->new;
return $default_object;
}
@@ -67,7 +79,7 @@ sub default_object {
my $import_called = 0;
sub import() {
$import_called = 1;
- my $class = (grep /^-base$/i, @_)
+ my $class = (grep /^-base$/i, @_)
? scalar(caller)
: $_[0];
if (not defined $default_class) {
@@ -90,7 +102,7 @@ sub import() {
Test::More->import(import => \@test_more_exports, @args)
if @args;
}
-
+
_strict_warnings();
goto &Spiffy::import;
}
@@ -147,14 +159,14 @@ sub blocks() {
if @_ && $_[0] !~ /^[a-zA-Z]\w*$/;
my $blocks = $self->block_list;
-
+
my $section_name = shift || '';
my @blocks = $section_name
? (grep { exists $_->{$section_name} } @$blocks)
: (@$blocks);
return scalar(@blocks) unless wantarray;
-
+
return (@blocks) if $self->_filters_delay;
for my $block (@blocks) {
@@ -225,7 +237,7 @@ sub filters() {
if (ref($_[0]) eq 'HASH') {
$self->_filters_map(shift);
}
- else {
+ else {
my $filters = $self->_filters;
push @$filters, @_;
}
@@ -242,23 +254,24 @@ sub have_text_diff {
$Algorithm::Diff::VERSION >= 1.15;
}
+provides 'is';
sub is($$;$) {
(my ($self), @_) = find_my_self(@_);
my ($actual, $expected, $name) = @_;
- local $Test::Builder::Level = $Test::Builder::Level + 1;
+ local $Test::Builder::Level = $Test::Builder::Level + 1 unless $HAS_PROVIDER;
if ($ENV{TEST_SHOW_NO_DIFFS} or
not defined $actual or
not defined $expected or
- $actual eq $expected or
- not($self->have_text_diff) or
+ $actual eq $expected or
+ not($self->have_text_diff) or
$expected !~ /\n./s
) {
Test::More::is($actual, $expected, $name);
}
else {
$name = '' unless defined $name;
- ok $actual eq $expected,
- $name . "\n" . Text::Diff::diff(\$expected, \$actual);
+ ok $actual eq $expected, $name;
+ diag Text::Diff::diff(\$expected, \$actual);
}
}
@@ -322,7 +335,7 @@ sub run_is() {
for my $block (@{$self->block_list}) {
next unless exists($block->{$x}) and exists($block->{$y});
$block->run_filters unless $block->is_filtered;
- is($block->$x, $block->$y,
+ is($block->$x, $block->$y,
$block->name ? $block->name : ()
);
}
@@ -335,7 +348,7 @@ sub run_is_deeply() {
for my $block (@{$self->block_list}) {
next unless exists($block->{$x}) and exists($block->{$y});
$block->run_filters unless $block->is_filtered;
- is_deeply($block->$x, $block->$y,
+ is_deeply($block->$x, $block->$y,
$block->name ? $block->name : ()
);
}
@@ -391,7 +404,7 @@ sub run_is_deep() {
for my $block (@{$self->block_list}) {
next unless exists($block->{$x}) and exists($block->{$y});
$block->run_filters unless $block->is_filtered;
- is_deep($block->$x, $block->$y,
+ is_deep($block->$x, $block->$y,
$block->name ? $block->name : ()
);
}
@@ -462,7 +475,7 @@ sub _make_block {
}
$description =~ s/\s*\z//;
$block->set_value(description => $description);
-
+
my $section_map = {};
my $section_order = [];
while (@parts) {
@@ -499,9 +512,9 @@ sub _spec_init {
$spec = <FILE>;
close FILE;
}
- else {
- $spec = do {
- package main;
+ else {
+ $spec = do {
+ package main;
no warnings 'once';
<DATA>;
};
@@ -617,7 +630,7 @@ sub run_filters {
join '', @value;
my $old = $_;
@value = &$function(@value);
- if (not(@value) or
+ if (not(@value) or
@value == 1 and defined($value[0]) and $value[0] =~ /\A(\d+|)\z/
) {
if ($value[0] && $_ eq $old) {
@@ -650,7 +663,7 @@ sub _get_filters {
$map_filters = [ $map_filters ] unless ref $map_filters;
my @append = ();
for (
- @{$self->blocks_object->_filters},
+ @{$self->blocks_object->_filters},
@$map_filters,
split(/\s+/, $string),
) {
@@ -675,8 +688,4 @@ sub _get_filters {
} keys(%Test::Base::Block::), qw( new DESTROY );
}
-__DATA__
-
-=encoding utf8
-
-#line 1374
+1;
@@ -1,73 +0,0 @@
-#line 1
-package Test::Builder::Module;
-
-use strict;
-
-use Test::Builder;
-
-require Exporter;
-our @ISA = qw(Exporter);
-
-our $VERSION = '0.98';
-$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
-
-
-#line 74
-
-sub import {
- my($class) = shift;
-
- # Don't run all this when loading ourself.
- return 1 if $class eq 'Test::Builder::Module';
-
- my $test = $class->builder;
-
- my $caller = caller;
-
- $test->exported_to($caller);
-
- $class->import_extra( \@_ );
- my(@imports) = $class->_strip_imports( \@_ );
-
- $test->plan(@_);
-
- $class->export_to_level( 1, $class, @imports );
-}
-
-sub _strip_imports {
- my $class = shift;
- my $list = shift;
-
- my @imports = ();
- my @other = ();
- my $idx = 0;
- while( $idx <= $#{$list} ) {
- my $item = $list->[$idx];
-
- if( defined $item and $item eq 'import' ) {
- push @imports, @{ $list->[ $idx + 1 ] };
- $idx++;
- }
- else {
- push @other, $item;
- }
-
- $idx++;
- }
-
- @$list = @other;
-
- return @imports;
-}
-
-#line 137
-
-sub import_extra { }
-
-#line 167
-
-sub builder {
- return Test::Builder->new;
-}
-
-1;
@@ -1,1633 +0,0 @@
-#line 1
-package Test::Builder;
-
-use 5.006;
-use strict;
-use warnings;
-
-our $VERSION = '0.98';
-$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
-
-BEGIN {
- if( $] < 5.008 ) {
- require Test::Builder::IO::Scalar;
- }
-}
-
-
-# Make Test::Builder thread-safe for ithreads.
-BEGIN {
- use Config;
- # Load threads::shared when threads are turned on.
- # 5.8.0's threads are so busted we no longer support them.
- if( $] >= 5.008001 && $Config{useithreads} && $INC{'threads.pm'} ) {
- require threads::shared;
-
- # Hack around YET ANOTHER threads::shared bug. It would
- # occasionally forget the contents of the variable when sharing it.
- # So we first copy the data, then share, then put our copy back.
- *share = sub (\[$@%]) {
- my $type = ref $_[0];
- my $data;
-
- if( $type eq 'HASH' ) {
- %$data = %{ $_[0] };
- }
- elsif( $type eq 'ARRAY' ) {
- @$data = @{ $_[0] };
- }
- elsif( $type eq 'SCALAR' ) {
- $$data = ${ $_[0] };
- }
- else {
- die( "Unknown type: " . $type );
- }
-
- $_[0] = &threads::shared::share( $_[0] );
-
- if( $type eq 'HASH' ) {
- %{ $_[0] } = %$data;
- }
- elsif( $type eq 'ARRAY' ) {
- @{ $_[0] } = @$data;
- }
- elsif( $type eq 'SCALAR' ) {
- ${ $_[0] } = $$data;
- }
- else {
- die( "Unknown type: " . $type );
- }
-
- return $_[0];
- };
- }
- # 5.8.0's threads::shared is busted when threads are off
- # and earlier Perls just don't have that module at all.
- else {
- *share = sub { return $_[0] };
- *lock = sub { 0 };
- }
-}
-
-#line 117
-
-our $Test = Test::Builder->new;
-
-sub new {
- my($class) = shift;
- $Test ||= $class->create;
- return $Test;
-}
-
-#line 139
-
-sub create {
- my $class = shift;
-
- my $self = bless {}, $class;
- $self->reset;
-
- return $self;
-}
-
-#line 168
-
-sub child {
- my( $self, $name ) = @_;
-
- if( $self->{Child_Name} ) {
- $self->croak("You already have a child named ($self->{Child_Name}) running");
- }
-
- my $parent_in_todo = $self->in_todo;
-
- # Clear $TODO for the child.
- my $orig_TODO = $self->find_TODO(undef, 1, undef);
-
- my $child = bless {}, ref $self;
- $child->reset;
-
- # Add to our indentation
- $child->_indent( $self->_indent . ' ' );
-
- $child->{$_} = $self->{$_} foreach qw{Out_FH Todo_FH Fail_FH};
- if ($parent_in_todo) {
- $child->{Fail_FH} = $self->{Todo_FH};
- }
-
- # This will be reset in finalize. We do this here lest one child failure
- # cause all children to fail.
- $child->{Child_Error} = $?;
- $? = 0;
- $child->{Parent} = $self;
- $child->{Parent_TODO} = $orig_TODO;
- $child->{Name} = $name || "Child of " . $self->name;
- $self->{Child_Name} = $child->name;
- return $child;
-}
-
-
-#line 211
-
-sub subtest {
- my $self = shift;
- my($name, $subtests) = @_;
-
- if ('CODE' ne ref $subtests) {
- $self->croak("subtest()'s second argument must be a code ref");
- }
-
- # Turn the child into the parent so anyone who has stored a copy of
- # the Test::Builder singleton will get the child.
- my($error, $child, %parent);
- {
- # child() calls reset() which sets $Level to 1, so we localize
- # $Level first to limit the scope of the reset to the subtest.
- local $Test::Builder::Level = $Test::Builder::Level + 1;
-
- $child = $self->child($name);
- %parent = %$self;
- %$self = %$child;
-
- my $run_the_subtests = sub {
- $subtests->();
- $self->done_testing unless $self->_plan_handled;
- 1;
- };
-
- if( !eval { $run_the_subtests->() } ) {
- $error = $@;
- }
- }
-
- # Restore the parent and the copied child.
- %$child = %$self;
- %$self = %parent;
-
- # Restore the parent's $TODO
- $self->find_TODO(undef, 1, $child->{Parent_TODO});
-
- # Die *after* we restore the parent.
- die $error if $error and !eval { $error->isa('Test::Builder::Exception') };
-
- local $Test::Builder::Level = $Test::Builder::Level + 1;
- return $child->finalize;
-}
-
-#line 281
-
-sub _plan_handled {
- my $self = shift;
- return $self->{Have_Plan} || $self->{No_Plan} || $self->{Skip_All};
-}
-
-
-#line 306
-
-sub finalize {
- my $self = shift;
-
- return unless $self->parent;
- if( $self->{Child_Name} ) {
- $self->croak("Can't call finalize() with child ($self->{Child_Name}) active");
- }
-
- local $? = 0; # don't fail if $subtests happened to set $? nonzero
- $self->_ending;
-
- # XXX This will only be necessary for TAP envelopes (we think)
- #$self->_print( $self->is_passing ? "PASS\n" : "FAIL\n" );
-
- local $Test::Builder::Level = $Test::Builder::Level + 1;
- my $ok = 1;
- $self->parent->{Child_Name} = undef;
- if ( $self->{Skip_All} ) {
- $self->parent->skip($self->{Skip_All});
- }
- elsif ( not @{ $self->{Test_Results} } ) {
- $self->parent->ok( 0, sprintf q[No tests run for subtest "%s"], $self->name );
- }
- else {
- $self->parent->ok( $self->is_passing, $self->name );
- }
- $? = $self->{Child_Error};
- delete $self->{Parent};
-
- return $self->is_passing;
-}
-
-sub _indent {
- my $self = shift;
-
- if( @_ ) {
- $self->{Indent} = shift;
- }
-
- return $self->{Indent};
-}
-
-#line 359
-
-sub parent { shift->{Parent} }
-
-#line 371
-
-sub name { shift->{Name} }
-
-sub DESTROY {
- my $self = shift;
- if ( $self->parent and $$ == $self->{Original_Pid} ) {
- my $name = $self->name;
- $self->diag(<<"FAIL");
-Child ($name) exited without calling finalize()
-FAIL
- $self->parent->{In_Destroy} = 1;
- $self->parent->ok(0, $name);
- }
-}
-
-#line 395
-
-our $Level;
-
-sub reset { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
- my($self) = @_;
-
- # We leave this a global because it has to be localized and localizing
- # hash keys is just asking for pain. Also, it was documented.
- $Level = 1;
-
- $self->{Name} = $0;
- $self->is_passing(1);
- $self->{Ending} = 0;
- $self->{Have_Plan} = 0;
- $self->{No_Plan} = 0;
- $self->{Have_Output_Plan} = 0;
- $self->{Done_Testing} = 0;
-
- $self->{Original_Pid} = $$;
- $self->{Child_Name} = undef;
- $self->{Indent} ||= '';
-
- share( $self->{Curr_Test} );
- $self->{Curr_Test} = 0;
- $self->{Test_Results} = &share( [] );
-
- $self->{Exported_To} = undef;
- $self->{Expected_Tests} = 0;
-
- $self->{Skip_All} = 0;
-
- $self->{Use_Nums} = 1;
-
- $self->{No_Header} = 0;
- $self->{No_Ending} = 0;
-
- $self->{Todo} = undef;
- $self->{Todo_Stack} = [];
- $self->{Start_Todo} = 0;
- $self->{Opened_Testhandles} = 0;
-
- $self->_dup_stdhandles;
-
- return;
-}
-
-#line 474
-
-my %plan_cmds = (
- no_plan => \&no_plan,
- skip_all => \&skip_all,
- tests => \&_plan_tests,
-);
-
-sub plan {
- my( $self, $cmd, $arg ) = @_;
-
- return unless $cmd;
-
- local $Level = $Level + 1;
-
- $self->croak("You tried to plan twice") if $self->{Have_Plan};
-
- if( my $method = $plan_cmds{$cmd} ) {
- local $Level = $Level + 1;
- $self->$method($arg);
- }
- else {
- my @args = grep { defined } ( $cmd, $arg );
- $self->croak("plan() doesn't understand @args");
- }
-
- return 1;
-}
-
-
-sub _plan_tests {
- my($self, $arg) = @_;
-
- if($arg) {
- local $Level = $Level + 1;
- return $self->expected_tests($arg);
- }
- elsif( !defined $arg ) {
- $self->croak("Got an undefined number of tests");
- }
- else {
- $self->croak("You said to run 0 tests");
- }
-
- return;
-}
-
-#line 529
-
-sub expected_tests {
- my $self = shift;
- my($max) = @_;
-
- if(@_) {
- $self->croak("Number of tests must be a positive integer. You gave it '$max'")
- unless $max =~ /^\+?\d+$/;
-
- $self->{Expected_Tests} = $max;
- $self->{Have_Plan} = 1;
-
- $self->_output_plan($max) unless $self->no_header;
- }
- return $self->{Expected_Tests};
-}
-
-#line 553
-
-sub no_plan {
- my($self, $arg) = @_;
-
- $self->carp("no_plan takes no arguments") if $arg;
-
- $self->{No_Plan} = 1;
- $self->{Have_Plan} = 1;
-
- return 1;
-}
-
-#line 586
-
-sub _output_plan {
- my($self, $max, $directive, $reason) = @_;
-
- $self->carp("The plan was already output") if $self->{Have_Output_Plan};
-
- my $plan = "1..$max";
- $plan .= " # $directive" if defined $directive;
- $plan .= " $reason" if defined $reason;
-
- $self->_print("$plan\n");
-
- $self->{Have_Output_Plan} = 1;
-
- return;
-}
-
-
-#line 638
-
-sub done_testing {
- my($self, $num_tests) = @_;
-
- # If done_testing() specified the number of tests, shut off no_plan.
- if( defined $num_tests ) {
- $self->{No_Plan} = 0;
- }
- else {
- $num_tests = $self->current_test;
- }
-
- if( $self->{Done_Testing} ) {
- my($file, $line) = @{$self->{Done_Testing}}[1,2];
- $self->ok(0, "done_testing() was already called at $file line $line");
- return;
- }
-
- $self->{Done_Testing} = [caller];
-
- if( $self->expected_tests && $num_tests != $self->expected_tests ) {
- $self->ok(0, "planned to run @{[ $self->expected_tests ]} ".
- "but done_testing() expects $num_tests");
- }
- else {
- $self->{Expected_Tests} = $num_tests;
- }
-
- $self->_output_plan($num_tests) unless $self->{Have_Output_Plan};
-
- $self->{Have_Plan} = 1;
-
- # The wrong number of tests were run
- $self->is_passing(0) if $self->{Expected_Tests} != $self->{Curr_Test};
-
- # No tests were run
- $self->is_passing(0) if $self->{Curr_Test} == 0;
-
- return 1;
-}
-
-
-#line 689
-
-sub has_plan {
- my $self = shift;
-
- return( $self->{Expected_Tests} ) if $self->{Expected_Tests};
- return('no_plan') if $self->{No_Plan};
- return(undef);
-}
-
-#line 706
-
-sub skip_all {
- my( $self, $reason ) = @_;
-
- $self->{Skip_All} = $self->parent ? $reason : 1;
-
- $self->_output_plan(0, "SKIP", $reason) unless $self->no_header;
- if ( $self->parent ) {
- die bless {} => 'Test::Builder::Exception';
- }
- exit(0);
-}
-
-#line 731
-
-sub exported_to {
- my( $self, $pack ) = @_;
-
- if( defined $pack ) {
- $self->{Exported_To} = $pack;
- }
- return $self->{Exported_To};
-}
-
-#line 761
-
-sub ok {
- my( $self, $test, $name ) = @_;
-
- if ( $self->{Child_Name} and not $self->{In_Destroy} ) {
- $name = 'unnamed test' unless defined $name;
- $self->is_passing(0);
- $self->croak("Cannot run test ($name) with active children");
- }
- # $test might contain an object which we don't want to accidentally
- # store, so we turn it into a boolean.
- $test = $test ? 1 : 0;
-
- lock $self->{Curr_Test};
- $self->{Curr_Test}++;
-
- # In case $name is a string overloaded object, force it to stringify.
- $self->_unoverload_str( \$name );
-
- $self->diag(<<"ERR") if defined $name and $name =~ /^[\d\s]+$/;
- You named your test '$name'. You shouldn't use numbers for your test names.
- Very confusing.
-ERR
-
- # Capture the value of $TODO for the rest of this ok() call
- # so it can more easily be found by other routines.
- my $todo = $self->todo();
- my $in_todo = $self->in_todo;
- local $self->{Todo} = $todo if $in_todo;
-
- $self->_unoverload_str( \$todo );
-
- my $out;
- my $result = &share( {} );
-
- unless($test) {
- $out .= "not ";
- @$result{ 'ok', 'actual_ok' } = ( ( $self->in_todo ? 1 : 0 ), 0 );
- }
- else {
- @$result{ 'ok', 'actual_ok' } = ( 1, $test );
- }
-
- $out .= "ok";
- $out .= " $self->{Curr_Test}" if $self->use_numbers;
-
- if( defined $name ) {
- $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness.
- $out .= " - $name";
- $result->{name} = $name;
- }
- else {
- $result->{name} = '';
- }
-
- if( $self->in_todo ) {
- $out .= " # TODO $todo";
- $result->{reason} = $todo;
- $result->{type} = 'todo';
- }
- else {
- $result->{reason} = '';
- $result->{type} = '';
- }
-
- $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = $result;
- $out .= "\n";
-
- $self->_print($out);
-
- unless($test) {
- my $msg = $self->in_todo ? "Failed (TODO)" : "Failed";
- $self->_print_to_fh( $self->_diag_fh, "\n" ) if $ENV{HARNESS_ACTIVE};
-
- my( undef, $file, $line ) = $self->caller;
- if( defined $name ) {
- $self->diag(qq[ $msg test '$name'\n]);
- $self->diag(qq[ at $file line $line.\n]);
- }
- else {
- $self->diag(qq[ $msg test at $file line $line.\n]);
- }
- }
-
- $self->is_passing(0) unless $test || $self->in_todo;
-
- # Check that we haven't violated the plan
- $self->_check_is_passing_plan();
-
- return $test ? 1 : 0;
-}
-
-
-# Check that we haven't yet violated the plan and set
-# is_passing() accordingly
-sub _check_is_passing_plan {
- my $self = shift;
-
- my $plan = $self->has_plan;
- return unless defined $plan; # no plan yet defined
- return unless $plan !~ /\D/; # no numeric plan
- $self->is_passing(0) if $plan < $self->{Curr_Test};
-}
-
-
-sub _unoverload {
- my $self = shift;
- my $type = shift;
-
- $self->_try(sub { require overload; }, die_on_fail => 1);
-
- foreach my $thing (@_) {
- if( $self->_is_object($$thing) ) {
- if( my $string_meth = overload::Method( $$thing, $type ) ) {
- $$thing = $$thing->$string_meth();
- }
- }
- }
-
- return;
-}
-
-sub _is_object {
- my( $self, $thing ) = @_;
-
- return $self->_try( sub { ref $thing && $thing->isa('UNIVERSAL') } ) ? 1 : 0;
-}
-
-sub _unoverload_str {
- my $self = shift;
-
- return $self->_unoverload( q[""], @_ );
-}
-
-sub _unoverload_num {
- my $self = shift;
-
- $self->_unoverload( '0+', @_ );
-
- for my $val (@_) {
- next unless $self->_is_dualvar($$val);
- $$val = $$val + 0;
- }
-
- return;
-}
-
-# This is a hack to detect a dualvar such as $!
-sub _is_dualvar {
- my( $self, $val ) = @_;
-
- # Objects are not dualvars.
- return 0 if ref $val;
-
- no warnings 'numeric';
- my $numval = $val + 0;
- return $numval != 0 and $numval ne $val ? 1 : 0;
-}
-
-#line 939
-
-sub is_eq {
- my( $self, $got, $expect, $name ) = @_;
- local $Level = $Level + 1;
-
- if( !defined $got || !defined $expect ) {
- # undef only matches undef and nothing else
- my $test = !defined $got && !defined $expect;
-
- $self->ok( $test, $name );
- $self->_is_diag( $got, 'eq', $expect ) unless $test;
- return $test;
- }
-
- return $self->cmp_ok( $got, 'eq', $expect, $name );
-}
-
-sub is_num {
- my( $self, $got, $expect, $name ) = @_;
- local $Level = $Level + 1;
-
- if( !defined $got || !defined $expect ) {
- # undef only matches undef and nothing else
- my $test = !defined $got && !defined $expect;
-
- $self->ok( $test, $name );
- $self->_is_diag( $got, '==', $expect ) unless $test;
- return $test;
- }
-
- return $self->cmp_ok( $got, '==', $expect, $name );
-}
-
-sub _diag_fmt {
- my( $self, $type, $val ) = @_;
-
- if( defined $$val ) {
- if( $type eq 'eq' or $type eq 'ne' ) {
- # quote and force string context
- $$val = "'$$val'";
- }
- else {
- # force numeric context
- $self->_unoverload_num($val);
- }
- }
- else {
- $$val = 'undef';
- }
-
- return;
-}
-
-sub _is_diag {
- my( $self, $got, $type, $expect ) = @_;
-
- $self->_diag_fmt( $type, $_ ) for \$got, \$expect;
-
- local $Level = $Level + 1;
- return $self->diag(<<"DIAGNOSTIC");
- got: $got
- expected: $expect
-DIAGNOSTIC
-
-}
-
-sub _isnt_diag {
- my( $self, $got, $type ) = @_;
-
- $self->_diag_fmt( $type, \$got );
-
- local $Level = $Level + 1;
- return $self->diag(<<"DIAGNOSTIC");
- got: $got
- expected: anything else
-DIAGNOSTIC
-}
-
-#line 1032
-
-sub isnt_eq {
- my( $self, $got, $dont_expect, $name ) = @_;
- local $Level = $Level + 1;
-
- if( !defined $got || !defined $dont_expect ) {
- # undef only matches undef and nothing else
- my $test = defined $got || defined $dont_expect;
-
- $self->ok( $test, $name );
- $self->_isnt_diag( $got, 'ne' ) unless $test;
- return $test;
- }
-
- return $self->cmp_ok( $got, 'ne', $dont_expect, $name );
-}
-
-sub isnt_num {
- my( $self, $got, $dont_expect, $name ) = @_;
- local $Level = $Level + 1;
-
- if( !defined $got || !defined $dont_expect ) {
- # undef only matches undef and nothing else
- my $test = defined $got || defined $dont_expect;
-
- $self->ok( $test, $name );
- $self->_isnt_diag( $got, '!=' ) unless $test;
- return $test;
- }
-
- return $self->cmp_ok( $got, '!=', $dont_expect, $name );
-}
-
-#line 1081
-
-sub like {
- my( $self, $this, $regex, $name ) = @_;
-
- local $Level = $Level + 1;
- return $self->_regex_ok( $this, $regex, '=~', $name );
-}
-
-sub unlike {
- my( $self, $this, $regex, $name ) = @_;
-
- local $Level = $Level + 1;
- return $self->_regex_ok( $this, $regex, '!~', $name );
-}
-
-#line 1105
-
-my %numeric_cmps = map { ( $_, 1 ) } ( "<", "<=", ">", ">=", "==", "!=", "<=>" );
-
-sub cmp_ok {
- my( $self, $got, $type, $expect, $name ) = @_;
-
- my $test;
- my $error;
- {
- ## no critic (BuiltinFunctions::ProhibitStringyEval)
-
- local( $@, $!, $SIG{__DIE__} ); # isolate eval
-
- my($pack, $file, $line) = $self->caller();
-
- # This is so that warnings come out at the caller's level
- $test = eval qq[
-#line $line "(eval in cmp_ok) $file"
-\$got $type \$expect;
-];
- $error = $@;
- }
- local $Level = $Level + 1;
- my $ok = $self->ok( $test, $name );
-
- # Treat overloaded objects as numbers if we're asked to do a
- # numeric comparison.
- my $unoverload
- = $numeric_cmps{$type}
- ? '_unoverload_num'
- : '_unoverload_str';
-
- $self->diag(<<"END") if $error;
-An error occurred while using $type:
-------------------------------------
-$error
-------------------------------------
-END
-
- unless($ok) {
- $self->$unoverload( \$got, \$expect );
-
- if( $type =~ /^(eq|==)$/ ) {
- $self->_is_diag( $got, $type, $expect );
- }
- elsif( $type =~ /^(ne|!=)$/ ) {
- $self->_isnt_diag( $got, $type );
- }
- else {
- $self->_cmp_diag( $got, $type, $expect );
- }
- }
- return $ok;
-}
-
-sub _cmp_diag {
- my( $self, $got, $type, $expect ) = @_;
-
- $got = defined $got ? "'$got'" : 'undef';
- $expect = defined $expect ? "'$expect'" : 'undef';
-
- local $Level = $Level + 1;
- return $self->diag(<<"DIAGNOSTIC");
- $got
- $type
- $expect
-DIAGNOSTIC
-}
-
-sub _caller_context {
- my $self = shift;
-
- my( $pack, $file, $line ) = $self->caller(1);
-
- my $code = '';
- $code .= "#line $line $file\n" if defined $file and defined $line;
-
- return $code;
-}
-
-#line 1205
-
-sub BAIL_OUT {
- my( $self, $reason ) = @_;
-
- $self->{Bailed_Out} = 1;
- $self->_print("Bail out! $reason");
- exit 255;
-}
-
-#line 1218
-
-{
- no warnings 'once';
- *BAILOUT = \&BAIL_OUT;
-}
-
-#line 1232
-
-sub skip {
- my( $self, $why ) = @_;
- $why ||= '';
- $self->_unoverload_str( \$why );
-
- lock( $self->{Curr_Test} );
- $self->{Curr_Test}++;
-
- $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share(
- {
- 'ok' => 1,
- actual_ok => 1,
- name => '',
- type => 'skip',
- reason => $why,
- }
- );
-
- my $out = "ok";
- $out .= " $self->{Curr_Test}" if $self->use_numbers;
- $out .= " # skip";
- $out .= " $why" if length $why;
- $out .= "\n";
-
- $self->_print($out);
-
- return 1;
-}
-
-#line 1273
-
-sub todo_skip {
- my( $self, $why ) = @_;
- $why ||= '';
-
- lock( $self->{Curr_Test} );
- $self->{Curr_Test}++;
-
- $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share(
- {
- 'ok' => 1,
- actual_ok => 0,
- name => '',
- type => 'todo_skip',
- reason => $why,
- }
- );
-
- my $out = "not ok";
- $out .= " $self->{Curr_Test}" if $self->use_numbers;
- $out .= " # TODO & SKIP $why\n";
-
- $self->_print($out);
-
- return 1;
-}
-
-#line 1353
-
-sub maybe_regex {
- my( $self, $regex ) = @_;
- my $usable_regex = undef;
-
- return $usable_regex unless defined $regex;
-
- my( $re, $opts );
-
- # Check for qr/foo/
- if( _is_qr($regex) ) {
- $usable_regex = $regex;
- }
- # Check for '/foo/' or 'm,foo,'
- elsif(( $re, $opts ) = $regex =~ m{^ /(.*)/ (\w*) $ }sx or
- ( undef, $re, $opts ) = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx
- )
- {
- $usable_regex = length $opts ? "(?$opts)$re" : $re;
- }
-
- return $usable_regex;
-}
-
-sub _is_qr {
- my $regex = shift;
-
- # is_regexp() checks for regexes in a robust manner, say if they're
- # blessed.
- return re::is_regexp($regex) if defined &re::is_regexp;
- return ref $regex eq 'Regexp';
-}
-
-sub _regex_ok {
- my( $self, $this, $regex, $cmp, $name ) = @_;
-
- my $ok = 0;
- my $usable_regex = $self->maybe_regex($regex);
- unless( defined $usable_regex ) {
- local $Level = $Level + 1;
- $ok = $self->ok( 0, $name );
- $self->diag(" '$regex' doesn't look much like a regex to me.");
- return $ok;
- }
-
- {
- ## no critic (BuiltinFunctions::ProhibitStringyEval)
-
- my $test;
- my $context = $self->_caller_context;
-
- local( $@, $!, $SIG{__DIE__} ); # isolate eval
-
- $test = eval $context . q{$test = $this =~ /$usable_regex/ ? 1 : 0};
-
- $test = !$test if $cmp eq '!~';
-
- local $Level = $Level + 1;
- $ok = $self->ok( $test, $name );
- }
-
- unless($ok) {
- $this = defined $this ? "'$this'" : 'undef';
- my $match = $cmp eq '=~' ? "doesn't match" : "matches";
-
- local $Level = $Level + 1;
- $self->diag( sprintf <<'DIAGNOSTIC', $this, $match, $regex );
- %s
- %13s '%s'
-DIAGNOSTIC
-
- }
-
- return $ok;
-}
-
-# I'm not ready to publish this. It doesn't deal with array return
-# values from the code or context.
-
-#line 1449
-
-sub _try {
- my( $self, $code, %opts ) = @_;
-
- my $error;
- my $return;
- {
- local $!; # eval can mess up $!
- local $@; # don't set $@ in the test
- local $SIG{__DIE__}; # don't trip an outside DIE handler.
- $return = eval { $code->() };
- $error = $@;
- }
-
- die $error if $error and $opts{die_on_fail};
-
- return wantarray ? ( $return, $error ) : $return;
-}
-
-#line 1478
-
-sub is_fh {
- my $self = shift;
- my $maybe_fh = shift;
- return 0 unless defined $maybe_fh;
-
- return 1 if ref $maybe_fh eq 'GLOB'; # its a glob ref
- return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob
-
- return eval { $maybe_fh->isa("IO::Handle") } ||
- eval { tied($maybe_fh)->can('TIEHANDLE') };
-}
-
-#line 1521
-
-sub level {
- my( $self, $level ) = @_;
-
- if( defined $level ) {
- $Level = $level;
- }
- return $Level;
-}
-
-#line 1553
-
-sub use_numbers {
- my( $self, $use_nums ) = @_;
-
- if( defined $use_nums ) {
- $self->{Use_Nums} = $use_nums;
- }
- return $self->{Use_Nums};
-}
-
-#line 1586
-
-foreach my $attribute (qw(No_Header No_Ending No_Diag)) {
- my $method = lc $attribute;
-
- my $code = sub {
- my( $self, $no ) = @_;
-
- if( defined $no ) {
- $self->{$attribute} = $no;
- }
- return $self->{$attribute};
- };
-
- no strict 'refs'; ## no critic
- *{ __PACKAGE__ . '::' . $method } = $code;
-}
-
-#line 1639
-
-sub diag {
- my $self = shift;
-
- $self->_print_comment( $self->_diag_fh, @_ );
-}
-
-#line 1654
-
-sub note {
- my $self = shift;
-
- $self->_print_comment( $self->output, @_ );
-}
-
-sub _diag_fh {
- my $self = shift;
-
- local $Level = $Level + 1;
- return $self->in_todo ? $self->todo_output : $self->failure_output;
-}
-
-sub _print_comment {
- my( $self, $fh, @msgs ) = @_;
-
- return if $self->no_diag;
- return unless @msgs;
-
- # Prevent printing headers when compiling (i.e. -c)
- return if $^C;
-
- # Smash args together like print does.
- # Convert undef to 'undef' so its readable.
- my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs;
-
- # Escape the beginning, _print will take care of the rest.
- $msg =~ s/^/# /;
-
- local $Level = $Level + 1;
- $self->_print_to_fh( $fh, $msg );
-
- return 0;
-}
-
-#line 1704
-
-sub explain {
- my $self = shift;
-
- return map {
- ref $_
- ? do {
- $self->_try(sub { require Data::Dumper }, die_on_fail => 1);
-
- my $dumper = Data::Dumper->new( [$_] );
- $dumper->Indent(1)->Terse(1);
- $dumper->Sortkeys(1) if $dumper->can("Sortkeys");
- $dumper->Dump;
- }
- : $_
- } @_;
-}
-
-#line 1733
-
-sub _print {
- my $self = shift;
- return $self->_print_to_fh( $self->output, @_ );
-}
-
-sub _print_to_fh {
- my( $self, $fh, @msgs ) = @_;
-
- # Prevent printing headers when only compiling. Mostly for when
- # tests are deparsed with B::Deparse
- return if $^C;
-
- my $msg = join '', @msgs;
- my $indent = $self->_indent;
-
- local( $\, $", $, ) = ( undef, ' ', '' );
-
- # Escape each line after the first with a # so we don't
- # confuse Test::Harness.
- $msg =~ s{\n(?!\z)}{\n$indent# }sg;
-
- # Stick a newline on the end if it needs it.
- $msg .= "\n" unless $msg =~ /\n\z/;
-
- return print $fh $indent, $msg;
-}
-
-#line 1793
-
-sub output {
- my( $self, $fh ) = @_;
-
- if( defined $fh ) {
- $self->{Out_FH} = $self->_new_fh($fh);
- }
- return $self->{Out_FH};
-}
-
-sub failure_output {
- my( $self, $fh ) = @_;
-
- if( defined $fh ) {
- $self->{Fail_FH} = $self->_new_fh($fh);
- }
- return $self->{Fail_FH};
-}
-
-sub todo_output {
- my( $self, $fh ) = @_;
-
- if( defined $fh ) {
- $self->{Todo_FH} = $self->_new_fh($fh);
- }
- return $self->{Todo_FH};
-}
-
-sub _new_fh {
- my $self = shift;
- my($file_or_fh) = shift;
-
- my $fh;
- if( $self->is_fh($file_or_fh) ) {
- $fh = $file_or_fh;
- }
- elsif( ref $file_or_fh eq 'SCALAR' ) {
- # Scalar refs as filehandles was added in 5.8.
- if( $] >= 5.008 ) {
- open $fh, ">>", $file_or_fh
- or $self->croak("Can't open scalar ref $file_or_fh: $!");
- }
- # Emulate scalar ref filehandles with a tie.
- else {
- $fh = Test::Builder::IO::Scalar->new($file_or_fh)
- or $self->croak("Can't tie scalar ref $file_or_fh");
- }
- }
- else {
- open $fh, ">", $file_or_fh
- or $self->croak("Can't open test output log $file_or_fh: $!");
- _autoflush($fh);
- }
-
- return $fh;
-}
-
-sub _autoflush {
- my($fh) = shift;
- my $old_fh = select $fh;
- $| = 1;
- select $old_fh;
-
- return;
-}
-
-my( $Testout, $Testerr );
-
-sub _dup_stdhandles {
- my $self = shift;
-
- $self->_open_testhandles;
-
- # Set everything to unbuffered else plain prints to STDOUT will
- # come out in the wrong order from our own prints.
- _autoflush($Testout);
- _autoflush( \*STDOUT );
- _autoflush($Testerr);
- _autoflush( \*STDERR );
-
- $self->reset_outputs;
-
- return;
-}
-
-sub _open_testhandles {
- my $self = shift;
-
- return if $self->{Opened_Testhandles};
-
- # We dup STDOUT and STDERR so people can change them in their
- # test suites while still getting normal test output.
- open( $Testout, ">&STDOUT" ) or die "Can't dup STDOUT: $!";
- open( $Testerr, ">&STDERR" ) or die "Can't dup STDERR: $!";
-
- $self->_copy_io_layers( \*STDOUT, $Testout );
- $self->_copy_io_layers( \*STDERR, $Testerr );
-
- $self->{Opened_Testhandles} = 1;
-
- return;
-}
-
-sub _copy_io_layers {
- my( $self, $src, $dst ) = @_;
-
- $self->_try(
- sub {
- require PerlIO;
- my @src_layers = PerlIO::get_layers($src);
-
- _apply_layers($dst, @src_layers) if @src_layers;
- }
- );
-
- return;
-}
-
-sub _apply_layers {
- my ($fh, @layers) = @_;
- my %seen;
- my @unique = grep { $_ ne 'unix' and !$seen{$_}++ } @layers;
- binmode($fh, join(":", "", "raw", @unique));
-}
-
-
-#line 1926
-
-sub reset_outputs {
- my $self = shift;
-
- $self->output ($Testout);
- $self->failure_output($Testerr);
- $self->todo_output ($Testout);
-
- return;
-}
-
-#line 1952
-
-sub _message_at_caller {
- my $self = shift;
-
- local $Level = $Level + 1;
- my( $pack, $file, $line ) = $self->caller;
- return join( "", @_ ) . " at $file line $line.\n";
-}
-
-sub carp {
- my $self = shift;
- return warn $self->_message_at_caller(@_);
-}
-
-sub croak {
- my $self = shift;
- return die $self->_message_at_caller(@_);
-}
-
-
-#line 1992
-
-sub current_test {
- my( $self, $num ) = @_;
-
- lock( $self->{Curr_Test} );
- if( defined $num ) {
- $self->{Curr_Test} = $num;
-
- # If the test counter is being pushed forward fill in the details.
- my $test_results = $self->{Test_Results};
- if( $num > @$test_results ) {
- my $start = @$test_results ? @$test_results : 0;
- for( $start .. $num - 1 ) {
- $test_results->[$_] = &share(
- {
- 'ok' => 1,
- actual_ok => undef,
- reason => 'incrementing test number',
- type => 'unknown',
- name => undef
- }
- );
- }
- }
- # If backward, wipe history. Its their funeral.
- elsif( $num < @$test_results ) {
- $#{$test_results} = $num - 1;
- }
- }
- return $self->{Curr_Test};
-}
-
-#line 2040
-
-sub is_passing {
- my $self = shift;
-
- if( @_ ) {
- $self->{Is_Passing} = shift;
- }
-
- return $self->{Is_Passing};
-}
-
-
-#line 2062
-
-sub summary {
- my($self) = shift;
-
- return map { $_->{'ok'} } @{ $self->{Test_Results} };
-}
-
-#line 2117
-
-sub details {
- my $self = shift;
- return @{ $self->{Test_Results} };
-}
-
-#line 2146
-
-sub todo {
- my( $self, $pack ) = @_;
-
- return $self->{Todo} if defined $self->{Todo};
-
- local $Level = $Level + 1;
- my $todo = $self->find_TODO($pack);
- return $todo if defined $todo;
-
- return '';
-}
-
-#line 2173
-
-sub find_TODO {
- my( $self, $pack, $set, $new_value ) = @_;
-
- $pack = $pack || $self->caller(1) || $self->exported_to;
- return unless $pack;
-
- no strict 'refs'; ## no critic
- my $old_value = ${ $pack . '::TODO' };
- $set and ${ $pack . '::TODO' } = $new_value;
- return $old_value;
-}
-
-#line 2193
-
-sub in_todo {
- my $self = shift;
-
- local $Level = $Level + 1;
- return( defined $self->{Todo} || $self->find_TODO ) ? 1 : 0;
-}
-
-#line 2243
-
-sub todo_start {
- my $self = shift;
- my $message = @_ ? shift : '';
-
- $self->{Start_Todo}++;
- if( $self->in_todo ) {
- push @{ $self->{Todo_Stack} } => $self->todo;
- }
- $self->{Todo} = $message;
-
- return;
-}
-
-#line 2265
-
-sub todo_end {
- my $self = shift;
-
- if( !$self->{Start_Todo} ) {
- $self->croak('todo_end() called without todo_start()');
- }
-
- $self->{Start_Todo}--;
-
- if( $self->{Start_Todo} && @{ $self->{Todo_Stack} } ) {
- $self->{Todo} = pop @{ $self->{Todo_Stack} };
- }
- else {
- delete $self->{Todo};
- }
-
- return;
-}
-
-#line 2298
-
-sub caller { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
- my( $self, $height ) = @_;
- $height ||= 0;
-
- my $level = $self->level + $height + 1;
- my @caller;
- do {
- @caller = CORE::caller( $level );
- $level--;
- } until @caller;
- return wantarray ? @caller : $caller[0];
-}
-
-#line 2315
-
-#line 2329
-
-#'#
-sub _sanity_check {
- my $self = shift;
-
- $self->_whoa( $self->{Curr_Test} < 0, 'Says here you ran a negative number of tests!' );
- $self->_whoa( $self->{Curr_Test} != @{ $self->{Test_Results} },
- 'Somehow you got a different number of results than tests ran!' );
-
- return;
-}
-
-#line 2350
-
-sub _whoa {
- my( $self, $check, $desc ) = @_;
- if($check) {
- local $Level = $Level + 1;
- $self->croak(<<"WHOA");
-WHOA! $desc
-This should never happen! Please contact the author immediately!
-WHOA
- }
-
- return;
-}
-
-#line 2374
-
-sub _my_exit {
- $? = $_[0]; ## no critic (Variables::RequireLocalizedPunctuationVars)
-
- return 1;
-}
-
-#line 2386
-
-sub _ending {
- my $self = shift;
- return if $self->no_ending;
- return if $self->{Ending}++;
-
- my $real_exit_code = $?;
-
- # Don't bother with an ending if this is a forked copy. Only the parent
- # should do the ending.
- if( $self->{Original_Pid} != $$ ) {
- return;
- }
-
- # Ran tests but never declared a plan or hit done_testing
- if( !$self->{Have_Plan} and $self->{Curr_Test} ) {
- $self->is_passing(0);
- $self->diag("Tests were run but no plan was declared and done_testing() was not seen.");
- }
-
- # Exit if plan() was never called. This is so "require Test::Simple"
- # doesn't puke.
- if( !$self->{Have_Plan} ) {
- return;
- }
-
- # Don't do an ending if we bailed out.
- if( $self->{Bailed_Out} ) {
- $self->is_passing(0);
- return;
- }
- # Figure out if we passed or failed and print helpful messages.
- my $test_results = $self->{Test_Results};
- if(@$test_results) {
- # The plan? We have no plan.
- if( $self->{No_Plan} ) {
- $self->_output_plan($self->{Curr_Test}) unless $self->no_header;
- $self->{Expected_Tests} = $self->{Curr_Test};
- }
-
- # Auto-extended arrays and elements which aren't explicitly
- # filled in with a shared reference will puke under 5.8.0
- # ithreads. So we have to fill them in by hand. :(
- my $empty_result = &share( {} );
- for my $idx ( 0 .. $self->{Expected_Tests} - 1 ) {
- $test_results->[$idx] = $empty_result
- unless defined $test_results->[$idx];
- }
-
- my $num_failed = grep !$_->{'ok'}, @{$test_results}[ 0 .. $self->{Curr_Test} - 1 ];
-
- my $num_extra = $self->{Curr_Test} - $self->{Expected_Tests};
-
- if( $num_extra != 0 ) {
- my $s = $self->{Expected_Tests} == 1 ? '' : 's';
- $self->diag(<<"FAIL");
-Looks like you planned $self->{Expected_Tests} test$s but ran $self->{Curr_Test}.
-FAIL
- $self->is_passing(0);
- }
-
- if($num_failed) {
- my $num_tests = $self->{Curr_Test};
- my $s = $num_failed == 1 ? '' : 's';
-
- my $qualifier = $num_extra == 0 ? '' : ' run';
-
- $self->diag(<<"FAIL");
-Looks like you failed $num_failed test$s of $num_tests$qualifier.
-FAIL
- $self->is_passing(0);
- }
-
- if($real_exit_code) {
- $self->diag(<<"FAIL");
-Looks like your test exited with $real_exit_code just after $self->{Curr_Test}.
-FAIL
- $self->is_passing(0);
- _my_exit($real_exit_code) && return;
- }
-
- my $exit_code;
- if($num_failed) {
- $exit_code = $num_failed <= 254 ? $num_failed : 254;
- }
- elsif( $num_extra != 0 ) {
- $exit_code = 255;
- }
- else {
- $exit_code = 0;
- }
-
- _my_exit($exit_code) && return;
- }
- elsif( $self->{Skip_All} ) {
- _my_exit(0) && return;
- }
- elsif($real_exit_code) {
- $self->diag(<<"FAIL");
-Looks like your test exited with $real_exit_code before it could output anything.
-FAIL
- $self->is_passing(0);
- _my_exit($real_exit_code) && return;
- }
- else {
- $self->diag("No tests run!\n");
- $self->is_passing(0);
- _my_exit(255) && return;
- }
-
- $self->is_passing(0);
- $self->_whoa( 1, "We fell off the end of _ending()" );
-}
-
-END {
- $Test->_ending if defined $Test;
-}
-
-#line 2574
-
-1;
-
@@ -1,762 +0,0 @@
-#line 1
-package Test::More;
-
-use 5.006;
-use strict;
-use warnings;
-
-#---- perlcritic exemptions. ----#
-
-# We use a lot of subroutine prototypes
-## no critic (Subroutines::ProhibitSubroutinePrototypes)
-
-# Can't use Carp because it might cause use_ok() to accidentally succeed
-# even though the module being used forgot to use Carp. Yes, this
-# actually happened.
-sub _carp {
- my( $file, $line ) = ( caller(1) )[ 1, 2 ];
- return warn @_, " at $file line $line\n";
-}
-
-our $VERSION = '0.98';
-$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
-
-use Test::Builder::Module;
-our @ISA = qw(Test::Builder::Module);
-our @EXPORT = qw(ok use_ok require_ok
- is isnt like unlike is_deeply
- cmp_ok
- skip todo todo_skip
- pass fail
- eq_array eq_hash eq_set
- $TODO
- plan
- done_testing
- can_ok isa_ok new_ok
- diag note explain
- subtest
- BAIL_OUT
-);
-
-#line 164
-
-sub plan {
- my $tb = Test::More->builder;
-
- return $tb->plan(@_);
-}
-
-# This implements "use Test::More 'no_diag'" but the behavior is
-# deprecated.
-sub import_extra {
- my $class = shift;
- my $list = shift;
-
- my @other = ();
- my $idx = 0;
- while( $idx <= $#{$list} ) {
- my $item = $list->[$idx];
-
- if( defined $item and $item eq 'no_diag' ) {
- $class->builder->no_diag(1);
- }
- else {
- push @other, $item;
- }
-
- $idx++;
- }
-
- @$list = @other;
-
- return;
-}
-
-#line 217
-
-sub done_testing {
- my $tb = Test::More->builder;
- $tb->done_testing(@_);
-}
-
-#line 289
-
-sub ok ($;$) {
- my( $test, $name ) = @_;
- my $tb = Test::More->builder;
-
- return $tb->ok( $test, $name );
-}
-
-#line 372
-
-sub is ($$;$) {
- my $tb = Test::More->builder;
-
- return $tb->is_eq(@_);
-}
-
-sub isnt ($$;$) {
- my $tb = Test::More->builder;
-
- return $tb->isnt_eq(@_);
-}
-
-*isn't = \&isnt;
-
-#line 416
-
-sub like ($$;$) {
- my $tb = Test::More->builder;
-
- return $tb->like(@_);
-}
-
-#line 431
-
-sub unlike ($$;$) {
- my $tb = Test::More->builder;
-
- return $tb->unlike(@_);
-}
-
-#line 476
-
-sub cmp_ok($$$;$) {
- my $tb = Test::More->builder;
-
- return $tb->cmp_ok(@_);
-}
-
-#line 511
-
-sub can_ok ($@) {
- my( $proto, @methods ) = @_;
- my $class = ref $proto || $proto;
- my $tb = Test::More->builder;
-
- unless($class) {
- my $ok = $tb->ok( 0, "->can(...)" );
- $tb->diag(' can_ok() called with empty class or reference');
- return $ok;
- }
-
- unless(@methods) {
- my $ok = $tb->ok( 0, "$class->can(...)" );
- $tb->diag(' can_ok() called with no methods');
- return $ok;
- }
-
- my @nok = ();
- foreach my $method (@methods) {
- $tb->_try( sub { $proto->can($method) } ) or push @nok, $method;
- }
-
- my $name = (@methods == 1) ? "$class->can('$methods[0]')" :
- "$class->can(...)" ;
-
- my $ok = $tb->ok( !@nok, $name );
-
- $tb->diag( map " $class->can('$_') failed\n", @nok );
-
- return $ok;
-}
-
-#line 577
-
-sub isa_ok ($$;$) {
- my( $object, $class, $obj_name ) = @_;
- my $tb = Test::More->builder;
-
- my $diag;
-
- if( !defined $object ) {
- $obj_name = 'The thing' unless defined $obj_name;
- $diag = "$obj_name isn't defined";
- }
- else {
- my $whatami = ref $object ? 'object' : 'class';
- # We can't use UNIVERSAL::isa because we want to honor isa() overrides
- my( $rslt, $error ) = $tb->_try( sub { $object->isa($class) } );
- if($error) {
- if( $error =~ /^Can't call method "isa" on unblessed reference/ ) {
- # Its an unblessed reference
- $obj_name = 'The reference' unless defined $obj_name;
- if( !UNIVERSAL::isa( $object, $class ) ) {
- my $ref = ref $object;
- $diag = "$obj_name isn't a '$class' it's a '$ref'";
- }
- }
- elsif( $error =~ /Can't call method "isa" without a package/ ) {
- # It's something that can't even be a class
- $obj_name = 'The thing' unless defined $obj_name;
- $diag = "$obj_name isn't a class or reference";
- }
- else {
- die <<WHOA;
-WHOA! I tried to call ->isa on your $whatami and got some weird error.
-Here's the error.
-$error
-WHOA
- }
- }
- else {
- $obj_name = "The $whatami" unless defined $obj_name;
- if( !$rslt ) {
- my $ref = ref $object;
- $diag = "$obj_name isn't a '$class' it's a '$ref'";
- }
- }
- }
-
- my $name = "$obj_name isa $class";
- my $ok;
- if($diag) {
- $ok = $tb->ok( 0, $name );
- $tb->diag(" $diag\n");
- }
- else {
- $ok = $tb->ok( 1, $name );
- }
-
- return $ok;
-}
-
-#line 656
-
-sub new_ok {
- my $tb = Test::More->builder;
- $tb->croak("new_ok() must be given at least a class") unless @_;
-
- my( $class, $args, $object_name ) = @_;
-
- $args ||= [];
- $object_name = "The object" unless defined $object_name;
-
- my $obj;
- my( $success, $error ) = $tb->_try( sub { $obj = $class->new(@$args); 1 } );
- if($success) {
- local $Test::Builder::Level = $Test::Builder::Level + 1;
- isa_ok $obj, $class, $object_name;
- }
- else {
- $tb->ok( 0, "new() died" );
- $tb->diag(" Error was: $error");
- }
-
- return $obj;
-}
-
-#line 741
-
-sub subtest {
- my ($name, $subtests) = @_;
-
- my $tb = Test::More->builder;
- return $tb->subtest(@_);
-}
-
-#line 765
-
-sub pass (;$) {
- my $tb = Test::More->builder;
-
- return $tb->ok( 1, @_ );
-}
-
-sub fail (;$) {
- my $tb = Test::More->builder;
-
- return $tb->ok( 0, @_ );
-}
-
-#line 833
-
-sub use_ok ($;@) {
- my( $module, @imports ) = @_;
- @imports = () unless @imports;
- my $tb = Test::More->builder;
-
- my( $pack, $filename, $line ) = caller;
-
- my $code;
- if( @imports == 1 and $imports[0] =~ /^\d+(?:\.\d+)?$/ ) {
- # probably a version check. Perl needs to see the bare number
- # for it to work with non-Exporter based modules.
- $code = <<USE;
-package $pack;
-use $module $imports[0];
-1;
-USE
- }
- else {
- $code = <<USE;
-package $pack;
-use $module \@{\$args[0]};
-1;
-USE
- }
-
- my( $eval_result, $eval_error ) = _eval( $code, \@imports );
- my $ok = $tb->ok( $eval_result, "use $module;" );
-
- unless($ok) {
- chomp $eval_error;
- $@ =~ s{^BEGIN failed--compilation aborted at .*$}
- {BEGIN failed--compilation aborted at $filename line $line.}m;
- $tb->diag(<<DIAGNOSTIC);
- Tried to use '$module'.
- Error: $eval_error
-DIAGNOSTIC
-
- }
-
- return $ok;
-}
-
-sub _eval {
- my( $code, @args ) = @_;
-
- # Work around oddities surrounding resetting of $@ by immediately
- # storing it.
- my( $sigdie, $eval_result, $eval_error );
- {
- local( $@, $!, $SIG{__DIE__} ); # isolate eval
- $eval_result = eval $code; ## no critic (BuiltinFunctions::ProhibitStringyEval)
- $eval_error = $@;
- $sigdie = $SIG{__DIE__} || undef;
- }
- # make sure that $code got a chance to set $SIG{__DIE__}
- $SIG{__DIE__} = $sigdie if defined $sigdie;
-
- return( $eval_result, $eval_error );
-}
-
-#line 902
-
-sub require_ok ($) {
- my($module) = shift;
- my $tb = Test::More->builder;
-
- my $pack = caller;
-
- # Try to determine if we've been given a module name or file.
- # Module names must be barewords, files not.
- $module = qq['$module'] unless _is_module_name($module);
-
- my $code = <<REQUIRE;
-package $pack;
-require $module;
-1;
-REQUIRE
-
- my( $eval_result, $eval_error ) = _eval($code);
- my $ok = $tb->ok( $eval_result, "require $module;" );
-
- unless($ok) {
- chomp $eval_error;
- $tb->diag(<<DIAGNOSTIC);
- Tried to require '$module'.
- Error: $eval_error
-DIAGNOSTIC
-
- }
-
- return $ok;
-}
-
-sub _is_module_name {
- my $module = shift;
-
- # Module names start with a letter.
- # End with an alphanumeric.
- # The rest is an alphanumeric or ::
- $module =~ s/\b::\b//g;
-
- return $module =~ /^[a-zA-Z]\w*$/ ? 1 : 0;
-}
-
-#line 979
-
-our( @Data_Stack, %Refs_Seen );
-my $DNE = bless [], 'Does::Not::Exist';
-
-sub _dne {
- return ref $_[0] eq ref $DNE;
-}
-
-## no critic (Subroutines::RequireArgUnpacking)
-sub is_deeply {
- my $tb = Test::More->builder;
-
- unless( @_ == 2 or @_ == 3 ) {
- my $msg = <<'WARNING';
-is_deeply() takes two or three args, you gave %d.
-This usually means you passed an array or hash instead
-of a reference to it
-WARNING
- chop $msg; # clip off newline so carp() will put in line/file
-
- _carp sprintf $msg, scalar @_;
-
- return $tb->ok(0);
- }
-
- my( $got, $expected, $name ) = @_;
-
- $tb->_unoverload_str( \$expected, \$got );
-
- my $ok;
- if( !ref $got and !ref $expected ) { # neither is a reference
- $ok = $tb->is_eq( $got, $expected, $name );
- }
- elsif( !ref $got xor !ref $expected ) { # one's a reference, one isn't
- $ok = $tb->ok( 0, $name );
- $tb->diag( _format_stack({ vals => [ $got, $expected ] }) );
- }
- else { # both references
- local @Data_Stack = ();
- if( _deep_check( $got, $expected ) ) {
- $ok = $tb->ok( 1, $name );
- }
- else {
- $ok = $tb->ok( 0, $name );
- $tb->diag( _format_stack(@Data_Stack) );
- }
- }
-
- return $ok;
-}
-
-sub _format_stack {
- my(@Stack) = @_;
-
- my $var = '$FOO';
- my $did_arrow = 0;
- foreach my $entry (@Stack) {
- my $type = $entry->{type} || '';
- my $idx = $entry->{'idx'};
- if( $type eq 'HASH' ) {
- $var .= "->" unless $did_arrow++;
- $var .= "{$idx}";
- }
- elsif( $type eq 'ARRAY' ) {
- $var .= "->" unless $did_arrow++;
- $var .= "[$idx]";
- }
- elsif( $type eq 'REF' ) {
- $var = "\${$var}";
- }
- }
-
- my @vals = @{ $Stack[-1]{vals} }[ 0, 1 ];
- my @vars = ();
- ( $vars[0] = $var ) =~ s/\$FOO/ \$got/;
- ( $vars[1] = $var ) =~ s/\$FOO/\$expected/;
-
- my $out = "Structures begin differing at:\n";
- foreach my $idx ( 0 .. $#vals ) {
- my $val = $vals[$idx];
- $vals[$idx]
- = !defined $val ? 'undef'
- : _dne($val) ? "Does not exist"
- : ref $val ? "$val"
- : "'$val'";
- }
-
- $out .= "$vars[0] = $vals[0]\n";
- $out .= "$vars[1] = $vals[1]\n";
-
- $out =~ s/^/ /msg;
- return $out;
-}
-
-sub _type {
- my $thing = shift;
-
- return '' if !ref $thing;
-
- for my $type (qw(Regexp ARRAY HASH REF SCALAR GLOB CODE)) {
- return $type if UNIVERSAL::isa( $thing, $type );
- }
-
- return '';
-}
-
-#line 1139
-
-sub diag {
- return Test::More->builder->diag(@_);
-}
-
-sub note {
- return Test::More->builder->note(@_);
-}
-
-#line 1165
-
-sub explain {
- return Test::More->builder->explain(@_);
-}
-
-#line 1231
-
-## no critic (Subroutines::RequireFinalReturn)
-sub skip {
- my( $why, $how_many ) = @_;
- my $tb = Test::More->builder;
-
- unless( defined $how_many ) {
- # $how_many can only be avoided when no_plan is in use.
- _carp "skip() needs to know \$how_many tests are in the block"
- unless $tb->has_plan eq 'no_plan';
- $how_many = 1;
- }
-
- if( defined $how_many and $how_many =~ /\D/ ) {
- _carp
- "skip() was passed a non-numeric number of tests. Did you get the arguments backwards?";
- $how_many = 1;
- }
-
- for( 1 .. $how_many ) {
- $tb->skip($why);
- }
-
- no warnings 'exiting';
- last SKIP;
-}
-
-#line 1315
-
-sub todo_skip {
- my( $why, $how_many ) = @_;
- my $tb = Test::More->builder;
-
- unless( defined $how_many ) {
- # $how_many can only be avoided when no_plan is in use.
- _carp "todo_skip() needs to know \$how_many tests are in the block"
- unless $tb->has_plan eq 'no_plan';
- $how_many = 1;
- }
-
- for( 1 .. $how_many ) {
- $tb->todo_skip($why);
- }
-
- no warnings 'exiting';
- last TODO;
-}
-
-#line 1370
-
-sub BAIL_OUT {
- my $reason = shift;
- my $tb = Test::More->builder;
-
- $tb->BAIL_OUT($reason);
-}
-
-#line 1409
-
-#'#
-sub eq_array {
- local @Data_Stack = ();
- _deep_check(@_);
-}
-
-sub _eq_array {
- my( $a1, $a2 ) = @_;
-
- if( grep _type($_) ne 'ARRAY', $a1, $a2 ) {
- warn "eq_array passed a non-array ref";
- return 0;
- }
-
- return 1 if $a1 eq $a2;
-
- my $ok = 1;
- my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2;
- for( 0 .. $max ) {
- my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_];
- my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_];
-
- next if _equal_nonrefs($e1, $e2);
-
- push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [ $e1, $e2 ] };
- $ok = _deep_check( $e1, $e2 );
- pop @Data_Stack if $ok;
-
- last unless $ok;
- }
-
- return $ok;
-}
-
-sub _equal_nonrefs {
- my( $e1, $e2 ) = @_;
-
- return if ref $e1 or ref $e2;
-
- if ( defined $e1 ) {
- return 1 if defined $e2 and $e1 eq $e2;
- }
- else {
- return 1 if !defined $e2;
- }
-
- return;
-}
-
-sub _deep_check {
- my( $e1, $e2 ) = @_;
- my $tb = Test::More->builder;
-
- my $ok = 0;
-
- # Effectively turn %Refs_Seen into a stack. This avoids picking up
- # the same referenced used twice (such as [\$a, \$a]) to be considered
- # circular.
- local %Refs_Seen = %Refs_Seen;
-
- {
- $tb->_unoverload_str( \$e1, \$e2 );
-
- # Either they're both references or both not.
- my $same_ref = !( !ref $e1 xor !ref $e2 );
- my $not_ref = ( !ref $e1 and !ref $e2 );
-
- if( defined $e1 xor defined $e2 ) {
- $ok = 0;
- }
- elsif( !defined $e1 and !defined $e2 ) {
- # Shortcut if they're both undefined.
- $ok = 1;
- }
- elsif( _dne($e1) xor _dne($e2) ) {
- $ok = 0;
- }
- elsif( $same_ref and( $e1 eq $e2 ) ) {
- $ok = 1;
- }
- elsif($not_ref) {
- push @Data_Stack, { type => '', vals => [ $e1, $e2 ] };
- $ok = 0;
- }
- else {
- if( $Refs_Seen{$e1} ) {
- return $Refs_Seen{$e1} eq $e2;
- }
- else {
- $Refs_Seen{$e1} = "$e2";
- }
-
- my $type = _type($e1);
- $type = 'DIFFERENT' unless _type($e2) eq $type;
-
- if( $type eq 'DIFFERENT' ) {
- push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] };
- $ok = 0;
- }
- elsif( $type eq 'ARRAY' ) {
- $ok = _eq_array( $e1, $e2 );
- }
- elsif( $type eq 'HASH' ) {
- $ok = _eq_hash( $e1, $e2 );
- }
- elsif( $type eq 'REF' ) {
- push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] };
- $ok = _deep_check( $$e1, $$e2 );
- pop @Data_Stack if $ok;
- }
- elsif( $type eq 'SCALAR' ) {
- push @Data_Stack, { type => 'REF', vals => [ $e1, $e2 ] };
- $ok = _deep_check( $$e1, $$e2 );
- pop @Data_Stack if $ok;
- }
- elsif($type) {
- push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] };
- $ok = 0;
- }
- else {
- _whoa( 1, "No type in _deep_check" );
- }
- }
- }
-
- return $ok;
-}
-
-sub _whoa {
- my( $check, $desc ) = @_;
- if($check) {
- die <<"WHOA";
-WHOA! $desc
-This should never happen! Please contact the author immediately!
-WHOA
- }
-}
-
-#line 1556
-
-sub eq_hash {
- local @Data_Stack = ();
- return _deep_check(@_);
-}
-
-sub _eq_hash {
- my( $a1, $a2 ) = @_;
-
- if( grep _type($_) ne 'HASH', $a1, $a2 ) {
- warn "eq_hash passed a non-hash ref";
- return 0;
- }
-
- return 1 if $a1 eq $a2;
-
- my $ok = 1;
- my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2;
- foreach my $k ( keys %$bigger ) {
- my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE;
- my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE;
-
- next if _equal_nonrefs($e1, $e2);
-
- push @Data_Stack, { type => 'HASH', idx => $k, vals => [ $e1, $e2 ] };
- $ok = _deep_check( $e1, $e2 );
- pop @Data_Stack if $ok;
-
- last unless $ok;
- }
-
- return $ok;
-}
-
-#line 1615
-
-sub eq_set {
- my( $a1, $a2 ) = @_;
- return 0 unless @$a1 == @$a2;
-
- no warnings 'uninitialized';
-
- # It really doesn't matter how we sort them, as long as both arrays are
- # sorted with the same algorithm.
- #
- # Ensure that references are not accidentally treated the same as a
- # string containing the reference.
- #
- # Have to inline the sort routine due to a threading/sort bug.
- # See [rt.cpan.org 6782]
- #
- # I don't know how references would be sorted so we just don't sort
- # them. This means eq_set doesn't really work with refs.
- return eq_array(
- [ grep( ref, @$a1 ), sort( grep( !ref, @$a1 ) ) ],
- [ grep( ref, @$a2 ), sort( grep( !ref, @$a2 ) ) ],
- );
-}
-
-#line 1817
-
-1;
@@ -1,27 +1,20 @@
-##
-# name: Module::Compile::Opt
-# abstract: Provide options to Module::Compile
-# author: Ingy döt Net <ingy@ingy.net>
-# license: perl
-# copyright: 2006, 2011
-
+use strict; use warnings;
package Module::Compile::Opt;
-use strict;
-use warnings;
-# use XXX;
-
-sub import {
- my ($class, @args) = @_;
- my $opts = $class->get_options(@args);
- $class->sanity_check($opts);
- require Module::Compile;
- require Module::Compile::Ext;
- Module::Compile::Ext->import(@{$opts->{ext}});
- # put coderef into @INC
- # Store PERL5OPT in .author
- # In Module::Compile, complain if PERL5OPT != .author/PERL5OPT
-}
+# TODO; What is this module for?
+# sub import {
+# my ($class, @args) = @_;
+# my $opts = $class->get_options(@args)
+# if $class->can('get_options');
+# $class->sanity_check($opts);
+# require Module::Compile;
+# require Module::Compile::Ext;
+# Module::Compile::Ext->import(@{$opts->{ext}});
+#
+# # put coderef into @INC
+# # Store PERL5OPT in .author
+# # In Module::Compile, complain if PERL5OPT != .author/PERL5OPT
+# }
sub sanity_check {
my $class = shift;
@@ -29,15 +22,3 @@ sub sanity_check {
}
1;
-
-=head1 SYNOPSIS
-
- > export PERL5OPT=-MModule::Compile::Opt=-ext,p,pm
- > perl -c lib/Foo.p
- > cat lib/Foo.pm
-
-=head1 DESCRIPTION
-
-Module::Compile::Opt allows you to give runtime options to Module::Compile
-By default Module::Compile compiles a module in a C<.pm> file into a C<.pmc>
-file.
@@ -1,3 +1,9 @@
+=pod
+
+=for comment
+DO NOT EDIT. This Pod was generated by Swim v0.1.31.
+See http://github.com/ingydotnet/swim-pm#readme
+
=encoding utf8
=head1 NAME
@@ -12,21 +18,27 @@ Module::Compile::Opt - Provide options to Module::Compile
=head1 DESCRIPTION
-Module::Compile::Opt allows you to give runtime options to Module::Compile
-By default Module::Compile compiles a module in a C<.pm> file into a C<.pmc>
-file.
+module::Compile::Opt allows you to give runtime options to Module::Compile
+By default Module::Compile compiles a module in a C<.pm> file into a
+C<.pmc> file.
+
+=head1 AUTHORS
+
+=over
+
+=item * Ingy döt Net <ingy@cpan.org>
-=head1 AUTHOR
+=item * Audrey Tang <audreyt@audreyt.org>
-Ingy döt Net <ingy@ingy.net>
+=back
-=head1 COPYRIGHT AND LICENSE
+=head1 COPYRIGHT
-Copyright (c) 2006, 2011. Ingy döt Net.
+Copyright 2006-2014. Ingy döt Net.
-This program is free software; you can redistribute it and/or modify it
-under the same terms as Perl itself.
+This program is free software; you can redistribute it and/or modify it under
+the same terms as Perl itself.
-See http://www.perl.com/perl/misc/Artistic.html
+See L<http://www.perl.com/perl/misc/Artistic.html>
=cut
@@ -0,0 +1,79 @@
+=pod
+
+=for comment
+DO NOT EDIT. This Pod was generated by Swim v0.1.31.
+See http://github.com/ingydotnet/swim-pm#readme
+
+=encoding utf8
+
+=head1 NAME
+
+Module::Optimize - Perl Module Optimization
+
+=head1 SYNOPSIS
+
+ package Foo;
+ use Module::Optimize -base;
+
+ sub pmc_optimize {
+ my ($self, $source) = @_;
+ # Convert perl5 $source into semantically equivalent $compiled_output
+ return $compiled_output;
+ }
+
+In C<Bar.pm>:
+
+ package Bar;
+
+ use Foo;
+
+or lexically:
+
+ package Bar;
+
+ {
+ use Foo;
+ ...
+ }
+
+To compile C<Bar.pm> into C<Bar.pmc>:
+
+ perl -c Bar.pm
+
+=head1 DESCRIPTION
+
+This module provides a system for writing modules that I<compile> other
+Perl modules.
+
+Modules that use these compilation modules get compiled into some altered form
+the first time they are run. The result is cached into C<.pmc> files.
+
+Perl has native support for C<.pmc> files. It always checks for them, before
+loading a C<.pm> file.
+
+You get the following benefits:
+
+=head1 SEE ALSO
+
+Module::Compile
+
+=head1 AUTHORS
+
+=over
+
+=item * Ingy döt Net <ingy@cpan.org>
+
+=item * Audrey Tang <audreyt@audreyt.org>
+
+=back
+
+=head1 COPYRIGHT
+
+Copyright 2006-2014. Ingy döt Net.
+
+This program is free software; you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+See L<http://www.perl.com/perl/misc/Artistic.html>
+
+=cut
@@ -1,25 +1,13 @@
-##
-# name: Module::Compile
-# abstract: Perl Module Compilation
-# author:
-# - Ingy döt Net <ingy@ingy.net>
-# - Audrey Tang <autrijus@autrijus.org>
-# license: perl
-# copyright: 2006, 2011
-
# To Do:
#
# - Make preface part of parsed code, since it might contain `package`
# statements or other scoping stuff.
# - Build code into an AST.
-use 5.008003;
+use strict; use warnings;
package Module::Compile;
-use strict;
-use warnings;
-
-our $VERSION = '0.23';
+our $VERSION = '0.35';
-use Digest::SHA1 2.13 ();
+use Digest::SHA1();
# A lexical hash to keep track of which files have already been filtered
my $filtered = {};
@@ -71,8 +59,8 @@ sub unimport {
sub pmc_import {
my ($class, @args) = @_;
- # Handler modules can do C< use Module::Compile -base; >. Make
- # them ISA Module::Compile and get the hell out of Dodge.
+ # Handler modules can do `use Module::Compile -base;`. Make them ISA
+ # Module::Compile and get the hell out of Dodge.
$class->pmc_set_base(@args) and return;
my ($module, $line) = (caller($class->pmc_caller_stack_frame))[1, 2];
@@ -120,7 +108,7 @@ sub pmc_file_caller_frame { 2 }
sub pmc_set_base {
my ($class, $flag) = @_;
- # Handle the C<use Module::Compile -base;> command.
+ # Handle the `use Module::Compile -base;` command.
if ($class->isa(__PACKAGE__) and defined $flag and $flag eq '-base') {
my $descendant = (caller 1)[0];;
no strict 'refs';
@@ -192,7 +180,7 @@ sub pmc_output {
}
return 0;
}
-
+
return 1;
}
@@ -317,7 +305,7 @@ sub pmc_reduce {
shift;
$block->[TEXT] .= $next->[TEXT];
}
- elsif (
+ elsif (
(not $prev or @{$prev->[CLASSES]} < @{$block->[CLASSES]}) and
(not $next or @{$next->[CLASSES]} < @{$block->[CLASSES]})
) {
@@ -383,7 +371,7 @@ sub pmc_parse_blocks {
@classes = grep {$_ ne $klass} @classes;
if (($use eq 'use') xor $klass->pmc_use_means_no) {
push @classes, $klass;
- $context->{$klass} = {%{$context->{$klass} || {}}};
+ $context->{$klass} = {%{$context->{$klass} || {}}};
$context->{$klass}{use} = $part;
if ($klass->pmc_use_means_now) {
push @blocks, ['', {%$context}, [@classes]];
@@ -579,204 +567,3 @@ sub pmc_unfold {
}
1;
-
-=head1 SYNOPSIS
-
- package Foo;
- use Module::Compile -base;
-
- sub pmc_compile {
- my ($class, $source) = @_;
- # Convert $source into (most likely Perl 5) $compiled_output
- return $compiled_output;
- }
-
-In F<Bar.pm>:
-
- package Bar;
-
- use Foo;
- ...
- no Foo
-
-or (implied "no Foo;"):
-
- package Bar;
-
- {
- use Foo;
- ...
- }
-
-To compile F<Bar.pm> into F<Bar.pmc>:
-
- perl -c Bar.pm
-
-=head1 DESCRIPTION
-
-This module provides a system for writing modules that I<compile> other
-Perl modules.
-
-Modules that use these compilation modules get compiled into some
-altered form the first time they are run. The result is cached into
-C<.pmc> files.
-
-Perl has native support for C<.pmc> files. It always checks for them, before
-loading a C<.pm> file.
-
-=head1 EXAMPLE
-
-You can declare a C<v6.pm> compiler with:
-
- package v6;
- use Module::Compile -base;
-
- sub pmc_compile {
- my ($class, $source) = @_;
- # ... some way to invoke pugs and give p5 code back ...
- }
-
-and use it like:
-
- # MyModule.pm
- use v6-pugs;
- module MyModule;
- # ...some p6 code here...
- no v6;
- # ...back to p5 land...
-
-On the first time this module is loaded, it will compile Perl 6
-blocks into Perl 5 (as soon as the C<no v6> line is seen), and
-merge it with the Perl 5 blocks, saving the result into a
-F<MyModule.pmc> file.
-
-The next time around, Perl 5 will automatically load F<MyModule.pmc>
-when someone says C<use MyModule>. On the other hand, Perl 6 can run
-MyModule.pm s a Perl 6 module just fine, as C<use v6-pugs> and C<no v6>
-both works in a Perl 6 setting.
-
-The B<v6.pm> module will also check if F<MyModule.pmc> is up to date. If
-it is, then it will touch its timestamp so the C<.pmc> is loaded on the
-next time.
-
-=head1 BENEFITS
-
-Module::Compile compilers gives you the following benefits:
-
-=over
-
-=item *
-
-Ability to mix many source filterish modules in a much more sane manner.
-Module::Compile controls the compilation process, calling each compiler
-at the right time with the right data.
-
-=item *
-
-Ability to ship precompiled modules without shipping Module::Compile and
-the compiler modules themselves.
-
-=item *
-
-Easier debugging of compiled/filtered code. The C<.pmc> has the real
-code you want to see.
-
-=item *
-
-Zero additional runtime penalty after compilation, because C<perl> has
-already been doing the C<.pmc> check on every module load since 1999!
-
-=back
-
-=head1 PARSING AND DISPATCH
-
-NOTE: *** NOT FULLY IMPLEMENTED YET ***
-
-Module::Compile attempts to make source filtering a sane process, by
-parsing up your module's source code into various blocks; so that by the
-time a compiler is called it only gets the source code that it should be
-looking at.
-
-This section describes the rather complex algorithm that
-Module::Compile uses.
-
-First, the source module is preprocessed to hide heredocs, since the content
-inside heredocs can possibly confuse further parsing.
-
-Next, the source module is divided into a shallow tree of blocks:
-
- PREAMBLE:
- (SUBROUTINE | BAREBLOCK | POD | PLAIN)S
- PACKAGES:
- PREFACE
- (SUBROUTINE | BAREBLOCK | POD | PLAIN)S
- DATA
-
-All of these blocks begin and end on line boundaries. They are described
-as follows:
-
- PREAMBLE - Lines before the first C<package> statement.
- PACKAGES - Lines beginning with a C<package statement and continuing
- until the next C<package> or C<DATA> section.
- DATA - The DATA section. Begins with the line C<__DATA__> or
- C<__END__>.
- SUBROUTINE - A top level (not nested) subroutine. Ending '}' must be
- on its own line in the first column.
- BAREBLOCK - A top level (not nested) code block. Ending '}' must be
- on its own line in the first column.
- POD - Pod sections beginning with C<^=\w+> and ending with C<=cut>.
- PLAIN - Lines not in SUBROUTINE, BAREBLOCK or POD.
- PREFACE - Lines before the first block in a package.
-
-Next, all the blocks are scanned for lines like:
-
- use Foo qw'x y z';
- no Foo;
-
-Where Foo is a Module::Compile subclass.
-
-The lines within a given block between a C<use> and C<no> statement
-are marked to be passed to that compiler. The end of an inner block
-effectively acts as a C<no> statement for any compile sections in
-that block. C<use> statements in a PREFACE apply to all the code in
-a PACKAGE. C<use> statements in a PREAMBLE apply to all the code in
-all PACKAGES.
-
-After all the code has been parsed into blocks and the blocks have been
-marked for various compilers, Module::Compile dispatches the code blocks
-to the compilers. It does so in a most specific to most general order.
-So inner blocks get compiled first, then outer blocks.
-
-A compiler may choose to declare that its result not be recompiled by
-some other containing parser. In this case the result of the compilation
-is replaced by a single line containing the hexadecimal digest of the
-result in double quotes followed by a semicolon. Like:
-
- "f1d2d2f924e986ac86fdf7b36c94bcdf32beec15";
-
-The rationale of this is that randoms strings are usally left alone by
-compilers. After all the compilers have finished, the digest lines will
-be expanded again.
-
-Every bit of the default process described above is overridable by
-various methods.
-
-=head1 DISTRIBUTION SUPPORT
-
-Module::Install makes it terribly easy to prepare a module distribution
-with compiled .pmc files. Module::Compile installs a
-Module::Install::PMC plugin. All you need to do is add this line to your
-Makefile.PL:
-
- pmc_support;
-
-Any of your distrbution's modules that use Module::Compile based modules
-will automatically be compiled into .pmc files and shipped with your
-distribtution precompiled. This means that people who install your
-module distribtution do not need to have the compilers installed
-themselves. So you don't need to make the compiler modules be
-prerequisites.
-
-=head1 SEE ALSO
-
-Module::Install
@@ -1,9 +1,19 @@
+=pod
+
+=for comment
+DO NOT EDIT. This Pod was generated by Swim v0.1.31.
+See http://github.com/ingydotnet/swim-pm#readme
+
=encoding utf8
=head1 NAME
Module::Compile - Perl Module Compilation
+=for html
+<a href="https://travis-ci.org/ingydotnet/module-compile-pm"><img src="https://travis-ci.org/ingydotnet/module-compile-pm.png" alt="module-compile-pm"></a>
+<a href="https://coveralls.io/r/ingydotnet/module-compile-pm?branch=master"><img src="https://coveralls.io/repos/ingydotnet/module-compile-pm/badge.png" alt="module-compile-pm"></a>
+
=head1 SYNOPSIS
package Foo;
@@ -15,10 +25,10 @@ Module::Compile - Perl Module Compilation
return $compiled_output;
}
-In F<Bar.pm>:
-
+In C<Bar.pm>:
+
package Bar;
-
+
use Foo;
...
no Foo
@@ -26,13 +36,13 @@ In F<Bar.pm>:
or (implied "no Foo;"):
package Bar;
-
+
{
use Foo;
...
}
-To compile F<Bar.pm> into F<Bar.pmc>:
+To compile C<Bar.pm> into C<Bar.pmc>:
perl -c Bar.pm
@@ -41,9 +51,8 @@ To compile F<Bar.pm> into F<Bar.pmc>:
This module provides a system for writing modules that I<compile> other
Perl modules.
-Modules that use these compilation modules get compiled into some
-altered form the first time they are run. The result is cached into
-C<.pmc> files.
+Modules that use these compilation modules get compiled into some altered form
+the first time they are run. The result is cached into C<.pmc> files.
Perl has native support for C<.pmc> files. It always checks for them, before
loading a C<.pm> file.
@@ -54,7 +63,7 @@ You can declare a C<v6.pm> compiler with:
package v6;
use Module::Compile -base;
-
+
sub pmc_compile {
my ($class, $source) = @_;
# ... some way to invoke pugs and give p5 code back ...
@@ -69,17 +78,16 @@ and use it like:
no v6;
# ...back to p5 land...
-On the first time this module is loaded, it will compile Perl 6
-blocks into Perl 5 (as soon as the C<no v6> line is seen), and
-merge it with the Perl 5 blocks, saving the result into a
-F<MyModule.pmc> file.
+On the first time this module is loaded, it will compile Perl 6 blocks into
+Perl 5 (as soon as the C<no v6> line is seen), and merge it with the Perl 5
+blocks, saving the result into a C<MyModule.pmc> file.
-The next time around, Perl 5 will automatically load F<MyModule.pmc>
-when someone says C<use MyModule>. On the other hand, Perl 6 can run
-MyModule.pm s a Perl 6 module just fine, as C<use v6-pugs> and C<no v6>
-both works in a Perl 6 setting.
+The next time around, Perl 5 will automatically load C<MyModule.pmc> when
+someone says C<use MyModule>. On the other hand, Perl 6 can run MyModule.pm s
+a Perl 6 module just fine, as C<use v6-pugs> and C<no v6> both works in a Perl
+6 setting.
-The B<v6.pm> module will also check if F<MyModule.pmc> is up to date. If
+The B<v6.pm> module will also check if C<MyModule.pmc> is up to date. If
it is, then it will touch its timestamp so the C<.pmc> is loaded on the
next time.
@@ -89,26 +97,13 @@ Module::Compile compilers gives you the following benefits:
=over
-=item *
-
-Ability to mix many source filterish modules in a much more sane manner.
-Module::Compile controls the compilation process, calling each compiler
-at the right time with the right data.
-
-=item *
+=item * Ability to mix many source filterish modules in a much more sane manner. Module::Compile controls the compilation process, calling each compiler at the right time with the right data.
-Ability to ship precompiled modules without shipping Module::Compile and
-the compiler modules themselves.
+=item * Ability to ship precompiled modules without shipping Module::Compile and the compiler modules themselves.
-=item *
+=item * Easier debugging of compiled/filtered code. The C<.pmc> has the real code you want to see.
-Easier debugging of compiled/filtered code. The C<.pmc> has the real
-code you want to see.
-
-=item *
-
-Zero additional runtime penalty after compilation, because C<perl> has
-already been doing the C<.pmc> check on every module load since 1999!
+=item * Zero additional runtime penalty after compilation, because C<perl> has already been doing the C<.pmc> check on every module load since 1999!
=back
@@ -116,13 +111,11 @@ already been doing the C<.pmc> check on every module load since 1999!
NOTE: *** NOT FULLY IMPLEMENTED YET ***
-Module::Compile attempts to make source filtering a sane process, by
-parsing up your module's source code into various blocks; so that by the
-time a compiler is called it only gets the source code that it should be
-looking at.
+Module::Compile attempts to make source filtering a sane process, by parsing
+up your module's source code into various blocks; so that by the time a
+compiler is called it only gets the source code that it should be looking at.
-This section describes the rather complex algorithm that
-Module::Compile uses.
+This section describes the rather complex algorithm that Module::Compile uses.
First, the source module is preprocessed to hide heredocs, since the content
inside heredocs can possibly confuse further parsing.
@@ -130,27 +123,59 @@ inside heredocs can possibly confuse further parsing.
Next, the source module is divided into a shallow tree of blocks:
PREAMBLE:
- (SUBROUTINE | BAREBLOCK | POD | PLAIN)S
+ (SUBROUTINE | BAREBLOCK | POD | PLAIN)S
PACKAGES:
- PREFACE
- (SUBROUTINE | BAREBLOCK | POD | PLAIN)S
+ PREFACE
+ (SUBROUTINE | BAREBLOCK | POD | PLAIN)S
DATA
All of these blocks begin and end on line boundaries. They are described
as follows:
- PREAMBLE - Lines before the first C<package> statement.
- PACKAGES - Lines beginning with a C<package statement and continuing
- until the next C<package> or C<DATA> section.
- DATA - The DATA section. Begins with the line C<__DATA__> or
- C<__END__>.
- SUBROUTINE - A top level (not nested) subroutine. Ending '}' must be
- on its own line in the first column.
- BAREBLOCK - A top level (not nested) code block. Ending '}' must be
- on its own line in the first column.
- POD - Pod sections beginning with C<^=\w+> and ending with C<=cut>.
- PLAIN - Lines not in SUBROUTINE, BAREBLOCK or POD.
- PREFACE - Lines before the first block in a package.
+=over
+
+=item PREAMBLE
+
+Lines before the first C<package> statement.
+
+=item PACKAGES
+
+Lines beginning with a `package statement and continuing
+
+ until the next `package` or `DATA` section.
+
+=item DATA
+
+The DATA section. Begins with the line C<__DATA__> or
+
+C<__END__>.
+
+=item SUBROUTINE
+
+A top level (not nested) subroutine. Ending '}' must be
+
+on its own line in the first column.
+
+=item BAREBLOCK
+
+A top level (not nested) code block. Ending '}' must be
+
+on its own line in the first column.
+
+=item POD
+
+Pod sections beginning with C<^=\w+> and ending with C<=cut>.
+
+=item PLAIN
+
+Lines not in SUBROUTINE, BAREBLOCK or POD.
+
+=item PREFACE
+
+Lines before the first block in a package.
+
+
+=back
Next, all the blocks are scanned for lines like:
@@ -159,63 +184,73 @@ Next, all the blocks are scanned for lines like:
Where Foo is a Module::Compile subclass.
-The lines within a given block between a C<use> and C<no> statement
-are marked to be passed to that compiler. The end of an inner block
-effectively acts as a C<no> statement for any compile sections in
-that block. C<use> statements in a PREFACE apply to all the code in
-a PACKAGE. C<use> statements in a PREAMBLE apply to all the code in
-all PACKAGES.
+The lines within a given block between a C<use> and C<no> statement are marked
+to be passed to that compiler. The end of an inner block effectively acts as a
+C<no> statement for any compile sections in that block. C<use> statements in a
+PREFACE apply to all the code in a PACKAGE. C<use> statements in a PREAMBLE
+apply to all the code in all PACKAGES.
-After all the code has been parsed into blocks and the blocks have been
-marked for various compilers, Module::Compile dispatches the code blocks
-to the compilers. It does so in a most specific to most general order.
-So inner blocks get compiled first, then outer blocks.
+After all the code has been parsed into blocks and the blocks have been marked
+for various compilers, Module::Compile dispatches the code blocks to the
-A compiler may choose to declare that its result not be recompiled by
-some other containing parser. In this case the result of the compilation
-is replaced by a single line containing the hexadecimal digest of the
-result in double quotes followed by a semicolon. Like:
+ compilers. It does so in a most specific to most general order. So inner
+ blocks get compiled first, then outer blocks.
+
+A compiler may choose to declare that its result not be recompiled by some
+other containing parser. In this case the result of the compilation is
+replaced by a single line containing the hexadecimal digest of the result in
+double quotes followed by a semicolon. Like:
"f1d2d2f924e986ac86fdf7b36c94bcdf32beec15";
The rationale of this is that randoms strings are usally left alone by
-compilers. After all the compilers have finished, the digest lines will
-be expanded again.
+compilers. After all the compilers have finished, the digest lines will be
+expanded again.
Every bit of the default process described above is overridable by
various methods.
=head1 DISTRIBUTION SUPPORT
-Module::Install makes it terribly easy to prepare a module distribution
-with compiled .pmc files. Module::Compile installs a
-Module::Install::PMC plugin. All you need to do is add this line to your
-Makefile.PL:
+Module::Install makes it terribly easy to prepare a module distribution with
+compiled .pmc files. See Module::Install::PMC. All you need to do is add this
+line to your Makefile.PL:
pmc_support;
-Any of your distrbution's modules that use Module::Compile based modules
-will automatically be compiled into .pmc files and shipped with your
-distribtution precompiled. This means that people who install your
-module distribtution do not need to have the compilers installed
-themselves. So you don't need to make the compiler modules be
-prerequisites.
+Any of your distrbution's modules that use Module::Compile based modules will
+automatically be compiled into .pmc files and shipped with your distribtution
+precompiled. This means that people who install your module distribtution do
+not need to have the compilers installed themselves. So you don't need to make
+the compiler modules be prerequisites.
=head1 SEE ALSO
-Module::Install
+=over
+
+=item * L<Module::Install>
+
+=item * L<Module::Install::PMC>
+
+=back
-=head1 AUTHOR
+=head1 AUTHORS
-Ingy döt Net <ingy@ingy.net>
+=over
+
+=item * Ingy döt Net <ingy@cpan.org>
+
+=item * Audrey Tang <audreyt@audreyt.org>
+
+=back
-=head1 COPYRIGHT AND LICENSE
+=head1 COPYRIGHT
-Copyright (c) 2006, 2011. Ingy döt Net.
+Copyright 2006-2014. Ingy döt Net.
-This program is free software; you can redistribute it and/or modify it
-under the same terms as Perl itself.
+This program is free software; you can redistribute it and/or modify it under
+the same terms as Perl itself.
-See http://www.perl.com/perl/misc/Artistic.html
+See L<http://www.perl.com/perl/misc/Artistic.html>
=cut
@@ -1,67 +0,0 @@
-##
-# name: Module::Install::Admin::PMC
-# abstract: Author Support for Perl Compilation (.pmc)
-# author: Ingy döt Net <ingy@ingy.net>
-# license: perl
-# copyright: 2006, 2011
-# see:
-# - Module::Install
-# - Module::Compile
-
-package Module::Install::Admin::PMC;
-
-use strict;
-use Module::Install::Base;
-use File::Basename ();
-
-use vars qw{$VERSION @ISA};
-BEGIN {
- $VERSION = '0.61';
- @ISA = qw{Module::Install::Base};
-}
-
-# Admin support for author side pmc management
-sub pmc_support {
- my $self = shift;
- require File::Find;
-
- # Need to find all the .pm files at `perl Makefile.PL` time
- my @pms = glob('*.pm');
- File::Find::find( sub {
- push @pms, $File::Find::name if /\.pm$/i;
- }, 'lib');
-
- # Then pre-force them to .pmc files (if they do pmc stuff)
- for my $pm (@pms) {
- system("$^X -c $pm")
- unless -e $pm . 'c';
- }
-
- # So we know which files require pmc support in the Makefile.
- my @pmcs = glob('*.pmc');
- File::Find::find( sub {
- push @pmcs, $File::Find::name if /\.pmc$/i;
- }, 'lib');
-
- # Need to refresh all .pmc files before moving them to blib
- # Also provide a PHONY pmc target for `make pmc`
- my $postamble = <<'.';
-config :: pmc
-
-pmc ::
-.
-
- for my $pmc (@pmcs) {
- my $pm = $pmc;
- chop $pm;
- # Add action for `make pmc`
- $postamble .= <<".";
-\t\$(PERL) -c $pm
-.
- }
-
- $self->postamble($postamble)
- if @pms;
-}
-
-1;
@@ -1,34 +0,0 @@
-=encoding utf8
-
-=head1 NAME
-
-Module::Install::Admin::PMC - Author Support for Perl Compilation (.pmc)
-
-=head1 SEE ALSO
-
-=over
-
-=item *
-
-L<Module::Install>
-
-=item *
-
-L<Module::Compile>
-
-=back
-
-=head1 AUTHOR
-
-Ingy döt Net <ingy@ingy.net>
-
-=head1 COPYRIGHT AND LICENSE
-
-Copyright (c) 2006, 2011. Ingy döt Net.
-
-This program is free software; you can redistribute it and/or modify it
-under the same terms as Perl itself.
-
-See http://www.perl.com/perl/misc/Artistic.html
-
-=cut
@@ -1,59 +0,0 @@
-##
-# name: Module::Install::PMC
-# abstract: Support for Perl Compilation (.pmc)
-# author: Ingy döt Net <ingy@ingy.net>
-# license: perl
-# copyright: 2006, 2011
-# see:
-# - Module::Install
-# - Module::Compile
-
-package Module::Install::PMC;
-
-use strict;
-use Module::Install::Base 1.01;
-use File::Basename ();
-
-use vars qw{$VERSION @ISA};
-BEGIN {
- $VERSION = '1.01';
- @ISA = qw{Module::Install::Base};
-}
-
-# Add support on the installer's side to make sure all pmcs have mtime >
-# mtime of .pms.
-sub pmc_support {
- my $self = shift;
- require File::Find;
-
- my $postamble = '';
-
- # This will generate all the .pmcs on the author side.
- $self->admin->pmc_support
- if $self->is_admin;
-
- my @pmcs = glob('*.pmc');
- File::Find::find( sub {
- push @pmcs, $File::Find::name if /\.pmc$/i;
- }, 'lib');
-
- $self->realclean_files("@pmcs");
-
- $postamble .= "\nconfig :: ".join(" ",@pmcs)."\n\n";
-
- for my $pmc (@pmcs) {
- my $pm = $pmc;
- chop($pm);
- $postamble .= <<".";
-$pmc: $pm
-\t-\$(NOECHO) \$(CHMOD) 644 $pmc
-\t-\$(NOECHO) \$(TOUCH) $pmc
-
-.
- }
-
- $self->postamble($postamble)
- if @pmcs;
-}
-
-1;
@@ -1,34 +0,0 @@
-=encoding utf8
-
-=head1 NAME
-
-Module::Install::PMC - Support for Perl Compilation (.pmc)
-
-=head1 SEE ALSO
-
-=over
-
-=item *
-
-L<Module::Install>
-
-=item *
-
-L<Module::Compile>
-
-=back
-
-=head1 AUTHOR
-
-Ingy döt Net <ingy@ingy.net>
-
-=head1 COPYRIGHT AND LICENSE
-
-Copyright (c) 2006, 2011. Ingy döt Net.
-
-This program is free software; you can redistribute it and/or modify it
-under the same terms as Perl itself.
-
-See http://www.perl.com/perl/misc/Artistic.html
-
-=cut
@@ -1,15 +1,6 @@
-##
-# name: Module::Optimize
-# abstract: Perl Module Optimization
-# author:
-# - Audrey Tang <autrijus@autrijus.org>
-# - Ingy döt Net <ingy@ingy.net>
-# license: perl
-# copyright: 2006, 2011
-
+use strict; use warnings;
package Module::Optimize;
-use strict;
-use warnings;
+
use Module::Compile -base;
sub pmc_is_optimizer_module { 1 }
@@ -22,51 +13,3 @@ sub pmc_optimize {
}
1;
-
-=head1 SYNOPSIS
-
- package Foo;
- use Module::Optimize -base;
-
- sub pmc_optimize {
- my ($self, $source) = @_;
- # Convert perl5 $source into semantically equivalent $compiled_output
- return $compiled_output;
- }
-
-In F<Bar.pm>:
-
- package Bar;
-
- use Foo;
-
-or lexically:
-
- package Bar;
-
- {
- use Foo;
- ...
- }
-
-To compile F<Bar.pm> into F<Bar.pmc>:
-
- perl -c Bar.pm
-
-=head1 DESCRIPTION
-
-This module provides a system for writing modules that I<compile> other
-Perl modules.
-
-Modules that use these compilation modules get compiled into some
-altered form the first time they are run. The result is cached into
-C<.pmc> files.
-
-Perl has native support for C<.pmc> files. It always checks for them, before
-loading a C<.pm> file.
-
-You get the following benefits:
-
-=head1 SEE ALSO
-
-Module::Compile
@@ -1,68 +0,0 @@
-=encoding utf8
-
-=head1 NAME
-
-Module::Optimize - Perl Module Optimization
-
-=head1 SYNOPSIS
-
- package Foo;
- use Module::Optimize -base;
-
- sub pmc_optimize {
- my ($self, $source) = @_;
- # Convert perl5 $source into semantically equivalent $compiled_output
- return $compiled_output;
- }
-
-In F<Bar.pm>:
-
- package Bar;
-
- use Foo;
-
-or lexically:
-
- package Bar;
-
- {
- use Foo;
- ...
- }
-
-To compile F<Bar.pm> into F<Bar.pmc>:
-
- perl -c Bar.pm
-
-=head1 DESCRIPTION
-
-This module provides a system for writing modules that I<compile> other
-Perl modules.
-
-Modules that use these compilation modules get compiled into some
-altered form the first time they are run. The result is cached into
-C<.pmc> files.
-
-Perl has native support for C<.pmc> files. It always checks for them, before
-loading a C<.pm> file.
-
-You get the following benefits:
-
-=head1 SEE ALSO
-
-Module::Compile
-
-=head1 AUTHOR
-
-Audrey Tang <autrijus@autrijus.org>
-
-=head1 COPYRIGHT AND LICENSE
-
-Copyright (c) 2006, 2011. Audrey Tang.
-
-This program is free software; you can redistribute it and/or modify it
-under the same terms as Perl itself.
-
-See http://www.perl.com/perl/misc/Artistic.html
-
-=cut
@@ -0,0 +1,19 @@
+# This test does a basic `use` check on all the code.
+use Test::More;
+
+use File::Find;
+
+sub test {
+ s{^lib/(.*)\.pm$}{$1} or return;
+ s{/}{::}g;
+ use_ok $_;
+}
+
+$ENV{PERL_ZILD_TEST_000_COMPILE_MODULES} = 1;
+
+find {
+ wanted => \&test,
+ no_chdir => 1,
+}, 'lib';
+
+done_testing;
@@ -1,11 +1,11 @@
-package t::TestModuleCompile;
+package TestModuleCompile;
use Test::Base -Base;
-use lib 't/lib';
+use lib -e 't' ? 't/lib' : 'test/lib';
use Module::Compile();
-package t::TestModuleCompile::Filter;
+package TestModuleCompile::Filter;
use base 'Test::Base::Filter';
sub process_pm {
@@ -1,4 +1,4 @@
-package t::Testorz;
+package Testorz;
use strict;
use warnings;
@@ -10,7 +10,7 @@ sub pmc_compile {
# orz...\n
$_
pass 'orz was here';
-pass __FILE__;
+pass __FILE__;
_
}
@@ -1,4 +1,5 @@
-use t::TestModuleCompile tests => 2;
+use lib (-e 't' ? 't' : 'test'), 'inc';
+use TestModuleCompile tests => 2;
filters {
perl => 'eval',
@@ -1,10 +1,11 @@
-use t::TestModuleCompile tests => 3;
+my $t; use lib ($t = -e 't' ? 't' : 'test'), 'inc';
+use TestModuleCompile tests => 3;
no_diff;
my $pmc;
BEGIN {
- $pmc = 't/lib/DataTest.pmc';
+ $pmc = "$t/lib/DataTest.pmc";
unlink($pmc);
ok((not -e $pmc), ".pmc doesn't exist yet");
}
@@ -1,8 +1,9 @@
-use t::TestModuleCompile tests => 3;
+my $t; use lib ($t = -e 't' ? 't' : 'test'), 'inc';
+use TestModuleCompile tests => 3;
my $pmc;
BEGIN {
- $pmc = 't/lib/DataTest.pmc';
+ $pmc = "$t/lib/DataTest.pmc";
ok((-e $pmc), ".pmc exists");
}
@@ -14,3 +15,5 @@ local $/;
my $data = <DataTest::DATA>;
is $data, "\none\ntwo\n\nthree\n\n",
"DATA section is correct";
+
+END { unlink "$t/lib/DataTest.pmc" }
@@ -1,4 +1,5 @@
-use t::TestModuleCompile tests => 9;
+use lib (-e 't' ? 't' : 'test'), 'inc';
+use TestModuleCompile tests => 9;
filters({ perl => 'process' });
@@ -1,4 +1,5 @@
-use t::TestModuleCompile tests => 1;
+use lib (-e 't' ? 't' : 'test'), 'inc';
+use TestModuleCompile tests => 1;
no_diff;
filters {
@@ -1,18 +1,21 @@
# BEGIN { unlink 't/orz.tc' }
-# Need to incoke Module::Compile before Test::More
+# Need to invoke Module::Compile before Test::More
+my $t; use lib ($t = -e 't' ? 't' : 'test'), 'inc';
use Module::Compile;
use Test::More tests => 5;
pass "Test runs";
-ok ((-f 't/orz.tc'), "Compiled file exists");
+ok ((-f "$t/orz.tc"), "Compiled file exists");
-use t::Testorz;
+use Testorz;
fail "don't want this to run";
-no t::Testorz;
+no Testorz;
pass "Second half of test runs";
+
+END { unlink "$t/orz.tc" }
@@ -1,4 +1,5 @@
-use t::TestModuleCompile tests => 1;
+use lib (-e 't' ? 't' : 'test'), 'inc';
+use TestModuleCompile tests => 1;
SKIP: {
eval "require YAML";
@@ -1,17 +1,23 @@
-use t::TestModuleCompile skip_all => 'In progress...'; # tests => 1;
+my $t; use lib ($t = -e 't' ? 't' : 'test'), 'inc';
+use TestModuleCompile skip_all => 'In progress...'; # tests => 1;
BEGIN { $ENV{PERL5OPT} = '-MModule::Compile=-ext,p,pm' };
pass('foo');
-use lib 't/lib';
+use lib "$t/lib";
-BEGIN { unlink 't/lib/Pre.pm' }
+BEGIN { unlink "$t/lib/Pre.pm" }
use Pre;
run_is module => 'pm';
+sub fixpath {
+ s/t/$t/;
+ return $_;
+}
+
sub fixup {
s/0\.\d\d/0.XX/;
s/0x[0-9A-Fa-f]{4,8}/0xXXXXXXXX/;
@@ -19,7 +25,7 @@ sub fixup {
__DATA__
=== Compile Foo.p to Foo.pm
---- module read_file fixup: t/lib/Foo.pm
+--- module fixpath read_file fixup: t/lib/Foo.pm
--- pm -trim
# Generated by Indented 0 (Module::Compile 0.XX) - do not edit!
################((( 32-bit Checksum Validator III )))################
@@ -1,21 +1,29 @@
-use t::TestModuleCompile tests => 1;
+my $t; use lib ($t = -e 't' ? 't' : 'test'), 'inc';
+use TestModuleCompile tests => 1;
-use lib 't/lib';
+use lib "$t/lib";
-BEGIN { unlink 't/lib/Foo.pmc' }
+BEGIN { unlink "$t/lib/Foo.pmc" }
use Foo;
run_is module => 'pmc';
+sub fixpath {
+ s/t/$t/;
+ return $_;
+}
+
sub fixup {
s/0\.\d\d/0.XX/;
s/0x[0-9A-Fa-f]{4,8}/0xXXXXXXXX/;
}
+END { unlink "$t/lib/Foo.pmc" }
+
__DATA__
=== Compile Foo.pm to Foo.pmc
---- module read_file fixup: t/lib/Foo.pmc
+--- module fixpath read_file fixup: t/lib/Foo.pmc
--- pmc -trim
# Generated by Indented 0 (Module::Compile 0.XX) - do not edit!
################((( 32-bit Checksum Validator III )))################
@@ -0,0 +1,14 @@
+#!perl
+
+BEGIN {
+ unless ($ENV{RELEASE_TESTING}) {
+ require Test::More;
+ Test::More::plan(skip_all => 'these tests are for release candidate testing');
+ }
+}
+
+# This file was automatically generated by Dist::Zilla::Plugin::PodSyntaxTests.
+use Test::More;
+use Test::Pod 1.41;
+
+all_pod_files_ok();