Commit | Line | Data |
94caac6e |
1 | package Devel::Declare; |
2 | |
3 | use strict; |
4 | use warnings; |
5 | use 5.008001; |
6 | |
bedac9ff |
7 | our $VERSION = '0.001011'; |
94caac6e |
8 | |
0ba8c7aa |
9 | # mirrored in Declare.xs as DD_HANDLE_* |
10 | |
11 | use constant DECLARE_NAME => 1; |
12 | use constant DECLARE_PROTO => 2; |
53e3ab32 |
13 | use constant DECLARE_NONE => 4; |
15d0d014 |
14 | use constant DECLARE_PACKAGE => 8+1; # name implicit |
0ba8c7aa |
15 | |
86c3de80 |
16 | use vars qw(%declarators %declarator_handlers @ISA); |
94caac6e |
17 | use base qw(DynaLoader); |
323ae557 |
18 | use Scalar::Util 'set_prototype'; |
94caac6e |
19 | |
20 | bootstrap Devel::Declare; |
21 | |
86c3de80 |
22 | @ISA = (); |
23 | |
94caac6e |
24 | sub import { |
0ba8c7aa |
25 | my ($class, %args) = @_; |
94caac6e |
26 | my $target = caller; |
0ba8c7aa |
27 | if (@_ == 1) { # "use Devel::Declare;" |
28 | no strict 'refs'; |
15d0d014 |
29 | foreach my $name (qw(NAME PROTO NONE PACKAGE)) { |
53e3ab32 |
30 | *{"${target}::DECLARE_${name}"} = *{"DECLARE_${name}"}; |
0ba8c7aa |
31 | } |
32 | } else { |
33 | $class->setup_for($target => \%args); |
34 | } |
94caac6e |
35 | } |
36 | |
37 | sub unimport { |
38 | my ($class) = @_; |
39 | my $target = caller; |
40 | $class->teardown_for($target); |
41 | } |
42 | |
43 | sub setup_for { |
44 | my ($class, $target, $args) = @_; |
45 | setup(); |
0ba8c7aa |
46 | foreach my $key (keys %$args) { |
47 | my $info = $args->{$key}; |
48 | my ($flags, $sub); |
49 | if (ref($info) eq 'ARRAY') { |
50 | ($flags, $sub) = @$info; |
51 | } elsif (ref($info) eq 'CODE') { |
52 | $flags = DECLARE_NAME; |
53 | $sub = $info; |
840ebcbb |
54 | } elsif (ref($info) eq 'HASH') { |
55 | $flags = 1; |
56 | $sub = $info; |
0ba8c7aa |
57 | } else { |
840ebcbb |
58 | die "Info for sub ${key} must be [ \$flags, \$sub ] or \$sub or handler hashref"; |
0ba8c7aa |
59 | } |
60 | $declarators{$target}{$key} = $flags; |
61 | $declarator_handlers{$target}{$key} = $sub; |
62 | } |
94caac6e |
63 | } |
64 | |
65 | sub teardown_for { |
66 | my ($class, $target) = @_; |
67 | delete $declarators{$target}; |
0ba8c7aa |
68 | delete $declarator_handlers{$target}; |
94caac6e |
69 | } |
70 | |
94caac6e |
71 | my $temp_name; |
0ba8c7aa |
72 | my $temp_save; |
94caac6e |
73 | |
74 | sub init_declare { |
0f070758 |
75 | my ($usepack, $use, $inpack, $name, $proto, $traits) = @_; |
53e3ab32 |
76 | my ($name_h, $XX_h, $extra_code) |
9026391e |
77 | = $declarator_handlers{$usepack}{$use}->( |
0f070758 |
78 | $usepack, $use, $inpack, $name, $proto, defined(wantarray), $traits |
53e3ab32 |
79 | ); |
15d0d014 |
80 | ($temp_name, $temp_save) = ([], []); |
0ba8c7aa |
81 | if ($name) { |
9026391e |
82 | $name = "${inpack}::${name}" unless $name =~ /::/; |
840ebcbb |
83 | shadow_sub($name, $name_h); |
0ba8c7aa |
84 | } |
85 | if ($XX_h) { |
840ebcbb |
86 | shadow_sub("${inpack}::X", $XX_h); |
0ba8c7aa |
87 | } |
53e3ab32 |
88 | if (defined wantarray) { |
89 | return $extra_code || '0;'; |
90 | } else { |
91 | return; |
92 | } |
94caac6e |
93 | } |
94 | |
840ebcbb |
95 | sub shadow_sub { |
96 | my ($name, $cr) = @_; |
97 | push(@$temp_name, $name); |
98 | no strict 'refs'; |
99 | my ($pack, $pname) = ($name =~ m/(.+)::([^:]+)/); |
100 | push(@$temp_save, $pack->can($pname)); |
101 | delete ${"${pack}::"}{$pname}; |
102 | no warnings 'redefine'; |
103 | no warnings 'prototype'; |
104 | *{$name} = $cr; |
105 | set_in_declare(~~@{$temp_name||[]}); |
106 | } |
107 | |
94caac6e |
108 | sub done_declare { |
109 | no strict 'refs'; |
86c3de80 |
110 | my $name = shift(@{$temp_name||[]}); |
0ba8c7aa |
111 | die "done_declare called with no temp_name stack" unless defined($name); |
86c3de80 |
112 | my $saved = shift(@$temp_save); |
15d0d014 |
113 | $name =~ s/(.*):://; |
114 | my $temp_pack = $1; |
0ba8c7aa |
115 | delete ${"${temp_pack}::"}{$name}; |
116 | if ($saved) { |
117 | no warnings 'prototype'; |
118 | *{"${temp_pack}::${name}"} = $saved; |
119 | } |
840ebcbb |
120 | set_in_declare(~~@{$temp_name||[]}); |
94caac6e |
121 | } |
122 | |
323ae557 |
123 | sub build_sub_installer { |
124 | my ($class, $pack, $name, $proto) = @_; |
125 | return eval " |
126 | package ${pack}; |
127 | my \$body; |
128 | sub ${name} (${proto}) :lvalue {\n" |
003ac394 |
129 | .' if (wantarray) { |
c5912dc7 |
130 | goto &$body; |
003ac394 |
131 | } |
132 | my $ret = $body->(@_); |
86c3de80 |
133 | return $ret; |
323ae557 |
134 | }; |
135 | sub { ($body) = @_; };'; |
136 | } |
137 | |
138 | sub setup_declarators { |
139 | my ($class, $pack, $to_setup) = @_; |
86c3de80 |
140 | die "${class}->setup_declarators(\$pack, \\\%to_setup)" |
141 | unless defined($pack) && ref($to_setup) eq 'HASH'; |
142 | my %setup_for_args; |
323ae557 |
143 | foreach my $name (keys %$to_setup) { |
144 | my $info = $to_setup->{$name}; |
145 | my $flags = $info->{flags} || DECLARE_NAME; |
146 | my $run = $info->{run}; |
147 | my $compile = $info->{compile}; |
148 | my $proto = $info->{proto} || '&'; |
149 | my $sub_proto = $proto; |
150 | # make all args optional to enable lvalue for DECLARE_NONE |
151 | $sub_proto =~ s/;//; $sub_proto = ';'.$sub_proto; |
86c3de80 |
152 | #my $installer = $class->build_sub_installer($pack, $name, $proto); |
153 | my $installer = $class->build_sub_installer($pack, $name, '@'); |
86c3de80 |
154 | $installer->(sub :lvalue { |
003ac394 |
155 | #{ no warnings 'uninitialized'; warn 'INST: '.join(', ', @_)."\n"; } |
c5534496 |
156 | if (@_) { |
157 | if (ref $_[0] eq 'HASH') { |
158 | shift; |
003ac394 |
159 | if (wantarray) { |
160 | my @ret = $run->(undef, undef, @_); |
161 | return @ret; |
162 | } |
c5534496 |
163 | my $r = $run->(undef, undef, @_); |
164 | return $r; |
165 | } else { |
003ac394 |
166 | return @_[1..$#_]; |
c5534496 |
167 | } |
86c3de80 |
168 | } |
169 | return my $sv; |
170 | }); |
171 | $setup_for_args{$name} = [ |
172 | $flags, |
173 | sub { |
0f070758 |
174 | my ($usepack, $use, $inpack, $name, $proto, $shift_hashref, $traits) = @_; |
175 | my $extra_code = $compile->($name, $proto, $traits); |
003ac394 |
176 | my $main_handler = sub { shift if $shift_hashref; |
c5534496 |
177 | ("DONE", $run->($name, $proto, @_)); |
003ac394 |
178 | }; |
86c3de80 |
179 | my ($name_h, $XX); |
180 | if (defined $proto) { |
181 | $name_h = sub :lvalue { return my $sv; }; |
182 | $XX = $main_handler; |
c5534496 |
183 | } elsif (defined $name && length $name) { |
86c3de80 |
184 | $name_h = $main_handler; |
185 | } |
003ac394 |
186 | $extra_code ||= ''; |
187 | $extra_code = '}, sub {'.$extra_code; |
86c3de80 |
188 | return ($name_h, $XX, $extra_code); |
189 | } |
190 | ]; |
323ae557 |
191 | } |
86c3de80 |
192 | $class->setup_for($pack, \%setup_for_args); |
193 | } |
194 | |
195 | sub install_declarator { |
196 | my ($class, $target_pack, $target_name, $flags, $filter, $handler) = @_; |
197 | $class->setup_declarators($target_pack, { |
198 | $target_name => { |
199 | flags => $flags, |
200 | compile => $filter, |
201 | run => $handler, |
202 | } |
203 | }); |
323ae557 |
204 | } |
205 | |
04a8a223 |
206 | sub linestr_callback_rv2cv { |
207 | my ($name, $offset) = @_; |
208 | $offset += toke_move_past_token($offset); |
209 | my $pack = get_curstash_name(); |
210 | my $flags = $declarators{$pack}{$name}; |
211 | my ($found_name, $found_proto); |
04a8a223 |
212 | if ($flags & DECLARE_NAME) { |
213 | $offset += toke_skipspace($offset); |
214 | my $linestr = get_linestr(); |
215 | if (substr($linestr, $offset, 2) eq '::') { |
216 | substr($linestr, $offset, 2) = ''; |
217 | set_linestr($linestr); |
218 | } |
219 | if (my $len = toke_scan_word($offset, $flags & DECLARE_PACKAGE)) { |
220 | $found_name = substr($linestr, $offset, $len); |
221 | $offset += $len; |
04a8a223 |
222 | } |
223 | } |
224 | if ($flags & DECLARE_PROTO) { |
225 | $offset += toke_skipspace($offset); |
226 | my $linestr = get_linestr(); |
227 | if (substr($linestr, $offset, 1) eq '(') { |
228 | my $length = toke_scan_str($offset); |
229 | $found_proto = get_lex_stuff(); |
230 | clear_lex_stuff(); |
231 | my $replace = |
232 | ($found_name ? ' ' : '=') |
233 | .'X'.(' ' x length($found_proto)); |
234 | $linestr = get_linestr(); |
235 | substr($linestr, $offset, $length) = $replace; |
236 | set_linestr($linestr); |
237 | $offset += $length; |
04a8a223 |
238 | } |
239 | } |
240 | my @args = ($pack, $name, $pack, $found_name, $found_proto); |
04a8a223 |
241 | $offset += toke_skipspace($offset); |
242 | my $linestr = get_linestr(); |
243 | if (substr($linestr, $offset, 1) eq '{') { |
244 | my $ret = init_declare(@args); |
245 | $offset++; |
246 | if (defined $ret && length $ret) { |
247 | substr($linestr, $offset, 0) = $ret; |
248 | set_linestr($linestr); |
249 | } |
250 | } else { |
251 | init_declare(@args); |
252 | } |
253 | #warn "linestr now ${linestr}"; |
254 | } |
255 | |
569ac469 |
256 | sub linestr_callback_const { |
04a8a223 |
257 | my ($name, $offset) = @_; |
258 | my $pack = get_curstash_name(); |
259 | my $flags = $declarators{$pack}{$name}; |
260 | if ($flags & DECLARE_NAME) { |
261 | $offset += toke_move_past_token($offset); |
262 | $offset += toke_skipspace($offset); |
263 | if (toke_scan_word($offset, $flags & DECLARE_PACKAGE)) { |
264 | my $linestr = get_linestr(); |
265 | substr($linestr, $offset, 0) = '::'; |
266 | set_linestr($linestr); |
267 | } |
268 | } |
569ac469 |
269 | } |
270 | |
271 | sub linestr_callback { |
272 | my $type = shift; |
840ebcbb |
273 | my $name = $_[0]; |
274 | my $pack = get_curstash_name(); |
275 | my $handlers = $declarator_handlers{$pack}{$name}; |
276 | if (ref $handlers eq 'CODE') { |
277 | my $meth = "linestr_callback_${type}"; |
278 | __PACKAGE__->can($meth)->(@_); |
279 | } elsif (ref $handlers eq 'HASH') { |
280 | if ($handlers->{$type}) { |
281 | $handlers->{$type}->(@_); |
282 | } |
283 | } else { |
284 | die "PANIC: unknown thing in handlers for $pack $name: $handlers"; |
285 | } |
569ac469 |
286 | } |
287 | |
94caac6e |
288 | =head1 NAME |
289 | |
290 | Devel::Declare - |
291 | |
292 | =head1 SYNOPSIS |
293 | |
f5f9f113 |
294 | Look at the tests. This module is currently on CPAN to ease smoke testing |
295 | and allow early adopters who've been involved in the design to experiment |
296 | with it. |
297 | |
94caac6e |
298 | =head1 DESCRIPTION |
299 | |
300 | =head2 import |
301 | |
302 | use Devel::Declare qw(list of subs); |
303 | |
304 | Calls Devel::Declare->setup_for(__PACKAGE__ => \@list_of_subs); |
305 | |
306 | =head2 unimport |
307 | |
308 | no Devel::Declare; |
309 | |
310 | Calls Devel::Declare->teardown_for(__PACKAGE__); |
311 | |
312 | =head2 setup_for |
313 | |
314 | Devel::Declare->setup_for($package => \@subnames); |
315 | |
316 | Installs declarator magic (unless already installed) and registers |
317 | "${package}::$name" for each member of @subnames |
318 | |
319 | =head2 teardown_for |
320 | |
321 | Devel::Declare->teardown_for($package); |
322 | |
323 | Deregisters all subs currently registered for $package and uninstalls |
324 | declarator magic if number of teardown_for calls matches number of setup_for |
325 | calls. |
326 | |
327 | =head1 AUTHOR |
328 | |
02f5a508 |
329 | Matt S Trout - <mst@shadowcat.co.uk> |
94caac6e |
330 | |
02f5a508 |
331 | Company: http://www.shadowcat.co.uk/ |
94caac6e |
332 | Blog: http://chainsawblues.vox.com/ |
333 | |
334 | =head1 LICENSE |
335 | |
336 | This library is free software under the same terms as perl itself |
337 | |
338 | =cut |
339 | |
340 | 1; |