view release on metacpan or  search on metacpan

lib/Data/Dump/HTML/PopUp.pm  view on Meta::CPAN

    s/([^\040-\176])/sprintf('\\x{%X}',ord($1))/eg;

    return qq("$_");
}
# END COPY PASTE FROM Data::Dump

# BEGIN COPY PASTE FROM String::PerlQuote
sub _single_quote {
    local($_) = $_[0];
    s/([\\'])/\\$1/g;
    return qq('$_');
}
# END COPY PASTE FROM String::PerlQuote

sub _dump_code {
    my $code = shift;

    state $deparse = do {
        require B::Deparse;
        B::Deparse->new("-l"); # -i option doesn't have any effect?
    };

    my $res = $deparse->coderef2text($code);

    my ($res_before_first_line, $res_after_first_line) =
        $res =~ /(.+?)^(#line .+)/ms;

    if ($OPT_REMOVE_PRAGMAS) {
        $res_before_first_line = "{";
    } elsif ($OPT_PERL_VERSION < 5.016) {
        # older perls' feature.pm doesn't yet support q{no feature ':all';}
        # so we replace it with q{no feature}.
        $res_before_first_line =~ s/no feature ':all';/no feature;/m;
    }
    $res_after_first_line =~ s/^#line .+//gm;

    $res = "sub" . $res_before_first_line . $res_after_first_line;
    $res =~ s/^\s+//gm;
    $res =~ s/\n+//g;
    $res =~ s/;\}\z/}/;
    $res;
}

sub _quote_key {
    $_[0] =~ /\A-?[A-Za-z_][A-Za-z0-9_]*\z/ ||
        $_[0] =~ /\A-?[1-9][0-9]{0,8}\z/ ? $_[0] : _double_quote($_[0]);
}

sub _dump {
    my ($val, $subscript, $depth) = @_;

    my $ref = ref($val);
    if ($ref eq '') {
        if (!defined($val)) {
            return "undef";
        } elsif (looks_like_number($val) && !$OPT_STRINGIFY_NUMBERS &&
                     # perl does several normalizations to number literal, e.g.
                     # "+1" becomes 1, 0123 is octal literal, etc. make sure we
                     # only leave out quote when the number is not normalized
                     $val eq $val+0 &&
                     # perl also doesn't recognize Inf and NaN as numeric
                     # literals (ref: perldata) so these unquoted literals will
                     # choke under 'use strict "subs"
                     $val !~ /\A-?(?:inf(?:inity)?|nan)\z/i
                 ) {
            return $val;
        } else {
            return encode_entities(_double_quote($val));
        }
    }
    my $refaddr = sprintf("%x", refaddr($val));
    $_subscripts{$refaddr} //= $subscript;
    if ($_seen_refaddrs{$refaddr}++) {
        my $target = "\$var" .
            ($_subscripts{$refaddr} ? "->$_subscripts{$refaddr}" : "");
        push @_fixups, "\$var->$subscript = $target;\n";
        return "<a href=#r$refaddr>".encode_entities(_single_quote($target))."</a>";
    }

    my $class;

    if ($ref eq 'Regexp' || $ref eq 'REGEXP') {
        require Regexp::Stringify;
        return encode_entities(
            Regexp::Stringify::stringify_regexp(
                regexp=>$val, with_qr=>1, plver=>$OPT_PERL_VERSION)
        );
    }

    if (blessed $val) {
        $class = $ref;
        $ref = reftype($val);
    }

    my $res = "";
    $res .= ("  " x $depth);
    if ($ref eq 'ARRAY') {
        $res .= "[\n";
        my $i = 0;
        for (@$val) {
            $res .= ",   # ".("." x $depth)."[".($i-1)."]\n" if $i;
            $res .= ("  " x ($depth+1));
            my $elem_ref = ref $_;
            my $elem_res = _dump($_, "$subscript\[$i]", $depth+1);
            if (($elem_ref eq 'ARRAY' || $elem_ref eq 'HASH') && length($elem_res) > 100) {
                my $elem_refaddr = sprintf("%x", refaddr($_));
                push @_result_divs, [$elem_refaddr, "$subscript\[$i]", $elem_res];
                $res .= qq(<a href="#r$elem_refaddr" target="_modal">).encode_entities(_single_quote("\$var->$subscript\[$i]"))."</a>";
            } else {
                $res .= $elem_res;
            }
            $i++;
        }
        $res .= "\n" . ("  " x $depth) . "]";
    } elsif ($ref eq 'HASH') {
        $res .= "{\n";
        my $i = 0;
        for (sort keys %$val) {
            $res .= ",   # ".("." x $depth)."{".($i-1)."}\n" if $i;
            $res .= ("  " x ($depth+1));
            my $k = _quote_key($_);