From 9881490f8c578555aa2349f8223104aa22fc8954 Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Mon, 10 Sep 2012 20:07:18 +0200 Subject: Development server. --- dev/MyServer.pm | 304 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ dev/server.pl | 28 ++++++ 2 files changed, 332 insertions(+) create mode 100644 dev/MyServer.pm create mode 100755 dev/server.pl (limited to 'dev') diff --git a/dev/MyServer.pm b/dev/MyServer.pm new file mode 100644 index 0000000..985afa7 --- /dev/null +++ b/dev/MyServer.pm @@ -0,0 +1,304 @@ +# A 99% clone of CGI::Application::Server that allows the server to pass +# parameters (e.g., CFG files). + +package MyServer; + +use strict; +use warnings; + +use Carp qw( confess ); +use CGI qw( param ); +use Scalar::Util qw( blessed reftype ); +use HTTP::Response; +use HTTP::Status; + +our $VERSION = '0.062'; + +use base qw( HTTP::Server::Simple::CGI ); +use HTTP::Server::Simple::Static; + +# HTTP::Server::Simple methods + +sub new { + my $class = shift; + my $self = $class->SUPER::new(@_); + $self->{entry_points} = {}; + $self->{document_root} = '.'; + $self->{options} = {}; + return $self; +} + +# accessors + +sub document_root { + my ($self, $document_root) = @_; + if (defined $document_root) { + (-d $document_root) + || confess "The server root ($document_root) is not found"; + $self->{document_root} = $document_root; + } + $self->{document_root}; +} + +sub entry_points { + my ($self, $entry_points) = @_; + if (defined $entry_points) { + (reftype($entry_points) && reftype($entry_points) eq 'HASH') + || confess "The entry points map must be a HASH reference, not $entry_points"; + $self->{entry_points} = $entry_points; + } + $self->{entry_points}; +} + +# check request + +sub options { + my ($self, $options) = @_; + if (defined $options) { + (reftype($options) && reftype($options) eq 'HASH') + || confess "The entry points map must be a HASH reference, not $options"; + $self->{options} = $options; + } + $self->{options}; +} + +sub is_valid_entry_point { + my ($self, $uri) = @_; + + # Remove all parameters + $uri =~ s/\?.*//; + + while ( $uri ) { + # Check to see if this is an exact match + if (exists $self->{entry_points}{$uri}) { + return ($uri, $self->{entry_points}{$uri}); + } + + # Remove the rightmost path element + $uri =~ s/\/[^\/]*$//; + } + + # Check to see if there's an entry for '/' + if (exists $self->{entry_points}{'/'}) { + return ($uri, $self->{entry_points}{'/'}); + } + + # Didn't find anything. Oh, well. + return; +} + +sub handle_request { + my ($self, $cgi) = @_; + if (my ($path, $target) = $self->is_valid_entry_point($ENV{REQUEST_URI})) { + # warn "$ENV{REQUEST_URI} ($target)\n"; + # warn "\t$_ => " . param( $_ ) . "\n" for param(); + + local $ENV{CGI_APP_RETURN_ONLY} = 1; + (local $ENV{PATH_INFO} = $ENV{PATH_INFO}) =~ s/\A\Q$path//; + + if (-d $target && -x $target) { + return $self->serve_static($cgi, $target); + } + elsif ($target->isa('CGI::Application::Dispatch')) { + return $self->_serve_response($target->dispatch); + } elsif ($target->isa('CGI::Application')) { + if (!defined blessed $target) { + return $self->_serve_response($target->new($self->options->{$path})->run); + } else { + $target->query($cgi); + return $self->_serve_response($target->run); + } + } + else { + confess "Target must be a CGI::Application or CGI::Application::Dispatch subclass or the name of a directory that exists and is readable.\n"; + } + } else { + return $self->serve_static($cgi, $self->document_root); + } +} + +sub _serve_response { + my ( $self, $stdout ) = @_; + + my $response = $self->_build_response( $stdout ); + print $response->as_string(); + + return 1; # Like ...Simple::Static::serve_static does +} + +# Shamelessly stolen from HTTP::Request::AsCGI by chansen +sub _build_response { + my ( $self, $stdout ) = @_; + + $stdout =~ s{(.*?\x0d?\x0a\x0d?\x0a)}{}xsm; + my $headers = $1; + + unless ( defined $headers ) { + $headers = "HTTP/1.1 500 Internal Server Error\x0d\x0a"; + } + + unless ( $headers =~ /^HTTP/ ) { + $headers = "HTTP/1.1 200 OK\x0d\x0a" . $headers; + } + + my $response = HTTP::Response->parse($headers); + $response->date( time() ) unless $response->date; + + my $message = $response->message; + my $status = $response->header('Status'); + + $response->header( Connection => 'close' ); + + if ( $message && $message =~ /^(.+)\x0d$/ ) { + $response->message($1); + } + + if ( $status && $status =~ /^(\d\d\d)\s?(.+)?$/ ) { + + my $code = $1; + $message = $2 || HTTP::Status::status_message($code); + + $response->code($code); + $response->message($message); + } + + my $length = length $stdout; + + if ( $response->code == 500 && !$length ) { + + $response->content( $response->error_as_HTML ); + $response->content_type('text/html'); + + return $response; + } + + $response->add_content($stdout); + $response->content_length($length); + + return $response; +} + + +1; + +__END__ + +=pod + +=head1 NAME + +CGI::Application::Server - A simple HTTP server for developing with CGI::Application + +=head1 SYNOPSIS + + use CGI::Application::Server; + use MyCGIApp; + use MyCGIApp::Admin; + use MyCGI::App::Account::Dispatch; + use MyCGIApp::DefaultApp; + + my $server = CGI::Application::Server->new(); + + my $object = MyOtherCGIApp->new(PARAMS => { foo => 1, bar => 2 }); + + $server->document_root('./htdocs'); + $server->entry_points({ + '/' => 'MyCGIApp::DefaultApp', + '/index.cgi' => 'MyCGIApp', + '/admin' => 'MyCGIApp::Admin', + '/account' => 'MyCGIApp::Account::Dispatch', + '/users' => $object, + '/static' => '/usr/local/htdocs', + }); + $server->run(); + +=head1 DESCRIPTION + +This is a simple HTTP server for for use during development with +L. At this moment, it serves our needs in a +very basic way. The plan is to release early and release often, +and add features when we need them. That said, we welcome any +and all patches, tests and feature requests (the ones with which +are accompanied by failing tests will get priority). + +=head1 METHODS + +=over 4 + +=item B + +This acts just like C for L, except it +will initialize instance slots that we use. + +=item B + +This will check the request uri and dispatch appropriately, either +to an entry point, or serve a static file (html, jpeg, gif, etc). + +=item B + +This accepts a HASH reference in C<$entry_points>, which maps server entry +points (uri) to L or L class +names or objects or to directories from which static content will be served +by HTTP::Server::Simple::Static. See the L above for examples. + +=item B + +This attempts to match the C<$uri> to an entry point. + +=item B + +This is the server's document root where all static files will +be served from. + +=back + +=head1 CAVEATS + +This is a subclass of L and all of its caveats +apply here as well. + +=head1 BUGS + +All complex software has bugs lurking in it, and this module is no +exception. If you find a bug please either email me, or add the bug +to cpan-RT. + +=head1 CODE COVERAGE + +I use L to test the code coverage of my tests, below +is the L report on this module's test suite. + + ---------------------------- ------ ------ ------ ------ ------ ------ ------ + File stmt bran cond sub pod time total + ---------------------------- ------ ------ ------ ------ ------ ------ ------ + ...CGI/Application/Server.pm 94.4 80.0 53.3 100.0 100.0 100.0 88.3 + Total 94.4 80.0 53.3 100.0 100.0 100.0 88.3 + ---------------------------- ------ ------ ------ ------ ------ ------ ------ + +=head1 ACKNOWLEDGEMENTS + +=over 4 + +=item The HTTP response handling was shamelessly stolen from L by chansen + +=back + +=head1 AUTHOR + +Stevan Little Estevan@iinteractive.comE + +Rob Kinyon Erob.kinyon@iinteractive.comE + +Ricardo SIGNES Erjbs@cpan.orgE + +=head1 COPYRIGHT AND LICENSE + +Copyright 2006 by Infinity Interactive, Inc. + +L + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/dev/server.pl b/dev/server.pl new file mode 100755 index 0000000..4b52789 --- /dev/null +++ b/dev/server.pl @@ -0,0 +1,28 @@ +#!/usr/bin/perl -CADS + +use strict; +use warnings; +use utf8; + +use dev::MyServer; +use lib 'lib'; +use Fripost::Panel::Interface; + +my $server = MyServer->new(); + +$server->entry_points({ + '/cgi-bin' => 'Fripost::Panel::Interface' +}); + +my @config = 'default.in'; +push @config, 'config.in' if -f 'config.in'; + +# TODO: This is only for testing purposes. Using a blessed target above +# prevents me from logging in. +$server->options({ + '/cgi-bin' => { + PARAMS => { cfg_file => [ @config ], format => 'equal' } + } +}); + +$server->run(); -- cgit v1.2.3