first cut of the invoker pragma.

.gitignore

@@ -0,0 +1,12 @@
+META.yml
+Makefile
+inc/
+pm_to_blib
+*~
+*.c
+*.o
+*.bs
+*.old
+*.bak
+MYMETA.yml
+blib/

.shipit

@@ -0,0 +1,2 @@
+steps = FindVersion, ChangeVersion, CheckChangeLog, DistTest, Commit, Tag, MakeDist, UploadCPAN
+git.push_to = origin

Changes

@@ -0,0 +1,4 @@
+Revision history for Perl extension invoker
+
+0.01  Sat Jan 15 17:05:02 2011
+        - original version

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

MANIFEST.SKIP

@@ -0,0 +1,14 @@
+\bRCS\b
+\bCVS\b
+\.svn/
+\.git/
+^MANIFEST\.
+^Makefile$
+~$
+\.old$
+^blib/
+^pm_to_blib
+^MakeMaker-\d
+\.gz$
+\.cvsignore
+\.shipit

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;

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

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);
+        }

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__
+
+