[Bast-commits] r4974 - in Devel-Declare/1.000/trunk: lib/Devel
lib/Devel/Declare lib/Devel/Declare/Context
lib/Devel/Declare/MethodInstaller t
rafl at dev.catalyst.perl.org
rafl at dev.catalyst.perl.org
Fri Oct 24 22:17:24 BST 2008
Author: rafl
Date: 2008-10-24 22:17:24 +0100 (Fri, 24 Oct 2008)
New Revision: 4974
Added:
Devel-Declare/1.000/trunk/lib/Devel/Declare/
Devel-Declare/1.000/trunk/lib/Devel/Declare/Context/
Devel-Declare/1.000/trunk/lib/Devel/Declare/Context/Simple.pm
Devel-Declare/1.000/trunk/lib/Devel/Declare/MethodInstaller/
Devel-Declare/1.000/trunk/lib/Devel/Declare/MethodInstaller/Simple.pm
Devel-Declare/1.000/trunk/t/ctx-simple.t
Devel-Declare/1.000/trunk/t/methinstaller-simple.t
Log:
Merge branch 'context_object'
Added: Devel-Declare/1.000/trunk/lib/Devel/Declare/Context/Simple.pm
===================================================================
--- Devel-Declare/1.000/trunk/lib/Devel/Declare/Context/Simple.pm (rev 0)
+++ Devel-Declare/1.000/trunk/lib/Devel/Declare/Context/Simple.pm 2008-10-24 21:17:24 UTC (rev 4974)
@@ -0,0 +1,129 @@
+package Devel::Declare::Context::Simple;
+
+use Devel::Declare ();
+use B::Hooks::EndOfScope;
+use strict;
+use warnings;
+
+sub new {
+ my $class = shift;
+ bless {@_}, $class;
+}
+
+sub init {
+ my $self = shift;
+ @{$self}{ qw(Declarator Offset) } = @_;
+ $self;
+}
+
+sub offset : lvalue { shift->{Offset}; }
+sub declarator { shift->{Declarator} }
+
+sub skip_declarator {
+ my $self = shift;
+ $self->offset += Devel::Declare::toke_move_past_token( $self->offset );
+}
+
+sub skipspace {
+ my $self = shift;
+ $self->offset += Devel::Declare::toke_skipspace( $self->offset );
+}
+
+sub get_linestr {
+ my $self = shift;
+ my $line = Devel::Declare::get_linestr();
+ return $line;
+}
+
+sub set_linestr {
+ my $self = shift;
+ my ($line) = @_;
+ Devel::Declare::set_linestr($line);
+}
+
+sub strip_name {
+ my $self = shift;
+ $self->skipspace;
+ if (my $len = Devel::Declare::toke_scan_word( $self->offset, 1 )) {
+ my $linestr = $self->get_linestr();
+ my $name = substr( $linestr, $self->offset, $len );
+ substr( $linestr, $self->offset, $len ) = '';
+ $self->set_linestr($linestr);
+ return $name;
+ }
+
+ $self->skipspace;
+ return;
+}
+
+sub strip_proto {
+ my $self = shift;
+ $self->skipspace;
+
+ my $linestr = $self->get_linestr();
+ if (substr($linestr, $self->offset, 1) eq '(') {
+ my $length = Devel::Declare::toke_scan_str($self->offset);
+ my $proto = Devel::Declare::get_lex_stuff();
+ Devel::Declare::clear_lex_stuff();
+ if( $length < 0 ) {
+ # Need to scan ahead more
+ $linestr .= $self->get_linestr();
+ $length = rindex($linestr, ")") - $self->offset + 1;
+ }
+ else {
+ $linestr = $self->get_linestr();
+ }
+
+ substr($linestr, $self->offset, $length) = '';
+ $self->set_linestr($linestr);
+
+ return $proto;
+ }
+ return;
+}
+
+sub get_curstash_name {
+ return Devel::Declare::get_curstash_name;
+}
+
+sub shadow {
+ my $self = shift;
+ my $pack = $self->get_curstash_name;
+ Devel::Declare::shadow_sub( $pack . '::' . $self->declarator, $_[0] );
+}
+
+sub inject_if_block {
+ my $self = shift;
+ my $inject = shift;
+ my $before = shift || '';
+
+ $self->skipspace;
+
+ my $linestr = $self->get_linestr;
+ if (substr($linestr, $self->offset, 1) eq '{') {
+ substr($linestr, $self->offset + 1, 0) = $inject;
+ substr($linestr, $self->offset, 0) = $before;
+ $self->set_linestr($linestr);
+ }
+}
+
+sub scope_injector_call {
+ my $self = shift;
+ my $inject = shift || '';
+ return ' BEGIN { ' . ref($self) . "->inject_scope('${inject}') }; ";
+}
+
+sub inject_scope {
+ my $class = shift;
+ my $inject = shift;
+ on_scope_end {
+ my $linestr = Devel::Declare::get_linestr;
+ return unless defined $linestr;
+ my $offset = Devel::Declare::get_linestr_offset;
+ substr( $linestr, $offset, 0 ) = ';' . $inject;
+ Devel::Declare::set_linestr($linestr);
+ };
+}
+
+1;
+# vi:sw=2 ts=2
Added: Devel-Declare/1.000/trunk/lib/Devel/Declare/MethodInstaller/Simple.pm
===================================================================
--- Devel-Declare/1.000/trunk/lib/Devel/Declare/MethodInstaller/Simple.pm (rev 0)
+++ Devel-Declare/1.000/trunk/lib/Devel/Declare/MethodInstaller/Simple.pm 2008-10-24 21:17:24 UTC (rev 4974)
@@ -0,0 +1,108 @@
+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 strip_attrs {
+ my $self = shift;
+ $self->skipspace;
+
+ my $Offset = $self->offset;
+ my $linestr = Devel::Declare::get_linestr;
+ my $attrs = '';
+
+ if (substr($linestr, $Offset, 1) eq ':') {
+ while (substr($linestr, $Offset, 1) ne '{') {
+ if (substr($linestr, $Offset, 1) eq ':') {
+ substr($linestr, $Offset, 1) = '';
+ Devel::Declare::set_linestr($linestr);
+
+ $attrs .= ':';
+ }
+
+ $self->skipspace;
+ $Offset = $self->offset;
+ $linestr = Devel::Declare::get_linestr();
+
+ if (my $len = Devel::Declare::toke_scan_word($Offset, 0)) {
+ my $name = substr($linestr, $Offset, $len);
+ substr($linestr, $Offset, $len) = '';
+ Devel::Declare::set_linestr($linestr);
+
+ $attrs .= " ${name}";
+
+ if (substr($linestr, $Offset, 1) eq '(') {
+ my $length = Devel::Declare::toke_scan_str($Offset);
+ my $arg = Devel::Declare::get_lex_stuff();
+ Devel::Declare::clear_lex_stuff();
+ $linestr = Devel::Declare::get_linestr();
+ substr($linestr, $Offset, $length) = '';
+ Devel::Declare::set_linestr($linestr);
+
+ $attrs .= "(${arg})";
+ }
+ }
+ }
+
+ $linestr = Devel::Declare::get_linestr();
+ }
+
+ return $attrs;
+}
+
+sub parser {
+ my $self = shift;
+ $self->init(@_);
+
+ $self->skip_declarator;
+ my $name = $self->strip_name;
+ my $proto = $self->strip_proto;
+ my $attrs = $self->strip_attrs;
+ my @decl = $self->parse_proto($proto);
+ my $inject = $self->inject_parsed_proto(@decl);
+ if (defined $name) {
+ $inject = $self->scope_injector_call() . $inject;
+ }
+ $self->inject_if_block($inject, $attrs ? "sub ${attrs} " : '');
+ if (defined $name) {
+ my $pkg = $self->get_curstash_name;
+ $name = join( '::', $pkg, $name )
+ unless( $name =~ /::/ );
+ $self->shadow( sub (&) {
+ my $code = shift;
+ # So caller() gets the subroutine name
+ no strict 'refs';
+ *{$name} = subname $name => $code;
+ });
+ } else {
+ $self->shadow(sub (&) { shift });
+ }
+}
+
+sub parse_proto { }
+
+sub inject_parsed_proto {
+ return $_[1];
+}
+
+1;
+
Added: Devel-Declare/1.000/trunk/t/ctx-simple.t
===================================================================
--- Devel-Declare/1.000/trunk/t/ctx-simple.t (rev 0)
+++ Devel-Declare/1.000/trunk/t/ctx-simple.t 2008-10-24 21:17:24 UTC (rev 4974)
@@ -0,0 +1,138 @@
+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) {
+ $proto =~ s/[\r\n\s]+/ /g;
+ $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 });
+
+ method multiline1(
+ $foo
+ )
+ {
+ return "$foo$foo";
+ }
+
+ method multiline2(
+ $foo, $bar
+ ) { return "$foo $bar"; }
+
+ method
+ multiline3 ($foo,
+ $bar) {
+ return "$bar $foo";
+ }
+
+}
+
+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');
+
+is($o->multiline1(3), '33', 'multiline1 proto ok');
+is($o->multiline2(1,2), '1 2', 'multiline2 proto ok');
+is($o->multiline3(4,5), '5 4', 'multiline3 proto 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');
+
Added: Devel-Declare/1.000/trunk/t/methinstaller-simple.t
===================================================================
--- Devel-Declare/1.000/trunk/t/methinstaller-simple.t (rev 0)
+++ Devel-Declare/1.000/trunk/t/methinstaller-simple.t 2008-10-24 21:17:24 UTC (rev 4974)
@@ -0,0 +1,98 @@
+
+{
+ 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 });
+
+ method leftie :lvalue { $self->{attributes} };
+}
+
+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->leftie = 'attributes work';
+is($o->leftie, 'attributes work', 'code attributes intact');
+
+$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');
+
More information about the Bast-commits
mailing list