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; |
13 | |
14 | use vars qw(%declarators %declarator_handlers); |
94caac6e |
15 | use base qw(DynaLoader); |
16 | |
17 | bootstrap Devel::Declare; |
18 | |
19 | sub import { |
0ba8c7aa |
20 | my ($class, %args) = @_; |
94caac6e |
21 | my $target = caller; |
0ba8c7aa |
22 | if (@_ == 1) { # "use Devel::Declare;" |
23 | no strict 'refs'; |
24 | foreach my $name (qw(DECLARE_NAME DECLARE_PROTO)) { |
25 | *{"${target}::${name}"} = *{"${name}"}; |
26 | } |
27 | } else { |
28 | $class->setup_for($target => \%args); |
29 | } |
94caac6e |
30 | } |
31 | |
32 | sub unimport { |
33 | my ($class) = @_; |
34 | my $target = caller; |
35 | $class->teardown_for($target); |
36 | } |
37 | |
38 | sub setup_for { |
39 | my ($class, $target, $args) = @_; |
40 | setup(); |
0ba8c7aa |
41 | foreach my $key (keys %$args) { |
42 | my $info = $args->{$key}; |
43 | my ($flags, $sub); |
44 | if (ref($info) eq 'ARRAY') { |
45 | ($flags, $sub) = @$info; |
46 | } elsif (ref($info) eq 'CODE') { |
47 | $flags = DECLARE_NAME; |
48 | $sub = $info; |
49 | } else { |
50 | die "Info for sub ${key} must be [ \$flags, \$sub ] or \$sub"; |
51 | } |
52 | $declarators{$target}{$key} = $flags; |
53 | $declarator_handlers{$target}{$key} = $sub; |
54 | } |
94caac6e |
55 | } |
56 | |
57 | sub teardown_for { |
58 | my ($class, $target) = @_; |
59 | delete $declarators{$target}; |
0ba8c7aa |
60 | delete $declarator_handlers{$target}; |
94caac6e |
61 | teardown(); |
62 | } |
63 | |
64 | my $temp_pack; |
65 | my $temp_name; |
0ba8c7aa |
66 | my $temp_save; |
94caac6e |
67 | |
68 | sub init_declare { |
0ba8c7aa |
69 | my ($pack, $use, $name, $proto) = @_; |
70 | my ($name_h, $XX_h) = $declarator_handlers{$pack}{$use}->( |
71 | $pack, $use, $name, $proto |
72 | ); |
73 | ($temp_pack, $temp_name, $temp_save) = ($pack, [], []); |
74 | if ($name) { |
75 | push(@$temp_name, $name); |
76 | no strict 'refs'; |
77 | push(@$temp_save, \&{"${pack}::${name}"}); |
78 | no warnings 'redefine'; |
79 | no warnings 'prototype'; |
80 | *{"${pack}::${name}"} = $name_h; |
81 | } |
82 | if ($XX_h) { |
83 | push(@$temp_name, 'X'); |
84 | no strict 'refs'; |
85 | push(@$temp_save, \&{"${pack}::X"}); |
86 | no warnings 'redefine'; |
87 | no warnings 'prototype'; |
88 | *{"${pack}::X"} = $XX_h; |
89 | } |
94caac6e |
90 | } |
91 | |
92 | sub done_declare { |
93 | no strict 'refs'; |
0ba8c7aa |
94 | my $name = pop(@{$temp_name||[]}); |
95 | die "done_declare called with no temp_name stack" unless defined($name); |
96 | my $saved = pop(@$temp_save); |
97 | delete ${"${temp_pack}::"}{$name}; |
98 | if ($saved) { |
99 | no warnings 'prototype'; |
100 | *{"${temp_pack}::${name}"} = $saved; |
101 | } |
94caac6e |
102 | } |
103 | |
104 | =head1 NAME |
105 | |
106 | Devel::Declare - |
107 | |
108 | =head1 SYNOPSIS |
109 | |
110 | =head1 DESCRIPTION |
111 | |
112 | =head2 import |
113 | |
114 | use Devel::Declare qw(list of subs); |
115 | |
116 | Calls Devel::Declare->setup_for(__PACKAGE__ => \@list_of_subs); |
117 | |
118 | =head2 unimport |
119 | |
120 | no Devel::Declare; |
121 | |
122 | Calls Devel::Declare->teardown_for(__PACKAGE__); |
123 | |
124 | =head2 setup_for |
125 | |
126 | Devel::Declare->setup_for($package => \@subnames); |
127 | |
128 | Installs declarator magic (unless already installed) and registers |
129 | "${package}::$name" for each member of @subnames |
130 | |
131 | =head2 teardown_for |
132 | |
133 | Devel::Declare->teardown_for($package); |
134 | |
135 | Deregisters all subs currently registered for $package and uninstalls |
136 | declarator magic if number of teardown_for calls matches number of setup_for |
137 | calls. |
138 | |
139 | =head1 AUTHOR |
140 | |
141 | Matt S Trout - <mst@shadowcatsystems.co.uk> |
142 | |
143 | Company: http://www.shadowcatsystems.co.uk/ |
144 | Blog: http://chainsawblues.vox.com/ |
145 | |
146 | =head1 LICENSE |
147 | |
148 | This library is free software under the same terms as perl itself |
149 | |
150 | =cut |
151 | |
152 | 1; |