view release on metacpan or  search on metacpan

lib/DBG.pm  view on Meta::CPAN

}


sub rt($$) {
    return unless $ON;
    for (@_) {
        die 'DBG::ts expected'
          unless blessed($_) && $_->isa('DBG::ts');
    }
    my ( $t1, $t2 ) = @_;
    my $i = natatime 2, ( $t2 - $t1 )->deltas;
    my $reported;
    my $text   = $t1->text;
    my $prefix = '';
    if ( defined $text ) {
        _tee("timestamp $text");
        $prefix = "\t";
    }
    while ( my ( $unit, $amt ) = $i->() ) {
        next unless $amt;
        $reported = 1;
        $unit =~ s/s$// if $amt == 1;
        _tee("$prefix$amt $unit");
    }
    _tee("${prefix}negligible time elapsed") unless $reported;
    return $t2;
}


sub trc() {
    return unless $ON;
    _tee 'TRACE';
    my $i = 0;
    my @stack;
    while ( my @frame = caller($i) ) {
        push @stack, [ $i++, $frame[3], $frame[1], $frame[2] ];
    }
    my $fmt = '%' . length( $stack[-1][0] ) . 'd) %s (%s:%d)';
    for $i ( 1 .. $#stack ) {
        _tee sprintf $fmt, ( @{ $stack[$i] } )[ 0 .. 1 ],
          ( @{ $stack[ $i - 1 ] } )[ 2 .. 3 ];
    }
    _tee 'END TRACE';
}


sub dmp($) {
    return unless $ON;
    my $ref = shift;
    local $Data::Dumper::Indent    = 1;
    local $Data::Dumper::Sortkeys  = 1;
    local $Data::Dumper::Quotekeys = 0;
    local $Data::Dumper::Terse     = 1;
    my $code = Dumper $ref;
    _dmp($code);
}

sub _dmp {
    my $code = shift;
    my ( $ds, $stderr_string );
    local @ARGV;    # prevents Perl::Tidy craziness
    my $error = Perl::Tidy::perltidy(
        source      => \$code,
        destination => \$ds,
        stderr      => \$stderr_string
    );
    if ($error) {
        _tee "TIDY ERROR: $stderr_string";
        _tee $code;
    }
    else {
        _tee $ds;
    }
}


sub dbg($) {
    return unless $ON;
    my $data = shift;
    _tee $data;
}


sub png(;$) {
    return unless $ON;
    my $msg   = shift;
    my @frame = caller(1);
    my $data;
    if ( @frame && $msg ) {
        ( $data = $frame[3] ) =~ s/.*::(.*)/in code $1/;
    }
    else {
        $data = @frame ? sprintf( 'PING %4$s (%2$s:%3$d)', @frame ) : 'PING';
    }
    $data .= " -- $msg" if $msg && ( ref $msg || $msg ne '1' );
    _tee $data;
}


sub cyc($) {
    return unless $ON;
    _tee '===== OBJECT GRAPH =====';
    _cycles( shift, {}, 0, 'base' );
}

sub _cycles {
    my ( $ref, $hash, $indent, $parent ) = @_;
    my $type = reftype $ref;
    return unless $type;
## Please see file perltidy.ERR
    my $addr = refaddr $ref;
    my $name = blessed $ref // $type;
    my $left = ' ' x ( $indent * 3 );
    if ( $hash->{$addr}++ ) {
        _tee sprintf '%s%s (%s <- %s) -- ref count: %d', $left, $name, $addr,
          $parent,
          $hash->{$addr};
    }
    else {
        _tee sprintf '%s%s (%s <- %s)', $left, $name, $addr, $parent;
        if ( $type eq 'HASH' ) {