Data-Dumper-Interp
view release on metacpan or search on metacpan
lib/Data/Dumper/Interp.pm view on Meta::CPAN
# License: Public Domain or CC0 See
# https://creativecommons.org/publicdomain/zero/1.0/
# The author, Jim Avera (jim.avera at gmail) has waived all copyright and
# related or neighboring rights. Attribution is requested but is not required.
##FIXME: Refaddr(1) has no effect inside Blessed structures
#
use strict; use warnings FATAL => 'all'; use utf8;
#use 5.010; # say, state
#use 5.011; # cpantester gets warning that 5.11 is the minimum acceptable
#use 5.014; # /r for non-destructive substitution
use 5.018; # lexical_subs
use feature qw(say state lexical_subs current_sub);
use feature 'lexical_subs';
use feature 'unicode_strings';
package
# newline so Dist::Zilla::Plugin::PkgVersion won't add $VERSION
DB {
sub DB_Vis_Evalwrapper {
eval $Data::Dumper::Interp::string_to_eval; ## no critic
}
}
package Data::Dumper::Interp;
{ no strict 'refs'; ${__PACKAGE__."::VER"."SION"} = 997.999; }
our $VERSION = '8.000'; # VERSION from Dist::Zilla::Plugin::OurPkgVersion
our $DATE = '2026-04-22'; # DATE from Dist::Zilla::Plugin::OurDate
# Arrgh! Moose forcibly enables experimental feature warnings!
# So import Moose first and then adjust warnings...
use Moose;
extends 'Data::Visitor' => { -version => 0.32 },
'Exporter' => { -version => 5.57 },
;
no warnings "experimental::lexical_subs";
use constant _SUPPORTS_CORE_BOOLS => defined &builtin::is_bool;
my $bitwise_supported;
BEGIN {
$bitwise_supported = eval "use feature 'bitwise'";
warnings->unimport("experimental::builtin") if _SUPPORTS_CORE_BOOLS;
}
use if $bitwise_supported, "feature", "bitwise";
use re qw/is_regexp regexp_pattern/;
use Data::Dumper ();
use Carp;
use POSIX qw(INT_MAX);
use Scalar::Util qw(blessed reftype refaddr looks_like_number weaken);
use List::Util 1.45 qw(min max first none all any sum0);
use Data::Structure::Util qw/circular_off/;
use Regexp::Common qw/RE_balanced RE_quoted/;
#use Term::ReadKey ();
use Term::Size 0.211 ();
use Sub::Identify qw/sub_name sub_fullname get_code_location/;
use File::Basename qw/basename/;
use overload ();
############################ Exports #######################################
# Short-hand functions/methods are generated on demand (i.e. if imported or
# called as a method) based on a naming convention.
############################################################################
our @EXPORT = qw( visnew
vis avis hvis ivis dvis
viso aviso hviso iviso ivisO dviso dvisO
visq avisq hvisq ivisq dvisq
visr avisr hvisr ivisr dvisr
rvis rvisq
addrvis addrvisl
u quotekey qsh qshlist qshpath
lib/Data/Dumper/Interp.pm view on Meta::CPAN
->Sortkeys(1)->Useqq(1)
###->Sortkeys(\&__sortkeys)->Pair("=>")
#->Useperl(1)
}
sub _dbvis(_) {chomp(my $s=_dbvisnew(shift)->Useqq(1)->Dump); $s }
sub _dbvisq(_){chomp(my $s=_dbvisnew(shift)->Useqq(0)->Dump); $s }
sub _dbvis1(_){chomp(my $s=_dbvisnew(shift)->Maxdepth(1)->Useqq(1)->Dump); $s }
sub _dbvis2(_){chomp(my $s=_dbvisnew(shift)->Maxdepth(3)->Useqq(1)->Dump); $s }
sub _dbavis(@){ "(" . join(", ", map{_dbvis} @_) . ")" }
sub _dbavis2(@){ "(" . join(", ", map{_dbvis2} @_) . ")" }
sub _dbrvis(_) { (ref($_[0]) ? addrvis(refaddr $_[0]) : "")._dbvis($_[0]) }
sub _dbrvis2(_){ (ref($_[0]) ? addrvis(refaddr $_[0]) : "")._dbvis2($_[0]) }
sub _dbravis2(@){ "(" . join(", ", map{_dbrvis2} @_) . ")" }
sub _dbshow(_) {
my $v = shift;
blessed($v) ? "(".blessed($v).")".$v # stringify with (classname) prefix
: _dbvis($v) # something else
}
our $_dbmaxlen = 300;
sub _dbrawstr(_) { "${LQ}".(length($_[0])>$_dbmaxlen ? substr($_[0],0,$_dbmaxlen-3)."..." : $_[0])."${RQ}" }
sub _dbstr($) {
local $_ = shift;
return "undef" if !defined;
s/\x{0a}/\N{U+2424}/sg; # a special NL glyph
s/ /\N{U+00B7}/sg; # space -> Middle Dot
s/[\x{00}-\x{1F}]/ chr( ord($&)+0x2400 ) /aseg;
$_
}
sub _dbstrposn($$) {
local $_ = shift;
my $posn = shift;
local $_dbmaxlen = max($_dbmaxlen+8, $posn+8);
my $visible = _dbstr($_); # simplified 'controlpics'
"posn=$posn shown at '(<<HERE)':"
. substr($visible, 0, $posn+1)."(<<HERE)".substr($visible,$posn+1)
}
############################################################################
#################### Configuration Globals #################
# Used by sub import() so must be declared first
our ($Debug, $MaxStringwidth, $Truncsuffix, $Trunctailwidth, $Objects,
$Refaddr, $Foldwidth, $Foldwidth1,
$Useqq, $Quotekeys, $Sortkeys,
$Maxdepth, $Maxrecurse, $Deparse, $Deepcopy);
sub _reset_defaults() {
$Debug = 0 unless defined $Debug;
$MaxStringwidth = 0 unless defined $MaxStringwidth;
$Truncsuffix = "..." unless defined $Truncsuffix;
$Trunctailwidth = 0 unless defined $Trunctailwidth;
$Objects = 1 unless defined $Objects;
$Refaddr = 0 unless defined $Refaddr;
$Foldwidth = undef unless defined $Foldwidth; # undef auto-detects
$Foldwidth1 = undef unless defined $Foldwidth1; # override for 1st
# The following override Data::Dumper defaults
# Initial D::D values are captured once when we are first loaded.
#$Useqq = "<unicode:controlpic>" unless defined $Useqq;
$Useqq = "unicode" unless defined $Useqq;
$Quotekeys = 0 unless defined $Quotekeys;
$Sortkeys = \&__sortkeys unless defined $Sortkeys;
$Maxdepth = $Data::Dumper::Maxdepth unless defined $Maxdepth;
$Maxrecurse = $Data::Dumper::Maxrecurse unless defined $Maxrecurse;
$Deparse = 0 unless defined $Deparse;
$Deepcopy = 0 unless defined $Deepcopy;
}
_reset_defaults(); # at startup
# This user-callable function (or method) restores default defaults
# Mainly useful after calling visnew->set_defaults()
sub reset_defaults() {
undef $Debug;
undef $MaxStringwidth;
undef $Truncsuffix;
undef $Trunctailwidth;
undef $Objects;
undef $Refaddr;
undef $Foldwidth; # undef auto-detects
undef $Foldwidth1; # override for 1st
undef $Useqq;
undef $Quotekeys;
undef $Sortkeys;
undef $Maxdepth;
undef $Maxrecurse;
undef $Deparse;
undef $Deepcopy;
_reset_defaults();
}
#################### Methods #################
has dd => (
is => 'ro',
lazy => 1,
default => sub{
my $self = shift;
Data::Dumper->new([],[])
->Terse(1)
->Indent(0)
->Sparseseen(1)
->Useqq($Useqq)
->Quotekeys($Quotekeys)
->Sortkeys($Sortkeys)
->Maxdepth($Maxdepth)
->Maxrecurse($Maxrecurse)
->Deparse($Deparse)
->Deepcopy($Deepcopy)
},
# This generates pass-through methods which call the dd object
handles => [qw/Values Useqq Quotekeys Trailingcomma Pad Varname Quotekeys
Maxdepth Maxrecurse Useperl Sortkeys Deparse Deepcopy
/],
);
# Config values which have no counterpart in Data::Dumper
has Debug => (is=>'rw', default => sub{ $Debug });
has MaxStringwidth => (is=>'rw', default => sub{ $MaxStringwidth });
has Truncsuffix => (is=>'rw', default => sub{ $Truncsuffix });
lib/Data/Dumper/Interp.pm view on Meta::CPAN
s/alvis/avisl/; # backwards compat.
s/hlvis/hvisl/; # backwards compat.
# Discontinued because NOW visl means something else.
#s/^[^diha]*\K(?:lvis|visl)/avisl/; # 'visl' same as 'avisl' for bw compat.
s/([ahid]?vis|set_defaults)// or error "can not infer the basic function";
my $basename = $1; # avis, hvis, ivis, dvis, or vis
my $N = s/(\d+)// ? $1 : undef;
my %mod = map{$_ => 1} split //, $_;
delete $mod{"_"}; # ignore underscores in names
if (($Debug//0) > 1) {
warn "## (D=$Debug) methname=$methname base=$basename \$_=$_\n";
}
## if ($basename =~ /^[id]/) {
## error "'$1' is inapplicable to $basename" if /([ahl])/;
## }
## error "'$1' mis-placed: Only allowed as '${1}vis'" if /([ahi])/;
# All these subs can be called as either or methods or functions.
# If the first argument is an object it is used, otherwise a new object
# is created; then option-setting methods are called as implied by
# the specific sub name.
#
# Finally the _Do() method is invoked for primatives like 'vis'.
#
# For ivis/dvis, control jumps to _Interpolate() which uses the object
# repeatedly when calling primatives to interpolate values into the string.
my $listform = '';
my $signature = $basename =~ /^[ah]/ ? '@' : '_'; # avis(@) ivis(_) vis(_)
my $code = "sub $methname($signature)";
if ($basename eq "vis") {
my $listform = delete($mod{l}) ? 'l' : '';
$code .= " { &__getself_s->_Listform('${listform}')";
}
elsif ($basename eq "avis") {
my $listform = delete($mod{l}) ? 'l' : 'a';
$code .= " { &__getself_a->_Listform('${listform}')";
}
elsif ($basename eq "hvis") {
my $listform = delete($mod{l}) ? 'l' : 'h';
$code .= " { &__getself_h->_Listform('${listform}')";
}
elsif ($basename eq "set_defaults") {
$code .= " { &__getself" ;
}
elsif ($basename eq "ivis") {
$code .= " { \@_ = ( &__getself" ;
}
elsif ($basename eq "dvis") {
$code .= " { \@_ = ( &__getself->_EnabUseqqFeature(_utfoutput() ? ':showspaces:condense' : ':condense')" ;
#$code .= " { \@_ = ( &__getself->_EnabUseqqFeature(':showspaces')" ;
}
else { oops "basename=",u($basename) }
my $useqq = "";
$useqq .= ":unicode:controlpics" if delete $mod{c};
$useqq .= ":condense" if delete $mod{C};
$code .= '->Debug(2)' if delete $mod{D};
$useqq .= ":hex" if delete $mod{h};
$code .= '->Objects(0)' if delete $mod{o}; # show internals
$code .= '->Objects({overloads => "transparent"})' if delete $mod{O}; # hide overloaded objects, not even showing classname
$useqq .= ":octets" if delete $mod{B};
$code .= '->Refaddr(1)' if delete $mod{r};
$useqq .= ":underscores" if delete $mod{u};
$code .= "->Useqq(\$Useqq.'${useqq}')" if $useqq ne "";
$code .= "->_EnabUseqqFeature(_utfoutput() ? ':showspaces:condense' : ':condense')" if delete($mod{d}) or $basename eq "dvis";
$code .= "->Useqq(0)" if delete $mod{q};
$code .= "->Maxdepth($N)" if defined($N);
if ($basename =~ /^([id])vis/) {
$code .= ", shift, '$1' ); goto &_Interpolate }";
}
elsif ($basename eq 'set_defaults') {
$code .= "->_SetDefaults }";
} else {
$code .= "->_Do }";
}
for (keys %mod) { error "Unknown or inappropriate modifier '$_'" }
if ($proto_only) {
$code =~ s/ *\{.*/;/ or oops;
}
# To see the generated code
# use Data::Dumper::Interp qw/:debug :DEFAULT/; # or :all
if ($Debug) {
warn "# generated: $code\n";
}
eval "$code"; oops "code=$code\n\$@=$@" if $@;
}#_generate_sub
sub visnew() { __PACKAGE__->new() } # shorthand
# $Carp::RefArgFormatter may be set to this to format traceback args
# The optional options are for use when currying, e.g.
# $Carp::RefArgFormatter = sub($) { Data::Dumper::Interp::CarpArgFormatter($_[0], Maxdepth=9, ...) }
sub RefArgFormatter {
my ($item, %opts) = @_;
$opts{Maxdepth} //= 3;
$opts{MaxStringwidth} //= 1000;
# Use whatever global defaults the user may have set...
#$opts{Refaddr} //= 1;
#$opts{Objects} //= {objects => 1, overloads => "tagged"};
my $obj = Data::Dumper::Interp::visnew;
for my $optname (keys %opts) {
$obj->$optname($opts{$optname});
}
return $obj->vis($item)
}
lib/Data/Dumper/Interp.pm view on Meta::CPAN
# Split keys into "components" (e.g. 2_16.A has 3 components) and sort
# components containing only digits numerically.
sub __sortkeys {
my $hash = shift;
my $r = [
sort { my @a = split /(?<=\d)(?=\D)|(?<=\D)(?=\d)/,$a;
my @b = split /(?<=\d)(?=\D)|(?<=\D)(?=\d)/,$b;
for (my $i=0; $i <= $#a; ++$i) {
return 1 if $i > $#b; # a is longer
my $r = ($a[$i] =~ /^\d+$/ && $b[$i] =~ /^\d+$/)
? ($a[$i] <=> $b[$i]) : ($a[$i] cmp $b[$i]) ;
return $r if $r != 0;
}
return -1 if $#a < $#b; # a is shorter
return 0;
}
keys %$hash
];
$r
}
my $quoted_re = RE_quoted(-delim => q{'"});
my $balanced_re = RE_balanced(-parens=>'{}[]()');
# cf man perldata
my $userident_re = qr/ (?: (?=\p{Word})\p{XID_Start} | _ )
(?: (?=\p{Word})\p{XID_Continue} )* /x;
my $pkgname_re = qr/ ${userident_re} (?: :: ${userident_re} )* /x;
our $curlies_re = RE_balanced(-parens=>'{}');
our $parens_re = RE_balanced(-parens=>'()');
our $curliesorsquares_re = RE_balanced(-parens=>'{}[]');
my $anyvname_re =
qr/ ${pkgname_re} | [0-9]+ | \^[A-Z]
| [-+!\$\&\;i"'().,\@\/:<>?\[\]\~\^\\] /x;
my $anyvname_or_refexpr_re = qr/ ${anyvname_re} | ${curlies_re} /x;
my $addrvis_re = qr/\<\d+:(?:\Q${\_ADDRVIS_SHARED_MARK}\E)?[\da-fA-F]+\>/;
sub __unmagic_atom() { # edits $_
## # FIXME this probably could omit the ([^'"]*?) bc there is never anything
## # between the open quote and the _MAGIC_NOQUOTES_PFX
## s/(['"])([^'"]*?)
## (?:\Q${\_MAGIC_NOQUOTES_PFX}\E)
## (.*?)(\1)/$2$3/xgs;
s/(['"])
(?:\Q${\_MAGIC_NOQUOTES_PFX}\E) (.*?)
(\1)/do{ local $_ = $2;
s!\\(.)!$1!g; # undo double-quotish backslash escapes
$_ }/xegs;
s/\Q${\_MAGIC_KEEPQUOTES_PFX}\E//gs;
}
sub __unesc_unicode() { # edits $_
if (/^"/) {
# Data::Dumper with Useqq(1) outputs wide characters as hex escapes;
# turn them back into the original characters if "printable".
# That means "Graph" category EXCEPT:
# BOM (which is ZERO WIDTH NO-BREAK SPACE so is considered "Graphical")
# and any other "Format" category Unicode characters; we want see those
# in hex.
s{
\G (?: [^\\]++ | \\[^x] )*+ \K (?<w> \\x\x{7B} (?<hex>[a-fA-F0-9]+) \x{7D} )
}{
my $orig = $+{w};
local $_ = hex( length($+{hex}) > 6 ? '0' : $+{hex} );
$_ = $_ > 0x10FFFF ? "\0" : chr($_); # 10FFFF is Unicode limit
# Using 'lc' so regression tests do not depend on Data::Dumper's
# choice of case when escaping wide characters.
(m<\P{XPosixGraph}|[\0-\177]>
|| m<\p{General_Category=Format}>) ? lc($orig) : $_
}xesg;
}
}
my %ctlesc2codepoint = (
'\\a' => ord("\a"),
'\\b' => ord("\b"),
'\\t' => ord("\t"),
'\\n' => ord("\n"),
'\\f' => ord("\f"),
'\\r' => ord("\r"),
'\\e' => ord("\e"),
);
sub __unesc_nonoctal () { # edits $_
# Change backslash escapes like \n back to octal escapes.
# This is to better visualize binary octet streams
if (/^"/) {
s{
\G (?: [^\\]++ | \\[x0-7] )*+ \K (?<w> \\[abtnfre])(?<digitnext>\d?)
}{
$+{digitnext}
? 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}",
lib/Data/Dumper/Interp.pm view on Meta::CPAN
#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)
= @$self{qw/Debug _Listform Foldwidth Foldwidth1/};
my $useqq = $self->_get_useqq_set_widechars();
my ($unesc_unicode,$condense_strings,$octet_strings,$nums_in_hex,
$controlpics,$showspaces,$underscores,$q_pfx,$q_lq,$q_rq);
if ($useqq && $useqq ne "1") {
my @useqq = split /(?<!\\):/, $useqq;
foreach (@useqq) {
$unesc_unicode = 1,next if /utf|unic/;
$condense_strings = 1,next if /cond/;
$octet_strings = 1,next if /octet/;
$nums_in_hex = 1,next if /hex/;
$controlpics = 1,next if /pic/;
$showspaces = 1,next if /space/;
$underscores = 1,next if /under/;
$_ = "qq={}" if $_ eq "qq"; # deprecated
if (/^qq=(.)(.)$/) { # deprecated
$q_pfx = "qq"; $q_lq = $1; $q_rq = $2;
next
}
next if $_ eq ""; # null specifier
if (/style=((?:[^:,]+|\\.)+),((?:[^:]|\\.)+)/) {
$q_pfx = ""; $q_lq = $1; $q_rq = $2;
$q_lq =~ s/\\(.)/$1/g; $q_rq =~ s/\\(.)/$1/g;
next
}
oops "Invalid ",_dbvis($_)," in Useqq specifier ",_dbvis($useqq),"\n";
}
}
my $pad = $self->Pad() // "";
$indent_unit = 2; # make configurable?
my $maxlinelen = $foldwidth1 || $foldwidth || INT_MAX;
my $maxlineNlen = ($foldwidth // INT_MAX) - length($pad);
if ($debug) {
our $_dbmaxlen = INT_MAX;
btw "## DD result: fw1=",u($foldwidth1)," fw=",u($foldwidth)," pad='${pad}' maxll=$maxlinelen maxlNl=$maxlineNlen\n result=",_dbrawstr($_);
}
my $top = { tlen => 0, children => [] };
my $context = $top;
my $prepending = "";
my sub atom($;$) {
(local $_, my $mode) = @_;
$mode //= "";
__unmagic_atom ;
__unesc_unicode if $unesc_unicode;
__unesc_nonoctal if $octet_strings;
__subst_controlpic_backesc if $controlpics;
__subst_visiblespaces if $showspaces;
__condense_strings(8) if $condense_strings;
__change_quotechars($q_pfx, $q_lq, $q_rq) if defined($q_pfx);
__nums_in_hex if $nums_in_hex;
__nums_with_underscores if $underscores;
if ($prepending) { $_ = $prepending . $_; $prepending = ""; }
btwN 1,"###atom",_mycallloc(), _dbrawstr($_),"($mode)"
,"\n context:",_dbvisnew($context)->Sortkeys(sub{[grep{exists $_[0]->{$_}} qw/O C tlen children CLOSE_AFTER_NEXT/]})->Dump()
if $debug;
if ($mode eq "prepend_to_next") {
$prepending .= $_;
} else {
if ($mode eq "") {
push @{ $context->{children} }, $_;
}
elsif ($mode eq "open") {
my $child = {
O => $_,
tlen => 0, # incremented below
children => [],
C => undef,
parent => $context,
};
weaken( $child->{parent} );
push @{ $context->{children} }, $child;
$context = $child;
}
elsif ($mode eq "close") {
oops if defined($context->{C});
$context->{C} = $_;
$context->{tlen} += length;
$context = $context->{parent}; # undef if closing the top item
}
elsif ($mode eq "append_to_prev") {
my $prev = $context;
{ #block for 'redo'
oops "No previous!" unless @{$prev->{children}} > 0;
if (ref($prev->{children}->[-1] // oops)) {
$prev = $prev->{children}->[-1];
if (! $prev->{C}) { # empty or not-yet-read closer?
redo; # ***
}
$prev->{C} .= $_;
} else {
$prev->{children}->[-1] .= $_;
}
}
}
else {
oops "mode=",_dbvis($mode);
}
my $c = $context;
while(defined $c) {
$c->{tlen} += length($_);
$c = $c->{parent};
}
lib/Data/Dumper/Interp.pm view on Meta::CPAN
=head2 Objects(I<[ list of classnames ]>)
A I<false> value disables special handling of objects
(that is, blessed things) and internals are shown as with Data::Dumper.
A "1" (the default) enables for all objects,
otherwise only for the specified class name(s) or derived classes.
When enabled, object internals are never shown.
The class and abbreviated address are shown as with C<addrvis>
e.g. "Foo::Bar<392:0f0>", unless the object overloads
the stringification ('""') operator,
or array-, hash-, scalar-, or glob- deref operators;
in that case the first overloaded operator found will be evaluated,
the object replaced by the result, and the check repeated.
By default, "(classname)" is prepended to the result of an overloaded operator
to make clear what happened.
=head2 Objects(I<< {objects => VALUE, overloads => OVOPT} >>)
This form, passing a hashref,
allows passing additional options for blessed objects:
=over
B<overloads =E<gt> "tagged"> (the default): "(classname)" is prepended to the result when an overloaded operator is evaluated.
B<overloads =E<gt> "transparent"> : The overload results
will appear unadorned, i.e. they will look as if the overload result
was the original value.
B<overloads =E<gt> "ignore"> : Overloaded operators are not evaluated at all;
the original object's abbreviated refaddr is shown
(if you want to see object internals, disable I<Objects> entirely.)
Deprecated: B<show_classname =E<gt> False> : Please use S<< B<overloads =E<gt> "transparent"> instead. >>
=back
The I<objects> value indicates whether and for which classes special
object handling is enabled (false, "1", "classname" or [list of classnames]).
=head2 Refaddr(I<BOOL>)
If true, references are identified as with C<addrvis>.
=head2 Sortkeys(I<SUBREF>)
The default sorts numeric substrings in keys by numerical
value, e.g. "A.20" sorts before "A.100". See C<Data::Dumper> documentation.
=head2 Useqq(I<argument>)
0 means generate 'single quoted' strings when possible.
1 means generate "double quoted" strings as-is from Data::Dumper.
Non-ASCII charcters will likely appeqar as hex or octal escapes.
Otherwise generate "double quoted" strings enhanced according to option
keywords given as a :-separated list, e.g. Useqq("unicode:controlpics").
The avilable options are:
=over 4
=item "unicode"
Printable ("graphic")
characters are shown as themselves rather than hex escapes, and
'\n', '\t', etc. are shown for ASCII control codes.
=item "controlpics"
Show ASCII control characters using single "control picture" characters:
'â¤' is shown for newline instead of '\n', and
similarly †⇠∠⛠⌠â ≠for \0 \a \b \e \f \r \t.
Every character occupies the same space with a fixed-width font, but
the tiny "control picures" can be hard to read;
to see traditional \n etc. while still seeing wide characters as themselves,
set C<Useqq> to just "unicode";
=item "octets"
Optimize for viewing binary strings (i.e. strings of octets, not "wide"
characters). Octal escapes are shown instead of \n, \r, etc.
=item "showspaces"
Make space characters visible (as 'â£').
(An older "spacedots" option used Middle Dot for this purpose)
=item "condense"
Repeated characters in strings are shown as "⸨I<char>xI<repcount>⸩".
For example
vec(my $s, 31, 1) = 1;
my $str = unpack "b*", $s;
say $str;
-->00000000000000000000000000000001
say visnew->Useqq("unicode:condense")->visl($str);
-->⸨0×31⸩1
=item "underscores"
Show numbers with '_' seprating groups of 3 digits.
=item "style=OPENQUOTE,CLOSEQUOTE"
Use the given symbols instead of double quotes. The symbols may
contain multiple characters. Escape , or : with backslash(E<92>).
=item "qq=XY"
(Deprecated) Equivalent to "style=qqX,Y"
=item "qq"
(Deprecated) Equivalent to "style=qq{,}"
=back
The default is C<Useqq('unicode')> except for C<dvis> which also
enables 'condense' and possibly 'showspaces'.
Functions/methods with 'q' in their name force C<Useqq(0)>;
=head2 Quotekeys
=head2 Maxdepth
=head2 Maxrecurse
=head2 Deparse
=head2 Deepcopy
See C<Data::Dumper> documentation.
=head1 B<set_defaults> Method
As an alternative to directly setting the global variables listed above,
the corresponding I<methods> can be called on an object
and finally the C<set_defaults> method, which stores whatever settings are in the
object back into the global variables. For example
visnew->MaxStringwidth(50)->Refaddr(1)->set_defaults();
would set the C<$Data::Dumper::Interp::MaxStringwidth>
and <$Data::Dumper::Interp::Refaddr>
variables, without risk of uncaught spelling errors.
=head2 B<reset_defaults>
The C<reset_defaults> method sets all Configuration variables to original default values.
=head1
=head1 UTILITY FUNCTIONS
=head2 u
=head2 u I<SCALAR>
Returns the argument ($_ by default) if it is defined, otherwise
the string "undef".
=head2 quotekey
=head2 quotekey I<SCALAR>
Returns the argument ($_ by default) if it is a valid bareword,
otherwise a "quoted string".
=head2 qsh
=head2 qsh I<$string>
The string ($_ by default) is quoted if necessary for parsing
by the shell (/bin/sh), which has different quoting rules than Perl.
On Win32 quoting is for cmd.com.
If the string contains only "shell-safe" ASCII characters
it is returned as-is, without quotes.
( run in 0.764 second using v1.01-cache-2.11-cpan-39bf76dae61 )