# Backtracking Verbs
ENDLIKE none Used only for the type field of verbs
- OPFAIL none Same as (?!)
- ACCEPT parno 1 Accepts the current matched string.
+ OPFAIL no-sv 1 Same as (?!), but with verb arg
+ ACCEPT no-sv/num Accepts the current matched string, with
+ 2L verbar
# Verbs With Arguments
VERB no-sv 1 Used only for the type field of verbs
These special patterns are generally of the form C<(*VERB:ARG)>. Unless
otherwise stated the ARG argument is optional; in some cases, it is
-forbidden.
+mandatory.
Any pattern containing a special backtracking verb that allows an argument
has the special behaviour that when executed it sets the current package's
=over 3
-=item Verbs that take an argument
+=item Verbs
=over 4
as after matching the A but failing on the B the C<(*THEN)> verb will
backtrack and try C; but the C<(*PRUNE)> verb will simply fail.
-=back
-
-=item Verbs without an argument
-
-=over 4
-
-=item C<(*COMMIT)>
+=item C<(*COMMIT)> C<(*COMMIT:args)>
X<(*COMMIT)>
This is the Perl 6 "commit pattern" C<< <commit> >> or C<:::>. It's a
does not match, the regex engine will not try any further matching on the
rest of the string.
-=item C<(*FAIL)> C<(*F)>
+=item C<(*FAIL)> C<(*F)> C<(*FAIL:arg)>
X<(*FAIL)> X<(*F)>
This pattern matches nothing and always fails. It can be used to force the
engine to backtrack. It is equivalent to C<(?!)>, but easier to read. In
-fact, C<(?!)> gets optimised into C<(*FAIL)> internally.
+fact, C<(?!)> gets optimised into C<(*FAIL)> internally. You can provide
+an argument so that if the match fails because of this FAIL directive
+the argument can be obtained from $REGERROR.
It is probably useful only when combined with C<(?{})> or C<(??{})>.
-=item C<(*ACCEPT)>
+=item C<(*ACCEPT)> C<(*ACCEPT:arg)>
X<(*ACCEPT)>
This pattern matches nothing and causes the end of successful matching at
be set. If another branch in the inner parentheses was matched, such as in the
string 'ACDE', then the C<D> and C<E> would have to be matched as well.
+You can provide an argument, which will be available in the var $REGMARK
+after the match completes.
+
=back
=back
STRLEN verb_len = 0;
char *start_arg = NULL;
unsigned char op = 0;
- int argok = 1;
+ int arg_required = 0;
int internal_argval = -1; /* if >-1 we are not allowed an argument*/
if (has_intervening_patws) {
case 'F': /* (*FAIL) */
if ( verb_len==1 || memEQs(start_verb,verb_len,"FAIL") ) {
op = OPFAIL;
- argok = 0;
}
break;
case ':': /* (*:NAME) */
case 'M': /* (*MARK:NAME) */
if ( verb_len==0 || memEQs(start_verb,verb_len,"MARK") ) {
op = MARKPOINT;
- argok = -1;
+ arg_required = 1;
}
break;
case 'P': /* (*PRUNE) */
"Unknown verb pattern '%"UTF8f"'",
UTF8fARG(UTF, verb_len, start_verb));
}
- if ( argok ) {
- if ( start_arg && internal_argval != -1 ) {
- vFAIL3("Verb pattern '%.*s' may not have an argument",
- verb_len, start_verb);
- } else if ( argok < 0 && !start_arg ) {
- vFAIL3("Verb pattern '%.*s' has a mandatory argument",
- verb_len, start_verb);
- } else if ( internal_argval == -1 ) {
- ret = reganode(pRExC_state, op, 0);
- if ( ! SIZE_ONLY ) {
- if (start_arg) {
- SV *sv = newSVpvn( start_arg,
- RExC_parse - start_arg);
- ARG(ret) = add_data( pRExC_state,
- STR_WITH_LEN("S"));
- RExC_rxi->data->data[ARG(ret)]=(void*)sv;
- ret->flags = 0;
- } else {
- ret->flags = 1;
- }
- }
- RExC_seen |= REG_VERBARG_SEEN;
- } else {
- /* ACCEPT does not allow :args like the rest of the verbs
- * as it currently uses its arg slot for something else.
- * We can change that in a future commit. */
- ret = reganode(pRExC_state, op, internal_argval);
+ if ( arg_required && !start_arg ) {
+ vFAIL3("Verb pattern '%.*s' has a mandatory argument",
+ verb_len, start_verb);
+ }
+ if (internal_argval == -1) {
+ ret = reganode(pRExC_state, op, 0);
+ } else {
+ ret = reg2Lanode(pRExC_state, op, 0, internal_argval);
+ }
+ RExC_seen |= REG_VERBARG_SEEN;
+ if ( ! SIZE_ONLY ) {
+ if (start_arg) {
+ SV *sv = newSVpvn( start_arg,
+ RExC_parse - start_arg);
+ ARG(ret) = add_data( pRExC_state,
+ STR_WITH_LEN("S"));
+ RExC_rxi->data->data[ARG(ret)]=(void*)sv;
+ ret->flags = 1;
+ } else {
+ ret->flags = 0;
}
- } else if ( start_arg ) {
- vFAIL3("Verb pattern '%.*s' may not have an argument",
- verb_len, start_verb);
- } else {
- ret = reg_node(pRExC_state, op);
- }
+ if ( internal_argval != -1 )
+ ARG2L_SET(ret, internal_argval);
+ }
nextchar(pRExC_state);
return ret;
}
--RExC_parse;
nextchar(pRExC_state);
if (*RExC_parse == ')') {
- ret=reg_node(pRExC_state, OPFAIL);
+ ret=reganode(pRExC_state, OPFAIL, 0);
nextchar(pRExC_state);
return ret;
}
ckWARNreg(RExC_parse, "Quantifier {n,m} with n > m can't match");
RExC_emit = orig_emit;
}
- ret = reg_node(pRExC_state, OPFAIL);
+ ret = reganode(pRExC_state, OPFAIL, 0);
return ret;
}
else if (min == max && RExC_parse < RExC_end && *RExC_parse == '?')
RExC_parse = (char *)orig_parse;
RExC_emit = (regnode *)orig_emit;
- ret = reg_node(pRExC_state, op);
+ if (regarglen[op]) {
+ ret = reganode(pRExC_state, op, 0);
+ } else {
+ ret = reg_node(pRExC_state, op);
+ }
RExC_parse = (char *)cur_parse;
|| k == GROUPP || OP(o)==ACCEPT)
{
AV *name_list= NULL;
- Perl_sv_catpvf(aTHX_ sv, "%d", (int)ARG(o)); /* Parenth number */
+ U32 parno= OP(o) == ACCEPT ? (U32)ARG2L(o) : ARG(o);
+ Perl_sv_catpvf(aTHX_ sv, "%"UVuf, (UV)parno); /* Parenth number */
if ( RXp_PAREN_NAMES(prog) ) {
name_list= MUTABLE_AV(progi->data->data[progi->name_list_idx]);
} else if ( pRExC_state ) {
}
if (name_list) {
if ( k != REF || (OP(o) < NREF)) {
- SV **name= av_fetch(name_list, ARG(o), 0 );
+ SV **name= av_fetch(name_list, parno, 0 );
if (name)
Perl_sv_catpvf(aTHX_ sv, " '%"SVf"'", SVfARG(*name));
}
else {
- SV *sv_dat= MUTABLE_SV(progi->data->data[ ARG( o ) ]);
+ SV *sv_dat= MUTABLE_SV(progi->data->data[ parno ]);
I32 *nums=(I32*)SvPVX(sv_dat);
SV **name= av_fetch(name_list, nums[0], 0 );
I32 n;
Perl_sv_catpvf(aTHX_ sv, " '%"SVf"'", SVfARG(*name));
}
}
- else if (k == VERB) {
- if (!o->flags)
- Perl_sv_catpvf(aTHX_ sv, ":%"SVf,
- SVfARG((MUTABLE_SV(progi->data->data[ ARG( o ) ]))));
- } else if (k == LOGICAL)
+ else if (k == LOGICAL)
/* 2: embedded, otherwise 1 */
Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags);
else if (k == ANYOF) {
Perl_sv_catpvf(aTHX_ sv, "[%d]", -(o->flags));
else if (OP(o) == SBOL)
Perl_sv_catpvf(aTHX_ sv, " /%s/", o->flags ? "\\A" : "^");
+
+ /* add on the verb argument if there is one */
+ if ( ( k == VERB || OP(o) == ACCEPT || OP(o) == OPFAIL ) && o->flags) {
+ Perl_sv_catpvf(aTHX_ sv, ":%"SVf,
+ SVfARG((MUTABLE_SV(progi->data->data[ ARG( o ) ]))));
+ }
#else
PERL_UNUSED_CONTEXT;
PERL_UNUSED_ARG(sv);
#*Backtracking Verbs
ENDLIKE ENDLIKE, none ; Used only for the type field of verbs
-OPFAIL ENDLIKE, none ; Same as (?!)
-ACCEPT ENDLIKE, parno 1 ; Accepts the current matched string.
-
+OPFAIL ENDLIKE, no-sv 1 ; Same as (?!), but with verb arg
+ACCEPT ENDLIKE, no-sv/num 2L ; Accepts the current matched string, with verbar
#*Verbs With Arguments
VERB VERB, no-sv 1 ; Used only for the type field of verbs
break;
case ACCEPT: /* (*ACCEPT) */
- if (ARG(scan)){
+ if (scan->flags)
+ sv_yes_mark = MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
+ if (ARG2L(scan)){
regnode *cursor;
for (cursor=scan;
cursor && OP(cursor)!=END;
NOT_REACHED; /* NOTREACHED */
case CUTGROUP: /* /(*THEN)/ */
- sv_yes_mark = st->u.mark.mark_name = scan->flags ? NULL :
- MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
+ sv_yes_mark = st->u.mark.mark_name = scan->flags
+ ? MUTABLE_SV(rexi->data->data[ ARG( scan ) ])
+ : NULL;
PUSH_STATE_GOTO(CUTGROUP_next, next, locinput);
/* NOTREACHED */
NOT_REACHED; /* NOTREACHED */
/* FALLTHROUGH */
case PRUNE: /* (*PRUNE) */
- if (!scan->flags)
+ if (scan->flags)
sv_yes_mark = sv_commit = MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
PUSH_STATE_GOTO(COMMIT_next, next, locinput);
/* NOTREACHED */
case COMMIT_next_fail:
no_final = 1;
/* FALLTHROUGH */
+ sayNO;
+ NOT_REACHED; /* NOTREACHED */
case OPFAIL: /* (*FAIL) */
+ if (scan->flags)
+ sv_commit = MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
if (logical) {
/* deal with (?(?!)X|Y) properly,
* make sure we trigger the no branch
NOT_REACHED; /* NOTREACHED */
case SKIP: /* (*SKIP) */
- if (scan->flags) {
+ if (!scan->flags) {
/* (*SKIP) : if we fail we cut here*/
ST.mark_name = NULL;
ST.mark_loc = locinput;
#define INSUBP 79 /* 0x4f Whether we are in a specific recurse. */
#define DEFINEP 80 /* 0x50 Never execute directly. */
#define ENDLIKE 81 /* 0x51 Used only for the type field of verbs */
-#define OPFAIL 82 /* 0x52 Same as (?!) */
-#define ACCEPT 83 /* 0x53 Accepts the current matched string. */
+#define OPFAIL 82 /* 0x52 Same as (?!), but with verb arg */
+#define ACCEPT 83 /* 0x53 Accepts the current matched string, with verbar */
#define VERB 84 /* 0x54 Used only for the type field of verbs */
#define PRUNE 85 /* 0x55 Pattern fails at this startpoint if no-backtracking through this */
#define MARKPOINT 86 /* 0x56 Push the current location for rollback by cut. */
EXTRA_SIZE(struct regnode_1), /* INSUBP */
EXTRA_SIZE(struct regnode_1), /* DEFINEP */
0, /* ENDLIKE */
- 0, /* OPFAIL */
- EXTRA_SIZE(struct regnode_1), /* ACCEPT */
+ EXTRA_SIZE(struct regnode_1), /* OPFAIL */
+ EXTRA_SIZE(struct regnode_2L), /* ACCEPT */
EXTRA_SIZE(struct regnode_1), /* VERB */
EXTRA_SIZE(struct regnode_1), /* PRUNE */
EXTRA_SIZE(struct regnode_1), /* MARKPOINT */
use strict;
use warnings;
use 5.010;
+our ($REGMARK, $REGERROR);
sub run_tests;
{
# Test named commits and the $REGERROR var
- our $REGERROR;
+ local $REGERROR;
for my $name ('', ':foo') {
for my $pat ("(*PRUNE$name)",
($name ? "(*MARK$name)" : "") . "(*SKIP$name)",
# Test named commits and the $REGERROR var
package Fnorble;
our $REGERROR;
+ local $REGERROR;
for my $name ('', ':foo') {
for my $pat ("(*PRUNE$name)",
($name ? "(*MARK$name)" : "") . "(*SKIP$name)",
{
# Test named commits and the $REGERROR var
my $message = '$REGERROR';
- our $REGERROR;
+ local $REGERROR;
for my $word (qw (bar baz bop)) {
$REGERROR = "";
"aaaaa$word" =~
{
my $message = '$REGMARK';
our @r = ();
- our ($REGMARK, $REGERROR);
+ local $REGMARK;
+ local $REGERROR;
like('foofoo', qr/foo (*MARK:foo) (?{push @r,$REGMARK}) /x, $message);
is("@r","foo", $message);
is($REGMARK, "foo", $message);
^((?(?!)xb|ya)z) xbz n - -
^((?(?!)xb|ya)z) yaz y $1 yaz # [perl-126222]
-(*ACCEPT:foo) foo c - Verb pattern 'ACCEPT' may not have an argument
-((*ACCEPT:foo)) foo c - Verb pattern 'ACCEPT' may not have an argument
+foo(*ACCEPT:foo) foo y $::REGMARK foo
+(foo(*ACCEPT:foo)) foo y $::REGMARK foo
+A(*FAIL:foo)[BC] A n $::REGERROR foo
# Keep these lines at the end of the file
# vim: softtabstop=0 noexpandtab
https://perl5.git.perl.org / perl5.git / commitdiff