#$@%#$%!

Ngiler SH3LL 360
: / usr / share / perl5 / vendor_perl / Data / Dump /

Information Server
MySQL : OFF Perl : OFF CURL : ON WGET : OFF PKEXEC : OFF

Directive	Local Value
IP Address	162.0.209.101
System	Linux premium169.web-hosting.com 4.18.0-553.50.1.lve.el8.x86_64 #1 SMP Thu Apr 17 19:10:24 UTC 2025 x86_64
User	luxeelil
PHP Version	8.0.30
Software	LiteSpeed
Doc root	Writable

Edit File : Trace.pm \| Size : 9.54 KB
package Data::Dump::Trace; $VERSION = "0.02"; # Todo: # - prototypes # in/out parameters key/value style # - exception # - wrap class # - configurable colors # - show call depth using indentation # - show nested calls sensibly # - time calls use strict; use base 'Exporter'; our @EXPORT_OK = qw(call mcall wrap autowrap trace); use Carp qw(croak); use overload (); my %obj_name; my %autowrap_class; my %name_count; sub autowrap { while (@_) { my $class = shift; my $info = shift; $info = { prefix => $info } unless ref($info); for ($info->{prefix}) { unless ($_) { $_ = lc($class); s/.:://; } $_ = '$' . $_ unless /^\$/; } $autowrap_class{$class} = $info; } } sub wrap { my %arg = @_; my $name = $arg{name} \|\| "func"; my $func = $arg{func}; my $proto = $arg{proto}; return sub { call($name, $func, $proto, @_); } if $func; if (my $obj = $arg{obj}) { $name = '$' . $name unless $name =~ /^\$/; $obj_name{overload::StrVal($obj)} = $name; return bless { name => $name, obj => $obj, proto => $arg{proto}, }, "Data::Dump::Trace::Wrapper"; } croak("Either the 'func' or 'obj' option must be given"); } sub trace { my($symbol, $prototype) = @_; no strict 'refs'; no warnings 'redefine'; {$symbol} = wrap(name => $symbol, func => \&{$symbol}, proto => $prototype); } sub call { my $name = shift; my $func = shift; my $proto = shift; my $fmt = Data::Dump::Trace::Call->new($name, $proto, \@_); if (!defined wantarray) { $func->(@_); return $fmt->return_void(\@_); } elsif (wantarray) { return $fmt->return_list(\@_, $func->(@_)); } else { return $fmt->return_scalar(\@_, scalar $func->(@_)); } } sub mcall { my $o = shift; my $method = shift; my $proto = shift; return if $method eq "DESTROY" && !$o->can("DESTROY"); my $oname = ref($o) ? $obj_name{overload::StrVal($o)} \|\| "\$o" : $o; my $fmt = Data::Dump::Trace::Call->new("$oname->$method", $proto, \@_); if (!defined wantarray) { $o->$method(@_); return $fmt->return_void(\@_); } elsif (wantarray) { return $fmt->return_list(\@_, $o->$method(@_)); } else { return $fmt->return_scalar(\@_, scalar $o->$method(@_)); } } package Data::Dump::Trace::Wrapper; sub AUTOLOAD { my $self = shift; our $AUTOLOAD; my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::')+2); Data::Dump::Trace::mcall($self->{obj}, $method, $self->{proto}{$method}, @_); } package Data::Dump::Trace::Call; use Term::ANSIColor (); use Data::Dump (); _dump = \&Data::Dump::dump; our %COLOR = ( name => "yellow", output => "cyan", error => "red", debug => "red", ); %COLOR = () unless -t STDOUT; sub _dumpav { return "(" . _dump(@_) . ")" if @_ == 1; return _dump(@_); } sub _dumpkv { return _dumpav(@_) if @_ % 2; my %h = @_; my $str = _dump(\%h); $str =~ s/^\{/(/ && $str =~ s/\}\z/)/; return $str; } sub new { my($class, $name, $proto, $input_args) = @_; my $self = bless { name => $name, proto => $proto, }, $class; my $proto_arg = $self->proto_arg; if ($proto_arg =~ /o/) { for (@$input_args) { push(@{$self->{input_av}}, _dump($_)); } } else { $self->{input} = $proto_arg eq "%" ? _dumpkv(@$input_args) : _dumpav(@$input_args); } return $self; } sub proto_arg { my $self = shift; my($arg, $ret) = split(/\s=\s/, $self->{proto} \|\| ""); $arg \|\|= '@'; return $arg; } sub proto_ret { my $self = shift; my($arg, $ret) = split(/\s=\s*/, $self->{proto} \|\| ""); $ret \|\|= '@'; return $ret; } sub color { my($self, $category, $text) = @_; return $text unless $COLOR{$category}; return Term::ANSIColor::colored($text, $COLOR{$category}); } sub print_call { my $self = shift; my $outarg = shift; print $self->color("name", "$self->{name}"); if (my $input = $self->{input}) { $input = "" if $input eq "()" && $self->{name} =~ /->/; print $self->color("input", $input); } else { my $proto_arg = $self->proto_arg; print "("; my $i = 0; for (@{$self->{input_av}}) { print ", " if $i; my $proto = substr($proto_arg, 0, 1, ""); if ($proto ne "o") { print $self->color("input", $_); } if ($proto eq "o" \|\| $proto eq "O") { print " = " if $proto eq "O"; print $self->color("output", _dump($outarg->[$i])); } } continue { $i++; } print ")"; } } sub return_void { my $self = shift; my $arg = shift; $self->print_call($arg); print "\n"; return; } sub return_scalar { my $self = shift; my $arg = shift; $self->print_call($arg); my $s = shift; my $name; my $proto_ret = $self->proto_ret; my $wrap = $autowrap_class{ref($s)}; if ($proto_ret =~ /^\$\w+\z/ && ref($s) && ref($s) !~ /^(?:ARRAY\|HASH\|CODE\|GLOB)\z/) { $name = $proto_ret; } else { $name = $wrap->{prefix} if $wrap; } if ($name) { $name .= $name_count{$name} if $name_count{$name}++; print " = ", $self->color("output", $name), "\n"; $s = Data::Dump::Trace::wrap(name => $name, obj => $s, proto => $wrap->{proto}); } else { print " = ", $self->color("output", _dump($s)); if (!$s && $proto_ret =~ /!/ && $!) { print " ", $self->color("error", errno($!)); } print "\n"; } return $s; } sub return_list { my $self = shift; my $arg = shift; $self->print_call($arg); print " = ", $self->color("output", $self->proto_ret eq "%" ? _dumpkv(@_) : _dumpav(@_)), "\n"; return @_; } sub errno { my $t = ""; for (keys %!) { if ($!{$_}) { $t = $_; last; } } my $n = int($!); return "$t($n) $!"; } 1; __END__ =head1 NAME Data::Dump::Trace - Helpers to trace function and method calls =head1 SYNOPSIS use Data::Dump::Trace qw(autowrap mcall); autowrap("LWP::UserAgent" => "ua", "HTTP::Response" => "res"); use LWP::UserAgent; $ua = mcall(LWP::UserAgent => "new"); # instead of LWP::UserAgent->new; $ua->get("http://www.example.com")->dump; =head1 DESCRIPTION The following functions are provided: =over =item autowrap( $class ) =item autowrap( $class => $prefix ) =item autowrap( $class1 => $prefix1, $class2 => $prefix2, ... ) =item autowrap( $class1 => \%info1, $class2 => \%info2, ... ) Register classes whose objects are automatically wrapped when returned by one of the call functions below. If $prefix is provided it will be used as to name the objects. Alternative is to pass an %info hash for each class. The recognized keys are: =over =item prefix => $string The prefix string used to name objects of this type. =item proto => \%hash A hash of prototypes to use for the methods when an object is wrapped. =back =item wrap( name => $str, func => \&func, proto => $proto ) =item wrap( name => $str, obj => $obj, proto => \%hash ) Returns a wrapped function or object. When a wrapped function is invoked then a trace is printed after the underlying function has returned. When a method on a wrapped object is invoked then a trace is printed after the methods on the underlying objects has returned. See L</"Prototypes"> for description of the C<proto> argument. =item call( $name, \&func, $proto, @ARGS ) Calls the given function with the given arguments. The trace will use $name as the name of the function. See L</"Prototypes"> for description of the $proto argument. =item mcall( $class, $method, $proto, @ARGS ) =item mcall( $object, $method, $proto, @ARGS ) Calls the given method with the given arguments. See L</"Prototypes"> for description of the $proto argument. =item trace( $symbol, $prototype ) Replaces the function given by $symbol with a wrapped function. =back =head2 Prototypes B<Note: The prototype string syntax described here is experimental and likely to change in revisions of this interface>. The $proto argument to call() and mcall() can optionally provide a prototype for the function call. This give the tracer hints about how to best format the argument lists and if there are I<in/out> or I<out> arguments. The general form for the prototype string is: <arguments> = <return_value> The default prototype is "@ = @"; list of values as input and list of values as output. The value '%' can be used for both arguments and return value to say that key/value pair style lists are used. Alternatively, individual positional arguments can be listed each represented by a letter: =over =item C<i> input argument =item C<o> output argument =item C<O> both input and output argument =back If the return value prototype has C<!> appended, then it signals that this function sets errno ($!) when it returns a false value. The trace will display the current value of errno in that case. If the return value prototype looks like a variable name (with C<$> prefix), and the function returns a blessed object, then the variable name will be used as prefix and the returned object automatically traced. =head1 SEE ALSO L<Data::Dump> =head1 AUTHOR Copyright 2009 Gisle Aas. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Back

Edit File : Trace.pm | Size : 9.54 KB

package Data::Dump::Trace;

$VERSION = "0.02";

# Todo:
#   - prototypes
#     in/out parameters key/value style
#   - exception
#   - wrap class
#   - configurable colors
#   - show call depth using indentation
#   - show nested calls sensibly
#   - time calls

use strict;

use base 'Exporter';
our @EXPORT_OK = qw(call mcall wrap autowrap trace);

use Carp qw(croak);
use overload ();

my %obj_name;
my %autowrap_class;
my %name_count;

sub autowrap {
    while (@_) {
        my $class = shift;
        my $info = shift;
        $info = { prefix => $info } unless ref($info);
        for ($info->{prefix}) {
            unless ($_) {
                $_ = lc($class);
                s/.*:://;
            }
            $_ = '$' . $_ unless /^\$/;
        }
        $autowrap_class{$class} = $info;
    }
}

sub wrap {
    my %arg = @_;
    my $name = $arg{name} || "func";
    my $func = $arg{func};
    my $proto = $arg{proto};

return sub {
        call($name, $func, $proto, @_);
    } if $func;

if (my $obj = $arg{obj}) {
        $name = '$' . $name unless $name =~ /^\$/;
        $obj_name{overload::StrVal($obj)} = $name;
        return bless {
            name => $name,
            obj => $obj,
            proto => $arg{proto},
        }, "Data::Dump::Trace::Wrapper";
    }

croak("Either the 'func' or 'obj' option must be given");
}

sub trace {
    my($symbol, $prototype) = @_;
    no strict 'refs';
    no warnings 'redefine';
    *{$symbol} = wrap(name => $symbol, func => \&{$symbol}, proto => $prototype);
}

sub call {
    my $name = shift;
    my $func = shift;
    my $proto = shift;
    my $fmt = Data::Dump::Trace::Call->new($name, $proto, \@_);
    if (!defined wantarray) {
        $func->(@_);
        return $fmt->return_void(\@_);
    }
    elsif (wantarray) {
        return $fmt->return_list(\@_, $func->(@_));
    }
    else {
        return $fmt->return_scalar(\@_, scalar $func->(@_));
    }
}

sub mcall {
    my $o = shift;
    my $method = shift;
    my $proto = shift;
    return if $method eq "DESTROY" && !$o->can("DESTROY");
    my $oname = ref($o) ? $obj_name{overload::StrVal($o)} || "\$o" : $o;
    my $fmt = Data::Dump::Trace::Call->new("$oname->$method", $proto, \@_);
    if (!defined wantarray) {
        $o->$method(@_);
        return $fmt->return_void(\@_);
    }
    elsif (wantarray) {
        return $fmt->return_list(\@_, $o->$method(@_));
    }
    else {
        return $fmt->return_scalar(\@_, scalar $o->$method(@_));
    }
}

package Data::Dump::Trace::Wrapper;

sub AUTOLOAD {
    my $self = shift;
    our $AUTOLOAD;
    my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::')+2);
    Data::Dump::Trace::mcall($self->{obj}, $method, $self->{proto}{$method}, @_);
}

package Data::Dump::Trace::Call;

use Term::ANSIColor ();
use Data::Dump ();

*_dump = \&Data::Dump::dump;

our %COLOR = (
    name => "yellow",
    output => "cyan",
    error => "red",
    debug => "red",
);

%COLOR = () unless -t STDOUT;

sub _dumpav {
    return "(" . _dump(@_) . ")" if @_ == 1;
    return _dump(@_);
}

sub _dumpkv {
    return _dumpav(@_) if @_ % 2;
    my %h = @_;
    my $str = _dump(\%h);
    $str =~ s/^\{/(/ && $str =~ s/\}\z/)/;
    return $str;
}

sub new {
    my($class, $name, $proto, $input_args) = @_;
    my $self = bless {
        name => $name,
        proto => $proto,
    }, $class;
    my $proto_arg = $self->proto_arg;
    if ($proto_arg =~ /o/) {
        for (@$input_args) {
            push(@{$self->{input_av}}, _dump($_));
        }
    }
    else {
        $self->{input} = $proto_arg eq "%" ? _dumpkv(@$input_args) : _dumpav(@$input_args);
    }
    return $self;
}

sub proto_arg {
    my $self = shift;
    my($arg, $ret) = split(/\s*=\s*/, $self->{proto} || "");
    $arg ||= '@';
    return $arg;
}

sub proto_ret {
    my $self = shift;
    my($arg, $ret) = split(/\s*=\s*/, $self->{proto} || "");
    $ret ||= '@';
    return $ret;
}

sub color {
    my($self, $category, $text) = @_;
    return $text unless $COLOR{$category};
    return Term::ANSIColor::colored($text, $COLOR{$category});
}

sub print_call {
    my $self = shift;
    my $outarg = shift;
    print $self->color("name", "$self->{name}");
    if (my $input = $self->{input}) {
        $input = "" if $input eq "()" && $self->{name} =~ /->/;
        print $self->color("input", $input);
    }
    else {
        my $proto_arg = $self->proto_arg;
        print "(";
        my $i = 0;
        for (@{$self->{input_av}}) {
            print ", " if $i;
            my $proto = substr($proto_arg, 0, 1, "");
            if ($proto ne "o") {
                print $self->color("input", $_);
            }
            if ($proto eq "o" || $proto eq "O") {
                print " = " if $proto eq "O";
                print $self->color("output", _dump($outarg->[$i]));
            }
        }
        continue {
            $i++;
        }
        print ")";
    }
}

sub return_void {
    my $self = shift;
    my $arg = shift;
    $self->print_call($arg);
    print "\n";
    return;
}

sub return_scalar {
    my $self = shift;
    my $arg = shift;
    $self->print_call($arg);
    my $s = shift;
    my $name;
    my $proto_ret = $self->proto_ret;
    my $wrap = $autowrap_class{ref($s)};
    if ($proto_ret =~ /^\$\w+\z/ && ref($s) && ref($s) !~ /^(?:ARRAY|HASH|CODE|GLOB)\z/) {
        $name = $proto_ret;
    }
    else {
        $name = $wrap->{prefix} if $wrap;
    }
    if ($name) {
        $name .= $name_count{$name} if $name_count{$name}++;
        print " = ", $self->color("output", $name), "\n";
        $s = Data::Dump::Trace::wrap(name => $name, obj => $s, proto => $wrap->{proto});
    }
    else {
        print " = ", $self->color("output", _dump($s));
        if (!$s && $proto_ret =~ /!/ && $!) {
            print " ", $self->color("error", errno($!));
        }
        print "\n";
    }
    return $s;
}

sub return_list {
    my $self = shift;
    my $arg = shift;
    $self->print_call($arg);
    print " = ", $self->color("output", $self->proto_ret eq "%" ? _dumpkv(@_) : _dumpav(@_)), "\n";
    return @_;
}

sub errno {
    my $t = "";
    for (keys %!) {
        if ($!{$_}) {
            $t = $_;
            last;
        }
    }
    my $n = int($!);
    return "$t($n) $!";
}

__END__

=head1 NAME

Data::Dump::Trace - Helpers to trace function and method calls

=head1 SYNOPSIS

use Data::Dump::Trace qw(autowrap mcall);

autowrap("LWP::UserAgent" => "ua", "HTTP::Response" => "res");

use LWP::UserAgent;
  $ua = mcall(LWP::UserAgent => "new");      # instead of LWP::UserAgent->new;
  $ua->get("http://www.example.com")->dump;

=head1 DESCRIPTION

The following functions are provided:

=over

=item autowrap( $class )

=item autowrap( $class => $prefix )

=item autowrap( $class1 => $prefix1,  $class2 => $prefix2, ... )

=item autowrap( $class1 => \%info1, $class2 => \%info2, ... )

Register classes whose objects are automatically wrapped when
returned by one of the call functions below.  If $prefix is provided
it will be used as to name the objects.

Alternative is to pass an %info hash for each class.  The recognized keys are:

=over

=item prefix => $string

The prefix string used to name objects of this type.

=item proto => \%hash

A hash of prototypes to use for the methods when an object is wrapped.

=back

=item wrap( name => $str, func => \&func, proto => $proto )

=item wrap( name => $str, obj => $obj, proto => \%hash )

Returns a wrapped function or object.  When a wrapped function is
invoked then a trace is printed after the underlying function has returned.
When a method on a wrapped object is invoked then a trace is printed
after the methods on the underlying objects has returned.

See L</"Prototypes"> for description of the C<proto> argument.

=item call( $name, \&func, $proto, @ARGS )

Calls the given function with the given arguments.  The trace will use
$name as the name of the function.

See L</"Prototypes"> for description of the $proto argument.

=item mcall( $class, $method, $proto, @ARGS )

=item mcall( $object, $method, $proto, @ARGS )

Calls the given method with the given arguments.

See L</"Prototypes"> for description of the $proto argument.

=item trace( $symbol, $prototype )

Replaces the function given by $symbol with a wrapped function.

=back

=head2 Prototypes

B<Note: The prototype string syntax described here is experimental and
likely to change in revisions of this interface>.

The $proto argument to call() and mcall() can optionally provide a
prototype for the function call.  This give the tracer hints about how
to best format the argument lists and if there are I<in/out> or I<out>
arguments.  The general form for the prototype string is:

The default prototype is "@ = @"; list of values as input and list of
values as output.

The value '%' can be used for both arguments and return value to say
that key/value pair style lists are used.

Alternatively, individual positional arguments can be listed each
represented by a letter:

=over

=item C<i>

input argument

=item C<o>

output argument

=item C<O>

both input and output argument

=back

If the return value prototype has C<!> appended, then it signals that
this function sets errno ($!) when it returns a false value.  The
trace will display the current value of errno in that case.

If the return value prototype looks like a variable name (with C<$>
prefix), and the function returns a blessed object, then the variable
name will be used as prefix and the returned object automatically
traced.

=head1 SEE ALSO

L<Data::Dump>

=head1 AUTHOR

This library is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=cut

Back