# New Ticket Created by Kay-Uwe Huell
# Please include the string: [perl #40106]
# in the subject line of all future correspondence about this issue.
# <URL: http://rt.perl.org/rt3/Ticket/Display.html?id=40106 >
Hi parrot-team,
fixed a few things in PGE::P5Regex and t/compilers/pge/p5regex/p5rx.t to
get 15 more p5regex tests running. (also 6 more TODO tests work, which
I've not identified yet.)
regards, kiwi
compilers/pge/PGE/P5Regex.pir | 38
++++++++++++++++++++++++++++++++++----
t/compilers/pge/p5regex/p5rx.t | 11 ++++++-----
2 files changed, 40 insertions(+), 9 deletions(-)
Index: compilers/pge/PGE/P5Regex.pir
===================================================================
--- compilers/pge/PGE/P5Regex.pir (Revision 13897)
+++ compilers/pge/PGE/P5Regex.pir (Arbeitskopie)
@@ -110,12 +110,19 @@
optable.addtok("infix:|", "<infix:", "left,nows", "PGE::Exp::Alt")
optable.addtok("close:}", "<infix:|", "nows") # XXX: hack
- optable.addtok("close:]", "close:}", "nows") # XXX: hack
$P0 = get_hll_global ["PGE::P5Regex"], "compile_p5regex"
compreg "PGE::P5Regex", $P0
.end
+.sub 'parse_error'
+ .param pmc mob
+ .param int pos
+ .param string message
+ print message
+ exit 1
+ .return ()
+.end
.sub "parse_lit"
.param pmc mob
@@ -129,6 +136,10 @@
pos = $P0
lastpos = length target
initchar = substr target, pos, 1
+ unless initchar == '*' goto initchar_ok
+ parse_error(mob, pos, "Quantifier follows nothing")
+
+ initchar_ok:
if initchar == ')' goto end
inc pos
if initchar != "\\" goto term_literal
@@ -136,6 +147,10 @@
term_backslash:
initchar = substr target, pos, 1
inc pos
+ if pos <= lastpos goto term_backslash_ok
+ parse_error(mob, pos, "Search pattern not terminated")
+
+ term_backslash_ok:
$I0 = index "nrteab", initchar
if $I0 < 0 goto term_literal
initchar = substr "\n\r\t\e\a\b", $I0, 1
@@ -144,10 +159,12 @@
litstart = pos
litlen = 0
term_literal_loop:
- if pos >= lastpos goto term_literal_end
+ unless pos < lastpos goto term_literal_end
$S0 = substr target, pos, 1
$I0 = index "[](){}*?+\\|^$.", $S0
- if $I0 >= 0 goto term_literal_end
+
+ # if I am not in circumfix:( ) I have to throw an error on ')', ...
+ unless $I0 < 0 goto term_literal_end
inc pos
inc litlen
goto term_literal_loop
@@ -292,6 +309,18 @@
isrange = 0
$I2 = ord charlist, -1
$I0 = ord $S0
+ unless $I0 < $I2 goto addrange_1
+
+ err_range:
+ $S0 = chr $I2
+ $S1 = chr $I0
+ $S2 = 'Invalid [] range "'
+ $S2 .= $S0
+ $S2 .= '-'
+ $S2 .= $S1
+ $S2 .= '"'
+ parse_error(mob, pos, $S2)
+
addrange_1:
inc $I2
if $I2 > $I0 goto scan
@@ -315,7 +344,8 @@
.return (mob)
err_close:
- parse_error(mob, pos, "No closing ']' for enumerated character list")
+ parse_error(mob, pos, "Unmatched [")
+ err_end:
.end
Index: t/compilers/pge/p5regex/p5rx.t
===================================================================
--- t/compilers/pge/p5regex/p5rx.t (Revision 13897)
+++ t/compilers/pge/p5regex/p5rx.t (Arbeitskopie)
@@ -79,7 +79,7 @@
plan tests => $numtests;
my @todo_tests = (
- q{unknown} => qw<99 100 142 172 184 223 232 233 234 236 241 243 244 246
+ q{unknown} => qw<172 184 223 232 233 234 236 241 243 244 246
247 253 254 256 257 260 261 381 382 396 397 398 419 422 428 429 432
435 439 440 444 445 446 447 448 449 452 453 454 455 485 495 498 500
501 503 504 505 506 507 508 509 510 511 512 515 522 523 524 527 528
@@ -118,10 +118,11 @@
755 756 757 758 759 760 761 771 772 773 774 775 776 777 778 779 789
790 791 792 793 794 795 796 797 802 803 805 834 835 836 838 859 862
877 886>,
- q{bug or error} => qw<78 79 80 135 136 138 143 144 148 149 155 167
+ q{bug or error} => qw<143 144 148 149 155 167
248 249 252 308 309 310 322 323 325 330 331 336 347 408 436 487 488
489 490 492 531 532 563 564 566 593 594 598 599 944 945>,
- q{kills a parrot} => qw<81 129 130 131 139 140 141 491 493 556 557
+ q{re_test broken col 4?} => qw<139>,
+ q{kills a parrot} => qw<491 493 556 557
568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584
585 586 587 588 589 590 591 592 800 828 829 830 957 958>,
q{hangs a parrot} => qw<806 807 808 809 810 811 812 813 814 815 816
@@ -214,12 +215,12 @@
.local string pattern
.local pmc rulesub
.local pmc match
- target = <<"TARGET"
+ target = <<'TARGET'
<<SUBJECT>>
TARGET
chopn target, 1
- pattern = <<"PATTERN"
+ pattern = <<'PATTERN'
<<PATTERN>>
PATTERN
chopn pattern, 1
