xref: /openbsd/gnu/usr.bin/perl/t/uni/method.t (revision e0680481) 
1#!./perl -w
2
3#
4# test method calls and autoloading.
5#
6
7BEGIN {
8    chdir 't' if -d 't';
9    require "./test.pl";
10    set_up_inc( qw(. ../lib ../cpan/parent/lib) );
11	require './charset_tools.pl';
12}
13
14use strict;
15use utf8;
16use open qw( :utf8 :std );
17no warnings 'once';
18
19plan(tests => 62);
20
21#Can't use bless yet, as it might not be clean
22
23sub F::ｂ { ::is shift, "F";  "UTF8 meth"       }
24sub Ｆ::b { ::is shift, "Ｆ";  "UTF8 Stash"     }
25sub Ｆ::ｂ { ::is shift, "Ｆ"; "UTF8 Stash&meth" }
26
27is(F->ｂ, "UTF8 meth", "If the method is in UTF-8, lookup works through explicitly named methods");
28is(F->${\"ｂ"}, "UTF8 meth", '..as does for ->${\""}');
29eval { F->${\"ｂ\0nul"} };
30ok $@, "If the method is in UTF-8, lookup is nul-clean";
31
32is(Ｆ->b, "UTF8 Stash", "If the stash is in UTF-8, lookup works through explicitly named methods");
33is(Ｆ->${\"b"}, "UTF8 Stash", '..as does for ->${\""}');
34eval { Ｆ->${\"b\0nul"} };
35ok $@, "If the stash is in UTF-8, lookup is nul-clean";
36
37is(Ｆ->ｂ, "UTF8 Stash&meth", "If both stash and method are in UTF-8, lookup works through explicitly named methods");
38is(Ｆ->${\"ｂ"}, "UTF8 Stash&meth", '..as does for ->${\""}');
39eval { Ｆ->${\"ｂ\0nul"} };
40ok $@, "Even if both stash and method are in UTF-8, lookup is nul-clean";
41
42eval { my $ref = \my $var; $ref->ｍｅｔｈｏｄ };
43like $@, qr/Can't call method "ｍｅｔｈｏｄ" on unblessed reference /u;
44
45{
46    use utf8;
47    use open qw( :utf8 :std );
48
49    my $e;
50
51    eval '$e = bless {}, "Ｅ::Ａ"; Ｅ::Ａ->ｆｏｏ()';
52    like ($@, qr/^\QCan't locate object method "ｆｏｏ" via package "Ｅ::Ａ" at/u);
53    eval '$e = bless {}, "Ｅ::Ｂ"; $e->ｆｏｏ()';
54    like ($@, qr/^\QCan't locate object method "ｆｏｏ" via package "Ｅ::Ｂ" at/u);
55    eval 'Ｅ::Ｃ->ｆｏｏ()';
56    like ($@, qr/^\QCan't locate object method "ｆｏｏ" via package "Ｅ::Ｃ" (perhaps /u);
57
58    eval 'UNIVERSAL->Ｅ::Ｄ::ｆｏｏ()';
59    like ($@, qr/^\QCan't locate object method "ｆｏｏ" via package "Ｅ::Ｄ" (perhaps /u);
60    eval 'my $e = bless {}, "UNIVERSAL"; $e->Ｅ::Ｅ::ｆｏｏ()';
61    like ($@, qr/^\QCan't locate object method "ｆｏｏ" via package "Ｅ::Ｅ" (perhaps /u);
62
63    $e = bless {}, "Ｅ::Ｆ";  # force package to exist
64    eval 'UNIVERSAL->Ｅ::Ｆ::ｆｏｏ()';
65    like ($@, qr/^\QCan't locate object method "ｆｏｏ" via package "Ｅ::Ｆ" at/u);
66    eval '$e = bless {}, "UNIVERSAL"; $e->Ｅ::Ｆ::ｆｏｏ()';
67    like ($@, qr/^\QCan't locate object method "ｆｏｏ" via package "Ｅ::Ｆ" at/u);
68}
69
70is(do { use utf8; use open qw( :utf8 :std ); eval 'Ｆｏｏ->ｂｏｏｇｉｅ()';
71	  $@ =~ /^\QCan't locate object method "ｂｏｏｇｉｅ" via package "Ｆｏｏ" (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 Ｔ::DESTROY { $x = $_[0]; } bless [], "Ｔ";!;
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 'Ｔ' during global destruction./u,
98            "DESTROY creating a new reference to the object generates a warning in UTF-8.");
99}
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";
115my $e_with_grave = byte_utf8a_to_utf8n("\303\250");
116my $e_with_grave_escaped= $e_with_grave=~s/\x{a8}/\\\\x\\{a8\\}/r;
117my $new_utf8  = "n${e_with_grave}w";
118my $newoct    = "n${e_with_grave}w";
119utf8::decode($new_utf8);
120
121like( 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." );
122like( 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." );
123like( 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." );
124{
125    local $@;
126    eval { Føø::Bær->$newoct };
127    like($@, qr/Can't locate object method "n${e_with_grave_escaped}w" via package "Føø::Bær"/u,
128        "Can't access [$newoct], stored in a scalar, as a method through a UTF-8 package." );
129}
130
131
132like( 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.");
133
134my $pkg_latin_1 = 'Føø::Bær';
135
136like( $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.');
137like( $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.');
138
139like( $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.");
140like( $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.");
141like( $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." );
142{
143    local $@;
144
145    eval { $pkg_latin_1->$newoct };
146    like($@, qr/Can't locate object method "n${e_with_grave_escaped}w" via package "Føø::Bær"/u,
147        "Can't access [$newoct], stored in a scalar, as a method, when the UTF-8 package name is also in a scalar.");
148}
149
150ok !!Føø::Bær->can($new_ascii), "->can works for [$new_ascii]";
151ok !!Føø::Bær->can($new_latin), "->can works for [$new_latin]";
152ok((not !!Føø::Bær->can($newoct)), "->can doesn't work for [$newoct]");
153
154package クラス {
155    sub new { bless {}, shift }
156    sub ニュー { bless {}, shift }
157}
158
159like( クラス::new("クラス"), qr/クラス=HASH/u);
160like( クラス->new, qr/クラス=HASH/u);
161
162like( クラス::ニュー("クラス"), qr/クラス=HASH/u);
163like( クラス->ニュー, qr/クラス=HASH/u);
164
165like( ニュー クラス, qr/クラス=HASH/u, "Indirect object is UTF-8, as is the class.");
166
167is( ref クラス->new, 'クラス');
168is( ref クラス->ニュー, 'クラス');
169
170package Foo::Bar {
171    our @ISA = qw( Føø::Bær );
172}
173
174package Foo::Bàz {
175    use parent qw( -norequire Føø::Bær );
176}
177
178package ฟọ::バッズ {
179    use parent qw( -norequire Føø::Bær クラス );
180}
181
182ok(Foo::Bar->new, 'Simple inheritance works by pushing into @ISA,');
183ok(Foo::Bar->nèw, 'Even with UTF-8 methods');
184
185ok(Foo::Bàz->new, 'Simple inheritance works with parent using -norequire,');
186ok(Foo::Bàz->nèw, 'Even with UTF-8 methods');
187
188ok(ฟọ::バッズ->new, 'parent using -norequire, in a UTF-8 package.');
189ok(ฟọ::バッズ->nèw, 'Also works with UTF-8 methods');
190ok(ฟọ::バッズ->ニュー, 'Even methods from an UTF-8 parent');
191
192BEGIN {no strict 'refs';
193       ++${"\xff::foo"} if $::IS_ASCII;
194       ++${"\xdf::foo"} if $::IS_EBCDIC;
195       } # autovivify the package
196package ÿ {                                 # without UTF8
197 sub AUTOLOAD {
198  if ($::IS_ASCII) {
199    ::is our $AUTOLOAD,
200      "\xff::\x{100}", '$AUTOLOAD made from Latin1 package + UTF8 sub';
201  }
202  else {
203    ::is our $AUTOLOAD,
204      "\xdf::\x{100}", '$AUTOLOAD made from Latin1 package + UTF8 sub';
205    }
206  }
207}
208ÿ->${\"\x{100}"};
209
210#This test should go somewhere else.
211#DATA was being generated in the wrong package.
212package ʑ;
213no strict 'refs';
214
215::ok( *{"ʑ::DATA"}{IO}, "DATA is generated in the right glob");
216::ok !defined(*{"main::DATA"}{IO});
217::is scalar <DATA>, "Some data\n";
218
219__DATA__
220Some data
221