@@ -1,3 +1,13 @@
+3.01 Fri Jun 20 19:46:26 2014
+ - Fixed test failures due to missing heredoc closing tags
+ in test scripts
+ - Some documentation touch-ups
+
+3.00 Thu Jun 12 18:19:37 2014
+ - Updated to accommodate for the changes in RPC::ExtDirect 3.0
+ - Many bug fixes, the bulk of the test data moved to the core
+ - More documentation
+
2.03 Tue Jun 10 20:02:18 2014
- Fixed a bug in CGI header handling that made HTTP response
output to be mangled sometimes with Perls 5.18+
@@ -1,5 +1,8 @@
Changes
examples/config/mime.types
+examples/htdocs/cgi-bin/api.cgi
+examples/htdocs/cgi-bin/poll.cgi
+examples/htdocs/cgi-bin/router.cgi
examples/htdocs/direct-form.html
examples/htdocs/direct-form.js
examples/htdocs/direct-grid.html
@@ -13,52 +16,40 @@ examples/htdocs/examples.js
examples/htdocs/index.html
examples/htdocs/named-arguments.html
examples/htdocs/named-arguments.js
+examples/p5httpd
lib/CGI/ExtDirect.pm
+lib/CGI/ExtDirect.pod
Makefile.PL
MANIFEST
README
+t/00_internal.t
t/01_api.t
t/02_router.t
t/03_poll.t
t/04_headers.t
t/05_env.t
-t/data/cgi-bin/api1.src
-t/data/cgi-bin/api2.src
-t/data/cgi-bin/api3.src
-t/data/cgi-bin/api4.src
-t/data/cgi-bin/header1.src
-t/data/cgi-bin/header2.src
-t/data/cgi-bin/header3.src
-t/data/cgi-bin/header4.src
-t/data/cgi-bin/poll1.src
-t/data/cgi-bin/poll2.src
-t/data/cgi-bin/poll3.src
-t/data/cgi-bin/poll4.src
-t/data/cgi-bin/poll5.src
-t/data/cgi-bin/router1.src
-t/data/cgi-bin/router2.src
-t/data/cgi-bin/router3.src
-t/data/cgi-bin/env.src
+t/cgi-bin/api1
+t/cgi-bin/api2
+t/cgi-bin/api3
+t/cgi-bin/api4
+t/cgi-bin/env
+t/cgi-bin/header1
+t/cgi-bin/header2
+t/cgi-bin/header3
+t/cgi-bin/header4
+t/cgi-bin/poll1
+t/cgi-bin/poll2
+t/cgi-bin/poll3
+t/cgi-bin/poll4
+t/cgi-bin/poll5
+t/cgi-bin/router1
+t/cgi-bin/router2
+t/cgi-bin/router3
t/data/cgi-data/bar.png
t/data/cgi-data/foo.jpg
t/data/cgi-data/qux.txt
t/data/cgi-data/script.js
-t/data/examples/cgi-bin/api.src
-t/data/examples/cgi-bin/poll.src
-t/data/examples/cgi-bin/router.src
-t/data/examples/p5httpd.src
-t/data/extdirect/api
-t/data/extdirect/poll
-t/data/extdirect/route
-t/data/extdirect/env
-t/lib/RPC/ExtDirect/Test/Bar.pm
-t/lib/RPC/ExtDirect/Test/Foo.pm
-t/lib/RPC/ExtDirect/Test/JuiceBar.pm
-t/lib/RPC/ExtDirect/Test/PollProvider.pm
-t/lib/RPC/ExtDirect/Test/Qux.pm
-t/lib/RPC/ExtDirect/Test/Env.pm
+t/lib/RPC/ExtDirect/Test/Util/CGI.pm
t/pod.t
-t/cgi-bin/.placeholder
-examples/htdocs/cgi-bin/.placeholder
META.yml Module YAML meta-data (added by MakeMaker)
META.json Module JSON meta-data (added by MakeMaker)
@@ -1,10 +1,10 @@
{
"abstract" : "RPC::ExtDirect gateway for CGI",
"author" : [
- "Alexander Tokarev <tokarev@cpan.org>"
+ "Alex Tokarev <tokarev@cpan.org>"
],
"dynamic_config" : 1,
- "generated_by" : "ExtUtils::MakeMaker version 6.84, CPAN::Meta::Converter version 2.132661",
+ "generated_by" : "ExtUtils::MakeMaker version 6.98, CPAN::Meta::Converter version 2.140640",
"license" : [
"perl_5"
],
@@ -22,8 +22,8 @@
"prereqs" : {
"build" : {
"requires" : {
- "CGI::Test" : "0.3",
- "Test::More" : "0"
+ "CGI::Test" : "0.32",
+ "Test::More" : "0.82"
}
},
"configure" : {
@@ -33,7 +33,9 @@
},
"runtime" : {
"requires" : {
- "RPC::ExtDirect" : "2.02"
+ "CGI" : "0",
+ "RPC::ExtDirect" : "3.01",
+ "perl" : "5.006"
}
}
},
@@ -46,5 +48,5 @@
"url" : "http://github.com/nohuhu/CGI-ExtDirect"
}
},
- "version" : "2.03"
+ "version" : "3.01"
}
@@ -1,26 +1,28 @@
---
abstract: 'RPC::ExtDirect gateway for CGI'
author:
- - 'Alexander Tokarev <tokarev@cpan.org>'
+ - 'Alex Tokarev <tokarev@cpan.org>'
build_requires:
- CGI::Test: 0.3
- Test::More: 0
+ CGI::Test: '0.32'
+ Test::More: '0.82'
configure_requires:
- ExtUtils::MakeMaker: 0
+ ExtUtils::MakeMaker: '0'
dynamic_config: 1
-generated_by: 'ExtUtils::MakeMaker version 6.84, CPAN::Meta::Converter version 2.132661'
+generated_by: 'ExtUtils::MakeMaker version 6.98, CPAN::Meta::Converter version 2.140640'
license: perl
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
- version: 1.4
+ version: '1.4'
name: CGI-ExtDirect
no_index:
directory:
- t
- inc
requires:
- RPC::ExtDirect: 2.02
+ CGI: '0'
+ RPC::ExtDirect: '3.01'
+ perl: '5.006'
resources:
bugtracker: http://github.com/nohuhu/CGI-ExtDirect/issues
repository: http://github.com/nohuhu/CGI-ExtDirect
-version: 2.03
+version: '3.01'
@@ -1,73 +1,62 @@
use 5.006000;
use ExtUtils::MakeMaker;
-# First prepare test and example cgi scripts
-my $perl = $^X;
+# Add the `devtest` target to run regression and POD tests in one go
+sub MY::postamble {
+ return <<'END';
+devtest :
+ REGRESSION_TESTS=1 POD_TESTS=1 $(MAKE) test
-my $we_are_unixy = $^O !~ /DOS|Win32|VMS/;
+END
+}
-my @dirs = ( [ 't/data/cgi-bin', 't/cgi-bin', ],
- [ 't/data/examples/cgi-bin', 'examples/htdocs/cgi-bin', ],
- [ 't/data/examples', 'examples', ],
-);
-
-while ( @dirs ) {
- my ($src_dir, $dst_dir) = @{ shift @dirs };
-
- system "mkdir -p $dst_dir" if $we_are_unixy;
-
- my @files = glob "$src_dir/*.src";
-
- for my $file ( @files ) {
- local $/;
-
- open my $fh, '<', $file or die "Can't open $file for reading: $!";
- my $script = <$fh>;
- close $fh;
+# Override `disttest` so it would behave as `devtest`
+sub MY::dist_test {
+ return <<'END';
+disttest : distdir
+ cd $(DISTVNAME) && $(ABSPERLRUN) Makefile.PL
+ cd $(DISTVNAME) && $(MAKE) $(PASTHRU)
+ cd $(DISTVNAME) && $(MAKE) devtest $(PASTHRU)
- die "Can't find Perl placeholder in script $file!"
- unless $script =~ s/\A#!PUT_PERL_HERE/#!$perl/ms;
+END
+}
- my ($fname) = $file =~ ( m{ \A .* [\/] (.*?) \.src \z }ixms );
- my $dest_name = $fname eq 'p5httpd' ? "$dst_dir/$fname.pl"
- : "$dst_dir/$fname.cgi"
- ;
+my $MM_VERSION = $ExtUtils::MakeMaker::VERSION;
- open $fh, '>', $dest_name or
- die "Can't open $dest_name for writing: $!";
- print $fh $script;
- close $fh;
-
- system "chmod +x $dest_name" if $we_are_unixy;
- };
-};
-
-# Finally, write Makefile
WriteMakefile(
NAME => 'CGI::ExtDirect',
- VERSION_FROM => 'lib/CGI/ExtDirect.pm', # finds $VERSION
- ($ExtUtils::MakeMaker::VERSION >= 6.55
+ VERSION_FROM => 'lib/CGI/ExtDirect.pm',
+ ($MM_VERSION >= 6.55
? ( BUILD_REQUIRES => {
- 'Test::More' => 0,
- 'CGI::Test' => '0.3',
+ 'Test::More' => '0.82',
+ 'CGI::Test' => '0.32',
},
PREREQ_PM => {
- 'RPC::ExtDirect' => '2.02',
+ # 5.20 warns that CGI is going to be removed from
+ # perl distro in 5.22, so we require it here
+ 'CGI' => 0,
+ 'RPC::ExtDirect' => '3.01',
},
)
: ( PREREQ_PM => {
- 'Test::More' => 0,
- 'CGI::Test' => '0.3',
- 'RPC::ExtDirect' => '2.02',
+ 'Test::More' => '0.82', # for explain()
+ 'CGI::Test' => '0.32',
+ 'CGI' => 0,
+ 'RPC::ExtDirect' => '3.01',
},
)
),
- ($] >= 5.005 ? ## Add these new keywords supported since 5.005
- (ABSTRACT => 'RPC::ExtDirect gateway for CGI',
- AUTHOR => 'Alexander Tokarev <tokarev@cpan.org>',
- LICENSE => 'perl') : ()),
- ($ExtUtils::MakeMaker::VERSION >= 6.46
+ ABSTRACT => 'RPC::ExtDirect gateway for CGI',
+ AUTHOR => 'Alex Tokarev <tokarev@cpan.org>',
+ LICENSE => 'perl',
+
+ ($MM_VERSION >= 6.48
+ ? ( MIN_PERL_VERSION => 5.006000 )
+ : (),
+ ),
+
+ ($MM_VERSION >= 6.46
? ( META_MERGE => {
resources => {
bugtracker => 'http://github.com/nohuhu/CGI-ExtDirect/issues',
@@ -77,9 +66,5 @@ WriteMakefile(
)
: ()
),
-
- clean => { FILES => 'examples/p5httpd.pl '.
- 'examples/htdocs/cgi-bin/*.cgi '.
- 't/cgi-bin/*.cgi' },
);
@@ -1,63 +1,59 @@
CGI::ExtDirect
==============
-This module implement RPC::ExtDirect gateway for CGI environment.
-It was successfully tested with Perl 5.6 and newer in Apache CGI
-and HTTP::Server::Simple::CGI applications.
+ This module provides an RPC::ExtDirect gateway implementation for CGI
+ compatible Web server environments. This includes both traditional CGI
+ scripts that start up anew for each HTTP request, as well as more modern
+ CGI environments in which a script is started once and then persists
+ through the lifetime of a server process.
-In fact, CGI::ExtDirect is dependent on only two non-core modules:
-Attribute::Handlers and JSON, both of which support Perl 5.6 and
-are pure Perl modules. Test suite is based on CGI::Test which is
-only used for testing; it is not needed for normal operation and
-in some cases may be skipped.
+ CGI::ExtDirect can be used wth Perl versions 5.6 and newer with many Web
+ servers; it was tested successfully with Apache/mod_perl, pure Perl
+ server based on HTTP::Server::Simple (RPC::ExtDirect::Server), and
+ various other HTTP server environments.
-What this means is that now there is an easy way to provide older CGI
-applications that are unfeasible (or plain impossible) to refactor
-with simple and easy to use interface to one of the most advanced
-JavaScript frameworks available.
-
-RPC::ExtDirect is an implementation of Ext.Direct remoting protocol
-used in Sencha Inc. ExtJS JavaScript framework.
-
-For more information, see RPC::ExtDirect documentation.
-
-For a simple example on how to use CGI::ExtDirect, see
-example/ directory.
+ If you are not familiar with Ext.Direct, more information can be found
+ in RPC::ExtDirect::Intro.
INSTALLATION
-To install this module type the following:
+ To install this module type the following:
- perl Makefile.PL
- make
- make test
- make install
+ perl Makefile.PL
+ make && make test
+ make install
-To run examples type the following:
+EXAMPLES
- cd examples
- ./p5httpd.pl
+ See included Ext JS examples for ideas on what Ext.Direct is and how to
+ use it in CGI applications. The examples are not installed along with
+ the CGI::ExtDirect module, and are only available in the `examples/'
+ directory of the CPAN distribution.
-Note that examples will work only after 'make && make test' but
-they do not require CGI::ExtDirect to be installed so you can try
-them before installing the module.
+ To run examples type the following in the CGI::ExtDirect tarball
+ directory:
-DEPENDENCIES
+ cd examples
+ perl p5httpd
-This module requires these other modules and libraries:
+ Note that these examples do not require CGI::ExtDirect to be installed
+ so you can try them beforehand. That said, CGI::ExtDirect depends on
+ RPC::ExtDirect being available in `@INC' so if you don't want to install
+ either module, unpack RPC::ExtDirect and CGI::ExtDirect tarballs to the
+ same directory and use `$PERL5LIB' to point to RPC::ExtDirect location:
- RPC::ExtDirect, JSON, Attribute::Handlers.
+ cd examples
+ PERL5LIB=../../RPC-ExtDirect-3.xx/lib perl p5httpd
COPYRIGHT AND LICENSE
-Copyright (C) 2011-2012 by Alexander Tokarev, <tokarev@cpan.org>
+ Copyright (c) 2011-2014 Alex Tokarev <tokarev@cpan.org>.
-This library is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself, either Perl version 5.6.0 or,
-at your option, any later version of Perl 5 you may have available.
+ This module is free software; you can redistribute it and/or modify it
+ under the same terms as Perl itself. See perlartistic.
-Included Ext JS examples are copyright (c) 2011, Sencha Inc. Example code
-is used and distributed under GPL 3.0 license as provided by Sencha Inc.
-See http://www.sencha.com/license. Ext JS is available for download at
-http://www.sencha.com/products/extjs/
+ Included Ext JS examples are copyright (c) 2011, Sencha Inc. Example
+ code is used and distributed under GPL 3.0 license as provided by Sencha
+ Inc. See http://www.sencha.com/license. Ext JS is available for download
+ at http://www.sencha.com/products/extjs/
diff --git a/var/tmp/source/TOKAREV/CGI-ExtDirect-2.03/CGI-ExtDirect-2.03/examples/htdocs/cgi-bin/.placeholder b/var/tmp/source/TOKAREV/CGI-ExtDirect-2.03/CGI-ExtDirect-2.03/examples/htdocs/cgi-bin/.placeholder
deleted file mode 100644
index e69de29b..00000000
@@ -0,0 +1,38 @@
+#!/bin/sh
+
+# The perl binary called below will need STDIN to read the script code;
+# that mangles the actual CGI input for the script. To avoid that,
+# we save STDIN here and reopen it later in the script.
+exec 3<&0
+
+# This construct is needed for the demo script to be executed by the
+# same perl binary as p5httpd. You do not have to use this technique
+# in your CGI scripts.
+$PERL -x <<'END_OF_SCRIPT'
+
+# The actual CGI script starts here
+#!perl
+
+use lib '../../../lib';
+
+# These modules provide demo Ext.Direct remoting and polling APIs
+use RPC::ExtDirect::Demo::TestAction;
+use RPC::ExtDirect::Demo::Profile;
+use RPC::ExtDirect::Demo::PollProvider;
+
+use RPC::ExtDirect::Config;
+use CGI::ExtDirect;
+
+open STDIN, '<&=', 3 or die "Can't reopen STDIN";
+
+my $config = RPC::ExtDirect::Config->new(
+ router_path => '/cgi-bin/router.cgi',
+ poll_path => '/cgi-bin/poll.cgi',
+);
+
+my $direct = CGI::ExtDirect->new( config => $config );
+
+print $direct->api();
+
+exit 0;
+
@@ -0,0 +1,30 @@
+#!/bin/sh
+
+# The perl binary called below will need STDIN to read the script code;
+# that mangles the actual CGI input for the script. To avoid that,
+# we save STDIN here and reopen it later in the script.
+exec 3<&0
+
+# This construct is needed for the demo script to be executed by the
+# same perl binary as p5httpd. You do not have to use this technique
+# in your CGI scripts.
+$PERL -x <<'END_OF_SCRIPT'
+
+# The actual CGI script starts here
+#!perl
+
+use lib '../../../lib';
+
+# This module provides demo Ext.Direct polling API
+use RPC::ExtDirect::Demo::PollProvider;
+
+use CGI::ExtDirect;
+
+open STDIN, '<&=', 3 or die "Can't reopen STDIN";
+
+my $direct = CGI::ExtDirect->new();
+
+print $direct->poll();
+
+exit 0;
+
@@ -0,0 +1,34 @@
+#!/bin/sh
+
+# The perl binary called below will need STDIN to read the script code;
+# that mangles the actual CGI input for the script. To avoid that,
+# we save STDIN here and reopen it later in the script.
+exec 3<&0
+
+# This construct is needed for the demo script to be executed by the
+# same perl binary as p5httpd. You do not have to use this technique
+# in your CGI scripts.
+$PERL -x <<'END_OF_SCRIPT'
+
+# The actual CGI script starts here
+#!perl
+
+use lib '../../../lib';
+
+# These modules provide demo Ext.Direct remoting API
+use RPC::ExtDirect::Demo::TestAction;
+use RPC::ExtDirect::Demo::Profile;
+
+use RPC::ExtDirect::Config;
+use CGI::ExtDirect;
+
+open STDIN, '<&=', 3 or die "Can't reopen STDIN";
+
+my $direct = CGI::ExtDirect->new(
+ config => RPC::ExtDirect::Config->new( verbose_exceptions => 1 ),
+);
+
+print $direct->route();
+
+exit 0;
+
@@ -0,0 +1,979 @@
+require 5.6.0; # needs perl > 5.6.0
+
+# This points to current blib so that freshly built CGI::ExtDirect
+# can be found and examples could be tried without installing the
+# module
+
+use lib '../blib/lib';
+
+# p5httpd: Tiny HTTP server, roughly HTTP 1.0 compliant according to
+# RFC 1945
+# - POD documentation at end of file
+# - User-serviceable configuration section below.
+# - Should work without configuration and without any additional files
+
+
+package p5httpd; # keep namespace separate from CGI scripts
+use strict;
+our $version = 0.07;
+
+################# Configuration section #######################
+
+# All filenames below have to be absolute (except $icondir).
+
+# A value of "" means that there is a reasonable default, which may
+# depend on the installation directory.
+
+# If $configdir/config_$osname exists, it is read after this
+# configuration section
+
+# ----------------- Basic configuration -----------------------
+
+# The server root directory is the place where requests for
+# http://this_host/ will look:
+# Default: ./html under the directory where p5httpd lives
+
+our $server_root = "./htdocs";
+
+# Config files are better kept in a separate directory, to avoid
+# clutter and to avoid worsening p5httpd's already dismal security :-)
+# Default: $server_root/../config
+
+our $config_dir = "";
+
+# The port on which p5httpd will listen. NB: ports below 1024 require
+# root privileges on unix machines! Default: 80
+
+our $port = 5000;
+
+# List of mime types (absolute pathname). You may use apaches
+# mime.types, or /etc/mime.types on unix machines. Default:
+# $configdir/mime.types, or else a minimal builtin list.
+
+our $mime_types = "";
+
+
+# Handlers associate a specal cgi script in cgi-bin directory with
+# specific mime-types
+our %handlers ; # = ("text/xml" => "xml.cgi");
+
+# Which filenames to treat as index files
+# Default: none
+
+our @index_filenames = qw(index.htm index.html);
+
+# ------------------ Forking and executing ------------------------
+
+# Forking policy. $never_fork and $fork_always do just what they say,;
+# $fork_after_first_invocation will cause the server to fork akways *except*
+# the first time a particular cgi script is run. This will ensure that
+# all needed modules are already loaded whenever the script is run
+# again, just as with mod_perl.
+
+my ( $never_fork, $fork_after_first_invocation, $fork_always ) = ( 1, 2, 3 );
+our $when_to_fork = $never_fork;
+
+# if a relative path matches this regexp (case-insensitively), it is
+# treated as a cgi script, and we'll try to eval or execute it.
+# Default: "\.cgi$" (matching any file with extension .cgi)
+# other possibilities: "\.pl$" or "\.(cgi|pl)$" or "\/cgi-bin\/"
+
+our $cgi_scriptname_regexp = '';
+
+# Whether to run cgi scripts by evaling or executing. $cgis_are_evaled
+# and $cgis_are_executed do just what they say, $only_perl_is_evaled
+# will run perl scripts by evaling and any other programs by executing
+# them. This is a tad expensive, as all cgi's have to
+# be sniffed and tasted before they are run.
+
+my ( $cgis_are_evaled, $only_perl_is_evaled, $cgis_are_executed ) = ( 1, 2, 3 );
+our $eval_or_execute = $cgis_are_executed;
+
+# -------------------- Icons -------------------------------------
+
+# Whether to show icons in a directory listing
+our $show_icons = 1;
+
+# icon directory, relative to $server_root. Default: "icons"
+our $icondir = ""; # relative name here!
+
+# -------------------- Authentication ---------------------------
+
+# Whether to use basic authentication as per HTTP/1.0
+# Only enable this when really needed, as it makes all requests slower
+our $use_authentication = 0;
+
+# Default: $config_dir/htpasswd
+our $password_file = "";
+
+# For every request, p5httpd will climb up the directory tree until it
+# finds either an explicitely public or a private directory. This will
+# determine whether a password is required. Default: Everything is private,
+# i.e. @public_directories = (), @private_directories = qw(/).
+# Directories are specified relative to server root, but you still
+# have to use leading and trailing slashes here:
+
+our @public_directories = qw(/);
+our @private_directories = qw(/wiki/secret/);
+
+############## End of configuration section ########################
+
+use Socket;
+use English;
+use Cwd qw(cwd abs_path);
+use autouse 'IPC::Open2' => qw( open2 );
+; # only import when needed, as EPOC (and maybe Windows?) doesn't have it.
+
+our (
+ $localname, $OSNAME, $HOSTNAME, $I_am_child,
+ %mime_types, %cgi_urls, %encrypted_passwords, %private,
+ %public, $invocation, $p5httpd_homedir
+);
+
+initialise();
+main_loop();
+exit;
+
+################################## Subroutines ###################
+
+sub logerr($$);
+sub logmsg($);
+sub log_and_die($);
+sub cat($$;$); # forward declarations
+
+sub initialise {
+ $HOSTNAME = $ENV{HOSTNAME} || "localhost";
+ $I_am_child = 0
+ ; # Will be 1 in child after a fork(). Children wil just exit after finishing work.
+
+
+ $PROGRAM_NAME =~ s#\\#/#g;
+ ($p5httpd_homedir) = ( $PROGRAM_NAME =~ m#^(.*)/# );
+ $p5httpd_homedir ||= cwd; # last resort
+ $p5httpd_homedir = abs_path($p5httpd_homedir);
+ $p5httpd_homedir =~ s#/$##;
+
+ my $extra_config_dir;
+ if ($config_dir) {
+ $extra_config_dir = $config_dir;
+ }
+ elsif ($server_root) {
+ $extra_config_dir = "$server_root/../config";
+ }
+ elsif ( -d "$p5httpd_homedir/config" ) {
+ $extra_config_dir = "$p5httpd_homedir/config";
+ }
+ else {
+ $extra_config_dir = $p5httpd_homedir;
+ }
+ my $extra_config_file = "$extra_config_dir/config_$OSNAME";
+ if ( -r $extra_config_file ) {
+ logmsg "Reading $extra_config_file";
+ do $extra_config_file;
+ $@ and logmsg "Something rotten in $extra_config_file: \n$@";
+ }
+ elsif ( -f $extra_config_file ) {
+ logmsg "$extra_config_file exists but not readable: $!";
+ }
+ else {
+# logmsg "looked for, but didn't find extra config in $extra_config_file";
+ }
+
+ # If $config_dir is still unset, set it now
+ $config_dir ||= $extra_config_dir;
+ push @INC, "$config_dir/modules"; # extra modules may be put here, and
+ $ENV{PERL5LIB} = ( $ENV{PERL5LIB}? "$ENV{PERL5LIB}:$config_dir/modules" : "$config_dir/modules"); # ... let children know about this
+
+ if ( not $server_root ) {
+ $server_root = (
+ -d "$p5httpd_homedir/html" ? "$p5httpd_homedir/html" : $p5httpd_homedir );
+ logmsg "You didn't specify the server root directory ";
+ logmsg "I'll use $server_root for now...";
+ }
+ $server_root =~ s#/$##; # remove final slash from $basdir
+
+ $p5httpd::server_root =
+ $server_root; # make this variable visible for CGI scripts
+
+ $port ||= 80 unless $port;
+ $password_file ||= "$config_dir/htpasswd"; # absolute path
+ $mime_types ||= "$config_dir/mime.types"; # absolute path
+ $icondir ||= 'icons'; # relative to $server_root
+ $cgi_scriptname_regexp ||= '\.cgi$';
+
+ if ( $mime_types and open MIME, $mime_types ) {
+ while (<MIME>) { # read list of mime types
+ chomp;
+ s/#.*//; # ignore comments
+ my ( $type, @suffixes ) = split;
+ next unless @suffixes;
+ foreach my $suffix (@suffixes) {
+ $mime_types{".$suffix"} = $type; # e.g " $mime_types{.png} = "image/png"
+ }
+ }
+ close MIME;
+ }
+ else {
+ logmsg(
+ (
+ $mime_types
+ ? "Couldn't read MIME types file $mime_types."
+ : "No MIME types configured"
+ )
+ . " Using a minimal set instead"
+ );
+ %mime_types = (
+ ".gif" => "image/gif",
+ ".jpg" => "image/jpeg",
+ ".htm" => "text/html",
+ ".html" => "text/html"
+ );
+ }
+
+ if ($use_authentication) { # read passwords
+ open PASS, $password_file
+ or log_and_die "Couldn't read password file $password_file: $!\n";
+ while (<PASS>) {
+ s/\s//g;
+ next if /^#/; # comments in a passwd file? Hmmm...
+ my ( $name, $encrypted_password ) = split /:/;
+ $encrypted_passwords{$name} = $encrypted_password
+ if $encrypted_password;
+ }
+ close PASS;
+
+ # initialise directory hashes
+ foreach my $dir (@public_directories) { $public{$dir} = 1; }
+ foreach my $dir (@private_directories) { $private{$dir} = 1; }
+ }
+
+ unless ( $when_to_fork == $never_fork ) {
+ logmsg "Setting SIG{CHLD} to 'IGNORE'";
+ $SIG{CHLD} = 'IGNORE'
+ ; # We don't care about children's exit status, we just don't want zombies
+ }
+
+}
+
+sub main_loop {
+
+ # Standard Perl incantation for creating a server socket:
+ my $tcp = getprotobyname('tcp');
+ socket( Server, PF_INET, SOCK_STREAM, $tcp ) or log_and_die "socket: $!";
+ setsockopt( Server, SOL_SOCKET, SO_REUSEADDR,
+ pack( "l", 1 ) ) # to prevent "address in use" errors
+ or $OSNAME =~ /EPOC/i or logmsg " Warning: setsockopt: $!";
+ if ( not bind( Server, sockaddr_in( $port, INADDR_ANY ) ) ) {
+ log_and_die(
+ $port < 1024
+ ? " bind: $! (ports below 1024 require root privs on unix-like systems)\n"
+ : "bind: $!\n"
+ );
+ }
+ listen( Server, SOMAXCONN ) or log_and_die " listen: $!";
+ logmsg
+ "Server started on port $port.\n\nPoint your browser at http://$HOSTNAME"
+ . ( $port == 80 ? "" : ":$port" );
+
+CONNECT:
+ for ( ; accept( Client, Server ) ; close Client ) {
+
+ my $remote_sockaddr = getpeername(Client);
+ my ( undef, $iaddr ) = sockaddr_in($remote_sockaddr);
+ my $peername = gethostbyaddr( $iaddr, AF_INET ) || "localhost";
+ my $peeraddr = inet_ntoa($iaddr) || "127.0.0.1";
+
+ my $local_sockaddr = getsockname(Client);
+ my ( undef, $iaddr_local ) = sockaddr_in($local_sockaddr);
+ $localname = gethostbyaddr( $iaddr_local, AF_INET ) || "localhost";
+ my $localaddr = inet_ntoa($iaddr_local) || "127.0.0.1";
+
+ $INPUT_RECORD_SEPARATOR =
+ "\n"; # input record separator should be \n here (the default)
+ $OUTPUT_AUTOFLUSH = 1;
+
+ chomp( $_ = <Client> ); # get Request-Line
+ my ( $method, $url, $proto, undef ) =
+ split; # parse it
+
+ if ( not $proto ) { # Whoa! HTTP 0.9 here
+ print Client
+"<html><head></head><body> <H1>This server doesn't speak HTTP 0.9!</H1> </body></html>";
+ next CONNECT;
+ }
+ $url =~ s#\\#/#g; # rewrite bla\sub as bla/sub
+ logmsg "<- $peername: $_";
+ my ( $abs_path, undef, $arglist ) =
+ ( $url =~ /([^?]*)(\?(.*))?/ ); # split at ?
+
+# An "absolute path" in RFC 1945-speak denotes a file *relative* to the server root!
+ if ( $abs_path !~ m#^/# ) {
+ logmsg "Whoa! an absolute path should begin with a slash /";
+ $abs_path = "/$abs_path";
+ }
+
+ my $path_info;
+ if ( not $arglist and $abs_path =~ m#(.*?\.cgi)/(.+)#i ) {
+ redirect("$1?$2");
+ next CONNECT;
+ }
+ my $abs_path_escaped = $abs_path; # keep a copy of filename with escapes
+ $abs_path =~ s/%([\dA-Fa-f]{2})/chr(hex($1))/eg; # %20 -> space
+
+ fork_if_necessary($abs_path)
+ and next CONNECT
+ ; # if we have indeed forked, the child will handle the request and we can move on...
+
+ if ( $method !~ /^(GET|POST|HEAD)$/ ) {
+ logerr 501, "I don't understand method $method";
+ exit if $I_am_child;
+ next CONNECT;
+ }
+
+ my ( $user, $passphrase );
+ $ENV{USER_AGENT} = $ENV{CONTENT_LENGTH} = $ENV{CONTENT_TYPE} = undef;
+ while (<Client>)
+ { # gobble up all remaining headers and notice the relevant ones:
+ s/[\r\l\n\s]+$//;
+ /^User-Agent: (.+)/i and $ENV{USER_AGENT} = $1;
+ /^Content-length: (\d+)/i and $ENV{CONTENT_LENGTH} = $1;
+ /^Content-type: (.+)/i and $ENV{CONTENT_TYPE} = $1;
+ /^Authorization:\s+Basic\s+(.+)/i and $passphrase = $1;
+
+ if (/^HTTP-(.+?): (.+)/i)
+ { # any header like HTTP-Blah-Gurgle is put in BLAH_GURGLE
+ my $environment_variable = uc($1);
+ $environment_variable =~ s/-/_/g;
+ $ENV{$environment_variable} = $2;
+ }
+
+ # We don't honour If-Modified-Since
+ last if (/^$/);
+
+ }
+
+ if ($use_authentication) {
+ $user = authorized( $abs_path, $passphrase );
+ if ( not defined $user )
+ { # $abs_path is private, and authentication failed
+ challenge( "p5httpd", $abs_path );
+ exit if $I_am_child;
+ next CONNECT;
+ }
+ }
+ if ( -d "$server_root$abs_path" ) {
+ unless ( $abs_path =~ m#/$# ) { # does $abs_path end with a slash ?
+ redirect("$abs_path/"); # no? redirect to $abs_path/
+ exit if $I_am_child;
+ next CONNECT;
+ }
+
+ # we can from now on assume that $abs_path ends with a slash
+
+ my $do_listing = 1;
+ foreach my $index (@index_filenames)
+ { # check for existence of an index page
+ if ( -f "$server_root$abs_path$index" ) {
+ $abs_path .= $index;
+ $do_listing = 0;
+ last;
+ }
+ }
+ if ($do_listing) { # no index found, do directory listing
+ directory_listing($abs_path);
+ exit if $I_am_child;
+ next CONNECT;
+ }
+ } # if (-d "$server_root$abs_path"
+
+ if ( not -r "$server_root$abs_path" ) { # check for existence of abs_path
+ logerr 404, "$abs_path: $!";
+ exit if $I_am_child;
+ next CONNECT;
+ }
+
+ print Client "HTTP/1.0 200 OK\n"; # probably OK by now
+
+ my $mime_type = filetype($abs_path);
+
+ my $handler = $handlers{$mime_type};
+
+ if ($handler) { # call handler
+ $arglist = "file=$abs_path";
+ $abs_path = "/cgi-bin/$handler";
+ $mime_type = "application/cgi";
+ $url = "$abs_path?$arglist";
+ $method = "GET";
+ }
+
+ if ( $mime_type eq "application/cgi" )
+ { # cf. the specification at http://hoohoo.ncsa.uiuc.edu/cgi/env.html
+ $ENV{SERVER_SOFTWARE} = "p5httpd/$version";
+ $ENV{SERVER_NAME} = $localname;
+ $ENV{GATEWAY_INTERFACE} = "CGI/1.1";
+ $ENV{SERVER_PROTOCOL} = $proto;
+ $ENV{SERVER_PORT} = $port;
+ $ENV{REQUEST_METHOD} = $method;
+ $ENV{PATH_INFO} = $path_info;
+
+ # $ENV{PATH_TRANSLATED} = Ehrrm....??
+ $ENV{SCRIPT_NAME} = $abs_path;
+ $ENV{QUERY_STRING} = $arglist;
+ $ENV{REMOTE_HOST} = $peername;
+ $ENV{REMOTE_ADDR} = $peeraddr;
+ $ENV{AUTH_TYPE} = ( $use_authentication ? "Basic" : "" );
+ $ENV{REMOTE_USER} = ( $use_authentication ? $user : "" );
+ $ENV{SERVER_URL} = "http://$localname:$port/";
+ $ENV{SCRIPT_FILENAME} = "$server_root$abs_path";
+ $ENV{REQUEST_URI} = $url;
+ $ENV{SERVER_ROOT} = $server_root; # non-standard?
+ $ENV{PERL} = $^X; # definitely non-standard ;)
+ $ENV{PERL5LIB}
+ = join ':', map { -e $_ ? abs_path($_) : $_ } @INC;
+
+ if ( $method =~ /POST/ ) {
+ logmsg
+ "<- Content-length: $ENV{CONTENT_LENGTH}, type: $ENV{CONTENT_TYPE}";
+ }
+ cgi_run( $abs_path, $arglist, $method );
+ exit if $I_am_child;
+ next CONNECT;
+ }
+
+
+ cat $abs_path, $mime_type, $method || logerr 500, "$abs_path: $!";
+ exit if $I_am_child;
+ next CONNECT;
+ }
+ log_and_die "$$ Fatal error: accept failed: $!\n"; # This should never happen
+}
+
+#################### other subroutines ####################
+
+# fork_if_necessary() inspects $when_to_fork and forks when it thinks it should.
+# This may involve keeping track of cgi script invocations when
+# $when_to_fork == $fork_after_first_invocation
+# Return value: 0 in child, when forking is not necessary, or after failure;
+# child pid in parent
+
+sub fork_if_necessary {
+ my ($file) = @_;
+ my $pid = 0;
+ if ( # always fork, or second or later invocation of .cgi script?
+ $when_to_fork == $fork_always
+ or ( $when_to_fork != $never_fork
+ and ( filetype($file) ne "application/cgi" or $cgi_urls{$file}++ ) )
+ )
+ {
+ eval {$pid = fork()};
+ if ( $@ or $pid < 0 ) {
+ warn
+ "Couldn't fork now and won't try again (can your OS ever do it?): $@";
+ $when_to_fork = $never_fork;
+ return 0;
+ }
+ $I_am_child = 1 unless $pid;
+ }
+ return $pid;
+}
+
+# logmsg "Couldn't frob the gnargle: $!"; logs a time-stamped message,
+# folowed by newline, to STDERR. No return value.
+
+sub logmsg ($) {
+ my ($text) = (@_);
+ my $fulltime = localtime();
+ my $PID = sprintf "%5d", $$;
+ my ($hms) = ( $fulltime =~ /(\d\d:\d\d:\d\d)/ );
+ my @text = split /\n/, $text;
+ foreach my $line (@text) {
+ print STDERR "$PID $hms $line\n";
+ }
+}
+
+sub log_and_die ($) {
+ my ($text) = (@_);
+ logmsg "FATAL: $text";
+ die "\n";
+}
+
+# logerr 404, "No gnargles here, sorry!"; signals error to browser,
+# logging it to STDERR as well. No return value.
+
+sub logerr ($$) {
+ my ( $code, $detail ) = @_;
+ my %codes = (
+ 200 => 'OK',
+ 400 => 'Bad Request',
+ 403 => 'Access Denied',
+ 404 => 'Not Found',
+ 500 => 'Internal Server Error',
+ 501 => 'Not Implemented',
+ );
+ my $msg = "$code " . $codes{$code};
+ logmsg "-> $msg $detail";
+ print Client <<EOF;
+ HTTP/1.0 $msg
+ Content-type: text/html
+
+ <html><body>
+ <h1>$msg</h1>
+ <p>$detail</p>
+ <hr>
+ <p><I>p5httpd/$version server at $localname port $port</I></p>
+ </body></html>
+EOF
+}
+
+# cat "relative/path", "text/html", $method; writes the appropriate
+# response headers to STDOUT. If $method == GET (which is the default)
+# then the file is dumped on STDOUT as well.
+
+sub cat($$;$) {
+ my ( $file, $mimetype, $method ) = @_;
+ $method = "GET" unless $method;
+ my $fullpath = "$server_root$file";
+
+ my ( undef, undef, undef, undef, undef, undef, undef, $length, undef, $mtime )
+ = stat($fullpath);
+ $mtime = gmtime $mtime;
+ my ( $day, $mon, $dm, $tm, $yr ) =
+ ( $mtime =~ m/(...) (...) (..) (..:..:..) (....)/ );
+
+ print Client "Content-length: $length\n";
+ print Client "Last-Modified: $day, $dm $mon $yr $tm GMT\n";
+ print Client "Content-type: $mimetype\n\n";
+ my $sent = 0;
+ if ( $method eq "GET" ) {
+ local $INPUT_RECORD_SEPARATOR = undef; # gobble whole files, but only here
+ open IN, "<$fullpath" || return 0;
+ my $content = <IN>;
+ close IN;
+ $sent = length($content);
+ print Client $content;
+ }
+ logmsg "-> 200 OK $file: $sent bytes sent as $mimetype";
+ return 1;
+}
+
+# cgi_run("relative/path.cgi", "encoded%20arglist", $method) changes to directory
+# where script lives, and then either evals or executes it.
+
+sub cgi_run {
+ my ( $script, $arglist, $method ) = @_;
+ my ($dir) = ( $script =~ /^(.*\/)/ );
+ my $script_path = "$server_root$script";
+ my $script_text;
+ my $old_chdir = cwd();
+ chdir "$server_root$dir"
+ or return logerr 500, "Cannot chdir to $server_root$dir: $!";
+ $script_path =~ s/[A-Z]://;
+
+# command line decoding, cf description at http://hoohoo.ncsa.uiuc.edu/cgi/cl.html:
+ local @ARGV;
+ unless ( $arglist =~ /=/ ) {
+ $arglist =~
+ s/%([\dA-Fa-f]{2})/chr(hex($1))/eg; # decode arglist, e.g. %20 -> space
+ @ARGV = split /\s+/, $arglist;
+ }
+ my $file_tastes_like_perl = 1;
+ if ( $eval_or_execute != $cgis_are_executed ) {
+
+ open CGI, $script_path
+ or return do {
+ chdir $old_chdir;
+ logerr 500, "Cannot read $script_path: $!";
+ };
+ my ( $script_text, $nread );
+ if ( $eval_or_execute == $only_perl_is_evaled ) {
+ logmsg "sniffing and tasting $script...";
+ $nread = read CGI, $script_text, 100, 0; # taste first 100 bytes
+ defined $nread
+ or return do {
+ chdir $old_chdir;
+ logerr 500, "Read error reading $script_path: $!";
+ };
+ if ( $script_text !~ /#!.*perl/i )
+ { # No #!/.../perl? Then it's not a perl script.
+ logmsg "yeachh! $script doesn't taste like perl!";
+ close CGI;
+ $file_tastes_like_perl = 0;
+ }
+ }
+ if ($file_tastes_like_perl) {
+ {
+ local $INPUT_RECORD_SEPARATOR = undef; # gobble rest of $script
+ $script_text .= <CGI>;
+ }
+ close CGI;
+ logmsg "-> eval'ing $script_path";
+ my $package_name = $script; # most CGI's dont bother to set package name.
+ $package_name =~ # mangle filename into package name in order to
+ s/\W/_/g; # avoid variable name clashes when in non-forking mode
+ eval <<EOF;
+ local *STDIN = *Client;
+ local *STDOUT = *Client;
+ package $package_name;
+ no strict;
+ $script_text
+EOF
+ $@ and logerr 500, "in $script:<br> <pre>$@</pre>";
+ }
+ }
+ if ( $eval_or_execute == $cgis_are_executed or not $file_tastes_like_perl ) {
+
+ #
+ # First they're chdir()'ing to where the script lives and then
+ # they try to open it using relative path starting from $0? WTF?!
+ #
+ my ($chdir_script_path) = $script_path =~ m{^.*[/\\](.*?)$};
+
+ -x $chdir_script_path or logerr 500, "Cannot execute $script_path: $!";
+ local $ENV{CHLD} = 'DEFAULT';
+
+ logmsg "-> exec'ing $chdir_script_path";
+ my ( $pid, $cgi_out, $cgi_in, $output, $errors );
+ my $parent_pid = $PID;
+ # the extra "" avoids the shell
+ eval { $pid = open2( $cgi_out, $cgi_in, "$^X $chdir_script_path" ) };
+ if ($@) { # we may be kid here from open2's fork(). Weird...
+ logmsg "(NB: note my PID!) When trying to execute $script:";
+ chomp($@);
+ logmsg $@;
+ exit 0 unless $PID == $parent_pid;
+ }
+ else {
+ if ( $method =~ /POST/i ) {
+ read( Client, $_, $ENV{CONTENT_LENGTH} );
+ local $SIG{PIPE} = 'IGNORE'; # avoid choking on broken pipe
+ print $cgi_in $_; # .. when tring to talk to a dead kid.
+ }
+ close $cgi_in;
+ {
+ local $INPUT_RECORD_SEPARATOR = undef; # slurp!
+ $output = <$cgi_out>;
+ }
+ close $cgi_out;
+ waitpid( $pid, 0 );
+ if ( $output =~ m#^\r?Content-Type:.*?\r?\n\r?\n#mi or $output =~/^\r?Status:\s+302/ ) {
+ print Client $output;
+ }
+ else { # Capturing scripts stderr with open3 would be just too painful
+ # (deadlock problems) so we're almost as unhelpful as apache!
+ print STDERR $output;
+ logerr 500,
+ "Premature end of script headers."
+ . ( $? ? "<br> Status: $?" : "" )
+ . "<br>Have a look at server log for stderr output of $script";
+ }
+ }
+ }
+ chdir $old_chdir;
+}
+
+sub directory_listing {
+ my ($dir) = @_;
+ $dir =~ s#//#/#g;
+ chdir "$server_root$dir"
+ or return logerr 500, "Cannot chdir to $server_root$dir: $!";
+ my @files = glob("*");
+ @files = sort @files;
+ $dir eq "/" or @files = ( "..", @files );
+ print Client <<EOF;
+HTTP/1.0 200 OK
+Content-type: text/html
+
+ <html>
+ <head><title>$dir</title></head>
+ <body>
+ <h1>$dir</h1>
+ <pre>
+EOF
+ foreach my $file (@files) {
+ print_direntry($file);
+ }
+ print Client <<EOF;
+ </pre>
+ <hr>
+ <p><I>p5httpd/$version server at $localname port $port</I>
+ </body>
+ </html>
+EOF
+ logmsg "-> 200 OK listing $dir";
+}
+
+sub filetype {
+ my ($relpath) = @_;
+ $relpath eq '..' and return "folder/parent";
+ -d $relpath and return "folder/normal";
+ ( cwd . "/$relpath" ) =~ /$cgi_scriptname_regexp/i
+ and return "application/cgi";
+ my ($suffix) = ( $relpath =~ /(\.\w+)$/ );
+ my $type = $mime_types{ lc($suffix) };
+ $type ||= "text/plain";
+ return $type;
+}
+
+sub print_direntry {
+ my @months = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
+ my ($file) = @_;
+ my ( undef, undef, undef, undef, undef, undef, undef, $size, undef, $mtime ) =
+ stat $file;
+ my ( $icon, $type );
+ if ($show_icons) {
+ $type = filetype($file);
+ $type =~ s/\//_/g;
+ -r "$server_root/$icondir/$type.gif" or $type = "unknown";
+ $icon = "$icondir/$type.gif";
+ $icon = ( -r "$server_root/$icon" ? "<img src=\"/$icon\">" : "" );
+ }
+ my $filename = ( $file eq ".." ? "Parent directory" : $file );
+ $filename = (
+ length($filename) > 18
+ ? sprintf( "%18.18s", $filename ) . ".."
+ : $filename
+ );
+ $filename .= "/" if $type eq "folder_normal";
+ my ( $x, $min, $hour, $mday, $mon, $year ) = localtime $mtime;
+ $year += 1900;
+ $min = sprintf "%2.2d", $min;
+ $hour = sprintf "%2.2d", $hour;
+ my $date = "$mday-$months[$mon]-$year $hour:$min";
+ my $spacing = " " x ( 25 - length($filename) );
+ printf Client "%s <a href=\"%s\">%s</a>%s %20.20s %8.8s\n", $icon, $file,
+ $filename, $spacing, $date, $size;
+}
+
+sub redirect {
+ my ($redir) = @_;
+ print Client "HTTP/1.0 301 Moved Permanently\nLocation: $redir\n\n";
+ logmsg "-> 301 Moved Permanently to $redir";
+}
+
+sub challenge {
+ my ( $realm, $file ) = @_;
+ print Client
+"HTTP/1.0 401 Access Denied\nContent-type: text/html\nWWW-Authenticate: Basic realm=\"$realm\"\n\n";
+ logmsg "-> Authentication requested for $file";
+}
+
+sub authorized {
+ my ( $file, $passphrase ) = @_;
+ my $parent = $file;
+ do { # check whether $file is public or private
+ # by stripping away final path components until
+ return ""
+ if $public{
+ "$parent/"}; # either a public or a private directory is reached
+ goto PROTECTED
+ if $private{"$parent/"}; # "last" would test the wile clause once more
+ } while ( $parent =~ s#/[^/]*$## );
+PROTECTED:
+ logmsg "checking password";
+ $passphrase =~ tr#A-Za-z0-9+/##cd; # remove non-base64 chars
+ $passphrase =~ tr#A-Za-z0-9+/# -_#; # convert to uuencoded format
+ my $len = pack( "c", 32 + 0.75 * length($passphrase) ); # compute length byte
+ my $decoded = unpack( "u", $len . $passphrase ); # uudecode and print
+ my ( $name, $password ) = split /:/, $decoded;
+
+ if ( my $encrypted_password = $encrypted_passwords{$name} ) {
+ return $name
+ if crypt( $password, $encrypted_password ) eq
+ $encrypted_password; # check password
+ }
+ return undef; # failed
+}
+
+__END__
+
+
+=head1 NAME
+
+p5httpd - tiny perl http server
+
+=head1 SYNOPSIS
+
+path/to/p5httpd.pl (or click on the icon)
+
+=head1 DESCRIPTION
+
+p5httpd is a simple HTTP 1.0 server written as a single perl
+file. Written for use on a hand-held machine, it should be useful on
+any machine as a quick and dirty, non-secure webserver for occasional
+use.
+
+Understands PUT, GET, and HEAD, can do basic authentication and
+directory listings. CGI scripts can be executed or, if they are perl
+scripts, eval'ed.
+
+
+
+=head1 INSTALLATION AND CONFIGURATION
+
+p5httpd.pl is a single file, containing a small configuration section
+at the beginning, and this POD documentation at the end. This single
+file, unedited, is already functional, but it will be more useful if
+you unzip the whole distribution and edit the first few lines of the
+server program to adapt it to your installation
+
+=head1 FORKING POLICY
+
+Unix servers typically use fork() in order to be ready for the next
+request as soon as possible, delegating the hard work to a child
+process. This may result in better performance (e.g. when requesting a
+page with a lot of images), but perl CGI scripts will have to load all
+their modules every time they're run.
+
+A non-forking server will run all scripts in the same interpreter
+process, an thus will have to load the modules ony once. For
+heavyweight modules like CGI.pm this may make a big difference.
+
+p5httpd can be configured (with the config variable $when_to_fork) to
+fork always, never, or always except the first time a particular
+script is run. This last policy combines the advantages of the
+always-forking and never-forking policies, as the server (and hence
+its children) will have the script's required modules loaded after its
+first (non-forking) run. In this case, expensive re-initialisations
+can also be avoided.
+
+=head1 EVAL OR EXECUTE?
+
+
+cgi scripts can be executed as a separate process, or they can be run
+(eval'ed) in the same interpreter as the server, if they are written
+in perl. You can configure the sever (with the config variable
+$eval_or_execute) to always execute, or always eval cgi scripts. It
+can also look at the script and try to find out whether it is perl (it
+then looks for the slashbang pattern #!/.../perl).
+
+
+=head1 SECURITY AND AUTHENTICATION
+
+p5httpd should not be used when security is critical. It can only use
+the "Basic" authentication scheme, where usernames and passwords are
+sent unencrypted over the network. It uses the same htpasswd files as
+apache (use the htpasswd (1) program, or
+http://www.euronet.nl/~arnow/htpasswd/ to generate them).
+
+A list of public directories and another list of private directories
+(in the config variables @public_directories and @private_directories)
+determines when authentication is requested: for any file access,
+p5httpd climbs up the directory tree until it finds a directory in
+either list (the public list is tried first)
+
+=head1 PATH INFO
+
+As a workaround for a bug in EPOC Opera (which will not reliably POST
+to an URL of the form /path/to.cgi?args) any requests to
+/path/to.cgi/args are redirected to /path/to.cgi?args. This is I<not>
+path info as per HTTP/1.0, and PATH_INFO will not be set.
+
+
+=head1 CGI SCRIPT PITFALLS WITH p5httpd
+
+Depending on the forking policy,and whether cgi's are eval'ed or
+executed, you may have to take some care when writing your scripts.
+When all cgi's are executed, and/or when the server forks for evey
+request, your scripts execute with "a clean slate" every time. This is
+the setting to use whenever you use cgi's that normally run on
+e.g. apache, at least initially, before you try the more dangerous
+(but possibly faster) settings.
+
+On the other extreme, when you evaluate your scripts and never fork(),
+(which is the only setting that works on EPOC/psion), there are a
+couple of things to watch out for:
+
+=over 4
+
+
+
+
+
+=item scope issues
+
+All CGI scripts run in a separate namespace, derived from the script
+name. Just as with e.g. mod_perl, package globals remain defined
+across invocations. This may be very useful in some situations
+(e.g. for preserving an expensive initialisation), but you should be
+aware of it. Unless you know what you're doing, take the following
+advice from the mod_perl FAQ:
+
+I<Properly scope your variables. Stop and read that sentence
+again. Conventional CGI scripts can be as sloppy with their namespace
+as they want, since they are restarted anew for each request. Your
+mod_perl script has a much longer lifetime (potentially as long as
+your [...] server is running), and requires much more care. Scope
+everything except long-lived variables with my() and use strict; so
+Perl will demand that you recognize your global variables.>
+
+I<Localize global variables. If you change any of Perl's global
+variables (e.g. $/ to change the input record separator), or even your
+own global variables remember to reset them or better still, always
+localize global variables before using them, e.g. local($/) =
+undef. If you can, reduce your dependency on global variables>
+
+
+=item die() and exit()
+
+If you call C<exit()> in your script, the whole server will quit
+(C<die()> will just print an error message). CGI scripts may hang, or
+even crash, the server. Filehandles remain open across invocations.
+
+=item CGI.pm
+
+If you use the C<CGI.pm> package, you have to use the (undocumented)
+subroutine C<CGI::initialize_globals()> to get it to re-read the script
+parameters. If you don't, the script will only read them the first
+time it runs.
+
+=back
+
+The server does a C<chdir> to a script's directory before running it,
+and sets the environment variable SERVER_ROOT to the absolute pathname
+of the server root directory.
+
+
+=head1 REQUIRES
+
+p5httpd needs perl 5.6.0 or newer It works
+on machines that cannot fork() (like Psion handhelds) but it can use
+fork() if available. Needs the IPC::Open2 module whenever a cgi should
+be executed (not eval'ed). This module may only be present on
+Unix-like systems.
+
+
+=head1 CREDITS
+
+Originally based on phttpd (pure perl httpd, (C) Paul Tchistopolskii
+1998, 99 The Wiki packaged with this server is based on QuickiWiki (C)
+Copyright 1999-2000 Ward Cunningham.
+
+=head1 AUTHOR
+
+Hans Lub. Bug reports to hlub@knoware.nl
+
+
+=head1 COPYRIGHT
+
+Copyright (c) 2002-2004 Hans Lub. This program is free software; you
+can redistribute it and/or modify it under the same terms as
+ Perl itself
+
+=cut
+
+# Local Variables:
+# mode: cperl
+# End:
+
+
+
+
+
+
+
+
+
+
+
+
+
@@ -8,37 +8,51 @@ use Carp;
use IO::Handle;
use File::Basename qw(basename);
-use RPC::ExtDirect ();
+use RPC::ExtDirect::Config;
use RPC::ExtDirect::API;
-use RPC::ExtDirect::Router;
-use RPC::ExtDirect::EventProvider;
+use RPC::ExtDirect;
+
+#
+# This module is not compatible with RPC::ExtDirect < 3.0
+#
+
+die __PACKAGE__." requires RPC::ExtDirect 3.0+"
+ if $RPC::ExtDirect::VERSION lt '3.0';
### PACKAGE GLOBAL VARIABLE ###
#
# Version of this module.
#
-our $VERSION = '2.03';
+our $VERSION = '3.01';
### PUBLIC CLASS METHOD (CONSTRUCTOR) ###
#
-# Instantiates CGI::ExtDirect object
+# Instantiate a new CGI::ExtDirect object
#
sub new {
my $class = shift;
- my %params = @_ == 1 && 'HASH' eq ref $_[0] ? %{ $_[0] }
- : @_
- ;
-
- # We need CGI object for input
- my $cgi = $params{cgi} || do { require CGI; new CGI };
+ my %arg = @_ == 1 && 'HASH' eq ref $_[0] ? %{ $_[0] }
+ : @_
+ ;
+
+ my $api = delete $arg{api} || RPC::ExtDirect->get_api();
+ my $config = delete $arg{config} || $api->config;
+
+ # We need a CGI object for input processing
+ my $cgi = $arg{cgi} || do { require CGI; new CGI };
# Debug flag defaults to off
- my $debug = exists $params{debug} ? $params{debug} : 0;
+ $config->debug( $arg{debug} ) if exists $arg{debug};
- my $self = bless { cgi => $cgi, debug => $debug }, $class;
+ my $self = bless {
+ config => $config,
+ api_obj => $api,
+ cgi => $cgi,
+ %arg,
+ }, $class;
return $self;
}
@@ -51,11 +65,13 @@ sub new {
sub api {
my ($self, @headers) = @_;
- # Set the debug flag
- local $RPC::ExtDirect::API::DEBUG = $self->debug;
-
# Get the API JavaScript
- my $js = eval { RPC::ExtDirect::API->get_remoting_api() };
+ my $js = eval {
+ $self->api_obj->get_remoting_api(
+ config => $self->config,
+ env => $self->cgi,
+ )
+ };
# If JS API call failed, return error headers
# What exactly went wrong is not too relevant here
@@ -89,9 +105,6 @@ sub api {
sub route {
my ($self, @headers) = @_;
- # First set the debug flag
- local $RPC::ExtDirect::Router::DEBUG = $self->debug;
-
# If any but POST method is used, just throw an error
return $self->error_headers(@headers)
if $self->cgi->request_method() ne 'POST';
@@ -102,25 +115,27 @@ sub route {
# When extraction fails, undef is returned
return $self->error_headers(@headers)
unless defined $router_input;
+
+ my $config = $self->config;
+ my $api = $self->api_obj;
+ my $router_class = $config->router_class;
+
+ eval "require $router_class";
+
+ my $router = $router_class->new(
+ config => $config,
+ api => $api,
+ );
# Routing requests is safe (Router won't croak under torture)
- my $result = RPC::ExtDirect::Router->route($router_input, $self->cgi);
+ my $result = $router->route($router_input, $self->cgi);
my ($content_type, $http_body, $content_length);
- # Older RPC::ExtDirect version returned two-element array
- if ( $RPC::ExtDirect::VERSION lt '2.00' ) {
- $content_type = $result->[0];
- $http_body = $result->[1];
- $content_length = do { no warnings; use bytes; length $http_body; };
- }
- else {
- $content_type = $result->[1]->[1];
- $content_length = $result->[1]->[3];
- $http_body = $result->[2]->[0];
- };
-
- my $http_status = '200 OK';
+ $content_type = $result->[1]->[1];
+ $content_length = $result->[1]->[3];
+ $http_body = $result->[2]->[0];
+ my $http_status = '200 OK';
# Munge the headers passed on us
my @real_headers = $self->_munge_headers($content_type,
@@ -143,15 +158,23 @@ sub route {
sub poll {
my ($self, @headers) = @_;
- # First set the debug flag
- local $RPC::ExtDirect::EventProvider::DEBUG = $self->debug;
-
# Only GET and POST methods are supported for polling
return $self->error_headers(@headers)
if $self->cgi->request_method() !~ / \A (GET|POST) \z /xms;
+
+ my $config = $self->config;
+ my $api = $self->api_obj;
+ my $provider_class = $config->eventprovider_class;
+
+ eval "require $provider_class";
+
+ my $provider = $provider_class->new(
+ config => $config,
+ api => $api,
+ );
# Polling for Events is safe
- my $http_body = RPC::ExtDirect::EventProvider->poll($self->cgi);
+ my $http_body = $provider->poll($self->cgi);
# Gather variables for HTTP response
my $content_type = 'application/json';
@@ -173,7 +196,7 @@ sub poll {
return $response;
}
-### PRIVATE INSTANCE METHOD ###
+### PUBLIC INSTANCE METHOD ###
#
# Returns error HTTP header string. There is not much sense in
# returning HTTP body as well since Ext.Direct calls are automated
@@ -194,11 +217,12 @@ sub error_headers {
### PUBLIC INSTANCE METHODS ###
#
-# Read-only getters
+# Read-write accessors
#
-sub debug { $_[0]->{debug} }
-sub cgi { $_[0]->{cgi} }
+RPC::ExtDirect::Util::Accessor->mk_accessors(
+ simple => [qw/ config api_obj cgi /],
+);
############## PRIVATE METHODS BELOW ##############
@@ -214,13 +238,10 @@ sub _munge_headers {
# Default charset is UTF-8
my $charset = 'utf-8';
- # First form is no additional headers passed on us, easy one
+ # First form is no additional headers passed on us, the easy one
# Second form includes only one parameter and that's content type
# Third form includes both content type and HTTP status
- # Last form is hash of headers but we'd better check that anyway
- #
- # If that's the case, just override it and that's that
- #
+ # The last form is a hash of headers but we'd better check anyway
return (
'-type' => $content_type,
'-status' => $http_status,
@@ -252,7 +273,7 @@ sub _munge_headers {
my @found_items = grep { /$pattern/ } keys %cgi_headers;
next HEADER_ITEM unless @found_items;
- # Then take *first* value -- we don't care about duplicates
+ # Then take the *first* value -- we don't care about duplicates
# and they should not have happened anyway, so there
my $value = $cgi_headers{ $found_items[0] };
@@ -263,10 +284,15 @@ sub _munge_headers {
$cgi_headers{ $item } = $value;
};
- # Forcibly replace the ones we need (even if they were not there)
- $cgi_headers{ '-type' } = $content_type;
- $cgi_headers{ '-status' } = $http_status;
- $cgi_headers{ '-content_length' } = $content_length;
+ # Make sure we have the required headers
+ $cgi_headers{'-type'} = $content_type
+ unless exists $cgi_headers{ '-type' };
+
+ $cgi_headers{'-status'} = $http_status
+ unless exists $cgi_headers{ '-status' };
+
+ # Content-length we force
+ $cgi_headers{'-content_length'} = $content_length;
# If they passed charset, then they probably know what they're doing
$cgi_headers{ '-charset' } = $charset
@@ -290,7 +316,7 @@ sub _munge_headers {
### PRIVATE INSTANCE METHOD ###
#
# Deals with intricacies of POST-fu and returns something suitable to
-# feed to Router (string or hashref, really). Or undef if something
+# feed to the Router (string or hashref, really). Or undef if something
# goes too wrong to recover.
my @STANDARD_KEYWORDS
@@ -326,7 +352,7 @@ sub _extract_post_data {
# Now if the form IS involved, it gets a little bit complicated
PARAM:
for my $param ( keys %keyword ) {
- # Defang CGI's idiosyncratic way to return multi-valued params
+ # Defang CGI's idiosyncratic way of returning multi-valued params
my @values = $cgi->param( $param );
$keyword{ $param } = @values == 0 ? undef
: @values == 1 ? $values[0]
@@ -340,7 +366,7 @@ sub _extract_post_data {
# Look for file uploads in this field
my @field_uploads = $self->_parse_uploads($cgi, $param);
- # Found some, add them to general stash and kill the field
+ # Found some, add them to the general stash and kill the field
if ( @field_uploads ) {
push @_uploads, @field_uploads;
delete $keyword{ $param };
@@ -350,7 +376,7 @@ sub _extract_post_data {
# Remove extType because it's meaningless later on
delete $keyword{ extType };
- # Fix TID so that it comes as number (JavaScript is picky)
+ # Fix up the TID so that it comes as a number (JavaScript is picky)
$keyword{ extTID } += 0 if exists $keyword{ extTID };
# Now add files to hash, if any
@@ -380,17 +406,17 @@ sub _parse_uploads {
# Here file uploads get collected
my @uploads = ();
- # Collect the info we need to repackage it in consistent way
+ # Collect the info we need to repackage it in a consistent way
FILE:
for my $key ( @file_keys ) {
# First take a closer look at this "blah-blah handle"
my $file_handle = shift @file_handles;
- # undef would mean there was upload error (timeout perhaps)
- # Following HTTP POST logic, when one upload breaks that
+ # undef would mean there was an upload error (timeout perhaps)
+ # Following HTTP POST logic, when one upload breaks, that
# would mean all subsequent uploads in this POST are also
# broken.
- # We can't do anything about it anyway so just stop trying.
+ # We can't recover from that so just stop trying.
last FILE unless defined $file_handle;
# In CGI.pm < 3.41, "lightweight handle" object doesn't support
@@ -405,7 +431,7 @@ sub _parse_uploads {
my $file_size = $self->_get_file_size($io_handle);
my $base_name = basename($file_name);
- # Now instead of "blah-blah handle" we have hashref full of info
+ # Now instead of a "blah-blah handle" we have a normalized hashref
push @uploads, {
type => $file_type,
size => $file_size,
@@ -452,201 +478,3 @@ sub _get_file_size {
}
1;
-
-__END__
-
-=pod
-
-=head1 NAME
-
-CGI::ExtDirect - Ext.Direct remoting interface for CGI applications
-
-=head1 SYNOPSIS
-
-=head2 API definition
-
-In api.cgi:
-
- use CGI::ExtDirect;
- use RPC::ExtDirect::API api_path => '/extdirect_api',
- router_path => '/extdirect_router',
- poll_path => '/extdirect_events',
- remoting_var => 'Ext.app.REMOTING_API',
- polling_var => 'Ext.app.POLLING_API',
- namespace => 'myApp', # Defaults to empty
- auto_connect => 0,
- no_polling => 0,
- debug => 0,
- before => \&global_before_hook,
- after => \&global_after_hook,
- ;
-
- use My::ExtDirect::Published::Module::Foo;
- use My::ExtDirect::Published::Module::Bar;
-
- my $direct = CGI::ExtDirect->new();
-
- print $direct->api(); # Prints full HTTP response
-
-=head2 Routing requests
-
-In router.cgi:
-
- use CGI::ExtDirect;
-
- use My::ExtDirect::Published::Module::Foo;
- use My::ExtDirect::Published::Module::Bar;
-
- my $debug = 1; # Optional debugging flag
- my %headers = ( # Optional CGI headers
- -charset => 'iso-8859-1',
- -nph => 1,
- -cookie => $cookie,
- );
-
- my $direct = CGI::ExtDirect->new( debug => $debug );
-
- print $direct->route(%headers); # Prints full HTTP response
-
-=head2 Providing Event polling service
-
-In poll.cgi:
-
- use CGI;
- use CGI::ExtDirect;
-
- use My::ExtDirect::Event::Provider1;
- use My::ExtDirect::Event::Provider2;
-
- my $debug = 1;
- my $cgi = CGI->new;
-
- # do something with $cgi but do not print headers
- ...
-
- my $direct = CGI::ExtDirect->new( cgi => $cgi, debug => $debug );
-
- print $direct->poll();
-
-=head1 DESCRIPTION
-
-This module provides RPC::ExtDirect gateway implementation for CGI
-compatible HTTP servers. It can be used wth Perl versions 5.6 and
-newer in about any environment; it was tested successfully with
-Apache, pure Perl server based on HTTP::Server::Simple and various
-other HTTP servers.
-
-You can change default configuration options by passing corresponding
-parameters like shown above. For the meaning of parameters, see
-L<RPC::ExtDirect::API> documentation.
-
-Note that Ext.Direct specification requires server side implementation
-to return diagnostic messages only when debugging is explicitly turned
-on. This is why C<debug> flag defaults to 'off' and CGI::ExtDirect
-returns generic error messages that do not contain any details as to
-where and what error has happened.
-
-=head1 METHODS
-
-=over 4
-
-=item new($arguments)
-
-Creates a new CGI::ExtDirect object. $arguments is an optional hashref
-with the following options:
-
-=over 8
-
-=item cgi
-
-Instantiated CGI or similar object.
-
-=item debug
-
-Debug flag, defaults to off. See the note above.
-
-=back
-
-=item api(%headers)
-
-Creates JavaScript code with server side Action and Method declarations
-and prints it to default output handle along with HTTP headers. You can
-specify additional headers in CGI format: NPH, cookies, whatever; they
-will be passed to CGI->header() which is used to form HTTP header part.
-
-Some of the headers, namely Content-Type, Content-Length and Status, are
-always overridden to provide client side with adequate response. Default
-Charset is UTF-8; however if you pass -charset header CGI::ExtDirect will
-honor it. It is implied that you should only do this when you clearly know
-what you are doing.
-
-Other headers are passed along to CGI->header() unchanged.
-
-=item route(%headers)
-
-Accepts Ext.Direct requests, dispatches them, collects results and prints
-them back as serialized stream.
-
-%headers are treated the same way as in api(), see above.
-
-=item poll(%headers)
-
-Queries Event provider Methods registered with RPC::ExtDirect as
-pollHandlers for events, collects them and returns back serialized stream.
-
-%headers are treated the same way as in api(), see above.
-
-=back
-
-=head1 DEPENDENCIES
-
-CGI::ExtDirect is dependent on the following modules:
- L<RPC::ExtDirect>, L<JSON>, L<Attribute::Handlers>.
-
-=head1 SEE ALSO
-
-For explanation of RPC::ExtDirect attributes, see L<RPC::ExtDirect>. For
-more detail on API options, see L<RPC::ExtDirect::API>.
-
-For more information on Ext.Direct API see specification:
-L<http://www.sencha.com/products/extjs/extdirect/> and documentation:
-L<http://docs.sencha.com/ext-js/4-0/#!/api/Ext.direct.Manager>.
-
-See included Ext JS examples for ideas on what Ext.Direct is and how to
-use it in CGI applications.
-
-=head1 ACKNOWLEDGEMENTS
-
-I would like to thank IntelliSurvey, Inc for sponsoring my work
-on version 2.0 of RPC::ExtDirect suite of modules.
-
-The tiny but CGI-capable HTTP server used to provide working examples
-is (c) 2002-2004 by Hans Lub, <hlub@knoware.nl>. It is called p5httpd
-and can be found here: L<http://utopia.knoware.nl/~hlub/rlwrap/>
-
-=head1 BUGS AND LIMITATIONS
-
-Hooks functionality depend on RPC::ExtDirect 2.0 which is incompatible
-with Perls older than 5.12.
-
-There are no known bugs in this module. Use github tracker to report
-bugs (better way) or just drop me an e-mail. Patches are welcome.
-
-=head1 AUTHOR
-
-Alexander Tokarev E<lt>tokarev@cpan.orgE<gt>
-
-=head1 COPYRIGHT AND LICENSE
-
-Copyright (c) 2011-2012 Alexander Tokarev.
-
-This module is free software; you can redistribute it and/or modify it under
-the same terms as Perl itself. See L<perlartistic>.
-
-Included Ext JS examples are copyright (c) 2011, Sencha Inc. Example code
-is used and distributed under GPL 3.0 license as provided by Sencha Inc.
-See L<http://www.sencha.com/license>. Ext JS is available for download at
-L<http://www.sencha.com/products/extjs/>
-
-=cut
-
@@ -0,0 +1,344 @@
+=pod
+
+=begin readme text
+
+CGI::ExtDirect
+==============
+
+=end readme
+
+=for readme stop
+
+=head1 NAME
+
+CGI::ExtDirect - Ext.Direct remoting gateway for CGI applications
+
+=head1 SYNOPSIS
+
+=head2 API definition
+
+In C</cgi-bin/api.cgi>:
+
+ use CGI::ExtDirect;
+ use RPC::ExtDirect::Config;
+
+ use My::ExtDirect::Published::Module::Foo;
+ use My::ExtDirect::Published::Module::Bar;
+
+ my $config = RPC::ExtDirect::Config->new(
+ api_path => '/cgi-bin/api.cgi',
+ router_path => '/cgi-bin/router.cgi',
+ poll_path => '/cgi-bin/events.cgi',
+ );
+
+ my $direct = CGI::ExtDirect->new(config => $config);
+
+ print $direct->api(); # Prints full HTTP response
+
+=head2 Routing requests
+
+In C</cgi-bin/router.cgi>:
+
+ use CGI::Cookie;
+ use CGI::ExtDirect;
+
+ use My::ExtDirect::Published::Module::Foo;
+ use My::ExtDirect::Published::Module::Bar;
+
+ my %headers = ( # Optional CGI headers
+ -charset => 'iso-8859-1',
+ -nph => 1,
+ -cookie => CGI::Cookie->new(
+ -name => 'foo',
+ -value => 'bar',
+ ),
+ );
+
+ my $direct = CGI::ExtDirect->new();
+
+ print $direct->route(%headers);
+
+=head2 Event polling service
+
+In C</cgi-bin/poll.cgi>:
+
+ use CGI::Simple;
+ use CGI::ExtDirect;
+
+ use My::ExtDirect::Event::Provider1;
+ use My::ExtDirect::Event::Provider2;
+
+ # CGI::Simple is supported as well
+ my $cgi = CGI::Simple->new;
+
+ # do something with $cgi but do not print headers
+ ...
+
+ my $direct = CGI::ExtDirect->new(cgi => $cgi);
+
+ print $direct->poll();
+
+=head1 DESCRIPTION
+
+=for readme continue
+
+This module provides an L<RPC::ExtDirect> gateway implementation for
+CGI compatible Web server environments. This includes both traditional
+CGI scripts that start up anew for each HTTP request, as well as more
+modern CGI environments in which a script is started once and then
+persists through the lifetime of a server process.
+
+CGI::ExtDirect can be used wth Perl versions 5.6 and newer with many
+Web servers; it was tested successfully with Apache/mod_perl, pure
+Perl server based on L<HTTP::Server::Simple> (L<RPC::ExtDirect::Server>),
+and various other HTTP server environments.
+
+If you are not familiar with Ext.Direct, more information can be found in
+L<RPC::ExtDirect::Intro>.
+
+=for readme stop
+
+=head1 CGI SCRIPTS
+
+If your environment requires using old fashioned standalone CGI scripts,
+CGI::ExtDirect is fine with that. In fact, it is tested in exactly this
+kind of environment to ensure it will work properly.
+
+You need to create at least two CGI scripts: API generator, and request
+router. The third Event provider script is optional, and is only needed
+if you plan to use event polling capabilities of Ext.Direct. The examples
+provided in L</SYNOPSIS> can be used as starting points for further
+customization. See also the L<examples|/EXAMPLES> packaged with
+CGI::ExtDirect.
+
+Note that this environment is supported as a measure of backwards
+compatibility. Using standalone CGI scripts is not recommended if you
+can avoid it; starting such script for each HTTP request is very
+slow and inefficient. Even the most basic persistent HTTP server will
+be much faster. If you are not familiar with this approach, refer to
+the L<section below|/"PERSISTENT CGI ENVIRONMENT">.
+
+=head1 PERSISTENT CGI ENVIRONMENT
+
+A more modern approach to building application servers is to use a
+persistent HTTP server that starts once and is reused for incoming
+HTTP requests without restarting. Usually such application server will
+be serving only I<dynamic> HTTP requests, with the task of serving
+static documents offloaded to a dedicated front-end HTTP server
+software with no Perl support built into it. Such front-end HTTP server
+is known as a I<reverse proxy> for the Perl application server.
+
+In a persistent environment, CGI::ExtDirect is configured once at
+startup, and then called when the application server receives an
+HTTP request to the URI assigned to a specific I<entry point>. The
+entry points are the same as with L<CGI scripts|/"CGI SCRIPTS">:
+API generator, request router, and optional event provider. A new
+L<CGI> object is generated for every request, but the CGI::ExtDirect
+object is reused.
+
+Configuration for this approach will depend largely on the application
+server chosen, and does not fit the scope of this documentation. If you
+are unsure which application server to choose, take a look at
+L<RPC::ExtDirect::Server> that comes preconfigured for CGI::ExtDirect
+and can be used out of box.
+
+=head1 USAGE
+
+=head2 Configuration
+
+To configure CGI::ExtDirect instance, you will need to create an
+instance of L<RPC::ExtDirect::Config> with all required options set,
+and pass it to CGI::ExtDirect L<constructor|/new> to be used. This
+step is optional; by default the Config instance in the
+L<global API instance|RPC::ExtDirect::API/"GLOBAL API TREE INSTANCE">
+will be used instead.
+
+Refer to L<RPC::ExtDirect::Config/OPTIONS> for the list of configuration
+options and their default values.
+
+=head2 Main methods
+
+As discussed above, CGI::ExtDirect has three main entry points: the
+API generator (L</api>), the Router (L</route>), and the Event provider
+(L</poll>). Each of these should be called as an instance method, and
+each will return the full text of an HTTP response to be printed,
+including HTTP status, headers, and the body of the response. Your
+script will need to print the response text to the appropriate pipe,
+which is STDOUT for standalone scripts.
+
+=head2 HTTP response headers
+
+In certain cases, you may need to include custom HTTP headers in
+Ext.Direct responses. This may be a specific charset when you cannot
+use the default UTF-8, or an HTTP cookie. To accommodate for such
+cases, CGI::ExtDirect allows passing through any header that is
+meaningful to the underlying L<CGI.pm|CGI> or L<CGI::Simple> object,
+and conforms to C<CGI::header()> method calling convention.
+
+All three of the main CGI::ExtDirect public methods (L</api>,
+L</route>, and L</poll>) accept custom headers in the following
+fashion:
+
+=over 4
+
+=item method('content/type')
+
+A single header value is interpreted as the content type that will
+override the default C<application/json> type.
+
+Example:
+
+ print $cgi->route('text/javascript'); # JSONP
+
+=item method('content/type', 'HTTP status')
+
+Two header values will be interpreted as the content type and
+HTTP status, respectively.
+
+Example:
+
+ print $cgi->poll('text/json', '401 Unauthorized'); # Auth request
+
+=item method(-header => 'value')
+
+Any custom header can be passed in the C<< key => value >> format.
+
+Example:
+
+ print $cgi->api(-foo_bar => '42'); # Foo-bar: 42
+
+=back
+
+See also L<CGI::Simple/"CREATING HTTP HEADERS"> for sane explanation of
+the header usage that also applies to the old L<CGI.pm|CGI>.
+
+=head1 OBJECT INTERFACE
+
+CGI::ExtDirect provides several public methods:
+
+=over 4
+
+=item C<new>
+
+Constructor. Returns a new CGI::ExtDirect object. Accepts named
+arguments in a hash or hashref.
+
+Parameters:
+
+=over 8
+
+=item C<api>
+
+Optional L<RPC::ExtDirect::API> instance to be used instead of the
+default L<global API tree|RPC::ExtDirect::API/"GLOBAL API TREE INSTANCE">.
+
+=item C<config>
+
+Optional L<RPC::ExtDirect::Config> instance to be used. If not provided,
+the Config instance in the API object (either default or passed in L</api>
+parameter) will be used.
+
+=item C<cgi>
+
+Instantiated L<CGI> or similar object. L<CGI::Simple> has been tested
+and works fine.
+
+=back
+
+=item C<api>
+
+Instance method. Returns the current API tree as a stringified
+L<API declaration|RPC::ExtDirect::Intro/"API declaration"> along with
+the HTTP status code and headers, to be printed or processed further.
+
+Accepts custom headers as described in L</"HTTP response headers">.
+
+=item C<route>
+
+Instance method. Parses Ext.Direct requests from the internal C<CGI> object
+passed to L<constructor|/new>; dispatches the quests, collects results and
+returns an HTTP response with results as a serialized JSON stream.
+
+Accepts custom headers as described in L</"HTTP response headers">.
+
+=item C<poll>
+
+Instance method. Queries Event provider
+L<Poll Handler Methods|RPC::ExtDirect::Intro/"Poll Handler Method">
+for events, collects these events and returns back a JSON stream.
+
+Accepts custom headers as described in L</"HTTP response headers">.
+
+=back
+
+=begin readme
+
+=head1 INSTALLATION
+
+To install this module type the following:
+
+ perl Makefile.PL
+ make && make test
+ make install
+
+=end readme
+
+=for readme continue
+
+=head1 EXAMPLES
+
+See included Ext JS examples for ideas on what Ext.Direct is and how to
+use it in CGI applications. The examples are not installed along with
+the CGI::ExtDirect module, and are only available in the C<examples/>
+directory of the CPAN distribution.
+
+To run examples type the following in the CGI::ExtDirect tarball
+directory:
+
+ cd examples
+ perl p5httpd
+
+Note that these examples do not require CGI::ExtDirect to be installed
+so you can try them beforehand. That said, CGI::ExtDirect depends on
+RPC::ExtDirect being available in C<@INC> so if you don't want to
+install either module, unpack RPC::ExtDirect and CGI::ExtDirect
+tarballs to the same directory and use C<$PERL5LIB> to point to
+RPC::ExtDirect location:
+
+ cd examples
+ PERL5LIB=../../RPC-ExtDirect-3.xx/lib perl p5httpd
+
+=for readme stop
+
+=head1 ACKNOWLEDGEMENTS
+
+I would like to thank IntelliSurvey, Inc for sponsoring my work
+on versions 2.x and 3.x of the RPC::ExtDirect suite of modules.
+
+The tiny but CGI capable HTTP server used to provide working examples
+is (c) 2002-2004 by Hans Lub, <hlub@knoware.nl>. It is called p5httpd
+and can be found here: L<http://utopia.knoware.nl/~hlub/rlwrap/>
+
+=head1 BUGS AND LIMITATIONS
+
+At this time there are no known bugs in this module. Please report problems
+to the author, patches are always welcome.
+
+Use L<Github tracker|https://github.com/nohuhu/CGI-ExtDirect/issues> to open
+bug reports, this is the easiest and quickest way to get your issue fixed.
+
+=for readme continue
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (c) 2011-2014 Alex Tokarev E<lt>tokarev@cpan.orgE<gt>.
+
+This module is free software; you can redistribute it and/or modify it under
+the same terms as Perl itself. See L<perlartistic>.
+
+Included Ext JS examples are copyright (c) 2011, Sencha Inc. Example code
+is used and distributed under GPL 3.0 license as provided by Sencha Inc.
+See L<http://www.sencha.com/license>. Ext JS is available for download at
+L<http://www.sencha.com/products/extjs/>
+
+=cut
@@ -0,0 +1,134 @@
+# Test header manipulation
+
+use strict;
+use warnings;
+
+use Test::More tests => 5;
+
+use CGI::ExtDirect;
+
+sub hash_sort {
+ my %hash = @_;
+
+ my @res = map { ( $_ => $hash{ $_ } ) } sort keys %hash;
+
+ return @res;
+}
+
+my $c = CGI::ExtDirect->new();
+
+# First CGI-like form
+my @want = hash_sort (
+ '-type' => 'content/foo',
+ '-content_length' => 42,
+ '-status' => '123 blah',
+ '-charset' => 'utf-8',
+);
+
+my @have = hash_sort $c->_munge_headers('content/foo', '123 blah', 42);
+
+is_deeply \@have, \@want, "First form"
+ or diag explain "Want:", \@want, "Have:", \@have;
+
+# Second CGI-like form, content-type override
+@want = hash_sort (
+ '-type' => 'content/foo',
+ '-content_length' => 123,
+ '-charset' => 'utf-8',
+ '-status' => '321 bleh',
+);
+
+@have = hash_sort $c->_munge_headers(
+ 'content/foo', '321 bleh', 123, 'content/bar'
+);
+
+is_deeply \@have, \@want, "Second form",
+ or diag explain "Want:", \@want, "Have:", \@have;
+
+# Third CGI-like form, both content-type and status are overridden
+@want = hash_sort (
+ '-type' => 'content/foo',
+ '-content_length' => 321,
+ '-charset' => 'utf-8',
+ '-status' => '111 blerg',
+);
+
+@have = hash_sort $c->_munge_headers(
+ 'content/foo', '111 blerg', 321, 'content/bar', '321 bleh',
+);
+
+is_deeply \@have, \@want, "Third form",
+ or diag explain "Want:", \@want, "Have:", \@have;
+
+# Fourth (and last) form is when headers are in a hash
+@want = hash_sort (
+ '-type' => 'content/bar',
+ '-content_length' => 111,
+ '-charset' => 'bleh',
+ '-status' => '200 OK',
+ 'Content-Foo' => 'bar',
+);
+
+@have = hash_sort $c->_munge_headers(
+ 'content/foo', '112 SOS', 111,
+
+ # This header should be overridden with a value from 3rd argument
+ 'Content-Length' => 222,
+
+ # These headers we no longer override in 3.0+
+ 'Content-Type' => 'content/bar',
+ 'Status' => '200 OK',
+
+ # These header should be passed through
+ 'Content-Foo' => 'bar',
+ '-charset' => 'bleh',
+);
+
+is_deeply \@have, \@want, "Fourth form with overrides"
+ or diag explain "Want:", \@want, "Have:", \@have;
+
+# Test that none of the "interesting" headers are coming through unmunged
+@want = hash_sort (
+ '-type' => 'content/foo',
+ '-status' => '222 fie-foe',
+ '-charset' => 'splurge-9',
+ '-nph' => 'mymse',
+ '-content_length' => 1234,
+);
+
+@have = hash_sort $c->_munge_headers(
+ 'content/foo', '222 fie-foe', 1234,
+
+ 'Type' => 'content/bar',
+ 'Content-Type' => 'content/bar',
+ '-Content_type' => 'content/bar',
+ '-type' => 'content/bar',
+ '-Content-Type' => 'content/bar',
+
+ 'Content-Length' => 111,
+ '-Content_length' => 111,
+ '-Content-Length' => 111,
+
+ 'Status' => '111 foe-foo',
+ '-status' => '111 foe-foo',
+
+ 'Charset' => 'mumbo-7',
+ '-charset' => 'mumbo-7',
+
+ 'nph' => 'mymse', # first one should be taken
+ '-nph' => 'blerg',
+);
+
+# Ensure a header with dashed name always comes first (no sorting here)
+@have = $c->_munge_headers(
+ 'foo/bar', '123 bleh', 111,
+
+ '-type' => 'bar/bleh',
+ '-charset' => 'blerg-16',
+ '-status' => '321 blah',
+ '-content_length' => 222,
+);
+
+like $have[0], qr/^-/, "Dashed header first"
+ or diag explain "Have:", \@have;
+
@@ -1,65 +1,12 @@
use strict;
use warnings;
-no warnings 'uninitialized';
-use Test::More tests => 13;
+use lib 't/lib';
+use RPC::ExtDirect::Test::Util::CGI;
+use RPC::ExtDirect::Test::Data::API;
-use CGI::Test (); # No need to import ok() from CGI::Test
-use CGI::Test::Input ();
-use CGI::Test::Input::URL ();
-use CGI::Test::Input::Multipart ();
+use CGI::ExtDirect;
-BEGIN { use_ok 'CGI::ExtDirect'; }
+my $tests = RPC::ExtDirect::Test::Data::API::get_tests;
-my $dfile = 't/data/extdirect/api';
-my $tests = eval do { local $/; open my $fh, '<', $dfile; <$fh> } ## no critic
- or die "Can't eval $dfile: '$@'";
-
-# Testing API
-my $ct = CGI::Test->new(
- -base_url => 'http://localhost/cgi-bin',
- -cgi_dir => 't/cgi-bin',
-);
-
-BAIL_OUT "Can't create CGI::Test object" unless $ct;
-
-for my $test ( @$tests ) {
- my $name = $test->{name};
- my $url = $test->{cgi_url};
- my $method = $test->{method};
- my $input_content = $test->{input_content};
- my $http_status_exp = $test->{http_status};
- my $content_regex = $test->{content_type};
- my $expected_output = $test->{expected_content};
-
- my $page = $ct->$method($url, $input_content);
-
- if ( ok $page, "$name not empty" ) {
- my $content_type = $page->content_type();
- my $http_status = $page->is_ok() ? 200 : $page->error_code();
-
- like $content_type, $content_regex, "$name content type";
- is $http_status, $http_status_exp, "$name HTTP status";
-
- my $http_output = $page->raw_content();
- $http_output =~ s/\s//g;
- $expected_output =~ s/\s//g;
-
- is $http_output, $expected_output, "$name content"
- or diag explain $page;
-
- $page->delete();
- };
-};
-
-exit 0;
-
-sub raw_post {
- my $input = shift;
-
- use bytes;
- my $cgi_input = CGI::Test::Input::URL->new();
- $cgi_input->add_field('POSTDATA', $input);
-
- return $cgi_input;
-};
+run_tests($tests, @ARGV);
@@ -1,97 +1,12 @@
use strict;
use warnings;
-no warnings 'uninitialized';
-use Test::More tests => 25;
+use lib 't/lib';
+use RPC::ExtDirect::Test::Util::CGI;
+use RPC::ExtDirect::Test::Data::Router;
-use Data::Dumper;
+use CGI::ExtDirect;
-use CGI::Test (); # No need to import ok() from CGI::Test
-use CGI::Test::Input ();
-use CGI::Test::Input::URL ();
-use CGI::Test::Input::Multipart ();
+my $tests = RPC::ExtDirect::Test::Data::Router::get_tests;
-BEGIN { use_ok 'CGI::ExtDirect'; }
-
-my $dfile = 't/data/extdirect/route';
-my $tests = eval do { local $/; open my $fh, '<', $dfile; <$fh> } ## no critic
- or die "Can't eval $dfile: '$@'";
-
-# Testing API
-my $ct = CGI::Test->new(
- -base_url => 'http://localhost/cgi-bin',
- -cgi_dir => 't/cgi-bin',
-);
-
-BAIL_OUT "Can't create CGI::Test object" unless $ct;
-
-for my $test ( @$tests ) {
- my $name = $test->{name};
- my $url = $test->{cgi_url};
- my $method = $test->{method};
- my $input_content = $test->{input_content};
- my $http_status_exp = $test->{http_status};
- my $content_regex = $test->{content_type};
- my $expected_output = $test->{expected_content};
-
- my $page = $ct->$method($url, $input_content);
-
- if ( ok $page, "$name not empty" ) {
- my $content_type = $page->content_type();
- my $http_status = $page->is_ok() ? 200 : $page->error_code();
-
- like $content_type, $content_regex, "$name content type";
- is $http_status, $http_status_exp, "$name HTTP status";
-
- my $http_output = $page->raw_content();
- $http_output =~ s/\s//g;
- $expected_output =~ s/\s//g;
-
- is $http_output, $expected_output, "$name content"
- or diag explain $page;
-
- $page->delete();
- };
-};
-
-exit 0;
-
-sub raw_post {
- my ($url, $input) = @_;
-
- use bytes;
- my $cgi_input = CGI::Test::Input::URL->new();
- $cgi_input->add_field('POSTDATA', $input);
-
- return $cgi_input;
-}
-
-sub form_post {
- my ($url, %fields) = @_;
-
- use bytes;
- my $cgi_input = CGI::Test::Input::URL->new();
- for my $field ( keys %fields ) {
- my $value = $fields{ $field };
- $cgi_input->add_field($field, $value);
- };
-
- return $cgi_input;
-}
-
-sub form_upload {
- my ($url, $files, %fields) = @_;
-
- my $cgi_input = CGI::Test::Input::Multipart->new();
-
- for my $field ( keys %fields ) {
- my $value = $fields{ $field };
- $cgi_input->add_field($field, $value);
- };
-
- for my $file ( @$files ) {
- $cgi_input->add_file_now("upload", "t/data/cgi-data/$file");
- };
-
- return $cgi_input;
-}
+run_tests($tests, @ARGV);
@@ -1,97 +1,12 @@
use strict;
use warnings;
-no warnings 'uninitialized';
-use Test::More tests => 21;
+use lib 't/lib';
+use RPC::ExtDirect::Test::Util::CGI;
+use RPC::ExtDirect::Test::Data::Poll;
-use Data::Dumper;
+use CGI::ExtDirect;
-use CGI::Test (); # No need to import ok() from CGI::Test
-use CGI::Test::Input ();
-use CGI::Test::Input::URL ();
-use CGI::Test::Input::Multipart ();
+my $tests = RPC::ExtDirect::Test::Data::Poll::get_tests;
-BEGIN { use_ok 'CGI::ExtDirect'; }
-
-my $dfile = 't/data/extdirect/poll';
-my $tests = eval do { local $/; open my $fh, '<', $dfile; <$fh> } ## no critic
- or die "Can't eval $dfile: '$@'";
-
-# Testing API
-my $ct = CGI::Test->new(
- -base_url => 'http://localhost/cgi-bin',
- -cgi_dir => 't/cgi-bin',
-);
-
-BAIL_OUT "Can't create CGI::Test object" unless $ct;
-
-for my $test ( @$tests ) {
- my $name = $test->{name};
- my $url = $test->{cgi_url};
- my $method = $test->{method};
- my $input_content = $test->{input_content};
- my $http_status_exp = $test->{http_status};
- my $content_regex = $test->{content_type};
- my $expected_output = $test->{expected_content};
-
- my $page = $ct->$method($url, $input_content);
-
- if ( ok $page, "$name not empty" ) {
- my $content_type = $page->content_type();
- my $http_status = $page->is_ok() ? 200 : $page->error_code();
-
- like $content_type, $content_regex, "$name content type";
- is $http_status, $http_status_exp, "$name HTTP status";
-
- my $http_output = $page->raw_content();
- $http_output =~ s/\s//g;
- $expected_output =~ s/\s//g;
-
- is $http_output, $expected_output, "$name content"
- or diag explain $page;
-
- $page->delete();
- };
-};
-
-exit 0;
-
-sub raw_post {
- my $input = shift;
-
- use bytes;
- my $cgi_input = CGI::Test::Input::URL->new();
- $cgi_input->add_field('POSTDATA', $input);
-
- return $cgi_input;
-}
-
-sub form_post {
- my (%fields) = @_;
-
- use bytes;
- my $cgi_input = CGI::Test::Input::URL->new();
- for my $field ( keys %fields ) {
- my $value = $fields{ $field };
- $cgi_input->add_field($field, $value);
- };
-
- return $cgi_input;
-}
-
-sub form_upload {
- my ($files, %fields) = @_;
-
- my $cgi_input = CGI::Test::Input::Multipart->new();
-
- for my $field ( keys %fields ) {
- my $value = $fields{ $field };
- $cgi_input->add_field($field, $value);
- };
-
- for my $file ( @$files ) {
- $cgi_input->add_file_now("upload", "t/data/cgi-data/$file");
- };
-
- return $cgi_input;
-}
+run_tests($tests, @ARGV);
@@ -1,15 +1,15 @@
use strict;
use warnings;
-no warnings 'uninitialized';
-use Test::More tests => 55;
+# This test is CGI::ExtDirect specific, hence it is not unified with the rest
+# of the framework
-use CGI::Test (); # No need to import ok() from CGI::Test
-use CGI::Test::Input ();
-use CGI::Test::Input::URL ();
-use CGI::Test::Input::Multipart ();
+use Test::More tests => 54;
-BEGIN { use_ok 'CGI::ExtDirect'; }
+use lib 't/lib';
+use RPC::ExtDirect::Test::Util::CGI qw/ raw_post form_post form_upload /;
+
+use CGI::ExtDirect;
my $tests = eval do { local $/; <DATA>; } ## no critic
or die "Can't eval DATA: '$@'";
@@ -22,14 +22,20 @@ my $ct = CGI::Test->new(
BAIL_OUT "Can't create CGI::Test object" unless $ct;
+my @run_only = @ARGV;
+
+TEST:
for my $test ( @$tests ) {
my $name = $test->{name};
- my $url = $test->{url};
+ my $cgi_url = $test->{url};
my $method = $test->{method};
my $input_content = $test->{input_content};
my $http_status_exp = $test->{http_status};
my $expected_headers = $test->{http_headers};
+ next TEST if @run_only && !grep { lc $name eq lc $_ } @run_only;
+
+ my $url = $ct->base_uri . $cgi_url;
my $page = $ct->$method($url, $input_content);
if ( ok $page, "$name not empty" ) {
@@ -38,90 +44,58 @@ for my $test ( @$tests ) {
my $http_headers = $ct->http_headers;
- for my $exp_header ( keys %$expected_headers ) {
- ok exists $http_headers->{ $exp_header }, "$exp_header exists";
- is $http_headers->{ $exp_header },
- $expected_headers->{ $exp_header }, "$exp_header value";
+ for my $want_hdr ( keys %$expected_headers ) {
+ ok exists $http_headers->{ $want_hdr },
+ "$name $want_hdr exists";
+
+ my $want = $expected_headers->{ $want_hdr };
+ my $have = $http_headers->{ $want_hdr };
+ my $desc = "$name $want_hdr value";
+
+ if ( 'Regexp' eq ref $want ) {
+ like $have, $want, $desc or diag explain $page;
+ }
+ else {
+ is $have, $want, $desc or diag explain $page;
+ }
};
$page->delete();
};
};
-exit 0;
-
-sub raw_post {
- my $input = shift;
-
- use bytes;
- my $cgi_input = CGI::Test::Input::URL->new();
- $cgi_input->add_field('POSTDATA', $input);
-
- return $cgi_input;
-}
-
-sub form_post {
- my (%fields) = @_;
-
- use bytes;
- my $cgi_input = CGI::Test::Input::URL->new();
- for my $field ( keys %fields ) {
- my $value = $fields{ $field };
- $cgi_input->add_field($field, $value);
- };
-
- return $cgi_input;
-}
-
-sub form_upload {
- my ($files, %fields) = @_;
-
- my $cgi_input = CGI::Test::Input::Multipart->new();
-
- for my $field ( keys %fields ) {
- my $value = $fields{ $field };
- $cgi_input->add_field($field, $value);
- };
-
- for my $file ( @$files ) {
- $cgi_input->add_file_now("upload", "t/data/cgi-data/$file");
- };
-
- return $cgi_input;
-}
-
__DATA__
[
{ name => 'One parameter', method => 'POST', http_status => 200,
- url => 'http://localhost/cgi-bin/header1.cgi', input_content => undef,
+ url => '/header1', input_content => undef,
http_headers => {
'Status' => '200 OK',
- 'Content-Type' => 'application/json; charset=utf-8',
+ 'Content-Type' => qr{^application/json},
'Content-Length' => '44',
},
},
{ name => 'Two parameters', method => 'POST', http_status => 200,
- url => 'http://localhost/cgi-bin/header2.cgi', input_content => undef,
+ url => '/header2', input_content => undef,
http_headers => {
'Status' => '200 OK',
- 'Content-Type' => 'application/json; charset=utf-8',
+ 'Content-Type' => qr{^application/json},
'Content-Length' => '44',
},
},
{ name => 'Charset override', method => 'POST', http_status => 200,
- url => 'http://localhost/cgi-bin/header3.cgi', input_content => undef,
+ url => '/header3', input_content => undef,
http_headers => {
- 'Status' => '200 OK',
- 'Content-Type' => 'application/json; charset=iso-8859-1',
+ 'Status' => '204 No Response',
+ 'Content-Type' => qr{^text/plain},
'Content-Length' => '44',
},
},
{ name => 'Event provider cookie headers', method => 'POST',
http_status => 200,
- url => 'http://localhost/cgi-bin/header4.cgi', input_content => undef,
+ url => '/header4', input_content => undef,
http_headers => {
- 'Status' => '200 OK',
- 'Content-Type' => 'application/json; charset=iso-8859-1',
+ 'Status' => '204 No Response',
+ 'Content-Type' => qr{^text/plain},
'Content-Length' => '44',
'Set-Cookie' => 'sessionID=xyzzy; domain=.capricorn.org; '.
'path=/cgi-bin/database; expires=Thursday, '.
@@ -129,23 +103,25 @@ __DATA__
},
},
{ name => 'API cookie headers', method => 'POST', http_status => 200,
- url => 'http://localhost/cgi-bin/api4.cgi', input_content => undef,
+ url => '/api4', input_content => undef,
http_headers => {
- 'Status' => '200 OK',
- 'Content-Type' => 'application/javascript; charset=iso-8859-1',
- 'Content-Length' => '591',
+ 'Status' => '204 No Response',
+ 'Content-Type' => qr{^text/plain},
+ 'Content-Length' => '642',
'Set-Cookie' => 'sessionID=xyzzy; domain=.capricorn.org; '.
'path=/cgi-bin/database; expires=Thursday, '.
'25-Apr-1999 00:40:33 GMT; secure',
},
},
{ name => 'Router cookie headers', method => 'POST', http_status => 200,
- url => 'http://localhost/cgi-bin/router3.cgi',
- input_content => raw_post('{"type":"rpc","tid":1,"action":"Qux",'.
- ' "method":"foo_foo","data":["bar"]}'),
+ url => '/router3',
+ input_content => raw_post(
+ 'http://localhost/router',
+ '{"type":"rpc","tid":1,"action":"Qux",'.
+ ' "method":"foo_foo","data":["bar"]}'),
http_headers => {
- 'Status' => '200 OK',
- 'Content-Type' => 'application/json; charset=iso-8859-1',
+ 'Status' => '204 No Response',
+ 'Content-Type' => qr{^text/plain},
'Content-Length' => '78',
'Set-Cookie' => 'sessionID=xyzzy; domain=.capricorn.org; '.
'path=/cgi-bin/database; expires=Thursday, '.
@@ -1,107 +1,12 @@
use strict;
use warnings;
-no warnings 'uninitialized';
-use Test::More;
+use lib 't/lib';
+use RPC::ExtDirect::Test::Util::CGI;
+use RPC::ExtDirect::Test::Data::Env;
-use CGI::Test (); # No need to import ok() from CGI::Test
-use CGI::Test::Input ();
-use CGI::Test::Input::URL ();
-use CGI::Test::Input::Multipart ();
+use CGI::ExtDirect;
-use RPC::ExtDirect;
+my $tests = RPC::ExtDirect::Test::Data::Env::get_tests;
-if ( $RPC::ExtDirect::VERSION < 2.00 ) {
- plan skip_all => "RPC::ExtDirect < 2.00 doesn't support Env objects";
- exit 0;
-};
-
-plan tests => 25;
-
-use_ok 'CGI::ExtDirect';
-
-my $dfile = 't/data/extdirect/env';
-my $tests = eval do { local $/; open my $fh, '<', $dfile; <$fh> } ## no critic
- or die "Can't eval $dfile: '$@'";
-
-# Testing API
-my $ct = CGI::Test->new(
- -base_url => 'http://localhost/cgi-bin',
- -cgi_dir => 't/cgi-bin',
- -cgi_env => {
- HTTP_COOKIE => 'foo=bar',
- },
-);
-
-BAIL_OUT "Can't create CGI::Test object" unless $ct;
-
-for my $test ( @$tests ) {
- my $name = $test->{name};
- my $url = $test->{cgi_url};
- my $method = $test->{method};
- my $input_content = $test->{input_content};
- my $http_status_exp = $test->{http_status};
- my $content_regex = $test->{content_type};
- my $expected_output = $test->{expected_content};
-
- my $page = $ct->$method($url, $input_content);
-
- if ( ok $page, "$name not empty" ) {
- my $content_type = $page->content_type();
- my $http_status = $page->is_ok() ? 200 : $page->error_code();
-
- like $content_type, $content_regex, "$name content type";
- is $http_status, $http_status_exp, "$name HTTP status";
-
- my $http_output = $page->raw_content();
- $http_output =~ s/\s//g;
- $expected_output =~ s/\s//g;
-
- is $http_output, $expected_output, "$name content"
- or diag explain $page;
-
- $page->delete();
- };
-};
-
-exit 0;
-
-sub raw_post {
- my ($url, $input) = @_;
-
- use bytes;
- my $cgi_input = CGI::Test::Input::URL->new();
- $cgi_input->add_field('POSTDATA', $input);
-
- return $cgi_input;
-}
-
-sub form_post {
- my ($url, %fields) = @_;
-
- use bytes;
- my $cgi_input = CGI::Test::Input::URL->new();
- for my $field ( keys %fields ) {
- my $value = $fields{ $field };
- $cgi_input->add_field($field, $value);
- };
-
- return $cgi_input;
-}
-
-sub form_upload {
- my ($url, $files, %fields) = @_;
-
- my $cgi_input = CGI::Test::Input::Multipart->new();
-
- for my $field ( keys %fields ) {
- my $value = $fields{ $field };
- $cgi_input->add_field($field, $value);
- };
-
- for my $file ( @$files ) {
- $cgi_input->add_file_now("upload", "t/data/cgi-data/$file");
- };
-
- return $cgi_input;
-}
+run_tests($tests, @ARGV);
diff --git a/var/tmp/source/TOKAREV/CGI-ExtDirect-2.03/CGI-ExtDirect-2.03/t/cgi-bin/.placeholder b/var/tmp/source/TOKAREV/CGI-ExtDirect-2.03/CGI-ExtDirect-2.03/t/cgi-bin/.placeholder
deleted file mode 100644
index e69de29b..00000000
@@ -0,0 +1,23 @@
+#!/bin/sh
+
+exec 3<&0
+
+$PERL -x <<'END_OF_SCRIPT'
+#!perl
+
+use CGI::ExtDirect;
+
+use RPC::ExtDirect::Test::Pkg::Foo;
+use RPC::ExtDirect::Test::Pkg::Bar;
+use RPC::ExtDirect::Test::Pkg::Qux;
+
+open STDIN, '<&3' or die "Can't reopen STDIN";
+
+my $cgi = CGI::ExtDirect->new({ debug => 1 });
+
+print $cgi->api();
+
+exit 0;
+
+END_OF_SCRIPT
+
@@ -0,0 +1,30 @@
+#!/bin/sh
+
+exec 3<&0
+
+$PERL -x <<'END_OF_SCRIPT'
+#!perl
+
+use CGI::ExtDirect;
+
+use RPC::ExtDirect::API Namespace => 'myApp.ns',
+ Router_path => '/router.cgi',
+ Poll_path => '/poll.cgi',
+ Remoting_var => 'Ext.app.REMOTE_CALL',
+ Polling_var => 'Ext.app.REMOTE_POLL',
+ Auto_Connect => 1;
+
+use RPC::ExtDirect::Test::Pkg::Foo;
+use RPC::ExtDirect::Test::Pkg::Bar;
+use RPC::ExtDirect::Test::Pkg::Qux;
+
+open STDIN, '<&3' or die "Can't reopen STDIN";
+
+my $cgi = CGI::ExtDirect->new({ debug => 1 });
+
+print $cgi->api();
+
+exit 0;
+
+END_OF_SCRIPT
+
@@ -0,0 +1,31 @@
+#!/bin/sh
+
+exec 3<&0
+
+$PERL -x <<'END_OF_SCRIPT'
+#!perl
+
+use CGI::ExtDirect;
+
+use RPC::ExtDirect::API Namespace => 'Namespace',
+ Router_path => '/cgi-bin/router.cgi',
+ Poll_path => '/cgi-bin/events.cgi',
+ Remoting_var => 'Ext.app.CALL',
+ Polling_var => 'Ext.app.POLL',
+ ;
+
+use RPC::ExtDirect::Test::Pkg::Foo;
+use RPC::ExtDirect::Test::Pkg::Bar;
+use RPC::ExtDirect::Test::Pkg::Qux;
+use RPC::ExtDirect::Test::Pkg::PollProvider;
+
+open STDIN, '<&3' or die "Can't reopen STDIN";
+
+my $cgi = CGI::ExtDirect->new({ debug => 1 });
+
+print $cgi->api();
+
+exit 0;
+
+END_OF_SCRIPT
+
@@ -0,0 +1,47 @@
+#!/bin/sh
+
+exec 3<&0
+
+$PERL -x <<'END_OF_SCRIPT'
+#!perl
+
+use CGI 'cookie';
+use CGI::ExtDirect;
+
+use RPC::ExtDirect::API Namespace => 'Namespace',
+ Router_path => '/cgi-bin/router.cgi',
+ Poll_path => '/cgi-bin/events.cgi',
+ Remoting_var => 'Ext.app.CALL',
+ Polling_var => 'Ext.app.POLL',
+ ;
+
+use RPC::ExtDirect::Test::Pkg::Foo;
+use RPC::ExtDirect::Test::Pkg::Bar;
+use RPC::ExtDirect::Test::Pkg::Qux;
+use RPC::ExtDirect::Test::Pkg::PollProvider;
+
+open STDIN, '<&3' or die "Can't reopen STDIN";
+
+my $cookie = cookie(-name=>'sessionID',
+ -value=>'xyzzy',
+ -expires=>'Thursday, 25-Apr-1999 00:40:33 GMT',
+ -path=>'/cgi-bin/database',
+ -domain=>'.capricorn.org',
+ -secure=>1);
+
+my %headers = (
+ '-Status' => '204 No Response',
+ '-Content-type' => 'text/plain',
+ '-ChArSeT' => 'iso-8859-1',
+ '-Content_Length' => '123123',
+ '-cookie' => $cookie,
+);
+
+my $cgi = CGI::ExtDirect->new({ debug => 1 });
+
+print $cgi->api( %headers );
+
+exit 0;
+
+END_OF_SCRIPT
+
@@ -0,0 +1,23 @@
+#!/bin/sh
+
+exec 3<&0
+
+$PERL -x <<'END_OF_SCRIPT'
+#!perl
+
+use CGI::ExtDirect;
+
+use RPC::ExtDirect::Test::Pkg::Env;
+
+open STDIN, '<&3' or die "Can't reopen STDIN";
+
+my %headers = ();
+
+my $exd = CGI::ExtDirect->new( debug => 1 );
+
+print $exd->route(%headers);
+
+exit 0;
+
+END_OF_SCRIPT
+
@@ -0,0 +1,23 @@
+#!/bin/sh
+
+exec 3<&0
+
+$PERL -x <<'END_OF_SCRIPT'
+#!perl
+
+use CGI::ExtDirect;
+
+use RPC::ExtDirect::Test::Pkg::PollProvider;
+
+open STDIN, '<&3' or die "Can't reopen STDIN";
+
+local $RPC::ExtDirect::Test::Pkg::PollProvider::WHAT_YOURE_HAVING = '';
+
+my $cgi = CGI::ExtDirect->new({ debug => 1 });
+
+print $cgi->poll('text/plain');
+
+exit 0;
+
+END_OF_SCRIPT
+
@@ -0,0 +1,23 @@
+#!/bin/sh
+
+exec 3<&0
+
+$PERL -x <<'END_OF_SCRIPT'
+#!perl
+
+use CGI::ExtDirect;
+
+use RPC::ExtDirect::Test::Pkg::PollProvider;
+
+open STDIN, '<&3' or die "Can't reopen STDIN";
+
+local $RPC::ExtDirect::Test::Pkg::PollProvider::WHAT_YOURE_HAVING = '';
+
+my $cgi = CGI::ExtDirect->new({ debug => 1 });
+
+print $cgi->poll('text/plain', '204 No Response');
+
+exit 0;
+
+END_OF_SCRIPT
+
@@ -0,0 +1,30 @@
+#!/bin/sh
+
+exec 3<&0
+
+$PERL -x <<'END_OF_SCRIPT'
+#!perl
+
+use CGI::ExtDirect;
+
+use RPC::ExtDirect::Test::Pkg::PollProvider;
+
+open STDIN, '<&3' or die "Can't reopen STDIN";
+
+local $RPC::ExtDirect::Test::Pkg::PollProvider::WHAT_YOURE_HAVING = '';
+
+my $cgi = CGI::ExtDirect->new({ debug => 1 });
+
+my %headers = (
+ '-Status' => '204 No Response',
+ '-Content-type' => 'text/plain',
+ '-ChArSeT' => 'iso-8859-1',
+ '-Content_Length' => '123123',
+);
+
+print $cgi->poll( %headers );
+
+exit 0;
+
+END_OF_SCRIPT
+
@@ -0,0 +1,41 @@
+#!/bin/sh
+
+exec 3<&0
+
+$PERL -x <<'END_OF_SCRIPT'
+#!perl
+
+use CGI;
+use CGI::ExtDirect;
+
+use RPC::ExtDirect::Test::Pkg::PollProvider;
+
+open STDIN, '<&3' or die "Can't reopen STDIN";
+
+local $RPC::ExtDirect::Test::Pkg::PollProvider::WHAT_YOURE_HAVING = '';
+
+my $q = CGI->new();
+
+my $extdirect = CGI::ExtDirect->new({ cgi => $q, debug => 1 });
+
+my $cookie = $q->cookie(-name=>'sessionID',
+ -value=>'xyzzy',
+ -expires=>'Thursday, 25-Apr-1999 00:40:33 GMT',
+ -path=>'/cgi-bin/database',
+ -domain=>'.capricorn.org',
+ -secure=>1);
+
+my %headers = (
+ '-Status' => '204 No Response',
+ '-Content-type' => 'text/plain',
+ '-ChArSeT' => 'iso-8859-1',
+ '-Content_Length' => '123123',
+ '-cookie' => $cookie,
+);
+
+print $extdirect->poll( %headers );
+
+exit 0;
+
+END_OF_SCRIPT
+
@@ -0,0 +1,26 @@
+#!/bin/sh
+
+exec 3<&0
+
+$PERL -x <<'END_OF_SCRIPT'
+#!perl
+
+use CGI::ExtDirect;
+
+use RPC::ExtDirect::Test::Pkg::PollProvider;
+
+open STDIN, '<&3' or die "Can't reopen STDIN";
+
+my %headers = ();
+
+local $RPC::ExtDirect::Test::Pkg::PollProvider::WHAT_YOURE_HAVING
+ = 'Usual, please';
+
+my $cgi = CGI::ExtDirect->new({ debug => 1 });
+
+print $cgi->poll(%headers);
+
+exit 0;
+
+END_OF_SCRIPT
+
@@ -0,0 +1,26 @@
+#!/bin/sh
+
+exec 3<&0
+
+$PERL -x <<'END_OF_SCRIPT'
+#!perl
+
+use CGI::ExtDirect;
+
+use RPC::ExtDirect::Test::Pkg::PollProvider;
+
+open STDIN, '<&3' or die "Can't reopen STDIN";
+
+my %headers = ();
+
+local $RPC::ExtDirect::Test::Pkg::PollProvider::WHAT_YOURE_HAVING
+ = 'Ein kaffe bitte';
+
+my $cgi = CGI::ExtDirect->new({ debug => 1 });
+
+print $cgi->poll(%headers);
+
+exit 0;
+
+END_OF_SCRIPT
+
@@ -0,0 +1,26 @@
+#!/bin/sh
+
+exec 3<&0
+
+$PERL -x <<'END_OF_SCRIPT'
+#!perl
+
+use CGI::ExtDirect;
+
+use RPC::ExtDirect::Test::Pkg::PollProvider;
+
+open STDIN, '<&3' or die "Can't reopen STDIN";
+
+my %headers = ();
+
+local $RPC::ExtDirect::Test::Pkg::PollProvider::WHAT_YOURE_HAVING
+ = 'Whiskey, straight away!';
+
+my $cgi = CGI::ExtDirect->new({ debug => 1 });
+
+print $cgi->poll(%headers);
+
+exit 0;
+
+END_OF_SCRIPT
+
@@ -0,0 +1,26 @@
+#!/bin/sh
+
+exec 3<&0
+
+$PERL -x <<'END_OF_SCRIPT'
+#!perl
+
+use CGI::ExtDirect;
+
+use RPC::ExtDirect::Test::Pkg::PollProvider;
+
+open STDIN, '<&3' or die "Can't reopen STDIN";
+
+my %headers = ();
+
+local $RPC::ExtDirect::Test::Pkg::PollProvider::WHAT_YOURE_HAVING
+ = "Sorry sir, but that's not on the menu?";
+
+my $cgi = CGI::ExtDirect->new({ debug => 1 });
+
+print $cgi->poll(%headers);
+
+exit 0;
+
+END_OF_SCRIPT
+
@@ -0,0 +1,26 @@
+#!/bin/sh
+
+exec 3<&0
+
+$PERL -x <<'END_OF_SCRIPT'
+#!perl
+
+use CGI::ExtDirect;
+
+use RPC::ExtDirect::Test::Pkg::PollProvider;
+
+open STDIN, '<&3' or die "Can't reopen STDIN";
+
+my %headers = ();
+
+local $RPC::ExtDirect::Test::Pkg::PollProvider::WHAT_YOURE_HAVING
+ = "Hey man! There's a roach in my soup!";
+
+my $cgi = CGI::ExtDirect->new({ debug => 1 });
+
+print $cgi->poll(%headers);
+
+exit 0;
+
+END_OF_SCRIPT
+
@@ -0,0 +1,25 @@
+#!/bin/sh
+
+exec 3<&0
+
+$PERL -x <<'END_OF_SCRIPT'
+#!perl
+
+use CGI::ExtDirect;
+
+use RPC::ExtDirect::Test::Pkg::Foo;
+use RPC::ExtDirect::Test::Pkg::Bar;
+use RPC::ExtDirect::Test::Pkg::Qux;
+
+open STDIN, '<&3' or die "Can't reopen STDIN";
+
+my %headers = ();
+
+my $cgi = CGI::ExtDirect->new({ debug => 1 });
+
+print $cgi->route(%headers);
+
+exit 0;
+
+END_OF_SCRIPT
+
@@ -0,0 +1,29 @@
+#!/bin/sh
+
+exec 3<&0
+
+$PERL -x <<'END_OF_SCRIPT'
+#!perl
+
+use CGI::ExtDirect;
+
+use RPC::ExtDirect::Test::Pkg::Foo;
+use RPC::ExtDirect::Test::Pkg::JuiceBar;
+use RPC::ExtDirect::Test::Pkg::Qux;
+
+open STDIN, '<&3' or die "Can't reopen STDIN";
+
+# Set the cheat flag for file uploads
+local $RPC::ExtDirect::Test::Pkg::JuiceBar::CHEAT = 1;
+
+my $debug = 1;
+my %headers = ();
+
+my $cgi = CGI::ExtDirect->new({ debug => 1 });
+
+print $cgi->route(%headers);
+
+exit 0;
+
+END_OF_SCRIPT
+
@@ -0,0 +1,42 @@
+#!/bin/sh
+
+exec 3<&0
+
+$PERL -x <<'END_OF_SCRIPT'
+#!perl
+
+use CGI 'cookie';
+use CGI::ExtDirect;
+
+use RPC::ExtDirect::Test::Pkg::Foo;
+use RPC::ExtDirect::Test::Pkg::JuiceBar;
+use RPC::ExtDirect::Test::Pkg::Qux;
+
+open STDIN, '<&3' or die "Can't reopen STDIN";
+
+# Set the cheat flag for file uploads
+local $RPC::ExtDirect::Test::Pkg::JuiceBar::CHEAT = 1;
+
+my $cookie = cookie(-name=>'sessionID',
+ -value=>'xyzzy',
+ -expires=>'Thursday, 25-Apr-1999 00:40:33 GMT',
+ -path=>'/cgi-bin/database',
+ -domain=>'.capricorn.org',
+ -secure=>1);
+
+my %headers = (
+ '-Status' => '204 No Response',
+ '-Content-type' => 'text/plain',
+ '-ChArSeT' => 'iso-8859-1',
+ '-Content_Length' => '123123',
+ '-cookie' => $cookie,
+);
+
+my $cgi = CGI::ExtDirect->new({ debug => 1 });
+
+print $cgi->route( %headers );
+
+exit 0;
+
+END_OF_SCRIPT
+
@@ -1,14 +0,0 @@
-#!PUT_PERL_HERE
-
-use CGI::ExtDirect;
-
-use lib '../lib';
-use RPC::ExtDirect::Test::Foo;
-use RPC::ExtDirect::Test::Bar;
-use RPC::ExtDirect::Test::Qux;
-
-my $cgi = CGI::ExtDirect->new({ debug => 1 });
-
-print $cgi->api();
-
-exit 0;
@@ -1,21 +0,0 @@
-#!PUT_PERL_HERE
-
-use CGI::ExtDirect;
-
-use RPC::ExtDirect::API Namespace => 'myApp.ns',
- Router_path => '/router.cgi',
- Poll_path => '/poll.cgi',
- Remoting_var => 'Ext.app.REMOTE_CALL',
- Polling_var => 'Ext.app.REMOTE_POLL',
- Auto_Connect => 1;
-
-use lib '../lib';
-use RPC::ExtDirect::Test::Foo;
-use RPC::ExtDirect::Test::Bar;
-use RPC::ExtDirect::Test::Qux;
-
-my $cgi = CGI::ExtDirect->new({ debug => 1 });
-
-print $cgi->api();
-
-exit 0;
@@ -1,22 +0,0 @@
-#!PUT_PERL_HERE
-
-use CGI::ExtDirect;
-
-use RPC::ExtDirect::API Namespace => 'Namespace',
- Router_path => '/cgi-bin/router.cgi',
- Poll_path => '/cgi-bin/events.cgi',
- Remoting_var => 'Ext.app.CALL',
- Polling_var => 'Ext.app.POLL',
- ;
-
-use lib '../lib';
-use RPC::ExtDirect::Test::Foo;
-use RPC::ExtDirect::Test::Bar;
-use RPC::ExtDirect::Test::Qux;
-use RPC::ExtDirect::Test::PollProvider;
-
-my $cgi = CGI::ExtDirect->new({ debug => 1 });
-
-print $cgi->api();
-
-exit 0;
@@ -1,38 +0,0 @@
-#!PUT_PERL_HERE
-
-use CGI 'cookie';
-use CGI::ExtDirect;
-
-use RPC::ExtDirect::API Namespace => 'Namespace',
- Router_path => '/cgi-bin/router.cgi',
- Poll_path => '/cgi-bin/events.cgi',
- Remoting_var => 'Ext.app.CALL',
- Polling_var => 'Ext.app.POLL',
- ;
-
-use lib '../lib';
-use RPC::ExtDirect::Test::Foo;
-use RPC::ExtDirect::Test::Bar;
-use RPC::ExtDirect::Test::Qux;
-use RPC::ExtDirect::Test::PollProvider;
-
-my $cookie = cookie(-name=>'sessionID',
- -value=>'xyzzy',
- -expires=>'Thursday, 25-Apr-1999 00:40:33 GMT',
- -path=>'/cgi-bin/database',
- -domain=>'.capricorn.org',
- -secure=>1);
-
-my %headers = (
- '-Status' => '204 No Response',
- '-Content-type' => 'text/plain',
- '-ChArSeT' => 'iso-8859-1',
- '-Content_Length' => '123123',
- '-cookie' => $cookie,
-);
-
-my $cgi = CGI::ExtDirect->new({ debug => 1 });
-
-print $cgi->api( %headers );
-
-exit 0;
@@ -1,14 +0,0 @@
-#!PUT_PERL_HERE
-
-use CGI::ExtDirect;
-
-use lib '../lib';
-use RPC::ExtDirect::Test::Env;
-
-my %headers = ();
-
-my $exd = CGI::ExtDirect->new( debug => 1 );
-
-print $exd->route(%headers);
-
-exit 0;
@@ -1,14 +0,0 @@
-#!PUT_PERL_HERE
-
-use CGI::ExtDirect;
-
-use lib '../lib';
-use RPC::ExtDirect::Test::PollProvider;
-
-local $RPC::ExtDirect::Test::PollProvider::WHAT_YOURE_HAVING = '';
-
-my $cgi = CGI::ExtDirect->new({ debug => 1 });
-
-print $cgi->poll('text/plain');
-
-exit 0;
@@ -1,14 +0,0 @@
-#!PUT_PERL_HERE
-
-use CGI::ExtDirect;
-
-use lib '../lib';
-use RPC::ExtDirect::Test::PollProvider;
-
-local $RPC::ExtDirect::Test::PollProvider::WHAT_YOURE_HAVING = '';
-
-my $cgi = CGI::ExtDirect->new({ debug => 1 });
-
-print $cgi->poll('text/plain', '204 No Response');
-
-exit 0;
@@ -1,21 +0,0 @@
-#!PUT_PERL_HERE
-
-use CGI::ExtDirect;
-
-use lib '../lib';
-use RPC::ExtDirect::Test::PollProvider;
-
-local $RPC::ExtDirect::Test::PollProvider::WHAT_YOURE_HAVING = '';
-
-my $cgi = CGI::ExtDirect->new({ debug => 1 });
-
-my %headers = (
- '-Status' => '204 No Response',
- '-Content-type' => 'text/plain',
- '-ChArSeT' => 'iso-8859-1',
- '-Content_Length' => '123123',
-);
-
-print $cgi->poll( %headers );
-
-exit 0;
@@ -1,32 +0,0 @@
-#!PUT_PERL_HERE
-
-use CGI;
-use CGI::ExtDirect;
-
-use lib '../lib';
-use RPC::ExtDirect::Test::PollProvider;
-
-local $RPC::ExtDirect::Test::PollProvider::WHAT_YOURE_HAVING = '';
-
-my $q = CGI->new();
-
-my $extdirect = CGI::ExtDirect->new({ cgi => $q, debug => 1 });
-
-my $cookie = $q->cookie(-name=>'sessionID',
- -value=>'xyzzy',
- -expires=>'Thursday, 25-Apr-1999 00:40:33 GMT',
- -path=>'/cgi-bin/database',
- -domain=>'.capricorn.org',
- -secure=>1);
-
-my %headers = (
- '-Status' => '204 No Response',
- '-Content-type' => 'text/plain',
- '-ChArSeT' => 'iso-8859-1',
- '-Content_Length' => '123123',
- '-cookie' => $cookie,
-);
-
-print $extdirect->poll( %headers );
-
-exit 0;
@@ -1,17 +0,0 @@
-#!PUT_PERL_HERE
-
-use CGI::ExtDirect;
-
-use lib '../lib';
-use RPC::ExtDirect::Test::PollProvider;
-
-my %headers = ();
-
-local $RPC::ExtDirect::Test::PollProvider::WHAT_YOURE_HAVING
- = 'Usual, please';
-
-my $cgi = CGI::ExtDirect->new({ debug => 1 });
-
-print $cgi->poll(%headers);
-
-exit 0;
@@ -1,17 +0,0 @@
-#!PUT_PERL_HERE
-
-use CGI::ExtDirect;
-
-use lib '../lib';
-use RPC::ExtDirect::Test::PollProvider;
-
-my %headers = ();
-
-local $RPC::ExtDirect::Test::PollProvider::WHAT_YOURE_HAVING
- = 'Ein kaffe bitte';
-
-my $cgi = CGI::ExtDirect->new({ debug => 1 });
-
-print $cgi->poll(%headers);
-
-exit 0;
@@ -1,17 +0,0 @@
-#!PUT_PERL_HERE
-
-use CGI::ExtDirect;
-
-use lib '../lib';
-use RPC::ExtDirect::Test::PollProvider;
-
-my %headers = ();
-
-local $RPC::ExtDirect::Test::PollProvider::WHAT_YOURE_HAVING
- = 'Whiskey, straight away!';
-
-my $cgi = CGI::ExtDirect->new({ debug => 1 });
-
-print $cgi->poll(%headers);
-
-exit 0;
@@ -1,17 +0,0 @@
-#!PUT_PERL_HERE
-
-use CGI::ExtDirect;
-
-use lib '../lib';
-use RPC::ExtDirect::Test::PollProvider;
-
-my %headers = ();
-
-local $RPC::ExtDirect::Test::PollProvider::WHAT_YOURE_HAVING
- = "Sorry sir, but that's not on the menu?";
-
-my $cgi = CGI::ExtDirect->new({ debug => 1 });
-
-print $cgi->poll(%headers);
-
-exit 0;
@@ -1,17 +0,0 @@
-#!PUT_PERL_HERE
-
-use CGI::ExtDirect;
-
-use lib '../lib';
-use RPC::ExtDirect::Test::PollProvider;
-
-my %headers = ();
-
-local $RPC::ExtDirect::Test::PollProvider::WHAT_YOURE_HAVING
- = "Hey man! There's a roach in my soup!";
-
-my $cgi = CGI::ExtDirect->new({ debug => 1 });
-
-print $cgi->poll(%headers);
-
-exit 0;
@@ -1,16 +0,0 @@
-#!PUT_PERL_HERE
-
-use CGI::ExtDirect;
-
-use lib '../lib';
-use RPC::ExtDirect::Test::Foo;
-use RPC::ExtDirect::Test::Bar;
-use RPC::ExtDirect::Test::Qux;
-
-my %headers = ();
-
-my $cgi = CGI::ExtDirect->new({ debug => 1 });
-
-print $cgi->route(%headers);
-
-exit 0;
@@ -1,17 +0,0 @@
-#!PUT_PERL_HERE
-
-use CGI::ExtDirect;
-
-use lib '../lib';
-use RPC::ExtDirect::Test::Foo;
-use RPC::ExtDirect::Test::JuiceBar;
-use RPC::ExtDirect::Test::Qux;
-
-my $debug = 1;
-my %headers = ();
-
-my $cgi = CGI::ExtDirect->new({ debug => 1 });
-
-print $cgi->route(%headers);
-
-exit 0;
@@ -1,30 +0,0 @@
-#!PUT_PERL_HERE
-
-use CGI 'cookie';
-use CGI::ExtDirect;
-
-use lib '../lib';
-use RPC::ExtDirect::Test::Foo;
-use RPC::ExtDirect::Test::JuiceBar;
-use RPC::ExtDirect::Test::Qux;
-
-my $cookie = cookie(-name=>'sessionID',
- -value=>'xyzzy',
- -expires=>'Thursday, 25-Apr-1999 00:40:33 GMT',
- -path=>'/cgi-bin/database',
- -domain=>'.capricorn.org',
- -secure=>1);
-
-my %headers = (
- '-Status' => '204 No Response',
- '-Content-type' => 'text/plain',
- '-ChArSeT' => 'iso-8859-1',
- '-Content_Length' => '123123',
- '-cookie' => $cookie,
-);
-
-my $cgi = CGI::ExtDirect->new({ debug => 1 });
-
-print $cgi->route( %headers );
-
-exit 0;
@@ -1,19 +0,0 @@
-#!PUT_PERL_HERE
-
-use lib '../../../blib/lib';
-
-use RPC::ExtDirect::Demo::TestAction;
-use RPC::ExtDirect::Demo::Profile;
-use RPC::ExtDirect::Demo::PollProvider;
-
-use RPC::ExtDirect::API router_path => '/cgi-bin/router.cgi',
- poll_path => '/cgi-bin/poll.cgi',
- ;
-
-use CGI::ExtDirect;
-
-my $direct = CGI::ExtDirect->new;
-
-print $direct->api();
-
-exit 0;
@@ -1,15 +0,0 @@
-#!PUT_PERL_HERE
-
-use lib '../../../blib/lib';
-
-use RPC::ExtDirect::Demo::TestAction;
-use RPC::ExtDirect::Demo::Profile;
-use RPC::ExtDirect::Demo::PollProvider;
-
-use CGI::ExtDirect;
-
-my $direct = CGI::ExtDirect->new;
-
-print $direct->poll();
-
-exit 0;
@@ -1,15 +0,0 @@
-#!PUT_PERL_HERE
-
-use lib '../../../blib/lib';
-
-use RPC::ExtDirect::Demo::TestAction;
-use RPC::ExtDirect::Demo::Profile;
-use RPC::ExtDirect::Demo::PollProvider;
-
-use CGI::ExtDirect;
-
-my $direct = CGI::ExtDirect->new({ debug => 1 });
-
-print $direct->route();
-
-exit 0;
@@ -1,978 +0,0 @@
-#!PUT_PERL_HERE
-
-require 5.6.0; # needs perl > 5.6.0
-
-# This points to current blib so that freshly built CGI::ExtDirect
-# can be found and examples could be tried without installing the
-# module
-
-use lib '../blib/lib';
-
-# p5httpd: Tiny HTTP server, roughly HTTP 1.0 compliant according to
-# RFC 1945
-# - POD documentation at end of file
-# - User-serviceable configuration section below.
-# - Should work without configuration and without any additional files
-
-
-package p5httpd; # keep namespace separate from CGI scripts
-use strict;
-our $version = 0.07;
-
-################# Configuration section #######################
-
-# All filenames below have to be absolute (except $icondir).
-
-# A value of "" means that there is a reasonable default, which may
-# depend on the installation directory.
-
-# If $configdir/config_$osname exists, it is read after this
-# configuration section
-
-# ----------------- Basic configuration -----------------------
-
-# The server root directory is the place where requests for
-# http://this_host/ will look:
-# Default: ./html under the directory where p5httpd lives
-
-our $server_root = "./htdocs";
-
-# Config files are better kept in a separate directory, to avoid
-# clutter and to avoid worsening p5httpd's already dismal security :-)
-# Default: $server_root/../config
-
-our $config_dir = "";
-
-# The port on which p5httpd will listen. NB: ports below 1024 require
-# root privileges on unix machines! Default: 80
-
-our $port = 5000;
-
-# List of mime types (absolute pathname). You may use apaches
-# mime.types, or /etc/mime.types on unix machines. Default:
-# $configdir/mime.types, or else a minimal builtin list.
-
-our $mime_types = "";
-
-
-# Handlers associate a specal cgi script in cgi-bin directory with
-# specific mime-types
-our %handlers ; # = ("text/xml" => "xml.cgi");
-
-# Which filenames to treat as index files
-# Default: none
-
-our @index_filenames = qw(index.htm index.html);
-
-# ------------------ Forking and executing ------------------------
-
-# Forking policy. $never_fork and $fork_always do just what they say,;
-# $fork_after_first_invocation will cause the server to fork akways *except*
-# the first time a particular cgi script is run. This will ensure that
-# all needed modules are already loaded whenever the script is run
-# again, just as with mod_perl.
-
-my ( $never_fork, $fork_after_first_invocation, $fork_always ) = ( 1, 2, 3 );
-our $when_to_fork = $never_fork;
-
-# if a relative path matches this regexp (case-insensitively), it is
-# treated as a cgi script, and we'll try to eval or execute it.
-# Default: "\.cgi$" (matching any file with extension .cgi)
-# other possibilities: "\.pl$" or "\.(cgi|pl)$" or "\/cgi-bin\/"
-
-our $cgi_scriptname_regexp = '';
-
-# Whether to run cgi scripts by evaling or executing. $cgis_are_evaled
-# and $cgis_are_executed do just what they say, $only_perl_is_evaled
-# will run perl scripts by evaling and any other programs by executing
-# them. This is a tad expensive, as all cgi's have to
-# be sniffed and tasted before they are run.
-
-my ( $cgis_are_evaled, $only_perl_is_evaled, $cgis_are_executed ) = ( 1, 2, 3 );
-our $eval_or_execute = $cgis_are_executed;
-
-# -------------------- Icons -------------------------------------
-
-# Whether to show icons in a directory listing
-our $show_icons = 1;
-
-# icon directory, relative to $server_root. Default: "icons"
-our $icondir = ""; # relative name here!
-
-# -------------------- Authentication ---------------------------
-
-# Whether to use basic authentication as per HTTP/1.0
-# Only enable this when really needed, as it makes all requests slower
-our $use_authentication = 0;
-
-# Default: $config_dir/htpasswd
-our $password_file = "";
-
-# For every request, p5httpd will climb up the directory tree until it
-# finds either an explicitely public or a private directory. This will
-# determine whether a password is required. Default: Everything is private,
-# i.e. @public_directories = (), @private_directories = qw(/).
-# Directories are specified relative to server root, but you still
-# have to use leading and trailing slashes here:
-
-our @public_directories = qw(/);
-our @private_directories = qw(/wiki/secret/);
-
-############## End of configuration section ########################
-
-use Socket;
-use English;
-use Cwd qw(cwd abs_path);
-use autouse 'IPC::Open2' => qw( open2 );
-; # only import when needed, as EPOC (and maybe Windows?) doesn't have it.
-
-our (
- $localname, $OSNAME, $HOSTNAME, $I_am_child,
- %mime_types, %cgi_urls, %encrypted_passwords, %private,
- %public, $invocation, $p5httpd_homedir
-);
-
-initialise();
-main_loop();
-exit;
-
-################################## Subroutines ###################
-
-sub logerr($$);
-sub logmsg($);
-sub log_and_die($);
-sub cat($$;$); # forward declarations
-
-sub initialise {
- $HOSTNAME = $ENV{HOSTNAME} || "localhost";
- $I_am_child = 0
- ; # Will be 1 in child after a fork(). Children wil just exit after finishing work.
-
-
- $PROGRAM_NAME =~ s#\\#/#g;
- ($p5httpd_homedir) = ( $PROGRAM_NAME =~ m#^(.*)/# );
- $p5httpd_homedir ||= cwd; # last resort
- $p5httpd_homedir = abs_path($p5httpd_homedir);
- $p5httpd_homedir =~ s#/$##;
-
- my $extra_config_dir;
- if ($config_dir) {
- $extra_config_dir = $config_dir;
- }
- elsif ($server_root) {
- $extra_config_dir = "$server_root/../config";
- }
- elsif ( -d "$p5httpd_homedir/config" ) {
- $extra_config_dir = "$p5httpd_homedir/config";
- }
- else {
- $extra_config_dir = $p5httpd_homedir;
- }
- my $extra_config_file = "$extra_config_dir/config_$OSNAME";
- if ( -r $extra_config_file ) {
- logmsg "Reading $extra_config_file";
- do $extra_config_file;
- $@ and logmsg "Something rotten in $extra_config_file: \n$@";
- }
- elsif ( -f $extra_config_file ) {
- logmsg "$extra_config_file exists but not readable: $!";
- }
- else {
-# logmsg "looked for, but didn't find extra config in $extra_config_file";
- }
-
- # If $config_dir is still unset, set it now
- $config_dir ||= $extra_config_dir;
- push @INC, "$config_dir/modules"; # extra modules may be put here, and
- $ENV{PERL5LIB} = ( $ENV{PERL5LIB}? "$ENV{PERL5LIB}:$config_dir/modules" : "$config_dir/modules"); # ... let children know about this
-
- if ( not $server_root ) {
- $server_root = (
- -d "$p5httpd_homedir/html" ? "$p5httpd_homedir/html" : $p5httpd_homedir );
- logmsg "You didn't specify the server root directory ";
- logmsg "I'll use $server_root for now...";
- }
- $server_root =~ s#/$##; # remove final slash from $basdir
-
- $p5httpd::server_root =
- $server_root; # make this variable visible for CGI scripts
-
- $port ||= 80 unless $port;
- $password_file ||= "$config_dir/htpasswd"; # absolute path
- $mime_types ||= "$config_dir/mime.types"; # absolute path
- $icondir ||= 'icons'; # relative to $server_root
- $cgi_scriptname_regexp ||= '\.cgi$';
-
- if ( $mime_types and open MIME, $mime_types ) {
- while (<MIME>) { # read list of mime types
- chomp;
- s/#.*//; # ignore comments
- my ( $type, @suffixes ) = split;
- next unless @suffixes;
- foreach my $suffix (@suffixes) {
- $mime_types{".$suffix"} = $type; # e.g " $mime_types{.png} = "image/png"
- }
- }
- close MIME;
- }
- else {
- logmsg(
- (
- $mime_types
- ? "Couldn't read MIME types file $mime_types."
- : "No MIME types configured"
- )
- . " Using a minimal set instead"
- );
- %mime_types = (
- ".gif" => "image/gif",
- ".jpg" => "image/jpeg",
- ".htm" => "text/html",
- ".html" => "text/html"
- );
- }
-
- if ($use_authentication) { # read passwords
- open PASS, $password_file
- or log_and_die "Couldn't read password file $password_file: $!\n";
- while (<PASS>) {
- s/\s//g;
- next if /^#/; # comments in a passwd file? Hmmm...
- my ( $name, $encrypted_password ) = split /:/;
- $encrypted_passwords{$name} = $encrypted_password
- if $encrypted_password;
- }
- close PASS;
-
- # initialise directory hashes
- foreach my $dir (@public_directories) { $public{$dir} = 1; }
- foreach my $dir (@private_directories) { $private{$dir} = 1; }
- }
-
- unless ( $when_to_fork == $never_fork ) {
- logmsg "Setting SIG{CHLD} to 'IGNORE'";
- $SIG{CHLD} = 'IGNORE'
- ; # We don't care about children's exit status, we just don't want zombies
- }
-
-}
-
-sub main_loop {
-
- # Standard Perl incantation for creating a server socket:
- my $tcp = getprotobyname('tcp');
- socket( Server, PF_INET, SOCK_STREAM, $tcp ) or log_and_die "socket: $!";
- setsockopt( Server, SOL_SOCKET, SO_REUSEADDR,
- pack( "l", 1 ) ) # to prevent "address in use" errors
- or $OSNAME =~ /EPOC/i or logmsg " Warning: setsockopt: $!";
- if ( not bind( Server, sockaddr_in( $port, INADDR_ANY ) ) ) {
- log_and_die(
- $port < 1024
- ? " bind: $! (ports below 1024 require root privs on unix-like systems)\n"
- : "bind: $!\n"
- );
- }
- listen( Server, SOMAXCONN ) or log_and_die " listen: $!";
- logmsg
- "Server started on port $port.\n\nPoint your browser at http://$HOSTNAME"
- . ( $port == 80 ? "" : ":$port" );
-
-CONNECT:
- for ( ; accept( Client, Server ) ; close Client ) {
-
- my $remote_sockaddr = getpeername(Client);
- my ( undef, $iaddr ) = sockaddr_in($remote_sockaddr);
- my $peername = gethostbyaddr( $iaddr, AF_INET ) || "localhost";
- my $peeraddr = inet_ntoa($iaddr) || "127.0.0.1";
-
- my $local_sockaddr = getsockname(Client);
- my ( undef, $iaddr_local ) = sockaddr_in($local_sockaddr);
- $localname = gethostbyaddr( $iaddr_local, AF_INET ) || "localhost";
- my $localaddr = inet_ntoa($iaddr_local) || "127.0.0.1";
-
- $INPUT_RECORD_SEPARATOR =
- "\n"; # input record separator should be \n here (the default)
- $OUTPUT_AUTOFLUSH = 1;
-
- chomp( $_ = <Client> ); # get Request-Line
- my ( $method, $url, $proto, undef ) =
- split; # parse it
-
- if ( not $proto ) { # Whoa! HTTP 0.9 here
- print Client
-"<html><head></head><body> <H1>This server doesn't speak HTTP 0.9!</H1> </body></html>";
- next CONNECT;
- }
- $url =~ s#\\#/#g; # rewrite bla\sub as bla/sub
- logmsg "<- $peername: $_";
- my ( $abs_path, undef, $arglist ) =
- ( $url =~ /([^?]*)(\?(.*))?/ ); # split at ?
-
-# An "absolute path" in RFC 1945-speak denotes a file *relative* to the server root!
- if ( $abs_path !~ m#^/# ) {
- logmsg "Whoa! an absolute path should begin with a slash /";
- $abs_path = "/$abs_path";
- }
-
- my $path_info;
- if ( not $arglist and $abs_path =~ m#(.*?\.cgi)/(.+)#i ) {
- redirect("$1?$2");
- next CONNECT;
- }
- my $abs_path_escaped = $abs_path; # keep a copy of filename with escapes
- $abs_path =~ s/%([\dA-Fa-f]{2})/chr(hex($1))/eg; # %20 -> space
-
- fork_if_necessary($abs_path)
- and next CONNECT
- ; # if we have indeed forked, the child will handle the request and we can move on...
-
- if ( $method !~ /^(GET|POST|HEAD)$/ ) {
- logerr 501, "I don't understand method $method";
- exit if $I_am_child;
- next CONNECT;
- }
-
- my ( $user, $passphrase );
- $ENV{USER_AGENT} = $ENV{CONTENT_LENGTH} = $ENV{CONTENT_TYPE} = undef;
- while (<Client>)
- { # gobble up all remaining headers and notice the relevant ones:
- s/[\r\l\n\s]+$//;
- /^User-Agent: (.+)/i and $ENV{USER_AGENT} = $1;
- /^Content-length: (\d+)/i and $ENV{CONTENT_LENGTH} = $1;
- /^Content-type: (.+)/i and $ENV{CONTENT_TYPE} = $1;
- /^Authorization:\s+Basic\s+(.+)/i and $passphrase = $1;
-
- if (/^HTTP-(.+?): (.+)/i)
- { # any header like HTTP-Blah-Gurgle is put in BLAH_GURGLE
- my $environment_variable = uc($1);
- $environment_variable =~ s/-/_/g;
- $ENV{$environment_variable} = $2;
- }
-
- # We don't honour If-Modified-Since
- last if (/^$/);
-
- }
-
- if ($use_authentication) {
- $user = authorized( $abs_path, $passphrase );
- if ( not defined $user )
- { # $abs_path is private, and authentication failed
- challenge( "p5httpd", $abs_path );
- exit if $I_am_child;
- next CONNECT;
- }
- }
- if ( -d "$server_root$abs_path" ) {
- unless ( $abs_path =~ m#/$# ) { # does $abs_path end with a slash ?
- redirect("$abs_path/"); # no? redirect to $abs_path/
- exit if $I_am_child;
- next CONNECT;
- }
-
- # we can from now on assume that $abs_path ends with a slash
-
- my $do_listing = 1;
- foreach my $index (@index_filenames)
- { # check for existence of an index page
- if ( -f "$server_root$abs_path$index" ) {
- $abs_path .= $index;
- $do_listing = 0;
- last;
- }
- }
- if ($do_listing) { # no index found, do directory listing
- directory_listing($abs_path);
- exit if $I_am_child;
- next CONNECT;
- }
- } # if (-d "$server_root$abs_path"
-
- if ( not -r "$server_root$abs_path" ) { # check for existence of abs_path
- logerr 404, "$abs_path: $!";
- exit if $I_am_child;
- next CONNECT;
- }
-
- print Client "HTTP/1.0 200 OK\n"; # probably OK by now
-
- my $mime_type = filetype($abs_path);
-
- my $handler = $handlers{$mime_type};
-
- if ($handler) { # call handler
- $arglist = "file=$abs_path";
- $abs_path = "/cgi-bin/$handler";
- $mime_type = "application/cgi";
- $url = "$abs_path?$arglist";
- $method = "GET";
- }
-
- if ( $mime_type eq "application/cgi" )
- { # cf. the specification at http://hoohoo.ncsa.uiuc.edu/cgi/env.html
- $ENV{SERVER_SOFTWARE} = "p5httpd/$version";
- $ENV{SERVER_NAME} = $localname;
- $ENV{GATEWAY_INTERFACE} = "CGI/1.1";
- $ENV{SERVER_PROTOCOL} = $proto;
- $ENV{SERVER_PORT} = $port;
- $ENV{REQUEST_METHOD} = $method;
- $ENV{PATH_INFO} = $path_info;
-
- # $ENV{PATH_TRANSLATED} = Ehrrm....??
- $ENV{SCRIPT_NAME} = $abs_path;
- $ENV{QUERY_STRING} = $arglist;
- $ENV{REMOTE_HOST} = $peername;
- $ENV{REMOTE_ADDR} = $peeraddr;
- $ENV{AUTH_TYPE} = ( $use_authentication ? "Basic" : "" );
- $ENV{REMOTE_USER} = ( $use_authentication ? $user : "" );
- $ENV{SERVER_URL} = "http://$localname:$port/";
- $ENV{SCRIPT_FILENAME} = "$server_root$abs_path";
- $ENV{REQUEST_URI} = $url;
- $ENV{SERVER_ROOT} = $server_root; # non-standard?
-
- if ( $method =~ /POST/ ) {
- logmsg
- "<- Content-length: $ENV{CONTENT_LENGTH}, type: $ENV{CONTENT_TYPE}";
- }
- cgi_run( $abs_path, $arglist, $method );
- exit if $I_am_child;
- next CONNECT;
- }
-
-
- cat $abs_path, $mime_type, $method || logerr 500, "$abs_path: $!";
- exit if $I_am_child;
- next CONNECT;
- }
- log_and_die "$$ Fatal error: accept failed: $!\n"; # This should never happen
-}
-
-#################### other subroutines ####################
-
-# fork_if_necessary() inspects $when_to_fork and forks when it thinks it should.
-# This may involve keeping track of cgi script invocations when
-# $when_to_fork == $fork_after_first_invocation
-# Return value: 0 in child, when forking is not necessary, or after failure;
-# child pid in parent
-
-sub fork_if_necessary {
- my ($file) = @_;
- my $pid = 0;
- if ( # always fork, or second or later invocation of .cgi script?
- $when_to_fork == $fork_always
- or ( $when_to_fork != $never_fork
- and ( filetype($file) ne "application/cgi" or $cgi_urls{$file}++ ) )
- )
- {
- eval {$pid = fork()};
- if ( $@ or $pid < 0 ) {
- warn
- "Couldn't fork now and won't try again (can your OS ever do it?): $@";
- $when_to_fork = $never_fork;
- return 0;
- }
- $I_am_child = 1 unless $pid;
- }
- return $pid;
-}
-
-# logmsg "Couldn't frob the gnargle: $!"; logs a time-stamped message,
-# folowed by newline, to STDERR. No return value.
-
-sub logmsg ($) {
- my ($text) = (@_);
- my $fulltime = localtime();
- my $PID = sprintf "%5d", $$;
- my ($hms) = ( $fulltime =~ /(\d\d:\d\d:\d\d)/ );
- my @text = split /\n/, $text;
- foreach my $line (@text) {
- print STDERR "$PID $hms $line\n";
- }
-}
-
-sub log_and_die ($) {
- my ($text) = (@_);
- logmsg "FATAL: $text";
- die "\n";
-}
-
-# logerr 404, "No gnargles here, sorry!"; signals error to browser,
-# logging it to STDERR as well. No return value.
-
-sub logerr ($$) {
- my ( $code, $detail ) = @_;
- my %codes = (
- 200 => 'OK',
- 400 => 'Bad Request',
- 403 => 'Access Denied',
- 404 => 'Not Found',
- 500 => 'Internal Server Error',
- 501 => 'Not Implemented',
- );
- my $msg = "$code " . $codes{$code};
- logmsg "-> $msg $detail";
- print Client <<EOF;
- HTTP/1.0 $msg
- Content-type: text/html
-
- <html><body>
- <h1>$msg</h1>
- <p>$detail</p>
- <hr>
- <p><I>p5httpd/$version server at $localname port $port</I></p>
- </body></html>
-EOF
-}
-
-# cat "relative/path", "text/html", $method; writes the appropriate
-# response headers to STDOUT. If $method == GET (which is the default)
-# then the file is dumped on STDOUT as well.
-
-sub cat($$;$) {
- my ( $file, $mimetype, $method ) = @_;
- $method = "GET" unless $method;
- my $fullpath = "$server_root$file";
-
- my ( undef, undef, undef, undef, undef, undef, undef, $length, undef, $mtime )
- = stat($fullpath);
- $mtime = gmtime $mtime;
- my ( $day, $mon, $dm, $tm, $yr ) =
- ( $mtime =~ m/(...) (...) (..) (..:..:..) (....)/ );
-
- print Client "Content-length: $length\n";
- print Client "Last-Modified: $day, $dm $mon $yr $tm GMT\n";
- print Client "Content-type: $mimetype\n\n";
- my $sent = 0;
- if ( $method eq "GET" ) {
- local $INPUT_RECORD_SEPARATOR = undef; # gobble whole files, but only here
- open IN, "<$fullpath" || return 0;
- my $content = <IN>;
- close IN;
- $sent = length($content);
- print Client $content;
- }
- logmsg "-> 200 OK $file: $sent bytes sent as $mimetype";
- return 1;
-}
-
-# cgi_run("relative/path.cgi", "encoded%20arglist", $method) changes to directory
-# where script lives, and then either evals or executes it.
-
-sub cgi_run {
- my ( $script, $arglist, $method ) = @_;
- my ($dir) = ( $script =~ /^(.*\/)/ );
- my $script_path = "$server_root$script";
- my $script_text;
- my $old_chdir = cwd();
- chdir "$server_root$dir"
- or return logerr 500, "Cannot chdir to $server_root$dir: $!";
- $script_path =~ s/[A-Z]://;
-
-# command line decoding, cf description at http://hoohoo.ncsa.uiuc.edu/cgi/cl.html:
- local @ARGV;
- unless ( $arglist =~ /=/ ) {
- $arglist =~
- s/%([\dA-Fa-f]{2})/chr(hex($1))/eg; # decode arglist, e.g. %20 -> space
- @ARGV = split /\s+/, $arglist;
- }
- my $file_tastes_like_perl = 1;
- if ( $eval_or_execute != $cgis_are_executed ) {
-
- open CGI, $script_path
- or return do {
- chdir $old_chdir;
- logerr 500, "Cannot read $script_path: $!";
- };
- my ( $script_text, $nread );
- if ( $eval_or_execute == $only_perl_is_evaled ) {
- logmsg "sniffing and tasting $script...";
- $nread = read CGI, $script_text, 100, 0; # taste first 100 bytes
- defined $nread
- or return do {
- chdir $old_chdir;
- logerr 500, "Read error reading $script_path: $!";
- };
- if ( $script_text !~ /#!.*perl/i )
- { # No #!/.../perl? Then it's not a perl script.
- logmsg "yeachh! $script doesn't taste like perl!";
- close CGI;
- $file_tastes_like_perl = 0;
- }
- }
- if ($file_tastes_like_perl) {
- {
- local $INPUT_RECORD_SEPARATOR = undef; # gobble rest of $script
- $script_text .= <CGI>;
- }
- close CGI;
- logmsg "-> eval'ing $script_path";
- my $package_name = $script; # most CGI's dont bother to set package name.
- $package_name =~ # mangle filename into package name in order to
- s/\W/_/g; # avoid variable name clashes when in non-forking mode
- eval <<EOF;
- local *STDIN = *Client;
- local *STDOUT = *Client;
- package $package_name;
- no strict;
- $script_text
-EOF
- $@ and logerr 500, "in $script:<br> <pre>$@</pre>";
- }
- }
- if ( $eval_or_execute == $cgis_are_executed or not $file_tastes_like_perl ) {
-
- #
- # First they're chdir()'ing to where the script lives and then
- # they try to open it using relative path starting from $0? WTF?!
- #
- my ($chdir_script_path) = $script_path =~ m{^.*[/\\](.*?)$};
-
- -x $chdir_script_path or logerr 500, "Cannot execute $script_path: $!";
- local $ENV{CHLD} = 'DEFAULT';
-
- logmsg "-> exec'ing $chdir_script_path";
- my ( $pid, $cgi_out, $cgi_in, $output, $errors );
- my $parent_pid = $PID;
- # the extra "" avoids the shell
- eval { $pid = open2( $cgi_out, $cgi_in, "$^X $chdir_script_path" ) };
- if ($@) { # we may be kid here from open2's fork(). Weird...
- logmsg "(NB: note my PID!) When trying to execute $script:";
- chomp($@);
- logmsg $@;
- exit 0 unless $PID == $parent_pid;
- }
- else {
- if ( $method =~ /POST/i ) {
- read( Client, $_, $ENV{CONTENT_LENGTH} );
- local $SIG{PIPE} = 'IGNORE'; # avoid choking on broken pipe
- print $cgi_in $_; # .. when tring to talk to a dead kid.
- }
- close $cgi_in;
- {
- local $INPUT_RECORD_SEPARATOR = undef; # slurp!
- $output = <$cgi_out>;
- }
- close $cgi_out;
- waitpid( $pid, 0 );
- if ( $output =~ m#^\r?Content-Type:.*?\r?\n\r?\n#mi or $output =~/^\r?Status:\s+302/ ) {
- print Client $output;
- }
- else { # Capturing scripts stderr with open3 would be just too painful
- # (deadlock problems) so we're almost as unhelpful as apache!
- print STDERR $output;
- logerr 500,
- "Premature end of script headers."
- . ( $? ? "<br> Status: $?" : "" )
- . "<br>Have a look at server log for stderr output of $script";
- }
- }
- }
- chdir $old_chdir;
-}
-
-sub directory_listing {
- my ($dir) = @_;
- $dir =~ s#//#/#g;
- chdir "$server_root$dir"
- or return logerr 500, "Cannot chdir to $server_root$dir: $!";
- my @files = glob("*");
- @files = sort @files;
- $dir eq "/" or @files = ( "..", @files );
- print Client <<EOF;
-HTTP/1.0 200 OK
-Content-type: text/html
-
- <html>
- <head><title>$dir</title></head>
- <body>
- <h1>$dir</h1>
- <pre>
-EOF
- foreach my $file (@files) {
- print_direntry($file);
- }
- print Client <<EOF;
- </pre>
- <hr>
- <p><I>p5httpd/$version server at $localname port $port</I>
- </body>
- </html>
-EOF
- logmsg "-> 200 OK listing $dir";
-}
-
-sub filetype {
- my ($relpath) = @_;
- $relpath eq '..' and return "folder/parent";
- -d $relpath and return "folder/normal";
- ( cwd . "/$relpath" ) =~ /$cgi_scriptname_regexp/i
- and return "application/cgi";
- my ($suffix) = ( $relpath =~ /(\.\w+)$/ );
- my $type = $mime_types{ lc($suffix) };
- $type ||= "text/plain";
- return $type;
-}
-
-sub print_direntry {
- my @months = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
- my ($file) = @_;
- my ( undef, undef, undef, undef, undef, undef, undef, $size, undef, $mtime ) =
- stat $file;
- my ( $icon, $type );
- if ($show_icons) {
- $type = filetype($file);
- $type =~ s/\//_/g;
- -r "$server_root/$icondir/$type.gif" or $type = "unknown";
- $icon = "$icondir/$type.gif";
- $icon = ( -r "$server_root/$icon" ? "<img src=\"/$icon\">" : "" );
- }
- my $filename = ( $file eq ".." ? "Parent directory" : $file );
- $filename = (
- length($filename) > 18
- ? sprintf( "%18.18s", $filename ) . ".."
- : $filename
- );
- $filename .= "/" if $type eq "folder_normal";
- my ( $x, $min, $hour, $mday, $mon, $year ) = localtime $mtime;
- $year += 1900;
- $min = sprintf "%2.2d", $min;
- $hour = sprintf "%2.2d", $hour;
- my $date = "$mday-$months[$mon]-$year $hour:$min";
- my $spacing = " " x ( 25 - length($filename) );
- printf Client "%s <a href=\"%s\">%s</a>%s %20.20s %8.8s\n", $icon, $file,
- $filename, $spacing, $date, $size;
-}
-
-sub redirect {
- my ($redir) = @_;
- print Client "HTTP/1.0 301 Moved Permanently\nLocation: $redir\n\n";
- logmsg "-> 301 Moved Permanently to $redir";
-}
-
-sub challenge {
- my ( $realm, $file ) = @_;
- print Client
-"HTTP/1.0 401 Access Denied\nContent-type: text/html\nWWW-Authenticate: Basic realm=\"$realm\"\n\n";
- logmsg "-> Authentication requested for $file";
-}
-
-sub authorized {
- my ( $file, $passphrase ) = @_;
- my $parent = $file;
- do { # check whether $file is public or private
- # by stripping away final path components until
- return ""
- if $public{
- "$parent/"}; # either a public or a private directory is reached
- goto PROTECTED
- if $private{"$parent/"}; # "last" would test the wile clause once more
- } while ( $parent =~ s#/[^/]*$## );
-PROTECTED:
- logmsg "checking password";
- $passphrase =~ tr#A-Za-z0-9+/##cd; # remove non-base64 chars
- $passphrase =~ tr#A-Za-z0-9+/# -_#; # convert to uuencoded format
- my $len = pack( "c", 32 + 0.75 * length($passphrase) ); # compute length byte
- my $decoded = unpack( "u", $len . $passphrase ); # uudecode and print
- my ( $name, $password ) = split /:/, $decoded;
-
- if ( my $encrypted_password = $encrypted_passwords{$name} ) {
- return $name
- if crypt( $password, $encrypted_password ) eq
- $encrypted_password; # check password
- }
- return undef; # failed
-}
-
-__END__
-
-
-=head1 NAME
-
-p5httpd - tiny perl http server
-
-=head1 SYNOPSIS
-
-path/to/p5httpd.pl (or click on the icon)
-
-=head1 DESCRIPTION
-
-p5httpd is a simple HTTP 1.0 server written as a single perl
-file. Written for use on a hand-held machine, it should be useful on
-any machine as a quick and dirty, non-secure webserver for occasional
-use.
-
-Understands PUT, GET, and HEAD, can do basic authentication and
-directory listings. CGI scripts can be executed or, if they are perl
-scripts, eval'ed.
-
-
-
-=head1 INSTALLATION AND CONFIGURATION
-
-p5httpd.pl is a single file, containing a small configuration section
-at the beginning, and this POD documentation at the end. This single
-file, unedited, is already functional, but it will be more useful if
-you unzip the whole distribution and edit the first few lines of the
-server program to adapt it to your installation
-
-=head1 FORKING POLICY
-
-Unix servers typically use fork() in order to be ready for the next
-request as soon as possible, delegating the hard work to a child
-process. This may result in better performance (e.g. when requesting a
-page with a lot of images), but perl CGI scripts will have to load all
-their modules every time they're run.
-
-A non-forking server will run all scripts in the same interpreter
-process, an thus will have to load the modules ony once. For
-heavyweight modules like CGI.pm this may make a big difference.
-
-p5httpd can be configured (with the config variable $when_to_fork) to
-fork always, never, or always except the first time a particular
-script is run. This last policy combines the advantages of the
-always-forking and never-forking policies, as the server (and hence
-its children) will have the script's required modules loaded after its
-first (non-forking) run. In this case, expensive re-initialisations
-can also be avoided.
-
-=head1 EVAL OR EXECUTE?
-
-
-cgi scripts can be executed as a separate process, or they can be run
-(eval'ed) in the same interpreter as the server, if they are written
-in perl. You can configure the sever (with the config variable
-$eval_or_execute) to always execute, or always eval cgi scripts. It
-can also look at the script and try to find out whether it is perl (it
-then looks for the slashbang pattern #!/.../perl).
-
-
-=head1 SECURITY AND AUTHENTICATION
-
-p5httpd should not be used when security is critical. It can only use
-the "Basic" authentication scheme, where usernames and passwords are
-sent unencrypted over the network. It uses the same htpasswd files as
-apache (use the htpasswd (1) program, or
-http://www.euronet.nl/~arnow/htpasswd/ to generate them).
-
-A list of public directories and another list of private directories
-(in the config variables @public_directories and @private_directories)
-determines when authentication is requested: for any file access,
-p5httpd climbs up the directory tree until it finds a directory in
-either list (the public list is tried first)
-
-=head1 PATH INFO
-
-As a workaround for a bug in EPOC Opera (which will not reliably POST
-to an URL of the form /path/to.cgi?args) any requests to
-/path/to.cgi/args are redirected to /path/to.cgi?args. This is I<not>
-path info as per HTTP/1.0, and PATH_INFO will not be set.
-
-
-=head1 CGI SCRIPT PITFALLS WITH p5httpd
-
-Depending on the forking policy,and whether cgi's are eval'ed or
-executed, you may have to take some care when writing your scripts.
-When all cgi's are executed, and/or when the server forks for evey
-request, your scripts execute with "a clean slate" every time. This is
-the setting to use whenever you use cgi's that normally run on
-e.g. apache, at least initially, before you try the more dangerous
-(but possibly faster) settings.
-
-On the other extreme, when you evaluate your scripts and never fork(),
-(which is the only setting that works on EPOC/psion), there are a
-couple of things to watch out for:
-
-=over 4
-
-
-
-
-
-=item scope issues
-
-All CGI scripts run in a separate namespace, derived from the script
-name. Just as with e.g. mod_perl, package globals remain defined
-across invocations. This may be very useful in some situations
-(e.g. for preserving an expensive initialisation), but you should be
-aware of it. Unless you know what you're doing, take the following
-advice from the mod_perl FAQ:
-
-I<Properly scope your variables. Stop and read that sentence
-again. Conventional CGI scripts can be as sloppy with their namespace
-as they want, since they are restarted anew for each request. Your
-mod_perl script has a much longer lifetime (potentially as long as
-your [...] server is running), and requires much more care. Scope
-everything except long-lived variables with my() and use strict; so
-Perl will demand that you recognize your global variables.>
-
-I<Localize global variables. If you change any of Perl's global
-variables (e.g. $/ to change the input record separator), or even your
-own global variables remember to reset them or better still, always
-localize global variables before using them, e.g. local($/) =
-undef. If you can, reduce your dependency on global variables>
-
-
-=item die() and exit()
-
-If you call C<exit()> in your script, the whole server will quit
-(C<die()> will just print an error message). CGI scripts may hang, or
-even crash, the server. Filehandles remain open across invocations.
-
-=item CGI.pm
-
-If you use the C<CGI.pm> package, you have to use the (undocumented)
-subroutine C<CGI::initialize_globals()> to get it to re-read the script
-parameters. If you don't, the script will only read them the first
-time it runs.
-
-=back
-
-The server does a C<chdir> to a script's directory before running it,
-and sets the environment variable SERVER_ROOT to the absolute pathname
-of the server root directory.
-
-
-=head1 REQUIRES
-
-p5httpd needs perl 5.6.0 or newer It works
-on machines that cannot fork() (like Psion handhelds) but it can use
-fork() if available. Needs the IPC::Open2 module whenever a cgi should
-be executed (not eval'ed). This module may only be present on
-Unix-like systems.
-
-
-=head1 CREDITS
-
-Originally based on phttpd (pure perl httpd, (C) Paul Tchistopolskii
-1998, 99 The Wiki packaged with this server is based on QuickiWiki (C)
-Copyright 1999-2000 Ward Cunningham.
-
-=head1 AUTHOR
-
-Hans Lub. Bug reports to hlub@knoware.nl
-
-
-=head1 COPYRIGHT
-
-Copyright (c) 2002-2004 Hans Lub. This program is free software; you
-can redistribute it and/or modify it under the same terms as
- Perl itself
-
-=cut
-
-# Local Variables:
-# mode: cperl
-# End:
-
-
-
-
-
-
-
-
-
-
-
-
-
@@ -1,111 +0,0 @@
-[
- { name => 'API 1', cgi_url => 'http://localhost/cgi-bin/api1.cgi',
- plack_url => '/api', method => 'GET', input_content => undef,
- plack_input => [ api_path => '/api', debug => 1, no_polling => 1,
- router_path => '/extdirectrouter', ],
- http_status => 200, content_type => qr|^application/javascript\b|,
- expected_content => q~
- Ext.app.REMOTING_API = {
- "actions":{
- "Bar": [
- { "len":5, "name":"bar_bar" },
- { "formHandler":true, "len":0, "name":"bar_baz" },
- { "len":4, "name":"bar_foo" }
- ],
- "Foo": [
- { "len":2, "name":"foo_bar" },
- { "name":"foo_baz", "params":["foo","bar","baz"] },
- { "len":1, "name":"foo_foo" }
- ],
- "Qux": [
- { "len":5, "name":"bar_bar" },
- { "formHandler":true, "len":0, "name":"bar_baz" },
- { "len":4, "name":"bar_foo" },
- { "len":2, "name":"foo_bar" },
- { "name":"foo_baz", "params":["foo","bar","baz"] },
- { "len":1, "name":"foo_foo" }
- ]
- },
- "type":"remoting",
- "url":"/extdirectrouter"
- };
- ~,
- },
- { name => 'API 2', cgi_url => 'http://localhost/cgi-bin/api2.cgi',
- plack_url => '/api', method => 'GET', input_content => undef,
- plack_input => [ api_path => '/api', namespace => 'myApp.ns',
- auto_connect => 1, router_path => '/router.cgi',
- debug => 1, remoting_var => 'Ext.app.REMOTE_CALL',
- no_polling => 1 ],
- http_status => 200, content_type => qr|^application/javascript\b|,
- expected_content => q~
- Ext.app.REMOTE_CALL = {
- "actions":{
- "Bar": [
- { "len":5, "name":"bar_bar" },
- { "formHandler":true, "len":0, "name":"bar_baz" },
- { "len":4, "name":"bar_foo" }
- ],
- "Foo": [
- { "len":2, "name":"foo_bar" },
- { "name":"foo_baz", "params":["foo","bar","baz"] },
- { "len":1, "name":"foo_foo" }
- ],
- "Qux": [
- { "len":5, "name":"bar_bar" },
- { "formHandler":true, "len":0, "name":"bar_baz" },
- { "len":4, "name":"bar_foo" },
- { "len":2, "name":"foo_bar" },
- { "name":"foo_baz", "params":["foo","bar","baz"] },
- { "len":1, "name":"foo_foo" }
- ]
- },
- "namespace":"myApp.ns",
- "type":"remoting",
- "url":"/router.cgi"
- };
- Ext.direct.Manager.addProvider(Ext.app.REMOTE_CALL);
- ~,
- },
- { name => 'API 3', cgi_url => 'http://localhost/cgi-bin/api3.cgi',
- plack_url => '/api', method => 'GET', input_content => undef,
- plack_input => [ remoting_var => 'Ext.app.CALL', debug => 1,
- polling_var => 'Ext.app.POLL', auto_connect => 0,
- router_path => '/cgi-bin/router.cgi',
- poll_path => '/cgi-bin/events.cgi',
- namespace => 'Namespace', api_path => '/api', ],
- http_status => 200, content_type => qr|^application/javascript\b|,
- expected_content => q~
- Ext.app.CALL = {
- "actions":{
- "Bar": [
- { "len":5, "name":"bar_bar" },
- { "formHandler":true, "len":0, "name":"bar_baz" },
- { "len":4, "name":"bar_foo" }
- ],
- "Foo": [
- { "len":2, "name":"foo_bar" },
- { "name":"foo_baz", "params":["foo","bar","baz"] },
- { "len":1, "name":"foo_foo" }
- ],
- "Qux": [
- { "len":5, "name":"bar_bar" },
- { "formHandler":true, "len":0, "name":"bar_baz" },
- { "len":4, "name":"bar_foo" },
- { "len":2, "name":"foo_bar" },
- { "name":"foo_baz", "params":["foo","bar","baz"] },
- { "len":1, "name":"foo_foo" }
- ]
- },
- "namespace":"Namespace",
- "type":"remoting",
- "url":"/cgi-bin/router.cgi"
- };
- Ext.app.POLL = {
- "type":"polling",
- "url":"/cgi-bin/events.cgi"
- };
- ~,
- },
-]
-
@@ -1,94 +0,0 @@
-[
- {
- name => 'http list', method => 'POST',
- cgi_url => 'http://localhost/cgi-bin/env.cgi',
- plack_url => 'http://localhost/router',
- plack_input => [ router_path => '/router', debug => 1, ],
- input_content => raw_post(
- 'http://localhost/router',
- '{"type":"rpc","tid":1,"action":"Env",'.
- ' "method":"http_list","data":[]}'),
- http_status => 200, content_type => qr|^application/json\b|,
- expected_content =>
- q|{"action":"Env","method":"http_list","result":|.
- q|["HTTP_ACCEPT","HTTP_ACCEPT_CHARSET","HTTP_CONNECTION",|.
- q|"HTTP_COOKIE","HTTP_HOST","HTTP_USER_AGENT"],|.
- q|"tid":1,"type":"rpc"}|,
- },
- {
- name => 'http header', method => 'POST',
- cgi_url => 'http://localhost/cgi-bin/env.cgi',
- plack_url => 'http://localhost/router',
- plack_input => [ router_path => '/router', debug => 1, ],
- input_content => raw_post(
- 'http://localhost/router',
- '{"type":"rpc","tid":1,"action":"Env",'.
- ' "method":"http_header","data":["HTTP_USER_AGENT"]}'),
- http_status => 200, content_type => qr|^application/json\b|,
- expected_content =>
- q|{"action":"Env","method":"http_header","result":|.
- q|"CGI::Test",|.
- q|"tid":1,"type":"rpc"}|,
- },
- {
- name => 'param list', method => 'POST',
- cgi_url => 'http://localhost/cgi-bin/env.cgi',
- plack_url => 'http://localhost/router',
- plack_input => [ router_path => '/router', debug => 1, ],
- input_content => raw_post(
- 'http://localhost/router',
- '{"type":"rpc","tid":1,"action":"Env",'.
- ' "method":"param_list","data":[]}'),
- http_status => 200, content_type => qr|^application/json\b|,
- expected_content =>
- q|{"action":"Env","method":"param_list","result":|.
- q|["POSTDATA"],|.
- q|"tid":1,"type":"rpc"}|,
- },
- {
- name => 'param get', method => 'POST',
- cgi_url => 'http://localhost/cgi-bin/env.cgi',
- plack_url => 'http://localhost/router',
- plack_input => [ router_path => '/router', debug => 1, ],
- input_content => raw_post(
- 'http://localhost/router',
- '{"type":"rpc","tid":1,"action":"Env",'.
- ' "method":"param_get","data":["POSTDATA"]}'),
- http_status => 200, content_type => qr|^application/json\b|,
- expected_content =>
- q|{"action":"Env","method":"param_get","result":|.
- q|"{\"type\":\"rpc\",\"tid\":1,\"action\":\"Env\",\"method\":\"param_get\",\"data\":[\"POSTDATA\"]}",|.
- q|"tid":1,"type":"rpc"}|,
- },
- {
- name => 'cookie list', method => 'POST',
- cgi_url => 'http://localhost/cgi-bin/env.cgi',
- plack_url => 'http://localhost/router',
- plack_input => [ router_path => '/router', debug => 1, ],
- input_content => raw_post(
- 'http://localhost/router',
- '{"type":"rpc","tid":1,"action":"Env",'.
- ' "method":"cookie_list","data":[]}'),
- http_status => 200, content_type => qr|^application/json\b|,
- expected_content =>
- q|{"action":"Env","method":"cookie_list","result":|.
- q|["foo"],|.
- q|"tid":1,"type":"rpc"}|,
- },
- {
- name => 'cookie get', method => 'POST',
- cgi_url => 'http://localhost/cgi-bin/env.cgi',
- plack_url => 'http://localhost/router',
- plack_input => [ router_path => '/router', debug => 1, ],
- input_content => raw_post(
- 'http://localhost/router',
- '{"type":"rpc","tid":1,"action":"Env",'.
- ' "method":"cookie_get","data":["foo"]}'),
- http_status => 200, content_type => qr|^application/json\b|,
- expected_content =>
- q|{"action":"Env","method":"cookie_get","result":|.
- q|"bar",|.
- q|"tid":1,"type":"rpc"}|,
- },
-]
-
@@ -1,56 +0,0 @@
-[
- { name => 'Two events', method => 'POST',
- password => 'Usual, please',
- cgi_url => 'http://localhost/cgi-bin/poll1.cgi',
- plack_url => 'http://localhost/events',
- plack_input => [ poll_path => '/events', debug => 1, ],
- input_content => undef,
- http_status => 200, content_type => qr|^application/json\b|,
- expected_content =>
- q|[{"data":["foo"],|.
- q| "name":"foo_event",|.
- q| "type":"event"},|.
- q| {"data":{"foo":"bar"},|.
- q| "name":"bar_event",|.
- q| "type":"event"}]|,
- },
- { name => 'One event', method => 'POST',
- password => 'Ein kaffe bitte',
- cgi_url => 'http://localhost/cgi-bin/poll2.cgi',
- plack_url => 'http://localhost/events',
- plack_input => [ poll_path => '/events', debug => 1, ],
- input_content => undef,
- http_status => 200, content_type => qr|^application/json\b|,
- expected_content =>
- q|{"data":"Uno cappuccino, presto!",|.
- q| "name":"coffee",|.
- q| "type":"event"}|,
- },
- { name => 'Failed method', method => 'POST',
- password => 'Whiskey, straight away!',
- cgi_url => 'http://localhost/cgi-bin/poll3.cgi',
- plack_url => 'http://localhost/events',
- plack_input => [ poll_path => '/events', debug => 1, ],
- input_content => undef,
- http_status => 200, content_type => qr|^application/json\b|,
- expected_content => q|{"data":"","name":"__NONE__","type":"event"}|,
- },
- { name => 'No events at all', method => 'POST',
- password => "Sorry sir, but that's not on the menu?",
- cgi_url => 'http://localhost/cgi-bin/poll4.cgi',
- plack_url => 'http://localhost/events',
- plack_input => [ poll_path => '/events', debug => 1, ],
- input_content => undef,
- http_status => 200, content_type => qr|^application/json\b|,
- expected_content => q|{"data":"","name":"__NONE__","type":"event"}|,
- },
- { name => 'Invalid Event provider output', method => 'POST',
- password => "Hey man! There's a roach in my soup!",
- cgi_url => 'http://localhost/cgi-bin/poll5.cgi',
- plack_url => 'http://localhost/events',
- plack_input => [ poll_path => '/events', debug => 1, ],
- input_content => undef,
- http_status => 200, content_type => qr|^application/json\b|,
- expected_content => q|{"data":"","name":"__NONE__","type":"event"}|,
- },
-]
@@ -1,121 +0,0 @@
-[
- { name => 'Invalid raw POST', method => 'POST',
- cgi_url => 'http://localhost/cgi-bin/router1.cgi',
- plack_url => 'http://localhost/router',
- plack_input => [ router_path => '/router', debug => 1, ],
- input_content => raw_post('http://localhost/router',
- '{"something":"invalid":"here"}'),
- http_status => 200, content_type => qr|^application/json\b|,
- expected_content =>
- q|{"action":null,"message":"ExtDirect error decoding POST data: |.
- q| ', or } expected while parsing object/hash,|.
- q| at character offset 22 (before \":\"here\"}\")'",|.
- q| "method":null, "tid": null, "type":"exception",|.
- q| "where":"RPC::ExtDirect::Deserialize->decode_post"}|,
- },
- {
- name => 'Valid raw POST, single request', method => 'POST',
- cgi_url => 'http://localhost/cgi-bin/router1.cgi',
- plack_url => 'http://localhost/router',
- plack_input => [ router_path => '/router', debug => 1, ],
- input_content => raw_post('http://localhost/router',
- '{"type":"rpc","tid":1,"action":"Foo",'.
- ' "method":"foo_foo","data":["bar"]}'),
- http_status => 200, content_type => qr|^application/json\b|,
- expected_content
- => q|{"action":"Foo","method":"foo_foo",|.
- q|"result":"foo! 'bar'","tid":1,"type":"rpc"}|,
- },
- {
- name => 'Valid raw POST, multiple requests', method => 'POST',
- cgi_url => 'http://localhost/cgi-bin/router1.cgi',
- plack_url => 'http://localhost/router',
- plack_input => [ router_path => '/router', debug => 1, ],
- input_content =>
- raw_post('http://localhost/router',
- q|[{"tid":1,"action":"Qux","method":"foo_foo",|.
- q| "data":["foo"],"type":"rpc"},|.
- q| {"tid":2,"action":"Qux","method":"foo_bar",|.
- q| "data":["bar1","bar2"],"type":"rpc"},|.
- q| {"tid":3,"action":"Qux","method":"foo_baz",|.
- q| "data":{"foo":"baz1","bar":"baz2",|.
- q| "baz":"baz3"},"type":"rpc"}]|),
- http_status => 200, content_type => qr|^application/json\b|,
- expected_content
- => q|[{"action":"Qux","method":"foo_foo",|.
- q|"result":"foo! 'foo'","tid":1,"type":"rpc"},|.
- q|{"action":"Qux","method":"foo_bar",|.
- q|"result":["foo! bar!","bar1","bar2"],"tid":2,"type":"rpc"},|.
- q|{"action":"Qux","method":"foo_baz",|.
- q|"result":{"bar":"baz2","baz":"baz3","foo":"baz1",|.
- q|"msg":"foo! bar! baz!"},"tid":3,"type":"rpc"}]|,
- },
- {
- name => 'Form request, no uploads', method => 'POST',
- cgi_url => 'http://localhost/cgi-bin/router1.cgi',
- plack_url => 'http://localhost/router',
- plack_input => [ router_path => '/router', debug => 1, ],
- input_content =>
- form_post('http://localhost/router',
- action => '/router.cgi', method => 'POST',
- extAction => 'Bar', extMethod => 'bar_baz',
- extTID => 123, field1 => 'foo', field2 => 'bar',
- extType => 'rpc'),
- http_status => 200, content_type => qr|^application/json\b|,
- expected_content =>
- q|{"action":"Bar","method":"bar_baz",|.
- q|"result":{"field1":"foo","field2":"bar"},|.
- q|"tid":123,"type":"rpc"}|,
- },
- {
- name => 'Form request, one upload', method => 'POST',
- cgi_url => 'http://localhost/cgi-bin/router2.cgi',
- plack_url => 'http://localhost/router',
- plack_input => [ router_path => '/router', debug => 1, ],
- input_content =>
- form_upload('http://localhost/router',
- ['qux.txt'],
- action => '/router.cgi', method => 'POST',
- extAction => 'JuiceBar', extMethod => 'bar_baz',
- extTID => 7, extType => 'rpc', foo_field => 'foo',
- bar_field => 'bar', extUpload => 'true',),
- http_status => 200, content_type => qr|^text/html\b|,
- expected_content =>
- q|<html><body><textarea>|.
- q|{"action":"JuiceBar","method":"bar_baz",|.
- q|"result":{"bar_field":"bar",|.
- q|"foo_field":"foo",|.
- q|"upload_response":"The following files were |.
- q|processed:\n|.
- q|qux.txt application/octet-stream 29 ok\n"|.
- q|},"tid":7,|.
- q|"type":"rpc"}|.
- q|</textarea></body></html>|,
- },
- {
- name => 'Form request, multiple uploads', method => 'POST',
- cgi_url => 'http://localhost/cgi-bin/router2.cgi',
- plack_url => 'http://localhost/router',
- plack_input => [ router_path => '/router', debug => 1, ],
- input_content =>
- form_upload('http://localhost/router',
- ['foo.jpg', 'bar.png', 'script.js'],
- action => '/router.cgi', method => 'POST',
- extAction => 'JuiceBar', extMethod => 'bar_baz',
- extTID => 8, field => 'value', extUpload => 'true',
- extType => 'rpc'),
- http_status => 200, content_type => qr|^text/html\b|,
- expected_content =>
- q|<html><body><textarea>|.
- q|{"action":"JuiceBar","method":"bar_baz",|.
- q|"result":{|.
- q|"field":"value",|.
- q|"upload_response":"The following files were |.
- q|processed:\n|.
- q|foo.jpg application/octet-stream 16157 ok\n|.
- q|bar.png application/octet-stream 20691 ok\n|.
- q|script.js application/octet-stream 78 ok\n"|.
- q|},"tid":8,"type":"rpc"}|.
- q|</textarea></body></html>|,
- },
-]
@@ -1,45 +0,0 @@
-package RPC::ExtDirect::Test::Bar;
-
-use strict;
-use warnings;
-no warnings 'uninitialized';
-
-use base 'RPC::ExtDirect::Test::Foo';
-
-use RPC::ExtDirect;
-
-use Carp;
-
-# This one croaks merrily
-sub bar_foo : ExtDirect(4) { croak 'bar foo!' }
-
-# Return number of passed arguments
-sub bar_bar : ExtDirect(5) { shift; pop; return scalar @_; }
-
-# This is a form handler
-sub bar_baz : ExtDirect( formHandler ) {
- my ($class, %param) = @_;
-
- delete $param{_env};
-
- # Simulate uploaded file handling
- my $uploads = $param{file_uploads};
- return \%param unless $uploads;
-
- # Return 'uploads' data
- my $response = "The following files were processed:\n";
- for my $upload ( @$uploads ) {
- my $name = $upload->{basename};
- my $type = $upload->{type};
- my $size = $upload->{size};
-
- $response .= "$name $type $size\n";
- };
-
- delete $param{file_uploads};
- $param{upload_response} = $response;
-
- return \%param;
-}
-
-1;
@@ -1,52 +0,0 @@
-package RPC::ExtDirect::Test::Env;
-
-use strict;
-use warnings;
-no warnings 'uninitialized';
-
-use RPC::ExtDirect class => 'Env';
-
-sub http_list : ExtDirect(0) {
- my ($class, $env) = @_;
-
- my @list = sort $env->http();
-
- return [ @list ];
-}
-
-sub http_header : ExtDirect(1) {
- my ($class, $header, $env) = @_;
-
- return $env->http($header);
-}
-
-sub param_list : ExtDirect(0) {
- my ($class, $env) = @_;
-
- my @list = sort $env->param();
-
- return [ @list ];
-}
-
-sub param_get : ExtDirect(1) {
- my ($class, $name, $env) = @_;
-
- return $env->param($name);
-}
-
-sub cookie_list : ExtDirect(0) {
- my ($class, $env) = @_;
-
- my @cookies = sort $env->cookie();
-
- return [ @cookies ];
-}
-
-sub cookie_get : ExtDirect(1) {
- my ($class, $name, $env) = @_;
-
- return $env->cookie($name);
-}
-
-1;
-
@@ -1,34 +0,0 @@
-package RPC::ExtDirect::Test::Foo;
-
-use strict;
-use warnings;
-no warnings 'uninitialized';
-
-use RPC::ExtDirect;
-
-# Return scalar result
-sub foo_foo : ExtDirect(1) {
- return "foo! '${_[1]}'"
-}
-
-# Return arrayref result
-sub foo_bar : ExtDirect(2) {
- return [ 'foo! bar!', $_[1], $_[2] ]
-}
-
-# Return hashref result
-sub foo_baz : ExtDirect( params => [foo, bar, baz] ) {
- my $class = shift;
- my %param = @_;
-
- my $ret = { msg => 'foo! bar! baz!', foo => $param{foo},
- bar => $param{bar}, baz => $param{baz},
- };
-
- delete @param{ qw(foo bar baz _env) };
- @$ret{ keys %param } = values %param;
-
- return $ret;
-}
-
-1;
@@ -1,61 +0,0 @@
-package RPC::ExtDirect::Test::JuiceBar;
-
-use strict;
-use warnings;
-no warnings 'uninitialized';
-
-use base 'RPC::ExtDirect::Test::Foo';
-
-use RPC::ExtDirect;
-
-use Carp;
-
-use Test::More;
-
-our $CHEAT = 0;
-
-# This one croaks merrily
-sub bar_foo : ExtDirect(4) { croak 'bar foo!' }
-
-# Return number of passed arguments
-sub bar_bar : ExtDirect(5) { shift; pop; return scalar @_; }
-
-# This is a form handler
-sub bar_baz : ExtDirect( formHandler ) {
- my ($class, %param) = @_;
-
- my $cgi = delete $param{_env};
-
- # Simulate uploaded file handling
- my $uploads = $param{file_uploads};
- return \%param unless $uploads;
-
- # Return 'uploads' data
- my $response = "The following files were processed:\n";
- for my $upload ( @$uploads ) {
- my $name = $upload->{basename};
- my $type = $upload->{type};
- my $size = $upload->{size};
-
- # CTI::Test somehow uploads files so that
- # they are 2 bytes shorter than actual size
- # This allows for the same test results to be
- # applied across all gateways and test frameworks
- #
- # Well, in all truthiness this should be the opposite
- # but CGI::Test was there first...
- $size -= 2 if $CHEAT;
-
- my $ok = (defined $upload->{handle} &&
- $upload->{handle}->opened) ? "ok" : "not ok";
-
- $response .= "$name $type $size $ok\n";
- };
-
- delete $param{file_uploads};
- $param{upload_response} = $response;
-
- return \%param;
-}
-
-1;
@@ -1,53 +0,0 @@
-package TheBug;
-
-sub new { bless { message => $_[1] }, $_[0] }
-sub result { $_[0] }
-
-package RPC::ExtDirect::Test::PollProvider;
-
-use strict;
-use warnings;
-no warnings 'uninitialized';
-
-use Carp;
-
-use RPC::ExtDirect;
-use RPC::ExtDirect::Event;
-
-# This is to control what gets returned
-our $WHAT_YOURE_HAVING = 'Usual, please';
-
-sub foo : ExtDirect( pollHandler ) {
- my ($class) = @_;
-
- # There ought to be something more substantive, but...
- if ( $WHAT_YOURE_HAVING eq 'Usual, please' ) {
- return (
- RPC::ExtDirect::Event->new('foo_event', [ 'foo' ]),
- RPC::ExtDirect::Event->new('bar_event', { foo => 'bar' }),
- );
- }
-
- elsif ( $WHAT_YOURE_HAVING eq 'Ein kaffe bitte' ) {
- return (
- RPC::ExtDirect::Event->new('coffee',
- 'Uno cappuccino, presto!'),
- );
- }
-
- elsif ( $WHAT_YOURE_HAVING eq 'Whiskey, straight away!' ) {
- croak "Burp!";
- }
-
- elsif ( $WHAT_YOURE_HAVING eq "Hey man! There's a roach in my soup!" ) {
- my $bug = new TheBug 'TIGER ROACH!! WHOA!';
- return $bug;
- }
-
- else {
- # Nothing special to report in our Special News Report!
- return ();
- };
-}
-
-1;
@@ -1,23 +0,0 @@
-package RPC::ExtDirect::Test::Qux;
-
-use strict;
-use warnings;
-no warnings 'uninitialized';
-
-use base 'RPC::ExtDirect::Test::Bar';
-
-use RPC::ExtDirect Action => 'Qux';
-
-# Redefine subs into Qux package without actually changing them
-sub foo_foo : ExtDirect( 1 ) { shift; __PACKAGE__->SUPER::foo_foo(@_); }
-sub foo_bar : ExtDirect( 2 ) { shift; __PACKAGE__->SUPER::foo_bar(@_); }
-sub foo_baz : ExtDirect( params => [ qw( foo bar baz ) ] )
- { shift; __PACKAGE__->SUPER::foo_baz(@_); }
-sub bar_foo : ExtDirect( 4 ) { shift; __PACKAGE__->SUPER::bar_foo(@_); }
-sub bar_bar : ExtDirect( 5 ) { shift; __PACKAGE__->SUPER::bar_bar(@_); }
-sub bar_baz : ExtDirect( formHandler ) {
- shift;
- __PACKAGE__->SUPER::bar_baz(@_);
-}
-
-1;
@@ -0,0 +1,151 @@
+package RPC::ExtDirect::Test::Util::CGI;
+
+use strict;
+use warnings;
+no warnings 'uninitialized';
+
+use Test::More;
+
+use CGI::Test (); # No need to import ok() from CGI::Test
+use CGI::Test::Input::URL ();
+use CGI::Test::Input::Multipart ();
+
+use RPC::ExtDirect::Test::Util;
+
+use base 'Exporter';
+
+our @EXPORT = qw/
+ run_tests
+/;
+
+our @EXPORT_OK = qw/
+ raw_post
+ form_post
+ form_upload
+/;
+
+### EXPORTED PUBLIC PACKAGE SUBROUTINE ###
+#
+# Run the test battery from the passed definitions
+#
+
+sub run_tests {
+ my ($tests, @run_only) = @_;
+
+ my $cmp_pkg = 'RPC::ExtDirect::Test::Util';
+ my $num_tests = @run_only || @$tests;
+
+ plan tests => 4 * $num_tests;
+
+ TEST:
+ for my $test ( @$tests ) {
+ my $name = $test->{name};
+ my $config = $test->{config} || {};
+ my $input = $test->{input};
+ my $output = $test->{output};
+
+ next TEST if @run_only && !grep { lc $name eq lc $_ } @run_only;
+
+ my $ct = CGI::Test->new(
+ -base_url => 'http://localhost/cgi-bin',
+ -cgi_dir => 't/cgi-bin',
+ %$config,
+ );
+
+ # CGI tests have the config hardcoded in the scripts
+ my $url = $ct->base_uri . $input->{cgi_url};
+ my $method = $input->{method};
+ my $input_content = $input->{cgi_content} || $input->{content};
+
+ my $req = prepare_input 'CGI', $input_content;
+ my $page = $ct->$method($url, $req);
+
+ if ( ok $page, "$name not empty" ) {
+ my $want_type = $output->{content_type};
+ my $have_type = $page->content_type();
+
+ like $have_type, $want_type, "$name content type";
+
+ my $want_status = $output->{status};
+ my $have_status = $page->is_ok() ? 200 : $page->error_code();
+
+ is $have_status, $want_status, "$name HTTP status";
+
+ my $cmp_fn = $output->{comparator};
+ my $want = $output->{cgi_content} || $output->{content};
+ my $have = $page->raw_content();
+
+ $cmp_pkg->$cmp_fn($have, $want, "$name content")
+ or diag explain "Page: ", $page;
+
+ $page->delete();
+ };
+ };
+}
+
+### NON EXPORTED PUBLIC PACKAGE SUBROUTINE ###
+#
+# Return a new CGI::Test::Input object for a raw POST call
+#
+
+sub raw_post {
+ # This can be called either as a class method, or a plain sub
+ shift if $_[0] eq __PACKAGE__;
+
+ my ($url, $input) = @_;
+
+ my $cgi_input = CGI::Test::Input::URL->new();
+ $cgi_input->set_raw_data($input);
+ $cgi_input->set_mime_type('application/json');
+
+ return $cgi_input;
+}
+
+### NON EXPORTED PUBLIC PACKAGE SUBROUTINE ###
+#
+# Return a new CGI::Test::Input oject for a form call
+#
+
+sub form_post {
+ # This can be called either as a class method, or a plain sub
+ shift if $_[0] eq __PACKAGE__;
+
+ my ($url, %fields) = @_;
+
+ my $cgi_input = CGI::Test::Input::URL->new();
+ for my $field ( keys %fields ) {
+ my $value = $fields{ $field };
+ $cgi_input->add_field($field, $value);
+ };
+
+ return $cgi_input;
+}
+
+### NON EXPORTED PUBLIC PACKAGE SUBROUTINE ###
+#
+# Return a new CGI::Test::Input object for a form call
+# with file uploads
+#
+
+sub form_upload {
+ # This can be called either as a class method, or a plain sub
+ shift if $_[0] eq __PACKAGE__;
+
+ my ($url, $files, %fields) = @_;
+
+ my $cgi_input = CGI::Test::Input::Multipart->new();
+
+ for my $field ( keys %fields ) {
+ my $value = $fields{ $field };
+ $cgi_input->add_field($field, $value);
+ };
+
+ for my $file ( @$files ) {
+ $cgi_input->add_file_now("upload", "t/data/cgi-data/$file");
+ };
+
+ return $cgi_input;
+}
+
+
+1;
@@ -1,6 +1,12 @@
use Test::More;
-eval "use Test::Pod 1.00";
-plan skip_all => "Test::Pod 1.00 required for testing POD" if $@;
+if ( $ENV{POD_TESTS} ) {
+ eval "use Test::Pod 1.00";
+ plan skip_all => "Test::Pod 1.00 required for testing POD" if $@;
+
+ all_pod_files_ok();
+}
+else {
+ plan skip_all => 'POD tests are not enabled.';
+}
-all_pod_files_ok();