Commit | Line | Data |
---|---|---|
192b9cd1 AB |
1 | #!./perl |
2 | ||
3 | BEGIN { | |
4 | chdir 't' if -d 't'; | |
5 | @INC = '../lib'; | |
6 | require './test.pl'; | |
7 | } | |
8 | ||
9 | # Do a basic test on all the tied methods of Tie::Hash::NamedCapture | |
10 | ||
89c9327b | 11 | plan(tests => 37); |
1e1d4b91 JJ |
12 | |
13 | # PL_curpm->paren_names can be a null pointer. See that this succeeds anyway. | |
14 | 'x' =~ /(.)/; | |
15 | () = %+; | |
16 | pass( 'still alive' ); | |
192b9cd1 AB |
17 | |
18 | "hlagh" =~ / | |
19 | (?<a>.) | |
20 | (?<b>.) | |
21 | (?<a>.) | |
22 | .* | |
23 | (?<e>$) | |
24 | /x; | |
25 | ||
26 | # FETCH | |
27 | is($+{a}, "h", "FETCH"); | |
28 | is($+{b}, "l", "FETCH"); | |
29 | is($-{a}[0], "h", "FETCH"); | |
30 | is($-{a}[1], "a", "FETCH"); | |
31 | ||
32 | # STORE | |
33 | eval { $+{a} = "yon" }; | |
e5351d2f | 34 | like($@, qr/read-only/, "STORE"); |
192b9cd1 AB |
35 | |
36 | # DELETE | |
37 | eval { delete $+{a} }; | |
e5351d2f | 38 | like($@, qr/read-only/, "DELETE"); |
192b9cd1 AB |
39 | |
40 | # CLEAR | |
41 | eval { %+ = () }; | |
e5351d2f | 42 | like($@, qr/read-only/, "CLEAR"); |
192b9cd1 AB |
43 | |
44 | # EXISTS | |
45 | ok(exists $+{e}, "EXISTS"); | |
46 | ok(!exists $+{d}, "EXISTS"); | |
47 | ||
48 | # FIRSTKEY/NEXTKEY | |
49 | is(join('|', sort keys %+), "a|b|e", "FIRSTKEY/NEXTKEY"); | |
50 | ||
51 | # SCALAR | |
52 | is(scalar(%+), 3, "SCALAR"); | |
53 | is(scalar(%-), 3, "SCALAR"); | |
1d021cc8 NC |
54 | |
55 | # Abuse all methods with undef as the first argument (RT #71828 and then some): | |
56 | ||
57 | is(Tie::Hash::NamedCapture::FETCH(undef, undef), undef, 'FETCH with undef'); | |
58 | eval {Tie::Hash::NamedCapture::STORE(undef, undef, undef)}; | |
59 | like($@, qr/Modification of a read-only value attempted/, 'STORE with undef'); | |
60 | eval {Tie::Hash::NamedCapture::DELETE(undef, undef)}; | |
61 | like($@, , qr/Modification of a read-only value attempted/, | |
62 | 'DELETE with undef'); | |
63 | eval {Tie::Hash::NamedCapture::CLEAR(undef)}; | |
64 | like($@, qr/Modification of a read-only value attempted/, 'CLEAR with undef'); | |
65 | is(Tie::Hash::NamedCapture::EXISTS(undef, undef), undef, 'EXISTS with undef'); | |
66 | is(Tie::Hash::NamedCapture::FIRSTKEY(undef), undef, 'FIRSTKEY with undef'); | |
67 | is(Tie::Hash::NamedCapture::NEXTKEY(undef, undef), undef, 'NEXTKEY with undef'); | |
68 | is(Tie::Hash::NamedCapture::SCALAR(undef), undef, 'SCALAR with undef'); | |
89c9327b NC |
69 | |
70 | my $obj = tied %+; | |
71 | foreach ([FETCH => '$key'], | |
72 | [STORE => '$key, $value'], | |
73 | [DELETE => '$key'], | |
74 | [CLEAR => ''], | |
75 | [EXISTS => '$key'], | |
76 | [FIRSTKEY => ''], | |
77 | [NEXTKEY => '$lastkey'], | |
78 | [SCALAR => ''], | |
79 | ) { | |
80 | my ($method, $error) = @$_; | |
81 | ||
82 | is(eval {$obj->$method(0..3); 1}, undef, "$method with undef"); | |
83 | like($@, qr/Usage: Tie::Hash::NamedCapture::$method\(\Q$error\E\)/, | |
84 | "usage method for $method"); | |
85 | } |