annotate Lib/IMPL/Profiler.pm @ 94:79bf75223afe

Fixed security related bugs
author wizard
date Thu, 29 Apr 2010 01:31:27 +0400
parents 16ada169ca75
children 44977efed303
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
rev   line source
49
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
1 package IMPL::Profiler;
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
2
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
3 our $Enabled;
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
4 our %TrappedModules;
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
5 our %InvokeInfo;
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
6 our $InvokeTime = 0;
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
7 my $level;
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
8
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
9 BEGIN {
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
10 $level = 0;
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
11 if ($Enabled) {
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
12 warn "profiler enabled";
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
13 no warnings 'once';
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
14 *CORE::GLOBAL::caller = sub {
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
15 my $target = (shift || 0)+1;
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
16 my $realFrame = 1;
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
17
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
18 for (my $i = 1; $i<$target; $i++) {
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
19 $realFrame ++;
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
20 my $caller = CORE::caller($realFrame-1) or return;
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
21 $realFrame ++ if $caller eq 'IMPL::Profiler::Proxy'; #current frame is proxy
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
22 }
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
23
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
24 my @frame = CORE::caller($realFrame) or return;
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
25 if ( $frame[0] eq 'IMPL::Profiler::Proxy' ) {
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
26 my @next = CORE::caller($realFrame+1) or return;
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
27 @frame[0..2] = @next[0..2];
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
28 }
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
29
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
30 #warn "\t"x$level,"$frame[0] - $frame[3]";
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
31 return wantarray ? @frame : $frame[0];
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
32 };
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
33 }
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
34 }
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
35 use strict;
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
36 use warnings;
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
37 use Time::HiRes;
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
38 require Scalar::Util;
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
39
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
40
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
41
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
42 sub trap_all {
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
43 return if not $Enabled;
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
44 no strict 'refs';
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
45 foreach my $class (@_) {
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
46 next if $TrappedModules{$class};
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
47 $TrappedModules{$class} = 1;
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
48
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
49 eval "warn 'load $class'; require $class;" if not %{"${class}::"};
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
50 die $@ if $@;
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
51
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
52 no strict 'refs';
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
53 my $table = \%{"${class}::"};
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
54 trap($class,$_) foreach (grep *{$table->{$_}}{CODE}, keys %$table);
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
55 }
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
56 }
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
57
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
58 sub trap {
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
59 my ($class,$method) = @_;
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
60
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
61 return if not $Enabled;
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
62
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
63 no strict 'refs';
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
64 my $prevCode = \&{"${class}::${method}"};
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
65 my $proto = prototype $prevCode;
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
66
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
67 if (defined $proto and not $proto) {
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
68 return;
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
69 }
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
70 {
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
71 package IMPL::Profiler::Proxy;
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
72 no warnings 'redefine';
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
73 my $sub = sub {
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
74 my $t0 = [Time::HiRes::gettimeofday];
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
75 my @arr;
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
76 my $scalar;
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
77 my $entry = $prevCode;
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
78 my ($timeOwn,$timeTotal);
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
79 my $context = wantarray;
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
80 {
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
81 local $InvokeTime = 0;
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
82 #warn "\t"x$level,"enter ${class}::$method";
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
83 $level ++;
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
84 if ($context) {
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
85 @arr = &$entry(@_);
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
86 } else {
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
87 if (defined $context) {
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
88 $scalar = &$entry(@_);
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
89 } else {
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
90 &$entry(@_);
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
91 }
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
92 }
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
93 $timeTotal = Time::HiRes::tv_interval($t0);
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
94 $timeOwn = $timeTotal - $InvokeTime;
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
95 }
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
96 $InvokeInfo{"${class}::${method}"}{Count} ++;
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
97 $InvokeInfo{"${class}::${method}"}{Total} += $timeTotal;
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
98 $InvokeInfo{"${class}::${method}"}{Own} += $timeOwn;
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
99 $InvokeTime += $timeTotal;
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
100 $level --;
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
101 #warn "\t"x$level,"leave ${class}::$method";
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
102 return $context ? @arr : $scalar;
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
103 };
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
104 if ($proto) {
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
105 Scalar::Util::set_prototype($sub => $proto);
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
106 }
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
107 *{"${class}::${method}"} = $sub;
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
108 }
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
109
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
110 }
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
111
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
112 sub PrintStatistics {
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
113 my $hout = shift || *STDERR;
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
114 print $hout "-- modules --\n";
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
115 print $hout "$_\n" foreach sort keys %TrappedModules;
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
116 print $hout "\n-- stats --\n";
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
117 print $hout
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
118 pad($_,50),
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
119 pad("$InvokeInfo{$_}{Count}",10),
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
120 pad(sprintf("%.3f",$InvokeInfo{$_}{Own}),10),
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
121 pad(sprintf("%.3f",$InvokeInfo{$_}{Total}),10),
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
122 "\n"
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
123 foreach sort { $InvokeInfo{$b}{Own} <=> $InvokeInfo{$a}{Own} } keys %InvokeInfo;
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
124 }
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
125
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
126 sub ResetStatistics {
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
127 $InvokeTime = 0;
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
128 %InvokeInfo = ();
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
129 }
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
130
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
131 sub pad {
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
132 my ($str,$len) = @_;
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
133 if (length $str < $len) {
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
134 return $str.(' 'x ($len- length $str));
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
135 } else {
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
136 return $str;
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
137 }
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
138 }
16ada169ca75 migrating to the Eclipse IDE
wizard@linux-odin.local
parents: 0
diff changeset
139 1;