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

package Lire::Test::FunctionalTestCase;

use strict;

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

use Carp;
use File::Path qw/ mkpath rmtree /;
use File::Copy;
use File::Basename;
use File::Path qw/rmtree/;
use IO::Dir;

use Lire::Config;
use Lire::PluginManager;
use Lire::Config::SpecParser;
use Lire::Config::Value;
use Lire::Config::Build qw/ ac_info ac_path /;
use Lire::Test::CommandResult;
use Lire::Utils qw/ tempdir create_file file_content check_param /;

=pod

=head1 NAME

Lire::Test::FunctionalTestCase - Base class for writing functional unit tests

=head1 SYNOPSIS

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

=head1 DESCRIPTION

This is a Test::Unit::TestCase subclass which can be used to make it
easier to write functional tests.

=head2 WHAT ARE FUNCTIONAL TESTS

Unlike unit tests that test the semantics of the API and document the
internals assumptions, functional tests are tests that tests the
'functionality' of the overall software. They kind of document the
expected functionality of the software.

=head2 Lire::Test::FunctionalTestCase

In Lire, the "expected functionality" is exercised by running
commands, so this module provides convenient methods to run Lire
commands and tests their expected output.

It also setup a mock sendmail which can be used to analyze the email
that the Lire system should send.

Some of Lire functionality cannot be tested anymore simply by running
command (for example the Curses::UI based user interface cannot be
tested that way but throught the use of Lire::Test::CursesUIDriver).
For these kind of tests, this base class will set up a new
Lire::Config and Lire::PluginManager instance in the set_up
method. Tests that requires these functionality can simply call
Lire::Config->init() and
Lire::PluginManager->instance()->register_default_converters()
without fear of messing the test environement.

=cut

sub new {
    my $self = shift->SUPER::new( @_ );

    $self->{'_test_files'} = [];
    $self->{'_locale'} = 'C';
    $self->_check_lire_installation();
    $self->_load_config_spec();

    return $self;
}

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

    $self->{'_config_files'} = {};
    $self->{'_rundir'} = tempdir( "FunctionalTest_XXXXXX" );
    $self->{'_homedir'} = $self->{'_rundir'} . "/home";
    mkdir $self->{'_homedir'}
      or croak "failed to create $self->{'_homedir'}";

    $self->_create_lire_home_directories();
    $self->_set_up_fake_sendmail();
    $self->_set_up_lire_globals();
    $self->{'_stdout_file'} = $self->{'_rundir'} . "/stdout.log";
    $self->{'_stderr_file'} = $self->{'_rundir'} . "/stderr.log";

    unshift @INC, ac_info( 'LR_PERL5LIB' );

    return;
}

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

    foreach my $f ( @{$self->{'_test_files'}}) {
        unlink $f
          or croak "failed to delete $f";
    }
    rmtree( $self->{'_rundir'} );

    $self->_tear_down_lire_globals();

    shift @INC if $INC[0] eq ac_info( 'LR_PERL5LIB' );

    return;
}

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

    my $lr_xml2report = ac_info( 'bindir' ) . "/lr_xml2report";
    my $defaults = ac_path( 'sysconfdir', 'PACKAGE' ) . "/defaults";
    my $sysconfdir = ac_path( 'sysconfdir', 'PACKAGE' );
    my $datadir = ac_path( 'datadir', 'PACKAGE' );

    croak "$lr_xml2report isn't an executable. Was Lire installed?"
      unless -f $lr_xml2report && -x $lr_xml2report;

    croak "$defaults isn't present. Was Lire installed?"
      unless -f $defaults && -r $defaults;

    croak "you need write access to Lire's sysconfdir ($sysconfdir) to use FunctionalTestCase"
      unless -w $sysconfdir;

    croak "you need write access to Lire's datadir ($datadir) to use FunctionalTestCase"
      unless -w $datadir;
}


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

    mkpath( [ $self->{'_homedir'} . "/.lire",
              $self->{'_homedir'} . "/.lire/config",
              $self->{'_homedir'} . "/.lire/converters",
              $self->{'_homedir'} . "/.lire/plugins",
              $self->{'_homedir'} . "/.lire/schemas",
              $self->{'_homedir'} . "/.lire/filters",
              $self->{'_homedir'} . "/.lire/reports",
            ], 0, 0755 ) == 7
      or croak "mkpath() failed";

    return;
}

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

    $self->{'_old_homedir'} = $ENV{'HOME'};
    $self->{'_old_config'} = $Lire::Config::SINGLETON;
    $self->{'_old_mgr'} = $Lire::PluginManager::instance;
    $ENV{'HOME'} = $self->{'_homedir'};
    $Lire::Config::SINGLETON = new Lire::Config::XMLFilesConfig();
    $Lire::PluginManager::instance = new Lire::PluginManager();

    return;
}

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

    $ENV{'HOME'} = $self->{'_old_homedir'};
    $Lire::Config::SINGLETON = $self->{'_old_config'};
    $Lire::PluginManager::instance = $self->{'_old_mgr'};

    return;
}

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

    my $parser = new Lire::Config::SpecParser();
    $parser->merge_specifications_dir( ac_path( 'datadir', 'PACKAGE') . "/config-spec" );
    $self->{'_spec'} = $parser->configspec();

    return;
}

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

    my $cfg = $self->create_test_cfg_file( "func_test_sendmail" );
    $cfg->global->get( "sendmail_path" )->set( $self->{'_sendmail_path'} );
    $cfg->save();

    return;
}

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

    $self->{'_maildir'} = "$self->{'_rundir'}/.func_test_mail";
    mkdir $self->{'_maildir'}, 0770
      or croak "mkdir $self->{'_maildir'} failed: $!";
    $self->{'_sendmail_path'} = "$self->{'_rundir'}/func_test_sendmail";

    open my $fh, "> $self->{'_sendmail_path'}"
      or croak "open $self->{'_sendmail_path'} failed: $!";

    my $script = <<'EOF';
#! PERL -w

use strict;

use File::Copy;

use Carp;

my $file;
my $idx = 0;
while (1) {
    $file =  sprintf( 'MAILDIR/%02x', $idx);
    last unless -f "$file.recipients";
    $idx++;
}

open RECIPIENTS, "> $file.recipients"
  or croak "open $file.recipients failed: $!\n";
print RECIPIENTS join( "\n", @ARGV ), "\n";
close RECIPIENTS;
copy( \*STDIN, $file . ".message" );
exit 0
EOF
    my $perl = ac_info( 'PERL' );
    $script =~ s/PERL/$perl/;
    $script =~ s/MAILDIR/$self->{'_maildir'}/g;
    print $fh $script;
    close $fh;
    chmod 0775, $self->{'_sendmail_path'}
      or croak "failed to chmod $self->{'_sendmail_path'}: $!\n";
    $self->_set_up_sendmail_config();

    return;
}

=pod

=head2 homedir()

Returns the directory which will be assigned to ENV{'HOME'} when commands
are run. This directory is cleaned up after every test.

=cut

sub homedir {
    return $_[0]{'_homedir'};
}

=pod 

=head2 rundir()

Returns the directory which will be the working directory when the
commands are run. This directory is cleaned up after every test.

=cut

sub rundir {
    return $_[0]{'_rundir'};
}

=pod

=head2 config_spec()

Returns the Lire::Config::TypeSpec object which will be used at runtime by
the functional tests. It can be used to setup configuration files for
the test.

=cut

sub config_spec {
    return $_[0]{'_spec'};
}

=pod

=head2 locale( [new_locale] )

Changes the locale under which the functional test is going to be run. By
default, all tests are run under the 'C' locale ignoring all user's
environment variables.

Returns the previous locale set.

=cut

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

    my $old = $self->{'_locale'};
    $self->{'_locale'} = $locale || 'C';

    return $old;
}
=pod

=head2 lire_run( $shell_cmd )

This method runs the command $shell_cmd through the shell and returns
a Lire::Test::CommandResult object which can be used to run tests on
this command. The Lire environment will be set up before invoking the
shell.

=cut

sub lire_run {
    my ($self, $cmd) = @_;

    check_param( $cmd, 'cmd' );

    rmtree( $self->{'_maildir'} );
    mkdir $self->{'_maildir'}, 0770
      or croak "mkdir $self->{'_maildir'} failed: $!";
    $self->_create_cfg_files();
    my $pid = fork;
    croak "fork failed: $!" unless defined $pid;
    if ( !$pid ) {
        $self->_run_command( $cmd );
    }

    return $self->_make_cmd_result( $cmd, $pid );
}

sub _run_command {
    my ( $self, $cmd ) = @_;

    local $ENV{'HOME'} = $self->homedir();
    local $ENV{'PATH'} = join( ":", ac_info( "bindir"), $ENV{'PATH'} );
    delete $ENV{'LANGUAGE'};
    delete $ENV{'LANG'};
    local $ENV{'LC_ALL'} = $self->{'_locale'};

    chdir $self->{'_rundir'}
      or croak "chdir failed; $!\n";
    open STDOUT, "> $self->{'_stdout_file'}"
      or croak "failed to redirect STDOUT: $!\n";
    open STDERR, "> $self->{'_stderr_file'}"
      or croak "failed to redirect STDERR: $!\n";

    exec( "/bin/sh", "-c", $cmd )
      or croak "exec failed: $!\n";
}

sub _make_cmd_result {
    my ( $self, $cmd, $pid ) = @_;

    waitpid $pid, 0
      or croak "waitpid failed: $!\n";

    my $result = new Lire::Test::CommandResult( '_command' => $cmd,
                                                '_status'  => $?,
                                              );

    $result->{'_stdout'} = file_content( $self->{'_stdout_file'} );
    $result->{'_stderr'} = file_content( $self->{'_stderr_file'} );
    $result->{'_sent_mail'} = $self->sent_mail();

    return $result;
}

=pod

=head2 sent_mail()

Returns in an array reference the message that were sent out during
the test. The element of this array are hash reference containing two
keys:

=over

=item recipients

An array reference containing the recipients as passed on the command
line to sendmail.

=item message

The email which was sent. This is the complete text of the email. This
is what was passed to sendmail via STDIN.

=back

=cut

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

    my $sent_mail = [];
    my $dir = new IO::Dir( $self->{'_maildir'} );
    my @emails = map { /(.*)\.recipients/ } grep { $_ =~ /\.recipients$/ } $dir->read;
    $dir->close;

    foreach my $base ( @emails ) {
        my $mail = { 'recipients' => [],
                     'message' => undef,
                   };
        $mail->{'recipients'} =
          [split ' ', file_content( "$self->{'_maildir'}/$base.recipients" )];
        $mail->{'message'} = file_content( "$self->{'_maildir'}/$base.message" );
        push @$sent_mail, $mail;
    }

    return $sent_mail;
}

=pod

=head2 create_test_file( $filename, [$content] )

Create a file $filename with the content $content. This file will be
removed after the test is run during the tear_down() method. An empty
file will be created if the $content parameter is omitted.

=cut

sub create_test_file {
    my ( $self, $filename, $content ) = @_;

    check_param( $filename, 'filename',
                 sub { ! -f $_[0] },
                 'file already exists' );

    $content = "" unless defined $content;

    create_file( $filename, $content );

    push @{$self->{'_test_files'}}, $filename;

    return;
}


=pod

=head2 install_xml_spec( $spec_type, $superservice, $file )

Install the XML specification in $file of base schema $superservice.
The $spec_type parameter specify where the file will be installed:

=over

=item site_filter

The file will be installed as a filter specification in the system
directory.

=item site_report

The file will be installed as a report specification in the system
directory.

=item site_schema

The file will be installed as a schema specification in the system
directory.

=item filter

The file will be installed as a filter specification in the HOME
directory.

=item report

The file will be installed as a report specification in the HOME
directory.

=item schema

The file will be installed as a schema specification in the HOME
directory.

=back

These files will be removed after the test.

=cut

sub install_xml_spec {
    my ( $self, $spec_type, $superservice, $spec_file ) = @_;

    check_param( $spec_type, 'spec_type',
                 qr/^(site_filter|site_schema|site_report|filter|report||schema)$/,
                 "invalid spec_type parameter" );
    check_param( $superservice, 'superservice' );
    check_param( $spec_file, 'spec_file',
                 sub { -f $_[0] && -r $_[0] },
                 "file doesn't exists" );

    my $tree_root   = $self->_find_tree_root( $spec_type );
    my $spec_dir = $self->_find_spec_dir( $spec_type, $superservice );
    unless (-d "$tree_root/$spec_dir" ) {
        mkdir "$tree_root/$spec_dir", 0775
          or croak "can't create directory $tree_root/$spec_dir";
    }

    my $filename = basename( $spec_file );
    copy( $spec_file, "$tree_root/$spec_dir/$filename" )
      or croak "copy failed: $!";

    push @{$self->{'_test_files'}}, "$tree_root/$spec_dir/$filename";

    return;
}

sub _find_tree_root {
    my ( $self, $spec_type) = @_;

    return $spec_type =~ /^site_/ ? ac_path( "datadir", "PACKAGE" ) : $self->{'_homedir'} . "/.lire";
}

sub _find_spec_dir {
    my ( $self, $spec_type, $superservice ) = @_;

    if ( $spec_type =~ /filter/ ) {
        return "filters/$superservice";
    } elsif ( $spec_type =~ /schema/ ) {
        return "schemas";
    } else {
        return "reports/$superservice";
    }
}

=pod

=head2 create_test_cfg_file( $name )

Returns a Lire::Config::ConfigFile object initialized with the
appropriate config specification. This configuration file will be
created under $HOME/.lire/config/$name.xml when lire_run() will be
used. It can be use to set config option which will be used when the
command is run:

  my $cfg = $self->create_test_cfg_file( "test" );
  $cfg->global->get( "lr_from" )->set( "flacoste\@logreport.org" );

If a configuration file $name was already created, it returns the
associated ConfigFile object.

Note that if you want these configurations variable to have effect
when running test in-process ( not via lire_run() ), you have to call
save() on the object before calling Lire::Config->init(). Otherwise,
you better set the configuration option directly using the
Lire::Config API.

=cut

sub create_test_cfg_file {
    my ($self, $name) = @_;

    check_param( $name, 'name',
                 qr/^[a-zA-Z0-9_-]+$/,
                 "'name' parameter should only contains digits, letters, '-' and '_'" );

    return $self->{'_config_files'}{$name}
      if exists $self->{'_config_files'}{$name};

    my $config_file = $self->homedir . "/.lire/config/$name.xml";

    my $cfg = new Lire::Config::ConfigFile( 'filename' => $config_file,
                                            'spec' => $self->{'_spec'} );
    $cfg->global( $self->{'_spec'}->instance );

    $self->{'_config_files'}{$name} = $cfg;

    return $cfg;
}

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

    foreach my $cfg_file ( values %{$self->{'_config_files'}}) {
        $cfg_file->save();
    }
}

# keep perl happy
1;

__END__

=pod

=head1 SEE ALSO

Test::Unit::TestCase(3pm)

=head1 VERSION

$Id: FunctionalTestCase.pm,v 1.27 2006/07/23 13:16:31 vanbaal Exp $

=head1 AUTHOR

Francis J. Lacoste <flacoste@logreport.org>

=head1 COPYRIGHT

Copyright (C) 2003 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