Skip to content
Browse files

first cut of the invoker pragma.

  • Loading branch information...
0 parents commit 2e25dc6fcdb0e78c67f96f0c434346beae779a26 @clkao committed Jan 15, 2011
Showing with 7,615 additions and 0 deletions.
  1. +12 −0 .gitignore
  2. +2 −0 .shipit
  3. +4 −0 Changes
  4. +30 −0 MANIFEST
  5. +14 −0 MANIFEST.SKIP
  6. +23 −0 Makefile.PL
  7. +56 −0 README
  8. +128 −0 invoker.xs
  9. +117 −0 lib/invoker.pm
  10. +7,063 −0 ppport.h
  11. +4 −0 t/00_compile.t
  12. +134 −0 t/01basic.t
  13. +1 −0 typemap
  14. +5 −0 xt/perlcritic.t
  15. +4 −0 xt/pod.t
  16. +14 −0 xt/podspell.t
  17. +4 −0 xt/synopsis.t
12 .gitignore
@@ -0,0 +1,12 @@
+META.yml
+Makefile
+inc/
+pm_to_blib
+*~
+*.c
+*.o
+*.bs
+*.old
+*.bak
+MYMETA.yml
+blib/
2 .shipit
@@ -0,0 +1,2 @@
+steps = FindVersion, ChangeVersion, CheckChangeLog, DistTest, Commit, Tag, MakeDist, UploadCPAN
+git.push_to = origin
4 Changes
@@ -0,0 +1,4 @@
+Revision history for Perl extension invoker
+
+0.01 Sat Jan 15 17:05:02 2011
+ - original version
30 MANIFEST
@@ -0,0 +1,30 @@
+.gitignore
+Changes
+inc/Module/Install.pm
+inc/Module/Install/AuthorTests.pm
+inc/Module/Install/Base.pm
+inc/Module/Install/Can.pm
+inc/Module/Install/Compiler.pm
+inc/Module/Install/Fetch.pm
+inc/Module/Install/Include.pm
+inc/Module/Install/Makefile.pm
+inc/Module/Install/Metadata.pm
+inc/Module/Install/ReadmeFromPod.pm
+inc/Module/Install/Repository.pm
+inc/Module/Install/Win32.pm
+inc/Module/Install/WriteAll.pm
+invoker.xs
+lib/invoker.pm
+Makefile.PL
+MANIFEST This list of files
+META.yml
+MYMETA.yml
+README
+t/00_compile.t
+t/01basic.t
+typemap
+xt/perlcritic.t
+xt/pod.t
+xt/podspell.t
+xt/synopsis.t
+ppport.h
14 MANIFEST.SKIP
@@ -0,0 +1,14 @@
+\bRCS\b
+\bCVS\b
+\.svn/
+\.git/
+^MANIFEST\.
+^Makefile$
+~$
+\.old$
+^blib/
+^pm_to_blib
+^MakeMaker-\d
+\.gz$
+\.cvsignore
+\.shipit
23 Makefile.PL
@@ -0,0 +1,23 @@
+sub readme_from {}; sub auto_include_deps {}; sub author_tests {}; sub auto_set_repository {};
+use strict;
+use ExtUtils::Depends;
+use inc::Module::Install;
+name 'invoker';
+all_from 'lib/invoker.pm';
+readme_from 'lib/invoker.pm';
+build_requires 'Test::More' => 0.88;
+auto_include_deps;
+author_tests('xt');
+configure_requires 'ExtUtils::Depends';
+configure_requires 'B::Hooks::OP::Check';
+
+requires 'B::Hooks::OP::Check';
+requires 'B::Hooks::EndOfScope';
+
+my $pkg = ExtUtils::Depends->new('invoker', 'B::Hooks::OP::Check');
+makemaker_args($pkg->get_makefile_vars);
+
+ppport;
+
+auto_set_repository;
+WriteAll;
56 README
@@ -0,0 +1,56 @@
+NAME
+ invoker - implicit invoker, sort of
+
+SYNOPSIS
+ use invoker;
+
+ sub foo {
+ my $self = shift;
+ $->bar; # calls $self->bar;
+ }
+
+ # use Method::Signatures::Simple
+ # method {
+ # $->bar # ditto
+ # }
+
+DESCRIPTION
+ the invoker pragma enables the "$->" syntax for invoking methods on
+ $self , inspired by Perl6's "$.method" invocation.
+
+ The module does not inject the $self variable for you. you are
+ encouraged to use it in conjunction with self,
+ <Method::Signatures::Simple>, or other similar modules.
+
+ The following syntax works:
+
+ $->foo( .. args ...)
+ $->foo
+ $->$method_name
+
+ The following syntax does not work:
+
+ $->$method_name( .. args ...)
+
+CAVEATS
+ WARNINGS WARNINGS WARNINGS
+
+ This is alpha code. Do not use in production.
+
+ Internally, the module installs a check on the ">" (gt) op. if the left
+ operand is $- (some format-related perlvar you probably shouldn't be
+ using), it then replaces the optree with an appropriate entersub with
+ method_named.
+
+TODO
+ make sure context are correct
+ custom invoker name with "use invoker '$this'"
+
+AUTHOR
+ Chia-liang Kao <clkao@clkao.org>
+
+LICENSE
+ This library is free software; you can redistribute it and/or modify it
+ under the same terms as Perl itself.
+
+SEE ALSO
128 invoker.xs
@@ -0,0 +1,128 @@
+#include "EXTERN.h"
+#include "perl.h"
+#include "embed.h"
+#include "XSUB.h"
+#define NEED_sv_2pv_flags_GLOBAL
+#include "ppport.h"
+
+#include "hook_op_check.h"
+
+#if PERL_REVISION == 5 && PERL_VERSION >= 13
+
+#else
+
+#define op_append_elem(a,b,c) Perl_append_elem(a,b,c)
+
+#if PERL_REVISION == 5 && PERL_VERSION >= 12
+
+#else
+#define pad_findmy(a,b,c) Perl_pad_findmy(a)
+#endif
+#endif
+
+typedef struct userdata_St {
+ hook_op_check_id eval_hook;
+ SV *class;
+} userdata_t;
+
+static OP *
+invoker_ck_gt(pTHX_ OP *o, void *ud) {
+ OP *left = cBINOPo->op_first; /* $- */
+ OP *right = left->op_sibling; /* the entersub */
+
+ if (left->op_type == OP_RV2SV) {
+ GV *gv;
+ left = cUNOPx(left)->op_first;
+ if (left->op_type == OP_GV &&
+ (gv = cGVOPx_gv(left)) &&
+ !strcmp(GvNAME_get(gv), "-")) {
+ const PADOFFSET tmp = pad_findmy("$self", 5, 0);
+ if (tmp == -1) {
+ croak("$self not found");
+ }
+ else {
+ OP * const self = newOP(OP_PADSV, 0);
+ self->op_targ = tmp;
+ //warn("right: %p %s. self = %d", right, PL_op_name[right->op_type], tmp);
+ if (right->op_type == OP_ENTERSUB) {
+ OP *f = ((cUNOPx(right)->op_first->op_sibling)
+ ? cUNOPx(right) : ((UNOP*)cUNOPx(right)->op_first))->op_first; // pushmark
+ OP *o2 = f->op_sibling; // the actual first argument
+
+ // warn("right first: %p %s", f, PL_op_name[f->op_type]);
+ // warn("right 2: %p %s", o2, PL_op_name[o2->op_type]);
+
+ self->op_sibling = o2;
+ f->op_sibling = self;
+
+ OP *last_arg = o2->op_type == OP_NULL ? f : o2;
+ while(last_arg->op_sibling->op_sibling)
+ last_arg = last_arg->op_sibling;
+
+ // warn("last_arg: %p %s", last_arg, PL_op_name[last_arg->op_type]);
+
+ OP *apply = cUNOPx(last_arg->op_sibling)->op_first;
+ // warn("apply: %p %s", apply, PL_op_name[apply->op_type]);
+ if (apply->op_type == OP_GV) {
+ SV *sv = newSVpv(GvNAME_get(cGVOPx_gv(apply)), 0);
+ const char *foo = GvNAME_get(cGVOPx_gv(apply));
+ OP *cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
+ last_arg->op_sibling = cmop;
+ }
+ else {
+ warn("unknown application: %s", PL_op_name[apply->op_type]);
+ return o;
+ }
+
+ // warn("self next = %p %s", self->op_next, PL_op_name[self->op_next->op_type]);
+
+ return right;
+ }
+ else if (right->op_type == OP_CONST) {
+ SV *name = ((SVOP*)right)->op_sv;
+ o = (OP *)newUNOP(OP_ENTERSUB, OPf_STACKED,
+ op_append_elem(OP_LIST, self,
+ newSVOP(OP_METHOD_NAMED, 0, name)));
+ return o;
+ }
+ else {
+ SV *sv = ((SVOP*)right)->op_sv;
+ o = (OP *)newUNOP(OP_ENTERSUB, OPf_STACKED,
+ op_append_elem(OP_LIST, self,
+ newUNOP(OP_METHOD, 0, right)));
+ return o;
+ }
+ }
+ }
+ }
+ return o;
+}
+
+
+MODULE = invoker PACKAGE = invoker
+PROTOTYPES: ENABLE
+
+hook_op_check_id
+setup (class)
+ SV *class;
+ PREINIT:
+ userdata_t *ud;
+ INIT:
+ Newx (ud, 1, userdata_t);
+ CODE:
+ ud->class = newSVsv (class);
+ RETVAL = hook_op_check (OP_GT, invoker_ck_gt, ud);
+ OUTPUT:
+ RETVAL
+
+void
+teardown (class, hook)
+ hook_op_check_id hook
+ PREINIT:
+ userdata_t *ud;
+ CODE:
+ ud = (userdata_t *)hook_op_check_remove (OP_GT, hook);
+ if (ud) {
+ SvREFCNT_dec (ud->class);
+ Safefree (ud);
+ }
117 lib/invoker.pm
@@ -0,0 +1,117 @@
+package invoker;
+
+use strict;
+use 5.010_001;
+
+use B::Hooks::OP::Check;
+use B::Hooks::EndOfScope;
+
+our $VERSION = "0.29_001";
+
+require XSLoader;
+XSLoader::load(__PACKAGE__, $VERSION);
+
+sub import {
+ my ($class) = @_;
+ my $caller = caller;
+
+ my $hook = $class->setup;
+
+ on_scope_end {
+ $class->teardown($hook);
+ };
+
+ return;
+}
+
+1;
+__END__
+
+=encoding utf-8
+
+=for stopwords
+
+=head1 NAME
+
+invoker - implicit invoker, sort of
+
+=head1 SYNOPSIS
+
+ use invoker;
+
+ sub foo {
+ my $self = shift;
+ $->bar; # calls $self->bar;
+ }
+
+ # use Method::Signatures::Simple
+ # method {
+ # $->bar # ditto
+ # }
+
+=head1 DESCRIPTION
+
+the invoker pragma enables the C<< $-> >> syntax for invoking methods
+on C< $self >, inspired by Perl6's C<< $.method >> invocation.
+
+The module does not inject the C< $self > variable for you. you are
+encouraged to use it in conjunction with L<self>,
+<Method::Signatures::Simple>, or other similar modules.
+
+The following syntax works:
+
+=over
+
+=item $->foo( .. args ...)
+
+=item $->foo
+
+=item $->$method_name
+
+=back
+
+The following syntax does not work:
+
+=over
+
+=item $->$method_name( .. args ...)
+
+=back
+
+=head1 CAVEATS
+
+WARNINGS WARNINGS WARNINGS
+
+This is alpha code. Do not use in production.
+
+Internally, the module installs a check on the C<< > >> (gt) op. if
+the left operand is C< $- > (some format-related perlvar you probably
+shouldn't be using), it then replaces the optree with an appropriate
+entersub with method_named.
+
+=head1 TODO
+
+=over
+
+=item make sure context are correct
+
+=item custom invoker name with "use invoker '$this'"
+
+=back
+
+=head1 AUTHOR
+
+Chia-liang Kao E<lt>clkao@clkao.orgE<gt>
+
+=head1 LICENSE
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+=cut
+
+__END__
+
+
7,063 ppport.h
7,063 additions, 0 deletions not shown because the diff is too large. Please use a local Git client to view these changes.
4 t/00_compile.t
@@ -0,0 +1,4 @@
+use strict;
+use Test::More tests => 1;
+
+BEGIN { use_ok 'invoker' }
134 t/01basic.t
@@ -0,0 +1,134 @@
+#!/usr/bin/perl -w
+use strict;
+
+package submain;
+our @ISA = ('main');
+sub foo {
+ push @main::foo, ['submain', @_ ]
+}
+
+package main;
+
+use Test::More;
+
+our @foo;
+
+sub foo {
+ push @foo, \@_;
+}
+{
+ my $sub = eval q{ sub {
+ use invoker;
+ sub {
+ my $self = shift;
+ $->foo("x", @_);
+ }
+ } };
+ ok($sub);
+ diag $@ if $@;
+
+ my $self = bless {}, 'main';
+ $sub->()->($self, 1,2);
+
+ my $subself = bless {}, 'submain';
+ $sub->()->($subself, 1,2);
+
+ is_deeply(\@foo, [[$self, 'x', 1,2],
+ ['submain', $subself, 'x', 1, 2]]);
+
+}
+
+{
+ @foo = ();
+ my $sub = eval q{ sub {
+ use invoker;
+ sub {
+ my $self = shift;
+ $->foo;
+ }
+ } };
+ ok($sub);
+ diag $@ if $@;
+
+ my $self = bless {}, 'main';
+ $sub->()->($self, 1,2);
+
+ my $subself = bless {}, 'submain';
+ $sub->()->($subself, 1,2);
+
+ is_deeply(\@foo, [[$self],
+ ['submain', $subself]]);
+}
+
+{
+ @foo = ();
+ my $sub = eval q{ sub {
+ use invoker;
+ sub {
+ my $self = shift;
+ $->bar('x');
+ }
+ } };
+
+ no warnings 'once';
+ *bar = sub {
+ push @foo, ['bar', @_];
+ };
+ ok($sub);
+ diag $@ if $@;
+
+ my $self = bless {}, 'main';
+ $sub->()->($self, 1,2);
+
+ my $subself = bless {}, 'submain';
+ $sub->()->($subself, 1,2);
+
+ is_deeply(\@foo, [['bar', $self, 'x'],
+ ['bar', $subself, 'x']]);
+ @foo = ();
+}
+
+{
+ @foo = ();
+ my $sub = eval q{ sub {
+ use invoker;
+ my $name = 'bar';
+ sub {
+ my $self = shift;
+ $->$name;
+ }
+ } };
+
+
+ ok($sub);
+ diag $@ if $@;
+
+ my $self = bless {}, 'main';
+ $sub->()->($self, 1,2);
+
+ my $subself = bless {}, 'submain';
+ $sub->()->($subself, 1,2);
+
+ is_deeply(\@foo, [['bar', $self],
+ ['bar', $subself]]);
+ @foo = ();
+}
+
+{
+ @foo = ();
+ my $sub = eval q{ sub {
+ use invoker;
+ my $name = 'bar';
+ sub {
+ $->$name;
+ }
+ } };
+
+
+ ok(!$sub);
+ like($@, qr'\$self not found');
+
+}
+
+
+done_testing;
1 typemap
@@ -0,0 +1 @@
+hook_op_check_id T_UV
5 xt/perlcritic.t
@@ -0,0 +1,5 @@
+use strict;
+use Test::More;
+eval q{ use Test::Perl::Critic };
+plan skip_all => "Test::Perl::Critic is not installed." if $@;
+all_critic_ok("lib");
4 xt/pod.t
@@ -0,0 +1,4 @@
+use Test::More;
+eval "use Test::Pod 1.00";
+plan skip_all => "Test::Pod 1.00 required for testing POD" if $@;
+all_pod_files_ok();
14 xt/podspell.t
@@ -0,0 +1,14 @@
+use Test::More;
+eval q{ use Test::Spelling };
+plan skip_all => "Test::Spelling is not installed." if $@;
+add_stopwords(<DATA>);
+set_spell_cmd("aspell -l en list");
+all_pod_files_spelling_ok('lib');
+__DATA__
+Chia
+liang
+Kao
+TODO
+entersub
+optree
+perlvar
4 xt/synopsis.t
@@ -0,0 +1,4 @@
+use Test::More;
+eval "use Test::Synopsis";
+plan skip_all => "Test::Synopsis required" if $@;
+all_synopsis_ok();

0 comments on commit 2e25dc6

Please sign in to comment.
Something went wrong with that request. Please try again.