cpan/Test-Simple/t/Behavior/MonkeyPatching_note.t

   1 use strict;
   2 use warnings;
   3 use B;
   4
   5 use Test::Stream;
   6 use Test::MostlyLike;
   7 use Test::More tests => 3;
   8 use Test::Builder; # Not loaded by default in modern mode
   9 my $orig = Test::Builder->can('note');
  10
  11 {
  12     package MyModernTester;
  13     use Test::More;
  14     use Test::Stream;
  15     use Test::MostlyLike;
  16
  17     no warnings 'redefine';
  18     local *Test::Builder::note = sub {
  19         my $self = shift;
  20         return $self->$orig(__PACKAGE__ . ": ", @_);
  21     };
  22     use warnings;
  23
  24     my $file = __FILE__;
  25     # Line number is tricky, just use what B says The sub may not actually think it
  26     # is on the line it is may be off by 1.
  27     my $line = B::svref_2object(\&Test::Builder::note)->START->line;
  28
  29     my @warnings;
  30     {
  31         local $SIG{__WARN__} = sub { push @warnings => @_ };
  32         note('first');
  33         note('seconds');
  34     }
  35     mostly_like(
  36         \@warnings,
  37         [
  38             qr{The new sub is 'MyModernTester::__ANON__' defined in $file around line $line},
  39             undef, #Only 1 warning
  40         ],
  41         "Found expected warning, just the one"
  42     );
  43 }
  44
  45 {
  46     package MyModernTester2;
  47     use Test::More;
  48     use Test::Stream;
  49     use Test::MostlyLike;
  50
  51     no warnings 'redefine';
  52     local *Test::Builder::note = sub {
  53         my $self = shift;
  54         return $self->$orig(__PACKAGE__ . ": ", @_);
  55     };
  56     use warnings;
  57
  58     my $file = __FILE__;
  59     # Line number is tricky, just use what B says The sub may not actually think it
  60     # is on the line it is may be off by 1.
  61     my $line = B::svref_2object(\&Test::Builder::note)->START->line;
  62
  63     my @warnings;
  64     {
  65         local $SIG{__WARN__} = sub { push @warnings => @_ };
  66         note('first');
  67         note('seconds');
  68     }
  69     mostly_like(
  70         \@warnings,
  71         [
  72             qr{The new sub is 'MyModernTester2::__ANON__' defined in $file around line $line},
  73             undef, #Only 1 warning
  74         ],
  75         "new override, new warning"
  76     );
  77 }
  78
  79 {
  80     package MyLegacyTester;
  81     use Test::More;
  82
  83     no warnings 'redefine';
  84     local *Test::Builder::note = sub {
  85         my $self = shift;
  86         return $self->$orig(__PACKAGE__ . ": ", @_);
  87     };
  88     use warnings;
  89
  90     my @warnings;
  91     {
  92         local $SIG{__WARN__} = sub { push @warnings => @_ };
  93         note('first');
  94         note('seconds');
  95     }
  96     is(@warnings, 0, "no warnings for a legacy tester");
  97 }