122 |
return undef unless defined $format; |
return undef unless defined $format; |
123 |
|
|
124 |
# caller() called only when necessary |
# caller() called only when necessary |
125 |
my $needs_caller = $format =~ /%[FLP]/; |
my $needs_caller = $format =~ /%[FLPS]/; |
126 |
return sub { |
return sub { |
127 |
my %p = @_; |
my %p = @_; |
128 |
$p{p} = delete $p{level}; |
$p{p} = delete $p{level}; |
129 |
$p{m} = delete $p{message}; |
$p{m} = delete $p{message}; |
130 |
$p{n} = "\n"; |
$p{n} = "\n"; |
131 |
$p{'%'} = '%'; |
$p{'%'} = '%'; |
132 |
|
require POSIX; |
133 |
|
$p{i} = POSIX::getpid(); |
134 |
|
|
135 |
if ($needs_caller) { |
if ($needs_caller) { |
136 |
my $depth = 0; |
my $depth = 0; |
137 |
$depth++ while caller($depth) =~ /^Log::Dispatch/; |
$depth++ while caller($depth) =~ /^Log::Dispatch/; |
138 |
$depth += :Dispatch::Config::CallerDepth; |
$depth += :Dispatch::Config::CallerDepth; |
139 |
@p{qw(P F L)} = caller($depth); |
@p{qw(P F L)} = caller($depth); |
140 |
|
my $subname = (caller($depth+1))[3]; |
141 |
|
$p{S} = $subname; |
142 |
|
$subname =~ s/^.*:://; |
143 |
|
$p{s} = $subname; |
144 |
} |
} |
145 |
|
|
146 |
my $log = $format; |
my $log = $format; |
147 |
$log =~ s{ |
$log =~ s{ |
148 |
(%d(?:{(.*?)})?)| # $1: datetime $2: datetime fmt |
(%d(?:{(.*?)})?)| # $1: datetime $2: datetime fmt |
149 |
(?:%([%pmFLPn])) # $3: others |
(?:%([%pmFLPSnis])) # $3: others |
150 |
}{ |
}{ |
151 |
if ($1 && $2) { |
if ($1 && $2) { |
152 |
_strftime($2); |
_strftime($2); |
267 |
%P package |
%P package |
268 |
%n newline (\n) |
%n newline (\n) |
269 |
%% % itself |
%% % itself |
270 |
|
%i process-id, returns POSIX::getpid() |
271 |
|
%S subroutine with package name |
272 |
|
%s subroutine without package name |
273 |
|
|
274 |
Note that datetime (%d) format is configurable by passing C<strftime> |
Note that datetime (%d) format is configurable by passing C<strftime> |
275 |
fmt in braket after %d. (I know it looks quite messy, but its |
fmt in braket after %d. (I know it looks quite messy, but its |