1 package Devel::Declare;
7 our $VERSION = '0.001010';
9 # mirrored in Declare.xs as DD_HANDLE_*
11 use constant DECLARE_NAME => 1;
12 use constant DECLARE_PROTO => 2;
13 use constant DECLARE_NONE => 4;
14 use constant DECLARE_PACKAGE => 8+1; # name implicit
16 use vars qw(%declarators %declarator_handlers @ISA);
17 use base qw(DynaLoader);
18 use Scalar::Util 'set_prototype';
20 bootstrap Devel::Declare;
25 my ($class, %args) = @_;
27 if (@_ == 1) { # "use Devel::Declare;"
29 foreach my $name (qw(NAME PROTO NONE PACKAGE)) {
30 *{"${target}::DECLARE_${name}"} = *{"DECLARE_${name}"};
33 $class->setup_for($target => \%args);
40 $class->teardown_for($target);
44 my ($class, $target, $args) = @_;
46 foreach my $key (keys %$args) {
47 my $info = $args->{$key};
49 if (ref($info) eq 'ARRAY') {
50 ($flags, $sub) = @$info;
51 } elsif (ref($info) eq 'CODE') {
52 $flags = DECLARE_NAME;
55 die "Info for sub ${key} must be [ \$flags, \$sub ] or \$sub";
57 $declarators{$target}{$key} = $flags;
58 $declarator_handlers{$target}{$key} = $sub;
63 my ($class, $target) = @_;
64 delete $declarators{$target};
65 delete $declarator_handlers{$target};
72 my ($usepack, $use, $inpack, $name, $proto, $traits) = @_;
73 my ($name_h, $XX_h, $extra_code)
74 = $declarator_handlers{$usepack}{$use}->(
75 $usepack, $use, $inpack, $name, $proto, defined(wantarray), $traits
77 ($temp_name, $temp_save) = ([], []);
79 $name = "${inpack}::${name}" unless $name =~ /::/;
80 push(@$temp_name, $name);
82 push(@$temp_save, \&{$name});
83 no warnings 'redefine';
84 no warnings 'prototype';
88 push(@$temp_name, "${inpack}::X");
90 push(@$temp_save, \&{"${inpack}::X"});
91 no warnings 'redefine';
92 no warnings 'prototype';
93 *{"${inpack}::X"} = $XX_h;
95 if (defined wantarray) {
96 return $extra_code || '0;';
104 my $name = shift(@{$temp_name||[]});
105 die "done_declare called with no temp_name stack" unless defined($name);
106 my $saved = shift(@$temp_save);
109 delete ${"${temp_pack}::"}{$name};
111 no warnings 'prototype';
112 *{"${temp_pack}::${name}"} = $saved;
116 sub build_sub_installer {
117 my ($class, $pack, $name, $proto) = @_;
121 sub ${name} (${proto}) :lvalue {\n"
125 my $ret = $body->(@_);
128 sub { ($body) = @_; };';
131 sub setup_declarators {
132 my ($class, $pack, $to_setup) = @_;
133 die "${class}->setup_declarators(\$pack, \\\%to_setup)"
134 unless defined($pack) && ref($to_setup) eq 'HASH';
136 foreach my $name (keys %$to_setup) {
137 my $info = $to_setup->{$name};
138 my $flags = $info->{flags} || DECLARE_NAME;
139 my $run = $info->{run};
140 my $compile = $info->{compile};
141 my $proto = $info->{proto} || '&';
142 my $sub_proto = $proto;
143 # make all args optional to enable lvalue for DECLARE_NONE
144 $sub_proto =~ s/;//; $sub_proto = ';'.$sub_proto;
145 #my $installer = $class->build_sub_installer($pack, $name, $proto);
146 my $installer = $class->build_sub_installer($pack, $name, '@');
147 $installer->(sub :lvalue {
148 #{ no warnings 'uninitialized'; warn 'INST: '.join(', ', @_)."\n"; }
150 if (ref $_[0] eq 'HASH') {
153 my @ret = $run->(undef, undef, @_);
156 my $r = $run->(undef, undef, @_);
164 $setup_for_args{$name} = [
167 my ($usepack, $use, $inpack, $name, $proto, $shift_hashref, $traits) = @_;
168 my $extra_code = $compile->($name, $proto, $traits);
169 my $main_handler = sub { shift if $shift_hashref;
170 ("DONE", $run->($name, $proto, @_));
173 if (defined $proto) {
174 $name_h = sub :lvalue { return my $sv; };
176 } elsif (defined $name && length $name) {
177 $name_h = $main_handler;
180 $extra_code = '}, sub {'.$extra_code;
181 return ($name_h, $XX, $extra_code);
185 $class->setup_for($pack, \%setup_for_args);
188 sub install_declarator {
189 my ($class, $target_pack, $target_name, $flags, $filter, $handler) = @_;
190 $class->setup_declarators($target_pack, {
205 Look at the tests. This module is currently on CPAN to ease smoke testing
206 and allow early adopters who've been involved in the design to experiment
213 use Devel::Declare qw(list of subs);
215 Calls Devel::Declare->setup_for(__PACKAGE__ => \@list_of_subs);
221 Calls Devel::Declare->teardown_for(__PACKAGE__);
225 Devel::Declare->setup_for($package => \@subnames);
227 Installs declarator magic (unless already installed) and registers
228 "${package}::$name" for each member of @subnames
232 Devel::Declare->teardown_for($package);
234 Deregisters all subs currently registered for $package and uninstalls
235 declarator magic if number of teardown_for calls matches number of setup_for
240 Matt S Trout - <mst@shadowcat.co.uk>
242 Company: http://www.shadowcat.co.uk/
243 Blog: http://chainsawblues.vox.com/
247 This library is free software under the same terms as perl itself