view release on metacpan or  search on metacpan

Dumper.pm  view on Meta::CPAN

    "\a" => "\\a",
    "\b" => "\\b",
    "\t" => "\\t",
    "\n" => "\\n",
    "\f" => "\\f",
    "\r" => "\\r",
    "\e" => "\\e",
);

my $low_controls = ($IS_ASCII)

                   # This includes \177, because traditionally it has been
                   # output as octal, even though it isn't really a "low"
                   # control
                   ? qr/[\0-\x1f\177]/

                     # EBCDIC low controls.
                   : qr/[\0-\x3f]/;

# put a string value in double quotes
sub qquote {
  local($_) = shift;
  s/([\\\"\@\$])/\\$1/g;

  # This efficiently changes the high ordinal characters to \x{} if the utf8
  # flag is on.  On ASCII platforms, the high ordinals are all the
  # non-ASCII's.  On EBCDIC platforms, we don't include in these the non-ASCII
  # controls whose ordinals are less than SPACE, excluded below by the range
  # \0-\x3f.  On ASCII platforms this range just compiles as part of :ascii:.
  # On EBCDIC platforms, there is just one outlier high ordinal control, and
  # it gets output as \x{}.
  my $bytes; { use bytes; $bytes = length }
  s/([^[:ascii:]\0-\x3f])/sprintf("\\x{%x}",ord($1))/ge
    if $bytes > length

       # The above doesn't get the EBCDIC outlier high ordinal control when
       # the string is UTF-8 but there are no UTF-8 variant characters in it.
       # We want that to come out as \x{} anyway.  We need is_utf8() to do
       # this.
       || (! $IS_ASCII && utf8::is_utf8($_));

  return qq("$_") unless /[[:^print:]]/;  # fast exit if only printables

  # Here, there is at least one non-printable to output.  First, translate the
  # escapes.
  s/([\a\b\t\n\f\r\e])/$esc{$1}/g;

  # no need for 3 digits in escape for octals not followed by a digit.
  s/($low_controls)(?!\d)/'\\'.sprintf('%o',ord($1))/eg;

  # But otherwise use 3 digits
  s/($low_controls)/'\\'.sprintf('%03o',ord($1))/eg;

    # all but last branch below not supported --BEHAVIOR SUBJECT TO CHANGE--
  my $high = shift || "";
    if ($high eq "iso8859") {   # Doesn't escape the Latin1 printables
      if ($IS_ASCII) {
        s/([\200-\240])/'\\'.sprintf('%o',ord($1))/eg;
      }
      else {
        my $high_control = utf8::unicode_to_native(0x9F);
        s/$high_control/sprintf('\\%o',ord($1))/eg;
      }
    } elsif ($high eq "utf8") {
#     Some discussion of what to do here is in
#       https://rt.perl.org/Ticket/Display.html?id=113088
#     use utf8;
#     $str =~ s/([^\040-\176])/sprintf "\\x{%04x}", ord($1)/ge;
    } elsif ($high eq "8bit") {
        # leave it as it is
    } else {
      s/([[:^ascii:]])/'\\'.sprintf('%03o',ord($1))/eg;
      #s/([^\040-\176])/sprintf "\\x{%04x}", ord($1)/ge;
    }

  return qq("$_");
}

sub _refine_name {
    my $s = shift;
    my ($name, $val, $i) = @_;
    if (defined $name) {
      if ($name =~ /^[*](.*)$/) {
        if (defined $val) {
            $name = (ref $val eq 'ARRAY') ? ( "\@" . $1 ) :
              (ref $val eq 'HASH')  ? ( "\%" . $1 ) :
              (ref $val eq 'CODE')  ? ( "\*" . $1 ) :
              ( "\$" . $1 ) ;
        }
        else {
          $name = "\$" . $1;
        }
      }
      elsif ($name !~ /^\$/) {
        $name = "\$" . $name;
      }
    }
    else { # no names provided
      $name = "\$" . $s->{varname} . $i;
    }
    return $name;
}

sub _compose_out {
    my $s = shift;
    my ($valstr, $postref) = @_;
    my $out = "";
    $out .= $s->{pad} . $valstr . $s->{sep};
    if (@{$postref}) {
        $out .= $s->{pad} .
            join(';' . $s->{sep} . $s->{pad}, @{$postref}) .
            ';' .
            $s->{sep};
    }
    return $out;
}

1;
__END__

=head1 NAME