1 package Devel::Declare;
7 our $VERSION = '0.001002';
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"
123 .'my $ret = $body->(@_);
126 sub { ($body) = @_; };';
129 sub setup_declarators {
130 my ($class, $pack, $to_setup) = @_;
131 die "${class}->setup_declarators(\$pack, \\\%to_setup)"
132 unless defined($pack) && ref($to_setup) eq 'HASH';
134 foreach my $name (keys %$to_setup) {
135 my $info = $to_setup->{$name};
136 my $flags = $info->{flags} || DECLARE_NAME;
137 my $run = $info->{run};
138 my $compile = $info->{compile};
139 my $proto = $info->{proto} || '&';
140 my $sub_proto = $proto;
141 # make all args optional to enable lvalue for DECLARE_NONE
142 $sub_proto =~ s/;//; $sub_proto = ';'.$sub_proto;
143 #my $installer = $class->build_sub_installer($pack, $name, $proto);
144 my $installer = $class->build_sub_installer($pack, $name, '@');
145 my $proto_maker = eval q!
148 sub (!.$sub_proto.q!) {
153 $installer->(sub :lvalue {
155 if (ref $_[0] eq 'HASH') {
157 my $r = $run->(undef, undef, @_);
165 $setup_for_args{$name} = [
168 my ($usepack, $use, $inpack, $name, $proto) = @_;
169 my $extra_code = $compile->($name, $proto);
170 my $main_handler = $proto_maker->(sub {
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;
183 return ($name_h, $XX, $extra_code);
187 $class->setup_for($pack, \%setup_for_args);
190 sub install_declarator {
191 my ($class, $target_pack, $target_name, $flags, $filter, $handler) = @_;
192 $class->setup_declarators($target_pack, {
207 Look at the tests. This module is currently on CPAN to ease smoke testing
208 and allow early adopters who've been involved in the design to experiment
215 use Devel::Declare qw(list of subs);
217 Calls Devel::Declare->setup_for(__PACKAGE__ => \@list_of_subs);
223 Calls Devel::Declare->teardown_for(__PACKAGE__);
227 Devel::Declare->setup_for($package => \@subnames);
229 Installs declarator magic (unless already installed) and registers
230 "${package}::$name" for each member of @subnames
234 Devel::Declare->teardown_for($package);
236 Deregisters all subs currently registered for $package and uninstalls
237 declarator magic if number of teardown_for calls matches number of setup_for
242 Matt S Trout - <mst@shadowcat.co.uk>
244 Company: http://www.shadowcat.co.uk/
245 Blog: http://chainsawblues.vox.com/
249 This library is free software under the same terms as perl itself