02_log-message.t

source of perl for linux application,

### Log::Message test suite ###
BEGIN { 
    if( $ENV{PERL_CORE} ) {
        chdir '../lib/Log/Message' if -d '../lib/Log/Message';
        unshift @INC, '../../..';
    }
} 

BEGIN { chdir 't' if -d 't' }


use strict;
use lib qw[../lib to_load];
use Test::More tests => 34;

### use tests
for my $pkg ( qw[ Log::Message          Log::Message::Config
                  Log::Message::Item    Log::Message::Handlers]
) {
    use_ok( $pkg ) or diag "'$pkg' not found. Dying";
}    

### test global stack
{
    my $log = Log::Message->new( private => 0 );
    is( $log->{STACK}, $Log::Message::STACK, q[Using global stack] );
}

### test using private stack
{
    my $log = Log::Message->new( private => 1 );
    isnt( $log->{STACK}, $Log::Message::STACK, q[Using private stack] );

    $log->store('foo'); $log->store('bar');

    ### retrieval tests
    {
        my @list = $log->retrieve();

        ok( @list == 2, q[Stored 2 messages] );
    }

    $log->store('zot'); $log->store('quux');

    {
        my @list = $log->retrieve( amount => 3 );

        ok( @list == 3, q[Retrieving 3 messages] );
    }

    {
        is( $log->first->message, 'foo',    q[  Retrieving first message] );
        is( $log->final->message, 'quux',   q[  Retrieving final message] );
    }

    {
        package Log::Message::Handlers;

        sub test    { return shift }
        sub test2   { shift; return @_ }

        package main;
    }

    $log->store(
            message     => 'baz',
            tag         => 'MY TAG',
            level       => 'test',
    );

    {
        ok( $log->retrieve( message => qr/baz/ ),   
                                        q[  Retrieving based on message] );
        ok( $log->retrieve( tag     => qr/TAG/ ),   
                                        q[  Retrieving based on tag] );
        ok( $log->retrieve( level   => qr/test/ ),  
                                        q[  Retrieving based on level] );
    }

    my $item = $log->retrieve( chrono => 0 );

    {
        ok( $item,                      q[Retrieving item] );
        is( $item->parent,  $log,       q[  Item reference to parent] );
        is( $item->message, 'baz',      q[  Item message stored] );
        is( $item->id,      4,          q[  Item id stored] );
        is( $item->tag,     'MY TAG',   q[  Item tag stored] );
        is( $item->level,   'test',     q[  Item level stored] );
    }

    {
        ### shortmess is very different from 5.6.1 => 5.8, so let's
        ### just check that it is filled.
        ok(     $item->shortmess,       q[Item shortmess stored] );
        like(   $item->shortmess, qr/\w+/,
                q[  Item shortmess stored properly]
        );
        
        ok(     $item->longmess,        q[Item longmess stored] );
        like(   $item->longmess, qr/Log::Message::store/s,
                q[  Item longmess stored properly]
        );

        my $t = scalar localtime;
        $t =~ /(\w+ \w+ \d+)/;

        like(   $item->when, qr/$1/, q[Item timestamp stored] );
    }

    {
        my $i = $item->test;
        my @a = $item->test2(1,2,3);

        is( $item, $i,              q[Item handler check] );
        is_deeply( $item, $i,       q[  Item handler deep check] );
        is_deeply( \@a, [1,2,3],    q[  Item extra argument check] );
    }

    {
        ok( $item->remove,          q[Removing item from stack] );
        ok( (!grep{ $item eq $_ } $log->retrieve), 
                                    q[  Item removed from stack] );
    }

    {
        $log->flush;
        ok( @{$log->{STACK}} == 0,  q[Flushing stack] );
    }
}
    
### test errors 
{   my $log = Log::Message->new( private => 1 );

    
    ### store errors
    {   ### dont make it print
        my $warnings;
        local $SIG{__WARN__} = sub { $warnings .= "@_" };
    
        my $rv  = $log->store();
        ok( !$rv,                       q[Logging empty message failed] );
        like( $warnings, qr/message/,   q[  Spotted the error] );
    }
    
    ### retrieve errors
    {   ### dont make it print
        my $warnings;
        local $SIG{__WARN__} = sub { $warnings .= "@_" };
    
        ### XXX whitebox test!
        local $Params::Check::VERBOSE = 1; # so the warnings are emitted
    
        my $rv  = $log->retrieve( frobnitz => $$ );
        ok( !$rv,                       q[Retrieval with bogus args] );
        like( $warnings, qr/not a valid key/,   
                                        qq[  Spotted the error] );
    }
}