X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2Fassertions.pm;h=0ced4bc228808a4c967aa7621584ac80707a6528;hb=1f42692825f0c2ae2aff7c8dc9679ad797e3f97c;hp=50e06a76df9c2ae2302741c0784bfe77efd01fc7;hpb=06492da604676b8820ba5623ac813ceec4f48731;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/assertions.pm b/lib/assertions.pm index 50e06a7..0ced4bc 100644 --- a/lib/assertions.pm +++ b/lib/assertions.pm @@ -1,41 +1,162 @@ package assertions; -our $VERSION = '0.01'; +our $VERSION = '0.02'; # use strict; # use warnings; my $hint=0x01000000; +my $seen_hint=0x02000000; + +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 & $seen_hint) { + _carp "assertion status '_' referenced but not previously defined"; + } + $t=($^H & $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}) { + foreach my $expr (@_) { + unless (_calc_expr $expr) { + # print STDERR "assertions deactived"; $^H &= ~$hint; + $^H |= $seen_hint; return; } } - $^H |= $hint; + # print STDERR "assertions actived"; + $^H |= $hint|$seen_hint; } sub unimport { + @_ > 1 + and _carp($_[0]."->unimport arguments are being ignored"); $^H &= ~$hint; } +sub enabled { + if (@_) { + if ($_[0]) { + $^H |= $hint; + } + else { + $^H &= ~$hint; + } + $^H |= $seen_hint; + } + return $^H & $hint ? 1 : 0; +} + +sub seen { + if (@_) { + if ($_[0]) { + $^H |= $seen_hint; + } + else { + $^H &= ~$seen_hint; + } + } + return $^H & $seen_hint ? 1 : 0; +} + 1; + __END__ =head1 NAME -assertions - selects assertions +assertions - select assertions in blocks of code =head1 SYNOPSIS @@ -46,47 +167,166 @@ 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 +The C pragma specifies the tags used to enable and disable +the execution of assertion subroutines. -C pragma selects the tags used to control assertion -execution. +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. -=head1 DESCRIPTION +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... + perl -A=foobar script.pl -=head2 EXPORT +Regular expressions can also be used within the -A +switch. For instance... -None by default. + perl -A='foo.*' script.pl -=head1 SEE ALSO +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.