diff options
| -rw-r--r-- | MANIFEST | 4 | ||||
| -rw-r--r-- | cv.h | 7 | ||||
| -rw-r--r-- | dump.c | 1 | ||||
| -rwxr-xr-x | embed.pl | 2 | ||||
| -rw-r--r-- | embedvar.h | 3 | ||||
| -rw-r--r-- | ext/B/B/Deparse.pm | 5 | ||||
| -rw-r--r-- | ext/B/defsubs_h.PL | 2 | ||||
| -rw-r--r-- | intrpvar.h | 1 | ||||
| -rw-r--r-- | lib/assertions.pm | 94 | ||||
| -rw-r--r-- | lib/assertions/activate.pm | 52 | ||||
| -rw-r--r-- | lib/perl5db.pl | 191 | ||||
| -rw-r--r-- | op.c | 20 | ||||
| -rw-r--r-- | perl.c | 19 | ||||
| -rw-r--r-- | perl.h | 9 | ||||
| -rw-r--r-- | perlapi.h | 2 | ||||
| -rw-r--r-- | pp_hot.c | 3 | ||||
| -rw-r--r-- | sv.c | 2 | ||||
| -rw-r--r-- | toke.c | 2 | ||||
| -rw-r--r-- | xsutils.c | 11 |
19 files changed, 408 insertions, 22 deletions
@@ -911,7 +911,9 @@ 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/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 @@ -82,9 +82,10 @@ Returns the stash of the CV. #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) @@ -124,6 +125,10 @@ Returns the stash of the CV. #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) @@ -1008,6 +1008,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo 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,"); @@ -219,7 +219,7 @@ my @extvars = qw(sv_undef sv_yes sv_no na dowarn curcop compiling tainting tainted stack_base stack_sp sv_arenaroot no_modify - curstash DBsub DBsingle debstash + curstash DBsub DBsingle DBassertion debstash rsfp stdingv defgv diff --git a/embedvar.h b/embedvar.h index 6339029236..b0416392f0 100644 --- a/embedvar.h +++ b/embedvar.h @@ -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 diff --git a/ext/B/B/Deparse.pm b/ext/B/B/Deparse.pm index 37b98a0343..7b2358b6a2 100644 --- a/ext/B/B/Deparse.pm +++ b/ext/B/B/Deparse.pm @@ -16,7 +16,7 @@ use B qw(class main_root main_start main_cv svref_2object opnumber perlstring 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 @@ Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL"); 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; diff --git a/ext/B/defsubs_h.PL b/ext/B/defsubs_h.PL index 2c2aecf6af..9748736ed0 100644 --- a/ext/B/defsubs_h.PL +++ b/ext/B/defsubs_h.PL @@ -12,7 +12,7 @@ foreach my $const (qw( 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 )) diff --git a/intrpvar.h b/intrpvar.h index 0cbe9c8304..f24f0940dd 100644 --- a/intrpvar.h +++ b/intrpvar.h @@ -120,6 +120,7 @@ PERLVAR(IDBsub, GV *) 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 */ diff --git a/lib/assertions.pm b/lib/assertions.pm new file mode 100644 index 0000000000..50e06a76df --- /dev/null +++ b/lib/assertions.pm @@ -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>sfandino@yahoo.comE<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 diff --git a/lib/assertions/activate.pm b/lib/assertions/activate.pm new file mode 100644 index 0000000000..d019b77aee --- /dev/null +++ b/lib/assertions/activate.pm @@ -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>sfandino@yahoo.comE<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 diff --git a/lib/perl5db.pl b/lib/perl5db.pl index 7a53b110b5..f43d8383fb 100644 --- a/lib/perl5db.pl +++ b/lib/perl5db.pl @@ -326,6 +326,23 @@ sub eval { # 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 @@ $inhibit_exit = $option{PrintRet} = 1; 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 @@ $inhibit_exit = $option{PrintRet} = 1; ImmediateStop => \$ImmediateStop, RemotePort => \$remoteport, windowSize => \$window, + WarnAssertions => \$warnassertions, ); %optionAction = ( @@ -401,6 +422,8 @@ $inhibit_exit = $option{PrintRet} = 1; tkRunning => \&tkRunning, ornaments => \&ornaments, RemotePort => \&RemotePort, + DollarCaretP => \&DollarCaretP, + OnlyAssertions=> \&OnlyAssertions, ); %optionRequire = ( @@ -897,7 +920,7 @@ EOP $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 @@ 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; # Put all the old includes at the start to get # the same debugger. for (@ini_INC) { @@ -1075,7 +1099,7 @@ EOP ? $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 @@ sub sub { 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 @@ sub sub { } @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_W { } } + + +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 @@ sub dump_option { 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 @@ sub NonStop { $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; @@ -3456,6 +3565,70 @@ sub clean_ENV { } } + +# 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 { $finished = 1 if $inhibit_exit; # So that some keys may be disabled. $fall_off_end = 1 unless $inhibit_exit; @@ -5785,6 +5785,7 @@ Perl_ck_subr(pTHX_ OP *o) 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 @@ Perl_ck_subr(pTHX_ OP *o) 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 @@ Perl_ck_subr(pTHX_ OP *o) 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; } @@ -1024,6 +1024,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) case 'W': case 'X': case 'w': + case 'A': if ((s = moreswitches(s))) goto reswitch; break; @@ -1235,7 +1236,7 @@ print \" \\@INC:\\n @INC\\n\";"); 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 @@ Perl_moreswitches(pTHX_ char *s) } } 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 @@ Perl_init_debugger(pTHX) 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; } @@ -3239,6 +3239,8 @@ enum { /* pass one of these to get_vtbl */ #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 @@ typedef struct am_table_short AMTS; #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 @@ typedef struct am_table_short AMTS; #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 @@ typedef struct am_table_short AMTS; #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 @@ -88,6 +88,8 @@ END_EXTERN_C #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 @@ -2580,6 +2580,9 @@ PP(pp_entersub) 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"); @@ -10749,6 +10749,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, 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 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, 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); @@ -3025,6 +3025,8 @@ Perl_yylex(pTHX) 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)) @@ -72,6 +72,15 @@ modify_SV_attributes(pTHX_ SV *sv, SV **retlist, SV **attrlist, int numattrs) 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 @@ usage: 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)) |