caller\( results from the CPAN

Badger

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;

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

    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('[<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

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

    print $DEBUG;                # 0

=head2 DEBUG

Used to define a C<DEBUG> constant in your module.  If the C<$DEBUG>
package variable is defined then the C<DEBUG> constant will be set to
whatever value it contains.  Otherwise it will be set to the default
value you provide.

    use Badger::Debug
        'DEBUG' => 0;            # debugging off by default

    print DEBUG;                 # 0

=head2 modules

This option can be used to set the C<$DEBUG> value true in one or more
packages.  This ensures that any debugging will be enabled in those modules.

    use Badger::Debug
        modules => 'My::Module::One My::Module::Two';

    use My::Module::One;        # debugging enabled in both modules
    use My::Module::Two;

Modules that haven't yet been loaded will have both compile time (L<DEBUG>)
and run time (L<$DEBUG>) debugging enabled.  Modules that have already been
loaded will only have run time debugging enabled.

=head2 dumps

This option can be used to construct a specialised L<dump()> method for
your module.  The method is used to display nested data in serialised
text form for debugging purposes.  The default L<dump()> method for an
object will display all items stored within the object.  The C<dumps>
import option can be used to limit the dump to only display the fields
specified.

    package Your::Module;
    use Badger::Debug dumps => 'foo bar baz';
    # ...more code...

    package main;
    my $object = Your::Module->new;
    print $object->dump;            # dumps foo, bar and baz

=head2 colour / color

Either of these (depending on your spelling preference) can be used to
enable colourful (or colorful) debugging.

    use Badger::Debug 'colour';

Debugging messages will then appear in colour (on a terminal supporting
ANSI escape sequences).  See the L<Badger::Test> module for an example
of this in use.

=head2 :debug

Imports all of the L<debug()>, L<debugging()>, L<debug_up()>,
L<debug_caller()>, L<debug_callers> and L<debug_args()> methods.

=head2 :dump

Imports all of the L<dump()>, L<dump_ref()>, L<dump_hash()>, L<dump_list()>,
L<dump_text()>, L<dump_data()> and L<dump_data_inline()> methods.

=head1 DEBUGGING METHODS

=head2 debug($msg1, $msg2, ...)

This method can be used to generate debugging messages.

    $object->debug("Hello ", "World\n");

It prints all argument to STDERR with a prefix indicating the
class name, file name and line number from where the C<debug()> method
was called.

    [Badger::Example line 42] Hello World

At some point in the future this will be extended to allow you to tie in
debug hooks, e.g. to forward to a logging module.

=head2 debugf($format, $arg1, $arg2, ...)

This method provides a C<printf()>-like wrapper around L<debug()>.

    $object->debugf('%s is %s', e => 2.718);    # e is 2.718

=head2 debug_up($n, $msg1, $msg2, ...)

The L<debug()> method generates a message showing the file and line number
from where the method was called. The C<debug_up()> method can be used to
report the error from somewhere higher up the call stack. This is typically
used when you create your own debugging methods, as shown in the following
example.

    sub parse {
        my $self = shift;

        while (my ($foo, $bar) = $self->get_foo_bar) {
            $self->trace($foo, $bar);               # report line here
            # do something
        }
    }

    sub trace {
        my ($self, $foo, $bar) = @_;
        $self->debug_up(2, "foo: $foo  bar: $bar"); # not here
    }

The C<trace()> method calls the L<debug_up()> method telling it to look I<two>
levels up in the caller stack instead of the usual I<one> (thus
C<debug_up(1,...)> has the same effect as C<debug(...)>).  So instead of
reporting the line number in the C<trace()> subroutine (which would be the
case if we called C<debug(...)> or C<debug_up(1,...)>), it will correctly
reporting the line number of the call to C<trace()> in the C<parse()>
method.

=head2 debug_at($info, $message)

This method is a wrapper around L<debug()> that allows you to specify a
different location to be added to the message generated.

    $at->debug_at(
        {
            where => 'At the edge of time',
            line  => 420
        },
        'Flying sideways'
    );

This generates the following debug message:

    [At the edge of time line 420] Flying sideways

Far out, man!

You can change the L<$FORMAT> package variable to define a different message
structure.  As well as the pre-defined placeholders (see the L<$FORMAT>
documentation) you can also define your own custom placeholders like
C<E<lt>serverE<gt>> in the following example.

    $Badger::Debug::FORMAT = '<server>: <msg> at line <line> of <file>';

You must then provide values for the additional placeholder in the C<$info>
hash array when you call the L<debug_at()> method.

    $at->debug_at(
        { server => 'Alpha' },
        'Normality is resumed'
    );

You can also specify a custom format in the C<$info> hash array.

    $at->debug_at(
        { format => '<msg> at line <line> of <file>' },
        'Normality is resumed'
    );

=head2 debug_caller()

Prints debugging information about the current caller.

    sub wibble {
        my $self = shift;
        $self->debug_caller;
    }

=head2 debug_callers()

Prints debugging information about the complete call stack.

    sub wibble {
        my $self = shift;
        $self->debug_callers;
    }

=head2 debug_args()

Prints debugging information about the arguments passed.

    sub wibble {
        my $self = shift;
        $self->debug_args(@_);
    }

=head2 debugging($flag)

This method of convenience can be used to set the C<$DEBUG> variable for
a module.  It can be called as a class or object method.

    Your::Module->debugging(1);     # turn debugging on
    Your::Module->debugging(0);     # turn debugging off

=head2 debug_modules(@modules)

This method can be used to set the C<$DEBUG> true in one or more modules.
Modules can be specified as a list of package names, a reference to a list,
or a whitespace delimited string.

    Badger::Debug->debug_modules('Your::Module::One Your::Module::Two');

The method is also accessible via the L<modules> import option.

=head1 DATA INSPECTION METHODS

These methods of convenience can be used to inspect data structures.
The emphasis is on brevity for the sake of debugging rather than full
blown inspection.  Use L<Data::Dumper> or on of the other fine modules
available from CPAN if you want something more thorough.

The methods below are recursive, so L<dump_list()>, on finding a hash
reference in the list will call L<dump_hash()> and so on.  However, this
recursion is deliberately limited to no more than L<$MAX_DEPTH> levels deep
(3 by default).  Remember, the emphasis here is on being able to see enough
of the data you're dealing with, neatly formatted for debugging purposes,
rather than being overwhelmed with the big picture.

If any of the methods encounter an object then they will call its
L<dump()> method if it has one.  Otherwise they fall back on L<dump_ref()>

( run in 1.566 second using v1.01-cache-2.11-cpan-75ffa21a3d4 )