]>
Commit | Line | Data |
---|---|---|
f17ddf12 MG |
1 | #!/usr/bin/perl |
2 | package evil; | |
3 | ||
4 | use 5.008009; | |
5 | use strict; | |
6 | use warnings; | |
7 | ||
8 | use Carp; | |
9 | ||
2f63ec14 MG |
10 | my $INTERMEDIATE = __PACKAGE__.'/intermediate'; |
11 | my $LAX = __PACKAGE__.'/lax'; | |
12 | ||
23276fbe | 13 | our $VERSION = 0.002; |
f17ddf12 MG |
14 | |
15 | our %tainted; | |
2f63ec14 | 16 | our %wants_strict; |
f17ddf12 MG |
17 | |
18 | sub import { | |
2f63ec14 MG |
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 | ||
f17ddf12 | 36 | $tainted{caller()} = 1; |
f17ddf12 MG |
37 | } |
38 | ||
39 | sub unimport { | |
277b168d MG |
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, @_; | |
2f63ec14 MG |
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 | |
f17ddf12 MG |
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; | |
f17ddf12 MG |
77 | |
78 | # in B.pm | |
79 | package B; | |
80 | no evil ':strict'; | |
81 | use A; # <dies> | |
f17ddf12 | 82 | |
177e0245 MG |
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 | |
f17ddf12 MG |
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 | |
177e0245 | 123 | directive to ensure the full functionality of this pragma. |
f17ddf12 MG |
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 | ||
c72607e1 MG |
131 | =item no B<evil> ':disable'; |
132 | ||
177e0245 MG |
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. | |
c72607e1 | 135 | |
177e0245 | 136 | =item no B<evil> ':intermediate' |
f17ddf12 | 137 | |
177e0245 MG |
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. | |
f17ddf12 | 143 | |
177e0245 | 144 | =item no B<evil> ':lax'; |
f17ddf12 | 145 | |
177e0245 MG |
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. | |
f17ddf12 MG |
149 | |
150 | =item no B<evil>; | |
151 | ||
177e0245 | 152 | Synonym for C<no evil ':intermediate'>. |
f17ddf12 MG |
153 | |
154 | =back | |
155 | ||
177e0245 MG |
156 | =head1 CAVEATS |
157 | ||
158 | When using intermediate and lax modes, any evil modules loaded before | |
159 | the pragma is enabled are ignored. This is by design, to allow | |
160 | temporarily disabling the pragma. An example: | |
161 | ||
162 | package MyModule; | |
163 | no evil; | |
164 | use Some::Module; | |
165 | use Another::Module; | |
166 | ||
167 | no evil ':disable'; | |
168 | use Evil::Module; # does not die | |
169 | no evil; | |
170 | ||
171 | use Some::More::Modules; | |
172 | ... | |
173 | ||
174 | Correct functioning of this pragma depends critically on the evil bit | |
175 | being set properly. If a faulty evil module fails to C<use evil;>, the | |
176 | pragma will not function properly. | |
177 | ||
f17ddf12 MG |
178 | =head1 AUTHOR |
179 | ||
180 | Marius Gavrilescu, E<lt>marius@ieval.roE<gt> | |
181 | ||
182 | =head1 COPYRIGHT AND LICENSE | |
183 | ||
184 | Copyright (C) 2016 by Marius Gavrilescu | |
185 | ||
186 | This library is free software; you can redistribute it and/or modify | |
187 | it under the same terms as Perl itself, either Perl version 5.22.2 or, | |
188 | at your option, any later version of Perl 5 you may have available. | |
189 | ||
190 | ||
191 | =cut |