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
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
package assertions;
-our $VERSION = '0.01';
+our $VERSION = '0.02';
# use strict;
# use warnings;
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
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;
}
}
}
- @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];
}
shift;
@_=(scalar(caller)) unless @_;
foreach my $expr (@_) {
- unless (calc_expr $expr) {
+ unless (_calc_expr $expr) {
# print STDERR "assertions deactived";
$^H &= ~$hint;
$^H |= $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__
}
{
- use assertions ' _ && bar ';
+ use assertions '_ && bar';
assert { print "asserting 'foo' && 'bar'\n" };
}
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<assertion> 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<assertions> 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<foo>, C<foobar>, C<foofoo>, 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<use
+assertions> 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<assertions> 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<assertions> is loaded with the C<require> keyword
+to avoid calling C<assertions::import()>).
+
+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<assertion::seen(1)> 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<assertions::compat> provides an alternative way to use assertions
+compatible with lower versions of perl.
+
=head1 SEE ALSO
-L<perlrun>.
+L<perlrun>, L<assertions::activate>, L<assertions::compat>.
=head1 AUTHOR
=head1 COPYRIGHT AND LICENSE
-Copyright 2002 by Salvador FandiE<ntilde>o
+Copyright 2002, 2005 by Salvador FandiE<ntilde>o
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.
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;
=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
=head1 COPYRIGHT AND LICENSE
-Copyright 2002 by Salvador FandiE<ntilde>o
+Copyright 2002, 2005 by Salvador FandiE<ntilde>o
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
--- /dev/null
+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<assertions::compat> 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<assertion> attribute handler
+
+The subroutine attribute C<assertion> is not recognised on perls
+without assertion support. This module provides a
+C<MODIFY_CODE_ATTRIBUTES> 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<unconditionally> called on perl without
+native support for them.
+
+=head2 Assertion execution status as a constant
+
+C<assertions::compat> 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<ASST>. Its value is true when assertions
+tagged as C<Foo::Bar> has been activated via L<assertions::activate>;
+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<and> statement at compile time.
+
+
+When no assertion selection tags are passed to C<use
+assertions::compat>, 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<asserting>
+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<perlrun>, L<assertions>, L<assertions::activate>, L<attributes>.
+
+=head1 AUTHOR
+
+Salvador FandiE<ntilde>o, E<lt>sfandino@yahoo.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2005 by Salvador FandiE<ntilde>o
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
* 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
};
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 */
S<[ B<-cw> ] [ B<-d>[B<t>][:I<debugger>] ] [ B<-D>[I<number/list>] ]>
S<[ B<-pna> ] [ B<-F>I<pattern> ] [ B<-l>[I<octal>] ] [ B<-0>[I<octal/hexadecimal>] ]>
S<[ B<-I>I<dir> ] [ B<-m>[B<->]I<module> ] [ B<-M>[B<->]I<'module...'> ]>
- S<[ B<-A [I<assertions>] >]>
+ S<[ B<-A>[I<module>][=I<assertions>] ]>
S<[ B<-C [I<number/list>] >]>
S<[ B<-P> ]>
S<[ B<-S> ]>
(This means that you cannot use the C<-x> with a directory name that
consists of hexadecimal digits.)
-=item B<-A [I<assertions>]>
+=item B<-A[I<module>][=I<assertions>]>
-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<assertions>.
+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<assertions::activate> 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<assertions> and L<assertions::activate>.
=item B<-a>
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 ";
}
--- /dev/null
+#!./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');
#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');
+
projects / p5sagit/p5-mst-13.2.git / commitdiff