This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
add support for assertions. Updated form of:
authorSalvador Fandiño <sfandino@yahoo.com>
Sat, 30 Nov 2002 17:24:09 +0000 (17:24 +0000)
committerhv <hv@crypt.org>
Sun, 16 Feb 2003 13:55:10 +0000 (13:55 +0000)
Subject: Re: Did the assertion patch/feature submission get overlooked?
Message-ID: <3DE8F439.50402@yahoo.com>

p4raw-id: //depot/perl@18727

19 files changed:
MANIFEST
cv.h
dump.c
embed.pl
embedvar.h
ext/B/B/Deparse.pm
ext/B/defsubs_h.PL
intrpvar.h
lib/assertions.pm [new file with mode: 0644]
lib/assertions/activate.pm [new file with mode: 0644]
lib/perl5db.pl
op.c
perl.c
perl.h
perlapi.h
pp_hot.c
sv.c
toke.c
xsutils.c

index b55d759..ed78573 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -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
diff --git a/cv.h b/cv.h
index 6e47141..e1191b6 100644 (file)
--- a/cv.h
+++ b/cv.h
@@ -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)
diff --git a/dump.c b/dump.c
index 47712e8..d545368 100644 (file)
--- a/dump.c
+++ b/dump.c
@@ -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,");
index 5fc18a7..19609d4 100755 (executable)
--- a/embed.pl
+++ b/embed.pl
@@ -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
index 6339029..b041639 100644 (file)
 
 #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)
 
 #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
 
 #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
index 37b98a0..7b2358b 100644 (file)
@@ -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;
index 2c2aecf..9748736 100644 (file)
@@ -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
                      ))
index 0cbe9c8..f24f094 100644 (file)
@@ -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 (file)
index 0000000..50e06a7
--- /dev/null
@@ -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 (file)
index 0000000..d019b77
--- /dev/null
@@ -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
index 7a53b11..f43d838 100644 (file)
@@ -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;
diff --git a/op.c b/op.c
index 9bd7aaa..0cc8c33 100644 (file)
--- a/op.c
+++ b/op.c
@@ -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;
 }
 
diff --git a/perl.c b/perl.c
index 7156ba6..4893762 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -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;
 }
 
diff --git a/perl.h b/perl.h
index 95f602f..ccc82da 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -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
 
index 779f140..0e9733b 100644 (file)
--- a/perlapi.h
+++ b/perlapi.h
@@ -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
index 63f8b9d..62b5c5c 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -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");
diff --git a/sv.c b/sv.c
index aa2b2f5..3dbab25 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -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);
diff --git a/toke.c b/toke.c
index 74499ab..bfe282c 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -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))
index b924c48..e0130d2 100644 (file)
--- a/xsutils.c
+++ b/xsutils.c
@@ -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))