t/aggregate/unit_core_log.t

   1 use strict;
   2 use warnings;
   3
   4 use Test::More tests => 23;
   5
   6 use Catalyst::Log;
   7
   8 local *Catalyst::Log::_send_to_log;
   9
  10 my @MESSAGES;
  11 {
  12     no warnings 'redefine';
  13     *Catalyst::Log::_send_to_log = sub {
  14         my $self = shift;
  15         push @MESSAGES, @_;
  16     };
  17 }
  18
  19 my $LOG = 'Catalyst::Log';
  20
  21 can_ok $LOG, 'new';
  22 ok my $log = $LOG->new, '... and creating a new log object should succeed';
  23 isa_ok $log, $LOG, '... and the object it returns';
  24
  25 can_ok $log, 'is_info';
  26 ok $log->is_info, '... and the default behavior is to allow info messages';
  27
  28 can_ok $log, 'info';
  29 ok $log->info('hello there!'),
  30     '... passing it an info message should succeed';
  31
  32 can_ok $log, "_flush";
  33 $log->_flush;
  34 ok @MESSAGES, '... and flushing the log should succeed';
  35 is scalar @MESSAGES, 1, '... with one log message';
  36 like $MESSAGES[0], qr/^\[info\] hello there!$/,
  37     '... which should match the format we expect';
  38
  39 {
  40
  41     package Catalyst::Log::Subclass;
  42     use base qw/Catalyst::Log/;
  43
  44     sub _send_to_log {
  45         my $self = shift;
  46         push @MESSAGES, '---';
  47         push @MESSAGES, @_;
  48     }
  49 }
  50
  51 my $SUBCLASS = 'Catalyst::Log::Subclass';
  52 can_ok $SUBCLASS, 'new';
  53 ok $log = Catalyst::Log::Subclass->new,
  54     '... and the log subclass constructor shoudl return a new object';
  55 isa_ok $log, $SUBCLASS, '... and the object it returns';
  56 isa_ok $log, $LOG,      '... and it also';
  57
  58 can_ok $log, 'info';
  59 ok $log->info('hi there!'),
  60     '... passing it an info message should succeed';
  61
  62 can_ok $log, "_flush";
  63 @MESSAGES = (); # clear the message log
  64 $log->_flush;
  65 ok @MESSAGES, '... and flushing the log should succeed';
  66 is scalar @MESSAGES, 2, '... with two log messages';
  67 is $MESSAGES[0], '---', '... with the first one being our new data';
  68 like $MESSAGES[1], qr/^\[info\] hi there!$/,
  69     '... which should match the format we expect';
  70