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     require "./test.pl";
  10     set_up_inc( qw(. ../lib ../cpan/parent/lib) );
  11         require './charset_tools.pl';
  12 }
  13
  14 use strict;
  15 use utf8;
  16 use open qw( :utf8 :std );
  17 no warnings 'once';
  18
  19 plan(tests => 62);
  20
  21 #Can't use bless yet, as it might not be clean
  22
  23 sub F::ｂ { ::is shift, "F";  "UTF8 meth"       }
  24 sub Ｆ::b { ::is shift, "Ｆ";  "UTF8 Stash"     }
  25 sub Ｆ::ｂ { ::is shift, "Ｆ"; "UTF8 Stash&meth" }
  26
  27 is(F->ｂ, "UTF8 meth", "If the method is in UTF-8, lookup works through explicitly named methods");
  28 is(F->${\"ｂ"}, "UTF8 meth", '..as does for ->${\""}');
  29 eval { F->${\"ｂ\0nul"} };
  30 ok $@, "If the method is in UTF-8, lookup is nul-clean";
  31
  32 is(Ｆ->b, "UTF8 Stash", "If the stash is in UTF-8, lookup works through explicitly named methods");
  33 is(Ｆ->${\"b"}, "UTF8 Stash", '..as does for ->${\""}');
  34 eval { Ｆ->${\"b\0nul"} };
  35 ok $@, "If the stash is in UTF-8, lookup is nul-clean";
  36
  37 is(Ｆ->ｂ, "UTF8 Stash&meth", "If both stash and method are in UTF-8, lookup works through explicitly named methods");
  38 is(Ｆ->${\"ｂ"}, "UTF8 Stash&meth", '..as does for ->${\""}');
  39 eval { Ｆ->${\"ｂ\0nul"} };
  40 ok $@, "Even if both stash and method are in UTF-8, lookup is nul-clean";
  41
  42 eval { my $ref = \my $var; $ref->ｍｅｔｈｏｄ };
  43 like $@, 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
  70 is(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.
  75 SKIP: {
  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
 101 package Føø::Bær {
 102     sub new { bless {}, shift }
 103     sub nèw { bless {}, shift }
 104 }
 105
 106 like( Føø::Bær::new("Føø::Bær"), qr/Føø::Bær=HASH/u, 'Can access new directly through a UTF-8 package.' );
 107 like( Føø::Bær->new, qr/Føø::Bær=HASH/u, 'Can access new as a method through a UTF-8 package.' );
 108 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.' );
 109 like( Føø::Bær->nèw, qr/Føø::Bær=HASH/u, 'Can access nèw as a method through a UTF-8 package.' );
 110
 111 is( ref Føø::Bær->new, 'Føø::Bær');
 112
 113 my $new_ascii = "new";
 114 my $new_latin = "nèw";
 115 my $e_with_grave = byte_utf8a_to_utf8n("\303\250");
 116 my $new_utf8  = "n${e_with_grave}w";
 117 my $newoct    = "n${e_with_grave}w";
 118 utf8::decode($new_utf8);
 119
 120 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." );
 121 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." );
 122 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." );
 123 {
 124     local $@;
 125     eval { Føø::Bær->$newoct };
 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." );
 127 }
 128
 129
 130 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.");
 131
 132 my $pkg_latin_1 = 'Føø::Bær';
 133
 134 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.');
 135 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.');
 136
 137 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.");
 138 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.");
 139 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." );
 140 {
 141     local $@;
 142     eval { $pkg_latin_1->$newoct };
 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.");
 144 }
 145
 146 ok !!Føø::Bær->can($new_ascii), "->can works for [$new_ascii]";
 147 ok !!Føø::Bær->can($new_latin), "->can works for [$new_latin]";
 148 ok((not !!Føø::Bær->can($newoct)), "->can doesn't work for [$newoct]");
 149
 150 package クラス {
 151     sub new { bless {}, shift }
 152     sub ニュー { bless {}, shift }
 153 }
 154
 155 like( クラス::new("クラス"), qr/クラス=HASH/u);
 156 like( クラス->new, qr/クラス=HASH/u);
 157
 158 like( クラス::ニュー("クラス"), qr/クラス=HASH/u);
 159 like( クラス->ニュー, qr/クラス=HASH/u);
 160
 161 like( ニュー クラス, qr/クラス=HASH/u, "Indirect object is UTF-8, as is the class.");
 162
 163 is( ref クラス->new, 'クラス');
 164 is( ref クラス->ニュー, 'クラス');
 165
 166 package Foo::Bar {
 167     our @ISA = qw( Føø::Bær );
 168 }
 169
 170 package Foo::Bàz {
 171     use parent qw( -norequire Føø::Bær );
 172 }
 173
 174 package ฟọ::バッズ {
 175     use parent qw( -norequire Føø::Bær クラス );
 176 }
 177
 178 ok(Foo::Bar->new, 'Simple inheritance works by pushing into @ISA,');
 179 ok(Foo::Bar->nèw, 'Even with UTF-8 methods');
 180
 181 ok(Foo::Bàz->new, 'Simple inheritance works with parent using -norequire,');
 182 ok(Foo::Bàz->nèw, 'Even with UTF-8 methods');
 183
 184 ok(ฟọ::バッズ->new, 'parent using -norequire, in a UTF-8 package.');
 185 ok(ฟọ::バッズ->nèw, 'Also works with UTF-8 methods');
 186 ok(ฟọ::バッズ->ニュー, 'Even methods from an UTF-8 parent');
 187
 188 BEGIN {no strict 'refs';
 189        ++${"\xff::foo"} if $::IS_ASCII;
 190        ++${"\xdf::foo"} if $::IS_EBCDIC;
 191        } # autovivify the package
 192 package ÿ {                                 # without UTF8
 193  sub AUTOLOAD {
 194   if ($::IS_ASCII) {
 195     ::is our $AUTOLOAD,
 196       "\xff::\x{100}", '$AUTOLOAD made from Latin1 package + UTF8 sub';
 197   }
 198   else {
 199     ::is our $AUTOLOAD,
 200       "\xdf::\x{100}", '$AUTOLOAD made from Latin1 package + UTF8 sub';
 201     }
 202   }
 203 }
 204 ÿ->${\"\x{100}"};
 205
 206 #This test should go somewhere else.
 207 #DATA was being generated in the wrong package.
 208 package ʑ;
 209 no 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__
 216 Some data