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 |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 3.88ms | 23.1ms | BEGIN@12 | Log::Log4perl::
1 | 1 | 1 | 207µs | 1.85ms | BEGIN@11 | Log::Log4perl::
1 | 1 | 1 | 34µs | 34µs | BEGIN@7 | Log::Log4perl::
1 | 1 | 1 | 19µs | 118µs | END | Log::Log4perl::
1 | 1 | 1 | 16µs | 76µs | BEGIN@13 | Log::Log4perl::
1 | 1 | 1 | 15µs | 39µs | BEGIN@488 | Log::Log4perl::
1 | 1 | 1 | 12µs | 28µs | BEGIN@9 | Log::Log4perl::
1 | 1 | 1 | 10µs | 18µs | BEGIN@525 | Log::Log4perl::
1 | 1 | 1 | 9µs | 14µs | BEGIN@8 | Log::Log4perl::
1 | 1 | 1 | 9µs | 26µs | BEGIN@96 | Log::Log4perl::
1 | 1 | 1 | 9µs | 9µs | import | Log::Log4perl::
1 | 1 | 1 | 9µs | 9µs | easy_closure_global_cleanup | Log::Log4perl::
1 | 1 | 1 | 9µs | 70µs | BEGIN@69 | Log::Log4perl::
1 | 1 | 1 | 6µs | 16µs | BEGIN@511 | Log::Log4perl::
1 | 1 | 1 | 6µs | 13µs | BEGIN@110 | Log::Log4perl::
1 | 1 | 1 | 5µs | 13µs | BEGIN@526 | Log::Log4perl::
1 | 1 | 1 | 5µs | 5µs | BEGIN@14 | Log::Log4perl::
1 | 1 | 1 | 5µs | 5µs | BEGIN@15 | Log::Log4perl::
0 | 0 | 0 | 0s | 0s | __ANON__[:134] | Log::Log4perl::
0 | 0 | 0 | 0s | 0s | __ANON__[:144] | Log::Log4perl::
0 | 0 | 0 | 0s | 0s | __ANON__[:156] | Log::Log4perl::
0 | 0 | 0 | 0s | 0s | __ANON__[:164] | Log::Log4perl::
0 | 0 | 0 | 0s | 0s | __ANON__[:173] | Log::Log4perl::
0 | 0 | 0 | 0s | 0s | __ANON__[:199] | Log::Log4perl::
0 | 0 | 0 | 0s | 0s | __ANON__[:495] | Log::Log4perl::
0 | 0 | 0 | 0s | 0s | __ANON__[:499] | Log::Log4perl::
0 | 0 | 0 | 0s | 0s | __ANON__[:503] | Log::Log4perl::
0 | 0 | 0 | 0s | 0s | __ANON__[:533] | Log::Log4perl::
0 | 0 | 0 | 0s | 0s | add_appender | Log::Log4perl::
0 | 0 | 0 | 0s | 0s | appender_by_name | Log::Log4perl::
0 | 0 | 0 | 0s | 0s | appender_thresholds_adjust | Log::Log4perl::
0 | 0 | 0 | 0s | 0s | appenders | Log::Log4perl::
0 | 0 | 0 | 0s | 0s | easy_closure_category_cleanup | Log::Log4perl::
0 | 0 | 0 | 0s | 0s | easy_closure_cleanup | Log::Log4perl::
0 | 0 | 0 | 0s | 0s | easy_closure_create | Log::Log4perl::
0 | 0 | 0 | 0s | 0s | easy_closure_logger_remove | Log::Log4perl::
0 | 0 | 0 | 0s | 0s | easy_init | Log::Log4perl::
0 | 0 | 0 | 0s | 0s | eradicate_appender | Log::Log4perl::
0 | 0 | 0 | 0s | 0s | get_logger | Log::Log4perl::
0 | 0 | 0 | 0s | 0s | infiltrate_lwp | Log::Log4perl::
0 | 0 | 0 | 0s | 0s | init | Log::Log4perl::
0 | 0 | 0 | 0s | 0s | init_and_watch | Log::Log4perl::
0 | 0 | 0 | 0s | 0s | init_once | Log::Log4perl::
0 | 0 | 0 | 0s | 0s | initialized | Log::Log4perl::
0 | 0 | 0 | 0s | 0s | new | Log::Log4perl::
0 | 0 | 0 | 0s | 0s | remove_logger | Log::Log4perl::
0 | 0 | 0 | 0s | 0s | reset | Log::Log4perl::
0 | 0 | 0 | 0s | 0s | wrapper_register | Log::Log4perl::
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 # 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 # 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 # 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 # 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 # 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 # 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 # 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 # 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 # 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 # 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 | ||||
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 # 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 # 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 # 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 # 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 # 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 # 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 | ||||
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__ |