add offset function for non-callback driven stuff, add tests

git-svn-id: http://dev.catalyst.perl.org/repos/bast/trunk/Devel-Declare@4830 bd8105ee-0ff8-0310-8827-fb3f25b6796d

diff --git a/Declare.xs b/Declare.xs
index 7ca77ed..52b41b2 100644 (file)
--- a/Declare.xs
+++ b/Declare.xs
@@ -136,6 +136,11 @@ char* dd_get_curstash_name(pTHX) {
   return HvNAME(PL_curstash);
 }
 
+int dd_get_linestr_offset(pTHX) {
+  char* linestr = SvPVX(PL_linestr);
+  return PL_bufptr - linestr;
+}
+
 char* dd_move_past_token (pTHX_ char* s) {
 
   /*
@@ -360,6 +365,13 @@ get_curstash_name()
     RETVAL
 
 int
+get_linestr_offset()
+  CODE:
+    RETVAL = dd_get_linestr_offset(aTHX);
+  OUTPUT:
+    RETVAL
+
+int
 toke_scan_word(int offset, int handle_package)
   CODE:
     RETVAL = dd_toke_scan_word(aTHX_ offset, handle_package);

diff --git a/t/method.t b/t/method.t
new file mode 100644 (file)
index 0000000..7bc3adb
--- /dev/null
+++ b/t/method.t
@@ -0,0 +1,179 @@
+use Devel::Declare ();
+use Scope::Guard;
+
+{
+  package MethodHandlers;
+
+  use strict;
+  use warnings;
+
+  our ($Declarator, $Offset);
+
+  sub skip_declarator {
+    $Offset += Devel::Declare::toke_move_past_token($Offset);
+  }
+
+  sub skipspace {
+    $Offset += Devel::Declare::toke_skipspace($Offset);
+  }
+
+  sub strip_name {
+    skipspace;
+    if (my $len = Devel::Declare::toke_scan_word($Offset, 1)) {
+      my $linestr = Devel::Declare::get_linestr();
+      my $name = substr($linestr, $Offset, $len);
+      substr($linestr, $Offset, $len) = '';
+      Devel::Declare::set_linestr($linestr);
+      return $name;
+    }
+    return;
+  }
+
+  sub strip_proto {
+    skipspace;
+    
+    my $linestr = Devel::Declare::get_linestr();
+    if (substr($linestr, $Offset, 1) eq '(') {
+      my $length = Devel::Declare::toke_scan_str($Offset);
+      my $proto = Devel::Declare::get_lex_stuff();
+      Devel::Declare::clear_lex_stuff();
+      $linestr = Devel::Declare::get_linestr();
+      substr($linestr, $Offset, $length) = '';
+      Devel::Declare::set_linestr($linestr);
+      return $proto;
+    }
+    return;
+  }
+
+  sub shadow {
+    my $pack = Devel::Declare::get_curstash_name;
+    Devel::Declare::shadow_sub("${pack}::${Declarator}", $_[0]);
+  }
+
+  sub inject_str {
+    my $linestr = Devel::Declare::get_linestr;
+    substr($linestr, $Offset, 0) = $_[0];
+    Devel::Declare::set_linestr($linestr);
+  }
+
+  sub strip_str {
+    my $linestr = Devel::Declare::get_linestr;
+    if (substr($linestr, $Offset, length($_[0])) eq $_[0]) {
+      substr($linestr, $Offset, length($_[0])) = '';
+      Devel::Declare::set_linestr($linestr);
+      return 1;
+    }
+    return 0;
+  }
+
+  sub parser {
+    my $pack = shift;
+    local ($Declarator, $Offset) = @_;
+    skip_declarator;
+    skipspace;
+    my $name = strip_name;
+    skipspace if defined($name);
+    my $proto = strip_proto;
+    skipspace if defined($proto);
+    my $linestr = Devel::Declare::get_linestr;
+    if (substr($linestr, $Offset, 1) eq '{') {
+      my $inject = 'my ($self';
+      if (defined $proto) {
+        $inject .= ", $proto" if length($proto);
+        $inject .= ') = @_; ';
+      } else {
+        $inject .= ') = shift;';
+      }
+      if (defined $name) {
+        $inject = ' BEGIN { MethodHandlers::inject_scope }; '.$inject;
+      }
+      substr($linestr, $Offset+1, 0) = $inject;
+      Devel::Declare::set_linestr($linestr);
+    }
+    if (defined $name) {
+      $name = join('::', $pack, $name) unless ($name =~ /::/);
+      shadow(sub (&) { no strict 'refs'; *{$name} = shift; });
+    } else {
+      shadow(sub (&) { shift });
+    }
+  }
+
+  sub inject_scope {
+    $^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);
+    });
+  }
+}
+
+my ($test_method1, $test_method2, @test_list);
+
+{
+  package DeclareTest;
+
+  sub method (&);
+
+  BEGIN {
+    Devel::Declare->setup_for(
+      __PACKAGE__,
+      { method => { const => sub { MethodHandlers::parser(__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');

diff --git a/t/new.t b/t/new.t
new file mode 100644 (file)
index 0000000..dc1d6ed
--- /dev/null
+++ b/t/new.t
@@ -0,0 +1,103 @@
+use Devel::Declare ();
+use Test::More qw(no_plan);
+
+{
+  package FoomHandlers;
+
+  use strict;
+  use warnings;
+
+  our ($Declarator, $Offset);
+
+  sub skip_declarator {
+    $Offset += Devel::Declare::toke_move_past_token($Offset);
+  }
+
+  sub skipspace {
+    $Offset += Devel::Declare::toke_skipspace($Offset);
+  }
+
+  sub strip_name {
+    skipspace;
+    if (my $len = Devel::Declare::toke_scan_word($Offset, 1)) {
+      my $linestr = Devel::Declare::get_linestr();
+      my $name = substr($linestr, $Offset, $len);
+      substr($linestr, $Offset, $len) = '';
+      Devel::Declare::set_linestr($linestr);
+      return $name;
+    }
+    return;
+  }
+
+  sub strip_proto {
+    skipspace;
+    
+    my $linestr = Devel::Declare::get_linestr();
+    if (substr($linestr, $Offset, 1) eq '(') {
+      my $length = Devel::Declare::toke_scan_str($Offset);
+      my $proto = Devel::Declare::get_lex_stuff();
+      Devel::Declare::clear_lex_stuff();
+      $linestr = Devel::Declare::get_linestr();
+      substr($linestr, $Offset, $length) = '';
+      Devel::Declare::set_linestr($linestr);
+      return $proto;
+    }
+    return;
+  }
+
+  sub shadow {
+    my $pack = Devel::Declare::get_curstash_name;
+    Devel::Declare::shadow_sub("${pack}::${Declarator}", $_[0]);
+  }
+
+  sub inject_str {
+    my $linestr = Devel::Declare::get_linestr;
+    substr($linestr, $Offset, 0) = $_[0];
+    Devel::Declare::set_linestr($linestr);
+  }
+
+  sub strip_str {
+    my $linestr = Devel::Declare::get_linestr;
+    if (substr($linestr, $Offset, length($_[0])) eq $_[0]) {
+      substr($linestr, $Offset, length($_[0])) = '';
+      Devel::Declare::set_linestr($linestr);
+      return 1;
+    }
+    return 0;
+  }
+
+  sub const {
+    local ($Declarator, $Offset) = @_;
+    skip_declarator;
+    my $name = strip_name;
+    my $str = "happy ".(defined $name ? "foom: ${name}" : "anonymous foom");
+    if (defined(my $proto = strip_proto)) {
+      $str .= "; ${proto}";
+    }
+    shadow(sub { $str });
+  }
+
+  package Foo;
+
+  use strict;
+  use warnings;
+
+  sub foom { }
+
+  BEGIN {
+    Devel::Declare->setup_for(
+      __PACKAGE__,
+      { foom => {
+          const => \&FoomHandlers::const,
+      } }
+    );
+  }
+
+  ::is(foom, "happy anonymous foom", "foom");
+
+  ::is(foom KABOOM, "happy foom: KABOOM", "foom KABOOM");
+
+  ::is(foom (zoom), "happy anonymous foom; zoom", "foom (zoom)");
+
+  ::is(foom KABOOM (zoom), "happy foom: KABOOM; zoom", "foom KABOOM (zoom)");
+}

diff --git a/t/statement.t b/t/statement.t
new file mode 100644 (file)
index 0000000..bccc35f
--- /dev/null
+++ b/t/statement.t
@@ -0,0 +1,113 @@
+use Devel::Declare ();
+use Test::More qw(no_plan);
+use Scope::Guard;
+
+{
+  package FoomHandlers;
+
+  use strict;
+  use warnings;
+
+  our ($Declarator, $Offset);
+
+  sub skip_declarator {
+    $Offset += Devel::Declare::toke_move_past_token($Offset);
+  }
+
+  sub skipspace {
+    $Offset += Devel::Declare::toke_skipspace($Offset);
+  }
+
+  sub strip_name {
+    skipspace;
+    if (my $len = Devel::Declare::toke_scan_word($Offset, 1)) {
+      my $linestr = Devel::Declare::get_linestr();
+      my $name = substr($linestr, $Offset, $len);
+      substr($linestr, $Offset, $len) = '';
+      Devel::Declare::set_linestr($linestr);
+      return $name;
+    }
+    return;
+  }
+
+  sub strip_proto {
+    skipspace;
+    
+    my $linestr = Devel::Declare::get_linestr();
+    if (substr($linestr, $Offset, 1) eq '(') {
+      my $length = Devel::Declare::toke_scan_str($Offset);
+      my $proto = Devel::Declare::get_lex_stuff();
+      Devel::Declare::clear_lex_stuff();
+      $linestr = Devel::Declare::get_linestr();
+      substr($linestr, $Offset, $length) = '';
+      Devel::Declare::set_linestr($linestr);
+      return $proto;
+    }
+    return;
+  }
+
+  sub shadow {
+    my $pack = Devel::Declare::get_curstash_name;
+    Devel::Declare::shadow_sub("${pack}::${Declarator}", $_[0]);
+  }
+
+  sub inject_str {
+    my $linestr = Devel::Declare::get_linestr;
+    substr($linestr, $Offset, 0) = $_[0];
+    Devel::Declare::set_linestr($linestr);
+  }
+
+  sub strip_str {
+    my $linestr = Devel::Declare::get_linestr;
+    if (substr($linestr, $Offset, length($_[0])) eq $_[0]) {
+      substr($linestr, $Offset, length($_[0])) = '';
+      Devel::Declare::set_linestr($linestr);
+      return 1;
+    }
+    return 0;
+  }
+
+  sub const {
+    local ($Declarator, $Offset) = @_;
+    skip_declarator;
+    skipspace;
+    my $linestr = Devel::Declare::get_linestr;
+    if (substr($linestr, $Offset, 1) eq '{') {
+      substr($linestr, $Offset+1, 0) = ' BEGIN { FoomHandlers::inject_scope }; ';
+      Devel::Declare::set_linestr($linestr);
+    }
+    shadow(sub (&) { "foom?" });
+  }
+
+  sub inject_scope {
+    $^H |= 0x120000;
+    $^H{DD_FOOMHANDLERS} = 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);
+    });
+  }
+
+  package Foo;
+
+  use strict;
+  use warnings;
+
+  sub foom (&) { }
+
+  BEGIN {
+    Devel::Declare->setup_for(
+      __PACKAGE__,
+      { foom => {
+          const => \&FoomHandlers::const,
+      } }
+    );
+  }
+
+  foom {
+    1;
+  }
+
+  ::ok(1, 'Compiled as statement ok');
+}