File Coverage

lib/Win32/TestServerManager.pm

Criterion	Covered	Total	%
statement	10	12	83.3
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	14	16	87.5

package Win32::TestServerManager;

use strict;
use warnings;
use Carp;
use Win32;
use Win32::Process;
use File::Spec;

our $VERSION = '0.04';

sub new {
  my $class = shift;

  bless {}, $class;
}

sub spawn {
  my ($self, $id, $args, $options) = @_;

  $self->kill($id) if $self->{$id};

  if ( !defined $args )         { $options = {}; $args = ''; }
  elsif ( ref $args eq 'HASH' ) { $options = $args; $args = ''; }

  if ( !defined $options )      { $options = {}; }
  elsif ( ref $options ne 'HASH' ) {
    croak "Usage: ->spawn( id, args, { options } )";
  }

  $args .= ' ' . $options->{args} if $options->{args};

  my $executable = $options->{executable} || $^X;

  my $flag = $options->{cflag} || NORMAL_PRIORITY_CLASS;
     $flag |= CREATE_NEW_CONSOLE if $options->{new_console};
     $flag |= CREATE_NO_WINDOW   if $options->{no_window};

  my $workdir = $options->{working_dir} || '.';

  if ( $options->{create_server_with} ) {
    my $code = $options->{create_server_with};
    if ( ref $code eq 'CODE' ) {
      require B::Deparse;
      my $deparser = B::Deparse->new;
      $code = $deparser->coderef2text( $code );
    }
    require File::Temp;
    require File::Slurp;
    my $tmpfile = File::Temp::tempnam( $workdir => '_tmp' );
    File::Slurp::write_file( $tmpfile, $code );
    $args = "$args $tmpfile";
    $self->{$id}->{tmpfile} = $tmpfile;
  }

  $self->{$id}->{dont_kill} = $options->{dont_kill};

  Win32::Process::Create(my $process,
    $executable,
    "$executable $args",
    0,
    $flag,
    File::Spec->rel2abs($workdir),
  ) or croak Win32::FormatMessage( Win32::GetLastError() );

  $self->{$id}->{process} = $process;
}

sub instance {
  my ($self, $id) = @_;
  return exists $self->{$id} ? $self->{$id} : undef;
}

sub process  {
  my ($self, $id) = @_;
  if ( my $instance = $self->instance($id) ) {
    return exists $instance->{process} ? $instance->{process} : undef;
  }
  return;
}

sub instances {
  my $self = shift;
  keys %{ $self };
}

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

  if ( my $instance = $self->{$id} ) {
    return $instance->{process}->GetProcessID;
  }
  return;
}

sub kill {
  my ($self, $id, $exitcode) = @_;

  $exitcode = 0 unless defined $exitcode;

  if ( my $instance = delete $self->{$id} ) {
    if ( $instance->{tmpfile} ) {
      my $counter = 0;
      while ( $counter++ < 3 ) {
        unlink $instance->{tmpfile};
        last unless -f $instance->{tmpfile};
        sleep 1;
        $counter++;
      }
    }
    return if $instance->{dont_kill};

    $instance->{process}->Kill($exitcode);
  }
}

sub DESTROY {
  my $self = shift;

  foreach my $id ( keys %{ $self } ) {
    $self->kill($id);
  }
}

1;

__END__