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
#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)
#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)
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,");
curcop compiling
tainting tainted stack_base stack_sp sv_arenaroot
no_modify
- curstash DBsub DBsingle debstash
+ curstash DBsub DBsingle DBassertion debstash
rsfp
stdingv
defgv
#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
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;
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;
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
))
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 */
--- /dev/null
+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
--- /dev/null
+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
# 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,
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,
ImmediateStop => \$ImmediateStop,
RemotePort => \$remoteport,
windowSize => \$window,
+ WarnAssertions => \$warnassertions,
);
%optionAction = (
tkRunning => \&tkRunning,
ornaments => \&ornaments,
RemotePort => \&RemotePort,
+ DollarCaretP => \&DollarCaretP,
+ OnlyAssertions=> \&OnlyAssertions,
);
%optionRequire = (
$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;
};
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) {
? $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) {
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 "),
}
@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 "),
}
}
+
+
+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 {
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;
$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;
}
}
+
+# 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;
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) ;
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;
+ }
}
}
}
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;
}
case 'W':
case 'X':
case 'w':
+ case 'A':
if ((s = moreswitches(s)))
goto reswitch;
break;
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)) {
}
}
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 */
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;
}
#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
#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 */
#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))
#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
#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
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");
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);
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);
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))
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")) {
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))
projects / platform / upstream / perl.git / commitdiff