1#!perl
2
3# This script tests not only the interface for XS AUTOLOAD routines to find
4# out the sub name, but also that that interface does not interfere with
5# prototypes, the way it did before 5.15.4.
6
7use strict;
8use warnings;
9
10use Test::More tests => 26;
11
12use XS::APItest;
13
14is XS::APItest::AutoLoader::frob(), 'frob', 'name passed to XS AUTOLOAD';
15is "XS::APItest::AutoLoader::fr\0b"->(), "fr\0b",
16  'name with embedded null passed to XS AUTOLOAD';
17is "XS::APItest::AutoLoader::fr\x{1ed9}b"->(), "fr\x{1ed9}b",
18  'Unicode name passed to XS AUTOLOAD';
19
20*AUTOLOAD = *XS::APItest::AutoLoader::AUTOLOADp;
21
22is frob(), 'frob', 'name passed to XS AUTOLOAD with proto';
23is prototype \&AUTOLOAD, '*$', 'prototype is unchanged';
24is "fr\0b"->(), "fr\0b",
25  'name with embedded null passed to XS AUTOLOAD with proto';
26is prototype \&AUTOLOAD, '*$', 'proto unchanged after embedded-null call';
27is "fr\x{1ed9}b"->(), "fr\x{1ed9}b",
28  'Unicode name passed to XS AUTOLOAD with proto';
29is prototype \&AUTOLOAD, '*$', 'prototype is unchanged after Unicode call';
30
31# Test that the prototype was preserved from the parser’s point of view
32
33ok !eval "sub { ::AUTOLOAD(1) }",
34   'parse failure due to AUTOLOAD prototype';
35ok eval "sub { ::AUTOLOAD(1,2) }", 'successful parse respecting prototype'
36  or diag $@;
37
38package fribble { sub a { return 7 } }
39no warnings 'once';
40*a = \&AUTOLOAD;
41'$'->();
42# &a('fribble') will return '$'
43# But if intuit_method does not see the (*...) proto, this compiles as
44# fribble->a
45no strict;
46is eval 'a fribble, 3', '$', 'intuit_method sees * in AUTOLOAD proto'
47  or diag $@;
48
49# precedence check
50# *$ should parse as a list operator, but right now the AUTOLOAD
51# sub name is $
52is join(" ", eval 'a "b", "c"'), '$',
53   'precedence determination respects prototype of AUTOLOAD sub';
54
55{
56    my $w;
57    local $SIG{__WARN__} = sub { $w .= shift };
58    eval 'sub a($){}';
59    like $w, qr/^Prototype mismatch: sub main::a \(\*\$\) vs \(\$\)/m,
60        'proto warnings respect AUTOLOAD prototypes';
61    undef $w;
62    *a = \&AUTOLOAD;
63    like $w, qr/^Prototype mismatch: sub main::a \(\$\) vs \(\*\$\)/m,
64        'GV assignment proto warnings respect AUTOLOAD prototypes';
65}
66
67
68#
69# This is a test for AUTOLOAD implemented as an XSUB.
70# It tests that $AUTOLOAD is set correctly, including the
71# case of inheritance.
72#
73# Rationale: Due to change ed850460, $AUTOLOAD is not currently set
74# for XSUB AUTOLOADs at all.  Instead, as of adb5a9ae the PV of the
75# AUTOLOAD XSUB is set to the name of the method. We cruelly test it
76# regardless.
77#
78
79# First, make sure we have the XS AUTOLOAD available for testing
80ok(XS::APItest::AUTOLOADtest->can('AUTOLOAD'), 'Test class ->can AUTOLOAD');
81
82# Used to communicate from the XS AUTOLOAD to Perl land
83use vars '$the_method';
84
85# First, set up the Perl equivalent to what we're testing in
86# XS so we have a comparison
87package PerlBase;
88use vars '$AUTOLOAD';
89sub AUTOLOAD {
90  Test::More::ok(defined $AUTOLOAD);
91  return 1 if not defined $AUTOLOAD;
92  $main::the_method = $AUTOLOAD;
93  return 0;
94}
95
96package PerlDerived;
97use vars '@ISA';
98@ISA = qw(PerlBase);
99
100package Derived;
101use vars '@ISA';
102@ISA = qw(XS::APItest::AUTOLOADtest);
103
104package main;
105
106# Test Perl AUTOLOAD in base class directly
107$the_method = undef;
108is(PerlBase->Blah(), 0,
109   "Perl AUTOLOAD gets called and returns success");
110is($the_method, 'PerlBase::Blah',
111   'Scalar set to correct class/method name');
112
113# Test Perl AUTOLOAD in derived class
114$the_method = undef;
115is(PerlDerived->Boo(), 0,
116   'Perl AUTOLOAD on derived class gets called and returns success');
117is($the_method, 'PerlDerived::Boo',
118   'Scalar set to correct class/method name');
119
120# Test XS AUTOLOAD in base class directly
121$the_method = undef;
122is(XS::APItest::AUTOLOADtest->Blah(), 0,
123     'XS AUTOLOAD gets called and returns success');
124is($the_method, 'XS::APItest::AUTOLOADtest::Blah',
125     'Scalar set to correct class/method name');
126
127# Test XS AUTOLOAD in derived class directly
128$the_method = undef;
129is(Derived->Foo(), 0,
130     'XS AUTOLOAD gets called and returns success');
131is($the_method, 'Derived::Foo',
132     'Scalar set to correct class/method name');
133