view release on metacpan or  search on metacpan

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

    @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__

=head1 NAME

Apache::TestTrace - Helper output generation functions

=head1 SYNOPSIS

    use Apache::TestTrace;

    debug "foo bar";