Badger
view release on metacpan or search on metacpan
lib/Badger/Base.pm view on Meta::CPAN
#-----------------------------------------------------------------------
# generate not_implemented() and todo() methods
#-----------------------------------------------------------------------
class->methods(
map {
my $name = $_;
$name => sub {
my $self = shift;
my $ref = ref $self || $self;
my ($pkg, $file, $line, $sub) = caller(0);
$sub = (caller(1))[3]; # subroutine the caller was called from
$sub =~ s/(.*):://;
my $msg = @_ ? join(BLANK, SPACE, @_) : BLANK;
return $self->error_msg( $name => "$sub()$msg", "for $ref in $file at line $line" );
};
}
qw( not_implemented todo )
);
#-----------------------------------------------------------------------
lib/Badger/Class.pm view on Meta::CPAN
# Badger::Class and each of its subclasses have their own metaclass
# table mapping class names to objects.
my $METACLASSES = { };
{
# class/package name - define this up-front so we can use it below
sub CLASS {
# first argument is object or class name, otherwise return caller
@_ ? (ref $_[0] || $_[0])
: (caller())[0];
}
# Sorry if this messes with your head. We want class() and classes()
# methods that create Badger::Class objects. However, we also want
# Badger::Class to be subclassable (e.g. Badger::Factory::Class), where
# class() and classes() return the subclass objects instead of the usual
# Badger::Class. So we have an UBER() class method whose job it is to
# create the class() and classes() methods for the relevant metaclass
sub UBER {
lib/Badger/Class.pm view on Meta::CPAN
# variable each time the closure is called. Ho hum.
my $class;
# The class() subroutine is used to fetch/create a Badger::Class
# object for a package name. The first argument is the class name,
# or the caller's package if undefined and we look it up in $CLASSES.
# If we get a second argument then we're being asked to lookup an
# entry for a subclass of Badger::Class, e.g. Badger::Factory::Class,
# so we first lookup the correct $METACLASS table.
my $class_sub = sub {
$class = @_ ? shift : (caller())[0];
$class = ref $class || $class;
return @_
? $METACLASSES->{ $_[0] }->{ $class } ||= $_[0]->new($class)
: $CLASSES->{ $class } ||= $pkg->new($class);
};
# The classes() method returns a list of Badger::Class objects for
# each class in the inheritance chain, starting with the object
# itself, followed by each base class, their base classes, and so on.
# As with class(), we use a generator to create a closure for the
# subroutine to allow the the class object name to be parameterised.
my $classes_sub = sub {
$class = shift || (caller())[0];
$class_sub->($class)->heritage;
};
no strict REFS;
no warnings 'redefine';
*{ $pkg.PKG.'CLASS' } = \&CLASS;
*{ $pkg.PKG.'class' } = $class_sub;
*{ $pkg.PKG.'bclass' } = $class_sub; # plan B
*{ $pkg.PKG.'classes' } = $classes_sub;
*{ $pkg.PKG.'_autoload' } = \&_autoload;
lib/Badger/Class.pm view on Meta::CPAN
sub all_vars {
my ($self, $name) = @_;
my $pkg = $self->{ name };
my ($value, @values);
no strict REFS;
no warnings ONCE;
# remove any leading '$'
$name =~ s/^\$//;
# _debug("all_vars() caller: ", join(', ', caller()), "\n");
foreach my $pkg ($self->heritage) {
_debug("looking for $name in ", $pkg || "UNDEF", "\n") if DEBUG;
push(@values, $value)
if defined ($value = ${ $pkg.PKG.$name });
_debug("got: $value\n") if DEBUG && $value;
}
return wantarray ? @values : \@values;
lib/Badger/Class.pm view on Meta::CPAN
return \%merged;
}
sub hash_value {
my ($self, $name, $item, $default) = @_;
# remove any leading '$'
$name =~ s/^\$//;
# _debug("hash_value() caller: ", join(', ', caller()), "\n");
foreach my $hash ($self->all_vars($name)) {
next unless ref $hash eq HASH;
return $hash->{ $item }
if defined $hash->{ $item };
}
return $default;
}
lib/Badger/Class/Methods.pm view on Meta::CPAN
my ($name) = ($AUTOLOAD =~ /([^:]+)$/ );
return if $name eq 'DESTROY';
if (my $method = $this->can($name, @args)) {
my $that = class($this);
$class->debug("$class installing $name method in $that") if DEBUG;
$that->method( $name => $method );
return $method->($this, @args);
}
# Hmmm... what if $this isn't a subclass of Badger::Base?
return $this->error_msg( bad_method => $name, ref $this, (caller())[1,2] );
}
);
$class->debug("installed AUTOLOAD and can() in $target") if DEBUG;
}
sub args {
my $class = shift;
my $target = shift;
my $methods = @_ == 1 ? shift : [ @_ ];
lib/Badger/Debug.pm view on Meta::CPAN
}
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)";
lib/Badger/Debug.pm view on Meta::CPAN
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);
}
lib/Badger/Debug.pm view on Meta::CPAN
# 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>";
lib/Badger/Debug.pm view on Meta::CPAN
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, ...)
lib/Badger/Debug.pm view on Meta::CPAN
'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()
lib/Badger/Exception.pm view on Meta::CPAN
sub throw {
my $self = shift;
# save relevant information from caller stack for enhanced debugging,
# but only the first time the exception is thrown
if ($self->{ trace } && ! $self->{ stack }) {
my @stack;
my $i = 1;
while (1) {
my @info = caller($i++);
last unless @info;
push(@stack, \@info);
}
$self->{ stack } = \@stack;
}
die $self;
}
lib/Badger/Exception.pm view on Meta::CPAN
This method throws the exception by calling C<die()> with the exception object
as an argument. If the C<$TRACE> flag is set to a true value then the method
will first save the pertinent details from a stack backtrace into the
exception object before throwing it.
=head2 stack()
If stack tracing is enabled then this method will return a reference to a list
of information from the caller stack at the point at which the exception was
thrown. Each item in the list is a reference to a list containing the
information returned by the inbuilt C<caller()> method. See
C<perldoc -f caller> for further information.
use Badger::Exception trace => 1;
eval {
# some code that throws an exception object
$exception->throw();
};
my $catch = $@; # exception object
lib/Badger/Exporter.pm view on Meta::CPAN
#------------------------------------------------------------------------
# import/export methods:
# import(@imports)
# export($target, @exports)
#------------------------------------------------------------------------
sub import {
my $class = shift;
my $target = (caller())[0];
# enable strict and warnings in the caller - this ensures that every
# Badger module (that calls this method - which is pretty much all of
# them) has strict/warnings enabled, without having to explicitly write
# it. Thx Moose!
strict->import;
warnings->import;
# call in the heavy guns
$class->export($target, @_);
lib/Badger/Mixin.pm view on Meta::CPAN
version => 3.00,
debug => 0,
base => 'Badger::Exporter',
import => 'class',
constants => 'PKG REFS ONCE ARRAY DELIMITER',
words => 'EXPORT_TAGS MIXINS';
sub mixin {
my $self = shift;
my $target = shift || (caller())[0];
my $class = $self->class;
my $mixins = $class->list_vars(MIXINS);
$self->debug("mixinto($target): ", $self->dump_data($mixins), "\n") if $DEBUG;
$self->export($target, $mixins);
}
sub mixins {
my $self = shift;
my $syms = @_ == 1 ? shift : [ @_ ];
my $class = $self->class;
lib/Badger/Test/Manager.pm view on Meta::CPAN
}
}
sub test_msg {
my $self = shift;
print $self->message(@_);
}
sub test_name ($) {
my $self = shift->prototype;
my ($pkg, $file, $line) = caller(2);
$self->message( name => $self->{ count }, $file, $line );
}
sub different {
my ($self, $expect, $result) = @_;
my ($pad_exp, $pad_res) = ($expect, $result);
for ($pad_exp, $pad_res) {
s/\n/\n# |/g;
}
my $msg = $self->message( not_eq => $pad_exp, $pad_res );
lib/Badger/Utils.pm view on Meta::CPAN
sub self_params {
my @args = @_;
local $SIG{__WARN__} = sub {
odd_params(@args);
} if DEBUG;
(shift, @_ && ref $_[0] eq HASH ? shift : { @_ });
}
sub odd_params {
my $method = (caller(2))[3];
$WARN->(
"$method() called with an odd number of arguments: ",
join(', ', map { defined $_ ? $_ : '<undef>' } @_),
"\n"
);
my $i = 3;
while (1) {
my @info = caller($i);
last unless @info;
my ($pkg, $file, $line, $sub) = @info;
$WARN->(
sprintf(
"%4s: Called from %s in %s at line %s\n",
'#' . ($i++ - 2), $sub, $file, $line
)
);
}
}
t/core/lib/My/Mixin/Bar.pm view on Meta::CPAN
#-----------------------------------------------------------------------
# generate not_implemented() and todo() methods
#-----------------------------------------------------------------------
class->methods(
map {
my $name = $_;
$name => sub {
my $self = shift;
my $ref = ref $self || $self;
my ($pkg, $file, $line, $sub) = caller(0);
$sub = (caller(1))[3]; # subroutine the caller was called from
$sub =~ s/(.*):://;
my $msg = @_ ? join(BLANK, SPACE, @_) : BLANK;
return $self->error_msg( $name => "$sub()$msg", "for $ref in $file at line $line" );
};
}
qw( not_implemented todo )
);
1;
( run in 0.456 second using v1.01-cache-2.11-cpan-a9ef4e587e4 )