Profile of Devel/Caller.pm

Filename	/home/doy/perl5/perlbrew/perls/perl-5.10.1/lib/site_perl/5.10.1/x86_64-linux/Devel/Caller.pm
Statements	Executed 27 statements in 5.92ms

Subroutines
Calls	P	F	Exclusive Time	Inclusive Time	Subroutine
1	1	1	8.84ms	13.3ms	Devel::Caller::::BEGIN@4 Devel::Caller::BEGIN@4
1	1	1	1.03ms	2.51ms	Devel::Caller::::BEGIN@5 Devel::Caller::BEGIN@5
1	1	1	110µs	138µs	MooseX::Params::Validate::::BEGIN@1MooseX::Params::Validate::BEGIN@1
1	1	1	69µs	69µs	Devel::Caller::::BEGIN@8 Devel::Caller::BEGIN@8
1	1	1	61µs	160µs	Devel::Caller::::BEGIN@3 Devel::Caller::BEGIN@3
1	1	1	36µs	275µs	Devel::Caller::::BEGIN@7 Devel::Caller::BEGIN@7
1	1	1	27µs	27µs	Devel::Caller::::BEGIN@6 Devel::Caller::BEGIN@6
0	0	0	0s	0s	Devel::Caller::::called_as_method Devel::Caller::called_as_method
0	0	0	0s	0s	Devel::Caller::::called_with Devel::Caller::called_with
0	0	0	0s	0s	Devel::Caller::::caller_args Devel::Caller::caller_args
0	0	0	0s	0s	Devel::Caller::::caller_cv Devel::Caller::caller_cv
0	0	0	0s	0s	Devel::Caller::::scan_forward Devel::Caller::scan_forward

Call graph for these subroutines as a Graphviz dot language file.

Line	State ments	Time on line	Calls	Time in subs	Code
1	3	202µs	2	165µs	# spent 138µs (110+27) within MooseX::Params::Validate::BEGIN@1 which was called: # once (110µs+27µs) by MooseX::Params::Validate::BEGIN@7 at line 1 use strict; # spent 138µs making 1 call to MooseX::Params::Validate::BEGIN@1 # spent 28µs making 1 call to strict::import
2					package Devel::Caller;
3	3	164µs	2	260µs	# spent 160µs (61+100) within Devel::Caller::BEGIN@3 which was called: # once (61µs+100µs) by MooseX::Params::Validate::BEGIN@7 at line 3 use warnings; # spent 160µs making 1 call to Devel::Caller::BEGIN@3 # spent 100µs making 1 call to warnings::import
4	3	643µs	2	13.4ms	# spent 13.3ms (8.84+4.47) within Devel::Caller::BEGIN@4 which was called: # once (8.84ms+4.47ms) by MooseX::Params::Validate::BEGIN@7 at line 4 use B; # spent 13.3ms making 1 call to Devel::Caller::BEGIN@4 # spent 124µs making 1 call to Exporter::import
5	3	514µs	1	2.51ms	# spent 2.51ms (1.03+1.48) within Devel::Caller::BEGIN@5 which was called: # once (1.03ms+1.48ms) by MooseX::Params::Validate::BEGIN@7 at line 5 use PadWalker (); # spent 2.51ms making 1 call to Devel::Caller::BEGIN@5
6	3	102µs	1	27µs	# spent 27µs within Devel::Caller::BEGIN@6 which was called: # once (27µs+0s) by MooseX::Params::Validate::BEGIN@7 at line 6 use XSLoader; # spent 27µs making 1 call to Devel::Caller::BEGIN@6
7	3	102µs	2	514µs	# spent 275µs (36+239) within Devel::Caller::BEGIN@7 which was called: # once (36µs+239µs) by MooseX::Params::Validate::BEGIN@7 at line 7 use base qw( Exporter ); # spent 275µs making 1 call to Devel::Caller::BEGIN@7 # spent 239µs making 1 call to base::import
8	3	3.52ms	1	69µs	# spent 69µs within Devel::Caller::BEGIN@8 which was called: # once (69µs+0s) by MooseX::Params::Validate::BEGIN@7 at line 8 use 5.008; # spent 69µs making 1 call to Devel::Caller::BEGIN@8
9
10	1	4µs			our $VERSION = '2.05';
11	1	630µs	1	600µs	XSLoader::load __PACKAGE__, $VERSION; # spent 600µs making 1 call to XSLoader::load
12
13	1	10µs			our @EXPORT_OK = qw( caller_cv caller_args caller_vars called_with called_as_method );
14
15					sub caller_cv {
16					my $level = shift;
17					my $cx = PadWalker::_upcontext($level + 1);
18					return unless $cx;
19					return _context_cv($cx);
20					}
21
22	1	2µs			our $DEBUG = 0;
23
24					sub scan_forward {
25					my $op = shift;
26					die "was expecting a pushmark, not a " . $op->name
27					if ($op->name ne "pushmark");
28
29					my @stack;
30					for (; $op && $op->name ne 'entersub'; $op = $op->next) {
31					print "SCAN op $op ", $op->name, "\n" if $DEBUG;
32					if ($op->name eq "pushmark") {
33					print "push $op\n" if $DEBUG;
34					push @stack, $op;
35					}
36					elsif (0) { # op consumes a mark
37					print "pop\n" if $DEBUG;
38					pop @stack;
39					}
40					}
41					return pop @stack;
42					}
43
44	1	6µs			*caller_vars = \&called_with;
45					sub called_with {
46					my $level = shift;
47					my $want_names = shift;
48
49					my $op = _context_op( PadWalker::_upcontext( $level + 1 ));
50					my $cv = caller_cv( $level + 2 );
51					my $pad = $cv ? B::svref_2object( $cv )->PADLIST : B::comppadlist;
52					my $padn = $pad->ARRAYelt( 0 );
53					my $padv = $pad->ARRAYelt( 1 );
54
55					print $op->name, "\n" if $DEBUG;
56					$op = scan_forward( $op );
57					print $op->name, "\n" if $DEBUG;
58
59					my @return;
60					my ($prev, $skip);
61					$skip = 0;
62					while (($prev = $op) && ($op = $op->next) && ($op->name ne "entersub")) {
63					print "op $op ", $op->name, "\n" if $DEBUG;
64					if ($op->name eq "pushmark") {
65					$skip = !$skip;
66					}
67					elsif ($op->name =~ "pad(sv\|av\|hv)") {
68					next if $skip;
69					print "PAD skip:$skip\n" if $DEBUG;
70
71					if ($op->next->next->name eq "sassign") {
72					$skip = 0;
73					next;
74					}
75
76					print "targ: ", $op->targ, "\n" if $DEBUG;
77					my $name = $padn->ARRAYelt( $op->targ )->PVX;
78					my $value = $padv->ARRAYelt( $op->targ )->object_2svref;
79					push @return, $want_names ? $name : $value;
80					next;
81					}
82					elsif ($op->name eq "gv") {
83					next;
84					}
85					elsif ($op->name =~ /gvsv\|rv2(av\|hv\|gv)/) {
86					print "GV skip:$skip\n" if $DEBUG;
87
88					if ($op->next->next->name eq "sassign") {
89					$skip = 0;
90					print "skipped\n" if $DEBUG;
91					next;
92					}
93
94					my $consider = ($op->name eq "gvsv") ? $op : $prev;
95					my $gv;
96
97					if (ref $consider eq 'B::PADOP') {
98					print "GV is really a padgv\n" if $DEBUG;
99					$gv = $padv->ARRAYelt( $consider->padix );
100					print "NEW GV $gv\n" if $DEBUG;
101					}
102					else {
103					$gv = $consider->gv;
104					}
105
106					print "consider: $consider ", $consider->name, " gv $gv\n"
107					if $DEBUG;
108
109					if ($want_names) {
110					my %sigils = (
111					"gvsv" => '$',
112					"rv2av" => '@',
113					"rv2hv" => '%',
114					"rv2gv" => '*',
115					);
116
117					push @return, $sigils{ $op->name } . $gv->STASH->NAME . "::" . $gv->SAFENAME;
118					}
119					else {
120					my %slots = (
121					"gvsv" => 'SCALAR',
122					"rv2av" => 'ARRAY',
123					"rv2hv" => 'HASH',
124					"rv2gv" => 'GLOB',
125					);
126					push @return, *{ $gv->object_2svref }{ $slots{ $op->name} };
127					}
128
129					next;
130					}
131					elsif ($op->name eq "const") {
132					print "const $op skip:$skip\n" if $DEBUG;
133					if ($op->next->next->name eq "sassign") {
134					$skip = 0;
135					next;
136					}
137
138					push @return, $want_names ? undef : $op->sv;
139					next;
140					}
141					}
142					return @return;
143					}
144
145
146					sub called_as_method {
147					my $level = shift \|\| 0;
148					my $op = _context_op( PadWalker::_upcontext( $level + 1 ));
149
150					print "called_as_method: $op\n" if $DEBUG;
151					die "was expecting a pushmark, not a ". $op->name
152					unless $op->name eq "pushmark";
153					while (($op = $op->next) && ($op->name ne "entersub")) {
154					print "method: ", $op->name, "\n" if $DEBUG;
155					return 1 if $op->name =~ /^method(?:_named)?$/;
156					}
157					return;
158					}
159
160
161					sub caller_args {
162					my $level = shift;
163					package DB;
164
- -
168	1	24µs			1;
169					__END__