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


line stmt bran cond sub pod time code
1             package Labyrinth::Test::Harness;
2              
3 7     7   90907 use warnings;
  7         15  
  7         252  
4 7     7   31 use strict;
  7         10  
  7         440  
5             $|++;
6              
7             our $VERSION = '1.09';
8              
9             #----------------------------------------------------------------------------
10              
11             =head1 NAME
12              
13             Labyrinth::Test::Harness - Test Harness for Labyrinth Plugin modules
14              
15             =head1 SYNOPSIS
16              
17             my $harness = Labyrinth::Test::Harness->new( %options );
18              
19             my $res = $harness->prep('file1.sql','file2.sql');
20              
21             $res = $harness->labyrinth(@plugins);
22              
23             $res = $harness->action('Base::Admin');
24              
25             $harness->refresh( \@plugins );
26             $harness->refresh(
27             \@plugins,
28             { test1 => 1 },
29             { test2 => 2 } );
30              
31             $harness->cleanup;
32              
33             $harness->clear();
34             my $vars = $harness->vars;
35             my $params = $harness->params;
36             my $settings = $harness->settings;
37             $harness->set_vars( name => 'Test', test => 1 );
38             $harness->set_params( name => 'Test', test => 1 );
39             $harness->set_settings( name => 'Test', test => 1 );
40              
41             my $error = $harness->error;
42              
43             my $config = $harness->config;
44             my $directory = $harness->directory;
45             $harness->copy_files($source,$target);
46              
47             =head1 DESCRIPTION
48              
49             Contains all the harness code around Labyrinth, to enable plugin testing.
50              
51             =cut
52              
53             #----------------------------------------------------------------------------
54             # Libraries
55              
56 7     7   34 use base qw(Class::Accessor::Fast);
  7         17  
  7         3904  
57              
58 7     7   23643 use Config::IniFiles;
  7         273649  
  7         291  
59 7     7   71 use File::Basename;
  7         11  
  7         518  
60 7     7   4345 use File::Copy;
  7         15171  
  7         462  
61 7     7   46 use File::Path;
  7         11  
  7         359  
62 7     7   3282 use IO::File;
  7         5202  
  7         854  
63 7     7   3418 use Module::Pluggable search_path => ['Labyrinth::Plugin'];
  7         56671  
  7         52  
64 7     7   4655 use Test::Database;
  7         1636445  
  7         280  
65              
66             # Required Core
67 7     7   6702 use Labyrinth;
  0            
  0            
68             use Labyrinth::Audit;
69             use Labyrinth::DTUtils;
70             use Labyrinth::Globals qw(:all);
71             use Labyrinth::Mailer;
72             use Labyrinth::Plugins;
73             use Labyrinth::Request;
74             use Labyrinth::Session;
75             use Labyrinth::Support;
76             use Labyrinth::Writer;
77             use Labyrinth::Variables;
78              
79             #----------------------------------------------------------------------------
80             # Default Test Variables
81              
82             my $CONFIG = 't/_DBDIR/test-config.ini';
83             my $DIRECTORY = 't/_DBDIR';
84              
85             #----------------------------------------------------------------------------
86             # Class Methods
87              
88             sub new {
89             my ($class, %hash) = @_;
90             my $self = {};
91             bless $self, $class;
92              
93             $self->keep( $hash{keep} || 0 );
94             $self->config( $hash{config} || $CONFIG );
95             $self->directory( $hash{directory} || $DIRECTORY );
96              
97             return $self;
98             }
99              
100             sub DESTROY {
101             my $self = shift;
102             $self->cleanup unless($self->keep);
103             }
104              
105             #----------------------------------------------------------------------------
106             # Object Methods
107              
108             __PACKAGE__->mk_accessors(qw( config directory keep ));
109              
110             sub prep {
111             my ($self,%hash) = @_;
112             $self->{error} = '';
113              
114             my $directory = $self->directory;
115              
116             # prep test directories
117             rmtree($directory);
118             mkpath($directory) or ( $self->{error} = "cannot create test directory" && return 0 );
119              
120             for my $dir ('html','cgi-bin') {
121             next unless(-d "vhost/$dir");
122             unless ($self->copy_files("vhost/$dir","$directory/$dir")) {
123             $self->{error} = "cannot create test files: " . $self->{error};
124             return 0;
125             }
126             }
127              
128             mkpath("$directory/html/cache") or ( $self->{error} = "cannot create cache directory" && return 0 );
129              
130             # copy additional files
131             if($hash{files}) {
132             for my $source (keys %{$hash{files}}) {
133             my $target = "$directory/$hash{files}{$source}";
134             unless ($self->copy_file($source,$target)) {
135             $self->{error} = "cannot create test files: " . $self->{error};
136             return 0;
137             }
138             }
139             }
140              
141             # prep database
142             my $td1 = Test::Database->handle( 'mysql' );
143             unless($td1) {
144             use Data::Dumper;
145             $self->{error} = "Unable to load a test database instance.";
146             return 0;
147             }
148              
149             create_mysql_databases($td1,$hash{sql});
150              
151             my %opts;
152             ($opts{dsn}, $opts{dbuser}, $opts{dbpass}) = $td1->connection_info();
153             ($opts{driver}) = $opts{dsn} =~ /dbi:([^;:]+)/;
154             ($opts{database}) = $opts{dsn} =~ /database=([^;]+)/;
155             ($opts{database}) = $opts{dsn} =~ /dbname=([^;]+)/ unless($opts{database});
156             ($opts{dbhost}) = $opts{dsn} =~ /host=([^;]+)/;
157             ($opts{dbport}) = $opts{dsn} =~ /port=([^;]+)/;
158             my %db_config = map {my $v = $opts{$_}; defined($v) ? ($_ => $v) : () }
159             qw(driver database dbfile dbhost dbport dbuser dbpass);
160              
161             # prep config files
162             unless( $self->create_config(\%db_config,$hash{config}) ) {
163             $self->{error} = "Failed to create config file";
164             return 0;
165             }
166              
167             # prep environment variables
168              
169             my %env = (
170             SERVER_PROTOCOL => 'http',
171             SERVER_PORT => 80,
172             HTTP_HOST => 'example.com',
173             REQUEST_URI => '/',
174             PATH_INFO => undef
175             );
176              
177             for my $key (keys %env) {
178             $ENV{$key} = $hash{ENV}{$key} || $env{$key};
179             }
180              
181             return 1;
182             }
183              
184             sub cleanup {
185             my ($self) = @_;
186              
187             my $directory = $self->directory;
188              
189             # remove test directories
190             rmtree($directory);
191              
192             # remove test database
193             eval "use Test::Database";
194             return if($@);
195              
196             my $td1 = Test::Database->handle( 'mysql' );
197             return unless($td1);
198              
199             $td1->{driver}->drop_database($td1->name);
200             }
201              
202             sub labyrinth {
203             my ($self,@plugins) = @_;
204             $self->{error} = '';
205              
206             my $config = $self->config;
207              
208             eval {
209             # configure labyrinth instance
210             $self->{labyrinth} = Labyrinth->new;
211              
212             Labyrinth::Variables::init(); # initial standard variable values
213              
214             UnPublish(); # Start a fresh slate
215             LoadSettings($config); # Load All Global Settings
216              
217             DBConnect();
218              
219             load_plugins( @plugins );
220             };
221              
222             return 1 unless($@);
223             $self->{error} = "Failed to load Labyrinth: $@";
224             return 0;
225             }
226              
227             sub action {
228             my ($self,$action) = @_;
229             $self->{error} = '';
230              
231             eval {
232             # run plugin action
233             $self->{labyrinth}->action($action);
234             };
235              
236             return 1 unless($@);
237             $self->{error} = "Failed to run action: $action: $@";
238             return 0;
239             }
240              
241             sub refresh {
242             my ($self,$plugins,$vars,$params,$settings) = @_;
243              
244             $self->labyrinth(@$plugins);
245             $self->set_vars( %$vars ) if($vars);
246             $self->set_params( %$params ) if($params);
247             $self->set_settings( %$settings ) if($settings);
248             }
249              
250             sub login {
251             my ($self,$id) = @_;
252             return unless($dbi && $id);
253             my @user = $dbi->GetQuery('hash','GetUserByID',$id);
254             Labyrinth::Session::InternalLogin($user[0]) if(@user);
255             }
256              
257             sub clear {
258             my ($self) = @_;
259             %tvars = ();
260             %cgiparams = ();
261             }
262              
263             sub vars {
264             my ($self) = @_;
265             return \%tvars;
266             }
267              
268             sub set_vars {
269             my ($self,%hash) = @_;
270             for my $name (keys %hash) {
271             $tvars{$name} = $hash{$name}
272             }
273             }
274              
275             sub params {
276             my ($self) = @_;
277             return \%cgiparams;
278             }
279              
280             sub set_params {
281             my ($self,%hash) = @_;
282             for my $name (keys %hash) {
283             $cgiparams{$name} = $hash{$name}
284             }
285             }
286              
287             sub settings {
288             my ($self) = @_;
289             return \%settings;
290             }
291              
292             sub set_settings {
293             my ($self,%hash) = @_;
294             for my $name (keys %hash) {
295             $settings{$name} = $hash{$name}
296             }
297             }
298              
299             sub error {
300             my ($self) = @_;
301             return $self->{error};
302             }
303              
304             #----------------------------------------------------------------------------
305             # Internal Functions
306              
307             sub copy_files {
308             my ($self,$source_dir,$target_dir) = @_;
309              
310             unless($source_dir) {
311             $self->{error} = "no source directory given";
312             return 0;
313             }
314             unless($target_dir) {
315             $self->{error} = "no target directory given";
316             return 0;
317             }
318             unless(-f $source_dir || -d $source_dir) {
319             $self->{error} = "failed to find source directory/file: $source_dir";
320             return 0;
321             }
322              
323             my @dirs = ($source_dir);
324             while(@dirs) {
325             my $dir = shift @dirs;
326              
327             my @files = glob("$dir/*");
328              
329             for my $filename (@files) {
330             my $source = $filename;
331             if(-f $source) {
332             my $target = $filename;
333             $target =~ s/^$source_dir/$target_dir/;
334             next if(-f $target);
335              
336             mkpath( dirname($target) );
337             if(-d dirname($target)) {
338             copy( $source, $target );
339             } else {
340             $self->{error} = "failed to created directory: " . dirname($target);
341             return 0;
342             }
343             } elsif(-d $source) {
344             push @dirs, $source;
345              
346             } else {
347             $self->{error} = "failed to to find source: $source";
348             return 0;
349             }
350             }
351             }
352              
353             return 1;
354             }
355              
356             sub copy_file {
357             my ($self,$source,$target) = @_;
358              
359             unless($source) {
360             $self->{error} = "no source file given";
361             return 0;
362             }
363             unless($target) {
364             $self->{error} = "no target file given";
365             return 0;
366             }
367             unless(-f $source) {
368             $self->{error} = "failed to find source file: $source";
369             return 0;
370             }
371              
372             my $dir = dirname($target);
373             mkpath($dir) unless(-d $dir);
374             if(-d $dir) {
375             copy( $source, $target );
376             } else {
377             $self->{error} = "failed to created directory: $dir";
378             return 0;
379             }
380             }
381              
382             sub create_config {
383             my ($self,$db_config,$user_config) = @_;
384              
385             my $config = $self->config;
386             my $directory = $self->directory;
387              
388             # main config
389             unlink $config if -f $config;
390              
391             my %CONFIG = (
392             PROJECT => {
393             icode => 'testsite',
394             iname => 'Test Site',
395             administrator => 'admin@example.com',
396             mailhost => '',
397             cookiename => 'session',
398             timeout => 3600,
399             autoguest => 1,
400             copyright => '2013-2014 Me',
401             lastpagereturn => 0,
402             minpasslen => 6,
403             maxpasslen => 20,
404             evalperl => 1
405             },
406             INTERNAL => {
407             phrasebook => "$directory/cgi-bin/config/phrasebook.ini",
408             logfile => "$directory/html/cache/audit.log",
409             loglevel => 4,
410             logclear => 1
411             },
412             HTTP => {
413             webpath => '',
414             cgipath => '/cgi-bin',
415             realm => 'public',
416             basedir => "$directory",
417             webdir => "$directory/html",
418             cgidir => "$directory/cgi-bin",
419             requests => "$directory/cgi-bin/config/requests"
420             },
421             CMS => {
422             htmltags => '+img',
423             maxpicwidth => 500,
424             randpicwidth => 400,
425             blank => 'images/blank.png',
426             testing => 0
427             }
428             );
429              
430             if($user_config) {
431             for my $section (keys %$user_config) {
432             for my $key (keys %{$user_config->{$section}}) {
433             $CONFIG{$section}{$key} = $user_config->{$section}{$key};
434             }
435             }
436             }
437              
438             # just in case, do this last to avoid being overwritten.
439             $CONFIG{DATABASE} = $db_config;
440              
441             my $fh = IO::File->new($config,'w+') or return 0;
442             for my $section (keys %CONFIG) {
443             print $fh "[$section]\n";
444             for my $key (keys %{$CONFIG{$section}}) {
445             print $fh "$key=$CONFIG{$section}{$key}\n";
446             }
447             print $fh "\n";
448             }
449              
450             $fh->close;
451             return 1;
452             }
453              
454             # this is primitive, but works :)
455              
456             sub create_mysql_databases {
457             my ($db1,$files) = @_;
458              
459             return unless($files && @$files > 0);
460              
461             my (@statements);
462             my $sql = '';
463              
464             for my $file (@$files) {
465             #print STDERR "# file=$file\n";
466             my $fh = IO::File->new($file,'r') or next;
467             while(<$fh>) {
468             next if(/^--/); # ignore comment lines
469             s/;\s+--.*/;/; # remove end of line comments
470             s/\s+$//; # remove trailing spaces
471             next unless($_);
472              
473             #print STDERR "# line=$_\n";
474             $sql .= ' ' . $_;
475             #print STDERR "# sql=$sql\n";
476             #exit;
477             if($sql =~ /;$/) {
478             $sql =~ s/;$//;
479             push @statements, $sql;
480             $sql = '';
481             }
482             }
483             $fh->close;
484             }
485              
486             #print STDERR "# statements=".join("\n# ",@statements)."\n";
487             dosql($db1,\@statements);
488             }
489              
490             sub dosql {
491             my ($db,$sql) = @_;
492              
493             for(@$sql) {
494             #print STDERR "#SQL: [$db] $_\n";
495             eval { $db->dbh->do($_); };
496             if($@) {
497             diag $@;
498             return 1;
499             }
500             }
501              
502             return 0;
503             }
504              
505             1;
506              
507             __END__