Profile of Log/Log4perl/Layout/PatternLayout.pm

← Index
NYTProf Performance Profile «block view•line view•sub view»
For xt/tapper-mcp-scheduler-with-db-longrun.t
Run on Tue May 22 17:18:39 2012
Reported on Tue May 22 17:22:35 2012

Filename | /2home/ss5/perl5/perlbrew/perls/perl-5.12.3/lib/site_perl/5.12.3/Log/Log4perl/Layout/PatternLayout.pm
Statements | Executed 86 statements in 2.64ms

Subroutines
Calls | P | F | Exclusive Time | Inclusive Time | Subroutine
--- | --- | --- | --- | --- | ---
1 | 1 | 1 | 1.16ms | 1.21ms | Log::Log4perl::Layout::PatternLayout::::BEGIN@15Log::Log4perl::Layout::PatternLayout::BEGIN@15
1 | 1 | 1 | 1.12ms | 1.32ms | Log::Log4perl::Layout::PatternLayout::::BEGIN@20Log::Log4perl::Layout::PatternLayout::BEGIN@20
1 | 1 | 1 | 481µs | 1.54ms | Log::Log4perl::Layout::PatternLayout::::BEGIN@18Log::Log4perl::Layout::PatternLayout::BEGIN@18
1 | 1 | 1 | 240µs | 291µs | Log::Log4perl::Layout::PatternLayout::::BEGIN@16Log::Log4perl::Layout::PatternLayout::BEGIN@16
1 | 1 | 1 | 205µs | 250µs | Log::Log4perl::Layout::PatternLayout::::BEGIN@17Log::Log4perl::Layout::PatternLayout::BEGIN@17
1 | 1 | 1 | 53µs | 197µs | Log::Log4perl::Layout::PatternLayout::::newLog::Log4perl::Layout::PatternLayout::new
1 | 1 | 1 | 39µs | 82µs | Log::Log4perl::Layout::PatternLayout::::defineLog::Log4perl::Layout::PatternLayout::define
1 | 1 | 1 | 23µs | 23µs | Log::Log4perl::Layout::PatternLayout::::BEGIN@5Log::Log4perl::Layout::PatternLayout::BEGIN@5
1 | 1 | 1 | 22µs | 22µs | Log::Log4perl::Layout::PatternLayout::::CORE:regcompLog::Log4perl::Layout::PatternLayout::CORE:regcomp (opcode)
1 | 1 | 1 | 12µs | 52µs | Log::Log4perl::Layout::PatternLayout::::BEGIN@11Log::Log4perl::Layout::PatternLayout::BEGIN@11
1 | 1 | 1 | 12µs | 12µs | Log::Log4perl::Layout::PatternLayout::::repLog::Log4perl::Layout::PatternLayout::rep
1 | 1 | 1 | 11µs | 59µs | Log::Log4perl::Layout::PatternLayout::::BEGIN@29Log::Log4perl::Layout::PatternLayout::BEGIN@29
3 | 3 | 1 | 11µs | 11µs | Log::Log4perl::Layout::PatternLayout::::CORE:substLog::Log4perl::Layout::PatternLayout::CORE:subst (opcode)
1 | 1 | 1 | 8µs | 79µs | Log::Log4perl::Layout::PatternLayout::::BEGIN@38Log::Log4perl::Layout::PatternLayout::BEGIN@38
1 | 1 | 1 | 8µs | 21µs | Log::Log4perl::Layout::PatternLayout::::BEGIN@40Log::Log4perl::Layout::PatternLayout::BEGIN@40
1 | 1 | 1 | 7µs | 9µs | Log::Log4perl::Layout::PatternLayout::::BEGIN@6Log::Log4perl::Layout::PatternLayout::BEGIN@6
1 | 1 | 1 | 7µs | 15µs | Log::Log4perl::Layout::PatternLayout::::BEGIN@7Log::Log4perl::Layout::PatternLayout::BEGIN@7
1 | 1 | 1 | 7µs | 48µs | Log::Log4perl::Layout::PatternLayout::::BEGIN@9Log::Log4perl::Layout::PatternLayout::BEGIN@9
1 | 1 | 1 | 6µs | 48µs | Log::Log4perl::Layout::PatternLayout::::BEGIN@14Log::Log4perl::Layout::PatternLayout::BEGIN@14
1 | 1 | 1 | 6µs | 6µs | Log::Log4perl::Layout::PatternLayout::::BEGIN@19Log::Log4perl::Layout::PatternLayout::BEGIN@19
1 | 1 | 1 | 5µs | 5µs | Log::Log4perl::Layout::PatternLayout::::BEGIN@13Log::Log4perl::Layout::PatternLayout::BEGIN@13
1 | 1 | 1 | 4µs | 4µs | Log::Log4perl::Layout::PatternLayout::::BEGIN@12Log::Log4perl::Layout::PatternLayout::BEGIN@12
2 | 1 | 1 | 2µs | 2µs | Log::Log4perl::Layout::PatternLayout::::CORE:substcontLog::Log4perl::Layout::PatternLayout::CORE:substcont (opcode)
1 | 1 | 1 | 200ns | 200ns | Log::Log4perl::Layout::PatternLayout::::CORE:matchLog::Log4perl::Layout::PatternLayout::CORE:match (opcode)
0 | 0 | 0 | 0s | 0s | Log::Log4perl::Layout::PatternLayout::::add_global_cspecLog::Log4perl::Layout::PatternLayout::add_global_cspec
0 | 0 | 0 | 0s | 0s | Log::Log4perl::Layout::PatternLayout::::add_layout_cspecLog::Log4perl::Layout::PatternLayout::add_layout_cspec
0 | 0 | 0 | 0s | 0s | Log::Log4perl::Layout::PatternLayout::::callinfo_dumpLog::Log4perl::Layout::PatternLayout::callinfo_dump
0 | 0 | 0 | 0s | 0s | Log::Log4perl::Layout::PatternLayout::::curly_actionLog::Log4perl::Layout::PatternLayout::curly_action
0 | 0 | 0 | 0s | 0s | Log::Log4perl::Layout::PatternLayout::::renderLog::Log4perl::Layout::PatternLayout::render
0 | 0 | 0 | 0s | 0s | Log::Log4perl::Layout::PatternLayout::::shrink_categoryLog::Log4perl::Layout::PatternLayout::shrink_category

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

Line | State ments | Time on line | Calls | Time in subs | Code
--- | --- | --- | --- | --- | ---
1 |  |  |  |  | ##################################################
2 |  |  |  |  | package Log::Log4perl::Layout::PatternLayout;
3 |  |  |  |  | ##################################################
4 |  |  |  |  |
5 | 3 | 32µs | 1 | 23µs | # spent 23µs within Log::Log4perl::Layout::PatternLayout::BEGIN@5 which was called: # once (23µs+0s) by Log::Log4perl::Layout::BEGIN@5 at line 5 use 5.006; # spent 23µs making 1 call to Log::Log4perl::Layout::PatternLayout::BEGIN@5
6 | 3 | 20µs | 2 | 11µs | # spent 9µs (7+2) within Log::Log4perl::Layout::PatternLayout::BEGIN@6 which was called: # once (7µs+2µs) by Log::Log4perl::Layout::BEGIN@5 at line 6 use strict; # spent 9µs making 1 call to Log::Log4perl::Layout::PatternLayout::BEGIN@6 # spent 2µs making 1 call to strict::import
7 | 3 | 18µs | 2 | 23µs | # spent 15µs (7+8) within Log::Log4perl::Layout::PatternLayout::BEGIN@7 which was called: # once (7µs+8µs) by Log::Log4perl::Layout::BEGIN@5 at line 7 use warnings; # spent 15µs making 1 call to Log::Log4perl::Layout::PatternLayout::BEGIN@7 # spent 8µs making 1 call to warnings::import
8 |  |  |  |  |
9 | 3 | 18µs | 2 | 90µs | # spent 48µs (7+42) within Log::Log4perl::Layout::PatternLayout::BEGIN@9 which was called: # once (7µs+42µs) by Log::Log4perl::Layout::BEGIN@5 at line 9 use constant _INTERNAL_DEBUG => 0; # spent 48µs making 1 call to Log::Log4perl::Layout::PatternLayout::BEGIN@9 # spent 42µs making 1 call to constant::import
10 |  |  |  |  |
11 | 3 | 19µs | 2 | 92µs | # spent 52µs (12+40) within Log::Log4perl::Layout::PatternLayout::BEGIN@11 which was called: # once (12µs+40µs) by Log::Log4perl::Layout::BEGIN@5 at line 11 use Carp; # spent 52µs making 1 call to Log::Log4perl::Layout::PatternLayout::BEGIN@11 # spent 40µs making 1 call to Exporter::import
12 | 3 | 19µs | 1 | 4µs | # spent 4µs within Log::Log4perl::Layout::PatternLayout::BEGIN@12 which was called: # once (4µs+0s) by Log::Log4perl::Layout::BEGIN@5 at line 12 use Log::Log4perl; # spent 4µs making 1 call to Log::Log4perl::Layout::PatternLayout::BEGIN@12
13 | 3 | 17µs | 1 | 5µs | # spent 5µs within Log::Log4perl::Layout::PatternLayout::BEGIN@13 which was called: # once (5µs+0s) by Log::Log4perl::Layout::BEGIN@5 at line 13 use Log::Log4perl::Util; # spent 5µs making 1 call to Log::Log4perl::Layout::PatternLayout::BEGIN@13
14 | 3 | 17µs | 2 | 90µs | # spent 48µs (6+42) within Log::Log4perl::Layout::PatternLayout::BEGIN@14 which was called: # once (6µs+42µs) by Log::Log4perl::Layout::BEGIN@5 at line 14 use Log::Log4perl::Level; # spent 48µs making 1 call to Log::Log4perl::Layout::PatternLayout::BEGIN@14 # spent 42µs making 1 call to Log::Log4perl::Level::import
15 | 3 | 92µs | 1 | 1.21ms | # spent 1.21ms (1.16+54µs) within Log::Log4perl::Layout::PatternLayout::BEGIN@15 which was called: # once (1.16ms+54µs) by Log::Log4perl::Layout::BEGIN@5 at line 15 use Log::Log4perl::DateFormat; # spent 1.21ms making 1 call to Log::Log4perl::Layout::PatternLayout::BEGIN@15
16 | 3 | 78µs | 1 | 291µs | # spent 291µs (240+52) within Log::Log4perl::Layout::PatternLayout::BEGIN@16 which was called: # once (240µs+52µs) by Log::Log4perl::Layout::BEGIN@5 at line 16 use Log::Log4perl::NDC; # spent 291µs making 1 call to Log::Log4perl::Layout::PatternLayout::BEGIN@16
17 | 3 | 70µs | 1 | 250µs | # spent 250µs (205+45) within Log::Log4perl::Layout::PatternLayout::BEGIN@17 which was called: # once (205µs+45µs) by Log::Log4perl::Layout::BEGIN@5 at line 17 use Log::Log4perl::MDC; # spent 250µs making 1 call to Log::Log4perl::Layout::PatternLayout::BEGIN@17
18 | 3 | 85µs | 1 | 1.54ms | # spent 1.54ms (481µs+1.06) within Log::Log4perl::Layout::PatternLayout::BEGIN@18 which was called: # once (481µs+1.06ms) by Log::Log4perl::Layout::BEGIN@5 at line 18 use Log::Log4perl::Util::TimeTracker; # spent 1.54ms making 1 call to Log::Log4perl::Layout::PatternLayout::BEGIN@18
19 | 3 | 19µs | 1 | 6µs | # spent 6µs within Log::Log4perl::Layout::PatternLayout::BEGIN@19 which was called: # once (6µs+0s) by Log::Log4perl::Layout::BEGIN@5 at line 19 use File::Spec; # spent 6µs making 1 call to Log::Log4perl::Layout::PatternLayout::BEGIN@19
20 | 3 | 177µs | 2 | 1.37ms | # spent 1.32ms (1.12+202µs) within Log::Log4perl::Layout::PatternLayout::BEGIN@20 which was called: # once (1.12ms+202µs) by Log::Log4perl::Layout::BEGIN@5 at line 20 use File::Basename; # spent 1.32ms making 1 call to Log::Log4perl::Layout::PatternLayout::BEGIN@20 # spent 53µs making 1 call to Exporter::import
21 |  |  |  |  |
22 | 1 | 600ns |  |  | our $TIME_HIRES_AVAILABLE_WARNED = 0;
23 | 1 | 200ns |  |  | our $HOSTNAME;
24 |  |  |  |  |
25 | 1 | 2µs |  |  | our %GLOBAL_USER_DEFINED_CSPECS = ();
26 |  |  |  |  |
27 | 1 | 400ns |  |  | our $CSPECS = 'cCdFHIlLmMnpPrRtTxX%';
28 |  |  |  |  |
29 |  |  |  |  | # spent 59µs (11+47) within Log::Log4perl::Layout::PatternLayout::BEGIN@29 which was called: # once (11µs+47µs) by Log::Log4perl::Layout::BEGIN@5 at line 36 BEGIN {
30 |  |  |  |  | # Check if we've got Sys::Hostname. If not, just punt.
31 | 4 | 8µs |  |  | $HOSTNAME = "unknown.host";
32 |  |  | 1 | 29µs | if(Log::Log4perl::Util::module_available("Sys::Hostname")) { # spent 29µs making 1 call to Log::Log4perl::Util::module_available
33 |  |  |  |  | require Sys::Hostname;
34 |  |  | 1 | 18µs | $HOSTNAME = Sys::Hostname::hostname(); # spent 18µs making 1 call to Sys::Hostname::hostname
35 |  |  |  |  | }
36 | 1 | 17µs | 1 | 59µs | } # spent 59µs making 1 call to Log::Log4perl::Layout::PatternLayout::BEGIN@29
37 |  |  |  |  |
38 | 3 | 22µs | 2 | 79µs | # spent 79µs (8+70) within Log::Log4perl::Layout::PatternLayout::BEGIN@38 which was called: # once (8µs+70µs) by Log::Log4perl::Layout::BEGIN@5 at line 38 use base qw(Log::Log4perl::Layout); # spent 79µs making 1 call to Log::Log4perl::Layout::PatternLayout::BEGIN@38 # spent 70µs making 1 call to base::import, recursion: max depth 1, sum of overlapping time 70µs
39 |  |  |  |  |
40 | 3 | 1.76ms | 2 | 35µs | # spent 21µs (8+13) within Log::Log4perl::Layout::PatternLayout::BEGIN@40 which was called: # once (8µs+13µs) by Log::Log4perl::Layout::BEGIN@5 at line 40 no strict qw(refs); # spent 21µs making 1 call to Log::Log4perl::Layout::PatternLayout::BEGIN@40 # spent 13µs making 1 call to strict::unimport
41 |  |  |  |  |
42 |  |  |  |  | ##################################################
43 |  |  |  |  | # spent 197µs (53+144) within Log::Log4perl::Layout::PatternLayout::new which was called: # once (53µs+144µs) by Log::Log4perl::BEGIN@12 at line 36 of Log/Log4perl/Logger.pm sub new {
44 |  |  |  |  | ##################################################
45 | 16 | 53µs |  |  | my $class = shift;
46 |  |  |  |  | $class = ref ($class) || $class;
47 |  |  |  |  |
48 |  |  |  |  | my $options = ref $_[0] eq "HASH" ? shift : {};
49 |  |  |  |  | my $layout_string = @_ ? shift : '%m%n';
50 |  |  |  |  |
51 |  |  |  |  | my $self = {
52 |  |  |  |  | format => undef,
53 |  |  |  |  | info_needed => {},
54 |  |  |  |  | stack => [],
55 |  |  |  |  | CSPECS => $CSPECS,
56 |  |  |  |  | dontCollapseArrayRefs => $options->{dontCollapseArrayRefs}{value},
57 |  |  |  |  | last_time => undef,
58 |  |  |  |  | };
59 |  |  |  |  |
60 |  |  | 1 | 59µs | $self->{timer} = Log::Log4perl::Util::TimeTracker->new( # spent 59µs making 1 call to Log::Log4perl::Util::TimeTracker::new
61 |  |  |  |  | time_function => $options->{time_function}
62 |  |  |  |  | );
63 |  |  |  |  |
64 |  |  |  |  | if(exists $options->{ConversionPattern}->{value}) {
65 |  |  |  |  | $layout_string = $options->{ConversionPattern}->{value};
66 |  |  |  |  | }
67 |  |  |  |  |
68 |  |  |  |  | if(exists $options->{message_chomp_before_newline}) {
69 |  |  |  |  | $self->{message_chomp_before_newline} =
70 |  |  |  |  | $options->{message_chomp_before_newline}->{value};
71 |  |  |  |  | } else {
72 |  |  |  |  | $self->{message_chomp_before_newline} = 1;
73 |  |  |  |  | }
74 |  |  |  |  |
75 |  |  |  |  | bless $self, $class;
76 |  |  |  |  |
77 |  |  |  |  | #add the global user-defined cspecs
78 |  |  |  |  | foreach my $f (keys %GLOBAL_USER_DEFINED_CSPECS){
79 |  |  |  |  | #add it to the list of letters
80 |  |  |  |  | $self->{CSPECS} .= $f;
81 |  |  |  |  | #for globals, the coderef is already evaled,
82 |  |  |  |  | $self->{USER_DEFINED_CSPECS}{$f} = $GLOBAL_USER_DEFINED_CSPECS{$f};
83 |  |  |  |  | }
84 |  |  |  |  |
85 |  |  |  |  | #add the user-defined cspecs local to this appender
86 |  |  |  |  | foreach my $f (keys %{$options->{cspec}}){
87 |  |  |  |  | $self->add_layout_cspec($f, $options->{cspec}{$f}{value});
88 |  |  |  |  | }
89 |  |  |  |  |
90 |  |  |  |  | # non-portable line breaks
91 |  |  | 1 | 2µs | $layout_string =~ s/\\n/\n/g; # spent 2µs making 1 call to Log::Log4perl::Layout::PatternLayout::CORE:subst
92 |  |  | 1 | 500ns | $layout_string =~ s/\\r/\r/g; # spent 500ns making 1 call to Log::Log4perl::Layout::PatternLayout::CORE:subst
93 |  |  |  |  |
94 |  |  | 1 | 82µs | $self->define($layout_string); # spent 82µs making 1 call to Log::Log4perl::Layout::PatternLayout::define
95 |  |  |  |  |
96 |  |  |  |  | return $self;
97 |  |  |  |  | }
98 |  |  |  |  |
99 |  |  |  |  | ##################################################
100 |  |  |  |  | # spent 82µs (39+44) within Log::Log4perl::Layout::PatternLayout::define which was called: # once (39µs+44µs) by Log::Log4perl::Layout::PatternLayout::new at line 94 sub define {
101 |  |  |  |  | ##################################################
102 | 6 | 71µs |  |  | my($self, $format) = @_;
103 |  |  |  |  |
104 |  |  |  |  | # If the message contains a %m followed by a newline,
105 |  |  |  |  | # make a note of that so that we can cut a superfluous
106 |  |  |  |  | # \n off the message later on
107 |  |  | 1 | 200ns | if($self->{message_chomp_before_newline} and $format =~ /%m%n/) { # spent 200ns making 1 call to Log::Log4perl::Layout::PatternLayout::CORE:match
108 |  |  |  |  | $self->{message_chompable} = 1;
109 |  |  |  |  | } else {
110 |  |  |  |  | $self->{message_chompable} = 0;
111 |  |  |  |  | }
112 |  |  |  |  |
113 |  |  |  |  | # Parse the format
114 |  |  | 4 | 32µs | $format =~ s/%(-?\d*(?:\.\d+)?) # spent 22µs making 1 call to Log::Log4perl::Layout::PatternLayout::CORE:regcomp # spent 8µs making 1 call to Log::Log4perl::Layout::PatternLayout::CORE:subst # spent 2µs making 2 calls to Log::Log4perl::Layout::PatternLayout::CORE:substcont, avg 1µs/call
115 |  |  | 1 | 12µs | ([$self->{CSPECS}]) # spent 12µs making 1 call to Log::Log4perl::Layout::PatternLayout::rep
116 |  |  |  |  | (?:{(.*?)})*/
117 |  |  |  |  | rep($self, $1, $2, $3);
118 |  |  |  |  | /gex;
119 |  |  |  |  |
120 |  |  |  |  | $self->{printformat} = $format;
121 |  |  |  |  | }
122 |  |  |  |  |
123 |  |  |  |  | ##################################################
124 |  |  |  |  | # spent 12µs within Log::Log4perl::Layout::PatternLayout::rep which was called: # once (12µs+0s) by Log::Log4perl::Layout::PatternLayout::define at line 115 sub rep {
125 |  |  |  |  | ##################################################
126 | 7 | 14µs |  |  | my($self, $num, $op, $curlies) = @_;
127 |  |  |  |  |
128 |  |  |  |  | return "%%" if $op eq "%";
129 |  |  |  |  |
130 |  |  |  |  | # If it's a %d{...} construct, initialize a simple date
131 |  |  |  |  | # format formatter, so that we can quickly render later on.
132 |  |  |  |  | # If it's just %d, assume %d{yyyy/MM/dd HH:mm:ss}
133 |  |  |  |  | my $sdf;
134 |  |  |  |  | if($op eq "d") {
135 |  |  |  |  | if(defined $curlies) {
136 |  |  |  |  | $sdf = Log::Log4perl::DateFormat->new($curlies);
137 |  |  |  |  | } else {
138 |  |  |  |  | $sdf = Log::Log4perl::DateFormat->new("yyyy/MM/dd HH:mm:ss");
139 |  |  |  |  | }
140 |  |  |  |  | }
141 |  |  |  |  |
142 |  |  |  |  | push @{$self->{stack}}, [$op, $sdf || $curlies];
143 |  |  |  |  |
144 |  |  |  |  | $self->{info_needed}->{$op}++;
145 |  |  |  |  |
146 |  |  |  |  | return "%${num}s";
147 |  |  |  |  | }
148 |  |  |  |  |
149 |  |  |  |  | ##################################################
150 |  |  |  |  | sub render {
151 |  |  |  |  | ##################################################
152 |  |  |  |  | my($self, $message, $category, $priority, $caller_level) = @_;
153 |  |  |  |  |
154 |  |  |  |  | $caller_level = 0 unless defined $caller_level;
155 |  |  |  |  |
156 |  |  |  |  | my %info = ();
157 |  |  |  |  |
158 |  |  |  |  | $info{m} = $message;
159 |  |  |  |  | # See 'define'
160 |  |  |  |  | chomp $info{m} if $self->{message_chompable};
161 |  |  |  |  |
162 |  |  |  |  | my @results = ();
163 |  |  |  |  |
164 |  |  |  |  | if($self->{info_needed}->{L} or
165 |  |  |  |  | $self->{info_needed}->{F} or
166 |  |  |  |  | $self->{info_needed}->{C} or
167 |  |  |  |  | $self->{info_needed}->{l} or
168 |  |  |  |  | $self->{info_needed}->{M} or
169 |  |  |  |  | $self->{info_needed}->{T} or
170 |  |  |  |  | 0
171 |  |  |  |  | ) {
172 |  |  |  |  | my ($package, $filename, $line,
173 |  |  |  |  | $subroutine, $hasargs,
174 |  |  |  |  | $wantarray, $evaltext, $is_require,
175 |  |  |  |  | $hints, $bitmask);
176 |  |  |  |  |
177 |  |  |  |  | {
178 |  |  |  |  | ($package, $filename, $line,
179 |  |  |  |  | $subroutine, $hasargs,
180 |  |  |  |  | $wantarray, $evaltext, $is_require,
181 |  |  |  |  | $hints, $bitmask) = my @callinfo =
182 |  |  |  |  | caller($caller_level);
183 |  |  |  |  |
184 |  |  |  |  | if(_INTERNAL_DEBUG) {
185 |  |  |  |  | callinfo_dump( $caller_level, \@callinfo );
186 |  |  |  |  | }
187 |  |  |  |  |
188 |  |  |  |  | if(exists $Log::Log4perl::WRAPPERS_REGISTERED{$package}) {
189 |  |  |  |  | # We hit a predefined wrapper, step up to the next frame.
190 |  |  |  |  | if(_INTERNAL_DEBUG) {
191 |  |  |  |  | print "[$package] recognized as a wrapper, increasing ",
192 |  |  |  |  | "caller level (currently $caller_level)\n";
193 |  |  |  |  | }
194 |  |  |  |  | $caller_level++;
195 |  |  |  |  | redo;
196 |  |  |  |  | }
197 |  |  |  |  | }
198 |  |  |  |  |
199 |  |  |  |  | # If caller() choked because of a whacko caller level,
200 |  |  |  |  | # correct undefined values to '[undef]' in order to prevent
201 |  |  |  |  | # warning messages when interpolating later
202 |  |  |  |  | unless(defined $bitmask) {
203 |  |  |  |  | for($package,
204 |  |  |  |  | $filename, $line,
205 |  |  |  |  | $subroutine, $hasargs,
206 |  |  |  |  | $wantarray, $evaltext, $is_require,
207 |  |  |  |  | $hints, $bitmask) {
208 |  |  |  |  | $_ = '[undef]' unless defined $_;
209 |  |  |  |  | }
210 |  |  |  |  | }
211 |  |  |  |  |
212 |  |  |  |  | $info{L} = $line;
213 |  |  |  |  | $info{F} = $filename;
214 |  |  |  |  | $info{C} = $package;
215 |  |  |  |  |
216 |  |  |  |  | if($self->{info_needed}->{M} or
217 |  |  |  |  | $self->{info_needed}->{l} or
218 |  |  |  |  | 0) {
219 |  |  |  |  | # To obtain the name of the subroutine which triggered the
220 |  |  |  |  | # logger, we need to go one additional level up.
221 |  |  |  |  | my $levels_up = 1;
222 |  |  |  |  | {
223 |  |  |  |  | my @callinfo = caller($caller_level+$levels_up);
224 |  |  |  |  |
225 |  |  |  |  | if(_INTERNAL_DEBUG) {
226 |  |  |  |  | callinfo_dump( $caller_level, \@callinfo );
227 |  |  |  |  | }
228 |  |  |  |  |
229 |  |  |  |  | $subroutine = $callinfo[3];
230 |  |  |  |  | # If we're inside an eval, go up one level further.
231 |  |  |  |  | if(defined $subroutine and
232 |  |  |  |  | $subroutine eq "(eval)") {
233 |  |  |  |  | print "Inside an eval, one up\n" if _INTERNAL_DEBUG;
234 |  |  |  |  | $levels_up++;
235 |  |  |  |  | redo;
236 |  |  |  |  | }
237 |  |  |  |  | }
238 |  |  |  |  | $subroutine = "main::" unless $subroutine;
239 |  |  |  |  | print "Subroutine is '$subroutine'\n" if _INTERNAL_DEBUG;
240 |  |  |  |  | $info{M} = $subroutine;
241 |  |  |  |  | $info{l} = "$subroutine $filename ($line)";
242 |  |  |  |  | }
243 |  |  |  |  | }
244 |  |  |  |  |
245 |  |  |  |  | $info{X} = "[No curlies defined]";
246 |  |  |  |  | $info{x} = Log::Log4perl::NDC->get() if $self->{info_needed}->{x};
247 |  |  |  |  | $info{c} = $category;
248 |  |  |  |  | $info{d} = 1; # Dummy value, corrected later
249 |  |  |  |  | $info{n} = "\n";
250 |  |  |  |  | $info{p} = $priority;
251 |  |  |  |  | $info{P} = $$;
252 |  |  |  |  | $info{H} = $HOSTNAME;
253 |  |  |  |  |
254 |  |  |  |  | my $current_time;
255 |  |  |  |  |
256 |  |  |  |  | if($self->{info_needed}->{r} or $self->{info_needed}->{R}) {
257 |  |  |  |  | if(!$TIME_HIRES_AVAILABLE_WARNED++ and
258 |  |  |  |  | !$self->{timer}->hires_available()) {
259 |  |  |  |  | warn "Requested %r/%R pattern without installed Time::HiRes\n";
260 |  |  |  |  | }
261 |  |  |  |  | $current_time = [$self->{timer}->gettimeofday()];
262 |  |  |  |  | }
263 |  |  |  |  |
264 |  |  |  |  | if($self->{info_needed}->{r}) {
265 |  |  |  |  | $info{r} = $self->{timer}->milliseconds( $current_time );
266 |  |  |  |  | }
267 |  |  |  |  | if($self->{info_needed}->{R}) {
268 |  |  |  |  | $info{R} = $self->{timer}->delta_milliseconds( $current_time );
269 |  |  |  |  | }
270 |  |  |  |  |
271 |  |  |  |  | # Stack trace wanted?
272 |  |  |  |  | if($self->{info_needed}->{T}) {
273 |  |  |  |  | local $Carp::CarpLevel =
274 |  |  |  |  | $Carp::CarpLevel + $caller_level;
275 |  |  |  |  | my $mess = Carp::longmess();
276 |  |  |  |  | chomp($mess);
277 |  |  |  |  | # $mess =~ s/(?:\A\s*at.*\n|^\s*Log::Log4perl.*\n|^\s*)//mg;
278 |  |  |  |  | $mess =~ s/(?:\A\s*at.*\n|^\s*)//mg;
279 |  |  |  |  | $mess =~ s/\n/, /g;
280 |  |  |  |  | $info{T} = $mess;
281 |  |  |  |  | }
282 |  |  |  |  |
283 |  |  |  |  | # As long as they're not implemented yet ..
284 |  |  |  |  | $info{t} = "N/A";
285 |  |  |  |  |
286 |  |  |  |  | # Iterate over all info fields on the stack
287 |  |  |  |  | for my $e (@{$self->{stack}}) {
288 |  |  |  |  | my($op, $curlies) = @$e;
289 |  |  |  |  |
290 |  |  |  |  | my $result;
291 |  |  |  |  |
292 |  |  |  |  | if(exists $self->{USER_DEFINED_CSPECS}->{$op}) {
293 |  |  |  |  | next unless $self->{info_needed}->{$op};
294 |  |  |  |  | $self->{curlies} = $curlies;
295 |  |  |  |  | $result = $self->{USER_DEFINED_CSPECS}->{$op}->($self,
296 |  |  |  |  | $message, $category, $priority,
297 |  |  |  |  | $caller_level+1);
298 |  |  |  |  | } elsif(exists $info{$op}) {
299 |  |  |  |  | $result = $info{$op};
300 |  |  |  |  | if($curlies) {
301 |  |  |  |  | $result = $self->curly_action($op, $curlies, $info{$op});
302 |  |  |  |  | } else {
303 |  |  |  |  | # just for %d
304 |  |  |  |  | if($op eq 'd') {
305 |  |  |  |  | $result = $info{$op}->format($self->{timer}->gettimeofday());
306 |  |  |  |  | }
307 |  |  |  |  | }
308 |  |  |  |  | } else {
309 |  |  |  |  | warn "Format %'$op' not implemented (yet)";
310 |  |  |  |  | $result = "FORMAT-ERROR";
311 |  |  |  |  | }
312 |  |  |  |  |
313 |  |  |  |  | $result = "[undef]" unless defined $result;
314 |  |  |  |  | push @results, $result;
315 |  |  |  |  | }
316 |  |  |  |  |
317 |  |  |  |  | return (sprintf $self->{printformat}, @results);
318 |  |  |  |  | }
319 |  |  |  |  |
320 |  |  |  |  | ##################################################
321 |  |  |  |  | sub curly_action {
322 |  |  |  |  | ##################################################
323 |  |  |  |  | my($self, $ops, $curlies, $data) = @_;
324 |  |  |  |  |
325 |  |  |  |  | if($ops eq "c") {
326 |  |  |  |  | $data = shrink_category($data, $curlies);
327 |  |  |  |  | } elsif($ops eq "C") {
328 |  |  |  |  | $data = shrink_category($data, $curlies);
329 |  |  |  |  | } elsif($ops eq "X") {
330 |  |  |  |  | $data = Log::Log4perl::MDC->get($curlies);
331 |  |  |  |  | } elsif($ops eq "d") {
332 |  |  |  |  | $data = $curlies->format( $self->{timer}->gettimeofday() );
333 |  |  |  |  | } elsif($ops eq "M") {
334 |  |  |  |  | $data = shrink_category($data, $curlies);
335 |  |  |  |  | } elsif($ops eq "m") {
336 |  |  |  |  | if($curlies eq "chomp") {
337 |  |  |  |  | chomp $data;
338 |  |  |  |  | }
339 |  |  |  |  | } elsif($ops eq "F") {
340 |  |  |  |  | my @parts = File::Spec->splitdir($data);
341 |  |  |  |  | # Limit it to max curlies entries
342 |  |  |  |  | if(@parts > $curlies) {
343 |  |  |  |  | splice @parts, 0, @parts - $curlies;
344 |  |  |  |  | }
345 |  |  |  |  | $data = File::Spec->catfile(@parts);
346 |  |  |  |  | } elsif($ops eq "p") {
347 |  |  |  |  | $data = substr $data, 0, $curlies;
348 |  |  |  |  | }
349 |  |  |  |  |
350 |  |  |  |  | return $data;
351 |  |  |  |  | }
352 |  |  |  |  |
353 |  |  |  |  | ##################################################
354 |  |  |  |  | sub shrink_category {
355 |  |  |  |  | ##################################################
356 |  |  |  |  | my($category, $len) = @_;
357 |  |  |  |  |
358 |  |  |  |  | my @components = split /\.|::/, $category;
359 |  |  |  |  |
360 |  |  |  |  | if(@components > $len) {
361 |  |  |  |  | splice @components, 0, @components - $len;
362 |  |  |  |  | $category = join '.', @components;
363 |  |  |  |  | }
364 |  |  |  |  |
365 |  |  |  |  | return $category;
366 |  |  |  |  | }
367 |  |  |  |  |
368 |  |  |  |  | ##################################################
369 |  |  |  |  | sub add_global_cspec {
370 |  |  |  |  | ##################################################
371 |  |  |  |  | # This is a Class method.
372 |  |  |  |  | # Accepts a coderef or text
373 |  |  |  |  | ##################################################
374 |  |  |  |  |
375 |  |  |  |  | unless($Log::Log4perl::ALLOW_CODE_IN_CONFIG_FILE) {
376 |  |  |  |  | die "\$Log::Log4perl::ALLOW_CODE_IN_CONFIG_FILE setting " .
377 |  |  |  |  | "prohibits user defined cspecs";
378 |  |  |  |  | }
379 |  |  |  |  |
380 |  |  |  |  | my ($letter, $perlcode) = @_;
381 |  |  |  |  |
382 |  |  |  |  | croak "Illegal value '$letter' in call to add_global_cspec()"
383 |  |  |  |  | unless ($letter =~ /^[a-zA-Z]$/);
384 |  |  |  |  |
385 |  |  |  |  | croak "Missing argument for perlcode for 'cspec.$letter' ".
386 |  |  |  |  | "in call to add_global_cspec()"
387 |  |  |  |  | unless $perlcode;
388 |  |  |  |  |
389 |  |  |  |  | croak "Please don't redefine built-in cspecs [$CSPECS]\n".
390 |  |  |  |  | "like you do for \"cspec.$letter\"\n "
391 |  |  |  |  | if ($CSPECS =~/$letter/);
392 |  |  |  |  |
393 |  |  |  |  | if (ref $perlcode eq 'CODE') {
394 |  |  |  |  | $GLOBAL_USER_DEFINED_CSPECS{$letter} = $perlcode;
395 |  |  |  |  |
396 |  |  |  |  | }elsif (! ref $perlcode){
397 |  |  |  |  |
398 |  |  |  |  | $GLOBAL_USER_DEFINED_CSPECS{$letter} =
399 |  |  |  |  | Log::Log4perl::Config::compile_if_perl($perlcode);
400 |  |  |  |  |
401 |  |  |  |  | if ($@) {
402 |  |  |  |  | die qq{Compilation failed for your perl code for }.
403 |  |  |  |  | qq{"log4j.PatternLayout.cspec.$letter":\n}.
404 |  |  |  |  | qq{This is the error message: \t$@\n}.
405 |  |  |  |  | qq{This is the code that failed: \n$perlcode\n};
406 |  |  |  |  | }
407 |  |  |  |  |
408 |  |  |  |  | croak "eval'ing your perlcode for 'log4j.PatternLayout.cspec.$letter' ".
409 |  |  |  |  | "doesn't return a coderef \n".
410 |  |  |  |  | "Here is the perl code: \n\t$perlcode\n "
411 |  |  |  |  | unless (ref $GLOBAL_USER_DEFINED_CSPECS{$letter} eq 'CODE');
412 |  |  |  |  |
413 |  |  |  |  | }else{
414 |  |  |  |  | croak "I don't know how to handle perlcode=$perlcode ".
415 |  |  |  |  | "for 'cspec.$letter' in call to add_global_cspec()";
416 |  |  |  |  | }
417 |  |  |  |  | }
418 |  |  |  |  |
419 |  |  |  |  | ##################################################
420 |  |  |  |  | sub add_layout_cspec {
421 |  |  |  |  | ##################################################
422 |  |  |  |  | # object method
423 |  |  |  |  | # adds a cspec just for this layout
424 |  |  |  |  | ##################################################
425 |  |  |  |  | my ($self, $letter, $perlcode) = @_;
426 |  |  |  |  |
427 |  |  |  |  | unless($Log::Log4perl::ALLOW_CODE_IN_CONFIG_FILE) {
428 |  |  |  |  | die "\$Log::Log4perl::ALLOW_CODE_IN_CONFIG_FILE setting " .
429 |  |  |  |  | "prohibits user defined cspecs";
430 |  |  |  |  | }
431 |  |  |  |  |
432 |  |  |  |  | croak "Illegal value '$letter' in call to add_layout_cspec()"
433 |  |  |  |  | unless ($letter =~ /^[a-zA-Z]$/);
434 |  |  |  |  |
435 |  |  |  |  | croak "Missing argument for perlcode for 'cspec.$letter' ".
436 |  |  |  |  | "in call to add_layout_cspec()"
437 |  |  |  |  | unless $perlcode;
438 |  |  |  |  |
439 |  |  |  |  | croak "Please don't redefine built-in cspecs [$CSPECS] \n".
440 |  |  |  |  | "like you do for 'cspec.$letter'"
441 |  |  |  |  | if ($CSPECS =~/$letter/);
442 |  |  |  |  |
443 |  |  |  |  | if (ref $perlcode eq 'CODE') {
444 |  |  |  |  |
445 |  |  |  |  | $self->{USER_DEFINED_CSPECS}{$letter} = $perlcode;
446 |  |  |  |  |
447 |  |  |  |  | }elsif (! ref $perlcode){
448 |  |  |  |  |
449 |  |  |  |  | $self->{USER_DEFINED_CSPECS}{$letter} =
450 |  |  |  |  | Log::Log4perl::Config::compile_if_perl($perlcode);
451 |  |  |  |  |
452 |  |  |  |  | if ($@) {
453 |  |  |  |  | die qq{Compilation failed for your perl code for }.
454 |  |  |  |  | qq{"cspec.$letter":\n}.
455 |  |  |  |  | qq{This is the error message: \t$@\n}.
456 |  |  |  |  | qq{This is the code that failed: \n$perlcode\n};
457 |  |  |  |  | }
458 |  |  |  |  | croak "eval'ing your perlcode for 'cspec.$letter' ".
459 |  |  |  |  | "doesn't return a coderef \n".
460 |  |  |  |  | "Here is the perl code: \n\t$perlcode\n "
461 |  |  |  |  | unless (ref $self->{USER_DEFINED_CSPECS}{$letter} eq 'CODE');
462 |  |  |  |  |
463 |  |  |  |  |
464 |  |  |  |  | }else{
465 |  |  |  |  | croak "I don't know how to handle perlcode=$perlcode ".
466 |  |  |  |  | "for 'cspec.$letter' in call to add_layout_cspec()";
467 |  |  |  |  | }
468 |  |  |  |  |
469 |  |  |  |  | $self->{CSPECS} .= $letter;
470 |  |  |  |  | }
471 |  |  |  |  |
472 |  |  |  |  | ###########################################
473 |  |  |  |  | sub callinfo_dump {
474 |  |  |  |  | ###########################################
475 |  |  |  |  | my($level, $info) = @_;
476 |  |  |  |  |
477 |  |  |  |  | my @called_by = caller(0);
478 |  |  |  |  |
479 |  |  |  |  | # Just for internal debugging
480 |  |  |  |  | $called_by[1] = basename $called_by[1];
481 |  |  |  |  | print "caller($level) at $called_by[1]-$called_by[2] returned ";
482 |  |  |  |  |
483 |  |  |  |  | my @by_idx;
484 |  |  |  |  |
485 |  |  |  |  | # $info->[1] = basename $info->[1] if defined $info->[1];
486 |  |  |  |  |
487 |  |  |  |  | my $i = 0;
488 |  |  |  |  | for my $field (qw(package filename line subroutine hasargs
489 |  |  |  |  | wantarray evaltext is_require hints bitmask)) {
490 |  |  |  |  | $by_idx[$i] = $field;
491 |  |  |  |  | $i++;
492 |  |  |  |  | }
493 |  |  |  |  |
494 |  |  |  |  | $i = 0;
495 |  |  |  |  | for my $value (@$info) {
496 |  |  |  |  | my $field = $by_idx[ $i ];
497 |  |  |  |  | print "$field=",
498 |  |  |  |  | (defined $info->[$i] ? $info->[$i] : "[undef]"),
499 |  |  |  |  | " ";
500 |  |  |  |  | $i++;
501 |  |  |  |  | }
502 |  |  |  |  |
503 |  |  |  |  | print "\n";
504 |  |  |  |  | }
505 |  |  |  |  |
506 | 1 | 4µs |  |  | 1;
507 |  |  |  |  |
508 |  |  |  |  | __END__
|  |  |  |  | # spent 200ns within Log::Log4perl::Layout::PatternLayout::CORE:match which was called: # once (200ns+0s) by Log::Log4perl::Layout::PatternLayout::define at line 107 sub Log::Log4perl::Layout::PatternLayout::CORE:match; # opcode
|  |  |  |  | # spent 22µs within Log::Log4perl::Layout::PatternLayout::CORE:regcomp which was called: # once (22µs+0s) by Log::Log4perl::Layout::PatternLayout::define at line 114 sub Log::Log4perl::Layout::PatternLayout::CORE:regcomp; # opcode
|  |  |  |  | # spent 11µs within Log::Log4perl::Layout::PatternLayout::CORE:subst which was called 3 times, avg 4µs/call: # once (8µs+0s) by Log::Log4perl::Layout::PatternLayout::define at line 114 # once (2µs+0s) by Log::Log4perl::Layout::PatternLayout::new at line 91 # once (500ns+0s) by Log::Log4perl::Layout::PatternLayout::new at line 92 sub Log::Log4perl::Layout::PatternLayout::CORE:subst; # opcode
|  |  |  |  | # spent 2µs within Log::Log4perl::Layout::PatternLayout::CORE:substcont which was called 2 times, avg 1µs/call: # 2 times (2µs+0s) by Log::Log4perl::Layout::PatternLayout::define at line 114, avg 1µs/call sub Log::Log4perl::Layout::PatternLayout::CORE:substcont; # opcode