view release on metacpan or  search on metacpan

lib/Apache/TestTrace.pm  view on Meta::CPAN

# 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};