ext/Log-Message/t/02_Log-Message.t

   1 ### Log::Message test suite ###
   2 BEGIN {
   3     if( $ENV{PERL_CORE} ) {
   4         chdir '../lib/Log/Message' if -d '../lib/Log/Message';
   5         unshift @INC, '../../..';
   6     }
   7 }
   8
   9 BEGIN { chdir 't' if -d 't' }
  10
  11
  12 use strict;
  13 use lib qw[../lib to_load];
  14 use Test::More tests => 34;
  15
  16 ### use tests
  17 for my $pkg ( qw[ Log::Message          Log::Message::Config
  18                   Log::Message::Item    Log::Message::Handlers]
  19 ) {
  20     use_ok( $pkg ) or diag "'$pkg' not found. Dying";
  21 }
  22
  23 ### test global stack
  24 {
  25     my $log = Log::Message->new( private => 0 );
  26     is( $log->{STACK}, $Log::Message::STACK, q[Using global stack] );
  27 }
  28
  29 ### test using private stack
  30 {
  31     my $log = Log::Message->new( private => 1 );
  32     isnt( $log->{STACK}, $Log::Message::STACK, q[Using private stack] );
  33
  34     $log->store('foo'); $log->store('bar');
  35
  36     ### retrieval tests
  37     {
  38         my @list = $log->retrieve();
  39
  40         ok( @list == 2, q[Stored 2 messages] );
  41     }
  42
  43     $log->store('zot'); $log->store('quux');
  44
  45     {
  46         my @list = $log->retrieve( amount => 3 );
  47
  48         ok( @list == 3, q[Retrieving 3 messages] );
  49     }
  50
  51     {
  52         is( $log->first->message, 'foo',    q[  Retrieving first message] );
  53         is( $log->final->message, 'quux',   q[  Retrieving final message] );
  54     }
  55
  56     {
  57         package Log::Message::Handlers;
  58
  59         sub test    { return shift }
  60         sub test2   { shift; return @_ }
  61
  62         package main;
  63     }
  64
  65     $log->store(
  66             message     => 'baz',
  67             tag         => 'MY TAG',
  68             level       => 'test',
  69     );
  70
  71     {
  72         ok( $log->retrieve( message => qr/baz/ ),
  73                                         q[  Retrieving based on message] );
  74         ok( $log->retrieve( tag     => qr/TAG/ ),
  75                                         q[  Retrieving based on tag] );
  76         ok( $log->retrieve( level   => qr/test/ ),
  77                                         q[  Retrieving based on level] );
  78     }
  79
  80     my $item = $log->retrieve( chrono => 0 );
  81
  82     {
  83         ok( $item,                      q[Retrieving item] );
  84         is( $item->parent,  $log,       q[  Item reference to parent] );
  85         is( $item->message, 'baz',      q[  Item message stored] );
  86         is( $item->id,      4,          q[  Item id stored] );
  87         is( $item->tag,     'MY TAG',   q[  Item tag stored] );
  88         is( $item->level,   'test',     q[  Item level stored] );
  89     }
  90
  91     {
  92         ### shortmess is very different from 5.6.1 => 5.8, so let's
  93         ### just check that it is filled.
  94         ok(     $item->shortmess,       q[Item shortmess stored] );
  95         like(   $item->shortmess, qr/\w+/,
  96                 q[  Item shortmess stored properly]
  97         );
  98
  99         ok(     $item->longmess,        q[Item longmess stored] );
 100         like(   $item->longmess, qr/Log::Message::store/s,
 101                 q[  Item longmess stored properly]
 102         );
 103
 104         my $t = scalar localtime;
 105         $t =~ /(\w+ \w+ \d+)/;
 106
 107         like(   $item->when, qr/$1/, q[Item timestamp stored] );
 108     }
 109
 110     {
 111         my $i = $item->test;
 112         my @a = $item->test2(1,2,3);
 113
 114         is( $item, $i,              q[Item handler check] );
 115         is_deeply( $item, $i,       q[  Item handler deep check] );
 116         is_deeply( \@a, [1,2,3],    q[  Item extra argument check] );
 117     }
 118
 119     {
 120         ok( $item->remove,          q[Removing item from stack] );
 121         ok( (!grep{ $item eq $_ } $log->retrieve),
 122                                     q[  Item removed from stack] );
 123     }
 124
 125     {
 126         $log->flush;
 127         ok( @{$log->{STACK}} == 0,  q[Flushing stack] );
 128     }
 129 }
 130
 131 ### test errors
 132 {   my $log = Log::Message->new( private => 1 );
 133
 134
 135     ### store errors
 136     {   ### dont make it print
 137         my $warnings;
 138         local $SIG{__WARN__} = sub { $warnings .= "@_" };
 139
 140         my $rv  = $log->store();
 141         ok( !$rv,                       q[Logging empty message failed] );
 142         like( $warnings, qr/message/,   q[  Spotted the error] );
 143     }
 144
 145     ### retrieve errors
 146     {   ### dont make it print
 147         my $warnings;
 148         local $SIG{__WARN__} = sub { $warnings .= "@_" };
 149
 150         ### XXX whitebox test!
 151         local $Params::Check::VERBOSE = 1; # so the warnings are emitted
 152         local $Params::Check::VERBOSE = 1; # so the warnings are emitted
 153
 154         my $rv  = $log->retrieve( frobnitz => $$ );
 155         ok( !$rv,                       q[Retrieval with bogus args] );
 156         like( $warnings, qr/not a valid key/,
 157                                         qq[  Spotted the error] );
 158     }
 159 }
 160
 161
 162
 163
 164
 165
 166
 167
 168
 169
 170
 171
 172
 173
 174
 175
 176