File Coverage

blib/lib/Labyrinth/Test/Harness.pm

Criterion	Covered	Total	%
statement	31	33	93.9
branch			n/a
condition			n/a
subroutine	11	11	100.0
pod			n/a
total	42	44	95.4

package Labyrinth::Test::Harness;

use warnings;
use strict;
$|++;

our $VERSION = '1.08';

#----------------------------------------------------------------------------

=head1 NAME

Labyrinth::Test::Harness - Test Harness for Labyrinth Plugin modules

=head1 SYNOPSIS

    my $harness = Labyrinth::Test::Harness->new( %options );

    my $res = $harness->prep('file1.sql','file2.sql');

    $res = $harness->labyrinth(@plugins);

    $res = $harness->action('Base::Admin');

    $harness->refresh( \@plugins );
    $harness->refresh(
        \@plugins,
        { test1 => 1 },
        { test2 => 2 } );

    $harness->cleanup;

    $harness->clear();
    my $vars     = $harness->vars;
    my $params   = $harness->params;
    my $settings = $harness->settings;
    $harness->set_vars( name => 'Test', test => 1 );
    $harness->set_params( name => 'Test', test => 1 );
    $harness->set_settings( name => 'Test', test => 1 );

    my $error = $harness->error;

    my $config    = $harness->config;
    my $directory = $harness->directory;
    $harness->copy_files($source,$target);

=head1 DESCRIPTION

Contains all the harness code around Labyrinth, to enable plugin testing.

=cut

#----------------------------------------------------------------------------
# Libraries

use base qw(Class::Accessor::Fast);

use Config::IniFiles;
use File::Basename;
use File::Copy;
use File::Path;
use IO::File;
use Module::Pluggable   search_path => ['Labyrinth::Plugin'];
use Test::Database;

# Required Core
use Labyrinth;
use Labyrinth::Audit;
use Labyrinth::DTUtils;
use Labyrinth::Globals  qw(:all);
use Labyrinth::Mailer;
use Labyrinth::Plugins;
use Labyrinth::Request;
use Labyrinth::Session;
use Labyrinth::Support;
use Labyrinth::Writer;
use Labyrinth::Variables;

#----------------------------------------------------------------------------
# Default Test Variables

my $CONFIG      = 't/_DBDIR/test-config.ini';
my $DIRECTORY   = 't/_DBDIR';

#----------------------------------------------------------------------------
# Class Methods

sub new {
    my ($class, %hash) = @_;
    my $self = {};
    bless $self, $class;

    $self->keep(        $hash{keep}      || 0           );
    $self->config(      $hash{config}    || $CONFIG     );
    $self->directory(   $hash{directory} || $DIRECTORY  );

    return $self;
}

sub DESTROY {
    my $self = shift;
    $self->cleanup  unless($self->keep);
}

#----------------------------------------------------------------------------
# Object Methods

__PACKAGE__->mk_accessors(qw( config directory keep ));

sub prep {
    my ($self,%hash) = @_;
    $self->{error} = '';

    my $directory = $self->directory;

    # prep test directories
    rmtree($directory);
    mkpath($directory) or ( $self->{error} = "cannot create test directory" && return 0 );

    for my $dir ('html','cgi-bin') {
        next    unless(-d "vhost/$dir");
        unless ($self->copy_files("vhost/$dir","$directory/$dir")) {
            $self->{error} = "cannot create test files: " . $self->{error};
            return 0;
        }
    }

    mkpath("$directory/html/cache") or ( $self->{error} = "cannot create cache directory" && return 0 );

    # copy additional files
    if($hash{files}) {
        for my $source (keys %{$hash{files}}) {
            my $target = "$directory/$hash{files}{$source}";
            unless ($self->copy_file($source,$target)) {
                $self->{error} = "cannot create test files: " . $self->{error};
                return 0;
            }
        }
    }

    # prep database
    my $td1 = Test::Database->handle( 'mysql' );
    unless($td1) {
        use Data::Dumper;
        $self->{error} = "Unable to load a test database instance.";
        return 0;
    }

    create_mysql_databases($td1,$hash{sql});

    my %opts;
    ($opts{dsn}, $opts{dbuser}, $opts{dbpass}) =  $td1->connection_info();
    ($opts{driver})    = $opts{dsn} =~ /dbi:([^;:]+)/;
    ($opts{database})  = $opts{dsn} =~ /database=([^;]+)/;
    ($opts{database})  = $opts{dsn} =~ /dbname=([^;]+)/     unless($opts{database});
    ($opts{dbhost})    = $opts{dsn} =~ /host=([^;]+)/;
    ($opts{dbport})    = $opts{dsn} =~ /port=([^;]+)/;
    my %db_config = map {my $v = $opts{$_}; defined($v) ? ($_ => $v) : () }
                        qw(driver database dbfile dbhost dbport dbuser dbpass);

    # prep config files
    unless( $self->create_config(\%db_config,$hash{config}) ) {
        $self->{error} = "Failed to create config file";
        return 0;
    }

    # prep environment variables

    my %env = (
        SERVER_PROTOCOL => 'http',
        SERVER_PORT     => 80,
        HTTP_HOST       => 'example.com',
        REQUEST_URI     => '/',
        PATH_INFO       => undef
    );

    for my $key (keys %env) {
        $ENV{$key} = $hash{ENV}{$key} || $env{$key};
    }

    return 1;
}

sub cleanup {
    my ($self) = @_;

    my $directory = $self->directory;

    # remove test directories
    rmtree($directory);

    # remove test database
    eval "use Test::Database";
    return  if($@);

    my $td1 = Test::Database->handle( 'mysql' );
    return  unless($td1);

    $td1->{driver}->drop_database($td1->name);
}

sub labyrinth {
    my ($self,@plugins) = @_;
    $self->{error} = '';

    my $config = $self->config;

    eval {
        # configure labyrinth instance
        $self->{labyrinth} = Labyrinth->new;

        Labyrinth::Variables::init();   # initial standard variable values

        UnPublish();                    # Start a fresh slate
        LoadSettings($config);          # Load All Global Settings

        DBConnect();

        load_plugins( @plugins );
    };

    return 1    unless($@);
    $self->{error} = "Failed to load Labyrinth: $@";
    return 0;
}

sub action {
    my ($self,$action) = @_;
    $self->{error} = '';

    eval {
        # run plugin action
        $self->{labyrinth}->action($action);
    };

    return 1    unless($@);
    $self->{error} = "Failed to run action: $action: $@";
    return 0;
}

sub refresh {
    my ($self,$plugins,$vars,$params,$settings) = @_;

    $self->labyrinth(@$plugins);
    $self->set_vars( %$vars )           if($vars);
    $self->set_params( %$params )       if($params);
    $self->set_settings( %$settings )   if($settings);
}

sub login {
    my ($self,$id) = @_;
    return  unless($dbi && $id);
    my @user = $dbi->GetQuery('hash','GetUserByID',$id);
    Labyrinth::Session::InternalLogin($user[0]) if(@user);
}

sub clear {
    my ($self) = @_;
    %tvars      = ();
    %cgiparams  = ();
}

sub vars {
    my ($self) = @_;
    return \%tvars;
}

sub set_vars {
    my ($self,%hash) = @_;
    for my $name (keys %hash) {
        $tvars{$name} = $hash{$name}
    }
}

sub params {
    my ($self) = @_;
    return \%cgiparams;
}

sub set_params {
    my ($self,%hash) = @_;
    for my $name (keys %hash) {
        $cgiparams{$name} = $hash{$name}
    }
}

sub settings {
    my ($self) = @_;
    return \%settings;
}

sub set_settings {
    my ($self,%hash) = @_;
    for my $name (keys %hash) {
        $settings{$name} = $hash{$name}
    }
}

sub error {
    my ($self) = @_;
    return $self->{error};
}

#----------------------------------------------------------------------------
# Internal Functions

sub copy_files {
    my ($self,$source_dir,$target_dir) = @_;

    unless($source_dir) {
        $self->{error} = "no source directory given";
        return 0;
    }
    unless($target_dir) {
        $self->{error} = "no target directory given";
        return 0;
    }
    unless(-f $source_dir || -d $source_dir) {
        $self->{error} = "failed to find source directory/file: $source_dir";
        return 0;
    }

    my @dirs = ($source_dir);
    while(@dirs) {
        my $dir = shift @dirs;

        my @files = glob("$dir/*");

        for my $filename (@files) {
            my $source = $filename;
            if(-f $source) {
                my $target = $filename;
                $target =~ s/^$source_dir/$target_dir/;
                next    if(-f $target);

                mkpath( dirname($target) );
                if(-d dirname($target)) {
                    copy( $source, $target );
                } else {
                    $self->{error} = "failed to created directory: " . dirname($target);
                    return 0;
                }
            } elsif(-d $source) {
                push @dirs, $source;

            } else {
                $self->{error} = "failed to to find source: $source";
                return 0;
            }
        }
    }

    return 1;
}

sub copy_file {
    my ($self,$source,$target) = @_;

    unless($source) {
        $self->{error} = "no source file given";
        return 0;
    }
    unless($target) {
        $self->{error} = "no target file given";
        return 0;
    }
    unless(-f $source) {
        $self->{error} = "failed to find source file: $source";
        return 0;
    }

    my $dir = dirname($target);
    mkpath($dir)    unless(-d $dir);
    if(-d $dir) {
        copy( $source, $target );
    } else {
        $self->{error} = "failed to created directory: $dir";
        return 0;
    }
}

sub create_config {
    my ($self,$db_config,$user_config) = @_;

    my $config      = $self->config;
    my $directory   = $self->directory;

    # main config
    unlink $config if -f $config;

    my %CONFIG = (
        PROJECT => {
            icode           => 'testsite',
            iname           => 'Test Site',
            administrator   => '[e-mail]',
            mailhost        => '',
            cookiename      => 'session',
            timeout         => 3600,
            autoguest       => 1,
            copyright       => '2013-2014 Me',
            lastpagereturn  => 0,
            minpasslen      => 6,
            maxpasslen      => 20,
            evalperl        => 1
        },
        INTERNAL => {
            phrasebook      => "$directory/cgi-bin/config/phrasebook.ini",
            logfile         => "$directory/html/cache/audit.log",
            loglevel        => 4,
            logclear        => 1
        },
        HTTP => {
            webpath         => '',
            cgipath         => '/cgi-bin',
            realm           => 'public',
            basedir         => "$directory",
            webdir          => "$directory/html",
            cgidir          => "$directory/cgi-bin",
            requests        => "$directory/cgi-bin/config/requests"
        },
        CMS => {
            htmltags        => '+img',
            maxpicwidth     => 500,
            randpicwidth    => 400,
            blank           => 'images/blank.png',
            testing         => 0
        }
    );

    if($user_config) {
        for my $section (keys %$user_config) {
            for my $key (keys %{$user_config->{$section}}) {
                $CONFIG{$section}{$key} = $user_config->{$section}{$key};
            }
        }
    }

    # just in case, do this last to avoid being overwritten.
    $CONFIG{DATABASE} = $db_config;

    my $fh = IO::File->new($config,'w+') or return 0;
    for my $section (keys %CONFIG) {
        print $fh "[$section]\n";
        for my $key (keys %{$CONFIG{$section}}) {
            print $fh "$key=$CONFIG{$section}{$key}\n";
        }
        print $fh "\n";
    }

    $fh->close;
    return 1;
}

# this is primitive, but works :)

sub create_mysql_databases {
    my ($db1,$files) = @_;

    return  unless($files && @$files > 0);

    my (@statements);
    my $sql = '';

    for my $file (@$files) {
#print STDERR "# file=$file\n";
        my $fh = IO::File->new($file,'r') or next;
        while(<$fh>) {
            next    if(/^--/);  # ignore comment lines
            s/;\s+--.*/;/;      # remove end of line comments
            s/\s+$//;           # remove trailing spaces
            next    unless($_);

#print STDERR "# line=$_\n";
            $sql .= ' ' . $_;
#print STDERR "# sql=$sql\n";
#exit;
            if($sql =~ /;$/) {
                $sql =~ s/;$//;
                push @statements, $sql;
                $sql = '';
            }
        }
        $fh->close;
    }

#print STDERR "# statements=".join("\n# ",@statements)."\n";
    dosql($db1,\@statements);
}

sub dosql {
    my ($db,$sql) = @_;

    for(@$sql) {
        #print STDERR "#SQL: [$db] $_\n";
        eval { $db->dbh->do($_); };
        if($@) {
            diag $@;
            return 1;
        }
    }

    return 0;
}

1;

__END__