Commit | Line | Data |
4536f655 |
1 | # File: Stem/Log.pm |
2 | |
3 | # This file is part of Stem. |
4 | # Copyright (C) 1999, 2000, 2001 Stem Systems, Inc. |
5 | |
6 | # Stem is free software; you can redistribute it and/or modify |
7 | # it under the terms of the GNU General Public License as published by |
8 | # the Free Software Foundation; either version 2 of the License, or |
9 | # (at your option) any later version. |
10 | |
11 | # Stem is distributed in the hope that it will be useful, |
12 | # but WITHOUT ANY WARRANTY; without even the implied warranty of |
13 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
14 | # GNU General Public License for more details. |
15 | |
16 | # You should have received a copy of the GNU General Public License |
17 | # along with Stem; if not, write to the Free Software |
18 | # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA |
19 | |
20 | # For a license to use the Stem under conditions other than those |
21 | # described here, to purchase support for this software, or to purchase a |
22 | # commercial warranty contract, please contact Stem Systems at: |
23 | |
24 | # Stem Systems, Inc. 781-643-7504 |
25 | # 79 Everett St. info@stemsystems.com |
26 | # Arlington, MA 02474 |
27 | # USA |
28 | |
29 | use strict ; |
30 | |
31 | use Stem::Log::Entry ; |
32 | use Stem::Log::File ; |
33 | |
34 | my %logs ; |
35 | |
36 | package Stem::Log ; |
37 | |
38 | use Stem::Trace 'log' => 'stem_status', 'sub' => 'TraceStatus' ; |
39 | use Stem::Trace 'log' => 'stem_error' , 'sub' => 'TraceError' ; |
40 | |
41 | |
42 | use Data::Dumper ; |
43 | |
44 | use Stem::Vars ; |
45 | |
46 | Stem::Route::register_class( __PACKAGE__, 'log' ) ; |
47 | |
48 | my $attr_spec = [ |
49 | |
50 | { |
51 | 'name' => 'name', |
52 | 'required' => 1, |
53 | 'help' => <<HELP, |
54 | Name of this logical log. |
55 | HELP |
56 | }, |
57 | { |
58 | 'name' => 'file', |
59 | 'class' => 'Stem::Log::File', |
60 | 'help' => <<HELP, |
61 | The Stem::Log::File object that will create and manage a physical log file. |
62 | HELP |
63 | }, |
64 | { |
65 | 'name' => 'format', |
66 | 'default' => '%T', |
67 | 'help' => <<HELP, |
68 | Format to print entries for this logical log. See elsewhere in this |
69 | document for the details of the sprintf-like format' |
70 | HELP |
71 | }, |
72 | { |
73 | 'name' => 'strftime', |
74 | 'default' => '%C', |
75 | 'help' => <<HELP, |
76 | Format passed to strftime to print the %f entry format. |
77 | HELP |
78 | }, |
79 | { |
80 | 'name' => 'use_gmt', |
81 | 'default' => 1, |
82 | 'type' => 'boolean', |
83 | 'help' => <<HELP, |
84 | Make strftime use gmtime instead of localtime to break the log entry |
85 | timestamp into its parts. |
86 | HELP |
87 | }, |
88 | { |
89 | 'name' => 'filters', |
90 | 'help' => <<HELP, |
91 | List of key/value pairs. The keys are either rules, actions or 'flag'. |
92 | The value is passed to the function for the key. Use a list for complex values. |
93 | HELP |
94 | }, |
95 | |
96 | ] ; |
97 | |
98 | |
99 | sub new { |
100 | |
101 | my( $class ) = shift ; |
102 | |
103 | my $self = Stem::Class::parse_args( $attr_spec, @_ ) ; |
104 | return $self unless ref $self ; |
105 | |
106 | $logs{ $self->{'name'} } = $self ; |
107 | |
108 | return ; |
109 | } |
110 | |
111 | # table to convert filter keys to code refs to execute |
112 | # these are all passed the $entry hash ref, the filter arg and the log object |
113 | |
114 | my %filter_to_code = ( |
115 | |
116 | 'match_text' => sub { $_[0]->{'text'} =~ /$_[1]/ }, |
117 | 'match_label' => sub { $_[0]->{'label'} =~ /$_[1]/ }, |
118 | |
119 | 'eq_level' => sub { $_[0]->{'level'} == $_[1] }, |
120 | 'lt_level' => sub { $_[0]->{'level'} < $_[1] }, |
121 | 'le_level' => sub { $_[0]->{'level'} <= $_[1] }, |
122 | 'gt_level' => sub { $_[0]->{'level'} > $_[1] }, |
123 | 'ge_level' => sub { $_[0]->{'level'} >= $_[1] }, |
124 | |
125 | 'env_eq_level' => sub { $_[0]->{'level'} == ( $Env{ $_[1] } || 0 ) }, |
126 | 'env_lt_level' => sub { $_[0]->{'level'} > ( $Env{ $_[1] } || 0 ) }, |
127 | 'env_le_level' => sub { $_[0]->{'level'} >= ( $Env{ $_[1] } || 0 ) }, |
128 | 'env_gt_level' => sub { $_[0]->{'level'} < ( $Env{ $_[1] } || 0 ) }, |
129 | 'env_ge_level' => sub { $_[0]->{'level'} <= ( $Env{ $_[1] } || 0 ) }, |
130 | |
131 | 'file' => \&_action_file, |
132 | 'stdout' => \&_action_stdout, |
133 | 'stderr' => \&_action_stderr, |
134 | 'dev_tty' => \&_action_dev_tty, |
135 | 'console' => \&_action_console, |
136 | # 'msg' => \&_action_msg, |
137 | 'write' => \&_action_write, |
138 | 'wall' => \&_action_wall, |
139 | 'email' => \&_action_email, |
140 | 'page' => \&_action_page, |
141 | 'forward' => \&_action_forward, |
142 | |
143 | 'custom' => \&_custom_filter, |
144 | ) ; |
145 | |
146 | my %flag_to_code = ( |
147 | |
148 | 'set' => sub { $_[0]->{'flag'} = 1 }, |
149 | 'clear' => sub { $_[0]->{'flag'} = 0 }, |
150 | 'invert' => sub { $_[0]->{'flag'} = ! $_[0]->{'flag'} }, |
151 | 'inverted_test' => sub { $_[0]->{'invert_test'} = 1 }, |
152 | 'normal_test' => sub { $_[0]->{'invert_test'} = 0 }, |
153 | 'or' => sub { $_[0]->{'or'} = 1 }, |
154 | 'and' => sub { $_[0]->{'or'} = 0 }, |
155 | ) ; |
156 | |
157 | sub submit { |
158 | |
159 | my( $self, $entry ) = @_ ; |
160 | |
161 | $entry->{'format'} = $self->{'format'} ; |
162 | $entry->{'strftime'} = $self->{'strftime'} ; |
163 | $entry->{'use_gmt'} = $self->{'use_gmt'} ; |
164 | |
165 | my $filter_list = $self->{'filters'} ; |
166 | |
167 | unless ( $filter_list ) { |
168 | |
169 | # no filter so the default is to log to the file |
170 | |
171 | _action_file( $entry, 0, $self ) ; |
172 | |
173 | return ; |
174 | } |
175 | |
176 | # start with all actions enabled |
177 | |
178 | $entry->{'flag'} = 1 ; |
179 | |
180 | # scan the filter list by pairs |
181 | |
182 | for( my $i = 0 ; $i < @{$filter_list} ; $i += 2 ) { |
183 | |
184 | my ( $filter_key, $filter_arg ) = |
185 | @{$filter_list}[$i, $i + 1] ; |
186 | |
187 | # handle the flag operations first. |
188 | |
189 | if ( $filter_key eq 'flag' ) { |
190 | |
191 | if ( my $code = $flag_to_code{ $filter_arg } ) { |
192 | |
193 | $code->( $entry ) ; |
194 | } |
195 | |
196 | next ; |
197 | } |
198 | |
199 | # skip this filter rule/action if the flag is false |
200 | |
201 | next unless $entry->{'flag'} && ! $entry->{'invert_test'} ; |
202 | |
203 | # check for and remove a 'not_' prefix |
204 | |
205 | my $not = $filter_key =~ s/^not_(\w+)$/$1/ ; |
206 | |
207 | #print "FILT $filter_key $filter_arg\n" ; |
208 | |
209 | my $code = $filter_to_code{ $filter_key } ; |
210 | |
211 | next unless $code ; |
212 | |
213 | # execute the rule/action code |
214 | |
215 | my $flag_val = $code->( $entry, $filter_arg, $self ) ; |
216 | |
217 | # don't mung the flag unless we get a boolean return |
218 | |
219 | next unless defined( $flag_val ) ; |
220 | |
221 | # invert the returned flag value if needed |
222 | |
223 | $flag_val = ! $flag_val if $not ; |
224 | |
225 | # do the right boolean op |
226 | |
227 | if ( $entry->{'or'} ) { |
228 | |
229 | $entry->{'flag'} ||= $flag_val ; |
230 | } |
231 | else { |
232 | |
233 | $entry->{'flag'} &&= $flag_val ; |
234 | } |
235 | } |
236 | } |
237 | |
238 | |
239 | sub _format_entry { |
240 | |
241 | my( $entry ) = @_ ; |
242 | |
243 | my $formatted = $entry->{'format'} ; |
244 | |
245 | $formatted =~ s/%(.)/_format_field( $entry, $1 )/seg ; |
246 | |
247 | return $formatted ; |
248 | } |
249 | |
250 | my %letter_to_key = ( |
251 | |
252 | 'T' => 'text', |
253 | 't' => 'time', |
254 | 'L' => 'label', |
255 | 'l' => 'level', |
256 | 'H' => 'hub_name', |
257 | 'h' => 'host_name', |
258 | 'P' => 'program_name', |
259 | ) ; |
260 | |
261 | sub _format_field { |
262 | |
263 | my( $entry, $letter ) = @_ ; |
264 | |
265 | if ( my $key = $letter_to_key{ $letter } ) { |
266 | |
267 | return $entry->{$key} ; |
268 | } |
269 | |
270 | if ( $letter eq 'f' ) { |
271 | |
272 | require POSIX ; |
273 | |
274 | $entry->{'formatted_time'} ||= do { |
275 | |
276 | my @times = ( $entry->{'use_gmt'} ) ? |
277 | gmtime( $entry->{'time'} ) : |
278 | localtime( $entry->{'time'} ) ; |
279 | |
280 | POSIX::strftime( $entry->{'strftime'}, @times ) ; |
281 | } ; |
282 | |
283 | return $entry->{'formatted_time'} ; |
284 | } |
285 | |
286 | return $letter ; |
287 | } |
288 | |
289 | sub _action_file { |
290 | |
291 | my( $entry, $arg, $log_obj ) = @_ ; |
292 | |
293 | my $file = $log_obj->{'file'} ; |
294 | |
295 | $file or return ; |
296 | |
297 | $entry->{'formatted'} ||= _format_entry( $entry ) ; |
298 | |
299 | $file->write( $entry->{'formatted'} ) ; |
300 | |
301 | return ; |
302 | } |
303 | |
304 | sub _action_stdout { |
305 | |
306 | my( $entry ) = shift ; |
307 | |
308 | $entry->{'formatted'} ||= _format_entry( $entry ) ; |
309 | |
310 | print STDOUT $entry->{'formatted'} ; |
311 | |
312 | return ; |
313 | } |
314 | |
315 | sub _action_stderr { |
316 | |
317 | my( $entry ) = shift ; |
318 | |
319 | $entry->{'formatted'} ||= _format_entry( $entry ) ; |
320 | |
321 | print STDERR $entry->{'formatted'} ; |
322 | |
323 | return ; |
324 | } |
325 | |
326 | sub _action_write { |
327 | |
328 | my( $entry, $arg ) = @_ ; |
329 | |
330 | $entry->{'formatted'} ||= _format_entry( $entry ) ; |
331 | |
332 | my @users = ref $arg ? @{$arg} : $arg ; |
333 | |
334 | foreach my $user ( @users ) { |
335 | |
336 | system <<SYS ; |
337 | /bin/echo '$entry->{'formatted'}' | write $user >/dev/null 2>&1 & |
338 | SYS |
339 | } |
340 | |
341 | return ; |
342 | } |
343 | |
344 | sub _action_wall { |
345 | |
346 | my( $entry ) = shift ; |
347 | |
348 | $entry->{'formatted'} ||= _format_entry( $entry ) ; |
349 | |
350 | |
351 | system <<SYS ; |
352 | /bin/echo '$entry->{'formatted'}' | wall & |
353 | SYS |
354 | |
355 | return ; |
356 | } |
357 | |
358 | # handle to write log entries to /dev/tty |
359 | |
360 | my $tty_fh ; |
361 | |
362 | sub _action_dev_tty { |
363 | |
364 | my( $entry ) = shift ; |
365 | |
366 | $tty_fh ||= IO::File->new( ">/dev/tty" ) ; |
367 | |
368 | unless( $tty_fh ) { |
369 | |
370 | warn "can't open log file /dev/tty $!" ; |
371 | return ; |
372 | } |
373 | |
374 | $entry->{'formatted'} ||= _format_entry( $entry ) ; |
375 | |
376 | print $tty_fh $entry->{'formatted'} ; |
377 | |
378 | return ; |
379 | } |
380 | |
381 | sub _action_console { |
382 | |
383 | my( $entry ) = shift ; |
384 | |
385 | $entry->{'formatted'} ||= _format_entry( $entry ) ; |
386 | |
387 | return unless Stem::Console->can( 'write' ) ; |
388 | |
389 | Stem::Console->write( $entry->{'formatted'} ) ; |
390 | |
391 | return ; |
392 | } |
393 | |
394 | sub _action_forward { |
395 | |
396 | my( $entry, $arg ) = @_ ; |
397 | |
398 | my @logs = ref $arg ? @{$arg} : $arg ; |
399 | |
400 | my $entry_obj = $entry->{'entry_obj'} ; |
401 | |
402 | $entry_obj->submit( @logs ) ; |
403 | |
404 | return ; |
405 | } |
406 | |
407 | sub _action_email { |
408 | |
409 | my( $entry, $arg ) = @_ ; |
410 | |
411 | $entry->{'formatted'} ||= _format_entry( $entry ) ; |
412 | |
413 | my ( $email_addr, $subject ) = ( ref $arg ) ? |
414 | @{$arg} : ( $arg, 'Stem::Log' ) ; |
415 | |
416 | #print "EMAIL $email_addr: $subject\n" ; |
417 | |
418 | require Mail::Send ; |
419 | |
420 | my $mail = Mail::Send->new( |
421 | 'To' => $email_addr, |
422 | 'Subject' => $subject |
423 | ) ; |
424 | |
425 | my $fh = $mail->open(); |
426 | |
427 | $fh->print( $entry->{'formatted'} ) ; |
428 | |
429 | $fh->close; |
430 | |
431 | return ; |
432 | } |
433 | |
434 | sub _custom_filter { |
435 | |
436 | my( $entry, $arg ) = @_ ; |
437 | |
438 | ##### |
439 | # do this |
440 | ##### |
441 | |
442 | return ; |
443 | } |
444 | |
445 | sub find_log { |
446 | |
447 | my ( $log_name ) = @_ ; |
448 | |
449 | return( $logs{ $log_name } ) ; |
450 | } |
451 | |
452 | sub status_cmd { |
453 | |
454 | my $status_text .= sprintf( "%-20s%-40s%10s\n", |
455 | "Logical Log", |
456 | "Physical File", |
457 | "Size" ) ; |
458 | $status_text .= sprintf "-" x 70 . "\n"; |
459 | |
460 | foreach my $log_name ( sort keys %logs ) { |
461 | |
462 | my $ref = $logs{$log_name} ; |
463 | |
464 | $status_text .= sprintf "%-20s%-40s%10s\n", |
465 | $log_name, |
466 | $ref->{'file'}{'path'}, |
467 | $ref->{'file'}{'size'} ; |
468 | } |
469 | |
470 | $status_text .= "\n\n" ; |
471 | |
472 | return $status_text ; |
473 | } |
474 | |
475 | 1 ; |