xref: /openbsd-src/gnu/usr.bin/perl/t/op/decl-refs.t (revision 5759b3d249badf144a6240f7eec4dcf9df003e6b)
1*5759b3d2Safresh1BEGIN {
2*5759b3d2Safresh1    chdir 't';
3*5759b3d2Safresh1    require './test.pl';
4*5759b3d2Safresh1    set_up_inc('../lib');
5*5759b3d2Safresh1}
6*5759b3d2Safresh1
7*5759b3d2Safresh1plan 402;
8*5759b3d2Safresh1
9*5759b3d2Safresh1for my $decl (qw< my CORE::state our local >) {
10*5759b3d2Safresh1    for my $funny (qw< $ @ % >) {
11*5759b3d2Safresh1        # Test three syntaxes with each declarator/funny char combination:
12*5759b3d2Safresh1        #     my \$foo    my(\$foo)    my\($foo)    for my \$foo
13*5759b3d2Safresh1
14*5759b3d2Safresh1        for my $code("$decl \\${funny}x", "$decl\(\\${funny}x\)",
15*5759b3d2Safresh1                     "$decl\\\(${funny}x\)",
16*5759b3d2Safresh1                     "for $decl \\${funny}x (\\${funny}y) {}") {
17*5759b3d2Safresh1          SKIP: {
18*5759b3d2Safresh1            skip "for local is illegal", 3 if $code =~ /^for local/;
19*5759b3d2Safresh1            eval $code;
20*5759b3d2Safresh1            like
21*5759b3d2Safresh1                $@,
22*5759b3d2Safresh1                qr/^The experimental declared_refs feature is not enabled/,
23*5759b3d2Safresh1               "$code error when feature is disabled";
24*5759b3d2Safresh1
25*5759b3d2Safresh1            use feature 'declared_refs';
26*5759b3d2Safresh1
27*5759b3d2Safresh1            my($w,$c);
28*5759b3d2Safresh1            local $SIG{__WARN__} = sub { $c++; $w = shift };
29*5759b3d2Safresh1            eval $code;
30*5759b3d2Safresh1            is $c, 1, "one warning from $code";
31*5759b3d2Safresh1            like $w, qr/^Declaring references is experimental at /,
32*5759b3d2Safresh1                "experimental warning for $code";
33*5759b3d2Safresh1          }
34*5759b3d2Safresh1        }
35*5759b3d2Safresh1    }
36*5759b3d2Safresh1}
37*5759b3d2Safresh1
38*5759b3d2Safresh1use feature 'declared_refs', 'state';
39*5759b3d2Safresh1no warnings 'experimental::declared_refs';
40*5759b3d2Safresh1
41*5759b3d2Safresh1for $decl ('my', 'state', 'our', 'local') {
42*5759b3d2Safresh1for $sigl ('$', '@', '%') {
43*5759b3d2Safresh1    # The weird code that follows uses ~ as a sigil placeholder and MY
44*5759b3d2Safresh1    # as a declarator placeholder.
45*5759b3d2Safresh1    my $code = '#line ' . (__LINE__+1) . ' ' . __FILE__ . "\n" . <<'END';
46*5759b3d2Safresh1    my $ret = MY \~a;
47*5759b3d2Safresh1    is $ret, \~a, 'MY \$a returns ref to $a';
48*5759b3d2Safresh1    isnt $ret, \~::a, 'MY \$a ret val is not pkg var';
49*5759b3d2Safresh1    my @ret = MY \(~b, ~c);
50*5759b3d2Safresh1    is "@ret", \~b." ".\~c, 'MY \(~b, ~c) returns correct refs';
51*5759b3d2Safresh1    isnt $ret[0], \~::b, 'first retval of MY \(~b, ~c) is not pkg var';
52*5759b3d2Safresh1    isnt $ret[1], \~::c, '2nd retval of MY \(~b, ~c) is not pkg var';
53*5759b3d2Safresh1    @ret = MY (\(~d, ~e));
54*5759b3d2Safresh1    is "@ret", \~d." ".\~e, 'MY (\(~d, ~e)) returns correct refs';
55*5759b3d2Safresh1    isnt $ret[0], \~::d, 'first retval of MY (\(~d, ~e)) is not pkg var';
56*5759b3d2Safresh1    isnt $ret[1], \~::e, '2nd retval of MY (\(~d, ~e)) is not pkg var';
57*5759b3d2Safresh1    @ret = \MY (\~f, ~g);
58*5759b3d2Safresh1    is ${$ret[0]}, \~f, 'first retval of MY (\~f, ~g) is \~f';
59*5759b3d2Safresh1    isnt ${$ret[0]}, \~::f, 'first retval of MY (\~f, ~g) is not \~::f';
60*5759b3d2Safresh1    is $ret[1], \~g, '2nd retval of MY (\~f, ~g) is ~g';
61*5759b3d2Safresh1    isnt $ret[1], \~::g, '2nd retval of MY (\~f, ~g) is not ~::g';
62*5759b3d2Safresh1    *MODIFY_SCALAR_ATTRIBUTES = sub {
63*5759b3d2Safresh1        is @_, 3, 'MY \~h : risible  calls handler with right no. of args';
64*5759b3d2Safresh1        is $_[2], 'risible', 'correct attr passed by MY \~h : risible';
65*5759b3d2Safresh1        return;
66*5759b3d2Safresh1    };
67*5759b3d2Safresh1    SKIP : {
68*5759b3d2Safresh1        unless ('MY' eq 'local') {
69*5759b3d2Safresh1            skip_if_miniperl "No attributes on miniperl", 2;
70*5759b3d2Safresh1            eval 'MY \~h : risible' or die $@ unless 'MY' eq 'local';
71*5759b3d2Safresh1        }
72*5759b3d2Safresh1    }
73*5759b3d2Safresh1    eval 'MY \~a ** 1';
74*5759b3d2Safresh1    like $@,
75*5759b3d2Safresh1        qr/^Can't (?:declare|modify) exponentiation \(\*\*\) in "?MY"? at/,
76*5759b3d2Safresh1       'comp error for MY \~a ** 1';
77*5759b3d2Safresh1    $ret = MY \\~i;
78*5759b3d2Safresh1    is $$ret, \~i, 'retval of MY \\~i is ref to ref to ~i';
79*5759b3d2Safresh1    $ret = MY \\~i;
80*5759b3d2Safresh1    isnt $$ret, \~::i, 'retval of MY \\~i is ref to ref to ~::i';
81*5759b3d2Safresh1    $ret = MY (\\~i);
82*5759b3d2Safresh1    is $$ret, \~i, 'retval of MY (\\~i) is ref to ref to ~i';
83*5759b3d2Safresh1    $ret = MY (\\~i);
84*5759b3d2Safresh1    isnt $$ret, \~::i, 'retval of MY (\\~i) is ref to ref to ~::i';
85*5759b3d2Safresh1    *MODIFY_SCALAR_ATTRIBUTES = sub {
86*5759b3d2Safresh1        is @_, 3, 'MY (\~h) : bumpy  calls handler with right no. of args';
87*5759b3d2Safresh1        is $_[2], 'bumpy', 'correct attr passed by MY (\~h) : bumpy';
88*5759b3d2Safresh1        return;
89*5759b3d2Safresh1    };
90*5759b3d2Safresh1    SKIP : {
91*5759b3d2Safresh1        unless ('MY' eq 'local') {
92*5759b3d2Safresh1            skip_if_miniperl "No attributes on miniperl", 2;
93*5759b3d2Safresh1            eval 'MY (\~h) : bumpy' or die $@;
94*5759b3d2Safresh1        }
95*5759b3d2Safresh1    }
96*5759b3d2Safresh1    1;
97*5759b3d2Safresh1END
98*5759b3d2Safresh1    $code =~ s/MY/$decl/g;
99*5759b3d2Safresh1    $code =~ s/~/$sigl/g;
100*5759b3d2Safresh1    $code =~ s/MODIFY_\KSCALAR/$sigl eq '@' ? "ARRAY" : "HASH"/eggnog
101*5759b3d2Safresh1        if $sigl ne '$';
102*5759b3d2Safresh1    if ($decl =~ /^(?:our|local)\z/) {
103*5759b3d2Safresh1        $code =~ s/is ?no?t/is/g; # tests for package vars
104*5759b3d2Safresh1    }
105*5759b3d2Safresh1    eval $code or die $@;
106*5759b3d2Safresh1}}
107*5759b3d2Safresh1
108*5759b3d2Safresh1use feature 'refaliasing'; no warnings "experimental::refaliasing";
109*5759b3d2Safresh1for $decl ('my', 'state', 'our') {
110*5759b3d2Safresh1for $sigl ('$', '@', '%') {
111*5759b3d2Safresh1    my $code = '#line ' . (__LINE__+1) . ' ' . __FILE__ . "\n" . <<'ENE';
112*5759b3d2Safresh1    for MY \~x (\~::y) {
113*5759b3d2Safresh1        is \~x, \~::y, '\~x aliased by for MY \~x';
114*5759b3d2Safresh1        isnt \~x, \~::x, '\~x is not equivalent to \~::x';
115*5759b3d2Safresh1    }
116*5759b3d2Safresh1    1;
117*5759b3d2Safresh1ENE
118*5759b3d2Safresh1    $code =~ s/MY/$decl/g;
119*5759b3d2Safresh1    $code =~ s/~/$sigl/g;
120*5759b3d2Safresh1    $code =~ s/is ?no?t/is/g if $decl eq 'our';
121*5759b3d2Safresh1    eval $code or die $@;
122*5759b3d2Safresh1}}
123