1 package Devel::Declare;
7 our $VERSION = '0.001001';
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, {
211 use Devel::Declare qw(list of subs);
213 Calls Devel::Declare->setup_for(__PACKAGE__ => \@list_of_subs);
219 Calls Devel::Declare->teardown_for(__PACKAGE__);
223 Devel::Declare->setup_for($package => \@subnames);
225 Installs declarator magic (unless already installed) and registers
226 "${package}::$name" for each member of @subnames
230 Devel::Declare->teardown_for($package);
232 Deregisters all subs currently registered for $package and uninstalls
233 declarator magic if number of teardown_for calls matches number of setup_for
238 Matt S Trout - <mst@shadowcat.co.uk>
240 Company: http://www.shadowcat.co.uk/
241 Blog: http://chainsawblues.vox.com/
245 This library is free software under the same terms as perl itself