aboutsummaryrefslogtreecommitdiffstats
path: root/dev
diff options
context:
space:
mode:
Diffstat (limited to 'dev')
-rw-r--r--dev/MyServer.pm304
-rwxr-xr-xdev/server.pl28
2 files changed, 332 insertions, 0 deletions
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<CGI::Application>. 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<new ($port)>
+
+This acts just like C<new> for L<HTTP::Server::Simple>, except it
+will initialize instance slots that we use.
+
+=item B<handle_request>
+
+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<entry_points (?$entry_points)>
+
+This accepts a HASH reference in C<$entry_points>, which maps server entry
+points (uri) to L<CGI::Application> or L<CGI::Application::Dispatch> class
+names or objects or to directories from which static content will be served
+by HTTP::Server::Simple::Static. See the L<SYNOPSIS> above for examples.
+
+=item B<is_valid_entry_point ($uri)>
+
+This attempts to match the C<$uri> to an entry point.
+
+=item B<document_root (?$document_root)>
+
+This is the server's document root where all static files will
+be served from.
+
+=back
+
+=head1 CAVEATS
+
+This is a subclass of L<HTTP::Server::Simple> 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<Devel::Cover> to test the code coverage of my tests, below
+is the L<Devel::Cover> 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<HTTP::Request::AsCGI> by chansen
+
+=back
+
+=head1 AUTHOR
+
+Stevan Little E<lt>stevan@iinteractive.comE<gt>
+
+Rob Kinyon E<lt>rob.kinyon@iinteractive.comE<gt>
+
+Ricardo SIGNES E<lt>rjbs@cpan.orgE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+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();
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-22 02:06:25 +0000