This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
perl5db: add tests for v command
[perl5.git] / t / uni / method.t
CommitLineData
79edd281
BF
1#!./perl -w
2
3#
4# test method calls and autoloading.
5#
6
7BEGIN {
8 chdir 't' if -d 't';
8c892c9b 9 require "./test.pl";
624c42e2 10 set_up_inc( qw(. ../lib ../cpan/parent/lib) );
8c892c9b 11 require './charset_tools.pl';
79edd281
BF
12}
13
14use strict;
15use utf8;
16use open qw( :utf8 :std );
17no warnings 'once';
18
61a9130e 19plan(tests => 62);
79edd281
BF
20
21#Can't use bless yet, as it might not be clean
22
23sub F::b { ::is shift, "F"; "UTF8 meth" }
24sub F::b { ::is shift, "F"; "UTF8 Stash" }
25sub F::b { ::is shift, "F"; "UTF8 Stash&meth" }
26
27is(F->b, "UTF8 meth", "If the method is in UTF-8, lookup works through explicitly named methods");
28is(F->${\"b"}, "UTF8 meth", '..as does for ->${\""}');
29eval { F->${\"b\0nul"} };
30ok $@, "If the method is in UTF-8, lookup is nul-clean";
31
32is(F->b, "UTF8 Stash", "If the stash is in UTF-8, lookup works through explicitly named methods");
33is(F->${\"b"}, "UTF8 Stash", '..as does for ->${\""}');
34eval { F->${\"b\0nul"} };
35ok $@, "If the stash is in UTF-8, lookup is nul-clean";
36
37is(F->b, "UTF8 Stash&meth", "If both stash and method are in UTF-8, lookup works through explicitly named methods");
38is(F->${\"b"}, "UTF8 Stash&meth", '..as does for ->${\""}');
39eval { F->${\"b\0nul"} };
40ok $@, "Even if both stash and method are in UTF-8, lookup is nul-clean";
41
b375e37b
BF
42eval { my $ref = \my $var; $ref->method };
43like $@, qr/Can't call method "method" on unblessed reference /u;
2a0f5ef0
BF
44
45{
46 use utf8;
47 use open qw( :utf8 :std );
48
49 my $e;
50
51 eval '$e = bless {}, "E::A"; E::A->foo()';
52 like ($@, qr/^\QCan't locate object method "foo" via package "E::A" at/u);
53 eval '$e = bless {}, "E::B"; $e->foo()';
54 like ($@, qr/^\QCan't locate object method "foo" via package "E::B" at/u);
55 eval 'E::C->foo()';
56 like ($@, qr/^\QCan't locate object method "foo" via package "E::C" (perhaps /u);
57
58 eval 'UNIVERSAL->E::D::foo()';
59 like ($@, qr/^\QCan't locate object method "foo" via package "E::D" (perhaps /u);
60 eval 'my $e = bless {}, "UNIVERSAL"; $e->E::E::foo()';
61 like ($@, qr/^\QCan't locate object method "foo" via package "E::E" (perhaps /u);
62
63 $e = bless {}, "E::F"; # force package to exist
64 eval 'UNIVERSAL->E::F::foo()';
65 like ($@, qr/^\QCan't locate object method "foo" via package "E::F" at/u);
66 eval '$e = bless {}, "UNIVERSAL"; $e->E::F::foo()';
67 like ($@, qr/^\QCan't locate object method "foo" via package "E::F" at/u);
68}
69
70is(do { use utf8; use open qw( :utf8 :std ); eval 'Foo->boogie()';
71 $@ =~ /^\QCan't locate object method "boogie" via package "Foo" (perhaps /u ? 1 : $@}, 1);
72
73#This reimplements a bit of _fresh_perl() from test.pl, as we want to decode
74#the output of that program before using it.
75SKIP: {
76 skip_if_miniperl('no dynamic loading on miniperl, no Encode');
77
78 my $prog = q!use utf8; use open qw( :utf8 :std ); sub T::DESTROY { $x = $_[0]; } bless [], "T";!;
79 utf8::decode($prog);
80
81 my $tmpfile = tempfile();
82 my $runperl_args = {};
83 $runperl_args->{progfile} = $tmpfile;
84 $runperl_args->{stderr} = 1;
85
86 open TEST, '>', $tmpfile or die "Cannot open $tmpfile: $!";
87
88 print TEST $prog;
89 close TEST or die "Cannot close $tmpfile: $!";
90
91 my $results = runperl(%$runperl_args);
92
93 require Encode;
94 $results = Encode::decode("UTF-8", $results);
95
96 like($results,
97 qr/DESTROY created new reference to dead object 'T' during global destruction./u,
98 "DESTROY creating a new reference to the object generates a warning in UTF-8.");
99}
2e7cc763
BF
100
101package Føø::Bær {
102 sub new { bless {}, shift }
103 sub nèw { bless {}, shift }
104}
105
106like( Føø::Bær::new("Føø::Bær"), qr/Føø::Bær=HASH/u, 'Can access new directly through a UTF-8 package.' );
107like( Føø::Bær->new, qr/Føø::Bær=HASH/u, 'Can access new as a method through a UTF-8 package.' );
108like( Føø::Bær::nèw("Føø::Bær"), qr/Føø::Bær=HASH/u, 'Can access nèw directly through a UTF-8 package.' );
109like( Føø::Bær->nèw, qr/Føø::Bær=HASH/u, 'Can access nèw as a method through a UTF-8 package.' );
110
111is( ref Føø::Bær->new, 'Føø::Bær');
112
113my $new_ascii = "new";
114my $new_latin = "nèw";
c326159a
KW
115my $e_with_grave = byte_utf8a_to_utf8n("\303\250");
116my $new_utf8 = "n${e_with_grave}w";
117my $newoct = "n${e_with_grave}w";
2e7cc763
BF
118utf8::decode($new_utf8);
119
120like( Føø::Bær->$new_ascii, qr/Føø::Bær=HASH/u, "Can access \$new_ascii, [$new_ascii], stored in a scalar, as a method, through a UTF-8 package." );
121like( Føø::Bær->$new_latin, qr/Føø::Bær=HASH/u, "Can access \$new_latin, [$new_latin], stored in a scalar, as a method, through a UTF-8 package." );
122like( Føø::Bær->$new_utf8, qr/Føø::Bær=HASH/u, "Can access \$new_utf8, [$new_utf8], stored in a scalar, as a method, through a UTF-8 package." );
123{
124 local $@;
125 eval { Føø::Bær->$newoct };
c326159a 126 like($@, qr/Can't locate object method "n${e_with_grave}w" via package "Føø::Bær"/u, "Can't access [$newoct], stored in a scalar, as a method through a UTF-8 package." );
2e7cc763
BF
127}
128
129
130like( nèw Føø::Bær, qr/Føø::Bær=HASH/u, "Can access [nèw] as a method through a UTF-8 indirect object package.");
131
132my $pkg_latin_1 = 'Føø::Bær';
133
134like( $pkg_latin_1->new, qr/Føø::Bær=HASH/u, 'Can access new as a method when the UTF-8 package name is in a scalar.');
135like( $pkg_latin_1->nèw, qr/Føø::Bær=HASH/u, 'Can access nèw as a method when the UTF-8 package name is in a scalar.');
136
137like( $pkg_latin_1->$new_ascii, qr/Føø::Bær=HASH/u, "Can access \$new_ascii, [$new_ascii], stored in a scalar, as a method, when the UTF-8 package name is also in a scalar.");
138like( $pkg_latin_1->$new_latin, qr/Føø::Bær=HASH/u, "Can access \$new_latin, [$new_latin], stored in a scalar, as a method, when the UTF-8 package name is also in a scalar.");
139like( $pkg_latin_1->$new_utf8, qr/Føø::Bær=HASH/u, "Can access \$new_utf8, [$new_utf8], stored in a scalar, as a method, when the UTF-8 package name is also in a scalar." );
140{
141 local $@;
142 eval { $pkg_latin_1->$newoct };
c326159a 143 like($@, qr/Can't locate object method "n${e_with_grave}w" via package "Føø::Bær"/u, "Can't access [$newoct], stored in a scalar, as a method, when the UTF-8 package name is also in a scalar.");
2e7cc763
BF
144}
145
146ok !!Føø::Bær->can($new_ascii), "->can works for [$new_ascii]";
147ok !!Føø::Bær->can($new_latin), "->can works for [$new_latin]";
148ok((not !!Føø::Bær->can($newoct)), "->can doesn't work for [$newoct]");
149
150package クラス {
151 sub new { bless {}, shift }
152 sub ニュー { bless {}, shift }
153}
154
155like( クラス::new("クラス"), qr/クラス=HASH/u);
156like( クラス->new, qr/クラス=HASH/u);
157
158like( クラス::ニュー("クラス"), qr/クラス=HASH/u);
159like( クラス->ニュー, qr/クラス=HASH/u);
160
161like( ニュー クラス, qr/クラス=HASH/u, "Indirect object is UTF-8, as is the class.");
162
163is( ref クラス->new, 'クラス');
164is( ref クラス->ニュー, 'クラス');
165
166package Foo::Bar {
167 our @ISA = qw( Føø::Bær );
168}
169
170package Foo::Bàz {
171 use parent qw( -norequire Føø::Bær );
172}
173
174package ฟọ::バッズ {
175 use parent qw( -norequire Føø::Bær クラス );
176}
177
178ok(Foo::Bar->new, 'Simple inheritance works by pushing into @ISA,');
179ok(Foo::Bar->nèw, 'Even with UTF-8 methods');
180
181ok(Foo::Bàz->new, 'Simple inheritance works with parent using -norequire,');
182ok(Foo::Bàz->nèw, 'Even with UTF-8 methods');
183
184ok(ฟọ::バッズ->new, 'parent using -norequire, in a UTF-8 package.');
185ok(ฟọ::バッズ->nèw, 'Also works with UTF-8 methods');
186ok(ฟọ::バッズ->ニュー, 'Even methods from an UTF-8 parent');
187
1157e716
KW
188BEGIN {no strict 'refs';
189 ++${"\xff::foo"} if $::IS_ASCII;
190 ++${"\xdf::foo"} if $::IS_EBCDIC;
191 } # autovivify the package
61a9130e
FC
192package ÿ { # without UTF8
193 sub AUTOLOAD {
1157e716
KW
194 if ($::IS_ASCII) {
195 ::is our $AUTOLOAD,
61a9130e 196 "\xff::\x{100}", '$AUTOLOAD made from Latin1 package + UTF8 sub';
1157e716
KW
197 }
198 else {
199 ::is our $AUTOLOAD,
200 "\xdf::\x{100}", '$AUTOLOAD made from Latin1 package + UTF8 sub';
201 }
202 }
61a9130e
FC
203}
204ÿ->${\"\x{100}"};
205
26df5401
BF
206#This test should go somewhere else.
207#DATA was being generated in the wrong package.
208package ʑ;
209no strict 'refs';
210
211::ok( *{"ʑ::DATA"}{IO}, "DATA is generated in the right glob");
212::ok !defined(*{"main::DATA"}{IO});
213::is scalar <DATA>, "Some data\n";
214
215__DATA__
216Some data