Commit | Line | Data |
94caac6e |
1 | package Devel::Declare; |
2 | |
3 | use strict; |
4 | use warnings; |
5 | use 5.008001; |
6 | |
7 | our $VERSION = 0.001000; |
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 | |
15d0d014 |
16 | use vars qw(%declarators %declarator_handlers); |
94caac6e |
17 | use base qw(DynaLoader); |
323ae557 |
18 | use Scalar::Util 'set_prototype'; |
94caac6e |
19 | |
20 | bootstrap Devel::Declare; |
21 | |
22 | sub import { |
0ba8c7aa |
23 | my ($class, %args) = @_; |
94caac6e |
24 | my $target = caller; |
0ba8c7aa |
25 | if (@_ == 1) { # "use Devel::Declare;" |
26 | no strict 'refs'; |
15d0d014 |
27 | foreach my $name (qw(NAME PROTO NONE PACKAGE)) { |
53e3ab32 |
28 | *{"${target}::DECLARE_${name}"} = *{"DECLARE_${name}"}; |
0ba8c7aa |
29 | } |
30 | } else { |
31 | $class->setup_for($target => \%args); |
32 | } |
94caac6e |
33 | } |
34 | |
35 | sub unimport { |
36 | my ($class) = @_; |
37 | my $target = caller; |
38 | $class->teardown_for($target); |
39 | } |
40 | |
41 | sub setup_for { |
42 | my ($class, $target, $args) = @_; |
43 | setup(); |
0ba8c7aa |
44 | foreach my $key (keys %$args) { |
45 | my $info = $args->{$key}; |
46 | my ($flags, $sub); |
47 | if (ref($info) eq 'ARRAY') { |
48 | ($flags, $sub) = @$info; |
49 | } elsif (ref($info) eq 'CODE') { |
50 | $flags = DECLARE_NAME; |
51 | $sub = $info; |
52 | } else { |
53 | die "Info for sub ${key} must be [ \$flags, \$sub ] or \$sub"; |
54 | } |
55 | $declarators{$target}{$key} = $flags; |
56 | $declarator_handlers{$target}{$key} = $sub; |
57 | } |
94caac6e |
58 | } |
59 | |
60 | sub teardown_for { |
61 | my ($class, $target) = @_; |
62 | delete $declarators{$target}; |
0ba8c7aa |
63 | delete $declarator_handlers{$target}; |
94caac6e |
64 | teardown(); |
65 | } |
66 | |
94caac6e |
67 | my $temp_name; |
0ba8c7aa |
68 | my $temp_save; |
94caac6e |
69 | |
70 | sub init_declare { |
9026391e |
71 | my ($usepack, $use, $inpack, $name, $proto) = @_; |
53e3ab32 |
72 | my ($name_h, $XX_h, $extra_code) |
9026391e |
73 | = $declarator_handlers{$usepack}{$use}->( |
74 | $usepack, $use, $inpack, $name, $proto, defined(wantarray) |
53e3ab32 |
75 | ); |
15d0d014 |
76 | ($temp_name, $temp_save) = ([], []); |
0ba8c7aa |
77 | if ($name) { |
9026391e |
78 | $name = "${inpack}::${name}" unless $name =~ /::/; |
0ba8c7aa |
79 | push(@$temp_name, $name); |
80 | no strict 'refs'; |
15d0d014 |
81 | push(@$temp_save, \&{$name}); |
0ba8c7aa |
82 | no warnings 'redefine'; |
83 | no warnings 'prototype'; |
15d0d014 |
84 | *{$name} = $name_h; |
0ba8c7aa |
85 | } |
86 | if ($XX_h) { |
9026391e |
87 | push(@$temp_name, "${inpack}::X"); |
0ba8c7aa |
88 | no strict 'refs'; |
9026391e |
89 | push(@$temp_save, \&{"${inpack}::X"}); |
0ba8c7aa |
90 | no warnings 'redefine'; |
91 | no warnings 'prototype'; |
9026391e |
92 | *{"${inpack}::X"} = $XX_h; |
0ba8c7aa |
93 | } |
53e3ab32 |
94 | if (defined wantarray) { |
95 | return $extra_code || '0;'; |
96 | } else { |
97 | return; |
98 | } |
94caac6e |
99 | } |
100 | |
101 | sub done_declare { |
102 | no strict 'refs'; |
0ba8c7aa |
103 | my $name = pop(@{$temp_name||[]}); |
104 | die "done_declare called with no temp_name stack" unless defined($name); |
105 | my $saved = pop(@$temp_save); |
15d0d014 |
106 | $name =~ s/(.*):://; |
107 | my $temp_pack = $1; |
0ba8c7aa |
108 | delete ${"${temp_pack}::"}{$name}; |
109 | if ($saved) { |
110 | no warnings 'prototype'; |
111 | *{"${temp_pack}::${name}"} = $saved; |
112 | } |
94caac6e |
113 | } |
114 | |
323ae557 |
115 | sub build_sub_installer { |
116 | my ($class, $pack, $name, $proto) = @_; |
117 | return eval " |
118 | package ${pack}; |
119 | my \$body; |
120 | sub ${name} (${proto}) :lvalue {\n" |
121 | .'$body->(@_); |
122 | }; |
123 | sub { ($body) = @_; };'; |
124 | } |
125 | |
126 | sub setup_declarators { |
127 | my ($class, $pack, $to_setup) = @_; |
128 | die "${class}->setup_declarator(\$pack, \\\%to_setup)" |
129 | unless defined($pack) && ref($to_setup eq 'HASH'); |
130 | foreach my $name (keys %$to_setup) { |
131 | my $info = $to_setup->{$name}; |
132 | my $flags = $info->{flags} || DECLARE_NAME; |
133 | my $run = $info->{run}; |
134 | my $compile = $info->{compile}; |
135 | my $proto = $info->{proto} || '&'; |
136 | my $sub_proto = $proto; |
137 | # make all args optional to enable lvalue for DECLARE_NONE |
138 | $sub_proto =~ s/;//; $sub_proto = ';'.$sub_proto; |
139 | my $installer = $class->build_sub_installer($pack, $name, $proto); |
140 | # XXX UNCLEAN |
141 | } |
142 | } |
143 | |
94caac6e |
144 | =head1 NAME |
145 | |
146 | Devel::Declare - |
147 | |
148 | =head1 SYNOPSIS |
149 | |
150 | =head1 DESCRIPTION |
151 | |
152 | =head2 import |
153 | |
154 | use Devel::Declare qw(list of subs); |
155 | |
156 | Calls Devel::Declare->setup_for(__PACKAGE__ => \@list_of_subs); |
157 | |
158 | =head2 unimport |
159 | |
160 | no Devel::Declare; |
161 | |
162 | Calls Devel::Declare->teardown_for(__PACKAGE__); |
163 | |
164 | =head2 setup_for |
165 | |
166 | Devel::Declare->setup_for($package => \@subnames); |
167 | |
168 | Installs declarator magic (unless already installed) and registers |
169 | "${package}::$name" for each member of @subnames |
170 | |
171 | =head2 teardown_for |
172 | |
173 | Devel::Declare->teardown_for($package); |
174 | |
175 | Deregisters all subs currently registered for $package and uninstalls |
176 | declarator magic if number of teardown_for calls matches number of setup_for |
177 | calls. |
178 | |
179 | =head1 AUTHOR |
180 | |
181 | Matt S Trout - <mst@shadowcatsystems.co.uk> |
182 | |
183 | Company: http://www.shadowcatsystems.co.uk/ |
184 | Blog: http://chainsawblues.vox.com/ |
185 | |
186 | =head1 LICENSE |
187 | |
188 | This library is free software under the same terms as perl itself |
189 | |
190 | =cut |
191 | |
192 | 1; |