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.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