get_linestr works, callback code works, set_linestr compiles but not tested

[p5sagit/Devel-Declare.git] / lib / Devel / Declare.pm

diff --git a/lib/Devel/Declare.pm b/lib/Devel/Declare.pm
index 8d0f5a5..de0ae81 100644 (file)
--- a/lib/Devel/Declare.pm
+++ b/lib/Devel/Declare.pm
@@ -4,7 +4,7 @@ use strict;
 use warnings;
 use 5.008001;
 
-our $VERSION = 0.001000;
+our $VERSION = '0.001011';
 
 # mirrored in Declare.xs as DD_HANDLE_*
 
@@ -63,17 +63,16 @@ sub teardown_for {
   my ($class, $target) = @_;
   delete $declarators{$target};
   delete $declarator_handlers{$target};
-  teardown();
 }
 
 my $temp_name;
 my $temp_save;
 
 sub init_declare {
-  my ($usepack, $use, $inpack, $name, $proto) = @_;
+  my ($usepack, $use, $inpack, $name, $proto, $traits) = @_;
   my ($name_h, $XX_h, $extra_code)
        = $declarator_handlers{$usepack}{$use}->(
-           $usepack, $use, $inpack, $name, $proto, defined(wantarray)
+           $usepack, $use, $inpack, $name, $proto, defined(wantarray), $traits
          );
   ($temp_name, $temp_save) = ([], []);
   if ($name) {
@@ -120,7 +119,10 @@ sub build_sub_installer {
     package ${pack};
     my \$body;
     sub ${name} (${proto}) :lvalue {\n"
-    .'my $ret = $body->(@_);
+    .'  if (wantarray) {
+        goto &$body;
+      }
+      my $ret = $body->(@_);
       return $ret;
     };
     sub { ($body) = @_; };';
@@ -142,35 +144,40 @@ sub setup_declarators {
     $sub_proto =~ s/;//; $sub_proto = ';'.$sub_proto;
     #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, @_);
+#{ no warnings 'uninitialized'; warn 'INST: '.join(', ', @_)."\n"; }
+      if (@_) {
+        if (ref $_[0] eq 'HASH') {
+          shift;
+          if (wantarray) {
+            my @ret = $run->(undef, undef, @_);
+            return @ret;
+          }
+          my $r = $run->(undef, undef, @_);
+          return $r;
+        } else {
+          return @_[1..$#_];
+        }
       }
       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 ($usepack, $use, $inpack, $name, $proto, $shift_hashref, $traits) = @_;
+        my $extra_code = $compile->($name, $proto, $traits);
+        my $main_handler = sub { shift if $shift_hashref;
+          ("DONE", $run->($name, $proto, @_));
+        };
         my ($name_h, $XX);
         if (defined $proto) {
           $name_h = sub :lvalue { return my $sv; };
           $XX = $main_handler;
-        } else {
+        } elsif (defined $name && length $name) {
           $name_h = $main_handler;
         }
+        $extra_code ||= '';
+        $extra_code = '}, sub {'.$extra_code;
         return ($name_h, $XX, $extra_code);
       }
     ];
@@ -189,12 +196,30 @@ sub install_declarator {
   });
 }
 
+sub linestr_callback_const {
+  warn "Linestr_callback_const: @_\n";
+  my $l = get_linestr();
+  warn "linestr: ${l}\n";
+  warn "w/offset: ".substr($l, $_[1])."\n";
+}
+
+sub linestr_callback {
+  my $type = shift;
+  my $meth = "linestr_callback_${type}";
+  __PACKAGE__->can($meth)->(@_);
+  return 'foo';
+}
+
 =head1 NAME
 
 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
@@ -226,9 +251,9 @@ calls.
 
 =head1 AUTHOR
 
-Matt S Trout - <mst@shadowcatsystems.co.uk>
+Matt S Trout - <mst@shadowcat.co.uk>
 
-Company: http://www.shadowcatsystems.co.uk/
+Company: http://www.shadowcat.co.uk/
 Blog: http://chainsawblues.vox.com/
 
 =head1 LICENSE