File Coverage

blib/lib/DeltaX/Trace.pm
Criterion Covered Total %
statement 9 111 8.1
branch 0 54 0.0
condition 0 33 0.0
subroutine 3 11 27.2
pod 7 7 100.0
total 19 216 8.8


line stmt bran cond sub pod time code
1             #-----------------------------------------------------------------
2             package DeltaX::Trace;
3             #-----------------------------------------------------------------
4             # $Id: Trace.pm,v 1.5 2004/10/20 10:04:35 martin Exp $
5             #
6             # (c) DELTA E.S., 2002 - 2003
7             # This package is free software; you can use it under "Artistic License" from
8             # Perl.
9             #-----------------------------------------------------------------
10              
11             $DeltaX::Trace::VERSION = '1.1';
12              
13 3     3   703 use Exporter;
  3         5  
  3         213  
14 3     3   18 use Carp;
  3         5  
  3         213  
15              
16 3     3   17 use vars qw(@ISA @EXPORT @EXPORT_OK %options);
  3         5  
  3         6696  
17             @ISA = qw(Exporter);
18             @EXPORT = qw(trace_set trace);
19             @EXPORT_OK = qw(error warn info debug _tspecial);
20              
21             %$options = (
22             trace_file => '/var/tmp/trace.log',
23             trace_error_file => 1,
24             trace_error_std => 0,
25             trace_warn_file => 1,
26             trace_warn_std => 0,
27             trace_info_file => 1,
28             trace_info_std => 0,
29             trace_debug_file => 1,
30             trace_debug_std => 0,
31             _special => '',
32             trace_pid => 0,
33             trace_stack => 0,
34             );
35              
36             sub trace_set {
37              
38 0 0   0 1   croak ("trace_set() called with odd number of parameters - should be of the form field => value")
39             if (@_ % 2);
40              
41 0           for (my $x = 0; $x <= $#_; $x += 2) {
42 0 0         croak ("Unkown parameter $_[$x] in trace_set()")
43             unless exists $options->{lc($_[$x])};
44 0           $options->{lc($_[$x])} = $_[$x+1];
45             }
46              
47             }
48              
49             sub trace {
50              
51 0     0 1   my $mtype = uc(shift);
52              
53 0           my $pos = 0;
54 0           my (undef, $mfile, $mline) = caller($pos);
55 0           my (undef, undef, undef, $msub) = caller($pos+1);
56 0           my ($l_mfile, $l_mline, $l_msub) = ($mfile, $mline, $msub);
57 0 0         $msub = 'main' if ! $msub;
58 0           while ($l_msub =~ /^DeltaX::Trace/) {
59 0           $pos++;
60 0           ($l_mfile, $l_mline, $l_msub) = ($mfile, $mline, $msub);
61 0           (undef, $mfile, $mline) = caller($pos);
62 0           (undef, undef, undef, $msub) = caller($pos+1);
63 0 0         $msub = 'main' if ! $msub;
64             }
65 0 0         if ($l_msub eq 'main') {
66 0           ($mfile,$mline,$msub) = ($l_mfile,$l_mline,$l_msub);
67 0           $l_msub = '';
68             }
69              
70 0 0         if ($options->{_special}) {
71 0           $mfile = $options->{_special};
72 0           $msub = '';
73             }
74 0 0         if ($options->{trace_pid}) {
75 0           $mfile .= " ($$)";
76 0           $l_mfile .= " ($$)";
77             }
78              
79 0           my $to_file = 0;
80 0           my $to_std = 0;
81 0           my $title = '';
82 0           for ($mtype) {
83 0 0         /^E/ && do {
84 0           $to_file = $options->{trace_error_file};
85 0           $to_std = $options->{trace_error_std};
86 0           $title = 'ERROR';
87 0           last;
88             };
89 0 0         /^W/ && do {
90 0           $to_file = $options->{trace_warn_file};
91 0           $to_std = $options->{trace_warn_std};
92 0           $title = 'WARN';
93 0           last;
94             };
95 0 0         /^I/ && do {
96 0           $to_file = $options->{trace_info_file};
97 0           $to_std = $options->{trace_info_std};
98 0           $title = 'INFO';
99 0           last;
100             };
101 0 0         /^D/ && do {
102 0           $to_file = $options->{trace_debug_file};
103 0           $to_std = $options->{trace_debug_std};
104 0           $title = 'DEBUG';
105 0           last;
106             };
107             }
108            
109 0           my $msg = '';
110 0           while (@_) { $msg = $msg . ' ' . shift; }
  0            
111 0           my $called = '';
112 0 0 0       if ($l_msub and ($msub ne $l_msub)) {
113 0           $msg = "$title at $l_msub ($l_mfile) [$l_mline]: $msg (... called from $msub [$mline])";
114             }
115             else {
116 0           $msg = "$title at $msub ($mfile) [$mline]: $msg";
117             }
118              
119             # get the stack for error
120 0 0         my @stack = get_stack() if $options->{trace_stack};
121              
122             # stderr output
123 0 0         if ($to_std) { print STDERR "$msg\n"; }
  0            
124 0 0         if ($to_file) {
125 0 0         if (open OUT, ">>".$options->{trace_file} ) {
126 0           print OUT scalar localtime, " $msg\n";
127 0 0 0       if ($options->{trace_stack} && $mtype eq 'E' ||
      0        
      0        
      0        
      0        
      0        
      0        
128             $options->{trace_stack} > 1 && $mtype eq 'W' ||
129             $options->{trace_stack} > 2 && $mtype eq 'I' ||
130             $options->{trace_stack} > 3 && $mtype eq 'D') { # print the stack
131 0           print OUT " *".join("\n *", @stack)."\n";
132             }
133 0           close OUT;
134             }
135             }
136             }
137              
138 0     0 1   sub error { trace('E', @_); }
139 0     0 1   sub warn { trace('W', @_); }
140 0     0 1   sub info { trace('I', @_); }
141 0     0 1   sub debug { trace('D', @_); }
142              
143             sub _tspecial {
144 0     0     $options->{_special} = shift;
145             }
146              
147             # get the stack - based on Carp::Heavy
148             sub get_stack {
149 0     0 1   my @stack;
150              
151 0           my ($pack, $file, $line, $sub, $hargs, $eval, $require);
152 0           my (@a);
153 0           my $i = 2;
154             # let's go
155 0           while (do { { package DB; @a = caller($i++) } } ) {
  0            
  0            
156             # local copies
157 0           ($pack, $file, $line, $sub, $hargs, undef, $eval, $require) = @a;
158             # subroutine name
159 0 0         if (defined $eval) {
    0          
160 0 0         if ($require) {
161 0           $sub = "require $eval";
162             }
163             else {
164 0           $eval =~ s/([\\\'])/\\$1/g;
165 0 0 0       if ($MAX_EVAL and length($eval) > $MAX_EVAL) {
166 0           substr($eval, $MAX_EVAL) = '...';
167             }
168 0           $sub = "eval '$eval'";
169             }
170             }
171             elsif ($sub eq '(eval)') {
172 0           $sub = "eval {...}";
173             }
174             # arguments
175 0 0         if ($hargs) {
176             # local copy
177 0           @a = @DB::args;
178             # check the number of arguments
179 0 0 0       if ($MAX_ARGS and @a > $MAX_ARGS) {
180 0           $#a = $MAX_ARGS;
181 0           $a[$#a] = '...';
182             }
183             # get them all
184 0           for (@a) {
185 0 0         $_ = 'undef', next unless defined $_;
186 0 0         if (ref $_) {
187             # force string representation...
188 0           $_ .= '';
189             }
190 0           s/'/\\'/g;
191             # check the length
192 0 0 0       if ($MAX_ARG_LEN and length > $MAX_ARG_LEN) {
193 0           substr($_, $MAX_ARG_LEN) = '...';
194             }
195             # quote (not for numbers)
196 0 0         $_ = "'$_'" unless /^-?[\d.]+$/;
197             }
198 0           $sub .= '(' . join(', ', @a) . ')';
199             }
200              
201 0           push @stack, "$sub at $file:$line";
202             }
203 0           return @stack;
204             }
205              
206             1;
207              
208             =head1 NAME
209              
210             DeltaX::Trace - Perl module for writing log messages
211              
212             _____
213             / \ _____ ______ ______ ___________
214             / \ / \\__ \ / ___// ___// __ \_ __ \
215             / Y \/ __ \_\___ \ \___ \\ ___/| | \/
216             \____|__ (____ /____ >____ >\___ >__|
217             \/ \/ \/ \/ \/ project
218              
219              
220             =head1 SYNOPSIS
221              
222             use DeltaX::Trace; # exports only trace() and trace_set()
223             use DeltaX::Trace qw/error warn info debug/;
224              
225             trace_set(trace_file=>'my_log_file.log');
226              
227             trace('D', "This is", "message");
228             warn("This is warning");
229              
230             =head1 FUNCTIONS
231              
232             =head2 trace_set()
233              
234             Used to set tracing options (parameters are in key => value form):
235              
236             =over
237              
238             =item trace_file
239              
240             File to write trace messages (default is /var/tmp/trace.log).
241              
242             =item trace_error_file
243              
244             If set, error messages will be written to file (default is true).
245              
246             =item trace_error_std
247              
248             If set, error messages will be written to stderr (default is false).
249              
250             =item trace_warn_file
251              
252             If set, warning messages will be written to file (default is true).
253              
254             =item trace_warn_std
255              
256             If set, warning messages will be written to stderr (default is false).
257              
258             =item trace_info_file
259              
260             If set, info messages will be written to file (default is true).
261              
262             =item trace_info_std
263              
264             If set, info messages will be written to stderr (default is false).
265              
266             =item trace_debug_file
267              
268             If set, debug messages will be written to file (default is true).
269              
270             =item trace_debug_std
271              
272             If set, debug messages will be written to stderr (default is false).
273              
274             =item trace_pid
275              
276             Is set, process ID will be attached to every message.
277              
278             =item trace_stack
279              
280             Is set, stack will be printed:
281             1 with ERROR's
282             2 with E and W
283             3 with E, W and I
284             4 with E, W, I and D
285              
286             0 stack won't be printed.
287              
288             =back
289              
290             =head2 trace()
291              
292             This function actually creates and writes a message. First argument is a type of
293             a message (E, W, I, D), other parameters are joined together into one line (with
294             spaces).
295              
296             =head2 error()
297              
298             Works as trace('E', ...).
299              
300             =head2 warn()
301              
302             Works as trace('W', ...).
303              
304             =head2 info()
305              
306             Works as trace('I', ...).
307              
308             =head2 debug()
309              
310             Works as trace('D', ...).
311              
312             =head2 _tspecial()
313              
314             Function for masser.fcgi - this value is printed instead of file name (if set).
315              
316             =head2 get_stack()
317              
318             Returns stack (as an array) - based on Carp::Heavy code.