summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ext/B/t/deparse.t7
-rw-r--r--lib/assertions.pm21
-rw-r--r--lib/assertions/activate.pm2
-rw-r--r--lib/perl5db.pl46
-rw-r--r--lib/warnings.pm12
-rw-r--r--op.c8
-rw-r--r--perl.h2
-rw-r--r--perlapi.c2
-rw-r--r--pod/perldiag.pod5
-rw-r--r--warnings.h4
-rw-r--r--warnings.pl2
11 files changed, 75 insertions, 36 deletions
diff --git a/ext/B/t/deparse.t b/ext/B/t/deparse.t
index ce133d0dff..1078112fe6 100644
--- a/ext/B/t/deparse.t
+++ b/ext/B/t/deparse.t
@@ -25,7 +25,12 @@ print "ok " . $i++ . "\n";
# Tell B::Deparse about our ambient pragmas
{ my ($hint_bits, $warning_bits);
- BEGIN {($hint_bits, $warning_bits) = ($^H, ${^WARNING_BITS})}
+ # Note: there used to be ${^WARNING_BITS} here, instead of
+ # warnings::bits('all'), but this doesn't work, as ${^WARNING_BITS} is
+ # supposed to be the set of warnings this code has been compiled with, and
+ # later in this test we include modules that themselves use warnings::register
+ # (thus modyfing the warnings mask).
+ BEGIN { ($hint_bits, $warning_bits) = ($^H, warnings::bits('all')); }
$deparse->ambient_pragmas (
hint_bits => $hint_bits,
warning_bits => $warning_bits,
diff --git a/lib/assertions.pm b/lib/assertions.pm
index 918808d00d..7af0fb0994 100644
--- a/lib/assertions.pm
+++ b/lib/assertions.pm
@@ -6,6 +6,7 @@ our $VERSION = '0.01';
# use warnings;
my $hint=0x01000000;
+my $seen_hint=0x02000000;
sub syntax_error ($$) {
my ($expr, $why)=@_;
@@ -13,6 +14,15 @@ sub syntax_error ($$) {
Carp::croak("syntax error on assertion filter '$expr' ($why)");
}
+sub my_warn ($) {
+ my $error=shift;
+ require warnings;
+ if (warnings::enabled('assertions')) {
+ require Carp;
+ Carp::carp($error);
+ }
+}
+
sub calc_expr {
my $expr=shift;
my @tokens=split / \s*
@@ -30,6 +40,8 @@ sub calc_expr {
my @op='start';
for my $t (@tokens) {
+ next if (!defined $t or $t eq '');
+
if ($t eq '(') {
unshift @now, 1;
unshift @op, 'start';
@@ -45,9 +57,6 @@ sub calc_expr {
and syntax_error $expr, 'consecutive operators';
$op[0]='&&';
}
- elsif (!defined $t or $t eq '') {
- # warn "empty token";
- }
else {
if ($t eq ')') {
@now==1 and
@@ -59,6 +68,9 @@ sub calc_expr {
shift @op;
}
elsif ($t eq '_') {
+ unless ($^H & $seen_hint) {
+ my_warn "assertion status '_' referenced but not previously defined";
+ }
$t=($^H & $hint) ? 1 : 0;
}
elsif ($t ne '0' and $t ne '1') {
@@ -98,11 +110,12 @@ sub import {
unless (calc_expr $expr) {
# print STDERR "assertions deactived";
$^H &= ~$hint;
+ $^H |= $seen_hint;
return;
}
}
# print STDERR "assertions actived";
- $^H |= $hint;
+ $^H |= $hint|$seen_hint;
}
diff --git a/lib/assertions/activate.pm b/lib/assertions/activate.pm
index f3abd1e380..0ce73f3316 100644
--- a/lib/assertions/activate.pm
+++ b/lib/assertions/activate.pm
@@ -8,7 +8,7 @@ our $VERSION = '0.01';
sub import {
shift;
@_='.*' unless @_;
- push @{^ASSERTING}, ( map { qr/^$_$/ } @_) ;
+ push @{^ASSERTING}, ( map { qr/^(?:$_)$/ } @_) ;
}
1;
diff --git a/lib/perl5db.pl b/lib/perl5db.pl
index 31a562dd72..7c8507c066 100644
--- a/lib/perl5db.pl
+++ b/lib/perl5db.pl
@@ -332,18 +332,11 @@ BEGIN { $ini_warn = $^W; $^W = 0 } # Switch compilation warnings off until anoth
# test if assertions are supported and actived:
BEGIN {
$ini_assertion=
- eval "sub asserting_test : assertion {1}; asserting_test()";
+ eval "sub asserting_test : assertion {1}; 1";
# $ini_assertion = undef => assertions unsupported,
- # " = 0 => assertions supported but inactive
- # " = 1 => assertions suported and active
+ # " = 1 => assertions suported
# print "\$ini_assertion=$ini_assertion\n";
}
-INIT { # We use also INIT {} because test doesn't work in BEGIN {} if
- # '-A' flag is in the perl script source file after the shebang
- # as in '#!/usr/bin/perl -A'
- $ini_assertion=
- eval "sub asserting_test1 : assertion {1}; asserting_test1()";
-}
local($^W) = 0; # Switch run-time warnings off during init.
warn ( # Do not ;-)
@@ -1001,7 +994,10 @@ EOP
print $OUT "Warning: some settings and command-line options may be lost!\n";
my (@script, @flags, $cl);
push @flags, '-w' if $ini_warn;
- push @flags, '-A' if $ini_assertion;
+ if ($ini_assertion and @{^ASSERTING}) {
+ push @flags, (map { /\:\^\(\?\:(.*)\)\$\)/ ?
+ "-A$1" : "-A$_" } @{^ASSERTING});
+ }
# Put all the old includes at the start to get
# the same debugger.
for (@ini_INC) {
@@ -2630,23 +2626,23 @@ sub OnlyAssertions {
&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");
+ unless (defined $ini_assertion) {
+ if ($term) {
+ &warn("Current Perl interpreter doesn't support assertions");
+ }
+ return 0;
}
- return 0;
- }
- if (shift) {
- unless ($ini_assertion) {
- print "Assertions will also be actived on next 'R'!\n";
- $ini_assertion=1;
+ 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};
- $^P|=$DollarCaretP_flags{PERLDBf_ASSERTION};
- }
- else {
- $^P|=$DollarCaretP_flags{PERLDBf_SUB};
- }
}
!($^P & $DollarCaretP_flags{PERLDBf_SUB}) || 0;
}
diff --git a/lib/warnings.pm b/lib/warnings.pm
index 0400a17527..06091c3788 100644
--- a/lib/warnings.pm
+++ b/lib/warnings.pm
@@ -180,11 +180,16 @@ use Carp ;
'utf8' => 88,
'void' => 90,
'y2k' => 92,
+
+ # Warnings Categories added in Perl 5.009
+
+ 'assertions' => 94,
);
%Bits = (
- 'all' => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x15", # [0..46]
+ 'all' => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55", # [0..47]
'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [29]
+ 'assertions' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40", # [47]
'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [30]
'closed' => "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
'closure' => "\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
@@ -233,8 +238,9 @@ use Carp ;
);
%DeadBits = (
- 'all' => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\x2a", # [0..46]
+ 'all' => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa", # [0..47]
'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [29]
+ 'assertions' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80", # [47]
'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [30]
'closed' => "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
'closure' => "\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
@@ -283,7 +289,7 @@ use Carp ;
);
$NONE = "\0\0\0\0\0\0\0\0\0\0\0\0";
-$LAST_BIT = 94 ;
+$LAST_BIT = 96 ;
$BYTES = 12 ;
$All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
diff --git a/op.c b/op.c
index f0156187a7..0ea6146bd6 100644
--- a/op.c
+++ b/op.c
@@ -5814,7 +5814,13 @@ Perl_ck_subr(pTHX_ OP *o)
if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
o->op_private |= OPpENTERSUB_DB;
}
- else delete=1;
+ else {
+ delete=1;
+ if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) {
+ Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
+ "Impossible to activate assertion call");
+ }
+ }
}
}
}
diff --git a/perl.h b/perl.h
index 0253a435b8..618da60480 100644
--- a/perl.h
+++ b/perl.h
@@ -3241,7 +3241,9 @@ enum { /* pass one of these to get_vtbl */
#define HINT_FILETEST_ACCESS 0x00400000 /* filetest pragma */
#define HINT_UTF8 0x00800000 /* utf8 pragma */
+/* assertions pragma */
#define HINT_ASSERTING 0x01000000
+#define HINT_ASSERTIONSSEEN 0x02000000
/* The following are stored in $sort::hints, not in PL_hints */
#define HINT_SORT_SORT_BITS 0x000000FF /* allow 256 different ones */
diff --git a/perlapi.c b/perlapi.c
index e6d4219475..83d30a9477 100644
--- a/perlapi.c
+++ b/perlapi.c
@@ -1,7 +1,7 @@
/*
* perlapi.c
*
- * Copyright (c) 1997-2002, Larry Wall
+ * Copyright (c) 1997-2003, Larry Wall
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index e64253e559..3881288f78 100644
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -1770,6 +1770,11 @@ name or CLI symbol definition when preparing to iterate over %ENV, and
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
diff --git a/warnings.h b/warnings.h
index 02c3cc2014..2798467a25 100644
--- a/warnings.h
+++ b/warnings.h
@@ -73,6 +73,10 @@
#define WARN_VOID 45
#define WARN_Y2K 46
+/* Warnings Categories added in Perl 5.009 */
+
+#define WARN_ASSERTIONS 47
+
#define WARNsize 12
#define WARN_ALLstring "\125\125\125\125\125\125\125\125\125\125\125\125"
#define WARN_NONEstring "\0\0\0\0\0\0\0\0\0\0\0\0"
diff --git a/warnings.pl b/warnings.pl
index 20ed7ffb07..875d91e314 100644
--- a/warnings.pl
+++ b/warnings.pl
@@ -63,6 +63,8 @@ my $tree = {
'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 ],
}],
} ;
View Lorry Controller Status