Keyword-Simple-0.03/0000755000175000017500000000000012420743013013271 5ustar maukemaukeKeyword-Simple-0.03/README0000644000175000017500000000174312420742032014156 0ustar maukemaukeKeyword-Simple define new keywords in pure Perl INSTALLATION To install this module, run the following commands: perl Makefile.PL make make test make install SUPPORT AND DOCUMENTATION After installing, you can find documentation for this module with the perldoc command. perldoc Keyword::Simple You can also look for information at: RT, CPAN's request tracker http://rt.cpan.org/NoAuth/Bugs.html?Dist=Keyword-Simple AnnoCPAN, Annotated CPAN documentation http://annocpan.org/dist/Keyword-Simple CPAN Ratings http://cpanratings.perl.org/d/Keyword-Simple MetaCPAN https://metacpan.org/module/Keyword::Simple COPYRIGHT AND LICENCE Copyright (C) 2012, 2013 Lukas Mai This program is free software; you can redistribute it and/or modify it under the terms of either: the GNU General Public License as published by the Free Software Foundation; or the Artistic License. See http://dev.perl.org/licenses/ for more information. Keyword-Simple-0.03/Changes0000644000175000017500000000043012420742736014574 0ustar maukemaukeRevision history for Keyword-Simple 0.03 2014-10-19 - Add note to POD about requiring perl v5.12. 0.02 2013-09-27 - Fix line number bug (line numbers off by one after keyword). 0.01 2012-12-02 First version, released on an unsuspecting world. Keyword-Simple-0.03/lib/0000755000175000017500000000000012420743013014037 5ustar maukemaukeKeyword-Simple-0.03/lib/Keyword/0000755000175000017500000000000012420743013015463 5ustar maukemaukeKeyword-Simple-0.03/lib/Keyword/Simple.pm0000644000175000017500000000664112420742666017276 0ustar maukemaukepackage Keyword::Simple; use v5.12.0; use warnings; use Carp qw(croak); use B::Hooks::EndOfScope; use XSLoader; BEGIN { our $VERSION = '0.03'; XSLoader::load __PACKAGE__, $VERSION; } # all shall burn our @meta; sub define { my ($kw, $sub) = @_; $kw =~ /^\p{XIDS}\p{XIDC}*\z/ or croak "'$kw' doesn't look like an identifier"; ref($sub) eq 'CODE' or croak "'$sub' doesn't look like a coderef"; my $n = @meta; push @meta, $sub; $^H{+HINTK_KEYWORDS} .= " $kw:$n"; on_scope_end { delete $meta[$n]; }; } sub undefine { my ($kw) = @_; $kw =~ /^\p{XIDS}\p{XIDC}*\z/ or croak "'$kw' doesn't look like an identifier"; $^H{+HINTK_KEYWORDS} .= " $kw:-"; } 'ok' __END__ =encoding UTF-8 =head1 NAME Keyword::Simple - define new keywords in pure Perl =head1 SYNOPSIS package Some::Module; use Keyword::Simple; sub import { # create keyword 'provided', expand it to 'if' at parse time Keyword::Simple::define 'provided', sub { my ($ref) = @_; substr($$ref, 0, 0) = 'if'; # inject 'if' at beginning of parse buffer }; } sub unimport { # lexically disable keyword again Keyword::Simple::undefine 'provided'; } 'ok' =head1 DESCRIPTION Warning: This module is still new and experimental. The API may change in future versions. The code may be buggy. This module lets you implement new keywords in pure Perl. To do this, you need to write a module and call L|/Keyword::Simple::define> in your C method. Any keywords defined this way will be available in the lexical scope that's currently being compiled. =head2 Functions =over =item C Takes two arguments, the name of a keyword and a coderef. Injects the keyword in the lexical scope currently being compiled. For every occurrence of the keyword, your coderef will be called with one argument: A reference to a scalar holding the rest of the source code (following the keyword). You can modify this scalar in any way you like and after your coderef returns, perl will continue parsing from that scalar as if its contents had been the real source code in the first place. =item C Takes one argument, the name of a keyword. Disables that keyword in the lexical scope that's currently being compiled. You can call this from your C method to make the C syntax work. =back =head1 BUGS AND LIMITATIONS This module depends on the L API introduced in perl 5.12. Older versions of perl are not supported. Every new keyword is actually a complete statement by itself. The parsing magic only happens afterwards. This means that e.g. the code in the L actually does this: provided ($foo > 2) { ... } # expands to ; if ($foo > 2) { ... } The C<;> represents a no-op statement, the C was injected by the Perl code, and the rest of the file is unchanged. This also means your new keywords can only occur at the beginning of a statement, not embedded in an expression. There are barely any tests. =head1 AUTHOR Lukas Mai, C<< >> =head1 COPYRIGHT & LICENSE Copyright 2012, 2013 Lukas Mai. This program is free software; you can redistribute it and/or modify it under the terms of either: the GNU General Public License as published by the Free Software Foundation; or the Artistic License. See http://dev.perl.org/licenses/ for more information. =cut Keyword-Simple-0.03/Simple.xs0000644000175000017500000001046112420742032015100 0ustar maukemauke/* Copyright 2012, 2013 Lukas Mai. This program is free software; you can redistribute it and/or modify it under the terms of either: the GNU General Public License as published by the Free Software Foundation; or the Artistic License. See http://dev.perl.org/licenses/ for more information. */ #ifdef __GNUC__ #if (__GNUC__ == 4 && __GNUC_MINOR__ >= 6) || __GNUC__ >= 5 #define PRAGMA_GCC_(X) _Pragma(#X) #define PRAGMA_GCC(X) PRAGMA_GCC_(GCC X) #endif #endif #ifndef PRAGMA_GCC #define PRAGMA_GCC(X) #endif #ifdef DEVEL #define WARNINGS_RESET PRAGMA_GCC(diagnostic pop) #define WARNINGS_ENABLEW(X) PRAGMA_GCC(diagnostic warning #X) #define WARNINGS_ENABLE \ WARNINGS_ENABLEW(-Wall) \ WARNINGS_ENABLEW(-Wextra) \ WARNINGS_ENABLEW(-Wundef) \ /* WARNINGS_ENABLEW(-Wshadow) :-( */ \ WARNINGS_ENABLEW(-Wbad-function-cast) \ WARNINGS_ENABLEW(-Wcast-align) \ WARNINGS_ENABLEW(-Wwrite-strings) \ /* WARNINGS_ENABLEW(-Wnested-externs) wtf? */ \ WARNINGS_ENABLEW(-Wstrict-prototypes) \ WARNINGS_ENABLEW(-Wmissing-prototypes) \ WARNINGS_ENABLEW(-Winline) \ WARNINGS_ENABLEW(-Wdisabled-optimization) #else #define WARNINGS_RESET #define WARNINGS_ENABLE #endif #define PERL_NO_GET_CONTEXT #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include #include #include WARNINGS_ENABLE #define HAVE_PERL_VERSION(R, V, S) \ (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S)))))) #define MY_PKG "Keyword::Simple" #define HINTK_KEYWORDS MY_PKG "/keywords" #ifndef PL_rsfp_filters #define PL_rsfp_filters (PL_parser->rsfp_filters) #endif static int (*next_keyword_plugin)(pTHX_ char *, STRLEN, OP **); static long kw_index(pTHX_ const char *kw_ptr, STRLEN kw_len) { HV *hints; SV *sv, **psv; char *p, *pv; STRLEN pv_len; if (!(hints = GvHV(PL_hintgv))) { return -1; } if (!(psv = hv_fetchs(hints, HINTK_KEYWORDS, 0))) { return -1; } sv = *psv; pv = SvPV(sv, pv_len); if (pv_len < 4 || pv_len - 2 <= kw_len) { return -1; } for ( p = pv; (p = strchr(p + 1, *kw_ptr)) && p < pv + pv_len - 1 - kw_len; ) { if ( p[-1] == ' ' && p[kw_len] == ':' && memcmp(kw_ptr, p, kw_len) == 0 ) { if (p[kw_len + 1] == '-') { return -1; } assert(p[kw_len + 1] >= '0' && p[kw_len + 1] <= '9'); return strtol(p + kw_len + 1, NULL, 10); } } return -1; } static I32 playback(pTHX_ int idx, SV *buf, int n) { char *ptr; STRLEN len, d; SV *sv = FILTER_DATA(idx); ptr = SvPV(sv, len); if (!len) { return 0; } if (!n) { char *nl = memchr(ptr, '\n', len); d = nl ? (STRLEN)(nl - ptr + 1) : len; } else { d = n < 0 ? INT_MAX : n; if (d > len) { d = len; } } sv_catpvn(buf, ptr, d); sv_chop(sv, ptr + d); return 1; } static void total_recall(pTHX_ I32 n) { SV *sv, *cb; AV *meta; dSP; ENTER; SAVETMPS; meta = get_av(MY_PKG "::meta", GV_ADD); cb = *av_fetch(meta, n, 0); sv = sv_2mortal(newSVpvs("")); if (lex_bufutf8()) { SvUTF8_on(sv); } /* sluuuuuurrrrp */ sv_setpvn(sv, PL_parser->bufptr, PL_parser->bufend - PL_parser->bufptr); lex_unstuff(PL_parser->bufend); /* you saw nothing */ if (!PL_rsfp_filters) { /* because FILTER_READ fails with filters=null but DTRT with filters=[] */ PL_rsfp_filters = newAV(); } while (FILTER_READ(0, sv, 4096) > 0) ; PUSHMARK(SP); mXPUSHs(newRV_inc(sv)); PUTBACK; call_sv(cb, G_VOID); SPAGAIN; { /* $sv .= "\n" */ char *p; STRLEN n; SvPV_force(sv, n); p = SvGROW(sv, n + 2); p[n] = '\n'; p[n + 1] = '\0'; SvCUR_set(sv, n + 1); } filter_add(playback, SvREFCNT_inc_simple_NN(sv)); CopLINE_dec(PL_curcop); PUTBACK; FREETMPS; LEAVE; } static int my_keyword_plugin(pTHX_ char *keyword_ptr, STRLEN keyword_len, OP **op_ptr) { long n; if ((n = kw_index(aTHX_ keyword_ptr, keyword_len)) >= 0) { total_recall(aTHX_ n); *op_ptr = newOP(OP_NULL, 0); return KEYWORD_PLUGIN_STMT; } return next_keyword_plugin(aTHX_ keyword_ptr, keyword_len, op_ptr); } WARNINGS_RESET MODULE = Keyword::Simple PACKAGE = Keyword::Simple PROTOTYPES: ENABLE BOOT: WARNINGS_ENABLE { HV *const stash = gv_stashpvs(MY_PKG, GV_ADD); /**/ newCONSTSUB(stash, "HINTK_KEYWORDS", newSVpvs(HINTK_KEYWORDS)); /**/ next_keyword_plugin = PL_keyword_plugin; PL_keyword_plugin = my_keyword_plugin; } WARNINGS_RESET Keyword-Simple-0.03/META.yml0000644000175000017500000000125712420743013014547 0ustar maukemauke--- abstract: 'define new keywords in pure Perl' author: - 'Lukas Mai ' build_requires: Dir::Self: '0' Test::More: '0' strict: '0' configure_requires: ExtUtils::MakeMaker: '6.48' strict: '0' warnings: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 6.98, CPAN::Meta::Converter version 2.140640' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Keyword-Simple no_index: directory: - t - inc requires: B::Hooks::EndOfScope: '0' Carp: '0' XSLoader: '0' perl: '5.012000' warnings: '0' resources: repository: git://github.com/mauke/Keyword-Simple version: '0.03' Keyword-Simple-0.03/META.json0000644000175000017500000000252312420743013014714 0ustar maukemauke{ "abstract" : "define new keywords in pure Perl", "author" : [ "Lukas Mai " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 6.98, CPAN::Meta::Converter version 2.140640", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Keyword-Simple", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : {} }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "6.48", "strict" : "0", "warnings" : "0" } }, "runtime" : { "requires" : { "B::Hooks::EndOfScope" : "0", "Carp" : "0", "XSLoader" : "0", "perl" : "5.012000", "warnings" : "0" } }, "test" : { "requires" : { "Dir::Self" : "0", "Test::More" : "0", "strict" : "0" } } }, "release_status" : "stable", "resources" : { "repository" : { "type" : "git", "url" : "git://github.com/mauke/Keyword-Simple", "web" : "https://github.com/mauke/Keyword-Simple" } }, "version" : "0.03" } Keyword-Simple-0.03/Makefile.PL0000644000175000017500000000331412420742032015244 0ustar maukemaukeuse strict; use warnings; use ExtUtils::MakeMaker; sub merge_key_into { my ($href, $target, $source) = @_; %{$href->{$target}} = (%{$href->{$target}}, %{delete $href->{$source}}); } my %opt = ( NAME => 'Keyword::Simple', AUTHOR => q{Lukas Mai }, VERSION_FROM => 'lib/Keyword/Simple.pm', ABSTRACT_FROM => 'lib/Keyword/Simple.pm', LICENSE => 'perl', PL_FILES => {}, MIN_PERL_VERSION => '5.12.0', CONFIGURE_REQUIRES => { 'strict' => 0, 'warnings' => 0, 'ExtUtils::MakeMaker' => '6.48', }, BUILD_REQUIRES => {}, TEST_REQUIRES => { 'strict' => 0, 'Dir::Self' => 0, 'Test::More' => 0, }, PREREQ_PM => { 'Carp' => 0, 'XSLoader' => 0, 'warnings' => 0, 'B::Hooks::EndOfScope' => 0, }, depend => { Makefile => '$(VERSION_FROM)' }, dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', }, clean => { FILES => 'Keyword-Simple-*' }, META_MERGE => { 'meta-spec' => { version => 2 }, resources => { repository => { url => 'git://github.com/mauke/Keyword-Simple', web => 'https://github.com/mauke/Keyword-Simple', type => 'git', }, }, }, ); (my $mm_version = ExtUtils::MakeMaker->VERSION($opt{CONFIGURE_REQUIRES}{'ExtUtils::MakeMaker'})) =~ tr/_//d; if ($mm_version < 6.67_04) { # Why? For the glory of satan, of course! no warnings qw(redefine); *ExtUtils::MM_Any::_add_requirements_to_meta_v1_4 = \&ExtUtils::MM_Any::_add_requirements_to_meta_v2; } if ($mm_version < 6.63_03) { merge_key_into \%opt, 'BUILD_REQUIRES', 'TEST_REQUIRES'; } if ($mm_version < 6.55_01) { merge_key_into \%opt, 'CONFIGURE_REQUIRES', 'BUILD_REQUIRES'; } if ($mm_version < 6.51_03) { merge_key_into \%opt, 'PREREQ_PM', 'CONFIGURE_REQUIRES'; } WriteMakefile %opt; Keyword-Simple-0.03/MANIFEST0000644000175000017500000000044312420743013014423 0ustar maukemaukeChanges MANIFEST MANIFEST.SKIP Makefile.PL README Simple.xs lib/Keyword/Simple.pm t/00-load.t t/basic.t t/lineno.t t/pod.t META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) Keyword-Simple-0.03/t/0000755000175000017500000000000012420743013013534 5ustar maukemaukeKeyword-Simple-0.03/t/00-load.t0000644000175000017500000000026212420742032015055 0ustar maukemauke#!perl use Test::More tests => 1; BEGIN { use_ok( 'Keyword::Simple' ) || print "Bail out!\n"; } diag( "Testing Keyword::Simple $Keyword::Simple::VERSION, Perl $], $^X" ); Keyword-Simple-0.03/t/lineno.t0000644000175000017500000000106612420742032015210 0ustar maukemauke#!perl use strict; use warnings FATAL => 'all'; use Test::More tests => 6; BEGIN { package Some::Module; use Keyword::Simple; sub import { Keyword::Simple::define 'provided', sub { my ($ref) = @_; substr($$ref, 0, 0) = 'if'; }; } sub unimport { Keyword::Simple::undefine 'provided'; } $INC{'Some/Module.pm'} = __FILE__; }; use Some::Module; provided (1) { is(__LINE__, 25); } #line 1 provided(1){is __LINE__, 1;} is __LINE__, 2; provided #line 1 (1) { is __LINE__, 1; } is __LINE__, 2; provided (2) { provided (3) { is __LINE__, 5; } } Keyword-Simple-0.03/t/basic.t0000644000175000017500000000055012420742032015002 0ustar maukemauke#!perl use warnings FATAL => 'all'; use strict; use Test::More tests => 2; { package Foo; use Keyword::Simple; sub import { Keyword::Simple::define peek => sub { substr ${$_[0]}, 0, 0, "ok 1, 'synthetic test';"; }; } sub unimport { Keyword::Simple::undefine 'peek'; } BEGIN { $INC{"Foo.pm"} = 1; } } use Foo; peek ok 1, "natural test"; Keyword-Simple-0.03/t/pod.t0000644000175000017500000000047612420742032014512 0ustar maukemauke#!perl use strict; use warnings; use Test::More; plan skip_all => "set RELEASE_TESTING=1 to run this test" unless $ENV{RELEASE_TESTING}; # Ensure a recent version of Test::Pod my $min_tp = 1.22; eval "use Test::Pod $min_tp"; plan skip_all => "Test::Pod $min_tp required for testing POD" if $@; all_pod_files_ok(); Keyword-Simple-0.03/MANIFEST.SKIP0000644000175000017500000000030112420742032015161 0ustar maukemauke\.tar\.gz$ ^Build$ ^Keyword-Simple- ^GNUmakefile$ ^MANIFEST\.(?!SKIP$) ^MYMETA\. ^Makefile$ ^Makefile\.old$ ^Simple\.(?:[iocs]|bs)$ ^\. ^_build ^blib ^cover_db$ ^pm_to_blib ^remote$ ^untracked