@@ -0,0 +1,60 @@
+Contributing
+============
+
+The "Template-Toolkit-Simple" 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/template-toolkit-simple-pm
+
+You can get the code with this command:
+
+ git clone https://github.com/ingydotnet/template-toolkit-simple-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/template-toolkit-simple-pm/issues
+
+or fix it and submit a pull request here:
+
+ https://github.com/ingydotnet/template-toolkit-simple-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
+---
+
+Template-Toolkit-Simple has an IRC channel where you can find real people to help you:
+
+ irc.freenode.net#pkg
+
+Join the channel. Join the team!
+
+
+ Thanks in advance, Ingy döt net
+
+
+
+
+
+# This file generated by Zilla-Dist-0.0.174
@@ -1,82 +1,99 @@
----
-version: 0.16
-date: Mon Nov 7 18:49:56 PST 2011
-changes:
-- Anthony Cornehl++ implemented JSON and XML support. \o/
----
-version: 0.15
-date: Sat Nov 5 01:09:40 PDT 2011
-changes:
-- Use fixed TestML
----
-version: 0.14
-date: Fri Oct 21 18:31:56 PDT 2011
-changes:
-- Use Module::Package
-- Add strict support
----
-version: 0.13
-date: Sun May 15 17:08:56 EST 2011
-changes:
-- Use Stardoc
-- use Package
----
-version: 0.12
-date: Sun May 15 12:46:44 EST 2011
-changes:
-- Forgot to 'use Encode'. doh!
----
-version: 0.11
-date: Sun May 15 12:11:50 EST 2011
-changes:
-- Finally works with utf8 templates and yaml. \o/
----
-version: 0.10
-date: Mon Nov 29 09:58:35 EST 2010
-changes:
-- Skip tests if YAML::XS not installed.
----
-version: 0.08
-date: Wed Sep 15 00:08:41 PDT 2010
-changes:
-- Remove old Test::Base subclass
-- Update copyright dates
----
-version: 0.07
-date: Tue Sep 14 23:06:07 PDT 2010
-changes:
-- Switched testing from Test::Base to TestML
-- 0.04 - 0.06 never made it to CPAN :\
-- Added new toys to Makefile.PL
----
-version: 0.06
-date: Mon Apr 27 16:57:55 PDT 2009
-changes:
-- Encode stuff was a mistake. Reverting.
----
-version: 0.05
-date: Sun Apr 26 19:06:13 PDT 2009
-changes:
-- Add usage text for command line help.
-- Fixed utf8 encoding. Hopefully.
----
-version: 0.04
-date: Fri Nov 7 14:44:23 PST 2008
-changes:
-- Support start_tag and end_tag.
----
-version: 0.03
-date: Mon Oct 27 17:02:25 PDT 2008
-changes:
-- Make api tt->(template, data, output); # added output.
----
-version: 0.02
-date: Sat Oct 25 17:47:04 PDT 2008
-changes:
-- Make all TT options work.
-- Support path//template shorcut syntax.
----
-version: 0.01
-date: Fri Sep 26 01:40:13 PDT 2008
-changes:
-- First Release
+0.31 Tue Dec 9 08:39:08 PST 2014
+ - Remove "use lib 'lib';". GitHub Issue
+
+0.30 Sat Aug 16 16:47:08 PDT 2014
+ - Change testdir to t
+
+0.29 Sat Aug 16 14:24:12 PDT 2014
+ - Remove =travis section
+
+0.28 Sat Aug 16 12:29:34 PDT 2014
+ - Meta 0.0.2
+
+0.27 Sat Aug 16 04:08:54 PDT 2014
+ - Eliminate spurious trailing whitespace
+
+0.26 Fri Aug 15 21:31:26 PDT 2014
+ - Remove t/use_ok.t
+
+0.25 Fri Aug 15 20:48:08 PDT 2014
+ - Add t/000-compile-modules.t
+
+0.24 Fri Aug 8 19:03:02 PDT 2014
+ - Fix bug of using a bad TestMLIncluder.
+
+0.23 Fri Aug 8 12:58:46 PDT 2014
+ - Switch hashbang to '#!/usr/bin/env perl'
+
+0.22 Tue Aug 5 11:23:13 PDT 2014
+ - Change IRC channel to irc.freenode.net#pkg
+
+0.21 Tue Aug 5 10:14:59 PDT 2014
+ - Add badges to doc
+
+0.20 Mon Aug 4 00:35:28 PDT 2014
+ - Remove (c) from Copyright
+ - Move doc to swim
+ - Fix Meta and add Contributing
+
+0.19 Wed Jun 18 11:23:29 PDT 2014
+ - Tests using TestML needed 'inc'
+
+0.18 Mon Jun 16 15:46:07 PDT 2014
+ - Switch to manual versioning
+
+0.17 Sun Jun 15 12:04:29 PDT 2014
+ - Move to Zilla::Dist
+
+0.16 Mon Nov 7 18:49:56 PST 2011
+ - Anthony Cornehl++ implemented JSON and XML support. \o/
+
+0.15 Sat Nov 5 01:09:40 PDT 2011
+ - Use fixed TestML
+
+0.14 Fri Oct 21 18:31:56 PDT 2011
+ - Use Module::Package
+ - Add strict support
+
+0.13 Sun May 15 17:08:56 EST 2011
+ - Use Stardoc
+ - use Package
+
+0.12 Sun May 15 12:46:44 EST 2011
+ - Forgot to 'use Encode'. doh!
+
+0.11 Sun May 15 12:11:50 EST 2011
+ - Finally works with utf8 templates and yaml. \o/
+
+0.10 Mon Nov 29 09:58:35 EST 2010
+ - Skip tests if YAML::XS not installed.
+
+0.08 Wed Sep 15 00:08:41 PDT 2010
+ - Remove old Test::Base subclass
+ - Update copyright dates
+
+0.07 Tue Sep 14 23:06:07 PDT 2010
+ - Switched testing from Test::Base to TestML
+ - 0.04 - 0.06 never made it to CPAN :\
+ - Added new toys to Makefile.PL
+
+0.06 Mon Apr 27 16:57:55 PDT 2009
+ - Encode stuff was a mistake. Reverting.
+
+0.05 Sun Apr 26 19:06:13 PDT 2009
+ - Add usage text for command line help.
+ - Fixed utf8 encoding. Hopefully.
+
+0.04 Fri Nov 7 14:44:23 PST 2008
+ - Support start_tag and end_tag.
+
+0.03 Mon Oct 27 17:02:25 PDT 2008
+ - Make api tt->(template, data, output);
+
+0.02 Sat Oct 25 17:47:04 PDT 2008
+ - Make all TT options work.
+ - Support path//template shorcut syntax.
+
+0.01 Fri Sep 26 01:40:13 PDT 2008
+ - First Release
+
@@ -1,4 +1,4 @@
-This software is copyright (c) 2011 by Ingy döt Net <ingy@cpan.org>.
+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,7 +12,7 @@ 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@cpan.org>.
+This software is Copyright (c) 2014 by Ingy döt net.
This is free software, licensed under:
@@ -22,7 +22,7 @@ This is free software, licensed under:
Version 1, February 1989
Copyright (C) 1989 Free Software Foundation, Inc.
- 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 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.
@@ -272,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@cpan.org>.
+This software is Copyright (c) 2014 by Ingy döt net.
This is free software, licensed under:
@@ -1,40 +1,41 @@
-bin/tt-render
+# This file was automatically generated by Dist::Zilla::Plugin::Manifest v5.019.
+CONTRIBUTING
Changes
-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/Scripts.pm
-inc/Module/Install/Win32.pm
-inc/Module/Install/WriteAll.pm
-inc/Module/Package.pm
+LICENSE
+MANIFEST
+META.json
+META.yml
+Makefile.PL
+README
+bin/tt-render
+inc/Pegex.pm
+inc/Pegex/Base.pm
+inc/Pegex/Bootstrap.pm
+inc/Pegex/Compiler.pm
inc/Pegex/Grammar.pm
inc/Pegex/Input.pm
-inc/Pegex/Mo.pm
+inc/Pegex/Optimizer.pm
inc/Pegex/Parser.pm
inc/Pegex/Receiver.pm
+inc/Pegex/Tree.pm
inc/TestML.pm
-inc/TestML/AST.pm
+inc/TestML/Base.pm
+inc/TestML/Bridge.pm
inc/TestML/Compiler.pm
-inc/TestML/Grammar.pm
+inc/TestML/Compiler/Lite.pm
+inc/TestML/Compiler/Pegex.pm
+inc/TestML/Compiler/Pegex/AST.pm
+inc/TestML/Compiler/Pegex/Grammar.pm
inc/TestML/Library/Debug.pm
inc/TestML/Library/Standard.pm
-inc/TestML/Mo.pm
inc/TestML/Runtime.pm
inc/TestML/Runtime/TAP.pm
+inc/TestML/Util.pm
lib/Template/Toolkit/Simple.pm
lib/Template/Toolkit/Simple.pod
-LICENSE
-Makefile.PL
-MANIFEST This list of files
-META.yml
-README
+t/000-compile-modules.t
t/cli.t
+t/release-pod-syntax.t
t/render.json
t/render.xml
t/render.yaml
@@ -43,4 +44,3 @@ t/render_xml.t
t/render_yaml.t
t/template/letter.tt
t/template/signature.tt
-t/use_ok.t
@@ -0,0 +1,61 @@
+{
+ "abstract" : "A Simple Interface to Template Toolkit",
+ "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" : "Template-Toolkit-Simple",
+ "no_index" : {
+ "directory" : [
+ "inc",
+ "t",
+ "xt",
+ "example"
+ ]
+ },
+ "prereqs" : {
+ "configure" : {
+ "requires" : {
+ "ExtUtils::MakeMaker" : "6.30"
+ }
+ },
+ "develop" : {
+ "requires" : {
+ "Test::Pod" : "1.41"
+ }
+ },
+ "runtime" : {
+ "recommends" : {
+ "JSON::XS" : "0",
+ "XML::Simple" : "0"
+ },
+ "requires" : {
+ "Template" : "2.22",
+ "YAML::XS" : "0.37",
+ "perl" : "v5.8.1"
+ }
+ }
+ },
+ "release_status" : "stable",
+ "resources" : {
+ "bugtracker" : {
+ "web" : "https://github.com/ingydotnet/template-toolkit-simple-pm/issues"
+ },
+ "homepage" : "https://github.com/ingydotnet/template-toolkit-simple-pm",
+ "repository" : {
+ "type" : "git",
+ "url" : "https://github.com/ingydotnet/template-toolkit-simple-pm.git",
+ "web" : "https://github.com/ingydotnet/template-toolkit-simple-pm"
+ }
+ },
+ "version" : "0.31"
+}
+
@@ -1,32 +1,32 @@
---
abstract: 'A Simple Interface to Template Toolkit'
author:
- - 'Ingy döt Net <ingy@cpan.org>'
-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.02'
+ 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: Template::Toolkit::Simple
+ version: '1.4'
name: Template-Toolkit-Simple
no_index:
directory:
- inc
- t
+ - xt
+ - example
+recommends:
+ JSON::XS: '0'
+ XML::Simple: '0'
requires:
- Template: 2.22
- YAML::XS: 0.37
- perl: 5.8.3
+ Template: '2.22'
+ YAML::XS: '0.37'
+ perl: v5.8.1
resources:
- homepage: https://github.com/ingydotnet/template-toolkit-simple-pm/tree
- license: http://dev.perl.org/licenses/
- repository:
- type: git
- url: git://github.com/ingydotnet/template-toolkit-simple-pm.git
- web: https://github.com/ingydotnet/template-toolkit-simple-pm/tree
-version: 0.16
+ bugtracker: https://github.com/ingydotnet/template-toolkit-simple-pm/issues
+ homepage: https://github.com/ingydotnet/template-toolkit-simple-pm
+ repository: https://github.com/ingydotnet/template-toolkit-simple-pm.git
+version: '0.31'
@@ -1 +1,53 @@
-use inc::Module::Package 'Ingy:modern 0.17';
+
+# 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" => "A Simple Interface to Template Toolkit",
+ "AUTHOR" => "Ingy d\x{f6}t net <ingy\@cpan.org>",
+ "CONFIGURE_REQUIRES" => {
+ "ExtUtils::MakeMaker" => "6.30"
+ },
+ "DISTNAME" => "Template-Toolkit-Simple",
+ "EXE_FILES" => [
+ "bin/tt-render"
+ ],
+ "LICENSE" => "perl",
+ "NAME" => "Template::Toolkit::Simple",
+ "PREREQ_PM" => {
+ "Template" => "2.22",
+ "YAML::XS" => "0.37"
+ },
+ "VERSION" => "0.31",
+ "test" => {
+ "TESTS" => "t/*.t"
+ }
+);
+
+
+my %FallbackPrereqs = (
+ "Template" => "2.22",
+ "YAML::XS" => "0.37"
+);
+
+
+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);
+
+
+
@@ -2,17 +2,17 @@ NAME
Template::Toolkit::Simple - A Simple Interface to Template Toolkit
SYNOPSIS
- use Template::Toolkit::Simple;
+ use Template::Toolkit::Simple;
- print tt
- ->path(['./', 'template/'])
- ->data('values.yaml')
- ->post_chomp
- ->render('foo.tt');
+ print tt
+ ->path(['./', 'template/'])
+ ->data('values.yaml')
+ ->post_chomp
+ ->render('foo.tt');
or from the command line:
- tt-render --path=./:template/ --data=values.yaml --post-chomp foo.tt
+ tt-render --path=./:template/ --data=values.yaml --post-chomp foo.tt
DESCRIPTION
Template Toolkit is the best Perl template framework. The only problem
@@ -96,7 +96,7 @@ METHODS
OPTION METHODS
All of the Template Toolkit options are available as methods to
Template::Toolkit::Simple objects, and also as command line options to
- the "tt-render" command.
+ the "tt- render" command.
For example, the "POST_CHOMP" options is available in the following
ways:
@@ -113,7 +113,7 @@ OPTION METHODS
If the method functionality is not explained below, please refer to
Template.
- config($file_name || $hash)
+ "config($file_name || $hash)"
If you have a common set of Template Toolkit options stored in a
file, you can use this method to read and parse the file, and set
the appropriate options.
@@ -123,7 +123,7 @@ OPTION METHODS
one. Note that XML::Simple is used to parse XML files and JSON::XS
is used to parse JSON files.
- data($file_name || $hash)
+ "data($file_name || $hash)"
Most templates use a hash object of data to access values while
rendering. You can specify this data in a file or with a hash
reference.
@@ -132,58 +132,113 @@ OPTION METHODS
format is determined by the file extension, so use the appropriate
one. Note the XML::Simple is used to parse XML files.
- include_path($template_directories) -- Default is undef
+ "include_path($template_directories)"
+ Default is undef
+
This method allows you to specify the directories that are searched
to find templates. You can specify this as a string containing a
single directory, an array ref of strings containing directory
names, or as a string containing multiple directories separated by
':'.
- path() -- Default is undef
+ "path()"
+ Default is undef
+
This is a shorter name for "include_path". It does the exact same
thing.
- start_tag() -- Default is '[%'
- end_tag() -- Default is '%]'
- tag_style() -- Default is 'template'
- pre_chomp() -- Default is 0
- post_chomp() -- Default is 0
- trim() -- Default is 0
- interpolate() -- Default is 0
- anycase() -- Default is 0
- delimiter() -- Default is ':'
- absolute() -- Default is 0
- relative() -- Default is 0
- strict() -- Default is 0
- default() -- Default is undef
- blocks() -- Default is undef
- auto_reset() -- Default is 1
- recursion() -- Default is 0
- eval_perl() -- Default is 0
- pre_process() -- Default is undef
- post_process() -- Default is undef
- process_template() -- Default is undef
+ "start_tag()"
+ Default is '[%'
+
+ "end_tag()"
+ Default is '%]'
+
+ "tag_style()"
+ Default is 'template'
+
+ "pre_chomp()"
+ Default is 0
+
+ "post_chomp()"
+ Default is 0
+
+ "trim()"
+ Default is 0
+
+ "interpolate()"
+ Default is 0
+
+ "anycase()"
+ Default is 0
+
+ "delimiter()"
+ Default is ':'
+
+ "absolute()"
+ Default is 0
+
+ "relative()"
+ Default is 0
+
+ "strict()"
+ Default is 0
+
+ "default()"
+ Default is undef
+
+ "blocks()"
+ Default is undef
+
+ "auto_reset()"
+ Default is 1
+
+ "recursion()"
+ Default is 0
+
+ "eval_perl()"
+ Default is 0
+
+ "pre_process()"
+ Default is undef
+
+ "post_process()"
+ Default is undef
+
+ "process_template()"
+ Default is undef
+
This is a proxy to the Template Toolkit PROCESS option. The
"process" method is used to actually process a template.
- error_template() -- Default is undef
+ "error_template()"
+ Default is undef
+
This is a proxy to the Template Toolkit ERROR option. The "error()"
method returns the error message on a failure.
- debug() -- Default is 0
- cache_size() -- Default is undef
- compile_ext() -- Default is undef
- compile_dir() -- Default is undef
- encoding() -- Default is 'utf8'
+ "debug()"
+ Default is 0
+
+ "cache_size()"
+ Default is undef
+
+ "compile_ext()"
+ Default is undef
+
+ "compile_dir()"
+ Default is undef
+
+ "encoding()"
+ Default is 'utf8'
AUTHOR
Ingy döt Net <ingy@cpan.org>
COPYRIGHT AND LICENSE
- Copyright (c) 2008, 2009, 2010, 2011. Ingy döt Net.
+ Copyright 2008-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,6 +1,5 @@
-#!/usr/bin/perl
+#!/usr/bin/env perl
-use lib 'lib';
use Template::Toolkit::Simple;
Template::Toolkit::Simple->_run_command(@ARGV);
@@ -1,83 +0,0 @@
-#line 1
-package Module::Install::Base;
-
-use strict 'vars';
-use vars qw{$VERSION};
-BEGIN {
- $VERSION = '1.02';
-}
-
-# 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.02';
- @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.02';
- @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,57 +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.16';
-
-sub githubmeta {
- my $self = shift;
- return unless $Module::Install::AUTHOR;
- return unless _under_git();
- return unless $self->can_run('git');
- my $remote = shift || 'origin';
- return unless my ($git_url) = `git remote show -n $remote` =~ /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\-]+\@([^:]+):!https://$1/!;
- $http_url =~ s!\.git$!/tree!;
- $self->repository(
- {
- type => 'git',
- url => $git_url,
- web => $http_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 117
@@ -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.02';
- @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.02';
- @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.02';
- @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,323 +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.30';
-
-#-----------------------------------------------------------------------------#
-# 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;
-my $module_package_dist_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);
- }
- else {
- $module_package_dist_plugin = $self->_load_dist_plugin($plugin_spec);
- $module_package_dist_plugin->mi($module_install_plugin) if ref $module_package_dist_plugin;
- }
- # 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_package_dist_plugin->_initial() if ref $module_package_dist_plugin;
- $module_install_plugin->_main();
- $module_package_dist_plugin->_main() if ref $module_package_dist_plugin;
- }
- };
- 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;
- }
- : do {
- $module_install_plugin->_final;
- $module_package_dist_plugin->_final() if ref $module_package_dist_plugin;
- }
- }
-}
-
-# 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, $namespace) = @_;
- $spec ||= '';
- $namespace ||= 'Module::Package';
- 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 = "${namespace}::${module}";
- $plugin = "${namespace}::${plugin}";
- eval "use $module $version (); 1" or die $@;
- return $plugin->new();
-}
-
-# Find and load the user side plugin:
-sub _load_dist_plugin {
- my ($self, $spec, $namespace) = @_;
- $spec ||= '';
- $namespace ||= 'Module::Package::Dist';
- my $r = eval { $self->_load_plugin($spec, $namespace); };
- return $r if ref $r;
- return;
-}
-
-#-----------------------------------------------------------------------------#
-# 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(@_);
-}
-
-# Base package for Module::Package plugin distributed components.
-package Module::Package::Dist;
-
-sub new {
- my ($class, %args) = @_;
- bless \%args, $class;
-}
-
-sub mi {
- @_ > 1 ? ($_[0]->{mi}=$_[1]) : $_[0]->{mi};
-}
-
-sub _initial {
- my ($self) = @_;
-}
-
-sub _main {
- my ($self) = @_;
-}
-
-sub _final {
- my ($self) = @_;
-}
-
-1;
-
-#-----------------------------------------------------------------------------#
-# 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";
- }
- my $pmc = $pm . 'c';
- $pm = $pmc if -e $pmc;
- $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 "Module::Package's \$main::PM value should end in '.pm'";
- return -e $pod ? $pod : '';
-};
-sub set { $_[0][0] = $_[1] }
-$main::POD = bless [$main::POD ? ($main::POD) : ()], __PACKAGE__;
-
-1;
-
@@ -1,29 +0,0 @@
-#line 1
-package Module::Install::Scripts;
-
-use strict 'vars';
-use Module::Install::Base ();
-
-use vars qw{$VERSION @ISA $ISCORE};
-BEGIN {
- $VERSION = '1.02';
- @ISA = 'Module::Install::Base';
- $ISCORE = 1;
-}
-
-sub install_script {
- my $self = shift;
- my $args = $self->makemaker_args;
- my $exe = $args->{EXE_FILES} ||= [];
- foreach ( @_ ) {
- if ( -f $_ ) {
- push @$exe, $_;
- } elsif ( -d 'script' and -f "script/$_" ) {
- push @$exe, "script/$_";
- } else {
- die("Cannot find script '$_'");
- }
- }
-}
-
-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.02';
- @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.02';
- @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.02';
-
- # 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.30';
- $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;
-
@@ -0,0 +1,9 @@
+package Pegex::Base;
+# use Mo qw'build default builder xxx import nonlazy required';
+# The following line of code was produced from the previous line by
+# Mo::Inline version 0.39
+no warnings;my$M=__PACKAGE__.'::';*{$M.Object::new}=sub{my$c=shift;my$s=bless{@_},$c;my%n=%{$c.'::'.':E'};map{$s->{$_}=$n{$_}->()if!exists$s->{$_}}keys%n;$s};*{$M.import}=sub{import warnings;$^H|=1538;my($P,%e,%o)=caller.'::';shift;eval"no Mo::$_",&{$M.$_.::e}($P,\%e,\%o,\@_)for@_;return if$e{M};%e=(extends,sub{eval"no $_[0]()";@{$P.ISA}=$_[0]},has,sub{my$n=shift;my$m=sub{$#_?$_[0]{$n}=$_[1]:$_[0]{$n}};@_=(default,@_)if!($#_%2);$m=$o{$_}->($m,$n,@_)for sort keys%o;*{$P.$n}=$m},%e,);*{$P.$_}=$e{$_}for keys%e;@{$P.ISA}=$M.Object};*{$M.'build::e'}=sub{my($P,$e)=@_;$e->{new}=sub{$c=shift;my$s=&{$M.Object::new}($c,@_);my@B;do{@B=($c.::BUILD,@B)}while($c)=@{$c.::ISA};exists&$_&&&$_($s)for@B;$s}};*{$M.'default::e'}=sub{my($P,$e,$o)=@_;$o->{default}=sub{my($m,$n,%a)=@_;exists$a{default}or return$m;my($d,$r)=$a{default};my$g='HASH'eq($r=ref$d)?sub{+{%$d}}:'ARRAY'eq$r?sub{[@$d]}:'CODE'eq$r?$d:sub{$d};my$i=exists$a{lazy}?$a{lazy}:!${$P.':N'};$i or ${$P.':E'}{$n}=$g and return$m;sub{$#_?$m->(@_):!exists$_[0]{$n}?$_[0]{$n}=$g->(@_):$m->(@_)}}};*{$M.'builder::e'}=sub{my($P,$e,$o)=@_;$o->{builder}=sub{my($m,$n,%a)=@_;my$b=$a{builder}or return$m;my$i=exists$a{lazy}?$a{lazy}:!${$P.':N'};$i or ${$P.':E'}{$n}=\&{$P.$b}and return$m;sub{$#_?$m->(@_):!exists$_[0]{$n}?$_[0]{$n}=$_[0]->$b:$m->(@_)}}};use constant XXX_skip=>1;my$dm='YAML::XS';*{$M.'xxx::e'}=sub{my($P,$e)=@_;$e->{WWW}=sub{require XXX;local$XXX::DumpModule=$dm;XXX::WWW(@_)};$e->{XXX}=sub{require XXX;local$XXX::DumpModule=$dm;XXX::XXX(@_)};$e->{YYY}=sub{require XXX;local$XXX::DumpModule=$dm;XXX::YYY(@_)};$e->{ZZZ}=sub{require XXX;local$XXX::DumpModule=$dm}};my$i=\&import;*{$M.import}=sub{(@_==2 and not$_[1])?pop@_:@_==1?push@_,grep!/import/,@f:();goto&$i};*{$M.'nonlazy::e'}=sub{${shift().':N'}=1};*{$M.'required::e'}=sub{my($P,$e,$o)=@_;$o->{required}=sub{my($m,$n,%a)=@_;if($a{required}){my$C=*{$P."new"}{CODE}||*{$M.Object::new}{CODE};no warnings 'redefine';*{$P."new"}=sub{my$s=$C->(@_);my%a=@_[1..$#_];die$n." required"if!exists$a{$n};$s}}$m}};@f=qw[build default builder xxx import nonlazy required];use strict;use warnings;
+
+our $DumpModule = 'YAML';
+
+1;
@@ -0,0 +1,546 @@
+package Pegex::Bootstrap;
+use Pegex::Base;
+extends 'Pegex::Compiler';
+
+use Pegex::Grammar::Atoms;
+use Pegex::Pegex::AST;
+
+use Carp qw(carp confess croak);
+
+#------------------------------------------------------------------------------
+# The grammar. A DSL data structure. Things with '=' are tokens.
+#------------------------------------------------------------------------------
+has pointer => 0;
+has groups => [];
+has tokens => [];
+has ast => {};
+has stack => [];
+has tree => {};
+has grammar => {
+ 'grammar' => [
+ '=pegex-start',
+ 'meta-section',
+ 'rule-section',
+ '=pegex-end',
+ ],
+ 'meta-section' => 'meta-directive*',
+ 'meta-directive' => [
+ '=directive-start',
+ '=directive-value',
+ '=directive-end',
+ ],
+ 'rule-section' => 'rule-definition*',
+ 'rule-definition' => [
+ '=rule-start',
+ '=rule-sep',
+ 'rule-group',
+ '=rule-end',
+ ],
+ 'rule-group' => 'any-group',
+ 'any-group' => [
+ '=list-alt?',
+ 'all-group',
+ [
+ '=list-alt',
+ 'all-group',
+ '*',
+ ],
+ ],
+ 'all-group' => 'rule-part+',
+ 'rule-part' => [
+ 'rule-item',
+ [
+ '=list-sep',
+ 'rule-item',
+ '?',
+ ],
+ ],
+ 'rule-item' => [
+ '|',
+ '=rule-reference',
+ '=quoted-regex',
+ 'regular-expression',
+ 'bracketed-group',
+ 'whitespace-token',
+ '=error-message',
+ ],
+ 'regular-expression' => [
+ '=regex-start',
+ '=!regex-end*',
+ '=regex-end',
+ ],
+ 'bracketed-group' => [
+ '=group-start',
+ 'rule-group',
+ '=group-end',
+ ],
+ 'whitespace-token' => [
+ '|',
+ '=whitespace-maybe',
+ '=whitespace-must',
+ ],
+};
+
+#------------------------------------------------------------------------------
+# Parser logic:
+#------------------------------------------------------------------------------
+sub parse {
+ my ($self, $grammar_text) = @_;
+
+ $self->lex($grammar_text);
+ # YYY $self->{tokens};
+ $self->{pointer} = 0;
+ $self->{farthest} = 0;
+ $self->{tree} = {};
+
+ $self->match_ref('grammar') || do {
+ my $far = $self->{farthest};
+ my $tokens = $self->{tokens};
+ $far -= 4 if $far >= 4;
+ WWW splice @$tokens, $far, 9;
+ die "Bootstrap parse failed";
+ };
+ # XXX $self->{tree};
+
+ return $self;
+}
+
+sub match_next {
+ my ($self, $next) = @_;
+ my $method;
+ if (ref $next) {
+ $next = [@$next];
+ if ($next->[0] eq '|') {
+ shift @$next;
+ $method = 'match_any';
+ }
+ else {
+ $method = 'match_all';
+ }
+ if ($next->[-1] =~ /^[\?\*\+]$/) {
+ my $quant = pop @$next;
+ return $self->match_times($quant, $method => $next);
+ }
+ else {
+ return $self->$method($next);
+ }
+ }
+ else {
+ $method = ($next =~ s/^=//) ? 'match_token' : 'match_ref';
+ if ($next =~ s/([\?\*\+])$//) {
+ return $self->match_times($1, $method => $next);
+ }
+ else {
+ return $self->$method($next);
+ }
+ }
+}
+
+sub match_times {
+ my ($self, $quantity, $method, @args) = @_;
+ my ($min, $max) =
+ $quantity eq '' ? (1, 1) :
+ $quantity eq '?' ? (0, 1) :
+ $quantity eq '*' ? (0, 0) :
+ $quantity eq '+' ? (1, 0) : die "Bad quantity '$quantity'";
+ my $stop = $max || 9999;
+ my $count = 0;
+ my $pointer = $self->{pointer};
+ while ($stop-- and $self->$method(@args)) {
+ $count++;
+ }
+ return 1 if $count >= $min and (not $max or $count <= $max);
+ $self->{pointer} = $pointer;
+ $self->{farthest} = $pointer if $pointer > $self->{farthest};
+ return;
+}
+
+sub match_any {
+ my ($self, $any) = @_;
+ my $pointer = $self->{pointer};
+ for (@$any) {
+ if ($self->match_next($_)) {
+ return 1;
+ }
+ }
+ $self->{pointer} = $pointer;
+ $self->{farthest} = $pointer if $pointer > $self->{farthest};
+ return;
+}
+
+sub match_all {
+ my ($self, $all) = @_;
+ my $pointer = $self->{pointer};
+ for (@$all) {
+ if (not $self->match_next($_)) {
+ $self->{pointer} = $pointer;
+ $self->{farthest} = $pointer if $pointer > $self->{farthest};
+ return;
+ }
+ }
+ return 1;
+}
+
+sub match_ref {
+ my ($self, $ref) = @_;
+ my $rule = $self->{grammar}->{$ref}
+ or Carp::confess "Not a rule reference: '$ref'";
+ $self->match_next($rule);
+}
+
+sub match_token {
+ my ($self, $token_want) = @_;
+ my $not = ($token_want =~ s/^\!//) ? 1 : 0;
+ return if $self->{pointer} >= @{$self->{tokens}};
+ my $token = $self->{tokens}[$self->{pointer}];
+ my $token_got = $token->[0];
+ if (($token_want eq $token_got) xor $not) {
+ $token_got =~ s/-/_/g;
+ my $method = "got_$token_got";
+ if ($self->can($method)) {
+ # print "$method\n";
+ $self->$method($token);
+ }
+ $self->{pointer}++;
+ return 1;
+ }
+ return;
+}
+
+#------------------------------------------------------------------------------
+# Receiver/ast-generator methods:
+#------------------------------------------------------------------------------
+sub got_directive_start {
+ my ($self, $token) = @_;
+ $self->{directive_name} = $token->[1];
+}
+
+sub got_directive_value {
+ my ($self, $token) = @_;
+ my $value = $token->[1];
+ $value =~ s/\s+$//;
+ my $name = $self->{directive_name};
+ if (my $old_value = $self->{tree}{"+$name"}) {
+ if (not ref($old_value)) {
+ $old_value = $self->{tree}{"+$name"} = [$old_value];
+ }
+ push @$old_value, $value;
+ }
+ else {
+ $self->{tree}{"+$name"} = $value;
+ }
+}
+
+sub got_rule_start {
+ my ($self, $token) = @_;
+ $self->{stack} = [];
+ my $rule_name = $token->[1];
+ $rule_name =~ s/-/_/g;
+ $self->{rule_name} = $rule_name;
+ $self->{tree}{'+toprule'} ||= $rule_name;
+ $self->{groups} = [[0, ':']];
+}
+
+sub got_rule_end {
+ my ($self) = @_;
+ $self->{tree}{$self->{rule_name}} = $self->group_ast;
+}
+
+sub got_group_start {
+ my ($self, $token) = @_;
+ push @{$self->{groups}}, [scalar(@{$self->{stack}}), $token->[1]];
+}
+
+sub got_group_end {
+ my ($self, $token) = @_;
+ my $rule = $self->group_ast;
+ Pegex::Pegex::AST::set_quantity($rule, $token->[1]);
+ push @{$self->{stack}}, $rule;
+}
+
+sub got_list_alt {
+ my ($self) = @_;
+ push @{$self->{stack}}, '|';
+}
+
+sub got_list_sep {
+ my ($self, $token) = @_;
+ push @{$self->{stack}}, $token->[1];
+}
+
+sub got_rule_reference {
+ my ($self, $token) = @_;
+ my $name = $token->[2];
+ $name =~ s/-/_/g;
+ $name =~ s/^<(.*)>$/$1/;
+ my $rule = { '.ref' => $name };
+ Pegex::Pegex::AST::set_modifier($rule, $token->[1]);
+ Pegex::Pegex::AST::set_quantity($rule, $token->[3]);
+ push @{$self->{stack}}, $rule;
+}
+
+sub got_error_message {
+ my ($self, $token) = @_;
+ push @{$self->{stack}}, { '.err' => $token->[1] };
+}
+
+sub got_whitespace_maybe {
+ my ($self) = @_;
+ $self->got_rule_reference(['whitespace-maybe', undef, '_', undef]);
+}
+
+sub got_whitespace_must {
+ my ($self) = @_;
+ $self->got_rule_reference(['whitespace-maybe', undef, '__', undef]);
+}
+
+sub got_quoted_regex {
+ my ($self, $token) = @_;
+ my $regex = $token->[1];
+ $regex =~ s/([^\w\`\%\:\<\/\,\=\;])/\\$1/g;
+ push @{$self->{stack}}, { '.rgx' => $regex };
+}
+
+sub got_regex_start {
+ my ($self) = @_;
+ push @{$self->{groups}}, [scalar(@{$self->{stack}}), '/'];
+}
+
+sub got_regex_end {
+ my ($self) = @_;
+ my $regex = join '', map {
+ if (ref($_)) {
+ my $part;
+ if (defined($part = $_->{'.rgx'})) {
+ $part;
+ }
+ elsif (defined($part = $_->{'.ref'})) {
+ "<$part>";
+ }
+ else {
+ XXX $_;
+ }
+ }
+ else {
+ $_;
+ }
+ } splice(@{$self->{stack}}, (pop @{$self->{groups}})->[0]);
+ $regex =~ s!\(([ism]?\:|\=|\!)!(?$1!g;
+ push @{$self->{stack}}, {'.rgx' => $regex};
+}
+
+sub got_regex_raw {
+ my ($self, $token) = @_;
+ push @{$self->{stack}}, $token->[1];
+}
+
+#------------------------------------------------------------------------------
+# Receiver helper methods:
+#------------------------------------------------------------------------------
+sub group_ast {
+ my ($self) = @_;
+ my ($offset, $gmod) = @{pop @{$self->{groups}}};
+ $gmod ||= '';
+ my $rule = [splice(@{$self->{stack}}, $offset)];
+
+ for (my $i = 0; $i < @$rule-1; $i++) {
+ if ($rule->[$i + 1] =~ /^%%?$/) {
+ $rule->[$i] = Pegex::Pegex::AST::set_separator(
+ $rule->[$i],
+ splice @$rule, $i+1, 2
+ );
+ }
+ }
+ my $started = 0;
+ for (
+ my $i = (@$rule and $rule->[0] eq '|') ? 1 : 0;
+ $i < @$rule-1;
+ $i++
+ ) {
+ next if $rule->[$i] eq '|';
+ if ($rule->[$i+1] eq '|') {
+ $i++;
+ $started = 0;
+ }
+ else {
+ $rule->[$i] = {'.all' => [$rule->[$i]]}
+ unless $started++;
+ push @{$rule->[$i]{'.all'}}, splice @$rule, $i+1, 1;
+ $i--
+ }
+ }
+ if (grep {$_ eq '|'} @$rule) {
+ $rule = [{'.any' => [ grep {$_ ne '|'} @$rule ]}];
+ }
+
+ $rule = $rule->[0] if @$rule <= 1;
+ Pegex::Pegex::AST::set_modifier($rule, $gmod)
+ unless $gmod eq ':';
+
+ return $rule;
+}
+
+# DEBUG: wrap/trace parse methods:
+# for my $method (qw(
+# match_times match_next match_ref match_token match_any match_all
+# )) {
+# no strict 'refs';
+# no warnings 'redefine';
+# my $orig = \&$method;
+# *$method = sub {
+# my $self = shift;
+# my $args = join ', ', map {
+# ref($_) ? '[' . join(', ', @$_) . ']' :
+# length($_) ? $_ : "''"
+# } @_;
+# print "$method($args)\n";
+# die if $main::x++ > 250;
+# $orig->($self, @_);
+# };
+# }
+
+#------------------------------------------------------------------------------
+# Lexer logic:
+#------------------------------------------------------------------------------
+my $ALPHA = 'A-Za-z';
+my $DIGIT = '0-9';
+my $DASH = '\-';
+my $SEMI = '\;';
+my $UNDER = '\_';
+my $HASH = '\#';
+my $EOL = '\r?\n';
+my $WORD = "$DASH$UNDER$ALPHA$DIGIT";
+my $WS = "(?:[\ \t]|$HASH.*$EOL)";
+my $MOD = '[\!\=\-\+\.]';
+my $GMOD = '[\.\-]';
+my $QUANT = '(?:[\?\*\+]|\d+(?:\+|\-\d+)?)';
+my $NAME = "$UNDER?[$UNDER$ALPHA](?:[$WORD]*[$ALPHA$DIGIT])?";
+
+# Repeated Rules:
+my $rem = [qr/\A(?:$WS+|$EOL+)/];
+my $qr = [qr/\A\'((?:\\.|[^\'])*)\'/, 'quoted-regex'];
+
+# Lexer regex tree:
+has regexes => {
+ pegex => [
+ [qr/\A%(grammar|version|extends|include)$WS+/,
+ 'directive-start', 'directive'],
+
+ [qr/\A($NAME)(?=$WS*\:)/,
+ 'rule-start', 'rule'],
+
+ $rem,
+
+ [qr/\A\z/,
+ 'pegex-end', 'end'],
+ ],
+
+ rule => [
+ [qr/\A(?:$SEMI$WS*$EOL?|\s*$EOL|)(?=$NAME$WS*\:|\z)/,
+ 'rule-end', 'end'],
+
+ [qr/\A\:/,
+ 'rule-sep'],
+
+ [qr/\A(?:\+|\~\~)(?=\s)/,
+ 'whitespace-must'],
+ [qr/\A(?:\-|\~)(?=\s)/,
+ 'whitespace-maybe'],
+
+ $qr,
+ [qr/\A($MOD)?($NAME|<$NAME>)($QUANT)?(?!$WS*$NAME\:)/,
+ 'rule-reference'],
+ [qr/\A\//,
+ 'regex-start', 'regex'],
+ [qr/\A\`([^\`\n]*?)\`/,
+ 'error-message'],
+
+ [qr/\A($GMOD)?\(/,
+ 'group-start'],
+ [qr/\A\)($QUANT)?/,
+ 'group-end'],
+ [qr/\A\|/,
+ 'list-alt'],
+ [qr/\A(\%\%?)/,
+ 'list-sep'],
+
+ $rem,
+ ],
+
+ directive => [
+ [qr/\A(\S.*)/,
+ 'directive-value'],
+ [qr/\A$EOL/,
+ 'directive-end', 'end']
+ ],
+
+ regex => [
+ [qr/\A$WS+(?:\+|\~\~|\-\-)/,
+ 'whitespace-must'],
+ [qr/\A(?:\-|~)(?![-~])/,
+ 'whitespace-maybe'],
+ $qr,
+ [qr/\A$WS+()($NAME|<$NAME>)/,
+ 'rule-reference'],
+ [qr/\A([^\s\'\/]+)/,
+ 'regex-raw'],
+ [qr/\A$WS+/],
+ [qr/\A$EOL+/],
+ [qr/\A\//,
+ 'regex-end', 'end'],
+ $rem,
+ ],
+};
+
+sub lex {
+ my ($self, $grammar) = @_;
+
+ my $tokens = $self->{tokens} = [['pegex-start']];
+ my $stack = ['pegex'];
+ my $pos = 0;
+
+ OUTER: while (1) {
+ my $state = $stack->[-1];
+ my $set = $self->{regexes}->{$state} or die "Invalid state '$state'";
+ for my $entry (@$set) {
+ my ($regex, $name, $scope) = @$entry;
+ if (substr($grammar, $pos) =~ $regex) {
+ $pos += length($&);
+ if ($name) {
+ no strict 'refs';
+ my @captures = map $$_, 1..$#+;
+ pop @captures
+ while @captures and not defined $captures[-1];
+ push @$tokens, [$name, @captures];
+ if ($scope) {
+ if ($scope eq 'end') {
+ pop @$stack;
+ }
+ else {
+ push @$stack, $scope;
+ # Hack to support /+ â¦/
+ if ($scope eq 'regex') {
+ if (substr($grammar, $pos) =~ /\A\+(?=[\s\/])/) {
+ $pos += length($&);
+ push @$tokens, ['whitespace-must'];
+ }
+ }
+ }
+ }
+ }
+ last OUTER unless @$stack;
+ next OUTER;
+ }
+ }
+ my $text = substr($grammar, $pos, 50);
+ $text =~ s/\n/\\n/g;
+ WWW $tokens;
+ die <<"...";
+Failed to lex $state here-->$text
+...
+ }
+}
+
+1;
+
+# vim: set lisp:
@@ -0,0 +1,188 @@
+package Pegex::Compiler;
+use Pegex::Base;
+
+use Pegex::Parser;
+use Pegex::Pegex::Grammar;
+use Pegex::Pegex::AST;
+use Pegex::Grammar::Atoms;
+
+has tree => ();
+
+sub compile {
+ my ($self, $grammar, @rules) = @_;
+
+ # Global request to use the Pegex bootstrap compiler
+ if ($Pegex::Bootstrap) {
+ require Pegex::Bootstrap;
+ $self = Pegex::Bootstrap->new;
+ }
+
+ @rules = map { s/-/_/g; $_ } @rules;
+
+ $self->parse($grammar);
+ $self->combinate(@rules);
+ $self->native;
+
+ return $self;
+}
+
+sub parse {
+ my ($self, $input) = @_;
+
+ my $parser = Pegex::Parser->new(
+ grammar => Pegex::Pegex::Grammar->new,
+ receiver => Pegex::Pegex::AST->new,
+ );
+
+ $self->{tree} = $parser->parse($input);
+
+ return $self;
+}
+
+#-----------------------------------------------------------------------------#
+# Combination
+#-----------------------------------------------------------------------------#
+has _tree => ();
+
+sub combinate {
+ my ($self, @rule) = @_;
+ if (not @rule) {
+ if (my $rule = $self->{tree}->{'+toprule'}) {
+ @rule = ($rule);
+ }
+ else {
+ return $self;
+ }
+ }
+ $self->{_tree} = {
+ map {($_, $self->{tree}->{$_})} grep { /^\+/ } keys %{$self->{tree}}
+ };
+ for my $rule (@rule) {
+ $self->combinate_rule($rule);
+ }
+ $self->{tree} = $self->{_tree};
+ delete $self->{_tree};
+ return $self;
+}
+
+sub combinate_rule {
+ my ($self, $rule) = @_;
+ return if exists $self->{_tree}->{$rule};
+
+ my $object = $self->{_tree}->{$rule} = $self->{tree}->{$rule};
+ $self->combinate_object($object);
+}
+
+sub combinate_object {
+ my ($self, $object) = @_;
+ if (exists $object->{'.rgx'}) {
+ $self->combinate_re($object);
+ }
+ elsif (exists $object->{'.ref'}) {
+ my $rule = $object->{'.ref'};
+ if (exists $self->{tree}{$rule}) {
+ $self->combinate_rule($rule);
+ }
+ else {
+ if (my $regex = (Pegex::Grammar::Atoms::atoms)->{$rule}) {
+ $self->{tree}{$rule} = { '.rgx' => $regex };
+ $self->combinate_rule($rule);
+ }
+ }
+ }
+ elsif (exists $object->{'.any'}) {
+ for my $elem (@{$object->{'.any'}}) {
+ $self->combinate_object($elem);
+ }
+ }
+ elsif (exists $object->{'.all' }) {
+ for my $elem (@{$object->{'.all'}}) {
+ $self->combinate_object($elem);
+ }
+ }
+ elsif (exists $object->{'.err' }) {
+ }
+ else {
+ require YAML::XS;
+ die "Can't combinate:\n" . YAML::XS::Dump($object);
+ }
+}
+
+sub combinate_re {
+ my ($self, $regexp) = @_;
+ my $atoms = Pegex::Grammar::Atoms->atoms;
+ my $re = $regexp->{'.rgx'};
+ while (1) {
+ $re =~ s[(?<!\\)(~+)]['<ws' . length($1) . '>']ge;
+ $re =~ s[<([\w\-]+)>][
+ (my $key = $1) =~ s/-/_/g;
+ $self->{tree}->{$key} and (
+ $self->{tree}->{$key}{'.rgx'} or
+ die "'$key' not defined as a single RE"
+ )
+ or $atoms->{$key}
+ or die "'$key' not defined in the grammar"
+ ]e;
+ last if $re eq $regexp->{'.rgx'};
+ $regexp->{'.rgx'} = $re;
+ }
+}
+
+#-----------------------------------------------------------------------------#
+# Compile to native Perl regexes
+#-----------------------------------------------------------------------------#
+sub native {
+ my ($self) = @_;
+ $self->perl_regexes($self->{tree});
+ return $self;
+}
+
+sub perl_regexes {
+ my ($self, $node) = @_;
+ if (ref($node) eq 'HASH') {
+ if (exists $node->{'.rgx'}) {
+ my $re = $node->{'.rgx'};
+ $node->{'.rgx'} = qr/\G$re/;
+ }
+ else {
+ for (keys %$node) {
+ $self->perl_regexes($node->{$_});
+ }
+ }
+ }
+ elsif (ref($node) eq 'ARRAY') {
+ $self->perl_regexes($_) for @$node;
+ }
+}
+
+#-----------------------------------------------------------------------------#
+# Serialization formatter methods
+#-----------------------------------------------------------------------------#
+sub to_yaml {
+ require YAML::XS;
+ my $self = shift;
+ return YAML::XS::Dump($self->tree);
+}
+
+sub to_json {
+ require JSON::XS;
+ my $self = shift;
+ return JSON::XS->new->utf8->canonical->pretty->encode($self->tree);
+}
+
+sub to_perl {
+ my $self = shift;
+ require Data::Dumper;
+ no warnings 'once';
+ $Data::Dumper::Terse = 1;
+ $Data::Dumper::Indent = 1;
+ $Data::Dumper::Sortkeys = 1;
+ my $perl = Data::Dumper::Dumper($self->tree);
+ $perl =~ s/\?\^:/?-xism:/g;
+ $perl =~ s!(\.rgx.*?qr/)\(\?-xism:(.*)\)(?=/)!$1$2!g;
+ die "to_perl failed with non compatible regex in:\n$perl"
+ if $perl =~ /\?\^/;
+ return $perl;
+}
+
+1;
@@ -1,83 +1,109 @@
-#line 1
-##
-# name: Pegex::Grammar
-# abstract: Pegex Grammar Base Class
-# author: Ingy döt Net <ingy@cpan.org>
-# license: perl
-# copyright: 2010, 2011
-
package Pegex::Grammar;
-use Pegex::Mo;
+use Pegex::Base;
# Grammar can be in text or tree form. Tree will be compiled from text.
-has 'text' => default => sub {
- my $self = shift;
- die "Can't create a '" . ref($self) . "' grammar. No 'text' or 'tree'.";
-};
-has 'tree' => builder => 'tree_';
-sub tree_ {
- require Pegex::Compiler;
- Pegex::Compiler->compile($_[0]->text)->tree;
-}
-
-# Parser and receiver classes to use.
-has 'parser' => default => sub {'Pegex::Parser'};
-has 'receiver' => default => sub {
- require Pegex::Receiver;
- Pegex::Receiver->new(wrap => 1);
-};
-
-sub parse {
- my $self = shift;
- $self = $self->new unless ref $self;
+# Grammar can also be stored in a file.
+has file => ();
+has text => (
+ builder => 'make_text',
+ lazy => 1,
+);
+has tree => (
+ builder => 'make_tree',
+ lazy => 1,
+);
+has start_rules => [];
- die "Usage: " . ref($self) . '->parse($input [, $start_rule]'
- unless 1 <= @_ and @_ <= 2;
-
- my $parser = $self->parser;
- if (not ref $parser) {
- eval "require $parser";
- my $receiver = $self->receiver;
- $receiver = do {
- eval "require $receiver";
- $receiver->new;
- } unless ref $receiver;
- $parser = $parser->new(
- grammar => $self,
- receiver => $receiver,
- );
- }
+sub make_text {
+ my ($self) = @_;
+ my $filename = $self->file
+ or return '';
+ open TEXT, $filename
+ or die "Can't open '$filename' for input\n:$!";
+ return do {local $/; <TEXT>}
+}
- return $parser->parse(@_);
+sub make_tree {
+ my ($self) = @_;
+ my $text = $self->text
+ or die "Can't create a '" . ref($self) .
+ "' grammar. No tree or text or file.";
+ require Pegex::Compiler;
+ return Pegex::Compiler->new->compile(
+ $text,
+ @{$self->start_rules || []}
+ )->tree;
}
+# This import is to support: perl -MPegex::Grammar::Module=compile
sub import {
- goto &Pegex::Mo::import
- unless ((caller))[1] =~ /^-e?$/ and @_ == 2 and $_[1] eq 'compile';
- my $package = shift;
- $package->compile_into_module();
- exit;
+ my ($package) = @_;
+ if (((caller))[1] =~ /^-e?$/ and @_ == 2 and $_[1] eq 'compile') {
+ $package->compile_into_module();
+ exit;
+ }
+ if (my $env = $ENV{PERL_PEGEX_AUTO_COMPILE}) {
+ my %modules = map {($_, 1)} split ',', $env;
+ if ($modules{$package}) {
+ if (my $grammar_file = $package->file) {
+ if (-f $grammar_file) {
+ my $module = $package;
+ $module =~ s!::!/!g;
+ $module .= '.pm';
+ my $module_file = $INC{$module};
+ if (-M $grammar_file < -M $module_file) {
+ $package->compile_into_module();
+ local $SIG{__WARN__};
+ delete $INC{$module};
+ require $module;
+ }
+ }
+ }
+ }
+ }
}
sub compile_into_module {
my ($package) = @_;
- my $grammar = $package->text;
+ my $grammar_file = $package->file;
+ open GRAMMAR, $grammar_file
+ or die "Can't open $grammar_file for input";
+ my $grammar_text = do {local $/; <GRAMMAR>};
+ close GRAMMAR;
my $module = $package;
$module =~ s!::!/!g;
$module = "$module.pm";
my $file = $INC{$module} or return;
- require Pegex::Compiler;
- my $perl = Pegex::Compiler->compile($grammar)->to_perl;
+ my $perl;
+ my @rules;
+ if ($package->can('start_rules')) {
+ @rules = @{$package->start_rules || []};
+ }
+ if ($module eq 'Pegex/Pegex/Grammar.pm') {
+ require Pegex::Bootstrap;
+ $perl = Pegex::Bootstrap->new->compile($grammar_text, @rules)->to_perl;
+ }
+ else {
+ require Pegex::Compiler;
+ $perl = Pegex::Compiler->new->compile($grammar_text, @rules)->to_perl;
+ }
open IN, $file or die $!;
my $module_text = do {local $/; <IN>};
+ require Pegex;
+ my $msg = " # Generated/Inlined by Pegex::Grammar ($Pegex::VERSION)";
close IN;
$perl =~ s/^/ /gm;
- $module_text =~ s/^(sub\s+tree_?\s*\{).*?(^\})/$1\n$perl$2/ms;
+ $module_text =~ s/^(sub\s+make_tree\s*\{).*?(^\})/$1$msg\n$perl$2/ms;
+ $module_text =~ s/^(sub\s+tree\s*\{).*?(^\})/$1$msg\n$perl$2/ms;
+ chomp $grammar_text;
+ $grammar_text = "<<'...';\n$grammar_text\n...\n";
+ $module_text =~ s/^(sub\s+text\s*\{).*?(^\})/$1$msg\n$grammar_text$2/ms;
+ $grammar_text =~ s/^/# /gm;
+ $module_text =~ s/^(# sub\s+text\s*\{).*?(^# \})/$1$msg\n$grammar_text$2/ms;
open OUT, '>', $file or die $!;
print OUT $module_text;
close OUT;
+ print "Compiled '$grammar_file' into '$file'.\n";
}
-
1;
-
@@ -1,96 +1,64 @@
-#line 1
-##
-# name: Pegex::Input
-# abstract: Pegex Parser Input Abstraction
-# author: Ingy döt Net <ingy@cpan.org>
-# license: perl
-# copyright: 2011
-
package Pegex::Input;
-use Pegex::Mo;
-has 'string';
-has 'stringref';
-has 'file';
-has 'handle';
-# has 'http';
-has '_buffer' => default => sub { my $x; \$x };
-has '_is_eof' => default => sub { 0 };
-has '_is_open' => default => sub { 0 };
-has '_is_close' => default => sub { 0 };
-# has '_pos' => 0;
-# has 'maxsize' => 4096;
-# has 'minlines' => 2;
+use Pegex::Base;
-sub new {
- my $class = shift;
- die "Pegex::Input->new() requires one or 2 arguments"
- unless 1 <= @_ and @_ <= 2;
- my $method = @_ == 2 ? shift : $class->_guess_input(@_);
- return $class->SUPER::new($method => shift);
-}
+has string => ();
+has stringref => ();
+has file => ();
+has handle => ();
+has _buffer => ();
+has _is_eof => 0;
+has _is_open => 0;
+has _is_close => 0;
# NOTE: Current implementation reads entire input into _buffer on open().
sub read {
my ($self) = @_;
- die "Attempted Pegex::Input::read before open" if not $self->_is_open;
- die "Attempted Pegex::Input::read after EOF" if $self->_is_eof;
-
- my $buffer = $self->_buffer;
- $self->_buffer(undef);
- $self->_is_eof(1);
+ die "Attempted Pegex::Input::read before open" if not $self->{_is_open};
+ die "Attempted Pegex::Input::read after EOF" if $self->{_is_eof};
+
+ my $buffer = $self->{_buffer};
+ $self->{_buffer} = undef;
+ $self->{_is_eof} = 1;
- return $$buffer;
+ return $buffer;
}
sub open {
- my $self = shift;
- die "Pegex::Input::open takes no arguments" if @_;
+ my ($self) = @_;
die "Attempted to reopen Pegex::Input object"
- if $self->_is_open or $self->_is_close;
+ if $self->{_is_open} or $self->{_is_close};
- if (my $ref = $self->stringref) {
- $self->_buffer($ref);
+ if (my $ref = $self->{stringref}) {
+ $self->{_buffer} = $ref;
}
- elsif (my $handle = $self->handle) {
- $self->_buffer(\ do { local $/; <$handle> });
+ elsif (my $handle = $self->{handle}) {
+ $self->{_buffer} = \ do { local $/; <$handle> };
}
- elsif (my $path = $self->file) {
+ elsif (my $path = $self->{file}) {
open my $handle, $path
or die "Pegex::Input can't open $path for input:\n$!";
- $self->_buffer(\ do { local $/; <$handle> });
+ $self->{_buffer} = \ do { local $/; <$handle> };
}
elsif (exists $self->{string}) {
- $self->_buffer(\$self->{string});
+ $self->{_buffer} = \$self->{string};
}
else {
- die "Pegex::open failed. No source to open";
+ die "Pegex::Input::open failed. No source to open";
}
-
- $self->_is_open(1);
-
+ $self->{_is_open} = 1;
return $self;
}
sub close {
my ($self) = @_;
- die "Attempted to close an unopen Pegex::Input object" if $self->_is_close;
- close $self->handle if $self->handle;
- $self->_is_open(0);
- $self->_is_close(1);
- $self->_buffer(undef);
+ die "Attempted to close an unopen Pegex::Input object"
+ if $self->{_is_close};
+ close $self->{handle} if $self->{handle};
+ $self->{_is_open} = 0;
+ $self->{_is_close} = 1;
+ $self->{_buffer} = undef;
return $self;
}
-sub _guess_input {
- return ref($_[1])
- ? (ref($_[1]) eq 'SCALAR')
- ? 'stringref'
- : 'handle'
- : (length($_[1]) and ($_[1] !~ /\n/) and -f $_[1])
- ? 'file'
- : 'string';
-}
-
1;
-
@@ -1,15 +0,0 @@
-#line 1
-##
-# name: Pegex::Mo
-# abstract: Mo Base Class for Pegex
-# author: Ingy döt Net <ingy@cpan.org>
-# license: perl
-# copyright: 2010, 2011
-
-package Pegex::Mo;
-# use Mo qw[builder default xxx import];
-# The following line of code was produced from the previous line by
-# Mo::Inline version 0.25
-no warnings;my$M=__PACKAGE__.::;*{$M.Object::new}=sub{bless{@_[1..$#_]},$_[0]};*{$M.import}=sub{import warnings;$^H|=1538;my($P,%e,%o)=caller.::;shift;eval"no Mo::$_",&{$M.$_.::e}($P,\%e,\%o)for@_;%e=(extends,sub{eval"no $_[0]()";@{$P.ISA}=$_[0]},has,sub{my$n=shift;my$m=sub{$#_?$_[0]{$n}=$_[1]:$_[0]{$n}};$m=$o{$_}->($m,$n,@_)for sort keys%o;*{$P.$n}=$m},%e,);*{$P.$_}=$e{$_}for keys%e;@{$P.ISA}=$M.Object};*{$M.'builder::e'}=sub{my($P,$e,$o)=@_;$o->{builder}=sub{my($m,$n,%a)=@_;my$b=$a{builder}or return$m;sub{$#_?$m->(@_):!exists$_[0]{$n}?$_[0]{$n}=$_[0]->$b:$m->(@_)}}};*{$M.'default::e'}=sub{my($P,$e,$o)=@_;$o->{default}=sub{my($m,$n,%a)=@_;$a{default}or return$m;sub{$#_?$m->(@_):!exists$_[0]{$n}?$_[0]{$n}=$a{default}->(@_):$m->(@_)}}};use constant XXX_skip=>1;${$M.'::DumpModule'}='YAML::XS';*{$M.'xxx::e'}=sub{my($P,$e)=@_;$e->{WWW}=sub{require XXX;local$XXX::DumpModule=${$M.DumpModule};XXX::WWW(@_)};$e->{XXX}=sub{require XXX;local$XXX::DumpModule=${$M.DumpModule};XXX::XXX(@_)};$e->{YYY}=sub{require XXX;local$XXX::DumpModule=${$M.DumpModule};XXX::YYY(@_)};$e->{ZZZ}=sub{require XXX;local$XXX::DumpModule=${$M.DumpModule};XXX::ZZZ(@_)}};my$i=\&import;*{$M.import}=sub{(@_==2 and not $_[1])?pop@_:@_==1 ?push@_,grep!/import/,@f:();goto&$i};@f=qw[builder default xxx import];
-
-our $DumpModule = 'YAML';
@@ -0,0 +1,137 @@
+package Pegex::Optimizer;
+use Pegex::Base;
+
+has parser => (required => 1);
+has grammar => (required => 1);
+has receiver => (required => 1);
+
+sub optimize_grammar {
+ my ($self, $start) = @_;
+ my $tree = $self->grammar->{tree};
+ return if $tree->{'+optimized'};
+ $self->set_max_parse if $self->parser->{maxparse};
+ $self->{extra} = {};
+ while (my ($name, $node) = each %$tree) {
+ next unless ref($node);
+ $self->optimize_node($node);
+ }
+ $self->optimize_node({'.ref' => $start});
+ my $extra = delete $self->{extra};
+ for my $key (%$extra) {
+ $tree->{$key} = $extra->{$key};
+ }
+ $tree->{'+optimized'} = 1;
+}
+
+sub optimize_node {
+ my ($self, $node) = @_;
+
+ my ($min, $max) = @{$node}{'+min', '+max'};
+ $node->{'+min'} = defined($max) ? 0 : 1
+ unless defined $node->{'+min'};
+ $node->{'+max'} = defined($min) ? 0 : 1
+ unless defined $node->{'+max'};
+ $node->{'+asr'} = 0
+ unless defined $node->{'+asr'};
+
+ for my $kind (qw(ref rgx all any err code xxx)) {
+ return if $kind eq 'xxx';
+ if ($node->{rule} = $node->{".$kind"}) {
+ delete $node->{".$kind"};
+ $node->{kind} = $kind;
+ if ($kind eq 'ref') {
+ my $rule = $node->{rule} or die;
+ if (my $method = $self->grammar->can("rule_$rule")) {
+ $node->{method} = $self->make_method_wrapper($method);
+ }
+ elsif (not $self->grammar->{tree}{$rule}) {
+ if (my $method = $self->grammar->can("$rule")) {
+ warn <<"...";
+Warning:
+
+ You have a method called '$rule' in your grammar.
+ It should probably be called 'rule_$rule'.
+
+...
+ }
+ die "No rule '$rule' defined in grammar";
+ }
+ }
+ $node->{method} ||= $self->parser->can("match_$kind") or die;
+ last;
+ }
+ }
+
+ if ($node->{kind} =~ /^(?:all|any)$/) {
+ $self->optimize_node($_) for @{$node->{rule}};
+ }
+ elsif ($node->{kind} eq 'ref') {
+ my $ref = $node->{rule};
+ my $rule = $self->grammar->{tree}{$ref};
+ $rule ||= $self->{extra}{$ref} = {};
+ if (my $action = $self->receiver->can("got_$ref")) {
+ $rule->{action} = $action;
+ }
+ elsif (my $gotrule = $self->receiver->can("gotrule")) {
+ $rule->{action} = $gotrule;
+ }
+ if ($self->parser->{debug}) {
+ $node->{method} = $self->make_trace_wrapper($node->{method});
+ }
+ }
+ elsif ($node->{kind} eq 'rgx') {
+ # XXX $node;
+ }
+}
+
+sub make_method_wrapper {
+ my ($self, $method) = @_;
+ return sub {
+ my ($parser, $ref, $parent) = @_;
+ @{$parser}{'rule', 'parent'} = ($ref, $parent);
+ $method->(
+ $parser->{grammar},
+ $parser,
+ $parser->{buffer},
+ $parser->{position},
+ );
+ }
+}
+
+sub make_trace_wrapper {
+ my ($self, $method) = @_;
+ return sub {
+ my ($self, $ref, $parent) = @_;
+ my $asr = $parent->{'+asr'};
+ my $note =
+ $asr == -1 ? '(!)' :
+ $asr == 1 ? '(=)' :
+ '';
+ $self->trace("try_$ref$note");
+ my $result;
+ if ($result = $self->$method($ref, $parent)) {
+ $self->trace("got_$ref$note");
+ }
+ else {
+ $self->trace("not_$ref$note");
+ }
+ return $result;
+ }
+}
+
+sub set_max_parse {
+ require Pegex::Parser;
+ my ($self) = @_;
+ my $maxparse = $self->parser->{maxparse};
+ no warnings 'redefine';
+ my $method = \&Pegex::Parser::match_ref;
+ my $counter = 0;
+ *Pegex::Parser::match_ref = sub {
+ die "Maximum parsing rules reached ($maxparse)\n"
+ if $counter++ >= $maxparse;
+ my $self = shift;
+ $self->$method(@_);
+ };
+}
+
+1;
@@ -1,279 +1,199 @@
-#line 1
-##
-# name: Pegex::Parser
-# abstract: Pegex Parser Runtime
-# author: Ingy döt Net <ingy@cpan.org>
-# license: perl
-# copyright: 2011
-# see:
-# - Pegex::Grammar
-
package Pegex::Parser;
-use Pegex::Mo;
+use Pegex::Base;
use Pegex::Input;
-
+use Pegex::Optimizer;
use Scalar::Util;
-# Grammar object or class
-has 'grammar';
-# Receiver object or class
-has 'receiver' => default => sub {
- require Pegex::Receiver;
- Pegex::Receiver->new();
-};
-
-# Parser options
-has 'throw_on_error' => default => sub {1};
-# # Allow a partial parse
-# has 'partial' => default => sub {0};
-# Wrap results in hash with rule name for key
-has 'wrap' => default => sub { $_[0]->receiver->wrap };
-
-# Internal properties.
-has 'input';
-has 'buffer';
-has 'position' => default => sub {0};
-
-# Debug the parsing of input.
-has 'debug' => builder => 'debug_';
-
-sub debug_ {
+has grammar => (required => 1);
+has receiver => ();
+has input => ();
+has debug => (
exists($ENV{PERL_PEGEX_DEBUG}) ? $ENV{PERL_PEGEX_DEBUG} :
defined($Pegex::Parser::Debug) ? $Pegex::Parser::Debug :
- 0;
+ 0
+);
+sub BUILD {
+ my ($self) = @_;
+ $self->{throw_on_error} ||= 1;
+ # $self->{rule} = undef;
+ # $self->{parent} = undef;
+ # $self->{error} = undef;
+ # $self->{position} = undef;
+ # $self->{farthest} = undef;
}
+# XXX Add an optional $position argument. Default to 0. This is the position
+# to start parsing. Set position and farthest below to this value. Allows for
+# sub-parsing. Need to somehow return the finishing position of a subparse.
+# Maybe this all goes in a subparse() method.
sub parse {
- my $self = shift;
- $self = $self->new unless ref $self;
+ my ($self, $input, $start) = @_;
- die "Usage: " . ref($self) . '->parse($input [, $start_rule]'
- unless 1 <= @_ and @_ <= 2;
+ $start =~ s/-/_/g if $start;
- my $input = (ref $_[0] and UNIVERSAL::isa($_[0], 'Pegex::Input'))
- ? shift
- : Pegex::Input->new(shift)->open;
- $self->input($input);
+ $self->{position} = 0;
+ $self->{farthest} = 0;
- $self->buffer($self->input->read);
+ $self->{input} = (not ref $input)
+ ? Pegex::Input->new(string => $input)
+ : $input;
- my $grammar = $self->grammar or die "No 'grammar'. Can't parse";
- if (not ref $grammar) {
- eval "require $grammar";
- $self->grammar($grammar->new);
- }
+ $self->{input}->open
+ unless $self->{input}{_is_open};
+ $self->{buffer} = $self->{input}->read;
- my $start_rule = shift ||
- $self->grammar->tree->{'+top'} ||
- ($self->grammar->tree->{'TOP'} ? 'TOP' : undef)
- or die "No starting rule for Pegex::Parser::parse";
+ die "No 'grammar'. Can't parse"
+ unless $self->{grammar};
- my $receiver = $self->receiver or die "No 'receiver'. Can't parse";
- if (not ref $receiver) {
- eval "require $receiver";
- $self->receiver($receiver->new);
- }
- # Add circular ref and weaken it.
- $self->receiver->parser($self);
- Scalar::Util::weaken($self->receiver->{parser});
+ $self->{grammar}{tree} ||= $self->{grammar}->make_tree;
- # Do the parse
- my $match = $self->match($start_rule) or return;
+ my $start_rule_ref = $start ||
+ $self->{grammar}{tree}{'+toprule'} ||
+ $self->{grammar}{tree}{'TOP'} & 'TOP' or
+ die "No starting rule for Pegex::Parser::parse";
- # Parse was successful!
- $self->input->close;
- return ($self->receiver->data || $match);
-}
+ die "No 'receiver'. Can't parse"
+ unless $self->{receiver};
-sub match {
- my ($self, $rule) = @_;
+ my $optimizer = Pegex::Optimizer->new(
+ parser => $self,
+ grammar => $self->{grammar},
+ receiver => $self->{receiver},
+ );
- $self->receiver->initialize($rule)
- if $self->receiver->can("initialize");
+ $optimizer->optimize_grammar($start_rule_ref);
- my $match = $self->match_next({'.ref' => $rule});
- if (not $match or $self->position < length($self->buffer)) {
- $self->throw_error("Parse document failed for some reason");
- return; # In case $self->throw_on_error is off
+ # Add circular ref and weaken it.
+ $self->{receiver}{parser} = $self;
+ Scalar::Util::weaken($self->{receiver}{parser});
+
+ if ($self->{receiver}->can("initial")) {
+ $self->{rule} = $start_rule_ref;
+ $self->{parent} = {};
+ $self->{receiver}->initial();
}
- $match = $match->[0];
- $match = $self->receiver->finalize($match, $rule)
- if $self->receiver->can("finalize");
+ my $match = $self->debug ? do {
+ my $method = $optimizer->make_trace_wrapper(\&match_ref);
+ $self->$method($start_rule_ref, {'+asr' => 0});
+ } : $self->match_ref($start_rule_ref, {});
- $match = {$rule => []} unless $match;
+ $self->{input}->close;
- $match = $match->{TOP} || $match if $rule eq 'TOP';
+ if (not $match or $self->{position} < length ${$self->{buffer}}) {
+ $self->throw_error("Parse document failed for some reason");
+ return; # In case $self->throw_on_error is off
+ }
- return $match;
-}
+ if ($self->{receiver}->can("final")) {
+ $self->{rule} = $start_rule_ref;
+ $self->{parent} = {};
+ $match = [ $self->{receiver}->final(@$match) ];
+ }
-sub get_min_max {
- my ($self, $next) = @_;
- defined($next->{'+min'})
- ? defined($next->{'+max'})
- ? (@{$next}{qw'+min +max'})
- : ($next->{'+min'}, 0)
- : defined($next->{'+max'})
- ? (0, $next->{'+max'})
- : (1, 1);
+ $match->[0];
}
sub match_next {
my ($self, $next) = @_;
- return $self->match_next_with_sep($next)
- if $next->{'.sep'};
-
- my ($min, $max) = $self->get_min_max($next);
- my $assertion = $next->{'+asr'} || 0;
- my ($rule, $kind) = map {($next->{".$_"}, $_)}
- grep {$next->{".$_"}} qw(ref rgx all any err code) or XXX $next;
+ my ($rule, $method, $kind, $min, $max, $assertion) =
+ @{$next}{'rule', 'method', 'kind', '+min', '+max', '+asr'};
- my ($match, $position, $count, $method) =
- ([], $self->position, 0, "match_$kind");
+ my ($position, $match, $count) =
+ ($self->{position}, [], 0);
-# XXX Need to rethink this. match_all must be able to complete possible zero
-# width matches at end of stream...
-# my $return;
-# while ($position < length($self->{buffer}) and
-# $return = $self->$method($rule, $next)) {
-
- while (my $return = $self->$method($rule, $next)) {
- $position = $self->position unless $assertion;
+ while (my $return = $method->($self, $rule, $next)) {
+ $position = $self->{position} unless $assertion;
$count++;
push @$match, @$return;
last if $max == 1;
}
- if ($max != 1) {
- $match = [$match];
- $self->position($position);
+ if (not $count and $min == 0 and $kind eq 'all') {
+ $match = [[]];
}
- my $result = (($count >= $min and (not $max or $count <= $max)) ? 1 : 0)
- ^ ($assertion == -1);
- $self->position($position)
- if not($result) or $assertion;
-
- $match = [] if $next->{'-skip'};
- return ($result ? $match : 0);
-}
-
-sub match_next_with_sep {
- my ($self, $next) = @_;
-
- my ($min, $max) = $self->get_min_max($next);
- my ($rule, $kind) = map {($next->{".$_"}, $_)}
- grep {$next->{".$_"}} qw(ref rgx all any err) or XXX $next;
- my $separator = $next->{'.sep'};
-
- my ($match, $position, $count, $method, $scount, $smin, $smax) =
- ([], $self->position, 0, "match_$kind", 0,
- $self->get_min_max($separator));
- if ($separator->{'+bok'}) {
- # TODO refactor with matching code below
- if (my $return = $self->match_next($separator)) {
- $position = $self->position;
- my @return = @$return;
- if (@return) {
- @return = @{$return[0]} if $smax != 1;
- push @$match, @return;
- }
+ if ($max != 1) {
+ if ($next->{-flat}) {
+ $match = [ map { (ref($_) eq 'ARRAY') ? (@$_) : ($_) } @$match ];
}
- }
- while (my $return = $self->$method($rule, $next)) {
- $position = $self->position;
- $count++;
- push @$match, @$return;
- $return = $self->match_next($separator) or last;
- my @return = @$return;
- if (@return) {
- @return = @{$return[0]} if $smax != 1;
- push @$match, @return;
+ else {
+ $match = [$match]
}
- $scount++;
+ $self->{farthest} = $position
+ if ($self->{position} = $position) > $self->{farthest};
}
- if ($max != 1) {
- $match = [$match];
+ my $result = ($count >= $min and (not $max or $count <= $max))
+ ^ ($assertion == -1);
+ if (not($result) or $assertion) {
+ $self->{farthest} = $position
+ if ($self->{position} = $position) > $self->{farthest};
}
- my $result = (($count >= $min and (not $max or $count <= $max)) ? 1 : 0);
- $self->revert_back($position)
- if $count == $scount and not $separator->{'+eok'};
- $match = [] if $next->{'-skip'};
- return ($result ? $match : 0);
+ ($result ? $next->{'-skip'} ? [] : $match : 0);
}
-sub revert_back {
- my ($self, $position) = @_;
- $self->position($position);
+sub match_rule {
+ my ($self, $position, $match) = (@_, []);
+ $self->{position} = $position;
+ $self->{farthest} = $position
+ if $position > $self->{farthest};
+ $match = [ $match ] if @$match > 1;
+ my ($ref, $parent) = @{$self}{'rule', 'parent'};
+ my $rule = $self->{grammar}{tree}{$ref}
+ or die "No rule defined for '$ref'";
+
+ [ $rule->{action}->($self->{receiver}, @$match) ];
}
sub match_ref {
my ($self, $ref, $parent) = @_;
- my $rule = $self->grammar->tree->{$ref};
- $rule ||= $self->can("match_rule_$ref")
- ? { '.code' => $ref }
- : die "\n\n*** No grammar support for '$ref'\n\n";
-
- my $trace = (not $rule->{'+asr'} and $self->debug);
- $self->trace("try_$ref") if $trace;
-
- my $match = (ref($rule) eq 'CODE')
- ? $self->$rule()
- : $self->match_next($rule);
- if (not $match) {
- $self->trace("not_$ref") if $trace;
- return 0;
- }
-
- # Call receiver callbacks
- $self->trace("got_$ref") if $trace;
- if (not $rule->{'+asr'} and not $parent->{'-skip'}) {
- my $callback = "got_$ref";
- if (my $sub = $self->receiver->can($callback)) {
- $match = [ $sub->($self->receiver, $match->[0]) ];
- }
- elsif ($self->wrap ? not($parent->{'-pass'}) : $parent->{'-wrap'}) {
- $match = [ @$match ? { $ref => $match->[0] } : () ];
- }
- }
-
- return $match;
+ my $rule = $self->{grammar}{tree}{$ref}
+ or die "No rule defined for '$ref'";
+ my $match = $self->match_next($rule) or return;
+ return $Pegex::Constant::Dummy unless $rule->{action};
+ @{$self}{'rule', 'parent'} = ($ref, $parent);
+
+ # XXX Possible API mismatch.
+ # Not sure if we should "splat" the $match.
+ [ $rule->{action}->($self->{receiver}, @$match) ];
}
-my $terminater = 0;
sub match_rgx {
- my ($self, $regexp, $parent) = @_;
+ my ($self, $regexp) = @_;
+ my $buffer = $self->{buffer};
- my $start = pos($self->{buffer}) = $self->position;
- die "Your grammar seems to not terminate at end of stream"
- if $start >= length $self->{buffer} and $terminater++ > 1000;
- $self->{buffer} =~ /$regexp/g or return 0;
- my $finish = pos($self->{buffer});
- no strict 'refs';
- my $match = [ map $$_, 1..$#+ ];
- $match = [ $match ] if $#+ > 1;
+ pos($$buffer) = $self->{position};
+ $$buffer =~ /$regexp/g or return;
+
+ $self->{position} = pos($$buffer);
+
+ $self->{farthest} = $self->{position}
+ if $self->{position} > $self->{farthest};
- $self->position($finish);
+ no strict 'refs';
+ my $captures = [ map $$_, 1..$#+ ];
+ $captures = [ $captures ] if $#+ > 1;
- return $match;
+ return $captures;
}
sub match_all {
- my ($self, $list, $parent) = @_;
- my $pos = $self->position;
+ my ($self, $list) = @_;
+ my $position = $self->{position};
my $set = [];
my $len = 0;
for my $elem (@$list) {
if (my $match = $self->match_next($elem)) {
- next if $elem->{'+asr'} or $elem->{'-skip'};
- push @$set, @$match;
- $len++;
+ if (not ($elem->{'+asr'} or $elem->{'-skip'})) {
+ push @$set, @$match;
+ $len++;
+ }
}
else {
- $self->revert_back($pos);
- return 0;
+ $self->{farthest} = $position
+ if ($self->{position} = $position) > $self->{farthest};
+ return;
}
}
$set = [ $set ] if $len > 1;
@@ -281,13 +201,13 @@ sub match_all {
}
sub match_any {
- my ($self, $list, $parent) = @_;
+ my ($self, $list) = @_;
for my $elem (@$list) {
if (my $match = $self->match_next($elem)) {
return $match;
}
}
- return 0;
+ return;
}
sub match_err {
@@ -295,49 +215,73 @@ sub match_err {
$self->throw_error($error);
}
-sub match_code {
- my ($self, $code) = @_;
- my $method = "match_rule_$code";
- return $self->$method();
-}
-
sub trace {
- my $self = shift;
- my $action = shift;
+ my ($self, $action) = @_;
my $indent = ($action =~ /^try_/) ? 1 : 0;
$self->{indent} ||= 0;
$self->{indent}-- unless $indent;
print STDERR ' ' x $self->{indent};
$self->{indent}++ if $indent;
- my $snippet = substr($self->buffer, $self->position);
- $snippet = substr($snippet, 0, 30) . "..." if length $snippet > 30;
+ my $snippet = substr(${$self->{buffer}}, $self->{position});
+ $snippet = substr($snippet, 0, 30) . "..."
+ if length $snippet > 30;
$snippet =~ s/\n/\\n/g;
- print STDERR sprintf("%-30s", $action) . ($indent ? " >$snippet<\n" : "\n");
+ print STDERR sprintf("%-30s", $action) .
+ ($indent ? " >$snippet<\n" : "\n");
}
sub throw_error {
- my $self = shift;
- my $msg = shift;
- my $line = @{[substr($self->buffer, 0, $self->position) =~ /(\n)/g]} + 1;
- my $column = $self->position - rindex($self->buffer, "\n", $self->position);
- my $context = substr($self->buffer, $self->position, 50);
+ my ($self, $msg) = @_;
+ $@ = $self->{error} = $self->format_error($msg);
+ return undef unless $self->{throw_on_error};
+ require Carp;
+ Carp::croak($self->{error});
+}
+
+sub format_error {
+ my ($self, $msg) = @_;
+ my $buffer = $self->{buffer};
+ my $position = $self->{farthest};
+ my $real_pos = $self->{position};
+
+ my $line = @{[substr($$buffer, 0, $position) =~ /(\n)/g]} + 1;
+ my $column = $position - rindex($$buffer, "\n", $position);
+
+ my $pretext = substr(
+ $$buffer,
+ $position < 50 ? 0 : $position - 50,
+ $position < 50 ? $position : 50
+ );
+ my $context = substr($$buffer, $position, 50);
+ $pretext =~ s/.*\n//gs;
$context =~ s/\n/\\n/g;
- my $position = $self->position;
- my $error = <<"...";
+
+ return <<"...";
Error parsing Pegex document:
- msg: $msg
- line: $line
- column: $column
- context: "$context"
- position: $position
+ msg: $msg
+ line: $line
+ column: $column
+ context: $pretext$context
+ ${\ (' ' x (length($pretext) + 10) . '^')}
+ position: $position ($real_pos pre-lookahead)
...
- if ($self->throw_on_error) {
- require Carp;
- Carp::croak($error);
- }
- $@ = $error;
- return 0;
}
-1;
+# TODO Move this to a Parser helper role/subclass
+sub line_column {
+ my ($self, $position) = @_;
+ $position ||= $self->{position};
+ my $buffer = $self->{buffer};
+ my $line = @{[substr($$buffer, 0, $position) =~ /(\n)/g]} + 1;
+ my $column = $position - rindex($$buffer, "\n", $position);
+ return [$line, $position];
+}
+# XXX Need to figure out what uses this. (sample.t)
+{
+ package Pegex::Constant;
+ our $Null = [];
+ our $Dummy = [];
+}
+
+1;
@@ -1,16 +1,21 @@
-#line 1
-##
-# name: Pegex::Receiver
-# abstract: Pegex Receiver Base Class
-# author: Ingy döt Net <ingy@cpan.org>
-# license: perl
-# copyright: 2011
-
package Pegex::Receiver;
-use Pegex::Mo;
+use Pegex::Base;
+
+has parser => (); # The parser object.
+
+sub rule { $_[0]->{parser}{rule} }
-has 'parser';
-has 'data';
-has wrap => default => sub { 0 };
+# Flatten a structure of nested arrays into a single array in place.
+sub flatten {
+ my ($self, $array, $times) = @_;
+ $times = -1
+ unless defined $times;
+ while ($times-- and grep {ref($_) eq 'ARRAY'} @$array) {
+ @$array = map {
+ (ref($_) eq 'ARRAY') ? @$_ : $_
+ } @$array;
+ }
+ return $array;
+}
1;
@@ -0,0 +1,19 @@
+package Pegex::Tree;
+use Pegex::Base;
+extends 'Pegex::Receiver';
+
+sub gotrule {
+ my $self = shift;
+ @_ || return ();
+ return {$self->{parser}{rule} => $_[0]}
+ if $self->{parser}{parent}{-wrap};
+ return $_[0];
+}
+
+sub final {
+ my $self = shift;
+ return(shift) if @_;
+ return [];
+}
+
+1;
@@ -0,0 +1,32 @@
+use strict; use warnings;
+package Pegex;
+our $VERSION = '0.57';
+
+use Pegex::Parser;
+
+use Exporter 'import';
+our @EXPORT = 'pegex';
+
+sub pegex {
+ my ($grammar, $receiver) = @_;
+ die "Argument 'grammar' required in function 'pegex'"
+ unless $grammar;
+ if (not ref $grammar or $grammar->isa('Pegex::Input')) {
+ require Pegex::Grammar;
+ $grammar = Pegex::Grammar->new(text => $grammar),
+ }
+ if (not defined $receiver) {
+ require Pegex::Tree::Wrap;
+ $receiver = Pegex::Tree::Wrap->new;
+ }
+ elsif (not ref $receiver) {
+ eval "require $receiver; 1";
+ $receiver = $receiver->new;
+ }
+ return Pegex::Parser->new(
+ grammar => $grammar,
+ receiver => $receiver,
+ );
+}
+
+1;
@@ -1,197 +0,0 @@
-#line 1
-package TestML::AST;
-use Pegex::Mo;
-extends 'Pegex::Receiver';
-
-use TestML::Runtime;
-
-has points => default => sub{[]};
-has function => default => sub { TestML::Function->new };
-
-# sub final {
-# my ($self, $match, $top) = @_;
-# XXX $match;
-# }
-# __END__
-
-sub got_code_section {
- my ($self, $code) = @_;
- $self->function->statements($code);
-}
-
-sub got_assignment_statement {
- my ($self, $match) = @_;
- return TestML::Statement->new(
- expression => TestML::Expression->new(
- units => [
- TestML::Transform->new(
- name => 'Set',
- args => [
- $match->[0],
- $match->[1],
- ],
- ),
- ],
- ),
- );
-}
-
-sub got_code_statement {
- my ($self, $list) = @_;
- my ($expression, $assertion);
- my $points = $self->points;
- $self->points([]);
-
- for (@$list) {
- if (ref eq 'TestML::Expression') {
- $expression = $_;
- }
- if (ref eq 'TestML::Assertion') {
- $assertion = $_;
- }
- }
- return TestML::Statement->new(
- $expression ? ( expression => $expression ) : (),
- $assertion ? ( assertion => $assertion ) : (),
- @$points ? ( points => $points ) : (),
- );
-}
-
-sub got_code_expression {
- my ($self, $list) = @_;
- my $units = [];
- push @$units, shift @$list if @$list;
- $list = shift @$list || [];
- for (@$list) {
- my $unit = $_->[0]; #->{unit_call}[0][0];
- push @$units, $unit;
- }
- return TestML::Expression->new(
- units => $units,
- );
-}
-
-sub got_number_object {
- my ($self, $number) = @_;
- return TestML::Num->new(
- value => $number,
- );
-}
-
-sub got_string_object {
- my ($self, $string) = @_;
- return $self->make_str($string);
-}
-
-sub got_point_object {
- my ($self, $point) = @_;
- $point =~ s/^\*// or die;
- push @{$self->points}, $point;
- return TestML::Transform->new(
- name => 'Point',
- args => [$point],
- );
-}
-
-sub make_str {
- my ($self, $object) = @_;
- return TestML::Str->new(
- value => $object,
- );
-}
-sub got_assertion_call {
- my ($self, $call) = @_;
- my ($name, $assertion);
- for (qw( eq has ok )) {
- if ($assertion = $call->{"assertion_$_"}) {
- $name = uc $_;
- $assertion =
- $assertion->{"assertion_operator_$_"}[0] ||
- $assertion->{"assertion_function_$_"}[0];
- last;
- }
- }
- XXX $call unless $assertion;
- return TestML::Assertion->new(
- name => $name,
- expression => $assertion,
- );
-}
-
-sub got_assertion_function_ok {
- my ($self, $ok) = @_;
- return {
- assertion_function_ok => [
- TestML::Expression->new,
- ]
- }
-}
-
-sub got_function_start {
- my ($self) = @_;
- my $function = TestML::Function->new();
- $function->outer($self->function);
- $self->function($function);
- return 1;
-}
-
-sub got_function_object {
- my ($self, $object) = @_;
-
- my $function = $self->function;
- $self->function($self->function->outer);
-
- if (ref($object->[0]) and ref($object->[0][0])) {
- $function->signature($object->[0][0]);
- }
- $function->statements($object->[-1]);
-
- return $function;
-}
-
-sub got_transform_name {
- my ($self, $match) = @_;
- return TestML::Transform->new(name => $match);
-}
-
-sub got_transform_object {
- my ($self, $object) = @_;
- my $transform = $object->[0];
- if ($object->[1][-1] and $object->[1][-1] eq 'explicit') {
- $transform->explicit_call(1);
- splice @{$object->[1]}, -1, 1;
- }
- my $args = [];
- $args = $object->[1][0] if $object->[1][0];
- $transform->args($args) if @$args;
- return $transform;
-}
-
-sub got_transform_argument_list {
- my ($self, $list) = @_;
- push @$list, 'explicit';
- return $list;
-}
-
-#----------------------------------------------------------
-sub got_data_section {
- my ($self, $data) = @_;
- $self->function->data($data);
-}
-
-sub got_data_block {
- my ($self, $block) = @_;
- return TestML::Block->new(
- label => $block->[0][0][0],
- points => +{map %$_, @{$block->[1]}},
- );
-}
-
-sub got_block_point {
- my ($self, $point) = @_;
- return {
- $point->[0] => $point->[1],
- };
-}
-
-1;
@@ -0,0 +1,10 @@
+package TestML::Base;
+
+# use Mo qw'build default builder xxx import';
+# The following line of code was produced from the previous line by
+# Mo::Inline version 0.38
+no warnings;my$M=__PACKAGE__.'::';*{$M.Object::new}=sub{my$c=shift;my$s=bless{@_},$c;my%n=%{$c.::.':E'};map{$s->{$_}=$n{$_}->()if!exists$s->{$_}}keys%n;$s};*{$M.import}=sub{import warnings;$^H|=1538;my($P,%e,%o)=caller.'::';shift;eval"no Mo::$_",&{$M.$_.::e}($P,\%e,\%o,\@_)for@_;return if$e{M};%e=(extends,sub{eval"no $_[0]()";@{$P.ISA}=$_[0]},has,sub{my$n=shift;my$m=sub{$#_?$_[0]{$n}=$_[1]:$_[0]{$n}};@_=(default,@_)if!($#_%2);$m=$o{$_}->($m,$n,@_)for sort keys%o;*{$P.$n}=$m},%e,);*{$P.$_}=$e{$_}for keys%e;@{$P.ISA}=$M.Object};*{$M.'build::e'}=sub{my($P,$e)=@_;$e->{new}=sub{$c=shift;my$s=&{$M.Object::new}($c,@_);my@B;do{@B=($c.::BUILD,@B)}while($c)=@{$c.::ISA};exists&$_&&&$_($s)for@B;$s}};*{$M.'default::e'}=sub{my($P,$e,$o)=@_;$o->{default}=sub{my($m,$n,%a)=@_;exists$a{default}or return$m;my($d,$r)=$a{default};my$g='HASH'eq($r=ref$d)?sub{+{%$d}}:'ARRAY'eq$r?sub{[@$d]}:'CODE'eq$r?$d:sub{$d};my$i=exists$a{lazy}?$a{lazy}:!${$P.':N'};$i or ${$P.':E'}{$n}=$g and return$m;sub{$#_?$m->(@_):!exists$_[0]{$n}?$_[0]{$n}=$g->(@_):$m->(@_)}}};*{$M.'builder::e'}=sub{my($P,$e,$o)=@_;$o->{builder}=sub{my($m,$n,%a)=@_;my$b=$a{builder}or return$m;my$i=exists$a{lazy}?$a{lazy}:!${$P.':N'};$i or ${$P.':E'}{$n}=\&{$P.$b}and return$m;sub{$#_?$m->(@_):!exists$_[0]{$n}?$_[0]{$n}=$_[0]->$b:$m->(@_)}}};use constant XXX_skip=>1;my$dm='YAML::XS';*{$M.'xxx::e'}=sub{my($P,$e)=@_;$e->{WWW}=sub{require XXX;local$XXX::DumpModule=$dm;XXX::WWW(@_)};$e->{XXX}=sub{require XXX;local$XXX::DumpModule=$dm;XXX::XXX(@_)};$e->{YYY}=sub{require XXX;local$XXX::DumpModule=$dm;XXX::YYY(@_)};$e->{ZZZ}=sub{require XXX;local$XXX::DumpModule=$dm}};my$i=\&import;*{$M.import}=sub{(@_==2 and not$_[1])?pop@_:@_==1?push@_,grep!/import/,@f:();goto&$i};@f=qw[build default builder xxx import];use strict;use warnings;
+
+our $DumpModule = 'YAML';
+
+1;
@@ -0,0 +1,7 @@
+package TestML::Bridge;
+
+use TestML::Base;
+
+use TestML::Util 'runtime';
+
+1;
@@ -0,0 +1,219 @@
+package TestML::Compiler::Lite;
+
+use TestML::Base;
+extends 'TestML::Compiler';
+
+use TestML::Runtime;
+
+has input => ();
+has points => ();
+has tokens => ();
+has function => ();
+
+my $WS = qr!\s+!;
+my $ANY = qr!.!;
+my $STAR = qr!\*!;
+my $NUM = qr!-?[0-9]+!;
+my $WORD = qr!\w+!;
+my $HASH = qr!#!;
+my $EQ = qr!=!;
+my $TILDE = qr!~!;
+my $LP = qr!\(!;
+my $RP = qr!\)!;
+my $DOT = qr!\.!;
+my $COMMA = qr!,!;
+my $SEMI = qr!;!;
+my $SSTR = qr!'(?:[^']*)'!;
+my $DSTR = qr!"(?:[^"]*)"!;
+my $ENDING = qr!(?:$RP|$COMMA|$SEMI)!;
+
+my $POINT = qr!$STAR$WORD!;
+my $QSTR = qr!(?:$SSTR|$DSTR)!;
+my $COMP = qr!(?:$EQ$EQ|$TILDE$TILDE)!;
+my $OPER = qr!(?:$COMP|$EQ)!;
+my $PUNCT = qr!(?:$LP|$RP|$DOT|$COMMA|$SEMI)!;
+
+my $TOKENS = qr!(?:$POINT|$NUM|$WORD|$QSTR|$PUNCT|$OPER)!;
+
+sub compile_code {
+ my ($self) = @_;
+ $self->{function} = TestML::Function->new;
+ while (length $self->{code}) {
+ $self->{code} =~ s{^(.*)(\r\n|\n|)}{};
+ $self->{line} = $1;
+ $self->tokenize;
+ next if $self->done;
+ $self->parse_assignment ||
+ $self->parse_assertion ||
+ $self->fail;
+ }
+}
+
+sub tokenize {
+ my ($self) = @_;
+ $self->{tokens} = [];
+ while (length $self->{line}) {
+ next if $self->{line} =~ s/^$WS//;
+ next if $self->{line} =~ s/^$HASH$ANY*//;
+ if ($self->{line} =~ s/^($TOKENS)//) {
+ push @{$self->{tokens}}, $1;
+ }
+ else {
+ $self->fail("Failed to get token here: '$self->{line}'");
+ }
+ }
+}
+
+sub parse_assignment {
+ my ($self) = @_;
+ return unless $self->peek(2) eq '=';
+ my ($var, $op) = $self->pop(2);
+ my $expr = $self->parse_expression;
+ $self->pop if not $self->done and $self->peek eq ';';
+ $self->fail unless $self->done;
+ push @{$self->function->statements},
+ TestML::Assignment->new(name => $var, expr => $expr);
+ return 1;
+}
+
+sub parse_assertion {
+ my ($self) = @_;
+ return unless grep /^$COMP$/, @{$self->tokens};
+ $self->{points} = [];
+ my $left = $self->parse_expression;
+ my $token = $self->pop;
+ my $op =
+ $token eq '==' ? 'EQ' :
+ $token eq '~~' ? 'HAS' :
+ $self->fail;
+ my $right = $self->parse_expression;
+ $self->pop if not $self->done and $self->peek eq ';';
+ $self->fail unless $self->done;
+
+ push @{$self->function->statements}, TestML::Statement->new(
+ expr => $left,
+ assert => TestML::Assertion->new(
+ name => $op,
+ expr => $right,
+ ),
+ @{$self->points} ? (points => $self->points) : (),
+ );
+ return 1;
+}
+
+sub parse_expression {
+ my ($self) = @_;
+
+ my $calls = [];
+ while (not $self->done and $self->peek !~ /^($ENDING|$COMP)$/) {
+ my $token = $self->pop;
+ if ($token =~ /^$NUM$/) {
+ push @$calls, TestML::Num->new(value => $token + 0);
+ }
+ elsif ($token =~/^$QSTR$/) {
+ my $str = substr($token, 1, length($token) - 2);
+ push @$calls, TestML::Str->new(value => $str);
+ }
+ elsif ($token =~ /^$WORD$/) {
+ my $call = TestML::Call->new(name => $token);
+ if (not $self->done and $self->peek eq '(') {
+ $call->{args} = $self->parse_args;
+ }
+ push @$calls, $call;
+ }
+ elsif ($token =~ /^$POINT$/) {
+ $token =~ /($WORD)/ or die;
+ push @{$self->{points}}, $1;
+ push @$calls, TestML::Point->new(name => $1);
+ }
+ else {
+ $self->fail("Unknown token '$token'");
+ }
+ if (not $self->done and $self->peek eq '.') {
+ $self->pop;
+ }
+ }
+ return @$calls == 1
+ ? $calls->[0]
+ : TestML::Expression->new(calls => $calls);
+}
+
+sub parse_args {
+ my ($self) = @_;
+ $self->pop eq '(' or die;
+ my $args = [];
+ while ($self->peek ne ')') {
+ push @$args, $self->parse_expression;
+ $self->pop if $self->peek eq ',';
+ }
+ $self->pop;
+ return $args;
+}
+
+sub compile_data {
+ my ($self) = @_;
+ my $input = $self->data;
+ $input =~ s/^#.*\n/\n/mg;
+ $input =~ s/^\\//mg;
+ my @blocks = grep $_, split /(^===.*?(?=^===|\z))/ms, $input;
+ for my $block (@blocks) {
+ $block =~ s/\n+\z/\n/;
+ }
+
+ my $data = [];
+ for my $string_block (@blocks) {
+ my $block = TestML::Block->new;
+ $string_block =~ s/^===\ +(.*?)\ *\n//g
+ or die "No block label! $string_block";
+ $block->{label} = $1;
+ while (length $string_block) {
+ next if $string_block =~ s/^\n+//;
+ my ($key, $value);
+ if ($string_block =~ s/\A---\ +(\w+):\ +(.*)\n//g or
+ $string_block =~ s/\A---\ +(\w+)\n(.*?)(?=^---|\z)//msg
+ ) {
+ ($key, $value) = ($1, $2);
+ }
+ else {
+ die "Failed to parse TestML string:\n$string_block";
+ }
+ $block->{points} ||= {};
+ $block->{points}{$key} = $value;
+
+ if ($key =~ /^(ONLY|SKIP|LAST)$/) {
+ $block->{$key} = 1;
+ }
+ }
+ push @$data, $block;
+ }
+ $self->function->{data} = $data if @$data;
+}
+
+sub done {
+ my ($self) = @_;
+ @{$self->{tokens}} ? 0 : 1
+}
+
+sub peek {
+ my ($self, $index) = @_;
+ $index ||= 1;
+ die if $index > @{$self->{tokens}};
+ $self->{tokens}->[$index - 1];
+}
+
+sub pop {
+ my ($self, $count) = @_;
+ $count ||= 1;
+ die if $count > @{$self->{tokens}};
+ splice @{$self->{tokens}}, 0, $count;
+}
+
+sub fail {
+ my ($self, $message) = @_;
+ my $text = "Failed to compile TestML document.\n";
+ $text .= "Reason: $message\n" if $message;
+ $text .= "\nCode section of failure:\n$self->{line}\n$self->{code}\n";
+ die $text;
+}
+
+1;
@@ -0,0 +1,200 @@
+package TestML::Compiler::Pegex::AST;
+
+use TestML::Base;
+extends 'Pegex::Tree';
+
+use TestML::Runtime;
+
+has points => [];
+has function => sub { TestML::Function->new };
+
+# sub final {
+# my ($self, $match, $top) = @_;
+# XXX $match;
+# }
+# __END__
+
+sub got_code_section {
+ my ($self, $code) = @_;
+ $self->function->{statements} = $code;
+}
+
+sub got_assignment_statement {
+ my ($self, $match) = @_;
+ return TestML::Assignment->new(
+ name => $match->[0],
+ expr => $match->[1],
+ );
+}
+
+sub got_code_statement {
+ my ($self, $list) = @_;
+ my ($expression, $assertion);
+ my $points = $self->points;
+ $self->{points} = [];
+
+ for (@$list) {
+ if (ref eq 'TestML::Assertion') {
+ $assertion = $_;
+ }
+ else {
+ #if (ref eq 'TestML::Expression') {
+ $expression = $_;
+ }
+ }
+ return TestML::Statement->new(
+ $expression ? ( expr => $expression ) : (),
+ $assertion ? ( assert => $assertion ) : (),
+ @$points ? ( points => $points ) : (),
+ );
+}
+
+sub got_code_expression {
+ my ($self, $list) = @_;
+ my $calls = [];
+ push @$calls, shift @$list if @$list;
+ $list = shift @$list || [];
+ for (@$list) {
+ my $call = $_->[0]; #->{call_call}[0][0];
+ push @$calls, $call;
+ }
+ return $calls->[0] if @$calls == 1;
+ return TestML::Expression->new(
+ calls => $calls,
+ );
+}
+
+sub got_string_object {
+ my ($self, $string) = @_;
+ return TestML::Str->new(
+ value => $string,
+ );
+}
+
+sub got_double_quoted_string {
+ my ($self, $string) = @_;
+ $string =~ s/\\n/\n/g;
+ return $string;
+}
+
+sub got_number_object {
+ my ($self, $number) = @_;
+ return TestML::Num->new(
+ value => $number + 0,
+ );
+}
+
+sub got_point_object {
+ my ($self, $point) = @_;
+ $point =~ s/^\*// or die;
+ push @{$self->points}, $point;
+ return TestML::Point->new(
+ name => $point,
+ );
+}
+
+sub got_assertion_call {
+ my ($self, $call) = @_;
+ # XXX $call strangley becomes an array when $PERL_PEGEX_DEBUG is on.
+ # Workaround for now, until I figure it out.
+ $call = $call->[0] if ref $call eq 'ARRAY';
+ my ($name, $expr);
+ for (qw( eq has ok )) {
+ if ($expr = $call->{"assertion_$_"}) {
+ $name = uc $_;
+ $expr =
+ $expr->{"assertion_operator_$_"}[0] ||
+ $expr->{"assertion_function_$_"}[0];
+ last;
+ }
+ }
+ return TestML::Assertion->new(
+ name => $name,
+ $expr ? (expr => $expr) : (),
+ );
+}
+
+sub got_assertion_function_ok {
+ my ($self, $ok) = @_;
+ return {
+ assertion_function_ok => [],
+ }
+}
+
+sub got_function_start {
+ my ($self) = @_;
+ my $function = TestML::Function->new;
+ $function->outer($self->function);
+ $self->{function} = $function;
+ return 1;
+}
+
+sub got_function_object {
+ my ($self, $object) = @_;
+
+ my $function = $self->function;
+ $self->{function} = $function->outer;
+
+ if (ref($object->[0]) and ref($object->[0][0])) {
+ $function->{signature} = $object->[0][0];
+ }
+ $function->{statements} = $object->[-1];
+
+ return $function;
+}
+
+sub got_call_name {
+ my ($self, $name) = @_;
+ return TestML::Call->new(name => $name);
+}
+
+sub got_call_object {
+ my ($self, $object) = @_;
+ my $call = $object->[0];
+ my $args = $object->[1][-1];
+ if ($args) {
+ $args = [
+ map {
+ ($_->isa('TestML::Expression') and @{$_->calls} == 1 and
+ (
+ $_->calls->[0]->isa('TestML::Point') ||
+ $_->calls->[0]->isa('TestML::Object')
+ )) ? $_->calls->[0] : $_;
+ } @$args
+ ];
+ $call->args($args)
+ }
+ return $call;
+}
+
+sub got_call_argument_list {
+ my ($self, $list) = @_;
+ return $list;
+}
+
+sub got_call_indicator {
+ my ($self) = @_;
+ return;
+}
+
+sub got_data_section {
+ my ($self, $data) = @_;
+ $self->function->data($data);
+}
+
+sub got_data_block {
+ my ($self, $block) = @_;
+ return TestML::Block->new(
+ label => $block->[0][0][0],
+ points => +{map %$_, @{$block->[1]}},
+ );
+}
+
+sub got_block_point {
+ my ($self, $point) = @_;
+ return {
+ $point->[0] => $point->[1],
+ };
+}
+
+1;
@@ -0,0 +1,521 @@
+package TestML::Compiler::Pegex::Grammar;
+
+use TestML::Base;
+extends 'Pegex::Grammar';
+
+use constant file => '../testml-pgx/testml.pgx';
+
+sub make_tree { # Generated/Inlined by Pegex::Grammar (0.43)
+ {
+ '+grammar' => 'testml',
+ '+include' => 'atom',
+ '+toprule' => 'testml_document',
+ '+version' => '0.0.1',
+ '__' => {
+ '.rgx' => qr/\G(?:[\ \t]|\r?\n|\#.*\r?\n)+/
+ },
+ 'assertion_call' => {
+ '.any' => [
+ {
+ '-wrap' => 1,
+ '.ref' => 'assertion_eq'
+ },
+ {
+ '-wrap' => 1,
+ '.ref' => 'assertion_ok'
+ },
+ {
+ '-wrap' => 1,
+ '.ref' => 'assertion_has'
+ }
+ ]
+ },
+ 'assertion_call_test' => {
+ '.rgx' => qr/\G(?:\.(?:[\ \t]|\r?\n|\#.*\r?\n)*|(?:[\ \t]|\r?\n|\#.*\r?\n)*\.)(?:EQ|OK|HAS)/
+ },
+ 'assertion_eq' => {
+ '.any' => [
+ {
+ '-wrap' => 1,
+ '.ref' => 'assertion_operator_eq'
+ },
+ {
+ '-wrap' => 1,
+ '.ref' => 'assertion_function_eq'
+ }
+ ]
+ },
+ 'assertion_function_eq' => {
+ '.all' => [
+ {
+ '.rgx' => qr/\G(?:\.(?:[\ \t]|\r?\n|\#.*\r?\n)*|(?:[\ \t]|\r?\n|\#.*\r?\n)*\.)EQ\(/
+ },
+ {
+ '.ref' => 'code_expression'
+ },
+ {
+ '.rgx' => qr/\G\)/
+ }
+ ]
+ },
+ 'assertion_function_has' => {
+ '.all' => [
+ {
+ '.rgx' => qr/\G(?:\.(?:[\ \t]|\r?\n|\#.*\r?\n)*|(?:[\ \t]|\r?\n|\#.*\r?\n)*\.)HAS\(/
+ },
+ {
+ '.ref' => 'code_expression'
+ },
+ {
+ '.rgx' => qr/\G\)/
+ }
+ ]
+ },
+ 'assertion_function_ok' => {
+ '.rgx' => qr/\G(?:\.(?:[\ \t]|\r?\n|\#.*\r?\n)*|(?:[\ \t]|\r?\n|\#.*\r?\n)*\.)(OK)(?:\((?:[\ \t]|\r?\n|\#.*\r?\n)*\))?/
+ },
+ 'assertion_has' => {
+ '.any' => [
+ {
+ '-wrap' => 1,
+ '.ref' => 'assertion_operator_has'
+ },
+ {
+ '-wrap' => 1,
+ '.ref' => 'assertion_function_has'
+ }
+ ]
+ },
+ 'assertion_ok' => {
+ '.ref' => 'assertion_function_ok'
+ },
+ 'assertion_operator_eq' => {
+ '.all' => [
+ {
+ '.rgx' => qr/\G(?:[\ \t]|\r?\n|\#.*\r?\n)+==(?:[\ \t]|\r?\n|\#.*\r?\n)+/
+ },
+ {
+ '.ref' => 'code_expression'
+ }
+ ]
+ },
+ 'assertion_operator_has' => {
+ '.all' => [
+ {
+ '.rgx' => qr/\G(?:[\ \t]|\r?\n|\#.*\r?\n)+\~\~(?:[\ \t]|\r?\n|\#.*\r?\n)+/
+ },
+ {
+ '.ref' => 'code_expression'
+ }
+ ]
+ },
+ 'assignment_statement' => {
+ '.all' => [
+ {
+ '.ref' => 'variable_name'
+ },
+ {
+ '.rgx' => qr/\G\s+=\s+/
+ },
+ {
+ '.ref' => 'code_expression'
+ },
+ {
+ '.ref' => 'ending'
+ }
+ ]
+ },
+ 'blank_line' => {
+ '.rgx' => qr/\G[\ \t]*\r?\n/
+ },
+ 'blanks' => {
+ '.rgx' => qr/\G[\ \t]+/
+ },
+ 'block_header' => {
+ '.all' => [
+ {
+ '.ref' => 'block_marker'
+ },
+ {
+ '+max' => 1,
+ '.all' => [
+ {
+ '.ref' => 'blanks'
+ },
+ {
+ '.ref' => 'block_label'
+ }
+ ]
+ },
+ {
+ '.ref' => 'blank_line'
+ }
+ ]
+ },
+ 'block_label' => {
+ '.ref' => 'unquoted_string'
+ },
+ 'block_marker' => {
+ '.rgx' => qr/\G===/
+ },
+ 'block_point' => {
+ '.any' => [
+ {
+ '.ref' => 'lines_point'
+ },
+ {
+ '.ref' => 'phrase_point'
+ }
+ ]
+ },
+ 'call_argument' => {
+ '.ref' => 'code_expression'
+ },
+ 'call_argument_list' => {
+ '.all' => [
+ {
+ '.rgx' => qr/\G\((?:[\ \t]|\r?\n|\#.*\r?\n)*/
+ },
+ {
+ '+max' => 1,
+ '.all' => [
+ {
+ '.ref' => 'call_argument'
+ },
+ {
+ '+min' => 0,
+ '-flat' => 1,
+ '.all' => [
+ {
+ '.rgx' => qr/\G(?:[\ \t]|\r?\n|\#.*\r?\n)*,(?:[\ \t]|\r?\n|\#.*\r?\n)*/
+ },
+ {
+ '.ref' => 'call_argument'
+ }
+ ]
+ }
+ ]
+ },
+ {
+ '.rgx' => qr/\G(?:[\ \t]|\r?\n|\#.*\r?\n)*\)/
+ }
+ ]
+ },
+ 'call_call' => {
+ '.all' => [
+ {
+ '+asr' => -1,
+ '.ref' => 'assertion_call_test'
+ },
+ {
+ '.ref' => 'call_indicator'
+ },
+ {
+ '.ref' => 'code_object'
+ }
+ ]
+ },
+ 'call_indicator' => {
+ '.rgx' => qr/\G(?:\.(?:[\ \t]|\r?\n|\#.*\r?\n)*|(?:[\ \t]|\r?\n|\#.*\r?\n)*\.)/
+ },
+ 'call_name' => {
+ '.any' => [
+ {
+ '.ref' => 'user_call'
+ },
+ {
+ '.ref' => 'core_call'
+ }
+ ]
+ },
+ 'call_object' => {
+ '.all' => [
+ {
+ '.ref' => 'call_name'
+ },
+ {
+ '+max' => 1,
+ '.ref' => 'call_argument_list'
+ }
+ ]
+ },
+ 'code_expression' => {
+ '.all' => [
+ {
+ '.ref' => 'code_object'
+ },
+ {
+ '+min' => 0,
+ '.ref' => 'call_call'
+ }
+ ]
+ },
+ 'code_object' => {
+ '.any' => [
+ {
+ '.ref' => 'function_object'
+ },
+ {
+ '.ref' => 'point_object'
+ },
+ {
+ '.ref' => 'string_object'
+ },
+ {
+ '.ref' => 'number_object'
+ },
+ {
+ '.ref' => 'call_object'
+ }
+ ]
+ },
+ 'code_section' => {
+ '+min' => 0,
+ '.any' => [
+ {
+ '.ref' => '__'
+ },
+ {
+ '.ref' => 'assignment_statement'
+ },
+ {
+ '.ref' => 'code_statement'
+ }
+ ]
+ },
+ 'code_statement' => {
+ '.all' => [
+ {
+ '.ref' => 'code_expression'
+ },
+ {
+ '+max' => 1,
+ '.ref' => 'assertion_call'
+ },
+ {
+ '.ref' => 'ending'
+ }
+ ]
+ },
+ 'comment' => {
+ '.rgx' => qr/\G\#.*\r?\n/
+ },
+ 'core_call' => {
+ '.rgx' => qr/\G([A-Z]\w*)/
+ },
+ 'data_block' => {
+ '.all' => [
+ {
+ '.ref' => 'block_header'
+ },
+ {
+ '+min' => 0,
+ '-skip' => 1,
+ '.any' => [
+ {
+ '.ref' => 'blank_line'
+ },
+ {
+ '.ref' => 'comment'
+ }
+ ]
+ },
+ {
+ '+min' => 0,
+ '.ref' => 'block_point'
+ }
+ ]
+ },
+ 'data_section' => {
+ '+min' => 0,
+ '.ref' => 'data_block'
+ },
+ 'double_quoted_string' => {
+ '.rgx' => qr/\G(?:"((?:[^\n\\"]|\\"|\\\\|\\[0nt])*?)")/
+ },
+ 'ending' => {
+ '.any' => [
+ {
+ '.rgx' => qr/\G(?:;|\r?\n)/
+ },
+ {
+ '+asr' => 1,
+ '.ref' => 'ending2'
+ }
+ ]
+ },
+ 'ending2' => {
+ '.rgx' => qr/\G(?:[\ \t]|\r?\n|\#.*\r?\n)*\}/
+ },
+ 'function_object' => {
+ '.all' => [
+ {
+ '+max' => 1,
+ '.ref' => 'function_signature'
+ },
+ {
+ '.ref' => 'function_start'
+ },
+ {
+ '+min' => 0,
+ '.any' => [
+ {
+ '.ref' => '__'
+ },
+ {
+ '.ref' => 'assignment_statement'
+ },
+ {
+ '.ref' => 'code_statement'
+ }
+ ]
+ },
+ {
+ '.rgx' => qr/\G(?:[\ \t]|\r?\n|\#.*\r?\n)*\}/
+ }
+ ]
+ },
+ 'function_signature' => {
+ '.all' => [
+ {
+ '.rgx' => qr/\G\((?:[\ \t]|\r?\n|\#.*\r?\n)*/
+ },
+ {
+ '+max' => 1,
+ '.ref' => 'function_variables'
+ },
+ {
+ '.rgx' => qr/\G(?:[\ \t]|\r?\n|\#.*\r?\n)*\)/
+ }
+ ]
+ },
+ 'function_start' => {
+ '.rgx' => qr/\G(?:[\ \t]|\r?\n|\#.*\r?\n)*(\{)(?:[\ \t]|\r?\n|\#.*\r?\n)*/
+ },
+ 'function_variable' => {
+ '.rgx' => qr/\G([a-zA-Z]\w*)/
+ },
+ 'function_variables' => {
+ '.all' => [
+ {
+ '.ref' => 'function_variable'
+ },
+ {
+ '+min' => 0,
+ '-flat' => 1,
+ '.all' => [
+ {
+ '.rgx' => qr/\G(?:[\ \t]|\r?\n|\#.*\r?\n)*,(?:[\ \t]|\r?\n|\#.*\r?\n)*/
+ },
+ {
+ '.ref' => 'function_variable'
+ }
+ ]
+ }
+ ]
+ },
+ 'lines_point' => {
+ '.all' => [
+ {
+ '.ref' => 'point_marker'
+ },
+ {
+ '.ref' => 'blanks'
+ },
+ {
+ '.ref' => 'point_name'
+ },
+ {
+ '.ref' => 'blank_line'
+ },
+ {
+ '.ref' => 'point_lines'
+ }
+ ]
+ },
+ 'number' => {
+ '.rgx' => qr/\G([0-9]+)/
+ },
+ 'number_object' => {
+ '.ref' => 'number'
+ },
+ 'phrase_point' => {
+ '.all' => [
+ {
+ '.ref' => 'point_marker'
+ },
+ {
+ '.ref' => 'blanks'
+ },
+ {
+ '.ref' => 'point_name'
+ },
+ {
+ '.rgx' => qr/\G:[\ \t]/
+ },
+ {
+ '.ref' => 'point_phrase'
+ },
+ {
+ '.rgx' => qr/\G\r?\n/
+ },
+ {
+ '.rgx' => qr/\G(?:\#.*\r?\n|[\ \t]*\r?\n)*/
+ }
+ ]
+ },
+ 'point_lines' => {
+ '.rgx' => qr/\G((?:(?!(?:===|\-\-\-)\ \w).*\r?\n)*)/
+ },
+ 'point_marker' => {
+ '.rgx' => qr/\G\-\-\-/
+ },
+ 'point_name' => {
+ '.rgx' => qr/\G([a-z]\w*|[A-Z]\w*)/
+ },
+ 'point_object' => {
+ '.rgx' => qr/\G(\*[a-z]\w*)/
+ },
+ 'point_phrase' => {
+ '.ref' => 'unquoted_string'
+ },
+ 'quoted_string' => {
+ '.any' => [
+ {
+ '.ref' => 'single_quoted_string'
+ },
+ {
+ '.ref' => 'double_quoted_string'
+ }
+ ]
+ },
+ 'single_quoted_string' => {
+ '.rgx' => qr/\G(?:'((?:[^\n\\']|\\'|\\\\)*?)')/
+ },
+ 'string_object' => {
+ '.ref' => 'quoted_string'
+ },
+ 'testml_document' => {
+ '.all' => [
+ {
+ '.ref' => 'code_section'
+ },
+ {
+ '+max' => 1,
+ '.ref' => 'data_section'
+ }
+ ]
+ },
+ 'unquoted_string' => {
+ '.rgx' => qr/\G([^\ \t\n\#](?:[^\n\#]*[^\ \t\n\#])?)/
+ },
+ 'user_call' => {
+ '.rgx' => qr/\G([a-z]\w*)/
+ },
+ 'variable_name' => {
+ '.rgx' => qr/\G([a-zA-Z]\w*)/
+ }
+ }
+}
+
+1;
@@ -0,0 +1,61 @@
+package TestML::Compiler::Pegex;
+
+use TestML::Base;
+extends 'TestML::Compiler';
+
+use TestML::Compiler::Pegex::Grammar;
+use TestML::Compiler::Pegex::AST;
+use Pegex::Parser;
+
+has parser => ();
+
+sub compile_code {
+ my ($self) = @_;
+
+ $self->{parser} = Pegex::Parser->new(
+ grammar => TestML::Compiler::Pegex::Grammar->new,
+ receiver => TestML::Compiler::Pegex::AST->new,
+ );
+ $self->fixup_grammar;
+
+ $self->parser->parse($self->code, 'code_section')
+ or die "Parse TestML code section failed";
+}
+
+sub compile_data {
+ my ($self) = @_;
+
+ if (length $self->data) {
+ $self->parser->parse($self->data, 'data_section')
+ or die "Parse TestML data section failed";
+ }
+
+ $self->{function} = $self->parser->receiver->function;
+}
+
+# TODO This can be moved to the AST some day.
+sub fixup_grammar {
+ my ($self) = @_;
+
+ my $tree = $self->{parser}->grammar->tree;
+
+ my $point_lines = $tree->{point_lines}{'.rgx'};
+
+ my $block_marker = $self->directives->{BlockMarker};
+ if ($block_marker) {
+ $block_marker =~ s/([\$\%\^\*\+\?\|])/\\$1/g;
+ $tree->{block_marker}{'.rgx'} = qr/\G$block_marker/;
+ $point_lines =~ s/===/$block_marker/;
+ }
+
+ my $point_marker = $self->directives->{PointMarker};
+ if ($point_marker) {
+ $point_marker =~ s/([\$\%\^\*\+\?\|])/\\$1/g;
+ $tree->{point_marker}{'.rgx'} = qr/\G$point_marker/;
+ $point_lines =~ s/\\-\\-\\-/$point_marker/;
+ }
+
+ $tree->{point_lines}{'.rgx'} = qr/$point_lines/;
+}
+
+1;
@@ -1,60 +1,39 @@
-#line 1
+use TestML::Runtime;
+
package TestML::Compiler;
-use TestML::Mo;
-use TestML::Grammar;
-use TestML::AST;
+use TestML::Base;
-has base => ();
+has code => ();
+has data => ();
+has text => ();
+has directives => ();
+has function => ();
sub compile {
- my $self = shift;
- my $file = shift;
- if (not ref $file and $file !~ /\n/) {
- $file =~ s/(.*)\/(.*)/$2/ or die;
- $self->base($1);
- }
- my $input = (not ref($file) and $file =~ /\n/)
- ? $file
- : $self->slurp($file);
-
- my $result = $self->preprocess($input, 'top');
-
- my ($code, $data) = @$result{qw(code data)};
+ my ($self, $input) = @_;
- my $grammar = TestML::Grammar->new(
- receiver => TestML::AST->new,
- );
- $grammar->parse($code, 'code_section')
- or die "Parse TestML code section failed";
-
- $self->fixup_grammar($grammar, $result);
-
- if (length $data) {
- $grammar->parse($data, 'data_section')
- or die "Parse TestML data section failed";
- }
+ $self->preprocess($input, 'top');
+ $self->compile_code;
+ $self->compile_data;
- if ($result->{DumpAST}) {
- XXX($grammar->receiver->function);
+ if ($self->directives->{DumpAST}) {
+ XXX($self->function);
}
- my $function = $grammar->receiver->function;
- $function->outer(TestML::Function->new());
+ $self->function->namespace->{TestML} = $self->directives->{TestML};
- return $function;
+ $self->function->outer(TestML::Function->new);
+ return $self->function;
}
sub preprocess {
- my $self = shift;
- my $text = shift;
- my $top = shift;
+ my ($self, $input, $top) = @_;
- my @parts = split /^((?:\%\w+.*|\#.*|\ *)\n)/m, $text;
+ my @parts = split /^((?:\%\w+.*|\#.*|\ *)\n)/m, $input;
+ $input = '';
- $text = '';
-
- my $result = {
+ $self->{directives} = {
TestML => '',
DataMarker => '',
BlockMarker => '===',
@@ -65,117 +44,75 @@ sub preprocess {
for my $part (@parts) {
next unless length($part);
if ($part =~ /^(\#.*|\ *)\n/) {
- $text .= "\n";
+ $input .= "\n";
next;
}
if ($part =~ /^%(\w+)\s*(.*?)\s*\n/) {
my ($directive, $value) = ($1, $2);
- $text .= "\n";
+ $input .= "\n";
if ($directive eq 'TestML') {
die "Invalid TestML directive"
- unless $value =~ /^\d+\.\d+$/;
+ unless $value =~ /^\d+\.\d+\.\d+$/;
die "More than one TestML directive found"
- if $result->{TestML};
- $result->{TestML} = TestML::Str->new(value => $value);
+ if $self->directives->{TestML};
+ $self->directives->{TestML} =
+ TestML::Str->new(value => $value);
next;
}
- $order_error = 1 unless $result->{TestML};
+ $order_error = 1 unless $self->directives->{TestML};
if ($directive eq 'Include') {
- my $sub_result = $self->preprocess($self->slurp($value));
- $text .= $sub_result->{text};
- $result->{DataMarker} = $sub_result->{DataMarker};
- $result->{BlockMarker} = $sub_result->{BlockMarker};
- $result->{PointMarker} = $sub_result->{PointMarker};
+ my $runtime = $TestML::Runtime::Singleton
+ or die "Can't process Include. No runtime available";
+ my $include = ref($self)->new;
+ $include->preprocess($runtime->read_testml_file($value));
+ $input .= $include->text;
+ $self->directives->{DataMarker} =
+ $include->directives->{DataMarker};
+ $self->directives->{BlockMarker} =
+ $include->directives->{BlockMarker};
+ $self->directives->{PointMarker} =
+ $include->directives->{PointMarker};
die "Can't define %TestML in an Included file"
- if $sub_result->{TestML};
+ if $include->directives->{TestML};
}
elsif ($directive =~ /^(DataMarker|BlockMarker|PointMarker)$/) {
- $result->{$directive} = $value;
+ $self->directives->{$directive} = $value;
}
elsif ($directive =~ /^(DebugPegex|DumpAST)$/) {
$value = 1 unless length($value);
- $result->{$directive} = $value;
+ $self->directives->{$directive} = $value;
}
else {
die "Unknown TestML directive '$directive'";
}
}
else {
- $order_error = 1 if $text and not $result->{TestML};
- $text .= $part;
+ $order_error = 1 if $input and not $self->directives->{TestML};
+ $input .= $part;
}
}
if ($top) {
die "No TestML directive found"
- unless $result->{TestML};
+ unless $self->directives->{TestML};
die "%TestML directive must be the first (non-comment) statement"
if $order_error;
- my $DataMarker = $result->{DataMarker} ||= $result->{BlockMarker};
- my ($code, $data);
- if ((my $split = index($text, "\n$DataMarker")) >= 0) {
- $result->{code} = substr($text, 0, $split + 1);
- $result->{data} = substr($text, $split + 1);
+ my $DataMarker =
+ $self->directives->{DataMarker} ||=
+ $self->directives->{BlockMarker};
+ if ((my $split = index($input, "\n$DataMarker")) >= 0) {
+ $self->{code} = substr($input, 0, $split + 1);
+ $self->{data} = substr($input, $split + 1);
}
else {
- $result->{code} = $text;
- $result->{data} = '';
+ $self->{code} = $input;
+ $self->{data} = '';
}
-
- $result->{code} =~ s/^\\(\\*[\%\#])/$1/gm;
- $result->{data} =~ s/^\\(\\*[\%\#])/$1/gm;
- }
- else {
- $result->{text} = $text;
- }
-
- return $result;
-}
-
-sub fixup_grammar {
- my $self = shift;
- my $grammar = shift;
- my $hash = shift;
-
- my $namespace = $grammar->receiver->function->namespace;
- $namespace->{TestML} = $hash->{TestML};
-
- my $tree = $grammar->tree;
-
- my $point_lines = $tree->{point_lines}{'.rgx'};
-
- my $block_marker = $hash->{BlockMarker};
- if ($block_marker) {
- $block_marker =~ s/([\$\%\^\*\+\?\|])/\\$1/g;
- $tree->{block_marker}{'.rgx'} = qr/\G$block_marker/;
- $point_lines =~ s/===/$block_marker/;
- }
-
- my $point_marker = $hash->{PointMarker};
- if ($point_marker) {
- $point_marker =~ s/([\$\%\^\*\+\?\|])/\\$1/g;
- $tree->{point_marker}{'.rgx'} = qr/\G$point_marker/;
- $point_lines =~ s/\\-\\-\\-/$point_marker/;
- }
-
- $tree->{point_lines}{'.rgx'} = qr/$point_lines/;
-}
-
-sub slurp {
- my $self = shift;
- my $file = shift;
- my $fh;
- if (ref($file)) {
- $fh = $file;
}
else {
- my $path = join '/', $self->base, $file;
- open $fh, $path
- or die "Can't open '$path' for input: $!";
+ $self->{text} = $input;
}
- local $/;
- return <$fh>;
}
1;
@@ -1,479 +0,0 @@
-#line 1
-package TestML::Grammar;
-use TestML::Mo;
-extends 'Pegex::Grammar';
-
-sub tree_ {
- {
- '+top' => 'testml_document',
- 'assertion_call' => {
- '.any' => [
- {
- '-wrap' => 1,
- '.ref' => 'assertion_eq'
- },
- {
- '-wrap' => 1,
- '.ref' => 'assertion_ok'
- },
- {
- '-wrap' => 1,
- '.ref' => 'assertion_has'
- }
- ]
- },
- 'assertion_call_test' => {
- '.rgx' => qr/(?-xism:\G(?:\.(?:[\ \t]|\r?\n|\#.*\r?\n)*|(?:[\ \t]|\r?\n|\#.*\r?\n)*\.)(?:EQ|OK|HAS))/
- },
- 'assertion_eq' => {
- '.any' => [
- {
- '-wrap' => 1,
- '.ref' => 'assertion_operator_eq'
- },
- {
- '-wrap' => 1,
- '.ref' => 'assertion_function_eq'
- }
- ]
- },
- 'assertion_function_eq' => {
- '.all' => [
- {
- '.rgx' => qr/(?-xism:\G(?:\.(?:[\ \t]|\r?\n|\#.*\r?\n)*|(?:[\ \t]|\r?\n|\#.*\r?\n)*\.)EQ\()/
- },
- {
- '.ref' => 'code_expression'
- },
- {
- '.rgx' => qr/(?-xism:\G\))/
- }
- ]
- },
- 'assertion_function_has' => {
- '.all' => [
- {
- '.rgx' => qr/(?-xism:\G(?:\.(?:[\ \t]|\r?\n|\#.*\r?\n)*|(?:[\ \t]|\r?\n|\#.*\r?\n)*\.)HAS\()/
- },
- {
- '.ref' => 'code_expression'
- },
- {
- '.rgx' => qr/(?-xism:\G\))/
- }
- ]
- },
- 'assertion_function_ok' => {
- '.rgx' => qr/(?-xism:\G(?:\.(?:[\ \t]|\r?\n|\#.*\r?\n)*|(?:[\ \t]|\r?\n|\#.*\r?\n)*\.)(OK)(?:\((?:[\ \t]|\r?\n|\#.*\r?\n)*\))?)/
- },
- 'assertion_has' => {
- '.any' => [
- {
- '-wrap' => 1,
- '.ref' => 'assertion_operator_has'
- },
- {
- '-wrap' => 1,
- '.ref' => 'assertion_function_has'
- }
- ]
- },
- 'assertion_ok' => {
- '.ref' => 'assertion_function_ok'
- },
- 'assertion_operator_eq' => {
- '.all' => [
- {
- '.rgx' => qr/(?-xism:\G(?:[\ \t]|\r?\n|\#.*\r?\n)+==(?:[\ \t]|\r?\n|\#.*\r?\n)+)/
- },
- {
- '.ref' => 'code_expression'
- }
- ]
- },
- 'assertion_operator_has' => {
- '.all' => [
- {
- '.rgx' => qr/(?-xism:\G(?:[\ \t]|\r?\n|\#.*\r?\n)+~~(?:[\ \t]|\r?\n|\#.*\r?\n)+)/
- },
- {
- '.ref' => 'code_expression'
- }
- ]
- },
- 'assignment_statement' => {
- '.all' => [
- {
- '.ref' => 'variable_name'
- },
- {
- '.rgx' => qr/(?-xism:\G\s+=\s+)/
- },
- {
- '.ref' => 'code_expression'
- },
- {
- '.ref' => 'semicolon'
- }
- ]
- },
- 'blank_line' => {
- '.rgx' => qr/(?-xism:\G[\ \t]*\r?\n)/
- },
- 'block_header' => {
- '.all' => [
- {
- '.ref' => 'block_marker'
- },
- {
- '+max' => 1,
- '.all' => [
- {
- '.rgx' => qr/(?-xism:\G[\ \t]+)/
- },
- {
- '.ref' => 'block_label'
- }
- ]
- },
- {
- '.rgx' => qr/(?-xism:\G[\ \t]*\r?\n)/
- }
- ]
- },
- 'block_label' => {
- '.ref' => 'unquoted_string'
- },
- 'block_marker' => {
- '.rgx' => qr/(?-xism:\G===)/
- },
- 'block_point' => {
- '.any' => [
- {
- '.ref' => 'lines_point'
- },
- {
- '.ref' => 'phrase_point'
- }
- ]
- },
- 'call_indicator' => {
- '.rgx' => qr/(?-xism:\G(?:\.(?:[\ \t]|\r?\n|\#.*\r?\n)*|(?:[\ \t]|\r?\n|\#.*\r?\n)*\.))/
- },
- 'code_expression' => {
- '.all' => [
- {
- '.ref' => 'code_object'
- },
- {
- '+min' => 0,
- '.ref' => 'unit_call'
- }
- ]
- },
- 'code_object' => {
- '.any' => [
- {
- '.ref' => 'function_object'
- },
- {
- '.ref' => 'point_object'
- },
- {
- '.ref' => 'string_object'
- },
- {
- '.ref' => 'number_object'
- },
- {
- '.ref' => 'transform_object'
- }
- ]
- },
- 'code_section' => {
- '+min' => 0,
- '.any' => [
- {
- '.rgx' => qr/(?-xism:\G(?:[\ \t]|\r?\n|\#.*\r?\n)+)/
- },
- {
- '.ref' => 'assignment_statement'
- },
- {
- '.ref' => 'code_statement'
- }
- ]
- },
- 'code_statement' => {
- '.all' => [
- {
- '.ref' => 'code_expression'
- },
- {
- '+max' => 1,
- '.ref' => 'assertion_call'
- },
- {
- '.ref' => 'semicolon'
- }
- ]
- },
- 'comment' => {
- '.rgx' => qr/(?-xism:\G\#.*\r?\n)/
- },
- 'core_transform' => {
- '.rgx' => qr/(?-xism:\G([A-Z]\w*))/
- },
- 'data_block' => {
- '.all' => [
- {
- '.ref' => 'block_header'
- },
- {
- '+min' => 0,
- '-skip' => 1,
- '.any' => [
- {
- '.ref' => 'blank_line'
- },
- {
- '.ref' => 'comment'
- }
- ]
- },
- {
- '+min' => 0,
- '.ref' => 'block_point'
- }
- ]
- },
- 'data_section' => {
- '+min' => 0,
- '.ref' => 'data_block'
- },
- 'double_quoted_string' => {
- '.rgx' => qr/(?-xism:\G(?:"((?:[^\n\\"]|\\"|\\\\|\\[0nt])*?)"))/
- },
- 'function_object' => {
- '.all' => [
- {
- '+max' => 1,
- '.ref' => 'function_signature'
- },
- {
- '.ref' => 'function_start'
- },
- {
- '+min' => 0,
- '.any' => [
- {
- '.rgx' => qr/(?-xism:\G(?:[\ \t]|\r?\n|\#.*\r?\n)+)/
- },
- {
- '.ref' => 'assignment_statement'
- },
- {
- '.ref' => 'code_statement'
- }
- ]
- },
- {
- '.rgx' => qr/(?-xism:\G(?:[\ \t]|\r?\n|\#.*\r?\n)*\})/
- }
- ]
- },
- 'function_signature' => {
- '.all' => [
- {
- '.rgx' => qr/(?-xism:\G\((?:[\ \t]|\r?\n|\#.*\r?\n)*)/
- },
- {
- '+max' => 1,
- '.ref' => 'function_variables'
- },
- {
- '.rgx' => qr/(?-xism:\G(?:[\ \t]|\r?\n|\#.*\r?\n)*\))/
- }
- ]
- },
- 'function_start' => {
- '.rgx' => qr/(?-xism:\G(?:[\ \t]|\r?\n|\#.*\r?\n)*(\{)(?:[\ \t]|\r?\n|\#.*\r?\n)*)/
- },
- 'function_variable' => {
- '.rgx' => qr/(?-xism:\G([a-zA-Z]\w*))/
- },
- 'function_variables' => {
- '+min' => 1,
- '.ref' => 'function_variable',
- '.sep' => {
- '.rgx' => qr/(?-xism:\G(?:[\ \t]|\r?\n|\#.*\r?\n)*,(?:[\ \t]|\r?\n|\#.*\r?\n)*)/
- }
- },
- 'lines_point' => {
- '.all' => [
- {
- '.ref' => 'point_marker'
- },
- {
- '.rgx' => qr/(?-xism:\G[\ \t]+)/
- },
- {
- '.ref' => 'point_name'
- },
- {
- '.rgx' => qr/(?-xism:\G[\ \t]*\r?\n)/
- },
- {
- '.ref' => 'point_lines'
- }
- ]
- },
- 'number' => {
- '.rgx' => qr/(?-xism:\G([0-9]+))/
- },
- 'number_object' => {
- '.ref' => 'number'
- },
- 'phrase_point' => {
- '.all' => [
- {
- '.ref' => 'point_marker'
- },
- {
- '.rgx' => qr/(?-xism:\G[\ \t]+)/
- },
- {
- '.ref' => 'point_name'
- },
- {
- '.rgx' => qr/(?-xism:\G:[\ \t])/
- },
- {
- '.ref' => 'point_phrase'
- },
- {
- '.rgx' => qr/(?-xism:\G\r?\n)/
- },
- {
- '.rgx' => qr/(?-xism:\G(?:\#.*\r?\n|[\ \t]*\r?\n)*)/
- }
- ]
- },
- 'point_lines' => {
- '.rgx' => qr/(?-xism:\G((?:(?!===|\-\-\-).*\r?\n)*))/
- },
- 'point_marker' => {
- '.rgx' => qr/(?-xism:\G\-\-\-)/
- },
- 'point_name' => {
- '.rgx' => qr/(?-xism:\G([a-z]\w*|[A-Z]\w*))/
- },
- 'point_object' => {
- '.rgx' => qr/(?-xism:\G(\*[a-z]\w*))/
- },
- 'point_phrase' => {
- '.ref' => 'unquoted_string'
- },
- 'quoted_string' => {
- '.any' => [
- {
- '.ref' => 'single_quoted_string'
- },
- {
- '.ref' => 'double_quoted_string'
- }
- ]
- },
- 'semicolon' => {
- '.any' => [
- {
- '.rgx' => qr/(?-xism:\G;)/
- },
- {
- '.err' => 'You seem to be missing a semicolon'
- }
- ]
- },
- 'single_quoted_string' => {
- '.rgx' => qr/(?-xism:\G(?:'((?:[^\n\\']|\\'|\\\\)*?)'))/
- },
- 'string_object' => {
- '.ref' => 'quoted_string'
- },
- 'testml_document' => {
- '.all' => [
- {
- '.ref' => 'code_section'
- },
- {
- '+max' => 1,
- '.ref' => 'data_section'
- }
- ]
- },
- 'transform_argument' => {
- '.ref' => 'code_expression'
- },
- 'transform_argument_list' => {
- '.all' => [
- {
- '.rgx' => qr/(?-xism:\G\((?:[\ \t]|\r?\n|\#.*\r?\n)*)/
- },
- {
- '+min' => 0,
- '.ref' => 'transform_argument',
- '.sep' => {
- '.rgx' => qr/(?-xism:\G(?:[\ \t]|\r?\n|\#.*\r?\n)*,(?:[\ \t]|\r?\n|\#.*\r?\n)*)/
- }
- },
- {
- '.rgx' => qr/(?-xism:\G(?:[\ \t]|\r?\n|\#.*\r?\n)*\))/
- }
- ]
- },
- 'transform_name' => {
- '.any' => [
- {
- '.ref' => 'user_transform'
- },
- {
- '.ref' => 'core_transform'
- }
- ]
- },
- 'transform_object' => {
- '.all' => [
- {
- '.ref' => 'transform_name'
- },
- {
- '+max' => 1,
- '.ref' => 'transform_argument_list'
- }
- ]
- },
- 'unit_call' => {
- '.all' => [
- {
- '+asr' => -1,
- '.ref' => 'assertion_call_test'
- },
- {
- '.ref' => 'call_indicator'
- },
- {
- '.ref' => 'code_object'
- }
- ]
- },
- 'unquoted_string' => {
- '.rgx' => qr/(?-xism:\G([^\ \t\n\#](?:[^\n\#]*[^\ \t\n\#])?))/
- },
- 'user_transform' => {
- '.rgx' => qr/(?-xism:\G([a-z]\w*))/
- },
- 'variable_name' => {
- '.rgx' => qr/(?-xism:\G([a-zA-Z]\w*))/
- }
- }
-}
@@ -1,6 +1,9 @@
-#line 1
package TestML::Library::Debug;
-use TestML();
+
+use TestML::Base;
+extends 'TestML::Library';
+
+no warnings 'redefine';
sub WWW {
require XXX;
@@ -1,226 +1,196 @@
-#line 1
package TestML::Library::Standard;
-use TestML;
-
-sub Point {
- my $context = shift;
- my $name = shift;
- $name = $name->value if ref $name;
- my $value = $context->runtime->function->getvar('Block')->points->{$name};
- if ($value =~ s/\n+\z/\n/ and $value eq "\n") {
- $value = '';
- }
- return str($value);
-}
-sub GetLabel {
- my $context = shift;
- my $label = $context->runtime->get_label;
- return str($label);
-}
+use TestML::Base;
+extends 'TestML::Library';
+
+use TestML::Util;
sub Get {
- my $context = shift;
- my $key = shift->str->value;
- return $context->runtime->function->getvar($key);
+ my ($self, $key) = @_;
+ return $self->runtime->function->getvar($key->str->value);
}
-sub Set {
- my $context = shift;
- my $key = shift;
- my $value = shift;
- $context->runtime->function->setvar($key, $value);
- return $value;
+# sub Set {
+# my ($self, $key, $value) = @_;
+# return $self->runtime->function->setvar($key, $value);
+# }
+
+sub GetLabel {
+ my ($self) = @_;
+ return str($self->runtime->get_label);
}
sub Type {
- return str(shift->type);
+ my ($self, $var) = @_;
+ return str($var->type);
}
sub Catch {
- my $context = shift;
- my $error = $context->runtime->get_error
+ my ($self) = @_;
+ my $error = $self->runtime->error
or die "Catch called but no TestML error found";
$error =~ s/ at .* line \d+\.\n\z//;
- $context->runtime->clear_error;
+ $self->runtime->{error} = undef;
return str($error);
}
sub Throw {
- my $context = shift;
- my $msg = @_ ? (shift)->value : $context->value
- or $context->runtime->throw("Throw called without an error msg");
- die $msg;
+ my ($self, $msg) = @_;
+ die $msg->value;
}
-sub Str { return str(shift->str->value) }
-sub Num { return num(shift->num->value) }
-sub Bool { return bool(shift->bool->value) }
+sub Str {
+ my ($self, $object) = @_;
+ return str($object->str->value);
+}
+# sub Num {
+# my ($self, $object) = @_;
+# return num($object->num->value);
+# }
+# sub Bool {
+# my ($self, $object) = @_;
+# return bool($object->bool->value);
+# }
sub List {
- my $context = shift;
+ my $self = shift;
return list([@_]);
}
sub Join {
- my $context = shift;
- my $separator = @_ ? shift->value : '';
- return join $separator, map $_->value, @{$context->list->value};
-}
-
-sub Strip {
- my $context = shift;
- my $string = $context->str->value;
- my $part = shift->str->value;
- if ((my $i = index($string, $part)) >= 0) {
- $string = substr($string, 0, $i) . substr($string, $i + length($part));
- }
- return $string;
+ my ($self, $list, $separator) = @_;
+ $separator = $separator ? $separator->value : '';
+ my @strings = map $_->value, @{$list->list->value};
+ return str join $separator, @strings;
}
-sub Not { return bool(shift->bool->value ? 0: 1) }
-
-sub Chomp {
- my $value = shift->str->value;
- chomp($value);
- return $value;
+sub Not {
+ my ($self, $bool) = @_;
+ return bool($bool->bool->value ? 0: 1);
}
-sub Has {
- my $text = shift->value;
- my $part = shift->value;
- return bool(index($text, $part) >= 0);
+sub Text {
+ my ($self, $lines) = @_;
+ my $value = $lines->list->value;
+ return str(join $/, map($_->value, @$value), '');
}
-sub RunCommand {
- require Capture::Tiny;
- my $context = shift;
- my $arg = shift
- or die "RunCommand requires an argument";
- my $command = $arg->value;
- chomp($command);
- my $sub = sub {
- system($command);
- };
- my ($stdout, $stderr) = Capture::Tiny::capture($sub);
- $context->runtime->function->setvar('_Stdout', $stdout);
- $context->runtime->function->setvar('_Stderr', $stderr);
- return str('');
+sub Count {
+ my ($self, $list) = @_;
+ return num scalar @{$list->list->value};
}
-sub RmPath {
- require File::Path;
- my $context = shift;
- my $arg = shift
- or die "RmPath requires an argument";
- my $path = $arg->value;
- File::Path::rmtree($path);
- return str('');
+sub Lines {
+ my ($self, $text) = @_;
+ return list([ map str($_), split /\n/, $text->value ]);
}
-sub Stdout {
- my $context = shift;
- return $context->runtime->function->getvar('_Stdout');
+sub Reverse {
+ my ($self, $list) = @_;
+ my $value = $list->list->value;
+ return list([ reverse @$value ]);
}
-sub Stderr {
- my $context = shift;
- return $context->runtime->function->getvar('_Stderr');
+sub Sort {
+ my ($self, $list) = @_;
+ my $value = $list->list->value;
+ return list([ sort { $a->value cmp $b->value } @$value ]);
}
-sub Chdir {
- my $context = shift;
- my $arg = shift
- or die "Chdir requires an argument";
- my $dir = $arg->value;
- chdir $dir;
- return str('');
-}
-
-sub Read {
- my $context = shift;
- my $arg = shift
- or die "Read requires an argument";
- my $file = $arg->value;
- use Cwd;
- open FILE, $file or die "Can't open $file for input in " . Cwd::cwd;
- my $text = do { local $/; <FILE> };
- close FILE;
- return str($text);
+sub Strip {
+ my ($self, $string, $part) = @_;
+ $string = $string->str->value;
+ $part = $part->str->value;
+ if ((my $i = index($string, $part)) >= 0) {
+ $string = substr($string, 0, $i) . substr($string, $i + length($part));
+ }
+ return str $string;
}
sub Print {
- my $context = shift;
- my $arg = shift;
- print STDOUT $arg ? $arg->value : $context->value;
+ my ($self, $string) = @_;
+ print STDOUT $string->value;
+ return bool(1);
}
-sub Pass {
- return @_;
+sub Chomp {
+ my ($self, $string) = @_;
+ my $value = $string->str->value;
+ chomp($value);
+ return str $value;
}
1;
-# sub Context {
-# my $context = shift;
-# $context->set(None => $context);
+# sub Has {
+# my ($self, $string, $part) = @_;
+# $string = $string->str->value;
+# $part = $part->str->value;
+# return bool(index($string, $part) >= 0);
# }
-#
-# sub Text {
-# my $context = shift;
-# my $value = $context->assert_type('List');
-# $context->set(Str => join "\n", @$value, '');
-# }
-#
-# sub Lines {
-# my $context = shift;
-# my $value = $context->value || '';
-# $value = [ split /\n/, $value ];
-# $context->set(List => $value);
+
+# sub RunCommand {
+# require Capture::Tiny;
+# my ($self, $command) = @_;
+# $command = $command->value;
+# chomp($command);
+# my $sub = sub {
+# system($command);
+# };
+# my ($stdout, $stderr) = Capture::Tiny::capture($sub);
+# $self->runtime->function->setvar('_Stdout', $stdout);
+# $self->runtime->function->setvar('_Stderr', $stderr);
+# return str('');
# }
-#
-# sub Join {
-# my $context = shift;
-# my $value = $context->assert_type('List');
-# my $string = @_ ? (shift)->value : '';
-# $context->set(Str => join $string, @$value);
+
+# sub RmPath {
+# require File::Path;
+# my ($self, $path) = @_;
+# $path = $path->value;
+# File::Path::rmtree($path);
+# return str('');
# }
-#
-# sub Reverse {
-# my $context = shift;
-# my $value = $context->assert_type('List');
-# return [ reverse @$value ];
+
+# sub Stdout {
+# my ($self) = @_;
+# return $self->runtime->function->getvar('_Stdout');
# }
-#
-# sub Sort {
-# my $context = shift;
-# my $value = $context->assert_type('List');
-# return [ sort @$value ];
+
+# sub Stderr {
+# my ($self) = @_;
+# return $self->runtime->function->getvar('_Stderr');
# }
-#
-# sub BoolStr {
-# my $context = shift;
-# return $context->value ? 'True' : 'False';
+
+# sub Chdir {
+# my ($self, $dir) = @_;
+# $dir = $dir->value;
+# chdir $dir;
+# return str('');
# }
-#
-#
-# sub Union {
-# my $list = (shift)->value;
-# # my $list2 = shift;
-# my $list2 = [ @$list ];
-# return [ @$list, @$list2 ];
+
+# sub Read {
+# my ($self, $file) = @_;
+# $file = $file->value;
+# use Cwd;
+# open FILE, $file or die "Can't open $file for input in " . Cwd::cwd;
+# my $text = do { local $/; <FILE> };
+# close FILE;
+# return str($text);
# }
-#
-# sub Unique {
-# my $list = (shift)->value;
-# # my $list2 = shift;
-# my $list2 = [ @$list ];
-# return [ @$list, @$list2 ];
+
+# sub Pass {
+# my ($self, @args) = @_;
+# return @args;
# }
-#
+
# sub Raw {
-# my $context = shift;
-# my $point = $context->point
+# my $self = shift;
+# my $point = $self->point
# or die "Raw called but there is no point";
-# return $context->runtime->block->points->{$point};
+# return $self->runtime->block->points->{$point};
+# }
+
+# sub Point {
+# my ($self, $name) = @_;
+# $name = $name->value;
+# $self->runtime->get_point($name);
# }
-#
@@ -1,15 +0,0 @@
-#line 1
-##
-# name: TestML::Mo
-# abstract: Mo Base Class for TestML
-# author: Ingy döt Net <ingy@cpan.org>
-# license: perl
-# copyright: 2010, 2011
-
-package TestML::Mo;
-# use Mo qw'build default builder xxx import';
-# The following line of code was produced from the previous line by
-# Mo::Inline version 0.25
-no warnings;my$M=__PACKAGE__.::;*{$M.Object::new}=sub{bless{@_[1..$#_]},$_[0]};*{$M.import}=sub{import warnings;$^H|=1538;my($P,%e,%o)=caller.::;shift;eval"no Mo::$_",&{$M.$_.::e}($P,\%e,\%o)for@_;%e=(extends,sub{eval"no $_[0]()";@{$P.ISA}=$_[0]},has,sub{my$n=shift;my$m=sub{$#_?$_[0]{$n}=$_[1]:$_[0]{$n}};$m=$o{$_}->($m,$n,@_)for sort keys%o;*{$P.$n}=$m},%e,);*{$P.$_}=$e{$_}for keys%e;@{$P.ISA}=$M.Object};*{$M.'build::e'}=sub{my($P,$e)=@_;$e->{new}=sub{$c=shift;my$s=bless{@_},$c;my@B;do{@B=($c.::BUILD,@B)}while($c)=@{$c.::ISA};exists&$_&&&$_($s)for@B;$s}};*{$M.'default::e'}=sub{my($P,$e,$o)=@_;$o->{default}=sub{my($m,$n,%a)=@_;$a{default}or return$m;sub{$#_?$m->(@_):!exists$_[0]{$n}?$_[0]{$n}=$a{default}->(@_):$m->(@_)}}};*{$M.'builder::e'}=sub{my($P,$e,$o)=@_;$o->{builder}=sub{my($m,$n,%a)=@_;my$b=$a{builder}or return$m;sub{$#_?$m->(@_):!exists$_[0]{$n}?$_[0]{$n}=$_[0]->$b:$m->(@_)}}};use constant XXX_skip=>1;${$M.'::DumpModule'}='YAML::XS';*{$M.'xxx::e'}=sub{my($P,$e)=@_;$e->{WWW}=sub{require XXX;local$XXX::DumpModule=${$M.DumpModule};XXX::WWW(@_)};$e->{XXX}=sub{require XXX;local$XXX::DumpModule=${$M.DumpModule};XXX::XXX(@_)};$e->{YYY}=sub{require XXX;local$XXX::DumpModule=${$M.DumpModule};XXX::YYY(@_)};$e->{ZZZ}=sub{require XXX;local$XXX::DumpModule=${$M.DumpModule};XXX::ZZZ(@_)}};my$i=\&import;*{$M.import}=sub{(@_==2 and not $_[1])?pop@_:@_==1 ?push@_,grep!/import/,@f:();goto&$i};@f=qw[build default builder xxx import];use strict;use warnings;
-
-our $DumpModule = 'YAML';
@@ -1,76 +1,113 @@
-#line 1
+use Test::Builder;
+use TestML::Runtime;
+
package TestML::Runtime::TAP;
-use TestML::Mo;
+
+use TestML::Base;
extends 'TestML::Runtime';
-use Test::Builder;
+has tap_object => sub { Test::Builder->new };
+has planned => 0;
-if ($TestML::Test::Differences) {
- no warnings 'redefine';
- require Test::Differences;
- *Test::Builder::is_eq = sub {
- my $self = shift;
- \&Test::Differences::eq_or_diff(@_);
- };
+sub run {
+ my ($self) = @_;
+ $self->SUPER::run;
+ $self->check_plan;
+ $self->plan_end;
}
-has test_builder => default => sub { Test::Builder->new };
+sub run_assertion {
+ my ($self, @args) = @_;
+ $self->check_plan;
+ $self->SUPER::run_assertion(@args);
+}
+
+sub check_plan {
+ my ($self) = @_;
+ if (! $self->planned) {
+ $self->title;
+ $self->plan_begin;
+ $self->{planned} = 1;
+ }
+}
sub title {
- my $self = shift;
+ my ($self) = @_;
if (my $title = $self->function->getvar('Title')) {
$title = $title->value;
$title = "=== $title ===\n";
- if ($self->test_builder->can('note')) {
- $self->test_builder->note($title);
- }
- else {
- $self->test_builder->diag($title);
- }
+ $self->tap_object->note($title);
}
}
+sub skip_test {
+ my ($self, $reason) = @_;
+ $self->tap_object->plan(skip_all => $reason);
+}
+
sub plan_begin {
- my $self = shift;
- if (defined (my $tests = $self->function->getvar('Plan'))) {
- $self->test_builder->plan(tests => $tests->value);
- }
- else {
- $self->test_builder->no_plan();
+ my ($self) = @_;
+ if (my $tests = $self->function->getvar('Plan')) {
+ $self->tap_object->plan(tests => $tests->value);
}
}
+sub plan_end {
+ my ($self) = @_;
+ $self->tap_object->done_testing();
+}
+
+# TODO Use Test::Diff here.
sub assert_EQ {
- my $self = shift;
- $self->test_builder->is_eq(
- shift->str->value,
- shift->str->value,
+ my ($self, $got, $want) = @_;
+ $got = $got->str->value;
+ $want = $want->str->value;
+ if ($got ne $want and $want =~ /\n/) {
+ my $block = $self->function->getvar('Block');
+ my $diff = $self->function->getvar('Diff');
+ if ($diff or exists $block->points->{DIFF}) {
+ require Text::Diff;
+ $self->tap_object->ok(0, $self->get_label);
+ my $diff = Text::Diff::diff(
+ \$want, \$got, {
+ FILENAME_A => "want",
+ FILENAME_B => "got",
+ },
+ );
+ $self->tap_object->diag($diff);
+ return;
+ }
+ }
+ $self->tap_object->is_eq(
+ $got,
+ $want,
$self->get_label,
);
}
sub assert_HAS {
- my $self = shift;
- my $text = shift->value;
- my $part = shift->value;
- my $assertion = (index($text, $part) >= 0);
+ my ($self, $got, $has) = @_;
+ $got = $got->str->value;
+ $has = $has->str->value;
+ my $assertion = (index($got, $has) >= 0);
if (not $assertion) {
my $msg = <<"...";
Failed TestML HAS (~~) assertion. This text:
-'$text'
+'$got'
does not contain this string:
-'$part'
+'$has'
...
- $self->test_builder->diag($msg);
+ $self->tap_object->diag($msg);
}
- $self->test_builder->ok($assertion, $self->get_label);
+ $self->tap_object->ok($assertion, $self->get_label);
}
sub assert_OK {
- my $self = shift;
- my $context = shift;
- $self->test_builder->ok(
- $context->bool->value,
+ my ($self, $got) = @_;
+ $self->tap_object->ok(
+ $got->bool->value,
$self->get_label,
);
}
+
+1;
@@ -1,453 +1,415 @@
-#line 1
package TestML::Runtime;
-use TestML::Mo;
-use TestML::Compiler;
+use TestML::Base;
-# Since there is only ever one test runtime, it makes things a LOT cleaner to
-# keep the reference to it in a global variable accessed by a method, than to
-# put a reference to it into every object that needs to access it.
-our $self;
+has testml => ();
+has bridge => ();
+has library => ();
+has compiler => ();
+has skip => ();
-has base => default => sub {$0 =~ m!(.*)/! ? $1 : "."}; # Base directory
-has testml => (); # TestML document filename, handle or text
-has bridge => (); # Bridge transform module
-
-# XXX Add TestML.pm support for -library keyword.
-has library => default => sub {[]}; # Transform library modules
-
-has function => (); # Current function executing
-has planned => default => sub {0}; # plan() has been called
-has test_number => default => sub {0}; # Number of tests run so far
+has function => ();
+has error => ();
+has global => ();
+has base => ();
sub BUILD {
- my $self = $TestML::Runtime::self = shift;
- $self->function($self->compile_testml);
- $self->load_variables;
- $self->load_transform_module('TestML::Library::Standard');
- $self->load_transform_module('TestML::Library::Debug');
- if ($self->bridge) {
- $self->load_transform_module($self->bridge);
- }
+ my ($self) = @_;
+ $TestML::Runtime::Singleton = $self;
+ $self->{base} ||= $0 =~ m!(.*)/! ? $1 : ".";
}
-# XXX Move to TestML::Adapter
-sub title { }
-sub plan_begin { }
-sub plan_end { }
-
sub run {
- my $self = shift;
+ my ($self) = @_;
+ $self->compile_testml;
+ $self->initialize_runtime;
+ $self->run_function($self->{function}, []);
+}
- my $function = $self->function;
- my $context = TestML::None->new;
- my $args = [];
+# TODO Functions should have return values
+sub run_function {
+ my ($self, $function, $args) = @_;
- $self->run_function($self->function, $context, $args);
+ $self->apply_signature($function, $args);
- $self->run_plan();
- $self->plan_end();
-}
+ my $parent = $self->function;
+ $self->{function} = $function;
-# XXX - TestML exception handling needs to happen at the function level, not
-# just at the expression level. Not yet handled here.
-sub run_function {
- my $self = shift;
- my $function = shift;
- my $context = shift;
- my $args = shift;
+ for my $statement (@{$function->statements}) {
+ if (ref($statement) eq 'TestML::Assignment') {
+ $self->run_assignment($statement);
+ }
+ else {
+ $self->run_statement($statement);
+ }
+ }
+ $self->{function} = $parent;
+ return;
+}
+sub apply_signature {
+ my ($self, $function, $args) = @_;
my $signature = $function->signature;
+
die sprintf(
"Function received %d args but expected %d",
scalar(@$args),
scalar(@$signature),
) if @$signature and @$args != @$signature;
- $function->setvar('Self', $context);
+
+ $function->setvar('Self', $function);
for (my $i = 0; $i < @$signature; $i++) {
my $arg = $args->[$i];
$arg = $self->run_expression($arg)
if ref($arg) eq 'TestML::Expression';
$function->setvar($signature->[$i], $arg);
}
-
- my $parent = $self->function;
- $self->function($function);
-
- for my $statement (@{$function->statements}) {
- $self->run_statement($statement);
- }
-
- $self->function($parent);
-
- return TestML::None->new;
}
sub run_statement {
- my $self = shift;
- my $statement = shift;
- my $blocks = @{$statement->points}
- ? $self->select_blocks($statement->points)
- : [1];
+ my ($self, $statement) = @_;
+ my $blocks = $self->select_blocks($statement->points || []);
for my $block (@$blocks) {
- $self->function->setvar('Block', $block) if ref($block);
- my $context = $self->run_expression($statement->expression);
- if (my $assertion = $statement->assertion) {
- $self->run_assertion($context, $assertion);
+ $self->function->setvar('Block', $block) if $block != 1;
+ my $result = $self->run_expression($statement->expr);
+ if (my $assert = $statement->assert) {
+ $self->run_assertion($result, $assert);
}
}
}
+sub run_assignment {
+ my ($self, $assignment) = @_;
+ $self->function->setvar(
+ $assignment->name,
+ $self->run_expression($assignment->expr),
+ );
+}
+
sub run_assertion {
- my $self = shift;
- my $left = shift;
- my $assertion = shift;
- my $method = 'assert_' . $assertion->name;
+ my ($self, $left, $assert) = @_;
+ my $method = 'assert_' . $assert->name;
- # Run this as late as possible.
- $self->run_plan;
+ $self->function->getvar('TestNumber')->{value}++;
- $self->test_number($self->test_number + 1);
- $self->function->setvar(
- TestNumber => TestML::Num->new(value => $self->test_number),
- );
+ if ($assert->expr) {
+ $self->$method($left, $self->run_expression($assert->expr));
+ }
+ else {
+ $self->$method($left);
+ }
+}
- # TODO - Should check
- my $results = ($left->type eq 'List')
- ? $left->value
- : [ $left ];
- for my $result (@$results) {
- if (@{$assertion->expression->units}) {
- my $right = $self->run_expression($assertion->expression);
- my $matches = ($right->type eq 'List')
- ? $right->value
- : [ $right ];
- for my $match (@$matches) {
- $self->$method($result, $match);
+sub run_expression {
+ my ($self, $expr) = @_;
+
+ my $context = undef;
+ $self->{error} = undef;
+ if ($expr->isa('TestML::Expression')) {
+ my @calls = @{$expr->calls};
+ die if @calls <= 1;
+ $context = $self->run_call(shift(@calls));
+ for my $call (@calls) {
+ if ($self->error) {
+ next unless
+ $call->isa('TestML::Call') and
+ $call->name eq 'Catch';
}
- }
- else {
- $self->$method($result);
+ $context = $self->run_call($call, $context);
}
}
+ else {
+ $context = $self->run_call($expr);
+ }
+ if ($self->error) {
+ die $self->error;
+ }
+ return $context;
}
-sub run_expression {
- my $self = shift;
- my $prev_expression = $self->function->expression;
- my $expression = shift;
- $self->function->expression($expression);
-
- my $units = $expression->units;
- my $context = TestML::None->new;
-
- for (my $i = 0; $i < @$units; $i++) {
- my $unit = $units->[$i];
- if ($expression->error) {
- next unless
- $unit->isa('TestML::Transform') and
- $unit->name eq 'Catch';
- }
- if ($unit->isa('TestML::Object')) {
- $context = $unit;
- next;
- }
- if ($unit->isa('TestML::Function')) {
- $context = $unit;
- next;
- }
- die "Unexpected unit: $unit" unless $unit->isa('TestML::Transform');
- my $callable = $self->function->getvar($unit->name)
- or die "Can't find transform '${\$unit->name}'";
- my $args = $unit->args;
- if ($callable->isa('TestML::Native')) {
- $context = $self->run_native($callable->value, $context, $args);
- }
- elsif ($callable->isa('TestML::Object')) {
- $context = $callable;
+sub run_call {
+ my ($self, $call, $context) = @_;
+
+ if ($call->isa('TestML::Object')) {
+ return $call;
+ }
+ if ($call->isa('TestML::Function')) {
+ return $call;
+ }
+ if ($call->isa('TestML::Point')) {
+ return $self->get_point($call->name);
+ }
+ if ($call->isa('TestML::Call')) {
+ my $name = $call->name;
+ my $callable =
+ $self->function->getvar($name) ||
+ $self->lookup_callable($name) ||
+ die "Can't locate '$name' callable";
+ if ($callable->isa('TestML::Object')) {
+ return $callable;
}
- elsif ($callable->isa('TestML::Function')) {
- if ($i or $unit->explicit_call) {
- my $points = $self->function->getvar('Block')->points;
- for my $key (keys %$points) {
- $callable->setvar($key, TestML::Str->new(value => $points->{$key}));
- }
- $context = $self->run_function($callable, $context, $args);
+ return $callable unless $call->args or defined $context;
+ $call->{args} ||= [];
+ my $args = [map $self->run_expression($_), @{$call->args}];
+ unshift @$args, $context if $context;
+ if ($callable->isa('TestML::Callable')) {
+ my $value = eval { $callable->value->(@$args) };
+ if ($@) {
+ $self->{error} = $@;
+ return TestML::Error->new(value => $@);
}
- $context = $callable;
+ die "'$name' did not return a TestML::Object object"
+ unless UNIVERSAL::isa($value, 'TestML::Object');
+ return $value;
}
- else {
- ZZZ $expression, $unit, $callable;
+ if ($callable->isa('TestML::Function')) {
+ return $self->run_function($callable, $args);
}
+ die;
}
- if ($expression->error) {
- die $expression->error;
- }
- $self->function->expression($prev_expression);
- return $context;
+ die;
}
-sub run_native {
- my $self = shift;
- my $function = shift;
- my $context = shift;
- my $args = shift;
- my $value = eval {
- &$function(
- $context,
- map {
- (ref($_) eq 'TestML::Expression')
- ? $self->run_expression($_)
- : $_
- } @$args
- );
- };
- if ($@) {
- $self->function->expression->error($@);
- $context = TestML::Error->new(value => $@);
- }
- elsif (UNIVERSAL::isa($value, 'TestML::Object')) {
- $context = $value;
+sub lookup_callable {
+ my ($self, $name) = @_;
+ for my $library (@{$self->function->getvar('Library')->value}) {
+ if ($library->can($name)) {
+ my $function = sub { $library->$name(@_) };
+ my $callable = TestML::Callable->new(value => $function);
+ $self->function->setvar($name, $callable);
+ return $callable;
+ }
}
- else {
- $context = $self->object_from_native($value);
+ return;
+}
+
+sub get_point {
+ my ($self, $name) = @_;
+ my $value = $self->function->getvar('Block')->{points}{$name};
+ defined $value or return;
+ if ($value =~ s/\n+\z/\n/ and $value eq "\n") {
+ $value = '';
}
- return $context;
+ $value =~ s/^\\//gm;
+ return TestML::Str->new(value => $value);
}
sub select_blocks {
- my $self = shift;
- my $wanted = shift;
+ my ($self, $wanted) = @_;
+ return [1] unless @$wanted;
my $selected = [];
OUTER: for my $block (@{$self->function->data}) {
my %points = %{$block->points};
next if exists $points{SKIP};
- for my $point (@$wanted) {
- next OUTER unless exists $points{$point};
- }
if (exists $points{ONLY}) {
- @$selected = ($block);
+ for my $point (@$wanted) {
+ return [] unless exists $points{$point};
+ }
+ $selected = [$block];
last;
}
+ for my $point (@$wanted) {
+ next OUTER unless exists $points{$point};
+ }
push @$selected, $block;
last if exists $points{LAST};
}
return $selected;
}
-sub object_from_native {
- my $self = shift;
- my $value = shift;
- return
- not(defined $value) ? TestML::None->new :
- ref($value) eq 'ARRAY' ? TestML::List->new(value => $value) :
- $value =~ /^-?\d+$/ ? TestML::Num->new(value => $value + 0) :
- "$value" eq "$TestML::Constant::True" ? $value :
- "$value" eq "$TestML::Constant::False" ? $value :
- "$value" eq "$TestML::Constant::None" ? $value :
- TestML::Str->new(value => $value);
-}
-
sub compile_testml {
- my $self = shift;
- my $path = ref($self->testml)
- ? $self->testml
- : join '/', $self->base, $self->testml;
- my $function = TestML::Compiler->new(base => $self->base)->compile($path)
+ my ($self) = @_;
+
+ die "'testml' document required but not found"
+ unless $self->testml;
+ if ($self->testml !~ /\n/) {
+ $self->testml =~ /(?:(.*)\/)?(.*)/ or die;
+ $self->{testml} = $2;
+ $self->{base} .= '/' . $1 if $1;
+ $self->{testml} = $self->read_testml_file($self->testml);
+ }
+ $self->{function} = $self->compiler->new->compile($self->testml)
or die "TestML document failed to compile";
- return $function;
}
-sub load_variables {
- my $self = shift;
- my $global = $self->function->outer;
- $global->setvar(Block => TestML::Block->new);
- $global->setvar(Label => TestML::Str->new(value => '$BlockLabel'));
- $global->setvar(True => $TestML::Constant::True);
- $global->setvar(False => $TestML::Constant::False);
- $global->setvar(None => $TestML::Constant::None);
-}
+sub initialize_runtime {
+ my ($self) = @_;
-sub load_transform_module {
- my $self = shift;
- my $module_name = shift;
- if ($module_name ne 'main') {
- eval "require $module_name; 1"
- or die "Can't use $module_name:\n$@";
- }
+ $self->{global} = $self->function->outer;
- my $global = $self->function->outer;
- no strict 'refs';
- for my $key (sort keys %{"$module_name\::"}) {
- next if $key eq "\x16";
- my $glob = ${"$module_name\::"}{$key};
- if (my $function = *$glob{CODE}) {
- $global->setvar(
- $key => TestML::Native->new(value => $function),
- );
+ $self->{global}->setvar(Block => TestML::Block->new);
+ $self->{global}->setvar(Label => TestML::Str->new(value => '$BlockLabel'));
+ $self->{global}->setvar(True => $TestML::Constant::True);
+ $self->{global}->setvar(False => $TestML::Constant::False);
+ $self->{global}->setvar(None => $TestML::Constant::None);
+ $self->{global}->setvar(TestNumber => TestML::Num->new(value => 0));
+ $self->{global}->setvar(Library => TestML::List->new);
+
+ my $library = $self->function->getvar('Library');
+ for my $lib ($self->bridge, $self->library) {
+ if (ref($lib) eq 'ARRAY') {
+ $library->push($_->new) for @$lib;
}
- elsif (my $object = *$glob{SCALAR}) {
- if (ref($$object)) {
- $global->setvar($key => $$object);
- }
+ else {
+ $library->push($lib->new);
}
}
}
sub get_label {
- my $self = shift;
- my $label = $self->function->getvar('Label')->value;
- sub label {
- my $self = shift;
- my $var = shift;
- my $block = $self->function->getvar('Block');
- return $block->label if $var eq 'BlockLabel';
- if (my $v = $block->points->{$var}) {
- $v =~ s/\n.*//s;
- $v =~ s/^\s*(.*?)\s*$/$1/;
- return $v;
- }
- if (my $v = $self->function->getvar($var)) {
- return $v->value;
- }
- }
- $label =~ s/\$(\w+)/label($self, $1)/ge;
- return $label ? ($label) : ();
+ my ($self) = @_;
+ my $label = $self->function->getvar('Label') or return;
+ $label = $label->value or return;
+ $label =~ s/\$(\w+)/$self->replace_label($1)/ge;
+ return $label;
}
-sub run_plan {
- my $self = shift;
- if (! $self->planned) {
- $self->title();
- $self->plan_begin();
- $self->planned(1);
+sub replace_label {
+ my ($self, $var) = @_;
+ my $block = $self->function->getvar('Block');
+ return $block->label if $var eq 'BlockLabel';
+ if (my $v = $block->points->{$var}) {
+ $v =~ s/\n.*//s;
+ $v =~ s/^\s*(.*?)\s*$/$1/;
+ return $v;
+ }
+ if (my $v = $self->function->getvar($var)) {
+ return $v->value;
}
}
-sub get_error {
- my $self = shift;
- return $self->function->expression->error;
-}
-
-sub clear_error {
- my $self = shift;
- return $self->function->expression->error(undef);
-}
-
-sub throw {
- require Carp;
- Carp::croak $_[1];
+sub read_testml_file {
+ my ($self, $file) = @_;
+ my $path = $self->base . '/' . $file;
+ open my $fh, $path
+ or die "Can't open '$path' for input: $!";
+ local $/;
+ return <$fh>;
}
#-----------------------------------------------------------------------------
package TestML::Function;
-use TestML::Mo;
-has type => default => sub {'Func'}; # Functions are TestML typed objects
-# XXX Make this a featherweight reference.
-has signature => default => sub {[]}; # Input variable names
-has namespace => default => sub {{}}; # Lexical scoped variable stash
-has statements => default => sub {[]}; # Exexcutable code statements
-has data => default => sub{[]}; # Data section scoped to this function
+use TestML::Base;
-# Runtime pointers to current objects.
-has expression => ();
-has block => ();
+has type => 'Func'; # Functions are TestML typed objects
+has signature => []; # Input variable names
+has namespace => {}; # Lexical scoped variable stash
+has statements => []; # Exexcutable code statements
+has data => []; # Data section scoped to this function
my $outer = {};
sub outer { @_ == 1 ? $outer->{$_[0]} : ($outer->{$_[0]} = $_[1]) }
sub getvar {
- my $self = shift;
- my $name = shift;
+ my ($self, $name) = @_;
while ($self) {
if (my $object = $self->namespace->{$name}) {
return $object;
}
$self = $self->outer;
}
- return;
+ undef;
}
sub setvar {
- my $self = shift;
- my $name = shift;
- my $object = shift;
- $self->namespace->{$name} = $object;
- return;
+ my ($self, $name, $value) = @_;
+ $self->namespace->{$name} = $value;
}
sub forgetvar {
- my $self = shift;
- my $name = shift;
+ my ($self, $name) = @_;
delete $self->namespace->{$name};
- return;
}
#-----------------------------------------------------------------------------
+package TestML::Assignment;
+
+use TestML::Base;
+
+has name => ();
+has expr => ();
+
+#-----------------------------------------------------------------------------
package TestML::Statement;
-use TestML::Mo;
-has expression => default => sub {TestML::Expression->new};
-has assertion => ();
-has points => default => sub {[]};
+use TestML::Base;
+
+has expr => ();
+has assert => ();
+has points => ();
#-----------------------------------------------------------------------------
package TestML::Expression;
-use TestML::Mo;
-has units => default => sub {[]};
-has error => ();
+use TestML::Base;
+
+has calls => [];
#-----------------------------------------------------------------------------
package TestML::Assertion;
-use TestML::Mo;
+
+use TestML::Base;
has name => ();
-has expression => default => sub {TestML::Expression->new};
+has expr => ();
#-----------------------------------------------------------------------------
-package TestML::Transform;
-use TestML::Mo;
+package TestML::Call;
+
+use TestML::Base;
has name => ();
-has args => default => sub {[]};
-has explicit_call => default => 0;
+has args => ();
+
+#-----------------------------------------------------------------------------
+package TestML::Callable;
+
+use TestML::Base;
+has value => ();
#-----------------------------------------------------------------------------
package TestML::Block;
-use TestML::Mo;
-has label => default => sub {''};
-has points => default => sub {{}};
+use TestML::Base;
+
+has label => '';
+has points => {};
+
+#-----------------------------------------------------------------------------
+package TestML::Point;
+
+use TestML::Base;
+
+has name => ();
#-----------------------------------------------------------------------------
package TestML::Object;
-use TestML::Mo;
+
+use TestML::Base;
has value => ();
sub type {
- my $type = ref(shift);
+ my $type = ref($_[0]);
$type =~ s/^TestML::// or die "Can't find type of '$type'";
return $type;
}
-sub runtime { return $TestML::Runtime::self }
-
-sub str { my $t = $_[0]->type; die "Cast from $t to Str is not supported" }
-sub num { my $t = $_[0]->type; die "Cast from $t to Num is not supported" }
-sub bool { my $t = $_[0]->type; die "Cast from $t to Bool is not supported" }
-sub list { my $t = $_[0]->type; die "Cast from $t to List is not supported" }
+sub str { die "Cast from ${\ $_[0]->type} to Str is not supported" }
+sub num { die "Cast from ${\ $_[0]->type} to Num is not supported" }
+sub bool { die "Cast from ${\ $_[0]->type} to Bool is not supported" }
+sub list { die "Cast from ${\ $_[0]->type} to List is not supported" }
sub none { $TestML::Constant::None }
#-----------------------------------------------------------------------------
package TestML::Str;
-use TestML::Mo;
+
+use TestML::Base;
extends 'TestML::Object';
-sub str { shift }
+sub str { $_[0] }
sub num { TestML::Num->new(
value => ($_[0]->value =~ /^-?\d+(?:\.\d+)$/ ? ($_[0]->value + 0) : 0),
)}
@@ -458,11 +420,12 @@ sub list { TestML::List->new(value => [split //, $_[0]->value]) }
#-----------------------------------------------------------------------------
package TestML::Num;
-use TestML::Mo;
+
+use TestML::Base;
extends 'TestML::Object';
sub str { TestML::Str->new(value => $_[0]->value . "") }
-sub num { shift }
+sub num { $_[0] }
sub bool { ($_[0]->value != 0) ? $TestML::Constant::True : $TestML::Constant::False }
sub list {
my $list = [];
@@ -472,42 +435,54 @@ sub list {
#-----------------------------------------------------------------------------
package TestML::Bool;
-use TestML::Mo;
+
+use TestML::Base;
extends 'TestML::Object';
sub str { TestML::Str->new(value => $_[0]->value ? "1" : "") }
sub num { TestML::Num->new(value => $_[0]->value ? 1 : 0) }
-sub bool { shift }
+sub bool { $_[0] }
#-----------------------------------------------------------------------------
package TestML::List;
-use TestML::Mo;
+
+use TestML::Base;
extends 'TestML::Object';
-sub list { shift }
+has value => [];
+sub list { $_[0] }
+sub push {
+ my ($self, $elem) = @_;
+ push @{$self->value}, $elem;
+}
#-----------------------------------------------------------------------------
package TestML::None;
-use TestML::Mo;
+
+use TestML::Base;
extends 'TestML::Object';
-sub str { Str('') }
-sub num { Num(0) }
+sub str { TestML::Str->new(value => '') }
+sub num { TestML::Num->new(value => 0) }
sub bool { $TestML::Constant::False }
-sub list { List([]) }
+sub list { TestML::List->new(value => []) }
#-----------------------------------------------------------------------------
-package TestML::Error;
-use TestML::Mo;
+package TestML::Native;
+
+use TestML::Base;
extends 'TestML::Object';
#-----------------------------------------------------------------------------
-package TestML::Native;
-use TestML::Mo;
+package TestML::Error;
+
+use TestML::Base;
extends 'TestML::Object';
+#-----------------------------------------------------------------------------
package TestML::Constant;
our $True = TestML::Bool->new(value => 1);
our $False = TestML::Bool->new(value => 0);
our $None = TestML::None->new;
+1;
@@ -0,0 +1,19 @@
+use strict; use warnings;
+
+use TestML::Runtime;
+
+package TestML::Util;
+
+use Exporter 'import';
+our @EXPORT = qw( runtime list str num bool none native );
+
+sub runtime { $TestML::Runtime::Singleton }
+
+sub list { TestML::List->new(value => $_[0]) }
+sub str { TestML::Str->new(value => $_[0]) }
+sub num { TestML::Num->new(value => $_[0]) }
+sub bool { TestML::Bool->new(value => $_[0]) }
+sub none { TestML::None->new(value => $_[0]) }
+sub native { TestML::Native->new(value => $_[0]) }
+
+1;
@@ -1,132 +1,47 @@
-#line 1
-##
-# name: TestML
-# author: Ingy döt Net <ingy@cpan.org>
-# abstract: A Generic Software Testing Meta Language
-# license: perl
-# copyright: 2009, 2010, 2011
-# see:
-# - http://www.testml.org/
-# - irc://irc.freenode.net#testml
-
-use 5.006001;
-use strict;
-use warnings;
-
-my $requires = "
-use Pegex 0.19 ();
-";
-
package TestML;
-use TestML::Runtime;
-
-our $VERSION = '0.26';
-
-use constant XXX_skip => 1;
-our $DumpModule = 'YAML::XS';
-sub WWW { require XXX; local $XXX::DumpModule = $DumpModule; XXX::WWW(@_) }
-sub XXX { require XXX; local $XXX::DumpModule = $DumpModule; XXX::XXX(@_) }
-sub YYY { require XXX; local $XXX::DumpModule = $DumpModule; XXX::YYY(@_) }
-sub ZZZ { require XXX; local $XXX::DumpModule = $DumpModule; XXX::ZZZ(@_) }
-
-sub str { TestML::Str->new(value => $_[0]) }
-sub num { TestML::Num->new(value => $_[0]) }
-sub bool { TestML::Bool->new(value => $_[0]) }
-sub list { TestML::List->new(value => $_[0]) }
-
-my $skipped;
-sub import {
- my $run;
- my $bridge = '';
- my $testml;
- $skipped = 0;
-
- strict->import;
- warnings->import;
+use TestML::Base;
+our $VERSION = '0.49';
+
+has runtime => ();
+has compiler => ();
+has bridge => ();
+has library => ();
+has testml => ();
+
+sub run {
+ my ($self) = @_;
+ $self->set_default_classes;
+ $self->runtime->new(
+ compiler => $self->compiler,
+ bridge => $self->bridge,
+ library => $self->library,
+ testml => $self->testml,
+ )->run;
+}
- my $pkg = shift;
- while (@_) {
- my $option = shift(@_);
- my $value = (@_ and $_[0] !~ /^-/) ? shift(@_) : '';
- if ($option eq '-run') {
- $run = $value || 'TestML::Runtime::TAP';
- }
- elsif ($option eq '-testml') {
- $testml = $value;
- }
- elsif ($option eq '-bridge') {
- $bridge = $value;
- }
- # XXX skip_all should call skip_all() from runner subclass
- elsif ($option eq '-dev_test') {
- if (-e 'inc' and not -e 'inc/.author') {
- skip_all('This is a developer test');
- }
- }
- elsif ($option eq '-skip_all') {
- my $reason = $value;
- die "-skip_all option requires a reason argument"
- unless $reason;
- skip_all($reason);
- }
- elsif ($option eq '-require_or_skip') {
- my $module = $value;
- die "-require_or_skip option requires a module argument"
- unless $module and $module !~ /^-/;
- eval "require $module; 1" or do {
- $skipped = 1;
- require Test::More;
- Test::More::plan(
- skip_all => "$module failed to load"
- );
- }
- }
- else {
- die "Unknown option '$option'";
- }
+sub set_default_classes {
+ my ($self) = @_;
+ if (not $self->runtime) {
+ require TestML::Runtime::TAP;
+ $self->{runtime} = 'TestML::Runtime::TAP';
}
-
- sub skip_all {
- return if $skipped;
- my $reason = shift;
- $skipped = 1;
- require Test::More;
- Test::More::plan(
- skip_all => $reason,
- );
+ if (not $self->compiler) {
+ require TestML::Compiler::Pegex;
+ $self->{compiler} = 'TestML::Compiler::Pegex';
}
-
- sub END {
- no warnings;
- return if $skipped;
- if ($run) {
- eval "require $run; 1" or die $@;
- $bridge ||= 'main';
- $run->new(
- testml => ($testml || \ *main::DATA),
- bridge => $bridge,
- )->run();
- }
- elsif ($testml or $bridge) {
- die "-testml or -bridge option used without -run option\n";
- }
+ if (not $self->bridge) {
+ require TestML::Bridge;
+ $self->{bridge} = 'TestML::Bridge';
}
-
- no strict 'refs';
- my $p = caller;
- *{$p.'::str'} = \&str;
- *{$p.'::num'} = \#
- *{$p.'::bool'} = \&bool;
- *{$p.'::list'} = \&list;
-
- if (not defined &{$pkg.'::XXX'}) {
- *{$p.'::WWW'} = \&WWW;
- *{$p.'::XXX'} = \&XXX;
- *{$p.'::YYY'} = \&YYY;
- *{$p.'::ZZZ'} = \&ZZZ;
+ if (not $self->library) {
+ require TestML::Library::Standard;
+ require TestML::Library::Debug;
+ $self->{library} = [
+ 'TestML::Library::Standard',
+ 'TestML::Library::Debug',
+ ];
}
}
1;
-
@@ -1,19 +1,6 @@
-##
-# name: Template::Toolkit::Simple
-# abstract: A Simple Interface to Template Toolkit
-# author: Ingy döt Net <ingy@cpan.org>
-# copyright: 2008, 2009, 2010, 2011
-# license: perl
-
-use strict;
-use warnings;
-use 5.008003;
-use Template 2.22 ();
-use YAML::XS 0.37 ();
-
+use strict; use warnings;
package Template::Toolkit::Simple;
-
-our $VERSION = '0.16';
+our $VERSION = '0.31';
use Encode;
use Getopt::Long;
@@ -255,233 +242,7 @@ sub _run_command {
} keys %$default
);
- print STDOUT $self->render($template);
+ print STDOUT $self->render($template);
}
1;
-
-=head1 SYNOPSIS
-
- use Template::Toolkit::Simple;
-
- print tt
- ->path(['./', 'template/'])
- ->data('values.yaml')
- ->post_chomp
- ->render('foo.tt');
-
-or from the command line:
-
- tt-render --path=./:template/ --data=values.yaml --post-chomp foo.tt
-
-=head1 DESCRIPTION
-
-Template Toolkit is the best Perl template framework. The only problem
-with it is that using it for simple stuff is a little bit cumbersome.
-Also there is no good utility for using it from the command line.
-
-This module is a simple wrapper around Template Toolkit. It exports a
-function called C<tt> which returns a new Template::Toolkit::Simple
-object. The object supports method calls for setting all the Template
-Toolkit options.
-
-This module also installs a program called C<tt-render> which you can
-use from the command line to render templates with all the power of the
-Perl object. All of the object methods become command line arguments in
-the command line version.
-
-=head1 COMMAND LINE USAGE
-
-This command renders the named file and prints the output to STDOUT. If
-an error occurs, it is printed to STDERR.
-
- tt-render [template-options] file-name
-
-=head1 TEMPLATE PATH
-
-When using Template::Toolkit::Simple or C<tt-render>, the most common
-parameters you will use are the main template file name and the
-directory of supporting templates. As a convenience, you can specify
-these together.
-
-This:
-
- tt->render('foo//bar/baz.tt');
- > tt-render foo//bar/baz.tt # command line version
-
-is the same as:
-
- tt->include_path('foo/')->render('bar/baz.tt');
- > tt-render --include_path=foo/ bar/baz.tt # command line version
-
-Just use a double slash to separate the path from the template. This is extra
-handy on the command line, because (at least in Bash) tab completion still
-works after you specify the '//'.
-
-=head1 EXPORTED SUBROUTINES
-
-=over
-
-=item tt
-
-Simply returns a new Template::Toolkit::Simple object. This is Simple
-sugar for:
-
- Template::Toolkit::Simple->new();
-
-It takes no parameters.
-
-=back
-
-=head1 METHODS
-
-This section describes the methods that are not option setting methods.
-Those methods are described below.
-
-=over
-
-=item new()
-
-Return a new Template::Toolkit::Simple object. Takes no parameters.
-
-=item render($template, $data);
-
-This is the method that actually renders the template. It is similar to
-the Template Toolkit C<process> method, except that it actually returns
-the template result as a string. It returns undef if an error occurs.
-
-The C<$data> field is optional and can be set with the C<data> method.
-
-If you need more control, see the process command below:
-
-=item process($template, $data, $output, %options);
-
-This command is simply a proxy to the Template Toolkit C<process>
-command. All the parameters you give it are passed to the real
-C<process> command and the result is returned. See L<Template> for more
-information.
-
-=item output($filepath)
-
-Specify a filepath to print the template result to.
-
-=item error()
-
-This method is a proxy to the Template Toolkit C<error> method. It
-returns the error message if there was an error.
-
-=back
-
-=head1 OPTION METHODS
-
-All of the Template Toolkit options are available as methods to
-Template::Toolkit::Simple objects, and also as command line options to
-the C<tt-render> command.
-
-For example, the C<POST_CHOMP> options is available in the following ways:
-
- tt->post_chomp # turn POST_CHOMP on
- tt->post_chomp(1) # turn POST_CHOMP on
- tt->post_chomp(0) # turn POST_CHOMP off
-
- --post_chomp # turn POST_CHOMP on
- --post-chomp # same. use - instead of _
- --post_chomp=1 # turn POST_CHOMP on
- --post_chomp=0 # turn POST_CHOMP off
-
-If the method functionality is not explained below, please refer to
-L<Template>.
-
-=over
-
-=item config($file_name || $hash)
-
-If you have a common set of Template Toolkit options stored in a file,
-you can use this method to read and parse the file, and set the
-appropriate options.
-
-The currently supported file formats are YAML, JSON and XML. The format
-is determined by the file extension, so use the appropriate one. Note
-that XML::Simple is used to parse XML files and JSON::XS is used to
-parse JSON files.
-
-=item data($file_name || $hash)
-
-Most templates use a hash object of data to access values while
-rendering. You can specify this data in a file or with a hash reference.
-
-The currently supported file formats are YAML, JSON and XML. The format
-is determined by the file extension, so use the appropriate one. Note
-the XML::Simple is used to parse XML files.
-
-=item include_path($template_directories) -- Default is undef
-
-This method allows you to specify the directories that are searched to
-find templates. You can specify this as a string containing a single
-directory, an array ref of strings containing directory names, or as a
-string containing multiple directories separated by ':'.
-
-=item path() -- Default is undef
-
-This is a shorter name for C<include_path>. It does the exact
-same thing.
-
-=item start_tag() -- Default is '[%'
-
-=item end_tag() -- Default is '%]'
-
-=item tag_style() -- Default is 'template'
-
-=item pre_chomp() -- Default is 0
-
-=item post_chomp() -- Default is 0
-
-=item trim() -- Default is 0
-
-=item interpolate() -- Default is 0
-
-=item anycase() -- Default is 0
-
-=item delimiter() -- Default is ':'
-
-=item absolute() -- Default is 0
-
-=item relative() -- Default is 0
-
-=item strict() -- Default is 0
-
-=item default() -- Default is undef
-
-=item blocks() -- Default is undef
-
-=item auto_reset() -- Default is 1
-
-=item recursion() -- Default is 0
-
-=item eval_perl() -- Default is 0
-
-=item pre_process() -- Default is undef
-
-=item post_process() -- Default is undef
-
-=item process_template() -- Default is undef
-
-This is a proxy to the Template Toolkit PROCESS option. The C<process>
-method is used to actually process a template.
-
-=item error_template() -- Default is undef
-
-This is a proxy to the Template Toolkit ERROR option. The C<error()>
-method returns the error message on a failure.
-
-=item debug() -- Default is 0
-
-=item cache_size() -- Default is undef
-
-=item compile_ext() -- Default is undef
-
-=item compile_dir() -- Default is undef
-
-=item encoding() -- Default is 'utf8'
-
-=back
@@ -1,52 +1,60 @@
+=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
Template::Toolkit::Simple - A Simple Interface to Template Toolkit
+=for html
+<a href="https://travis-ci.org/ingydotnet/template-toolkit-simple-pm"><img src="https://travis-ci.org/ingydotnet/template-toolkit-simple-pm.png" alt="template-toolkit-simple-pm"></a>
+<a href="https://coveralls.io/r/ingydotnet/template-toolkit-simple-pm?branch=master"><img src="https://coveralls.io/repos/ingydotnet/template-toolkit-simple-pm/badge.png" alt="template-toolkit-simple-pm"></a>
+
=head1 SYNOPSIS
- use Template::Toolkit::Simple;
+ use Template::Toolkit::Simple;
- print tt
- ->path(['./', 'template/'])
- ->data('values.yaml')
- ->post_chomp
- ->render('foo.tt');
+ print tt
+ ->path(['./', 'template/'])
+ ->data('values.yaml')
+ ->post_chomp
+ ->render('foo.tt');
or from the command line:
- tt-render --path=./:template/ --data=values.yaml --post-chomp foo.tt
+ tt-render --path=./:template/ --data=values.yaml --post-chomp foo.tt
=head1 DESCRIPTION
-Template Toolkit is the best Perl template framework. The only problem
-with it is that using it for simple stuff is a little bit cumbersome.
-Also there is no good utility for using it from the command line.
+Template Toolkit is the best Perl template framework. The only problem with it
+is that using it for simple stuff is a little bit cumbersome. Also there is no
+good utility for using it from the command line.
-This module is a simple wrapper around Template Toolkit. It exports a
-function called C<tt> which returns a new Template::Toolkit::Simple
-object. The object supports method calls for setting all the Template
-Toolkit options.
+This module is a simple wrapper around Template Toolkit. It exports a function
+called C<tt> which returns a new Template::Toolkit::Simple object. The object
+supports method calls for setting all the Template Toolkit options.
-This module also installs a program called C<tt-render> which you can
-use from the command line to render templates with all the power of the
-Perl object. All of the object methods become command line arguments in
-the command line version.
+This module also installs a program called C<tt-render> which you can use
+from the command line to render templates with all the power of the Perl
+object. All of the object methods become command line arguments in the
+command line version.
=head1 COMMAND LINE USAGE
-This command renders the named file and prints the output to STDOUT. If
-an error occurs, it is printed to STDERR.
+This command renders the named file and prints the output to STDOUT. If an
+error occurs, it is printed to STDERR.
tt-render [template-options] file-name
=head1 TEMPLATE PATH
When using Template::Toolkit::Simple or C<tt-render>, the most common
-parameters you will use are the main template file name and the
-directory of supporting templates. As a convenience, you can specify
-these together.
+parameters you will use are the main template file name and the directory of
+supporting templates. As a convenience, you can specify these together.
This:
@@ -79,8 +87,8 @@ It takes no parameters.
=head1 METHODS
-This section describes the methods that are not option setting methods.
-Those methods are described below.
+This section describes the methods that are not option setting methods. Those
+methods are described below.
=over
@@ -90,9 +98,9 @@ Return a new Template::Toolkit::Simple object. Takes no parameters.
=item render($template, $data);
-This is the method that actually renders the template. It is similar to
-the Template Toolkit C<process> method, except that it actually returns
-the template result as a string. It returns undef if an error occurs.
+This is the method that actually renders the template. It is similar to the
+Template Toolkit C<process> method, except that it actually returns the
+template result as a string. It returns undef if an error occurs.
The C<$data> field is optional and can be set with the C<data> method.
@@ -100,10 +108,9 @@ If you need more control, see the process command below:
=item process($template, $data, $output, %options);
-This command is simply a proxy to the Template Toolkit C<process>
-command. All the parameters you give it are passed to the real
-C<process> command and the result is returned. See L<Template> for more
-information.
+This command is simply a proxy to the Template Toolkit C<process> command. All
+the parameters you give it are passed to the real C<process> command and the
+result is returned. See L<Template> for more information.
=item output($filepath)
@@ -111,16 +118,16 @@ Specify a filepath to print the template result to.
=item error()
-This method is a proxy to the Template Toolkit C<error> method. It
-returns the error message if there was an error.
+This method is a proxy to the Template Toolkit C<error> method. It returns the
+error message if there was an error.
=back
=head1 OPTION METHODS
All of the Template Toolkit options are available as methods to
-Template::Toolkit::Simple objects, and also as command line options to
-the C<tt-render> command.
+Template::Toolkit::Simple objects, and also as command line options to the C<tt-
+render> command.
For example, the C<POST_CHOMP> options is available in the following ways:
@@ -138,95 +145,173 @@ L<Template>.
=over
-=item config($file_name || $hash)
+=item C<config($file_name || $hash)>
-If you have a common set of Template Toolkit options stored in a file,
-you can use this method to read and parse the file, and set the
-appropriate options.
+If you have a common set of Template Toolkit options stored in a file, you can
+use this method to read and parse the file, and set the appropriate options.
The currently supported file formats are YAML, JSON and XML. The format
is determined by the file extension, so use the appropriate one. Note
-that XML::Simple is used to parse XML files and JSON::XS is used to
-parse JSON files.
+that XML::Simple is used to parse XML files and JSON::XS is used to parse
+JSON files.
-=item data($file_name || $hash)
+=item C<data($file_name || $hash)>
-Most templates use a hash object of data to access values while
-rendering. You can specify this data in a file or with a hash reference.
+Most templates use a hash object of data to access values while rendering. You
+can specify this data in a file or with a hash reference.
-The currently supported file formats are YAML, JSON and XML. The format
-is determined by the file extension, so use the appropriate one. Note
-the XML::Simple is used to parse XML files.
+The currently supported file formats are YAML, JSON and XML. The format is
+determined by the file extension, so use the appropriate one. Note the
+XML::Simple is used to parse XML files.
+
+=item C<include_path($template_directories)>
+
+Default is undef
+
+This method allows you to specify the directories that are searched to find
+templates. You can specify this as a string containing a single directory, an
+array ref of strings containing directory names, or as a string containing
+multiple directories separated by ':'.
+
+=item C<path()>
+
+Default is undef
+
+This is a shorter name for C<include_path>. It does the exact same thing.
+
+=item C<start_tag()>
+
+Default is '[%'
+
+
+=item C<end_tag()>
+
+Default is '%]'
+
+
+=item C<tag_style()>
+
+Default is 'template'
+
+
+=item C<pre_chomp()>
+
+Default is 0
+
+
+=item C<post_chomp()>
+
+Default is 0
+
+
+=item C<trim()>
+
+Default is 0
+
+
+=item C<interpolate()>
+
+Default is 0
+
+
+=item C<anycase()>
+
+Default is 0
+
+
+=item C<delimiter()>
+
+Default is ':'
+
+
+=item C<absolute()>
+
+Default is 0
+
+
+=item C<relative()>
+
+Default is 0
+
+
+=item C<strict()>
+
+Default is 0
+
+
+=item C<default()>
+
+Default is undef
+
+
+=item C<blocks()>
+
+Default is undef
+
+
+=item C<auto_reset()>
+
+Default is 1
+
+
+=item C<recursion()>
-=item include_path($template_directories) -- Default is undef
+Default is 0
-This method allows you to specify the directories that are searched to
-find templates. You can specify this as a string containing a single
-directory, an array ref of strings containing directory names, or as a
-string containing multiple directories separated by ':'.
-=item path() -- Default is undef
+=item C<eval_perl()>
-This is a shorter name for C<include_path>. It does the exact
-same thing.
+Default is 0
-=item start_tag() -- Default is '[%'
-=item end_tag() -- Default is '%]'
+=item C<pre_process()>
-=item tag_style() -- Default is 'template'
+Default is undef
-=item pre_chomp() -- Default is 0
-=item post_chomp() -- Default is 0
+=item C<post_process()>
-=item trim() -- Default is 0
+Default is undef
-=item interpolate() -- Default is 0
-=item anycase() -- Default is 0
+=item C<process_template()>
-=item delimiter() -- Default is ':'
+Default is undef
-=item absolute() -- Default is 0
+This is a proxy to the Template Toolkit PROCESS option. The C<process> method
+is used to actually process a template.
-=item relative() -- Default is 0
+=item C<error_template()>
-=item strict() -- Default is 0
+Default is undef
-=item default() -- Default is undef
+This is a proxy to the Template Toolkit ERROR option. The C<error()> method
+returns the error message on a failure.
-=item blocks() -- Default is undef
+=item C<debug()>
-=item auto_reset() -- Default is 1
+Default is 0
-=item recursion() -- Default is 0
-=item eval_perl() -- Default is 0
+=item C<cache_size()>
-=item pre_process() -- Default is undef
+Default is undef
-=item post_process() -- Default is undef
-=item process_template() -- Default is undef
+=item C<compile_ext()>
-This is a proxy to the Template Toolkit PROCESS option. The C<process>
-method is used to actually process a template.
+Default is undef
-=item error_template() -- Default is undef
-This is a proxy to the Template Toolkit ERROR option. The C<error()>
-method returns the error message on a failure.
+=item C<compile_dir()>
-=item debug() -- Default is 0
+Default is undef
-=item cache_size() -- Default is undef
-=item compile_ext() -- Default is undef
+=item C<encoding()>
-=item compile_dir() -- Default is undef
+Default is 'utf8'
-=item encoding() -- Default is 'utf8'
=back
@@ -236,11 +321,11 @@ Ingy döt Net <ingy@cpan.org>
=head1 COPYRIGHT AND LICENSE
-Copyright (c) 2008, 2009, 2010, 2011. Ingy döt Net.
+Copyright 2008-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,17 @@
+# 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 $_;
+}
+
+find {
+ wanted => \&test,
+ no_chdir => 1,
+}, 'lib';
+
+done_testing;
@@ -1,28 +1,44 @@
-use TestML -run,
- -require_or_skip => 'YAML::XS';
-
-sub run_command {
- my $command = shift->value;
- open my $execution, "$^X bin/$command |"
- or die "Couldn't open subprocess: $!\n";
- local $/;
- my $output = <$execution>;
- close $execution;
- return $output;
-}
-
-sub expected {
- return <<'...';
+use lib 'inc';
+
+use TestML;
+
+TestML->new(
+ testml => do { local $/; <DATA> },
+ bridge => 'main',
+)->run;
+
+{
+ package main;
+ use base 'TestML::Bridge';
+ use TestML::Util;
+
+ sub run_command {
+ my ($self, $command) = @_;
+ $command = $command->value;
+ if (-d 'test') {
+ $command =~ s/\bt\b/test/g;
+ }
+ open my $execution, "$^X bin/$command |"
+ or die "Couldn't open subprocess: $!\n";
+ local $/;
+ my $output = <$execution>;
+ close $execution;
+ return str $output;
+ }
+
+ sub expected {
+ return str <<'...';
Hi Löver,
Have a nice day.
Smööches, Ingy
...
+ }
}
__DATA__
-%TestML 1.0
+%TestML 0.1.0
Plan = 3;
@@ -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();
@@ -1,19 +1,37 @@
-use TestML -run,
- -require_or_skip => 'JSON::XS';
-
-use Template::Toolkit::Simple;
-
-sub render_template {
- my $context = shift;
- return tt
- ->post_chomp
- ->path('t/template')
- ->data('t/render.json')
- ->render($context->value);
+use lib 'inc';
+
+{
+ use Test::More;
+ eval "use JSON::XS; 1" or
+ plan skip_all => 'JSON::XS required';
+}
+
+use TestML;
+
+TestML->new(
+ testml => do { local $/; <DATA> },
+ bridge => 'main',
+)->run;
+
+{
+ package main;
+ use base 'TestML::Bridge';
+ use TestML::Util;
+ use Template::Toolkit::Simple;
+
+ sub render_template {
+ my ($self, $context) = @_;
+ my $t = -d 't' ? 't' : 'test';
+ return str tt
+ ->post_chomp
+ ->path("$t/template")
+ ->data("$t/render.json")
+ ->render($context->value);
+ }
}
__DATA__
-%TestML 1.0
+%TestML 0.1.0
Plan = 1;
@@ -1,19 +1,37 @@
-use TestML -run,
- -require_or_skip => 'XML::Simple';
-
-use Template::Toolkit::Simple;
-
-sub render_template {
- my $context = shift;
- return tt
- ->post_chomp
- ->path('t/template')
- ->data('t/render.xml')
- ->render($context->value);
+use lib 'inc';
+
+{
+ use Test::More;
+ eval "use XML::Simple; 1" or
+ plan skip_all => 'XML::Simple required';
+}
+
+use TestML;
+
+TestML->new(
+ testml => do { local $/; <DATA> },
+ bridge => 'main',
+)->run;
+
+{
+ package main;
+ use base 'TestML::Bridge';
+ use TestML::Util;
+ use Template::Toolkit::Simple;
+
+ sub render_template {
+ my ($self, $context) = @_;
+ my $t = -d 't' ? 't' : 'test';
+ return str tt
+ ->post_chomp
+ ->path("$t/template")
+ ->data("$t/render.xml")
+ ->render($context->value);
+ }
}
__DATA__
-%TestML 1.0
+%TestML 0.1.0
Plan = 1;
@@ -1,19 +1,31 @@
-use TestML -run,
- -require_or_skip => 'YAML::XS';
-
-use Template::Toolkit::Simple;
-
-sub render_template {
- my $context = shift;
- return tt
- ->post_chomp
- ->path('t/template')
- ->data('t/render.yaml')
- ->render($context->value);
+use lib 'inc';
+
+use TestML;
+
+TestML->new(
+ testml => do { local $/; <DATA> },
+ bridge => 'main',
+)->run;
+
+{
+ package main;
+ use base 'TestML::Bridge';
+ use TestML::Util;
+ use Template::Toolkit::Simple;
+
+ sub render_template {
+ my ($self, $context) = @_;
+ my $t = -d 't' ? 't' : 'test';
+ return str tt
+ ->post_chomp
+ ->path("$t/template")
+ ->data("$t/render.yaml")
+ ->render($context->value);
+ }
}
__DATA__
-%TestML 1.0
+%TestML 0.1.0
Plan = 1;
@@ -1,3 +0,0 @@
-use Test::More tests => 1;
-
-use_ok 'Template::Toolkit::Simple';