ext/XS-APItest/t/gv_fetchmeth_autoload.t

   1 #!perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More tests => 53;
   7
   8 use_ok('XS::APItest');
   9
  10 my $level = -1;
  11 my @types = map { 'gv_fetchmeth' . $_ . "_autoload" } '', qw( _sv _pv _pvn );
  12
  13 sub test { "Sanity check" }
  14
  15 for my $type ( 0..3 ) {
  16     is *{XS::APItest::gv_fetchmeth_autoload_type(
  17            \%::, "test", $type, $level, 0
  18         )}{CODE}->(), "Sanity check";
  19 }
  20
  21 {
  22     ok !XS::APItest::gv_fetchmeth_autoload_type(\%::, "etc", 1, $level, 0), "fails when the glob doesn't exist and AUTOLOAD is undefined,";
  23     local *AUTOLOAD = sub { 1 };
  24     is XS::APItest::gv_fetchmeth_autoload_type(\%::, "etc", 1, $level, 0), "*main::etc", "..but defining AUTOLOAD makes it succeed.";
  25 }
  26
  27 for my $type ( 0..3 ) {
  28     my $meth = "gen$type";
  29     ok !XS::APItest::gv_fetchmeth_autoload_type(\%::, $meth, $type, -1, 0), "With level = -1, $types[$type] returns false.";
  30     ok !$::{$meth}, "...and doesn't vivify the glob.";
  31
  32     ok !XS::APItest::gv_fetchmeth_autoload_type(\%::, $meth, $type, 0, 0), "With level = 0, $types[$type] still returns false.";
  33     ok $::{$meth}, "...but does vivify the glob.";
  34
  35     ok !XS::APItest::gv_fetchmeth_autoload_type(\%::, $meth . $type, $type, $level, 0), "$types[$type] fails when the glob doesn't exist and AUTOLOAD is undefined,";
  36     local *AUTOLOAD = sub { 1 };
  37     is XS::APItest::gv_fetchmeth_autoload_type(\%::, $meth . $type, $type, $level, 0), "*main::$meth$type", "..but defining AUTOLOAD makes it succeed.";
  38 }
  39
  40 {
  41     no warnings 'once';
  42     *method = sub { 1 };
  43 }
  44
  45 ok !XS::APItest::gv_fetchmeth_autoload_type(\%::, "method\0not quite!", 0, $level, 0), "gv_fetchmeth() is nul-clean";
  46 ok !XS::APItest::gv_fetchmeth_autoload_type(\%::, "method\0not quite!", 1, $level, 0), "gv_fetchmeth_autoload_sv() is nul-clean";
  47 is XS::APItest::gv_fetchmeth_autoload_type(\%::, "method\0not quite!", 2, $level, 0), "*main::method", "gv_fetchmeth_autoload_pv() is not nul-clean";
  48 ok !XS::APItest::gv_fetchmeth_autoload_type(\%::, "method\0not quite!", 3, $level, 0), "gv_fetchmeth_autoload_pvn() is nul-clean";
  49
  50 {
  51     use utf8;
  52     use open qw( :utf8 :std );
  53
  54     package ｍａｉｎ;
  55
  56     sub ｍｅｔｈｏｄ { 1 }
  57
  58     my $meth_as_octets =
  59             "\357\275\215\357\275\205\357\275\224\357\275\210\357\275\217\357\275\204";
  60
  61     $level = -1;
  62     for my $type ( 1..3 ) {
  63         ::is XS::APItest::gv_fetchmeth_autoload_type(\%ｍａｉｎ::, "ｍｅｔｈｏｄ", $type, $level, 0), "*ｍａｉｎ::ｍｅｔｈｏｄ", "$types[$type] is UTF-8 clean";
  64         ::ok !XS::APItest::gv_fetchmeth_autoload_type(\%ｍａｉｎ::, $meth_as_octets, $type, $level, 0);
  65         ::ok !XS::APItest::gv_fetchmeth_autoload_type(\%ｍａｉｎ::, "method", $type, $level, 0);
  66
  67         {
  68             no warnings 'once';
  69             local *AUTOLOAD = sub { 1 };
  70             ::is XS::APItest::gv_fetchmeth_autoload_type(\%ｍａｉｎ::, "ｍｅｔｈｏｄ$type", $type, $level, 0), "*ｍａｉｎ::ｍｅｔｈｏｄ$type", "Autoloading UTF-8 subs works";
  71         }
  72
  73         {
  74             no strict 'refs';
  75             ::ok !XS::APItest::gv_fetchmeth_autoload_type(
  76                             \%{"\357\275\215\357\275\201\357\275\211\357\275\216::"},
  77                             "ｍｅｔｈｏｄ", $type, $level, 0);
  78             ::ok !XS::APItest::gv_fetchmeth_autoload_type(
  79                             \%{"\357\275\215\357\275\201\357\275\211\357\275\216::"},
  80                             "method", $type, $level, 0);
  81         }
  82     }
  83 }