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