← 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
StatementsExecuted 86 statements in 2.64ms
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
1111.16ms1.21msLog::Log4perl::Layout::PatternLayout::::BEGIN@15Log::Log4perl::Layout::PatternLayout::BEGIN@15
1111.12ms1.32msLog::Log4perl::Layout::PatternLayout::::BEGIN@20Log::Log4perl::Layout::PatternLayout::BEGIN@20
111481µs1.54msLog::Log4perl::Layout::PatternLayout::::BEGIN@18Log::Log4perl::Layout::PatternLayout::BEGIN@18
111240µs291µsLog::Log4perl::Layout::PatternLayout::::BEGIN@16Log::Log4perl::Layout::PatternLayout::BEGIN@16
111205µs250µsLog::Log4perl::Layout::PatternLayout::::BEGIN@17Log::Log4perl::Layout::PatternLayout::BEGIN@17
11153µs197µsLog::Log4perl::Layout::PatternLayout::::newLog::Log4perl::Layout::PatternLayout::new
11139µs82µsLog::Log4perl::Layout::PatternLayout::::defineLog::Log4perl::Layout::PatternLayout::define
11123µs23µsLog::Log4perl::Layout::PatternLayout::::BEGIN@5Log::Log4perl::Layout::PatternLayout::BEGIN@5
11122µs22µsLog::Log4perl::Layout::PatternLayout::::CORE:regcompLog::Log4perl::Layout::PatternLayout::CORE:regcomp (opcode)
11112µs52µsLog::Log4perl::Layout::PatternLayout::::BEGIN@11Log::Log4perl::Layout::PatternLayout::BEGIN@11
11112µs12µsLog::Log4perl::Layout::PatternLayout::::repLog::Log4perl::Layout::PatternLayout::rep
11111µs59µsLog::Log4perl::Layout::PatternLayout::::BEGIN@29Log::Log4perl::Layout::PatternLayout::BEGIN@29
33111µs11µsLog::Log4perl::Layout::PatternLayout::::CORE:substLog::Log4perl::Layout::PatternLayout::CORE:subst (opcode)
1118µs79µsLog::Log4perl::Layout::PatternLayout::::BEGIN@38Log::Log4perl::Layout::PatternLayout::BEGIN@38
1118µs21µsLog::Log4perl::Layout::PatternLayout::::BEGIN@40Log::Log4perl::Layout::PatternLayout::BEGIN@40
1117µs9µsLog::Log4perl::Layout::PatternLayout::::BEGIN@6Log::Log4perl::Layout::PatternLayout::BEGIN@6
1117µs15µsLog::Log4perl::Layout::PatternLayout::::BEGIN@7Log::Log4perl::Layout::PatternLayout::BEGIN@7
1117µs48µsLog::Log4perl::Layout::PatternLayout::::BEGIN@9Log::Log4perl::Layout::PatternLayout::BEGIN@9
1116µs48µsLog::Log4perl::Layout::PatternLayout::::BEGIN@14Log::Log4perl::Layout::PatternLayout::BEGIN@14
1116µs6µsLog::Log4perl::Layout::PatternLayout::::BEGIN@19Log::Log4perl::Layout::PatternLayout::BEGIN@19
1115µs5µsLog::Log4perl::Layout::PatternLayout::::BEGIN@13Log::Log4perl::Layout::PatternLayout::BEGIN@13
1114µs4µsLog::Log4perl::Layout::PatternLayout::::BEGIN@12Log::Log4perl::Layout::PatternLayout::BEGIN@12
2112µs2µsLog::Log4perl::Layout::PatternLayout::::CORE:substcontLog::Log4perl::Layout::PatternLayout::CORE:substcont (opcode)
111200ns200nsLog::Log4perl::Layout::PatternLayout::::CORE:matchLog::Log4perl::Layout::PatternLayout::CORE:match (opcode)
0000s0sLog::Log4perl::Layout::PatternLayout::::add_global_cspecLog::Log4perl::Layout::PatternLayout::add_global_cspec
0000s0sLog::Log4perl::Layout::PatternLayout::::add_layout_cspecLog::Log4perl::Layout::PatternLayout::add_layout_cspec
0000s0sLog::Log4perl::Layout::PatternLayout::::callinfo_dumpLog::Log4perl::Layout::PatternLayout::callinfo_dump
0000s0sLog::Log4perl::Layout::PatternLayout::::curly_actionLog::Log4perl::Layout::PatternLayout::curly_action
0000s0sLog::Log4perl::Layout::PatternLayout::::renderLog::Log4perl::Layout::PatternLayout::render
0000s0sLog::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##################################################
2package Log::Log4perl::Layout::PatternLayout;
3##################################################
4
5332µs123µ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
6320µs211µ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
7318µs223µ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
9318µs290µ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
11319µs292µ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
12319µs14µ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;
13317µs15µ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;
14317µs290µ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
15392µs11.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
16378µs1291µ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
17370µs1250µ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
18385µs11.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
19319µs16µ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;
203177µs21.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
221600nsour $TIME_HIRES_AVAILABLE_WARNED = 0;
231200nsour $HOSTNAME;
24
2512µsour %GLOBAL_USER_DEFINED_CSPECS = ();
26
271400nsour $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.
3148µs $HOSTNAME = "unknown.host";
32129µ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;
34118µs $HOSTNAME = Sys::Hostname::hostname();
# spent 18µs making 1 call to Sys::Hostname::hostname
35 }
36117µs159µs}
# spent 59µs making 1 call to Log::Log4perl::Layout::PatternLayout::BEGIN@29
37
38322µs279µ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
4031.76ms235µ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##################################################
451653µ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
60159µ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
9112µs $layout_string =~ s/\\n/\n/g;
921500ns $layout_string =~ s/\\r/\r/g;
# spent 500ns making 1 call to Log::Log4perl::Layout::PatternLayout::CORE:subst
93
94182µ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##################################################
102671µ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
1071200ns 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
114432µ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
115112µ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##################################################
126714µ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##################################################
150sub 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##################################################
321sub 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##################################################
354sub 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##################################################
369sub 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##################################################
420sub 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###########################################
473sub 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
50614µs1;
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