Parse-Keyword-0.08000755001750000144 012225545635 13261 5ustar00doyusers000000000000README100644001750000144 35612225545635 14206 0ustar00doyusers000000000000Parse-Keyword-0.08 This archive contains the distribution Parse-Keyword, version 0.08: DEPRECATED: write syntax extensions in perl This software is Copyright (c) 2013 by Jesse Luehrs. This is free software, licensed under: The MIT (X11) License Changes100644001750000144 200212225545635 14627 0ustar00doyusers000000000000Parse-Keyword-0.08Revision history for Parse-Keyword 0.08 2013-10-10 - doc tweaks to make the deprecation notice more visible 0.07 2013-10-10 - THIS MODULE IS NO LONGER SUPPORTED DUE TO UNFIXABLE BROKENNESS see the warning in the documentation for more details - fix tests for newer Carp (abraxxa) 0.06 2013-08-01 - support building on windows (forwardever, #3) 0.05 2013-07-24 - fix skipping tests 0.04 2013-07-23 - pass the keyword name into the parsing function 0.03 2013-07-23 - the parse_* functions now return undef when there was a parse error - various bugs related to error handling should be fixed - remove unnecessary test dep on B::Hooks::EndOfScope 0.02 2013-07-22 - work around some issues that would happen when you peeked past the end of the line - allow parsing into non-anonymous subs (this makes a difference in some obscure situations) - fix compilation on threaded perls 0.01 2013-07-21 - Initial release LICENSE100644001750000144 220712225545635 14350 0ustar00doyusers000000000000Parse-Keyword-0.08This software is Copyright (c) 2013 by Jesse Luehrs. This is free software, licensed under: The MIT (X11) License The MIT License Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. dist.ini100644001750000144 125012225545635 15004 0ustar00doyusers000000000000Parse-Keyword-0.08name = Parse-Keyword author = Jesse Luehrs license = MIT copyright_holder = Jesse Luehrs [@DOY] :version = 0.14 dist = Parse-Keyword repository = github awesome = =inc::MakeMaker [AutoPrereqs] skip = ^Error.*$ skip = ^My::Parser$ skip = ^(?:Try|Fun)$ skip = ^perl$ skip = ^Sub::Name$ skip = ^Try::Tiny$ skip = ^Exporter::Lexical$ skip = ^B::Hooks::EndOfScope$ skip = ^Capture::Tiny$ skip = ^MyExample$ [Prereqs] perl = 5.014 [Prereqs / ConfigureRequires] Devel::CallParser = 0 [Prereqs / DevelopRequires] Sub::Name = 0 Try::Tiny = 0 B::Hooks::EndOfScope = 0 Capture::Tiny = 0 [PruneFiles] filenames = Makefile.PL filenames = callparser1.h [ContributorsFromGit] t000755001750000144 012225545635 13445 5ustar00doyusers000000000000Parse-Keyword-0.08peek.t100644001750000144 44512225545635 14701 0ustar00doyusers000000000000Parse-Keyword-0.08/t#!/usr/bin/env perl use strict; use warnings; use Test::More; { package Parser; use Parse::Keyword { foo => \&parse_foo }; sub foo {} sub parse_foo { lex_peek(99999999); return sub {}; } ::is_deeply([ foo ], []); } is(__LINE__, 20); done_testing; META.yml100644001750000144 1434712225545635 14644 0ustar00doyusers000000000000Parse-Keyword-0.08--- abstract: 'DEPRECATED: write syntax extensions in perl' author: - 'Jesse Luehrs ' build_requires: Carp: 0 Exporter: 0 File::Find: 0 File::Temp: 0 Test::More: 0.88 base: 0 if: 0 lib: 0 configure_requires: Devel::CallParser: 0 ExtUtils::MakeMaker: 6.30 dynamic_config: 0 generated_by: 'Dist::Zilla version 4.300035, CPAN::Meta::Converter version 2.132140' license: mit meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Parse-Keyword provides: Parse::Keyword: file: lib/Parse/Keyword.pm version: 0.08 requires: Devel::CallParser: 0 XSLoader: 0 perl: 5.014 strict: 0 warnings: 0 resources: bugtracker: https://github.com/doy/parse-keyword/issues homepage: http://metacpan.org/release/Parse-Keyword repository: git://github.com/doy/parse-keyword.git version: 0.08 x_Dist_Zilla: perl: version: 5.018001 plugins: - class: Dist::Zilla::Plugin::Prereqs config: Dist::Zilla::Plugin::Prereqs: phase: test type: requires name: '@DOY/TestMoreDoneTesting' version: 4.300035 - class: Dist::Zilla::Plugin::GatherDir name: '@DOY/GatherDir' version: 4.300035 - class: Dist::Zilla::Plugin::PruneCruft name: '@DOY/PruneCruft' version: 4.300035 - class: Dist::Zilla::Plugin::ManifestSkip name: '@DOY/ManifestSkip' version: 4.300035 - class: Dist::Zilla::Plugin::MetaYAML name: '@DOY/MetaYAML' version: 4.300035 - class: Dist::Zilla::Plugin::License name: '@DOY/License' version: 4.300035 - class: Dist::Zilla::Plugin::Readme name: '@DOY/Readme' version: 4.300035 - class: Dist::Zilla::Plugin::RunExtraTests name: '@DOY/RunExtraTests' version: 0.011 - class: Dist::Zilla::Plugin::ExecDir name: '@DOY/ExecDir' version: 4.300035 - class: Dist::Zilla::Plugin::ShareDir name: '@DOY/ShareDir' version: 4.300035 - class: inc::MakeMaker name: '@DOY/=inc::MakeMaker' version: ~ - class: Dist::Zilla::Plugin::Manifest name: '@DOY/Manifest' version: 4.300035 - class: Dist::Zilla::Plugin::TestRelease name: '@DOY/TestRelease' version: 4.300035 - class: Dist::Zilla::Plugin::ConfirmRelease name: '@DOY/ConfirmRelease' version: 4.300035 - class: Dist::Zilla::Plugin::MetaConfig name: '@DOY/MetaConfig' version: 4.300035 - class: Dist::Zilla::Plugin::MetaJSON name: '@DOY/MetaJSON' version: 4.300035 - class: Dist::Zilla::Plugin::NextRelease name: '@DOY/NextRelease' version: 4.300035 - class: Dist::Zilla::Plugin::CheckChangesHasContent name: '@DOY/CheckChangesHasContent' version: 0.006 - class: Dist::Zilla::Plugin::PkgVersion name: '@DOY/PkgVersion' version: 4.300035 - class: Dist::Zilla::Plugin::Authority name: '@DOY/Authority' version: 1.006 - class: Dist::Zilla::Plugin::PodCoverageTests name: '@DOY/PodCoverageTests' version: 4.300035 - class: Dist::Zilla::Plugin::PodSyntaxTests name: '@DOY/PodSyntaxTests' version: 4.300035 - class: Dist::Zilla::Plugin::NoTabsTests name: '@DOY/NoTabsTests' version: 0.01 - class: Dist::Zilla::Plugin::EOLTests name: '@DOY/EOLTests' version: 0.02 - class: Dist::Zilla::Plugin::Test::Compile name: '@DOY/Test::Compile' version: 2.002 - class: Dist::Zilla::Plugin::Metadata name: '@DOY/Metadata' version: 3.03 - class: Dist::Zilla::Plugin::MetaResources name: '@DOY/MetaResources' version: 4.300035 - class: Dist::Zilla::Plugin::Git::Check name: '@DOY/Git::Check' version: 2.013 - class: Dist::Zilla::Plugin::Git::Commit name: '@DOY/Git::Commit' version: 2.013 - class: Dist::Zilla::Plugin::Git::Tag name: '@DOY/Git::Tag' version: 2.013 - class: Dist::Zilla::Plugin::Git::NextVersion name: '@DOY/Git::NextVersion' version: 2.013 - class: Dist::Zilla::Plugin::ContributorsFromGit name: '@DOY/ContributorsFromGit' version: 0.006 - class: Dist::Zilla::Plugin::MetaProvides::Package name: '@DOY/MetaProvides::Package' version: 1.14000002 - class: Dist::Zilla::Plugin::PodWeaver name: '@DOY/PodWeaver' version: 3.101641 - class: Dist::Zilla::Plugin::UploadToCPAN name: '@DOY/UploadToCPAN' version: 4.300035 - class: Dist::Zilla::Plugin::AutoPrereqs name: AutoPrereqs version: 4.300035 - class: Dist::Zilla::Plugin::Prereqs config: Dist::Zilla::Plugin::Prereqs: phase: runtime type: requires name: Prereqs version: 4.300035 - class: Dist::Zilla::Plugin::Prereqs config: Dist::Zilla::Plugin::Prereqs: phase: configure type: requires name: ConfigureRequires version: 4.300035 - class: Dist::Zilla::Plugin::Prereqs config: Dist::Zilla::Plugin::Prereqs: phase: develop type: requires name: DevelopRequires version: 4.300035 - class: Dist::Zilla::Plugin::PruneFiles name: PruneFiles version: 4.300035 - class: Dist::Zilla::Plugin::ContributorsFromGit name: ContributorsFromGit version: 0.006 - class: Dist::Zilla::Plugin::FinderCode name: ':InstallModules' version: 4.300035 - class: Dist::Zilla::Plugin::FinderCode name: ':IncModules' version: 4.300035 - class: Dist::Zilla::Plugin::FinderCode name: ':TestFiles' version: 4.300035 - class: Dist::Zilla::Plugin::FinderCode name: ':ExecFiles' version: 4.300035 - class: Dist::Zilla::Plugin::FinderCode name: ':ShareFiles' version: 4.300035 - class: Dist::Zilla::Plugin::FinderCode name: ':MainModule' version: 4.300035 zilla: class: Dist::Zilla::Dist::Builder config: is_trial: 0 version: 4.300035 x_authority: cpan:DOY MANIFEST100644001750000144 133412225545635 14474 0ustar00doyusers000000000000Parse-Keyword-0.08Changes Keyword.xs LICENSE MANIFEST META.json META.yml Makefile.PL README dist.ini inc/MMHelper.pm inc/MakeMaker.pm lib/Parse/Keyword.pm t/00-compile.t t/basic.t t/closure.t t/error.pl t/error.t t/fun/anon.t t/fun/basic.t t/fun/closure-proto.t t/fun/compile-time.t t/fun/defaults.t t/fun/lib/Fun.pm t/fun/name.t t/fun/package.t t/fun/recursion.t t/fun/slurpy-syntax-errors.t t/fun/slurpy.t t/fun/state.t t/keyword-name.t t/lexical.t t/lib/My/Parser.pm t/peek.t t/scope-inject.t t/try/basic.t t/try/context.t t/try/finally.t t/try/given_when.t t/try/lib/Error1.pm t/try/lib/Error2.pm t/try/lib/Try.pm t/try/syntax.t t/try/when.t t/unavailable.t xt/release/eol.t xt/release/no-tabs.t xt/release/pod-coverage.t xt/release/pod-syntax.t basic.t100644001750000144 112112225545635 15046 0ustar00doyusers000000000000Parse-Keyword-0.08/t#!/usr/bin/env perl use strict; use warnings; use Test::More; { package Foo; use Parse::Keyword { bar => \&bar_parser }; sub bar { @_ } sub bar_parser { return sub { return (1, 2, 3) } } ::is_deeply([bar], [1, 2, 3]); } { package Bar; use Parse::Keyword { baz => \&baz_parser }; my $code; sub baz { $code = $_[0] } sub baz_parser { lex_read_space; my $block = parse_block; return (sub { $block }, 1); } baz { 1 + 2 } ::is(ref($code), 'CODE'); ::is($code->(), 3); } done_testing; error.t100644001750000144 335212225545635 15126 0ustar00doyusers000000000000Parse-Keyword-0.08/t#!/usr/bin/env perl use strict; use warnings; use Test::More; use lib 't/lib'; use My::Parser; { my $ret = eval 'foo'; # not testing the value of $@ because it's just "whatever the parser # happens to do after getting into a confused state" ok($@); ok(!$ret); ok(!$My::Parser::got_code); } { my $ret = eval 'foo { }'; ok(!$@); ok($ret); ok($My::Parser::got_code); } { my $ret = eval 'foo { $baz }'; like($@, qr/^Global symbol "\$baz" requires explicit package name/); ok(!$ret); ok(!$My::Parser::got_code); } # wrapping a parsing function in an eval doesn't actually help, because parsing # doesn't throw errors in the same way. errors are all saved up until parsing # finishes, and then they are all reported at once if there were any. { my $ret = eval 'bar'; # not testing the value of $@ because it's just "whatever the parser # happens to do after getting into a confused state" ok($@); ok(!$ret); ok(!$My::Parser::got_code); } { my $ret = eval 'bar { }'; ok(!$@); ok($ret); ok($My::Parser::got_code); } { my $ret = eval 'bar { $baz }'; # the eval does, however, prevent perl from seeing what the message was like($@, qr/^Compilation error/); ok(!$ret); ok(!$My::Parser::got_code); } SKIP: { skip "Capture::Tiny is required here", 1 unless eval { require Capture::Tiny }; my ($out, $err, $exit) = Capture::Tiny::capture(sub { system($^X, (map { qq[-I$_] } @INC), 't/error.pl') }); is($out, ''); is( $err, <<'ERR' Global symbol "$baz" requires explicit package name at t/error.pl line 9. Execution of t/error.pl aborted due to compilation errors. ERR ); isnt($exit, 0); } done_testing; META.json100644001750000144 2407112225545635 15007 0ustar00doyusers000000000000Parse-Keyword-0.08{ "abstract" : "DEPRECATED: write syntax extensions in perl", "author" : [ "Jesse Luehrs " ], "dynamic_config" : 0, "generated_by" : "Dist::Zilla version 4.300035, CPAN::Meta::Converter version 2.132140", "license" : [ "mit" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Parse-Keyword", "prereqs" : { "configure" : { "requires" : { "Devel::CallParser" : "0", "ExtUtils::MakeMaker" : "6.30" } }, "develop" : { "requires" : { "B::Hooks::EndOfScope" : "0", "Capture::Tiny" : "0", "Pod::Coverage::TrustPod" : "0", "Sub::Name" : "0", "Test::Pod" : "1.41", "Test::Pod::Coverage" : "1.08", "Try::Tiny" : "0" } }, "runtime" : { "requires" : { "Devel::CallParser" : "0", "XSLoader" : "0", "perl" : "5.014", "strict" : "0", "warnings" : "0" } }, "test" : { "requires" : { "Carp" : "0", "Exporter" : "0", "File::Find" : "0", "File::Temp" : "0", "Test::More" : "0.88", "base" : "0", "if" : "0", "lib" : "0" } } }, "provides" : { "Parse::Keyword" : { "file" : "lib/Parse/Keyword.pm", "version" : "0.08" } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/doy/parse-keyword/issues" }, "homepage" : "http://metacpan.org/release/Parse-Keyword", "repository" : { "type" : "git", "url" : "git://github.com/doy/parse-keyword.git", "web" : "https://github.com/doy/parse-keyword" } }, "version" : "0.08", "x_Dist_Zilla" : { "perl" : { "version" : "5.018001" }, "plugins" : [ { "class" : "Dist::Zilla::Plugin::Prereqs", "config" : { "Dist::Zilla::Plugin::Prereqs" : { "phase" : "test", "type" : "requires" } }, "name" : "@DOY/TestMoreDoneTesting", "version" : "4.300035" }, { "class" : "Dist::Zilla::Plugin::GatherDir", "name" : "@DOY/GatherDir", "version" : "4.300035" }, { "class" : "Dist::Zilla::Plugin::PruneCruft", "name" : "@DOY/PruneCruft", "version" : "4.300035" }, { "class" : "Dist::Zilla::Plugin::ManifestSkip", "name" : "@DOY/ManifestSkip", "version" : "4.300035" }, { "class" : "Dist::Zilla::Plugin::MetaYAML", "name" : "@DOY/MetaYAML", "version" : "4.300035" }, { "class" : "Dist::Zilla::Plugin::License", "name" : "@DOY/License", "version" : "4.300035" }, { "class" : "Dist::Zilla::Plugin::Readme", "name" : "@DOY/Readme", "version" : "4.300035" }, { "class" : "Dist::Zilla::Plugin::RunExtraTests", "name" : "@DOY/RunExtraTests", "version" : "0.011" }, { "class" : "Dist::Zilla::Plugin::ExecDir", "name" : "@DOY/ExecDir", "version" : "4.300035" }, { "class" : "Dist::Zilla::Plugin::ShareDir", "name" : "@DOY/ShareDir", "version" : "4.300035" }, { "class" : "inc::MakeMaker", "name" : "@DOY/=inc::MakeMaker", "version" : null }, { "class" : "Dist::Zilla::Plugin::Manifest", "name" : "@DOY/Manifest", "version" : "4.300035" }, { "class" : "Dist::Zilla::Plugin::TestRelease", "name" : "@DOY/TestRelease", "version" : "4.300035" }, { "class" : "Dist::Zilla::Plugin::ConfirmRelease", "name" : "@DOY/ConfirmRelease", "version" : "4.300035" }, { "class" : "Dist::Zilla::Plugin::MetaConfig", "name" : "@DOY/MetaConfig", "version" : "4.300035" }, { "class" : "Dist::Zilla::Plugin::MetaJSON", "name" : "@DOY/MetaJSON", "version" : "4.300035" }, { "class" : "Dist::Zilla::Plugin::NextRelease", "name" : "@DOY/NextRelease", "version" : "4.300035" }, { "class" : "Dist::Zilla::Plugin::CheckChangesHasContent", "name" : "@DOY/CheckChangesHasContent", "version" : "0.006" }, { "class" : "Dist::Zilla::Plugin::PkgVersion", "name" : "@DOY/PkgVersion", "version" : "4.300035" }, { "class" : "Dist::Zilla::Plugin::Authority", "name" : "@DOY/Authority", "version" : "1.006" }, { "class" : "Dist::Zilla::Plugin::PodCoverageTests", "name" : "@DOY/PodCoverageTests", "version" : "4.300035" }, { "class" : "Dist::Zilla::Plugin::PodSyntaxTests", "name" : "@DOY/PodSyntaxTests", "version" : "4.300035" }, { "class" : "Dist::Zilla::Plugin::NoTabsTests", "name" : "@DOY/NoTabsTests", "version" : "0.01" }, { "class" : "Dist::Zilla::Plugin::EOLTests", "name" : "@DOY/EOLTests", "version" : "0.02" }, { "class" : "Dist::Zilla::Plugin::Test::Compile", "name" : "@DOY/Test::Compile", "version" : "2.002" }, { "class" : "Dist::Zilla::Plugin::Metadata", "name" : "@DOY/Metadata", "version" : "3.03" }, { "class" : "Dist::Zilla::Plugin::MetaResources", "name" : "@DOY/MetaResources", "version" : "4.300035" }, { "class" : "Dist::Zilla::Plugin::Git::Check", "name" : "@DOY/Git::Check", "version" : "2.013" }, { "class" : "Dist::Zilla::Plugin::Git::Commit", "name" : "@DOY/Git::Commit", "version" : "2.013" }, { "class" : "Dist::Zilla::Plugin::Git::Tag", "name" : "@DOY/Git::Tag", "version" : "2.013" }, { "class" : "Dist::Zilla::Plugin::Git::NextVersion", "name" : "@DOY/Git::NextVersion", "version" : "2.013" }, { "class" : "Dist::Zilla::Plugin::ContributorsFromGit", "name" : "@DOY/ContributorsFromGit", "version" : "0.006" }, { "class" : "Dist::Zilla::Plugin::MetaProvides::Package", "name" : "@DOY/MetaProvides::Package", "version" : "1.14000002" }, { "class" : "Dist::Zilla::Plugin::PodWeaver", "name" : "@DOY/PodWeaver", "version" : "3.101641" }, { "class" : "Dist::Zilla::Plugin::UploadToCPAN", "name" : "@DOY/UploadToCPAN", "version" : "4.300035" }, { "class" : "Dist::Zilla::Plugin::AutoPrereqs", "name" : "AutoPrereqs", "version" : "4.300035" }, { "class" : "Dist::Zilla::Plugin::Prereqs", "config" : { "Dist::Zilla::Plugin::Prereqs" : { "phase" : "runtime", "type" : "requires" } }, "name" : "Prereqs", "version" : "4.300035" }, { "class" : "Dist::Zilla::Plugin::Prereqs", "config" : { "Dist::Zilla::Plugin::Prereqs" : { "phase" : "configure", "type" : "requires" } }, "name" : "ConfigureRequires", "version" : "4.300035" }, { "class" : "Dist::Zilla::Plugin::Prereqs", "config" : { "Dist::Zilla::Plugin::Prereqs" : { "phase" : "develop", "type" : "requires" } }, "name" : "DevelopRequires", "version" : "4.300035" }, { "class" : "Dist::Zilla::Plugin::PruneFiles", "name" : "PruneFiles", "version" : "4.300035" }, { "class" : "Dist::Zilla::Plugin::ContributorsFromGit", "name" : "ContributorsFromGit", "version" : "0.006" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":InstallModules", "version" : "4.300035" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":IncModules", "version" : "4.300035" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":TestFiles", "version" : "4.300035" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":ExecFiles", "version" : "4.300035" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":ShareFiles", "version" : "4.300035" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":MainModule", "version" : "4.300035" } ], "zilla" : { "class" : "Dist::Zilla::Dist::Builder", "config" : { "is_trial" : "0" }, "version" : "4.300035" } }, "x_authority" : "cpan:DOY" } Keyword.xs100644001750000144 1106312225545635 15363 0ustar00doyusers000000000000Parse-Keyword-0.08#include "EXTERN.h" #include "perl.h" #include "callparser1.h" #include "XSUB.h" #ifndef cv_clone #define cv_clone(a) Perl_cv_clone(aTHX_ a) #endif static SV *parser_fn(OP *(fn)(pTHX_ U32), bool named) { I32 floor; CV *code; U8 errors; ENTER; PL_curcop = &PL_compiling; SAVEVPTR(PL_op); SAVEI8(PL_parser->error_count); PL_parser->error_count = 0; floor = start_subparse(0, named ? 0 : CVf_ANON); code = newATTRSUB(floor, NULL, NULL, NULL, fn(aTHX_ 0)); errors = PL_parser->error_count; LEAVE; if (errors) { ++PL_parser->error_count; return newSV(0); } else { if (CvCLONE(code)) { code = cv_clone(code); } return newRV_inc((SV*)code); } } static OP *parser_callback(pTHX_ GV *namegv, SV *psobj, U32 *flagsp) { dSP; SV *args_generator; SV *statement = NULL; I32 count; /* call the parser callback * it should take no arguments and return a coderef which, when called, * produces the arguments to the keyword function * the optree we want to generate is for something like * mykeyword($code->()) * where $code is the thing returned by the parser function */ PUSHMARK(SP); mXPUSHp(GvNAME(namegv), GvNAMELEN(namegv)); PUTBACK; count = call_sv(psobj, G_ARRAY); SPAGAIN; if (count > 1) { statement = POPs; } args_generator = SvREFCNT_inc(POPs); PUTBACK; if (!SvROK(args_generator) || SvTYPE(SvRV(args_generator)) != SVt_PVCV) { croak("The parser function for %s must return a coderef, not %"SVf, GvNAME(namegv), args_generator); } if (SvTRUE(statement)) { *flagsp |= CALLPARSER_STATEMENT; } return newUNOP(OP_ENTERSUB, OPf_STACKED, newCVREF(0, newSVOP(OP_CONST, 0, args_generator))); } /* TODO: * - "parse a variable name" * - "parse a quoted string" * - "create a new lexical variable" (maybe?) */ MODULE = Parse::Keyword PACKAGE = Parse::Keyword PROTOTYPES: DISABLE void install_keyword_handler(keyword, handler) SV *keyword SV *handler CODE: cv_set_call_parser((CV*)SvRV(keyword), parser_callback, handler); SV * lex_peek(len = 1) UV len CODE: PL_curcop = &PL_compiling; /* XXX before 5.19.2, lex_next_chunk when we aren't at the end of a line * just breaks things entirely (the parser no longer sees the text that is * read in). this is (i think inadvertently) fixed in 5.19.2 (21791330a), * but it still screws up the line numbers of everything that follows. so, * the workaround is just to not call lex_next_chunk unless we're at the * end of a line. this is a bit limiting, but should rarely come up in * practice. */ /* while (PL_parser->bufend - PL_parser->bufptr < len) { if (!lex_next_chunk(0)) { break; } } */ if (PL_parser->bufptr == PL_parser->bufend) { lex_next_chunk(0); } if (PL_parser->bufend - PL_parser->bufptr < len) { len = PL_parser->bufend - PL_parser->bufptr; } RETVAL = newSVpvn(PL_parser->bufptr, len); /* XXX unicode? */ OUTPUT: RETVAL void lex_read(len = 1) UV len CODE: PL_curcop = &PL_compiling; lex_read_to(PL_parser->bufptr + len); void lex_read_space() CODE: PL_curcop = &PL_compiling; lex_read_space(0); void lex_stuff(str) SV *str CODE: PL_curcop = &PL_compiling; lex_stuff_sv(str, 0); SV * parse_block(named = FALSE) bool named CODE: RETVAL = parser_fn(Perl_parse_block, named); OUTPUT: RETVAL SV * parse_stmtseq(named = FALSE) bool named CODE: RETVAL = parser_fn(Perl_parse_stmtseq, named); OUTPUT: RETVAL SV * parse_fullstmt(named = FALSE) bool named CODE: RETVAL = parser_fn(Perl_parse_fullstmt, named); OUTPUT: RETVAL SV * parse_barestmt(named = FALSE) bool named CODE: RETVAL = parser_fn(Perl_parse_barestmt, named); OUTPUT: RETVAL SV * parse_fullexpr(named = FALSE) bool named CODE: RETVAL = parser_fn(Perl_parse_fullexpr, named); OUTPUT: RETVAL SV * parse_listexpr(named = FALSE) bool named CODE: RETVAL = parser_fn(Perl_parse_listexpr, named); OUTPUT: RETVAL SV * parse_termexpr(named = FALSE) bool named CODE: RETVAL = parser_fn(Perl_parse_termexpr, named); OUTPUT: RETVAL SV * parse_arithexpr(named = FALSE) bool named CODE: RETVAL = parser_fn(Perl_parse_arithexpr, named); OUTPUT: RETVAL SV * compiling_package() CODE: RETVAL = newSVsv(PL_curstname); OUTPUT: RETVAL error.pl100644001750000144 14012225545635 15246 0ustar00doyusers000000000000Parse-Keyword-0.08/t#!/usr/bin/env perl use strict; use warnings; use lib 't/lib'; use My::Parser; foo { $baz }; lexical.t100644001750000144 123212225545635 15411 0ustar00doyusers000000000000Parse-Keyword-0.08/t#!/usr/bin/env perl use strict; use warnings; use Test::More; BEGIN { if (!eval { require Exporter::Lexical }) { plan skip_all => "This test requires Exporter::Lexical"; } } BEGIN { plan skip_all => "This doesn't work yet." } BEGIN { package My::Parser; use Exporter::Lexical -exports => ['foo']; use Parse::Keyword { foo => \&parse_foo }; sub foo { $_[0]->() } sub parse_foo { lex_read_space; my $code = parse_block; return sub { $code }; } $INC{'My/Parser.pm'} = __FILE__; } { use My::Parser; is(foo { my $x = 1; $x + 3 }, 4); } eval "foo { 1 }"; like $@, qr/slkfdj/; done_testing; closure.t100644001750000144 176712225545635 15461 0ustar00doyusers000000000000Parse-Keyword-0.08/t#!/usr/bin/env perl use strict; use warnings; use 5.014; use Test::More; BEGIN { package MyExample; $INC{'MyExample.pm'} = __FILE__; use base 'Exporter'; use Parse::Keyword { example => \&_parse_example }; our @EXPORT = 'example'; sub example { shift->(); } sub _parse_example { lex_read_space; my $code = parse_block; lex_read_space; return sub { $code }; } } use MyExample 'example'; is(example { 1 }, 1); is(example { 2 }, 2); is(example { 3 }, 3); for our $package (1..3) { is(example { $package }, $package); } for my $lexical (1..3) { local $TODO = "broken"; is(example { $lexical }, $lexical); } sub xxxx { my $lexical = shift; say example { $lexical }; } for (1..3) { local $TODO = "broken" if $_ > 1; is(xxxx($_), $_); } is(xxxx(1), 1); { local $TODO = "broken"; is(xxxx(2), 2); is(xxxx(3), 3); } for my $x (1..3) { local $TODO = "broken" if $x > 1; is(xxxx($x), $x); } done_testing; Makefile.PL100644001750000144 351712225545635 15322 0ustar00doyusers000000000000Parse-Keyword-0.08# This Makefile.PL for was generated by Dist::Zilla. # Don't edit it but the dist.ini used to construct it. BEGIN { require 5.014; } use strict; use warnings; use ExtUtils::MakeMaker 6.30; my %WriteMakefileArgs = ( 'ABSTRACT' => 'DEPRECATED: write syntax extensions in perl', 'AUTHOR' => 'Jesse Luehrs ', 'BUILD_REQUIRES' => { 'Carp' => '0', 'Exporter' => '0', 'File::Find' => '0', 'File::Temp' => '0', 'Test::More' => '0.88', 'base' => '0', 'if' => '0', 'lib' => '0' }, 'CONFIGURE_REQUIRES' => { 'Devel::CallParser' => '0', 'ExtUtils::MakeMaker' => '6.30' }, 'DISTNAME' => 'Parse-Keyword', 'EXE_FILES' => [], 'LICENSE' => 'mit', 'NAME' => 'Parse::Keyword', 'NORECURS' => 1, 'PREREQ_PM' => { 'Devel::CallParser' => '0', 'XSLoader' => '0', 'strict' => '0', 'warnings' => '0' }, 'VERSION' => '0.08', 'clean' => { 'FILES' => 'callparser1.h' }, 'test' => { 'TESTS' => 't/*.t t/fun/*.t t/try/*.t' } ); unless ( eval { ExtUtils::MakeMaker->VERSION(6.56) } ) { my $br = delete $WriteMakefileArgs{BUILD_REQUIRES}; my $pp = $WriteMakefileArgs{PREREQ_PM}; for my $mod ( keys %$br ) { if ( exists $pp->{$mod} ) { $pp->{$mod} = $br->{$mod} if $br->{$mod} > $pp->{$mod}; } else { $pp->{$mod} = $br->{$mod}; } } } delete $WriteMakefileArgs{CONFIGURE_REQUIRES} unless eval { ExtUtils::MakeMaker->VERSION(6.52) }; use File::Spec::Functions 'abs2rel'; use Devel::CallParser 'callparser1_h', 'callparser_linkable'; open my $fh, '>', 'callparser1.h' or die "Couldn't write to callparser1.h"; $fh->print(callparser1_h); my @linkable = map { abs2rel($_) } callparser_linkable; unshift @linkable, '$(BASEEXT)$(OBJ_EXT)' if @linkable; $WriteMakefileArgs{OBJECT} = join(' ', @linkable) if @linkable; WriteMakefile(%WriteMakefileArgs); fun000755001750000144 012225545635 14235 5ustar00doyusers000000000000Parse-Keyword-0.08/tanon.t100644001750000144 53112225545635 15474 0ustar00doyusers000000000000Parse-Keyword-0.08/t/fun#!/usr/bin/env perl use strict; use warnings; use Test::More; use lib 't/fun/lib'; BEGIN { if (!eval { require Sub::Name }) { plan skip_all => "This test requires Sub::Name"; } } use Fun; my $fun = fun ($x, $y) { $x * $y }; is($fun->(3, 4), 12); my $fun2 = fun ($z, $w = 10) { $z / $w }; is($fun2->(60), 6); done_testing; name.t100644001750000144 174712225545635 15513 0ustar00doyusers000000000000Parse-Keyword-0.08/t/fun#!/usr/bin/env perl use strict; use warnings; use Test::More; use lib 't/fun/lib'; BEGIN { if (!eval { require Sub::Name }) { plan skip_all => "This test requires Sub::Name"; } } use Carp; my $file = __FILE__; my $line = __LINE__; { package Foo; use Fun; fun foo ($x, $y) { Carp::confess "$x $y"; } eval { foo("abc", "123"); }; my $line_confess = $line + 6; my $line_foo = $line + 10; ::like($@, qr/^abc 123 at $file line $line_confess\.?\n\tFoo::foo\(['"]abc['"], 123\) called at $file line $line_foo/); } SKIP: { skip "Sub::Name required", 1 unless eval { require Sub::Name }; { package Bar; use Fun; *bar = Sub::Name::subname(bar => fun ($a, $b) { Carp::confess($a + $b) }); eval { bar(4, 5); }; my $line_confess = $line + 24; my $line_bar = $line + 27; ::like($@, qr/^9 at $file line $line_confess\.?\n\tBar::bar\(4, 5\) called at $file line $line_bar/); } } done_testing; try000755001750000144 012225545635 14263 5ustar00doyusers000000000000Parse-Keyword-0.08/twhen.t100644001750000144 113612225545635 15552 0ustar00doyusers000000000000Parse-Keyword-0.08/t/try#!/usr/bin/env perl use strict; use warnings; use Test::More; use lib 't/try/lib'; use 5.014; BEGIN { if (!eval { require Try::Tiny }) { plan skip_all => "This test requires Try::Tiny"; } } no if $] >= 5.018, warnings => 'experimental::smartmatch'; use Try; my ( $foo, $bar, $other ); $_ = "magic"; try { die "foo"; } catch { like( $_, qr/foo/ ); when (/bar/) { $bar++ }; when (/foo/) { $foo++ }; default { $other++ }; } is( $_, "magic", '$_ not clobbered' ); ok( !$bar, "bar didn't match" ); ok( $foo, "foo matched" ); ok( !$other, "fallback didn't match" ); done_testing; state.t100644001750000144 45512225545635 15666 0ustar00doyusers000000000000Parse-Keyword-0.08/t/fun#!/usr/bin/env perl use strict; use warnings; use Test::More; use lib 't/fun/lib'; BEGIN { if (!eval { require Sub::Name }) { plan skip_all => "This test requires Sub::Name"; } } use 5.10.0; use Fun; fun bar ($y) { state $x = 10; $x * $y; } is(bar(3), 30); done_testing; basic.t100644001750000144 76512225545635 15633 0ustar00doyusers000000000000Parse-Keyword-0.08/t/fun#!/usr/bin/env perl use strict; use warnings; use Test::More; use lib 't/fun/lib'; BEGIN { if (!eval { require Sub::Name }) { plan skip_all => "This test requires Sub::Name"; } } use Fun; fun mul ($x, $y) { return $x * $y; } is(mul(3, 4), 12); fun sum (@nums) { my $sum; for my $num (@nums) { $sum += $num; } return $sum; } is(sum(1, 2, 3, 4), 10); { package Foo; use Fun; fun foo { } foo(); } ok(exists $Foo::{foo}); done_testing; basic.t100644001750000144 420412225545635 15671 0ustar00doyusers000000000000Parse-Keyword-0.08/t/try#!/usr/bin/env perl use strict; use warnings; use Test::More; use lib 't/try/lib'; BEGIN { if (!eval { require Try::Tiny }) { plan skip_all => "This test requires Try::Tiny"; } } use Try; sub _eval { local $@; local $Test::Builder::Level = $Test::Builder::Level + 2; return ( scalar(eval { $_[0]->(); 1 }), $@ ); } sub lives_ok (&$) { my ( $code, $desc ) = @_; local $Test::Builder::Level = $Test::Builder::Level + 1; my ( $ok, $error ) = _eval($code); ok($ok, $desc ); diag "error: $@" unless $ok; } sub throws_ok (&$$) { my ( $code, $regex, $desc ) = @_; local $Test::Builder::Level = $Test::Builder::Level + 1; my ( $ok, $error ) = _eval($code); if ( $ok ) { fail($desc); } else { like($error || '', $regex, $desc ); } } my $prev; lives_ok { try { die "foo"; } pass("syntax ok"); } "basic try"; throws_ok { try { die "foo"; } catch { die $_ } pass("syntax ok"); } qr/foo/, "rethrow"; lives_ok { try { die "foo"; } catch { my $err = shift; try { like $err, qr/foo/; } catch { fail("shouldn't happen"); } pass "got here"; } pass("syntax ok"); } "try in try catch block"; throws_ok { try { die "foo"; } catch { my $err = shift; try { } catch { } pass("syntax ok"); die "rethrowing $err"; } pass("syntax ok"); } qr/rethrowing foo/, "rethrow with try in catch block"; sub Evil::DESTROY { eval { "oh noes" }; } sub Evil::new { bless { }, $_[0] } { local $@ = "magic"; local $_ = "other magic"; try { my $object = Evil->new; die "foo"; } catch { pass("catch invoked"); like($_, qr/foo/); } pass("syntax ok"); is( $@, "magic", '$@ untouched' ); is( $_, "other magic", '$_ untouched' ); } { my ( $caught, $prev ); { local $@; eval { die "bar\n" }; is( $@, "bar\n", 'previous value of $@' ); try { die { prev => $@, } } catch { $caught = $_; $prev = $@; } pass("syntax ok"); } is_deeply( $caught, { prev => "bar\n" }, 'previous value of $@ available for capture' ); is( $prev, "bar\n", 'previous value of $@ also available in catch block' ); } done_testing; slurpy.t100644001750000144 104712225545635 16122 0ustar00doyusers000000000000Parse-Keyword-0.08/t/fun#!/usr/bin/env perl use strict; use warnings; use Test::More; use lib 't/fun/lib'; BEGIN { if (!eval { require Sub::Name }) { plan skip_all => "This test requires Sub::Name"; } } use Fun; fun test_array ( $foo, @bar ) { return [ $foo, @bar ]; } fun test_hash ( $foo, %bar ) { return { foo => $foo, %bar }; } is_deeply( test_array( 1, 2 .. 10 ), [ 1, 2 .. 10 ], '... slurpy array worked' ); is_deeply( test_hash( 1, ( two => 2, three => 3 ) ), { foo => 1, two => 2, three => 3 }, '... slurpy hash worked' ); done_testing; syntax.t100644001750000144 132112225545635 16133 0ustar00doyusers000000000000Parse-Keyword-0.08/t/try#!/usr/bin/env perl use strict; use warnings; use Test::More; use lib 't/try/lib'; BEGIN { if (!eval { require Try::Tiny }) { plan skip_all => "This test requires Try::Tiny"; } } use Try; my $err; try { require Error1; } catch { $err = $_; } like( $err, qr/Can't call method "finallyy" without a package or object reference at |Can't locate object method "finallyy" via package "1" \(perhaps you forgot to load "1"\?\) at /, ); try { require Error2; } catch { $err = $_; } like( $err, qr/Can't call method "catch" without a package or object reference at |Can't locate object method "catch" via package "1" \(perhaps you forgot to load "1"\?\) at /, ); done_testing; 00-compile.t100644001750000144 312612225545635 15641 0ustar00doyusers000000000000Parse-Keyword-0.08/t#!perl use strict; use warnings; use Test::More; use File::Find; use File::Temp qw{ tempdir }; my @modules; find( sub { return if $File::Find::name !~ /\.pm\z/; my $found = $File::Find::name; $found =~ s{^lib/}{}; $found =~ s{[/\\]}{::}g; $found =~ s/\.pm$//; # nothing to skip push @modules, $found; }, 'lib', ); sub _find_scripts { my $dir = shift @_; my @found_scripts = (); find( sub { return unless -f; my $found = $File::Find::name; # nothing to skip open my $FH, '<', $_ or do { note( "Unable to open $found in ( $! ), skipping" ); return; }; my $shebang = <$FH>; return unless $shebang =~ /^#!.*?\bperl\b\s*$/; push @found_scripts, $found; }, $dir, ); return @found_scripts; } my @scripts; do { push @scripts, _find_scripts($_) if -d $_ } for qw{ bin script scripts }; my $plan = scalar(@modules) + scalar(@scripts); $plan ? (plan tests => $plan) : (plan skip_all => "no tests to run"); { # fake home for cpan-testers # no fake requested ## local $ENV{HOME} = tempdir( CLEANUP => 1 ); like( qx{ $^X -Ilib -e "require $_; print '$_ ok'" }, qr/^\s*$_ ok/s, "$_ loaded ok" ) for sort @modules; SKIP: { eval "use Test::Script 1.05; 1;"; skip "Test::Script needed to test script compilation", scalar(@scripts) if $@; foreach my $file ( @scripts ) { my $script = $file; $script =~ s!.*/!!; script_compiles( $file, "$script script compiles" ); } } } unavailable.t100644001750000144 133512225545635 16257 0ustar00doyusers000000000000Parse-Keyword-0.08/t#!/usr/bin/env perl use strict; use warnings; use Test::More; BEGIN { package My::Parser; use Exporter 'import'; our @EXPORT = ('foo', 'bar'); use Parse::Keyword { foo => \&parse_foo, bar => \&parse_bar, }; sub foo {} sub parse_foo { lex_read_space; die unless lex_peek eq '{'; parse_block(1)->(); return (sub {}, 1); } sub bar { $::body = $_[0] } sub parse_bar { lex_read_space; die unless lex_peek eq '{'; my $body = parse_block; return (sub { $body }, 1); } $INC{'My/Parser.pm'} = __FILE__; } use My::Parser; my $bar; my $baz = 5; foo { bar { $baz } } is($::body->(), 5); done_testing; package.t100644001750000144 51112225545635 16132 0ustar00doyusers000000000000Parse-Keyword-0.08/t/fun#!/usr/bin/env perl use strict; use warnings; use Test::More; use lib 't/fun/lib'; BEGIN { if (!eval { require Sub::Name }) { plan skip_all => "This test requires Sub::Name"; } } use Fun; fun Foo::foo ($x, $y) { $x + $y; } ok(!main->can('foo')); ok(Foo->can('foo')); is(Foo::foo(1, 2), 3); done_testing; context.t100644001750000144 177112225545635 16302 0ustar00doyusers000000000000Parse-Keyword-0.08/t/try#!/usr/bin/env perl use strict; use warnings; use Test::More; use lib 't/try/lib'; BEGIN { if (!eval { require Try::Tiny }) { plan skip_all => "This test requires Try::Tiny"; } } use Try; my $ctx_index = { VOID => undef, LIST => 1, SCALAR => '', }; my ($ctx, $die); for (sort keys %$ctx_index) { $ctx = $_; for (0,1) { $die = $_; if ($ctx_index->{$ctx}) { is_deeply( [ run() ], [ $die ? 'catch' : 'try' ], ); } elsif (defined $ctx_index->{$ctx}) { is_deeply( [ scalar run() ], [ $die ? 'catch' : 'try' ], ); } else { run(); 1; } } } sub run { try { is (wantarray, $ctx_index->{$ctx}, "Proper context $ctx in try{}"); die if $die; return 'try'; } catch { is (wantarray, $ctx_index->{$ctx}, "Proper context $ctx in catch{}"); return 'catch'; } finally { is (wantarray, undef, "Proper VOID context in finally{}"); return 'finally'; } } done_testing; finally.t100644001750000144 320012225545635 16241 0ustar00doyusers000000000000Parse-Keyword-0.08/t/try#!/usr/bin/env perl use strict; use warnings; use Test::More; use lib 't/try/lib'; BEGIN { if (!eval { require Try::Tiny }) { plan skip_all => "This test requires Try::Tiny"; } } use Try; try { my $a = 1+1; } catch { fail('Cannot go into catch block because we did not throw an exception') } finally { pass('Moved into finally from try'); } try { die('Die'); } catch { ok($_ =~ /Die/, 'Error text as expected'); pass('Into catch block as we died in try'); } finally { pass('Moved into finally from catch'); } try { die('Die'); } finally { pass('Moved into finally block when try throws an exception and we have no catch block'); } try { # do not die } finally { if (@_) { fail("errors reported: @_"); } else { pass("no error reported") ; } } try { die("Die\n"); } finally { is_deeply(\@_, [ "Die\n" ], "finally got passed the exception"); } try { try { die "foo"; } catch { die "bar"; } finally { pass("finally called"); } pass("syntax ok"); } $_ = "foo"; try { is($_, "foo", "not localized in try"); } catch { } finally { is(scalar(@_), 0, "nothing in \@_ (finally)"); is($_, "foo", "\$_ not localized (finally)"); } is($_, "foo", "same afterwards"); $_ = "foo"; try { is($_, "foo", "not localized in try"); die "bar\n"; } catch { is($_[0], "bar\n", "error in \@_ (catch)"); is($_, "bar\n", "error in \$_ (catch)"); } finally { is(scalar(@_), 1, "error in \@_ (finally)"); is($_[0], "bar\n", "error in \@_ (finally)"); is($_, "foo", "\$_ not localized (finally)"); } is($_, "foo", "same afterwards"); done_testing; inc000755001750000144 012225545635 13753 5ustar00doyusers000000000000Parse-Keyword-0.08MMHelper.pm100644001750000144 115012225545635 16117 0ustar00doyusers000000000000Parse-Keyword-0.08/incpackage inc::MMHelper; use strict; use warnings; sub makefile_pl_extra { return <<'EXTRA'; use File::Spec::Functions 'abs2rel'; use Devel::CallParser 'callparser1_h', 'callparser_linkable'; open my $fh, '>', 'callparser1.h' or die "Couldn't write to callparser1.h"; $fh->print(callparser1_h); my @linkable = map { abs2rel($_) } callparser_linkable; unshift @linkable, '$(BASEEXT)$(OBJ_EXT)' if @linkable; $WriteMakefileArgs{OBJECT} = join(' ', @linkable) if @linkable; EXTRA } sub mm_args { return { NORECURS => 1, clean => { FILES => "callparser1.h", } }; } 1; keyword-name.t100644001750000144 61512225545635 16356 0ustar00doyusers000000000000Parse-Keyword-0.08/t#!/usr/bin/env perl use strict; use warnings; use Test::More; BEGIN { package My::Parser; use Exporter 'import'; our @EXPORT = 'foo'; use Parse::Keyword { foo => \&parse_foo }; sub foo { $_[0] } sub parse_foo { my ($keyword) = @_; return sub { uc($keyword) }; } $INC{'My/Parser.pm'} = __FILE__; } use My::Parser; is(foo, 'FOO'); done_testing; scope-inject.t100644001750000144 200712225545635 16354 0ustar00doyusers000000000000Parse-Keyword-0.08/t#!/usr/bin/env perl use strict; use warnings; use Test::More; BEGIN { if (!eval { require B::Hooks::EndOfScope }) { plan skip_all => "B::Hooks::EndOfScope is required for this test"; } } BEGIN { package My::Parser; use Exporter 'import'; our @EXPORT = 'foo'; use Parse::Keyword { foo => \&parse_foo }; sub foo { $_[0]->() } sub parse_foo { lex_read_space; die "syntax error" unless lex_peek eq '{'; lex_read; lex_stuff( '{' . 'my $foo = 42;' . '{' . 'BEGIN { B::Hooks::EndOfScope::on_scope_end {' . 'Parse::Keyword::lex_stuff(q[}])' . '} }' ); my $body = parse_block; return sub { $body }; } $INC{'My/Parser.pm'} = __FILE__; } use My::Parser; is(foo { $foo }, 42); { my $warnings; local $SIG{__WARN__} = sub { $warnings .= $_[0] }; is(foo { my $foo = 12; $foo }, 12); is($warnings, undef); } done_testing; defaults.t100644001750000144 245512225545635 16377 0ustar00doyusers000000000000Parse-Keyword-0.08/t/fun#!/usr/bin/env perl use strict; use warnings; use Test::More; use lib 't/fun/lib'; BEGIN { if (!eval { require Sub::Name }) { plan skip_all => "This test requires Sub::Name"; } } use Fun; fun foo ($x, $y = 5) { return $x + $y; } is(foo(3, 4), 7); is(foo(3), 8); { my $warning; local $SIG{__WARN__} = sub { $warning = $_[0] }; is(foo, 5); like($warning, qr/Use of uninitialized value \$x in addition \(\+\)/); } fun bar ($baz, $quux = foo(1) * 2, $blorg = sub { return "ran sub, got " . $_[0] }) { $blorg->($baz + $quux); } is(bar(3, 4, sub { $_[0] }), 7); is(bar(5, 6), "ran sub, got 11"); is(bar(7), "ran sub, got 19"); { my $warning; local $SIG{__WARN__} = sub { $warning = $_[0] }; is(bar, "ran sub, got 12"); like($warning, qr/Use of uninitialized value \$baz in addition \(\+\)/); } fun baz ($a, $b = our $FOO) { return "$a $b"; } { no warnings 'misc'; # 'not imported' warning because we use $FOO later eval '$FOO'; like($@, qr/Global symbol "\$FOO" requires explicit package name/, "doesn't leak scope"); } our $FOO = "abc"; is(baz("123"), "123 abc"); fun goorch ($x, $y = []) { return $y } my $goorch_y_1 = goorch( 10 ); my $goorch_y_2 = goorch( 10 ); isnt($goorch_y_1, $goorch_y_2, '... not the same reference'); done_testing; lib000755001750000144 012225545635 15003 5ustar00doyusers000000000000Parse-Keyword-0.08/t/funFun.pm100644001750000144 652612225545635 16242 0ustar00doyusers000000000000Parse-Keyword-0.08/t/fun/libpackage Fun; use strict; use warnings; use Parse::Keyword { fun => \&fun_parser }; use Sub::Name 'subname'; use Exporter 'import'; our @EXPORT = 'fun'; # XXX this isn't quite right, i think, but probably close enough for now? my $start_rx = qr/^[\p{ID_Start}_]$/; my $cont_rx = qr/^\p{ID_Continue}$/; sub fun { @_ ? $_[0] : () } sub fun_parser { my ($name, $prototype, $body); lex_read_space; if (lex_peek =~ /$start_rx|^:$/) { $name = parse_name(1); } lex_read_space; if (lex_peek eq '(') { $prototype = parse_prototype(); } lex_read_space; if (lex_peek eq '{') { local $Fun::{'DEFAULTS::'}; if ($prototype) { lex_read; my $preamble = '{'; my @names = map { $_->{name} } @$prototype; $preamble .= 'my (' . join(', ', @names) . ') = @_;'; my $index = 1; for my $var (grep { defined $_->{default} } @$prototype) { { no strict 'refs'; *{ 'Fun::DEFAULTS::default_' . $index } = sub () { $var->{default} }; } $preamble .= $var->{name} . ' = Fun::DEFAULTS::default_' . $index . '->()' . ' unless @_ > ' . $var->{index} . ';'; $index++; } lex_stuff($preamble); } $body = parse_block; } else { die "syntax error"; } if (defined $name) { my $full_name = join('::', compiling_package, $name); { no strict 'refs'; *$full_name = subname $full_name, $body; } return (sub {}, 1); } else { return (sub { $body }, 0); } } sub parse_name { my ($allow_package) = @_; my $name = ''; my $char_rx = $start_rx; while (1) { my $char = lex_peek; last unless length $char; if ($char =~ $char_rx) { $name .= $char; lex_read; $char_rx = $cont_rx; } elsif ($allow_package && $char eq ':') { die "syntax error" unless lex_peek(3) =~ /^::(?:[^:]|$)/; $name .= '::'; lex_read(2); } else { last; } } return length($name) ? $name : undef; } sub parse_prototype { die "syntax error" unless lex_peek eq '('; lex_read; lex_read_space; if (lex_peek eq ')') { lex_read; return; } my $seen_slurpy; my @vars; while ((my $sigil = lex_peek) ne ')') { my $var = {}; die "syntax error" unless $sigil eq '$' || $sigil eq '@' || $sigil eq '%'; die "Can't declare parameters after a slurpy parameter" if $seen_slurpy; $seen_slurpy = 1 if $sigil eq '@' || $sigil eq '%'; lex_read; lex_read_space; my $name = parse_name(0); lex_read_space; $var->{name} = "$sigil$name"; if (lex_peek eq '=') { lex_read; lex_read_space; $var->{default} = parse_arithexpr; } $var->{index} = @vars; push @vars, $var; die "syntax error" unless lex_peek eq ')' || lex_peek eq ','; if (lex_peek eq ',') { lex_read; lex_read_space; } } lex_read; return \@vars; } 1; lib000755001750000144 012225545635 15031 5ustar00doyusers000000000000Parse-Keyword-0.08/t/tryTry.pm100644001750000144 166512225545635 16315 0ustar00doyusers000000000000Parse-Keyword-0.08/t/try/libpackage Try; use strict; use warnings; use Try::Tiny (); use Parse::Keyword { try => \&try_parser }; use Exporter 'import'; our @EXPORT = ('try'); sub try { my ($try, $catch, $finally) = @_; &Try::Tiny::try( $try, ($catch ? (&Try::Tiny::catch($catch)) : ()), ($finally ? (&Try::Tiny::finally($finally)) : ()), ); } sub try_parser { my ($try, $catch, $finally); lex_read_space; die "syntax error" unless lex_peek eq '{'; $try = parse_block; lex_read_space; if (lex_peek(6) =~ /^catch\b/) { lex_read(5); lex_read_space; die "syntax error" unless lex_peek eq '{'; $catch = parse_block; } lex_read_space; if (lex_peek(8) =~ /^finally\b/) { lex_read(7); lex_read_space; die "syntax error" unless lex_peek eq '{'; $finally = parse_block; } return (sub { ($try, $catch, $finally) }, 1); } 1; MakeMaker.pm100644001750000144 116512225545635 16311 0ustar00doyusers000000000000Parse-Keyword-0.08/incpackage inc::MakeMaker; use Moose; use inc::MMHelper; extends 'Dist::Zilla::Plugin::MakeMaker::Awesome'; around _build_MakeFile_PL_template => sub { my $orig = shift; my $self = shift; my $tmpl = $self->$orig; my $extra = inc::MMHelper::makefile_pl_extra; $tmpl =~ s/^(WriteMakefile\()/$extra\n$1/m or die "Couldn't fix template"; return $tmpl; }; around _build_WriteMakefile_args => sub { my $orig = shift; my $self = shift; my $args = $self->$orig(@_); return { %$args, %{ inc::MMHelper::mm_args() }, } }; __PACKAGE__->meta->make_immutable; no Moose; 1; release000755001750000144 012225545635 15255 5ustar00doyusers000000000000Parse-Keyword-0.08/xteol.t100644001750000144 24012225545635 16335 0ustar00doyusers000000000000Parse-Keyword-0.08/xt/releaseuse strict; use warnings; use Test::More; eval 'use Test::EOL'; plan skip_all => 'Test::EOL required' if $@; all_perl_files_ok({ trailing_whitespace => 1 }); recursion.t100644001750000144 117612225545635 16600 0ustar00doyusers000000000000Parse-Keyword-0.08/t/fun#!/usr/bin/env perl use strict; use warnings; use Test::More; use lib 't/fun/lib'; BEGIN { if (!eval { require Sub::Name }) { plan skip_all => "This test requires Sub::Name"; } } BEGIN { if (!eval { require 5.016; 1 }) { plan skip_all => "This test requires 5.16"; } } use 5.016; use Fun; fun fact ($n) { if ($n < 2) { return 1; } return $n * __SUB__->($n - 1); } is(fact(5), 120); is(fun ($n = 8) { $n < 2 ? 1 : $n * __SUB__->($n - 1) }->(), 40320); fun fact2 ($n) { if ($n < 2) { return 1; } return $n * fact2($n - 1); } is(fact2(5), 120); done_testing; My000755001750000144 012225545635 14600 5ustar00doyusers000000000000Parse-Keyword-0.08/t/libParser.pm100644001750000144 66512225545635 16521 0ustar00doyusers000000000000Parse-Keyword-0.08/t/lib/Mypackage My::Parser; use Exporter 'import'; our @EXPORT = ('foo', 'bar'); use Parse::Keyword { foo => \&parse_foo, bar => \&parse_bar, }; our $got_code; sub foo { 1 } sub parse_foo { lex_read_space; my $code = parse_block; $got_code = $code ? 1 : 0; return sub {}; } sub bar { 1 } sub parse_bar { lex_read_space; my $code = eval { parse_block }; $got_code = $code ? 1 : 0; return sub {}; } 1; given_when.t100644001750000144 125112225545635 16740 0ustar00doyusers000000000000Parse-Keyword-0.08/t/try#!/usr/bin/env perl use strict; use warnings; use Test::More; use lib 't/try/lib'; use 5.014; BEGIN { if (!eval { require Try::Tiny }) { plan skip_all => "This test requires Try::Tiny"; } } no if $] >= 5.018, warnings => 'experimental::smartmatch'; use Try; my ( $error, $topic ); given ("foo") { when (qr/./) { try { die "blah\n"; } catch { $topic = $_; $error = $_[0]; } pass("syntax ok"); }; } is( $error, "blah\n", "error caught" ); { local $TODO = "perhaps a workaround can be found" if $] < 5.018; is( $topic, $error, 'error is also in $_' ); } done_testing; Error2.pm100644001750000144 12712225545635 16662 0ustar00doyusers000000000000Parse-Keyword-0.08/t/try/libpackage Error2; use strict; use warnings; use Try; try { } finally { } catch { } 1; Error1.pm100644001750000144 13012225545635 16653 0ustar00doyusers000000000000Parse-Keyword-0.08/t/try/libpackage Error1; use strict; use warnings; use Try; try { } catch { } finallyy { } 1; Parse000755001750000144 012225545635 15022 5ustar00doyusers000000000000Parse-Keyword-0.08/libKeyword.pm100644001750000144 1776312225545635 17202 0ustar00doyusers000000000000Parse-Keyword-0.08/lib/Parsepackage Parse::Keyword; BEGIN { $Parse::Keyword::AUTHORITY = 'cpan:DOY'; } { $Parse::Keyword::VERSION = '0.08'; } use strict; use warnings; use 5.014; # ABSTRACT: DEPRECATED: write syntax extensions in perl use Devel::CallParser; use XSLoader; XSLoader::load( __PACKAGE__, exists $Parse::Keyword::{VERSION} ? ${ $Parse::Keyword::{VERSION} } : (), ); sub import { my $package = shift; my ($keywords) = @_; my $caller = caller; for my $keyword (keys %$keywords) { my $sub = do { no strict 'refs'; \&{ $caller . '::' . $keyword }; }; install_keyword_handler($sub, $keywords->{$keyword}); } my @helpers = qw( lex_peek lex_read lex_read_space lex_stuff parse_block parse_stmtseq parse_fullstmt parse_barestmt parse_fullexpr parse_listexpr parse_termexpr parse_arithexpr compiling_package ); for my $helper (@helpers) { no strict 'refs'; *{ $caller . '::' . $helper } = \&{ __PACKAGE__ . '::' . $helper }; } } 1; __END__ =pod =head1 NAME Parse::Keyword - DEPRECATED: write syntax extensions in perl =head1 VERSION version 0.08 =head1 SYNOPSIS use Parse::Keyword { try => \&try_parser }; use Exporter 'import'; our @EXPORT = 'try'; sub try { my ($try, $catch) = @_; &Try::Tiny::try($try, ($catch ? (&Try::Tiny::catch($catch)) : ())); } sub try_parser { lex_read_space; die "syntax error" unless lex_peek eq '{'; my $try = parse_block; lex_read_space; my $catch; if (lex_peek(6) =~ /^catch\b/) { lex_read(5); lex_read_space; die "syntax error" unless lex_peek eq '{'; $catch = parse_block; } return (sub { ($try, $catch) }, 1); } =head1 DESCRIPTION =head2 DO NOT USE! This module has fundamental errors in the way it handles closures, which are not fixable. Runtime keywords will never be able to work properly with the current design of this module. There are certain cases where this module is still safe to use (keywords that only have effect at compile time, or keywords that never call any of the C functions), but that is limiting enough to make this module mostly worthless, and I likely won't be continuing to maintain it. Be warned! B<< NOTE: The API of this module is still in flux. I may make backwards-incompatible changes as I figure out how it should look. >> This module allows you to write keyword-based syntax extensions without requiring you to write any C code yourself. It is similar to L, except that it uses the Perl parser API introduced in Perl 5.14 in order to allow you to parse parts of things using perl's own parser, rather than having to fake it with balanced brace matching or other fragile things. To use this module, you should pass a hashref to the C statement. The keys of this hashref are subroutines in the current package which should have special parsing behavior attached to them, and the values are coderefs which should be used to implement the custom parsing behavior. The parsing coderefs will be called when perl encounters a call to the keyword that you attached custom parsing to. The current parser state will be directly after parsing the keyword. The parser function will receive the name of the keyword as a parameter, and should return a coderef which, when called at runtime, will produce the arguments to the function. In addition, if your keyword should be parsed as a statement (for instance, if you don't want to require a trailing semicolon), you can return a second, true value. In order to actually handle the parsing itself, this module also exports various parsing functions, which you can call. See below for details. =head1 FUNCTIONS =head2 lex_peek($n) Returns a string consisting of the next C<$n> characters in the input (or next one character, if C<$n> isn't given). This string may be shorter than C<$n> characters if there are fewer than C<$n> characters remaining to read. The current position in the buffer to be parsed is not moved. See L<< perlapi/PL_parser->linestr >> and L for more information. NOTE: This function currently only returns text that is on the current line, unless the current line has been fully read (via C). This is due to a bug in perl itself, and this restriction will hopefully be lifted in a future version of this module, so don't depend on it. See the L section for more information. =head2 lex_read($n) Moves the current position in the parsing buffer forward by C<$n> characters (or one character, if C<$n> isn't given). See L for more details. =head2 lex_read_space Moves the current position in the parsing buffer forward past any whitespace or comments. See L for more details. =head2 lex_stuff($str) Inserts C<$str> into the current parsing buffer at the current location, so that future calls to C and such will see it. Note that this does not move the current position in the parsing buffer, so multiple calls to C at the same location will end up inserted into the buffer in reverse order. See L for more information. =head2 parse_block, parse_stmtseq, parse_fullstmt, parse_barestmt, parse_fullexpr, parse_listexpr, parse_termexpr, parse_arithexpr These functions parse the specified amount of Perl code, and return a coderef which will evaluate that code when executed. They each take an optional boolean parameter that should be true if you are creating a subroutine which will be going in the symbol table, or in other more obscure situations involving closures (the CVf_ANON flag will be set on the created coderef if this is not passed - see C in this distribution). See L, L, L, L, L, L, L, and L for more details. =head2 compiling_package Returns the name of the package that the keyword which is currently being parsed was called in. This should be used instead of C if you want to do something like install a subroutine in the calling package. =head1 BUGS Peeking into the next line is currently (as of 5.19.2) broken in perl if the current line hasn't been fully consumed. This module works around this by just not doing that. This shouldn't be an issue for the most part, since it will only come up if you need to conditionally parse something based on a token that can span multiple lines. Just keep in mind that if you're reading in a large chunk of text, you'll need to alternate between calling C and C, or else you'll only be able to see text on the current line. This module also inherits the limitation from L that custom parsing is only triggered if the keyword is called by its unqualified name (C, not C, for instance). This module doesn't yet work with lexical subs, such as via L. This will hopefully be fixed in the future, but will likely require modifications to perl. Please report any bugs to GitHub Issues at L. =head1 SEE ALSO L L L =head1 SUPPORT You can find this documentation for this module with the perldoc command. perldoc Parse::Keyword You can also look for information at: =over 4 =item * MetaCPAN L =item * RT: CPAN's request tracker L =item * Github L =item * CPAN Ratings L =back =for Pod::Coverage install_keyword_handler =head1 AUTHOR Jesse Luehrs =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2013 by Jesse Luehrs. This is free software, licensed under: The MIT (X11) License =cut compile-time.t100644001750000144 40312225545635 17123 0ustar00doyusers000000000000Parse-Keyword-0.08/t/fun#!/usr/bin/env perl use strict; use warnings; use Test::More; use lib 't/fun/lib'; BEGIN { if (!eval { require Sub::Name }) { plan skip_all => "This test requires Sub::Name"; } } use Fun; is(foo(), "FOO"); fun foo { "FOO" } done_testing; no-tabs.t100644001750000144 21212225545635 17120 0ustar00doyusers000000000000Parse-Keyword-0.08/xt/releaseuse strict; use warnings; use Test::More; eval 'use Test::NoTabs'; plan skip_all => 'Test::NoTabs required' if $@; all_perl_files_ok(); closure-proto.t100644001750000144 45612225545635 17364 0ustar00doyusers000000000000Parse-Keyword-0.08/t/fun#!/usr/bin/env perl use strict; use warnings; use Test::More; use lib 't/fun/lib'; BEGIN { if (!eval { require Sub::Name }) { plan skip_all => "This test requires Sub::Name"; } } use Fun; { my $x = 10; fun bar ($y) { $x * $y } } is(bar(3), 30); done_testing; pod-syntax.t100644001750000144 21212225545635 17663 0ustar00doyusers000000000000Parse-Keyword-0.08/xt/release#!perl use Test::More; eval "use Test::Pod 1.41"; plan skip_all => "Test::Pod 1.41 required for testing POD" if $@; all_pod_files_ok(); pod-coverage.t100644001750000144 52712225545635 20141 0ustar00doyusers000000000000Parse-Keyword-0.08/xt/release#!perl use Test::More; eval "use Test::Pod::Coverage 1.08"; plan skip_all => "Test::Pod::Coverage 1.08 required for testing POD coverage" if $@; eval "use Pod::Coverage::TrustPod"; plan skip_all => "Pod::Coverage::TrustPod required for testing POD coverage" if $@; all_pod_coverage_ok({ coverage_class => 'Pod::Coverage::TrustPod' }); slurpy-syntax-errors.t100644001750000144 107112225545635 20755 0ustar00doyusers000000000000Parse-Keyword-0.08/t/fun#!/usr/bin/env perl use strict; use warnings; use Test::More; use lib 't/fun/lib'; BEGIN { if (!eval { require Sub::Name }) { plan skip_all => "This test requires Sub::Name"; } } use Fun; { eval 'fun ( $foo, @bar, $baz ) { return [] }'; ok $@, '... got an error'; } { eval 'fun ( $foo, %bar, $baz ) { return {} }'; ok $@, '... got an error'; } { eval 'fun ( $foo, @bar, %baz ) { return [] }'; ok $@, '... got an error'; } { eval 'fun ( $foo, %bar, @baz ) { return {} }'; ok $@, '... got an error'; } done_testing;