X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2Fassertions.pm;h=6c5c211b2750aa07649e124eb871c8a5d0f17689;hb=c1e8580e8ecd78fc1f67b0caa695b9884a700d93;hp=50e06a76df9c2ae2302741c0784bfe77efd01fc7;hpb=06492da604676b8820ba5623ac813ceec4f48731;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/assertions.pm b/lib/assertions.pm index 50e06a7..6c5c211 100644 --- a/lib/assertions.pm +++ b/lib/assertions.pm @@ -1,41 +1,162 @@ package assertions; -our $VERSION = '0.01'; +our $VERSION = '0.04'; # use strict; # use warnings; -my $hint=0x01000000; +my $hint = 1; +my $seen_hint = 2; + +sub _syntax_error ($$) { + my ($expr, $why)=@_; + require Carp; + Carp::croak("syntax error on assertion filter '$expr' ($why)"); +} + +sub _carp { + require warnings; + if (warnings::enabled('assertions')) { + require Carp; + Carp::carp(@_); + } +} + +sub _calc_expr { + my $expr=shift; + my @tokens=split / \s* + ( && # and + | \|\| # or + | \( # parents + | \) ) + \s* + | \s+ # spaces out + /x, $expr; + + # print STDERR "tokens: -", join('-',@tokens), "-\n"; + + my @now=1; + my @op='start'; + + for my $t (@tokens) { + next if (!defined $t or $t eq ''); + + if ($t eq '(') { + unshift @now, 1; + unshift @op, 'start'; + } + else { + if ($t eq '||') { + defined $op[0] + and _syntax_error $expr, 'consecutive operators'; + $op[0]='||'; + } + elsif ($t eq '&&') { + defined $op[0] + and _syntax_error $expr, 'consecutive operators'; + $op[0]='&&'; + } + else { + if ($t eq ')') { + @now==1 and + _syntax_error $expr, 'unbalanced parens'; + defined $op[0] and + _syntax_error $expr, "key missing after operator '$op[0]'"; + + $t=shift @now; + shift @op; + } + elsif ($t eq '_') { + unless ($^H{assertions} & $seen_hint) { + _carp "assertion status '_' referenced but not previously defined"; + } + $t=($^H{assertions} & $hint) ? 1 : 0; + } + elsif ($t ne '0' and $t ne '1') { + $t = ( grep { ref $_ eq 'Regexp' + ? $t=~$_ + : $_->check($t) + } @{^ASSERTING} ) ? 1 : 0; + } + + defined $op[0] or + _syntax_error $expr, 'operator expected'; + + if ($op[0] eq 'start') { + $now[0]=$t; + } + elsif ($op[0] eq '||') { + $now[0]||=$t; + } + else { + $now[0]&&=$t; + } + undef $op[0]; + } + } + } + @now==1 or _syntax_error $expr, 'unbalanced parens'; + defined $op[0] and _syntax_error $expr, "expression ends on operator '$op[0]'"; + + return $now[0]; +} + sub import { + # print STDERR "\@_=", join("|", @_), "\n"; shift; @_=(scalar(caller)) unless @_; - - if ($_[0] eq '&') { - return unless $^H & $hint; - shift; - } - - for my $tag (@_) { - unless (grep { $tag=~$_ } @{^ASSERTING}) { - $^H &= ~$hint; + foreach my $expr (@_) { + unless (_calc_expr $expr) { + # print STDERR "assertions deactived"; + $^H{assertions} &= ~$hint; + $^H{assertions} |= $seen_hint; return; } } - $^H |= $hint; + # print STDERR "assertions actived"; + $^H{assertions} |= $hint|$seen_hint; } sub unimport { - $^H &= ~$hint; + @_ > 1 + and _carp($_[0]."->unimport arguments are being ignored"); + $^H{assertions} &= ~$hint; +} + +sub enabled { + if (@_) { + if ($_[0]) { + $^H{assertions} |= $hint; + } + else { + $^H{assertions} &= ~$hint; + } + $^H{assertions} |= $seen_hint; + } + return $^H{assertions} & $hint ? 1 : 0; +} + +sub seen { + if (@_) { + if ($_[0]) { + $^H{assertions} |= $seen_hint; + } + else { + $^H{assertions} &= ~$seen_hint; + } + } + return $^H{assertions} & $seen_hint ? 1 : 0; } 1; + __END__ =head1 NAME -assertions - selects assertions +assertions - select assertions in blocks of code =head1 SYNOPSIS @@ -46,47 +167,170 @@ assertions - selects assertions { use assertions qw( foo bar ); - assert { print "asserting 'foo' & 'bar'\n" }; + assert { print "asserting 'foo' and 'bar'\n" }; } { use assertions qw( bar ); - assert { print "asserting 'bar'\n" }; + assert { print "asserting only 'bar'\n" }; } { - use assertions qw( & bar ); - assert { print "asserting 'foo' & 'bar'\n" }; + use assertions '_ && bar'; + assert { print "asserting 'foo' && 'bar'\n" }; } assert { print "asserting 'foo' again\n" }; +=head1 DESCRIPTION -=head1 ABSTRACT + *** WARNING: assertion support is only available from perl version + *** 5.9.0 and upwards. Check assertions::compat (also available from + *** this package) for an alternative backwards compatible module. -C pragma selects the tags used to control assertion -execution. +The C pragma specifies the tags used to enable and disable +the execution of assertion subroutines. -=head1 DESCRIPTION +An assertion subroutine is declared with the C<:assertion> attribute. +This subroutine is not normally executed: it's optimized away by perl +at compile-time. +The C pragma associates to its lexical scope one or +several assertion tags. Then, to activate the execution of the +assertions subroutines in this scope, these tags must be given to perl +via the B<-A> command-line option. For instance, if... + use assertions 'foobar'; +is used, assertions on the same lexical scope will only be executed +when perl is called as... -=head2 EXPORT + perl -A=foobar script.pl -None by default. +Regular expressions can also be used within the -A +switch. For instance... -=head1 SEE ALSO + perl -A='foo.*' script.pl + +will activate assertions tagged as C, C, C, etc. + +=head2 Selecting assertions + +Selecting which tags are required to activate assertions inside a +lexical scope, is done with the arguments passed on the C sentence. + +If no arguments are given, the package name is used as the assertion tag: + + use assertions; + +is equivalent to + use assertions __PACKAGE__; + +When several tags are given, all of them have to be activated via the +C<-A> switch to activate assertion execution on that lexical scope, +i.e.: + + use assertions qw(Foo Bar); + +Constants C<1> and C<0> can be used to force unconditional activation +or deactivation respectively: + + use assertions '0'; + use assertions '1'; + +Operators C<&&> and C<||> and parenthesis C<(...)> can be used to +construct logical expressions: + + use assertions 'foo && bar'; + use assertions 'foo || bar'; + use assertions 'foo && (bar || doz)'; + +(note that the logical operators and the parens have to be included +inside the quoted string). + +Finally, the special tag C<_> refers to the current assertion +activation state: + + use assertions 'foo'; + use assertions '_ && bar; + +is equivalent to + + use assertions 'foo && bar'; + +=head2 Handling assertions your own way + +The C module also provides a set of low level functions to +allow for custom assertion handling modules. + +Those functions are not exported and have to be fully qualified with +the package name when called, for instance: + + require assertions; + assertions::enabled(1); + +(note that C is loaded with the C keyword +to avoid calling C). + +Those functions have to be called at compile time (they are +useless at runtime). + +=over 4 + +=item enabled($on) + +activates or deactivates assertion execution. For instance: + + package assertions::always; + + require assertions; + sub import { assertions::enabled(1) } + + 1; + +This function calls C also (see below). + +=item enabled() + +returns a true value when assertion execution is active. + +=item seen($on) + +A warning is generated when an assertion subroutine is found before +any assertion selection code. This function is used to just tell perl +that assertion selection code has been seen and that the warning is +not required for the currently compiling lexical scope. + +=item seen() + +returns true if any assertion selection module (or code) has been +called before on the currently compiling lexical scope. + +=back + +=head1 COMPATIBILITY + +Support for assertions is only available in perl from version 5.9. On +previous perl versions this module will do nothing, though it will not +harm either. + +L provides an alternative way to use assertions +compatible with lower versions of perl. + + +=head1 SEE ALSO +L, L, L. =head1 AUTHOR -Salvador Fandiño, Esfandino@yahoo.comE +Salvador FandiEo, Esfandino@yahoo.comE =head1 COPYRIGHT AND LICENSE -Copyright 2002 by Salvador Fandiño +Copyright 2002, 2005 by Salvador FandiEo This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself.