Profile of Log/Log4perl.pm

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

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

Subroutines
Calls | P | F | Exclusive Time | Inclusive Time | Subroutine
--- | --- | --- | --- | --- | ---
1 | 1 | 1 | 3.88ms | 23.1ms | Log::Log4perl::::BEGIN@12Log::Log4perl::BEGIN@12
1 | 1 | 1 | 207µs | 1.85ms | Log::Log4perl::::BEGIN@11Log::Log4perl::BEGIN@11
1 | 1 | 1 | 34µs | 34µs | Log::Log4perl::::BEGIN@7Log::Log4perl::BEGIN@7
1 | 1 | 1 | 19µs | 118µs | Log::Log4perl::::ENDLog::Log4perl::END
1 | 1 | 1 | 16µs | 76µs | Log::Log4perl::::BEGIN@13Log::Log4perl::BEGIN@13
1 | 1 | 1 | 15µs | 39µs | Log::Log4perl::::BEGIN@488Log::Log4perl::BEGIN@488
1 | 1 | 1 | 12µs | 28µs | Log::Log4perl::::BEGIN@9Log::Log4perl::BEGIN@9
1 | 1 | 1 | 10µs | 18µs | Log::Log4perl::::BEGIN@525Log::Log4perl::BEGIN@525
1 | 1 | 1 | 9µs | 14µs | Log::Log4perl::::BEGIN@8Log::Log4perl::BEGIN@8
1 | 1 | 1 | 9µs | 26µs | Log::Log4perl::::BEGIN@96Log::Log4perl::BEGIN@96
1 | 1 | 1 | 9µs | 9µs | Log::Log4perl::::importLog::Log4perl::import
1 | 1 | 1 | 9µs | 9µs | Log::Log4perl::::easy_closure_global_cleanupLog::Log4perl::easy_closure_global_cleanup
1 | 1 | 1 | 9µs | 70µs | Log::Log4perl::::BEGIN@69Log::Log4perl::BEGIN@69
1 | 1 | 1 | 6µs | 16µs | Log::Log4perl::::BEGIN@511Log::Log4perl::BEGIN@511
1 | 1 | 1 | 6µs | 13µs | Log::Log4perl::::BEGIN@110Log::Log4perl::BEGIN@110
1 | 1 | 1 | 5µs | 13µs | Log::Log4perl::::BEGIN@526Log::Log4perl::BEGIN@526
1 | 1 | 1 | 5µs | 5µs | Log::Log4perl::::BEGIN@14Log::Log4perl::BEGIN@14
1 | 1 | 1 | 5µs | 5µs | Log::Log4perl::::BEGIN@15Log::Log4perl::BEGIN@15
0 | 0 | 0 | 0s | 0s | Log::Log4perl::::__ANON__[:134]Log::Log4perl::__ANON__[:134]
0 | 0 | 0 | 0s | 0s | Log::Log4perl::::__ANON__[:144]Log::Log4perl::__ANON__[:144]
0 | 0 | 0 | 0s | 0s | Log::Log4perl::::__ANON__[:156]Log::Log4perl::__ANON__[:156]
0 | 0 | 0 | 0s | 0s | Log::Log4perl::::__ANON__[:164]Log::Log4perl::__ANON__[:164]
0 | 0 | 0 | 0s | 0s | Log::Log4perl::::__ANON__[:173]Log::Log4perl::__ANON__[:173]
0 | 0 | 0 | 0s | 0s | Log::Log4perl::::__ANON__[:199]Log::Log4perl::__ANON__[:199]
0 | 0 | 0 | 0s | 0s | Log::Log4perl::::__ANON__[:495]Log::Log4perl::__ANON__[:495]
0 | 0 | 0 | 0s | 0s | Log::Log4perl::::__ANON__[:499]Log::Log4perl::__ANON__[:499]
0 | 0 | 0 | 0s | 0s | Log::Log4perl::::__ANON__[:503]Log::Log4perl::__ANON__[:503]
0 | 0 | 0 | 0s | 0s | Log::Log4perl::::__ANON__[:533]Log::Log4perl::__ANON__[:533]
0 | 0 | 0 | 0s | 0s | Log::Log4perl::::add_appenderLog::Log4perl::add_appender
0 | 0 | 0 | 0s | 0s | Log::Log4perl::::appender_by_nameLog::Log4perl::appender_by_name
0 | 0 | 0 | 0s | 0s | Log::Log4perl::::appender_thresholds_adjustLog::Log4perl::appender_thresholds_adjust
0 | 0 | 0 | 0s | 0s | Log::Log4perl::::appendersLog::Log4perl::appenders
0 | 0 | 0 | 0s | 0s | Log::Log4perl::::easy_closure_category_cleanupLog::Log4perl::easy_closure_category_cleanup
0 | 0 | 0 | 0s | 0s | Log::Log4perl::::easy_closure_cleanupLog::Log4perl::easy_closure_cleanup
0 | 0 | 0 | 0s | 0s | Log::Log4perl::::easy_closure_createLog::Log4perl::easy_closure_create
0 | 0 | 0 | 0s | 0s | Log::Log4perl::::easy_closure_logger_removeLog::Log4perl::easy_closure_logger_remove
0 | 0 | 0 | 0s | 0s | Log::Log4perl::::easy_initLog::Log4perl::easy_init
0 | 0 | 0 | 0s | 0s | Log::Log4perl::::eradicate_appenderLog::Log4perl::eradicate_appender
0 | 0 | 0 | 0s | 0s | Log::Log4perl::::get_loggerLog::Log4perl::get_logger
0 | 0 | 0 | 0s | 0s | Log::Log4perl::::infiltrate_lwpLog::Log4perl::infiltrate_lwp
0 | 0 | 0 | 0s | 0s | Log::Log4perl::::initLog::Log4perl::init
0 | 0 | 0 | 0s | 0s | Log::Log4perl::::init_and_watchLog::Log4perl::init_and_watch
0 | 0 | 0 | 0s | 0s | Log::Log4perl::::init_onceLog::Log4perl::init_once
0 | 0 | 0 | 0s | 0s | Log::Log4perl::::initializedLog::Log4perl::initialized
0 | 0 | 0 | 0s | 0s | Log::Log4perl::::newLog::Log4perl::new
0 | 0 | 0 | 0s | 0s | Log::Log4perl::::remove_loggerLog::Log4perl::remove_logger
0 | 0 | 0 | 0s | 0s | Log::Log4perl::::resetLog::Log4perl::reset
0 | 0 | 0 | 0s | 0s | Log::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 |  |  |  |  | ##################################################
2 |  |  |  |  | package Log::Log4perl;
3 |  |  |  |  | ##################################################
4 |  |  |  |  |
5 | 2 | 16µs | 1 | 99µ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 |  |  |  |  |
7 | 3 | 40µs | 1 | 34µ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
8 | 3 | 18µs | 2 | 20µ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
9 | 3 | 19µs | 2 | 44µ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 |  |  |  |  |
11 | 3 | 111µs | 1 | 1.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
12 | 3 | 113µs | 1 | 23.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
13 | 3 | 26µs | 2 | 136µ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
14 | 3 | 19µs | 1 | 5µ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
15 | 3 | 155µs | 1 | 5µ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 |  |  |  |  |
17 | 1 | 800ns |  |  | our $VERSION = '1.36';
18 |  |  |  |  |
19 |  |  |  |  | # set this to '1' if you're using a wrapper
20 |  |  |  |  | # around Log::Log4perl
21 | 1 | 300ns |  |  | our $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
25 | 1 | 4µs |  |  | our %ALLOWED_CODE_OPS = (
26 |  |  |  |  | 'safe' => [ ':browse' ],
27 |  |  |  |  | 'restrictive' => [ ':default' ],
28 |  |  |  |  | );
29 |  |  |  |  |
30 | 1 | 3µs |  |  | our %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
36 | 1 | 200ns |  |  | our @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)
42 | 1 | 1µs |  |  | our %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
52 | 1 | 400ns |  |  | our $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
56 | 1 | 400ns |  |  | our $JOIN_MSG_ARRAY_CHAR = '';
57 |  |  |  |  |
58 |  |  |  |  | #version required for XML::DOM, to enable XML Config parsing
59 |  |  |  |  | #and XML Config unit tests
60 | 1 | 400ns |  |  | our $DOM_VERSION_REQUIRED = '1.29';
61 |  |  |  |  |
62 | 1 | 300ns |  |  | our $CHATTY_DESTROY_METHODS = 0;
63 |  |  |  |  |
64 | 1 | 200ns |  |  | our $LOGDIE_MESSAGE_ON_STDERR = 1;
65 | 1 | 200ns |  |  | our $LOGEXIT_CODE = 1;
66 | 1 | 200ns |  |  | our %IMPORT_CALLED;
67 |  |  |  |  |
68 | 1 | 600ns |  |  | our $EASY_CLOSURES = {};
69 | 3 | 104µs | 2 | 131µ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 |  |  |  |  | ##################################################
74 | 1 | 500ns |  |  | my($class) = shift;
75 |  |  |  |  |
76 | 1 | 1µs |  |  | my $caller_pkg = caller();
77 |  |  |  |  |
78 | 1 | 2µs |  |  | return 1 if $IMPORT_CALLED{$caller_pkg}++;
79 |  |  |  |  |
80 | 1 | 500ns |  |  | my(%tags) = map { $_ => 1 } @_;
81 |  |  |  |  |
82 |  |  |  |  | # Lazy man's logger
83 | 1 | 400ns |  |  | if(exists $tags{':easy'}) {
84 |  |  |  |  | $tags{':levels'} = 1;
85 |  |  |  |  | $tags{':nowarn'} = 1;
86 |  |  |  |  | $tags{'get_logger'} = 1;
87 |  |  |  |  | }
88 |  |  |  |  |
89 | 1 | 300ns |  |  | 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 | 1 | 400ns |  |  | if(exists $tags{get_logger}) {
95 |  |  |  |  | # Export get_logger into the calling module's
96 | 3 | 70µs | 2 | 43µ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 | 1 | 300ns |  |  | 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};
110 | 3 | 1.39ms | 2 | 21µ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 | 1 | 200ns |  |  | 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 | 1 | 200ns |  |  | if(exists $tags{':nowarn'}) {
177 |  |  |  |  | $Log::Log4perl::Logger::NON_INIT_WARNED = 1;
178 |  |  |  |  | delete $tags{':nowarn'};
179 |  |  |  |  | }
180 |  |  |  |  |
181 | 1 | 300ns |  |  | if(exists $tags{':nostrict'}) {
182 |  |  |  |  | $Log::Log4perl::Logger::NO_STRICT = 1;
183 |  |  |  |  | delete $tags{':nostrict'};
184 |  |  |  |  | }
185 |  |  |  |  |
186 | 1 | 200ns |  |  | 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 | 1 | 5µs |  |  | if(keys %tags) {
204 |  |  |  |  | # We received an Option we couldn't understand.
205 |  |  |  |  | die "Unknown Option(s): @{[keys %tags]}";
206 |  |  |  |  | }
207 |  |  |  |  | }
208 |  |  |  |  |
209 |  |  |  |  | ##################################################
210 |  |  |  |  | sub initialized {
211 |  |  |  |  | ##################################################
212 |  |  |  |  | return $Log::Log4perl::Logger::INITIALIZED;
213 |  |  |  |  | }
214 |  |  |  |  |
215 |  |  |  |  | ##################################################
216 |  |  |  |  | sub new {
217 |  |  |  |  | ##################################################
218 |  |  |  |  | die "THIS CLASS ISN'T FOR DIRECT USE. " .
219 |  |  |  |  | "PLEASE CHECK 'perldoc " . __PACKAGE__ . "'.";
220 |  |  |  |  | }
221 |  |  |  |  |
222 |  |  |  |  | ##################################################
223 |  |  |  |  | sub reset { # Mainly for debugging/testing
224 |  |  |  |  | ##################################################
225 |  |  |  |  | # Delegate this to the logger ...
226 |  |  |  |  | return Log::Log4perl::Logger->reset();
227 |  |  |  |  | }
228 |  |  |  |  |
229 |  |  |  |  | ##################################################
230 |  |  |  |  | sub init_once { # Call init only if it hasn't been
231 |  |  |  |  | # called yet.
232 |  |  |  |  | ##################################################
233 |  |  |  |  | init(@_) unless $Log::Log4perl::Logger::INITIALIZED;
234 |  |  |  |  | }
235 |  |  |  |  |
236 |  |  |  |  | ##################################################
237 |  |  |  |  | sub 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 |  |  |  |  | ##################################################
251 |  |  |  |  | sub 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 |  |  |  |  | ##################################################
266 |  |  |  |  | sub 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 |  |  |  |  | ##################################################
344 |  |  |  |  | sub wrapper_register {
345 |  |  |  |  | ##################################################
346 |  |  |  |  | my $wrapper = $_[-1];
347 |  |  |  |  |
348 |  |  |  |  | $WRAPPERS_REGISTERED{ $wrapper } = 1;
349 |  |  |  |  | }
350 |  |  |  |  |
351 |  |  |  |  | ##################################################
352 |  |  |  |  | sub 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 |  |  |  |  | ##################################################
394 |  |  |  |  | sub appenders { # Get a hashref of all defined appender wrappers
395 |  |  |  |  | ##################################################
396 |  |  |  |  | return \%Log::Log4perl::Logger::APPENDER_BY_NAME;
397 |  |  |  |  | }
398 |  |  |  |  |
399 |  |  |  |  | ##################################################
400 |  |  |  |  | sub 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
415 |  |  |  |  | sub 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 |  |  |  |  | ##################################################
460 |  |  |  |  | sub 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 |  |  |  |  | ##################################################
478 |  |  |  |  | sub 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 |  |  |  |  | ##################################################
486 |  |  |  |  | sub infiltrate_lwp { #
487 |  |  |  |  | ##################################################
488 | 3 | 142µs | 2 | 63µ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 |  |  |  |  | ##################################################
507 |  |  |  |  | sub easy_closure_create {
508 |  |  |  |  | ##################################################
509 |  |  |  |  | my($caller_pkg, $entry, $code, $logger) = @_;
510 |  |  |  |  |
511 | 3 | 83µs | 2 | 26µ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 |  |  |  |  | ###########################################
521 |  |  |  |  | sub easy_closure_cleanup {
522 |  |  |  |  | ###########################################
523 |  |  |  |  | my($caller_pkg, $entry) = @_;
524 |  |  |  |  |
525 | 3 | 19µs | 2 | 26µ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
526 | 3 | 269µs | 2 | 20µ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 |  |  |  |  | ##################################################
538 |  |  |  |  | sub 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 |  |  |  |  |
557 | 1 | 15µs |  |  | for my $caller_pkg ( keys %$EASY_CLOSURES ) {
558 |  |  |  |  | easy_closure_category_cleanup( $caller_pkg );
559 |  |  |  |  | }
560 |  |  |  |  | }
561 |  |  |  |  |
562 |  |  |  |  | ###########################################
563 |  |  |  |  | sub 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 |  |  |  |  | ##################################################
578 |  |  |  |  | sub 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 |  |  |  |  |
590 | 1 | 9µs |  |  | 1;
591 |  |  |  |  |
592 |  |  |  |  | __END__