Change 18727 by [EMAIL PROTECTED] on 2003/02/16 13:55:10
add support for assertions. Updated form of:
Subject: Re: Did the assertion patch/feature submission get overlooked?
From: Salvador =?ISO-8859-1?Q?Fandi=F1o?= <[EMAIL PROTECTED]>
Date: Sat, 30 Nov 2002 17:24:09 +0000
Message-ID: <[EMAIL PROTECTED]>
Affected files ...
... //depot/perl/MANIFEST#980 edit
... //depot/perl/cv.h#42 edit
... //depot/perl/dump.c#136 edit
... //depot/perl/embed.pl#326 edit
... //depot/perl/embedvar.h#159 edit
... //depot/perl/ext/B/B/Deparse.pm#126 edit
... //depot/perl/ext/B/defsubs_h.PL#15 edit
... //depot/perl/intrpvar.h#115 edit
... //depot/perl/lib/assertions.pm#1 add
... //depot/perl/lib/assertions/activate.pm#1 add
... //depot/perl/lib/perl5db.pl#92 edit
... //depot/perl/op.c#541 edit
... //depot/perl/perl.c#466 edit
... //depot/perl/perl.h#485 edit
... //depot/perl/perlapi.h#81 edit
... //depot/perl/pp_hot.c#304 edit
... //depot/perl/sv.c#630 edit
... //depot/perl/toke.c#462 edit
... //depot/perl/xsutils.c#21 edit
Differences ...
==== //depot/perl/MANIFEST#980 (text) ====
Index: perl/MANIFEST
--- perl/MANIFEST#979~18712~ Sat Feb 15 00:39:38 2003
+++ perl/MANIFEST Sun Feb 16 05:55:10 2003
@@ -911,7 +911,9 @@
lib/AnyDBM_File.pm Perl module to emulate dbmopen
lib/AnyDBM_File.t See if AnyDBM_File works
lib/assert.pl assertion and panic with stack trace
-lib/Attribute/Handlers.pm Attribute::Handlers
+lib/assertions.pm module support for -A flag
+lib/assertions/activate.pm assertions activate/deactivate
+lib/Attribute/Handlers.pm Attribute::Handlers
lib/Attribute/Handlers/Changes Attribute::Handlers
lib/Attribute/Handlers/demo/demo.pl Attribute::Handlers demo
lib/Attribute/Handlers/demo/Demo.pm Attribute::Handlers demo
==== //depot/perl/cv.h#42 (text) ====
Index: perl/cv.h
--- perl/cv.h#41~18354~ Wed Dec 25 19:54:09 2002
+++ perl/cv.h Sun Feb 16 05:55:10 2003
@@ -82,9 +82,10 @@
#define CVf_LVALUE 0x0100 /* CV return value can be used as lvalue */
#define CVf_CONST 0x0200 /* inlinable sub */
#define CVf_WEAKOUTSIDE 0x0400 /* CvOUTSIDE isn't ref counted */
+#define CVf_ASSERTION 0x0800 /* CV called only when asserting */
/* This symbol for optimised communication between toke.c and op.c: */
-#define CVf_BUILTIN_ATTRS (CVf_METHOD|CVf_LOCKED|CVf_LVALUE)
+#define CVf_BUILTIN_ATTRS (CVf_METHOD|CVf_LOCKED|CVf_LVALUE|CVf_ASSERTION)
#define CvCLONE(cv) (CvFLAGS(cv) & CVf_CLONE)
#define CvCLONE_on(cv) (CvFLAGS(cv) |= CVf_CLONE)
@@ -123,6 +124,10 @@
#define CvLVALUE(cv) (CvFLAGS(cv) & CVf_LVALUE)
#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))
==== //depot/perl/dump.c#136 (text) ====
Index: perl/dump.c
--- perl/dump.c#135~18640~ Sun Feb 2 15:38:40 2003
+++ perl/dump.c Sun Feb 16 05:55:10 2003
@@ -1008,6 +1008,7 @@
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,");
==== //depot/perl/embed.pl#326 (xtext) ====
Index: perl/embed.pl
--- perl/embed.pl#325~18718~ Sun Feb 16 01:47:02 2003
+++ perl/embed.pl Sun Feb 16 05:55:10 2003
@@ -219,7 +219,7 @@
curcop compiling
tainting tainted stack_base stack_sp sv_arenaroot
no_modify
- curstash DBsub DBsingle debstash
+ curstash DBsub DBsingle DBassertion debstash
rsfp
stdingv
defgv
==== //depot/perl/embedvar.h#159 (text+w) ====
Index: perl/embedvar.h
--- perl/embedvar.h#158~18715~ Sat Feb 15 13:19:37 2003
+++ perl/embedvar.h Sun Feb 16 05:55:10 2003
@@ -165,6 +165,7 @@
#define PL_Argv (vTHX->IArgv)
#define PL_Cmd (vTHX->ICmd)
+#define PL_DBassertion (vTHX->IDBassertion)
#define PL_DBcv (vTHX->IDBcv)
#define PL_DBgv (vTHX->IDBgv)
#define PL_DBline (vTHX->IDBline)
@@ -455,6 +456,7 @@
#define PL_IArgv PL_Argv
#define PL_ICmd PL_Cmd
+#define PL_IDBassertion PL_DBassertion
#define PL_IDBcv PL_DBcv
#define PL_IDBgv PL_DBgv
#define PL_IDBline PL_DBline
@@ -908,6 +910,7 @@
#ifdef PERL_POLLUTE /* disabled by default in 5.6.0 */
+#define DBassertion PL_DBassertion
#define DBsingle PL_DBsingle
#define DBsub PL_DBsub
#define compiling PL_compiling
==== //depot/perl/ext/B/B/Deparse.pm#126 (text) ====
Index: perl/ext/B/B/Deparse.pm
--- perl/ext/B/B/Deparse.pm#125~18302~ Sat Dec 14 14:34:25 2002
+++ perl/ext/B/B/Deparse.pm Sun Feb 16 05:55:10 2003
@@ -16,7 +16,7 @@
OPpCONST_ARYBASE OPpEXISTS_SUB OPpSORT_NUMERIC OPpSORT_INTEGER
OPpSORT_REVERSE
SVf_IOK SVf_NOK SVf_ROK SVf_POK SVpad_OUR SVf_FAKE
- CVf_METHOD CVf_LOCKED CVf_LVALUE
+ CVf_METHOD CVf_LOCKED CVf_LVALUE CVf_ASSERTION
PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE PMf_SKIPWHITE
PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED);
$VERSION = 0.63;
@@ -748,11 +748,12 @@
if ($cv->FLAGS & SVf_POK) {
$proto = "(". $cv->PV . ") ";
}
- if ($cv->CvFLAGS & (CVf_METHOD|CVf_LOCKED|CVf_LVALUE)) {
+ if ($cv->CvFLAGS & (CVf_METHOD|CVf_LOCKED|CVf_LVALUE|CVf_ASSERTION)) {
$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;
==== //depot/perl/ext/B/defsubs_h.PL#15 (text) ====
Index: perl/ext/B/defsubs_h.PL
--- perl/ext/B/defsubs_h.PL#14~18302~ Sat Dec 14 14:34:25 2002
+++ perl/ext/B/defsubs_h.PL Sun Feb 16 05:55:10 2003
@@ -12,7 +12,7 @@
SVf_READONLY SVTYPEMASK
GVf_IMPORTED_AV GVf_IMPORTED_HV
GVf_IMPORTED_SV GVf_IMPORTED_CV
- CVf_METHOD CVf_LOCKED CVf_LVALUE CVf_CONST
+ CVf_METHOD CVf_LOCKED CVf_LVALUE CVf_CONST CVf_ASSERTION
SVpad_OUR SVf_FAKE SVf_IOK SVf_IVisUV SVf_NOK SVf_POK
SVf_ROK SVp_IOK SVp_POK SVp_NOK
))
==== //depot/perl/intrpvar.h#115 (text) ====
Index: perl/intrpvar.h
--- perl/intrpvar.h#114~18715~ Sat Feb 15 13:19:37 2003
+++ perl/intrpvar.h Sun Feb 16 05:55:10 2003
@@ -120,6 +120,7 @@
PERLVAR(IDBsingle, SV *)
PERLVAR(IDBtrace, SV *)
PERLVAR(IDBsignal, SV *)
+PERLVAR(IDBassertion, SV *)
PERLVAR(Ilineary, AV *) /* lines of script for debugger */
PERLVAR(Idbargs, AV *) /* args to call listed by caller function */
==== //depot/perl/lib/assertions.pm#1 (text) ====
Index: perl/lib/assertions.pm
--- /dev/null Tue May 5 13:32:27 1998
+++ perl/lib/assertions.pm Sun Feb 16 05:55:10 2003
@@ -0,0 +1,94 @@
+package assertions;
+
+our $VERSION = '0.01';
+
+# use strict;
+# use warnings;
+
+my $hint=0x01000000;
+
+sub import {
+ shift;
+ @_=(scalar(caller)) unless @_;
+
+ if ($_[0] eq '&') {
+ return unless $^H & $hint;
+ shift;
+ }
+
+ for my $tag (@_) {
+ unless (grep { $tag=~$_ } @{^ASSERTING}) {
+ $^H &= ~$hint;
+ return;
+ }
+ }
+ $^H |= $hint;
+}
+
+sub unimport {
+ $^H &= ~$hint;
+}
+
+1;
+__END__
+
+
+=head1 NAME
+
+assertions - selects assertions
+
+=head1 SYNOPSIS
+
+ sub assert (&) : assertion { &{$_[0]}() }
+
+ use assertions 'foo';
+ assert { print "asserting 'foo'\n" };
+
+ {
+ use assertions qw( foo bar );
+ assert { print "asserting 'foo' & 'bar'\n" };
+ }
+
+ {
+ use assertions qw( bar );
+ assert { print "asserting 'bar'\n" };
+ }
+
+ {
+ use assertions qw( & bar );
+ assert { print "asserting 'foo' & 'bar'\n" };
+ }
+
+ assert { print "asserting 'foo' again\n" };
+
+
+=head1 ABSTRACT
+
+C<assertions> pragma selects the tags used to control assertion
+execution.
+
+=head1 DESCRIPTION
+
+
+
+
+=head2 EXPORT
+
+None by default.
+
+=head1 SEE ALSO
+
+
+
+=head1 AUTHOR
+
+Salvador Fandi�o, E<lt>[EMAIL PROTECTED]<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2002 by Salvador Fandi�o
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
==== //depot/perl/lib/assertions/activate.pm#1 (text) ====
Index: perl/lib/assertions/activate.pm
--- /dev/null Tue May 5 13:32:27 1998
+++ perl/lib/assertions/activate.pm Sun Feb 16 05:55:10 2003
@@ -0,0 +1,52 @@
+package assertions::activate;
+
+our $VERSION = '0.01';
+
+# use strict;
+# use warnings;
+
+sub import {
+ shift;
+ push @{^ASSERTING}, ( map { qr/^$_$/ } @_) ;
+}
+
+1;
+__END__
+
+=head1 NAME
+
+assertions::activate - assertions activation
+
+=head1 SYNOPSIS
+
+ use assertions::activate 'Foo', 'bar', 'Foo::boz::.*' ;
+
+=head1 ABSTRACT
+
+C<assertions::activate> module is used to configure assertion
+execution.
+
+=head1 DESCRIPTION
+
+
+
+=head2 EXPORT
+
+None by default.
+
+=head1 SEE ALSO
+
+L<assertions>
+
+=head1 AUTHOR
+
+Salvador Fandi�o, E<lt>[EMAIL PROTECTED]<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2002 by Salvador Fandi�o
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
==== //depot/perl/lib/perl5db.pl#92 (text) ====
Index: perl/lib/perl5db.pl
--- perl/lib/perl5db.pl#91~18346~ Sun Dec 22 22:14:22 2002
+++ perl/lib/perl5db.pl Sun Feb 16 05:55:10 2003
@@ -326,6 +326,23 @@
# Needed for the statement after exec():
BEGIN { $ini_warn = $^W; $^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}; asserting_test()";
+ # $ini_assertion = undef => assertions unsupported,
+ # " = 0 => assertions supported but inactive
+ # " = 1 => assertions suported and active
+ # 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 ;-)
$dumpvar::hashDepth,
@@ -359,7 +376,10 @@
recallCommand ShellBang pager tkRunning ornaments
signalLevel warnLevel dieLevel inhibit_exit
ImmediateStop bareStringify CreateTTY
- RemotePort windowSize);
+ RemotePort windowSize DollarCaretP OnlyAssertions
+ WarnAssertions);
+
+@RememberOnROptions = qw(DollarCaretP OnlyAssertions);
%optionVars = (
hashDepth => \$dumpvar::hashDepth,
@@ -381,6 +401,7 @@
ImmediateStop => \$ImmediateStop,
RemotePort => \$remoteport,
windowSize => \$window,
+ WarnAssertions => \$warnassertions,
);
%optionAction = (
@@ -401,6 +422,8 @@
tkRunning => \&tkRunning,
ornaments => \&ornaments,
RemotePort => \&RemotePort,
+ DollarCaretP => \&DollarCaretP,
+ OnlyAssertions=> \&OnlyAssertions,
);
%optionRequire = (
@@ -897,7 +920,7 @@
$incr = $window - 1;
$cmd = 'l ' . ($start) . '+'; };
# rjsf ->
- $cmd =~ /^([aAbBhlLMoOvwW])\b\s*(.*)/s && do {
+ $cmd =~ /^([aAbBhlLMoOvwWP])\b\s*(.*)/s && do {
&cmd_wrapper($1, $2, $line);
next CMD;
};
@@ -1054,6 +1077,7 @@
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;
# Put all the old includes at the start to get
# the same debugger.
for (@ini_INC) {
@@ -1075,7 +1099,7 @@
? $term->GetHistory : @hist);
my @had_breakpoints = keys %had_breakpoints;
set_list("PERLDB_VISITED", @had_breakpoints);
- set_list("PERLDB_OPT", %option);
+ set_list("PERLDB_OPT", options2remember());
set_list("PERLDB_ON_LOAD", %break_on_load);
my @hard;
for (0 .. $#had_breakpoints) {
@@ -1389,7 +1413,19 @@
print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
: print_lineinfo(' ' x ($stack_depth - 1), "entering $sub$al\n")) if $frame;
if (wantarray) {
- @ret = &$sub;
+ if ($assertion) {
+ $assertion=0;
+ eval {
+ @ret = &$sub;
+ };
+ if ($@) {
+ print $OUT $@;
+ $signal=1 unless $warnassertions;
+ }
+ }
+ else {
+ @ret = &$sub;
+ }
$single |= $stack[$stack_depth--];
($frame & 4
? ( print_lineinfo(' ' x $stack_depth, "out "),
@@ -1405,11 +1441,24 @@
}
@ret;
} else {
- if (defined wantarray) {
- $ret = &$sub;
- } else {
- &$sub; undef $ret;
- };
+ if ($assertion) {
+ $assertion=0;
+ eval {
+ $ret = &$sub;
+ };
+ if ($@) {
+ print $OUT $@;
+ $signal=1 unless $warnassertions;
+ }
+ $ret=undef unless defined wantarray;
+ }
+ else {
+ if (defined wantarray) {
+ $ret = &$sub;
+ } else {
+ &$sub; undef $ret;
+ }
+ }
$single |= $stack[$stack_depth--];
($frame & 4
? ( print_lineinfo(' ' x $stack_depth, "out "),
@@ -1963,6 +2012,25 @@
}
}
+
+
+sub cmd_P {
+ 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
+}
+
### END of the API section
sub save {
@@ -2386,6 +2454,13 @@
printf $OUT "%20s = '%s'\n", $opt, $val;
}
+sub options2remember {
+ foreach my $k (@RememberOnROptions) {
+ $option{$k}=option_val($k, 'N/A');
+ }
+ return %option;
+}
+
sub option_val {
my ($opt, $default)= @_;
my $val;
@@ -2599,6 +2674,40 @@
$runnonstop;
}
+sub DollarCaretP {
+ if ($term) {
+ &warn("Some flag changes could not take effect until next 'R'!\n") if @_;
+ }
+ $^P = parse_DollarCaretP_flags(shift) if @_;
+ 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 also be actived 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;
+}
+
sub pager {
if (@_) {
$pager = shift;
@@ -3454,6 +3563,70 @@
} else {
delete($ENV{PERLDB_PIDS});
}
+}
+
+
+# PERLDBf_... flag names from perl.h
+our (%DollarCaretP_flags, %DollarCaretP_flags_r);
+BEGIN {
+ %DollarCaretP_flags =
+ ( PERLDBf_SUB => 0x01, # Debug sub enter/exit
+ PERLDBf_LINE => 0x02, # Keep line #
+ PERLDBf_NOOPT => 0x04, # Switch off optimizations
+ PERLDBf_INTER => 0x08, # Preserve more data
+ PERLDBf_SUBLINE => 0x10, # Keep subr source lines
+ PERLDBf_SINGLE => 0x20, # Start with single-step on
+ PERLDBf_NONAME => 0x40, # For _SUB: no name of the subr
+ 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
+ );
+
+ %DollarCaretP_flags_r=reverse %DollarCaretP_flags;
+}
+
+sub parse_DollarCaretP_flags {
+ my $flags=shift;
+ $flags=~s/^\s+//;
+ $flags=~s/\s+$//;
+ my $acu=0;
+ foreach my $f (split /\s*\|\s*/, $flags) {
+ my $value;
+ if ($f=~/^0x([[:xdigit:]]+)$/) {
+ $value=hex $1;
+ }
+ elsif ($f=~/^(\d+)$/) {
+ $value=int $1;
+ }
+ elsif ($f=~/^DEFAULT$/i) {
+ $value=$DollarCaretP_flags{PERLDB_ALL};
+ }
+ else {
+ $f=~/^(?:PERLDBf_)?(.*)$/i;
+ $value=$DollarCaretP_flags{'PERLDBf_'.uc($1)};
+ unless (defined $value) {
+ print $OUT ("Unrecognized \$^P flag '$f'!\n",
+ "Acceptable flags are: ".
+ join(', ', sort keys %DollarCaretP_flags),
+ ", and hexadecimal and decimal numbers.\n");
+ return undef;
+ }
+ }
+ $acu|=$value;
+ }
+ $acu;
+}
+
+sub expand_DollarCaretP_flags {
+ my $DollarCaretP=shift;
+ my @bits= ( map { my $n=(1<<$_);
+ ($DollarCaretP & $n)
+ ? ($DollarCaretP_flags_r{$n}
+ || sprintf('0x%x', $n))
+ : () } 0..31 );
+ return @bits ? join('|', @bits) : 0;
}
END {
==== //depot/perl/op.c#541 (text) ====
Index: perl/op.c
--- perl/op.c#540~18723~ Sun Feb 16 03:12:58 2003
+++ perl/op.c Sun Feb 16 05:55:10 2003
@@ -5785,6 +5785,7 @@
I32 contextclass = 0;
char *e = 0;
STRLEN n_a;
+ bool delete=0;
o->op_private |= OPpENTERSUB_HASTARG;
for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
@@ -5798,9 +5799,18 @@
cv = GvCVu(gv);
if (!cv)
tmpop->op_private |= OPpEARLY_CV;
- else if (SvPOK(cv)) {
- namegv = CvANON(cv) ? gv : CvGV(cv);
- proto = SvPV((SV*)cv, n_a);
+ else {
+ if (SvPOK(cv)) {
+ namegv = CvANON(cv) ? gv : CvGV(cv);
+ proto = SvPV((SV*)cv, n_a);
+ }
+ if (CvASSERTION(cv)) {
+ if (PL_hints & HINT_ASSERTING) {
+ if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
+ o->op_private |= OPpENTERSUB_DB;
+ }
+ else delete=1;
+ }
}
}
}
@@ -5984,6 +5994,10 @@
if (proto && !optional &&
(*proto && *proto != '@' && *proto != '%' && *proto != ';'))
return too_few_arguments(o, gv_ename(namegv));
+ if(delete) {
+ op_free(o);
+ o=newSVOP(OP_CONST, 0, newSViv(0));
+ }
return o;
}
==== //depot/perl/perl.c#466 (text) ====
Index: perl/perl.c
--- perl/perl.c#465~18715~ Sat Feb 15 13:19:37 2003
+++ perl/perl.c Sun Feb 16 05:55:10 2003
@@ -1024,6 +1024,7 @@
case 'W':
case 'X':
case 'w':
+ case 'A':
if ((s = moreswitches(s)))
goto reswitch;
break;
@@ -1235,7 +1236,7 @@
d = s;
if (!*s)
break;
- if (!strchr("DIMUdmtw", *s))
+ if (!strchr("DIMUdmtwA", *s))
Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
while (++s && *s) {
if (isSPACE(*s)) {
@@ -2319,6 +2320,20 @@
}
}
return s;
+ case 'A':
+ forbid_setid("-A");
+ if (*++s) {
+ SV *sv=newSVpv("use assertions::activate split(/,/,q{",0);
+ sv_catpv(sv,s);
+ sv_catpv(sv,"})");
+ s+=strlen(s);
+ if(!PL_preambleav)
+ PL_preambleav = newAV();
+ av_push(PL_preambleav, sv);
+ }
+ else
+ Perl_croak(aTHX_ "No space allowed after -A");
+ return s;
case 'M':
forbid_setid("-M"); /* XXX ? */
/* FALL THROUGH */
@@ -3265,6 +3280,8 @@
sv_setiv(PL_DBtrace, 0);
PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
sv_setiv(PL_DBsignal, 0);
+ PL_DBassertion = GvSV((gv_fetchpv("assertion", GV_ADDMULTI, SVt_PV)));
+ sv_setiv(PL_DBassertion, 0);
PL_curstash = ostash;
}
==== //depot/perl/perl.h#485 (text) ====
Index: perl/perl.h
--- perl/perl.h#484~18715~ Sat Feb 15 13:19:37 2003
+++ perl/perl.h Sun Feb 16 05:55:10 2003
@@ -3239,6 +3239,8 @@
#define HINT_FILETEST_ACCESS 0x00400000 /* filetest pragma */
#define HINT_UTF8 0x00800000 /* utf8 pragma */
+#define HINT_ASSERTING 0x01000000
+
/* The following are stored in $sort::hints, not in PL_hints */
#define HINT_SORT_SORT_BITS 0x000000FF /* allow 256 different ones */
#define HINT_SORT_QUICKSORT 0x00000001
@@ -3703,8 +3705,8 @@
#define PERLDB_ALL (PERLDBf_SUB | PERLDBf_LINE | \
PERLDBf_NOOPT | PERLDBf_INTER | \
PERLDBf_SUBLINE| PERLDBf_SINGLE| \
- PERLDBf_NAMEEVAL| PERLDBf_NAMEANON)
- /* No _NONAME, _GOTO */
+ PERLDBf_NAMEEVAL| PERLDBf_NAMEANON )
+ /* No _NONAME, _GOTO, _ASSERTION */
#define PERLDBf_SUB 0x01 /* Debug sub enter/exit */
#define PERLDBf_LINE 0x02 /* Keep line # */
#define PERLDBf_NOOPT 0x04 /* Switch off optimizations */
@@ -3716,6 +3718,7 @@
#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))
@@ -3727,7 +3730,7 @@
#define PERLDB_GOTO (PL_perldb && (PL_perldb & PERLDBf_GOTO))
#define PERLDB_NAMEEVAL (PL_perldb && (PL_perldb & PERLDBf_NAMEEVAL))
#define PERLDB_NAMEANON (PL_perldb && (PL_perldb & PERLDBf_NAMEANON))
-
+#define PERLDB_ASSERTION (PL_perldb && (PL_perldb & PERLDBf_ASSERTION))
#ifdef USE_LOCALE_NUMERIC
==== //depot/perl/perlapi.h#81 (text+w) ====
Index: perl/perlapi.h
--- perl/perlapi.h#80~18715~ Sat Feb 15 13:19:37 2003
+++ perl/perlapi.h Sun Feb 16 05:55:10 2003
@@ -88,6 +88,8 @@
#define PL_Argv (*Perl_IArgv_ptr(aTHX))
#undef PL_Cmd
#define PL_Cmd (*Perl_ICmd_ptr(aTHX))
+#undef PL_DBassertion
+#define PL_DBassertion (*Perl_IDBassertion_ptr(aTHX))
#undef PL_DBcv
#define PL_DBcv (*Perl_IDBcv_ptr(aTHX))
#undef PL_DBgv
==== //depot/perl/pp_hot.c#304 (text) ====
Index: perl/pp_hot.c
--- perl/pp_hot.c#303~18726~ Sun Feb 16 05:10:32 2003
+++ perl/pp_hot.c Sun Feb 16 05:55:10 2003
@@ -2580,6 +2580,9 @@
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);
+
cv = get_db_sub(&sv, cv);
if (!cv)
DIE(aTHX_ "No DBsub routine");
==== //depot/perl/sv.c#630 (text) ====
Index: perl/sv.c
--- perl/sv.c#629~18726~ Sun Feb 16 05:10:32 2003
+++ perl/sv.c Sun Feb 16 05:55:10 2003
@@ -10749,6 +10749,7 @@
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_lineary = av_dup(proto_perl->Ilineary, param);
PL_dbargs = av_dup(proto_perl->Idbargs, param);
@@ -10781,6 +10782,7 @@
PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
else
PL_op_mask = Nullch;
+ /* PL_asserting = proto_perl->Iasserting; */
/* current interpreter roots */
PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param);
==== //depot/perl/toke.c#462 (text) ====
Index: perl/toke.c
--- perl/toke.c#461~18699~ Thu Feb 13 01:43:33 2003
+++ perl/toke.c Sun Feb 16 05:55:10 2003
@@ -3025,6 +3025,8 @@
CvLOCKED_on(PL_compcv);
else if (!PL_in_my && len == 6 && strnEQ(s, "method", len))
CvMETHOD_on(PL_compcv);
+ else if (!PL_in_my && len == 9 && strnEQ(s, "assertion", len))
+ CvASSERTION_on(PL_compcv);
#ifdef USE_ITHREADS
else if (PL_in_my == KEY_our && len == 6 &&
strnEQ(s, "unique", len))
==== //depot/perl/xsutils.c#21 (text) ====
Index: perl/xsutils.c
--- perl/xsutils.c#20~16572~ Mon May 13 05:30:35 2002
+++ perl/xsutils.c Sun Feb 16 05:55:10 2003
@@ -72,6 +72,15 @@
switch ((int)len) {
case 6:
switch (*name) {
+ case 'a':
+ if (strEQ(name, "assertion")) {
+ if (negated)
+ CvFLAGS((CV*)sv) &= ~CVf_ASSERTION;
+ else
+ CvFLAGS((CV*)sv) |= CVf_ASSERTION;
+ continue;
+ }
+ break;
case 'l':
#ifdef CVf_LVALUE
if (strEQ(name, "lvalue")) {
@@ -220,6 +229,8 @@
XPUSHs(sv_2mortal(newSVpvn("method", 6)));
if (GvUNIQUE(CvGV((CV*)sv)))
XPUSHs(sv_2mortal(newSVpvn("unique", 6)));
+ if (cvflags & CVf_ASSERTION)
+ XPUSHs(sv_2mortal(newSVpvn("assertion", 9)));
break;
case SVt_PVGV:
if (GvUNIQUE(sv))
End of Patch.
