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;
54 } elsif (ref($info) eq 'HASH') {
58 die "Info for sub ${key} must be [ \$flags, \$sub ] or \$sub or handler hashref";
60 $declarators{$target}{$key} = $flags;
61 $declarator_handlers{$target}{$key} = $sub;
66 my ($class, $target) = @_;
67 delete $declarators{$target};
68 delete $declarator_handlers{$target};
75 my ($usepack, $use, $inpack, $name, $proto, $traits) = @_;
76 my ($name_h, $XX_h, $extra_code)
77 = $declarator_handlers{$usepack}{$use}->(
78 $usepack, $use, $inpack, $name, $proto, defined(wantarray), $traits
80 ($temp_name, $temp_save) = ([], []);
82 $name = "${inpack}::${name}" unless $name =~ /::/;
83 shadow_sub($name, $name_h);
86 shadow_sub("${inpack}::X", $XX_h);
88 if (defined wantarray) {
89 return $extra_code || '0;';
97 push(@$temp_name, $name);
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';
105 set_in_declare(~~@{$temp_name||[]});
110 my $name = shift(@{$temp_name||[]});
111 die "done_declare called with no temp_name stack" unless defined($name);
112 my $saved = shift(@$temp_save);
115 delete ${"${temp_pack}::"}{$name};
117 no warnings 'prototype';
118 *{"${temp_pack}::${name}"} = $saved;
120 set_in_declare(~~@{$temp_name||[]});
123 sub build_sub_installer {
124 my ($class, $pack, $name, $proto) = @_;
128 sub ${name} (${proto}) :lvalue {\n"
132 my $ret = $body->(@_);
135 sub { ($body) = @_; };';
138 sub setup_declarators {
139 my ($class, $pack, $to_setup) = @_;
140 die "${class}->setup_declarators(\$pack, \\\%to_setup)"
141 unless defined($pack) && ref($to_setup) eq 'HASH';
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;
152 #my $installer = $class->build_sub_installer($pack, $name, $proto);
153 my $installer = $class->build_sub_installer($pack, $name, '@');
154 $installer->(sub :lvalue {
155 #{ no warnings 'uninitialized'; warn 'INST: '.join(', ', @_)."\n"; }
157 if (ref $_[0] eq 'HASH') {
160 my @ret = $run->(undef, undef, @_);
163 my $r = $run->(undef, undef, @_);
171 $setup_for_args{$name} = [
174 my ($usepack, $use, $inpack, $name, $proto, $shift_hashref, $traits) = @_;
175 my $extra_code = $compile->($name, $proto, $traits);
176 my $main_handler = sub { shift if $shift_hashref;
177 ("DONE", $run->($name, $proto, @_));
180 if (defined $proto) {
181 $name_h = sub :lvalue { return my $sv; };
183 } elsif (defined $name && length $name) {
184 $name_h = $main_handler;
187 $extra_code = '}, sub {'.$extra_code;
188 return ($name_h, $XX, $extra_code);
192 $class->setup_for($pack, \%setup_for_args);
195 sub install_declarator {
196 my ($class, $target_pack, $target_name, $flags, $filter, $handler) = @_;
197 $class->setup_declarators($target_pack, {
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);
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);
219 if (my $len = toke_scan_word($offset, $flags & DECLARE_PACKAGE)) {
220 $found_name = substr($linestr, $offset, $len);
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();
232 ($found_name ? ' ' : '=')
233 .'X'.(' ' x length($found_proto));
234 $linestr = get_linestr();
235 substr($linestr, $offset, $length) = $replace;
236 set_linestr($linestr);
240 my @args = ($pack, $name, $pack, $found_name, $found_proto);
241 $offset += toke_skipspace($offset);
242 my $linestr = get_linestr();
243 if (substr($linestr, $offset, 1) eq '{') {
244 my $ret = init_declare(@args);
246 if (defined $ret && length $ret) {
247 substr($linestr, $offset, 0) = $ret;
248 set_linestr($linestr);
253 #warn "linestr now ${linestr}";
256 sub linestr_callback_const {
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);
271 sub linestr_callback {
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}->(@_);
284 die "PANIC: unknown thing in handlers for $pack $name: $handlers";
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
302 use Devel::Declare qw(list of subs);
304 Calls Devel::Declare->setup_for(__PACKAGE__ => \@list_of_subs);
310 Calls Devel::Declare->teardown_for(__PACKAGE__);
314 Devel::Declare->setup_for($package => \@subnames);
316 Installs declarator magic (unless already installed) and registers
317 "${package}::$name" for each member of @subnames
321 Devel::Declare->teardown_for($package);
323 Deregisters all subs currently registered for $package and uninstalls
324 declarator magic if number of teardown_for calls matches number of setup_for
329 Matt S Trout - <mst@shadowcat.co.uk>
331 Company: http://www.shadowcat.co.uk/
332 Blog: http://chainsawblues.vox.com/
336 This library is free software under the same terms as perl itself