From: Matt S Trout <mst@shadowcat.co.uk>
Date: Sat, 20 Sep 2008 14:30:28 +0000 (+0000)
Subject: final tweaking and ChangeLog
X-Git-Tag: 0.005000~92
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=2ee34f20d4433723e6dcd4a91ec011f68f9e3520;p=p5sagit%2FDevel-Declare.git

final tweaking and ChangeLog
---

diff --git a/Changes b/Changes
index e80ef14..a811102 100644
--- a/Changes
+++ b/Changes
@@ -1,5 +1,8 @@
 Changes for Devel-Declare
 
+0.002000
+  - rewrite guts into perl, add tests for new declaration style
+
 0.001011
   - add support for 'method main' and other package names
 
diff --git a/Declare.xs b/Declare.xs
index 52b41b2..34652c9 100644
--- a/Declare.xs
+++ b/Declare.xs
@@ -12,18 +12,10 @@
 # define Newx(v,n,t) New(0,v,n,t)
 #endif /* !Newx */
 
-#if 1
-#define DD_HAS_TRAITS
-#endif
-
 #if 0
 #define DD_DEBUG
 #endif
 
-#define DD_HANDLE_NAME 1
-#define DD_HANDLE_PROTO 2
-#define DD_HANDLE_PACKAGE 8
-
 #ifdef DD_DEBUG
 #define DD_DEBUG_S printf("Buffer: %s\n", s);
 #else
diff --git a/Makefile.PL b/Makefile.PL
index ea6d149..98fefd6 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -7,6 +7,7 @@ all_from 'lib/Devel/Declare.pm';
 
 requires 'Scalar::Util';
 build_requires 'Test::More';
+build_requires 'Scope::Guard';
 
 WriteMakefile(
   dist => {
diff --git a/lib/Devel/Declare.pm b/lib/Devel/Declare.pm
index 72f1f40..c90f6a7 100644
--- a/lib/Devel/Declare.pm
+++ b/lib/Devel/Declare.pm
@@ -4,9 +4,7 @@ use strict;
 use warnings;
 use 5.008001;
 
-our $VERSION = '0.001011';
-
-# mirrored in Declare.xs as DD_HANDLE_*
+our $VERSION = '0.002000';
 
 use constant DECLARE_NAME => 1;
 use constant DECLARE_PROTO => 2;
@@ -291,38 +289,201 @@ Devel::Declare -
 
 =head1 SYNOPSIS
 
-Look at the tests. This module is currently on CPAN to ease smoke testing
-and allow early adopters who've been involved in the design to experiment
-with it.
-
-=head1 DESCRIPTION
-
-=head2 import
-
-  use Devel::Declare qw(list of subs);
-
-Calls Devel::Declare->setup_for(__PACKAGE__ => \@list_of_subs);
-
-=head2 unimport
+  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]);
+    }
+  
+    # 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 inject_if_block {
+      my $inject = shift;
+      skipspace;
+      my $linestr = Devel::Declare::get_linestr;
+      if (substr($linestr, $Offset, 1) eq '{') {
+        substr($linestr, $Offset+1, 0) = $inject;
+        Devel::Declare::set_linestr($linestr);
+      }
+    }
 
-  no Devel::Declare;
+    sub scope_injector_call {
+      return ' BEGIN { MethodHandlers::inject_scope }; ';
+    }
+  
+    sub parser {
+      local ($Declarator, $Offset) = @_;
+      skip_declarator;
+      my $name = strip_name;
+      my $proto = strip_proto;
+      my $inject = make_proto_unwrap($proto);
+      if (defined $name) {
+        $inject = scope_injector_call().$inject;
+      }
+      inject_if_block($inject);
+      if (defined $name) {
+        $name = join('::', Devel::Declare::get_curstash_name(), $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 => \&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');
+
+(this is t/method-no-semi.t in this distribution)
 
-Calls Devel::Declare->teardown_for(__PACKAGE__);
+=head1 DESCRIPTION
 
 =head2 setup_for
 
-  Devel::Declare->setup_for($package => \@subnames);
-
-Installs declarator magic (unless already installed) and registers
-"${package}::$name" for each member of @subnames
-
-=head2 teardown_for
-
-  Devel::Declare->teardown_for($package);
+  Devel::Declare->setup_for(
+    $package,
+    {
+      $name => { $op_type => $sub }
+    }
+  );
 
-Deregisters all subs currently registered for $package and uninstalls
-declarator magic if number of teardown_for calls matches number of setup_for
-calls.
+Currently valid op types: 'check', 'rv2cv'
 
 =head1 AUTHOR
 
diff --git a/t/method.t b/t/method.t
index 7bc3adb..9833e30 100644
--- a/t/method.t
+++ b/t/method.t
@@ -1,5 +1,4 @@
 use Devel::Declare ();
-use Scope::Guard;
 
 {
   package MethodHandlers;
@@ -50,48 +49,43 @@ use Scope::Guard;
     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);
+  # 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 strip_str {
+  sub inject_if_block {
+    my $inject = shift;
+    skipspace;
     my $linestr = Devel::Declare::get_linestr;
-    if (substr($linestr, $Offset, length($_[0])) eq $_[0]) {
-      substr($linestr, $Offset, length($_[0])) = '';
+    if (substr($linestr, $Offset, 1) eq '{') {
+      substr($linestr, $Offset+1, 0) = $inject;
       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);
-    }
+    inject_if_block(
+      make_proto_unwrap($proto)
+    );
     if (defined $name) {
-      $name = join('::', $pack, $name) unless ($name =~ /::/);
+      $name = join('::', Devel::Declare::get_curstash_name(), $name)
+        unless ($name =~ /::/);
       shadow(sub (&) { no strict 'refs'; *{$name} = shift; });
     } else {
       shadow(sub (&) { shift });
@@ -119,26 +113,26 @@ my ($test_method1, $test_method2, @test_list);
   BEGIN {
     Devel::Declare->setup_for(
       __PACKAGE__,
-      { method => { const => sub { MethodHandlers::parser(__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]);
@@ -148,7 +142,7 @@ my ($test_method1, $test_method2, @test_list);
     return join(', ', ref $self, $what);
   };
 
-  method main () { return "main"; }
+  method main () { return "main"; };
 
   @test_list = (method { 1 }, sub { 2 }, method () { 3 }, sub { 4 });