Keyword-Simple-0.02/0000755000175000001440000000000012221211727013324 5ustar maukeusersKeyword-Simple-0.02/lib/0000755000175000001440000000000012221211727014072 5ustar maukeusersKeyword-Simple-0.02/lib/Keyword/0000755000175000001440000000000012221211727015516 5ustar maukeusersKeyword-Simple-0.02/lib/Keyword/Simple.pm0000644000175000001440000000641212221211577017313 0ustar maukeuserspackage Keyword::Simple; use v5.12.0; use warnings; use Carp qw(croak); use B::Hooks::EndOfScope; use XSLoader; BEGIN { our $VERSION = '0.02'; 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 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.02/META.yml0000644000175000001440000000111312221211727014571 0ustar maukeusers--- abstract: 'define new keywords in pure Perl' author: - 'Lukas Mai ' build_requires: Dir::Self: 0 Test::More: 0 strict: 0 dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 6.78, CPAN::Meta::Converter version 2.132661' 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.02 Keyword-Simple-0.02/Makefile.PL0000644000175000001440000000331412221124010015263 0ustar maukeusersuse 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.02/t/0000755000175000001440000000000012221211727013567 5ustar maukeusersKeyword-Simple-0.02/t/lineno.t0000644000175000001440000000106612221211340015232 0ustar maukeusers#!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.02/t/00-load.t0000644000175000001440000000026212221123227015105 0ustar maukeusers#!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.02/t/pod.t0000644000175000001440000000047612221125252014542 0ustar maukeusers#!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.02/t/basic.t0000644000175000001440000000055012221123227015032 0ustar maukeusers#!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.02/MANIFEST.SKIP0000644000175000001440000000030112221123227015211 0ustar maukeusers\.tar\.gz$ ^Build$ ^Keyword-Simple- ^GNUmakefile$ ^MANIFEST\.(?!SKIP$) ^MYMETA\. ^Makefile$ ^Makefile\.old$ ^Simple\.(?:[iocs]|bs)$ ^\. ^_build ^blib ^cover_db$ ^pm_to_blib ^remote$ ^untracked Keyword-Simple-0.02/MANIFEST0000644000175000001440000000044312221211727014456 0ustar maukeusersChanges 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.02/Simple.xs0000644000175000001440000001046112221210551015125 0ustar maukeusers/* 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.02/META.json0000644000175000001440000000225412221211727014750 0ustar maukeusers{ "abstract" : "define new keywords in pure Perl", "author" : [ "Lukas Mai " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 6.78, CPAN::Meta::Converter version 2.132661", "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" : {} }, "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.02" } Keyword-Simple-0.02/Changes0000644000175000001440000000031312221211666014616 0ustar maukeusersRevision history for Keyword-Simple 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.02/README0000644000175000001440000000174312221124063014205 0ustar maukeusersKeyword-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.