This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
TODO test for $AUTOLOAD with XS AUTOLOAD
[perl5.git] / ext / XS-APItest / t / autoload.t
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
7 use strict;
8 use warnings;
9
10 use Test::More tests => 27;
11
12 use XS::APItest;
13
14 is XS::APItest::AutoLoader::frob(), 'frob', 'name passed to XS AUTOLOAD';
15 is "XS::APItest::AutoLoader::fr\0b"->(), "fr\0b",
16   'name with embedded null passed to XS AUTOLOAD';
17 is "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
22 is frob(), 'frob', 'name passed to XS AUTOLOAD with proto';
23 is prototype \&AUTOLOAD, '*$', 'prototype is unchanged';
24 is "fr\0b"->(), "fr\0b",
25   'name with embedded null passed to XS AUTOLOAD with proto';
26 is prototype \&AUTOLOAD, '*$', 'proto unchanged after embedded-null call';
27 is "fr\x{1ed9}b"->(), "fr\x{1ed9}b",
28   'Unicode name passed to XS AUTOLOAD with proto';
29 is prototype \&AUTOLOAD, '*$', 'prototype is unchanged after Unicode call';
30
31 # Test that the prototype was preserved from the parser’s point of view
32
33 ok !eval "sub { ::AUTOLOAD(1) }",
34    'parse failure due to AUTOLOAD prototype';
35 ok eval "sub { ::AUTOLOAD(1,2) }", 'successful parse respecting prototype'
36   or diag $@;
37
38 package fribble { sub a { return 7 } }
39 no 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
45 no strict;
46 is 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 $
52 is 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
80 ok(XS::APItest::AUTOLOADtest->can('AUTOLOAD'), 'Test class ->can AUTOLOAD');
81
82 # Used to communicate from the XS AUTOLOAD to Perl land
83 use vars '$the_method';
84
85 # First, set up the Perl equivalent to what we're testing in
86 # XS so we have a comparison
87 package PerlBase;
88 use vars '$AUTOLOAD';
89 sub AUTOLOAD {
90   Test::More::ok(defined $AUTOLOAD);
91   return 1 if not defined $AUTOLOAD;
92   $main::the_method = $AUTOLOAD;
93   return 0;
94 }
95
96 package PerlDerived;
97 use vars '@ISA';
98 @ISA = qw(PerlBase);
99
100 package Derived;
101 use vars '@ISA';
102 @ISA = qw(XS::APItest::AUTOLOADtest);
103
104 package main;
105
106 # Test Perl AUTOLOAD in base class directly
107 $the_method = undef;
108 is(PerlBase->Blah(), 0,
109    "Perl AUTOLOAD gets called and returns success");
110 is($the_method, 'PerlBase::Blah',
111    'Scalar set to correct class/method name');
112
113 # Test Perl AUTOLOAD in derived class
114 $the_method = undef;
115 is(PerlDerived->Boo(), 0,
116    'Perl AUTOLOAD on derived class gets called and returns success');
117 is($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;
122 TODO: {
123   local $TODO = 'Bug: $AUTOLOAD not set for XSUB AUTOLOADs';
124   is(XS::APItest::AUTOLOADtest->Blah(), 0,
125      'XS AUTOLOAD gets called and returns success');
126   is($the_method, 'XS::APItest::AUTOLOADtest::Blah',
127      'Scalar set to correct class/method name');
128 }
129
130 # Test XS AUTOLOAD in derived class directly
131 $the_method = undef;
132 TODO: {
133   local $TODO = 'Bug: $AUTOLOAD not set for XSUB AUTOLOADs';
134   is(Derived->Foo(), 0,
135      'XS AUTOLOAD gets called and returns success');
136   is($the_method, 'Derived::Foo',
137      'Scalar set to correct class/method name');
138 }