Data-Dumper-Interp
view release on metacpan or search on metacpan
t/50_shebang.t view on Meta::CPAN
my $orig_data = eval $orig_str; oops "bug" if $@;
foreach my $MSw (1..9) {
# hand-truncate to create "expected result" data
(my $exp_str = $orig_str) =~ s{(")([a-zA-Z]{$MSw})([a-zA-Z]*+)(\1)}{
local $_ = $1
. $2
. (length($3) > 3 ? "..." : $3)
. $4 ;
# v5.005: hash keys are no longer substituted
#$_ = "\"$_\"" if m{^\w.*\.\.\.$}; #bareword
$_
}segx;
local $Data::Dumper::Interp::MaxStringwidth = $MSw;
mycheck "with MaxStringwidth=$MSw", $exp_str, eval 'vis($orig_data)';
oops "MaxStringwidth=$MSw : Original data corrupted"
unless Compare($orig_data, $check_data);
}
}
# There was a bug for s/dvis called direct from outer scope, so don't use eval:
#
# Another bug was here: On some older platforms qr/.../ can visualize to a
# different, longer representation, so forcing wrap to be the same everywhere
#
my $SS = do{ my $x=" "; dvis('$x') =~ /x="(.)"/ or die; $1 }; # spacedots?
mycheck
'global dvis %toplex_h',
q!%toplex_h=(
"" => "Emp",
A => 111,
"B!.$SS.q!B" => 222,
C => {d => 888,e => 999},
D => {},
EEEEEEEEEEEEEEEEEEEEEEEEEE => \\42,
F_long_enough_to_force_wrap_FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
=> "\\\\#",
G => qr/foo.*bar/six
)!,
dvis('%toplex_h');
mycheck 'global divs @ARGV', q(@ARGV=("fake","argv")), dvis('@ARGV');
mycheck 'global divs $.', q($.=1234), dvis('$.');
mycheck 'global divs $ENV{EnvVar}', q("Test EnvVar Value"), ivis('$ENV{EnvVar}');
sub func {
mycheck 'func args', q(@_=(1,2,3)), dvis('@_');
}
func(1,2,3);
# There was once a "took almost forever" backtracking problem
my @backtrack_bugtest_data = (
42,
{A => 0, BBBBBBBBBBBBB => "foo"},
);
timed_run {
mycheck 'dvis @backtrack_bugtest_data',
'@backtrack_bugtest_data=(42,{A => 0,BBBBBBBBBBBBB => "foo"})',
dvis('@backtrack_bugtest_data');
} 0.10; # some cpan test machines are slow!
sub vis_sans_quotes($) {
my $r = visnew->Useqq("unicode")->vis($_[0]);
$r =~ s/^"(.*)"$/$1/ or oops;
$r
}
{ my @items = (qw/A Z 8 9 ? ! @ $ % ^ & * ( ) _ - = + . ? : ; > < ./,
"#", ",", "\0", "\1", "\x{80}", "\x{C0}", "\x{FF}", "\\",
);
my $repcount = 20;
for my $before_item ("X", "0") { # Can't test \0 because it can become \000
for my $after_item ("Z", "\0", "0") {
for my $item (@items) {
my $before = $before_item eq $item ? "" : $before_item;
my $after = $after_item eq $item ? "" : $after_item;
my $str = $before.($item x $repcount).$after;
my $got = visnew->Useqq("condense")->vis($str);
# Capture special characters which were used just now
my ($LB, $MULT, $RB) = ($Data::Dumper::Interp::COND_LB,
$Data::Dumper::Interp::COND_MULT,
$Data::Dumper::Interp::COND_RB);
next if $item eq $LB;
next if $item eq $MULT;
next if $item eq $RB;
my $exp = '"'.vis_sans_quotes($before)
.$LB.vis_sans_quotes($item).$MULT.$repcount.$RB
.vis_sans_quotes($after).'"';
like($got, $exp, "condense",
visnew->Useqq("unicode")->dvis('$before $item $after $str'));
}
}
}
}
sub doquoting($$) {
my ($input, $useqq) = @_;
my $quoted = $input;
if ($useqq) {
my %subopts;
if ($useqq ne "1") {
foreach my $item (split /:/, $useqq) {
if ($item =~ /^([^=]+)=(.*)/) {
$subopts{$1} = $2;
} else {
$subopts{$item} = 1;
}
}
}
$quoted =~ s/([\$\@\\])/\\$1/gs;
if (delete $subopts{controlpic}) {
$quoted =~ s/\n/\N{SYMBOL FOR NEWLINE}/gs;
$quoted =~ s/\t/\N{SYMBOL FOR HORIZONTAL TABULATION}/gs;
} else {
$quoted =~ s/\n/\\n/gs;
$quoted =~ s/\t/\\t/gs;
}
my $unicode = delete $subopts{unicode} || delete $subopts{utf8};
if (!$unicode) {
$quoted = join("", map{ ord($_) > 127 ? sprintf("\\x{%x}", ord($_)) : $_ }
split //,$quoted);
}
if (my $arg = delete $subopts{qq}) {
my ($left, $right) = split //, ($arg eq 1 ? "{}" : $arg);
$quoted =~ s/([\Q${left}${right}\E])/\\$1/g;
$quoted = "qq" . $left . $quoted . $right;
} else {
$quoted =~ s/"/\\"/g;
$quoted = '"' . $quoted . '"';
}
oops("testbug: Useqq subopt: '",keys(%subopts),"'\n")
if %subopts;
} else {
$quoted =~ s/([\\'])/\\$1/gs;
$quoted = "'${quoted}'";
}
return $quoted;
}
sub show_white($) {
local $_ = shift;
return "(Is undef)" unless defined;
s/\t/<tab>/sg;
s/( +)$/"<space>" x length($1)/seg; # only trailing spaces
s/\n/<newline>\n/sg;
$_
}
my $unicode_str = join "", map { chr($_) } (0x263A .. 0x2650);
my $byte_str = join "",map { chr $_ } 10..30;
sub get_closure(;$) {
my ($clobber) = @_;
confess "Non-zero CHILD_ERROR ($?)" if $? != 0;
my %closure_h = (%toplex_h);
my @closure_a = (@toplex_a);
my $closure_ar = \@closure_a;
my $closure_hr = \%closure_h;
my $closure_obj = $toplex_obj;
if ($clobber) { # try to over-write deleted objects
@closure_a = ("bogusa".."bogusz");
}
return sub {
confess "Non-zero CHILD_ERROR ($?)" if $? != 0;
# Perl is inconsistent about whether an eval in package DB can see
# lexicals in enclosing scopes. Sometimes it can, sometimes not.
# However explicitly referencing those "global lexicals" in the closure
# seems to make it work.
# 5/16/16: Perl v5.22.1 *segfaults* if these are included
# (at least *_obj). But removing them all causes some to appear
# to be non-existent.
my $forget_me_not = [
\$unicode_str, \$byte_str,
\@toplex_a, \%toplex_h, \$toplex_hr, \$toplex_ar, \$toplex_obj,
\@global_a, \%global_h, \$global_hr, \$global_ar, \$global_obj,
];
# Referencing these intermediate variables also prevents them from
# being destroyed before this closure is executed:
my $saverefs = [ \%closure_h, \@closure_a, \$closure_ar, \$closure_hr, \$closure_obj ];
my $zero = 0;
my $one = 1;
my $two = 2;
my $EnvVarName = 'EnvVar';
my $flex = 'Lexical in sub f';
my $flex_ref = \$flex;
my $ARGV_ref = \@ARGV;
eval { die "FAKE DEATH\n" }; # set $@
my %sublexx_h = %toplex_h;
my @sublexx_a = @toplex_a;
my $sublexx_ar = \@sublexx_a;
my $sublexx_hr = \%sublexx_h;
my $sublexx_obj = $toplex_obj;
our %subglobal_h = %toplex_h;
our @subglobal_a = @toplex_a;
our $subglobal_ar = \@subglobal_a;
our $subglobal_hr = \%subglobal_h;
our $subglobal_obj = $toplex_obj;
our %maskedglobal_h = %toplex_h;
our @maskedglobal_a = @toplex_a;
our $maskedglobal_ar = \@maskedglobal_a;
our $maskedglobal_hr = \%maskedglobal_h;
our $maskedglobal_obj = $toplex_obj;
our $maskedglobal_regexp = $toplex_regexp;
local %local_h = %toplex_h;
local @local_a = @toplex_a;
local $local_ar = \@toplex_a;
local $local_hr = \%local_h;
local $local_obj = $toplex_obj;
local $local_regexp = $toplex_regexp;
use constant CPICS_DEFAULT => 0; # is Useqq('controlpics') the default?
my @dvis_tests = (
[ __LINE__, q(hexesc:\x{263a}), qq(hexesc:\N{U+263A}) ], # \x{...} in dvis input
[ __LINE__, q(NUesc:\N{U+263a}), qq(NUesc:\N{U+263A}) ], # \N{U+...} in dvis input
[ __LINE__, q(aaa\\\\bbb), q(aaa\bbb) ],
[ __LINE__, q(re is $toplex_regexp), q(re is toplex_regexp=qr/my.*regexp/) ],
#[ q($unicode_str\n), qq(unicode_str=\" \\x{263a} \\x{263b} \\x{263c} \\x{263d} \\x{263e} \\x{263f} \\x{2640} \\x{2641} \\x{2642} \\x{2643} \\x{2644} \\x{2645} \\x{2646} \\x{2647} \\x{2648} \\x{2649} \\x{264a} \\x{264b} \\x{264c} \\x{264d} \\x{26...
[__LINE__, q($unicode_str\n), qq(unicode_str="${unicode_str}"\n) ],
[__LINE__, q(unicodehex_str=\"\\x{263a}\\x{263b}\\x{263c}\\x{263d}\\x{263e}\\x{263f}\\x{2640}\\x{2641}\\x{2642}\\x{2643}\\x{2644}\\x{2645}\\x{2646}\\x{2647}\\x{2648}\\x{2649}\\x{264a}\\x{264b}\\x{264c}\\x{264d}\\x{264e}\\x{264f}\\x{2650}\"\n), qq...
(CPICS_DEFAULT ? (
[__LINE__, q($byte_str\n), qq(byte_str=\"\N{SYMBOL FOR NEWLINE}\\13\N{SYMBOL FOR FORM FEED}\N{SYMBOL FOR CARRIAGE RETURN}\\16\\17\\20\\21\\22\\23\\24\\25\\26\\27\\30\\31\\32\N{SYMBOL FOR ESCAPE}\\34\\35\\36\"\n) ]
):(
[__LINE__, q($byte_str\n), qq(byte_str=\"\\n\\13\\f\\r\\16\\17\\20\\21\\22\\23\\24\\25\\26\\27\\30\\31\\32\\e\\34\\35\\36\"\n) ],
#[__LINE__, q($byte_str\n), qq(byte_str=\"\\n\\x{B}\\f\\r\\x{E}\\x{F}\\x{10}\\x{11}\\x{12}\\x{13}\\x{14}\\x{15}\\x{16}\\x{17}\\x{18}\\x{19}\\x{1A}\\e\\x{1C}\\x{1D}\\x{1E}\"\n) ],
)),
[__LINE__, q($flex\n), qq(flex=\"Lexical${SS}in${SS}sub${SS}f\"\n) ],
[__LINE__, q($$flex_ref\n), qq(\$\$flex_ref=\"Lexical${SS}in${SS}sub${SS}f\"\n) ],
[__LINE__, q($_ $ARG\n), qq(\$_=\"GroupA.GroupB\" ARG=\"GroupA.GroupB\"\n) ],
[__LINE__, q($a\n), qq(a=\"global-a\"\n) ],
[__LINE__, q($b\n), qq(b=\"global-b\"\n) ],
[__LINE__, q($1\n), qq(\$1=\"GroupA\"\n) ],
[__LINE__, q($2\n), qq(\$2=\"GroupB\"\n) ],
[__LINE__, q($3\n), qq(\$3=undef\n) ],
[__LINE__, q($&\n), qq(\$&=\"GroupA.GroupB\"\n) ],
[__LINE__, q(${^MATCH}\n), qq(\${^MATCH}=\"GroupA.GroupB\"\n) ],
[__LINE__, q($.\n), qq(\$.=1234\n) ],
[__LINE__, q($NR\n), qq(NR=1234\n) ],
(CPICS_DEFAULT ? (
[__LINE__, q($/\n), qq(\$/=\"\N{SYMBOL FOR NEWLINE}\"\n) ],
):(
[__LINE__, q($/\n), qq(\$/=\"\\n\"\n) ],
)),
[__LINE__, q($\\\n), qq(\$\\=undef\n) ],
[__LINE__, q($"\n), qq(\$\"=\"${SS}\"\n) ],
[__LINE__, q($~\n), qq(\$~=\"STDOUT\"\n) ],
#20 :
[__LINE__, q($^\n), qq(\$^=\"STDOUT_TOP\"\n) ],
(CPICS_DEFAULT ? (
[__LINE__, q($:\n), qq(\$:=\" \N{SYMBOL FOR NEWLINE}-\"\n) ],
[__LINE__, q($^L\n), qq(\$^L=\"\N{SYMBOL FOR FORM FEED}\"\n) ],
):(
[__LINE__, q($:\n), qq(\$:=\"${SS}\\n-\"\n) ],
)),
[__LINE__, q($?\n), qq(\$?=0\n) ],
[__LINE__, q($[\n), qq(\$[=0\n) ],
[__LINE__, q($$\n), qq(\$\$=$$\n) ],
[__LINE__, q($^N\n), qq(\$^N=\"GroupB\"\n) ],
[__LINE__, q($+\n), qq(\$+=\"GroupB\"\n) ],
[__LINE__, q(@+ $#+\n), qq(\@+=(13,6,13) \$#+=2\n) ],
[__LINE__, q(@- $#-\n), qq(\@-=(0,0,7) \$#-=2\n) ],
#30 :
[__LINE__, q($;\n), qq(\$;=\"\\34\"\n) ],
#[__LINE__, q($;\n), qq(\$;=\"\\x{1C}\"\n) ],
[__LINE__, q(@ARGV\n), qq(\@ARGV=(\"fake\",\"argv\")\n) ],
[__LINE__, q($ENV{EnvVar}\n), qq(\$ENV{EnvVar}=\"Test${SS}EnvVar${SS}Value\"\n) ],
[__LINE__, q($ENV{$EnvVarName}\n), qq(\$ENV{\$EnvVarName}=\"Test${SS}EnvVar${SS}Value\"\n) ],
[__LINE__, q(@_\n), <<EOF ], # N.B. Foldwidth was set to 72
\@_=(
42,
[
0,
1,
"C",
{
"" => "Emp",
A => 111,
t/50_shebang.t view on Meta::CPAN
# N.B. mycheck() compares as strings
mycheck "dvis('$dvis_input') lno $lno : $varname NOT PRESERVED : ",
defined($actual) ? $actual+0 : "<undef>",
defined($expecting) ? $expecting+0 : "<undef>" ;
}
for my $use_oo (0,1) {
my $actual;
my $dollarat_val = $@;
eval { $@ = $dollarat_val;
# Verify that special vars are preserved and don't affect DDI
# (except if testing a punctuation var, then don't change it's value)
my ($origAt,$origFs,$origBs,$origComma,$origBang,$origCarE,$origCarW)
= ($@, $/, $\, $,, $!+0, $^E, $^W);
# Don't change a value if being tested in $dvis_input
my ($fakeAt,$fakeFs,$fakeBs,$fakeCom,$fakeBang,$fake_cE,$fake_cW)
= ($dvis_input =~ /(?<!\\)\$@/ ? $origAt : "FakeAt",
$dvis_input =~ /(?<!\\)\$\// ? $origFs : "FakeFs",
$dvis_input =~ /(?<!\\)\$\\\\/ ? $origBs : "FakeBs",
$dvis_input =~ /(?<!\\)\$,/ ? $origComma : "FakeComma",
$dvis_input =~ /(?<!\\)\$!/ ? $origBang : 6,
$dvis_input =~ /(?<!\\)\$^E/ ? $origCarE : 6, # $^E aliases $! on most OSs
$dvis_input =~ /(?<!\\)\$^W/ ? $origCarW : 0); # $^W can only be 0 or 1
($@, $/, $\, $,, $!, $^E, $^W)
= ($fakeAt,$fakeFs,$fakeBs,$fakeCom,$fakeBang,$fake_cE,$fake_cW);
#say "XXX dvis_input='${dvis_input}'";
# 12/13/2023 now dvis enables :spacedots by default
# but our test setup can not deal with that
$actual = $use_oo
? Data::Dumper::Interp->new()->dvis($dvis_input)
: dvis($dvis_input);
mycheckspunct('$@', $@, $fakeAt);
mycheckspunct('$/', $/, $fakeFs);
mycheckspunct('$\\', $\, $fakeBs);
mycheckspunct('$,', $,, $fakeCom);
# In FreeBSD a reference to $& can set errno! So can't mycheck $! unless we save&restore it in the tests
mychecknpunct('$!', $!+0, $fakeBang);
mychecknpunct('$^E', $^E+0,$fake_cE);
mychecknpunct('$^W', $^W+0,$fake_cW);
# Restore
($@, $/, $\, $,, $!, $^E, $^W)
= ($origAt,$origFs,$origBs,$origComma,$origBang,$origCarE,$origCarW);
$dollarat_val = $@;
}; #// do{ $actual = $@ };
$actual = $@ if $@;
$@ = $dollarat_val;
mycheck(
"Test case lno $lno, (use_oo=$use_oo) dvis input "
. $quotes[0].show_white($dvis_input).$quotes[1],
$expected,
$actual);
}
for my $useqq (0, 1, "utf8", "unicode", "unicode:controlpic",
"unicode:qq", "unicode:qq=()", "qq",
) {
my $input = $expected.$dvis_input.'qqq@_(\(\))){\{\}\""'."'"; # gnarly
# Now Data::Dumper (version 2.174) forces "double quoted" output
# if there are any Unicode characters present.
# So we can not test single-quoted mode in those cases
next
#if !$useqq && $input =~ tr/\0-\377//c;
if !$useqq && $input =~ /\P{PosixGraph}/a;
my $exp = doquoting($input, $useqq);
my $act = Data::Dumper::Interp->new()->Useqq($useqq)->vis($input);
oops "\n\nUseqq ",u($useqq)," bug:\n"
." Input ".displaystr($input)."\n"
." Expected ".displaystr($exp)."\n"
." Got ".displaystr($act)."\n"
unless $exp eq $act;
}
}
};
} # get_closure()
sub f($) {
get_closure(1);
my $code = get_closure(0);
get_closure(1);
get_closure(1);
$code->(@_);
no warnings 'once';
oops "Punct save/restore imbalance" if @Data::Dumper::save_stack != 0;
}
sub g($) {
local $_ = 'SHOULD NEVER SEE THIS';
goto &f;
}
confess "Non-zero CHILD_ERROR ($?)" if $? != 0;
&g(42,$toplex_ar);
#print "Tests passed.\n";
#say "stderrstring:$stderr_string";
ok(1, "The whole shebang");
done_testing();
exit 0;
BEGIN{ main::diag("end of compiling ".__LINE__."\n"); } # try to find mystery Windows crash
# End Tester
( run in 0.883 second using v1.01-cache-2.11-cpan-75ffa21a3d4 )