From: Florian Ragwitz <rafl@debian.org>
Date: Fri, 24 Oct 2008 21:17:24 +0000 (+0000)
Subject: Merge branch 'context_object'
X-Git-Tag: 0.005000~47
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=086ef3b14c90020bc2a1860b136db91bd66f4f01;hp=b1e909d390e40bdae05c2e9057d232d078028126;p=p5sagit%2FDevel-Declare.git

Merge branch 'context_object'
---

diff --git a/lib/Devel/Declare/Context/Simple.pm b/lib/Devel/Declare/Context/Simple.pm
new file mode 100644
index 0000000..474025a
--- /dev/null
+++ b/lib/Devel/Declare/Context/Simple.pm
@@ -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
diff --git a/lib/Devel/Declare/MethodInstaller/Simple.pm b/lib/Devel/Declare/MethodInstaller/Simple.pm
new file mode 100644
index 0000000..96fa88c
--- /dev/null
+++ b/lib/Devel/Declare/MethodInstaller/Simple.pm
@@ -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;
+
diff --git a/t/ctx-simple.t b/t/ctx-simple.t
new file mode 100644
index 0000000..14f80f4
--- /dev/null
+++ b/t/ctx-simple.t
@@ -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');
+
diff --git a/t/methinstaller-simple.t b/t/methinstaller-simple.t
new file mode 100644
index 0000000..c588bea
--- /dev/null
+++ b/t/methinstaller-simple.t
@@ -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');
+