r1117 - in packages: . libdebug-trace-perl libdebug-trace-perl/branches libdebug-trace-perl/branches/upstream libdebug-trace-perl/branches/upstream/current libdebug-trace-perl/branches/upstream/current/t
Gustavo Franco
stratus@costa.debian.org
Mon, 13 Jun 2005 00:55:11 +0000
Author: stratus
Date: 2005-06-13 00:55:11 +0000 (Mon, 13 Jun 2005)
New Revision: 1117
Added:
packages/libdebug-trace-perl/
packages/libdebug-trace-perl/branches/
packages/libdebug-trace-perl/branches/upstream/
packages/libdebug-trace-perl/branches/upstream/current/
packages/libdebug-trace-perl/branches/upstream/current/Changes
packages/libdebug-trace-perl/branches/upstream/current/MANIFEST
packages/libdebug-trace-perl/branches/upstream/current/Makefile.PL
packages/libdebug-trace-perl/branches/upstream/current/README
packages/libdebug-trace-perl/branches/upstream/current/Trace.pm
packages/libdebug-trace-perl/branches/upstream/current/t/
packages/libdebug-trace-perl/branches/upstream/current/t/basic.t
packages/libdebug-trace-perl/branches/upstream/current/t/caller.t
packages/libdebug-trace-perl/branches/upstream/current/t/maxlen.t
packages/libdebug-trace-perl/branches/upstream/current/t/stack.t
packages/libdebug-trace-perl/tags/
Log:
[svn-inject] Installing original source of libdebug-trace-perl
Added: packages/libdebug-trace-perl/branches/upstream/current/Changes
===================================================================
--- packages/libdebug-trace-perl/branches/upstream/current/Changes 2005-06-13 00:54:07 UTC (rev 1116)
+++ packages/libdebug-trace-perl/branches/upstream/current/Changes 2005-06-13 00:55:11 UTC (rev 1117)
@@ -0,0 +1,21 @@
+Revision history for Perl extension Debug::Trace.
+
+0.01 Thu Oct 3 09:14:47 2002
+ - initial version
+
+0.02 Thu Oct 3 11:10:44 2002
+ - Added kit files README, MANIFEST and such.
+ - Added self test program.
+ - Use Data::Dumper to format values.
+ - Send output using warn() bu default.
+ - Implement modifiers: :warn :nowarn
+
+0.03 Fri Oct 4 02:20:00 2002
+ - Add where/from in trace output.
+ - Rework configuring.
+ - More config options: caller stacktrace maxlen.
+ - DD options via config: indent useqq maxdepth quotekeys sortkeys.
+
+0.04 Fri Oct 4 22:01:45 2002
+ - Add tests, update documentation and small fixes for caller,
+ stacktrace, maxlen.
Added: packages/libdebug-trace-perl/branches/upstream/current/MANIFEST
===================================================================
--- packages/libdebug-trace-perl/branches/upstream/current/MANIFEST 2005-06-13 00:54:07 UTC (rev 1116)
+++ packages/libdebug-trace-perl/branches/upstream/current/MANIFEST 2005-06-13 00:55:11 UTC (rev 1117)
@@ -0,0 +1,9 @@
+Changes
+Makefile.PL
+MANIFEST
+README
+Trace.pm
+t/basic.t
+t/caller.t
+t/maxlen.t
+t/stack.t
Added: packages/libdebug-trace-perl/branches/upstream/current/Makefile.PL
===================================================================
--- packages/libdebug-trace-perl/branches/upstream/current/Makefile.PL 2005-06-13 00:54:07 UTC (rev 1116)
+++ packages/libdebug-trace-perl/branches/upstream/current/Makefile.PL 2005-06-13 00:55:11 UTC (rev 1117)
@@ -0,0 +1,18 @@
+# Makefile.PL for Debug::Trace.
+
+use ExtUtils::MakeMaker;
+
+my %ctl = (
+ NAME => 'Debug::Trace',
+ VERSION_FROM => 'Trace.pm',
+ PREREQ_PM => {
+ 'Data::Dumper' => 2.101,
+ },
+);
+
+if ( $] >= 5.005 ) {
+ $ctl{ABSTRACT_FROM} = 'Trace.pm';
+ $ctl{AUTHOR} = 'JPC, KANE, JV';
+}
+
+WriteMakefile(%ctl);
Added: packages/libdebug-trace-perl/branches/upstream/current/README
===================================================================
--- packages/libdebug-trace-perl/branches/upstream/current/README 2005-06-13 00:54:07 UTC (rev 1116)
+++ packages/libdebug-trace-perl/branches/upstream/current/README 2005-06-13 00:55:11 UTC (rev 1117)
@@ -0,0 +1,49 @@
+Debug/Trace version 0.04
+========================
+
+Debug::Trace instruments subroutines to provide tracing information
+upon every call and return.
+
+Using Debug::Trace does not require any changes to your sources. Most
+often, it will be used from the command line:
+
+ perl -MDebug::Trace=foo,bar yourprogram.pl
+
+This will have your subroutines foo() and bar() printing call and
+return information.
+
+Subroutine names may be fully qualified to denote subroutines in other
+packages than the default main::.
+
+By default, the trace information is output using the standard warn()
+function.
+
+Modifiers are supported to change the default behavior.
+
+INSTALLATION
+
+To install this module type the following:
+
+ perl Makefile.PL
+ make
+ make test
+ make install
+
+DEPENDENCIES
+
+Minimal Perl version is 5.005_03.
+This module uses Perl core modules Data::Dumper and Carp.
+This module requires no other modules and libraries.
+
+SEE ALSO
+
+Attributes::Control.
+
+COPYRIGHT AND LICENCE
+
+Copyright 2002 Amsterdam.pm -- All Rights Reserved.
+
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+
Added: packages/libdebug-trace-perl/branches/upstream/current/Trace.pm
===================================================================
--- packages/libdebug-trace-perl/branches/upstream/current/Trace.pm 2005-06-13 00:54:07 UTC (rev 1116)
+++ packages/libdebug-trace-perl/branches/upstream/current/Trace.pm 2005-06-13 00:55:11 UTC (rev 1117)
@@ -0,0 +1,355 @@
+package Debug::Trace;
+
+use 5.00503; # Yes!
+$VERSION = '0.04';
+
+use strict;
+#use warnings; # Such a pity we cannot use this one...
+
+use Data::Dumper;
+use Carp;
+
+my @debug;
+
+sub import {
+ shift;
+ push @debug, [ scalar caller, @_ ];
+}
+
+# Fully qualify package names.
+sub _q {
+ my($name, $pkg) = @_;
+
+ $name =~ /::/ ? $name : $pkg . "::" . $name;
+}
+
+# Nicely formatted argument values closure.
+sub _mkv {
+ my $config = shift;
+
+ return sub {
+ local $Data::Dumper::Indent = $config->{ indent };
+ local $Data::Dumper::Useqq = $config->{ useqq };
+ local $Data::Dumper::Maxdepth = $config->{ maxdepth };
+ local $Data::Dumper::Quotekeys = $config->{ quotekeys };
+ local $Data::Dumper::Sortkeys = $config->{ sortkeys };
+ my $args = Data::Dumper->Dump([shift]);
+ $args = $1 if $args =~ /\[(.*)\];/s;
+ $args;
+ };
+}
+
+# create appropriate output closure
+sub _mkout {
+ my $config = shift;
+
+ my $trunc;
+ if ( my $maxlen = $config->{maxlen} ) {
+ $trunc = sub {
+ if ( length($_[0]) > $maxlen ) {
+ return substr($_[0], 0, $maxlen - 3) . "...\n";
+ }
+ else {
+ return $_[0];
+ }
+ };
+ }
+
+ if ( $config->{'warn'} ) {
+ return sub {
+ warn $trunc ? $trunc->(join("", @_)) : @_;
+ };
+ }
+ else {
+ return sub {
+ print STDERR $trunc ? $trunc->(join("", @_)) : @_;
+ };
+ }
+}
+
+# create appropriate "TRACE: called..." closure
+sub _mkpre {
+ my($config, $out) = @_;
+
+ my $st = $config->{ stacktrace };
+ if ( $config->{'caller'} ) {
+ return sub {
+ my($pkg, $file, $line) = caller(1);
+ my(undef, undef, undef, $sub) = caller(2);
+ if ( $st ) {
+ local $Carp::CarpLevel = 1;
+ my $msg = Carp::longmess;
+ $msg =~ s/^ at .*\n//;
+ $msg =~ s/ called at .*?Trace\.pm line \d+\n\tDebug::Trace::__ANON__//g;
+ $out->("TRACE:\t", @_, " called at ",
+ "$file line $line\n", $msg);
+ }
+ else {
+ $out->("TRACE:\t", @_, " called at ",
+ "$file line $line ",
+ (defined $sub ? "sub $sub" : "package $pkg"),
+ "\n");
+ }
+ };
+ }
+ else {
+ return sub {
+ $out->("TRACE:\t", @_, "\n");
+ };
+ }
+}
+
+# Generate the closure to handle the tracing.
+sub _s {
+ my ($fqs, $cref, $config) = @_;
+
+ my $out = _mkout($config);
+ my $pre = _mkpre($config, $out);
+ my $v = _mkv($config);
+
+ sub {
+ $pre->("$fqs(", $v->(\@_), ")");
+ if ( !defined wantarray ) {
+ &$cref;
+ $out->("TRACE:\t$fqs() returned\n");
+ }
+ elsif ( wantarray ) {
+ my @r = &$cref;
+ $out->("TRACE:\t$fqs() returned: (", $v->(\@r), ")\n");
+ @r;
+ }
+ else {
+ my $r = &$cref;
+ $out->("TRACE:\t$fqs() returned: ", $v->([$r]), "\n");
+ $r;
+ }
+ };
+}
+
+# Better use CHECK, but this requires Perl 5.6 or later.
+sub INIT {
+
+ # configurable options
+ my %config;
+
+ _default_config(\%config);
+
+ for my $d ( @debug ) {
+ my($caller, @subs) = @$d;
+
+ for my $s ( @subs ) {
+
+ # is it a config option?
+ if ( $s =~ /^:\w/ ) {
+ _config_option(\%config, $s);
+ next;
+ }
+
+ my $fqs = _q($s, $caller);
+ no strict 'refs';
+ my $cref = *{ $fqs }{CODE};
+ if ( !$cref ) {
+ warn "Instrumenting unknown function $fqs\n" if $^W;
+ next;
+ }
+ # no warnings 'redefine';
+ local($^W) = 0;
+ *{ $fqs } = _s($fqs, $cref, \%config);
+ }
+ }
+}
+
+# fill default config options
+sub _default_config {
+ my $config = shift;
+
+ $config->{ 'warn' } = 1;
+ $config->{ 'caller' } = 1;
+ $config->{ stacktrace } = 0;
+ $config->{ maxlen } = 0;
+
+ # Data::Dumper specific options
+ $config->{ indent } = 0;
+ $config->{ useqq } = 1;
+ $config->{ maxdepth } = 2;
+ $config->{ quotekeys } = 0;
+ $config->{ sortkeys } = 0;
+
+ if ( my $e = $ENV{PERL5DEBUGTRACE} ) {
+ for my $c ( split /[\s:]+(?!\()/, $e ) {
+ next unless $c;
+ _config_option($config, ":".$c);
+ }
+ }
+}
+
+# process one config option
+sub _config_option {
+ my $config = shift;
+ $_ = lc(shift);
+
+ if ( /^:no(\w+)$/ && exists $config->{$1} ) {
+ $config->{$1} = 0;
+ }
+ elsif ( /^:(\w+)$/ && exists $config->{$1} ) {
+ $config->{$1} = 1;
+ }
+ elsif ( /^:(\w+)\s*\((-?\d+)\)$/ && exists $config->{$1} ) {
+ $config->{$1} = $2;
+ }
+ else {
+ warn "Unrecognized Debug::Trace config option $_\n";
+ }
+}
+
+1;
+
+=head1 NAME
+
+Debug::Trace - Perl extension to trace subroutine calls
+
+=head1 SYNOPSIS
+
+ perl -MDebug::Trace=foo,bar yourprogram.pl
+
+=head1 DESCRIPTION
+
+Debug::Trace instruments subroutines to provide tracing information
+upon every call and return.
+
+Using Debug::Trace does not require any changes to your sources. Most
+often, it will be used from the command line:
+
+ perl -MDebug::Trace=foo,bar yourprogram.pl
+
+This will have your subroutines foo() and bar() printing call and
+return information.
+
+Subroutine names may be fully qualified to denote subroutines in other
+packages than the default main::.
+
+By default, the trace information is output using the standard warn()
+function.
+
+=head2 MODIFIERS
+
+Modifiers can be inserted in the list of subroutines to change the
+default behavior of this module. All modifiers can be used in three
+ways:
+
+=over 4
+
+=item *
+
+C<:>I<name> to enable a specific feature.
+
+=item *
+
+C<:no>I<name> to disable a specific feature.
+
+=item *
+
+C<:>I<name>C<(>I<value>C<)> to set a feature to a specific value. In
+general, C<:>I<name> is equivalent to C<:>I<name>C<(1)>, while
+C<:no>I<name> corresponds to C<:>I<name>C<(0)>.
+
+=back
+
+The following modifiers are recognized:
+
+=over 4
+
+=item :warn
+
+Uses warn() to produce the trace output (default). C<:nowarn> Sends
+trace output directly to STDERR.
+
+=item :caller
+
+Add basic call information to the trace message, including from where
+the routine was called, and by whom. This is enabled by default.
+
+=item :stacktrace
+
+Add a stack trace (call history).
+
+=item :maxlen(I<length>)
+
+Truncate the length of the lines of trace information to I<length>
+characters.
+
+=back
+
+The following modifiers can be used to control the way Data::Dumper
+prints the values of parameters and return values. See also L<Data::Dumper>.
+
+=over 4
+
+=item :indent
+
+Controls the style of indentation. It can be set to 0, 1, 2 or 3.
+Style 0 spews output without any newlines, indentation, or spaces
+between list items. C<:indent(0)> is the default.
+
+=item :useqq
+
+When enabled, uses double quotes for representing string values.
+Whitespace other than space will be represented as C<[\n\t\r]>,
+"unsafe" characters will be backslashed, and unprintable characters
+will be output as quoted octal integers. This is the default,
+use C<:nouseqq> to disable.
+
+=item :maxdepth(I<depth>)
+
+Can be set to a positive integer that specifies the depth beyond which
+which we don't print structure contents. The default is 2, which means
+one level of array/hashes in argument lists and return values is expanded.
+If you use C<:nomaxdepth> or C<:maxdepth(0)>, nested structures are
+fully expanded.
+
+=item :quotekeys
+
+Controls wether hash keys are always printed quoted. The default is
+C<:noquotekeys>.
+
+=item sortkeys
+
+Controls whether hash keys are dumped in sorted order. The default is
+C<:nosortkeys>.
+
+=back
+
+Modifiers apply only to the subroutines that follow in the list of
+arguments.
+
+=head1 METHODS
+
+None, actually. Everything is handled by the module's import.
+
+=head1 ENVIRONMENT VARIABLES
+
+Environment variable C<PERL5DEBUGTRACE> can be used to preset initial
+modifiers, e.g.:
+
+ export PERL5DEBUGTRACE=":warn:indent(2):nomaxdepth:quotekeys"
+
+=head1 SEE ALSO
+
+L<Data::Dumper>, L<Carp>
+
+=head1 AUTHOR
+
+Jan-Pieter Cornet <jpc@cpan.org>;
+Jos Boumans <kane@cpan.org>;
+Johan Vromans <jv@cpan.org>;
+
+This is an Amsterdam.pm production. See http://amsterdam.pm.org.
+
+=head1 COPYRIGHT
+
+Copyright 2002 Amsterdam.pm. All rights reserved.
+
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
Added: packages/libdebug-trace-perl/branches/upstream/current/t/basic.t
===================================================================
--- packages/libdebug-trace-perl/branches/upstream/current/t/basic.t 2005-06-13 00:54:07 UTC (rev 1116)
+++ packages/libdebug-trace-perl/branches/upstream/current/t/basic.t 2005-06-13 00:55:11 UTC (rev 1117)
@@ -0,0 +1,64 @@
+# Basic tests for Debug::Trace -*-perl-*-
+
+#########################
+
+use Test;
+BEGIN { plan tests => 6 };
+
+# We need to catch the output for verification.
+BEGIN { $ENV{PERL5DEBUGTRACE} = ":warn" }
+
+use Debug::Trace qw(foo1 foo2);
+ok(1); # If we made it this far, we're ok.
+
+#########################
+
+sub foo1 {
+ wantarray ? (aa => "bb") : 42;
+}
+sub foo2 {
+ wantarray ? 42 : { aa => "bb" };
+}
+
+# warn() interceptor.
+my $msg;
+$SIG{__WARN__} = sub { $msg .= "@_" };
+
+my $fl; # file/line
+$msg = ""; $fl = join(" line ", __FILE__, __LINE__+1);
+foo1("blah");
+ok($msg,<<EOD);
+TRACE: main::foo1("blah") called at $fl package main
+TRACE: main::foo1() returned
+EOD
+
+$msg = ""; $fl = join(" line ", __FILE__, __LINE__+1);
+my @a = foo1(["blah","blech foo"]);
+ok($msg,<<EOD);
+TRACE: main::foo1(["blah","blech foo"]) called at $fl package main
+TRACE: main::foo1() returned: ("aa","bb")
+EOD
+
+$msg = ""; $fl = join(" line ", __FILE__, __LINE__+1);
+foo2(foo1(["blah" => "blech foo"], { "blah","blech foo" }));
+ok($msg,<<EOD);
+TRACE: main::foo1(["blah","blech foo"],{blah => "blech foo"}) called at $fl package main
+TRACE: main::foo1() returned: ("aa","bb")
+TRACE: main::foo2("aa","bb") called at $fl package main
+TRACE: main::foo2() returned
+EOD
+
+$msg = ""; $fl = join(" line ", __FILE__, __LINE__+1);
+if ( foo1("blah","blech foo") ) {}
+ok($msg,<<EOD);
+TRACE: main::foo1("blah","blech foo") called at $fl package main
+TRACE: main::foo1() returned: 42
+EOD
+
+$msg = ""; $fl = join(" line ", __FILE__, __LINE__+1);
+sub bar { foo1(1,2,[3,4]) }
+bar(3);
+ok($msg,<<EOD);
+TRACE: main::foo1(1,2,[3,4]) called at $fl sub main::bar
+TRACE: main::foo1() returned
+EOD
Added: packages/libdebug-trace-perl/branches/upstream/current/t/caller.t
===================================================================
--- packages/libdebug-trace-perl/branches/upstream/current/t/caller.t 2005-06-13 00:54:07 UTC (rev 1116)
+++ packages/libdebug-trace-perl/branches/upstream/current/t/caller.t 2005-06-13 00:55:11 UTC (rev 1117)
@@ -0,0 +1,41 @@
+# -*-perl-*-
+
+#########################
+
+use Test;
+BEGIN { plan tests => 2 };
+
+# We need to catch the output for verification.
+BEGIN { $ENV{PERL5DEBUGTRACE} = ":warn" }
+
+use Debug::Trace qw(x1 :nocaller x2 :caller x3 :nocaller x4);
+ok(1); # If we made it this far, we're ok.
+
+#########################
+
+my $l1 = __LINE__ + 1;
+sub x1 { x2(qw(a b c)) }
+my $l2 = __LINE__ + 1;
+sub x2 { x3(qw(x y z)) }
+my $l3 = __LINE__ + 1;
+sub x3 { x4(qw(1 2 3)) }
+my $l4 = __LINE__ + 1;
+sub x4 { "foo" }
+
+# warn() interceptor.
+my $msg;
+$SIG{__WARN__} = sub { $msg .= "@_" };
+
+my $fl;
+$msg = ""; $fl = __LINE__ + 1;
+x1("blah");
+ok($msg,<<EOD);
+TRACE: main::x1("blah") called at @{[__FILE__]} line $fl package main
+TRACE: main::x2("a","b","c")
+TRACE: main::x3("x","y","z") called at @{[__FILE__]} line $l2 sub main::x2
+TRACE: main::x4(1,2,3)
+TRACE: main::x4() returned
+TRACE: main::x3() returned
+TRACE: main::x2() returned
+TRACE: main::x1() returned
+EOD
Added: packages/libdebug-trace-perl/branches/upstream/current/t/maxlen.t
===================================================================
--- packages/libdebug-trace-perl/branches/upstream/current/t/maxlen.t 2005-06-13 00:54:07 UTC (rev 1116)
+++ packages/libdebug-trace-perl/branches/upstream/current/t/maxlen.t 2005-06-13 00:55:11 UTC (rev 1117)
@@ -0,0 +1,36 @@
+# Testing the :maxlen modifier -*-perl-*-
+
+#########################
+
+use Test;
+BEGIN { plan tests => 3 };
+
+# We need to catch the output for verification.
+BEGIN { $ENV{PERL5DEBUGTRACE} = ":warn" }
+
+use Debug::Trace qw(:maxlen(56) x1 :nomaxlen x2);
+ok(1); # If we made it this far, we're ok.
+
+#########################
+
+sub x1 { "foo" }
+sub x2 { "bar" }
+
+# warn() interceptor.
+my $msg;
+$SIG{__WARN__} = sub { $msg .= "@_" };
+
+my $fl;
+$msg = ""; $fl = __LINE__ + 1;
+my @foo = x1(qw(abcde abcdef abcdefg));
+ok($msg,<<EOD);
+TRACE: main::x1("abcde","abcdef","abcdefg") called at...
+TRACE: main::x1() returned: ("foo")
+EOD
+
+$msg = ""; $fl = __LINE__ + 1;
+my $bar = x2(qw(abcde abcdef abcdefg));
+ok($msg,<<EOD);
+TRACE: main::x2("abcde","abcdef","abcdefg") called at @{[__FILE__]} line $fl package main
+TRACE: main::x2() returned: "bar"
+EOD
Added: packages/libdebug-trace-perl/branches/upstream/current/t/stack.t
===================================================================
--- packages/libdebug-trace-perl/branches/upstream/current/t/stack.t 2005-06-13 00:54:07 UTC (rev 1116)
+++ packages/libdebug-trace-perl/branches/upstream/current/t/stack.t 2005-06-13 00:55:11 UTC (rev 1117)
@@ -0,0 +1,46 @@
+# -*-perl-*-
+
+#########################
+
+use Test;
+BEGIN { plan tests => 2 };
+
+# We need to catch the output for verification.
+BEGIN { $ENV{PERL5DEBUGTRACE} = ":warn" }
+
+use Debug::Trace qw(x1 :stacktrace x2 :nostacktrace x3 :stacktrace x4);
+ok(1); # If we made it this far, we're ok.
+
+#########################
+
+my $l1 = __LINE__ + 1;
+sub x1 { x2(qw(a b c)) }
+my $l2 = __LINE__ + 1;
+sub x2 { x3(qw(x y z)) }
+my $l3 = __LINE__ + 1;
+sub x3 { x4(qw(1 2 3)) }
+my $l4 = __LINE__ + 1;
+sub x4 { "foo" }
+
+# warn() interceptor.
+my $msg;
+$SIG{__WARN__} = sub { $msg .= "@_" };
+
+my $fl;
+$msg = ""; $fl = __LINE__ + 1;
+x1("blah");
+$msg =~ s/', '/','/g; # to match some older Carps
+ok($msg,<<EOD);
+TRACE: main::x1("blah") called at @{[__FILE__]} line $fl package main
+TRACE: main::x2("a","b","c") called at @{[__FILE__]} line $l1
+ main::x1('blah') called at @{[__FILE__]} line $fl
+TRACE: main::x3("x","y","z") called at @{[__FILE__]} line $l2 sub main::x2
+TRACE: main::x4(1,2,3) called at @{[__FILE__]} line $l3
+ main::x3('x','y','z') called at @{[__FILE__]} line $l2
+ main::x2('a','b','c') called at @{[__FILE__]} line $l1
+ main::x1('blah') called at @{[__FILE__]} line $fl
+TRACE: main::x4() returned
+TRACE: main::x3() returned
+TRACE: main::x2() returned
+TRACE: main::x1() returned
+EOD