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