← 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.pm
StatementsExecuted 76 statements in 2.64ms
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
1113.88ms23.1msLog::Log4perl::::BEGIN@12Log::Log4perl::BEGIN@12
111207µs1.85msLog::Log4perl::::BEGIN@11Log::Log4perl::BEGIN@11
11134µs34µsLog::Log4perl::::BEGIN@7Log::Log4perl::BEGIN@7
11119µs118µsLog::Log4perl::::ENDLog::Log4perl::END
11116µs76µsLog::Log4perl::::BEGIN@13Log::Log4perl::BEGIN@13
11115µs39µsLog::Log4perl::::BEGIN@488Log::Log4perl::BEGIN@488
11112µs28µsLog::Log4perl::::BEGIN@9Log::Log4perl::BEGIN@9
11110µs18µsLog::Log4perl::::BEGIN@525Log::Log4perl::BEGIN@525
1119µs14µsLog::Log4perl::::BEGIN@8Log::Log4perl::BEGIN@8
1119µs26µsLog::Log4perl::::BEGIN@96Log::Log4perl::BEGIN@96
1119µs9µsLog::Log4perl::::importLog::Log4perl::import
1119µs9µsLog::Log4perl::::easy_closure_global_cleanupLog::Log4perl::easy_closure_global_cleanup
1119µs70µsLog::Log4perl::::BEGIN@69Log::Log4perl::BEGIN@69
1116µs16µsLog::Log4perl::::BEGIN@511Log::Log4perl::BEGIN@511
1116µs13µsLog::Log4perl::::BEGIN@110Log::Log4perl::BEGIN@110
1115µs13µsLog::Log4perl::::BEGIN@526Log::Log4perl::BEGIN@526
1115µs5µsLog::Log4perl::::BEGIN@14Log::Log4perl::BEGIN@14
1115µs5µsLog::Log4perl::::BEGIN@15Log::Log4perl::BEGIN@15
0000s0sLog::Log4perl::::__ANON__[:134]Log::Log4perl::__ANON__[:134]
0000s0sLog::Log4perl::::__ANON__[:144]Log::Log4perl::__ANON__[:144]
0000s0sLog::Log4perl::::__ANON__[:156]Log::Log4perl::__ANON__[:156]
0000s0sLog::Log4perl::::__ANON__[:164]Log::Log4perl::__ANON__[:164]
0000s0sLog::Log4perl::::__ANON__[:173]Log::Log4perl::__ANON__[:173]
0000s0sLog::Log4perl::::__ANON__[:199]Log::Log4perl::__ANON__[:199]
0000s0sLog::Log4perl::::__ANON__[:495]Log::Log4perl::__ANON__[:495]
0000s0sLog::Log4perl::::__ANON__[:499]Log::Log4perl::__ANON__[:499]
0000s0sLog::Log4perl::::__ANON__[:503]Log::Log4perl::__ANON__[:503]
0000s0sLog::Log4perl::::__ANON__[:533]Log::Log4perl::__ANON__[:533]
0000s0sLog::Log4perl::::add_appenderLog::Log4perl::add_appender
0000s0sLog::Log4perl::::appender_by_nameLog::Log4perl::appender_by_name
0000s0sLog::Log4perl::::appender_thresholds_adjustLog::Log4perl::appender_thresholds_adjust
0000s0sLog::Log4perl::::appendersLog::Log4perl::appenders
0000s0sLog::Log4perl::::easy_closure_category_cleanupLog::Log4perl::easy_closure_category_cleanup
0000s0sLog::Log4perl::::easy_closure_cleanupLog::Log4perl::easy_closure_cleanup
0000s0sLog::Log4perl::::easy_closure_createLog::Log4perl::easy_closure_create
0000s0sLog::Log4perl::::easy_closure_logger_removeLog::Log4perl::easy_closure_logger_remove
0000s0sLog::Log4perl::::easy_initLog::Log4perl::easy_init
0000s0sLog::Log4perl::::eradicate_appenderLog::Log4perl::eradicate_appender
0000s0sLog::Log4perl::::get_loggerLog::Log4perl::get_logger
0000s0sLog::Log4perl::::infiltrate_lwpLog::Log4perl::infiltrate_lwp
0000s0sLog::Log4perl::::initLog::Log4perl::init
0000s0sLog::Log4perl::::init_and_watchLog::Log4perl::init_and_watch
0000s0sLog::Log4perl::::init_onceLog::Log4perl::init_once
0000s0sLog::Log4perl::::initializedLog::Log4perl::initialized
0000s0sLog::Log4perl::::newLog::Log4perl::new
0000s0sLog::Log4perl::::remove_loggerLog::Log4perl::remove_logger
0000s0sLog::Log4perl::::resetLog::Log4perl::reset
0000s0sLog::Log4perl::::wrapper_registerLog::Log4perl::wrapper_register
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;
3##################################################
4
5216µs199µs
# spent 118µs (19+99) within Log::Log4perl::END which was called: # once (19µs+99µs) by main::RUNTIME at line 0 of xt/tapper-mcp-scheduler-with-db-longrun.t
END { local($?); Log::Log4perl::Logger::cleanup(); }
# spent 99µs making 1 call to Log::Log4perl::Logger::cleanup
6
7340µs134µs
# spent 34µs within Log::Log4perl::BEGIN@7 which was called: # once (34µs+0s) by MooseX::Log::Log4perl::BEGIN@5 at line 7
use 5.006;
# spent 34µs making 1 call to Log::Log4perl::BEGIN@7
8318µs220µs
# spent 14µs (9+5) within Log::Log4perl::BEGIN@8 which was called: # once (9µs+5µs) by MooseX::Log::Log4perl::BEGIN@5 at line 8
use strict;
# spent 14µs making 1 call to Log::Log4perl::BEGIN@8 # spent 5µs making 1 call to strict::import
9319µs244µs
# spent 28µs (12+16) within Log::Log4perl::BEGIN@9 which was called: # once (12µs+16µs) by MooseX::Log::Log4perl::BEGIN@5 at line 9
use warnings;
# spent 28µs making 1 call to Log::Log4perl::BEGIN@9 # spent 16µs making 1 call to warnings::import
10
113111µs11.85ms
# spent 1.85ms (207µs+1.64) within Log::Log4perl::BEGIN@11 which was called: # once (207µs+1.64ms) by MooseX::Log::Log4perl::BEGIN@5 at line 11
use Log::Log4perl::Util;
# spent 1.85ms making 1 call to Log::Log4perl::BEGIN@11
123113µs123.1ms
# spent 23.1ms (3.88+19.3) within Log::Log4perl::BEGIN@12 which was called: # once (3.88ms+19.3ms) by MooseX::Log::Log4perl::BEGIN@5 at line 12
use Log::Log4perl::Logger;
# spent 23.1ms making 1 call to Log::Log4perl::BEGIN@12
13326µs2136µs
# spent 76µs (16+60) within Log::Log4perl::BEGIN@13 which was called: # once (16µs+60µs) by MooseX::Log::Log4perl::BEGIN@5 at line 13
use Log::Log4perl::Level;
# spent 76µs making 1 call to Log::Log4perl::BEGIN@13 # spent 60µs making 1 call to Log::Log4perl::Level::import
14319µs15µs
# spent 5µs within Log::Log4perl::BEGIN@14 which was called: # once (5µs+0s) by MooseX::Log::Log4perl::BEGIN@5 at line 14
use Log::Log4perl::Config;
# spent 5µs making 1 call to Log::Log4perl::BEGIN@14
153155µs15µs
# spent 5µs within Log::Log4perl::BEGIN@15 which was called: # once (5µs+0s) by MooseX::Log::Log4perl::BEGIN@5 at line 15
use Log::Log4perl::Appender;
# spent 5µs making 1 call to Log::Log4perl::BEGIN@15
16
171800nsour $VERSION = '1.36';
18
19 # set this to '1' if you're using a wrapper
20 # around Log::Log4perl
211300nsour $caller_depth = 0;
22
23 #this is a mapping of convenience names to opcode masks used in
24 #$ALLOWED_CODE_OPS_IN_CONFIG_FILE below
2514µsour %ALLOWED_CODE_OPS = (
26 'safe' => [ ':browse' ],
27 'restrictive' => [ ':default' ],
28);
29
3013µsour %WRAPPERS_REGISTERED = map { $_ => 1 } qw(Log::Log4perl);
31
32 #set this to the opcodes which are allowed when
33 #$ALLOW_CODE_IN_CONFIG_FILE is set to a true value
34 #if undefined, there are no restrictions on code that can be
35 #excuted
361200nsour @ALLOWED_CODE_OPS_IN_CONFIG_FILE;
37
38 #this hash lists things that should be exported into the Safe
39 #compartment. The keys are the package the symbol should be
40 #exported from and the values are array references to the names
41 #of the symbols (including the leading type specifier)
4211µsour %VARS_SHARED_WITH_SAFE_COMPARTMENT = (
43 main => [ '%ENV' ],
44);
45
46 #setting this to a true value will allow Perl code to be executed
47 #within the config file. It works in conjunction with
48 #$ALLOWED_CODE_OPS_IN_CONFIG_FILE, which if defined restricts the
49 #opcodes which can be executed using the 'Safe' module.
50 #setting this to a false value disables code execution in the
51 #config file
521400nsour $ALLOW_CODE_IN_CONFIG_FILE = 1;
53
54 #arrays in a log message will be joined using this character,
55 #see Log::Log4perl::Appender::DBI
561400nsour $JOIN_MSG_ARRAY_CHAR = '';
57
58 #version required for XML::DOM, to enable XML Config parsing
59 #and XML Config unit tests
601400nsour $DOM_VERSION_REQUIRED = '1.29';
61
621300nsour $CHATTY_DESTROY_METHODS = 0;
63
641200nsour $LOGDIE_MESSAGE_ON_STDERR = 1;
651200nsour $LOGEXIT_CODE = 1;
661200nsour %IMPORT_CALLED;
67
681600nsour $EASY_CLOSURES = {};
693104µs2131µs
# spent 70µs (9+61) within Log::Log4perl::BEGIN@69 which was called: # once (9µs+61µs) by MooseX::Log::Log4perl::BEGIN@5 at line 69
use constant _INTERNAL_DEBUG => 0;
# spent 70µs making 1 call to Log::Log4perl::BEGIN@69 # spent 61µs making 1 call to constant::import
70
71##################################################
72
# spent 9µs within Log::Log4perl::import which was called: # once (9µs+0s) by MooseX::Log::Log4perl::BEGIN@5 at line 5 of MooseX/Log/Log4perl.pm
sub import {
73##################################################
741311µs my($class) = shift;
75
76 my $caller_pkg = caller();
77
78 return 1 if $IMPORT_CALLED{$caller_pkg}++;
79
80 my(%tags) = map { $_ => 1 } @_;
81
82 # Lazy man's logger
83 if(exists $tags{':easy'}) {
84 $tags{':levels'} = 1;
85 $tags{':nowarn'} = 1;
86 $tags{'get_logger'} = 1;
87 }
88
89 if(exists $tags{':no_extra_logdie_message'}) {
90 $Log::Log4perl::LOGDIE_MESSAGE_ON_STDERR = 0;
91 delete $tags{':no_extra_logdie_message'};
92 }
93
94 if(exists $tags{get_logger}) {
95 # Export get_logger into the calling module's
96370µs243µs
# spent 26µs (9+17) within Log::Log4perl::BEGIN@96 which was called: # once (9µs+17µs) by MooseX::Log::Log4perl::BEGIN@5 at line 96
no strict qw(refs);
# spent 26µs making 1 call to Log::Log4perl::BEGIN@96 # spent 17µs making 1 call to strict::unimport
97 *{"$caller_pkg\::get_logger"} = *get_logger;
98
99 delete $tags{get_logger};
100 }
101
102 if(exists $tags{':levels'}) {
103 # Export log levels ($DEBUG, $INFO etc.) from Log4perl::Level
104 for my $key (keys %Log::Log4perl::Level::PRIORITY) {
105 my $name = "$caller_pkg\::$key";
106 # Need to split this up in two lines, or CVS will
107 # mess it up.
108 my $value = $
109 Log::Log4perl::Level::PRIORITY{$key};
11031.39ms221µs
# spent 13µs (6+7) within Log::Log4perl::BEGIN@110 which was called: # once (6µs+7µs) by MooseX::Log::Log4perl::BEGIN@5 at line 110
no strict qw(refs);
# spent 13µs making 1 call to Log::Log4perl::BEGIN@110 # spent 7µs making 1 call to strict::unimport
111 *{"$name"} = \$value;
112 }
113
114 delete $tags{':levels'};
115 }
116
117 # Lazy man's logger
118 if(exists $tags{':easy'}) {
119 delete $tags{':easy'};
120
121 # Define default logger object in caller's package
122 my $logger = get_logger("$caller_pkg");
123
124 # Define DEBUG, INFO, etc. routines in caller's package
125 for(qw(TRACE DEBUG INFO WARN ERROR FATAL ALWAYS)) {
126 my $level = $_;
127 $level = "OFF" if $level eq "ALWAYS";
128 my $lclevel = lc($_);
129 easy_closure_create($caller_pkg, $_, sub {
130 Log::Log4perl::Logger::init_warn() unless
131 $Log::Log4perl::Logger::INITIALIZED or
132 $Log::Log4perl::Logger::NON_INIT_WARNED;
133 $logger->{$level}->($logger, @_, $level);
134 }, $logger);
135 }
136
137 # Define LOGCROAK, LOGCLUCK, etc. routines in caller's package
138 for(qw(LOGCROAK LOGCLUCK LOGCARP LOGCONFESS)) {
139 my $method = "Log::Log4perl::Logger::" . lc($_);
140
141 easy_closure_create($caller_pkg, $_, sub {
142 unshift @_, $logger;
143 goto &$method;
144 }, $logger);
145 }
146
147 # Define LOGDIE, LOGWARN
148 easy_closure_create($caller_pkg, "LOGDIE", sub {
149 Log::Log4perl::Logger::init_warn() unless
150 $Log::Log4perl::Logger::INITIALIZED or
151 $Log::Log4perl::Logger::NON_INIT_WARNED;
152 $logger->{FATAL}->($logger, @_, "FATAL");
153 $Log::Log4perl::LOGDIE_MESSAGE_ON_STDERR ?
154 CORE::die(Log::Log4perl::Logger::callerline(join '', @_)) :
155 exit $Log::Log4perl::LOGEXIT_CODE;
156 }, $logger);
157
158 easy_closure_create($caller_pkg, "LOGEXIT", sub {
159 Log::Log4perl::Logger::init_warn() unless
160 $Log::Log4perl::Logger::INITIALIZED or
161 $Log::Log4perl::Logger::NON_INIT_WARNED;
162 $logger->{FATAL}->($logger, @_, "FATAL");
163 exit $Log::Log4perl::LOGEXIT_CODE;
164 }, $logger);
165
166 easy_closure_create($caller_pkg, "LOGWARN", sub {
167 Log::Log4perl::Logger::init_warn() unless
168 $Log::Log4perl::Logger::INITIALIZED or
169 $Log::Log4perl::Logger::NON_INIT_WARNED;
170 $logger->{WARN}->($logger, @_, "WARN");
171 CORE::warn(Log::Log4perl::Logger::callerline(join '', @_))
172 if $Log::Log4perl::LOGDIE_MESSAGE_ON_STDERR;
173 }, $logger);
174 }
175
176 if(exists $tags{':nowarn'}) {
177 $Log::Log4perl::Logger::NON_INIT_WARNED = 1;
178 delete $tags{':nowarn'};
179 }
180
181 if(exists $tags{':nostrict'}) {
182 $Log::Log4perl::Logger::NO_STRICT = 1;
183 delete $tags{':nostrict'};
184 }
185
186 if(exists $tags{':resurrect'}) {
187 my $FILTER_MODULE = "Filter::Util::Call";
188 if(! Log::Log4perl::Util::module_available($FILTER_MODULE)) {
189 die "$FILTER_MODULE required with :resurrect" .
190 "(install from CPAN)";
191 }
192 eval "require $FILTER_MODULE" or die "Cannot pull in $FILTER_MODULE";
193 Filter::Util::Call::filter_add(
194 sub {
195 my($status);
196 s/^\s*###l4p// if
197 ($status = Filter::Util::Call::filter_read()) > 0;
198 $status;
199 });
200 delete $tags{':resurrect'};
201 }
202
203 if(keys %tags) {
204 # We received an Option we couldn't understand.
205 die "Unknown Option(s): @{[keys %tags]}";
206 }
207}
208
209##################################################
210sub initialized {
211##################################################
212 return $Log::Log4perl::Logger::INITIALIZED;
213}
214
215##################################################
216sub new {
217##################################################
218 die "THIS CLASS ISN'T FOR DIRECT USE. " .
219 "PLEASE CHECK 'perldoc " . __PACKAGE__ . "'.";
220}
221
222##################################################
223sub reset { # Mainly for debugging/testing
224##################################################
225 # Delegate this to the logger ...
226 return Log::Log4perl::Logger->reset();
227}
228
229##################################################
230sub init_once { # Call init only if it hasn't been
231 # called yet.
232##################################################
233 init(@_) unless $Log::Log4perl::Logger::INITIALIZED;
234}
235
236##################################################
237sub init { # Read the config file
238##################################################
239 my($class, @args) = @_;
240
241 #woops, they called ::init instead of ->init, let's be forgiving
242 if ($class ne __PACKAGE__) {
243 unshift(@args, $class);
244 }
245
246 # Delegate this to the config module
247 return Log::Log4perl::Config->init(@args);
248}
249
250##################################################
251sub init_and_watch {
252##################################################
253 my($class, @args) = @_;
254
255 #woops, they called ::init instead of ->init, let's be forgiving
256 if ($class ne __PACKAGE__) {
257 unshift(@args, $class);
258 }
259
260 # Delegate this to the config module
261 return Log::Log4perl::Config->init_and_watch(@args);
262}
263
264
265##################################################
266sub easy_init { # Initialize the root logger with a screen appender
267##################################################
268 my($class, @args) = @_;
269
270 # Did somebody call us with Log::Log4perl::easy_init()?
271 if(ref($class) or $class =~ /^\d+$/) {
272 unshift @args, $class;
273 }
274
275 # Reset everything first
276 Log::Log4perl->reset();
277
278 my @loggers = ();
279
280 my %default = ( level => $DEBUG,
281 file => "STDERR",
282 utf8 => undef,
283 category => "",
284 layout => "%d %m%n",
285 );
286
287 if(!@args) {
288 push @loggers, \%default;
289 } else {
290 for my $arg (@args) {
291 if($arg =~ /^\d+$/) {
292 my %logger = (%default, level => $arg);
293 push @loggers, \%logger;
294 } elsif(ref($arg) eq "HASH") {
295 my %logger = (%default, %$arg);
296 push @loggers, \%logger;
297 }
298 }
299 }
300
301 for my $logger (@loggers) {
302
303 my $app;
304
305 if($logger->{file} =~ /^stderr$/i) {
306 $app = Log::Log4perl::Appender->new(
307 "Log::Log4perl::Appender::Screen",
308 utf8 => $logger->{utf8});
309 } elsif($logger->{file} =~ /^stdout$/i) {
310 $app = Log::Log4perl::Appender->new(
311 "Log::Log4perl::Appender::Screen",
312 stderr => 0,
313 utf8 => $logger->{utf8});
314 } else {
315 my $binmode;
316 if($logger->{file} =~ s/^(:.*?)>/>/) {
317 $binmode = $1;
318 }
319 $logger->{file} =~ /^(>)?(>)?/;
320 my $mode = ($2 ? "append" : "write");
321 $logger->{file} =~ s/.*>+\s*//g;
322 $app = Log::Log4perl::Appender->new(
323 "Log::Log4perl::Appender::File",
324 filename => $logger->{file},
325 mode => $mode,
326 utf8 => $logger->{utf8},
327 binmode => $binmode,
328 );
329 }
330
331 my $layout = Log::Log4perl::Layout::PatternLayout->new(
332 $logger->{layout});
333 $app->layout($layout);
334
335 my $log = Log::Log4perl->get_logger($logger->{category});
336 $log->level($logger->{level});
337 $log->add_appender($app);
338 }
339
340 $Log::Log4perl::Logger::INITIALIZED = 1;
341}
342
343##################################################
344sub wrapper_register {
345##################################################
346 my $wrapper = $_[-1];
347
348 $WRAPPERS_REGISTERED{ $wrapper } = 1;
349}
350
351##################################################
352sub get_logger { # Get an instance (shortcut)
353##################################################
354 # get_logger() can be called in the following ways:
355 #
356 # (1) Log::Log4perl::get_logger() => ()
357 # (2) Log::Log4perl->get_logger() => ("Log::Log4perl")
358 # (3) Log::Log4perl::get_logger($cat) => ($cat)
359 #
360 # (5) Log::Log4perl->get_logger($cat) => ("Log::Log4perl", $cat)
361 # (6) L4pSubclass->get_logger($cat) => ("L4pSubclass", $cat)
362
363 # Note that (4) L4pSubclass->get_logger() => ("L4pSubclass")
364 # is indistinguishable from (3) and therefore can't be allowed.
365 # Wrapper classes always have to specify the category explicitely.
366
367 my $category;
368
369 if(@_ == 0) {
370 # 1
371 my $level = 0;
372 do { $category = scalar caller($level++);
373 } while exists $WRAPPERS_REGISTERED{ $category };
374
375 } elsif(@_ == 1) {
376 # 2, 3
377 $category = $_[0];
378
379 my $level = 0;
380 while(exists $WRAPPERS_REGISTERED{ $category }) {
381 $category = scalar caller($level++);
382 }
383
384 } else {
385 # 5, 6
386 $category = $_[1];
387 }
388
389 # Delegate this to the logger module
390 return Log::Log4perl::Logger->get_logger($category);
391}
392
393##################################################
394sub appenders { # Get a hashref of all defined appender wrappers
395##################################################
396 return \%Log::Log4perl::Logger::APPENDER_BY_NAME;
397}
398
399##################################################
400sub add_appender { # Add an appender to the system, but don't assign
401 # it to a logger yet
402##################################################
403 my($class, $appender) = @_;
404
405 my $name = $appender->name();
406 die "Mandatory parameter 'name' missing in appender" unless defined $name;
407
408 # Make it known by name in the Log4perl universe
409 # (so that composite appenders can find it)
410 Log::Log4perl->appenders()->{ $name } = $appender;
411}
412
413##################################################
414# Return number of appenders changed
415sub appender_thresholds_adjust { # Readjust appender thresholds
416##################################################
417 # If someone calls L4p-> and not L4p::
418 shift if $_[0] eq __PACKAGE__;
419 my($delta, $appenders) = @_;
420 my $retval = 0;
421
422 if($delta == 0) {
423 # Nothing to do, no delta given.
424 return;
425 }
426
427 if(defined $appenders) {
428 # Map names to objects
429 $appenders = [map {
430 die "Unkown appender: '$_'" unless exists
431 $Log::Log4perl::Logger::APPENDER_BY_NAME{
432 $_};
433 $Log::Log4perl::Logger::APPENDER_BY_NAME{
434 $_}
435 } @$appenders];
436 } else {
437 # Just hand over all known appenders
438 $appenders = [values %{Log::Log4perl::appenders()}] unless
439 defined $appenders;
440 }
441
442 # Change all appender thresholds;
443 foreach my $app (@$appenders) {
444 my $old_thres = $app->threshold();
445 my $new_thres;
446 if($delta > 0) {
447 $new_thres = Log::Log4perl::Level::get_higher_level(
448 $old_thres, $delta);
449 } else {
450 $new_thres = Log::Log4perl::Level::get_lower_level(
451 $old_thres, -$delta);
452 }
453
454 ++$retval if ($app->threshold($new_thres) == $new_thres);
455 }
456 return $retval;
457}
458
459##################################################
460sub appender_by_name { # Get a (real) appender by name
461##################################################
462 # If someone calls L4p->appender_by_name and not L4p::appender_by_name
463 shift if $_[0] eq __PACKAGE__;
464
465 my($name) = @_;
466
467 if(defined $name and
468 exists $Log::Log4perl::Logger::APPENDER_BY_NAME{
469 $name}) {
470 return $Log::Log4perl::Logger::APPENDER_BY_NAME{
471 $name}->{appender};
472 } else {
473 return undef;
474 }
475}
476
477##################################################
478sub eradicate_appender { # Remove an appender from the system
479##################################################
480 # If someone calls L4p->... and not L4p::...
481 shift if $_[0] eq __PACKAGE__;
482 Log::Log4perl::Logger->eradicate_appender(@_);
483}
484
485##################################################
486sub infiltrate_lwp { #
487##################################################
4883142µs263µs
# spent 39µs (15+24) within Log::Log4perl::BEGIN@488 which was called: # once (15µs+24µs) by MooseX::Log::Log4perl::BEGIN@5 at line 488
no warnings qw(redefine);
# spent 39µs making 1 call to Log::Log4perl::BEGIN@488 # spent 24µs making 1 call to warnings::unimport
489
490 my $l4p_wrapper = sub {
491 my($prio, @message) = @_;
492 local $Log::Log4perl::caller_depth =
493 $Log::Log4perl::caller_depth + 2;
494 get_logger(scalar caller(1))->log($prio, @message);
495 };
496
497 *LWP::Debug::trace = sub {
498 $l4p_wrapper->($INFO, @_);
499 };
500 *LWP::Debug::conns =
501 *LWP::Debug::debug = sub {
502 $l4p_wrapper->($DEBUG, @_);
503 };
504}
505
506##################################################
507sub easy_closure_create {
508##################################################
509 my($caller_pkg, $entry, $code, $logger) = @_;
510
511383µs226µs
# spent 16µs (6+10) within Log::Log4perl::BEGIN@511 which was called: # once (6µs+10µs) by MooseX::Log::Log4perl::BEGIN@5 at line 511
no strict 'refs';
# spent 16µs making 1 call to Log::Log4perl::BEGIN@511 # spent 10µs making 1 call to strict::unimport
512
513 print("easy_closure: Setting shortcut $caller_pkg\::$entry ",
514 "(logger=$logger\n") if _INTERNAL_DEBUG;
515
516 $EASY_CLOSURES->{ $caller_pkg }->{ $entry } = $logger;
517 *{"$caller_pkg\::$entry"} = $code;
518}
519
520###########################################
521sub easy_closure_cleanup {
522###########################################
523 my($caller_pkg, $entry) = @_;
524
525319µs226µs
# spent 18µs (10+8) within Log::Log4perl::BEGIN@525 which was called: # once (10µs+8µs) by MooseX::Log::Log4perl::BEGIN@5 at line 525
no warnings 'redefine';
# spent 18µs making 1 call to Log::Log4perl::BEGIN@525 # spent 8µs making 1 call to warnings::unimport
5263269µs220µs
# spent 13µs (5+7) within Log::Log4perl::BEGIN@526 which was called: # once (5µs+7µs) by MooseX::Log::Log4perl::BEGIN@5 at line 526
no strict 'refs';
# spent 13µs making 1 call to Log::Log4perl::BEGIN@526 # spent 7µs making 1 call to strict::unimport
527
528 my $logger = $EASY_CLOSURES->{ $caller_pkg }->{ $entry };
529
530 print("easy_closure: Nuking easy shortcut $caller_pkg\::$entry ",
531 "(logger=$logger\n") if _INTERNAL_DEBUG;
532
533 *{"$caller_pkg\::$entry"} = sub { };
534 delete $EASY_CLOSURES->{ $caller_pkg }->{ $entry };
535}
536
537##################################################
538sub easy_closure_category_cleanup {
539##################################################
540 my($caller_pkg) = @_;
541
542 if(! exists $EASY_CLOSURES->{ $caller_pkg } ) {
543 return 1;
544 }
545
546 for my $entry ( keys %{ $EASY_CLOSURES->{ $caller_pkg } } ) {
547 easy_closure_cleanup( $caller_pkg, $entry );
548 }
549
550 delete $EASY_CLOSURES->{ $caller_pkg };
551}
552
553###########################################
554
# spent 9µs within Log::Log4perl::easy_closure_global_cleanup which was called: # once (9µs+0s) by Log::Log4perl::Logger::cleanup at line 65 of Log/Log4perl/Logger.pm
sub easy_closure_global_cleanup {
555###########################################
556
557115µs for my $caller_pkg ( keys %$EASY_CLOSURES ) {
558 easy_closure_category_cleanup( $caller_pkg );
559 }
560}
561
562###########################################
563sub easy_closure_logger_remove {
564###########################################
565 my($class, $logger) = @_;
566
567 PKG: for my $caller_pkg ( keys %$EASY_CLOSURES ) {
568 for my $entry ( keys %{ $EASY_CLOSURES->{ $caller_pkg } } ) {
569 if( $logger == $EASY_CLOSURES->{ $caller_pkg }->{ $entry } ) {
570 easy_closure_category_cleanup( $caller_pkg );
571 next PKG;
572 }
573 }
574 }
575}
576
577##################################################
578sub remove_logger {
579##################################################
580 my ($class, $logger) = @_;
581
582 # Any stealth logger convenience function still using it will
583 # now become a no-op.
584 Log::Log4perl->easy_closure_logger_remove( $logger );
585
586 # Remove the logger from the system
587 delete $Log::Log4perl::Logger::LOGGERS_BY_NAME->{ $logger->{category} };
588}
589
59019µs1;
591
592__END__