File Coverage

blib/lib/Test/ttserver.pm

Criterion	Covered	Total	%
statement	42	109	38.5
branch	6	52	11.5
condition	1	16	6.2
subroutine	13	24	54.1
pod	12	12	100.0
total	74	213	34.7

package Test::ttserver;

use strict;
use warnings;
use Cwd;
use File::Temp;
use File::Path;
use IO::File;
use POSIX qw/SIGTERM WNOHANG :sys_wait_h/;
use Time::HiRes 'sleep';
use Test::TCP;

our $VERSION = '0.003';
$VERSION = eval $VERSION;

our $errstr;
our @SearchPaths = qw(/usr/bin /usr/local/bin);
our @BooleanArgs = qw(dmn kl ld le uas rcc);
our %Defaults    = (
    debug      => 0,
    auto_start => 1,
    base_dir   => undef,
    bin        => undef,
);

sub new {
    my $class  = shift;
    my $dbname = shift || '';
    my $self = bless +{
        %Defaults,
        @_ == 1 ? %{$_[0]} : @_,
    }, $class;

    $self->{'bin'} = $self->_find_bin or return;

    if ( defined $self->{'base_dir'} && $self->{'base_dir'} !~ m{^/} ) {
        $self->{'base_dir'} = getcwd . '/' . $self->{'base_dir'}
    } else {
        $self->{'base_dir'} = File::Temp::tempdir(
            CLEANUP => $ENV{TEST_TTSERVE_PRESERVE} ? undef : 1,
        );
    }

    my %args;
    for (keys %$self) {
        $args{$_} = delete $self->{$_} unless exists $Defaults{$_};
    }
    $args{'pid'}    = $self->{'base_dir'} . '/tmp/pid';
    $args{'host'} ||= $self->host;
    $args{'port'} ||= $self->port;
    $self->{'args'} = \%args;

    $self->{'dbname'} = $dbname ? $self->{'base_dir'} .'/tmp/'. $dbname : '';

    if ( $self->{'auto_start'} ) {
        $self->setup;
        $self->start;
    }

    return $self;
}

sub DESTROY {
    my $self = shift;
    $self->stop if defined $self->pid;
}

sub setup {
    my $self = shift;
    mkpath( $self->{'base_dir'} . '/tmp', { verbose => $self->{'debug'} });
}

sub start {
    my $self = shift;
    return if defined $self->pid;

    my $log_file = $self->{'base_dir'} . '/tmp/ttserver.log';
    my $log_fh = IO::File->new($log_file, O_WRONLY|O_APPEND|O_CREAT)
        or die qq/failed to create log file: $! "$log_file"/;

    my $pid = fork;
    die qq/failed to fork: $!/ unless defined $pid;

    if ( $pid == 0 ) {
        my $bin  = $self->{'bin'};
        my $args = $self->{'args'};
        my %bool; @bool{@BooleanArgs} = (1) x @BooleanArgs;
        my @command = (
            $self->{'bin'},
            ( map {
                $bool{$_} ? "-$_" : ("-$_" => $args->{$_})
            } (keys %$args) ),
            $self->{'dbname'},
        );
        pop @command unless @command and defined $command[-1];
        warn "@command\n" if $self->{'debug'};
        open STDOUT, '>&', $log_fh or die qq/failed to dup: $! "stdout"/;
        open STDERR, '>&', $log_fh or die qq/failed to dup: $! "stderr"/;
        exec @command;
        die qq/failed to launch ttserver: $? "$bin"/;
    }

    $log_fh->close;
    while (! -e $self->{'args'}{'pid'}) {
        if ( 0 < waitpid $pid, WNOHANG ) {
            die qq/*** failed to launch ttserver ***\n/ . $self->_get_log( $log_file );
        }
        sleep 0.1;
    }

    $self->{'child'} = $pid;
}

sub stop {
    my ( $self, $sig ) = @_;
    return unless defined $self->pid;
    $sig ||= SIGTERM;
    kill $sig, $self->pid;
    1 while ( 0 >= waitpid $self->pid, 0 );
    my $is_exited = WIFEXITED( $? );
    delete $self->{'child'};
    # might remain for example when sending SIGKILL
    unlink $self->{'args'}{'pid'};
    return $is_exited;
}

sub socket    { ($_[0]->host, $_[0]->port) }
sub host      { shift->{'args'}{'host'} || '127.0.0.1' }
sub port      { shift->{'args'}{'port'} || empty_port  }
sub pid       { shift->{'child'}         }
sub is_up     { shift->{'child'} ? 1 : 0 }
sub is_down   { shift->is_up ? 0 : 1     }
sub pid_file  { shift->{'args'}{'pid'}   }
sub args      { shift->{'args'}          }

sub _find_bin {
    my $self = shift;

    my @paths = @SearchPaths;
    push @paths, split ':', $ENV{'PATH'} if defined $ENV{'PATH'};

    for my $path (@paths) {
        my $bin = $path . '/ttserver';
        return $bin if -x $bin;
    }

    $errstr = "could not find ttserver, please set appropriate PATH";
    return;
}

sub _get_log {
    my ( $self, $log_file ) = @_;
    my $log = '';
    if ( my $log_fh = IO::File->new($log_file, O_RDONLY) ) {
        $log = do { local $/; <$log_fh> };
        $log_fh->close;
    }
    return $log;
}

1;

__END__