[Bps-public-commit] r12754 - in Devel-CallTrace: . lib/Devel

[sartak at bestpractical.com]

Author: sartak
Date: Thu May 29 16:17:24 2008
New Revision: 12754

Added:
   Devel-CallTrace/t/2args.t
Modified:
   Devel-CallTrace/   (props changed)
   Devel-CallTrace/lib/Devel/CallTrace.pm

Log:
 r61271 at onn:  sartak | 2008-05-29 16:16:37 -0400
 Set $SUBS_MATCHING on import, so that users can say:
     perl -d:CallTrace="main::" script.pl
 or
     perl -d:CallTrace="^Net::Server|^HTTP::Server::Simple" sbin/rt-server
 :)


Modified: Devel-CallTrace/lib/Devel/CallTrace.pm
==============================================================================
--- Devel-CallTrace/lib/Devel/CallTrace.pm	(original)
+++ Devel-CallTrace/lib/Devel/CallTrace.pm	Thu May 29 16:17:24 2008
@@ -73,9 +73,12 @@
 BEGIN { $^P |= (0x01 | 0x80 | 0x100 | 0x200); };
 
 sub import {
+    my $self = shift;
+    my $re = shift;
 
-
+    $Devel::CallTrace::SUBS_MATCHING = qr/$re/;
 }
+
 package DB;
 
 # Any debugger needs to have a sub DB. It doesn't need to do anything.

Added: Devel-CallTrace/t/2args.t
==============================================================================
--- (empty file)
+++ Devel-CallTrace/t/2args.t	Thu May 29 16:17:24 2008
@@ -0,0 +1,42 @@
+#!/usr/bin/perl
+
+# I can't make this go with Test::More because we're hooking the symbol table
+use vars qw/@CALLED/;
+use Devel::CallTrace '::baz$';
+
+package DB;
+sub Devel::CallTrace::called {
+    my @args = ($_[0], $DB::sub, $_[1]);
+    push @main::CALLED, \@args;
+}
+package main;
+
+
+sub bar {
+  baz();
+}
+sub baz {
+1;
+}
+
+my $return = bar();
+
+package DB;
+
+eval "sub DB::sub  {&\$DB::sub};";
+
+package main;
+
+
+unless( scalar @CALLED == 1 ) { print "not "};
+print "ok 1 - There was one matching call\n";
+unless ($return ==1) { print "not "};
+print "ok 2\n";
+
+my $second = shift @CALLED;
+unless ($second->[0] == '2') { print "not "};
+print "ok 3 - Started with a depth of 2 ".$second->[0]."\n";
+unless ($second->[1] eq 'main::baz') { print "not "};
+print "ok 4 - baz was called second ".$second->[1]."\n";
+print "1..4\n";
+1;