From: Rhesa Rozendaal <rhesa@cpan.org>
Date: Mon, 6 Oct 2008 11:40:27 +0000 (+0000)
Subject: added DD::Context::Simple, which packages the synopsis (or method_no_semi.t) for... 
X-Git-Tag: 0.005000~47^2~3
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=p5sagit%2FDevel-Declare.git;a=commitdiff_plain;h=e7be1784afaeb943f278a4249d5000bd2b706f11

added DD::Context::Simple, which packages the synopsis (or method_no_semi.t) for easier reuse
---

diff --git a/lib/Devel/Declare/Context/Simple.pm b/lib/Devel/Declare/Context/Simple.pm
new file mode 100644
index 0000000..268514c
--- /dev/null
+++ b/lib/Devel/Declare/Context/Simple.pm
@@ -0,0 +1,101 @@
+package Devel::Declare::Context::Simple;
+
+use Devel::Declare ();
+use Scope::Guard;
+use strict;
+use warnings;
+
+sub new {
+    my $class = shift;
+    bless {@_}, $class;
+}
+
+sub init {
+    my $ctx = shift;
+    @{$ctx}{ qw(Declarator Offset) } = @_;
+    $ctx;
+}
+
+sub offset : lvalue { shift->{Offset}; }
+sub declarator { shift->{Declarator} }
+
+sub skip_declarator {
+    my $ctx = shift;
+    $ctx->offset += Devel::Declare::toke_move_past_token( $ctx->offset );
+}
+
+sub skipspace {
+    my $ctx = shift;
+    $ctx->offset += Devel::Declare::toke_skipspace( $ctx->offset );
+}
+
+sub strip_name {
+    my $ctx = shift;
+    $ctx->skipspace;
+    if( my $len = Devel::Declare::toke_scan_word( $ctx->offset, 1 ) ) {
+        my $linestr = Devel::Declare::get_linestr();
+        my $name = substr( $linestr, $ctx->offset, $len );
+        substr( $linestr, $ctx->offset, $len ) = '';
+        Devel::Declare::set_linestr($linestr);
+        return $name;
+    }
+    return;
+}
+
+sub strip_proto {
+    my $ctx = shift;
+    $ctx->skipspace;
+
+    my $linestr = Devel::Declare::get_linestr();
+    if( substr( $linestr, $ctx->offset, 1 ) eq '(' ) {
+        my $length = Devel::Declare::toke_scan_str( $ctx->offset );
+        my $proto  = Devel::Declare::get_lex_stuff();
+        Devel::Declare::clear_lex_stuff();
+        $linestr = Devel::Declare::get_linestr();
+        substr( $linestr, $ctx->offset, $length ) = '';
+        Devel::Declare::set_linestr($linestr);
+        return $proto;
+    }
+    return;
+}
+
+sub get_curstash_name {
+    return Devel::Declare::get_curstash_name;
+}
+
+sub shadow {
+    my $ctx  = shift;
+    my $pack = $ctx->get_curstash_name;
+    Devel::Declare::shadow_sub( $pack . '::' . $ctx->declarator, $_[0] );
+}
+
+sub inject_if_block {
+    my $ctx    = shift;
+    my $inject = shift;
+    $ctx->skipspace;
+    my $linestr = Devel::Declare::get_linestr;
+    if( substr( $linestr, $ctx->offset, 1 ) eq '{' ) {
+        substr( $linestr, $ctx->offset + 1, 0 ) = $inject;
+        Devel::Declare::set_linestr($linestr);
+    }
+}
+
+sub scope_injector_call {
+    return ' BEGIN { ' . __PACKAGE__ . '::inject_scope }; ';
+}
+
+sub inject_scope {
+    my $ctx = shift;
+    $^H |= 0x120000;
+    $^H{DD_METHODHANDLERS} = Scope::Guard->new(
+        sub {
+            my $linestr = Devel::Declare::get_linestr;
+            my $offset  = Devel::Declare::get_linestr_offset;
+            substr( $linestr, $offset, 0 ) = ';';
+            Devel::Declare::set_linestr($linestr);
+        }
+    );
+}
+
+1;
+
diff --git a/lib/Devel/Declare/MethodInstaller/Simple.pm b/lib/Devel/Declare/MethodInstaller/Simple.pm
new file mode 100644
index 0000000..0df21d1
--- /dev/null
+++ b/lib/Devel/Declare/MethodInstaller/Simple.pm
@@ -0,0 +1,61 @@
+package Devel::Declare::MethodInstaller::Simple;
+
+use base 'Devel::Declare::Context::Simple';
+
+use Devel::Declare ();
+use Sub::Name;
+use strict;
+use warnings;
+
+sub install_methodhandler {
+    my $class = shift;
+    my %args  = @_;
+    {
+        no strict 'refs';
+        *{$args{into}.'::'.$args{name}}   = sub (&) {};
+    }
+
+    my $ctx = $class->new( %args );
+    Devel::Declare->setup_for(
+        $args{into},
+        { $args{name} => { const => sub { $ctx->parser(@_) } } }
+    );
+
+}
+
+sub parser {
+    my $ctx = shift;
+    $ctx->init(@_);
+
+    $ctx->skip_declarator;
+    my $name   = $ctx->strip_name;
+    my $proto  = $ctx->strip_proto;
+    my @decl   = $ctx->parse_proto($proto);
+    my $inject = $ctx->inject_parsed_proto(@decl);
+    if( defined $name ) {
+        $inject = $ctx->scope_injector_call() . $inject;
+    }
+    $ctx->inject_if_block($inject);
+    if( defined $name ) {
+        my $pkg = $ctx->get_curstash_name;
+        $name = join( '::', $pkg, $name )
+            unless( $name =~ /::/ );
+        $ctx->shadow( sub (&) {
+            my $code = shift;
+            # So caller() gets the subroutine name
+            no strict 'refs';
+            *{$name} = subname $name => $code;
+        });
+    } else {
+        $ctx->shadow(sub (&) { shift });
+    }
+}
+sub parse_proto { }
+sub inject_parsed_proto {
+    my $ctx = shift;
+    shift;
+}
+
+
+1;
+
diff --git a/t/ctx-simple.t b/t/ctx-simple.t
new file mode 100644
index 0000000..938afc7
--- /dev/null
+++ b/t/ctx-simple.t
@@ -0,0 +1,132 @@
+use Devel::Declare ();
+
+{
+  package MethodHandlers;
+
+  use strict;
+  use warnings;
+  use Devel::Declare::Context::Simple;
+
+  # undef  -> my ($self) = shift;
+  # ''     -> my ($self) = @_;
+  # '$foo' -> my ($self, $foo) = @_;
+
+  sub make_proto_unwrap {
+    my ($proto) = @_;
+    my $inject = 'my ($self';
+    if (defined $proto) {
+      $inject .= ", $proto" if length($proto);
+      $inject .= ') = @_; ';
+    } else {
+      $inject .= ') = shift;';
+    }
+    return $inject;
+  }
+
+  sub parser {
+    my $ctx = Devel::Declare::Context::Simple->new->init(@_);
+
+    $ctx->skip_declarator;
+    my $name = $ctx->strip_name;
+    my $proto = $ctx->strip_proto;
+    my $inject = make_proto_unwrap($proto);
+    if (defined $name) {
+      $inject = $ctx->scope_injector_call().$inject;
+    }
+    $ctx->inject_if_block($inject);
+    if (defined $name) {
+      $name = join('::', Devel::Declare::get_curstash_name(), $name)
+        unless ($name =~ /::/);
+      $ctx->shadow(sub (&) { no strict 'refs'; *{$name} = shift; });
+    } else {
+      $ctx->shadow(sub (&) { shift });
+    }
+  }
+
+}
+
+my ($test_method1, $test_method2, @test_list);
+
+{
+  package DeclareTest;
+
+  sub method (&);
+
+  BEGIN {
+    Devel::Declare->setup_for(
+      __PACKAGE__,
+      { method => { const => \&MethodHandlers::parser } }
+    );
+  }
+
+  method new {
+    my $class = ref $self || $self;
+    return bless({ @_ }, $class);
+  }
+
+  method foo ($foo) {
+    return (ref $self).': Foo: '.$foo;
+  }
+
+  method upgrade(){ # no spaces to make case pathological
+    bless($self, 'DeclareTest2');
+  }
+
+  method DeclareTest2::bar () {
+    return 'DeclareTest2: bar';
+  }
+
+  $test_method1 = method {
+    return join(', ', $self->{attr}, $_[1]);
+  };
+
+  $test_method2 = method ($what) {
+    return join(', ', ref $self, $what);
+  };
+
+  method main () { return "main"; }
+
+  @test_list = (method { 1 }, sub { 2 }, method () { 3 }, sub { 4 });
+
+}
+
+use Test::More 'no_plan';
+
+my $o = DeclareTest->new(attr => "value");
+
+isa_ok($o, 'DeclareTest');
+
+is($o->{attr}, 'value', '@_ args ok');
+
+is($o->foo('yay'), 'DeclareTest: Foo: yay', 'method with argument ok');
+
+is($o->main, 'main', 'declaration of package named method ok');
+
+$o->upgrade;
+
+isa_ok($o, 'DeclareTest2');
+
+is($o->bar, 'DeclareTest2: bar', 'absolute method declaration ok');
+
+is($o->$test_method1('no', 'yes'), 'value, yes', 'anon method with @_ ok');
+
+is($o->$test_method2('this'), 'DeclareTest2, this', 'anon method with proto ok');
+
+is_deeply([ map { $_->() } @test_list ], [ 1, 2, 3, 4], 'binding ok');
+
+__END__
+/home/rhesa/perl/t/method-no-semi....
+ok 1 - The object isa DeclareTest
+ok 2 - @_ args ok
+ok 3 - method with argument ok
+ok 4 - declaration of package named method ok
+ok 5 - The object isa DeclareTest2
+ok 6 - absolute method declaration ok
+ok 7 - anon method with @_ ok
+ok 8 - anon method with proto ok
+ok 9 - binding ok
+1..9
+ok
+All tests successful.
+Files=1, Tests=9,  0 wallclock secs ( 0.04 usr  0.00 sys +  0.05 cusr  0.00 csys =  0.09 CPU)
+Result: PASS
diff --git a/t/methinstaller-simple.t b/t/methinstaller-simple.t
new file mode 100644
index 0000000..37ba354
--- /dev/null
+++ b/t/methinstaller-simple.t
@@ -0,0 +1,110 @@
+
+{
+  package MethodHandlers;
+
+  use strict;
+  use warnings;
+  use base 'Devel::Declare::MethodInstaller::Simple';
+
+  # undef  -> my ($self) = shift;
+  # ''     -> my ($self) = @_;
+  # '$foo' -> my ($self, $foo) = @_;
+
+  sub parse_proto {
+    my $ctx = shift;
+    my ($proto) = @_;
+    my $inject = 'my ($self';
+    if (defined $proto) {
+      $inject .= ", $proto" if length($proto);
+      $inject .= ') = @_; ';
+    } else {
+      $inject .= ') = shift;';
+    }
+    return $inject;
+  }
+
+}
+
+my ($test_method1, $test_method2, @test_list);
+
+{
+  package DeclareTest;
+
+  BEGIN { # normally, this'd go in MethodHandlers::import
+  MethodHandlers->install_methodhandler(
+    name => 'method',
+    into => __PACKAGE__,
+    );
+  }
+
+  method new {
+    my $class = ref $self || $self;
+    return bless({ @_ }, $class);
+  }
+
+  method foo ($foo) {
+    return (ref $self).': Foo: '.$foo;
+  }
+
+  method upgrade(){ # no spaces to make case pathological
+    bless($self, 'DeclareTest2');
+  }
+
+  method DeclareTest2::bar () {
+    return 'DeclareTest2: bar';
+  }
+
+  $test_method1 = method {
+    return join(', ', $self->{attr}, $_[1]);
+  };
+
+  $test_method2 = method ($what) {
+    return join(', ', ref $self, $what);
+  };
+
+  method main () { return "main"; }
+
+  @test_list = (method { 1 }, sub { 2 }, method () { 3 }, sub { 4 });
+
+}
+
+use Test::More 'no_plan';
+
+my $o = DeclareTest->new(attr => "value");
+
+isa_ok($o, 'DeclareTest');
+
+is($o->{attr}, 'value', '@_ args ok');
+
+is($o->foo('yay'), 'DeclareTest: Foo: yay', 'method with argument ok');
+
+is($o->main, 'main', 'declaration of package named method ok');
+
+$o->upgrade;
+
+isa_ok($o, 'DeclareTest2');
+
+is($o->bar, 'DeclareTest2: bar', 'absolute method declaration ok');
+
+is($o->$test_method1('no', 'yes'), 'value, yes', 'anon method with @_ ok');
+
+is($o->$test_method2('this'), 'DeclareTest2, this', 'anon method with proto ok');
+
+is_deeply([ map { $_->() } @test_list ], [ 1, 2, 3, 4], 'binding ok');
+
+__END__
+/home/rhesa/perl/t/methinstaller-simple....
+ok 1 - The object isa DeclareTest
+ok 2 - @_ args ok
+ok 3 - method with argument ok
+ok 4 - declaration of package named method ok
+ok 5 - The object isa DeclareTest2
+ok 6 - absolute method declaration ok
+ok 7 - anon method with @_ ok
+ok 8 - anon method with proto ok
+ok 9 - binding ok
+1..9
+ok
+All tests successful.
+Files=1, Tests=9,  0 wallclock secs ( 0.04 usr  0.00 sys +  0.05 cusr  0.00 csys =  0.09 CPU)
+Result: PASS