view release on metacpan or  search on metacpan

Peek.pm  view on Meta::CPAN

	    my $r = shift;
	    [         sort {      $b  <=>      $a  } keys %{$r} ];
	    },
    'V'   => sub {	# Sort by value
	    my $r = shift;
	    [         sort { $r->{$a} cmp $r->{$b} } keys %{$r} ];
	    },
    'VN'  => sub {	# Sort by value numeric
	    my $r = shift;
	    [         sort { $r->{$a} <=> $r->{$b} } keys %{$r} ];
	    },
    'VNR' => sub {	# Sort by value numeric reverse
	    my $r = shift;
	    [         sort { $r->{$b} <=> $r->{$a} } keys %{$r} ];
	    },
    'VR'  => sub {	# Sort by value reverse
	    my $r = shift;
	    [         sort { $r->{$b} cmp $r->{$a} } keys %{$r} ];
	    },
    );
my  $_sortkeys = 1;
our $_perltidy = 0;

my %pmap = map {( $_ => $_ )} map {( split //, $_ )}
    q{ !""#$%&'()*+,-./0123456789:;<=>},
    q{@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^},
    q{`abcdefghijklmnopqrstuvwxyz|~}, "{}";
$pmap{$_} = "." for grep { !exists $pmap{$_} } map { chr } 0 .. 255;

sub DDsort {
    @_ or return;

    $_sortkeys = exists $sk{$_[0]} ? $sk{$_[0]} : $_[0];
    } # DDsort

sub import {
    my @exp = @_;
    my @etl;
    foreach my $p (@exp) {
	exists $sk{$p} and DDsort ($p), next;

	if ($p eq ":tidy") {
	    $_perltidy = $has_perltidy;
	    next;
	    }

	push @etl, $p;
	}
    __PACKAGE__->export_to_level (1, @etl);
    } # import

sub DDumper {
    $_perltidy and goto \&DTidy;

    local $Data::Dumper::Sortkeys  = $_sortkeys;
    local $Data::Dumper::Indent    = 1;
    local $Data::Dumper::Quotekeys = 0;
    local $Data::Dumper::Deparse   = 1;
    local $Data::Dumper::Terse     = 1;
    local $Data::Dumper::Purity    = 1;
    local $Data::Dumper::Useqq     = 0;	# I want unicode visible

    my $s = Data::Dumper::Dumper (@_);
    $s =~ s/^(\s*)(.*?)\s*=>/sprintf "%s%-16s =>", $1, $2/gme;  # Align =>
    $s =~ s/\bbless\s*\(\s*/bless (/gm and $s =~ s/\s+\)([;,])$/)$1/gm;
    $s =~ s/^(?=\s*[]}](?:[;,]|$))/  /gm;
    $s =~ s/^(\s*[{[]) *\n *(?=\S)(?![{[])/$1   /gm;
    $s =~ s/^(\s+)/$1$1/gm;

    defined wantarray or warn $s;
    return $s;
    } # DDumper

sub DTidy {
    $has_perltidy or goto \&DDumper;

    local $Data::Dumper::Sortkeys  = $_sortkeys;
    local $Data::Dumper::Indent    = 1;
    local $Data::Dumper::Quotekeys = 1;
    local $Data::Dumper::Deparse   = 1;
    local $Data::Dumper::Terse     = 1;
    local $Data::Dumper::Purity    = 1;
    local $Data::Dumper::Useqq     = 0;

    my $s = Data::Dumper::Dumper (@_);
    my $t;
    my @opts = (
	# Disable stupid options in ~/.perltidyrc
	# people do so, even for root
	"--no-backup-and-modify-in-place",
	"--no-check-syntax",
	"--no-standard-output",
	"--no-warning-output",
	);
    # RT#99514 - Perl::Tidy memoizes .perltidyrc incorrectly
    $has_perltidy > 20120714 and push @opts => "--no-memoize";

    Perl::Tidy::perltidy ('source' => \$s, 'destination' => \$t, 'argv' => \@opts);
    $s = $t;

    defined wantarray or warn $s;
    return $s;
    } # DTidy

### ############# DDump () ####################################################

sub _DDump_ref {
    my (undef, $down) = (@_, 0);

    my $ref = ref $_[0];
    if ($ref eq "SCALAR" || $ref eq "REF") {
	my %hash = DDump (${$_[0]}, $down);
	return { %hash };
	}
    if ($ref eq "ARRAY") {
	my @list;
	foreach my $list (@{$_[0]}) {
	    my %hash = DDump ($list, $down);
	    push @list, { %hash };
	    }
	return [ @list ];