| Filename | /2home/ss5/perl5/perlbrew/perls/perl-5.12.3/lib/site_perl/5.12.3/Log/Log4perl/Layout/PatternLayout.pm |
| Statements | Executed 86 statements in 2.64ms |
| Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
|---|---|---|---|---|---|
| 1 | 1 | 1 | 1.16ms | 1.21ms | Log::Log4perl::Layout::PatternLayout::BEGIN@15 |
| 1 | 1 | 1 | 1.12ms | 1.32ms | Log::Log4perl::Layout::PatternLayout::BEGIN@20 |
| 1 | 1 | 1 | 481µs | 1.54ms | Log::Log4perl::Layout::PatternLayout::BEGIN@18 |
| 1 | 1 | 1 | 240µs | 291µs | Log::Log4perl::Layout::PatternLayout::BEGIN@16 |
| 1 | 1 | 1 | 205µs | 250µs | Log::Log4perl::Layout::PatternLayout::BEGIN@17 |
| 1 | 1 | 1 | 53µs | 197µs | Log::Log4perl::Layout::PatternLayout::new |
| 1 | 1 | 1 | 39µs | 82µs | Log::Log4perl::Layout::PatternLayout::define |
| 1 | 1 | 1 | 23µs | 23µs | Log::Log4perl::Layout::PatternLayout::BEGIN@5 |
| 1 | 1 | 1 | 22µs | 22µs | Log::Log4perl::Layout::PatternLayout::CORE:regcomp (opcode) |
| 1 | 1 | 1 | 12µs | 52µs | Log::Log4perl::Layout::PatternLayout::BEGIN@11 |
| 1 | 1 | 1 | 12µs | 12µs | Log::Log4perl::Layout::PatternLayout::rep |
| 1 | 1 | 1 | 11µs | 59µs | Log::Log4perl::Layout::PatternLayout::BEGIN@29 |
| 3 | 3 | 1 | 11µs | 11µs | Log::Log4perl::Layout::PatternLayout::CORE:subst (opcode) |
| 1 | 1 | 1 | 8µs | 79µs | Log::Log4perl::Layout::PatternLayout::BEGIN@38 |
| 1 | 1 | 1 | 8µs | 21µs | Log::Log4perl::Layout::PatternLayout::BEGIN@40 |
| 1 | 1 | 1 | 7µs | 9µs | Log::Log4perl::Layout::PatternLayout::BEGIN@6 |
| 1 | 1 | 1 | 7µs | 15µs | Log::Log4perl::Layout::PatternLayout::BEGIN@7 |
| 1 | 1 | 1 | 7µs | 48µs | Log::Log4perl::Layout::PatternLayout::BEGIN@9 |
| 1 | 1 | 1 | 6µs | 48µs | Log::Log4perl::Layout::PatternLayout::BEGIN@14 |
| 1 | 1 | 1 | 6µs | 6µs | Log::Log4perl::Layout::PatternLayout::BEGIN@19 |
| 1 | 1 | 1 | 5µs | 5µs | Log::Log4perl::Layout::PatternLayout::BEGIN@13 |
| 1 | 1 | 1 | 4µs | 4µs | Log::Log4perl::Layout::PatternLayout::BEGIN@12 |
| 2 | 1 | 1 | 2µs | 2µs | Log::Log4perl::Layout::PatternLayout::CORE:substcont (opcode) |
| 1 | 1 | 1 | 200ns | 200ns | Log::Log4perl::Layout::PatternLayout::CORE:match (opcode) |
| 0 | 0 | 0 | 0s | 0s | Log::Log4perl::Layout::PatternLayout::add_global_cspec |
| 0 | 0 | 0 | 0s | 0s | Log::Log4perl::Layout::PatternLayout::add_layout_cspec |
| 0 | 0 | 0 | 0s | 0s | Log::Log4perl::Layout::PatternLayout::callinfo_dump |
| 0 | 0 | 0 | 0s | 0s | Log::Log4perl::Layout::PatternLayout::curly_action |
| 0 | 0 | 0 | 0s | 0s | Log::Log4perl::Layout::PatternLayout::render |
| 0 | 0 | 0 | 0s | 0s | Log::Log4perl::Layout::PatternLayout::shrink_category |
| Line | State ments |
Time on line |
Calls | Time in subs |
Code |
|---|---|---|---|---|---|
| 1 | ################################################## | ||||
| 2 | package Log::Log4perl::Layout::PatternLayout; | ||||
| 3 | ################################################## | ||||
| 4 | |||||
| 5 | 3 | 32µs | 1 | 23µs | # spent 23µs within Log::Log4perl::Layout::PatternLayout::BEGIN@5 which was called:
# once (23µs+0s) by Log::Log4perl::Layout::BEGIN@5 at line 5 # spent 23µs making 1 call to Log::Log4perl::Layout::PatternLayout::BEGIN@5 |
| 6 | 3 | 20µs | 2 | 11µs | # spent 9µs (7+2) within Log::Log4perl::Layout::PatternLayout::BEGIN@6 which was called:
# once (7µs+2µs) by Log::Log4perl::Layout::BEGIN@5 at line 6 # spent 9µs making 1 call to Log::Log4perl::Layout::PatternLayout::BEGIN@6
# spent 2µs making 1 call to strict::import |
| 7 | 3 | 18µs | 2 | 23µs | # spent 15µs (7+8) within Log::Log4perl::Layout::PatternLayout::BEGIN@7 which was called:
# once (7µs+8µs) by Log::Log4perl::Layout::BEGIN@5 at line 7 # spent 15µs making 1 call to Log::Log4perl::Layout::PatternLayout::BEGIN@7
# spent 8µs making 1 call to warnings::import |
| 8 | |||||
| 9 | 3 | 18µs | 2 | 90µs | # spent 48µs (7+42) within Log::Log4perl::Layout::PatternLayout::BEGIN@9 which was called:
# once (7µs+42µs) by Log::Log4perl::Layout::BEGIN@5 at line 9 # spent 48µs making 1 call to Log::Log4perl::Layout::PatternLayout::BEGIN@9
# spent 42µs making 1 call to constant::import |
| 10 | |||||
| 11 | 3 | 19µs | 2 | 92µs | # spent 52µs (12+40) within Log::Log4perl::Layout::PatternLayout::BEGIN@11 which was called:
# once (12µs+40µs) by Log::Log4perl::Layout::BEGIN@5 at line 11 # spent 52µs making 1 call to Log::Log4perl::Layout::PatternLayout::BEGIN@11
# spent 40µs making 1 call to Exporter::import |
| 12 | 3 | 19µs | 1 | 4µs | # spent 4µs within Log::Log4perl::Layout::PatternLayout::BEGIN@12 which was called:
# once (4µs+0s) by Log::Log4perl::Layout::BEGIN@5 at line 12 # spent 4µs making 1 call to Log::Log4perl::Layout::PatternLayout::BEGIN@12 |
| 13 | 3 | 17µs | 1 | 5µs | # spent 5µs within Log::Log4perl::Layout::PatternLayout::BEGIN@13 which was called:
# once (5µs+0s) by Log::Log4perl::Layout::BEGIN@5 at line 13 # spent 5µs making 1 call to Log::Log4perl::Layout::PatternLayout::BEGIN@13 |
| 14 | 3 | 17µs | 2 | 90µs | # spent 48µs (6+42) within Log::Log4perl::Layout::PatternLayout::BEGIN@14 which was called:
# once (6µs+42µs) by Log::Log4perl::Layout::BEGIN@5 at line 14 # spent 48µs making 1 call to Log::Log4perl::Layout::PatternLayout::BEGIN@14
# spent 42µs making 1 call to Log::Log4perl::Level::import |
| 15 | 3 | 92µs | 1 | 1.21ms | # spent 1.21ms (1.16+54µs) within Log::Log4perl::Layout::PatternLayout::BEGIN@15 which was called:
# once (1.16ms+54µs) by Log::Log4perl::Layout::BEGIN@5 at line 15 # spent 1.21ms making 1 call to Log::Log4perl::Layout::PatternLayout::BEGIN@15 |
| 16 | 3 | 78µs | 1 | 291µs | # spent 291µs (240+52) within Log::Log4perl::Layout::PatternLayout::BEGIN@16 which was called:
# once (240µs+52µs) by Log::Log4perl::Layout::BEGIN@5 at line 16 # spent 291µs making 1 call to Log::Log4perl::Layout::PatternLayout::BEGIN@16 |
| 17 | 3 | 70µs | 1 | 250µs | # spent 250µs (205+45) within Log::Log4perl::Layout::PatternLayout::BEGIN@17 which was called:
# once (205µs+45µs) by Log::Log4perl::Layout::BEGIN@5 at line 17 # spent 250µs making 1 call to Log::Log4perl::Layout::PatternLayout::BEGIN@17 |
| 18 | 3 | 85µs | 1 | 1.54ms | # spent 1.54ms (481µs+1.06) within Log::Log4perl::Layout::PatternLayout::BEGIN@18 which was called:
# once (481µs+1.06ms) by Log::Log4perl::Layout::BEGIN@5 at line 18 # spent 1.54ms making 1 call to Log::Log4perl::Layout::PatternLayout::BEGIN@18 |
| 19 | 3 | 19µs | 1 | 6µs | # spent 6µs within Log::Log4perl::Layout::PatternLayout::BEGIN@19 which was called:
# once (6µs+0s) by Log::Log4perl::Layout::BEGIN@5 at line 19 # spent 6µs making 1 call to Log::Log4perl::Layout::PatternLayout::BEGIN@19 |
| 20 | 3 | 177µs | 2 | 1.37ms | # spent 1.32ms (1.12+202µs) within Log::Log4perl::Layout::PatternLayout::BEGIN@20 which was called:
# once (1.12ms+202µs) by Log::Log4perl::Layout::BEGIN@5 at line 20 # spent 1.32ms making 1 call to Log::Log4perl::Layout::PatternLayout::BEGIN@20
# spent 53µs making 1 call to Exporter::import |
| 21 | |||||
| 22 | 1 | 600ns | our $TIME_HIRES_AVAILABLE_WARNED = 0; | ||
| 23 | 1 | 200ns | our $HOSTNAME; | ||
| 24 | |||||
| 25 | 1 | 2µs | our %GLOBAL_USER_DEFINED_CSPECS = (); | ||
| 26 | |||||
| 27 | 1 | 400ns | our $CSPECS = 'cCdFHIlLmMnpPrRtTxX%'; | ||
| 28 | |||||
| 29 | # spent 59µs (11+47) within Log::Log4perl::Layout::PatternLayout::BEGIN@29 which was called:
# once (11µs+47µs) by Log::Log4perl::Layout::BEGIN@5 at line 36 | ||||
| 30 | # Check if we've got Sys::Hostname. If not, just punt. | ||||
| 31 | 2 | 6µs | $HOSTNAME = "unknown.host"; | ||
| 32 | 2 | 3µs | 1 | 29µs | if(Log::Log4perl::Util::module_available("Sys::Hostname")) { # spent 29µs making 1 call to Log::Log4perl::Util::module_available |
| 33 | require Sys::Hostname; | ||||
| 34 | 1 | 18µs | $HOSTNAME = Sys::Hostname::hostname(); # spent 18µs making 1 call to Sys::Hostname::hostname | ||
| 35 | } | ||||
| 36 | 1 | 17µs | 1 | 59µs | } # spent 59µs making 1 call to Log::Log4perl::Layout::PatternLayout::BEGIN@29 |
| 37 | |||||
| 38 | 3 | 22µs | 2 | 79µs | # spent 79µs (8+70) within Log::Log4perl::Layout::PatternLayout::BEGIN@38 which was called:
# once (8µs+70µs) by Log::Log4perl::Layout::BEGIN@5 at line 38 # spent 79µs making 1 call to Log::Log4perl::Layout::PatternLayout::BEGIN@38
# spent 70µs making 1 call to base::import, recursion: max depth 1, sum of overlapping time 70µs |
| 39 | |||||
| 40 | 3 | 1.76ms | 2 | 35µs | # spent 21µs (8+13) within Log::Log4perl::Layout::PatternLayout::BEGIN@40 which was called:
# once (8µs+13µs) by Log::Log4perl::Layout::BEGIN@5 at line 40 # spent 21µs making 1 call to Log::Log4perl::Layout::PatternLayout::BEGIN@40
# spent 13µs making 1 call to strict::unimport |
| 41 | |||||
| 42 | ################################################## | ||||
| 43 | # spent 197µs (53+144) within Log::Log4perl::Layout::PatternLayout::new which was called:
# once (53µs+144µs) by Log::Log4perl::BEGIN@12 at line 36 of Log/Log4perl/Logger.pm | ||||
| 44 | ################################################## | ||||
| 45 | 15 | 52µs | my $class = shift; | ||
| 46 | $class = ref ($class) || $class; | ||||
| 47 | |||||
| 48 | my $options = ref $_[0] eq "HASH" ? shift : {}; | ||||
| 49 | my $layout_string = @_ ? shift : '%m%n'; | ||||
| 50 | |||||
| 51 | my $self = { | ||||
| 52 | format => undef, | ||||
| 53 | info_needed => {}, | ||||
| 54 | stack => [], | ||||
| 55 | CSPECS => $CSPECS, | ||||
| 56 | dontCollapseArrayRefs => $options->{dontCollapseArrayRefs}{value}, | ||||
| 57 | last_time => undef, | ||||
| 58 | }; | ||||
| 59 | |||||
| 60 | 1 | 59µs | $self->{timer} = Log::Log4perl::Util::TimeTracker->new( # spent 59µs making 1 call to Log::Log4perl::Util::TimeTracker::new | ||
| 61 | time_function => $options->{time_function} | ||||
| 62 | ); | ||||
| 63 | |||||
| 64 | if(exists $options->{ConversionPattern}->{value}) { | ||||
| 65 | $layout_string = $options->{ConversionPattern}->{value}; | ||||
| 66 | } | ||||
| 67 | |||||
| 68 | 1 | 1µs | if(exists $options->{message_chomp_before_newline}) { | ||
| 69 | $self->{message_chomp_before_newline} = | ||||
| 70 | $options->{message_chomp_before_newline}->{value}; | ||||
| 71 | } else { | ||||
| 72 | $self->{message_chomp_before_newline} = 1; | ||||
| 73 | } | ||||
| 74 | |||||
| 75 | bless $self, $class; | ||||
| 76 | |||||
| 77 | #add the global user-defined cspecs | ||||
| 78 | foreach my $f (keys %GLOBAL_USER_DEFINED_CSPECS){ | ||||
| 79 | #add it to the list of letters | ||||
| 80 | $self->{CSPECS} .= $f; | ||||
| 81 | #for globals, the coderef is already evaled, | ||||
| 82 | $self->{USER_DEFINED_CSPECS}{$f} = $GLOBAL_USER_DEFINED_CSPECS{$f}; | ||||
| 83 | } | ||||
| 84 | |||||
| 85 | #add the user-defined cspecs local to this appender | ||||
| 86 | foreach my $f (keys %{$options->{cspec}}){ | ||||
| 87 | $self->add_layout_cspec($f, $options->{cspec}{$f}{value}); | ||||
| 88 | } | ||||
| 89 | |||||
| 90 | # non-portable line breaks | ||||
| 91 | 1 | 2µs | $layout_string =~ s/\\n/\n/g; # spent 2µs making 1 call to Log::Log4perl::Layout::PatternLayout::CORE:subst | ||
| 92 | 1 | 500ns | $layout_string =~ s/\\r/\r/g; # spent 500ns making 1 call to Log::Log4perl::Layout::PatternLayout::CORE:subst | ||
| 93 | |||||
| 94 | 1 | 82µs | $self->define($layout_string); # spent 82µs making 1 call to Log::Log4perl::Layout::PatternLayout::define | ||
| 95 | |||||
| 96 | return $self; | ||||
| 97 | } | ||||
| 98 | |||||
| 99 | ################################################## | ||||
| 100 | # spent 82µs (39+44) within Log::Log4perl::Layout::PatternLayout::define which was called:
# once (39µs+44µs) by Log::Log4perl::Layout::PatternLayout::new at line 94 | ||||
| 101 | ################################################## | ||||
| 102 | 4 | 67µs | my($self, $format) = @_; | ||
| 103 | |||||
| 104 | # If the message contains a %m followed by a newline, | ||||
| 105 | # make a note of that so that we can cut a superfluous | ||||
| 106 | # \n off the message later on | ||||
| 107 | 1 | 1µs | 1 | 200ns | if($self->{message_chomp_before_newline} and $format =~ /%m%n/) { # spent 200ns making 1 call to Log::Log4perl::Layout::PatternLayout::CORE:match |
| 108 | $self->{message_chompable} = 1; | ||||
| 109 | } else { | ||||
| 110 | $self->{message_chompable} = 0; | ||||
| 111 | } | ||||
| 112 | |||||
| 113 | # Parse the format | ||||
| 114 | 1 | 3µs | 4 | 32µs | $format =~ s/%(-?\d*(?:\.\d+)?) # spent 22µs making 1 call to Log::Log4perl::Layout::PatternLayout::CORE:regcomp
# spent 8µs making 1 call to Log::Log4perl::Layout::PatternLayout::CORE:subst
# spent 2µs making 2 calls to Log::Log4perl::Layout::PatternLayout::CORE:substcont, avg 1µs/call |
| 115 | 1 | 12µs | ([$self->{CSPECS}]) # spent 12µs making 1 call to Log::Log4perl::Layout::PatternLayout::rep | ||
| 116 | (?:{(.*?)})*/ | ||||
| 117 | rep($self, $1, $2, $3); | ||||
| 118 | /gex; | ||||
| 119 | |||||
| 120 | $self->{printformat} = $format; | ||||
| 121 | } | ||||
| 122 | |||||
| 123 | ################################################## | ||||
| 124 | # spent 12µs within Log::Log4perl::Layout::PatternLayout::rep which was called:
# once (12µs+0s) by Log::Log4perl::Layout::PatternLayout::define at line 115 | ||||
| 125 | ################################################## | ||||
| 126 | 7 | 14µs | my($self, $num, $op, $curlies) = @_; | ||
| 127 | |||||
| 128 | return "%%" if $op eq "%"; | ||||
| 129 | |||||
| 130 | # If it's a %d{...} construct, initialize a simple date | ||||
| 131 | # format formatter, so that we can quickly render later on. | ||||
| 132 | # If it's just %d, assume %d{yyyy/MM/dd HH:mm:ss} | ||||
| 133 | my $sdf; | ||||
| 134 | if($op eq "d") { | ||||
| 135 | if(defined $curlies) { | ||||
| 136 | $sdf = Log::Log4perl::DateFormat->new($curlies); | ||||
| 137 | } else { | ||||
| 138 | $sdf = Log::Log4perl::DateFormat->new("yyyy/MM/dd HH:mm:ss"); | ||||
| 139 | } | ||||
| 140 | } | ||||
| 141 | |||||
| 142 | push @{$self->{stack}}, [$op, $sdf || $curlies]; | ||||
| 143 | |||||
| 144 | $self->{info_needed}->{$op}++; | ||||
| 145 | |||||
| 146 | return "%${num}s"; | ||||
| 147 | } | ||||
| 148 | |||||
| 149 | ################################################## | ||||
| 150 | sub render { | ||||
| 151 | ################################################## | ||||
| 152 | my($self, $message, $category, $priority, $caller_level) = @_; | ||||
| 153 | |||||
| 154 | $caller_level = 0 unless defined $caller_level; | ||||
| 155 | |||||
| 156 | my %info = (); | ||||
| 157 | |||||
| 158 | $info{m} = $message; | ||||
| 159 | # See 'define' | ||||
| 160 | chomp $info{m} if $self->{message_chompable}; | ||||
| 161 | |||||
| 162 | my @results = (); | ||||
| 163 | |||||
| 164 | if($self->{info_needed}->{L} or | ||||
| 165 | $self->{info_needed}->{F} or | ||||
| 166 | $self->{info_needed}->{C} or | ||||
| 167 | $self->{info_needed}->{l} or | ||||
| 168 | $self->{info_needed}->{M} or | ||||
| 169 | $self->{info_needed}->{T} or | ||||
| 170 | 0 | ||||
| 171 | ) { | ||||
| 172 | my ($package, $filename, $line, | ||||
| 173 | $subroutine, $hasargs, | ||||
| 174 | $wantarray, $evaltext, $is_require, | ||||
| 175 | $hints, $bitmask); | ||||
| 176 | |||||
| 177 | { | ||||
| 178 | ($package, $filename, $line, | ||||
| 179 | $subroutine, $hasargs, | ||||
| 180 | $wantarray, $evaltext, $is_require, | ||||
| 181 | $hints, $bitmask) = my @callinfo = | ||||
| 182 | caller($caller_level); | ||||
| 183 | |||||
| 184 | if(_INTERNAL_DEBUG) { | ||||
| 185 | callinfo_dump( $caller_level, \@callinfo ); | ||||
| 186 | } | ||||
| 187 | |||||
| 188 | if(exists $Log::Log4perl::WRAPPERS_REGISTERED{$package}) { | ||||
| 189 | # We hit a predefined wrapper, step up to the next frame. | ||||
| 190 | if(_INTERNAL_DEBUG) { | ||||
| 191 | print "[$package] recognized as a wrapper, increasing ", | ||||
| 192 | "caller level (currently $caller_level)\n"; | ||||
| 193 | } | ||||
| 194 | $caller_level++; | ||||
| 195 | redo; | ||||
| 196 | } | ||||
| 197 | } | ||||
| 198 | |||||
| 199 | # If caller() choked because of a whacko caller level, | ||||
| 200 | # correct undefined values to '[undef]' in order to prevent | ||||
| 201 | # warning messages when interpolating later | ||||
| 202 | unless(defined $bitmask) { | ||||
| 203 | for($package, | ||||
| 204 | $filename, $line, | ||||
| 205 | $subroutine, $hasargs, | ||||
| 206 | $wantarray, $evaltext, $is_require, | ||||
| 207 | $hints, $bitmask) { | ||||
| 208 | $_ = '[undef]' unless defined $_; | ||||
| 209 | } | ||||
| 210 | } | ||||
| 211 | |||||
| 212 | $info{L} = $line; | ||||
| 213 | $info{F} = $filename; | ||||
| 214 | $info{C} = $package; | ||||
| 215 | |||||
| 216 | if($self->{info_needed}->{M} or | ||||
| 217 | $self->{info_needed}->{l} or | ||||
| 218 | 0) { | ||||
| 219 | # To obtain the name of the subroutine which triggered the | ||||
| 220 | # logger, we need to go one additional level up. | ||||
| 221 | my $levels_up = 1; | ||||
| 222 | { | ||||
| 223 | my @callinfo = caller($caller_level+$levels_up); | ||||
| 224 | |||||
| 225 | if(_INTERNAL_DEBUG) { | ||||
| 226 | callinfo_dump( $caller_level, \@callinfo ); | ||||
| 227 | } | ||||
| 228 | |||||
| 229 | $subroutine = $callinfo[3]; | ||||
| 230 | # If we're inside an eval, go up one level further. | ||||
| 231 | if(defined $subroutine and | ||||
| 232 | $subroutine eq "(eval)") { | ||||
| 233 | print "Inside an eval, one up\n" if _INTERNAL_DEBUG; | ||||
| 234 | $levels_up++; | ||||
| 235 | redo; | ||||
| 236 | } | ||||
| 237 | } | ||||
| 238 | $subroutine = "main::" unless $subroutine; | ||||
| 239 | print "Subroutine is '$subroutine'\n" if _INTERNAL_DEBUG; | ||||
| 240 | $info{M} = $subroutine; | ||||
| 241 | $info{l} = "$subroutine $filename ($line)"; | ||||
| 242 | } | ||||
| 243 | } | ||||
| 244 | |||||
| 245 | $info{X} = "[No curlies defined]"; | ||||
| 246 | $info{x} = Log::Log4perl::NDC->get() if $self->{info_needed}->{x}; | ||||
| 247 | $info{c} = $category; | ||||
| 248 | $info{d} = 1; # Dummy value, corrected later | ||||
| 249 | $info{n} = "\n"; | ||||
| 250 | $info{p} = $priority; | ||||
| 251 | $info{P} = $$; | ||||
| 252 | $info{H} = $HOSTNAME; | ||||
| 253 | |||||
| 254 | my $current_time; | ||||
| 255 | |||||
| 256 | if($self->{info_needed}->{r} or $self->{info_needed}->{R}) { | ||||
| 257 | if(!$TIME_HIRES_AVAILABLE_WARNED++ and | ||||
| 258 | !$self->{timer}->hires_available()) { | ||||
| 259 | warn "Requested %r/%R pattern without installed Time::HiRes\n"; | ||||
| 260 | } | ||||
| 261 | $current_time = [$self->{timer}->gettimeofday()]; | ||||
| 262 | } | ||||
| 263 | |||||
| 264 | if($self->{info_needed}->{r}) { | ||||
| 265 | $info{r} = $self->{timer}->milliseconds( $current_time ); | ||||
| 266 | } | ||||
| 267 | if($self->{info_needed}->{R}) { | ||||
| 268 | $info{R} = $self->{timer}->delta_milliseconds( $current_time ); | ||||
| 269 | } | ||||
| 270 | |||||
| 271 | # Stack trace wanted? | ||||
| 272 | if($self->{info_needed}->{T}) { | ||||
| 273 | local $Carp::CarpLevel = | ||||
| 274 | $Carp::CarpLevel + $caller_level; | ||||
| 275 | my $mess = Carp::longmess(); | ||||
| 276 | chomp($mess); | ||||
| 277 | # $mess =~ s/(?:\A\s*at.*\n|^\s*Log::Log4perl.*\n|^\s*)//mg; | ||||
| 278 | $mess =~ s/(?:\A\s*at.*\n|^\s*)//mg; | ||||
| 279 | $mess =~ s/\n/, /g; | ||||
| 280 | $info{T} = $mess; | ||||
| 281 | } | ||||
| 282 | |||||
| 283 | # As long as they're not implemented yet .. | ||||
| 284 | $info{t} = "N/A"; | ||||
| 285 | |||||
| 286 | # Iterate over all info fields on the stack | ||||
| 287 | for my $e (@{$self->{stack}}) { | ||||
| 288 | my($op, $curlies) = @$e; | ||||
| 289 | |||||
| 290 | my $result; | ||||
| 291 | |||||
| 292 | if(exists $self->{USER_DEFINED_CSPECS}->{$op}) { | ||||
| 293 | next unless $self->{info_needed}->{$op}; | ||||
| 294 | $self->{curlies} = $curlies; | ||||
| 295 | $result = $self->{USER_DEFINED_CSPECS}->{$op}->($self, | ||||
| 296 | $message, $category, $priority, | ||||
| 297 | $caller_level+1); | ||||
| 298 | } elsif(exists $info{$op}) { | ||||
| 299 | $result = $info{$op}; | ||||
| 300 | if($curlies) { | ||||
| 301 | $result = $self->curly_action($op, $curlies, $info{$op}); | ||||
| 302 | } else { | ||||
| 303 | # just for %d | ||||
| 304 | if($op eq 'd') { | ||||
| 305 | $result = $info{$op}->format($self->{timer}->gettimeofday()); | ||||
| 306 | } | ||||
| 307 | } | ||||
| 308 | } else { | ||||
| 309 | warn "Format %'$op' not implemented (yet)"; | ||||
| 310 | $result = "FORMAT-ERROR"; | ||||
| 311 | } | ||||
| 312 | |||||
| 313 | $result = "[undef]" unless defined $result; | ||||
| 314 | push @results, $result; | ||||
| 315 | } | ||||
| 316 | |||||
| 317 | return (sprintf $self->{printformat}, @results); | ||||
| 318 | } | ||||
| 319 | |||||
| 320 | ################################################## | ||||
| 321 | sub curly_action { | ||||
| 322 | ################################################## | ||||
| 323 | my($self, $ops, $curlies, $data) = @_; | ||||
| 324 | |||||
| 325 | if($ops eq "c") { | ||||
| 326 | $data = shrink_category($data, $curlies); | ||||
| 327 | } elsif($ops eq "C") { | ||||
| 328 | $data = shrink_category($data, $curlies); | ||||
| 329 | } elsif($ops eq "X") { | ||||
| 330 | $data = Log::Log4perl::MDC->get($curlies); | ||||
| 331 | } elsif($ops eq "d") { | ||||
| 332 | $data = $curlies->format( $self->{timer}->gettimeofday() ); | ||||
| 333 | } elsif($ops eq "M") { | ||||
| 334 | $data = shrink_category($data, $curlies); | ||||
| 335 | } elsif($ops eq "m") { | ||||
| 336 | if($curlies eq "chomp") { | ||||
| 337 | chomp $data; | ||||
| 338 | } | ||||
| 339 | } elsif($ops eq "F") { | ||||
| 340 | my @parts = File::Spec->splitdir($data); | ||||
| 341 | # Limit it to max curlies entries | ||||
| 342 | if(@parts > $curlies) { | ||||
| 343 | splice @parts, 0, @parts - $curlies; | ||||
| 344 | } | ||||
| 345 | $data = File::Spec->catfile(@parts); | ||||
| 346 | } elsif($ops eq "p") { | ||||
| 347 | $data = substr $data, 0, $curlies; | ||||
| 348 | } | ||||
| 349 | |||||
| 350 | return $data; | ||||
| 351 | } | ||||
| 352 | |||||
| 353 | ################################################## | ||||
| 354 | sub shrink_category { | ||||
| 355 | ################################################## | ||||
| 356 | my($category, $len) = @_; | ||||
| 357 | |||||
| 358 | my @components = split /\.|::/, $category; | ||||
| 359 | |||||
| 360 | if(@components > $len) { | ||||
| 361 | splice @components, 0, @components - $len; | ||||
| 362 | $category = join '.', @components; | ||||
| 363 | } | ||||
| 364 | |||||
| 365 | return $category; | ||||
| 366 | } | ||||
| 367 | |||||
| 368 | ################################################## | ||||
| 369 | sub add_global_cspec { | ||||
| 370 | ################################################## | ||||
| 371 | # This is a Class method. | ||||
| 372 | # Accepts a coderef or text | ||||
| 373 | ################################################## | ||||
| 374 | |||||
| 375 | unless($Log::Log4perl::ALLOW_CODE_IN_CONFIG_FILE) { | ||||
| 376 | die "\$Log::Log4perl::ALLOW_CODE_IN_CONFIG_FILE setting " . | ||||
| 377 | "prohibits user defined cspecs"; | ||||
| 378 | } | ||||
| 379 | |||||
| 380 | my ($letter, $perlcode) = @_; | ||||
| 381 | |||||
| 382 | croak "Illegal value '$letter' in call to add_global_cspec()" | ||||
| 383 | unless ($letter =~ /^[a-zA-Z]$/); | ||||
| 384 | |||||
| 385 | croak "Missing argument for perlcode for 'cspec.$letter' ". | ||||
| 386 | "in call to add_global_cspec()" | ||||
| 387 | unless $perlcode; | ||||
| 388 | |||||
| 389 | croak "Please don't redefine built-in cspecs [$CSPECS]\n". | ||||
| 390 | "like you do for \"cspec.$letter\"\n " | ||||
| 391 | if ($CSPECS =~/$letter/); | ||||
| 392 | |||||
| 393 | if (ref $perlcode eq 'CODE') { | ||||
| 394 | $GLOBAL_USER_DEFINED_CSPECS{$letter} = $perlcode; | ||||
| 395 | |||||
| 396 | }elsif (! ref $perlcode){ | ||||
| 397 | |||||
| 398 | $GLOBAL_USER_DEFINED_CSPECS{$letter} = | ||||
| 399 | Log::Log4perl::Config::compile_if_perl($perlcode); | ||||
| 400 | |||||
| 401 | if ($@) { | ||||
| 402 | die qq{Compilation failed for your perl code for }. | ||||
| 403 | qq{"log4j.PatternLayout.cspec.$letter":\n}. | ||||
| 404 | qq{This is the error message: \t$@\n}. | ||||
| 405 | qq{This is the code that failed: \n$perlcode\n}; | ||||
| 406 | } | ||||
| 407 | |||||
| 408 | croak "eval'ing your perlcode for 'log4j.PatternLayout.cspec.$letter' ". | ||||
| 409 | "doesn't return a coderef \n". | ||||
| 410 | "Here is the perl code: \n\t$perlcode\n " | ||||
| 411 | unless (ref $GLOBAL_USER_DEFINED_CSPECS{$letter} eq 'CODE'); | ||||
| 412 | |||||
| 413 | }else{ | ||||
| 414 | croak "I don't know how to handle perlcode=$perlcode ". | ||||
| 415 | "for 'cspec.$letter' in call to add_global_cspec()"; | ||||
| 416 | } | ||||
| 417 | } | ||||
| 418 | |||||
| 419 | ################################################## | ||||
| 420 | sub add_layout_cspec { | ||||
| 421 | ################################################## | ||||
| 422 | # object method | ||||
| 423 | # adds a cspec just for this layout | ||||
| 424 | ################################################## | ||||
| 425 | my ($self, $letter, $perlcode) = @_; | ||||
| 426 | |||||
| 427 | unless($Log::Log4perl::ALLOW_CODE_IN_CONFIG_FILE) { | ||||
| 428 | die "\$Log::Log4perl::ALLOW_CODE_IN_CONFIG_FILE setting " . | ||||
| 429 | "prohibits user defined cspecs"; | ||||
| 430 | } | ||||
| 431 | |||||
| 432 | croak "Illegal value '$letter' in call to add_layout_cspec()" | ||||
| 433 | unless ($letter =~ /^[a-zA-Z]$/); | ||||
| 434 | |||||
| 435 | croak "Missing argument for perlcode for 'cspec.$letter' ". | ||||
| 436 | "in call to add_layout_cspec()" | ||||
| 437 | unless $perlcode; | ||||
| 438 | |||||
| 439 | croak "Please don't redefine built-in cspecs [$CSPECS] \n". | ||||
| 440 | "like you do for 'cspec.$letter'" | ||||
| 441 | if ($CSPECS =~/$letter/); | ||||
| 442 | |||||
| 443 | if (ref $perlcode eq 'CODE') { | ||||
| 444 | |||||
| 445 | $self->{USER_DEFINED_CSPECS}{$letter} = $perlcode; | ||||
| 446 | |||||
| 447 | }elsif (! ref $perlcode){ | ||||
| 448 | |||||
| 449 | $self->{USER_DEFINED_CSPECS}{$letter} = | ||||
| 450 | Log::Log4perl::Config::compile_if_perl($perlcode); | ||||
| 451 | |||||
| 452 | if ($@) { | ||||
| 453 | die qq{Compilation failed for your perl code for }. | ||||
| 454 | qq{"cspec.$letter":\n}. | ||||
| 455 | qq{This is the error message: \t$@\n}. | ||||
| 456 | qq{This is the code that failed: \n$perlcode\n}; | ||||
| 457 | } | ||||
| 458 | croak "eval'ing your perlcode for 'cspec.$letter' ". | ||||
| 459 | "doesn't return a coderef \n". | ||||
| 460 | "Here is the perl code: \n\t$perlcode\n " | ||||
| 461 | unless (ref $self->{USER_DEFINED_CSPECS}{$letter} eq 'CODE'); | ||||
| 462 | |||||
| 463 | |||||
| 464 | }else{ | ||||
| 465 | croak "I don't know how to handle perlcode=$perlcode ". | ||||
| 466 | "for 'cspec.$letter' in call to add_layout_cspec()"; | ||||
| 467 | } | ||||
| 468 | |||||
| 469 | $self->{CSPECS} .= $letter; | ||||
| 470 | } | ||||
| 471 | |||||
| 472 | ########################################### | ||||
| 473 | sub callinfo_dump { | ||||
| 474 | ########################################### | ||||
| 475 | my($level, $info) = @_; | ||||
| 476 | |||||
| 477 | my @called_by = caller(0); | ||||
| 478 | |||||
| 479 | # Just for internal debugging | ||||
| 480 | $called_by[1] = basename $called_by[1]; | ||||
| 481 | print "caller($level) at $called_by[1]-$called_by[2] returned "; | ||||
| 482 | |||||
| 483 | my @by_idx; | ||||
| 484 | |||||
| 485 | # $info->[1] = basename $info->[1] if defined $info->[1]; | ||||
| 486 | |||||
| 487 | my $i = 0; | ||||
| 488 | for my $field (qw(package filename line subroutine hasargs | ||||
| 489 | wantarray evaltext is_require hints bitmask)) { | ||||
| 490 | $by_idx[$i] = $field; | ||||
| 491 | $i++; | ||||
| 492 | } | ||||
| 493 | |||||
| 494 | $i = 0; | ||||
| 495 | for my $value (@$info) { | ||||
| 496 | my $field = $by_idx[ $i ]; | ||||
| 497 | print "$field=", | ||||
| 498 | (defined $info->[$i] ? $info->[$i] : "[undef]"), | ||||
| 499 | " "; | ||||
| 500 | $i++; | ||||
| 501 | } | ||||
| 502 | |||||
| 503 | print "\n"; | ||||
| 504 | } | ||||
| 505 | |||||
| 506 | 1 | 4µs | 1; | ||
| 507 | |||||
| 508 | __END__ | ||||
# spent 200ns within Log::Log4perl::Layout::PatternLayout::CORE:match which was called:
# once (200ns+0s) by Log::Log4perl::Layout::PatternLayout::define at line 107 | |||||
# spent 22µs within Log::Log4perl::Layout::PatternLayout::CORE:regcomp which was called:
# once (22µs+0s) by Log::Log4perl::Layout::PatternLayout::define at line 114 | |||||
# spent 11µs within Log::Log4perl::Layout::PatternLayout::CORE:subst which was called 3 times, avg 4µs/call:
# once (8µs+0s) by Log::Log4perl::Layout::PatternLayout::define at line 114
# once (2µs+0s) by Log::Log4perl::Layout::PatternLayout::new at line 91
# once (500ns+0s) by Log::Log4perl::Layout::PatternLayout::new at line 92 | |||||
# spent 2µs within Log::Log4perl::Layout::PatternLayout::CORE:substcont which was called 2 times, avg 1µs/call:
# 2 times (2µs+0s) by Log::Log4perl::Layout::PatternLayout::define at line 114, avg 1µs/call |