view release on metacpan or  search on metacpan

lib/DBG.pm  view on Meta::CPAN

    my $data = shift;
    return unless defined $data;
    if ( $HEADER && !$stamped ) {
        my @msg = (
            '>> DEBUGGING SESSION START: ',
            DateTime->now, ' ; PID: ', $$, ' <<', "\n\n"
        );
        print $fh @msg if $fh;
        print STDERR @msg;
        $stamped = 1;
    }
    $data =~ s/\s++$//;
    $data .= "\n";
    print $fh $data if $fh;
    print STDERR $data;
}

BEGIN {
    if ( length $fn ) {
        $fh = FileHandle->new(">> $fn") or die $!;
        binmode $fh,     ':utf8';
        binmode *STDERR, ':utf8';
        $fh->autoflush(1);
    }
}

END {
    if ( $HEADER && $stamped ) {
        my $msg = join '', "\n", '** DEBUGGING SESSION END: ', DateTime->now,
          ' ; PID: ', $$, ' **';
        _tee($msg);
    }
    $fh->close if $fh;
}

{    # DateTime with optional label payload

    package DBG::ts;
$DBG::ts::VERSION = '0.004';
use parent 'DateTime';
    use Scalar::Util qw(refaddr);

    our %messages;

    sub text {
        my ( $self, $text ) = @_;
        my $addr = refaddr $self;
        my $old  = $messages{$addr};
        $messages{$addr} = $text if defined $text;
        return $old;
    }

    sub DESTROY {
        my $self = shift;
        delete $messages{ refaddr $self };
        $self->SUPER::DESTROY if $self->can("SUPER::DESTROY");
    }
}


sub ts(;$) {
    my $ts = DBG::ts->now;
    $ts->text(shift);
    return $ts;
}


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,

lib/DBG.pm  view on Meta::CPAN

            _cycles( $_, $hash, $indent + 1, $addr ) for @$ref;
        }
    }
}


sub prp($$) {
    my ( $msg, $var ) = @_;
    $msg =~ s/\??\s*$/? /;
    _tee( $msg . ( $var ? 'yes' : 'no' ) );
}


sub cnm($;$) {
    my ( $code, $quiet ) = @_;
    return unless ref $code;
    my $gv   = _code_name($code);
    my $name = '';
    if ( my $st = $gv->STASH ) {
        $name = $st->NAME . '::';
    }
    my $n = $gv->NAME;
    if ($n) {
        $name .= $n;
        if ( $n eq '__ANON__' ) {
            $name .= ' defined at ' . $gv->FILE . ':' . $gv->LINE;
        }
    }
    _tee($name) unless $quiet;
    return $name;
}

sub _code_name {
    my $code = shift;
    return unless my $cv = svref_2object($code);
    return
      unless $cv->isa('B::CV')
      and my $gv = $cv->GV;
    return $gv;
}


sub pkg($$;$) {
    my ( $obj, $method, $file ) = @_;
    return _tee('first parameter must be an object') unless blessed $obj;
    return _tee('method not defined') unless defined $method;
    my $m = $obj->can($method);
    return _tee( "did not find method $method in " . ref $obj ) unless $m;
    my $gv = _code_name($m);
    return _tee("could not find $method") unless $gv;
    if ( !$file ) {
        _tee( sprintf 'package: %s; file: %s; line: %s',
            $gv->STASH->NAME, $gv->FILE, $gv->LINE );
    }
    else {
        _tee( $gv->STASH->NAME );
    }
}


sub sz($;$) {
    state $ts = eval { require Devel::Size };
    if ($ts) {
        my $msg = Devel::Size::total_size( pop @_ );
        $msg = pop(@_) . ' ' . $msg if @_;
        _tee($msg);
    }
    else {
        _tee('sz requires Devel::Size');
    }
}


sub mtd($;$) {
    my ( $obj, $verbose ) = @_;
    if ( my $class = ref $obj ) {
        my $meta = Class::MOP::Class->initialize($class);
        _tee("Class: $class");
        if ($verbose) {
            my $longest = 0;
            for ( $meta->get_all_methods ) {
                my $l = length $_->name;
                $longest = $l if $l > $longest;
            }
            my $format = '%-' . $longest . 's : %s  %s';
            for my $method ( sort { $a->name cmp $b->name }
                $meta->get_all_methods )
            {
                my $code = $obj->can( $method->name );
                my $gv   = _code_name($code);
                if ( $gv->LINE ) {
                    _tee( sprintf $format, $method->name, $gv->FILE,
                        $gv->LINE );
                }
                else {
                    _tee( $method->fully_qualified_name );
                }
            }
        }
        else {
            dmp(
                [
                    sort map { $_->fully_qualified_name }
                      $meta->get_all_methods
                ]
            );
        }
    }
    else {
        _tee "NOT AN OBJECT: $obj";
    }
}


sub inh($) {
    my $class = shift;
    _tee('inh needs a class') && return unless length( $class // '' );
    $class = ref($class) || $class;
    my $hash = { $class => 1 };
    _fetch_classes( $class, $hash );
    my @classes = sort keys %$hash;