179 lines
3.5 KiB
Perl
179 lines
3.5 KiB
Perl
|
|
package HTTP::Server::Simple::CGI;
|
|
|
|
use base qw(HTTP::Server::Simple HTTP::Server::Simple::CGI::Environment);
|
|
use strict;
|
|
use warnings;
|
|
|
|
use vars qw($VERSION $default_doc $DEFAULT_CGI_INIT $DEFAULT_CGI_CLASS);
|
|
$VERSION = $HTTP::Server::Simple::VERSION;
|
|
|
|
$DEFAULT_CGI_CLASS = "CGI";
|
|
$DEFAULT_CGI_INIT = sub { require CGI; CGI::initialize_globals()};
|
|
|
|
|
|
=head1 NAME
|
|
|
|
HTTP::Server::Simple::CGI - CGI.pm-style version of HTTP::Server::Simple
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
HTTP::Server::Simple was already simple, but some smart-ass pointed
|
|
out that there is no CGI in HTTP, and so this module was born to
|
|
isolate the CGI.pm-related parts of this handler.
|
|
|
|
|
|
=head2 accept_hook
|
|
|
|
The accept_hook in this sub-class clears the environment to the
|
|
start-up state.
|
|
|
|
=cut
|
|
|
|
sub accept_hook {
|
|
my $self = shift;
|
|
$self->setup_environment(@_);
|
|
}
|
|
|
|
=head2 post_setup_hook
|
|
|
|
Initializes the global L<CGI> object, as well as other environment
|
|
settings.
|
|
|
|
=cut
|
|
|
|
sub post_setup_hook {
|
|
my $self = shift;
|
|
$self->setup_server_url;
|
|
if ( my $init = $self->cgi_init ) {
|
|
$init->();
|
|
}
|
|
}
|
|
|
|
=head2 cgi_class [Classname]
|
|
|
|
Gets or sets the class to use for creating the C<$cgi> object passed to
|
|
C<handle_request>.
|
|
|
|
Called with a single argument, it sets the coderef. Called with no arguments,
|
|
it returns this field's current value.
|
|
|
|
To provide an initialization subroutine to be run in the post_setup_hook,
|
|
see L</cgi_init>.
|
|
|
|
e.g.
|
|
|
|
$server->cgi_class('CGI');
|
|
|
|
$server->cgi_init(sub {
|
|
require CGI;
|
|
CGI::initialize_globals();
|
|
});
|
|
|
|
or, if you want to use L<CGI::Simple>,
|
|
|
|
$server->cgi_class('CGI::Simple');
|
|
$server->cgi_init(sub {
|
|
require CGI::Simple;
|
|
});
|
|
|
|
=cut
|
|
|
|
sub cgi_class {
|
|
my $self = shift;
|
|
if (@_) {
|
|
$self->{cgi_class} = shift;
|
|
}
|
|
return $self->{cgi_class} || $DEFAULT_CGI_CLASS;
|
|
}
|
|
|
|
=head2 cgi_init [CODEREF]
|
|
|
|
A coderef to run in the post_setup_hook.
|
|
|
|
Called with a single argument, it sets the coderef. Called with no arguments,
|
|
it returns this field's current value.
|
|
|
|
=cut
|
|
|
|
sub cgi_init {
|
|
my $self = shift;
|
|
if (@_) {
|
|
$self->{cgi_init} = shift;
|
|
}
|
|
return $self->{cgi_init} || $DEFAULT_CGI_INIT;
|
|
|
|
}
|
|
|
|
|
|
=head2 setup
|
|
|
|
This method sets up CGI environment variables based on various
|
|
meta-headers, like the protocol, remote host name, request path, etc.
|
|
|
|
See the docs in L<HTTP::Server::Simple> for more detail.
|
|
|
|
=cut
|
|
|
|
sub setup {
|
|
my $self = shift;
|
|
$self->setup_environment_from_metadata(@_);
|
|
}
|
|
|
|
=head2 handle_request CGI
|
|
|
|
This routine is called whenever your server gets a request it can
|
|
handle.
|
|
|
|
It's called with a CGI object that's been pre-initialized.
|
|
You want to override this method in your subclass
|
|
|
|
|
|
=cut
|
|
|
|
$default_doc = ( join "", <DATA> );
|
|
|
|
sub handle_request {
|
|
my ( $self, $cgi ) = @_;
|
|
|
|
print "HTTP/1.0 200 OK\r\n"; # probably OK by now
|
|
print "Content-Type: text/html\r\nContent-Length: ", length($default_doc),
|
|
"\r\n\r\n", $default_doc;
|
|
}
|
|
|
|
=head2 handler
|
|
|
|
Handler implemented as part of HTTP::Server::Simple API
|
|
|
|
=cut
|
|
|
|
sub handler {
|
|
my $self = shift;
|
|
my $cgi;
|
|
$cgi = $self->cgi_class->new;
|
|
eval { $self->handle_request($cgi) };
|
|
if ($@) {
|
|
my $error = $@;
|
|
warn $error;
|
|
}
|
|
}
|
|
|
|
1;
|
|
|
|
__DATA__
|
|
<html>
|
|
<head>
|
|
<title>Hello!</title>
|
|
</head>
|
|
<body>
|
|
<h1>Congratulations!</h1>
|
|
|
|
<p>You now have a functional HTTP::Server::Simple::CGI running.
|
|
</p>
|
|
|
|
<p><i>(If you're seeing this page, it means you haven't subclassed
|
|
HTTP::Server::Simple::CGI, which you'll need to do to make it
|
|
useful.)</i>
|
|
</p>
|
|
</body>
|
|
</html>
|