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$/, @_;
  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