]>
Commit | Line | Data |
---|---|---|
1 | #!/usr/bin/perl | |
2 | package evil; | |
3 | ||
4 | use 5.008009; | |
5 | use strict; | |
6 | use warnings; | |
7 | ||
8 | use Carp; | |
9 | ||
10 | my $INTERMEDIATE = __PACKAGE__.'/intermediate'; | |
11 | my $LAX = __PACKAGE__.'/lax'; | |
12 | ||
13 | our $VERSION = 0.003; | |
14 | ||
15 | our %tainted; | |
16 | our %wants_strict; | |
17 | ||
18 | sub import { | |
19 | croak "Cannot load evil module when \"no evil ':strict'\" is in effect" if %wants_strict; | |
20 | ||
21 | my $hinthash = (caller 0)[10] || {}; | |
22 | croak "Current module requested no evilness" if $hinthash->{$LAX}; | |
23 | ||
24 | $hinthash = (caller 3)[10] || {}; | |
25 | croak "Cannot load evil module when parent requested \"no evil ':lax'\"" if $hinthash->{$LAX}; | |
26 | ||
27 | my $level = 4; | |
28 | my @caller; | |
29 | while (@caller = caller $level) { | |
30 | $hinthash = $caller[10] || {}; | |
31 | croak "Cannot load evil module when ancestor requested \"no evil ':intermediate'\"" | |
32 | if $hinthash->{$INTERMEDIATE}; | |
33 | $level++; | |
34 | } | |
35 | ||
36 | $tainted{caller()} = 1; | |
37 | } | |
38 | ||
39 | sub unimport { | |
40 | my $strict_arg = grep /^:strict$/i, @_; | |
41 | my $intermediate_arg = grep /^:intermediate$/i, @_; | |
42 | my $lax_arg = grep /^:lax$/i, @_; | |
43 | my $disable_arg = grep /^:disable$/i, @_; | |
44 | ||
45 | if (!$disable_arg && $tainted{caller()}) { # caller is evil | |
46 | croak 'Current module is evil' | |
47 | } | |
48 | ||
49 | if ($strict_arg) { | |
50 | $wants_strict{caller()} = 1; | |
51 | croak "Evil module already loaded. Cannot enforce \"no evil ':strict'\"" if %tainted | |
52 | } elsif ($lax_arg) { | |
53 | $^H{$LAX} = 1 | |
54 | } elsif ($disable_arg) { | |
55 | delete $wants_strict{caller()}; | |
56 | delete $^H{$LAX}; | |
57 | delete $^H{$INTERMEDIATE}; | |
58 | } else { # $intermediate_arg or no arg | |
59 | $^H{$INTERMEDIATE} = $^H{$LAX} = 1 | |
60 | } | |
61 | } | |
62 | ||
63 | 1; | |
64 | __END__ | |
65 | ||
66 | =encoding utf-8 | |
67 | ||
68 | =head1 NAME | |
69 | ||
70 | evil - RFC 3514 (evil bit) implementation for Perl modules | |
71 | ||
72 | =head1 SYNOPSIS | |
73 | ||
74 | # in A.pm | |
75 | package A; | |
76 | use evil; | |
77 | ||
78 | # in B.pm | |
79 | package B; | |
80 | no evil ':strict'; | |
81 | use A; # <dies> | |
82 | ||
83 | # in C.pm | |
84 | package C; | |
85 | use A; | |
86 | ||
87 | # in D.pm | |
88 | package D; | |
89 | no evil; | |
90 | use C; # <dies> | |
91 | ||
92 | # in E.pm | |
93 | package E; | |
94 | no evil ':lax'; | |
95 | use C; # does not die, as C is not evil | |
96 | ||
97 | # in F.pm | |
98 | package F; | |
99 | use C; | |
100 | no evil; | |
101 | # does not die, as modules loaded before the pragma are ignored | |
102 | ||
103 | =head1 DESCRIPTION | |
104 | ||
105 | L<RFC3514|https://www.ietf.org/rfc/rfc3514.txt> introduces a new flag | |
106 | called the "evil bit" in all IP packets. The intention is to simplify | |
107 | the work of firewalls. Software that sends IP packets with malicious | |
108 | intent must set the evil bit to true, and firewalls can simply drop | |
109 | such packets. | |
110 | ||
111 | The evil pragma is a Perl implementation of the same concept. With | |
112 | this pragma malicious modules can declare their evil intent while | |
113 | critical modules can request that they will only use / run alongside | |
114 | non-evil code. | |
115 | ||
116 | The pragma can be used in the following ways: | |
117 | ||
118 | =over | |
119 | ||
120 | =item use B<evil>; | |
121 | ||
122 | Marks the current package as evil. All malicious modules MUST use this | |
123 | directive to ensure the full functionality of this pragma. | |
124 | ||
125 | =item no B<evil> ':strict'; | |
126 | ||
127 | The calling module function properly if malignant code is loaded | |
128 | anywhere in the program. Throws an exception if an evil module is | |
129 | loaded, whether at the moment of calling this pragma or in the future. | |
130 | ||
131 | =item no B<evil> ':disable'; | |
132 | ||
133 | Removes the effect of any previous C<no B<evil> ':something'> used in | |
134 | this module, thus stating the module does not care about evil code. | |
135 | ||
136 | =item no B<evil> ':intermediate' | |
137 | ||
138 | The calling module cannot function properly if it is using evil code, | |
139 | whether directly or indirectly. Throws an exception if an evil module | |
140 | is subsequently loaded by the calling module or by one of the children | |
141 | modules (or by one of their children modules, etc). Also throws an | |
142 | exception if the current module is evil. | |
143 | ||
144 | =item no B<evil> ':lax'; | |
145 | ||
146 | The calling module cannot function properly if it is using evil code | |
147 | direcly. Throws an exception if the calling module subsequently loads | |
148 | an evil module, or if the current module is evil. | |
149 | ||
150 | =item no B<evil>; | |
151 | ||
152 | Synonym for C<no evil ':intermediate'>. | |
153 | ||
154 | =back | |
155 | ||
156 | =head1 BUGS | |
157 | ||
158 | The following does not die: | |
159 | ||
160 | # Evil.pm | |
161 | package Evil; | |
162 | use evil; | |
163 | ||
164 | # A.pm | |
165 | package A; | |
166 | use Evil; | |
167 | ||
168 | # B.pm | |
169 | package B; | |
170 | no evil ':intermediate'; | |
171 | use Evil; | |
172 | ||
173 | # script.pl | |
174 | #!/usr/bin/perl | |
175 | use A; | |
176 | use B; | |
177 | ||
178 | Since Evil was loaded by A, B does not load Evil and therefore does | |
179 | not detect that Evil is... evil. If we loaded B before A in script.pl, | |
180 | we would get an exception. So order of loading modules matters for | |
181 | intermediate and lax modes. Strict mode is unaffected by this bug. | |
182 | ||
183 | =head1 CAVEATS | |
184 | ||
185 | When using intermediate and lax modes, any evil modules loaded before | |
186 | the pragma is enabled are ignored. This is by design, to allow | |
187 | temporarily disabling the pragma. An example: | |
188 | ||
189 | package MyModule; | |
190 | no evil; | |
191 | use Some::Module; | |
192 | use Another::Module; | |
193 | ||
194 | no evil ':disable'; | |
195 | use Evil::Module; # does not die | |
196 | no evil; | |
197 | ||
198 | use Some::More::Modules; | |
199 | ... | |
200 | ||
201 | Correct functioning of this pragma depends critically on the evil bit | |
202 | being set properly. If a faulty evil module fails to C<use evil;>, the | |
203 | pragma will not function properly. | |
204 | ||
205 | =head1 AUTHOR | |
206 | ||
207 | Marius Gavrilescu, E<lt>marius@ieval.roE<gt> | |
208 | ||
209 | =head1 COPYRIGHT AND LICENSE | |
210 | ||
211 | Copyright (C) 2016-2017 by Marius Gavrilescu | |
212 | ||
213 | This library is free software; you can redistribute it and/or modify | |
214 | it under the same terms as Perl itself, either Perl version 5.22.2 or, | |
215 | at your option, any later version of Perl 5 you may have available. | |
216 | ||
217 | ||
218 | =cut |