1 package Devel::Declare;
7 our $VERSION = '0.001006';
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};
73 my ($usepack, $use, $inpack, $name, $proto) = @_;
74 my ($name_h, $XX_h, $extra_code)
75 = $declarator_handlers{$usepack}{$use}->(
76 $usepack, $use, $inpack, $name, $proto, defined(wantarray)
78 ($temp_name, $temp_save) = ([], []);
80 $name = "${inpack}::${name}" unless $name =~ /::/;
81 push(@$temp_name, $name);
83 push(@$temp_save, \&{$name});
84 no warnings 'redefine';
85 no warnings 'prototype';
89 push(@$temp_name, "${inpack}::X");
91 push(@$temp_save, \&{"${inpack}::X"});
92 no warnings 'redefine';
93 no warnings 'prototype';
94 *{"${inpack}::X"} = $XX_h;
96 if (defined wantarray) {
97 return $extra_code || '0;';
105 my $name = shift(@{$temp_name||[]});
106 die "done_declare called with no temp_name stack" unless defined($name);
107 my $saved = shift(@$temp_save);
110 delete ${"${temp_pack}::"}{$name};
112 no warnings 'prototype';
113 *{"${temp_pack}::${name}"} = $saved;
117 sub build_sub_installer {
118 my ($class, $pack, $name, $proto) = @_;
122 sub ${name} (${proto}) :lvalue {\n"
126 my $ret = $body->(@_);
129 sub { ($body) = @_; };';
132 sub setup_declarators {
133 my ($class, $pack, $to_setup) = @_;
134 die "${class}->setup_declarators(\$pack, \\\%to_setup)"
135 unless defined($pack) && ref($to_setup) eq 'HASH';
137 foreach my $name (keys %$to_setup) {
138 my $info = $to_setup->{$name};
139 my $flags = $info->{flags} || DECLARE_NAME;
140 my $run = $info->{run};
141 my $compile = $info->{compile};
142 my $proto = $info->{proto} || '&';
143 my $sub_proto = $proto;
144 # make all args optional to enable lvalue for DECLARE_NONE
145 $sub_proto =~ s/;//; $sub_proto = ';'.$sub_proto;
146 #my $installer = $class->build_sub_installer($pack, $name, $proto);
147 my $installer = $class->build_sub_installer($pack, $name, '@');
148 $installer->(sub :lvalue {
149 #{ no warnings 'uninitialized'; warn 'INST: '.join(', ', @_)."\n"; }
151 if (ref $_[0] eq 'HASH') {
154 my @ret = $run->(undef, undef, @_);
157 my $r = $run->(undef, undef, @_);
165 $setup_for_args{$name} = [
168 my ($usepack, $use, $inpack, $name, $proto, $shift_hashref) = @_;
169 my $extra_code = $compile->($name, $proto);
170 my $main_handler = sub { shift if $shift_hashref;
171 ("DONE", $run->($name, $proto, @_));
174 if (defined $proto) {
175 $name_h = sub :lvalue { return my $sv; };
177 } elsif (defined $name && length $name) {
178 $name_h = $main_handler;
181 $extra_code = '}, sub {'.$extra_code;
182 return ($name_h, $XX, $extra_code);
186 $class->setup_for($pack, \%setup_for_args);
189 sub install_declarator {
190 my ($class, $target_pack, $target_name, $flags, $filter, $handler) = @_;
191 $class->setup_declarators($target_pack, {
206 Look at the tests. This module is currently on CPAN to ease smoke testing
207 and allow early adopters who've been involved in the design to experiment
214 use Devel::Declare qw(list of subs);
216 Calls Devel::Declare->setup_for(__PACKAGE__ => \@list_of_subs);
222 Calls Devel::Declare->teardown_for(__PACKAGE__);
226 Devel::Declare->setup_for($package => \@subnames);
228 Installs declarator magic (unless already installed) and registers
229 "${package}::$name" for each member of @subnames
233 Devel::Declare->teardown_for($package);
235 Deregisters all subs currently registered for $package and uninstalls
236 declarator magic if number of teardown_for calls matches number of setup_for
241 Matt S Trout - <mst@shadowcat.co.uk>
243 Company: http://www.shadowcat.co.uk/
244 Blog: http://chainsawblues.vox.com/
248 This library is free software under the same terms as perl itself