view release on metacpan or  search on metacpan

lib/Data/Dumper/Interp.pm  view on Meta::CPAN

        ? sprintf("\\%03o", ($ctlesc2codepoint{$+{w}} // oops))
        : sprintf("\\%01o", ($ctlesc2codepoint{$+{w}} // oops))
     }xesg;
  }
}

sub __change_quotechars($$$) {  # edits $_
  if (s/^"//) {
    oops unless s/"$//;
    my ($pfx, $l, $r) = @_;
    s/\\"/"/g;
    s/([\Q$l\E])/\\$1/g if length($l)==1; # assume traditional qqLR
    s/([\Q$r\E])/\\$1/g if length($r)==1; # with single-character brackets
    $_ = $pfx.$l.$_.$r;
  }
}

my %qqesc2controlpic = (
  '\0' => "\N{SYMBOL FOR NULL}",   # occurs if next char is not a digit
  '\000' => "\N{SYMBOL FOR NULL}", # occurs if next char is a digit
  '\a' => "\N{SYMBOL FOR BELL}",
  '\b' => "\N{SYMBOL FOR BACKSPACE}",
  '\e' => "\N{SYMBOL FOR ESCAPE}",
  '\f' => "\N{SYMBOL FOR FORM FEED}",
  '\n' => "\N{SYMBOL FOR NEWLINE}",
  '\r' => "\N{SYMBOL FOR CARRIAGE RETURN}",
  '\t' => "\N{SYMBOL FOR HORIZONTAL TABULATION}",
);
my %char2controlpic = (
  map{
    my $cp = $qqesc2controlpic{$_};
    my $char = eval(qq("$_")) // die;
    die "XX<<$_>> YY<<$char>>" unless length($char) == 1;
    ($char => $cp)
  } keys %qqesc2controlpic
);
sub __subst_controlpic_backesc() {  # edits $_
  # Replace '\t' '\n' etc. escapes with "control picture" characters
  return unless/^"/;
  s{ \G (?: [^\\]++ | \\[^0abefnrt] )*+ \K
        ( \\[abefnrt] | \\0(?![0-7]) | \\[0-3][0-7][0-7] )
   }{
      $qqesc2controlpic{$1} // $1
    }xesg;
}
sub __subst_visiblespaces() {  # edits $_
  if (/^"/) {
    #s{\N{MIDDLE DOT}}{\N{BLACK LARGE CIRCLE}}g;
    #s{ }{\N{MIDDLE DOT}}g;
    s{ }{\N{OPEN BOX}}g;  # ␣
  }
}

sub __condense_strings($) {  # edits $_
  if (/^"/) {
    my $minrep_m1 = $_[0] - 1;
    my $singlechar_restr = "[^\\\\${COND_LB}${COND_RB}${COND_MULT}]";

    # Special case a string of nul represented as \n\n\n...\00n (n=0..7)
    # D::D generates this to avoid ambiguity if a digit follows
    s<( (\\([0-7])){$minrep_m1,}\\00\g{-1} )>
     < $COND_LB."${2}${COND_MULT}".((length($1)-2)/length($2)).$COND_RB >xge;

    # \0 \1 ... if there is no digit following, which makes it ambiguous
    s<( (\\\d) \g{-1}{$minrep_m1,} ) (?![0-7]) >
     < $COND_LB."${2}${COND_MULT}".(length($1)/length($2)).$COND_RB >xge;

    # \x for almost any x besides a digit or \
    s<( ($singlechar_restr | \\\D | \\[0-3][0-7][0-7] | \\x\{[^\{\}]+\})
        \g{-1}{$minrep_m1,} )
     >
     < $COND_LB."${2}${COND_MULT}".(length($1)/length($2)).$COND_RB >xge;
  }
}

sub __nums_in_hex() {
  if (looks_like_number($_)) {
    s/^([1-9]\d+)$/ sprintf("%#x", $1) /e; # Leave single-digit numbers as-is
  }
}
sub __nums_with_underscores() {
  if (looks_like_number($_)) {
    while( s/^([^\._]*?\d)(\d\d\d)(?=$|\.|_)/$1_$2/ ) { }
  }
}

my $indent_unit;

sub _mycallloc(;@) {
  my ($lno, $subcalled) = (caller(1))[2,3];
  ":".$lno.(@_ ? _dbavis(@_) : "")." "
}

use constant {
  _WRAP_ALWAYS  => 1,
  _WRAP_ALLHASH => 2,
};
use constant _WRAP_STYLE => (_WRAP_ALLHASH);

sub _get_useqq_set_widechars {
  my ($self) = @_;
  my $useqq = $self->Useqq();
  if ($useqq) {

    carp "WARNING: The Useqq specification string ",_dbvis($useqq)," contains a non-ASCII character but 'use utf8;' was not in effect when the literal was compiled; the intended chracter was probably not used.\n"
      if $useqq =~ /[^\x{0}-\x{7F}]/ && !utf8::is_utf8($useqq);

    my $unesc_unicode = $useqq =~ /utf|unic/;
    if ($unesc_unicode && _utfoutput()) {
      # STDOUT is using a UTF encoding -- wide characters should be safe
      $COND_LB = "\N{LEFT DOUBLE PARENTHESIS}";   # left bracket for 'condense' form
      $COND_RB = "\N{RIGHT DOUBLE PARENTHESIS}";
      $COND_MULT = "\N{MULTIPLICATION SIGN}";
      $LQ = "«";
      $RQ = "»";
    } else {
      $COND_LB = "(";
      $COND_RB = ")";
      $COND_MULT = "x";
      $LQ = "<<";
      $RQ = ">>";
    }
  }
  return $useqq;
}

sub _postprocess_DD_result {
  (my $self, local $_, my $original) = @_;
  no warnings 'recursion';
  my ($debug, $listform, $foldwidth, $foldwidth1)