From: Salvador Fandiño Date: Mon, 13 Jun 2005 16:48:01 +0000 (+0100) Subject: better assertion support X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=aefc56c5a86a8918fc9d52065e8cf4df301d4ee4;p=p5sagit%2Fp5-mst-13.2.git better assertion support Message-ID: <20050613154719.29295.qmail@lists.develooper.com> p4raw-id: //depot/perl@24832 --- diff --git a/MANIFEST b/MANIFEST index 3c18af1..12986a1 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1178,6 +1178,7 @@ lib/abbrev.pl An abbreviation table builder lib/AnyDBM_File.pm Perl module to emulate dbmopen lib/AnyDBM_File.t See if AnyDBM_File works lib/assertions/activate.pm assertions activate/deactivate +lib/assertions/compat.pm assertions compatibility for earlier perls lib/assertions.pm module support for -A flag lib/assert.pl assertion and panic with stack trace lib/Attribute/Handlers/Changes Attribute::Handlers @@ -2612,6 +2613,7 @@ t/cmd/subval.t See if subroutine values work t/cmd/switch.t See if switch optimizations work t/cmd/while.t See if while loops work t/comp/assertions.t See if assertions work +t/comp/asstcompat.t See if assertions::compat work t/comp/bproto.t See if builtins conform to their prototypes t/comp/cmdopt.t See if command optimization works t/comp/colon.t See if colons are parsed correctly diff --git a/lib/assertions.pm b/lib/assertions.pm index 700abf4..0ced4bc 100644 --- a/lib/assertions.pm +++ b/lib/assertions.pm @@ -1,6 +1,6 @@ package assertions; -our $VERSION = '0.01'; +our $VERSION = '0.02'; # use strict; # use warnings; @@ -8,22 +8,21 @@ our $VERSION = '0.01'; my $hint=0x01000000; my $seen_hint=0x02000000; -sub syntax_error ($$) { +sub _syntax_error ($$) { my ($expr, $why)=@_; require Carp; Carp::croak("syntax error on assertion filter '$expr' ($why)"); } -sub my_warn ($) { - my $error=shift; +sub _carp { require warnings; if (warnings::enabled('assertions')) { require Carp; - Carp::carp($error); + Carp::carp(@_); } } -sub calc_expr { +sub _calc_expr { my $expr=shift; my @tokens=split / \s* ( && # and @@ -49,38 +48,39 @@ sub calc_expr { else { if ($t eq '||') { defined $op[0] - and syntax_error $expr, 'consecutive operators'; + and _syntax_error $expr, 'consecutive operators'; $op[0]='||'; } elsif ($t eq '&&') { defined $op[0] - and syntax_error $expr, 'consecutive operators'; + and _syntax_error $expr, 'consecutive operators'; $op[0]='&&'; } else { if ($t eq ')') { @now==1 and - syntax_error $expr, 'unbalanced parens'; + _syntax_error $expr, 'unbalanced parens'; defined $op[0] and - syntax_error $expr, "key missing after operator '$op[0]'"; + _syntax_error $expr, "key missing after operator '$op[0]'"; $t=shift @now; shift @op; } elsif ($t eq '_') { unless ($^H & $seen_hint) { - my_warn "assertion status '_' referenced but not previously defined"; + _carp "assertion status '_' referenced but not previously defined"; } $t=($^H & $hint) ? 1 : 0; } elsif ($t ne '0' and $t ne '1') { - # print STDERR "'$t' resolved as "; - $t=grep ({ $t=~$_ } @{^ASSERTING}) ? 1 : 0; - # print STDERR "$t\n"; + $t = ( grep { ref $_ eq 'Regexp' + ? $t=~$_ + : $_->check($t) + } @{^ASSERTING} ) ? 1 : 0; } defined $op[0] or - syntax_error $expr, 'operator expected'; + _syntax_error $expr, 'operator expected'; if ($op[0] eq 'start') { $now[0]=$t; @@ -95,8 +95,8 @@ sub calc_expr { } } } - @now==1 or syntax_error $expr, 'unbalanced parens'; - defined $op[0] and syntax_error $expr, "expression ends on operator '$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]; } @@ -107,7 +107,7 @@ sub import { shift; @_=(scalar(caller)) unless @_; foreach my $expr (@_) { - unless (calc_expr $expr) { + unless (_calc_expr $expr) { # print STDERR "assertions deactived"; $^H &= ~$hint; $^H |= $seen_hint; @@ -119,10 +119,38 @@ sub import { } 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__ @@ -148,7 +176,7 @@ assertions - select assertions in blocks of code } { - use assertions ' _ && bar '; + use assertions '_ && bar'; assert { print "asserting 'foo' && 'bar'\n" }; } @@ -160,17 +188,137 @@ The C pragma specifies the tags used to enable and disable the execution of assertion subroutines. An assertion subroutine is declared with the C<:assertion> attribute. -This subroutine is not normally executed : it's optimized away by perl +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. +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 + +Regular expressions can also be used within the -A +switch. For instance... + + 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, L. =head1 AUTHOR @@ -178,11 +326,9 @@ Salvador FandiEo, Esfandino@yahoo.comE =head1 COPYRIGHT AND LICENSE -Copyright 2002 by Salvador FandiEo +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. =cut - -TODO : Some more docs are to be added about assertion expressions. diff --git a/lib/assertions/activate.pm b/lib/assertions/activate.pm index 198b836..04bc032 100644 --- a/lib/assertions/activate.pm +++ b/lib/assertions/activate.pm @@ -1,11 +1,11 @@ package assertions::activate; -our $VERSION = '0.01'; +our $VERSION = '0.02'; sub import { shift; @_ = '.*' unless @_; - push @{^ASSERTING}, map { qr/^(?:$_)\z/ } @_; + push @{^ASSERTING}, map { ref $_ eq 'Regexp' ? $_ : qr/^(?:$_)\z/ } @_; } 1; @@ -25,7 +25,11 @@ assertions::activate - activate assertions =head1 DESCRIPTION This module is used internally by perl (and its C<-A> command-line switch) to -enable and disable assertions. It can also be used directly. +enable and disable assertions. + +It can also be used directly: + + use assertions::activate qw(foo bar); The import parameters are a list of strings or of regular expressions. The assertion tags that match those regexps are enabled. If no parameter is @@ -41,7 +45,7 @@ Salvador FandiEo, Esfandino@yahoo.comE =head1 COPYRIGHT AND LICENSE -Copyright 2002 by Salvador FandiEo +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. diff --git a/lib/assertions/compat.pm b/lib/assertions/compat.pm new file mode 100644 index 0000000..156f897 --- /dev/null +++ b/lib/assertions/compat.pm @@ -0,0 +1,183 @@ +package assertions::compat; + +require assertions; +our @ISA = qw(assertions); + +sub _on () { 1 } +sub _off () { 0 } + +sub import { + my $class = shift; + my $name = @_ ? shift : 'asserting'; + my $pkg = caller; + $name =~ /::/ or $name = "${pkg}::${name}"; + @_ = $pkg unless @_; + $class->SUPER::import(@_); + my $enabled = assertions::enabled(); + { + no strict 'vars'; + no warnings; + undef &{$name}; + *{$name} = $enabled ? \&_on : \&_off; + } +} + +sub _compat_assertion_handler { + shift; shift; + grep $_ ne 'assertion', @_ +} + +sub _do_nothing_handler {} + +# test if 'assertion' attribute is natively supported +my $assertion_ok=eval q{ + sub _my_asserting_test : assertion { 1 } + _my_asserting_test() +}; + +*MODIFY_CODE_ATTRIBUTES = + defined($assertion_ok) + ? \&_do_nothing_handler + : \&_compat_assertion_handler; + +1; + +__END__ + +=head1 NAME + +assertions::compat - assertions for pre-5.9 versions of perl + +=head1 SYNOPSIS + + # add support for 'assertion' attribute: + use base 'assertions::compat'; + sub assert_foo : assertion { ... }; + + # then, maybe in another module: + package Foo::Bar; + + # define sub 'asserting' with the assertion status: + use assertions::compat; + asserting and assert_foo(1,2,3,4); + + # or + use assertions::compat ASST => 'Foo::Bar::doz'; + ASST and assert_foo('dozpera'); + +=head1 DESCRIPTION + +C allows to use assertions on perl versions prior +to 5.9.0 (that is the first one to natively support them). Though, +it's not magic, do not expect it to allow for conditional executed +subroutines. + +This module provides support for two different functionalities: + +=head2 The C attribute handler + +The subroutine attribute C is not recognised on perls +without assertion support. This module provides a +C handler for this attribute. It must be used +via inheritance: + + use base 'assertions::compat'; + + sub assert_foo : assertion { ... } + +Be aware that the handler just discards the attribute, so subroutines +declared as assertions will be B called on perl without +native support for them. + +=head2 Assertion execution status as a constant + +C also allows to create constant subs which value +is the assertion execution status. That allows checking explicitly and +efficiently if assertions have to be executed on perls without native +assertion support. + +For instance... + + use assertions::compat ASST => 'Foo::Bar'; + +exports constant subroutine C. Its value is true when assertions +tagged as C has been activated via L; +usually done with the -A switch from the command line on perls +supporting it... + + perl -A=Foo::Bar my_script.pl + +or alternatively with... + + perl -Massertions::activate=Foo::Bar my_script.pl + +on pre-5.9.0 versions of perl. + +The constant sub defined can be used following this idiom: + + use assertions::compat ASST => 'Foo::Bar'; + ... + ASST and assert_foo(); + +When ASST is false, the perl interpreter optimizes away the rest of +the C statement at compile time. + + +When no assertion selection tags are passed to C, the current module name is used as the selection +tag, so... + + use assertions::compat 'ASST'; + +is equivalent to... + + use assertions::compat ASST => __PACKAGE__; + +If the name of the constant subroutine is also omitted, C +is used. + +This module will not emit a warning when the constant is redefined. +this is done on purpose to allow for code like that: + + use assertions::compat ASST => 'Foo'; + ASST and assert_foo(); + + use assertions::compat ASST => 'Bar'; + ASST and assert_bar(); + +Finally, be aware that while assertion execution status is lexical +scoped, defined constants are not. You should be careful on that to +not write inconsistent code. For instance... + + package Foo; + + use MyAssertions qw(assert_foo); + + use assertions::compat ASST => 'Foo::Out' + { + use assertions::compat ASST => 'Foo::In'; + ASST and assert_foo(); # ok! + } + + ASST and assert_foo() # bad usage! + # ASST refers to tag Foo::In while assert_foo() is + # called only when Foo::Out has been activated. + # This is not what you want!!! + + +=head1 SEE ALSO + +L, L, L, L. + +=head1 AUTHOR + +Salvador FandiEo, Esfandino@yahoo.comE + +=head1 COPYRIGHT AND LICENSE + +Copyright 2005 by Salvador FandiEo + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/perl.c b/perl.c index 216923c..ba25c33 100644 --- a/perl.c +++ b/perl.c @@ -2427,37 +2427,37 @@ S_usage(pTHX_ const char *name) /* XXX move this out into a module ? */ * Removed -h because the user already knows that option. Others? */ static const char * const usage_msg[] = { -"-0[octal] specify record separator (\\0, if no argument)", -"-A[name] activate all/given assertions", -"-a autosplit mode with -n or -p (splits $_ into @F)", -"-C[number/list] enables the listed Unicode features", -"-c check syntax only (runs BEGIN and CHECK blocks)", -"-d[:debugger] run program under debugger", -"-D[number/list] set debugging flags (argument is a bit mask or alphabets)", -"-e program one line of program (several -e's allowed, omit programfile)", +"-0[octal] specify record separator (\\0, if no argument)", +"-A[mod][=pattern] activate all/given assertions", +"-a autosplit mode with -n or -p (splits $_ into @F)", +"-C[number/list] enables the listed Unicode features", +"-c check syntax only (runs BEGIN and CHECK blocks)", +"-d[:debugger] run program under debugger", +"-D[number/list] set debugging flags (argument is a bit mask or alphabets)", +"-e program one line of program (several -e's allowed, omit programfile)", #ifdef USE_SITECUSTOMIZE -"-f don't do $sitelib/sitecustomize.pl at startup", -#endif -"-F/pattern/ split() pattern for -a switch (//'s are optional)", -"-i[extension] edit <> files in place (makes backup if extension supplied)", -"-Idirectory specify @INC/#include directory (several -I's allowed)", -"-l[octal] enable line ending processing, specifies line terminator", -"-[mM][-]module execute \"use/no module...\" before executing program", -"-n assume \"while (<>) { ... }\" loop around program", -"-p assume loop like -n but print line also, like sed", -"-P run program through C preprocessor before compilation", -"-s enable rudimentary parsing for switches after programfile", -"-S look for programfile using PATH environment variable", -"-t enable tainting warnings", -"-T enable tainting checks", -"-u dump core after parsing program", -"-U allow unsafe operations", -"-v print version, subversion (includes VERY IMPORTANT perl info)", -"-V[:variable] print configuration summary (or a single Config.pm variable)", -"-w enable many useful warnings (RECOMMENDED)", -"-W enable all warnings", -"-x[directory] strip off text before #!perl line and perhaps cd to directory", -"-X disable all warnings", +"-f don't do $sitelib/sitecustomize.pl at startup", +#endif +"-F/pattern/ split() pattern for -a switch (//'s are optional)", +"-i[extension] edit <> files in place (makes backup if extension supplied)", +"-Idirectory specify @INC/#include directory (several -I's allowed)", +"-l[octal] enable line ending processing, specifies line terminator", +"-[mM][-]module execute \"use/no module...\" before executing program", +"-n assume \"while (<>) { ... }\" loop around program", +"-p assume loop like -n but print line also, like sed", +"-P run program through C preprocessor before compilation", +"-s enable rudimentary parsing for switches after programfile", +"-S look for programfile using PATH environment variable", +"-t enable tainting warnings", +"-T enable tainting checks", +"-u dump core after parsing program", +"-U allow unsafe operations", +"-v print version, subversion (includes VERY IMPORTANT perl info)", +"-V[:variable] print configuration summary (or a single Config.pm variable)", +"-w enable many useful warnings (RECOMMENDED)", +"-W enable all warnings", +"-x[directory] strip off text before #!perl line and perhaps cd to directory", +"-X disable all warnings", "\n", NULL }; @@ -2729,17 +2729,27 @@ Perl_moreswitches(pTHX_ char *s) forbid_setid("-A"); if (!PL_preambleav) PL_preambleav = newAV(); - if (*++s) { - SV *sv = newSVpv("use assertions::activate split(/,/,q", 0); - sv_catpvn(sv, "\0", 1); /* Use NUL as q//-delimiter. */ - sv_catpv(sv,s); - sv_catpvn(sv, "\0)", 2); - s+=strlen(s); + s++; + { + char *start = s; + SV *sv = newSVpv("use assertions::activate", 24); + while(isALNUM(*s) || *s == ':') ++s; + if (s != start) { + sv_catpvn(sv, "::", 2); + sv_catpvn(sv, start, s-start); + } + if (*s == '=') { + sv_catpvn(sv, " split(/,/,q\0", 13); + sv_catpv(sv, s+1); + sv_catpvn(sv, "\0)", 2); + s+=strlen(s); + } + else if (*s != '\0') { + Perl_croak(aTHX_ "Can't use '%c' after -A%.*s", *s, s-start, start); + } av_push(PL_preambleav, sv); + return s; } - else - av_push(PL_preambleav, newSVpvn("use assertions::activate",24)); - return s; case 'M': forbid_setid("-M"); /* XXX ? */ /* FALL THROUGH */ diff --git a/pod/perlrun.pod b/pod/perlrun.pod index 71af29c..a5260a9 100644 --- a/pod/perlrun.pod +++ b/pod/perlrun.pod @@ -9,7 +9,7 @@ B S<[ B<-sTtuUWX> ]> S<[ B<-cw> ] [ B<-d>[B][:I] ] [ B<-D>[I] ]> S<[ B<-pna> ] [ B<-F>I ] [ B<-l>[I] ] [ B<-0>[I] ]> S<[ B<-I>I ] [ B<-m>[B<->]I ] [ B<-M>[B<->]I<'module...'> ]> - S<[ B<-A [I] >]> + S<[ B<-A>[I][=I] ]> S<[ B<-C [I] >]> S<[ B<-P> ]> S<[ B<-S> ]> @@ -256,11 +256,17 @@ format: C<-0xHHH...>, where the C are valid hexadecimal digits. (This means that you cannot use the C<-x> with a directory name that consists of hexadecimal digits.) -=item B<-A [I]> +=item B<-A[I][=I]> -Activates the assertions given after the switch as a comma-separated -list of assertion names. If no assertion name is given, activates all -assertions. See L. +Activates the assertions given after the equal sign as a comma-separated +list of assertion names or regular expressions. If no assertion name +is given, activates all assertions. + +The module L is used by default to activate the +selected assertions. An alternate module may be specified including +its name between the switch and the equal sign. + +See L and L. =item B<-a> diff --git a/t/comp/assertions.t b/t/comp/assertions.t index da9f568..9edc13a 100644 --- a/t/comp/assertions.t +++ b/t/comp/assertions.t @@ -45,17 +45,17 @@ require assertions; while (@expr) { my $expr=shift @expr; my $expected=shift @expr; - my $result=eval {assertions::calc_expr($expr)}; + my $result=eval {assertions::_calc_expr($expr)}; if (defined $expected) { unless (defined $result and $result == $expected) { - print STDERR "assertions::calc_expr($expr) failed,". + print STDERR "assertions::_calc_expr($expr) failed,". " expected '$expected' but '$result' obtained (\$@=$@)\n"; print "not "; } } else { if (defined $result) { - print STDERR "assertions::calc_expr($expr) failed,". + print STDERR "assertions::_calc_expr($expr) failed,". " expected undef but '$result' obtained\n"; print "not "; } diff --git a/t/comp/asstcompat.t b/t/comp/asstcompat.t new file mode 100644 index 0000000..fa0a357 --- /dev/null +++ b/t/comp/asstcompat.t @@ -0,0 +1,40 @@ +#!./perl + +my $i = 1; +sub ok { + my $ok = shift; + print( ($ok ? '' : 'not '), "ok $i", (@_ ? " - @_" : ''), "\n"); + $i++; +} + +print "1..7\n"; + +# 1 +use base 'assertions::compat'; +ok(eval "sub assert_foo : assertion { 0 } ; 1", "handle assertion attribute"); + +use assertions::activate 'Foo'; + +# 2 +use assertions::compat asserting_2 => 'Foo'; +ok(asserting_2, 'on'); + +# 3 +use assertions::compat asserting_3 => 'Bar'; +ok(!asserting_3, 'off'); + +# 4 +use assertions::compat asserting_4 => '_ || Bar'; +ok(!asserting_4, 'current off or off'); + +# 5 +use assertions::compat asserting_5 => '_ || Foo'; +ok(asserting_5, 'current off or on'); + +# 6 +use assertions::compat asserting_6 => '_ || Bar'; +ok(asserting_6, 'current on or off'); + +# 7 +use assertions::compat asserting_7 => '_ && Foo'; +ok(asserting_7, 'current on and on'); diff --git a/t/run/switch_A.t b/t/run/switch_A.t index d79f430..5111b9d 100755 --- a/t/run/switch_A.t +++ b/t/run/switch_A.t @@ -13,24 +13,25 @@ BEGIN { #1 fresh_perl_is('sub cm : assertion { "ok" }; use assertions Hello; print cm()', 'ok', - { switches => ['-AHello'] }, '-AHello'); + { switches => ['-A=Hello'] }, '-A=Hello'); #2 fresh_perl_is('sub cm : assertion { "ok" }; use assertions SDFJKS; print cm()', 'ok', - { switches => ['-A.*'] }, '-A.*'); + { switches => ['-A=.*'] }, '-A=.*'); #3 fresh_perl_is('sub cm : assertion { "ok" }; use assertions Bye; print cm()', 'ok', - { switches => ['-AB.e'] }, '-AB.e'); + { switches => ['-A=B.e'] }, '-A=B.e'); #4 fresh_perl_is('sub cm : assertion { "ok" }; use assertions Hello; print cm()', '0', - { switches => ['-ANoH..o'] }, '-ANoH..o'); + { switches => ['-A=NoH..o'] }, '-A=NoH..o'); #5 fresh_perl_is('sub cm : assertion { "ok" }; use assertions Hello; print cm()', 'ok', { switches => ['-A'] }, '-A'); +