view release on metacpan or  search on metacpan

lib/Debug/LTrace/plstrace.pm  view on Meta::CPAN

    shift;
    $import_params{ ${ \scalar caller } } = [@_];
}

# External constructor
sub new {
    return unless defined wantarray;
    my $self = shift->_new( scalar caller, @_ );
    $self;
}

# Internal constructor
sub _new {
    my ( $class, $trace_package, @params ) = @_;
    my $self;

    # Parse input parameters
    foreach my $p (@params) {
        if ($p =~ /^(-\w+)(?:=(.*))?/) {
            # option
            if ($1 eq '-time0') {
                $time0 = $2;
            } else {
                $self->{$1} = defined($2) ? $2 : 1;
            }
            next;
        }

        #process sub
        $p = $trace_package . '::' . $p unless $p =~ m/::/;
        push @{ $self->{subs} }, (
            $p =~ /^(.+)::\*(\*?)$/
            ? Devel::Symdump ->${ \( $2 ? 'rnew' : 'new' ) }($1)->functions()
            : $p
            );
    }

    bless $self, $class;
    $self->_start_trace();
    #use DD; dd $self;

    $self;
}

my $prevtime;
# Bind all hooks for tracing
sub _start_trace {
    my ($self) = @_;
    return unless ref $self;

    $self->{wrappers} = {};
    my @messages;

    foreach my $sub ( @{ $self->{subs} } ) {
        next if $self->{wrappers}{$sub};    # Skip already wrapped

        $self->{wrappers}{$sub} = Hook::LexWrap::wrap(
            $sub,
            pre => sub {
                pop();
                #my ( $pkg, $file, $line ) = caller(0);
                #my ($caller_sub) = ( caller(1) )[3];

                my $args = join(", ", map {$self->_esc($_)} @_);
                my $entry_time = time();
                my $msg = "> $sub($args)";
                $msg = $self->_fmttime($entry_time) . " $msg" if $self->{-show_time};
                if ($self->{-show_time}) {
                    warn "$msg\n";
                    $prevtime = $entry_time;
                }
                unshift @messages, [ "$sub($args)", $entry_time ];
            },
            post => sub {
                my $exit_time = time();
                my $wantarray = ( caller(0) )[5];
                my $call_data = shift(@messages);

                my $res = defined($wantarray) ? " = ".$self->_esc($wantarray ? pop : [pop]) : '';
                my $msg = "< $call_data->[0]$res";
                $msg = $self->_fmttime($exit_time) . " $msg" if $self->{-show_time};
                $msg .= sprintf(" <%.6f>", $exit_time - $call_data->[1] ) if $self->{-show_spent_time};
                if ($self->{-show_exit}) {
                    warn "$msg\n";
                    $prevtime = $exit_time;
                }

            } );
    }

    # defaults
    $self->{-strsize} //= 32;
    $self->{-show_entry} //= 1;
    $self->{-show_exit}  //= 1;

    $self;
}

sub _esc {
    my ($self, $data) = @_;
    if (!defined($data)) {
        "undef";
    } elsif (ref $data) {
        "$data";
    } elsif (length($data) > $self->{-strsize}) {
        double_quote(substr($data,0,$self->{-strsize}))."...";
    } else {
        double_quote($data);
    }
}

sub _fmttime {
    my ($self, $time) = @_;

    my @lt = localtime($time);
    my $t = $self->{-show_time};
    if ($t > 3) {
        # we try to remove this module's effect on relative time
        # but this is negligible (all below 1ms)
        my $reltime = ($time - $time0) - ($time2-$time1) - ($time4-$time3);
        sprintf "%010.6f", ($t < 5 || !$prevtime ? $reltime : $time-$prevtime);
    } elsif ($t > 2) {
        sprintf "%.6f", $time;
    } elsif ($t > 1) {
        my $frac = ($time - int($time)) * 1000_000;
        sprintf "%02d:%02d:%02d.%06d", $lt[2], $lt[1], $lt[0], $frac;
    } else {
        sprintf "%02d:%02d:%02d", $lt[2], $lt[1], $lt[0];
    }
}

INIT {
    $time3 = time(); # time3 = start of wrapping
    while ( my ( $package, $params ) = each %import_params ) {
        push @permanent_objects, __PACKAGE__->_new( $package, @$params ) if @$params;
    }