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