diff -ru perl-current/cv.h my-perl-current/cv.h --- perl-current/cv.h Sat Oct 19 16:21:46 2002 +++ my-perl-current/cv.h Mon Nov 11 11:32:16 2002 @@ -77,8 +77,9 @@ #define CVf_LOCKED 0x0080 /* CV locks itself or first arg on entry */ #define CVf_LVALUE 0x0100 /* CV return value can be used as lvalue */ #define CVf_CONST 0x0200 /* inlinable sub */ +#define CVf_ASSERTION 0x0400 /* 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) @@ -117,6 +118,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)) diff -ru perl-current/embed.pl my-perl-current/embed.pl --- perl-current/embed.pl Tue Nov 5 09:04:31 2002 +++ my-perl-current/embed.pl Mon Nov 11 11:32:16 2002 @@ -212,7 +212,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 diff -ru perl-current/embedvar.h my-perl-current/embedvar.h --- perl-current/embedvar.h Mon Nov 4 22:53:34 2002 +++ my-perl-current/embedvar.h Mon Nov 11 12:24:03 2002 @@ -178,6 +178,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) @@ -202,6 +203,7 @@ #define PL_argvgv (vTHX->Iargvgv) #define PL_argvout_stack (vTHX->Iargvout_stack) #define PL_argvoutgv (vTHX->Iargvoutgv) +#define PL_asserting (vTHX->Iasserting) #define PL_basetime (vTHX->Ibasetime) #define PL_beginav (vTHX->Ibeginav) #define PL_beginav_save (vTHX->Ibeginav_save) @@ -466,6 +468,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 @@ -490,6 +493,7 @@ #define PL_Iargvgv PL_argvgv #define PL_Iargvout_stack PL_argvout_stack #define PL_Iargvoutgv PL_argvoutgv +#define PL_Iasserting PL_asserting #define PL_Ibasetime PL_basetime #define PL_Ibeginav PL_beginav #define PL_Ibeginav_save PL_beginav_save @@ -928,6 +932,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 -ru perl-current/intrpvar.h my-perl-current/intrpvar.h --- perl-current/intrpvar.h Sat Oct 19 16:21:46 2002 +++ my-perl-current/intrpvar.h Mon Nov 11 11:32:16 2002 @@ -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 */ @@ -149,6 +150,7 @@ /* internal state */ PERLVAR(Itainting, bool) /* doing taint checks */ PERLVARI(Iop_mask, char *, NULL) /* masked operations for safe evals */ +PERLVAR(Iasserting, bool) /* running assertion subs (unrelated to C assert macro */ /* current interpreter roots */ PERLVAR(Imain_cv, CV *) diff -ru perl-current/lib/perl5db.pl my-perl-current/lib/perl5db.pl --- perl-current/lib/perl5db.pl Tue Jun 18 23:32:59 2002 +++ my-perl-current/lib/perl5db.pl Mon Nov 11 12:31:39 2002 @@ -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 "), @@ -1962,6 +2011,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 { @@ -2385,6 +2453,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; @@ -2598,6 +2673,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; @@ -3452,6 +3561,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 { diff -ru perl-current/op.c my-perl-current/op.c --- perl-current/op.c Thu Nov 7 12:46:02 2002 +++ my-perl-current/op.c Mon Nov 11 11:32:16 2002 @@ -5800,6 +5800,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) ; @@ -5813,9 +5814,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_asserting) { + if (PERLDB_ASSERTION && PL_curstash != PL_debstash) + o->op_private |= OPpENTERSUB_DB; + } + else delete=1; + } } } } @@ -5999,6 +6009,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; } diff -ru perl-current/perl.c my-perl-current/perl.c --- perl-current/perl.c Mon Nov 4 22:53:34 2002 +++ my-perl-current/perl.c Mon Nov 11 11:32:16 2002 @@ -1025,6 +1025,7 @@ case 'W': case 'X': case 'w': + case 'A': if ((s = moreswitches(s))) goto reswitch; break; @@ -1236,7 +1237,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)) { @@ -2491,6 +2492,10 @@ PL_compiling.cop_warnings = pWARN_NONE ; s++; return s; + case 'A': + PL_asserting=TRUE; + s++; + return s; case '*': case ' ': if (s[1] == '-') /* Additional switches on #! line. */ @@ -3246,6 +3251,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; } diff -ru perl-current/perl.h my-perl-current/perl.h --- perl-current/perl.h Thu Nov 7 14:26:22 2002 +++ my-perl-current/perl.h Mon Nov 11 11:32:16 2002 @@ -3692,8 +3692,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 */ @@ -3705,6 +3705,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)) @@ -3716,7 +3717,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 diff -ru perl-current/perlapi.h my-perl-current/perlapi.h --- perl-current/perlapi.h Tue Nov 5 21:25:10 2002 +++ my-perl-current/perlapi.h Mon Nov 11 12:24:03 2002 @@ -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 @@ -136,6 +138,8 @@ #define PL_argvout_stack (*Perl_Iargvout_stack_ptr(aTHX)) #undef PL_argvoutgv #define PL_argvoutgv (*Perl_Iargvoutgv_ptr(aTHX)) +#undef PL_asserting +#define PL_asserting (*Perl_Iasserting_ptr(aTHX)) #undef PL_basetime #define PL_basetime (*Perl_Ibasetime_ptr(aTHX)) #undef PL_beginav diff -ru perl-current/pp_hot.c my-perl-current/pp_hot.c --- perl-current/pp_hot.c Thu Nov 7 12:46:02 2002 +++ my-perl-current/pp_hot.c Mon Nov 11 11:32:16 2002 @@ -2546,6 +2546,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"); diff -ru perl-current/sv.c my-perl-current/sv.c --- perl-current/sv.c Thu Nov 7 14:31:28 2002 +++ my-perl-current/sv.c Mon Nov 11 11:32:17 2002 @@ -10311,6 +10311,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); @@ -10343,6 +10344,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); diff -ru perl-current/toke.c my-perl-current/toke.c --- perl-current/toke.c Tue Oct 29 21:47:14 2002 +++ my-perl-current/toke.c Mon Nov 11 11:32:17 2002 @@ -3024,6 +3024,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)) diff -ru perl-current/xsutils.c my-perl-current/xsutils.c --- perl-current/xsutils.c Mon May 13 14:35:25 2002 +++ my-perl-current/xsutils.c Mon Nov 11 11:32:17 2002 @@ -220,6 +220,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))