latest updates

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

diff --git a/lib/Devel/Declare.pm b/lib/Devel/Declare.pm
index c5cab5a..db54af1 100644 (file)
--- a/lib/Devel/Declare.pm
+++ b/lib/Devel/Declare.pm
@@ -10,9 +10,12 @@ our $VERSION = 0.001000;
 
 use constant DECLARE_NAME => 1;
 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 base qw(DynaLoader);
+use Scalar::Util 'set_prototype';
 
 bootstrap Devel::Declare;
 
@@ -21,8 +24,8 @@ sub import {
   my $target = caller;
   if (@_ == 1) { # "use Devel::Declare;"
     no strict 'refs';
-    foreach my $name (qw(DECLARE_NAME DECLARE_PROTO)) {
-      *{"${target}::${name}"} = *{"${name}"};
+    foreach my $name (qw(NAME PROTO NONE PACKAGE)) {
+      *{"${target}::DECLARE_${name}"} = *{"DECLARE_${name}"};
     }
   } else {
     $class->setup_for($target => \%args);
@@ -61,31 +64,37 @@ sub teardown_for {
   teardown();
 }
 
-my $temp_pack;
 my $temp_name;
 my $temp_save;
 
 sub init_declare {
-  my ($pack, $use, $name, $proto) = @_;
-  my ($name_h, $XX_h) = $declarator_handlers{$pack}{$use}->(
-                            $pack, $use, $name, $proto
-                        );
-  ($temp_pack, $temp_name, $temp_save) = ($pack, [], []);
+  my ($usepack, $use, $inpack, $name, $proto) = @_;
+  my ($name_h, $XX_h, $extra_code)
+       = $declarator_handlers{$usepack}{$use}->(
+           $usepack, $use, $inpack, $name, $proto, defined(wantarray)
+         );
+  ($temp_name, $temp_save) = ([], []);
   if ($name) {
+    $name = "${inpack}::${name}" unless $name =~ /::/;
     push(@$temp_name, $name);
     no strict 'refs';
-    push(@$temp_save, \&{"${pack}::${name}"});
+    push(@$temp_save, \&{$name});
     no warnings 'redefine';
     no warnings 'prototype';
-    *{"${pack}::${name}"} = $name_h;
+    *{$name} = $name_h;
   }
   if ($XX_h) {
-    push(@$temp_name, 'X');
+    push(@$temp_name, "${inpack}::X");
     no strict 'refs';
-    push(@$temp_save, \&{"${pack}::X"});
+    push(@$temp_save, \&{"${inpack}::X"});
     no warnings 'redefine';
     no warnings 'prototype';
-    *{"${pack}::X"} = $XX_h;
+    *{"${inpack}::X"} = $XX_h;
+  }
+  if (defined wantarray) {
+    return $extra_code || '0;';
+  } else {
+    return;
   }
 }
 
@@ -94,6 +103,8 @@ sub done_declare {
   my $name = pop(@{$temp_name||[]});
   die "done_declare called with no temp_name stack" unless defined($name);
   my $saved = pop(@$temp_save);
+  $name =~ s/(.*):://;
+  my $temp_pack = $1;
   delete ${"${temp_pack}::"}{$name};
   if ($saved) {
     no warnings 'prototype';
@@ -101,6 +112,35 @@ sub done_declare {
   }
 }
 
+sub build_sub_installer {
+  my ($class, $pack, $name, $proto) = @_;
+  return eval "
+    package ${pack};
+    my \$body;
+    sub ${name} (${proto}) :lvalue {\n"
+    .'$body->(@_);
+    };
+    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');
+  foreach my $name (keys %$to_setup) {
+    my $info = $to_setup->{$name};
+    my $flags = $info->{flags} || DECLARE_NAME;
+    my $run = $info->{run};
+    my $compile = $info->{compile};
+    my $proto = $info->{proto} || '&';
+    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 
+  }
+}
+
 =head1 NAME
 
 Devel::Declare -