]> iEval git - acme-evil.git/blob - lib/evil.pm
c5faa09bf2163ff7b4cf3b16ca3639d603866e82
[acme-evil.git] / lib / evil.pm
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$/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
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
This page took 0.056592 seconds and 3 git commands to generate.