Apache::TestTrace - Helper output generation functions

    use Apache::TestTrace;

    debug "foo bar";

    info_sub "missed it";

    error_mark "something is wrong";

    # test sub that exercises all the tracing functions
    sub test {
        print $Apache::TestTrace::LogFH
              "TraceLevel: $Apache::TestTrace::Level\n";
        $_->($_,[1..3],$_) for qw(emerg alert crit error
                                  warning notice info debug todo);
        print $Apache::TestTrace::LogFH "\n\n"
    };

    # demo the trace subs using default setting
    test();

    {
        # override the default trace level with 'crit'
        local $Apache::TestTrace::Level = 'crit';
        # now only 'crit' and higher levels will do tracing lower level
        test();
    }

    {
        # set the trace level to 'debug'
        local $Apache::TestTrace::Level = 'debug';
        # now only 'debug' and higher levels will do tracing lower level
        test();
    }

    {
        open OUT, ">/tmp/foo" or die $!;
        # override the default Log filehandle
        local $Apache::TestTrace::LogFH = \*OUT;
        # now the traces will go into a new filehandle
        test();
        close OUT;
    }

    # override tracing level via -trace opt
    % t/TEST -trace=debug

    # override tracing level via env var
    % env APACHE_TEST_TRACE_LEVEL=debug t/TEST

 o provide an option to disable the coloring altogether via some flag
   or import()

# Licensed to the Apache Software Foundation (ASF) under one or more
# contributor license agreements.  See the NOTICE file distributed with
# this work for additional information regarding copyright ownership.
# The ASF licenses this file to You under the Apache License, Version 2.0
# (the "License"); you may not use this file except in compliance with
# the License.  You may obtain a copy of the License at
#
#     http://www.apache.org/licenses/LICENSE-2.0
#
# Unless required by applicable law or agreed to in writing, software
# distributed under the License is distributed on an "AS IS" BASIS,
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
# See the License for the specific language governing permissions and
# limitations under the License.
#
package Apache::TestTrace;

use strict;
use warnings FATAL => 'all';

use Exporter ();
use vars qw(@Levels @Utils @Level_subs @Util_subs
            @ISA @EXPORT $VERSION $Level $LogFH);

BEGIN {
    @Levels = qw(emerg alert crit error warning notice info debug);
    @Utils  = qw(todo);
    @Level_subs = map {($_, "${_}_mark", "${_}_sub")} (@Levels);
    @Util_subs  = map {($_, "${_}_mark", "${_}_sub")} (@Utils);
}

@ISA     = qw(Exporter);
@EXPORT  = (@Level_subs);
$VERSION = '0.01';
use subs (@Level_subs, @Util_subs);

# default settings overrideable by users
$Level = undef;
$LogFH = \*STDERR;

# private data
use constant COLOR   => ($ENV{APACHE_TEST_COLOR} && -t STDOUT) ? 1 : 0;
use constant HAS_COLOR  => eval {
    #XXX: another way to color WINFU terms?
    !(grep { $^O eq $_ } qw(MSWin32 cygwin NetWare)) and
    COLOR and require Term::ANSIColor;
};
use constant HAS_DUMPER => eval { require Data::Dumper;    };

# emerg => 1, alert => 2, crit => 3, ...
my %levels; @levels{@Levels} = 1..@Levels;
$levels{todo} = $levels{debug};
my $default_level = 'info'; # to prevent user typos

my %colors = ();

if (HAS_COLOR) {
    %colors = (
        emerg   => 'bold white on_blue',
        alert   => 'bold blue on_yellow',
        crit    => 'reverse',
        error   => 'bold red',
        warning => 'yellow',
        notice  => 'green',
        info    => 'cyan',
        debug   => 'magenta',
        reset   => 'reset',
        todo    => 'underline',
    );

    $Term::ANSIColor::AUTORESET = 1;

    for (keys %colors) {
        $colors{$_} = Term::ANSIColor::color($colors{$_});
    }
}

*expand = HAS_DUMPER ?
    sub { map { ref $_ ? Data::Dumper::Dumper($_) : $_ } @_ } :
    sub { @_ };

sub prefix {
    my $prefix = shift;

    if ($prefix eq 'mark') {
        return join(":", (caller(3))[1..2]) . " : ";
    }
    elsif ($prefix eq 'sub') {
        return (caller(3))[3] . " : ";
    }
    else {
        return '';
    }
}

sub c_trace {
    my ($level, $prefix_type) = (shift, shift);
    my $prefix = prefix($prefix_type);
    print $LogFH
        map { "$colors{$level}$prefix$_$colors{reset}\n"}
        grep defined($_), expand(@_);
}

sub nc_trace {
    my ($level, $prefix_type) = (shift, shift);
    my $prefix = prefix($prefix_type);
    print $LogFH
        map { sprintf "[%7s] %s%s\n", $level, $prefix, $_ }
        grep defined($_), expand(@_);
}

{
    my $trace = HAS_COLOR ? \&c_trace : \&nc_trace;
    my @prefices = ('', 'mark', 'sub');
    # if the level is sufficiently high, enable the tracing for a
    # given level otherwise assign NOP
    for my $level (@Levels, @Utils) {
        no strict 'refs';
        for my $prefix (@prefices) {
            my $func = $prefix ? "${level}_$prefix" : $level;
            *$func = sub { $trace->($level, $prefix, @_)
                               if trace_level() >= $levels{$level};
                     };
        }
    }
}

sub trace_level {
    # overriden by user/-trace
    (defined $Level && $levels{$Level}) ||
    # or overriden by env var
    (exists $ENV{APACHE_TEST_TRACE_LEVEL} &&
        $levels{$ENV{APACHE_TEST_TRACE_LEVEL}}) ||
    # or default
    $levels{$default_level};
}

1;
__END__