HTTP::WebTest::Utils - Miscellaneous subroutines used by HTTP::WebTest

    use HTTP::WebTest::Utils;

    *method = make_access_method($field);
    *method = make_access_method($field, $default_value);
    *method = make_access_method($field, sub { ... });

    find_port(hostname => $hostname);
    my $pid = start_webserver(port => $port, server_sub => sub { ... });
    stop_webserver($pid);

    copy_dir($src_dir, $dst_dir);

    load_package($package);

    my $ret = eval_in_playground($code);
    die $@ if $@;

    *method = make_access_method($field, ...);

# $Id: Utils.pm,v 1.9 2003/03/02 11:52:10 m_ilya Exp $

package HTTP::WebTest::Utils;

use strict;

use Cwd;
use File::Copy;
use File::Find;
use File::Path;
use File::Spec::Functions;
use HTTP::Daemon;

use base qw(Exporter);

use vars qw(@EXPORT_OK);

@EXPORT_OK = qw(make_access_method find_port
                copy_dir load_package
                eval_in_playground make_sub_in_playground
                start_webserver stop_webserver);

sub make_access_method {
    # field name
    my $field = shift;
    # subroutine or method which returns some default value for field
    my $default_value = shift;

    my $sub = sub {
	my $self = shift;

	if(@_) {
	    $self->{$field} = shift;
	}

	unless(defined $self->{$field}) {
	    if(defined $default_value) {
		if(ref($default_value) eq 'CODE') {
		    $self->{$field} = $default_value->($self);
		} else {
		    $self->{$field} = $self->$default_value();
		}
	    }
	}

	return $self->{$field};
    };
}

sub find_port {
    my %param = @_;

    my $hostname = $param{hostname};

    my $daemon =
	    HTTP::Daemon->new(($hostname ? (LocalAddr => $hostname) : ()));

    if(defined $daemon) {
	my $port = $daemon->sockport;
	$daemon->close;
	return $port;
    }

    return undef;
}

sub start_webserver {
    my %param = @_;

    my $daemon = HTTP::Daemon->new(LocalPort => $param{port}, Reuse => 1)
	or die;

    # create daemon process
    my $pid = fork;
    die unless defined $pid;
    return $pid if $pid != 0;

    # when we are run under debugger do not stop and call debugger at
    # the exit of the forked process. This helps to workaround problem
    # when forked process tries to takeover and to screw the terminal
    $DB::inhibit_exit = 0;

    # if we are running with Test::Builder do not let it output
    # anything for daemon process
    if(Test::Builder->can('new')) {
        Test::Builder->new->no_ending(1);
    }

    # set 'we are working' flag
    my $done = 0;

    # exit on SIGTERM
    $SIG{TERM} = sub { $done = 1 };
    # handle connections closed by client
    $SIG{PIPE} = 'IGNORE';

    # handle requests till process is killed
    eval {
	until($done) {
	    # wait one tenth of second for connection
	    my $rbits = '';
	    vec($rbits, $daemon->fileno, 1) = 1;
	    my $nfound = select $rbits, '', '', 0.1;

	    # handle incoming connections
	    if($nfound > 0) {
		my $connect = $daemon->accept;
		die unless defined $connect;

		while (my $request = $connect->get_request) {
                    $param{server_sub}->(connect => $connect,
                                         request => $request);
		}
		$connect->close;
	    }
	}
    };
    # in any event try to shutdown daemon nicely
    $daemon->close;
    if($@) { die $@ };

    exit 0;
}

sub stop_webserver {
    my $pid = shift;

    return kill 'SIGTERM', $pid;
}

sub copy_dir {
    my $src_dir = shift;
    my $dst_dir = shift;

    my $cwd = getcwd;

    $dst_dir = catdir($cwd, $dst_dir)
	unless file_name_is_absolute($dst_dir);

    # define subroutine that copies files to destination directory
    # directory
    my $copytree = sub {
	my $filename = $_;

	my $rel_dirname = $File::Find::dir;

	if(-d $filename) {
	    # create this directory in destination directory tree
	    my $path = catdir($dst_dir, $rel_dirname, $filename);
	    mkpath($path) unless -d $path;
	}

	if(-f $filename) {
	    # copy this file to destination directory tree, create
	    # subdirectory if neccessary
	    my $path = catdir($dst_dir, $rel_dirname);
	    mkpath($path) unless -d $path;

	    copy($filename, catfile($path, $filename))
		or die "HTTP::WebTest: Can't copy file: $!";
	}
    };

    # descend recursively from directory, copy files to destination
    # directory
    chdir $src_dir
	or die "HTTP::WebTest: Can't chdir to directory '$src_dir': $!";
    find($copytree, '.');
    chdir $cwd
	or die "HTTP::WebTest: Can't chdir to directory '$cwd': $!";
}

sub load_package {
    my $package = shift;

    # check if package is loaded already (we are asuming that all of
    # them have method 'new')
    return if $package->can('new');

    eval "require $package";

    die $@ if $@;
}

sub eval_in_playground {
    my $code = shift;

    return eval <<CODE;
package HTTP::WebTest::PlayGround;

no strict;
local \$^W; # aka no warnings in new perls

$code
CODE
}

sub make_sub_in_playground {
    my $code = shift;

    return eval_in_playground("sub { local \$^W; $code }");
}

1;