lib/Archive/Tar/t/src/short/b Archive::Tar tests
lib/Archive/Tar/t/src/short/bar.tar.packed Archive::Tar tests
lib/Archive/Tar/t/src/short/foo.tgz.packed Archive::Tar tests
-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
lib/Attribute/Handlers/demo/demo2.pl Attribute::Handlers demo
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
t/run/runenv.t Test if perl honors its environment variables.
t/run/switch0.t Test the -0 switch
t/run/switcha.t Test the -a switch
-t/run/switch_A.t Test the -A switch
t/run/switchC.t Test the -C switch
t/run/switchd.t Test the -d switch
t/run/switches.t Tests for the other switches (-0, -l, -c, -s, -M, -m, -V, -v, -h, -z, -i)
#define CVf_METHOD 0x0001 /* CV is explicitly marked as a method */
#define CVf_LOCKED 0x0002 /* CV locks itself or first arg on entry */
#define CVf_LVALUE 0x0004 /* CV return value can be used as lvalue */
-#define CVf_ASSERTION 0x0008 /* CV called only when asserting */
#define CVf_WEAKOUTSIDE 0x0010 /* CvOUTSIDE isn't ref counted */
#define CVf_CLONE 0x0020 /* anon CV uses external lexicals */
#define CVf_ISXSUB 0x0800 /* CV is an XSUB, not pure perl. */
/* This symbol for optimised communication between toke.c and op.c: */
-#define CVf_BUILTIN_ATTRS (CVf_METHOD|CVf_LOCKED|CVf_LVALUE|CVf_ASSERTION)
+#define CVf_BUILTIN_ATTRS (CVf_METHOD|CVf_LOCKED|CVf_LVALUE)
#define CvCLONE(cv) (CvFLAGS(cv) & CVf_CLONE)
#define CvCLONE_on(cv) (CvFLAGS(cv) |= CVf_CLONE)
#define CvLVALUE_on(cv) (CvFLAGS(cv) |= CVf_LVALUE)
#define CvLVALUE_off(cv) (CvFLAGS(cv) &= ~CVf_LVALUE)
-#define CvASSERTION(cv) (CvFLAGS(cv) & CVf_ASSERTION)
-#define CvASSERTION_on(cv) (CvFLAGS(cv) |= CVf_ASSERTION)
-#define CvASSERTION_off(cv) (CvFLAGS(cv) &= ~CVf_ASSERTION)
-
#define CvEVAL(cv) (CvUNIQUE(cv) && !SvFAKE(cv))
#define CvEVAL_on(cv) (CvUNIQUE_on(cv),SvFAKE_off(cv))
#define CvEVAL_off(cv) CvUNIQUE_off(cv)
if (CvMETHOD(sv)) sv_catpv(d, "METHOD,");
if (CvLOCKED(sv)) sv_catpv(d, "LOCKED,");
if (CvWEAKOUTSIDE(sv)) sv_catpv(d, "WEAKOUTSIDE,");
- if (CvASSERTION(sv)) sv_catpv(d, "ASSERTION,");
break;
case SVt_PVHV:
if (HvSHAREKEYS(sv)) sv_catpv(d, "SHAREKEYS,");
specialsv_list[5] = (SV *) pWARN_NONE;
specialsv_list[6] = (SV *) pWARN_STD;
#if PERL_VERSION <= 8
-# define CVf_ASSERTION 0
# define OPpPAD_STATE 0
#endif
#include "defsubs.h"
@hints{4096,8192,16384,32768,65536} = ('I', 'F', 'B', 'S', 'R');
# taint and eval
@hints{1048576,2097152} = ('T', 'E');
-# filetest access, UTF-8, assertions, assertions seen
-@hints{4194304,8388608,16777216,33554432} = ('X', 'U', 'A', 'a');
+# filetest access, UTF-8
+@hints{4194304,8388608} = ('X', 'U');
sub _flags {
my($hash, $x) = @_;
OPpCONST_ARYBASE OPpEXISTS_SUB OPpSORT_NUMERIC OPpSORT_INTEGER
OPpSORT_REVERSE OPpSORT_INPLACE OPpSORT_DESCEND OPpITER_REVERSED
SVf_IOK SVf_NOK SVf_ROK SVf_POK SVpad_OUR SVf_FAKE SVs_RMG SVs_SMG
- CVf_METHOD CVf_LOCKED CVf_LVALUE CVf_ASSERTION
+ CVf_METHOD CVf_LOCKED CVf_LVALUE
PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE
PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED),
($] < 5.009 ? 'PMf_SKIPWHITE' : 'RXf_SKIPWHITE');
# - here-docs?
# Current test.deparse failures
-# comp/assertions 38 - disabled assertions should be like "my($x) if 0"
-# 'sub f : assertion {}; no assertions; my $x=1; {f(my $x=2); print "$x\n"}'
# comp/hints 6 - location of BEGIN blocks wrt. block openings
# run/switchI 1 - missing -I switches entirely
# perl -Ifoo -e 'print @INC'
if ($cv->FLAGS & SVf_POK) {
$proto = "(". $cv->PV . ") ";
}
- if ($cv->CvFLAGS & (CVf_METHOD|CVf_LOCKED|CVf_LVALUE|CVf_ASSERTION)) {
+ if ($cv->CvFLAGS & (CVf_METHOD|CVf_LOCKED|CVf_LVALUE)) {
$proto .= ": ";
$proto .= "lvalue " if $cv->CvFLAGS & CVf_LVALUE;
$proto .= "locked " if $cv->CvFLAGS & CVf_LOCKED;
$proto .= "method " if $cv->CvFLAGS & CVf_METHOD;
- $proto .= "assertion " if $cv->CvFLAGS & CVf_ASSERTION;
}
local($self->{'curcv'}) = $cv;
foreach my $const (qw(
CVf_ANON
- CVf_ASSERTION
CVf_CLONE
CVf_CLONED
CVf_CONST
40 + 16 # Data::Dumper, Digest::MD5
+ 517 + 262 # B::Deparse, B
+ 595 + 190 # POSIX, IO::Socket
- + 345 * ($] > 5.009)
- + 17 * ($] >= 5.009003)
- - 366); # fudge
+ - 6); # fudge
require_ok("B::Concise");
XS => [qw( svref_2object perlstring opnumber main_start
main_root main_cv )],
- constant => [qw/ ASSIGN CVf_ASSERTION CVf_LOCKED CVf_LVALUE
+ constant => [qw/ ASSIGN CVf_LOCKED CVf_LVALUE
CVf_METHOD LIST_CONTEXT OP_CONST OP_LIST OP_RV2SV
OP_STRINGIFY OPf_KIDS OPf_MOD OPf_REF OPf_SPECIAL
OPf_STACKED OPf_WANT OPf_WANT_LIST OPf_WANT_SCALAR
+++ /dev/null
-package assertions;
-
-our $VERSION = '0.04';
-
-# use strict;
-# use warnings;
-
-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 { re::is_regexp($_)
- ? $t=~$_
- : $_->($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 @_;
- foreach my $expr (@_) {
- unless (_calc_expr $expr) {
- # print STDERR "assertions deactived";
- $^H{assertions} &= ~$hint;
- $^H{assertions} |= $seen_hint;
- return;
- }
- }
- # print STDERR "assertions actived";
- $^H{assertions} |= $hint|$seen_hint;
-}
-
-sub unimport {
- @_ > 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 - select assertions in blocks of code
-
-=head1 SYNOPSIS
-
- sub assert (&) : assertion { &{$_[0]}() }
-
- use assertions 'foo';
- assert { print "asserting 'foo'\n" };
-
- {
- use assertions qw( foo bar );
- assert { print "asserting 'foo' and 'bar'\n" };
- }
-
- {
- use assertions qw( bar );
- assert { print "asserting only 'bar'\n" };
- }
-
- {
- use assertions '_ && bar';
- assert { print "asserting 'foo' && 'bar'\n" };
- }
-
- assert { print "asserting 'foo' again\n" };
-
-=head1 DESCRIPTION
-
- *** 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.
-
-The C<assertions> 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
-at compile-time.
-
-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<assertions::activate>, L<assertions::compat>.
-
-=head1 AUTHOR
-
-Salvador FandiE<ntilde>o, E<lt>sfandino@yahoo.comE<gt>
-
-=head1 COPYRIGHT AND LICENSE
-
-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
+++ /dev/null
-package assertions::activate;
-
-our $VERSION = '0.02';
-
-sub import {
- shift;
- @_ = '.*' unless @_;
- push @{^ASSERTING}, map { ref $_ ? $_ : qr/^(?:$_)\z/ } @_;
-}
-
-1;
-__END__
-
-=head1 NAME
-
-assertions::activate - activate assertions
-
-=head1 SYNOPSIS
-
- use assertions::activate 'Foo', 'bar', 'Foo::boz::.*';
-
- # activate all assertions
- use assertions::activate;
-
-=head1 DESCRIPTION
-
-This module is used internally by perl (and its C<-A> command-line switch) to
-enable and disable assertions.
-
-Though it can also be explicetly used:
-
- 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
-given, all assertions are activated. References are activated as-is.
-
-=head1 SEE ALSO
-
-L<assertions>, L<perlrun>.
-
-=head1 AUTHOR
-
-Salvador FandiE<ntilde>o, E<lt>sfandino@yahoo.comE<gt>
-
-=head1 COPYRIGHT AND LICENSE
-
-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
+++ /dev/null
-package assertions::compat;
-
-our $VERSION = '0.02';
-
-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;
-
-*supported =
- defined($assertion_ok)
- ? \&_on
- : \&_off;
-
-unless (defined $assertion_ok) {
- package assertions;
- require warnings::register;
- warnings::register->import;
-}
-
-
-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 conditionally 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.
-
-This module also provides the C<supported> function to check if
-assertions are supported or not:
-
- my $supported = assertions::compat::supported();
-
-
-=head2 Assertion execution status as a constant
-
-C<assertions::compat> also allows to create constant subs whose value
-is the assertion execution status. That allows checking explicitly and
-efficiently when 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.
-
-
-If 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, the 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
$^W = 0;
} # Switch compilation warnings off until another BEGIN.
-# test if assertions are supported and actived:
-BEGIN {
- $ini_assertion = eval "sub asserting_test : assertion {1}; 1";
-
- # $ini_assertion = undef => assertions unsupported,
- # " = 1 => assertions supported
- # print "\$ini_assertion=$ini_assertion\n";
-}
-
local ($^W) = 0; # Switch run-time warnings off during init.
=head2 THREADS SUPPORT
signalLevel warnLevel dieLevel
inhibit_exit ImmediateStop bareStringify
CreateTTY RemotePort windowSize
- DollarCaretP OnlyAssertions WarnAssertions
+ DollarCaretP
);
-@RememberOnROptions = qw(DollarCaretP OnlyAssertions);
+@RememberOnROptions = qw(DollarCaretP);
=pod
ImmediateStop => \$ImmediateStop,
RemotePort => \$remoteport,
windowSize => \$window,
- WarnAssertions => \$warnassertions,
HistFile => \$histfile,
HistSize => \$histsize,
);
ornaments => \&ornaments,
RemotePort => \&RemotePort,
DollarCaretP => \&DollarCaretP,
- OnlyAssertions=> \&OnlyAssertions,
);
=pod
# Called in array context. call sub and capture output.
# DB::DB will recursively get control again if appropriate; we'll come
# back here when the sub is finished.
- if ($assertion) {
- $assertion = 0;
- eval { @ret = &$sub; };
- if ($@) {
- print $OUT $@;
- $signal = 1 unless $warnassertions;
- }
- }
- else {
- @ret = &$sub;
- }
+ @ret = &$sub;
# Pop the single-step value back off the stack.
$single |= $stack[ $stack_depth-- ];
# Scalar context.
else {
- if ($assertion) {
- $assertion = 0;
- eval {
-
- # Save the value if it's wanted at all.
- $ret = &$sub;
- };
- if ($@) {
- print $OUT $@;
- $signal = 1 unless $warnassertions;
- }
- $ret = undef unless defined wantarray;
- }
- else {
- if ( defined wantarray ) {
+ if ( defined wantarray ) {
- # Save the value if it's wanted at all.
- $ret = &$sub;
- }
- else {
+ # Save the value if it's wanted at all.
+ $ret = &$sub;
+ }
+ else {
- # Void return, explicitly.
- &$sub;
- undef $ret;
- }
- } # if assertion
+ # Void return, explicitly.
+ &$sub;
+ undef $ret;
+ }
# Pop the single-step value off the stack.
$single |= $stack[ $stack_depth-- ];
These are general support routines that are used in a number of places
throughout the debugger.
-=over 4
-
-=item cmd_P
-
-Something to do with assertions
-
-=back
-
-=cut
-
-sub cmd_P {
- unless ($ini_assertion) {
- print $OUT "Assertions not supported in this Perl interpreter\n";
- } else {
- if ( $cmd =~ /^.\b\s*([+-]?)\s*(~?)\s*(\w+(\s*\|\s*\w+)*)\s*$/ ) {
- my ( $how, $neg, $flags ) = ( $1, $2, $3 );
- my $acu = parse_DollarCaretP_flags($flags);
- if ( defined $acu ) {
- $acu = ~$acu if $neg;
- if ( $how eq '+' ) { $^P |= $acu }
- elsif ( $how eq '-' ) { $^P &= ~$acu }
- else { $^P = $acu }
- }
-
- # else { print $OUT "undefined acu\n" }
- }
- my $expanded = expand_DollarCaretP_flags($^P);
- print $OUT "Internal Perl debugger flags:\n\$^P=$expanded\n";
- $expanded;
- }
-}
-
=head2 save
save() saves the user's versions of globals that would mess us up in C<@saved>,
expand_DollarCaretP_flags($^P);
}
-sub OnlyAssertions {
- if ($term) {
- &warn("Too late to set up OnlyAssertions mode, enabled on next 'R'!\n")
- if @_;
- }
- if (@_) {
- unless ( defined $ini_assertion ) {
- if ($term) {
- &warn("Current Perl interpreter doesn't support assertions");
- }
- return 0;
- }
- if (shift) {
- unless ($ini_assertion) {
- print "Assertions will be active on next 'R'!\n";
- $ini_assertion = 1;
- }
- $^P &= ~$DollarCaretP_flags{PERLDBf_SUB};
- $^P |= $DollarCaretP_flags{PERLDBf_ASSERTION};
- }
- else {
- $^P |= $DollarCaretP_flags{PERLDBf_SUB};
- }
- }
- !( $^P & $DollarCaretP_flags{PERLDBf_SUB} ) || 0;
-}
-
=head2 C<pager>
Set up the C<$pager> variable. Adds a pipe to the front unless there's one
B<e> Display current thread id.
B<E> Display all thread ids the current one will be identified: <n>.
B<y> [I<n> [I<Vars>]] List lexicals in higher scope <n>. Vars same as B<V>.
-B<P> Something to do with assertions...
B<<> ? List Perl commands to run before each prompt.
B<<> I<expr> Define Perl command to run before each prompt.
PERLDBf_GOTO => 0x80, # Report goto: call DB::goto
PERLDBf_NAMEEVAL => 0x100, # Informative names for evals
PERLDBf_NAMEANON => 0x200, # Informative names for anon subs
- PERLDBf_ASSERTION => 0x400, # Debug assertion subs enter/exit
- PERLDB_ALL => 0x33f, # No _NONAME, _GOTO, _ASSERTION
+ PERLDB_ALL => 0x33f, # No _NONAME, _GOTO
);
%DollarCaretP_flags_r = reverse %DollarCaretP_flags;
# If warn was on before, turn it on again.
push @flags, '-w' if $ini_warn;
- if ( $ini_assertion and @{^ASSERTING} ) {
- push @flags,
- ( map { /\:\^\(\?\:(.*)\)\$\)/ ? "-A$1" : "-A$_" }
- @{^ASSERTING} );
- }
# Rebuild the -I flags that were on the initial
# command line.
proto = SvPV((SV*)cv, len);
proto_end = proto + len;
}
- if (CvASSERTION(cv)) {
- U32 asserthints = 0;
- HV *const hinthv = GvHV(PL_hintgv);
- if (hinthv) {
- SV **svp = hv_fetchs(hinthv, "assertions", FALSE);
- if (svp && *svp)
- asserthints = SvUV(*svp);
- }
- if (asserthints & HINT_ASSERTING) {
- if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
- o->op_private |= OPpENTERSUB_DB;
- }
- else {
- delete_op = 1;
- if (!(asserthints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
- Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
- "Impossible to activate assertion call");
- }
- }
- }
}
}
}
PL_DBsingle = NULL;
PL_DBtrace = NULL;
PL_DBsignal = NULL;
- PL_DBassertion = NULL;
PL_DBcv = NULL;
PL_dbargs = NULL;
PL_debstash = NULL;
case 'W':
case 'X':
case 'w':
- case 'A':
if ((s = moreswitches(s)))
goto reswitch;
break;
static const char * const usage_msg[] = {
"-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)",
}
}
return s;
- case 'A':
- forbid_setid('A', -1);
- s++;
- {
- char * const start = s;
- SV * const sv = newSVpvs("use assertions::activate");
- while(isALNUM(*s) || *s == ':') ++s;
- if (s != start) {
- sv_catpvs(sv, "::");
- sv_catpvn(sv, start, s-start);
- }
- if (*s == '=') {
- Perl_sv_catpvf(aTHX_ sv, " split(/,/,q%c%s%c)", 0, ++s, 0);
- s+=strlen(s);
- }
- else if (*s != '\0') {
- Perl_croak(aTHX_ "Can't use '%c' after -A%.*s", *s, (int)(s-start), start);
- }
- Perl_av_create_and_push(aTHX_ &PL_preambleav, sv);
- return s;
- }
case 'M':
forbid_setid('M', -1); /* XXX ? */
/* FALL THROUGH */
sv_setiv(PL_DBtrace, 0);
PL_DBsignal = GvSV((gv_fetchpvs("DB::signal", GV_ADDMULTI, SVt_PV)));
sv_setiv(PL_DBsignal, 0);
- PL_DBassertion = GvSV((gv_fetchpvs("DB::assertion", GV_ADDMULTI, SVt_PV)));
- sv_setiv(PL_DBassertion, 0);
PL_curstash = ostash;
}
#define HINT_FILETEST_ACCESS 0x00400000 /* filetest pragma */
#define HINT_UTF8 0x00800000 /* utf8 pragma */
-/* assertions pragma, stored in $^H{assertions} */
-#define HINT_ASSERTING 0x00000001
-#define HINT_ASSERTIONSSEEN 0x00000002
-
/* The following are stored in $^H{sort}, not in PL_hints */
#define HINT_SORT_SORT_BITS 0x000000FF /* allow 256 different ones */
#define HINT_SORT_QUICKSORT 0x00000001
#define PERLDBf_GOTO 0x80 /* Report goto: call DB::goto */
#define PERLDBf_NAMEEVAL 0x100 /* Informative names for evals */
#define PERLDBf_NAMEANON 0x200 /* Informative names for anon subs */
-#define PERLDBf_ASSERTION 0x400 /* Debug assertion subs enter/exit */
#define PERLDB_SUB (PL_perldb && (PL_perldb & PERLDBf_SUB))
#define PERLDB_LINE (PL_perldb && (PL_perldb & PERLDBf_LINE))
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...'> ] [ B<-f> ]>
- S<[ B<-A>[I<module>][=I<assertions>] ]>
S<[ B<-C [I<number/list>] >]>
S<[ B<-P> ]>
S<[ B<-S> ]>
didn't see the expected delimiter between key and value, so the line was
ignored.
-=item Impossible to activate assertion call
-
-(W assertions) You're calling an assertion function in a block that is
-not under the control of the C<assertions> pragma.
-
=item (in cleanup) %s
(W misc) This prefix usually indicates that a DESTROY() method raised
all -+
|
- +- assertions
- |
+- closure
|
+- deprecated
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...'> ] [ B<-f> ]>
- 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<module>][=I<assertions>]>
-X<-A>
-
-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>
X<-a> X<autosplit>
The old perltodo notes "Look at the "reification" code in C<av.c>".
-=head2 What hooks would assertions need?
-
-Assertions are in the core, and work. However, assertions needed to be added
-as a core patch, rather than an XS module in ext, or a CPAN module, because
-the core has no hooks in the necessary places. It would be useful to
-investigate what hooks would need to be added to make it possible to provide
-the full assertion support from a CPAN module, so that we aren't constraining
-the imagination of future CPAN authors.
-
=head2 Properly Unicode safe tokeniser and pads.
The tokeniser isn't actually very UTF-8 clean. C<use utf8;> is a hack -
gimme = GIMME_V;
if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
- if (CvASSERTION(cv) && PL_DBassertion)
- sv_setiv(PL_DBassertion, 1);
-
Perl_get_db_sub(aTHX_ &sv, cv);
if (CvISXSUB(cv))
PL_curcopdb = PL_curcop;
PL_DBsingle = sv_dup(proto_perl->IDBsingle, param);
PL_DBtrace = sv_dup(proto_perl->IDBtrace, param);
PL_DBsignal = sv_dup(proto_perl->IDBsignal, param);
- PL_DBassertion = sv_dup(proto_perl->IDBassertion, param);
PL_dbargs = av_dup(proto_perl->Idbargs, param);
/* symbol tables */
+++ /dev/null
-#!./perl
-
-BEGIN { $^W=0 }
-
-use base 'assertions::compat';
-
-sub callme ($ ) : assertion {
- return shift;
-}
-
-# select STDERR; $|=1;
-
-my @expr=( '1' => 1,
- '0' => 0,
- '1 && 1' => 1,
- '1 && 0' => 0,
- '0 && 1' => 0,
- '0 && 0' => 0,
- '1 || 1' => 1,
- '1 || 0' => 1,
- '0 || 1' => 1,
- '0 || 0' => 0,
- '(1)' => 1,
- '(0)' => 0,
- '1 && ((1) && 1)' => 1,
- '1 && (0 || 1)' => 1,
- '1 && ( 0' => undef,
- '1 &&' => undef,
- '&& 1' => undef,
- '1 && || 1' => undef,
- '(1 && 1) && 1)' => undef,
- 'one && two' => 1,
- '_ && one' => 0,
- 'one && three' => 0,
- '1 ' => 1,
- ' 1' => 1,
- ' 1 ' => 1,
- ' ( 1 && 1 ) ' => 1,
- ' ( 1 && 0 ) ' => 0,
- '(( 1 && 1) && ( 1 || 0)) || _ && one && ( one || three)' => 1 );
-
-my $supported = assertions::compat::supported();
-
-my $n=@expr/2 + ($supported ? 12 : 0);
-my $i=1;
-print "1..$n\n";
-
-use assertions::activate 'one', 'two';
-require assertions;
-
-while (@expr) {
- my $expr=shift @expr;
- my $expected=shift @expr;
- my $result=eval {assertions::_calc_expr($expr)};
- if (defined $expected) {
- unless (defined $result and $result == $expected) {
- 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,".
- " expected undef but '$result' obtained\n";
- print "not ";
- }
- }
- print "ok ", $i++, "\n";
-}
-
-if ($supported) {
-
- # @expr/2+1
- if (callme(1)) {
- print STDERR "assertions called by default\n";
- print "not ";
- }
- print "ok ", $i++, "\n";
-
- # 2
- use assertions::activate 'mine';
- {
- package mine;
- use base 'assertions::compat';
- sub callme ($) : assertion {
- return shift;
- }
- use assertions;
- unless (callme(1)) {
- print STDERR "'use assertions;' doesn't active assertions based on package name\n";
- print "not ";
- }
- }
- print "ok ", $i++, "\n";
-
- # 3
- use assertions 'foo';
- if (callme(1)) {
- print STDERR "assertion deselection doesn't work\n";
- print "not ";
- }
- print "ok ", $i++, "\n";
-
- # 4
- use assertions::activate 'bar', 'doz';
- use assertions 'bar';
- unless (callme(1)) {
- print STDERR "assertion selection doesn't work\n";
- print "not ";
- }
- print "ok ", $i++, "\n";
-
- # 5
- use assertions q(_ && doz);
- unless (callme(1)) {
- print STDERR "assertion activation filtering doesn't work\n";
- print "not ";
- }
- print "ok ", $i++, "\n";
-
- # 6
- use assertions q(_ && foo);
- if (callme(1)) {
- print STDERR "assertion deactivation filtering doesn't work\n";
- print "not ";
- }
- print "ok ", $i++, "\n";
-
- # 7
- if (1) {
- use assertions 'bar';
- }
- if (callme(1)) {
- print STDERR "assertion scoping doesn't work\n";
- print "not ";
- }
- print "ok ", $i++, "\n";
-
- # 8
- use assertions::activate 're.*';
- use assertions 'reassert';
- unless (callme(1)) {
- print STDERR "assertion selection with re failed\n";
- print "not ";
- }
- print "ok ", $i++, "\n";
-
- # 9
- my $b=12;
- {
- use assertions 'bar';
- callme(my $b=45);
- unless ($b == 45) {
- print STDERR "this shouldn't fail ever (b=$b)\n";
- print "not ";
- }
- }
- print "ok ", $i++, "\n";
-
- # 10
- {
- no assertions;
- callme(my $b=46);
- if (defined $b) {
- print STDERR "lexical declaration in assertion arg ignored (b=$b\n";
- print "not ";
- }
- }
- print "ok ", $i++, "\n";
-
- # 11
- {
- use assertions::activate sub { return 1 if $_[0] eq 'via_sub' };
- use assertions 'via_sub';
- callme(my $b=47);
- unless ($b == 47) {
- print STDERR "this shouldn't fail ever (b=$b)\n";
- print "not ";
- }
- }
- print "ok ", $i++, "\n";
-
- # 12
- {
- use assertions 'not_asserted';
- callme(my $b=48);
- if ($b == 48) {
- print STDERR "this shouldn't fail ever (b=$b)\n";
- print "not ";
- }
- }
- print "ok ", $i++, "\n";
-}
+++ /dev/null
-#!./perl
-
-BEGIN { $^W = 0 }
-
-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');
my @code = qw(lvalue locked method);
-unshift @code, 'assertion' if $] >= 5.009;
my @other = qw(shared unique);
my %valid;
$valid{CODE} = {map {$_ => 1} @code};
+++ /dev/null
-#!./perl
-
-BEGIN {
- chdir 't' if -d 't';
- @INC = '../lib';
- require './test.pl';
-}
-
-BEGIN {
- plan(5);
-}
-
-#1
-fresh_perl_is('sub cm : assertion { "ok" }; use assertions Hello; print cm()',
- 'ok',
- { switches => ['-A=Hello'] }, '-A=Hello');
-
-#2
-fresh_perl_is('sub cm : assertion { "ok" }; use assertions SDFJKS; print cm()',
- 'ok',
- { switches => ['-A=.*'] }, '-A=.*');
-
-#3
-fresh_perl_is('sub cm : assertion { "ok" }; use assertions Bye; print cm()',
- 'ok',
- { switches => ['-A=B.e'] }, '-A=B.e');
-
-#4
-fresh_perl_is('sub cm : assertion { "ok" }; use assertions Hello; print cm()',
- '0',
- { switches => ['-A=NoH..o'] }, '-A=NoH..o');
-
-#5
-fresh_perl_is('sub cm : assertion { "ok" }; use assertions Hello; print cm()',
- 'ok',
- { switches => ['-A'] }, '-A');
-
sv_free(sv);
CvMETHOD_on(PL_compcv);
}
- else if (!PL_in_my && len == 9 && strnEQ(SvPVX(sv), "assertion", len)) {
- sv_free(sv);
- CvASSERTION_on(PL_compcv);
- }
/* After we've set the flags, it could be argued that
we don't need to do the attributes.pm-based setting
process, and shouldn't bother appending recognized
'pack' => [ 5.008, DEFAULT_OFF],
'unpack' => [ 5.008, DEFAULT_OFF],
'threads' => [ 5.008, DEFAULT_OFF],
- 'assertions' => [ 5.009, DEFAULT_OFF],
#'default' => [ 5.008, DEFAULT_ON ],
}],
switch (SvTYPE(sv)) {
case SVt_PVCV:
switch ((int)len) {
-#ifdef CVf_ASSERTION
- case 9:
- if (memEQ(name, "assertion", 9)) {
- if (negated)
- CvFLAGS((CV*)sv) &= ~CVf_ASSERTION;
- else
- CvFLAGS((CV*)sv) |= CVf_ASSERTION;
- continue;
- }
- break;
-#endif
case 6:
switch (name[3]) {
#ifdef CVf_LVALUE
XPUSHs(sv_2mortal(newSVpvs("method")));
if (GvUNIQUE(CvGV((CV*)sv)))
XPUSHs(sv_2mortal(newSVpvs("unique")));
- if (cvflags & CVf_ASSERTION)
- XPUSHs(sv_2mortal(newSVpvs("assertion")));
break;
case SVt_PVGV:
if (GvUNIQUE(sv))
projects / platform / upstream / perl.git / commitdiff