File Coverage

blib/lib/Apache/TestTrace.pm
Criterion Covered Total %
statement 47 53 88.7
branch 8 14 57.1
condition 5 14 35.7
subroutine 15 16 93.8
pod 0 4 0.0
total 75 101 74.3


line stmt bran cond sub pod time code
1             # Licensed to the Apache Software Foundation (ASF) under one or more
2             # contributor license agreements. See the NOTICE file distributed with
3             # this work for additional information regarding copyright ownership.
4             # The ASF licenses this file to You under the Apache License, Version 2.0
5             # (the "License"); you may not use this file except in compliance with
6             # the License. You may obtain a copy of the License at
7             #
8             # http://www.apache.org/licenses/LICENSE-2.0
9             #
10             # Unless required by applicable law or agreed to in writing, software
11             # distributed under the License is distributed on an "AS IS" BASIS,
12             # WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
13             # See the License for the specific language governing permissions and
14             # limitations under the License.
15             #
16             package Apache::TestTrace;
17              
18 6     6   118 use strict;
  6         56  
  6         85  
19 6     6   86 use warnings FATAL => 'all';
  6         54  
  6         83  
20              
21 6     6   91 use Exporter ();
  6         52  
  6         58  
22 6         220 use vars qw(@Levels @Utils @Level_subs @Util_subs
23 6     6   83 @ISA @EXPORT $VERSION $Level $LogFH);
  6         57  
24              
25             BEGIN {
26 6     6   104     @Levels = qw(emerg alert crit error warning notice info debug);
27 6         99     @Utils = qw(todo);
28 6         59     @Level_subs = map {($_, "${_}_mark", "${_}_sub")} (@Levels);
  48         630  
29 6         88     @Util_subs = map {($_, "${_}_mark", "${_}_sub")} (@Utils);
  6         89  
30             }
31              
32             @ISA     = qw(Exporter);
33             @EXPORT  = (@Level_subs);
34             $VERSION = '0.01';
35 6     6   4552 use subs (@Level_subs, @Util_subs);
  6         61  
  6         105  
36              
37             # default settings overrideable by users
38             $Level = undef;
39             $LogFH = \*STDERR;
40              
41             # private data
42 6 50 33 6   105 use constant COLOR => ($ENV{APACHE_TEST_COLOR} && -t STDOUT) ? 1 : 0;
  6         121  
  6         253  
43 6         61 use constant HAS_COLOR => eval {
44             #XXX: another way to color WINFU terms?
45 6 50 50     59     !(grep { $^O eq $_ } qw(MSWin32 cygwin NetWare)) and
  18         287  
46                 COLOR and require Term::ANSIColor;
47 6     6   110 };
  6         56  
48 6     6   101 use constant HAS_DUMPER => eval { require Data::Dumper; };
  6         55  
  6         95  
  6         223  
49              
50             # emerg => 1, alert => 2, crit => 3, ...
51             my %levels; @levels{@Levels} = 1..@Levels;
52             $levels{todo} = $levels{debug};
53             my $default_level = 'info'; # to prevent user typos
54              
55             my %colors = ();
56              
57             if (HAS_COLOR) {
58                 %colors = (
59                     emerg => 'bold white on_blue',
60                     alert => 'bold blue on_yellow',
61                     crit => 'reverse',
62                     error => 'bold red',
63                     warning => 'yellow',
64                     notice => 'green',
65                     info => 'cyan',
66                     debug => 'magenta',
67                     reset => 'reset',
68                     todo => 'underline',
69                 );
70              
71                 $Term::ANSIColor::AUTORESET = 1;
72              
73                 for (keys %colors) {
74                     $colors{$_} = Term::ANSIColor::color($colors{$_});
75                 }
76             }
77              
78             *expand = HAS_DUMPER ?
79 6 50   6   107     sub { map { ref $_ ? Data::Dumper::Dumper($_) : $_ } @_ } :
  6         93  
80                 sub { @_ };
81              
82             sub prefix {
83 6     6 0 75     my $prefix = shift;
84              
85 6 50       93     if ($prefix eq 'mark') {
    50          
86 0         0         return join(":", (caller(3))[1..2]) . " : ";
87                 }
88                 elsif ($prefix eq 'sub') {
89 0         0         return (caller(3))[3] . " : ";
90                 }
91                 else {
92 6         74         return '';
93                 }
94             }
95              
96             sub c_trace {
97 0     0 0 0     my ($level, $prefix_type) = (shift, shift);
98 0         0     my $prefix = prefix($prefix_type);
99 0         0     print $LogFH
100 0         0         map { "$colors{$level}$prefix$_$colors{reset}\n"}
101                     grep defined($_), expand(@_);
102             }
103              
104             sub nc_trace {
105 6     6 0 142     my ($level, $prefix_type) = (shift, shift);
106 6         201     my $prefix = prefix($prefix_type);
107 6         8314     print $LogFH
108 6         287         map { sprintf "[%7s] %s%s\n", $level, $prefix, $_ }
109                     grep defined($_), expand(@_);
110             }
111              
112             {
113                 my $trace = HAS_COLOR ? \&c_trace : \&nc_trace;
114                 my @prefices = ('', 'mark', 'sub');
115             # if the level is sufficiently high, enable the tracing for a
116             # given level otherwise assign NOP
117                 for my $level (@Levels, @Utils) {
118 6     6   146         no strict 'refs';
  6         101  
  6         92  
119                     for my $prefix (@prefices) {
120                         my $func = $prefix ? "${level}_$prefix" : $level;
121 204 100   204   3044             *$func = sub { $trace->($level, $prefix, @_)
122                                            if trace_level() >= $levels{$level};
123                                  };
124                     }
125                 }
126             }
127              
128             sub trace_level {
129             # overriden by user/-trace
130 204 50 33 204 0 11900     (defined $Level && $levels{$Level}) ||
      33        
      33        
131             # or overriden by env var
132                 (exists $ENV{APACHE_TEST_TRACE_LEVEL} &&
133                     $levels{$ENV{APACHE_TEST_TRACE_LEVEL}}) ||
134             # or default
135                 $levels{$default_level};
136             }
137              
138             1;
139             __END__
140            
141             =head1 NAME
142            
143             Apache::TestTrace - Helper output generation functions
144            
145             =head1 SYNOPSIS
146            
147             use Apache::TestTrace;
148            
149             debug "foo bar";
150            
151             info_sub "missed it";
152            
153             error_mark "something is wrong";
154            
155             # test sub that exercises all the tracing functions
156             sub test {
157             print $Apache::TestTrace::LogFH
158             "TraceLevel: $Apache::TestTrace::Level\n";
159             $_->($_,[1..3],$_) for qw(emerg alert crit error
160             warning notice info debug todo);
161             print $Apache::TestTrace::LogFH "\n\n"
162             };
163            
164             # demo the trace subs using default setting
165             test();
166            
167             {
168             # override the default trace level with 'crit'
169             local $Apache::TestTrace::Level = 'crit';
170             # now only 'crit' and higher levels will do tracing lower level
171             test();
172             }
173            
174             {
175             # set the trace level to 'debug'
176             local $Apache::TestTrace::Level = 'debug';
177             # now only 'debug' and higher levels will do tracing lower level
178             test();
179             }
180            
181             {
182             open OUT, ">/tmp/foo" or die $!;
183             # override the default Log filehandle
184             local $Apache::TestTrace::LogFH = \*OUT;
185             # now the traces will go into a new filehandle
186             test();
187             close OUT;
188             }
189            
190             # override tracing level via -trace opt
191             % t/TEST -trace=debug
192            
193             # override tracing level via env var
194             % env APACHE_TEST_TRACE_LEVEL=debug t/TEST
195            
196             =head1 DESCRIPTION
197            
198             This module exports a number of functions that make it easier
199             generating various diagnostics messages in your programs in a
200             consistent way and saves some keystrokes as it handles the new lines
201             and sends the messages to STDERR for you.
202            
203             This module provides the same trace methods as syslog(3)'s log
204             levels. Listed from low level to high level: emerg(), alert(), crit(),
205             error(), warning(), notice(), info(), debug(). The only different
206             function is warning(), since warn is already taken by Perl.
207            
208             The module provides another trace function called todo() which is
209             useful for todo items. It has the same level as I<debug> (the
210             highest).
211            
212             There are two more variants of each of these functions. If the
213             I<_mark> suffix is appended (e.g., I<error_mark>) the trace will start
214             with the filename and the line number the function was called from. If
215             the I<_sub> suffix is appended (e.g., I<error_info>) the trace will
216             start with the name of the subroutine the function was called from.
217            
218             If you have C<Term::ANSIColor> installed the diagnostic messages will
219             be colorized, otherwise a special for each function prefix will be
220             used.
221            
222             If C<Data::Dumper> is installed and you pass a reference to a variable
223             to any of these functions, the variable will be dumped with
224             C<Data::Dumper::Dumper()>.
225            
226             Functions whose level is above the level set in
227             C<$Apache::TestTrace::Level> become NOPs. For example if the level is
228             set to I<alert>, only alert() and emerg() functions will generate the
229             output. The default setting of this variable is I<warning>. Other
230             valid values are: I<emerg>, I<alert>, I<crit>, I<error>, I<warning>,
231             I<notice>, I<info>, I<debug>.
232            
233             Another way to affect the trace level is to set
234             C<$ENV{APACHE_TEST_TRACE_LEVEL}>, which takes effect if
235             C<$Apache::TestTrace::Level> is not set. So an explicit setting of
236             C<$Apache::TestTrace::Level> always takes precedence.
237            
238             By default all the output generated by these functions goes to
239             STDERR. You can override the default filehandler by overriding
240             C<$Apache::TestTrace::LogFH> with a new filehandler.
241            
242             When you override this package's global variables, think about
243             localizing your local settings, so it won't affect other modules using
244             this module in the same run.
245            
246             =head1 TODO
247            
248             o provide an option to disable the coloring altogether via some flag
249             or import()
250            
251             =head1 AUTHOR
252            
253             Stas Bekman with contributions from Doug MacEachern
254            
255             =cut
256            
257