← 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:23:39 2012

Filename/2home/ss5/perl5/perlbrew/perls/perl-5.12.3/lib/site_perl/5.12.3/Log/Log4perl/Logger.pm
StatementsExecuted 297 statements in 4.72ms
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
111974µs8.74msLog::Log4perl::Logger::::BEGIN@12Log::Log4perl::Logger::BEGIN@12
111953µs1.47msLog::Log4perl::Logger::::BEGIN@10Log::Log4perl::Logger::BEGIN@10
111197µs197µsLog::Log4perl::Logger::::BEGIN@13Log::Log4perl::Logger::BEGIN@13
111184µs7.95msLog::Log4perl::Logger::::BEGIN@11Log::Log4perl::Logger::BEGIN@11
811148µs148µsLog::Log4perl::Logger::::create_log_level_methodsLog::Log4perl::Logger::create_log_level_methods
11187µs99µsLog::Log4perl::Logger::::cleanupLog::Log4perl::Logger::cleanup
11180µs154µsLog::Log4perl::Logger::::set_output_methodsLog::Log4perl::Logger::set_output_methods
103130µs30µsLog::Log4perl::Logger::::generate_watch_codeLog::Log4perl::Logger::generate_watch_code
11127µs27µsLog::Log4perl::Logger::::BEGIN@5Log::Log4perl::Logger::BEGIN@5
82122µs45µsLog::Log4perl::Logger::::generate_is_xxx_coderefLog::Log4perl::Logger::generate_is_xxx_coderef
11119µs174µsLog::Log4perl::Logger::::_newLog::Log4perl::Logger::_new
11119µs198µsLog::Log4perl::Logger::::resetLog::Log4perl::Logger::reset
11115µs20µsLog::Log4perl::Logger::::generate_coderefLog::Log4perl::Logger::generate_coderef
11111µs31µsLog::Log4perl::Logger::::BEGIN@731Log::Log4perl::Logger::BEGIN@731
11110µs69µsLog::Log4perl::Logger::::BEGIN@15Log::Log4perl::Logger::BEGIN@15
1118µs11µsLog::Log4perl::Logger::::BEGIN@6Log::Log4perl::Logger::BEGIN@6
1118µs11µsLog::Log4perl::Logger::::generate_noop_coderefLog::Log4perl::Logger::generate_noop_coderef
1118µs22µsLog::Log4perl::Logger::::BEGIN@7Log::Log4perl::Logger::BEGIN@7
1117µs17µsLog::Log4perl::Logger::::BEGIN@738Log::Log4perl::Logger::BEGIN@738
1117µs40µsLog::Log4perl::Logger::::BEGIN@20Log::Log4perl::Logger::BEGIN@20
1117µs7µsLog::Log4perl::Logger::::BEGIN@14Log::Log4perl::Logger::BEGIN@14
1117µs7µsLog::Log4perl::Logger::::BEGIN@9Log::Log4perl::Logger::BEGIN@9
1116µs14µsLog::Log4perl::Logger::::BEGIN@791Log::Log4perl::Logger::BEGIN@791
1116µs14µsLog::Log4perl::Logger::::BEGIN@760Log::Log4perl::Logger::BEGIN@760
1113µs3µsLog::Log4perl::Logger::::DESTROYLog::Log4perl::Logger::DESTROY
1113µs3µsLog::Log4perl::Logger::::levelLog::Log4perl::Logger::level
1112µs2µsLog::Log4perl::Logger::::parent_loggerLog::Log4perl::Logger::parent_logger
111500ns500nsLog::Log4perl::Logger::::CORE:substLog::Log4perl::Logger::CORE:subst (opcode)
0000s0sLog::Log4perl::Logger::::__ANON__[:300]Log::Log4perl::Logger::__ANON__[:300]
0000s0sLog::Log4perl::Logger::::__ANON__[:324]Log::Log4perl::Logger::__ANON__[:324]
0000s0sLog::Log4perl::Logger::::__ANON__[:347]Log::Log4perl::Logger::__ANON__[:347]
0000s0sLog::Log4perl::Logger::::__ANON__[:416]Log::Log4perl::Logger::__ANON__[:416]
0000s0sLog::Log4perl::Logger::::__ANON__[:428]Log::Log4perl::Logger::__ANON__[:428]
0000s0sLog::Log4perl::Logger::::__ANON__[:435]Log::Log4perl::Logger::__ANON__[:435]
0000s0sLog::Log4perl::Logger::::__ANON__[:773]Log::Log4perl::Logger::__ANON__[:773]
0000s0sLog::Log4perl::Logger::::__ANON__[:783]Log::Log4perl::Logger::__ANON__[:783]
0000s0sLog::Log4perl::Logger::::add_appenderLog::Log4perl::Logger::add_appender
0000s0sLog::Log4perl::Logger::::additivityLog::Log4perl::Logger::additivity
0000s0sLog::Log4perl::Logger::::and_dieLog::Log4perl::Logger::and_die
0000s0sLog::Log4perl::Logger::::and_warnLog::Log4perl::Logger::and_warn
0000s0sLog::Log4perl::Logger::::callerlineLog::Log4perl::Logger::callerline
0000s0sLog::Log4perl::Logger::::create_custom_levelLog::Log4perl::Logger::create_custom_level
0000s0sLog::Log4perl::Logger::::dec_levelLog::Log4perl::Logger::dec_level
0000s0sLog::Log4perl::Logger::::eradicate_appenderLog::Log4perl::Logger::eradicate_appender
0000s0sLog::Log4perl::Logger::::error_dieLog::Log4perl::Logger::error_die
0000s0sLog::Log4perl::Logger::::error_warnLog::Log4perl::Logger::error_warn
0000s0sLog::Log4perl::Logger::::generate_watch_conditionalLog::Log4perl::Logger::generate_watch_conditional
0000s0sLog::Log4perl::Logger::::get_loggerLog::Log4perl::Logger::get_logger
0000s0sLog::Log4perl::Logger::::get_root_loggerLog::Log4perl::Logger::get_root_logger
0000s0sLog::Log4perl::Logger::::has_appendersLog::Log4perl::Logger::has_appenders
0000s0sLog::Log4perl::Logger::::inc_levelLog::Log4perl::Logger::inc_level
0000s0sLog::Log4perl::Logger::::init_warnLog::Log4perl::Logger::init_warn
0000s0sLog::Log4perl::Logger::::less_loggingLog::Log4perl::Logger::less_logging
0000s0sLog::Log4perl::Logger::::logLog::Log4perl::Logger::log
0000s0sLog::Log4perl::Logger::::logcarpLog::Log4perl::Logger::logcarp
0000s0sLog::Log4perl::Logger::::logcluckLog::Log4perl::Logger::logcluck
0000s0sLog::Log4perl::Logger::::logconfessLog::Log4perl::Logger::logconfess
0000s0sLog::Log4perl::Logger::::logcroakLog::Log4perl::Logger::logcroak
0000s0sLog::Log4perl::Logger::::logdieLog::Log4perl::Logger::logdie
0000s0sLog::Log4perl::Logger::::logexitLog::Log4perl::Logger::logexit
0000s0sLog::Log4perl::Logger::::logwarnLog::Log4perl::Logger::logwarn
0000s0sLog::Log4perl::Logger::::more_loggingLog::Log4perl::Logger::more_logging
0000s0sLog::Log4perl::Logger::::parent_stringLog::Log4perl::Logger::parent_string
0000s0sLog::Log4perl::Logger::::remove_appenderLog::Log4perl::Logger::remove_appender
0000s0sLog::Log4perl::Logger::::reset_all_output_methodsLog::Log4perl::Logger::reset_all_output_methods
0000s0sLog::Log4perl::Logger::::warning_renderLog::Log4perl::Logger::warning_render
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::Logger;
3##################################################
4
5336µs127µs
# spent 27µs within Log::Log4perl::Logger::BEGIN@5 which was called: # once (27µs+0s) by Log::Log4perl::BEGIN@12 at line 5
use 5.006;
# spent 27µs making 1 call to Log::Log4perl::Logger::BEGIN@5
6318µs214µs
# spent 11µs (8+3) within Log::Log4perl::Logger::BEGIN@6 which was called: # once (8µs+3µs) by Log::Log4perl::BEGIN@12 at line 6
use strict;
# spent 11µs making 1 call to Log::Log4perl::Logger::BEGIN@6 # spent 2µs making 1 call to strict::import
7318µs237µs
# spent 22µs (8+15) within Log::Log4perl::Logger::BEGIN@7 which was called: # once (8µs+15µs) by Log::Log4perl::BEGIN@12 at line 7
use warnings;
# spent 22µs making 1 call to Log::Log4perl::Logger::BEGIN@7 # spent 15µs making 1 call to warnings::import
8
9319µs17µs
# spent 7µs within Log::Log4perl::Logger::BEGIN@9 which was called: # once (7µs+0s) by Log::Log4perl::BEGIN@12 at line 9
use Log::Log4perl;
# spent 7µs making 1 call to Log::Log4perl::Logger::BEGIN@9
10378µs21.51ms
# spent 1.47ms (953µs+515µs) within Log::Log4perl::Logger::BEGIN@10 which was called: # once (953µs+515µs) by Log::Log4perl::BEGIN@12 at line 10
use Log::Log4perl::Level;
# spent 1.47ms making 1 call to Log::Log4perl::Logger::BEGIN@10 # spent 41µs making 1 call to Log::Log4perl::Level::import
11397µs17.95ms
# spent 7.95ms (184µs+7.77) within Log::Log4perl::Logger::BEGIN@11 which was called: # once (184µs+7.77ms) by Log::Log4perl::BEGIN@12 at line 11
use Log::Log4perl::Layout;
# spent 7.95ms making 1 call to Log::Log4perl::Logger::BEGIN@11
12395µs18.74ms
# spent 8.74ms (974µs+7.77) within Log::Log4perl::Logger::BEGIN@12 which was called: # once (974µs+7.77ms) by Log::Log4perl::BEGIN@12 at line 12
use Log::Log4perl::Appender;
# spent 8.74ms making 1 call to Log::Log4perl::Logger::BEGIN@12
133203µs1197µs
# spent 197µs within Log::Log4perl::Logger::BEGIN@13 which was called: # once (197µs+0s) by Log::Log4perl::BEGIN@12 at line 13
use Log::Log4perl::Appender::String;
# spent 197µs making 1 call to Log::Log4perl::Logger::BEGIN@13
14319µs17µs
# spent 7µs within Log::Log4perl::Logger::BEGIN@14 which was called: # once (7µs+0s) by Log::Log4perl::BEGIN@12 at line 14
use Log::Log4perl::Filter;
# spent 7µs making 1 call to Log::Log4perl::Logger::BEGIN@14
15334µs2127µs
# spent 69µs (10+59) within Log::Log4perl::Logger::BEGIN@15 which was called: # once (10µs+59µs) by Log::Log4perl::BEGIN@12 at line 15
use Carp;
# spent 69µs making 1 call to Log::Log4perl::Logger::BEGIN@15 # spent 58µs making 1 call to Exporter::import
16
1711µs$Carp::Internal{"Log::Log4perl"}++;
1811µs$Carp::Internal{"Log::Log4perl::Logger"}++;
19
2032.35ms272µs
# spent 40µs (7+32) within Log::Log4perl::Logger::BEGIN@20 which was called: # once (7µs+32µs) by Log::Log4perl::BEGIN@12 at line 20
use constant _INTERNAL_DEBUG => 0;
# spent 40µs making 1 call to Log::Log4perl::Logger::BEGIN@20 # spent 33µs making 1 call to constant::import
21
22 # Initialization
231200nsour $ROOT_LOGGER;
241900nsour $LOGGERS_BY_NAME = {};
2512µsour %APPENDER_BY_NAME = ();
261200nsour $INITIALIZED = 0;
271100nsour $NON_INIT_WARNED;
281200nsour $DIE_DEBUG = 0;
291300nsour $DIE_DEBUG_BUFFER = "";
30 # Define the default appender that's used for formatting
31 # warn/die/croak etc. messages.
321400nsour $STRING_APP_NAME = "_l4p_warn";
3314µs167µsour $STRING_APP = Log::Log4perl::Appender->new(
# spent 67µs making 1 call to Log::Log4perl::Appender::new
34 "Log::Log4perl::Appender::String",
35 name => $STRING_APP_NAME);
3618µs2200µs$STRING_APP->layout(Log::Log4perl::Layout::PatternLayout->new("%m"));
# spent 197µs making 1 call to Log::Log4perl::Layout::PatternLayout::new # spent 4µs making 1 call to Log::Log4perl::Appender::layout
3712µs120µsour $STRING_APP_CODEREF = generate_coderef([[$STRING_APP_NAME, $STRING_APP]]);
# spent 20µs making 1 call to Log::Log4perl::Logger::generate_coderef
38
3914µs1198µs__PACKAGE__->reset();
# spent 198µs making 1 call to Log::Log4perl::Logger::reset
40
41###########################################
42sub warning_render {
43###########################################
44 my($logger, @message) = @_;
45
46 $STRING_APP->string("");
47 $STRING_APP_CODEREF->($logger,
48 @message,
49 Log::Log4perl::Level::to_level($ALL));
50 return $STRING_APP->string();
51}
52
53##################################################
54
# spent 99µs (87+12) within Log::Log4perl::Logger::cleanup which was called: # once (87µs+12µs) by Log::Log4perl::END at line 5 of Log/Log4perl.pm
sub cleanup {
55##################################################
56 # warn "Logger cleanup";
57
58 # Nuke all convenience loggers to avoid them causing cleanup to
59 # be delayed until global destruction. Problem is that something like
60 # *{"DEBUG"} = sub { $logger->debug };
61 # ties up a reference to $logger until global destruction, so we
62 # need to clean up all :easy shortcuts, hence freeing the last
63 # logger references, to then rely on the garbage collector for cleaning
64 # up the loggers.
65112µs19µs Log::Log4perl->easy_closure_global_cleanup();
# spent 9µs making 1 call to Log::Log4perl::easy_closure_global_cleanup
66
67 # Delete all loggers
6815µs $LOGGERS_BY_NAME = {};
69
70 # Delete the root logger
71116µs undef $ROOT_LOGGER;
72
73 # Delete all appenders
74135µs13µs %APPENDER_BY_NAME = ();
# spent 3µs making 1 call to Log::Log4perl::Logger::DESTROY
75
76110µs undef $INITIALIZED;
77}
78
79##################################################
80
# spent 3µs within Log::Log4perl::Logger::DESTROY which was called: # once (3µs+0s) by Log::Log4perl::Logger::cleanup at line 74
sub DESTROY {
81##################################################
82111µs CORE::warn "Destroying logger $_[0] ($_[0]->{category})"
83 if $Log::Log4perl::CHATTY_DESTROY_METHODS;
84}
85
86##################################################
87
# spent 198µs (19+179) within Log::Log4perl::Logger::reset which was called: # once (19µs+179µs) by Log::Log4perl::BEGIN@12 at line 39
sub reset {
88##################################################
8912µs1174µs $ROOT_LOGGER = __PACKAGE__->_new("", $OFF);
# spent 174µs making 1 call to Log::Log4perl::Logger::_new
90# $LOGGERS_BY_NAME = {}; #leave this alone, it's used by
91 #reset_all_output_methods when
92 #the config changes
93
941700ns %APPENDER_BY_NAME = ();
951500ns undef $INITIALIZED;
961200ns undef $NON_INIT_WARNED;
9712µs13µs Log::Log4perl::Appender::reset();
# spent 3µs making 1 call to Log::Log4perl::Appender::reset
98
99 #clear out all the existing appenders
10012µs foreach my $logger (values %$LOGGERS_BY_NAME){
1011900ns $logger->{appender_names} = [];
102
103 #this next bit deals with an init_and_watch case where a category
104 #is deleted from the config file, we need to zero out the existing
105 #loggers so ones not in the config file not continue with their old
106 #behavior --kg
10713µs next if $logger eq $ROOT_LOGGER;
108 $logger->{level} = undef;
109 $logger->level(); #set it from the hierarchy
110 }
111
112 # Clear all filters
11315µs13µs Log::Log4perl::Filter::reset();
# spent 3µs making 1 call to Log::Log4perl::Filter::reset
114}
115
116##################################################
117
# spent 174µs (19+155) within Log::Log4perl::Logger::_new which was called: # once (19µs+155µs) by Log::Log4perl::Logger::reset at line 89
sub _new {
118##################################################
11911µs my($class, $category, $level) = @_;
120
1211300ns print("_new: $class/$category/", defined $level ? $level : "undef",
122 "\n") if _INTERNAL_DEBUG;
123
1241300ns die "usage: __PACKAGE__->_new(category)" unless
125 defined $category;
126
12715µs1500ns $category =~ s/::/./g;
# spent 500ns making 1 call to Log::Log4perl::Logger::CORE:subst
128
129 # Have we created it previously?
13011µs if(exists $LOGGERS_BY_NAME->{$category}) {
131 print "_new: exists already\n" if _INTERNAL_DEBUG;
132 return $LOGGERS_BY_NAME->{$category};
133 }
134
13512µs my $self = {
136 category => $category,
137 num_appenders => 0,
138 additivity => 1,
139 level => $level,
140 layout => undef,
141 };
142
14312µs bless $self, $class;
144
1451300ns $level ||= $self->level();
146
147 # Save it in global structure
14811µs $LOGGERS_BY_NAME->{$category} = $self;
149
15012µs1154µs $self->set_output_methods;
# spent 154µs making 1 call to Log::Log4perl::Logger::set_output_methods
151
1521100ns print("Created logger $self ($category)\n") if _INTERNAL_DEBUG;
153
15413µs return $self;
155}
156
157##################################################
158sub reset_all_output_methods {
159##################################################
160 print "reset_all_output_methods: \n" if _INTERNAL_DEBUG;
161
162 foreach my $loggername ( keys %$LOGGERS_BY_NAME){
163 $LOGGERS_BY_NAME->{$loggername}->set_output_methods;
164 }
165 $ROOT_LOGGER->set_output_methods;
166}
167
168##################################################
169
# spent 154µs (80+74) within Log::Log4perl::Logger::set_output_methods which was called: # once (80µs+74µs) by Log::Log4perl::Logger::_new at line 150
sub set_output_methods {
170# Here's a big performance increase. Instead of having the logger
171# calculate whether to log and whom to log to every time log() is called,
172# we calculcate it once when the logger is created, and recalculate
173# it if the config information ever changes.
174#
175##################################################
1761500ns my ($self) = @_;
177
1781400ns my (@appenders, %seen);
179
18012µs13µs my ($level) = $self->level();
# spent 3µs making 1 call to Log::Log4perl::Logger::level
181
1821200ns print "set_output_methods: $self->{category}/$level\n" if _INTERNAL_DEBUG;
183
184 #collect the appenders in effect for this category
185
18613µs12µs for(my $logger = $self; $logger; $logger = parent_logger($logger)) {
# spent 2µs making 1 call to Log::Log4perl::Logger::parent_logger
187
18812µs foreach my $appender_name (@{$logger->{appender_names}}){
189
190 #only one message per appender, (configurable)
191 next if $seen{$appender_name} ++ &&
192 $Log::Log4perl::one_message_per_appender;
193
194 push (@appenders,
195 [$appender_name,
196 $APPENDER_BY_NAME{$appender_name},
197 ]
198 );
199 }
2001400ns last unless $logger->{additivity};
2011500ns }
202
203 #make a no-op coderef for inactive levels
20412µs111µs my $noop = generate_noop_coderef();
# spent 11µs making 1 call to Log::Log4perl::Logger::generate_noop_coderef
205
206 #make a coderef
20711µs my $coderef = (! @appenders ? $noop : &generate_coderef(\@appenders));
208
20917µs my %priority = %Log::Log4perl::Level::PRIORITY; #convenience and cvs
210
211 # changed to >= from <= as level ints were reversed
21216µs foreach my $levelname (keys %priority){
213811µs814µs if (Log::Log4perl::Level::isGreaterOrEqual($level,
# spent 14µs making 8 calls to Log::Log4perl::Level::isGreaterOrEqual, avg 2µs/call
214 $priority{$levelname}
215 )) {
2161100ns print " ($priority{$levelname} <= $level)\n"
217 if _INTERNAL_DEBUG;
2181500ns $self->{$levelname} = $coderef;
21912µs14µs $self->{"is_$levelname"} = generate_is_xxx_coderef("1");
# spent 4µs making 1 call to Log::Log4perl::Logger::generate_is_xxx_coderef
2201400ns print "Setting is_$levelname to 1\n" if _INTERNAL_DEBUG;
221 }else{
2227700ns print " ($priority{$levelname} > $level)\n" if _INTERNAL_DEBUG;
22374µs $self->{$levelname} = $noop;
224713µs741µs $self->{"is_$levelname"} = generate_is_xxx_coderef("0");
# spent 41µs making 7 calls to Log::Log4perl::Logger::generate_is_xxx_coderef, avg 6µs/call
22572µs print "Setting is_$levelname to 0\n" if _INTERNAL_DEBUG;
226 }
227
22883µs print(" Setting [$self] $self->{category}.$levelname to ",
229 ($self->{$levelname} == $noop ? "NOOP" :
230 ("Coderef [$coderef]: " . scalar @appenders . " appenders")),
231 "\n") if _INTERNAL_DEBUG;
232 }
233}
234
235##################################################
236
# spent 20µs (15+5) within Log::Log4perl::Logger::generate_coderef which was called: # once (15µs+5µs) by Log::Log4perl::BEGIN@12 at line 37
sub generate_coderef {
237##################################################
2381300ns my $appenders = shift;
239
2401100ns print "generate_coderef: ", scalar @$appenders,
241 " appenders\n" if _INTERNAL_DEBUG;
242
24312µs15µs my $watch_check_code = generate_watch_code("logger", 1);
# spent 5µs making 1 call to Log::Log4perl::Logger::generate_watch_code
244
245 return sub {
246 my $logger = shift;
247 my $level = pop;
248
249 my $message;
250 my $appenders_fired = 0;
251
252 # Evaluate all parameters that need to be evaluated. Two kinds:
253 #
254 # (1) It's a hash like { filter => "filtername",
255 # value => "value" }
256 # => filtername(value)
257 #
258 # (2) It's a code ref
259 # => coderef()
260 #
261
262 $message = [map { ref $_ eq "HASH" &&
263 exists $_->{filter} &&
264 ref $_->{filter} eq 'CODE' ?
265 $_->{filter}->($_->{value}) :
266 ref $_ eq "CODE" ?
267 $_->() : $_
268 } @_];
269
270 print("coderef: $logger->{category}\n") if _INTERNAL_DEBUG;
271
272 if(defined $Log::Log4perl::Config::WATCHER) {
273 return unless $watch_check_code->($logger, @_, $level);
274 }
275
276 foreach my $a (@$appenders) { #note the closure here
277 my ($appender_name, $appender) = @$a;
278
279 print(" Sending message '<$message->[0]>' ($level) " .
280 "to $appender_name\n") if _INTERNAL_DEBUG;
281
282 $appender->log(
283 #these get passed through to Log::Dispatch
284 { name => $appender_name,
285 level => $Log::Log4perl::Level::L4P_TO_LD{
286 $level},
287 message => $message,
288 },
289 #these we need
290 $logger->{category},
291 $level,
292 ) and $appenders_fired++;
293 # Only counting it if it returns a true value. Otherwise
294 # the appender threshold might have suppressed it after all.
295
296 } #end foreach appenders
297
298 return $appenders_fired;
299
300110µs }; #end coderef
301}
302
303##################################################
304
# spent 11µs (8+2) within Log::Log4perl::Logger::generate_noop_coderef which was called: # once (8µs+2µs) by Log::Log4perl::Logger::set_output_methods at line 204
sub generate_noop_coderef {
305##################################################
3061200ns my $watch_delay_code;
307
308 # This might seem crazy at first, but even in a Log4perl noop, we
309 # need to check if the configuration changed in a init_and_watch
310 # situation. Why? Say, an application is running in a loop that
311 # constantly tries to issue debug() messages, but they're suppressed by
312 # the current Log4perl configuration. If debug() (which is a noop
313 # here) wasn't watching the configuration for changes, it would never
314 # catch the case where someone bumps up the log level and expects
315 # the application to pick it up and start logging debug() statements.
316
31711µs12µs my $watch_check_code = generate_watch_code("logger", 1);
# spent 2µs making 1 call to Log::Log4perl::Logger::generate_watch_code
318
3191300ns my $coderef;
320
3211700ns if(defined $Log::Log4perl::Config::WATCHER) {
322 $coderef = $watch_check_code;
323 } else {
32412µs $coderef = sub { undef };
325 }
326
32714µs return $coderef;
328}
329
330##################################################
331
# spent 45µs (22+22) within Log::Log4perl::Logger::generate_is_xxx_coderef which was called 8 times, avg 6µs/call: # 7 times (20µs+20µs) by Log::Log4perl::Logger::set_output_methods at line 224, avg 6µs/call # once (2µs+2µs) by Log::Log4perl::Logger::set_output_methods at line 219
sub generate_is_xxx_coderef {
332##################################################
33383µs my($return_token) = @_;
334
335819µs822µs return generate_watch_code("checker", $return_token);
# spent 22µs making 8 calls to Log::Log4perl::Logger::generate_watch_code, avg 3µs/call
336}
337
338##################################################
339
# spent 30µs within Log::Log4perl::Logger::generate_watch_code which was called 10 times, avg 3µs/call: # 8 times (22µs+0s) by Log::Log4perl::Logger::generate_is_xxx_coderef at line 335, avg 3µs/call # once (5µs+0s) by Log::Log4perl::Logger::generate_coderef at line 243 # once (2µs+0s) by Log::Log4perl::Logger::generate_noop_coderef at line 317
sub generate_watch_code {
340##################################################
341105µs my($type, $return_token) = @_;
342
343101µs print "generate_watch_code:\n" if _INTERNAL_DEBUG;
344
345 # No watcher configured, return a no-op as watch code.
3461039µs if(! defined $Log::Log4perl::Config::WATCHER) {
347 return sub { $return_token };
348 }
349
350 my $cond = generate_watch_conditional();
351
352 return sub {
353 print "exe_watch_code:\n" if _INTERNAL_DEBUG;
354
355 if(_INTERNAL_DEBUG) {
356 print "Next check: ",
357 "$Log::Log4perl::Config::Watch::NEXT_CHECK_TIME ",
358 " Now: ", time(), " Mod: ",
359 (stat($Log::Log4perl::Config::WATCHER->file()))[9],
360 "\n";
361 }
362
363 if( $cond->() ) {
364 my $init_permitted = 1;
365
366 if(exists $Log::Log4perl::Config::OPTS->{ preinit_callback } ) {
367 print "Calling preinit_callback\n" if _INTERNAL_DEBUG;
368 $init_permitted =
369 $Log::Log4perl::Config::OPTS->{ preinit_callback }->(
370 Log::Log4perl::Config->watcher()->file() );
371 print "Callback returned $init_permitted\n" if _INTERNAL_DEBUG;
372 }
373
374 if( $init_permitted ) {
375 Log::Log4perl->init_and_watch();
376 } else {
377 # It was time to reinit, but init wasn't permitted.
378 # Return true, so that the logger continues as if
379 # it wasn't time to reinit.
380 return 1;
381 }
382
383 my $logger = shift;
384 my $level = pop;
385
386 # Forward call to new configuration
387 if($type eq "checker") {
388 return $logger->$level();
389
390 } elsif( $type eq "logger") {
391 my $methodname = lc($level);
392
393 # Bump up the caller level by three, since
394 # we've artifically introduced additional levels.
395 local $Log::Log4perl::caller_depth =
396 $Log::Log4perl::caller_depth + 3;
397
398 # Get a new logger for the same category (the old
399 # logger might be obsolete because of the re-init)
400 $logger = Log::Log4perl::get_logger( $logger->{category} );
401
402 $logger->$methodname(@_); # send the message
403 # to the new configuration
404 return undef; # Return false, so the logger finishes
405 # prematurely and doesn't log the same
406 # message again.
407 } else {
408 die "internal error: unknown type";
409 }
410 } else {
411 if(_INTERNAL_DEBUG) {
412 print "Conditional returned false\n";
413 }
414 return $return_token;
415 }
416 };
417}
418
419##################################################
420sub generate_watch_conditional {
421##################################################
422
423 if(defined $Log::Log4perl::Config::Watch::SIGNAL_CAUGHT) {
424 # In this mode, we just check for the variable indicating
425 # that the signal has been caught
426 return sub {
427 return $Log::Log4perl::Config::Watch::SIGNAL_CAUGHT;
428 };
429 }
430
431 return sub {
432 return
433 ( time() > $Log::Log4perl::Config::Watch::NEXT_CHECK_TIME and
434 $Log::Log4perl::Config::WATCHER->change_detected() );
435 };
436}
437
438##################################################
439sub parent_string {
440##################################################
441 my($string) = @_;
442
443 if($string eq "") {
444 return undef; # root doesn't have a parent.
445 }
446
447 my @components = split /\./, $string;
448
449 if(@components == 1) {
450 return "";
451 }
452
453 pop @components;
454
455 return join('.', @components);
456}
457
458##################################################
459
# spent 3µs within Log::Log4perl::Logger::level which was called: # once (3µs+0s) by Log::Log4perl::Logger::set_output_methods at line 180
sub level {
460##################################################
4611700ns my($self, $level, $dont_reset_all) = @_;
462
463 # 'Set' function
4641200ns if(defined $level) {
465 croak "invalid level '$level'"
466 unless Log::Log4perl::Level::is_valid($level);
467 if ($level =~ /\D/){
468 $level = Log::Log4perl::Level::to_priority($level);
469 }
470 $self->{level} = $level;
471
472 &reset_all_output_methods
473 unless $dont_reset_all; #keep us from getting overworked
474 #if it's the config file calling us
475
476 return $level;
477 }
478
479 # 'Get' function
48014µs if(defined $self->{level}) {
481 return $self->{level};
482 }
483
484 for(my $logger = $self; $logger; $logger = parent_logger($logger)) {
485
486 # Does the current logger have the level defined?
487
488 if($logger->{category} eq "") {
489 # It's the root logger
490 return $ROOT_LOGGER->{level};
491 }
492
493 if(defined $LOGGERS_BY_NAME->{$logger->{category}}->{level}) {
494 return $LOGGERS_BY_NAME->{$logger->{category}}->{level};
495 }
496 }
497
498 # We should never get here because at least the root logger should
499 # have a level defined
500 die "We should never get here.";
501}
502
503##################################################
504
# spent 2µs within Log::Log4perl::Logger::parent_logger which was called: # once (2µs+0s) by Log::Log4perl::Logger::set_output_methods at line 186
sub parent_logger {
505# Get the parent of the current logger or undef
506##################################################
5071500ns my($logger) = @_;
508
509 # Is it the root logger?
51013µs if($logger->{category} eq "") {
511 # Root has no parent
512 return undef;
513 }
514
515 # Go to the next defined (!) parent
516 my $parent_class = parent_string($logger->{category});
517
518 while($parent_class ne "" and
519 ! exists $LOGGERS_BY_NAME->{$parent_class}) {
520 $parent_class = parent_string($parent_class);
521 $logger = $LOGGERS_BY_NAME->{$parent_class};
522 }
523
524 if($parent_class eq "") {
525 $logger = $ROOT_LOGGER;
526 } else {
527 $logger = $LOGGERS_BY_NAME->{$parent_class};
528 }
529
530 return $logger;
531}
532
533##################################################
534sub get_root_logger {
535##################################################
536 my($class) = @_;
537 return $ROOT_LOGGER;
538}
539
540##################################################
541sub additivity {
542##################################################
543 my($self, $onoff) = @_;
544
545 if(defined $onoff) {
546 $self->{additivity} = $onoff;
547 }
548
549 return $self->{additivity};
550}
551
552##################################################
553sub get_logger {
554##################################################
555 my($class, $category) = @_;
556
557 unless(defined $ROOT_LOGGER) {
558 die "Internal error: Root Logger not initialized.";
559 }
560
561 return $ROOT_LOGGER if $category eq "";
562
563 my $logger = $class->_new($category);
564 return $logger;
565}
566
567##################################################
568sub add_appender {
569##################################################
570 my($self, $appender, $dont_reset_all) = @_;
571
572 # We take this as an indicator that we're initialized.
573 $INITIALIZED = 1;
574
575 my $appender_name = $appender->name();
576
577 $self->{num_appenders}++; #should this be inside the unless?
578
579 # Add newly created appender to the end of the appender array
580 unless (grep{$_ eq $appender_name} @{$self->{appender_names}}){
581 $self->{appender_names} = [sort @{$self->{appender_names}},
582 $appender_name];
583 }
584
585 $APPENDER_BY_NAME{$appender_name} = $appender;
586
587 reset_all_output_methods
588 unless $dont_reset_all; # keep us from getting overworked
589 # if it's the config file calling us
590
591 # For chaining calls ...
592 return $appender;
593}
594
595##################################################
596sub remove_appender {
597##################################################
598 my($self, $appender_name, $dont_reset_all, $sloppy) = @_;
599
600 my %appender_names = map { $_ => 1 } @{$self->{appender_names}};
601
602 if(!exists $appender_names{$appender_name}) {
603 die "No such appender: $appender_name" unless $sloppy;
604 return undef;
605 }
606
607 delete $appender_names{$appender_name};
608 $self->{num_appenders}--;
609 $self->{appender_names} = [sort keys %appender_names];
610
611 &reset_all_output_methods
612 unless $dont_reset_all;
613}
614
615##################################################
616sub eradicate_appender {
617##################################################
618 # If someone calls Logger->... and not Logger::...
619 shift if $_[0] eq __PACKAGE__;
620
621 my($appender_name, $dont_reset_all) = @_;
622
623 return 0 unless exists
624 $APPENDER_BY_NAME{$appender_name};
625
626 # Remove the given appender from all loggers
627 # and delete all references to it, causing
628 # its DESTROY method to be called.
629 foreach my $logger (values %$LOGGERS_BY_NAME){
630 $logger->remove_appender($appender_name, 0, 1);
631 }
632 # Also remove it from the root logger
633 $ROOT_LOGGER->remove_appender($appender_name, 0, 1);
634
635 delete $APPENDER_BY_NAME{$appender_name};
636
637 &reset_all_output_methods
638 unless $dont_reset_all;
639
640 return 1;
641}
642
643##################################################
644sub has_appenders {
645##################################################
646 my($self) = @_;
647
648 return $self->{num_appenders};
649}
650
651##################################################
652sub log {
653# external api
654##################################################
655 my ($self, $priority, @messages) = @_;
656
657 confess("log: No priority given!") unless defined($priority);
658
659 # Just in case of 'init_and_watch' -- see Changes 0.21
660 $_[0] = $LOGGERS_BY_NAME->{$_[0]->{category}} if
661 defined $Log::Log4perl::Config::WATCHER;
662
663 init_warn() unless $INITIALIZED or $NON_INIT_WARNED;
664
665 croak "priority $priority isn't numeric" if ($priority =~ /\D/);
666
667 my $which = Log::Log4perl::Level::to_level($priority);
668
669 $self->{$which}->($self, @messages,
670 Log::Log4perl::Level::to_level($priority));
671}
672
673######################################################################
674#
675# create_custom_level
676# creates a custom level
677# in theory, could be used to create the default ones
678######################################################################
679sub create_custom_level {
680######################################################################
681 my $level = shift || die("create_custom_level: " .
682 "forgot to pass in a level string!");
683 my $after = shift || die("create_custom_level: " .
684 "forgot to pass in a level after which to " .
685 "place the new level!");
686 my $syslog_equiv = shift; # can be undef
687 my $log_dispatch_level = shift; # optional
688
689 ## only let users create custom levels before initialization
690
691 die("create_custom_level must be called before init or " .
692 "first get_logger() call") if ($INITIALIZED);
693
694 my %PRIORITY = %Log::Log4perl::Level::PRIORITY; #convenience
695
696 die("create_custom_level: no such level \"$after\"! Use one of: ",
697 join(", ", sort keys %PRIORITY)) unless $PRIORITY{$after};
698
699 # figure out new int value by AFTER + (AFTER+ 1) / 2
700
701 my $next_prio = Log::Log4perl::Level::get_lower_level($PRIORITY{$after}, 1);
702 my $cust_prio = int(($PRIORITY{$after} + $next_prio) / 2);
703
704 die(qq{create_custom_level: Calculated level of $cust_prio already exists!
705 This should only happen if you've made some insane number of custom
706 levels (like 15 one after another)
707 You can usually fix this by re-arranging your code from:
708 create_custom_level("cust1", X);
709 create_custom_level("cust2", X);
710 create_custom_level("cust3", X);
711 create_custom_level("cust4", X);
712 create_custom_level("cust5", X);
713 into:
714 create_custom_level("cust3", X);
715 create_custom_level("cust5", X);
716 create_custom_level("cust4", 4);
717 create_custom_level("cust2", cust3);
718 create_custom_level("cust1", cust2);
719 }) if (${Log::Log4perl::Level::LEVELS{$cust_prio}});
720
721 Log::Log4perl::Level::add_priority($level, $cust_prio, $syslog_equiv,
722 $log_dispatch_level);
723
724 print("Adding prio $level at $cust_prio\n") if _INTERNAL_DEBUG;
725
726 # get $LEVEL into namespace of Log::Log4perl::Logger to
727 # create $logger->foo nd $logger->is_foo
728 my $name = "Log::Log4perl::Logger::";
729 my $key = $level;
730
731352µs251µs
# spent 31µs (11+20) within Log::Log4perl::Logger::BEGIN@731 which was called: # once (11µs+20µs) by Log::Log4perl::BEGIN@12 at line 731
no strict qw(refs);
# spent 31µs making 1 call to Log::Log4perl::Logger::BEGIN@731 # spent 20µs making 1 call to strict::unimport
732 # be sure to use ${Log...} as CVS adds log entries for Log
733 *{"$name$key"} = \${Log::Log4perl::Level::PRIORITY{$level}};
734
735 # now, stick it in the caller's namespace
736 $name = caller(0) . "::";
737 *{"$name$key"} = \${Log::Log4perl::Level::PRIORITY{$level}};
738384µs226µs
# spent 17µs (7+10) within Log::Log4perl::Logger::BEGIN@738 which was called: # once (7µs+10µs) by Log::Log4perl::BEGIN@12 at line 738
use strict qw(refs);
# spent 17µs making 1 call to Log::Log4perl::Logger::BEGIN@738 # spent 10µs making 1 call to strict::import
739
740 create_log_level_methods($level);
741
742 return 0;
743
744}
745
746########################################
747#
748# if we were hackin' lisp (or scheme), we'd be returning some lambda
749# expressions. But we aren't. :) So we'll just create some strings and
750# eval them.
751########################################
752
# spent 148µs within Log::Log4perl::Logger::create_log_level_methods which was called 8 times, avg 18µs/call: # 8 times (148µs+0s) by Log::Log4perl::BEGIN@12 at line 798, avg 18µs/call
sub create_log_level_methods {
753########################################
75484µs my $level = shift || die("create_log_level_methods: " .
755 "forgot to pass in a level string!");
75684µs my $lclevel = lc($level);
75785µs my $levelint = uc($level) . "_INT";
75884µs my $initial_cap = ucfirst($lclevel);
759
7603174µs222µs
# spent 14µs (6+8) within Log::Log4perl::Logger::BEGIN@760 which was called: # once (6µs+8µs) by Log::Log4perl::BEGIN@12 at line 760
no strict qw(refs);
# spent 14µs making 1 call to Log::Log4perl::Logger::BEGIN@760 # spent 8µs making 1 call to strict::unimport
761
762 # This is a bit better way to create code on the fly than eval'ing strings.
763 # -erik
764
765 *{__PACKAGE__ . "::$lclevel"} = sub {
766 if(_INTERNAL_DEBUG) {
767 my $level_disp = (defined $_[0]->{level} ? $_[0]->{level}
768 : "[undef]");
769 print "$lclevel: ($_[0]->{category}/$level_disp) [@_]\n";
770 }
771 init_warn() unless $INITIALIZED or $NON_INIT_WARNED;
772 $_[0]->{$level}->(@_, $level) if defined $_[0]->{$level};
773838µs };
774
775 # Added these to have is_xxx functions as fast as xxx functions
776 # -ms
777
77884µs my $islevel = "is_" . $level;
77983µs my $islclevel = "is_" . $lclevel;
780
781 *{__PACKAGE__ . "::is_$lclevel"} = sub {
782 $_[0]->{$islevel}->($_[0], $islclevel);
783842µs };
784
785 # Add the isXxxEnabled() methods as identical to the is_xxx
786 # functions. - dviner
787
788 *{__PACKAGE__ . "::is".$initial_cap."Enabled"} =
789832µs \&{__PACKAGE__ . "::is_$lclevel"};
790
7913941µs221µs
# spent 14µs (6+8) within Log::Log4perl::Logger::BEGIN@791 which was called: # once (6µs+8µs) by Log::Log4perl::BEGIN@12 at line 791
use strict qw(refs);
# spent 14µs making 1 call to Log::Log4perl::Logger::BEGIN@791 # spent 8µs making 1 call to strict::import
792
793823µs return 0;
794}
795
796#now lets autogenerate the logger subs based on the defined priorities
79712µsforeach my $level (keys %Log::Log4perl::Level::PRIORITY){
798815µs8148µs create_log_level_methods($level);
# spent 148µs making 8 calls to Log::Log4perl::Logger::create_log_level_methods, avg 18µs/call
799}
800
801##################################################
802sub init_warn {
803##################################################
804 CORE::warn "Log4perl: Seems like no initialization happened. " .
805 "Forgot to call init()?\n";
806 # Only tell this once;
807 $NON_INIT_WARNED = 1;
808}
809
810#######################################################
811# call me from a sub-func to spew the sub-func's caller
812#######################################################
813sub callerline {
814 my $message = join ('', @_);
815
816 my ($pack, $file, $line) = caller($Log::Log4perl::caller_depth + 1);
817
818 if (not chomp $message) { # no newline
819 $message .= " at $file line $line";
820
821 # Someday, we'll use Threads. Really.
822 if (defined &Thread::tid) {
823 my $tid = Thread->self->tid;
824 $message .= " thread $tid" if $tid;
825 }
826 }
827
828 return ($message, "\n");
829}
830
831#######################################################
832sub and_warn {
833#######################################################
834 my $self = shift;
835 CORE::warn(callerline($self->warning_render(@_)));
836}
837
838#######################################################
839sub and_die {
840#######################################################
841 my $self = shift;
842
843 my($msg) = callerline($self->warning_render(@_));
844
845 if($DIE_DEBUG) {
846 $DIE_DEBUG_BUFFER = "DIE_DEBUG: $msg";
847 } else {
848 die("$msg\n");
849 }
850}
851
852##################################################
853sub logwarn {
854##################################################
855 my $self = shift;
856
857 local $Log::Log4perl::caller_depth =
858 $Log::Log4perl::caller_depth + 1;
859
860 if ($self->is_warn()) {
861 # Since we're one caller level off now, compensate for that.
862 my @chomped = @_;
863 chomp($chomped[-1]);
864 $self->warn(@chomped);
865 }
866
867 $self->and_warn(@_);
868}
869
870##################################################
871sub logdie {
872##################################################
873 my $self = shift;
874
875 local $Log::Log4perl::caller_depth =
876 $Log::Log4perl::caller_depth + 1;
877
878 if ($self->is_fatal()) {
879 # Since we're one caller level off now, compensate for that.
880 my @chomped = @_;
881 chomp($chomped[-1]);
882 $self->fatal(@chomped);
883 }
884
885 $Log::Log4perl::LOGDIE_MESSAGE_ON_STDERR ?
886 $self->and_die(@_) :
887 exit($Log::Log4perl::LOGEXIT_CODE);
888}
889
890##################################################
891sub logexit {
892##################################################
893 my $self = shift;
894
895 local $Log::Log4perl::caller_depth =
896 $Log::Log4perl::caller_depth + 1;
897
898 if ($self->is_fatal()) {
899 # Since we're one caller level off now, compensate for that.
900 my @chomped = @_;
901 chomp($chomped[-1]);
902 $self->fatal(@chomped);
903 }
904
905 exit $Log::Log4perl::LOGEXIT_CODE;
906}
907
908##################################################
909# clucks and carps are WARN level
910sub logcluck {
911##################################################
912 my $self = shift;
913
914 local $Log::Log4perl::caller_depth =
915 $Log::Log4perl::caller_depth + 1;
916
917 local $Carp::CarpLevel =
918 $Carp::CarpLevel + 1;
919
920 my $msg = $self->warning_render(@_);
921
922 if ($self->is_warn()) {
923 my $message = Carp::longmess($msg);
924 foreach (split(/\n/, $message)) {
925 $self->warn("$_\n");
926 }
927 }
928
929 Carp::cluck($msg);
930}
931
932##################################################
933sub logcarp {
934##################################################
935 my $self = shift;
936
937 local $Carp::CarpLevel = $Carp::CarpLevel + 1;
938
939 local $Log::Log4perl::caller_depth =
940 $Log::Log4perl::caller_depth + 1;
941
942 my $msg = $self->warning_render(@_);
943
944 if ($self->is_warn()) {
945 my $message = Carp::shortmess($msg);
946 foreach (split(/\n/, $message)) {
947 $self->warn("$_\n");
948 }
949 }
950
951 Carp::carp($msg);
952}
953
954##################################################
955# croaks and confess are FATAL level
956##################################################
957sub logcroak {
958##################################################
959 my $self = shift;
960
961 my $msg = $self->warning_render(@_);
962
963 local $Carp::CarpLevel =
964 $Carp::CarpLevel + 1;
965
966 local $Log::Log4perl::caller_depth =
967 $Log::Log4perl::caller_depth + 1;
968
969 if ($self->is_fatal()) {
970 my $message = Carp::shortmess($msg);
971 foreach (split(/\n/, $message)) {
972 $self->fatal("$_\n");
973 }
974 }
975
976 $Log::Log4perl::LOGDIE_MESSAGE_ON_STDERR ?
977 Carp::croak($msg) :
978 exit($Log::Log4perl::LOGEXIT_CODE);
979}
980
981##################################################
982sub logconfess {
983##################################################
984 my $self = shift;
985
986 local $Carp::CarpLevel =
987 $Carp::CarpLevel + 1;
988
989 local $Log::Log4perl::caller_depth =
990 $Log::Log4perl::caller_depth + 1;
991
992 my $msg = $self->warning_render(@_);
993
994 if ($self->is_fatal()) {
995 my $message = Carp::longmess($msg);
996 foreach (split(/\n/, $message)) {
997 $self->fatal("$_\n");
998 }
999 }
1000
1001 $Log::Log4perl::LOGDIE_MESSAGE_ON_STDERR ?
1002 confess($msg) :
1003 exit($Log::Log4perl::LOGEXIT_CODE);
1004}
1005
1006##################################################
1007# in case people prefer to use error for warning
1008##################################################
1009sub error_warn {
1010##################################################
1011 my $self = shift;
1012
1013 local $Log::Log4perl::caller_depth =
1014 $Log::Log4perl::caller_depth + 1;
1015
1016 if ($self->is_error()) {
1017 $self->error(@_);
1018 }
1019
1020 $self->and_warn(@_);
1021}
1022
1023##################################################
1024sub error_die {
1025##################################################
1026 my $self = shift;
1027
1028 local $Log::Log4perl::caller_depth =
1029 $Log::Log4perl::caller_depth + 1;
1030
1031 my $msg = $self->warning_render(@_);
1032
1033 if ($self->is_error()) {
1034 $self->error($msg);
1035 }
1036
1037 $Log::Log4perl::LOGDIE_MESSAGE_ON_STDERR ?
1038 $self->and_die($msg) :
1039 exit($Log::Log4perl::LOGEXIT_CODE);
1040}
1041
1042##################################################
1043sub more_logging {
1044##################################################
1045 my ($self) = shift;
1046 return $self->dec_level(@_);
1047}
1048
1049##################################################
1050sub inc_level {
1051##################################################
1052 my ($self, $delta) = @_;
1053
1054 $delta ||= 1;
1055
1056 $self->level(Log::Log4perl::Level::get_higher_level($self->level(),
1057 $delta));
1058
1059 $self->set_output_methods;
1060}
1061
1062##################################################
1063sub less_logging {
1064##################################################
1065 my ($self) = shift;
1066 return $self->inc_level(@_);
1067}
1068
1069##################################################
1070sub dec_level {
1071##################################################
1072 my ($self, $delta) = @_;
1073
1074 $delta ||= 1;
1075
1076 $self->level(Log::Log4perl::Level::get_lower_level($self->level(), $delta));
1077
1078 $self->set_output_methods;
1079}
1080
1081121µs1;
1082
1083__END__
 
# spent 500ns within Log::Log4perl::Logger::CORE:subst which was called: # once (500ns+0s) by Log::Log4perl::Logger::_new at line 127
sub Log::Log4perl::Logger::CORE:subst; # opcode