use warnings;
use 5.008001;
-our $VERSION = 0.001000;
+our $VERSION = '0.001008';
-use vars qw(%declarators);
+# mirrored in Declare.xs as DD_HANDLE_*
+
+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 @ISA);
use base qw(DynaLoader);
+use Scalar::Util 'set_prototype';
bootstrap Devel::Declare;
+@ISA = ();
+
sub import {
- my ($class, @args) = @_;
+ my ($class, %args) = @_;
my $target = caller;
- $class->setup_for($target => \@args);
+ if (@_ == 1) { # "use Devel::Declare;"
+ no strict 'refs';
+ foreach my $name (qw(NAME PROTO NONE PACKAGE)) {
+ *{"${target}::DECLARE_${name}"} = *{"DECLARE_${name}"};
+ }
+ } else {
+ $class->setup_for($target => \%args);
+ }
}
sub unimport {
sub setup_for {
my ($class, $target, $args) = @_;
setup();
- $declarators{$target}{$_} = 1 for @$args;
+ foreach my $key (keys %$args) {
+ my $info = $args->{$key};
+ my ($flags, $sub);
+ if (ref($info) eq 'ARRAY') {
+ ($flags, $sub) = @$info;
+ } elsif (ref($info) eq 'CODE') {
+ $flags = DECLARE_NAME;
+ $sub = $info;
+ } else {
+ die "Info for sub ${key} must be [ \$flags, \$sub ] or \$sub";
+ }
+ $declarators{$target}{$key} = $flags;
+ $declarator_handlers{$target}{$key} = $sub;
+ }
}
sub teardown_for {
my ($class, $target) = @_;
delete $declarators{$target};
- teardown();
+ delete $declarator_handlers{$target};
}
-my $temp_pack;
my $temp_name;
+my $temp_save;
sub init_declare {
- my ($pack, $use, $name) = @_;
- no strict 'refs';
- *{"${pack}::${name}"} = sub (&) { ($pack, $name, $_[0]); };
- ($temp_pack, $temp_name) = ($pack, $name);
+ 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), $traits
+ );
+ ($temp_name, $temp_save) = ([], []);
+ if ($name) {
+ $name = "${inpack}::${name}" unless $name =~ /::/;
+ push(@$temp_name, $name);
+ no strict 'refs';
+ push(@$temp_save, \&{$name});
+ no warnings 'redefine';
+ no warnings 'prototype';
+ *{$name} = $name_h;
+ }
+ if ($XX_h) {
+ push(@$temp_name, "${inpack}::X");
+ no strict 'refs';
+ push(@$temp_save, \&{"${inpack}::X"});
+ no warnings 'redefine';
+ no warnings 'prototype';
+ *{"${inpack}::X"} = $XX_h;
+ }
+ if (defined wantarray) {
+ return $extra_code || '0;';
+ } else {
+ return;
+ }
}
sub done_declare {
no strict 'refs';
- delete ${"${temp_pack}::"}{$temp_name};
+ my $name = shift(@{$temp_name||[]});
+ die "done_declare called with no temp_name stack" unless defined($name);
+ my $saved = shift(@$temp_save);
+ $name =~ s/(.*):://;
+ my $temp_pack = $1;
+ delete ${"${temp_pack}::"}{$name};
+ if ($saved) {
+ no warnings 'prototype';
+ *{"${temp_pack}::${name}"} = $saved;
+ }
+}
+
+sub build_sub_installer {
+ my ($class, $pack, $name, $proto) = @_;
+ return eval "
+ package ${pack};
+ my \$body;
+ sub ${name} (${proto}) :lvalue {\n"
+ .' if (wantarray) {
+ goto &$body;
+ }
+ my $ret = $body->(@_);
+ return $ret;
+ };
+ sub { ($body) = @_; };';
+}
+
+sub setup_declarators {
+ my ($class, $pack, $to_setup) = @_;
+ 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;
+ 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);
+ 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,
+ }
+ });
}
=head1 NAME
=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
=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
projects / p5sagit/Devel-Declare.git / blobdiff