view release on metacpan or  search on metacpan

t/dumper.t  view on Meta::CPAN

}

#############
{
  # [perl #107372] blessed overloaded globs
  my $want = <<'EOW';
#$VAR1 = bless( \*::finkle, 'overtest' );
EOW
  {
    package overtest;
    use overload fallback=>1, q\""\=>sub{"oaoaa"};
  }
  TEST_BOTH(q(Data::Dumper->Dumpxs([bless \*finkle, "overtest"])),
            'blessed overloaded globs',
            $want);
}
#############
{
  # [perl #74798] uncovered behaviour
  my $want = <<'EOW';
#$VAR1 = "\0000";
EOW
  local $Data::Dumper::Useqq = 1;
  TEST_BOTH(q(Data::Dumper->Dumpxs(["\x000"])),
            "\\ octal followed by digit",
            $want);

  $want = <<'EOW';
#$VAR1 = "\x{100}\0000";
EOW
  local $Data::Dumper::Useqq = 1;
  TEST_BOTH(q(Data::Dumper->Dumpxs(["\x{100}\x000"])),
            "\\ octal followed by digit unicode",
            $want);

  $want = <<'EOW';
#$VAR1 = "\0\x{660}";
EOW
  TEST_BOTH(q(Data::Dumper->Dumpxs(["\\x00\\x{0660}"])),
            "\\ octal followed by unicode digit",
            $want);

  # [perl #118933 - handling of digits
  $want = <<'EOW';
#$VAR1 = 0;
#$VAR2 = 1;
#$VAR3 = 90;
#$VAR4 = -10;
#$VAR5 = "010";
#$VAR6 = 112345678;
#$VAR7 = "1234567890";
EOW
  TEST_BOTH(q(Data::Dumper->Dumpxs([0, 1, 90, -10, "010", "112345678", "1234567890" ])),
            "numbers and number-like scalars",
            $want);
}
#############
{
  # [github #18614 - handling of Unicode characters in regexes]
  # [github #18764 - ... without breaking subsequent Latin-1]
  if ($] lt '5.010') {
      SKIP_BOTH("Incomplete support for UTF-8 in old perls");
      last;
  }
  my $want = <<"EOW";
#\$VAR1 = [
#  "\\x{41f}",
#  qr/\x{8b80}/,
#  qr/\x{41f}/,
#  qr/\x{e4}/,
#  '\xE4'
#];
EOW
  if ($] lt '5.010001') {
      $want =~ s!qr/!qr/(?-xism:!g;
      $want =~ s!/,!)/,!g;
  }
  elsif ($] gt '5.014') {
      $want =~ s{/(,?)$}{/u$1}mg;
  }
  my $want_xs = $want;
  $want_xs =~ s/'\xE4'/"\\x{e4}"/;
  $want_xs =~ s<([^\0-\177])> <sprintf '\\x{%x}', ord $1>ge;
  TEST_BOTH(qq(Data::Dumper->Dumpxs([ [qq/\x{41f}/, qr/\x{8b80}/, qr/\x{41f}/, qr/\x{e4}/, "\xE4"] ])),
            "string with Unicode + regexp with Unicode",
            $want, $want_xs);
}
#############
{
  # [more perl #58608 tests]
  my $bs = "\\\\";
  my $want = <<"EOW";
#\$VAR1 = [
#  qr/ \\/ /,
#  qr/ \\?\\/ /,
#  qr/ $bs\\/ /,
#  qr/ $bs:\\/ /,
#  qr/ \\?$bs:\\/ /,
#  qr/ $bs$bs\\/ /,
#  qr/ $bs$bs:\\/ /,
#  qr/ $bs$bs$bs\\/ /
#];
EOW
  if ($] lt '5.010001') {
      $want =~ s!qr/!qr/(?-xism:!g;
      $want =~ s! /! )/!g;
  }
  TEST_BOTH(qq(Data::Dumper->Dumpxs([ [qr! / !, qr! \\?/ !, qr! $bs/ !, qr! $bs:/ !, qr! \\?$bs:/ !, qr! $bs$bs/ !, qr! $bs$bs:/ !, qr! $bs$bs$bs/ !, ] ])),
            "more perl #58608",
            $want);
}
#############
{
  # [github #18614, github #18764, perl #58608 corner cases]
  if ($] lt '5.010') {
      SKIP_BOTH("Incomplete support for UTF-8 in old perls");
      last;
  }
  my $bs = "\\\\";
  my $want = <<"EOW";
#\$VAR1 = [
#  "\\x{2e18}",
#  qr/ \x{203d}\\/ /,
#  qr/ \\\x{203d}\\/ /,
#  qr/ \\\x{203d}$bs:\\/ /,
#  '\xA3'
#];
EOW
  if ($] lt '5.010001') {
      $want =~ s!qr/!qr/(?-xism:!g;
      $want =~ s!/,!)/,!g;
  }
  elsif ($] gt '5.014') {
      $want =~ s{/(,?)$}{/u$1}mg;
  }
  my $want_xs = $want;
  $want_xs =~ s/'\x{A3}'/"\\x{a3}"/;
  $want_xs =~ s/\x{203D}/\\x{203d}/g;
  TEST_BOTH(qq(Data::Dumper->Dumpxs([ [ '\x{2e18}', qr! \x{203d}/ !, qr! \\\x{203d}/ !, qr! \\\x{203d}$bs:/ !, "\xa3"] ])),
            "github #18614, github #18764, perl #58608 corner cases",
            $want, $want_xs);
}
#############
{
  # [CPAN #84569]
  my $dollar = '${\q($)}';
  my $want = <<"EOW";
#\$VAR1 = [
#  "\\x{2e18}",
#  qr/^\$/,
#  qr/^\$/,
#  qr/${dollar}foo/,
#  qr/\\\$foo/,
#  qr/$dollar \x{A3} /u,
#  qr/$dollar \x{203d} /u,
#  qr/\\\$ \x{203d} /u,
#  qr/\\\\$dollar \x{203d} /u,
#  qr/ \$| \x{203d} /u,
#  qr/ (\$) \x{203d} /u,
#  '\xA3'
#];
EOW
  if ($] lt '5.014') {
      $want =~ s{/u,$}{/,}mg;
  }
  if ($] lt '5.010001') {
      $want =~ s!qr/!qr/(?-xism:!g;
      $want =~ s!/,!)/,!g;
  }
  my $want_xs = $want;
  $want_xs =~ s/'\x{A3}'/"\\x{a3}"/;
  $want_xs =~ s/\x{A3}/\\x{a3}/;
  $want_xs =~ s/\x{203D}/\\x{203d}/g;
  my $have = <<"EOT";
Data::Dumper->Dumpxs([ [
  "\\x{2e18}",
  qr/^\$/,
  qr'^\$',
  qr'\$foo',
  qr/\\\$foo/,
  qr'\$ \x{A3} ',
  qr'\$ \x{203d} ',
  qr/\\\$ \x{203d} /,
  qr'\\\\\$ \x{203d} ',
  qr/ \$| \x{203d} /,
  qr/ (\$) \x{203d} /,
  '\xA3'
] ]);
EOT
  TEST_BOTH($have, "CPAN #84569", $want, $want_xs);
}
#############
{
  # [perl #82948]
  # re::regexp_pattern was moved to universal.c in v5.10.0-252-g192c1e2
  # and apparently backported to maint-5.10
  my $want = $] > 5.010 ? <<'NEW' : <<'OLD';
#$VAR1 = qr/abc/;
#$VAR2 = qr/abc/i;
NEW
#$VAR1 = qr/(?-xism:abc)/;
#$VAR2 = qr/(?i-xsm:abc)/;
OLD
  TEST_BOTH(q(Data::Dumper->Dumpxs([ qr/abc/, qr/abc/i ])), "qr// xs", $want);
}
#############

{
  sub foo {}
  my $want = <<'EOW';
#*a = sub { "DUMMY" };
#$b = \&a;
EOW

  TEST_BOTH(q(Data::Dumper->new([ \&foo, \\&foo ], [ "*a", "b" ])->Dumpxs),
            "name of code in *foo",
            $want);
}
#############

{
    # There is special code to handle the single control that in EBCDIC is
    # not in the block with all the other controls, when it is UTF-8 and
    # there are no variants in it (All controls in EBCDIC are invariant.)
    # This tests that.  There is no harm in testing this works on ASCII,
    # and is better to not have split code paths.