File Coverage

blib/lib/Test/BrewBuild/Tester.pm
Criterion Covered Total %
statement 39 321 12.1
branch 0 134 0.0
condition 0 18 0.0
subroutine 13 25 52.0
pod 8 8 100.0
total 60 506 11.8


line stmt bran cond sub pod time code
1             package Test::BrewBuild::Tester;
2 34     34   605 use strict;
  34         73  
  34         1204  
3 34     34   703 use warnings;
  34         90  
  34         865  
4              
5 34     34   152 use Carp qw(croak);
  34         54  
  34         1267  
6 34     34   157 use Config;
  34         54  
  34         1322  
7 34     34   161 use Cwd qw(getcwd);
  34         69  
  34         1480  
8 34     34   221 use File::Path qw(remove_tree);
  34         118  
  34         1527  
9 34     34   582 use IO::Socket::INET;
  34         18421  
  34         366  
10 34     34   16774 use Logging::Simple;
  34         10355  
  34         788  
11 34     34   14212 use Proc::Background;
  34         88896  
  34         1304  
12 34     34   757 use Storable;
  34         2672  
  34         1347  
13 34     34   627 use Test::BrewBuild;
  34         61  
  34         687  
14 34     34   153 use Test::BrewBuild::Constant qw(:all);
  34         56  
  34         3093  
15 34     34   4551 use Test::BrewBuild::Git;
  34         74  
  34         86926  
16              
17             our $VERSION = '2.20';
18              
19             $| = 1;
20              
21             my $log;
22              
23             sub new {
24 0     0 1   my ($class, %args) = @_;
25 0           my $self = bless {}, $class;
26              
27 0 0         $self->{log_to_stdout} = defined $args{stdout} ? $args{stdout} : 0;
28 0           $self->{logfile} = $args{logfile};
29              
30 0           $self->{auto} = $args{auto};
31 0           $self->{csum} = $args{csum};
32              
33 0           $log = Logging::Simple->new(level => 0, name => 'Tester');
34 0           $log->_7("instantiating new object");
35              
36 0 0         if (defined $args{debug}){
37 0 0         $log->level($args{debug}) if defined $args{debug};
38 0           $self->{debug} = $args{debug};
39             }
40              
41 0           my $log_file = \$self->{log};
42              
43 0 0         if ($self->{logfile}){
44 0           $log_file = Test::BrewBuild->workdir ."/bbtester_parent.log";
45             }
46              
47 0 0         if ($self->{log_to_stdout}){
48 0           $log->_7("logging to STDOUT");
49             }
50              
51 0           my $tester_log = $log->child('new');
52 0           $tester_log->_5("instantiating new Test::BrewBuild::Tester object");
53              
54 0           my $arg_string;
55              
56 0           for (keys %args){
57 0 0         next if ! defined $args{$_};
58 0           $arg_string .= "$_: $args{$_}\n";
59             }
60              
61 0 0         if ($arg_string){
62 0           $tester_log->_7("args:");
63 0           $tester_log->_7("\n$arg_string");
64             }
65              
66 0           $self->_config;
67 0           $self->_pid_file;
68              
69 0           return $self;
70             }
71             sub start {
72 0     0 1   my $self = shift;
73              
74 0           my $log = $log->child("start");
75              
76 0           my $existing_pid = $self->pid;
77              
78 0 0         if ($existing_pid){
79 0 0         if (kill 0, $existing_pid){
80 0           $log->_1("tester is already running at PID $existing_pid");
81 0           warn "\nTest::BrewBuild test server already running " .
82             "on PID $existing_pid...\n\n";
83              
84 0           return;
85             }
86             else {
87 0           $log->_1(
88             "tester is not running, but a PID file exists for " .
89             "PID $existing_pid. The tester must have crashed."
90             );
91 0           warn "\nTest::BrewBuild test server crashed in a previous " .
92             "run. Cleaning up and starting...\n\n";
93              
94 0 0         unlink $self->_pid_file or die "can't remove PID file...\n";
95             }
96             }
97              
98 0           my ($perl, @args);
99 0           my $work_dir = Test::BrewBuild->workdir;
100              
101 0 0         if ($^O =~ /MSWin/){
102 0           $log->_6("on Windows, using work dir $work_dir");
103              
104 0           my $t;
105              
106 0           for (split /;/, $ENV{PATH}){
107 0 0         if (-x "$_/perl.exe"){
108 0           $perl = "$_/perl.exe";
109 0           last;
110             }
111             }
112 0           for (split /;/, $ENV{PATH}){
113 0 0         if (-e "$_/bbtester"){
114 0           $t = "$_/bbtester";
115 0           last;
116             }
117             }
118 0           $log->_6("using command: $perl $t --fg");
119              
120 0           @args = ($t, '--fg');
121             }
122             else {
123 0           $log->_6("on Unix, using work dir $work_dir");
124              
125 0           $perl = 'perl';
126 0           @args = qw(bbtester --fg);
127              
128 0           $log->_6("using command: bbtester --fg");
129             }
130              
131 0 0         if (defined $self->{auto}){
132 0           push @args, ('--auto', $self->{auto});
133 0 0         push @args, ('--csum', $self->{csum}) if defined $self->{csum};
134              
135             }
136 0 0         if (defined $self->{debug}){
137 0           push @args, ('--debug', $self->{debug});
138             }
139 0 0         if ($self->{logfile}){
140 0           push @args, ('--logfile');
141             }
142              
143 0 0 0       mkdir $work_dir or croak "can't create $work_dir dir: $!" if ! -d $work_dir;
144 0 0         chdir $work_dir or croak "can't change to dir $work_dir: $!";
145 0           $log->_7("chdir to: ".getcwd());
146              
147 0           my $bg;
148              
149 0 0         if ($^O =~ /MSWin/){
150 0           $bg = Proc::Background->new($perl, @args);
151             }
152             else {
153 0           $bg = Proc::Background->new(@args);
154             }
155              
156 0           my $pid = $bg->pid;
157              
158 0           my $ip = $self->ip;
159 0           my $port = $self->port;
160              
161 0           $log->_5("Started the BB test server at PID $pid on IP $ip and port $port");
162              
163 0           print "\nStarted the Test::BrewBuild test server at PID $pid on IP " .
164             "address $ip and TCP port $port...\n\n";
165              
166 0 0         open my $wfh, '>', $self->_pid_file or croak $!;
167 0           print $wfh $pid;
168 0           close $wfh;
169              
170             # error check for bbtester
171              
172 0 0         if ($self->status){
173 0           sleep 1;
174 0           my $existing_pid = $self->pid;
175              
176 0 0         if ($existing_pid){
177 0 0         if (! kill 0, $existing_pid){
178 0           $log->_0("error! run bbtester --fg at the CLI and check for " .
179             "failure"
180             );
181 0           croak "\nerror! run bbtester --fg at the command line and " .
182             "check for failure\n\n";
183             }
184             }
185             }
186             }
187             sub stop {
188 0     0 1   my $self = shift;
189              
190 0           my $log = $log->child("stop");
191              
192 0           $log->_5("attempting to stop the tester service");
193              
194 0 0         if (! $self->status) {
195 0           $log->_5("Test::BrewBuild test server is not running");
196 0           print "\nTest::BrewBuild test server is not running...\n\n";
197 0           return;
198             }
199              
200 0           my $pid = $self->pid;
201 0           my $pid_file = $self->_pid_file;
202              
203 0           $log->_5("Stopping the BB test server at PID $pid");
204 0           print "\nStopping the Test::BrewBuild test server at PID $pid...\n\n";
205 0           kill 'KILL', $pid;
206 0           unlink $pid_file;
207             }
208             sub status {
209 0     0 1   my $self = shift;
210 0           my $log = $log->child("status");
211              
212 0           my $status;
213              
214 0 0 0       if (defined $self->pid && $self->pid){
215 0 0         if (! kill 0, $self->pid){
216 0           $log->_1("bbtester is in an inconsistent state. Cleaning up...");
217 0           warn "\nbbtester is in an inconsistent state. Cleaning up...\n\n";
218 0 0         unlink $self->_pid_file or die "can't remove PID file...\n";
219 0           $status = 0;
220             }
221             else {
222 0           $status = 1;
223             }
224             }
225             else {
226 0           $status = 0;
227             }
228 0           $log->_6("test server status: $status");
229 0           return $status;
230             }
231             sub listen {
232 0     0 1   my $self = shift;
233 0           my $log = $log->child("listen");
234              
235 0           my $log_file = \$self->{log};
236 0 0         if ($self->{logfile}){
237 0           $log_file = Test::BrewBuild->workdir ."/bbtester_child.log";
238             }
239 0 0         $log->file($log_file) if ! $self->{log_to_stdout};
240              
241 0           my $sock = new IO::Socket::INET (
242             LocalHost => $self->ip,
243             LocalPort => $self->port,
244             Proto => 'tcp',
245             Listen => 5,
246             Reuse => 1,
247             );
248 0 0         croak "cannot create socket $!\n" unless $sock;
249              
250 0           $log->_6("successfully created network socket on IP $self->{ip} and port " .
251             "$self->{port}"
252             );
253              
254 0           $log->_7("$self->{ip} now accepting incoming connections");
255              
256 0           while (1){
257              
258 0           my $work_dir = Test::BrewBuild->workdir;
259 0 0         mkdir $work_dir if ! -d $work_dir;
260 0           chdir $work_dir;
261 0           $log->_7("work dir is: $work_dir");
262 0           $log->_7("chdir to work dir: ".getcwd());
263              
264             my $res = {
265             platform => $Config{archname},
266 0           };
267              
268 0           $log->_7("TESTER: $self->{ip} PLATFORM: $res->{platform}");
269 0           $log->_7("waiting for a connection...\n");
270              
271 0           my $dispatch = $sock->accept;
272              
273             # ack
274 0           my $ack;
275 0           $dispatch->recv($ack, 1024);
276              
277 0           $log->_7("received ack: $ack");
278              
279 0           $dispatch->send($ack);
280              
281 0           $log->_7("returned ack: $ack");
282              
283 0           my $cmd;
284 0           $dispatch->recv($cmd, 1024);
285 0           $res->{cmd} = $cmd;
286              
287 0           $log->_7("received cmd: $res->{cmd}");
288              
289 0           my @args = split /\s+/, $cmd;
290              
291 0 0         if ($args[0] ne 'brewbuild'){
292 0           my $err = "error: only 'brewbuild' is allowed as a command. ";
293 0           $err .= "you sent in: " . join ' ', @args;
294 0           $log->_0($err);
295 0           $dispatch->send($err);
296 0           next;
297             }
298 0           my $unsafe_args = _unsafe_args();
299              
300 0           for my $unsafe_arg (@$unsafe_args){
301 0 0         if (grep /\Q$unsafe_arg\E/, @args){
302 0           croak "'$unsafe_arg' is an invalid argument to brewbuild. " .
303             "Can't continue...\n";
304             }
305             }
306              
307 0           shift @args;
308 0           $log->_7("sending 'ok'");
309 0           $dispatch->send('ok');
310              
311 0           my $repo = '';
312 0           $dispatch->recv($repo, 1024);
313 0           $res->{repo} = $repo;
314              
315 0           $log->_7("received repo: $repo");
316              
317 0 0         if ($repo){
318 0           my $git = Test::BrewBuild::Git->new(debug => $self->{debug});
319 0           $log->_7("using Git: " . $git->git);
320              
321 0           $log->_7("before all checks, repo set to $repo");
322              
323 0           my $repo_name = $git->name($repo);
324 0           my $csums_differ;
325              
326 0 0         if (-d $repo_name){
327 0 0         chdir $repo_name or croak $!;
328              
329 0           $log->_7("chdir to: ".getcwd());
330              
331 0           $log->_7("repo $repo_name exists");
332              
333 0 0 0       if (defined $self->{auto} && $self->{auto}){
334 0           $log->_6("in auto mode");
335              
336 0           my $status = $git->status(repo => $git->link);
337 0           my $local_sum = $git->revision(repo => $git->link);
338 0           my $remote_sum = $git->revision(
339             remote => 1,
340             repo => $git->link
341             );
342              
343 0 0         $csums_differ = 1 if $local_sum ne $remote_sum;
344              
345 0           $log->_7(
346             "\nGit check:" .
347             "\n\tstatus: $status" .
348             "\n\tlocal: $local_sum" .
349             "\n\tremote: $remote_sum"
350             );
351              
352 0 0         if (! defined $self->{csum}){
353 0           $log->_6("in auto mode, checking commit checksum reqs");
354              
355 0 0         if (! $status) {
356 0           $log->_6(
357             "local repo is ahead in commits than remote...".
358             " Nothing to do"
359             );
360 0           $self->{log} = '';
361 0           shutdown($dispatch, 1);
362 0           next;
363             }
364              
365 0 0         if ($local_sum eq $remote_sum) {
366 0           $log->_6(
367             "local and remote commit sums match. Nothing " .
368             "to do"
369             );
370 0           $self->{log} = '';
371 0           shutdown($dispatch, 1);
372 0           next;
373             }
374             }
375             }
376              
377 0           my $pull_output;
378              
379 0 0         if ($csums_differ){
380 0           $log->_7("pulling $repo_name");
381 0           $pull_output = $git->pull;
382 0           $log->_7($pull_output);
383             }
384             else {
385 0           $log->_7("commit checksums are equal; no need to pull");
386             }
387             }
388             else {
389 0           $log->_7("repo doesn't exist... cloning");
390 0           $git->clone($repo);
391 0           chdir $git->name($repo);
392 0           $log->_7("chdir to: ".getcwd());
393             }
394              
395 0           my %opts = Test::BrewBuild->options(\@args);
396              
397 0 0         if (defined $opts{error}){
398 0           my $err = "invalid arguments sent to brewbuild: ";
399 0           $err .= join ', ', @args;
400 0           $log->_0($err);
401 0           $dispatch->send($err);
402 0           next;
403             }
404 0           my $opt_str;
405              
406 0           for (keys %opts){
407 0 0         $opt_str .= "$_ => $opts{$_}\n" if defined $opts{$_};
408             }
409 0 0         if ($opt_str){
410 0           $log->_5("COMMENCING TEST RUN; args: $opt_str");
411             }
412             else {
413 0           $log->_5("COMMENCING TEST RUN; no args (default)");
414             }
415              
416 0           my $bb = Test::BrewBuild->new(%opts);
417              
418 0 0         $bb->log()->file($log_file) if ! $self->{log_to_stdout};
419              
420 0 0         $bb->instance_remove if $opts{remove};
421 0 0         if ($opts{install}){
    0          
422 0           $bb->instance_install($opts{install});
423             }
424             elsif ($opts{new}){
425 0           $bb->instance_install($opts{new});
426             }
427              
428 0 0         if ($opts{notest}){
429 0           $log->_5("no tests run due to --notest flag set");
430 0           $log->_5("storing and sending results back to dispatcher");
431 0           $res->{log} = $self->{log};
432 0           Storable::nstore_fd($res, $dispatch);
433 0           next;
434             }
435 0 0         if ($opts{revdep}){
436 0           $log->_6("revdep enabled");
437 0           $res->{data} = $bb->revdep(%opts);
438             }
439             else {
440 0           $log->_7("executing test()");
441 0           $res->{data} = $bb->test;
442             }
443              
444 0 0         if (-d 'bblog'){
445 0           chdir 'bblog';
446 0           $log->_7("chdir to: ".getcwd());
447 0           my @entries = glob '*';
448              
449 0 0         if (@entries){
450 0           $log->_5("log files: " . join ', ', @entries);
451             }
452             else {
453 0           $log->_7("no log files generated, nothing to process");
454             }
455 0           for (@entries){
456 0           $log->_7("processing log file: " .getcwd() ."/$_");
457 0 0 0       next if ! -f || ! /\.bblog/;
458 0 0         open my $fh, '<', $_ or croak $!;
459 0           @{ $res->{files}{$_} } = <$fh>;
  0            
460 0           close $fh;
461             }
462 0           chdir '..';
463 0           $log->_7("chdir to: ".getcwd());
464              
465 0           $log->_7("removing log dir: " . getcwd() . "/bblog");
466 0 0         remove_tree 'bblog' or croak $!;
467             }
468 0           $log->_5("storing and sending results back to dispatcher");
469 0           $res->{log} = $self->{log};
470              
471 0           Storable::nstore_fd($res, $dispatch);
472 0           chdir '..';
473              
474 0           $self->{log} = '';
475 0           shutdown($dispatch, 1);
476             }
477             }
478 0           $sock->close();
479             }
480             sub ip {
481 0     0 1   my ($self, $ip) = @_;
482              
483 0 0         return $self->{ip} if $self->{ip};
484              
485 0 0 0       if (! $ip && $self->{conf}{ip}){
486 0           $ip = $self->{conf}{ip};
487             }
488 0 0         $ip = '0.0.0.0' if ! $ip;
489 0           $self->{ip} = $ip;
490             }
491             sub port {
492 0     0 1   my ($self, $port) = @_;
493              
494 0 0         return $self->{port} if $self->{port};
495              
496 0 0 0       if (! $port && $self->{conf}{port}){
497 0           $port = $self->{conf}{port};
498             }
499 0 0         $port = '7800' if ! defined $port;
500 0           $self->{port} = $port;
501             }
502             sub _config {
503             # bring in config file elements
504              
505 0     0     my $self = shift;
506              
507 0           my $conf_file = Test::BrewBuild->config_file;
508              
509 0 0         if (-f $conf_file){
510 0           my $conf = Config::Tiny->read($conf_file)->{tester};
511 0           $self->{conf}{ip} = $conf->{ip};
512 0           $self->{conf}{port} = $conf->{port};
513             }
514             }
515             sub pid {
516 0     0 1   my $pid;
517 0 0         if (-f $_[0]->_pid_file){
518 0 0         open my $fh, '<', $_[0]->_pid_file or croak "can't open PID file!: $!";
519 0           $pid = <$fh>;
520             }
521             else {
522 0           $pid = undef;
523             }
524 0           return $pid;
525             }
526             sub _pid_file {
527             # fetch the PID file location, and set the file
528 0     0     my $self = shift;
529 0 0         return $self->{pid_file} if defined $self->{pid_file};
530 0           $self->{pid_file} = Test::BrewBuild->workdir . '/brewbuild.pid';
531             }
532             sub _unsafe_args {
533             # non-allowed chars in bbdispach's "-c" command line string for brewbuild
534 0     0     return ['*', '#', '!', '?', '^', '$', '|', '\\'];
535             }
536       0     sub __placeholder {} # vim folds
537              
538             1;
539              
540             =head1 NAME
541              
542             Test::BrewBuild::Tester - Daemonized testing service for dispatched test run
543             execution, for Windows & Unix.
544              
545             =head1 DESCRIPTION
546              
547             Builds and puts into the background a L remote tester
548             listening service.
549              
550             Note that by default, the working directory is C<~/brewbuild> on all platforms.
551              
552             =head1 METHODS
553              
554             =head2 new
555              
556             Returns a new C object.
557              
558             Parameters:
559              
560             debug => $level
561              
562             Integer, optional. Debug level from least verbose (0) to maximum verbosity (7).
563              
564             stdout => $bool
565              
566             Integer, optional. By default, we return the test log/debug output with the
567             results of the test run. Set this to true (1) to disable this, and have the
568             tester print its output directly to STDOUT instead.
569              
570             logfile => $bool
571              
572             Integer, optional. Set this to true (1) and we'll write all tester output to a
573             log file. The parent tester server will create a C<$workdir/bbtester_parent.log>
574             file (where C<$workdir> is C<~/brewbuild> by default), and the children tester
575             runners will all log to C<$workdir/bbtester_child.log>.
576              
577             =head2 start
578              
579             Starts the tester, and puts it into the background.
580              
581             =head2 stop
582              
583             Stops the tester and all of its processes.
584              
585             =head2 status
586              
587             Returns the current PID (true) if there's a tester currently running, and 0 if
588             not.
589              
590             =head2 pid
591              
592             Returns the current PID the tester is running under if it is running, and C<0>
593             if not.
594              
595             =head2 ip($ip)
596              
597             Default listening IP address is C<0.0.0.0> ie. all currently bound IPs. Send in
598             an alternate IP address to listen on a specific one.
599              
600             This will override any IP information in the configuration file, if present.
601              
602             Returns the currently used IP.
603              
604             =head2 port($port)
605              
606             Default port is C<7800>. Send in an alternate to listen on it instead.
607              
608             This will override any port information in the configuration file, if present.
609              
610             Returns the port currently being used.
611              
612             =head2 listen
613              
614             This is the actual service that listens for and processes requests.
615              
616             By default, listens on all IP addresses bound to all network interfaces, on
617             port C<7800>.
618              
619             =head1 AUTHOR
620              
621             Steve Bertrand, C<< >>
622              
623             =head1 LICENSE AND COPYRIGHT
624              
625             Copyright 2017 Steve Bertrand.
626              
627             This program is free software; you can redistribute it and/or modify it
628             under the terms of either: the GNU General Public License as published
629             by the Free Software Foundation; or the Artistic License.
630              
631             See L for more information.
632              
633              
634             =cut
635