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