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