]>
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.002; | |
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$/, @_; | |
41 | my $intermediate_arg = grep /^:intermediate$/, @_; | |
42 | my $lax_arg = grep /^:lax$/, @_; | |
43 | my $disable_arg = grep /^:disable/, @_; | |
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 | ||
79 | # in B.pm | |
80 | package B; | |
81 | no evil ':strict'; | |
82 | use A; # <dies> | |
83 | ... | |
84 | ||
85 | ||
86 | =head1 DESCRIPTION | |
87 | ||
88 | L<RFC3514|https://www.ietf.org/rfc/rfc3514.txt> introduces a new flag | |
89 | called the "evil bit" in all IP packets. The intention is to simplify | |
90 | the work of firewalls. Software that sends IP packets with malicious | |
91 | intent must set the evil bit to true, and firewalls can simply drop | |
92 | such packets. | |
93 | ||
94 | The evil pragma is a Perl implementation of the same concept. With | |
95 | this pragma malicious modules can declare their evil intent while | |
96 | critical modules can request that they will only use / run alongside | |
97 | non-evil code. | |
98 | ||
99 | The pragma can be used in the following ways: | |
100 | ||
101 | =over | |
102 | ||
103 | =item use B<evil>; | |
104 | ||
105 | Marks the current package as evil. All malicious modules MUST use this | |
106 | directive to ensure the full functionality of this module. | |
107 | ||
108 | =item no B<evil> ':strict'; | |
109 | ||
110 | The calling module function properly if malignant code is loaded | |
111 | anywhere in the program. Throws an exception if an evil module is | |
112 | loaded, whether at the moment of calling this pragma or in the future. | |
113 | ||
114 | =item no B<evil> ':disable'; | |
115 | ||
116 | Removes the effect of any previous C<no B<evil> ':strict'>. In other | |
117 | words evil modules will now be allowed to be loaded. | |
118 | ||
119 | =item no B<evil> ':intermediate'; (TODO) | |
120 | ||
121 | Not yet implemented. The calling module cannot function properly if it | |
122 | is using evil code, whether directly or indirectly. Throws an | |
123 | exception if an evil module is loaded by the calling module or by one | |
124 | of the children modules (or by one of their children modules, etc). | |
125 | ||
126 | =item no B<evil> ':lax'; (TODO) | |
127 | ||
128 | Not yet implemented. The calling module cannot function properly if it | |
129 | is using evil code direcly. Throws an exception if the calling module | |
130 | loads an evil module. | |
131 | ||
132 | =item no B<evil>; | |
133 | ||
134 | This would normally be equivalent to C<no evil ':intermediate';> but | |
135 | since that mode is not yet implemented this call does the same as | |
136 | C<no evil ':strict';> while also emitting a warning saying that this | |
137 | behaviour will change in a future version. | |
138 | ||
139 | =back | |
140 | ||
141 | =head1 AUTHOR | |
142 | ||
143 | Marius Gavrilescu, E<lt>marius@ieval.roE<gt> | |
144 | ||
145 | =head1 COPYRIGHT AND LICENSE | |
146 | ||
147 | Copyright (C) 2016 by Marius Gavrilescu | |
148 | ||
149 | This library is free software; you can redistribute it and/or modify | |
150 | it under the same terms as Perl itself, either Perl version 5.22.2 or, | |
151 | at your option, any later version of Perl 5 you may have available. | |
152 | ||
153 | ||
154 | =cut |