lire 2:2.1.1-2.1 / usr / share / perl5 / Lire / Test / TestCase.pm

package Lire::Test::TestCase;

use strict;

use base qw/ Test::Unit::TestCase /;

use POSIX qw/ setlocale LC_MESSAGES tzset /;
use File::Basename qw/ dirname /;
use Cwd 'realpath';
use Test::Unit::Failure;
use Test::Unit::Error;

use Lire::Config;
use Lire::Config::SpecParser;
use Lire::Test::HashConfig;
use Lire::PluginManager;
use Lire::Utils qw/check_param/;

=pod

=head1 NAME

Lire::Test::TestCase - Common base for Lire test cases.

=head1 SYNOPSIS

 use base qw/Lire::Test::TestCase/;

 sub set_up {
     my $self = shift->SUPER::set_up();

     $self->{'cfg'}{'lr_schemas_path'} = [ $self->{'tmpdir'} ];
 }

=head1 DESCRIPTION

This package can be used to write test cases for Lire instead of
inheriting directly from Test::Unit::TestCase.

The default set_up method will create a Lire::Test::HashConfig object
and set it up in the configuration framework. This makes it easy to
set configuration variables to arbitrary values in the set_up()
method.

It also sets the LC_MESSAGES locale category to 'C'.

If you override set_up() and tear_down() be sure to call the SUPER::
implementation.

This subclass also defined a new kind of assertion which make sure
that a snippet of code died with a proper error message.

=head2 assert_died( $test, $regex, [ $msg ] )

Execute $test and fail unless it dies with a message matching $regex.
$test should be a reference to CODE. $regex should be a Regexp ref.

=head2 assert_dies( $regex, $test, [ $msg ] )

Like assert_died() but with a signature closer to the one defined in
Test::Unit::Assert.

=head2 assert_isa( $class, $instance, [ $msg ] )

Fails unless $instance is an instance of $class.

=head1 FIXTURE RELATED METHOD

=head2 lire_default_config_spec()

Returns a Lire::Config::ConfigSpec object initialized from the
default Lire configuration specification.

=head2 set_up_tz( $tz )

When you tests uses timelocal() or localtime(), you should
use that method to specify the TZ under which it should run.

The TZ will be reset to its previous value during tear_down().

=head2 set_up_plugin_mgr()

This will make the global PluginManager an instance that will only
live for the current test. The old PluginManager will be reinstated
during tear_down(). This way, you do not need to track calls to
register_plugin().

=head1 SEE ALSO

Test::Unit::TestCase(3pm)

=head1 VERSION

$Id: TestCase.pm,v 1.17 2006/07/23 13:16:32 vanbaal Exp $

=head1 AUTHORS

Francis J. Lacoste <flacoste@logreport.org>

=head1 COPYRIGHT

Copyright (C) 2003, 2004 Stichting LogReport Foundation LogReport@LogReport.org

This file is part of Lire.

Lire is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program (see COPYING); if not, check with
http://www.gnu.org/copyleft/gpl.html. 

=cut

sub set_up {
    my $self = $_[0];

    $self->{'_saved_cfg'} = $Lire::Config::SINGLETON;
    $self->{'cfg'} = new Lire::Test::HashConfig( {} );
    $Lire::Config::SINGLETON = $self->{'cfg'};

    $self->{'_old_lc_messages'} = setlocale( LC_MESSAGES );
    setlocale( LC_MESSAGES, 'C' );

    return $self;
}

sub tear_down {
    my $self = $_[0];

    $Lire::Config::SINGLETON = $self->{'_saved_cfg'};

    setlocale( LC_MESSAGES, $self->{'_old_lc_messages'} );

    $self->_tear_down_tz();
    $self->_tear_down_plugin_mgr();

    return $self;
}

sub set_up_tz {
    my ( $self, $tz ) = @_;

    check_param( $tz, 'tz' );
    $self->{'_old_tz'} = $ENV{'TZ'}
      unless defined $self->{'_old_tz'};

    $ENV{'TZ'} = $tz;
    tzset();

    return;
}

sub _tear_down_tz {
    my $self = $_[0];

    return unless defined $self->{'_old_tz'};

    $ENV{'TZ'} = $self->{'_old_tz'} || '';
    tzset();
    $self->{'_old_tz'} = undef;

    return;
}

sub set_up_plugin_mgr {
    my $self = $_[0];

    unless ( defined $self->{'_old_plugin_mgr'} ) {
        $self->{'_old_plugin_mgr'} = $Lire::PluginManager::instance;
        $Lire::PluginManager::instance = new Lire::PluginManager();
    }

    return;
}

sub _tear_down_plugin_mgr {
    my $self = $_[0];

    if ( defined $self->{'_old_plugin_mgr'} ) {
        $Lire::PluginManager::instance = $self->{'_old_plugin_mgr'};
        $self->{'_old_plugin_mgr'} = undef;
    }

    return;
}

my $default_spec = undef;
sub lire_default_config_spec {
    my $self = $_[0];

    return $default_spec if defined $default_spec;

    my $dir = realpath( dirname( __FILE__ ) . '/../../config-spec' );
    my $parser = new Lire::Config::SpecParser();
    $parser->merge_specification( $dir . '/lire.xml' );

    return $default_spec = $parser->configspec();
}

sub assert_isa {
    my ( $self, $class, $instance, $msg ) = @_;

    $self->_error( "missing 'class' parameter"  )
      unless defined $class;

    $self->_error( "missing 'instance' parameter"  )
      unless @_ > 2;

    $self->_fail( defined $msg
                  ? $msg
                  : "expected a '$class' instance, got undef" )
      unless defined $instance;

    $self->_fail( defined $msg
                  ? $msg
                  : "expected a '$class' instance, got unblessed '$instance'" )
      unless ref $instance;

    $self->_fail( defined $msg
                  ? $msg
                  : ( "expected a '$class' instance, got a '"
                      . ref( $instance ) . "' instance" ) )
      unless UNIVERSAL::isa( $instance,  $class );

}

sub assert_dies {
    my ( $self, $regex, $test, $msg ) = @_;
    $self->assert_died( $test, $regex, $msg );
}

sub assert_died {
    my ( $self, $test, $regex, $msg ) = @_;

    $self->_error( "missing 'test' parameter" )
      unless defined $test;

    $self->_error( "missing 'regex' parameter" )
      unless defined $regex;

    $self->_error( "'test' parameter should be a CODE reference" )
      unless ref $test eq 'CODE';

    $self->_error( "'regex' parameter should be a Regexp reference" )
      unless ref $regex eq 'Regexp';

    eval {  $test->() };
    $self->_fail( defined $msg ? $msg : "expected test to die" )
      unless $@;

    $self->_fail( defined $msg
                  ? $msg
                  : "expected die message to match $regex, got '$@'" )
      unless $@ =~ /$regex/;
}

sub _caller {
    my $self = $_[0];

    my $level = 2;
    my ( $asserter, $file, $line ) = caller( $level );
    while ( $file eq __FILE__ ) {
        $level++;
        ( $asserter, $file, $line ) = caller( $level );
    }

    return ( $asserter, $file, $line );
}

sub _fail {
    my $self = shift;


    my ( $asserter, $file, $line ) = $self->_caller();
    my $message = join '', @_; 
    Test::Unit::Failure->throw( '-text' => $message,
                                '-object' => $self,
                                '-file' => $file,
                                '-line' => $line );
}

sub _error {
    my $self = shift;

    my( $asserter, $file, $line ) = $self->_caller();
    my $message = join '', @_;
    Test::Unit::Error->throw( '-text' => $message,
                              '-object' => $self,
                              '-file' => $file,
                              '-line' => $line );
}

1;