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