[Bast-commits] r4831 - in trunk/Devel-Declare: . lib/Devel t

matthewt at dev.catalyst.perl.org matthewt at dev.catalyst.perl.org
Sat Sep 20 15:30:28 BST 2008


Author: matthewt
Date: 2008-09-20 15:30:28 +0100 (Sat, 20 Sep 2008)
New Revision: 4831

Modified:
   trunk/Devel-Declare/Changes
   trunk/Devel-Declare/Declare.xs
   trunk/Devel-Declare/Makefile.PL
   trunk/Devel-Declare/lib/Devel/Declare.pm
   trunk/Devel-Declare/t/method.t
Log:
final tweaking and ChangeLog

Modified: trunk/Devel-Declare/Changes
===================================================================
--- trunk/Devel-Declare/Changes	2008-09-20 14:22:27 UTC (rev 4830)
+++ trunk/Devel-Declare/Changes	2008-09-20 14:30:28 UTC (rev 4831)
@@ -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
 

Modified: trunk/Devel-Declare/Declare.xs
===================================================================
--- trunk/Devel-Declare/Declare.xs	2008-09-20 14:22:27 UTC (rev 4830)
+++ trunk/Devel-Declare/Declare.xs	2008-09-20 14:30:28 UTC (rev 4831)
@@ -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

Modified: trunk/Devel-Declare/Makefile.PL
===================================================================
--- trunk/Devel-Declare/Makefile.PL	2008-09-20 14:22:27 UTC (rev 4830)
+++ trunk/Devel-Declare/Makefile.PL	2008-09-20 14:30:28 UTC (rev 4831)
@@ -7,6 +7,7 @@
 
 requires 'Scalar::Util';
 build_requires 'Test::More';
+build_requires 'Scope::Guard';
 
 WriteMakefile(
   dist => {

Modified: trunk/Devel-Declare/lib/Devel/Declare.pm
===================================================================
--- trunk/Devel-Declare/lib/Devel/Declare.pm	2008-09-20 14:22:27 UTC (rev 4830)
+++ trunk/Devel-Declare/lib/Devel/Declare.pm	2008-09-20 14:30:28 UTC (rev 4831)
@@ -4,10 +4,8 @@
 use warnings;
 use 5.008001;
 
-our $VERSION = '0.001011';
+our $VERSION = '0.002000';
 
-# mirrored in Declare.xs as DD_HANDLE_*
-
 use constant DECLARE_NAME => 1;
 use constant DECLARE_PROTO => 2;
 use constant DECLARE_NONE => 4;
@@ -291,39 +289,202 @@
 
 =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.
+  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);
+      }
+    }
 
-=head1 DESCRIPTION
+    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');
 
-=head2 import
+(this is t/method-no-semi.t in this distribution)
 
-  use Devel::Declare qw(list of subs);
+=head1 DESCRIPTION
 
-Calls Devel::Declare->setup_for(__PACKAGE__ => \@list_of_subs);
-
-=head2 unimport
-
-  no Devel::Declare;
-
-Calls Devel::Declare->teardown_for(__PACKAGE__);
-
 =head2 setup_for
 
-  Devel::Declare->setup_for($package => \@subnames);
+  Devel::Declare->setup_for(
+    $package,
+    {
+      $name => { $op_type => $sub }
+    }
+  );
 
-Installs declarator magic (unless already installed) and registers
-"${package}::$name" for each member of @subnames
+Currently valid op types: 'check', 'rv2cv'
 
-=head2 teardown_for
-
-  Devel::Declare->teardown_for($package);
-
-Deregisters all subs currently registered for $package and uninstalls
-declarator magic if number of teardown_for calls matches number of setup_for
-calls.
-
 =head1 AUTHOR
 
 Matt S Trout - <mst at shadowcat.co.uk>

Modified: trunk/Devel-Declare/t/method.t
===================================================================
--- trunk/Devel-Declare/t/method.t	2008-09-20 14:22:27 UTC (rev 4830)
+++ trunk/Devel-Declare/t/method.t	2008-09-20 14:30:28 UTC (rev 4831)
@@ -1,5 +1,4 @@
 use Devel::Declare ();
-use Scope::Guard;
 
 {
   package MethodHandlers;
@@ -50,48 +49,43 @@
     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 @@
   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 @@
     return join(', ', ref $self, $what);
   };
 
-  method main () { return "main"; }
+  method main () { return "main"; };
 
   @test_list = (method { 1 }, sub { 2 }, method () { 3 }, sub { 4 });
 




More information about the Bast-commits mailing list