#============================================================= -*-perl-*-
#
# t/core/debug.t
#
# Test the Badger::Debug module.
#
# Written by Andy Wardley <abw@wardley.org>
#
# This is free software; you can redistribute it and/or modify it
# under the same terms as Perl itself.
#
#========================================================================
use strict;
use warnings;
use lib qw( ./lib ../lib ../../lib t/core/lib );
use Badger::Debug;
use Badger::Base;
use Badger::Test
debug => 'Badger::Debug',
args => \@ARGV,
tests => 35;
#-----------------------------------------------------------------------
# tied object to catch output to STDERR
#-----------------------------------------------------------------------
package Badger::TieString;
sub TIEHANDLE {
my ($class, $textref) = @_;
bless $textref, $class;
}
sub PRINT {
my $self = shift;
$$self = join('', @_);
}
#-----------------------------------------------------------------------
# simple test
#-----------------------------------------------------------------------
package main;
my $dbgmsg;
tie *STDERR, 'Badger::TieString', \$dbgmsg;
$SIG{__DIE__} = sub {
no warnings;
untie *STDERR;
};
my $obj = Badger::Base->new();
$obj->debug("Hello World\n");
like( $dbgmsg, qr/\[main \(Badger::Base\) line \d\d\]\s> Hello World/s, 'Hello World' );
$obj->debug('Hello ', "Badger\n");
like( $dbgmsg, qr/\[main \(Badger::Base\) line \d\d\]\s> Hello Badger/s, 'Hello Badger' );
#-----------------------------------------------------------------------
# subclass
#-----------------------------------------------------------------------
package Badger::Test::Debug1;
use Badger::Debug 'debugging debug debugf';
our $DEBUG = 1;
sub new {
bless { }, shift;
}
sub hello {
my ($self, $name) = @_;
$self->debug("Hello ", $name || 'World') if $DEBUG;
}
package main;
use strict;
use warnings;
pass('here');
$obj = Badger::Test::Debug1->new;
pass('there');
$obj->hello('Ferret');
pass('there');
like( $dbgmsg, qr/\[Badger::Test::Debug1::hello\(\) line \d\d\]\s> Hello Ferret/s, 'Hello Ferret' );
pass('there');
$dbgmsg = '';
$obj->debugf('foo(%s)', 'bar');
like( $dbgmsg, qr/foo\(bar\)/, 'debugf()' );
$dbgmsg = '';
is( $obj->debugging(0), 0, 'turned debugging off' );
is( $obj->debugging, 0, 'debugging is now turned off' );
$obj->hello('Stoat');
is( $dbgmsg, '', 'No stoats allowed' );
#-----------------------------------------------------------------------
# test $DEBUG variable
#-----------------------------------------------------------------------
package Badger::Test::Debug::Variable;
use Badger::Debug 'debugging', '$DEBUG' => 1;
use Badger::Test;
is( $Badger::Test::Debug::Variable::DEBUG, 1, 'set $DEBUG to 1' );
package main;
is( Badger::Test::Debug::Variable->debugging, 1, 'debugging for var is on' );
Badger::Test::Debug::Variable->debugging(0);
is( Badger::Test::Debug::Variable->debugging, 0, 'debugging for var is now off' );
is( $Badger::Test::Debug::Variable::DEBUG, 0, 'set $DEBUG to 0' );
#-----------------------------------------------------------------------
# test DEBUG constant
#-----------------------------------------------------------------------
package Badger::Test::Debug::Constant::One;
use My::Debugger1;
use Badger::Test;
is( My::Debugger1->wibble, 'normal wibble', 'DEBUG is off' );
# pretend we never loaded it so we can play again...
delete $INC{'My/Debugger1.pm'};
package Badger::Test::Debug::Constant::Two;
# setting $DEBUG variable before loading My::Debugger should make DEBUG
# be set true, so will enable debugging code in the module as it is
# compiled.
$My::Debugger1::DEBUG = 1;
require My::Debugger1;
use Badger::Test;
is( My::Debugger1->wibble, 'debugging wibble', 'DEBUG is on' );
#-----------------------------------------------------------------------
# test default option
#-----------------------------------------------------------------------
package Badger::Test::Debug::Mixed1;
use My::Debugger2;
use Badger::Test;
is( My::Debugger2->wibble, 'normal wibble', 'wibble DEBUG is off' );
is( My::Debugger2->wobble, 'normal wobble', 'wobble $DEBUG is off' );
My::Debugger2->debugging(1);
is( My::Debugger2->wibble, 'normal wibble', 'wibble DEBUG is still off' );
is( My::Debugger2->wobble, 'debugging wobble', 'wobble $DEBUG is now on' );
# pretend we never loaded it so we can play again...
delete $INC{'My/Debugger2.pm'};
package Badger::Test::Debug::Mixed2;
# setting $DEBUG variable before loading My::Debugger should make DEBUG
# be set true, so will enable debugging code in the module as it is
# compiled.
$My::Debugger2::DEBUG = 1;
require My::Debugger2;
use Badger::Test;
is( My::Debugger2->wibble, 'debugging wibble', 'wibble DEBUG is on' );
is( My::Debugger2->wobble, 'debugging wobble', 'wobble $DEBUG is on' );
My::Debugger2->debugging(0);
is( My::Debugger2->wibble, 'debugging wibble', 'wibble DEBUG is still on' );
is( My::Debugger2->wobble, 'normal wobble', 'wobble $DEBUG is now off' );
package main;
$dbgmsg = '';
My::Debugger2->hello;
is( $dbgmsg, "[My::Debugger2::hello() line 23]\n> Hello world\n", 'got debug message' );
#-----------------------------------------------------------------------
# test debug load option
#-----------------------------------------------------------------------
package Badger::Test::Debug::Mixed3;
use Badger::Debug
modules => 'My::Debugger3';
use My::Debugger3;
package main;
is( My::Debugger3->debug_static_status, 'on', 'debugger3 static debugging is on' );
is( My::Debugger3->debug_dynamic_status, 'on', 'debugger3 dynamic debugging is on' );
My::Debugger3->debugging(0);
is( My::Debugger3->debug_static_status, 'on', 'debugger3 static debugging is still on' );
is( My::Debugger3->debug_dynamic_status, 'off', 'debugger3 dynamic debugging is now off' );
#-----------------------------------------------------------------------
# changed Badger::Class to delegate debug to Badger::Debug
#-----------------------------------------------------------------------
ok( Badger::Debug->export('foo', '$DEBUG' => 1), 'exported from Badger::Debug' );
#-----------------------------------------------------------------------
# test debug_at();
#-----------------------------------------------------------------------
package Badger::Test::Debug::At;
use Badger::Debug ':debug';
use Badger::Class
base => 'Badger::Base',
debug => 1;
package main;
my $at = Badger::Test::Debug::At->new;
is(
$at->debug_at(
{ where => 'At the edge of time', line => 420 },
'Flying sideways'
),
"[At the edge of time line 420]\n> Flying sideways\n",
'I can fly sideways through time'
);
#-----------------------------------------------------------------------
# change message format
#-----------------------------------------------------------------------
package Badger::Test::Debug::Format;
use Badger::Debug ':debug';
use Badger::Class
base => 'Badger::Base',
debug => 1;
package main;
use Badger::Timestamp 'Now';
my $format = Badger::Test::Debug::Format->new;
{
local $Badger::Debug::FORMAT = '<pkg> <class> <where> <line> <msg>';
local $Badger::Debug::MESSAGE = '%s';
is(
$format->debug_at(
{ where => 'backside', line => 540 },
'method air'
),
"main Badger::Test::Debug::Format backside 540 method air\n",
'backside 540 method air'
);
is(
$format->debug_at(
{ where => 'frontside', format => '<where> <msg>' },
'boardslide'
),
"frontside boardslide\n",
'frontside boardslide'
);
local $Badger::Debug::FORMAT = '<msg> on <date> at <time>';
my $date = Now->date;
like(
$format->debug('beep'),
qr/beep on $date at \d\d/,
'message format with date and time'
);
}