Win32::TestServerManager - manage simple test servers on Win32

Win32-TestServerManager documentation Contained in the Win32-TestServerManager distribution.

Index

Code Index:

NAME

Top

Win32::TestServerManager - manage simple test servers on Win32

SYNOPSIS

Top

    use Test::More 'no_plan';
    use Test::WWW::Mechanize;
    use Win32::TestServerManager;

    my $manager = Win32::TestServerManager->new;

    # you can run a ready-made perl server
    $manager->spawn(
        testserver => 'script/test_server.pl',
        { new_console => 1 }
    );

    # or other executables
    $manager->spawn(
        lighty => '-D -f lighty.conf',
        { executable => 'c:\lighttpd\bin\lighttpd.exe' }
    );

    # you can provide a source code of a temporary server script
    $manager->spawn(
        onthefly => '',
        { create_server_with => server_script_source() }
    );

    # you can omit blank command line args
    $manager->spawn(
        onthefly => { create_server_with => server_script_source() }
    );

    # coderef would be deparsed into a source code, and then turned into a script
    $manager->spawn(
        onthefly => { create_server_with => \&server_func }
    );

    # do some Mech stuff
    my $mech = Test::WWW::Mechanize->new;
    $mech->get_ok('http://localhost:8888/');

    # you can kill servers explicitly
    $manager->kill('testserver');

    # other servers will be killed at DESTROY time

    sub server_script_source { return <<'EndofScript';
    #!c:\perl\bin\perl.exe

    my $server = TestServer->new(8080);
    $server->run;

    package TestServer;
    use base 'HTTP::Server::Simple::CGI';

    EndofScript
    }

    sub server_func {
        my $server = TestServer->new(8080);
        $server->run;

        package TestServer;
        use base 'HTTP::Server::Simple::CGI';
    }

DESCRIPTION

Top

It's a bit harder to test web applications on Win32, due to the limitations of fork and signals. You can use LWP/Mech stuff, and you can run servers written in Perl, but you usually need something to run both servers and test scripts at the same time, and cleanly kill them later.

This module helps you to create new processes to run external servers (which may be, or may not be, written in Perl), and helps you to kill them. Actually you can use this for other purposes, but if you want to launch rather complicated applications, or if you want finer control, you may want to use Win32::Job.

OK. I admit. I wrote this just because I was tired of launching fastcgi server script and lighty proxy from one console at the same time again and again.

METHODS

Top

new

creates an object.

spawn

creates a new process and spawns a (server) application. This usually takes two or three arguments:

id

a scalar name of the process you want to create.

args

an optional string which represents command line arguments for the executable (default: perl) to run.

options

an optional hashref. Acceptable keys are:

executable

If you want to launch other executable than perl (apache, lighttpd, etc), provide an absolute path to the executable.

args

a string which represents command line arguments for the executable to run. If you also set "args" outside the hashref (see above), this optional "args" would be appended.

working_dir

is where temporary file would be created (current directory by default).

new_console

If this is set to true, new process would be created with new console. If your server spits lots of debugging message, this may help.

no_window

If this is set to true, new process would be created without a window. This may be convenient sometimes but usually you don't want to set this, as you'll need task manager to kill the process by yourself.

cflag

If you want to specify more complicated cflag (see Win32::Process for details), use this.

create_server_with

A temporary file would be created to be a final argument to the executable. Despite of the name, you can pass the contents as a config file like:

    $manager->spawn(
        lighty => '-D -f ',
        {
          executable => 'c:\lighttpd\bin\lighttpd.exe',
          create_server_with => <<'EndofConf',
    server.port = 8090
    server.document-root = ".\root"
    EndofConf
        }
    );

In this case, the final command line argument passed to Win32::Process::Create would be "c:\lighttpd\bin\lighttpd.exe -D -f <temporary file>".

As of 0.03, you can provide a code reference, which would be deparsed and then turned into a server script.

dont_kill

by default, the processes created by this module would be killed at DESTROY time, but if this is set to true, the process wouldn't be killed. This may be handy if you just want to launch servers. Of course such servers should be killed by yourself.

kill

kills the process: takes the id you've specified at spawn time.

pid

shows the pid of the process: takes the id you've specified at spawn time.

process

returns the Win32::Process object you created: takes the id you've specified at spawn time.

instance

returns an internal hashref which holds the process object, a temporary filename you may have created, and 'dont_kill' flag: takes the id you've specified at spawn time.

instances

returns an array of instance ids you've specified and created.

SEE ALSO

Top

Win32::Job, Win32::Process

AUTHOR

Top

Kenichi Ishigaki, <ishigaki at cpan.org>

COPYRIGHT AND LICENSE

Top

Copyright (C) 2007 by Kenichi Ishigaki.

This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.

Win32-TestServerManager documentation Contained in the Win32-TestServerManager distribution. 
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__