#!/usr/bin/perl

# lets you examine data recursively, following references.

use warnings;
use strict;

# control behavior:

# never go deeper than MAXDEPTH (saves us from circular shenanigans)
use constant MAXDEPTH => 16;
# cut off long hash keys
use constant MAXHASHKEYLEN => 16;
# if deferencing through multiple references ($$$$node), collapse the
# references?
use constant MULTICOLLAPSE => 1;
# if deferencing through multiple references ($$$$node), indent
# accordingly?
use constant MULTIINDENT => 0;
# show the indices on array elts?
use constant ARRAYIDX => 1;

# control the output format:

# for references to references: \$var, \\\%hash, etc.
use constant DEFERENCE  => '->';
# for truncating long or nasty hash keys
use constant TRUNCATE   => '|..';
# for printing hashes
use constant HASHOPEN   => '{';
use constant HASHCLOSE  => '}';
use constant HASHKEY    => '=>';
use constant HASHSEP    => ',';
# for printing arrays
use constant ARRAYOPEN  => '[';
use constant ARRAYCLOSE => ']';
use constant ARRAYSEP   => ',';
# for printing array indices
use constant ARIDXOPEN  => '[';
use constant ARIDXCLOSE => ']';
# for printing strings
use constant STROPEN    => '"';
use constant STRCLOSE   => '"';
# for printing undefined scalars
use constant UNDEF      => 'undef';
# for extra horizontal spacing (recommended ' ')
use constant EXTRASPACE => ' ';
# for vertical spacing (recommended "\n")
use constant NEWLINE    => "\n";
# indentation string (set to null if NEWLINE != "\n")
use constant INDENT     => ' 'x4;

my $depth = 0;

sub indent () { print INDENT x $depth; }
sub newline () { print NEWLINE; }
# is it a number?  Put it in its own sub to keep warnings on elsewhere
sub numberp ($) {
    no warnings;
    my $s = shift;
    return ($s == 0 && $s ne '0');
}
# quote non-numbers, hack around ""
sub formatscalar ($) {
    my $str = shift;
    if (! defined($str)) { #
        return UNDEF;
    } elsif (numberp($str)) { # not a number
        return STROPEN."$str".STRCLOSE;
    } else { # a number
        return $str;
    }
}
# truncate degenerate hash keys
sub formatkey ($) {
    my $key = shift;
    if ( # truncate at newline
        ($key =~ s/\n.*//m) or
        # truncate at nonprinting chars
        ($key =~ s/[^[:print:]].*//m) or
        # truncate if it's too long
        ($key =~ s/(.{@{[MAXHASHKEYLEN - length TRUNCATE]}}).+/$1/) or
        # this can only serve to confuse
        ($key =~ s/@{[HASHKEY]}.*//)
    ) { # then we truncated.
        $key .= TRUNCATE;
    } elsif ( length $key == 0 ) {
        $key = UNDEF;
    }
    return $key;
}

# recursive, so prototype first
sub printnode ($);
sub printnode ($) {
    my $node = shift;
    my $ref = ref $node;
    if ($depth > MAXDEPTH) {
        warn 'Depth exceeded '.MAXDEPTH.', possible circular reference
+';
        return;
    }
    if ($ref eq 'HASH') {
        print HASHOPEN; newline;
        for (sort keys %{ $node }) {
            ++$depth;
            indent; print formatkey($_),EXTRASPACE.HASHKEY.EXTRASPACE 
+;
            printnode(${ $node }{$_});
            --$depth;
            print HASHSEP; newline;
        }
        indent; print HASHCLOSE;
    } elsif ($ref eq 'ARRAY') {
        print ARRAYOPEN; newline;
        my $index = 0;
        for (@{ $node }) {
            ++$depth;
            indent;
            print "[@{[$index++]}]".EXTRASPACE if ARRAYIDX;
            printnode($_);
            --$depth;
            print ARRAYSEP; newline;
        }
        indent; print ARRAYCLOSE;
    } elsif ( $ref eq '' ) {
        print formatscalar($node);
    } elsif ( $ref eq 'CODE' or $ref eq 'LVALUE' ) {
        print $node;
    } elsif ( $ref eq 'GLOB' ) {
        print $$node;
    } elsif ( $ref eq 'REF' or $ref eq 'SCALAR') {
        if (MULTICOLLAPSE) {
            my $refdepth=1;
            while ($ref eq 'REF') {
                $node = $$node;
                $ref = ref $node;
                $refdepth++;
            }
            if ($ref eq 'SCALAR') {
                $node = $$node;
            } else {
                $refdepth--;
            }
            $depth += $refdepth if MULTIINDENT;
            print DEFERENCE.(($refdepth>1)?"^$refdepth":'').EXTRASPACE
+;
            newline if MULTIINDENT;
            indent if MULTIINDENT;
            printnode($node);
            $depth -= $refdepth if MULTIINDENT;
        } else {
            print DEFERENCE.EXTRASPACE;
            $depth++ if MULTIINDENT;
            printnode($$node);
            $depth-- if MULTIINDENT;
        }
    } else { die "ref returned unknown value $ref" }
}

sub examinedata($) {
    my $node = shift;
    printnode($node);
    newline;
}

my $variable;
my $variable2 = 140;
my $hashref;
$hashref = { key => $hashref };
sub code () {}
examinedata(
    {
        hash => $hashref,
        test => {
            test => 1,
        },
        test2 => {
            test3 => 4,
            test4 => [(1..10)],
            test5 => \&code,
        },
        test6 => [
            \\\\$variable2,
            \\\\$variable,
            \\\$variable2,
            \\\$variable,
            \\$variable2,
            \\$variable,
            \$variable2,
            \$variable,
            $variable2,
            $variable,
            \\&code,
            \&code,
            \\\\\\\[1..2],
            \\\[1..2],
            \\[1..2],
            \[1..2],
            [1..2],
        ],
        test7 => [
            "test",
            \\*GLOB,
            \*GLOB,
            *GLOB,
        ],
        test8 => \\@{ [
            "test",
            \\*GLOB,
            \*GLOB,
            *GLOB,
        ] },
        "This is a long key."                       => undef,
        "This\n is a stupid key."                   => undef,
        "\n This one's stupider still!"             => undef,
        "ASCII 020\020 = Data Link Escape.  WTF?"   => undef,
        "LEET=>HAX"                                 => undef,
        $variable => \$variable,
        100 => \$variable,
    }
);
[download]