ext/XS-APItest/t/gv_fetchmethod_flags.t

   1 #!perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More tests => 24;
   7
   8 use_ok('XS::APItest');
   9
  10 sub method { 1 }
  11
  12 ok !XS::APItest::gv_fetchmethod_flags_type(\%::, "nothing", 1, 0);
  13
  14 for my $type ( 1..3 ) {
  15     is XS::APItest::gv_fetchmethod_flags_type(\%::, "method", $type, 0), "*main::method", "Sanity check";
  16 }
  17
  18 ok !XS::APItest::gv_fetchmethod_flags_type(\%::, "method\0not quite!", 1, 0), "gv_fetchmethod_flags_sv() is nul-clean";
  19 ok !XS::APItest::gv_fetchmethod_flags_type(\%::, "method\0not quite!", 3, 0), "gv_fetchmethod_flags_pvn() is nul-clean";
  20
  21 ok XS::APItest::gv_fetchmethod_flags_type(\%::, "method\0not quite!", 0, 0), "gv_fetchmethod_flags() is not nul-clean";
  22 is XS::APItest::gv_fetchmethod_flags_type(\%::, "method\0not quite!", 2, 0), "*main::method", "gv_fetchmethod_flags_pv() is not nul-clean";
  23
  24 {
  25     use utf8;
  26     use open qw( :utf8 :std );
  27
  28     package ｍａｉｎ;
  29
  30     sub ｍｅｔｈｏｄ { 1 }
  31     sub method { 1 }
  32
  33     my $meth_as_octets =
  34             "\357\275\215\357\275\205\357\275\224\357\275\210\357\275\217\357\275\204";
  35
  36     for my $type ( 1..3 ) {
  37         ::is XS::APItest::gv_fetchmethod_flags_type(\%ｍａｉｎ::, "ｍｅｔｈｏｄ", $type, 0), "*ｍａｉｎ::ｍｅｔｈｏｄ";
  38         ::ok !XS::APItest::gv_fetchmethod_flags_type(\%ｍａｉｎ::, $meth_as_octets, $type, 0);
  39         ::is XS::APItest::gv_fetchmethod_flags_type(\%ｍａｉｎ::, "method", $type, 0), "*ｍａｉｎ::method";
  40
  41         {
  42             no strict 'refs';
  43             ::ok !XS::APItest::gv_fetchmethod_flags_type(
  44                             \%{"\357\275\215\357\275\201\357\275\211\357\275\216::"},
  45                             "ｍｅｔｈｏｄ", $type, 0);
  46             ::ok !XS::APItest::gv_fetchmethod_flags_type(
  47                             \%{"\357\275\215\357\275\201\357\275\211\357\275\216::"},
  48                             "method", $type, 0);
  49         }
  50     }
  51 }
  52
  53 # [perl #129267] Buffer overrun when argument name ends with colon and
  54 #                there is a colon past the end.  This used to segv.
  55 XS::APItest::gv_fetchmethod_flags_type(\%::, "method:::::", 4, 7);
  56                                              # With type 4, 7 is the length