File Coverage

blib/lib/Logfile/Access.pm
Criterion Covered Total %
statement 245 363 67.4
branch 33 122 27.0
condition 1 12 8.3
subroutine 53 60 88.3
pod 4 41 9.7
total 336 598 56.1


line stmt bran cond sub pod time code
1             package Logfile::Access;
2              
3             # $Id: Access.pm,v 1.30 2004/10/25 18:58:12 root Exp $
4              
5 1     1   24451 use 5.008;
  1         4  
  1         43  
6 1     1   6 use strict;
  1         2  
  1         38  
7 1     1   6 use warnings;
  1         6  
  1         34  
8              
9 1     1   2289 use URI;
  1         19531  
  1         33  
10 1     1   13 use URI::Escape;
  1         2  
  1         82  
11 1     1   1002 use Locale::Country;
  1         56358  
  1         210  
12              
13             require Exporter;
14              
15             our @ISA = qw(Exporter);
16              
17             # Items to export into callers namespace by default. Note: do not export
18             # names by default without a very good reason. Use EXPORT_OK instead.
19             # Do not simply export all your public functions/methods/constants.
20              
21             # This allows declaration use Logfile::Access ':all';
22             # If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
23             # will save memory.
24             our %EXPORT_TAGS = ( 'all' => [ qw(
25            
26             ) ] );
27              
28             our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
29              
30             our @EXPORT = qw(
31            
32             );
33              
34             our $VERSION = '1.30';
35              
36             # Preloaded methods go here.
37              
38 1     1   11 use constant MIME_TYPE_CONFIG_FILENAME => "/etc/httpd/conf/mime.types";
  1         3  
  1         483  
39              
40             sub new
41             {
42              
43 1     1 0 13 my $self = {};
44 1         3 my $loop = 1;
45              
46 1         3 my @column;
47 1 50       8 if (scalar @_ > 1)
48             {
49 0         0 foreach my $key (@column)
50             {
51 0         0 $self->{$key} = $_[$loop++];
52             }
53             }
54 1         33 bless($self);
55 1         6 $self->load_mime_types;
56 1         5 return $self;
57             }
58              
59             my %mime_type;
60             sub load_mime_types
61             {
62 1 50   1 0 6 return if %mime_type;
63 1 50       34 if (open (IN, MIME_TYPE_CONFIG_FILENAME))
64             {
65 0         0 while ()
66             {
67 0 0       0 next if $_ =~ /^ *\#/;
68 0         0 $_ =~ s/\n|\r//g;
69 0         0 my @data = split (/( |\t)+/, $_);
70 0         0 my $mime_type = shift @data;
71 0         0 foreach my $extension (@data)
72             {
73 0 0       0 next if $extension !~ /\w/;
74 0         0 $mime_type{$extension} = $mime_type;
75             }
76             }
77 0         0 close IN;
78             }
79             else
80             {
81 1         61 warn "unable to open " . MIME_TYPE_CONFIG_FILENAME . "\n";
82             }
83             }
84              
85 1     1   7 use constant REGEX_IP => q{(\S+)};
  1         4  
  1         64  
86 1     1   6 use constant REGEX_DATE => q{(\d{2})\/(\w{3})\/(\d{4})};
  1         9  
  1         53  
87 1     1   7 use constant REGEX_TIME => q{(\d{2}):(\d{2}):(\d{2})};
  1         2  
  1         56  
88 1     1   5 use constant REGEX_OFFSET => q{([+\-]\d{4})};
  1         2  
  1         61  
89 1     1   5 use constant REGEX_METHOD => q{(\S+)};
  1         2  
  1         46  
90 1     1   5 use constant REGEX_OBJECT => q{([^ ]+)};
  1         2  
  1         51  
91 1     1   14 use constant REGEX_PROTOCOL => q{(\w+\/[\d\.]+)};
  1         2  
  1         45  
92 1     1   5 use constant REGEX_STATUS => q{(\d+|\-)};
  1         2  
  1         55  
93 1     1   7 use constant REGEX_CONTENT_LENGTH => q{(\d+|\-)};
  1         2  
  1         48  
94 1     1   5 use constant REGEX_HTTP_REFERER => q{([^"]+)};
  1         2  
  1         51  
95 1     1   5 use constant REGEX_HTTP_USER_AGENT => q{([^"]+)};
  1         2  
  1         42  
96 1     1   5 use constant REGEX_COOKIE => q{([^"]+)};
  1         2  
  1         7704  
97              
98             sub parse_iis
99             {
100 0     0 0 0 my $class = "parse";
101 0         0 my $self = shift;
102 0         0 my $row = shift;
103              
104             #1998-11-19 22:48:39 206.175.82.5 - 208.201.133.173 GET /global/images/navlineboards.gif - 200 540 324 157 HTTP/1.0 Mozilla/4.0+(compatible;+MSIE+4.01;+Windows+95) USERID=CustomerA;+IMPID=01234 http://www.loganalyzer.net
105 0 0       0 if ($row =~ /^(\d{4})-(\d{2})-(\d{2}) @{[REGEX_TIME]} @{[REGEX_IP]} @{[REGEX_IP]} @{[REGEX_METHOD]} @{[REGEX_OBJECT]} (\S+) @{[REGEX_STATUS]} (\d+) (\d+) (\d+) (\d+) @{[REGEX_PROTOCOL]} @{[REGEX_HTTP_USER_AGENT]} @{[REGEX_COOKIE]} @{[REGEX_HTTP_REFERER]} *$/)
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
106             {
107 0         0 $self->{"date"} = join("/", $1, $2, $3);
108 0         0 $self->{"year"} = $1;
109 0         0 $self->{"month"} = $2;
110 0         0 $self->{"mday"} = $3;
111              
112 0         0 $self->{"time"} = join(":", $4, $5, $6);
113 0         0 $self->{"hour"} = $4;
114 0         0 $self->{"minute"} = $5;
115 0         0 $self->{"second"} = $6;
116             }
117             else
118             {
119 0         0 return 0;
120             }
121              
122 0         0 return $self->{$class}
123             }
124              
125             sub parse
126             {
127 2     2 0 12 my $class = "parse";
128 2         5 my $self = shift;
129 2         4 my $row = shift;
130              
131 2         11 $row =~ s/\n|\r//g;
132              
133 2 50 33     5 if (
134 2         7 ($row =~ /^@{[REGEX_IP]} (\S+) (\S+) \[@{[REGEX_DATE]}:@{[REGEX_TIME]} @{[REGEX_OFFSET]}\] \"@{[REGEX_METHOD]} @{[REGEX_OBJECT]} @{[REGEX_PROTOCOL]}\" @{[REGEX_STATUS]} @{[REGEX_CONTENT_LENGTH]} *$/)
  2         6  
  2         6  
  2         6  
  2         7  
  2         5  
  2         5  
  2         5  
  2         123  
135             ||
136 2         6 ($row =~ /^@{[REGEX_IP]} (\S+) (\S+) \[@{[REGEX_DATE]}:@{[REGEX_TIME]} @{[REGEX_OFFSET]}\] \"@{[REGEX_METHOD]} @{[REGEX_OBJECT]} @{[REGEX_PROTOCOL]}\" @{[REGEX_STATUS]} @{[REGEX_CONTENT_LENGTH]} \"?@{[REGEX_HTTP_REFERER]}\"? \"?@{[REGEX_HTTP_USER_AGENT]}\"?$/)
  2         5  
  2         6  
  2         4  
  2         5  
  2         4  
  2         7  
  2         3  
  2         6  
  2         5  
  2         135  
137             )
138             {
139 2         19 $self->{"remote_host"} = $1;
140 2         16 $self->{"logname"} = $2;
141 2         8 $self->{"user"} = $3;
142 2         14 $self->{"date"} = join("/", $4, $5, $6);
143 2         6 $self->{"mday"} = $4;
144 2         7 $self->{"month"} = $5;
145 2         5 $self->{"year"} = $6;
146 2         13 $self->{"time"} = join(":", $7, $8, $9);
147 2         5 $self->{"hour"} = $7;
148 2         6 $self->{"minute"} = $8;
149 2         5 $self->{"second"} = $9;
150 2         11 $self->{"offset"} = $10;
151 2         17 $self->{"method"} = $11;
152 2         7 $self->{"object"} = $12;
153 2         5 $self->{"protocol"} = $13;
154 2         7 $self->{"response_code"} = $14;
155 2         8 $self->{"content_length"} = $15;
156 2         4 $self->{"http_referer"} = $16;
157 2         6 $self->{"http_user_agent"} = $17;
158 2         16 return 1;
159             }
160             else
161             {
162             #die $row;
163 0         0 return 0;
164             }
165             #if (@_) {$self->{$class} = shift}
166             #return $self->{$class}
167             }
168              
169             sub print
170             {
171 0     0 0 0 my $class = "print";
172 0         0 my $self = shift;
173              
174 0         0 my $datetime = "[" . $self->{"date"} . ":" . $self->{"time"} . " " . $self->{"offset"} . "]";
175 0         0 my $object = "\"" . join(" ", $self->{"method"}, $self->{"object"}, $self->{"protocol"}) . "\"";
176 0         0 print join(" ", $self->{"remote_host"}, $self->{"logname"}, $self->{"user"}, $datetime, $object, $self->{"response_code"}, $self->{"content_length"}, "\n");
177              
178 0 0       0 if (@_) {$self->{$class} = shift}
  0         0  
179 0         0 return $self->{$class}
180             }
181              
182             ## REMOTE HOST RELATED FUNCTIONS
183             sub class_a
184             {
185 1     1 0 2 my $self = shift;
186            
187 1         7 my $host = $self->remote_host;
188 1 50       12 if ($host =~ /^(\d{1,3}\.)(\d{1,3}\.){2}(\d+)(:\d+)?$/)
189             {
190 1         7 return $1;
191             }
192             }
193              
194             sub class_b
195             {
196 1     1 0 3 my $self = shift;
197            
198 1         3 my $host = $self->remote_host;
199 1 50       12 if ($host =~ /^((\d{1,3}\.){2})(\d{1,3}\.)(\d+)(:\d+)?$/)
200             {
201 1         8 return $1;
202             }
203             }
204              
205             sub class_c
206             {
207 1     1 0 3 my $self = shift;
208            
209 1         4 my $host = $self->remote_host;
210 1 50       14 if ($host =~ /^((\d{1,3}\.){3})(\d+)(:\d+)?$/)
211             {
212 1         7 return $1;
213             }
214             }
215              
216             sub tld
217             {
218 4     4 0 12 my $class = "tld";
219 4         7 my $self = shift;
220              
221            
222 4 50       19 if (my $host = $self->{"remote_host"})
223             {
224 4 100       39 if ($host =~ /\.([a-z]{2,5})$/i)
225             {
226 2         4 my $tld = $1;
227 2         23 $tld =~ tr/A-Z/a-z/;
228 2         10 return $tld;
229             }
230             }
231             }
232              
233             sub country_name
234             {
235 2     2 0 5 my $class = "country_name";
236 2         4 my $self = shift;
237              
238 2         6 my $host = $self->{"remote_host"};
239 2         5 my $tld = $self->tld;
240 2         13 $self->{$class} = code2country($tld);
241 2         121 return $self->{$class};
242             }
243              
244             sub domain
245             {
246 2     2 0 4 my $self = shift;
247              
248 2         8 my $host = $self->remote_host;
249 2         5 $host =~ s/:\d+$//;
250            
251 2 100       17 return if $host =~ /\.\d+(:\d+)?$/;
252             do
253 1         2 {
254 2 50       21 $host =~ s/^([^\.]*\.)// || return $host;
255             }
256             until $host =~ /^[\w\-]+\.[\w]+$/;
257 1         5 return $host;
258             }
259              
260             sub remote_port
261             {
262             ## THIS IS A USELESS PIECE OF CODE, REMOTE_HOSTS NEVER HAVE PORT NUMBER
263 0     0 0 0 my $class = "remote_port";
264 0         0 my $self = shift;
265              
266 0         0 my $host = $self->{"remote_host"};
267 0 0       0 return $1 if $host =~ /:(\d+)\b$/;
268             }
269              
270             sub remote_host
271             {
272 7     7 1 11 my $class = "remote_host";
273 7         11 my $self = shift;
274 7 50       20 if (@_) {$self->{$class} = shift}
  0         0  
275 7         26 return $self->{$class}
276             }
277              
278             sub logname
279             {
280 2     2 0 5 my $class = "logname";
281 2         5 my $self = shift;
282 2 50       7 if (@_) {$self->{$class} = shift}
  0         0  
283 2         10 return $self->{$class}
284             }
285              
286             sub user
287             {
288 2     2 0 4 my $class = "user";
289 2         4 my $self = shift;
290 2 50       8 if (@_) {$self->{$class} = shift}
  0         0  
291 2         10 return $self->{$class}
292             }
293              
294             sub date
295             {
296 2     2 1 5 my $class = "date";
297 2         12 my $self = shift;
298 2 50       8 if (@_) {$self->{$class} = shift}
  0         0  
299 2         11 return $self->{$class}
300             }
301              
302             sub fix_mday
303             {
304             ## BUG: DOES NOT SUPPORT LEAP YEAR
305 0     0 0 0 my $self = shift;
306 0         0 my $mday = shift;
307              
308 0         0 $mday = int($mday);
309 0 0       0 $mday = 1 if $mday < 1;
310 0 0       0 $mday = 31 if $mday > 31;
311              
312 0 0       0 if ($self->{"month"} =~ /^(jan|mar|may|jul|aug|oct|dec)$/i)
    0          
    0          
313             {
314 0 0       0 $mday = 31 if $mday > 31;
315             }
316             elsif ($self->{"month"} =~ /^(apr|jun|sep|nov)$/i)
317             {
318 0 0       0 $mday = 30 if $mday > 30;
319             }
320             elsif ($self->{"month"} =~ /^(feb)$/i)
321             {
322 0 0       0 $mday = 29 if $mday > 29;
323             }
324            
325 0         0 return $mday;
326             }
327              
328             sub mday
329             {
330 2     2 0 5 my $class = "mday";
331 2         4 my $self = shift;
332 2 50       8 if (@_)
333             {
334 0         0 $self->{$class} = shift;
335 0         0 $self->{$class} = fix_mday($self, $self->{$class});
336 0         0 $self->{"date"} = sprintf("%2.2d/%3.3s/%4.4d", $self->{"mday"}, $self->{"month"}, $self->{"year"});
337             }
338 2         11 return $self->{$class}
339             }
340              
341             sub fix_month
342             {
343 0     0 0 0 my $month = shift;
344              
345 0 0       0 if ($month =~ /^\d+$/)
346             {
347 0         0 $month %= 12;
348 0 0       0 $month = 12 if $month == 0;
349             }
350              
351 0 0       0 if ($month =~ /^(jan|0?1)$/i)
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
352             {
353 0         0 $month = "Jan";
354             }
355             elsif ($month =~ /^(feb|0?2)$/i)
356             {
357 0         0 $month = "Feb";
358             }
359             elsif ($month =~ /^(mar|0?3)$/i)
360             {
361 0         0 $month = "Mar";
362             }
363             elsif ($month =~ /^(apr|0?4)$/i)
364             {
365 0         0 $month = "Apr";
366             }
367             elsif ($month =~ /^(may|0?5)$/i)
368             {
369 0         0 $month = "May";
370             }
371             elsif ($month =~ /^(jun|0?6)$/i)
372             {
373 0         0 $month = "Jun";
374             }
375             elsif ($month =~ /^(jul|0?7)$/i)
376             {
377 0         0 $month = "Jul";
378             }
379             elsif ($month =~ /^(aug|0?8)$/i)
380             {
381 0         0 $month = "Aug";
382             }
383             elsif ($month =~ /^(sep|0?9)$/i)
384             {
385 0         0 $month = "Sep";
386             }
387             elsif ($month =~ /^(oct|10)$/i)
388             {
389 0         0 $month = "Oct";
390             }
391             elsif ($month =~ /^(nov|11)$/i)
392             {
393 0         0 $month = "Nov";
394             }
395             elsif ($month =~ /^(dec|12)$/i)
396             {
397 0         0 $month = "Dec";
398             }
399             }
400              
401             sub month
402             {
403 2     2 0 5 my $class = "month";
404 2         4 my $self = shift;
405 2 50       7 if (@_)
406             {
407 0         0 $self->{$class} = shift;
408 0         0 $self->{$class} = fix_month($self->{$class});
409 0         0 $self->{"date"} = sprintf("%2.2d/%3.3s/%4.4d", $self->{"mday"}, $self->{"month"}, $self->{"year"});
410             }
411 2         10 return $self->{$class}
412             }
413              
414             sub fix_year
415             {
416 0     0 0 0 my $year = shift;
417              
418             ## CLEAN UP DATA
419 0         0 $year =~ s/\D//g;
420 0         0 $year = int($year);
421 0         0 $year =~ s/^(\d{4}).*$/$1/;
422              
423             ## ALLOW FOR SHORTCUTS
424 0 0 0     0 $year = 1900 + $year if (($year >= 38) && ($year < 100));
425 0 0 0     0 $year = 2000 + $year if (($year >= 00) && ($year < 38));
426              
427 0         0 $year = sprintf("%4.4d", $year);
428 0         0 return $year;
429             }
430              
431             sub year
432             {
433 2     2 0 5 my $class = "year";
434 2         4 my $self = shift;
435 2 50       8 if (@_)
436             {
437 0         0 $self->{$class} = shift;
438 0         0 $self->{$class} = fix_year($self->{$class});
439 0         0 $self->{"date"} = sprintf("%2.2d/%3.3s/%4.4d", $self->{"mday"}, $self->{"month"}, $self->{"year"});
440             }
441 2         11 return $self->{$class}
442             }
443              
444             sub time
445             {
446 2     2 1 3 my $class = "time";
447 2         6 my $self = shift;
448 2 50       7 if (@_) {$self->{$class} = shift}
  0         0  
449 2         18 return $self->{$class}
450             }
451              
452             sub fix_time
453             {
454 0     0 0 0 my $value = shift;
455 0 0 0     0 $value = "00" if (($value < 0) || ($value > 23));
456 0         0 $value = int($value);
457 0         0 return $value;
458             }
459              
460             sub hour
461             {
462 2     2 0 4 my $class = "hour";
463 2         5 my $self = shift;
464 2 50       8 if (@_)
465             {
466 0         0 $self->{$class} = shift;
467 0         0 $self->{$class} = fix_time($self->{$class});
468 0         0 $self->{"time"} = sprintf("%2.2d:%2.2d:%2.2d", $self->{"hour"}, $self->{"minute"}, $self->{"second"});
469             }
470 2         11 return $self->{$class}
471             }
472              
473             sub minute
474             {
475 2     2 0 5 my $class = "minute";
476 2         4 my $self = shift;
477 2 50       7 if (@_)
478             {
479 0         0 $self->{$class} = shift;
480 0         0 $self->{$class} = fix_time($self->{$class});
481 0         0 $self->{"time"} = sprintf("%2.2d:%2.2d:%2.2d", $self->{"hour"}, $self->{"minute"}, $self->{"second"});
482             }
483 2         11 return $self->{$class}
484             }
485              
486             sub second
487             {
488 2     2 0 4 my $class = "second";
489 2         5 my $self = shift;
490 2 50       7 if (@_)
491             {
492 0         0 $self->{$class} = shift;
493 0         0 $self->{$class} = fix_time($self->{$class});
494 0         0 $self->{"time"} = sprintf("%2.2d:%2.2d:%2.2d", $self->{"hour"}, $self->{"minute"}, $self->{"second"});
495             }
496 2         127 return $self->{$class}
497             }
498              
499             sub offset
500             {
501 2     2 0 4 my $class = "offset";
502 2         3 my $self = shift;
503 2 50       8 if (@_) {$self->{$class} = shift}
  0         0  
504 2         17 return $self->{$class}
505             }
506              
507             sub method
508             {
509 2     2 0 6 my $class = "method";
510 2         4 my $self = shift;
511 2 50       7 if (@_) {$self->{$class} = shift}
  0         0  
512 2         11 return $self->{$class}
513             }
514              
515             ## OBJECT SPECIFIC ROUTINES
516             sub scheme
517             {
518 2     2 0 4 my $class = "scheme";
519 2         4 my $self = shift;
520              
521 2         17 my $uri = URI->new($self->{"object"});
522 2         6660 return $uri->scheme;
523             }
524              
525             sub query_string
526             {
527 2     2 0 933 my $class = "query_string";
528 2         3 my $self = shift;
529              
530 2         14 my $uri = URI->new($self->{"object"});
531 2         93 return $uri->query;
532             }
533              
534             sub path
535             {
536 4     4 0 621 my $class = "path";
537 4         7 my $self = shift;
538              
539 4         17 my $uri = URI->new($self->{"object"});
540 4         191 return $uri->path;
541             }
542              
543             sub mime_type
544             {
545 2     2 0 1297 my $self = shift;
546              
547 2         6 my $object = $self->path;
548 2 50       38 if ($object =~ /\.(\w+)$/)
549             {
550 2         7 my $extension = $1;
551 2         6 $extension =~ tr/A-Z/a-z/;
552 2         14 return $mime_type{$extension};
553             }
554             }
555              
556             sub unescape_object
557             {
558 2     2 0 5 my $self = shift;
559              
560 2         6 my $object = $self->{"object"};
561 2         12 return uri_unescape($object);
562             }
563              
564             sub escape_object
565             {
566 2     2 0 580 my $self = shift;
567              
568 2         9 my $object = $self->{"object"};
569 2         12 return uri_escape($object);
570             }
571              
572             sub object
573             {
574 2     2 1 588 my $class = "object";
575 2         4 my $self = shift;
576 2 50       12 if (@_) {$self->{$class} = shift}
  0         0  
577 2         11 uri_unescape($self->{$class});
578 2         19 return $self->{$class}
579             }
580              
581             sub protocol
582             {
583 2     2 0 6 my $class = "protocol";
584 2         4 my $self = shift;
585 2 50       10 if (@_) {$self->{$class} = shift}
  0         0  
586 2         10 return $self->{$class}
587             }
588              
589             sub response_code
590             {
591 2     2 0 5 my $class = "response_code";
592 2         5 my $self = shift;
593 2 50       8 if (@_) {$self->{$class} = shift}
  0         0  
594 2         13 return $self->{$class}
595             }
596              
597             sub content_length
598             {
599 2     2 0 4 my $class = "content_length";
600 2         4 my $self = shift;
601 2 50       8 if (@_) {$self->{$class} = shift}
  0         0  
602 2         13 return $self->{$class}
603             }
604              
605             sub http_referer
606             {
607 2     2 0 5 my $class = "http_referer";
608 2         6 my $self = shift;
609 2 50       6 if (@_) {$self->{$class} = shift}
  0         0  
610 2         13 return $self->{$class}
611             }
612              
613             sub http_user_agent
614             {
615 2     2 0 6 my $class = "http_user_agent";
616 2         9 my $self = shift;
617 2 50       8 if (@_) {$self->{$class} = shift}
  0         0  
618 2         18 return $self->{$class}
619             }
620              
621              
622             # Autoload methods go after =cut, and are processed by the autosplit program.
623              
624             1;
625             __END__