X-Git-Url: http://git.ieval.ro/?a=blobdiff_plain;f=lib%2Fevil.pm;h=54f2dd8a3be6a3f2d1336b12ae322bb423f57051;hb=refs%2Ftags%2F0.003001;hp=56f782470024dbb4f96fc105c7a44ed09285c1d2;hpb=c72607e1a24d4e5172664949faf7d7abfa58b176;p=acme-evil.git diff --git a/lib/evil.pm b/lib/evil.pm index 56f7824..54f2dd8 100644 --- a/lib/evil.pm +++ b/lib/evil.pm @@ -1,30 +1,62 @@ #!/usr/bin/perl package evil; -use 5.008009; +use 5.010001; use strict; use warnings; use Carp; -our $VERSION = 0.001; +my $INTERMEDIATE = __PACKAGE__.'/intermediate'; +my $LAX = __PACKAGE__.'/lax'; + +our $VERSION = 0.003001; our %tainted; -our $strict; +our %wants_strict; sub import { + croak "Cannot load evil module when \"no evil ':strict'\" is in effect" if %wants_strict; + + my $hinthash = (caller 0)[10] || {}; + croak "Current module requested no evilness" if $hinthash->{$LAX}; + + $hinthash = (caller 3)[10] || {}; + croak "Cannot load evil module when parent requested \"no evil ':lax'\"" if $hinthash->{$LAX}; + + my $level = 4; + my @caller; + while (@caller = caller $level) { + $hinthash = $caller[10] || {}; + croak "Cannot load evil module when ancestor requested \"no evil ':intermediate'\"" + if $hinthash->{$INTERMEDIATE}; + $level++; + } + $tainted{caller()} = 1; - croak "Cannot load evil module when \"no evil ':strict'\" is in effect" if $strict; } sub unimport { - my $strict_arg = grep /^:strict$/, @_; - my $disable_arg = grep /^:disable/, @_; - carp 'no evil; interpreted as no evil ":strict". This will change in a future version of Acme::Evil' unless $strict_arg || $disable_arg; - $strict = 1 unless $disable_arg; # To be changed when other modes are implemented - $strict = 0 if $disable_arg; - if ($strict && %tainted) { - croak "Evil module already loaded. Cannot enforce \"no evil ':strict'\""; + my $strict_arg = grep /^:strict$/i, @_; + my $intermediate_arg = grep /^:intermediate$/i, @_; + my $lax_arg = grep /^:lax$/i, @_; + my $disable_arg = grep /^:disable$/i, @_; + + if (!$disable_arg && $tainted{caller()}) { # caller is evil + croak 'Current module is evil' + } + + if ($strict_arg) { + $wants_strict{caller()} = 1; + croak "Evil module already loaded. Cannot enforce \"no evil ':strict'\"" if %tainted + } elsif ($lax_arg) { + $^H{$LAX} = 1 + } elsif ($disable_arg) { + delete $wants_strict{caller()}; + delete $^H{$LAX}; + delete $^H{$INTERMEDIATE}; + } else { # $intermediate_arg or no arg + $^H{$INTERMEDIATE} = $^H{$LAX} = 1 } } @@ -42,14 +74,31 @@ evil - RFC 3514 (evil bit) implementation for Perl modules # in A.pm package A; use evil; - ... # in B.pm package B; no evil ':strict'; use A; # - ... + # in C.pm + package C; + use A; + + # in D.pm + package D; + no evil; + use C; # + + # in E.pm + package E; + no evil ':lax'; + use C; # does not die, as C is not evil + + # in F.pm + package F; + use C; + no evil; + # does not die, as modules loaded before the pragma are ignored =head1 DESCRIPTION @@ -71,7 +120,7 @@ The pragma can be used in the following ways: =item use B; Marks the current package as evil. All malicious modules MUST use this -directive to ensure the full functionality of this module. +directive to ensure the full functionality of this pragma. =item no B ':strict'; @@ -81,38 +130,85 @@ loaded, whether at the moment of calling this pragma or in the future. =item no B ':disable'; -Removes the effect of any previous C ':strict'>. In other -words evil modules will now be allowed to be loaded. +Removes the effect of any previous C ':something'> used in +this module, thus stating the module does not care about evil code. -=item no B ':intermediate'; (TODO) +=item no B ':intermediate' -Not yet implemented. The calling module cannot function properly if it -is using evil code, whether directly or indirectly. Throws an -exception if an evil module is loaded by the calling module or by one -of the children modules (or by one of their children modules, etc). +The calling module cannot function properly if it is using evil code, +whether directly or indirectly. Throws an exception if an evil module +is subsequently loaded by the calling module or by one of the children +modules (or by one of their children modules, etc). Also throws an +exception if the current module is evil. -=item no B ':lax'; (TODO) +=item no B ':lax'; -Not yet implemented. The calling module cannot function properly if it -is using evil code direcly. Throws an exception if the calling module -loads an evil module. +The calling module cannot function properly if it is using evil code +direcly. Throws an exception if the calling module subsequently loads +an evil module, or if the current module is evil. =item no B; -This would normally be equivalent to C but -since that mode is not yet implemented this call does the same as -C while also emitting a warning saying that this -behaviour will change in a future version. +Synonym for C. =back +=head1 BUGS + +The following does not die: + + # Evil.pm + package Evil; + use evil; + + # A.pm + package A; + use Evil; + + # B.pm + package B; + no evil ':intermediate'; + use Evil; + + # script.pl + #!/usr/bin/perl + use A; + use B; + +Since Evil was loaded by A, B does not load Evil and therefore does +not detect that Evil is... evil. If we loaded B before A in script.pl, +we would get an exception. So order of loading modules matters for +intermediate and lax modes. Strict mode is unaffected by this bug. + +=head1 CAVEATS + +When using intermediate and lax modes, any evil modules loaded before +the pragma is enabled are ignored. This is by design, to allow +temporarily disabling the pragma. An example: + + package MyModule; + no evil; + use Some::Module; + use Another::Module; + + no evil ':disable'; + use Evil::Module; # does not die + no evil; + + use Some::More::Modules; + ... + +Correct functioning of this pragma depends critically on the evil bit +being set properly. If a faulty evil module fails to C, the +pragma will not function properly. + =head1 AUTHOR Marius Gavrilescu, Emarius@ieval.roE =head1 COPYRIGHT AND LICENSE -Copyright (C) 2016 by Marius Gavrilescu +Copyright (C) 2016-2017 by Marius Gavrilescu This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself, either Perl version 5.22.2 or,