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

[p5sagit/Devel-Declare.git] / t / new.t

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