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

[matthewt at dev.catalyst.perl.org]

Author: matthewt
Date: 2007-09-17 01:43:15 +0100 (Mon, 17 Sep 2007)
New Revision: 3752

Added:
   trunk/Devel-Declare/t/sugar.t
Modified:
   trunk/Devel-Declare/lib/Devel/Declare.pm
Log:
sugar test basically working

Modified: trunk/Devel-Declare/lib/Devel/Declare.pm
===================================================================
--- trunk/Devel-Declare/lib/Devel/Declare.pm	2007-09-16 18:18:13 UTC (rev 3751)
+++ trunk/Devel-Declare/lib/Devel/Declare.pm	2007-09-17 00:43:15 UTC (rev 3752)
@@ -13,12 +13,14 @@
 use constant DECLARE_NONE => 4;
 use constant DECLARE_PACKAGE => 8+1; # name implicit
 
-use vars qw(%declarators %declarator_handlers);
+use vars qw(%declarators %declarator_handlers @ISA);
 use base qw(DynaLoader);
 use Scalar::Util 'set_prototype';
 
 bootstrap Devel::Declare;
 
+ at ISA = ();
+
 sub import {
   my ($class, %args) = @_;
   my $target = caller;
@@ -100,9 +102,9 @@
 
 sub done_declare {
   no strict 'refs';
-  my $name = pop(@{$temp_name||[]});
+  my $name = shift(@{$temp_name||[]});
   die "done_declare called with no temp_name stack" unless defined($name);
-  my $saved = pop(@$temp_save);
+  my $saved = shift(@$temp_save);
   $name =~ s/(.*):://;
   my $temp_pack = $1;
   delete ${"${temp_pack}::"}{$name};
@@ -118,15 +120,17 @@
     package ${pack};
     my \$body;
     sub ${name} (${proto}) :lvalue {\n"
-    .'$body->(@_);
+    .'my $ret = $body->(@_);
+      return $ret;
     };
     sub { ($body) = @_; };';
 }
 
 sub setup_declarators {
   my ($class, $pack, $to_setup) = @_;
-  die "${class}->setup_declarator(\$pack, \\\%to_setup)"
-    unless defined($pack) && ref($to_setup eq 'HASH');
+  die "${class}->setup_declarators(\$pack, \\\%to_setup)"
+    unless defined($pack) && ref($to_setup) eq 'HASH';
+  my %setup_for_args;
   foreach my $name (keys %$to_setup) {
     my $info = $to_setup->{$name};
     my $flags = $info->{flags} || DECLARE_NAME;
@@ -136,11 +140,55 @@
     my $sub_proto = $proto;
     # make all args optional to enable lvalue for DECLARE_NONE
     $sub_proto =~ s/;//; $sub_proto = ';'.$sub_proto;
-    my $installer = $class->build_sub_installer($pack, $name, $proto);
-    # XXX UNCLEAN 
+    #my $installer = $class->build_sub_installer($pack, $name, $proto);
+    my $installer = $class->build_sub_installer($pack, $name, '@');
+    my $proto_maker = eval q!
+      sub {
+        my $body = shift;
+        sub (!.$sub_proto.q!) {
+          $body->(@_);
+        };
+      };
+    !;
+    $installer->(sub :lvalue {
+      if (@_) { warn @_;
+        $run->(undef, undef, @_);
+      }
+      return my $sv;
+    });
+    $setup_for_args{$name} = [
+      $flags,
+      sub {
+        my ($usepack, $use, $inpack, $name, $proto) = @_;
+        my $extra_code = $compile->($name, $proto);
+        my $main_handler = $proto_maker->(sub {
+          $run->($name, $proto, @_);
+        });
+        my ($name_h, $XX);
+        if (defined $proto) {
+          $name_h = sub :lvalue { return my $sv; };
+          $XX = $main_handler;
+        } else {
+          $name_h = $main_handler;
+        }
+        return ($name_h, $XX, $extra_code);
+      }
+    ];
   }
+  $class->setup_for($pack, \%setup_for_args);
 }
 
+sub install_declarator {
+  my ($class, $target_pack, $target_name, $flags, $filter, $handler) = @_;
+  $class->setup_declarators($target_pack, {
+    $target_name => {
+      flags => $flags,
+      compile => $filter,
+      run => $handler,
+   }
+  });
+}
+
 =head1 NAME
 
 Devel::Declare - 

Added: trunk/Devel-Declare/t/sugar.t
===================================================================
--- trunk/Devel-Declare/t/sugar.t	                        (rev 0)
+++ trunk/Devel-Declare/t/sugar.t	2007-09-17 00:43:15 UTC (rev 3752)
@@ -0,0 +1,77 @@
+use Devel::Declare;
+
+BEGIN {
+
+  Devel::Declare->install_declarator(
+    'DeclareTest', 'method', DECLARE_PACKAGE | DECLARE_PROTO,
+    sub {
+      my ($name, $proto) = @_;
+      return 'my $self = shift;' unless defined $proto && $proto ne '@_';
+      return 'my ($self'.(length $proto ? ", ${proto}" : "").') = @_;';
+    },
+    sub {
+      my ($name, $proto, $sub) = @_;
+      if (defined $name && length $name) {
+        unless ($name =~ /::/) {
+          $name = "DeclareTest::${name}";
+        }
+        no strict 'refs';
+        *{$name} = $sub;
+      }
+      return $sub;
+    }
+  );
+
+}
+
+my ($test_method1, $test_method2);
+
+{
+  package DeclareTest;
+
+  method new {
+    my $class = ref $self || $self;
+    return bless({ @_ }, $class);
+  };
+
+  method foo ($foo) {
+    return (ref $self).': Foo: '.$foo;
+  };
+
+  method upgrade () {
+    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);
+  };
+
+}
+
+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');
+
+$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');