1#!perl -w
2
3# test the MULTICALL macros
4# Note: as of Oct 2010, there are not yet comprehensive tests
5# for these macros.
6
7use warnings;
8use strict;
9
10use Test::More tests => 80;
11use XS::APItest;
12
13
14{
15    my $sum = 0;
16    sub add { $sum += $_++ }
17
18    my @a = (1..3);
19    XS::APItest::multicall_each \&add, @a;
20    is($sum, 6, "sum okay");
21    is($a[0], 2, "a[0] okay");
22    is($a[1], 3, "a[1] okay");
23    is($a[2], 4, "a[2] okay");
24}
25
26# [perl #78070]
27# multicall using a sub that already has CvDEPTH > 1 caused sub
28# to be prematurely freed
29
30{
31    my $destroyed = 0;
32    sub REC::DESTROY { $destroyed = 1 }
33
34    my $closure_var;
35    {
36	my $f = sub {
37	    no warnings 'void';
38	    $closure_var;
39	    my $sub = shift;
40	    if (defined $sub) {
41		XS::APItest::multicall_each \&$sub, 1,2,3;
42	    }
43	};
44	bless $f,  'REC';
45	$f->($f);
46	is($destroyed, 0, "f not yet destroyed");
47    }
48    is($destroyed, 1, "f now destroyed");
49
50}
51
52# [perl #115602]
53# deep recursion realloced the CX stack, but the dMULTICALL local var
54# 'cx' still pointed to the old one.
55# This doesn't actually test the failure (I couldn't think of a way to
56# get the failure to show at the perl level) but it allows valgrind or
57# similar to spot any errors.
58
59{
60    sub rec { my $c = shift; rec($c-1) if $c > 0 };
61    my @r = XS::APItest::multicall_each { rec(90) } 1,2,3;
62    pass("recursion");
63}
64
65
66
67# Confirm that MULTICALL handles arg return correctly in the various
68# contexts. Also check that lvalue subs are handled the same way, as
69# these take different code paths.
70# Whenever an explicit 'return' is used, it is followed by '1;' to avoid
71# the return being optimised into a leavesub.
72# Adding a 'for' loop pushes extra junk on the stack, which we want to
73# avoid being interpreted as a return arg.
74
75{
76    package Ret;
77
78    use XS::APItest qw(multicall_return G_VOID G_SCALAR G_LIST);
79
80    # Helper function for the block that follows:
81    # check that @$got matches what would be expected if a function returned
82    # the items in @$args in $gimme context.
83
84    sub gimme_check {
85        my ($gimme, $got, $args, $desc) = @_;
86
87        if ($gimme == G_VOID) {
88            ::is (scalar @$got, 0, "G_VOID:   $desc");
89        }
90        elsif ($gimme == G_SCALAR) {
91            ::is (scalar @$got, 1, "G_SCALAR: $desc: expect 1 arg");
92            ::is ($got->[0], (@$args ? $args->[-1] : undef),
93                        "G_SCALAR: $desc: correct arg");
94        }
95        else {
96            ::is (join('-',@$got), join('-', @$args), "G_LIST:  $desc");
97        }
98    }
99
100    for my $gimme (G_VOID, G_SCALAR, G_LIST) {
101        my @a;
102
103        # zero args
104
105        @a = multicall_return {()} $gimme;
106        gimme_check($gimme, \@a, [], "()");
107        sub f1 :lvalue { () }
108        @a = multicall_return \&f1, $gimme;
109        gimme_check($gimme, \@a, [], "() lval");
110
111        @a = multicall_return { return; 1 } $gimme;
112        gimme_check($gimme, \@a, [], "return");
113        sub f2 :lvalue { return; 1 }
114        @a = multicall_return \&f2, $gimme;
115        gimme_check($gimme, \@a, [], "return lval");
116
117
118        @a = multicall_return { for (1,2) { return; 1 } } $gimme;
119        gimme_check($gimme, \@a, [], "for-return");
120        sub f3 :lvalue { for (1,2) { return; 1 } }
121        @a = multicall_return \&f3, $gimme;
122        gimme_check($gimme, \@a, [], "for-return lval");
123
124        # one arg
125
126        @a = multicall_return {"one"} $gimme;
127        gimme_check($gimme, \@a, ["one"], "one arg");
128        sub f4 :lvalue { "one" }
129        @a = multicall_return \&f4, $gimme;
130        gimme_check($gimme, \@a, ["one"], "one arg lval");
131
132        @a = multicall_return { return "one"; 1} $gimme;
133        gimme_check($gimme, \@a, ["one"], "return one arg");
134        sub f5 :lvalue { return "one"; 1 }
135        @a = multicall_return \&f5, $gimme;
136        gimme_check($gimme, \@a, ["one"], "return one arg lval");
137
138        @a = multicall_return { for (1,2) { return "one"; 1} } $gimme;
139        gimme_check($gimme, \@a, ["one"], "for-return one arg");
140        sub f6 :lvalue { for (1,2) { return "one"; 1 } }
141        @a = multicall_return \&f6, $gimme;
142        gimme_check($gimme, \@a, ["one"], "for-return one arg lval");
143
144        # two args
145
146        @a = multicall_return {"one", "two" } $gimme;
147        gimme_check($gimme, \@a, ["one", "two"], "two args");
148        sub f7 :lvalue { "one", "two" }
149        @a = multicall_return \&f7, $gimme;
150        gimme_check($gimme, \@a, ["one", "two"], "two args lval");
151
152        @a = multicall_return { return "one", "two"; 1} $gimme;
153        gimme_check($gimme, \@a, ["one", "two"], "return two args");
154        sub f8 :lvalue { return "one", "two"; 1 }
155        @a = multicall_return \&f8, $gimme;
156        gimme_check($gimme, \@a, ["one", "two"], "return two args lval");
157
158        @a = multicall_return { for (1,2) { return "one", "two"; 1} } $gimme;
159        gimme_check($gimme, \@a, ["one", "two"], "for-return two args");
160        sub f9 :lvalue { for (1,2) { return "one", "two"; 1 } }
161        @a = multicall_return \&f9, $gimme;
162        gimme_check($gimme, \@a, ["one", "two"], "for-return two args lval");
163    }
164
165    # MULTICALL *shouldn't* clear savestack after each call
166
167    sub f10 { my $x = 1; $x };
168    my @a = XS::APItest::multicall_return \&f10, G_SCALAR;
169    ::is($a[0], 1, "leave scope");
170}
171