1 package Devel::Declare;
7 our $VERSION = '0.001011';
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, {
199 sub linestr_callback_rv2cv {
200 my ($name, $offset) = @_;
201 $offset += toke_move_past_token($offset);
202 my $pack = get_curstash_name();
203 my $flags = $declarators{$pack}{$name};
204 my ($found_name, $found_proto);
206 if ($flags & DECLARE_NAME) {
207 $offset += toke_skipspace($offset);
208 my $linestr = get_linestr();
209 if (substr($linestr, $offset, 2) eq '::') {
210 substr($linestr, $offset, 2) = '';
211 set_linestr($linestr);
213 if (my $len = toke_scan_word($offset, $flags & DECLARE_PACKAGE)) {
214 $found_name = substr($linestr, $offset, $len);
219 if ($flags & DECLARE_PROTO) {
220 $offset += toke_skipspace($offset);
221 my $linestr = get_linestr();
222 if (substr($linestr, $offset, 1) eq '(') {
223 my $length = toke_scan_str($offset);
224 $found_proto = get_lex_stuff();
227 ($found_name ? ' ' : '=')
228 .'X'.(' ' x length($found_proto));
229 $linestr = get_linestr();
230 substr($linestr, $offset, $length) = $replace;
231 set_linestr($linestr);
236 my @args = ($pack, $name, $pack, $found_name, $found_proto);
237 set_in_declare($in_declare);
238 $offset += toke_skipspace($offset);
239 my $linestr = get_linestr();
240 if (substr($linestr, $offset, 1) eq '{') {
241 my $ret = init_declare(@args);
243 if (defined $ret && length $ret) {
244 substr($linestr, $offset, 0) = $ret;
245 set_linestr($linestr);
250 #warn "linestr now ${linestr}";
253 sub linestr_callback_const {
254 my ($name, $offset) = @_;
255 my $pack = get_curstash_name();
256 my $flags = $declarators{$pack}{$name};
257 if ($flags & DECLARE_NAME) {
258 $offset += toke_move_past_token($offset);
259 $offset += toke_skipspace($offset);
260 if (toke_scan_word($offset, $flags & DECLARE_PACKAGE)) {
261 my $linestr = get_linestr();
262 substr($linestr, $offset, 0) = '::';
263 set_linestr($linestr);
268 sub linestr_callback {
270 my $meth = "linestr_callback_${type}";
271 __PACKAGE__->can($meth)->(@_);
280 Look at the tests. This module is currently on CPAN to ease smoke testing
281 and allow early adopters who've been involved in the design to experiment
288 use Devel::Declare qw(list of subs);
290 Calls Devel::Declare->setup_for(__PACKAGE__ => \@list_of_subs);
296 Calls Devel::Declare->teardown_for(__PACKAGE__);
300 Devel::Declare->setup_for($package => \@subnames);
302 Installs declarator magic (unless already installed) and registers
303 "${package}::$name" for each member of @subnames
307 Devel::Declare->teardown_for($package);
309 Deregisters all subs currently registered for $package and uninstalls
310 declarator magic if number of teardown_for calls matches number of setup_for
315 Matt S Trout - <mst@shadowcat.co.uk>
317 Company: http://www.shadowcat.co.uk/
318 Blog: http://chainsawblues.vox.com/
322 This library is free software under the same terms as perl itself