view release on metacpan or  search on metacpan

lib/Badger/Debug.pm  view on Meta::CPAN

#========================================================================
#
# Badger::Debug
#
# DESCRIPTION
#   Mixin module implementing functionality for debugging.
#
# AUTHOR
#   Andy Wardley   <abw@wardley.org>
#
#========================================================================

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 => '<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      = "[<where> line <line>]\n<msg>"
    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(

lib/Badger/Debug.pm  view on Meta::CPAN

        $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('[<where> line <line>]')
         . "\n<msg>";

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

=head1 NAME

Badger::Debug - base class mixin module implement debugging methods

=head1 SYNOPSIS

    package Your::Module;

    use Badger::Debug
        default => 0;   # default value for $DEBUG and DEBUG

    sub some_method {
        my $self = shift;

        # DEBUG is a compile-time constant, so very efficient
        $self->debug("First Message") if DEBUG;

        # $DEBUG is a runtime variable, so more flexible
        $self->debug("Second Message") if $DEBUG;
    }

    package main;
    use Your::Module;

    Your::Module->some_method;      # no output, debugging off by default
    Your::Module->debugging(1);     # turns runtime debugging on
    Your::Module->some_method;      # [Your::Module line 13] Second Message

=head1 DESCRIPTION

This mixin module implements a number of methods for debugging. Read L<The
Whole Caboodle> if you just want to get started quickly. Read L<Picky Picky
Picky> if you want to get all picky about what you want to use or want more
information on the individual features.

Note that all of the debugging methods described below work equally well as
both object and class methods even if we don't explicitly show them being
used both ways.

    # class method
    Your::Module->debug('called as a class method');

    # object method
    my $object = Your::Module->new;
    $object->debug('called as an object method');