File Coverage

lib/Badger/Debug.pm

Criterion	Covered	Total	%
statement	125	174	71.8
branch	43	74	58.1
condition	15	32	46.8
subroutine	24	33	72.7
pod	17	17	100.0
total	224	330	67.8

#========================================================================
#
# Badger::Debug
#
# DESCRIPTION
#   Mixin module implementing functionality for debugging.
#
# AUTHOR
#   Andy Wardley
#
#========================================================================

package Badger::Debug;

use Carp;
use Badger::Rainbow
    ANSI => 'bold red yellow green cyan white';
use Scalar::Util qw( blessed refaddr );
use Badger::Class
    base      => 'Badger::Exporter',
    version   => 0.01,
    constants => 'PKG REFS SCALAR ARRAY HASH CODE REGEX DELIMITER',
    words     => 'DEBUG',
    import    => 'class',
    constant  => {
        UNDEF => '',
    },
    exports   => {
        tags  => {
            debug => 'debugging debug debugf debug_up debug_at debug_caller
                      debug_callers debug_args',
            dump  => 'dump dump_data dump_data_inline
                      dump_ref dump_hash dump_list dump_text'
        },
        hooks => {
            color    => \&enable_colour,
            colour   => \&enable_colour,
            dumps    => [\&_export_debug_dumps,    1],  # expects 1 arguments
            default  => [\&_export_debug_default,  1],
            modules  => [\&_export_debug_modules,  1],
            'DEBUG'  => [\&_export_debug_constant, 1],
            '$DEBUG' => [\&_export_debug_variable, 1],
        },
    };

our $PAD         = '    ';
our $MAX_TEXT    = 48;
our $MAX_DEPTH   = 3;     # prevent runaways in debug/dump
our $FORMAT      = "[ line ]\n"
    unless defined $FORMAT;
our $PROMPT      = '> '
    unless defined $PROMPT;
our $MESSAGE     = "$PROMPT%s";
our $HIDE_UNDER  = 1;
our $CALLER_UP   = 0;      # hackola to allow debug() to use a different caller
our $CALLER_AT   = { };    # ditto
our $DUMPING     = { };
our $DEBUG       = 0 unless defined $DEBUG;
our $DUMP_METHOD = 'dump';

#-----------------------------------------------------------------------
# export hooks
#-----------------------------------------------------------------------

sub _export_debug_dumps {
    my ($self, $target, $symbol, $value, $symbols) = @_;
    $self->export_symbol($target, dumper => sub {
        $_[0]->dump_hash($_[0],$_[1],$value);
    });
    unshift(@$symbols, ':dump');
    return $self;
}


sub _export_debug_default {
    my ($self, $target, $symbol, $value, $symbols) = @_;
    unshift(
        @$symbols,
        '$DEBUG' => $value,
        'DEBUG' => $value,
        'debug',
        'debugging'
    );
    return $self;
}


sub _export_debug_variable {
    my ($self, $target, $symbol, $value) = @_;
    no strict REFS;

    # use any existing value in $DEBUG
    $value = ${ $target.PKG.DEBUG }
        if defined ${ $target.PKG.DEBUG };

    $self->debug("$symbol option setting $target \$DEBUG to $value\n") if $DEBUG;
    *{ $target.PKG.DEBUG } = \$value;
}


sub _export_debug_constant {
    my ($self, $target, $symbol, $value) = @_;
    no strict REFS;

    # use any existing value in $DEBUG
    $value = ${ $target.PKG.DEBUG }
        if defined ${ $target.PKG.DEBUG };

    $self->debug("$symbol option setting $target DEBUG to $value\n") if $DEBUG;
    my $temp = $value; # make sure this is a const sub on 5.22
    *{ $target.PKG.DEBUG } = sub () { $temp };
}


sub _export_debug_modules {
    my ($self, $target, $symbol, $modules) = @_;
    $self->debug_modules($modules);
}


#-----------------------------------------------------------------------
# exportable debugging methods
#-----------------------------------------------------------------------

sub debugging {
    my $self = shift;
    my $pkg  = ref $self || $self;
    no strict REFS;

    # return current $DEBUG value when called without args
    return ${ $pkg.PKG.DEBUG } || 0
        unless @_;

    # set new debug value when called with an argument
    my $debug = shift;
    $debug = 0 if $debug =~ /^off$/i;

    # TODO: consider setting different parts of the flag, like TT2,

    $self->debug("debugging() Setting $pkg debug to $debug\n") if $DEBUG;

    if (defined ${ $pkg.PKG.DEBUG }) {
        # update existing variable
        ${ $pkg.PKG.DEBUG } = $debug;
    }
    else {
        # define new variable, poking it into the symbol table using
        # *{...} rather than ${...} so that it's visible at compile time,
        # thus preventing any "Variable $DEBUG not defined errors
        *{ $pkg.PKG.DEBUG } = \$debug;
    }
    return $debug;
}


sub debug {
    my $self   = shift;
    my $msg    = join('', @_),
    my $class  = ref $self || $self;
    my $format = $CALLER_AT->{ format } || $FORMAT;
    my ($pkg, $file, $line) = caller($CALLER_UP);
    my (undef, undef, undef, $sub) = caller($CALLER_UP + 1);
    if (defined $sub) {
        $sub =~ s/.*?([^:]+)$/::$1()/;
    }
    else {
        $sub = '';
    }
    my $where  = ($class eq $pkg)
        ? $class . $sub
        : $pkg   . $sub . " ($class)";

    $msg = join("\n", map { sprintf($MESSAGE, $_) } split("\n", $msg));
#    $msg =~ s/^/$PROMPT/gm;

    # We load this dynamically because it uses Badger::Debug and we don't
    # want to end up in a gruesome birth spiral
    require Badger::Timestamp;
    my $now  = Badger::Timestamp->now;
    my $data = {
        msg   => $msg,
        where => $where,
        class => $class,
        file  => $file,
        line  => $line,
        pkg   => $pkg,
        sub   => $sub,
        date  => $now->date,
        time  => $now->time,
        pid   => $$,
        %$CALLER_AT,
    };
    $format  =~ s/<(\w+)>/defined $data->{ $1 } ? $data->{ $1 } : "<$1 undef>"/eg;
    $format .= "\n" unless $format =~ /\n$/;

    print STDERR $format;
}


sub debugf {
    local $CALLER_UP = 1;
    shift->debug( sprintf(shift, @_) );
}


sub debug_up {
    my $self = shift;
    local $CALLER_UP = shift;
    $self->debug(@_);
}


sub debug_at {
    my $self = shift;
    local $CALLER_AT = shift;
    local $CALLER_UP = 1;
    $self->debug(@_);
}


sub debug_caller {
    my $self = shift;
    my ($pkg, $file, $line, $sub) = caller(1);
    my $msg = "$sub called from ";
    ($pkg, undef, undef, $sub) = caller(2);
    $msg .= "$sub in $file at line $line\n";
    $self->debug($msg);
}


sub debug_callers {
    my $self = shift;
    my $msg  = '';
    my $i    = 1;

    while (1) {
        my @info = caller($i);
        last unless @info;
        my ($pkg, $file, $line, $sub) = @info;
        $msg .= sprintf(
            "%4s: Called from %s in %s at line %s\n",
            '#' . $i++, $sub, $file, $line
        );
    }
    $self->debug($msg);
}


sub debug_args {
    my $self = shift;
    $self->debug_up(
        2, "args: ",
        join(', ', map { $self->dump_data_inline($_) } @_),
        "\n"
    );
}


sub debug_modules {
    my $self    = shift;
    my $modules = @_ == 1 ? shift : [ @_ ];
    my $debug   = 1;

    $modules = [ split(DELIMITER, $modules) ]
        unless ref $modules eq ARRAY;

    # TODO: handle other refs?

    foreach my $pkg (@$modules) {
        no strict REFS;
        *{ $pkg.PKG.DEBUG } = \$debug;
    }
}


#-----------------------------------------------------------------------
# data dumping methods
#-----------------------------------------------------------------------

sub dump {
    my $self = shift;
    my $code = $self->can('dumper');
    return $code
         ? $code->($self, @_)
         : $self->dump_ref($self, @_);
}


sub dump_data {
    local $DUMPING = { };
    _dump_data(@_);
}


sub _dump_data {
    if (! defined $_[1]) {
        return UNDEF;
    }
    elsif (! ref $_[1]) {
        return $_[1];
    }
    elsif (blessed($_[1]) && (my $code = $_[1]->can($DUMP_METHOD))) {
        shift;  # remove $self object, leave target object first
        return $code->(@_);
    }
    else {
        goto &dump_ref;
    }
}


sub dump_ref {
    my ($self, $data, $indent) = @_;
    return "<$data>" if $DUMPING->{ $data }++;

    # TODO: change these to reftype
    if (UNIVERSAL::isa($data, HASH)) {
        return dump_hash($self, $data, $indent);
    }
    elsif (UNIVERSAL::isa($data, ARRAY)) {
        return dump_list($self, $data, $indent);
    }
    elsif (UNIVERSAL::isa($data, REGEX)) {
        return dump_text($self, $data);
    }
    elsif (UNIVERSAL::isa($data, SCALAR)) {
        return dump_text($self, $$data);
    }
    else {
        return $data;
    }
}


sub dump_data_inline {
    local $PAD = '';
    my $text = shift->dump_data(@_);
    $text =~ s/\n/ /g;
    return $text;
}


sub dump_hash {
    my ($self, $hash, $indent, $keys) = @_;
    $indent ||= 0;
    return "..." if $indent > $MAX_DEPTH;
    my $pad = $PAD x $indent;

    return '{ }' unless $hash && %$hash;

    if ($keys) {
        $keys = [ split(DELIMITER, $keys) ]
            unless ref $keys;
        $keys = { map { $_ => 1 } @$keys }
            if ref $keys eq ARRAY;
        return $self->error("Invalid keys passed to dump_hash(): $keys")
            unless ref $keys eq HASH;

        $self->debug("constructed hash keys: ", join(', ', %$keys)) if $DEBUG;
    }

    return "\{\n"
        . join( ",\n",
                map { "$pad$PAD$_ => " . _dump_data($self, $hash->{$_}, $indent + 1) }
                sort
                grep { $keys ? $keys->{ $_ } : 1 }
                grep { (/^_/ && $HIDE_UNDER) ? 0 : 1 }
                keys %$hash
           )
        . "\n$pad}";
}


sub dump_list {
    my ($self, $list, $indent) = @_;
    $indent ||= 0;
    my $pad = $PAD x $indent;

    return '[ ]' unless @$list;
    return "\[\n$pad$PAD"
        . ( @$list
            ? join(",\n$pad$PAD", map { _dump_data($self, $_, $indent + 1) } @$list)
            : '' )
        . "\n$pad]";
}


sub dump_text {
    my ($self, $text, $length) = @_;
    $text = $$text if ref $text;
    $length ||= $MAX_TEXT;
    my $snippet = substr($text, 0, $length);
    $snippet .= '...' if length $text > $length;
    $snippet =~ s/\n/\\n/g;
    return $snippet;
}



#-----------------------------------------------------------------------
# enable_colour()
#
# Export hook which gets called when the Badger::Debug module is
# used with the 'colour' or 'color' option.  It redefines the formats
# for $Badger::Base::DEBUG_FORMAT and $Badger::Exception::FORMAT
# to display in glorious ANSI technicolor.
#-----------------------------------------------------------------------

sub enable_colour {
    my ($class, $target, $symbol) = @_;
    $target ||= (caller())[0];
    $symbol ||= 'colour';

    print bold green "Enabling debug in $symbol from $target\n";

    # colour the debug format
    $MESSAGE = cyan($PROMPT) . yellow('%s');
    $FORMAT
         = cyan('[ line ]')
         . "\n";

    # exceptions are in red
    $Badger::Exception::FORMAT
        = bold red $Badger::Exception::FORMAT;

    $Badger::Exception::MESSAGES->{ caller }
        = yellow('<4>')   . cyan(' called from ')
        . yellow("<1>\n") . cyan('  in ')
        . white('<2>')   . cyan(' at line ')
        . white('<3>');
}



1;

__END__