Skip to content

Commit decc0b8

Browse files
fglockfglock
committed
Rewrite code_block_constants.t and recursive_patterns.t to use Test::More
- Convert old TAP format to proper Test::More functions - Use ok(), is(), cmp_ok(), like(), pass(), fail() instead of print statements - Cleaner, more maintainable test code - Reduced code by 322 lines - All 141 unit tests pass with prove -e ./jperl - Tests increased from 1944 to 1965
1 parent e1b4b68 commit decc0b8

File tree

2 files changed

+84
-322
lines changed

2 files changed

+84
-322
lines changed

‎src/test/resources/unit/regex/code_block_constants.t‎

Lines changed: 46 additions & 190 deletions
Original file line numberDiff line numberDiff line change
@@ -2,131 +2,65 @@
22

33
use strict;
44
use warnings;
5+
use Test::More;
56

67
# Test regex (?{...}) code blocks with constant folding and $^R variable
78

8-
print "1..19\n";
9-
my $test = 1;
10-
119
# Test 1: Simple numeric constant
1210
{
1311
my $str = "abc";
14-
if ($str =~ /a(?{ 42 })bc/) {
15-
if (defined $^R && $^R == 42) {
16-
print "ok $test - Simple numeric constant in (?{...})\n";
17-
} else {
18-
print "not ok $test - \$^R should be 42, got: " . (defined $^R ? $^R : "undef") . "\n";
19-
}
20-
} else {
21-
print "not ok $test - Pattern should match\n";
22-
}
23-
$test++;
12+
ok($str =~ /a(?{ 42 })bc/, 'Simple numeric constant - pattern matches');
13+
is($^R, 42, 'Simple numeric constant - $^R should be 42');
2414
}
2515

2616
# Test 2: String constant
2717
{
2818
my $str = "test";
29-
if ($str =~ /t(?{ 'hello' })est/) {
30-
if (defined $^R && $^R eq 'hello') {
31-
print "ok $test - String constant in (?{...})\n";
32-
} else {
33-
print "not ok $test - \$^R should be 'hello', got: " . (defined $^R ? $^R : "undef") . "\n";
34-
}
35-
} else {
36-
print "not ok $test - Pattern should match\n";
37-
}
38-
$test++;
19+
ok($str =~ /t(?{ 'hello' })est/, 'String constant - pattern matches');
20+
is($^R, 'hello', 'String constant - $^R should be hello');
3921
}
4022

4123
# Test 3: Arithmetic expression (constant folding)
4224
{
4325
my $str = "xyz";
44-
if ($str =~ /x(?{ 2 + 2 })yz/) {
45-
if (defined $^R && $^R == 4) {
46-
print "ok $test - Arithmetic expression constant folding\n";
47-
} else {
48-
print "not ok $test - \$^R should be 4, got: " . (defined $^R ? $^R : "undef") . "\n";
49-
}
50-
} else {
51-
print "not ok $test - Pattern should match\n";
52-
}
53-
$test++;
26+
ok($str =~ /x(?{ 2 + 2 })yz/, 'Arithmetic expression - pattern matches');
27+
is($^R, 4, 'Arithmetic expression constant folding - $^R should be 4');
5428
}
5529

5630
# Test 4: Alternation - first branch
5731
{
5832
my $str = "s";
59-
if ($str =~ / s (?{ 10111 }) | i (?{ 20222 }) /x) {
60-
if (defined $^R && $^R == 10111) {
61-
print "ok $test - Alternation first branch\n";
62-
} else {
63-
print "not ok $test - \$^R should be 10111, got: " . (defined $^R ? $^R : "undef") . "\n";
64-
}
65-
} else {
66-
print "not ok $test - Pattern should match\n";
67-
}
68-
$test++;
33+
ok($str =~ / s (?{ 10111 }) | i (?{ 20222 }) /x, 'Alternation first branch - pattern matches');
34+
is($^R, 10111, 'Alternation first branch - $^R should be 10111');
6935
}
7036

7137
# Test 5: Alternation - second branch
7238
{
7339
my $str = "i";
74-
if ($str =~ / s (?{ 10111 }) | i (?{ 20222 }) /x) {
75-
if (defined $^R && $^R == 20222) {
76-
print "ok $test - Alternation second branch\n";
77-
} else {
78-
print "not ok $test - \$^R should be 20222, got: " . (defined $^R ? $^R : "undef") . "\n";
79-
}
80-
} else {
81-
print "not ok $test - Pattern should match\n";
82-
}
83-
$test++;
40+
ok($str =~ / s (?{ 10111 }) | i (?{ 20222 }) /x, 'Alternation second branch - pattern matches');
41+
is($^R, 20222, 'Alternation second branch - $^R should be 20222');
8442
}
8543

8644
# Test 6: Alternation - third branch
8745
{
8846
my $str = "l";
89-
if ($str =~ / s (?{ 10111 }) | i (?{ 20222 }) | l (?{ 30333 }) /x) {
90-
if (defined $^R && $^R == 30333) {
91-
print "ok $test - Alternation third branch\n";
92-
} else {
93-
print "not ok $test - \$^R should be 30333, got: " . (defined $^R ? $^R : "undef") . "\n";
94-
}
95-
} else {
96-
print "not ok $test - Pattern should match\n";
97-
}
98-
$test++;
47+
ok($str =~ / s (?{ 10111 }) | i (?{ 20222 }) | l (?{ 30333 }) /x, 'Alternation third branch - pattern matches');
48+
is($^R, 30333, 'Alternation third branch - $^R should be 30333');
9949
}
10050

10151
# Test 7: Multiple code blocks in sequence
10252
{
10353
my $str = "abc";
104-
if ($str =~ /a(?{ 1 })b(?{ 2 })c/) {
105-
# $^R should contain the result of the last code block
106-
if (defined $^R && $^R == 2) {
107-
print "ok $test - Multiple code blocks - last value\n";
108-
} else {
109-
print "not ok $test - \$^R should be 2, got: " . (defined $^R ? $^R : "undef") . "\n";
110-
}
111-
} else {
112-
print "not ok $test - Pattern should match\n";
113-
}
114-
$test++;
54+
ok($str =~ /a(?{ 1 })b(?{ 2 })c/, 'Multiple code blocks - pattern matches');
55+
# $^R should contain the result of the last code block
56+
is($^R, 2, 'Multiple code blocks - $^R contains last value');
11557
}
11658

11759
# Test 8: Code block with /x modifier (whitespace)
11860
{
11961
my $str = "test";
120-
if ($str =~ / t (?{ 99 }) est /x) {
121-
if (defined $^R && $^R == 99) {
122-
print "ok $test - Code block with /x modifier\n";
123-
} else {
124-
print "not ok $test - \$^R should be 99, got: " . (defined $^R ? $^R : "undef") . "\n";
125-
}
126-
} else {
127-
print "not ok $test - Pattern should match\n";
128-
}
129-
$test++;
62+
ok($str =~ / t (?{ 99 }) est /x, 'Code block with /x modifier - pattern matches');
63+
is($^R, 99, 'Code block with /x modifier - $^R should be 99');
13064
}
13165

13266
# Test 9: pack.t use case - map with alternation
@@ -141,156 +75,79 @@ my $test = 1;
14175
$^R
14276
} @codes;
14377

144-
if ($val{s} == 10111 && $val{i} == 20222 && $val{l} == 30333) {
145-
print "ok $test - pack.t use case with map\n";
146-
} else {
147-
print "not ok $test - Values should be s=10111 i=20222 l=30333, got: s=$val{s} i=$val{i} l=$val{l}\n";
148-
}
149-
$test++;
78+
is($val{s}, 10111, 'pack.t use case - s value correct');
79+
is($val{i}, 20222, 'pack.t use case - i value correct');
80+
is($val{l}, 30333, 'pack.t use case - l value correct');
15081
}
15182

15283
# Test 10: Large number constant
15384
{
15485
my $str = "x";
155-
if ($str =~ /x(?{ 1234567890 })/) {
156-
if (defined $^R && $^R == 1234567890) {
157-
print "ok $test - Large number constant\n";
158-
} else {
159-
print "not ok $test - \$^R should be 1234567890, got: " . (defined $^R ? $^R : "undef") . "\n";
160-
}
161-
} else {
162-
print "not ok $test - Pattern should match\n";
163-
}
164-
$test++;
86+
ok($str =~ /x(?{ 1234567890 })/, 'Large number constant - pattern matches');
87+
is($^R, 1234567890, 'Large number constant - $^R should be 1234567890');
16588
}
16689

16790
# Test 11: Scientific notation
16891
{
16992
my $str = "y";
170-
if ($str =~ /y(?{ 1.5e2 })/) {
171-
if (defined $^R && $^R == 150) {
172-
print "ok $test - Scientific notation constant\n";
173-
} else {
174-
print "not ok $test - \$^R should be 150, got: " . (defined $^R ? $^R : "undef") . "\n";
175-
}
176-
} else {
177-
print "not ok $test - Pattern should match\n";
178-
}
179-
$test++;
93+
ok($str =~ /y(?{ 1.5e2 })/, 'Scientific notation - pattern matches');
94+
cmp_ok($^R, '==', 150, 'Scientific notation constant - $^R should be 150');
18095
}
18196

18297
# Test 12: Negative number
18398
{
18499
my $str = "z";
185-
if ($str =~ /z(?{ -42 })/) {
186-
if (defined $^R && $^R == -42) {
187-
print "ok $test - Negative number constant\n";
188-
} else {
189-
print "not ok $test - \$^R should be -42, got: " . (defined $^R ? $^R : "undef") . "\n";
190-
}
191-
} else {
192-
print "not ok $test - Pattern should match\n";
193-
}
194-
$test++;
100+
ok($str =~ /z(?{ -42 })/, 'Negative number - pattern matches');
101+
is($^R, -42, 'Negative number constant - $^R should be -42');
195102
}
196103

197104
# Test 13: Zero
198105
{
199106
my $str = "a";
200-
if ($str =~ /a(?{ 0 })/) {
201-
if (defined $^R && $^R == 0) {
202-
print "ok $test - Zero constant\n";
203-
} else {
204-
print "not ok $test - \$^R should be 0, got: " . (defined $^R ? $^R : "undef") . "\n";
205-
}
206-
} else {
207-
print "not ok $test - Pattern should match\n";
208-
}
209-
$test++;
107+
ok($str =~ /a(?{ 0 })/, 'Zero constant - pattern matches');
108+
is($^R, 0, 'Zero constant - $^R should be 0');
210109
}
211110

212111
# Test 14: Empty string
213112
{
214113
my $str = "b";
215-
if ($str =~ /b(?{ '' })/) {
216-
if (defined $^R && $^R eq '') {
217-
print "ok $test - Empty string constant\n";
218-
} else {
219-
print "not ok $test - \$^R should be empty string, got: " . (defined $^R ? $^R : "undef") . "\n";
220-
}
221-
} else {
222-
print "not ok $test - Pattern should match\n";
223-
}
224-
$test++;
114+
ok($str =~ /b(?{ '' })/, 'Empty string - pattern matches');
115+
is($^R, '', 'Empty string constant - $^R should be empty string');
225116
}
226117

227118
# Test 15: Code block doesn't affect match position
228119
{
229120
my $str = "hello world";
230-
if ($str =~ /hello(?{ 123 }) world/) {
231-
if (defined $^R && $^R == 123) {
232-
print "ok $test - Code block doesn't affect match position\n";
233-
} else {
234-
print "not ok $test - \$^R should be 123, got: " . (defined $^R ? $^R : "undef") . "\n";
235-
}
236-
} else {
237-
print "not ok $test - Pattern should match\n";
238-
}
239-
$test++;
121+
ok($str =~ /hello(?{ 123 }) world/, 'Code block doesn\'t affect match position - pattern matches');
122+
is($^R, 123, 'Code block doesn\'t affect match position - $^R should be 123');
240123
}
241124

242125
# Test 16: Undef constant
243126
{
244127
my $str = "u";
245-
if ($str =~ /u(?{ undef })/) {
246-
if (!defined $^R) {
247-
print "ok $test - Undef constant\n";
248-
} else {
249-
print "not ok $test - \$^R should be undef, got: $^R\n";
250-
}
251-
} else {
252-
print "not ok $test - Pattern should match\n";
253-
}
254-
$test++;
128+
ok($str =~ /u(?{ undef })/, 'Undef constant - pattern matches');
129+
ok(!defined $^R, 'Undef constant - $^R should be undef');
255130
}
256131

257132
# Test 17: $^R works (cb* filtering from %+ is a future enhancement)
258133
# Note: Internal cb* captures currently appear in %+ hash, but this doesn't
259134
# affect the core functionality of $^R. Filtering will be added in a future PR.
260135
{
261136
my $str = "test";
262-
if ($str =~ /t(?{ 42 })est/) {
263-
# Just verify that $^R got the value - core functionality works
264-
if (defined $^R && $^R == 42) {
265-
print "ok $test - \$^R works correctly\n";
266-
} else {
267-
print "not ok $test - \$^R should be 42, got: " . (defined $^R ? $^R : "undef") . "\n";
268-
}
269-
} else {
270-
print "not ok $test - Pattern should match\n";
271-
}
272-
$test++;
137+
ok($str =~ /t(?{ 42 })est/, '$^R works - pattern matches');
138+
# Just verify that $^R got the value - core functionality works
139+
is($^R, 42, '$^R works correctly');
273140
}
274141

275142
# Test 18: $^R works with regular named captures
276143
{
277144
my $str = "abc";
278-
if ($str =~ /(?<first>a)(?{ 99 })(?<second>b)c/) {
279-
# Check that $^R got the code block value
280-
if (defined $^R && $^R == 99) {
281-
# Check that regular captures still work
282-
if ($+{first} eq 'a' && $+{second} eq 'b') {
283-
print "ok $test - \$^R and named captures work together\n";
284-
} else {
285-
print "not ok $test - Named captures failed: first=$+{first}, second=$+{second}\n";
286-
}
287-
} else {
288-
print "not ok $test - \$^R should be 99, got: " . (defined $^R ? $^R : "undef") . "\n";
289-
}
290-
} else {
291-
print "not ok $test - Pattern should match\n";
292-
}
293-
$test++;
145+
ok($str =~ /(?<first>a)(?{ 99 })(?<second>b)c/, '$^R with named captures - pattern matches');
146+
# Check that $^R got the code block value
147+
is($^R, 99, '$^R and named captures - $^R should be 99');
148+
# Check that regular captures still work
149+
is($+{first}, 'a', '$^R and named captures - first capture correct');
150+
is($+{second}, 'b', '$^R and named captures - second capture correct');
294151
}
295152

296153
# Test 19: Interpolated pattern with code block (future enhancement)
@@ -311,8 +168,7 @@ my $test = 1;
311168

312169
# The eval is expected to fail or return 0 since interpolation isn't supported
313170
# We pass the test because this is a known limitation, not a bug
314-
print "ok $test - Interpolated patterns are a future enhancement (expected to not work yet)\n";
315-
$test++;
171+
pass('Interpolated patterns are a future enhancement (expected to not work yet)');
316172
}
317173

318-
# All tests complete
174+
done_testing();

0 commit comments

Comments
 (0)