t/op/warn.t

   1 #!./perl
   2 #line 3 warn.t
   3
   4 BEGIN {
   5     chdir 't' if -d 't';
   6     require './test.pl'; require './charset_tools.pl';
   7     set_up_inc('../lib');
   8 }
   9
  10 plan 32;
  11
  12 my @warnings;
  13 my $wa = []; my $ea = [];
  14 $SIG{__WARN__} = sub { push @warnings, $_[0] };
  15
  16 @warnings = ();
  17 $@ = "";
  18 warn "foo\n";
  19 ok @warnings==1 && $warnings[0] eq "foo\n";
  20
  21 @warnings = ();
  22 $@ = "";
  23 warn "foo", "bar\n";
  24 ok @warnings==1 && $warnings[0] eq "foobar\n";
  25
  26 @warnings = ();
  27 $@ = "";
  28 warn "foo";
  29 ok @warnings==1 && $warnings[0] eq "foo at warn.t line 28.\n";
  30
  31 @warnings = ();
  32 $@ = "";
  33 warn $wa;
  34 ok @warnings==1 && ref($warnings[0]) eq "ARRAY" && $warnings[0] == $wa;
  35
  36 @warnings = ();
  37 $@ = "";
  38 warn "";
  39 ok @warnings==1 &&
  40     $warnings[0] eq "Warning: something's wrong at warn.t line 38.\n";
  41
  42 @warnings = ();
  43 $@ = "";
  44 warn;
  45 ok @warnings==1 &&
  46     $warnings[0] eq "Warning: something's wrong at warn.t line 44.\n";
  47
  48 @warnings = ();
  49 $@ = "ERR\n";
  50 warn "foo\n";
  51 ok @warnings==1 && $warnings[0] eq "foo\n";
  52
  53 @warnings = ();
  54 $@ = "ERR\n";
  55 warn "foo", "bar\n";
  56 ok @warnings==1 && $warnings[0] eq "foobar\n";
  57
  58 @warnings = ();
  59 $@ = "ERR\n";
  60 warn "foo";
  61 ok @warnings==1 && $warnings[0] eq "foo at warn.t line 60.\n";
  62
  63 @warnings = ();
  64 $@ = "ERR\n";
  65 warn $wa;
  66 ok @warnings==1 && ref($warnings[0]) eq "ARRAY" && $warnings[0] == $wa;
  67
  68 @warnings = ();
  69 $@ = "ERR\n";
  70 warn "";
  71 ok @warnings==1 &&
  72     $warnings[0] eq "ERR\n\t...caught at warn.t line 70.\n";
  73
  74 @warnings = ();
  75 $@ = "ERR\n";
  76 warn;
  77 ok @warnings==1 &&
  78     $warnings[0] eq "ERR\n\t...caught at warn.t line 76.\n";
  79
  80 @warnings = ();
  81 $@ = $ea;
  82 warn "foo\n";
  83 ok @warnings==1 && $warnings[0] eq "foo\n";
  84
  85 @warnings = ();
  86 $@ = $ea;
  87 warn "foo", "bar\n";
  88 ok @warnings==1 && $warnings[0] eq "foobar\n";
  89
  90 @warnings = ();
  91 $@ = $ea;
  92 warn "foo";
  93 ok @warnings==1 && $warnings[0] eq "foo at warn.t line 92.\n";
  94
  95 @warnings = ();
  96 $@ = $ea;
  97 warn $wa;
  98 ok @warnings==1 && ref($warnings[0]) eq "ARRAY" && $warnings[0] == $wa;
  99
 100 @warnings = ();
 101 $@ = $ea;
 102 warn "";
 103 ok @warnings==1 && ref($warnings[0]) eq "ARRAY" && $warnings[0] == $ea;
 104
 105 @warnings = ();
 106 $@ = $ea;
 107 warn;
 108 ok @warnings==1 && ref($warnings[0]) eq "ARRAY" && $warnings[0] == $ea;
 109
 110 fresh_perl_like(
 111  '
 112    $a = "\xee\n";
 113    print STDERR $a; warn $a;
 114    utf8::upgrade($a);
 115    print STDERR $a; warn $a;
 116  ',
 117   qr/^\xee(?:\r?\n\xee){3}/,
 118   { switches => [ "-C0" ] },
 119  'warn emits logical characters, not internal bytes [perl #45549]'
 120 );
 121
 122 SKIP: {
 123     skip_if_miniperl('miniperl ignores -C', 1);
 124    $ee = uni_to_native("\xee");
 125    $bytes = byte_utf8a_to_utf8n("\xc3\xae");
 126 fresh_perl_like(
 127  "
 128    \$a = \"$ee\n\";
 129    print STDERR \$a; warn \$a;
 130    utf8::upgrade(\$a);
 131    print STDERR \$a; warn \$a;
 132  ",
 133   qr/^$bytes(?:\r?\n$bytes){3}/,
 134   { switches => ['-CE'] },
 135  'warn respects :utf8 layer'
 136 );
 137 }
 138
 139 $bytes = byte_utf8a_to_utf8n("\xc4\xac");
 140 fresh_perl_like(
 141  'warn chr 300',
 142   qr/^Wide character in warn .*\n$bytes at /,
 143   { switches => [ "-C0" ] },
 144  'Wide character in warn (not print)'
 145 );
 146
 147 fresh_perl_like(
 148  'warn []',
 149   qr/^ARRAY\(0x[\da-f]+\) at /a,
 150   { },
 151  'warn stringifies in the absence of $SIG{__WARN__}'
 152 );
 153
 154 use Tie::Scalar;
 155 tie $@, "Tie::StdScalar";
 156
 157 $@ = "foo\n";
 158 @warnings = ();
 159 warn;
 160 is @warnings, 1;
 161 like $warnings[0], qr/^foo\n\t\.\.\.caught at warn\.t /,
 162     '...caught is appended to tied $@';
 163
 164 $@ = \$_;
 165 @warnings = ();
 166 {
 167   local *{ref(tied $@) . "::STORE"} = sub {};
 168   undef $@;
 169 }
 170 warn;
 171 is @warnings, 1;
 172 is $warnings[0], \$_, '!SvOK tied $@ that returns ref is used';
 173
 174 untie $@;
 175
 176 @warnings = ();
 177 {
 178   package o;
 179   use overload '""' => sub { "" };
 180 }
 181 tie $t, Tie::StdScalar;
 182 $t = bless [], o;
 183 {
 184   local *{ref(tied $t) . "::STORE"} = sub {};
 185   undef $t;
 186 }
 187 warn $t;
 188 is @warnings, 1;
 189 object_ok $warnings[0], 'o',
 190   'warn $tie_returning_object_that_stringifes_emptily';
 191
 192 @warnings = ();
 193 eval "#line 42 Cholmondeley\n \$\@ = '3'; warn";
 194 eval "#line 42 Cholmondeley\n \$\@ = 3; warn";
 195 is @warnings, 2;
 196 is $warnings[1], $warnings[0], 'warn treats $@=3 and $@="3" the same way';
 197
 198 fresh_perl_is(<<'EOF', "should be line 4 at - line 4.\n", {stderr => 1}, "");
 199 ${
 200     foo
 201 } = "should be line 4";
 202 warn $foo;
 203 EOF
 204
 205 TODO: {
 206     local $::TODO = "Line numbers don't yet match up for \${ EXPR }";
 207     my $expected = <<'EOF';
 208 line 1 at - line 1.
 209 line 4 at - line 3.
 210 also line 4 at - line 4.
 211 line 5 at - line 5.
 212 EOF
 213     fresh_perl_is(<<'EOF', $expected, {stderr => 1}, "");
 214 warn "line 1";
 215 (${
 216     foo
 217 } = "line 5") && warn("line 4"); warn("also line 4");
 218 warn $foo;
 219 EOF
 220 }
 221
 222 1;