This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
t/op/magic.t: Generalize for non-ASCII platforms
[perl5.git] / t / uni / method.t
1 #!./perl -w
2
3 #
4 # test method calls and autoloading.
5 #
6
7 BEGIN {
8     chdir 't' if -d 't';
9     @INC = qw(. ../lib ../cpan/parent/lib);
10     require "./test.pl";
11 }
12
13 use strict;
14 use utf8;
15 use open qw( :utf8 :std );
16 no warnings 'once';
17
18 plan(tests => 62);
19
20 #Can't use bless yet, as it might not be clean
21
22 sub F::b { ::is shift, "F";  "UTF8 meth"       }
23 sub F::b { ::is shift, "F";  "UTF8 Stash"     }
24 sub F::b { ::is shift, "F"; "UTF8 Stash&meth" }
25
26 is(F->b, "UTF8 meth", "If the method is in UTF-8, lookup works through explicitly named methods");
27 is(F->${\"b"}, "UTF8 meth", '..as does for ->${\""}');
28 eval { F->${\"b\0nul"} };
29 ok $@, "If the method is in UTF-8, lookup is nul-clean";
30
31 is(F->b, "UTF8 Stash", "If the stash is in UTF-8, lookup works through explicitly named methods");
32 is(F->${\"b"}, "UTF8 Stash", '..as does for ->${\""}');
33 eval { F->${\"b\0nul"} };
34 ok $@, "If the stash is in UTF-8, lookup is nul-clean";
35
36 is(F->b, "UTF8 Stash&meth", "If both stash and method are in UTF-8, lookup works through explicitly named methods");
37 is(F->${\"b"}, "UTF8 Stash&meth", '..as does for ->${\""}');
38 eval { F->${\"b\0nul"} };
39 ok $@, "Even if both stash and method are in UTF-8, lookup is nul-clean";
40
41 eval { my $ref = \my $var; $ref->method };
42 like $@, qr/Can't call method "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 {}, "E::A"; E::A->foo()';
51     like ($@, qr/^\QCan't locate object method "foo" via package "E::A" at/u);
52     eval '$e = bless {}, "E::B"; $e->foo()';  
53     like ($@, qr/^\QCan't locate object method "foo" via package "E::B" at/u);
54     eval 'E::C->foo()';
55     like ($@, qr/^\QCan't locate object method "foo" via package "E::C" (perhaps /u);
56     
57     eval 'UNIVERSAL->E::D::foo()';
58     like ($@, qr/^\QCan't locate object method "foo" via package "E::D" (perhaps /u);
59     eval 'my $e = bless {}, "UNIVERSAL"; $e->E::E::foo()';
60     like ($@, qr/^\QCan't locate object method "foo" via package "E::E" (perhaps /u);
61     
62     $e = bless {}, "E::F";  # force package to exist
63     eval 'UNIVERSAL->E::F::foo()';
64     like ($@, qr/^\QCan't locate object method "foo" via package "E::F" at/u);
65     eval '$e = bless {}, "UNIVERSAL"; $e->E::F::foo()';
66     like ($@, qr/^\QCan't locate object method "foo" via package "E::F" at/u);
67 }
68
69 is(do { use utf8; use open qw( :utf8 :std ); eval 'Foo->boogie()';
70           $@ =~ /^\QCan't locate object method "boogie" via package "Foo" (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.
74 SKIP: {
75     skip_if_miniperl('no dynamic loading on miniperl, no Encode');
76
77     my $prog = q!use utf8; use open qw( :utf8 :std ); sub T::DESTROY { $x = $_[0]; } bless [], "T";!;
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 'T' during global destruction./u,
97             "DESTROY creating a new reference to the object generates a warning in UTF-8.");
98 }
99
100 package Føø::Bær {
101     sub new { bless {}, shift }
102     sub nèw { bless {}, shift }
103 }
104
105 like( Føø::Bær::new("Føø::Bær"), qr/Føø::Bær=HASH/u, 'Can access new directly through a UTF-8 package.' );
106 like( Føø::Bær->new, qr/Føø::Bær=HASH/u, 'Can access new as a method through a UTF-8 package.' );
107 like( Føø::Bær::nèw("Føø::Bær"), qr/Føø::Bær=HASH/u, 'Can access nèw directly through a UTF-8 package.' );
108 like( Føø::Bær->nèw, qr/Føø::Bær=HASH/u, 'Can access nèw as a method through a UTF-8 package.' );
109
110 is( ref Føø::Bær->new, 'Føø::Bær');
111
112 my $new_ascii = "new";
113 my $new_latin = "nèw";
114 my $e_with_grave = byte_utf8a_to_utf8n("\303\250");
115 my $new_utf8  = "n${e_with_grave}w";
116 my $newoct    = "n${e_with_grave}w";
117 utf8::decode($new_utf8);
118
119 like( 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." );
120 like( 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." );
121 like( 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." );
122 {
123     local $@;
124     eval { Føø::Bær->$newoct };
125     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." );
126 }
127
128
129 like( 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.");
130
131 my $pkg_latin_1 = 'Føø::Bær';
132
133 like( $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.');
134 like( $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.');
135
136 like( $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.");
137 like( $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.");
138 like( $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." );
139 {
140     local $@;
141     eval { $pkg_latin_1->$newoct };
142     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.");
143 }
144
145 ok !!Føø::Bær->can($new_ascii), "->can works for [$new_ascii]";
146 ok !!Føø::Bær->can($new_latin), "->can works for [$new_latin]";
147 ok((not !!Føø::Bær->can($newoct)), "->can doesn't work for [$newoct]");
148
149 package クラス {
150     sub new { bless {}, shift }
151     sub ニュー { bless {}, shift }
152 }
153
154 like( クラス::new("クラス"), qr/クラス=HASH/u);
155 like( クラス->new, qr/クラス=HASH/u);
156
157 like( クラス::ニュー("クラス"), qr/クラス=HASH/u);
158 like( クラス->ニュー, qr/クラス=HASH/u);
159
160 like( ニュー クラス, qr/クラス=HASH/u, "Indirect object is UTF-8, as is the class.");
161
162 is( ref クラス->new, 'クラス');
163 is( ref クラス->ニュー, 'クラス');
164
165 package Foo::Bar {
166     our @ISA = qw( Føø::Bær );
167 }
168
169 package Foo::Bàz {
170     use parent qw( -norequire Føø::Bær );
171 }
172
173 package ฟọ::バッズ {
174     use parent qw( -norequire Føø::Bær クラス );
175 }
176
177 ok(Foo::Bar->new, 'Simple inheritance works by pushing into @ISA,');
178 ok(Foo::Bar->nèw, 'Even with UTF-8 methods');
179
180 ok(Foo::Bàz->new, 'Simple inheritance works with parent using -norequire,');
181 ok(Foo::Bàz->nèw, 'Even with UTF-8 methods');
182
183 ok(ฟọ::バッズ->new, 'parent using -norequire, in a UTF-8 package.');
184 ok(ฟọ::バッズ->nèw, 'Also works with UTF-8 methods');
185 ok(ฟọ::バッズ->ニュー, 'Even methods from an UTF-8 parent');
186
187 BEGIN {no strict 'refs'; ++${"\xff::foo"} } # autovivify the package
188 package ÿ {                                 # without UTF8
189  sub AUTOLOAD {
190   ::is our $AUTOLOAD,
191       "\xff::\x{100}", '$AUTOLOAD made from Latin1 package + UTF8 sub';
192  }
193 }
194 ÿ->${\"\x{100}"};
195
196 #This test should go somewhere else.
197 #DATA was being generated in the wrong package.
198 package ʑ;
199 no strict 'refs';
200
201 ::ok( *{"ʑ::DATA"}{IO}, "DATA is generated in the right glob");
202 ::ok !defined(*{"main::DATA"}{IO});
203 ::is scalar <DATA>, "Some data\n";
204
205 __DATA__
206 Some data