| 1 | | | | | package Apache::LogFormat::Compiler; |
| 2 | | | | | |
| 3 | | | | | use strict; |
| 4 | | | | | use warnings; |
| 5 | | | | | use 5.008004; |
| 6 | | | | | use Carp; |
| 7 | | | | | use POSIX::strftime::Compiler qw//; |
| 8 | | | | | use constant { |
| 9 | | | | | ENVS => 0, |
| 10 | | | | | RES => 1, |
| 11 | | | | | LENGTH => 2, |
| 12 | | | | | REQTIME => 3, |
| 13 | | | | | TIME => 4, |
| 14 | | | | | }; |
| 15 | | | | | |
| 16 | | | | | our $VERSION = '0.30'; |
| 17 | | | | | |
| 18 | | | | | # copy from Plack::Middleware::AccessLog |
| 19 | | | | | our %formats = ( |
| 20 | | | | | common => '%h %l %u %t "%r" %>s %b', |
| 21 | | | | | combined => '%h %l %u %t "%r" %>s %b "%{Referer}i" "%{User-agent}i"', |
| 22 | | | | | ); |
| 23 | | | | | |
| 24 | | | | | sub _safe { |
| 25 | | | | | my $string = shift; |
| 26 | | | | | return unless defined $string; |
| 27 | | | | | $string =~ s/([^[:print:]])/"\\x" . unpack("H*", $1)/eg; |
| 28 | | | | | return $string; |
| 29 | | | | | } |
| 30 | | | | | |
| 31 | | | | | sub _string { |
| 32 | | | | | my $string = shift; |
| 33 | | | | | return '-' if ! defined $string; |
| 34 | | | | | return '-' if ! length $string; |
| 35 | | | | | $string =~ s/([^[:print:]])/"\\x" . unpack("H*", $1)/eg; |
| 36 | | | | | return $string; |
| 37 | | | | | } |
| 38 | | | | | |
| 39 | | | | | sub header_get { |
| 40 | | | | | my ($headers, $key) = @_; |
| 41 | | | | | $key = lc $key; |
| 42 | | | | | my @headers = @$headers; # copy |
| 43 | | | | | my $value; |
| 44 | | | | | while (my($hdr, $val) = splice @headers, 0, 2) { |
| 45 | | | | | if ( lc $hdr eq $key ) { |
| 46 | | | | | $value = $val; |
| 47 | | | | | last; |
| 48 | | | | | } |
| 49 | | | | | } |
| 50 | | | | | return $value; |
| 51 | | | | | } |
| 52 | | | | | |
| 53 | | | | | my $psgi_reserved = { CONTENT_LENGTH => 1, CONTENT_TYPE => 1 }; |
| 54 | | | | | |
| 55 | | | | | my $block_handler = sub { |
| 56 | | | | | my($block, $type, $extra) = @_; |
| 57 | | | | | my $cb; |
| 58 | | | | | if ($type eq 'i') { |
| 59 | | | | | $block =~ s/-/_/g; |
| 60 | | | | | $block = uc($block); |
| 61 | | | | | $block = "HTTP_${block}" unless $psgi_reserved->{$block}; |
| 62 | | | | | $cb = q!_string($_[ENVS]->{'!.$block.q!'})!; |
| 63 | | | | | } elsif ($type eq 'o') { |
| 64 | | | | | $cb = q!_string(header_get($_[RES]->[1],'!.$block.q!'))!; |
| 65 | | | | | } elsif ($type eq 't') { |
| 66 | | | | | $cb = q!"[" . POSIX::strftime::Compiler::strftime('!.$block.q!', @lt) . "]"!; |
| 67 | | | | | } elsif (exists $extra->{$type}) { |
| 68 | | | | | $cb = q!_string($extra_block_handlers->{'!.$type.q!'}->('!.$block.q!',$_[ENVS],$_[RES],$_[LENGTH],$_[REQTIME]))!; |
| 69 | | | | | } else { |
| 70 | | | | | Carp::croak("{$block}$type not supported"); |
| 71 | | | | | $cb = "-"; |
| 72 | | | | | } |
| 73 | | | | | return q|! . | . $cb . q| |
| 74 | | | | | . q!|; |
| 75 | | | | | }; |
| 76 | | | | | |
| 77 | | | | | our %char_handler = ( |
| 78 | | | | | '%' => q!'%'!, |
| 79 | | | | | h => q!($_[ENVS]->{REMOTE_ADDR} || '-')!, |
| 80 | | | | | l => q!'-'!, |
| 81 | | | | | u => q!($_[ENVS]->{REMOTE_USER} || '-')!, |
| 82 | | | | | t => q!'[' . $t . ']'!, |
| 83 | | | | | r => q!_safe($_[ENVS]->{REQUEST_METHOD}) . " " . _safe($_[ENVS]->{REQUEST_URI}) . |
| 84 | | | | | " " . $_[ENVS]->{SERVER_PROTOCOL}!, |
| 85 | | | | | s => q!$_[RES]->[0]!, |
| 86 | | | | | b => q!(defined $_[LENGTH] ? $_[LENGTH] : '-')!, |
| 87 | | | | | T => q!(defined $_[REQTIME] ? int($_[REQTIME]*1_000_000) : '-')!, |
| 88 | | | | | D => q!(defined $_[REQTIME] ? $_[REQTIME] : '-')!, |
| 89 | | | | | v => q!($_[ENVS]->{SERVER_NAME} || '-')!, |
| 90 | | | | | V => q!($_[ENVS]->{HTTP_HOST} || $_[ENVS]->{SERVER_NAME} || '-')!, |
| 91 | | | | | p => q!$_[ENVS]->{SERVER_PORT}!, |
| 92 | | | | | P => q!$$!, |
| 93 | | | | | m => q!_safe($_[ENVS]->{REQUEST_METHOD})!, |
| 94 | | | | | U => q!_safe($_[ENVS]->{PATH_INFO})!, |
| 95 | | | | | q => q!(($_[ENVS]->{QUERY_STRING} ne '') ? '?' . _safe($_[ENVS]->{QUERY_STRING}) : '' )!, |
| 96 | | | | | H => q!$_[ENVS]->{SERVER_PROTOCOL}!, |
| 97 | | | | | |
| 98 | | | | | ); |
| 99 | | | | | |
| 100 | | | | | my $char_handler = sub { |
| 101 | | | | | my ($char, $extra) = @_; |
| 102 | | | | | my $cb = $char_handler{$char}; |
| 103 | | | | | if (!$cb && exists $extra->{$char}) { |
| 104 | | | | | $cb = q!_string($extra_char_handlers->{'!.$char.q!'}->($_[ENVS],$_[RES],$_[LENGTH],$_[REQTIME]))!; |
| 105 | | | | | } |
| 106 | | | | | unless ($cb) { |
| 107 | | | | | Carp::croak "\%$char not supported."; |
| 108 | | | | | return "-"; |
| 109 | | | | | } |
| 110 | | | | | q|! . | . $cb . q| |
| 111 | | | | | . q!|; |
| 112 | | | | | }; |
| 113 | | | | | |
| 114 | | | | | sub new { |
| 115 | | | | | my $class = shift; |
| 116 | | | | | |
| 117 | | | | | my $fmt = shift || "combined"; |
| 118 | | | | | $fmt = $formats{$fmt} if exists $formats{$fmt}; |
| 119 | | | | | |
| 120 | | | | | my %opts = @_; |
| 121 | | | | | |
| 122 | | | | | my ($code_ref, $code) = compile($fmt, $opts{block_handlers} || {}, $opts{char_handlers} || {}); |
| 123 | | | | | bless [$code_ref, $code], $class; |
| 124 | | | | | } |
| 125 | | | | | |
| 126 | | | | | sub compile { |
| 127 | | | | | my $fmt = shift; |
| 128 | | | | | my $extra_block_handlers = shift; |
| 129 | | | | | my $extra_char_handlers = shift; |
| 130 | | | | | $fmt =~ s/!/\\!/g; |
| 131 | | | | | $fmt =~ s! |
| 132 | | | | | (?: |
| 133 | | | | | \%\{(.+?)\}([a-zA-Z]) | |
| 134 | | | | | \%(?:[<>])?([a-zA-Z\%]) |
| 135 | | | | | ) |
| 136 | | | | | ! $1 ? $block_handler->($1, $2, $extra_block_handlers) : $char_handler->($3, $extra_char_handlers) !egx; |
| 137 | | | | | |
| 138 | | | | | my @abbr = qw( Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec ); |
| 139 | | | | | my $c = {}; |
| 140 | | | | | $fmt = q~sub { |
| 141 | | | | | $_[TIME] = time() if ! defined $_[TIME]; |
| 142 | | | | | my @lt = localtime($_[TIME]); |
| 143 | | | | | if ( ! exists $c->{tz_cache} || ! exists $c->{isdst_cache} || $lt[8] != $c->{isdst_cache} ) { |
| 144 | | | | | $c->{tz_cache} = POSIX::strftime::Compiler::strftime('%z',@lt); |
| 145 | | | | | $c->{isdst_cache} = $lt[8]; |
| 146 | | | | | } |
| 147 | | | | | my $t = sprintf '%02d/%s/%04d:%02d:%02d:%02d %s', $lt[3], $abbr[$lt[4]], $lt[5]+1900, |
| 148 | | | | | $lt[2], $lt[1], $lt[0], $c->{tz_cache}; |
| 149 | | | | | q!~ . $fmt . q~! |
| 150 | | | | | }~; |
| 151 | | | | | my $code_ref = eval $fmt; ## no critic |
| 152 | | | | | die $@ . "\n===\n" . $fmt if $@; |
| 153 | | | | | wantarray ? ($code_ref, $fmt) : $code_ref; |
| 154 | | | | | } |
| 155 | | | | | |
| 156 | | | | | sub log_line { |
| 157 | | | | | my $self = shift; |
| 158 | | | | | $self->[0]->(@_) . "\n"; |
| 159 | | | | | } |
| 160 | | | | | |
| 161 | | | | | sub code { |
| 162 | | | | | my $self = shift; |
| 163 | | | | | $self->[1]; |
| 164 | | | | | } |
| 165 | | | | | |
| 166 | | | | | sub code_ref { |
| 167 | | | | | my $self = shift; |
| 168 | | | | | $self->[0]; |
| 169 | | | | | } |
| 170 | | | | | |
| 171 | | | | | 1; |
| 172 | | | | | __END__ |
| 173 | | | | | |
| 174 | | | | | =encoding utf8 |
| 175 | | | | | |
| 176 | | | | | =head1 NAME |
| 177 | | | | | |
| 178 | | | | | Apache::LogFormat::Compiler - Compile a log format string to perl-code |
| 179 | | | | | |
| 180 | | | | | =head1 SYNOPSIS |
| 181 | | | | | |
| 182 | | | | | use Apache::LogFormat::Compiler; |
| 183 | | | | | |
| 184 | | | | | my $log_handler = Apache::LogFormat::Compiler->new("combined"); |
| 185 | | | | | my $log = $log_handler->log_line( |
| 186 | | | | | $env, |
| 187 | | | | | $res, |
| 188 | | | | | $length, |
| 189 | | | | | $reqtime, |
| 190 | | | | | $time |
| 191 | | | | | ); |
| 192 | | | | | |
| 193 | | | | | =head1 DESCRIPTION |
| 194 | | | | | |
| 195 | | | | | Compile a log format string to perl-code. For faster generation of access_log lines. |
| 196 | | | | | |
| 197 | | | | | =head1 METHOD |
| 198 | | | | | |
| 199 | | | | | =over 4 |
| 200 | | | | | |
| 201 | | | | | =item new($fmt:String) |
| 202 | | | | | |
| 203 | | | | | Takes a format string (or a preset template C<combined> or C<custom>) |
| 204 | | | | | to specify the log format. This module implements a subset of |
| 205 | | | | | L<Apache's LogFormat templates|http://httpd.apache.org/docs/2.0/mod/mod_log_config.html>: |
| 206 | | | | | |
| 207 | | | | | %% a percent sign |
| 208 | | | | | %h REMOTE_ADDR from the PSGI environment, or - |
| 209 | | | | | %l remote logname not implemented (currently always -) |
| 210 | | | | | %u REMOTE_USER from the PSGI environment, or - |
| 211 | | | | | %t [local timestamp, in default format] |
| 212 | | | | | %r REQUEST_METHOD, REQUEST_URI and SERVER_PROTOCOL from the PSGI environment |
| 213 | | | | | %s the HTTP status code of the response |
| 214 | | | | | %b content length of the response |
| 215 | | | | | %T custom field for handling times in subclasses |
| 216 | | | | | %D custom field for handling sub-second times in subclasses |
| 217 | | | | | %v SERVER_NAME from the PSGI environment, or - |
| 218 | | | | | %V HTTP_HOST or SERVER_NAME from the PSGI environment, or - |
| 219 | | | | | %p SERVER_PORT from the PSGI environment |
| 220 | | | | | %P the worker's process id |
| 221 | | | | | %m REQUEST_METHOD from the PSGI environment |
| 222 | | | | | %U PATH_INFO from the PSGI environment |
| 223 | | | | | %q QUERY_STRING from the PSGI environment |
| 224 | | | | | %H SERVER_PROTOCOL from the PSGI environment |
| 225 | | | | | |
| 226 | | | | | In addition, custom values can be referenced, using C<%{name}>, |
| 227 | | | | | with one of the mandatory modifier flags C<i>, C<o> or C<t>: |
| 228 | | | | | |
| 229 | | | | | %{variable-name}i HTTP_VARIABLE_NAME value from the PSGI environment |
| 230 | | | | | %{header-name}o header-name header in the response |
| 231 | | | | | %{time-format]t localtime in the specified strftime format |
| 232 | | | | | |
| 233 | | | | | =item log_line($env:HashRef, $res:ArrayRef, $length:Integer, $reqtime:Integer, $time:Integer): $log:String |
| 234 | | | | | |
| 235 | | | | | Generates log line. |
| 236 | | | | | |
| 237 | | | | | $env PSGI env request HashRef |
| 238 | | | | | $res PSGI response ArrayRef |
| 239 | | | | | $length Content-Length |
| 240 | | | | | $reqtime The time taken to serve request in microseconds. optional |
| 241 | | | | | $time Time the request was received. optional. If $time is undefined. current timestamp is used. |
| 242 | | | | | |
| 243 | | | | | Sample psgi |
| 244 | | | | | |
| 245 | | | | | use Plack::Builder; |
| 246 | | | | | use Time::HiRes; |
| 247 | | | | | use Apache::LogFormat::Compiler; |
| 248 | | | | | |
| 249 | | | | | my $log_handler = Apache::LogFormat::Compiler->new( |
| 250 | | | | | '%h %l %u %t "%r" %>s %b "%{Referer}i" "%{User-agent}i" %D' |
| 251 | | | | | ); |
| 252 | | | | | my $compile_log_app = builder { |
| 253 | | | | | enable sub { |
| 254 | | | | | my $app = shift; |
| 255 | | | | | sub { |
| 256 | | | | | my $env = shift; |
| 257 | | | | | my $t0 = [gettimeofday]; |
| 258 | | | | | my $res = $app->(); |
| 259 | | | | | my $reqtime = int(Time::HiRes::tv_interval($t0) * 1_000_000); |
| 260 | | | | | $env->{psgi.error}->print($log_handler->log_line( |
| 261 | | | | | $env,$res,6,$reqtime, $t0->[0])); |
| 262 | | | | | } |
| 263 | | | | | }; |
| 264 | | | | | $app |
| 265 | | | | | }; |
| 266 | | | | | |
| 267 | | | | | =back |
| 268 | | | | | |
| 269 | | | | | =head1 ABOUT POSIX::strftime::Compiler |
| 270 | | | | | |
| 271 | | | | | This module uses L<POSIX::strftime::Compiler> for generate datetime string. POSIX::strftime::Compiler provides GNU C library compatible strftime(3). But this module will not affected by the system locale. This feature is useful when you want to write loggers, servers and portable applications. |
| 272 | | | | | |
| 273 | | | | | =head1 ADD CUSTOM FORMAT STRING |
| 274 | | | | | |
| 275 | | | | | Apache::LogFormat::Compiler allows one to add a custom format string |
| 276 | | | | | |
| 277 | | | | | my $log_handler = Apache::LogFormat::Compiler->new( |
| 278 | | | | | '%z %{HTTP_X_FORWARDED_FOR|REMOTE_ADDR}Z', |
| 279 | | | | | char_handlers => +{ |
| 280 | | | | | 'z' => sub { |
| 281 | | | | | my ($env,$req) = @_; |
| 282 | | | | | return $env->{HTTP_X_FORWARDED_FOR}; |
| 283 | | | | | } |
| 284 | | | | | }, |
| 285 | | | | | block_handlers => +{ |
| 286 | | | | | 'Z' => sub { |
| 287 | | | | | my ($block,$env,$req) = @_; |
| 288 | | | | | # block eq 'HTTP_X_FORWARDED_FOR|REMOTE_ADDR' |
| 289 | | | | | my ($main, $alt) = split('\|', $args); |
| 290 | | | | | return exists $env->{$main} ? $env->{$main} : $env->{$alt}; |
| 291 | | | | | } |
| 292 | | | | | }, |
| 293 | | | | | ); |
| 294 | | | | | |
| 295 | | | | | Any single letter can be used, other than those already defined by Apache::LogFormat::Compiler. |
| 296 | | | | | Your sub is called with two or three arguments: the content inside the C<{}> |
| 297 | | | | | from the format (block_handlers only), the PSGI environment (C<$env>), |
| 298 | | | | | and the ArrayRef of the response. It should return the string to be logged. |
| 299 | | | | | |
| 300 | | | | | =head1 AUTHOR |
| 301 | | | | | |
| 302 | | | | | Masahiro Nagano E<lt>kazeburo@gmail.comE<gt> |
| 303 | | | | | |
| 304 | | | | | =head1 SEE ALSO |
| 305 | | | | | |
| 306 | | | | | L<Plack::Middleware::AccessLog>, L<http://httpd.apache.org/docs/2.2/mod/mod_log_config.html> |
| 307 | | | | | |
| 308 | | | | | =head1 LICENSE |
| 309 | | | | | |
| 310 | | | | | Copyright (C) Masahiro Nagano |
| 311 | | | | | |
| 312 | | | | | This library is free software; you can redistribute it and/or modify |
| 313 | | | | | it under the same terms as Perl itself. |
| 314 | | | | | |
| 315 | | | | | =cut |