Initial Commit
This commit is contained in:
Riley Schneider
178
database/perl/vendor/lib/HTTP/Server/Simple/CGI.pm
vendored
Normal file
178
database/perl/vendor/lib/HTTP/Server/Simple/CGI.pm
vendored
Normal file
@@ -0,0 +1,178 @@
|
||||
|
||||
package HTTP::Server::Simple::CGI;
|
||||
|
||||
use base qw(HTTP::Server::Simple HTTP::Server::Simple::CGI::Environment);
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use vars qw($default_doc $DEFAULT_CGI_INIT $DEFAULT_CGI_CLASS);
|
||||
|
||||
$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>
|
||||
115
database/perl/vendor/lib/HTTP/Server/Simple/CGI/Environment.pm
vendored
Normal file
115
database/perl/vendor/lib/HTTP/Server/Simple/CGI/Environment.pm
vendored
Normal file
@@ -0,0 +1,115 @@
|
||||
|
||||
package HTTP::Server::Simple::CGI::Environment;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use HTTP::Server::Simple;
|
||||
|
||||
use vars qw(%ENV_MAPPING);
|
||||
|
||||
my %clean_env = %ENV;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
HTTP::Server::Simple::CGI::Environment - a HTTP::Server::Simple mixin to provide the CGI protocol
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This mixin abstracts the CGI protocol out from
|
||||
L<HTTP::Server::Simple::CGI> so that it's easier to provide your own
|
||||
CGI handlers with L<HTTP::Server::Simple> which B<don't> use CGI.pm
|
||||
|
||||
=head2 setup_environment
|
||||
|
||||
C<setup_environemnt> is usually called in the superclass's accept_hook
|
||||
|
||||
This routine in this sub-class clears the environment to the
|
||||
start-up state.
|
||||
|
||||
=cut
|
||||
|
||||
sub setup_environment {
|
||||
%ENV = (
|
||||
%clean_env,
|
||||
SERVER_SOFTWARE => "HTTP::Server::Simple/$HTTP::Server::Simple::VERSION",
|
||||
GATEWAY_INTERFACE => 'CGI/1.1'
|
||||
);
|
||||
}
|
||||
|
||||
=head2 setup_server_url
|
||||
|
||||
Sets up the C<SERVER_URL> environment variable
|
||||
|
||||
=cut
|
||||
|
||||
sub setup_server_url {
|
||||
$ENV{SERVER_URL}
|
||||
||= ( "http://" . ($ENV{SERVER_NAME} || 'localhost') . ":" . ( $ENV{SERVER_PORT}||80) . "/" );
|
||||
}
|
||||
|
||||
=head2 setup_environment_from_metadata
|
||||
|
||||
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
|
||||
|
||||
%ENV_MAPPING = (
|
||||
protocol => "SERVER_PROTOCOL",
|
||||
localport => "SERVER_PORT",
|
||||
localname => "SERVER_NAME",
|
||||
path => "PATH_INFO",
|
||||
request_uri => "REQUEST_URI",
|
||||
method => "REQUEST_METHOD",
|
||||
peeraddr => "REMOTE_ADDR",
|
||||
peername => "REMOTE_HOST",
|
||||
peerport => "REMOTE_PORT",
|
||||
query_string => "QUERY_STRING",
|
||||
);
|
||||
|
||||
sub setup_environment_from_metadata {
|
||||
no warnings 'uninitialized';
|
||||
my $self = shift;
|
||||
|
||||
# XXX TODO: rather than clone functionality from the base class,
|
||||
# we should call super
|
||||
#
|
||||
while ( my ( $item, $value ) = splice @_, 0, 2 ) {
|
||||
if ( my $k = $ENV_MAPPING{$item} ) {
|
||||
$ENV{$k} = $value;
|
||||
}
|
||||
}
|
||||
|
||||
# Apache and lighttpd both do one layer of unescaping on
|
||||
# path_info; we should duplicate that.
|
||||
$ENV{PATH_INFO} =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
|
||||
}
|
||||
|
||||
=head2 header
|
||||
|
||||
C<header> turns a single HTTP headers into CGI environment variables.
|
||||
|
||||
=cut
|
||||
|
||||
sub header {
|
||||
my $self = shift;
|
||||
my $tag = shift;
|
||||
my $value = shift;
|
||||
|
||||
$tag = uc($tag);
|
||||
$tag =~ s/^COOKIES$/COOKIE/;
|
||||
$tag =~ s/-/_/g;
|
||||
$tag = "HTTP_" . $tag
|
||||
unless $tag =~ m/^CONTENT_(?:LENGTH|TYPE)$/;
|
||||
|
||||
if ( exists $ENV{$tag} ) {
|
||||
$ENV{$tag} .= $tag eq 'HTTP_COOKIE' ? "; $value" : ", $value";
|
||||
}
|
||||
else {
|
||||
$ENV{$tag} = $value;
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
Reference in New Issue
Block a user