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 db54af1..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_*
 
@@ -13,12 +13,14 @@ use constant DECLARE_PROTO => 2;
 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;
 
+@ISA = ();
+
 sub import {
   my ($class, %args) = @_;
   my $target = caller;
@@ -61,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) {
@@ -100,9 +101,9 @@ sub init_declare {
 
 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 +119,20 @@ sub build_sub_installer {
     package ${pack};
     my \$body;
     sub ${name} (${proto}) :lvalue {\n"
-    .'$body->(@_);
+    .'  if (wantarray) {
+        goto &$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,9 +142,72 @@ sub setup_declarators {
     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, '@');
+    $installer->(sub :lvalue {
+#{ 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, $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;
+        } elsif (defined $name && length $name) {
+          $name_h = $main_handler;
+        }
+        $extra_code ||= '';
+        $extra_code = '}, sub {'.$extra_code;
+        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,
+   }
+  });
+}
+
+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
@@ -147,6 +216,10 @@ 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
@@ -178,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