[catagits/Test-WWW-Mechanize-Catalyst.git] / t / lib / ExternalCatty.pm

package ExternalCatty;
use strict;
use warnings;
use Catalyst qw/-Engine=HTTP/;
our $VERSION = '0.01';

__PACKAGE__->config( name => 'ExternalCatty' );
__PACKAGE__->setup;

sub default : Private {
    my ( $self, $c ) = @_;
    $c->response->content_type('text/html; charset=utf-8');
    $c->response->output( html( 'Root', 'Hello, test ☺!' ) );
}

# redirect to a redirect
sub hello: Global {
    my ( $self, $context ) = @_;
    my $where = $context->uri_for('/');
    $context->response->redirect($where);
    return;
}

sub html {
    my ( $title, $body ) = @_;
    return qq[
<html>
<head>
    <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
    <title>$title</title>
</head>
<body>$body</body>
</html>
];
}

# The Cat HTTP server background option is useless here :-(
# Thus we have to provide our own background method.
sub background {
    my $self  = shift;
    my $port  = shift;
    my $child = fork;
    die "Can't fork Cat HTTP server: $!" unless defined $child;
    return $child if $child;

    if ( $^O !~ /MSWin32/ ) {
        require POSIX;
        POSIX::setsid() or die "Can't start a new session: $!";
    }

    $self->run($port);
}

1;
Commit	Line	Data
6bc86362	1	package ExternalCatty;
	2	use strict;
	3	use warnings;
	4	use Catalyst qw/-Engine=HTTP/;
	5	our $VERSION = '0.01';
	6
	7	__PACKAGE__->config( name => 'ExternalCatty' );
	8	__PACKAGE__->setup;
	9
	10	sub default : Private {
	11	my ( $self, $c ) = @_;
	12	$c->response->content_type('text/html; charset=utf-8');
	13	$c->response->output( html( 'Root', 'Hello, test ☺!' ) );
	14	}
	15
97ae89ab	16	# redirect to a redirect
	17	sub hello: Global {
	18	my ( $self, $context ) = @_;
	19	my $where = $context->uri_for('/');
	20	$context->response->redirect($where);
	21	return;
	22	}
	23
6bc86362	24	sub html {
	25	my ( $title, $body ) = @_;
	26	return qq[
	27	<html>
	28	<head>
	29	<meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
	30	<title>$title</title>
	31	</head>
	32	<body>$body</body>
	33	</html>
	34	];
	35	}
	36
	37	# The Cat HTTP server background option is useless here :-(
	38	# Thus we have to provide our own background method.
	39	sub background {
	40	my $self = shift;
	41	my $port = shift;
	42	my $child = fork;
	43	die "Can't fork Cat HTTP server: $!" unless defined $child;
	44	return $child if $child;
	45
	46	if ( $^O !~ /MSWin32/ ) {
	47	require POSIX;
	48	POSIX::setsid() or die "Can't start a new session: $!";
	49	}
	50
	51	$self->run($port);
	52	}
	53
	54	1;
	55