[libcgi-test-perl] 01/24: Made a fork from unauthorized 0.1.4 version; updated it to be usable in modern Perl environment
Axel Beckert
abe at deuxchevaux.org
Mon Jan 11 00:38:05 UTC 2016
This is an automated email from the git hooks/post-receive script.
abe pushed a commit to annotated tag 0.50
in repository libcgi-test-perl.
commit b00492560984d01bc8149a119d0a74eaeb38099c
Author: Alexander Tokarev <tokarev at cpan.org>
Date: Fri Sep 30 14:42:30 2011 +0400
Made a fork from unauthorized 0.1.4 version; updated it to be usable in modern Perl environment
---
.Changes.swp | Bin 0 -> 12288 bytes
Changes | 101 +++
MANIFEST | 46 +
Makefile.PL | 37 +
README | 44 +
lib/CGI/Test.pm | 1152 ++++++++++++++++++++++++
lib/CGI/Test/Form.pm | 1231 ++++++++++++++++++++++++++
lib/CGI/Test/Form/Group.pm | 229 +++++
lib/CGI/Test/Form/Widget.pm | 592 +++++++++++++
lib/CGI/Test/Form/Widget/Box.pm | 433 +++++++++
lib/CGI/Test/Form/Widget/Box/Check.pm | 92 ++
lib/CGI/Test/Form/Widget/Box/Radio.pm | 140 +++
lib/CGI/Test/Form/Widget/Button.pm | 363 ++++++++
lib/CGI/Test/Form/Widget/Button/Image.pm | 82 ++
lib/CGI/Test/Form/Widget/Button/Plain.pm | 85 ++
lib/CGI/Test/Form/Widget/Button/Reset.pm | 111 +++
lib/CGI/Test/Form/Widget/Button/Submit.pm | 102 +++
lib/CGI/Test/Form/Widget/Hidden.pm | 129 +++
lib/CGI/Test/Form/Widget/Input.pm | 242 +++++
lib/CGI/Test/Form/Widget/Input/File.pm | 97 ++
lib/CGI/Test/Form/Widget/Input/Password.pm | 95 ++
lib/CGI/Test/Form/Widget/Input/Text_Area.pm | 163 ++++
lib/CGI/Test/Form/Widget/Input/Text_Field.pm | 168 ++++
lib/CGI/Test/Form/Widget/Menu.pm | 484 ++++++++++
lib/CGI/Test/Form/Widget/Menu/List.pm | 144 +++
lib/CGI/Test/Form/Widget/Menu/Popup.pm | 138 +++
lib/CGI/Test/Input.pm | 395 +++++++++
lib/CGI/Test/Input/Multipart.pm | 167 ++++
lib/CGI/Test/Input/URL.pm | 125 +++
lib/CGI/Test/Page.pm | 251 ++++++
lib/CGI/Test/Page/Error.pm | 102 +++
lib/CGI/Test/Page/HTML.pm | 205 +++++
lib/CGI/Test/Page/Other.pm | 71 ++
lib/CGI/Test/Page/Real.pm | 182 ++++
lib/CGI/Test/Page/Text.pm | 74 ++
t/browse.pl | 145 +++
t/cgi/dumpargs | 33 +
t/cgi/getform | 109 +++
t/cgi/printenv | 28 +
t/env.t | 108 +++
t/get.t | 81 ++
t/parsing.t | 127 +++
t/play_get.t | 22 +
t/play_multi.t | 22 +
t/play_post.t | 22 +
t/pod.t | 6 +
t/post.t | 81 ++
47 files changed, 8856 insertions(+)
diff --git a/.Changes.swp b/.Changes.swp
new file mode 100644
index 0000000..d1791b2
Binary files /dev/null and b/.Changes.swp differ
diff --git a/Changes b/Changes
new file mode 100644
index 0000000..65ece62
--- /dev/null
+++ b/Changes
@@ -0,0 +1,101 @@
+Fri Sep 30 14:22:14 MSD 2011 Alexander Tokarev <tokarev at cpan.org>
+
+. Description:
+
+ Version 0.2.0
+
+ Forked from unauthorized 0.1.4 version, using Github as
+ repository: https://github.com/nohuhu/CGI-Test
+
+ Removed all dependencies on Carp::Datum as it is long outdated
+ and unsupported.
+
+ Updated Makefile.PL to new format, with modules in lib/ and
+ ChangeLog renamed to Changes.
+
+ Updated dependencies to reflect the changes in CPAN module
+ distribution. For one, HTTP::Status module was split from LWP
+ along with several others in HTTP::Message bundle which
+ requires Perl 5.8.8+ to build and it breaks CGI::Test build
+ pattern. Now Makefile.PL will choose either LWP or HTTP::Message
+ depending on Perl version.
+
+ Added small feature: HTTP response headers are now stored in
+ CGI::Test object and can be read with headers() method. Maybe
+ it would be better to place them in CGI::Test::Page object but
+ by CGI::Test logic Page represents an actual page not HTTP
+ response.
+
+ Updated code to be compatible with Perl 5.14.
+
+ Added Pod testing script and fixed Pod errors it discovered.
+
+ Test suite now runs successfully under Linux, Solaris and Darwin
+ platforms; Perls 5.6.1 to 5.14.1 were used to run tests.
+
+ Bumped version to clearly reflect changes.
+
+Sat Oct 4 12:26:30 EDT 2003 Steven Hilton <mshiltonj at mshiltonj.com>
+
+. Description:
+
+ Version 0.1.4.
+
+ CGI::Test has changed ownership. The new owner is Steven Hilton
+ <mshiltonj at mshiltonj.com>. Many thanks to Raphael Manfredi
+ and Steve Fink.
+
+ CGI::Test is now hosted as a SourceForge project. It is located
+ at <http://cgi-test.sourceforge.net>.
+
+ POD updated to reflect the above.
+
+ make() method on various objects has been deprecated, and has been
+ replaced by more conventional (for me, at least) new() method.
+ Support for make() may be removed in a later release.
+
+ Entire codebase reformatted using perltidy
+ Go to <http://perltidy.sourceforge.net/> to see how neat it is.
+
+ Self-referential object variable name standardized to '$this'
+ throughout code.
+
+Tue Apr 17 13:27:06 MEST 2001 Raphael Manfredi <Raphael_Manfredi at pobox.com>
+
+. Description:
+
+ Version 0.1.3.
+
+ Changed test 22 in t/browse.pl to perform explicit sorting
+ of the month parameter string, so that the string comparison
+ is reliable.
+
+Tue Apr 17 12:44:16 MEST 2001 Raphael Manfredi <Raphael_Manfredi at pobox.com>
+
+. Description:
+
+ Version 0.1.2.
+
+ Discard parameters when figuring out content-type, so that
+ we build proper Page objects.
+
+ Added note about possible parameters in content_type in
+ the man page for CGI::Test::Page.
+
+ Fixed t/parsing regression test so that it works even when there
+ are parameters in the returned content-type field.
+
+Sat Apr 14 10:52:17 MEST 2001 Raphael Manfredi <Raphael_Manfredi at pobox.com>
+
+. Description:
+
+ Version 0.1.1.
+
+ Set PERL5LIB in child to mirror parent's @INC, so that the CGI
+ program, if written in Perl, can get the same include path.
+
+Sat Mar 31 12:39:37 MEST 2001 Raphael Manfredi <Raphael_Manfredi at pobox.com>
+
+ Version 0.1.0.
+ Initial public alpha relase.
+
diff --git a/MANIFEST b/MANIFEST
new file mode 100644
index 0000000..b1bae8b
--- /dev/null
+++ b/MANIFEST
@@ -0,0 +1,46 @@
+Changes
+lib/CGI/Test.pm
+lib/CGI/Test/Form.pm
+lib/CGI/Test/Form/Group.pm
+lib/CGI/Test/Form/Widget.pm
+lib/CGI/Test/Form/Widget/Box.pm
+lib/CGI/Test/Form/Widget/Box/Check.pm
+lib/CGI/Test/Form/Widget/Box/Radio.pm
+lib/CGI/Test/Form/Widget/Button.pm
+lib/CGI/Test/Form/Widget/Button/Image.pm
+lib/CGI/Test/Form/Widget/Button/Plain.pm
+lib/CGI/Test/Form/Widget/Button/Reset.pm
+lib/CGI/Test/Form/Widget/Button/Submit.pm
+lib/CGI/Test/Form/Widget/Hidden.pm
+lib/CGI/Test/Form/Widget/Input.pm
+lib/CGI/Test/Form/Widget/Input/File.pm
+lib/CGI/Test/Form/Widget/Input/Password.pm
+lib/CGI/Test/Form/Widget/Input/Text_Area.pm
+lib/CGI/Test/Form/Widget/Input/Text_Field.pm
+lib/CGI/Test/Form/Widget/Menu.pm
+lib/CGI/Test/Form/Widget/Menu/List.pm
+lib/CGI/Test/Form/Widget/Menu/Popup.pm
+lib/CGI/Test/Input.pm
+lib/CGI/Test/Input/Multipart.pm
+lib/CGI/Test/Input/URL.pm
+lib/CGI/Test/Page.pm
+lib/CGI/Test/Page/Error.pm
+lib/CGI/Test/Page/HTML.pm
+lib/CGI/Test/Page/Other.pm
+lib/CGI/Test/Page/Real.pm
+lib/CGI/Test/Page/Text.pm
+Makefile.PL
+MANIFEST
+README
+t/browse.pl
+t/cgi/dumpargs
+t/cgi/getform
+t/cgi/printenv
+t/env.t
+t/get.t
+t/parsing.t
+t/play_get.t
+t/play_multi.t
+t/play_post.t
+t/pod.t
+t/post.t
diff --git a/Makefile.PL b/Makefile.PL
new file mode 100644
index 0000000..f5f3f10
--- /dev/null
+++ b/Makefile.PL
@@ -0,0 +1,37 @@
+#
+# $Id: Makefile.PL,v 1.2 2003/10/04 14:26:05 mshiltonj Exp $
+#
+# Copyright (c) 2001, Raphael Manfredi
+#
+# You may redistribute only under the terms of the Artistic License,
+# as specified in the README file that comes with the distribution.
+#
+#
+
+use ExtUtils::MakeMaker;
+
+# See lib/ExtUtils/MakeMaker.pm for details of how to influence
+# the contents of the Makefile that is written.
+WriteMakefile(
+ NAME => 'CGI::Test',
+ VERSION_FROM => 'lib/CGI/Test.pm', # finds $VERSION
+ PREREQ_PM => {
+ 'CGI' => '0',
+ 'Digest::MD5' => '0',
+ 'Getargs::Long' => '0.103',
+ 'Log::Agent' => '0.207',
+ 'URI' => '1.10',
+ ($] >= 5.008 # HTTP::Status is now in
+ ? ('HTTP::Message' => '0', ) # HTTP::Message bundle which
+ : ('LWP' => '0', ) # requires 5.8+
+ ),
+ 'HTML::TreeBuilder' => '0',
+ 'File::Temp' => '0',
+ 'File::Spec' => '0',
+ 'Storable' => '1.000',
+ },
+ ($] >= 5.005 ? ## Add these new keywords supported since 5.005
+ (ABSTRACT => 'CGI regression test framework',
+ AUTHOR => 'Raphael Manfredi <Raphael_Manfredi at pobox.com>') : ()),
+);
+
diff --git a/README b/README
new file mode 100644
index 0000000..a3c6b2a
--- /dev/null
+++ b/README
@@ -0,0 +1,44 @@
+ CGI::Test 0.2
+ Copyright (c) 2001, Raphael Manfredi
+
+------------------------------------------------------------------------
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the Artistic License, a copy of which can be
+ found with perl.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ Artistic License for more details.
+------------------------------------------------------------------------
+
+ *** This is alpha software -- use at your own risks ***
+
+Name DSLI Description Info
+----------- ---- -------------------------------------------- -----
+CGI::Test adpO A CGI regression test framework RAM
+
+The CGI::Test framework is my answer to the CGI testing problem.
+
+It is very difficult to perform testing of complex CGI scripts, which
+handle multiple states and screens, and where a session involves
+multiple interactions with the form. The offline testing mode of the
+CGI module reaches its limit there.
+
+Hence CGI::Test, which acts as a "server" for CGI scripts and can run
+them offline, outside of any real web server. The framework offers
+the infrastructure to analyze the HTML generated by CGI scripts, extract
+the various widget information, and gives programmatic control on them.
+
+The framework can be used to easily "test" that the various expected
+widget controls are there, without necessarily interacting with the
+widgets. You also have access to the raw HTML tree if you wish to
+further inspect the generation.
+
+Two important limitations are expected to be removed "soon": the
+inability to test a script in-situ, through direct HTTP requests,
+meaning it is ran by the HTTP server itself, and the inability to
+handle cookies.
+
+-- Raphael Manfredi <Raphael_Manfredi at pobox.com>
+
diff --git a/lib/CGI/Test.pm b/lib/CGI/Test.pm
new file mode 100644
index 0000000..21d57ff
--- /dev/null
+++ b/lib/CGI/Test.pm
@@ -0,0 +1,1152 @@
+package CGI::Test;
+use strict;
+use warnings;
+################################################################
+# $Id: Test.pm 412 2011-09-26 13:15:02Z nohuhu at nohuhu.org $
+# $Name: cgi-test_0-104_t1 $
+#################################################################
+# Copyright (c) 2001, Raphael Manfredi
+#
+# You may redistribute only under the terms of the Artistic License,
+# as specified in the README file that comes with the distribution.
+#
+
+use Carp;
+use Getargs::Long;
+use Log::Agent;
+use HTTP::Status;
+use URI;
+use File::Temp qw(mkstemp);
+use File::Spec;
+use File::Basename;
+
+require Exporter;
+use vars qw($VERSION @ISA @EXPORT);
+
+$VERSION = '0.200';
+ at ISA = qw(Exporter);
+ at EXPORT = qw(ok);
+
+#############################################################################
+#
+# ->new
+#
+# Creation routine
+#
+# Arguments:
+# base_url URL to cgi-bin, e.g. http://foo:18/cgi-bin
+# cgi_dir physical location of base_url
+# tmp_dir (optional) temporary directory to use
+# cgi_env (optional) default CGI environment
+# doc_dir (optional) physical location of docs, for path translation
+#
+#############################################################################
+sub new
+{
+ my $this = bless {}, shift;
+ my ($ubase, $dir, $doc, $tmp, $env) =
+ xgetargs(@_,
+ -base_url => 's',
+ -cgi_dir => 's',
+ -doc_dir => [ 's', "/var/www" ],
+ -tmp_dir => [ 's', $ENV{TMPDIR} || "/tmp" ],
+ -cgi_env => [ 'HASH' ],
+ );
+
+ my $uri = URI->new($ubase);
+ croak "-base_url $ubase is not within the http scheme"
+ unless $uri->scheme eq 'http';
+
+ my ($server, $path) = $this->split_uri($uri);
+ $this->{host_port} = $server;
+ $this->{base_path} = $path;
+ $this->{cgi_dir} = $dir;
+ $this->{tmp_dir} = $tmp;
+ $env = {} unless defined $env;
+ $this->{cgi_env} = $env;
+ $this->{doc_dir} = $doc;
+
+ #
+ # The following default settings will apply unless alternatives given
+ # by user via the -cgi_env parameter.
+ #
+
+ my %dflt = (AUTH_TYPE => "Basic",
+ GATEWAY_INTERFACE => "CGI/1.1",
+ HTTP_ACCEPT => "*/*",
+ HTTP_CONNECTION => "Close",
+ HTTP_USER_AGENT => "CGI::Test",
+ HTTP_ACCEPT_CHARSET => "iso-8859-1",
+ REMOTE_HOST => "localhost",
+ REMOTE_ADDR => "127.0.0.1",
+ SERVER_NAME => $uri->host,
+ SERVER_PORT => $uri->port,
+ SERVER_PROTOCOL => "HTTP/1.1",
+ SERVER_SOFTWARE => "CGI::Test",
+ );
+
+ while (my ($key, $value) = each %dflt)
+ {
+ $env->{$key} = $value unless exists $env->{$key};
+ }
+
+ #
+ # Object types to create depending on returned content-type.
+ # If not listed here, "Other" is assummed.
+ #
+
+ $this->{_obj_type} = {'text/plain' => 'Text',
+ 'text/html' => 'HTML',
+ };
+
+ return $this;
+}
+
+######################################################################
+#
+######################################################################
+sub make
+{ #
+ my $class = shift;
+ return $class->new(@_);
+}
+
+#
+# Attribute access
+#
+
+######################################################################
+sub host_port
+{
+ my $this = shift;
+ return $this->{host_port};
+}
+
+######################################################################
+sub base_path
+{
+ my $this = shift;
+ return $this->{base_path};
+}
+
+######################################################################
+sub cgi_dir
+{
+ my $this = shift;
+ return $this->{cgi_dir};
+}
+
+######################################################################
+sub doc_dir
+{
+ my $this = shift;
+ return $this->{doc_dir};
+}
+
+######################################################################
+sub tmp_dir
+{
+ my $this = shift;
+ return $this->{tmp_dir};
+}
+
+######################################################################
+sub cgi_env
+{
+ my $this = shift;
+ return $this->{cgi_env};
+}
+
+######################################################################
+sub _obj_type
+{
+ my $this = shift;
+ return $this->{_obj_type};
+}
+
+######################################################################
+sub http_headers {
+ my ($self) = @_;
+
+ return $self->{http_headers};
+}
+
+######################################################################
+#
+# ->_dpath
+#
+# Returns direct path to final component of argument,
+# i.e. the original path with . and .. items removed.
+#
+# Will probably only work on Unix (possibly Win32 if paths given with "/").
+#
+######################################################################
+sub _dpath
+{
+ my $this = shift;
+ my ($dir) = @_;
+ my $root = ($dir =~ s|^/||) ? "/" : "";
+ my @cur;
+ foreach my $item (split(m|/|, $dir))
+ {
+ next if $item eq '.';
+ if ($item eq '..')
+ {
+ pop(@cur);
+ }
+ else
+ {
+ push(@cur, $item);
+ }
+ }
+ my $path = $root . join('/', @cur);
+ $path =~ tr|/||s;
+ return $path;
+}
+
+######################################################################
+#
+# ->split_uri
+#
+# Split down URI into (server, path, query) components.
+#
+######################################################################
+sub split_uri
+{
+ my $this = shift;
+ my ($uri) = @_;
+ return ($uri->host_port, $this->_dpath($uri->path), $uri->query);
+}
+
+######################################################################
+#
+# ->GET
+#
+# Perform an HTTP GET request on a CGI URI by running the script directly.
+# Returns a CGI::Test::Page object representing the returned page, or the
+# error.
+#
+# Optional $user provides the name of the "authenticated" user running
+# this script.
+#
+######################################################################
+sub GET
+{
+ my $this = shift;
+ my ($uri, $user) = @_;
+
+ return $this->_cgi_request($uri, $user, undef);
+}
+
+######################################################################
+#
+# ->POST
+#
+# Perform an HTTP POST request on a CGI URI by running the script directly.
+# Returns a CGI::Test::Page object representing the returned page, or the
+# error.
+#
+# Data to send to the script are held in $input, a CGI::Test::Input object.
+#
+# Optional $user provides the name of the "authenticated" user running
+# this script.
+#
+######################################################################
+sub POST
+{
+ my $this = shift;
+ my ($uri, $input, $user) = @_;
+
+ return $this->_cgi_request($uri, $user, $input);
+}
+
+######################################################################
+#
+# ->_cgi_request
+#
+# Common routine to handle GET and POST.
+#
+######################################################################
+sub _cgi_request
+{
+ my $this = shift;
+ my ($uri, $user, $input) = @_; # $input defined for POST
+
+ my $u = URI->new($uri);
+ croak "URI $uri is not within the http scheme"
+ unless $u->scheme eq 'http';
+
+ require CGI::Test::Page::Error;
+ my $error = "CGI::Test::Page::Error";
+
+ my ($userver, $upath, $uquery) = $this->split_uri($u);
+ my $server = $this->host_port;
+ my $base_path = $this->base_path . "/";
+
+ croak "URI $uri is not located on server $server"
+ unless $userver eq $server;
+
+ croak "URI $uri is not located under the $base_path directory"
+ unless substr($upath, 0, length $base_path) eq $base_path;
+
+ substr($upath, 0, length $base_path) = '';
+
+ logdbg 'info', "uri $uri -> script+path $upath";
+
+ #
+ # We have script + path_info in the $upath variable. To determine where
+ # the path_info starts, we have to walk through the components and
+ # compare, at each step, the current walk-through path with one on the
+ # filesystem under cgi_dir.
+ #
+
+ my $cgi_dir = $this->cgi_dir;
+ my @components = split(m|/|, $upath);
+ my @script;
+
+ while (@components)
+ {
+ my $item = shift @components;
+ if (-e File::Spec->catfile($cgi_dir, @script, $item))
+ {
+ push(@script, $item);
+ }
+ else
+ {
+ unshift @components, $item;
+ last;
+ }
+ }
+
+ my $script = File::Spec->catfile($cgi_dir, @script); # Real
+ my $script_name = $base_path . join("/", @script); # Virtual
+ my $path = "/" . join("/", @components); # Virtual
+
+ logdbg 'info', "script=$script, path=$path";
+
+ return $error->new(RC_NOT_FOUND, $this) unless -f $script;
+ return $error->new(RC_UNAUTHORIZED, $this) unless -x $script;
+
+ #
+ # Prepare input for POST requests.
+ #
+
+ my @post = ();
+ local $SIG{PIPE} = 'IGNORE';
+ local (*PREAD, *PWRITE);
+ if (defined $input)
+ {
+ unless (pipe(PREAD, PWRITE))
+ {
+ logerr "can't open pipe: $!";
+ return $error->new(RC_INTERNAL_SERVER_ERROR, $this);
+ }
+
+ @post = (-in => \*PREAD,
+ -input => $input,);
+ }
+
+ #
+ # Prepare temporary file for storing output, which we'll parse once
+ # the script is done.
+ #
+
+ my ($fh, $fname) =
+ mkstemp(File::Spec->catfile($this->tmp_dir, "cgi_out.XXXXXX"));
+
+ select((select(STDOUT), $| = 1)[ 0 ]);
+ print STDOUT ""; # Flush STDOUT before forking
+
+ #
+ # Fork...
+ #
+
+ my $pid = fork;
+ logdie "can't fork: $!" unless defined $pid;
+
+ #
+ # Child will run the CGI program with no input if it's a GET and
+ # output stored to $fh. When issuing a POST, data will be provided
+ # by the parent through a pipe.
+ #
+
+ if ($pid == 0)
+ {
+ close PWRITE if defined $input; # Writing side of the pipe
+ $this->_run_cgi(
+ -script_file => $script, # Real path
+ -script_name => $script_name, # Virtual path, given in URI
+ -user => $user,
+ -out => $fh,
+ -uri => $u,
+ -path_info => $path,
+ @post, # Additional params for POST
+ );
+ logconfess "not reachable!";
+ }
+
+ #
+ # Parent process
+ #
+
+ close $fh;
+ if (defined $input)
+ { # Send POST input data
+ close PREAD;
+ syswrite PWRITE, $input->data, $input->length;
+ close PWRITE or logwarn "failure while closing pipe: $!";
+ }
+
+ my $child = waitpid $pid, 0;
+
+ if ($pid != $child)
+ {
+ logerr "waitpid returned with pid=$child, but expected pid=$pid";
+ kill 'TERM', $pid or logwarn "can't SIGTERM pid $pid: $!";
+ unlink $fname or logwarn "can't unlink $fname: $!";
+ return $error->new(RC_NO_CONTENT, $this);
+ }
+
+ #
+ # Get header within generated response, and determine Content-Type.
+ #
+
+ my $header = $this->_parse_header($fname);
+ unless (scalar keys %$header)
+ {
+ logerr "script $script_name generated no valid headers";
+ unlink $fname or logwarn "can't unlink $fname: $!";
+ return $error->new(RC_INTERNAL_SERVER_ERROR, $this);
+ }
+
+ #
+ # Store headers for later retrieval
+ #
+
+ $this->{http_headers} = $header;
+
+ #
+ # Create proper page object, which will parse the results file as needed.
+ #
+
+ my $type = $header->{'Content-Type'};
+ my $base_type = lc($type);
+ $base_type =~ s/;.*//; # Strip type parameters
+ my $objtype = $this->_obj_type->{$base_type} || "Other";
+ $objtype = "CGI::Test::Page::$objtype";
+
+ eval "require $objtype";
+ logdie "can't load module $objtype: $@" if chop $@;
+
+ my $page = $objtype->new(
+ -server => $this,
+ -file => $fname,
+ -content_type => $type, # raw type, with parameters
+ -user => $user,
+ -uri => $u,
+ );
+
+ unlink $fname or logwarn "can't unlink $fname: $!";
+
+ return $page;
+}
+
+######################################################################
+#
+# ->_run_cgi
+#
+# Run the specified script within a CGI environment.
+#
+# The -user is the name of the authenticated user running this script.
+#
+# The -in and -out parameters are file handles where STDIN and STDOUT
+# need to be connected to. If $in is undefined, STDIN is connected
+# to /dev/null.
+#
+# Returns nothing.
+#
+######################################################################
+sub _run_cgi
+{
+ my $this = shift;
+ my ($script, $name, $user, $in, $out, $u, $path, $input) =
+ cxgetargs(@_,
+ -script_file => 's',
+ -script_name => 's',
+ -user => [ undef ],
+ -in => [ undef ],
+ -out => undef,
+ -uri => 'URI',
+ -path_info => 's',
+ -input => [ 'CGI::Test::Input' ],
+ );
+
+ #
+ # Connect file descriptors.
+ #
+
+ if (defined $in)
+ {
+ open(STDIN, '<&=' . fileno($in)) || logdie "can't redirect STDIN: $!";
+ }
+ else
+ {
+ my $devnull = File::Spec->devnull;
+ open(STDIN, $devnull) || logdie "can't open $devnull: $!";
+ }
+ open(STDOUT, '>&=' . fileno($out)) || logdie "can't redirect STDOUT: $!";
+
+ #
+ # Setup default CGI environment.
+ #
+
+ while (my ($key, $value) = each %{$this->cgi_env})
+ {
+ $ENV{$key} = $value;
+ }
+
+ #
+ # Where there is a script input, setup CONTENT_* variables.
+ # If there's no input, delete CONTENT_* variables.
+ #
+
+ if (defined $in)
+ {
+ $ENV{CONTENT_TYPE} = $input->mime_type;
+ $ENV{CONTENT_LENGTH} = $input->length;
+ }
+ else
+ {
+ delete $ENV{CONTENT_TYPE};
+ delete $ENV{CONTENT_LENGTH};
+ }
+
+ #
+ # Supersede whatever they may have set for the following variables,
+ # which are very request-specific:
+ #
+
+ $ENV{REQUEST_METHOD} = defined $in ? "POST" : "GET";
+ $ENV{PATH_INFO} = $path;
+ $ENV{SCRIPT_NAME} = $name;
+ $ENV{SCRIPT_FILENAME} = $script;
+ $ENV{HTTP_HOST} = $u->host_port;
+
+ if (length $path)
+ {
+ $ENV{PATH_TRANSLATED} = $this->doc_dir . $path;
+ }
+ else
+ {
+ delete $ENV{PATH_TRANSLATED};
+ }
+
+ if (defined $user)
+ {
+ $ENV{REMOTE_USER} = $user;
+ }
+ else
+ {
+ delete $ENV{REMOTE_USER};
+ delete $ENV{AUTH_TYPE};
+ }
+
+ if (defined $u->query)
+ {
+ $ENV{QUERY_STRING} = $u->query;
+ }
+ else
+ {
+ delete $ENV{QUERY_STRING};
+ }
+
+ #
+ # Make sure the script sees the same @INC as we do currently.
+ # This is very important when running a regression test suite, to
+ # make sure any CGI script using the module we're testing will see
+ # the files from the build directory.
+ #
+ # Since we're about to chdir() to the cgi-bin directory, we must anchor
+ # any relative path to the current working directory.
+ #
+
+ use Cwd qw(abs_path);
+
+ $ENV{PERL5LIB} = join(':', map {-e $_ ? abs_path($_) : $_} @INC);
+
+ #
+ # Now run the script, changing the current directory to the location
+ # of the script, as a web server would.
+ #
+
+ my $directory = dirname($script);
+ my $basename = basename($script);
+
+ chdir $directory or logdie "can't cd to $directory: $!";
+
+ {exec "./$basename"}
+ logdie "could not exec $script: $!";
+ return;
+}
+
+######################################################################
+#
+# ->_parse_header
+#
+# Look for a set of leading HTTP headers in the file, and insert them
+# into a hash table (we don't expect duplicates).
+#
+# Returns ref to hash containing the headers.
+#
+######################################################################
+sub _parse_header
+{
+ my $this = shift;
+ my ($file) = @_;
+ my %header;
+ local *FILE;
+ open(FILE, $file) || logerr "can't open $file: $!";
+ local $_;
+ my $field;
+
+ while (<FILE>)
+ {
+ last if /^\015?\012$/ || /^\015\012$/;
+ s/\015?\012$//;
+ if (s/^\s+/ /)
+ {
+ last if $field eq ''; # Cannot be a header
+ $header{$field} .= $_ if $field ne '';
+ }
+ elsif (($field, my $value) = /^([\w-]+)\s*:\s*(.*)/)
+ {
+ $field =~ s/(\w+)/\u\L$1/g; # Normalize spelling
+ if (exists $header{$field})
+ {
+ logwarn "duplicate $field header in $file";
+ $header{$field} .= " ";
+ }
+ $header{$field} .= $value;
+ }
+ else
+ {
+ logwarn "mangled header in $file";
+ %header = (); # Discard what we read sofar
+ last;
+ }
+ }
+ close FILE;
+ return \%header;
+}
+
+######################################################################
+#
+# ok
+#
+# Useful to print test result when using Test::Harness.
+#
+######################################################################
+sub ok
+{
+ my ($num, $ok, $comment) = @_;
+ print "not " unless $ok;
+ print "ok $num";
+ print " # $comment" if defined $comment;
+ print "\n";
+}
+
+1;
+
+=head1 NAME
+
+CGI::Test - CGI regression test framework
+
+=head1 SYNOPSIS
+
+ # In some t/script.t regression test, for instance
+ use CGI::Test; # exports ok()
+
+ my $ct = CGI::Test->new(
+ -base_url => "http://some.server:1234/cgi-bin",
+ -cgi_dir => "/path/to/cgi-bin",
+ );
+
+ my $page = $ct->GET("http://some.server:1234/cgi-bin/script?arg=1");
+ ok 1, $page->content_type =~ m|text/html\b|;
+
+ my $form = $page->forms->[0];
+ ok 2, $form->action eq "/cgi-bin/some_target";
+
+ my $menu = $form->menu_by_name("months");
+ ok 3, $menu->is_selected("January");
+ ok 4, !$menu->is_selected("March");
+ ok 5, $menu->multiple;
+
+ my $send = $form->submit_by_name("send_form");
+ ok 6, defined $send;
+
+ #
+ # Now interact with the CGI
+ #
+
+ $menu->select("March"); # "click" on the March label
+ my $answer = $send->press; # "click" on the send button
+ ok 7, $answer->is_ok; # and make sure we don't get an HTTP error
+
+=head1 DESCRIPTION
+
+The C<CGI::Test> module provides a CGI regression test framework which
+allows you to run your CGI programs offline, i.e. outside a web server,
+and interact with them programmatically, without the need to type data
+and click from a web browser.
+
+If you're using the C<CGI> module, you may be familiar with its offline
+testing mode. However, this mode is appropriate for simple things, and
+there is no support for conducting a full session with a stateful script.
+C<CGI::Test> fills this gap by providing the necessary infrastructure to
+run CGI scripts, then parse the output to construct objects that can be
+queried, and on which you can interact to "play" with the script's control
+widgets, finally submitting data back. And so on...
+
+Note that the CGI scripts you can test with C<CGI::Test> need not be
+implemented in Perl at all. As far as this framework is concerned, CGI
+scripts are executables that are run on a CGI-like environment and which
+produce an output.
+
+To use the C<CGI::Test> framework, you need to configure a C<CGI::Test>
+object to act like a web server, by providing the URL base where
+CGI scripts lie on this pseudo-server, and which physical directory
+corresponds to that URL base.
+
+From then on, you may issue GET and POST requests giving an URL, and
+the pseudo-server returns a C<CGI::Test::Page> object representing the
+outcome of the request. This page may be an error, plain text, some
+binary data, or an HTML page (see L<CGI::Test::Page> for details).
+
+The latter (an HTML page) can contain one or more CGI forms (identified
+by C<E<lt>FORME<gt>> tags), which are described by instances of
+C<CGI::Test::Form> objects (see L<CGI::Test::Form> for details).
+
+Forms can be queried to see whether they contain a particular type
+of widget (menu, text area, button, etc...), of a particular name
+(that's the CGI parameter name). Once found, one may interact with
+a widget as the user would from a browser. Widgets are described by
+polymorphic objects which conform to the C<CGI::Test::Form::Widget> type.
+The specific interaction that is offered depends on the dynamic type of
+the object (see L<CGI::Test::Form::Widget> for details).
+
+An interaction with a form ends by a submission of the form data to the
+server, and getting a reply back. This is done by pressing a submit button,
+and the press() routine returns a new page. Naturally, no server is
+contacted at all within the C<CGI::Test> framework, and the CGI script is
+ran through a proper call to one of the GET/POST method on the
+C<CGI::Test> object.
+
+Finally, since C<CGI::Test> is meant to be used from regression test
+scripts, it exports a single ok() routine which merely prints the messages
+expected by C<Test::Harness>. This is the only functional routine in this
+module, all other accesses being made through a C<CGI::Test> object.
+
+=head1 INTERFACE
+
+=head2 Procedural Interface
+
+There is only one such routine:
+
+=over 4
+
+=item C<ok> I<num>, I<boolean> [, I<comment>]
+
+Prints the I<ok> or I<not ok> message for C<Test::Harness> depending
+on whether I<boolean> is respectively I<true> or I<false>. An optional
+I<comment> string may be supplied as well and will be printed after a
+'#' sign:
+
+ ok 1, 2+2 == 4, "trivial arithmetic";
+
+will print:
+
+ ok 1 # trivial arithmetic
+
+since the test trivially succeeds.
+
+=back
+
+=head2 Creation Interface
+
+The creation routine C<new()> takes the following mandatory parameters:
+
+=over 4
+
+=item C<-base_url> => I<URL of the cgi-bin directory>
+
+Defines the URL domain which is handled by C<CGI::Test>.
+This is the URL of the C<cgi-bin> directory.
+
+Note that there is no need to have something actually running on the
+specified host or port, and the server name can be any host name,
+whether it exists or not. For instance, if you say:
+
+ -base_url => "http://foo.example.com:70/cgi-bin"
+
+you simply declare that the C<CGI::Test> object will know how to handle
+a GET request for, say:
+
+ http://foo.example.com:70/cgi-bin/script
+
+and it will do so I<internally>, without contacting C<foo.example.com>
+on port 70...
+
+=item C<-cgi_dir> => I<path to the cgi-bin directoru>
+
+Defines the physical path corresponding to the C<cgi-bin> directory defined
+by the C<-base_url> parameter.
+
+For instance, given the settings:
+
+ -base_url => "http://foo.example.com:70/cgi-bin",
+ -cgi_dir => "/home/ram/cgi/test"
+
+then requesting
+
+ http://foo.example.com:70/cgi-bin/script
+
+will actually run
+
+ /home/ram/cgi/test/script
+
+Those things are really easier to understand via examples than via
+formal descriptions, aren't they?
+
+=back
+
+The following optional arguments may also be provided:
+
+=over 4
+
+=item C<-cgi_env> => I<HASH ref>
+
+Defines additional environment variables that must be set, or changes
+hardwirted defaults. Some variables like C<CONTENT_TYPE> really depend
+on the request and will be dynamically computed by C<CGI::Test>.
+
+For instance:
+
+ -cgi_env => {
+ HTTP_USER_AGENT => "Mozilla/4.76",
+ AUTH_TYPE => "Digest",
+ }
+
+See L<CGI ENVIRONMENT VARIABLES> for more details on which environment
+variables are defined, and which may be superseded.
+
+=item C<-doc_dir> => I<path to document tree>
+
+This defines the root directory of the HTTP server, for path translation.
+It defaults to C</var/www>.
+
+B<NOTE>: C<CGI::Test> only serves CGI scripts for now, so this setting
+is not terribly useful, unless you care about C<PATH_TRANSLATED>.
+
+=item C<-tmp_dir> => I<path to temporary directory>
+
+The temporary directory to use for internal files created while processing
+requests. Defaults to the value of the environment variable C<TMPDIR>,
+or C</tmp> if it is not set.
+
+=back
+
+=head2 Object Interface
+
+The following methods, listed in alphabetical order, are available:
+
+=over 4
+
+=item C<GET> I<url_string> [, I<auth_user>]
+
+Issues an HTTP GET request of the specified URL, given as the string
+I<url_string>. It must be in the http scheme, and must lie within the
+configured CGI space (i.e. under the base URL given at creation time
+via C<-base_url>).
+
+Optionally, you may specify the name of an authenticated user as the
+I<auth_user> string. C<CGI::Test> will simply setup the CGI environment
+variable C<REMOTE_USER> accordingly. Since we're in a testing framework,
+you can pretend to be anyone you like. See L<CGI ENVIRONMENT VARIABLES>
+for more information on environment variables, and in particular
+C<AUTH_TYPE>.
+
+C<GET> returns a C<CGI::Test::Page> polymorphic object, i.e. an object whose
+dynamic type is an heir of C<CGI::Test::Page>. See L<CGI::Test::Page> for
+more information on this class hierarchy.
+
+=item C<POST> I<url_string>, I<input_data> [, I<auth_user>]
+
+Issues an HTTP POST request of the specified URL. See C<GET> above for
+a discussion on I<url_string> and I<auth_user>, which applies to C<POST>
+as well.
+
+The I<input_data> parameter must be a C<CGI::Test::Input> object.
+It specifies the CGI parameters to be sent to the script. Users normally
+don't issue POST requests manually: they are the result of submits on
+forms, which are obtained via an initial GET. Nonetheless, you can
+create your own input easily and issue a "faked" POST request, to see
+how your script might react to inconsistent (and probably malicious)
+input for instance. See L<CGI::Test::Input> to learn how to construct
+suitable input.
+
+C<POST> returns a C<CGI::Test::Page> polymorphic object, like C<GET> does.
+
+=item C<base_path>
+
+The base path in the URL space of the base URL configured at creation time.
+It's the URL with the scheme, host and port information removed.
+
+=item C<cgi_dir>
+
+The configured CGI root directory where scripts to be run are held.
+
+=item C<doc_dir>
+
+The configured document root directory.
+
+=item C<host_port>
+
+The host and port of the base URL you configured at creation time.
+
+=item C<split_uri> I<URI>
+
+Splits an URI object into server (host and port), path and query components.
+The path is simplified using UNIX semantics, i.e. C</./> is ignored and
+stripped, and C</../> is resolved by forgetting the path component that
+immediately precedes it (no attempt is made to make sure the translated path
+was indeed pointing to an existing directory: simplification happens in the
+path space).
+
+Returns the list (host, path, query).
+
+=item C<tmp_dir>
+
+The temporary directory that is being used.
+
+=item C<http_headers>
+
+Returns hashref with parsed HTTP headers received from CGI script.
+
+=back
+
+=head1 CGI ENVIRONMENT VARIABLES
+
+The CGI protocol defines a set of environment variables which are to be set
+by the web server before invoking the script. The environment created by
+C<CGI::Test> conforms to the CGI/1.1 specifications.
+
+Here is a list of all the known variables. Some of those are marked
+I<read-only>. It means you may choose to set them via the C<-cgi_env>
+switch of the C<new()> routine, but your settings will have no effect and
+C<CGI::Test> will always compute a suitable value.
+
+Variables are listed in alphabetical order:
+
+=over 4
+
+=item C<AUTH_TYPE>
+
+The authentication scheme used to authenticate the user given by C<REMOTE_USER>.
+This variable is not present in the environment if there was no user specified
+in the GET/POST requests.
+
+By default, it is set to "Basic" when present.
+
+=item C<CONTENT_LENGTH>
+
+Read-only variable, giving the length of data to be read on STDIN by POST
+requests (as told by C<REQUEST_METHOD>). If is not present for GET requests.
+
+=item C<CONTENT_TYPE>
+
+Read-only variable, giving the MIME type of data to be read on STDIN by POST
+requests (as told by C<REQUEST_METHOD>). If is not present for GET requests.
+
+=item C<GATEWAY_INTERFACE>
+
+The Common Gateway Interface (CGI) version specification.
+Defaults to "CGI/1.1".
+
+=item C<HTTP_ACCEPT>
+
+The set of Content-Type that are said to be accepted by the client issuing
+the HTTP request. Since there is no browser making any request here, the
+default is set to "*/*".
+
+It is up to your script to honour the value of this variable if it wishes to
+be nice with the client.
+
+=item C<HTTP_ACCEPT_CHARSET>
+
+The charset that is said to be accepted by the client issuing the HTTP
+request. Since there is no browser making any request here, the
+default is set to "iso-8859-1".
+
+=item C<HTTP_CONNECTION>
+
+Whether the connection should be kept alive by the server or closed after
+this request. Defaults to "Close", but since there's no connection and
+no real client...
+
+=item C<HTTP_HOST>
+
+This is the host processing the HTTP request.
+It is a read-only variable, set to the hostname and port parts of the
+requested URL.
+
+=item C<HTTP_USER_AGENT>
+
+The user agent tag string. This can be used by scripts to emit code that
+can be understood by the client, and is also further abused to derive the
+OS type where the user agent runs.
+
+In order to be as neutral as possible, it is set to "CGI::Test" by default.
+
+=item C<PATH_INFO>
+
+Read-only variable set to the extra path information part of the requested URL.
+Always present, even if empty.
+
+=item C<PATH_TRANSLATED>
+
+This read-only variable is only present when there is a non-empty C<PATH_INFO>
+variable. It is simply set to the value of C<PATH_INFO> with the document
+rootdir path prepended to it (the value of the C<-doc_dir> creation argument).
+
+=item C<QUERY_STRING>
+
+This very important read-only variable is the query string present in the
+requested URL. Note that it may very well be set even for a POST request.
+
+=item C<REMOTE_ADDR>
+
+The IP address of the client making the requst. Can be used to implement
+an access policy from within the script. Here, given that there's no real
+client, the default is set to "127.0.0.1", which is the IP of the local
+loopback interface.
+
+=item C<REMOTE_HOST>
+
+The DNS-translated hostname of the IP address held in C<REMOTE_ADDR>.
+Here, for testing purposes, it is not computed after C<REMOTE_ADDR> but can
+be freely set. Defaults to "localhost".
+
+=item C<REMOTE_USER>
+
+This read-only variable is only present when making an authenticated GET or
+POST request. Its value is the name of the user we are supposed to have
+successfully authenticated, using the scheme held in C<AUTH_TYPE>.
+
+=item C<REQUEST_METHOD>
+
+Read-only variable, whose value is either C<GET> or C<POST>.
+
+=item C<SCRIPT_FILENAME>
+
+Read-only variable set to the filesystem path of the CGI script being run.
+
+=item C<SCRIPT_NAME>
+
+Read-only variable set to the virtual path of the CGI script being run,
+i.e. the path given in the requested URL.
+
+=item C<SERVER_NAME>
+
+The host name running the server, which defaults to the host name present
+in the base URL, provided at creation time as the C<-base_url> argument.
+
+=item C<SERVER_PORT>
+
+The port where the server listens, which defaults to the port present
+in the base URL, provided at creation time as the C<-base_url> argument.
+If no port was explicitely given, 80 is assumed.
+
+=item C<SERVER_PROTOCOL>
+
+The protocol which must be followed when replying to the client request.
+Set to "HTTP/1.1" by default.
+
+=item C<SERVER_SOFTWARE>
+
+The name of the server software. Defaults to "CGI::Test".
+
+=back
+
+=head1 BUGS
+
+There are some, most probably. Please notify me about them.
+
+The following limitations (in decreasing amount of importance)
+are known and may be lifted one day -- patches welcome:
+
+=over 4
+
+=item *
+
+There is no support for cookies. A CGI installing cookies and expecting
+them to be resent on further invocations to friendly scripts is bound
+to disappointment.
+
+=item *
+
+There is no support for testing a script in-situ, i.e. via a real web server,
+whereby C<CGI::Test> would merely act as a client. Currently, scripts are
+run internally only, and therefore it is not possible to validate the
+installation procedure on the server.
+
+=item *
+
+There is no support for plain document retrieval: only CGI scripts can
+be fetched by an HTTP request for now.
+
+=item *
+
+There is no support for javascript (!). Plain buttons attached to scripts
+will do nothing when pressed...
+
+=item *
+
+There is no support for frames (!).
+
+=item *
+
+There is no support for Java (!). Perhaps if I work for Sun one day...
+
+=item *
+
+There is no support for the <ISINDEX> tag, which is deprecated.
+
+=back
+
+=head1 WEBSITE
+
+You can find information about CGI::Test and other related modules at:
+
+ http://cgi-test.sourceforge.net
+
+=head1 PUBLIC CVS SERVER
+
+CGI::Test now has a publicly accessible CVS server provided by
+SourceForge (www.sourceforge.net). You can access it by going to:
+
+ http://sourceforge.net/cvs/?group_id=89570
+
+=head1 AUTHORS
+
+The original author is Raphael Manfredi F<E<lt>Raphael_Manfredi at pobox.comE<gt>>.
+
+Send bug reports, hints, tips, suggestions to Steven Hilton F<E<lt>mshiltonj at mshiltonj.comE<gt>>.
+
+=head1 SEE ALSO
+
+CGI(3), CGI::Test::Page(3), CGI::Test::Form(3), CGI::Test::Input(3),
+CGI::Test::Form::Widget(3), HTTP::Status(3), URI(3).
+
+=cut
+
diff --git a/lib/CGI/Test/Form.pm b/lib/CGI/Test/Form.pm
new file mode 100644
index 0000000..18b03fd
--- /dev/null
+++ b/lib/CGI/Test/Form.pm
@@ -0,0 +1,1231 @@
+package CGI::Test::Form;
+use strict;
+####################################################################
+# $Id: Form.pm 411 2011-09-26 11:19:30Z nohuhu at nohuhu.org $
+# $Name: cgi-test_0-104_t1 $
+####################################################################
+# Copyright (c) 2001, Raphael Manfredi
+#
+# You may redistribute only under the terms of the Artistic License,
+# as specified in the README file that comes with the distribution.
+#
+
+#
+# Class interfacing with the content of a <FORM> tag, which comes from
+# a CGI::Test::Page object. The tree nodes we are playing with here are
+# direct pointers into the node of the page object.
+#
+
+use Carp;
+use Log::Agent;
+
+#
+# We may not create an instance of all those classes, but the cost of
+# lazily requiring them would probably outweigh the cost of loading
+# them once and for all, on reasonably sized forms.
+#
+use CGI::Test::Form::Widget::Button::Submit;
+use CGI::Test::Form::Widget::Button::Reset;
+use CGI::Test::Form::Widget::Button::Image;
+use CGI::Test::Form::Widget::Button::Plain;
+use CGI::Test::Form::Widget::Input::Text_Field;
+use CGI::Test::Form::Widget::Input::Text_Area;
+use CGI::Test::Form::Widget::Input::Password;
+use CGI::Test::Form::Widget::Input::File;
+use CGI::Test::Form::Widget::Menu::List;
+use CGI::Test::Form::Widget::Menu::Popup;
+use CGI::Test::Form::Widget::Box::Radio;
+use CGI::Test::Form::Widget::Box::Check;
+use CGI::Test::Form::Widget::Hidden;
+
+######################################################################
+#
+# ->new
+#
+# Creation routine
+#
+######################################################################
+sub new
+{
+ my $this = bless {}, shift;
+ my ($node, $page) = @_;
+
+ $this->{tree} = $node; # <FORM> is the root node of the tree
+ $this->{page} = $page;
+
+ $this->{enctype} = $node->attr("enctype")
+ || "application/x-www-form-urlencoded";
+ $this->{method} = uc $node->attr("method") || "POST";
+
+ foreach my $attr (qw(action name accept accept-charset))
+ {
+ my $oattr = $attr;
+ $oattr =~ s/-/_/g;
+ my $value = $node->attr($attr);
+ $this->{$oattr} = $value if defined $value;
+ }
+
+ #
+ # Although ACTION is now required in newer HTML DTDs, it was optional
+ # in HTML 2.0 and defaults to the base URI of the document.
+ #
+
+ $this->{action} = $page->uri->as_string unless exists $this->{action};
+
+ return $this;
+}
+
+######################################################################
+# DEPRECATED
+######################################################################
+sub make
+{ #
+ my $class = shift;
+ return $class->new(@_);
+}
+
+#
+# Attribute access
+#
+
+######################################################################
+sub tree
+{
+ my $this = shift;
+ return $this->{tree};
+}
+
+######################################################################
+sub page
+{
+ my $this = shift;
+ return $this->{page};
+}
+
+######################################################################
+sub enctype
+{
+ my $this = shift;
+ return $this->{enctype};
+}
+
+######################################################################
+sub action
+{
+ my $this = shift;
+ return $this->{action};
+}
+
+######################################################################
+sub method
+{
+ my $this = shift;
+ return $this->{method};
+}
+
+######################################################################
+sub name
+{
+ my $this = shift;
+ return $this->{name};
+}
+
+######################################################################
+sub accept
+{
+ my $this = shift;
+ return $this->{accept};
+}
+
+######################################################################
+sub accept_charset
+{
+ my $this = shift;
+ return $this->{accept_charset};
+}
+
+#
+# Lazy attribute access
+#
+
+######################################################################
+sub buttons
+{
+ my $this = shift;
+ return $this->{buttons} || $this->_xtract("buttons");
+}
+
+######################################################################
+sub inputs
+{
+ my $this = shift;
+ return $this->{inputs} || $this->_xtract("inputs");
+}
+
+######################################################################
+sub menus
+{
+ my $this = shift;
+ return $this->{menus} || $this->_xtract("menus");
+}
+
+######################################################################
+sub radios
+{
+ my $this = shift;
+ return $this->{radios} || $this->_xtract("radios");
+}
+
+######################################################################
+sub checkboxes
+{
+ my $this = shift;
+ return $this->{checkboxes} || $this->_xtract("checkboxes");
+}
+
+######################################################################
+sub hidden
+{
+ my $this = shift;
+ return $this->{hidden} || $this->_xtract("hidden");
+}
+
+######################################################################
+sub widgets
+{
+ my $this = shift;
+ return $this->{widgets} || $this->_xtract("widgets");
+}
+
+#
+# Second-order lazy attributes
+#
+
+######################################################################
+sub submits
+{
+ my $this = shift;
+ return $this->{submits} || ($this->{submits} = $this->_submits);
+}
+
+######################################################################
+sub radio_groups
+{
+ my $this = shift;
+ return $this->radios()
+ && $this->{radio_groups};
+}
+######################################################################
+sub checkbox_groups
+{
+ my $this = shift;
+ return $this->checkboxes()
+ && $this->{checkbox_groups};
+}
+
+#
+# Expanded lists -- syntactic sugar
+#
+
+######################################################################
+sub button_list
+{
+ my $this = shift;
+ return @{$this->buttons()};
+}
+######################################################################
+sub input_list
+{
+ my $this = shift;
+ return @{$this->inputs()};
+}
+######################################################################
+sub menu_list
+{
+ my $this = shift;
+ return @{$this->menus()};
+}
+######################################################################
+sub radio_list
+{
+ my $this = shift;
+ return @{$this->radios()};
+}
+######################################################################
+sub checkbox_list
+{
+ my $this = shift;
+ return @{$this->checkboxes()};
+}
+######################################################################
+sub hidden_list
+{
+ my $this = shift;
+ return @{$this->hidden()};
+}
+######################################################################
+sub widget_list
+{
+ my $this = shift;
+ return @{$this->widgets()};
+}
+######################################################################
+sub submit_list
+{
+ my $this = shift;
+ @{$this->submits()};
+}
+
+#
+# By parameter-name n-n widget access (one widget returned for each asked)
+#
+
+######################################################################
+sub button_by_name
+{
+ my $this = shift;
+ $this->_by_name($this->buttons, @_);
+}
+######################################################################
+sub input_by_name
+{
+ my $this = shift;
+ $this->_by_name($this->inputs, @_);
+}
+######################################################################
+sub menu_by_name
+{
+ my $this = shift;
+ $this->_by_name($this->menus, @_);
+}
+######################################################################
+sub radio_by_name
+{
+ my $this = shift;
+ $this->_by_name($this->radios, @_);
+}
+######################################################################
+sub checkbox_by_name
+{
+ my $this = shift;
+ $this->_by_name($this->checkboxes, @_);
+}
+######################################################################
+sub hidden_by_name
+{
+ my $this = shift;
+ $this->_by_name($this->hidden, @_);
+}
+######################################################################
+sub widget_by_name
+{
+ my $this = shift;
+ $this->_by_name($this->widgets, @_);
+}
+######################################################################
+sub submit_by_name
+{
+ my $this = shift;
+ return $this->_by_name($this->submits, @_);
+}
+
+#
+# By parameter-name 1-n widget access (many widgets may be returned, one asked)
+#
+
+######################################################################
+sub buttons_named
+{
+ my $this = shift;
+ return $this->_all_named($this->buttons, @_);
+}
+######################################################################
+sub inputs_named
+{
+ my $this = shift;
+ return $this->_all_named($this->inputs, @_);
+}
+######################################################################
+sub menus_named
+{
+ my $this = shift;
+ return $this->_all_named($this->menus, @_);
+}
+######################################################################
+sub radios_named
+{
+ my $this = shift;
+ return $this->_all_named($this->radios, @_);
+}
+######################################################################
+sub checkboxes_named
+{
+ my $this = shift;
+ return $this->_all_named($this->checkboxes, @_);
+}
+######################################################################
+sub hidden_named
+{
+ my $this = shift;
+ return $this->_all_named($this->hidden, @_);
+}
+######################################################################
+sub widgets_named
+{
+ my $this = shift;
+ return $this->_all_named($this->widgets, @_);
+}
+######################################################################
+sub submits_named
+{
+ my $this = shift;
+ return $this->_all_named($this->submits, @_);
+}
+
+#
+# Convenience routines around ->_matching().
+#
+
+######################################################################
+sub buttons_matching
+{
+ my $this = shift;
+ return $this->_matching($this->buttons, @_);
+}
+######################################################################
+sub inputs_matching
+{
+ my $this = shift;
+ return $this->_matching($this->inputs, @_);
+}
+######################################################################
+sub menus_matching
+{
+ my $this = shift;
+ return $this->_matching($this->menus, @_);
+}
+######################################################################
+sub radios_matching
+{
+ my $this = shift;
+ return $this->_matching($this->radios, @_);
+}
+######################################################################
+sub checkboxes_matching
+{
+ my $this = shift;
+ return $this->_matching($this->checkboxes, @_);
+}
+######################################################################
+sub hidden_matching
+{
+ my $this = shift;
+ return $this->_matching($this->hidden, @_);
+}
+######################################################################
+sub widgets_matching
+{
+ my $this = shift;
+ return $this->_matching($this->widgets, @_);
+}
+######################################################################
+sub submits_matching
+{
+ my $this = shift;
+ return $this->_matching($this->submits, @_);
+}
+
+######################################################################
+#
+# ->reset
+#
+# Reset form state, restoring all the widget controls to the value they
+# had upon entry.
+#
+######################################################################
+sub reset
+{
+ my $this = shift;
+
+ foreach my $w ($this->widget_list)
+ {
+ $w->reset_state;
+ }
+ return;
+}
+
+######################################################################
+#
+# ->submit
+#
+# Submit this form.
+# Returns resulting CGI::Test::Page.
+#
+######################################################################
+sub submit
+{
+ my $this = shift;
+
+ my $method = $this->method;
+ my $input = $this->_output; # Input to the request we're about to make
+ my $action = $this->_action_url;
+ my $page = $this->page;
+ my $server = $page->server;
+ my $result;
+
+ if ($method eq "GET")
+ {
+ logconfess "GET requests only allowed URL encoding, not %s",
+ $input->mime_type
+ unless $input->mime_type eq "application/x-www-form-urlencoded";
+
+ $action->query($input->data);
+ $result = $server->GET($action->as_string, $page->user);
+ }
+ elsif ($method eq "POST")
+ {
+ $result = $server->POST($action->as_string, $input, $page->user);
+ }
+ else
+ {
+ logconfess "unsupported method $method for FORM action";
+ }
+
+ return $result;
+}
+
+######################################################################
+#
+# ->_xtract
+#
+# Widget extraction routine: traverse the <FORM> tree and create an instance
+# of CGI::Test::Form::Widget per encountered widget. The dynamic type depends
+# on the widget type, e.g. a button creates a CGI::Test::Form::Widget::Button
+# object.
+#
+# Widgets are also sorted by type, and stored as object attribute:
+#
+# buttons all buttons
+# inputs text area, text fields, password fields
+# menus popup menus
+# radios radio buttons
+# checkboxes all checkboxes
+# hidden all hidden fields
+# widgets all widgets, whatever their type.
+#
+# The special attribute `radio_groups' is only built when there is at least
+# one radio button.
+#
+# Although we extract ALL the widgets, caller is only interested in a
+# specific list, given in $which. Therefore, returns a list ref on that
+# particular set.
+#
+######################################################################
+sub _xtract
+{
+ my $this = shift;
+ my ($which) = @_;
+
+ #
+ # Initiate traversal to locate all widgets nodes.
+ #
+
+ my %is_widget = map {$_ => 1} qw(input textarea select button isindex);
+ my @wg = $this->tree->look_down(sub {$is_widget{$_[ 0 ]->tag}});
+
+ #
+ # Initialize all lists to be empty
+ #
+
+ for my $attr ( qw(buttons inputs radios checkboxes hidden menus widgets) )
+ {
+ $this->{$attr} = [];
+ }
+
+ #
+ # And now sort them out.
+ #
+
+ my %input = ( # [ class name, attribute ]
+ "submit" => [ 'Button::Submit', "buttons" ],
+ "reset" => [ 'Button::Reset', "buttons" ],
+ "image" => [ 'Button::Image', "buttons" ],
+ "text" => [ 'Input::Text_Field', "inputs" ],
+ "file" => [ 'Input::File', "inputs" ],
+ "password" => [ 'Input::Password', "inputs" ],
+ "radio" => [ 'Box::Radio', "radios" ],
+ "checkbox" => [ 'Box::Check', "checkboxes" ],
+ "hidden" => [ 'Hidden', "hidden" ],
+ );
+
+ my %button = ( # [ class name, attribute ]
+ "submit" => [ 'Button::Submit', "buttons" ],
+ "reset" => [ 'Button::Reset', "buttons" ],
+ "button" => [ 'Button::Plain', "buttons" ],
+ );
+
+ my $wlist = $this->{widgets}; # All widgets also inserted there
+
+ foreach my $node (@wg)
+ {
+ my $tag = $node->tag;
+ my ($class, $attr);
+ my $hlookup;
+
+ if ($tag eq "input")
+ {
+ $hlookup = \%input;
+ }
+ elsif ($tag eq "textarea")
+ {
+ ($class, $attr) = ("Input::Text_Area", "inputs");
+ }
+ elsif ($tag eq "select")
+ {
+ $attr = "menus";
+ $class =
+ ($node->attr("multiple") || defined $node->attr("size"))
+ ? "Menu::List"
+ : "Menu::Popup";
+ }
+ elsif ($tag eq "button")
+ {
+ $hlookup = \%button;
+ }
+ elsif ($tag eq "isindex")
+ {
+ logwarn "ISINDEX is deprecated, ignoring %s", $node->starttag;
+ next;
+ }
+ else
+ {
+ logconfess "reached tag '$tag': invalid tree look_down()?";
+ }
+
+ #
+ # If $hlookup is defined, we need to look at the TYPE attribute
+ # within the tag to determine the object to build.
+ #
+ # This handles <INPUT TYPE="xxx"> and <BUTTON TYPE="xxx">
+ #
+
+ if (defined $hlookup)
+ {
+ my $type = $node->attr("type");
+ unless (defined $type)
+ {
+ logerr "missing TYPE indication in %s: %s", uc($tag),
+ $node->starttag;
+ next;
+ }
+ my $info = $hlookup->{lc($type)};
+ unless (defined $info)
+ {
+ logerr "unknown TYPE '%s' in %s: %s", $type, uc($tag),
+ $node->starttag;
+ next;
+ }
+
+ ($class, $attr) = @$info;
+ }
+
+ #
+ # Create object of given class, insert into attribute list.
+ # Objects will not keep a reference on the node, but will reference us.
+ #
+
+ my $obj = "CGI::Test::Form::Widget::$class"->new($node, $this);
+ push @{$this->{$attr}}, $obj;
+ push @$wlist, $obj;
+ }
+
+ #
+ # Special handling for radio buttons: they need to be groupped, so that
+ # selecting one automatically unselects others from the same group.
+ #
+ # Special handling for checkboxes: one may wish to get at a "group of
+ # checkboxes" instead of an individual checkbox widget.
+ #
+
+ my $radios = $this->{radios};
+ my $checkboxes = $this->{checkboxes};
+
+ if (@$radios)
+ {
+ require CGI::Test::Form::Group;
+ $this->{radio_groups} = CGI::Test::Form::Group->new($radios);
+ }
+
+ if (@$checkboxes)
+ {
+ require CGI::Test::Form::Group;
+ $this->{checkbox_groups} = CGI::Test::Form::Group->new($checkboxes);
+ }
+
+ #
+ # Finally, return the list they asked for.
+ #
+
+ return $this->{
+ $which};
+}
+
+######################################################################
+#
+# ->_by_name
+#
+# Access to widgets, by name, in an n-n fashion: one widget returned for
+# each name asked, multiple names may be givem.
+#
+# Extract and return a list of widgets from a list, by comparing names.
+# If no widget of corresponding name exists, returns undef.
+#
+# There is one returned element per requested name.
+# When only one name is requested, either scalar or list context may be used.
+#
+# For widgets which may be groupped (e.g. radios or checkboxes), the item
+# selected is the last one bearing that name within the form.
+#
+######################################################################
+sub _by_name
+{
+ my $this = shift;
+ my ($wlist, @names) = @_;
+
+ croak '$wlist is not ARRAY' unless ref $wlist eq 'ARRAY';
+
+ my %byname = map {$_->name => $_} @$wlist;
+ my @results = map {$byname{$_}} @names;
+
+ if (@names == 1)
+ {
+ return @results if wantarray;
+ return $results[ 0 ];
+ }
+
+ return @results;
+}
+
+######################################################################
+#
+# ->_all_named
+#
+# Access to widgets, by name, in a 1-n fashion: from one name, multiple widgets
+# may be returned.
+#
+# Extract and return a list of widgets from a list, by comparing names.
+# If no widget of corresponding name exists, returns an empty list.
+# Otherwise returns the list of all widgets bearing that name.
+#
+######################################################################
+sub _all_named
+{
+ my $this = shift;
+ my ($wlist, $name) = @_;
+
+ croak 'wlist is not ARRAY' unless ref $wlist eq 'ARRAY';
+
+ return grep {$_->name eq $name} @$wlist;
+}
+
+######################################################################
+#
+# ->_matching
+#
+# Extract widgets from list via matching callback, invoked as:
+#
+# callback($widget, $context)
+#
+# where $context is one of the select routine parameters.
+# Returns list of widgets for which the callback returned true.
+#
+######################################################################
+sub _matching
+{
+ my $this = shift;
+ my ($wlist, $code, $context) = @_;
+
+ croak '$wlist is not ARRAY' unless ref $wlist eq 'ARRAY';
+ croak '$code is not CODE reference' unless ref $code eq 'CODE';
+
+ return grep {&$code($_, $context)} @$wlist;
+}
+
+######################################################################
+#
+# ->delete
+#
+# Done with this page, cleanup by breaking circular & multiple refs.
+#
+######################################################################
+sub delete
+{
+ my $this = shift;
+
+ $this->{node} = undef;
+ $this->{page} = undef;
+
+ delete $this->{submits};
+
+ #
+ # Handle lazy attributes.
+ #
+
+ if (ref $this->{widgets})
+ {
+
+ #
+ # Each widget has a reference on us, which must be cleared.
+ #
+
+ foreach my $w (@{$this->{widgets}})
+ {
+ $w->delete;
+ }
+
+ #
+ # All widget objects have two references from here: one through their
+ # type list, and one through the general "widgets" list. Simply
+ # break the "widgets" list.
+ #
+
+ $this->{widgets} = undef;
+ }
+
+ $this->{radio_groups}->delete if ref $this->{radio_groups};
+ $this->{checkbox_groups}->delete if ref $this->{checkbox_groups};
+
+ return;
+}
+
+######################################################################
+#
+# ->_output
+#
+# Create a CGI::Test::Input object and fill it with all the submitable
+# widgets. That object can then generate the data to be used as input of
+# the form's action URL, depending on the form's encoding type.
+#
+######################################################################
+sub _output
+{
+ my $this = shift;
+
+ my $enctype = $this->enctype;
+ my $input;
+
+ #
+ # Create polymorphic form input object, holding this form's output.
+ #
+ # It's called "input" because its data are meant to be the input of the
+ # target CGI script.
+ #
+
+ if ($enctype eq "multipart/form-data")
+ {
+ require CGI::Test::Input::Multipart;
+ $input = CGI::Test::Input::Multipart->new();
+ }
+ else
+ {
+ logwarn "unknown FORM encoding type $enctype, using default"
+ if $enctype ne "application/x-www-form-urlencoded";
+ require CGI::Test::Input::URL;
+ $input = CGI::Test::Input::URL->new();
+ }
+
+ #
+ # Add all submitable widgets.
+ #
+
+ foreach my $w ($this->widgets_matching(sub {$_[ 0 ]->is_submitable}))
+ {
+ $input->add_widget($w);
+ }
+
+ return $input;
+}
+
+######################################################################
+#
+# ->_action_url
+#
+# Compute the action URL, which is what is going to be requested in response
+# to a form submit. It does not contain the query part.
+#
+# We force re-anchor to the server if the action URL is not tied to it
+# explicitely (e.g. ACTION="/cgi-bin/foo").
+#
+######################################################################
+sub _action_url
+{
+ my $this = shift;
+
+ my $uri = $this->page->uri; # The URL that generated this form
+ my $host_port = $uri->host_port;
+
+ require URI;
+
+ my $action = URI->new($this->action, "http");
+ $action->scheme("http");
+ $action->host_port($uri->host_port) unless defined $action->host_port;
+
+ return $action;
+}
+
+######################################################################
+#
+# ->_submits
+#
+# Compute list of submit buttons.
+# Returns ref to this list.
+#
+######################################################################
+sub _submits
+{
+ my $this = shift;
+
+ my @submit = $this->buttons_matching(sub {$_[ 0 ]->is_submit});
+
+ return \@submit;
+}
+
+1;
+
+=head1 NAME
+
+CGI::Test::Form - Querying interface to CGI form widgets
+
+=head1 SYNOPSIS
+
+ my $form = $page->forms->[0]; # first form in CGI::Test::Page
+
+ #
+ # Querying interface, to access form widgets
+ #
+
+ my @buttons = $form->button_list; # ->buttons would give list ref
+ my $radio_listref = $form->radios; # ->radios_list would give list
+
+ my $passwd_widget = $form->input_by_name("password");
+ my ($login, $passwd) = $form->input_by_name(qw(login password));
+
+ my @menus = $form->widgets_matching(sub { $_[0]->is_menu });
+ my @menus = $form->menu_list; # same as line above
+
+ my $rg = $form->radio_groups; # a CGI::Test::Form::Group or undef
+
+ #
+ # <FORM> attributes, as defined by HTML 4.0
+ #
+
+ my $encoding = $form->enctype;
+ my $action = $form->action;
+ my $method = $form->method;
+ my $name = $form->name;
+ my $accept = $form->accept;
+ my $accept_charset = $form->accept_charset;
+
+ #
+ # Miscellaneous
+ #
+
+ # Low-level, direct calls normally not needed
+ $form->reset;
+ my $new_page = $form->submit;
+
+ # Very low-level access
+ my $html_tree = $form->tree; # HTML::Element form tree
+ my $page = $form->page; # Page containing this form
+
+ #
+ # Garbage collection -- needed to break circular references
+ #
+
+ $form->delete;
+
+=head1 DESCRIPTION
+
+The C<CGI::Test::Form> class provides an interface to the content of
+the CGI forms. Instances are automatically created by C<CGI::Test> when
+it analyzes an HTML output from a GET/POST request and encounters such
+beasts.
+
+This class is really the basis of the C<CGI::Test> testing abilities:
+it provides the necessary routines to query the CGI widgets present in the
+form: buttons, input areas, menus, etc... Queries can be made by type, and
+by name. There is also an interface to specifically access groupped widgets
+like checkboxes and radio buttons.
+
+All widgets returned by the queries are polymorphic objects, heirs of
+C<CGI::Test::Form::Widget>. If the querying interface can be compared to
+the human eye, enabling you to locate a particular graphical item on the
+browser screen, the widget interface can be compared to the mouse and keyboard,
+allowing you to interact with the located graphical components. Please
+refer to L<CGI::Test::Form::Widget> for interaction details.
+
+Apart from the widget querying interface, this class also offers a few
+services to other C<CGI::Test> components, like handling of I<reset> and
+I<submit> actions, which need not be used directly in practice.
+
+Finally, it provides inspection of the <FORM> tag attributes (encoding
+type, action, etc...) and, if you really need it, to the HTML tree of
+the all <FORM> content. This interface is based on the C<HTML::Element>
+class, which represents a tree node. The tree is shared with other
+C<CGI::Test> components, it is not a private copy. See L<HTML::Element> if
+you are not already familiar with it.
+
+If memory is a problem, you must be aware that circular references are
+used almost everywhere within C<CGI::Test>. Because Perl's garbage collector
+cannot reclaim objects that are part of such a reference loop, you must
+explicitely call the I<delete> method on C<CGI::Test::Form>.
+Simply forgetting about the reference to that object is not enough.
+Don't bother with it if your regression test scripts die quickly.
+
+=head1 INTERFACE
+
+The interface is mostly a querying interface. Most of the routines return
+widget objects, via lists or list references. See L<CGI::Test::Form::Widget>
+for details about the interface provided by widget objects, and the
+classification.
+
+The order of the widgets returned lists is the same as the order the widgets
+appear in the HTML representation.
+
+=head2 Type Querying Interface
+
+There are two groups or routines: one group returns expanded lists, the
+other returns list references. They are listed in the table below.
+
+The I<Item Polymorphic Type> column refers to the polymorphic dynamic
+type of items held within the list: each item is guaranteed to at least
+be of that type, but can be a descendant. Types are listed in the
+abridged form, and you have to prepend the string C<CGI::Test::Form::>
+in front of them to get the real type.
+
+ Expanded List List Reference Item Polymorphic Type
+ ------------- -------------- ----------------------
+ button_list buttons Widget::Button
+ checkbox_list checkboxes Widget::Box::Check
+ hidden_list hidden Widget::Hidden
+ input_list inputs Widget::Input
+ menu_list menus Widget::Menu
+ radio_list radios Widget::Box::Radio
+ submit_list submits Widget::Button::Submit
+ widget_list widgets Widget
+
+For instance:
+
+ my @widgets = @{$form->widgets}; # heavy style
+ my @widgets = $form->widget_list; # light style
+
+A given widget may appear in several lists, i.e.the above do not form a
+partition over the widget set. For instance, a submit button would appear
+in the C<widget_list> (which lists I<all> widgets), in the C<button_list>
+and in the C<submit_list>.
+
+=head2 Name Querying Interface
+
+Those routine take a name or a list of names, and return the widgets whose
+parameter name is B<exactly> the given name (string comparison). You may
+query all widgets, or a particular class, like all buttons, or all input
+fields.
+
+There are two groups of routines:
+
+=over 4
+
+=item *
+
+One group allows for multiple name queries, and returns a list of widgets,
+one entry for each listed name. Some widgets like radio buttons may have
+multiple instances bearing the same name, and in that case only one is
+returned. When querying for one name, you are allowed to use scalar context:
+
+ my @hidden = $form->hidden_by_name("foo", "bar");
+ my ($context) = $form->hidden_by_name("context");
+ my $context = $form->hidden_by_name("context");
+
+When no widget (of that particular type) bearing the requested name is found,
+C<undef> is returned for that particular slot, so don't blindly make method
+calls on each returned value.
+
+We shall call that group of query routines the B<by-name> group.
+
+=item *
+
+The other group allows for a single name query, but returns a list of all
+the widgets (of some particular type when not querying the whole widget list)
+bearing that name.
+
+ my @hidden = $form->hidden_named("foo");
+
+Don't assume that only radios and checkboxes can have multiple instances
+bearing the same name.
+
+We shall call that group of query routines the B<all-named> group.
+
+=back
+
+The available routines are listed in the table below. Note that I<by-name>
+queries are singular, because there is at most one returned widget per name
+asked, whereas I<all-named> queries are plural, where possible.
+
+The I<Item Polymorphic Type> column refers to the polymorphic dynamic
+type of items held within the list: each defined item is guaranteed to at
+least be of that type, but can be a descendant. Types are listed in the
+abridged form, and you have to prepend the string C<CGI::Test::Form::>
+in front of them to get the real type.
+
+ By-Name Queries All-Named Queries Item Polymorphic Type
+ ---------------- ----------------- ----------------------
+ button_by_name buttons_named Widget::Button
+ checkbox_by_name checkboxes_named Widget::Box::Check
+ hidden_by_name hidden_named Widget::Hidden
+ input_by_name inputs_named Widget::Input
+ menu_by_name menus_named Widget::Menu
+ radio_by_name radios_named Widget::Box::Radio
+ submit_by_name submits_named Widget::Button::Submit
+ widget_by_name widgets_named Widget
+
+=head2 Match Querying Interface
+
+This is a general interface, which invokes a matching callback on each
+widget of a particular category. The signature of the matching routines is:
+
+ my @matching = $form->widgets_matching(sub {code}, $arg);
+
+and the callback is invoked as:
+
+ callback($widget, $arg);
+
+A widget is kept if, and only if, the callback returns true. Be sure to
+write your callback so that is only uses calls that apply to the particular
+widget. When you know you're matching on menu widgets, you can call
+menu-specific features, but should you use that same callback for buttons,
+you would get a runtime error.
+
+Each matching routine returns a list of matching widgets. Using the $arg
+parameter is optional, and should be avoided unless you have no other choice,
+so as to be as stateless as possible.
+
+The following table lists the available matching routines, along with the
+polymorphic widget type to be expected in the callback. As usual, you must
+prepend the string C<CGI::Test::Form::> to get the real type.
+
+ Matching Routine Item Polymorphic Type
+ ------------------- ---------------------
+ buttons_matching Widget::Button
+ checkboxes_matching Widget::Box::Check
+ hidden_matching Widget::Hidden
+ inputs_matching Widget::Input
+ menus_matching Widget::Menu
+ radios_matching Widget::Box::Radio
+ submits_matching Widget::Button::Submit
+ widgets_matching Widget
+
+For instance:
+
+ my @menus = $form->widgets_matching(sub { $_[0]->is_menu });
+ my @color = $form->widgets_matching(
+ sub { $_[0]->is_menu && $_[0]->name eq "color" }
+ );
+
+is an inefficient way of saying:
+
+ my @menus = $form->menu_list;
+ my @color = $form->menus_matching(sub { $_[0]->name eq "color" });
+
+and the latter can further be rewritten as:
+
+ my @color = $form->menus_named("color");
+
+=head2 Form Interface
+
+This provides an interface to get at the attributes of the <FORM> tag.
+For instance:
+
+ my $enctype = $form->enctype;
+
+to get at the encoding type of that particular form.
+The following attributes are available:
+
+ accept
+ accept_charset
+ action
+ enctype
+ method
+ name
+
+as defined by HTML 4.0.
+
+=head2 Group Querying Interface
+
+There are two kinds of widgets that are architecturally groupped, meaning
+more that one instance of that widget can bear the same name: radio buttons
+and checkboxes (although you may have a single standalone checkbox).
+
+All radio buttons and checkboxes defined in a form are automatically
+inserted into a group of their own, which is an instance of the
+C<CGI::Test::Form::Group> class. This class contains all the defined
+groups for a particular kind. The routines:
+
+ checkbox_groups
+ radio_groups
+
+give you access to the C<CGI::Test::Form::Group> container. Both routines
+may return C<undef> when there is no checkbox or radio button in the form.
+See L<CGI::Test::Form::Group> for its querying interface.
+
+=head2 Memory Cleanup
+
+You B<must> call the I<delete> method to break the circular references
+if you wish to dispose of the object.
+
+=head2 Internal Interface
+
+The following routines are available internally:
+
+=over 4
+
+=item reset
+
+Reset the form state, restoring all the controls to the value they
+had upon entry.
+
+=item submit
+
+Submit the form, returning a C<CGI::Test::Page> reply.
+
+=back
+
+=head1 BUGS
+
+There are documentation bugs, problably, and implementation bugs, improbably.
+
+=head1 WEBSITE
+
+You can find information about CGI::Test and other related modules at:
+
+ http://cgi-test.sourceforge.net
+
+=head1 PUBLIC CVS SERVER
+
+CGI::Test now has a publicly accessible CVS server provided by
+SourceForge <http://www.sourceforge.net>. You can access it by going to:
+
+ http://sourceforge.net/cvs/?group_id=89570
+
+=head1 AUTHOR
+
+The original author is Raphael Manfredi F<E<lt>Raphael_Manfredi at pobox.comE<gt>>.
+
+Send bug reports, hints, tips, suggestions to Steven Hilton at <mshiltonj at mshiltonj.com>
+
+=head1 SEE ALSO
+
+CGI::Test(3), CGI::Test::Form::Widget(3), CGI::Test::Form::Group(3),
+CGI::Test::Page(3), HTML::Element(3).
+
+=cut
+
diff --git a/lib/CGI/Test/Form/Group.pm b/lib/CGI/Test/Form/Group.pm
new file mode 100644
index 0000000..56b0229
--- /dev/null
+++ b/lib/CGI/Test/Form/Group.pm
@@ -0,0 +1,229 @@
+package CGI::Test::Form::Group;
+use strict;
+################################################################
+# $Id: Group.pm 411 2011-09-26 11:19:30Z nohuhu at nohuhu.org $
+# $Name: cgi-test_0-104_t1 $
+################################################################
+# Copyright (c) 2001, Raphael Manfredi
+#
+# You may redistribute only under the terms of the Artistic License,
+# as specified in the README file that comes with the distribution.
+
+#
+# This class records names of grouped objects (radio buttons, checkboxes),
+# and which buttons belong to some named group.
+#
+
+use Log::Agent;
+
+#
+# ->new
+#
+# Creation routine
+#
+# From a listref of box widgets, build a hash table indexed by group name
+# and listing all the buttons belonging to the named group. Each box is
+# also made aware of this object.
+#
+sub new
+{
+ my $this = bless {}, shift; # The object is the hash table we use
+ my ($rlist) = @_;
+
+ #
+ # Create map: "group name" => [list of buttons in group]
+ #
+
+ foreach my $b (@$rlist)
+ {
+ my $gname = $b->name;
+ $this->{$gname} = [] unless exists $this->{$gname};
+ push @{$this->{$gname}}, $b;
+ $b->set_group($this);
+ }
+
+ $this->_validate_radios() if $rlist->[ 0 ]->is_radio();
+
+ return $this;
+}
+
+#
+# Attribute access
+#
+
+sub names
+{
+ my $this = shift;
+ return keys %{$this};
+}
+
+#
+# ->widgets_in
+#
+# Returns list of widgets held within named group, empty if none.
+#
+sub widgets_in
+{
+ my $this = shift;
+ my ($gname) = @_;
+
+ my $list = $this->{$gname} || [];
+ return @$list;
+}
+
+#
+# ->widget_count
+#
+# Returns amount of widgets held within named group, 0 if none.
+#
+sub widget_count
+{
+ my $this = shift;
+ my ($gname) = @_;
+
+ my $list = $this->{$gname};
+ return ref $list ? scalar(@$list) : 0;
+}
+
+#
+# ->is_groupname
+#
+# Check whether name is that of a known widget group.
+#
+sub is_groupname
+{
+ my $this = shift;
+ my ($gname) = @_;
+
+ return exists $this->{$gname};
+}
+
+#
+# ->_validate_radios
+#
+# When groupping radio buttons, make sure there is at least one such
+# button selected, otherwise mark the first as selected. Also ensure
+# exactly one radio is selected, or unselect all extra.
+#
+sub _validate_radios
+{
+ my $this = shift;
+
+ foreach my $gname ($this->names)
+ {
+ my @checked = grep {$_->is_checked} $this->widgets_in($gname);
+ my $checked = @checked;
+
+ if ($checked > 1)
+ {
+ my $first = shift @checked;
+
+ #
+ # NB: we're not calling uncheck() nor set_is_checked() to fix
+ # incorrectly configured radio buttons, since it is normally an
+ # invalid operation. We're resettting the attribute directly.
+ #
+
+ logwarn
+ "found %d checked %ss for '%s', keeping first (tag \"%s\")",
+ $checked, $first->gui_type, $gname, ($first->value || "");
+
+ foreach my $b (@checked)
+ {
+ $b->{is_checked} = 0; # Direct access
+ }
+ }
+ elsif ($checked == 0)
+ {
+ my $first = $this->{$gname}->[ 0 ];
+ logwarn "no checked %ss for '%s', checking first (tag \"%s\")",
+ $first->gui_type, $gname, ($first->value || "");
+ $first->{is_checked} = 1; # Direct access
+ }
+
+ }
+
+ return;
+}
+
+1;
+
+=head1 NAME
+
+CGI::Test::Form::Group - Records groups of box-type widgets
+
+=head1 SYNOPSIS
+
+ # $form is a CGI::Test::Form object
+
+ use CGI::Test;
+
+ my $rgroup = $form->radio_groups;
+ ok 1, defined $rgroup;
+
+ my @title = $rgroup->widgets_in("title");
+ my ($mister) = grep { $_->value eq "Mr" } @title;
+ ok 2, $mister->is_checked;
+
+=head1 DESCRIPTION
+
+This class is a container for box-type widgets, i.e. radio buttons and
+checkboxes, which may be groupped by name.
+
+It can be queried to easily retrieve widgets belonging to a group, or to
+get all the group names.
+
+It is also used internally by C<CGI::Test> to keep track of associated
+radio buttons, so that checking one automatically unchecks the others in the
+same group.
+
+=head1 INTERFACE
+
+The following features are available:
+
+=over 4
+
+=item C<is_groupname> I<name>
+
+Checks whether I<name> is the name of a group.
+
+=item C<names>
+
+Returns a list of group names, in random order.
+
+=item C<widget_count> I<groupname>
+
+Returns amount of widgets held in I<groupname>, 0 if none.
+
+=item C<widgets_in> I<groupname>
+
+Returns a list of all the widgets in the given I<groupname>. If the
+name is not a valid group name, the list will be empty.
+
+=back
+
+=head1 WEBSITE
+
+You can find information about CGI::Test and other related modules at:
+
+ http://cgi-test.sourceforge.net
+
+=head1 PUBLIC CVS SERVER
+
+CGI::Test now has a publicly accessible CVS server provided by
+SourceForge (www.sourceforge.net). You can access it by going to:
+
+ http://sourceforge.net/cvs/?group_id=89570
+
+=head1 AUTHORS
+
+The original author is Raphael Manfredi F<E<lt>Raphael_Manfredi at pobox.comE<gt>>.
+
+Send bug reports, hints, tips, suggestions to Steven Hilton at <mshiltonj at mshiltonj.com>
+
+=head1 SEE ALSO
+
+CGI::Test::Form(3), CGI::Test::Form::Widget::Box(3).
+
+=cut
+
diff --git a/lib/CGI/Test/Form/Widget.pm b/lib/CGI/Test/Form/Widget.pm
new file mode 100644
index 0000000..1454365
--- /dev/null
+++ b/lib/CGI/Test/Form/Widget.pm
@@ -0,0 +1,592 @@
+package CGI::Test::Form::Widget;
+use strict;
+################################################################
+# $Id: Widget.pm 411 2011-09-26 11:19:30Z nohuhu at nohuhu.org $
+# $Name: cgi-test_0-104_t1 $
+################################################################
+#
+# Copyright (c) 2001, Raphael Manfredi
+#
+# You may redistribute only under the terms of the Artistic License,
+# as specified in the README file that comes with the distribution.
+#
+
+#
+# This class models a CGI form widget (button, text field, etc...).
+# It belongs to one form, identified by its `form' attribute , a ref
+# to a CGI::Test::Form object.
+#
+
+use Log::Agent;
+
+############################################################
+#
+# ->new
+#
+# Creation routine -- common to ALL widgets but <BUTTON> elements.
+#
+############################################################
+sub new
+{
+ my $this = bless {}, shift;
+ my ($node, $form) = @_;
+
+ #
+ # Can't create a CGI::Test::Form::Widget object, only heirs.
+ #
+
+ logconfess "%s is a deferred class", __PACKAGE__
+ if ref $this eq __PACKAGE__;
+
+ $this->_common_init($form);
+
+ #
+ # We don't keep any reference on the node.
+ # Analyze the HTML tree to determine some parameters.
+ #
+
+ $this->_init($node); # Defined in each heir
+
+ return $this;
+}
+
+############################################################
+#
+# ->_common_init
+#
+# Common attribute initialization for all widgets
+#
+############################################################
+sub _common_init
+{
+ my $this = shift;
+ my ($form) = @_;
+
+ $this->{form} = $form; # <FORM> containing this widget
+ $this->{name} = ""; # Always possible to query, must be defined
+ $this->{value} = ""; # Idem
+
+ return;
+}
+
+############################################################
+#
+# ->_init
+#
+# Per-widget initialization routine.
+# Parse HTML node to determine our specific parameters.
+#
+############################################################
+sub _init
+{
+ my $this = shift;
+ my ($node) = @_;
+ logconfess "deferred";
+}
+
+############################################################
+#
+# ->_parse_attr
+#
+# Each heir locally defines a hash table mapping HTML node attributes to
+# class attributes. This structure is used to parse the node and setup
+# the object accordingly.
+#
+############################################################
+sub _parse_attr
+{
+ my $this = shift;
+ my ($node, $attr) = @_;
+
+ while (my ($html_attr, $obj_attr) = each %$attr)
+ {
+ my $val = $node->attr($html_attr);
+ $this->{$obj_attr} = $val if defined $val;
+ }
+
+ return;
+}
+
+#
+# Attribute access
+#
+
+sub form
+{
+ my $this = shift;
+ return $this->{form};
+}
+
+#
+# Access to attributes that must be setup by heirs within _init()
+# Those are common attributes for the whole Widget hierarchy.
+#
+# The `value' attribute may not have any meaning (e.g. for an image button)
+# but it is always possible to query it.
+#
+
+sub name
+{
+ my $this = shift;
+ return $this->{name};
+}
+
+sub value
+{
+ my $this = shift;
+ return $this->{value};
+}
+
+sub old_value
+{
+ my $this = shift;
+ return $this->{old_value};
+}
+
+sub is_disabled
+{
+ my $this = shift;
+ return $this->{is_disabled};
+} # "grayed out"
+
+#
+# Global widget predicates
+#
+
+sub is_read_only
+{
+ 0
+} # Can change "value"
+
+#
+# High-level classification predicates
+#
+
+############################################################
+sub is_button
+{
+ return 0;
+}
+############################################################
+sub is_input
+{
+ return 0;
+}
+############################################################
+sub is_menu
+{
+ return 0;
+}
+############################################################
+sub is_box
+{
+ return 0;
+}
+############################################################
+sub is_hidden
+{
+ return 0;
+}
+############################################################
+sub is_file
+{
+ return 0;
+}
+
+sub gui_type
+{
+ logconfess "deferred";
+}
+
+############################################################
+#
+# ->is_mutable
+#
+# Check whether it is possible to change widget's value from a user interface.
+# Optionally warn if widget's value cannot be changed.
+#
+############################################################
+sub is_mutable
+{
+ my $this = shift;
+ my ($warn) = @_;
+
+ if ($this->is_disabled)
+ {
+ logcarp 'cannot change value of disabled %s "%s"', $this->gui_type,
+ $this->name
+ if $warn;
+ return 0;
+ }
+
+ if ($this->is_read_only)
+ {
+ logcarp 'cannot change value of read-only %s "%s"', $this->gui_type,
+ $this->name
+ if $warn;
+ return 0;
+ }
+
+ return 1;
+}
+
+############################################################
+#
+# ->set_value
+#
+# Change value.
+# Only allowd to proceed if mutable.
+#
+############################################################
+sub set_value
+{
+ my $this = shift;
+ my ($value) = @_;
+
+ return unless $this->is_mutable(1); # Cannot change value
+ return if $value eq $this->{value}; # No change
+
+ #
+ # To ease redefinition, let this call _frozen_set_value, which is
+ # not redefinable and performs the common operation.
+ #
+
+ $this->_frozen_set_value($value);
+ return;
+}
+
+############################################################
+#
+# ->_frozen_set_value -- frozen
+#
+# Change value.
+#
+############################################################
+sub _frozen_set_value
+{
+ my $this = shift;
+ my ($value) = @_;
+
+ #
+ # The first time we do this, save current value in `old_value'.
+ #
+
+ $this->{old_value} = $this->{value} unless exists $this->{old_value};
+ $this->{value} = $value;
+
+ return;
+}
+
+############################################################
+#
+# ->reset_state
+#
+# Called when a "Reset" button is pressed to restore the value the widget
+# had upon form entry.
+#
+############################################################
+sub reset_state
+{
+ my $this = shift;
+
+ #
+ # If there is `old_value' attribute yet, then the value is already OK.
+ #
+
+ return unless exists $this->{old_value};
+
+ #
+ # Restore value from old_value, and delete this attribute to signal that
+ # the value is now back to its original setting.
+ #
+
+ $this->{value} = delete $this->{old_value};
+ return;
+}
+
+############################################################
+#
+# ->is_submitable
+#
+# Check whether widget is "successful" (that's such an ugly name), in other
+# words, whether its name/value pair should be part of submittted form data.
+#
+# A "successful" widget must not be disabled.
+# Heirs should define the _is_successful internal routine.
+#
+# Returns true if submitable.
+#
+############################################################
+sub is_submitable
+{
+ my $this = shift;
+
+ return 0 if $this->is_disabled;
+ return $this->_is_successful;
+}
+
+############################################################
+#
+# ->_is_successful
+#
+# Is the enabled widget "successful", according to W3C's specs?
+#
+############################################################
+sub _is_successful
+{
+ logconfess "deferred";
+}
+
+############################################################
+#
+# ->submit_tuples
+#
+# Returns list of (name => value) tuples that should be part of the
+# submitted form data. There may be more than one tuple returned for
+# scrollable lists only: each checkbox is a widget, and therefore can
+# return only one tuple.
+#
+############################################################
+sub submit_tuples
+{
+ my $this = shift;
+
+ return ($this->name(), $this->value());
+}
+
+############################################################
+#
+# ->delete
+#
+# Done with this widget, cleanup by breaking circular refs.
+#
+############################################################
+sub delete
+{
+ my $this = shift;
+ $this->{form} = undef;
+ return;
+}
+
+1;
+
+=head1 NAME
+
+CGI::Test::Form::Widget - Ancestor of all form widget classes
+
+=head1 SYNOPSIS
+
+ # Deferred class, only heirs can be created
+
+=head1 DESCRIPTION
+
+The C<CGI::Test::Form::Widget> class is deferred.
+It is an abstract representation of a <FORM> widget, i.e. a graphical control
+element like a popup menu or a submit button.
+
+Here is an outline of the class hierarchy tree, with the leading
+C<CGI::Test::Form::> string stripped for readability, and a trailing C<*>
+indicating deferred classes:
+
+ Widget*
+ . Widget::Box*
+ . . Widget::Box::Check
+ . . Widget::Box::Radio
+ . Widget::Button*
+ . . Widget::Button::Plain
+ . . Widget::Button::Submit
+ . . Widget::Button::Image
+ . . Widget::Button::Reset
+ . Widget::Hidden
+ . Widget::Input*
+ . . Widget::Input::Text_Area
+ . . Widget::Input::Text_Field
+ . . Widget::Input::File
+ . . Widget::Input::Password
+ . Widget::Menu*
+ . . Widget::Menu::List
+ . . Widget::Menu::Popup
+
+Only leaf nodes are concrete classes, and there is one such class for each
+known control type that can appear in the <FORM> element.
+
+Those classes are constructed as needed by C<CGI::Test>. They are the
+programmatic artefacts which can be used to manipulate those graphical
+elements, on which you would otherwise click and fill within a browser.
+
+=head1 INTERFACE
+
+This is the interface defined at the C<CGI::Test::Form::Widget> level,
+and which is therefore common to all classes in the hierarchy.
+Each subclass may naturally add further specific features.
+
+It is very important to stick to using common widget features when
+writing a matching callback for the C<widgets_matching> routine in
+C<CGI::Test::Form>, or you run the risk of getting a runtime error
+since Perl is not statically typed.
+
+=head2 Attributes
+
+=over 4
+
+=item C<form>
+
+The C<CGI::Test::Form> to which this widget belongs.
+
+=item C<gui_type>
+
+A human readable description of the widget, as it would appear on a GUI,
+like "popup menu" or "radio button". Meant for logging only, not to
+determine the object type.
+
+=item C<name>
+
+The CGI parameter name.
+
+=item C<value>
+
+The current CGI parameter value.
+
+=back
+
+=head2 Attribute Setting
+
+=over 4
+
+=item C<set_value> I<new_value>
+
+Change the C<value> attribute to I<new_value>.
+The widget must not be C<is_read_only> nor C<is_disabled>.
+
+=back
+
+=head2 Widget Modification Predicates
+
+Those predicates may be used to determine whether it is possible to
+change the value of a widget from the user interface.
+
+=over 4
+
+=item C<is_disabled>
+
+When I<true>, the widget is disabled, i.e. not available for editing.
+It would typically appear as being I<grayed out> within a browser.
+
+This predicate is not architecturally defined: a widget may or may not
+be marked as disabled in HTML via a suitable attribute.
+
+=item C<is_mutable> [I<warn_flag>]
+
+Test whether widget can change value. Returns I<false> when
+the widget C<is_read_only> or C<is_disabled>.
+
+When the optional I<warn_flag> is true, C<logcarp> is called
+to emit a warning from the perspective of the caller.
+
+=item C<is_read_only>
+
+When I<false>, the C<value> parameter can be changed with C<set_value>.
+This is an architecturally defined predicate, i.e. its value depends only
+on the widget type.
+
+=back
+
+=head2 Widget Classification Predicates
+
+Those predicates may be used to determine the overall widget type.
+The classification is rather high level and only helps determining
+the kind of calls that may be used on a given widget object.
+
+=over 4
+
+=item C<is_box>
+
+Returns true for radio buttons and checkboxes.
+
+=item C<is_button>
+
+Returns true for all buttons that are not boxes.
+
+=item C<is_file>
+
+Returns true for a I<file upload> widget, which allows file selection.
+
+=item C<is_hidden>
+
+Returns true for hidden fields, which have no graphical representation
+by definition.
+
+=item C<is_input>
+
+Returns true for all input fields, where the user can type text.
+
+=item C<is_menu>
+
+Returns true for popup menus and scrolling lists.
+
+=back
+
+=head2 Miscellaneous Features
+
+Although documented, those features are more targetted for internal use...
+
+=over 4
+
+=item C<delete>
+
+Breaks circular references.
+This is normally done by the C<delete> routine on the enclosing form.
+
+=item C<is_submitable>
+
+Returns I<true> when the name/value tupple of this widget need to be
+part of the submitted parameters. The rules for determining the submitable
+nature of a widget vary depending on the widget type.
+
+=item C<reset_state>
+
+Reset the widget's C<value> to the one it had initially. Invoked internally
+when a reset button is pressed.
+
+=item C<submit_tuples>
+
+For submitable widgets, return the list of (name => value) tupples that
+should be part of the submitted data. Widgets like scrolling list may return
+more than one tuple.
+
+This routine is invoked to compute the parameter list that must be sent back
+when pressing a submit button.
+
+=back
+
+=head1 WEBSITE
+
+You can find information about CGI::Test and other related modules at:
+
+ http://cgi-test.sourceforge.net
+
+=head1 PUBLIC CVS SERVER
+
+CGI::Test now has a publicly accessible CVS server provided by
+SourceForge (www.sourceforge.net). You can access it by going to:
+
+ http://sourceforge.net/cvs/?group_id=89570
+
+=head1 AUTHORS
+
+The original author is Raphael Manfredi F<E<lt>Raphael_Manfredi at pobox.comE<gt>>.
+
+Send bug reports, hints, tips, suggestions to Steven Hilton at <mshiltonj at mshiltonj.com>
+
+=head1 SEE ALSO
+
+CGI::Test::Form(3),
+CGI::Test::Form::Widget::Box(3),
+CGI::Test::Form::Widget::Button(3),
+CGI::Test::Form::Widget::Input(3),
+CGI::Test::Form::Widget::Hidden(3),
+CGI::Test::Form::Widget::Menu(3),
+Log::Agent(3).
+
+=cut
+
diff --git a/lib/CGI/Test/Form/Widget/Box.pm b/lib/CGI/Test/Form/Widget/Box.pm
new file mode 100644
index 0000000..782088c
--- /dev/null
+++ b/lib/CGI/Test/Form/Widget/Box.pm
@@ -0,0 +1,433 @@
+package CGI::Test::Form::Widget::Box;
+use strict;
+##################################################################
+# $Id: Box.pm 411 2011-09-26 11:19:30Z nohuhu at nohuhu.org $
+# $Name: cgi-test_0-104_t1 $
+##################################################################
+# Copyright (c) 2001, Raphael Manfredi
+#
+# You may redistribute only under the terms of the Artistic License,
+# as specified in the README file that comes with the distribution.
+#
+
+#
+# This class models a FORM box, either a radio button or a checkbox.
+#
+
+use CGI::Test::Form::Widget;
+use base qw(CGI::Test::Form::Widget);
+
+use Log::Agent;
+
+############################################################
+#
+# %attr
+#
+# Defines which HTML attributes we should look at within the node, and how
+# to translate that into class attributes.
+#
+############################################################
+
+my %attr = ('name' => 'name',
+ 'value' => 'value',
+ 'checked' => 'is_checked',
+ 'disabled' => 'is_disabled',
+ );
+
+############################################################
+#
+# ->_init
+#
+# Per-widget initialization routine.
+# Parse HTML node to determine our specific parameters.
+#
+############################################################
+sub _init
+{
+ my $this = shift;
+ my ($node) = shift;
+ $this->_parse_attr($node, \%attr);
+ return;
+}
+
+############################################################
+#
+# ->_is_successful -- defined
+#
+# Is the enabled widget "successful", according to W3C's specs?
+# Any ticked checkbox and radio button is.
+#
+############################################################
+sub _is_successful
+{
+ my $this = shift;
+ return $this->is_checked();
+}
+
+############################################################
+#
+# ->group_list
+#
+# Returns list of widgets belonging to the same group as we do.
+#
+############################################################
+sub group_list
+{
+ my $this = shift;
+
+ return $this->group->widgets_in($this->name);
+}
+
+#
+# Local attribute access
+#
+
+############################################################
+sub group
+{
+ my $this = shift;
+ return $this->{group};
+}
+############################################################
+sub is_checked
+{
+ my $this = shift;
+ return $this->{is_checked};
+}
+############################################################
+sub old_is_checked
+{
+ my $this = shift;
+ $this->{old_is_checked};
+}
+
+#
+# Checking shortcuts
+#
+
+############################################################
+sub check
+{
+ my $this = shift;
+ $this->set_is_checked(1);
+}
+############################################################
+sub uncheck
+{
+ my $this = shift;
+ $this->set_is_checked(0);
+}
+############################################################
+sub check_tagged
+{
+ my $this = shift;
+ my $tag = shift;
+ $this->_mark_by_tag($tag, 1);
+}
+############################################################
+sub uncheck_tagged
+{
+ my $this = shift;
+ my $tag = shift;
+ $this->_mark_by_tag($tag, 0);
+}
+
+#
+# Attribute setting
+#
+
+############################################################
+sub set_group
+{
+ my $this = shift;
+ my $group = shift;
+ $this->{group} = $group;
+}
+
+############################################################
+#
+# ->set_is_checked
+#
+# Select or unselect box.
+#
+############################################################
+sub set_is_checked
+{
+ my $this = shift;
+ my ($checked) = @_;
+
+ return if !$checked == !$this->is_checked(); # No change
+
+ #
+ # To ease redefinition, let this call _frozen_set_is_checked, which is
+ # not redefinable and performs the common operation.
+ #
+
+ $this->_frozen_set_is_checked($checked);
+ return;
+}
+
+############################################################
+#
+# ->reset_state -- redefined
+#
+# Called when a "Reset" button is pressed to restore the value the widget
+# had upon form entry.
+#
+############################################################
+sub reset_state
+{
+ my $this = shift;
+
+ $this->{is_checked} = delete $this->{old_is_checked}
+ if exists $this->{old_is_checked};
+
+ return;
+}
+
+#
+# Global widget predicates
+#
+
+############################################################
+sub is_read_only
+{
+ return 1;
+}
+
+#
+# High-level classification predicates
+#
+
+############################################################
+sub is_box
+{
+ return 1;
+}
+
+#
+# Predicates for the Box hierarchy
+#
+
+############################################################
+sub is_radio
+{
+ logconfess "deferred";
+}
+############################################################
+sub is_standalone
+{
+ my $this = shift;
+ 1 == $this->group->widget_count($this->name());
+}
+
+#
+# ->delete
+#
+# Break circular refs.
+#
+sub delete
+{
+ my $this = shift;
+
+ delete $this->{group};
+ $this->SUPER::delete;
+
+ return;
+}
+
+#
+# ->_frozen_set_is_checked
+#
+# Frozen implementation of set_is_checked().
+#
+sub _frozen_set_is_checked
+{
+ my $this = shift;
+ my ($checked) = @_;
+
+ #
+ # The first time we do this, save current status in `old_is_checked'.
+ #
+
+ $this->{old_is_checked} = $this->{is_checked}
+ unless exists $this->{old_is_checked};
+ $this->{is_checked} = $checked;
+
+ return;
+}
+
+############################################################
+#
+# ->_mark_by_tag
+#
+# Lookup the box in the group whose name is the given tag, and mark it
+# as specified.
+#
+############################################################
+sub _mark_by_tag
+{
+ my $this = shift;
+ my ($tag, $checked) = @_;
+
+ my @boxes = grep {$_->value eq $tag} $this->group_list();
+
+ if (@boxes == 0)
+ {
+ logcarp "no %s within the group '%s' bears the tag \"$tag\"",
+ $this->gui_type(), $this->name();
+ }
+ else
+ {
+ logcarp "found %d %ss within the group '%s' bearing the tag \"$tag\"",
+ scalar(@boxes), $this->gui_type(), $this->name()
+ if @boxes > 1;
+
+ $boxes[ 0 ]->set_is_checked($checked);
+ }
+
+ return;
+}
+
+1;
+
+=head1 NAME
+
+CGI::Test::Form::Widget::Box - Abstract representation of a tickable box
+
+=head1 SYNOPSIS
+
+ # Inherits from CGI::Test::Form::Widget
+
+=head1 DESCRIPTION
+
+This class is the abstract representation of a tickable box, i.e. a radio
+button or a checkbox.
+
+To simulate user checking or un-checking on a box,
+use the C<check()> and C<uncheck()> routines, as described below.
+
+=head1 INTERFACE
+
+The interface is the same as the one described in L<CGI::Test::Form::Widget>,
+with the following additions:
+
+=head2 Attributes
+
+=over 4
+
+=item C<group>
+
+The C<CGI::Test::Form::Group> object which holds all the groups of the same
+widget type.
+
+=item C<group_list>
+
+The list of widgets belonging to the same group as we do.
+
+=item C<is_checked>
+
+True when the box is checked, i.e. marked with a tick.
+
+=back
+
+=head2 Attribute Setting
+
+=over 4
+
+=item C<check>
+
+Check the box, by ticking it.
+
+=item C<check_tagged> I<tag>
+
+This may be called on any box, and it will locate the box whose value
+attribute is I<tag> within the C<group_list>, and then check it.
+
+If the specified I<tag> is not found, the caller will get a warning
+via C<logcarp>.
+
+=item C<uncheck>
+
+Uncheck the box, by removing its ticking mark.
+It is not possible to do this on a radio button: you must I<check> another
+radio button of the same group instead.
+
+=item C<uncheck_tagged> I<tag>
+
+This may be called on any box, and it will locate the box whose value
+attribute is I<tag> within the C<group_list>, and then remove its ticking mark.
+It is not possible to do this on a radio button, as explained in C<uncheck>
+above.
+
+If the specified I<tag> is not found, the caller will get a warning
+via C<logcarp>.
+
+=back
+
+=head2 Widget Classification Predicates
+
+There is an additional predicate to distinguish between a checkbox and
+a radio button:
+
+=over 4
+
+=item C<is_radio>
+
+Returns I<true> for a radio button.
+
+=item C<is_standalone>
+
+Returns I<true> if the box is the sole member of its group.
+
+Normally only useful for checkboxes: a standalone radio button,
+although perfectly legal, would always remain in the checked state, and
+therefore not be especially interesting...
+
+=back
+
+=head2 Miscellaneous Features
+
+Although documented, those features are more targetted for
+internal use...
+
+=over 4
+
+=item C<set_is_checked> I<flag>
+
+Change the checked status. Radio buttons can only be checked, i.e. the
+I<flag> must be true: all other radio buttons in the same group are
+immediately unchecked.
+
+You should use the C<check> and C<uncheck> convenience routines instead
+of calling this feature.
+
+=back
+
+=head1 WEBSITE
+
+You can find information about CGI::Test and other related modules at:
+
+ http://cgi-test.sourceforge.net
+
+=head1 PUBLIC CVS SERVER
+
+CGI::Test now has a publicly accessible CVS server provided by
+SourceForge (www.sourceforge.net). You can access it by going to:
+
+ http://sourceforge.net/cvs/?group_id=89570
+
+=head1 AUTHORS
+
+The original author is Raphael Manfredi F<E<lt>Raphael_Manfredi at pobox.comE<gt>>.
+
+Send bug reports, hints, tips, suggestions to Steven Hilton at <mshiltonj at mshiltonj.com>
+
+=head1 SEE ALSO
+
+CGI::Test::Form::Widget(3),
+CGI::Test::Form::Widget::Box::Radio(3),
+CGI::Test::Form::Widget::Box::Check(3).
+
+=cut
+
diff --git a/lib/CGI/Test/Form/Widget/Box/Check.pm b/lib/CGI/Test/Form/Widget/Box/Check.pm
new file mode 100644
index 0000000..c5c6c99
--- /dev/null
+++ b/lib/CGI/Test/Form/Widget/Box/Check.pm
@@ -0,0 +1,92 @@
+package CGI::Test::Form::Widget::Box::Check;
+use strict;
+##################################################################
+# $Id: Check.pm 411 2011-09-26 11:19:30Z nohuhu at nohuhu.org $
+# $Name: cgi-test_0-104_t1 $
+##################################################################
+#
+# Copyright (c) 2001, Raphael Manfredi
+#
+# You may redistribute only under the terms of the Artistic License,
+# as specified in the README file that comes with the distribution.
+#
+
+#
+# This class models a FORM checkbox button.
+#
+
+use CGI::Test::Form::Widget::Box;
+use base qw(CGI::Test::Form::Widget::Box);
+
+use Log::Agent;
+
+#
+# Attribute access
+#
+
+sub gui_type
+{
+ return "checkbox";
+}
+
+#
+# Defined predicates
+#
+
+sub is_radio
+{
+ return 0;
+}
+
+1;
+
+=head1 NAME
+
+CGI::Test::Form::Widget::Box::Check - A checkbox widget
+
+=head1 SYNOPSIS
+
+ # Inherits from CGI::Test::Form::Widget::Box
+ # $form is a CGI::Test::Form
+
+ use Log::Agent; # logdie below
+
+ my ($agree, $ads) = $form->checkbox_by_name(qw(i_agree ads));
+
+ logdie "expected a standalone checkbox" unless $agree->is_standalone;
+ $agree->check;
+ $ads->uncheck_tagged("spam OK");
+
+=head1 DESCRIPTION
+
+This class represents a checkbox widget, which may be checked or unchecked
+at will by users.
+
+The interface is the same as the one described
+in L<CGI::Test::Form::Widget::Box>.
+
+=head1 WEBSITE
+
+You can find information about CGI::Test and other related modules at:
+
+ http://cgi-test.sourceforge.net
+
+=head1 PUBLIC CVS SERVER
+
+CGI::Test now has a publicly accessible CVS server provided by
+SourceForge (www.sourceforge.net). You can access it by going to:
+
+ http://sourceforge.net/cvs/?group_id=89570
+
+=head1 AUTHORS
+
+The original author is Raphael Manfredi F<E<lt>Raphael_Manfredi at pobox.comE<gt>>.
+
+Send bug reports, hints, tips, suggestions to Steven Hilton at <mshiltonj at mshiltonj.com>
+
+=head1 SEE ALSO
+
+CGI::Test::Form::Widget::Box(3), CGI::Test::Form::Widget::Box::Radio(3).
+
+=cut
+
diff --git a/lib/CGI/Test/Form/Widget/Box/Radio.pm b/lib/CGI/Test/Form/Widget/Box/Radio.pm
new file mode 100644
index 0000000..6422c40
--- /dev/null
+++ b/lib/CGI/Test/Form/Widget/Box/Radio.pm
@@ -0,0 +1,140 @@
+package CGI::Test::Form::Widget::Box::Radio;
+use strict;
+##################################################################
+# $Id: Radio.pm 411 2011-09-26 11:19:30Z nohuhu at nohuhu.org $
+# $Name: cgi-test_0-104_t1 $
+##################################################################
+#
+# Copyright (c) 2001, Raphael Manfredi
+#
+# You may redistribute only under the terms of the Artistic License,
+# as specified in the README file that comes with the distribution.
+#
+
+#
+# This class models a FORM radio button.
+#
+
+use CGI::Test::Form::Widget::Box;
+use base qw(CGI::Test::Form::Widget::Box);
+
+use Log::Agent;
+
+#
+# ->set_is_checked -- redefined
+#
+# Change checked state.
+#
+# A radio button can only be "clicked on", i.e. it is not otherwise
+# un-checkable. Therefore, $checked must always be true. Furthermore,
+# all related radio buttons must be cleared.
+#
+sub set_is_checked
+{
+ my $this = shift;
+ my ($checked) = @_;
+
+ return if !$checked == !$this->is_checked(); # No change
+
+ #
+ # We're checking a radio button that was cleared previously.
+ # All the other radio buttons in the group are going to be cleared.
+ #
+
+ $this->_frozen_set_is_checked($checked);
+ foreach my $radio ($this->group_list)
+ {
+ next if $radio == $this;
+ $radio->_frozen_set_is_checked(0);
+ }
+
+ return;
+}
+
+sub uncheck
+{
+ logcarp "ignoring uncheck on radio button";
+}
+
+sub uncheck_tagged
+{
+ logcarp "ignoring uncheck_tagged on radio button";
+}
+
+#
+# Attribute access
+#
+
+sub gui_type
+{
+ return "radio button";
+}
+
+#
+# Defined predicates
+#
+
+sub is_radio
+{
+ return 1;
+}
+
+1;
+
+=head1 NAME
+
+CGI::Test::Form::Widget::Box::Radio - A radio button widget
+
+=head1 SYNOPSIS
+
+ # Inherits from CGI::Test::Form::Widget::Box
+ # $form is a CGI::Test::Form
+
+ my @title = $form->radios_named("title");
+ my ($mister) = grep { $_->value eq "Mr" } @title;
+ $mister->check if defined $mister;
+
+ my $title = $form->radio_by_name("title");
+ $title->check_tagged("Mr");
+
+=head1 DESCRIPTION
+
+This class represents a radio button widget, which may be checked at
+will by users. All other radio buttons of the same group are automatically
+unchecked.
+
+If no radio button is checked initially, C<CGI::Test> arbitrarily chooses
+the first one listed and warns you via C<logwarn>.
+
+The interface is the same as the one described
+in L<CGI::Test::Form::Widget::Box>.
+
+Any attempt to C<uncheck> a radio button will be ignored, and a warning
+emitted via C<logcarp>, to help you identify the caller.
+
+=head1 WEBSITE
+
+You can find information about CGI::Test and other related modules at:
+
+ http://cgi-test.sourceforge.net
+
+=head1 PUBLIC CVS SERVER
+
+CGI::Test now has a publicly accessible CVS server provided by
+SourceForge (www.sourceforge.net). You can access it by going to:
+
+ http://sourceforge.net/cvs/?group_id=89570
+
+=head1 AUTHORS
+
+The original author is Raphael Manfredi F<E<lt>Raphael_Manfredi at pobox.comE<gt>>.
+
+Send bug reports, hints, tips, suggestions to Steven Hilton at <mshiltonj at mshiltonj.com>
+
+=head1 SEE ALSO
+
+CGI::Test::Form::Widget::Box(3), CGI::Test::Form::Widget::Box::Check(3),
+Log::Agent(3).
+
+=cut
+
diff --git a/lib/CGI/Test/Form/Widget/Button.pm b/lib/CGI/Test/Form/Widget/Button.pm
new file mode 100644
index 0000000..7c34435
--- /dev/null
+++ b/lib/CGI/Test/Form/Widget/Button.pm
@@ -0,0 +1,363 @@
+package CGI::Test::Form::Widget::Button;
+use strict;
+##################################################################
+# $Id: Button.pm 411 2011-09-26 11:19:30Z nohuhu at nohuhu.org $
+# $Name: cgi-test_0-104_t1 $
+##################################################################
+#
+# Copyright (c) 2001, Raphael Manfredi
+#
+# You may redistribute only under the terms of the Artistic License,
+# as specified in the README file that comes with the distribution.
+#
+#
+# This class models a FORM button.
+#
+
+require CGI::Test::Form::Widget;
+use base qw(CGI::Test::Form::Widget);
+
+use Log::Agent;
+
+############################################################
+#
+# ->new
+#
+# Creation routine for <BUTTON> elements.
+#
+############################################################
+sub new
+{
+ my $this = bless {}, shift;
+ my ($node, $form) = @_;
+
+ #
+ # Can't create a CGI::Test::Form::Widget::Button object, only heirs.
+ #
+
+ logconfess "%s is a deferred class", __PACKAGE__
+ if ref $this eq __PACKAGE__;
+
+ $this->_common_init($form);
+
+ #
+ # We don't keep any reference on the node.
+ # Analyze the HTML tree to determine some parameters.
+ #
+
+ $this->_init_button($node);
+
+ return $this;
+}
+
+############################################################
+#
+# %attr
+# %attr_button
+#
+# Defines which HTML attributes we should look at within the node, and how
+# to translate that into class attributes. The %attr_button is specific
+# to the <BUTTON> tags.
+#
+############################################################
+
+my %attr = ('name' => 'name',
+ 'value' => 'value',
+ 'disabled' => 'is_disabled',
+ );
+
+my %attr_button = (%attr,);
+
+############################################################
+#
+# ->_init
+#
+# Per-widget initialization routine, for <INPUT>.
+# Parse HTML node to determine our specific parameters.
+#
+############################################################
+sub _init
+{
+ my $this = shift;
+ my ($node) = shift;
+ $this->_parse_attr($node, \%attr);
+ $this->{is_enhanced} = 0;
+ $this->{is_pressed} = 0;
+ return;
+}
+
+############################################################
+#
+# ->_init_button
+#
+# Per-widget initialization routine, for <BUTTON>.
+# Parse HTML node to determine our specific parameters.
+#
+############################################################
+sub _init_button
+{
+ my $this = shift;
+ my ($node) = shift;
+ $this->_parse_attr($node, \%attr_button);
+ $this->{is_enhanced} = 1;
+ $this->{is_pressed} = 0;
+ return;
+}
+
+############################################################
+#
+# ->_is_successful -- defined
+#
+# Is the enabled widget "successful", according to W3C's specs?
+# Any pressed button is.
+#
+############################################################
+sub _is_successful
+{
+ my $this = shift;
+ return $this->is_pressed();
+}
+
+#
+# Attribute access
+#
+
+############################################################
+sub is_enhanced
+{
+ my $this = shift;
+ return $this->{is_enhanced};
+} # True for <BUTTON> elements
+############################################################
+sub is_pressed
+{
+ my $this = shift;
+ return $this->{is_pressed};
+}
+
+############################################################
+#
+# ->press
+#
+# Press button.
+#
+# Has immediate effect:
+# * If it's a reset button, all widgets are reset to their initial state.
+# * If it's a submit button, a GET/POST request is issued.
+# * By default, a warning is issued that the action is ignored.
+#
+# Returns undef if no submit is done, a new CGI::Test::Page otherwise.
+#
+############################################################
+sub press
+{
+ my $this = shift;
+
+ #
+ # Default action: do nothing
+ # Routine is redefined in heirs when processing required.
+ #
+
+ logwarn 'ignoring button press: name="%s", value="%s"', $this->name(),
+ $this->value();
+
+ return undef;
+}
+
+############################################################
+#
+# ->set_is_pressed
+#
+# Press or unpress button.
+#
+############################################################
+sub set_is_pressed
+{
+ my $this = shift;
+ my ($pressed) = @_;
+ $this->{is_pressed} = $pressed;
+ return;
+}
+
+############################################################
+#
+# ->reset_state -- redefined
+#
+# Called when a "Reset" button is pressed to restore the value the widget
+# had upon form entry.
+#
+############################################################
+sub reset_state
+{
+ my $this = shift;
+ $this->{is_pressed} = 0;
+ return;
+}
+
+############################################################
+#
+#
+# Global widget predicates
+#
+############################################################
+sub is_read_only
+{
+ return 1;
+}
+
+#
+# Button predicates
+#
+
+############################################################
+sub is_reset
+{
+ return 0;
+}
+############################################################
+sub is_submit
+{
+ return 0;
+}
+############################################################
+sub is_plain
+{
+ return 0;
+}
+
+#
+# High-level classification predicates
+#
+
+############################################################
+sub is_button
+{
+ return 1;
+}
+
+1;
+
+=head1 NAME
+
+CGI::Test::Form::Widget::Button - Abstract representation of a button
+
+=head1 SYNOPSIS
+
+ # Inherits from CGI::Test::Form::Widget
+
+=head1 DESCRIPTION
+
+This class is the abstract representation of a button, i.e. a submit
+button, an image button, a reset button or a plain button.
+
+Pressing a button is achieved by calling C<press()> on it, which returns a
+new page, as a C<CGI::Test::Page> object, or C<undef> if pressing had
+no round-trip effect.
+
+=head1 INTERFACE
+
+The interface is the same as the one described in L<CGI::Test::Form::Widget>,
+with the following additions:
+
+=head2 Attributes
+
+=over 4
+
+=item C<is_pressed>
+
+True when the button is pressed.
+
+=back
+
+=head2 Attribute Setting
+
+=over 4
+
+=item C<press>
+
+Press the button, setting C<is_pressed> to true.
+
+If the button is a reset button (C<is_reset> is true), all widgets
+are reset to their initial state, and C<undef> is returned.
+
+If the button is a submit button (C<is_submit> is true), then a GET/POST
+request is issued as appropriate and the reply is made available through
+a C<CGI::Test::Page> object.
+
+Otherwise, the button pressing is ignored, a warning is issued from the
+perspective of the caller, via C<logcarp>, and C<undef> is returned.
+
+=back
+
+=head2 Widget Classification Predicates
+
+There is an additional set of predicates to distinguish between the various
+buttons:
+
+=over 4
+
+=item C<is_plain>
+
+Returns I<true> for a plain button, i.e. a button that has no submit/reset
+effects. Usually, those buttons are linked to a script, but C<CGI::Test>
+does not support scripting yet.
+
+=item C<is_reset>
+
+Returns I<true> for reset buttons.
+
+=item C<is_submit>
+
+Returns I<true> for submit buttons, whether they are really shown as
+buttons or as images. A submit button will cause an HTTP request to be
+issued in response to its being pressed.
+
+=back
+
+=head2 Miscellaneous Features
+
+Although documented, those features are more targetted for
+internal use...
+
+=over 4
+
+=item C<set_is_pressed> I<flag>
+
+Change the pressed status of the button, to the value of I<flag>.
+It does not raise any other side effect, like submitting an HTTP request
+if the button is a submit button.
+
+You should probably use the C<press> convenience routine instead of calling
+this feature directly.
+
+=back
+
+=head1 WEBSITE
+
+You can find information about CGI::Test and other related modules at:
+
+ http://cgi-test.sourceforge.net
+
+=head1 PUBLIC CVS SERVER
+
+CGI::Test now has a publicly accessible CVS server provided by
+SourceForge (www.sourceforge.net). You can access it by going to:
+
+ http://sourceforge.net/cvs/?group_id=89570
+
+=head1 AUTHORS
+
+The original author is Raphael Manfredi F<E<lt>Raphael_Manfredi at pobox.comE<gt>>.
+
+Send bug reports, hints, tips, suggestions to Steven Hilton at <mshiltonj at mshiltonj.com>
+
+=head1 SEE ALSO
+
+CGI::Test::Form::Widget(3),
+CGI::Test::Form::Widget::Button::Image(3),
+CGI::Test::Form::Widget::Button::Plain(3),
+CGI::Test::Form::Widget::Button::Reset(3),
+CGI::Test::Form::Widget::Button::Submit(3).
+
+=cut
+
diff --git a/lib/CGI/Test/Form/Widget/Button/Image.pm b/lib/CGI/Test/Form/Widget/Button/Image.pm
new file mode 100644
index 0000000..bfa0658
--- /dev/null
+++ b/lib/CGI/Test/Form/Widget/Button/Image.pm
@@ -0,0 +1,82 @@
+package CGI::Test::Form::Widget::Button::Image;
+use strict;
+##################################################################
+# $Id: Image.pm 411 2011-09-26 11:19:30Z nohuhu at nohuhu.org $
+# $Name: cgi-test_0-104_t1 $
+##################################################################
+#
+# Copyright (c) 2001, Raphael Manfredi
+#
+# You may redistribute only under the terms of the Artistic License,
+# as specified in the README file that comes with the distribution.
+#
+
+#
+# This class models a FORM image button.
+# It's really a submit button in disguise as far as processing goes.
+#
+
+use CGI::Test::Form::Widget::Button::Submit;
+use base qw(CGI::Test::Form::Widget::Button::Submit);
+
+use Log::Agent;
+
+#
+# Attribute access
+#
+
+sub gui_type
+{
+ return "image button";
+}
+
+1;
+
+=head1 NAME
+
+CGI::Test::Form::Widget::Button::Image - A nice submit button
+
+=head1 SYNOPSIS
+
+ # Inherits from CGI::Test::Form::Widget::Button
+ # $form is a CGI::Test::Form
+
+ my $send = $form->submit_by_name("send");
+ my $answer = $send->press;
+
+=head1 DESCRIPTION
+
+This class models an image button. Apart from the fact that it's probably
+nicer on a browser, this widget otherwise behaves like your ordinary
+submit button.
+
+Pressing it immediately triggers an HTTP request, as defined by the form.
+
+The interface is the same as the one described in
+L<CGI::Test::Form::Widget::Button>.
+
+=head1 WEBSITE
+
+You can find information about CGI::Test and other related modules at:
+
+ http://cgi-test.sourceforge.net
+
+=head1 PUBLIC CVS SERVER
+
+CGI::Test now has a publicly accessible CVS server provided by
+SourceForge (www.sourceforge.net). You can access it by going to:
+
+ http://sourceforge.net/cvs/?group_id=89570
+
+=head1 AUTHORS
+
+The original author is Raphael Manfredi F<E<lt>Raphael_Manfredi at pobox.comE<gt>>.
+
+Send bug reports, hints, tips, suggestions to Steven Hilton at <mshiltonj at mshiltonj.com>
+
+=head1 SEE ALSO
+
+CGI::Test::Form::Widget::Button(3).
+
+=cut
+
diff --git a/lib/CGI/Test/Form/Widget/Button/Plain.pm b/lib/CGI/Test/Form/Widget/Button/Plain.pm
new file mode 100644
index 0000000..c61ba0b
--- /dev/null
+++ b/lib/CGI/Test/Form/Widget/Button/Plain.pm
@@ -0,0 +1,85 @@
+package CGI::Test::Form::Widget::Button::Plain;
+use strict;
+##################################################################
+# $Id: Plain.pm 411 2011-09-26 11:19:30Z nohuhu at nohuhu.org $
+# $Name: cgi-test_0-104_t1 $
+##################################################################
+#
+# Copyright (c) 2001, Raphael Manfredi
+#
+# You may redistribute only under the terms of the Artistic License,
+# as specified in the README file that comes with the distribution.
+#
+
+#
+# This class models a FORM plain <BUTTON>.
+#
+
+require CGI::Test::Form::Widget::Button;
+use base qw(CGI::Test::Form::Widget::Button);
+
+use Log::Agent;
+
+#
+# Attribute access
+#
+
+sub gui_type
+{
+ return "plain button";
+}
+
+#
+# Button predicates
+#
+
+sub is_plain
+{
+ return 1;
+}
+
+1;
+
+=head1 NAME
+
+CGI::Test::Form::Widget::Button::Plain - A button with client-side processing
+
+=head1 SYNOPSIS
+
+ # Inherits from CGI::Test::Form::Widget::Button
+
+=head1 DESCRIPTION
+
+This class models a plain button, which probably has some client-side
+processing attached to it. Unfortunately, C<CGI::Test> does not support
+this, so there's not much you can do with this button, apart from making
+sure it is present.
+
+The interface is the same as the one described in
+L<CGI::Test::Form::Widget::Button>.
+
+=head1 WEBSITE
+
+You can find information about CGI::Test and other related modules at:
+
+ http://cgi-test.sourceforge.net
+
+=head1 PUBLIC CVS SERVER
+
+CGI::Test now has a publicly accessible CVS server provided by
+SourceForge (www.sourceforge.net). You can access it by going to:
+
+ http://sourceforge.net/cvs/?group_id=89570
+
+=head1 AUTHORS
+
+The original author is Raphael Manfredi F<E<lt>Raphael_Manfredi at pobox.comE<gt>>.
+
+Send bug reports, hints, tips, suggestions to Steven Hilton at <mshiltonj at mshiltonj.com>
+
+=head1 SEE ALSO
+
+CGI::Test::Form::Widget::Button(3).
+
+=cut
+
diff --git a/lib/CGI/Test/Form/Widget/Button/Reset.pm b/lib/CGI/Test/Form/Widget/Button/Reset.pm
new file mode 100644
index 0000000..7d7e716
--- /dev/null
+++ b/lib/CGI/Test/Form/Widget/Button/Reset.pm
@@ -0,0 +1,111 @@
+package CGI::Test::Form::Widget::Button::Reset;
+use strict;
+##################################################################
+# $Id: Reset.pm 411 2011-09-26 11:19:30Z nohuhu at nohuhu.org $
+# $Name: cgi-test_0-104_t1 $
+##################################################################
+#
+# Copyright (c) 2001, Raphael Manfredi
+#
+# You may redistribute only under the terms of the Artistic License,
+# as specified in the README file that comes with the distribution.
+#
+#
+# This class models a FORM reset button.
+#
+
+require CGI::Test::Form::Widget::Button;
+use base qw(CGI::Test::Form::Widget::Button);
+
+use Log::Agent;
+
+#
+# Attribute access
+#
+
+sub gui_type
+{
+ return "reset button";
+}
+
+#
+# ->press
+#
+# Press button.
+# Has immediate effect: all widgets are reset to their initial state.
+#
+# Returns undef.
+#
+sub press
+{
+ my $this = shift;
+ $this->form->reset();
+ return undef;
+}
+
+#
+# Global widget predicates
+#
+
+sub is_read_only
+{
+ return 1;
+} # Handled internally by client
+
+#
+# Button predicates
+#
+
+sub is_reset
+{
+ return 1;
+}
+
+1;
+
+=head1 NAME
+
+CGI::Test::Form::Widget::Button::Reset - A reset button
+
+=head1 SYNOPSIS
+
+ # Inherits from CGI::Test::Form::Widget::Button
+ # $form is a CGI::Test::Form
+
+ my @reset = $form->buttons_matching(sub { $_[0]->is_reset });
+ $reset[0]->press if @reset;
+
+=head1 DESCRIPTION
+
+This class models a reset button. Pressing this buttom immediately
+resets the form to its original state. The processing is done on the
+client-side, and no request is made to the HTTP server.
+
+The interface is the same as the one described in
+L<CGI::Test::Form::Widget::Button>.
+
+=head1 WEBSITE
+
+You can find information about CGI::Test and other related modules at:
+
+ http://cgi-test.sourceforge.net
+
+=head1 PUBLIC CVS SERVER
+
+CGI::Test now has a publicly accessible CVS server provided by
+SourceForge (www.sourceforge.net). You can access it by going to:
+
+ http://sourceforge.net/cvs/?group_id=89570
+
+=head1 AUTHORS
+
+The original author is Raphael Manfredi F<E<lt>Raphael_Manfredi at pobox.comE<gt>>.
+
+Send bug reports, hints, tips, suggestions to Steven Hilton at <mshiltonj at mshiltonj.com>
+
+=head1 SEE ALSO
+
+CGI::Test::Form::Widget::Button(3).
+
+=cut
+
diff --git a/lib/CGI/Test/Form/Widget/Button/Submit.pm b/lib/CGI/Test/Form/Widget/Button/Submit.pm
new file mode 100644
index 0000000..3d92865
--- /dev/null
+++ b/lib/CGI/Test/Form/Widget/Button/Submit.pm
@@ -0,0 +1,102 @@
+package CGI::Test::Form::Widget::Button::Submit;
+use strict;
+##################################################################
+# $Id: Submit.pm 411 2011-09-26 11:19:30Z nohuhu at nohuhu.org $
+# $Name: cgi-test_0-104_t1 $
+##################################################################
+#
+# Copyright (c) 2001, Raphael Manfredi
+#
+# You may redistribute only under the terms of the Artistic License,
+# as specified in the README file that comes with the distribution.
+#
+
+#
+# This class models a FORM submit button.
+#
+
+use CGI::Test::Form::Widget::Button;
+use base qw(CGI::Test::Form::Widget::Button);
+
+use Log::Agent;
+
+#
+# Attribute access
+#
+
+sub gui_type
+{
+ return "submit button";
+}
+
+#
+# ->press
+#
+# Press button.
+# Has immediate effect: a GET/POST request is issued.
+#
+# Returns resulting CGI::Test::Page.
+#
+sub press
+{
+ my $this = shift;
+ $this->set_is_pressed(1);
+ return $this->form->submit;
+}
+
+#
+# Button predicates
+#
+
+sub is_submit
+{
+ return 1;
+}
+
+1;
+
+=head1 NAME
+
+CGI::Test::Form::Widget::Button::Submit - A submit button
+
+=head1 SYNOPSIS
+
+ # Inherits from CGI::Test::Form::Widget::Button
+ # $form is a CGI::Test::Form
+
+ my $send = $form->submit_by_name("send");
+ my $answer = $send->press;
+
+=head1 DESCRIPTION
+
+This class models a submit button.
+Pressing it immediately triggers an HTTP request, as defined by the form.
+
+The interface is the same as the one described in
+L<CGI::Test::Form::Widget::Button>.
+
+=head1 WEBSITE
+
+You can find information about CGI::Test and other related modules at:
+
+ http://cgi-test.sourceforge.net
+
+=head1 PUBLIC CVS SERVER
+
+CGI::Test now has a publicly accessible CVS server provided by
+SourceForge (www.sourceforge.net). You can access it by going to:
+
+ http://sourceforge.net/cvs/?group_id=89570
+
+=head1 AUTHORS
+
+The original author is Raphael Manfredi F<E<lt>Raphael_Manfredi at pobox.comE<gt>>.
+
+Send bug reports, hints, tips, suggestions to Steven Hilton at <mshiltonj at mshiltonj.com>
+
+=head1 SEE ALSO
+
+CGI::Test::Form::Widget::Button(3).
+
+=cut
+
diff --git a/lib/CGI/Test/Form/Widget/Hidden.pm b/lib/CGI/Test/Form/Widget/Hidden.pm
new file mode 100644
index 0000000..3e28f57
--- /dev/null
+++ b/lib/CGI/Test/Form/Widget/Hidden.pm
@@ -0,0 +1,129 @@
+package CGI::Test::Form::Widget::Hidden;
+use strict;
+##################################################################
+# $Id: Hidden.pm 411 2011-09-26 11:19:30Z nohuhu at nohuhu.org $
+# $Name: cgi-test_0-104_t1 $
+##################################################################
+#
+# Copyright (c) 2001, Raphael Manfredi
+#
+# You may redistribute only under the terms of the Artistic License,
+# as specified in the README file that comes with the distribution.
+
+#
+# This class models a FORM hidden field.
+#
+
+require CGI::Test::Form::Widget;
+use base qw(CGI::Test::Form::Widget);
+
+use Log::Agent;
+
+#
+# %attr
+#
+# Defines which HTML attributes we should look at within the node, and how
+# to translate that into class attributes.
+#
+
+my %attr = ('name' => 'name',
+ 'value' => 'value',
+ 'disabled' => 'is_disabled',
+ );
+
+#
+# ->_init
+#
+# Per-widget initialization routine.
+# Parse HTML node to determine our specific parameters.
+#
+sub _init
+{
+ my $this = shift;
+ my ($node) = shift;
+ $this->_parse_attr($node, \%attr);
+ return;
+}
+
+#
+# ->_is_successful -- defined
+#
+# Is the enabled widget "successful", according to W3C's specs?
+# Any hidden field with a VALUE attribute is.
+#
+sub _is_successful
+{
+ my $this = shift;
+ return defined $this->value();
+}
+
+#
+# Attribute access
+#
+
+sub gui_type
+{
+ return "hidden field";
+}
+
+#
+# Global widget predicates
+#
+
+sub is_read_only
+{
+ return 1;
+}
+
+#
+# High-level classification predicates
+#
+
+sub is_hidden
+{
+ return 1;
+}
+
+1;
+
+=head1 NAME
+
+CGI::Test::Form::Widget::Hidden - A hidden field
+
+=head1 SYNOPSIS
+
+ # Inherits from CGI::Test::Form::Widget
+
+=head1 DESCRIPTION
+
+This class represents a hidden field, which is meant to be resent as-is
+upon submit. Such a widget is therefore read-only.
+
+The interface is the same as the one described
+in L<CGI::Test::Form::Widget>.
+
+=head1 WEBSITE
+
+You can find information about CGI::Test and other related modules at:
+
+ http://cgi-test.sourceforge.net
+
+=head1 PUBLIC CVS SERVER
+
+CGI::Test now has a publicly accessible CVS server provided by
+SourceForge (www.sourceforge.net). You can access it by going to:
+
+ http://sourceforge.net/cvs/?group_id=89570
+
+=head1 AUTHORS
+
+The original author is Raphael Manfredi F<E<lt>Raphael_Manfredi at pobox.comE<gt>>.
+
+Send bug reports, hints, tips, suggestions to Steven Hilton at <mshiltonj at mshiltonj.com>
+
+=head1 SEE ALSO
+
+CGI::Test::Form::Widget(3).
+
+=cut
+
diff --git a/lib/CGI/Test/Form/Widget/Input.pm b/lib/CGI/Test/Form/Widget/Input.pm
new file mode 100644
index 0000000..0cd43de
--- /dev/null
+++ b/lib/CGI/Test/Form/Widget/Input.pm
@@ -0,0 +1,242 @@
+package CGI::Test::Form::Widget::Input;
+use strict;
+##################################################################
+# $Id: Input.pm 411 2011-09-26 11:19:30Z nohuhu at nohuhu.org $
+# $Name: cgi-test_0-104_t1 $
+##################################################################
+#
+# Copyright (c) 2001, Raphael Manfredi
+#
+# You may redistribute only under the terms of the Artistic License,
+# as specified in the README file that comes with the distribution.
+#
+
+#
+# This class models a FORM input field.
+# It factorizes the interface of our heirs: Text_Area and Text_Field
+#
+
+use CGI::Test::Form::Widget;
+use base qw(CGI::Test::Form::Widget);
+
+use Log::Agent;
+
+#
+# ->_is_successful -- defined
+#
+# Is the enabled widget "successful", according to W3C's specs?
+# Any input is.
+#
+sub _is_successful
+{
+ my $this = shift;
+ return 1;
+}
+
+#
+# Editing shortcuts
+#
+# The set_value() routine from the Widget class is protected against
+# disabled and read-only fields, so don't duplicate checks within these
+# shortcut routines.
+#
+# All are obvious, excepted filter perhaps, which runs a filtering subroutine
+# on the field's value, preset in $_:
+#
+# $i->filter(sub { s/this/that/ });
+#
+# In the traditional Perl way...
+#
+
+sub prepend
+{
+ my $this = shift;
+ my $prepend = shift;
+ $this->set_value($prepend . $this->value());
+}
+
+sub append
+{
+ my $this = shift;
+ my $append = shift;
+ $this->set_value($this->value() . $append);
+}
+
+sub replace
+{
+ my $this = shift;
+ my $new_value = shift;
+ $this->set_value($new_value);
+}
+
+sub clear
+{
+ my $this = shift;
+ $this->set_value('');
+}
+
+sub filter
+{
+ my $this = shift;
+ my $filter = shift;
+ local $_ = $this->value();
+ &{$filter};
+ $this->set_value($_);
+}
+
+#
+# Attribute access
+#
+
+sub is_read_only
+{
+ my $this = shift;
+ return $this->{is_read_only};
+}
+
+#
+# High-level classification predicates
+#
+
+sub is_input
+{
+ return 1;
+}
+
+#
+# Predicates for the Input hierarchy
+#
+
+sub is_field
+{
+ return 0;
+}
+
+sub is_area
+{
+ return 0;
+}
+
+sub is_password
+{
+ return 0;
+}
+
+sub is_file
+{
+ return 0;
+}
+
+1;
+
+=head1 NAME
+
+CGI::Test::Form::Widget::Input - Abstract representation of an input field
+
+=head1 SYNOPSIS
+
+ # Inherits from CGI::Test::Form::Widget
+
+=head1 DESCRIPTION
+
+This class is the abstract representation of a text input field, i.e. a
+text field, a password field, a file upload field or a text area.
+
+To simulate user input in those fields, there are a set of routines to
+C<prepend()>, C<append()>, C<replace()>, C<clear()> or even run existing text
+through C<filter()>.
+
+=head1 INTERFACE
+
+The interface is the same as the one described in L<CGI::Test::Form::Widget>,
+with the following additions:
+
+=head2 Attribute Setting
+
+There are a number of convenience routines that are wrappers on C<set_value()>:
+
+=over 4
+
+=item C<append> I<string>
+
+Appends the I<string> text to the existing text.
+
+=item C<clear>
+
+Clears existing text.
+
+=item C<filter> I<filter_routine>
+
+Runs existing text through the given I<filter_routine>. The C<$_> variable
+is set to the whole text value, and is made available to the filter.
+Hence you may write:
+
+ $input->filter(sub { s/this/that/g });
+
+to replace all instances of C<this> by C<that> within the input text.
+
+=item C<prepend> I<string>
+
+Prepends the I<string> text to the existing text.
+
+=item C<replace> I<string>
+
+Replaces the existing text with I<string>.
+
+=back
+
+=head2 Widget Classification Predicates
+
+There are additional predicates to distinguish between the various
+input fields:
+
+=over 4
+
+=item C<is_area>
+
+Returns I<true> for a text area.
+
+=item C<is_field>
+
+Returns I<true> for a pure text field.
+
+=item C<is_file>
+
+Returns I<true> for a file upload field (text field with browser support for
+file selection).
+
+=item C<is_password>
+
+Returns I<true> for a password field (text field with input masked by GUI).
+
+=back
+
+=head1 WEBSITE
+
+You can find information about CGI::Test and other related modules at:
+
+ http://cgi-test.sourceforge.net
+
+=head1 PUBLIC CVS SERVER
+
+CGI::Test now has a publicly accessible CVS server provided by
+SourceForge (www.sourceforge.net). You can access it by going to:
+
+ http://sourceforge.net/cvs/?group_id=89570
+
+=head1 AUTHORS
+
+The original author is Raphael Manfredi F<E<lt>Raphael_Manfredi at pobox.comE<gt>>.
+
+Send bug reports, hints, tips, suggestions to Steven Hilton at <mshiltonj at mshiltonj.com>
+
+=head1 SEE ALSO
+
+CGI::Test::Form::Widget(3),
+CGI::Test::Form::Widget::Input::File(3),
+CGI::Test::Form::Widget::Input::Password(3),
+CGI::Test::Form::Widget::Input::Text_Area(3),
+CGI::Test::Form::Widget::Input::Text_Field(3).
+
+=cut
+
diff --git a/lib/CGI/Test/Form/Widget/Input/File.pm b/lib/CGI/Test/Form/Widget/Input/File.pm
new file mode 100644
index 0000000..d9f0e5c
--- /dev/null
+++ b/lib/CGI/Test/Form/Widget/Input/File.pm
@@ -0,0 +1,97 @@
+package CGI::Test::Form::Widget::Input::File;
+use strict;
+##################################################################
+# $Id: File.pm 411 2011-09-26 11:19:30Z nohuhu at nohuhu.org $
+# $Name: cgi-test_0-104_t1 $
+##################################################################
+#
+# Copyright (c) 2001, Raphael Manfredi
+#
+# You may redistribute only under the terms of the Artistic License,
+# as specified in the README file that comes with the distribution.
+#
+
+#
+# This class models a FORM file input for uploading.
+#
+# It inherits from Text_Field, since the only distinction between a text field
+# and a file upload field is the presence of the "browse" button displayed by
+# the browser to select a file.
+#
+
+use CGI::Test::Form::Widget::Input::Text_Field;
+use base qw(CGI::Test::Form::Widget::Input::Text_Field);
+
+use Log::Agent;
+
+#
+# Attribute access
+#
+
+sub gui_type
+{
+ return "file upload";
+}
+
+#
+# Redefined predicates
+#
+
+sub is_field
+{
+ return 0;
+} # not a pure text field
+
+sub is_file
+{
+ return 1;
+}
+
+1;
+
+=head1 NAME
+
+CGI::Test::Form::Widget::Input::File - A file upload control
+
+=head1 SYNOPSIS
+
+ # Inherits from CGI::Test::Form::Widget::Input
+ # $form is a CGI::Test::Form
+
+ my $upload = $form->input_by_name("upload");
+ $upload->replace("/tmp/file");
+
+=head1 DESCRIPTION
+
+This class models a file upload control, which is a text field to enter
+a file name, with a little "browse" control button nearby that allows
+the user to select a file via a GUI...
+
+The interface is the same as the one described in
+L<CGI::Test::Form::Widget::Input::Text_Field>.
+
+=head1 WEBSITE
+
+You can find information about CGI::Test and other related modules at:
+
+ http://cgi-test.sourceforge.net
+
+=head1 PUBLIC CVS SERVER
+
+CGI::Test now has a publicly accessible CVS server provided by
+SourceForge (www.sourceforge.net). You can access it by going to:
+
+ http://sourceforge.net/cvs/?group_id=89570
+
+=head1 AUTHORS
+
+The original author is Raphael Manfredi F<E<lt>Raphael_Manfredi at pobox.comE<gt>>.
+
+Send bug reports, hints, tips, suggestions to Steven Hilton at <mshiltonj at mshiltonj.com>
+
+=head1 SEE ALSO
+
+CGI::Test::Form::Widget::Input(3).
+
+=cut
+
diff --git a/lib/CGI/Test/Form/Widget/Input/Password.pm b/lib/CGI/Test/Form/Widget/Input/Password.pm
new file mode 100644
index 0000000..f8d8278
--- /dev/null
+++ b/lib/CGI/Test/Form/Widget/Input/Password.pm
@@ -0,0 +1,95 @@
+package CGI::Test::Form::Widget::Input::Password;
+use strict;
+##################################################################
+# $Id: Password.pm 411 2011-09-26 11:19:30Z nohuhu at nohuhu.org $
+# $Name: cgi-test_0-104_t1 $
+##################################################################
+#
+# Copyright (c) 2001, Raphael Manfredi
+#
+# You may redistribute only under the terms of the Artistic License,
+# as specified in the README file that comes with the distribution.
+
+#
+# This class models a FORM password input field.
+#
+# It inherits from Text_Field, since the only distinction between a text field
+# and a password field is whether characters are shown as typed or not.
+#
+
+use CGI::Test::Form::Widget::Input::Text_Field;
+use base qw(CGI::Test::Form::Widget::Input::Text_Field);
+
+use Log::Agent;
+
+#
+# Attribute access
+#
+
+sub gui_type
+{
+ return "password field";
+}
+
+#
+# Redefined predicates
+#
+
+sub is_field
+{
+ return 0;
+} # not a pure text field
+
+sub is_password
+{
+ return 1;
+}
+
+1;
+
+=head1 NAME
+
+CGI::Test::Form::Widget::Input::Password - A password field
+
+=head1 SYNOPSIS
+
+ # Inherits from CGI::Test::Form::Widget::Input
+ # $form is a CGI::Test::Form
+
+ my $passwd = $form->input_by_name("password");
+ $passwd->replace("foobar");
+
+=head1 DESCRIPTION
+
+This class models a password field, which is a text field whose input
+is masked by the browser, but which otherwise behaves like a regular
+text field.
+
+The interface is the same as the one described in
+L<CGI::Test::Form::Widget::Input::Text_Field>.
+
+=head1 WEBSITE
+
+You can find information about CGI::Test and other related modules at:
+
+ http://cgi-test.sourceforge.net
+
+=head1 PUBLIC CVS SERVER
+
+CGI::Test now has a publicly accessible CVS server provided by
+SourceForge (www.sourceforge.net). You can access it by going to:
+
+ http://sourceforge.net/cvs/?group_id=89570
+
+=head1 AUTHORS
+
+The original author is Raphael Manfredi F<E<lt>Raphael_Manfredi at pobox.comE<gt>>.
+
+Send bug reports, hints, tips, suggestions to Steven Hilton at <mshiltonj at mshiltonj.com>
+
+=head1 SEE ALSO
+
+CGI::Test::Form::Widget::Input(3).
+
+=cut
+
diff --git a/lib/CGI/Test/Form/Widget/Input/Text_Area.pm b/lib/CGI/Test/Form/Widget/Input/Text_Area.pm
new file mode 100644
index 0000000..af5b905
--- /dev/null
+++ b/lib/CGI/Test/Form/Widget/Input/Text_Area.pm
@@ -0,0 +1,163 @@
+package CGI::Test::Form::Widget::Input::Text_Area;
+use strict;
+##################################################################
+# $Id: Text_Area.pm 411 2011-09-26 11:19:30Z nohuhu at nohuhu.org $
+# $Name: cgi-test_0-104_t1 $
+##################################################################
+#
+# Copyright (c) 2001, Raphael Manfredi
+#
+# You may redistribute only under the terms of the Artistic License,
+# as specified in the README file that comes with the distribution.
+
+#
+# This class models a FORM textarea input field.
+#
+
+use CGI::Test::Form::Widget::Input;
+use base qw(CGI::Test::Form::Widget::Input);
+
+use Log::Agent;
+
+#
+# %attr
+#
+# Defines which HTML attributes we should look at within the node, and how
+# to translate that into class attributes.
+#
+
+my %attr = ('name' => 'name',
+ 'value' => 'value',
+ 'rows' => 'rows',
+ 'cols' => 'columns',
+ 'wrap' => 'wrap_mode',
+ 'disabled' => 'is_disabled',
+ 'readonly' => 'is_read_only',
+ );
+
+#
+# ->_init
+#
+# Per-widget initialization routine.
+# Parse HTML node to determine our specific parameters.
+#
+sub _init
+{
+ my $this = shift;
+ my ($node) = shift;
+ $this->_parse_attr($node, \%attr);
+ return;
+}
+
+#
+# Attribute access
+#
+############################################################
+sub rows
+{
+ my $this = shift;
+ return $this->{rows};
+}
+############################################################
+sub columns
+{
+ my $this = shift;
+ return $this->{columns};
+}
+############################################################
+sub wrap_mode
+{
+ my $this = shift;
+ return $this->{wrap_mode};
+}
+############################################################
+
+sub gui_type
+{
+ "text area"
+}
+
+#
+# Redefined predicates
+#
+
+############################################################
+sub is_area
+{
+ 1
+}
+
+1;
+
+=head1 NAME
+
+CGI::Test::Form::Widget::Input::Text_Area - A text area
+
+=head1 SYNOPSIS
+
+ # Inherits from CGI::Test::Form::Widget::Input
+ # $form is a CGI::Test::Form
+
+ my $comments = $form->input_by_name("comments");
+ $comments->append(<<EOM);
+ --
+ There's more than one way to do it.
+ --Larry Wall
+ EOM
+
+=head1 DESCRIPTION
+
+This class models a text area, where users can type text.
+
+=head1 INTERFACE
+
+The interface is the same as the one described in
+L<CGI::Test::Form::Widget::Input>, with the following additional attributes:
+
+=over 4
+
+=item C<columns>
+
+Amount of displayed columns.
+
+=item C<rows>
+
+Amount of displayed text rows.
+
+=item C<wrap_mode>
+
+The selected work wrapping mode.
+
+=back
+
+=head1 BUGS
+
+Does not handle C<wrap_mode> and C<columns> yet. There is actually some work
+done by the browser when the wrapping mode is set to C<"hard">, which alters
+the value transmitted back to the script upon submit.
+
+=head1 WEBSITE
+
+You can find information about CGI::Test and other related modules at:
+
+ http://cgi-test.sourceforge.net
+
+=head1 PUBLIC CVS SERVER
+
+CGI::Test now has a publicly accessible CVS server provided by
+SourceForge (www.sourceforge.net). You can access it by going to:
+
+ http://sourceforge.net/cvs/?group_id=89570
+
+=head1 AUTHORS
+
+The original author is Raphael Manfredi F<E<lt>Raphael_Manfredi at pobox.comE<gt>>.
+
+Send bug reports, hints, tips, suggestions to Steven Hilton at <mshiltonj at mshiltonj.com>
+
+=head1 SEE ALSO
+
+CGI::Test::Form::Widget::Input(3).
+
+=cut
+
diff --git a/lib/CGI/Test/Form/Widget/Input/Text_Field.pm b/lib/CGI/Test/Form/Widget/Input/Text_Field.pm
new file mode 100644
index 0000000..61943b3
--- /dev/null
+++ b/lib/CGI/Test/Form/Widget/Input/Text_Field.pm
@@ -0,0 +1,168 @@
+package CGI::Test::Form::Widget::Input::Text_Field;
+use strict;
+##################################################################
+# $Id: Text_Field.pm 411 2011-09-26 11:19:30Z nohuhu at nohuhu.org $
+# $Name: cgi-test_0-104_t1 $
+##################################################################
+#
+# Copyright (c) 2001, Raphael Manfredi
+#
+# You may redistribute only under the terms of the Artistic License,
+# as specified in the README file that comes with the distribution.
+#
+#
+# This class models a FORM text field.
+#
+
+use CGI::Test::Form::Widget::Input;
+use base qw(CGI::Test::Form::Widget::Input);
+
+use Log::Agent;
+
+#
+# %attr
+#
+# Defines which HTML attributes we should look at within the node, and how
+# to translate that into class attributes.
+#
+
+my %attr = ('name' => 'name',
+ 'value' => 'value',
+ 'size' => 'size',
+ 'maxlength' => 'max_length',
+ 'disabled' => 'is_disabled',
+ 'readonly' => 'is_read_only',
+ );
+
+#
+# ->_init
+#
+# Per-widget initialization routine.
+# Parse HTML node to determine our specific parameters.
+#
+sub _init
+{
+ my $this = shift;
+ my ($node) = shift;
+ $this->_parse_attr($node, \%attr);
+ return;
+}
+
+#
+# Attribute access
+#
+
+sub size
+{
+ $_[ 0 ]->{size};
+}
+
+sub max_length
+{
+ $_[ 0 ]->{max_length};
+}
+
+sub gui_type
+{
+ "text field"
+}
+
+#
+# Redefined predicates
+#
+
+sub is_field
+{
+ 1
+}
+
+#
+# Redefined routines
+#
+
+#
+# ->set_value -- redefined
+#
+# Ensure text is not larger than the maximum field length, by truncating
+# from the right.
+#
+sub set_value
+{
+ my $this = shift;
+ my ($value) = @_;
+
+ my $maxlen = $this->max_length;
+ $maxlen = 1 if defined $maxlen && $maxlen < 1;
+
+ if (defined $maxlen && length($value) > $maxlen)
+ {
+ logcarp "truncating text to %d byte%s for %s '%s'", $maxlen,
+ $maxlen == 1 ? "" : "s", $this->gui_type, $this->name;
+ substr($value, $maxlen) = '';
+ }
+
+ $this->SUPER::set_value($value);
+}
+
+1;
+
+=head1 NAME
+
+CGI::Test::Form::Widget::Input::Text_Field - A text field
+
+=head1 SYNOPSIS
+
+ # Inherits from CGI::Test::Form::Widget::Input
+ # $form is a CGI::Test::Form
+
+ my $desc = $form->input_by_name("description");
+ $desc->replace("small and beautiful");
+
+=head1 DESCRIPTION
+
+This class models a single-line text field, where users can type text.
+
+=head1 INTERFACE
+
+The interface is the same as the one described in
+L<CGI::Test::Form::Widget::Input>, with the following additional attributes:
+
+=over 4
+
+=item C<max_length>
+
+The maximum allowed text length within the field. If not defined, it means
+the length is not limited.
+
+=item C<size>
+
+The size of the displayed text field, in characters. The text held within
+the field can be much larger than that, however.
+
+=back
+
+=head1 WEBSITE
+
+You can find information about CGI::Test and other related modules at:
+
+ http://cgi-test.sourceforge.net
+
+=head1 PUBLIC CVS SERVER
+
+CGI::Test now has a publicly accessible CVS server provided by
+SourceForge (www.sourceforge.net). You can access it by going to:
+
+ http://sourceforge.net/cvs/?group_id=89570
+
+=head1 AUTHORS
+
+The original author is Raphael Manfredi F<E<lt>Raphael_Manfredi at pobox.comE<gt>>.
+
+Send bug reports, hints, tips, suggestions to Steven Hilton at <mshiltonj at mshiltonj.com>
+
+=head1 SEE ALSO
+
+CGI::Test::Form::Widget::Input(3).
+
+=cut
+
diff --git a/lib/CGI/Test/Form/Widget/Menu.pm b/lib/CGI/Test/Form/Widget/Menu.pm
new file mode 100644
index 0000000..038f326
--- /dev/null
+++ b/lib/CGI/Test/Form/Widget/Menu.pm
@@ -0,0 +1,484 @@
+package CGI::Test::Form::Widget::Menu;
+use strict;
+##################################################################
+# $Id: Menu.pm 411 2011-09-26 11:19:30Z nohuhu at nohuhu.org $
+# $Name: cgi-test_0-104_t1 $
+##################################################################
+#
+# Copyright (c) 2001, Raphael Manfredi
+#
+# You may redistribute only under the terms of the Artistic License,
+# as specified in the README file that comes with the distribution.
+#
+
+#
+# This class models a FORM menu (either a popup or a scrollable list).
+#
+
+use Carp;
+
+use CGI::Test::Form::Widget;
+use base qw(CGI::Test::Form::Widget);
+
+use Log::Agent;
+use Storable qw(dclone);
+
+############################################################
+#
+# ->_parse_options
+#
+# Parse <OPTION> items held within the <SELECT> node.
+# We ignore <OPTGROUP> items, since those are only there for grouping options,
+# and cannot be individually selected as such.
+#
+# The following attributes are used to record the options:
+#
+# option_labels listref of option labels, in the order they appear
+# option_values listref of option values, in the order they appear
+# known_values hashref, recording valid *values*
+# selected hashref, recording selected *values*
+# selected_count amount of selected items
+#
+############################################################
+sub _parse_options
+{
+ my $this = shift;
+ my ($node) = shift;
+
+ my $labels = $this->{option_labels} = [];
+ my $values = $this->{option_values} = [];
+ my $selected = $this->{selected} = {};
+ my $known = $this->{known_values} = {};
+ my $count = 0;
+ my %seen;
+
+ my @nodes = $node->look_down(sub {1});
+ shift @nodes; # first node is the <SELECT> itself
+
+ foreach my $opt (@nodes)
+ {
+ next if $opt->tag() eq "optgroup";
+ unless ($opt->tag() eq "option")
+ {
+ logwarn "ignoring non-option tag '%s' within SELECT",
+ uc($opt->tag());
+ next;
+ }
+
+ #
+ # The option label is normally the content of the <OPTION> tag.
+ # However, if there is a LABEL= within the tag, it should be used
+ # in preference to the option content, says the W3C's norm.
+ #
+
+ my $label = $opt->attr("label") || $opt->as_text();
+ my $is_selected = $opt->attr("selected");
+ my $value = $opt->attr("value");
+
+ unless (defined $value)
+ {
+ logwarn "ignoring OPTION tag with no value: %s", $opt->starttag();
+ next;
+ }
+
+ #
+ # It is not really an error to have duplicate values, but is it
+ # a good interface style? The user will be faced with multiple
+ # labels to choose from, some of them being handled in the same way
+ # since they bear the same value... Tough choice... Let's warn!
+ #
+
+ logwarn "duplicate value '%s' in OPTION for SELECT NAME=\"%s\"",
+ $value, $this->name
+ if $seen{$value}++;
+
+ push @$labels, $label;
+ push @$values, $value;
+ $known->{$value}++; # help them spot dups
+ if ($is_selected)
+ {
+ $selected->{$value}++;
+ $count++;
+ }
+ }
+
+ #
+ # A popup menu needs to have at least one item selected. We're the
+ # user agent, and we get to choose which item we'll select implicitely.
+ # Use the first listed value, if any.
+ #
+
+ if ($count == 0 && $this->is_popup() && @$values)
+ {
+ my $first = $values->[ 0 ];
+ $selected->{$first}++;
+ $count++;
+ logwarn "implicitely selecting OPTION '%s' for SELECT NAME=\"%s\"",
+ $first, $this->name();
+ }
+
+ $this->{selected_count} = $count;
+
+ return;
+}
+
+############################################################
+#
+# ->_is_successful -- defined
+#
+# Is the enabled widget "successful", according to W3C's specs?
+# Any menu with at least one selected item is.
+#
+############################################################
+sub _is_successful
+{
+ my $this = shift;
+ return $this->selected_count > 0;
+}
+
+############################################################
+#
+# ->submit_tuples -- redefined
+#
+# Returns list of (name => value) tuples that should be part of the
+# submitted form data.
+#
+############################################################
+sub submit_tuples
+{
+ my $this = shift;
+
+ my $name = $this->name();
+ my $selected = $this->selected();
+
+ my @tuples =
+ map {$name => $_} grep {$selected->{$_}} @{$this->option_values()};
+
+ return @tuples;
+}
+
+#
+# Attribute access
+#
+############################################################
+sub multiple
+{
+ my $this = shift;
+ return $this->{multiple};
+} # Set by Menu::List
+
+############################################################
+sub option_labels
+{
+ my $this = shift;
+ return $this->{option_labels};
+}
+############################################################
+sub option_values
+{
+ my $this = shift;
+ return $this->{option_values};
+}
+############################################################
+sub known_values
+{
+ my $this = shift;
+ return $this->{known_values};
+}
+############################################################
+sub selected
+{
+ my $this = shift;
+ return $this->{selected};
+}
+############################################################
+sub selected_count
+{
+ my $this = shift;
+ return $this->{selected_count};
+}
+############################################################
+sub old_selected
+{
+ my $this = shift;
+ return $this->{old_selected};
+}
+
+#
+# Selection shortcuts
+#
+
+############################################################
+sub select
+{
+ my $this = shift;
+ my $item = shift;
+ $this->set_selected($item, 1);
+}
+############################################################
+sub unselect
+{
+ my $this = shift;
+ my $item = shift;
+ $this->set_selected($item, 0);
+}
+
+#
+# Global widget predicates
+#
+
+############################################################
+sub is_read_only
+{
+ return 1;
+}
+
+#
+# High-level classification predicates
+#
+
+############################################################
+sub is_menu
+{
+ return 1;
+}
+
+#
+# Predicates for menus
+#
+
+############################################################
+sub is_popup
+{
+ logconfess "deferred";
+}
+
+############################################################
+#
+# ->is_selected
+#
+# Checks whether given value is selected.
+#
+############################################################
+sub is_selected
+{
+ my $this = shift;
+ my ($value) = @_;
+
+ unless ($this->known_values->{$value})
+ {
+ logcarp "unknown value \"%s\" in $this", $value;
+ return 0;
+ }
+
+ return exists $this->selected->{$value};
+}
+
+############################################################
+#
+# ->set_selected
+#
+# Change "selected" status for a menu value.
+#
+############################################################
+sub set_selected
+{
+ my $this = shift;
+ my ($value, $state) = @_;
+
+ unless ($this->known_values->{$value})
+ {
+ logcarp "unknown value \"%s\" in $this", $value;
+ return;
+ }
+
+ my $is_selected = $this->is_selected($value);
+ return if !$is_selected == !$state; # No change // WTF? -nohuhu
+
+ #
+ # Save selected status for all the values the first time a change is made.
+ #
+
+ $this->{old_selected} = dclone $this->{selected}
+ unless exists $this->{old_selected};
+
+ #
+ # If multiple selection is not authorized, clear the selection list.
+ #
+
+ my $selected = $this->selected();
+ %$selected = () unless $this->multiple();
+
+ $selected->{$value} = 1 if $state;
+ delete $selected->{$value} unless $state;
+ $this->{selected_count} = scalar keys %$selected;
+
+ return;
+}
+
+############################################################
+#
+# ->reset_state
+#
+# Called when a "Reset" button is pressed to restore the value the widget
+# had upon form entry.
+#
+############################################################
+sub reset_state
+{
+ my $this = shift;
+
+ return unless exists $this->{old_selected};
+ $this->{selected} = delete $this->{old_selected};
+ $this->{selected_count} = scalar keys %{$this->selected()};
+
+ return;
+}
+
+1;
+
+=head1 NAME
+
+CGI::Test::Form::Widget::Menu - Abstract representation of a menu
+
+=head1 SYNOPSIS
+
+ # Inherits from CGI::Test::Form::Widget
+
+=head1 DESCRIPTION
+
+This class is the abstract representation of a menu from which one can choose
+one or several items, i.e. either a popup menu or a scrollable list
+(with possibly multiple selections).
+
+There is an interface to query the selected items, get at the presented
+labels and associated values, and naturally C<select()> or C<unselect()>
+items.
+
+=head1 INTERFACE
+
+The interface is the same as the one described in L<CGI::Test::Form::Widget>,
+with the following additions:
+
+=head2 Attributes
+
+=over 4
+
+=item C<known_values>
+
+An hash reference, recording valid menu values, as tuples
+(I<value> => I<count>), with I<count> set to the number of times the same
+value is re-used amongst the proposed options.
+
+=item C<multiple>
+
+Whether menu allows multiple selections.
+
+=item C<option_labels>
+
+A list reference, providing the labels to choose from, in the order in which
+they appear. The retained labels are either the content of the <OPTION>
+elements, or the value of their C<label> attribute, when specified.
+
+=item C<option_values>
+
+A list reference, providing the underlying values that the user chooses from
+when he selects labels, in the order in which they appear in the menu.
+
+=item C<selected>
+
+An hash reference, whose keys are the selected values.
+
+=item C<selected_count>
+
+The amount of currently selected items.
+
+=back
+
+=head2 Attribute Setting
+
+=over 4
+
+=item C<select> I<value>
+
+Mark the option I<value> as selected. If C<multiple> is false, any
+previously selected value is automatically unselected.
+
+Note that this takes a I<value>, not a I<label>.
+
+=item C<unselect> I<value>
+
+Unselect an option I<value>. It is not possible to do that on a popup
+menu: you must C<select> another item to unselect any previously selected one.
+
+=back
+
+=head2 Menu Probing
+
+=over 4
+
+=item C<is_selected> I<value>
+
+Test whether an option I<value> is currently selected or not. This is
+not testing a label, but a value, which is what the script will get back
+eventually: labels are there for human consumption only.
+
+=back
+
+=head2 Widget Classification Predicates
+
+There is an additional predicate to distinguish between a popup menu (single
+selection mandatory) from a scrolling list (multiple selection allowed, and
+may select nothing).
+
+=over 4
+
+=item C<is_popup>
+
+Returns I<true> for a popup menu.
+
+=back
+
+=head2 Miscellaneous Features
+
+Although documented, those features are more targetted for
+internal use...
+
+=over 4
+
+=item C<set_selected> I<value>, I<flag>
+
+Change the selection status of an option I<value>.
+
+You should use the C<select> and C<unselect> convenience routines instead
+of calling this feature.
+
+=back
+
+=head1 WEBSITE
+
+You can find information about CGI::Test and other related modules at:
+
+ http://cgi-test.sourceforge.net
+
+=head1 PUBLIC CVS SERVER
+
+CGI::Test now has a publicly accessible CVS server provided by
+SourceForge (www.sourceforge.net). You can access it by going to:
+
+ http://sourceforge.net/cvs/?group_id=89570
+
+=head1 AUTHORS
+
+The original author is Raphael Manfredi F<E<lt>Raphael_Manfredi at pobox.comE<gt>>.
+
+Send bug reports, hints, tips, suggestions to Steven Hilton at <mshiltonj at mshiltonj.com>
+
+=head1 SEE ALSO
+
+CGI::Test::Form::Widget(3),
+CGI::Test::Form::Widget::Menu::List(3),
+CGI::Test::Form::Widget::Menu::Popup(3).
+
+=cut
+
diff --git a/lib/CGI/Test/Form/Widget/Menu/List.pm b/lib/CGI/Test/Form/Widget/Menu/List.pm
new file mode 100644
index 0000000..1e57860
--- /dev/null
+++ b/lib/CGI/Test/Form/Widget/Menu/List.pm
@@ -0,0 +1,144 @@
+package CGI::Test::Form::Widget::Menu::List;
+use strict;
+##################################################################
+# $Id: List.pm 411 2011-09-26 11:19:30Z nohuhu at nohuhu.org $
+# $Name: cgi-test_0-104_t1 $
+##################################################################
+#
+# Copyright (c) 2001, Raphael Manfredi
+#
+# You may redistribute only under the terms of the Artistic License,
+# as specified in the README file that comes with the distribution.
+
+#
+# This class models a FORM scrollable list.
+#
+
+use CGI::Test::Form::Widget::Menu;
+use base qw(CGI::Test::Form::Widget::Menu);
+
+use Log::Agent;
+
+#
+# %attr
+#
+# Defines which HTML attributes we should look at within the node, and how
+# to translate that into class attributes.
+#
+
+my %attr = ('name' => 'name',
+ 'size' => 'size',
+ 'multiple' => 'multiple',
+ 'disabled' => 'is_disabled',
+ );
+
+#
+# ->_init
+#
+# Per-widget initialization routine.
+# Parse HTML node to determine our specific parameters.
+#
+sub _init
+{
+ my $this = shift;
+ my ($node) = shift;
+ $this->_parse_attr($node, \%attr);
+ $this->_parse_options($node);
+ return;
+}
+
+#
+# ->submit_tuples -- redefined
+#
+# Returns list of (name => value) tuples that should be part of the
+# submitted form data.
+#
+sub submit_tuples
+{
+ my $this = shift;
+
+ return map {$this->name => $_} keys %{$this->selected()};
+}
+
+#
+# Attribute access
+#
+
+sub size
+{
+ my $this = shift;
+ return $this->{size};
+}
+
+sub gui_type
+{
+ "scrolling list"
+}
+
+#
+# Defined predicates
+#
+
+sub is_popup
+{
+ return 0;
+}
+
+1;
+
+=head1 NAME
+
+CGI::Test::Form::Widget::Menu::List - A scrolling list menu
+
+=head1 SYNOPSIS
+
+ # Inherits from CGI::Test::Form::Widget::Menu
+ # $form is a CGI::Test::Form
+
+ my $action = $form->menu_by_name("action");
+ $action->unselect("allow-gracetime");
+ $action->select("reboot");
+
+=head1 DESCRIPTION
+
+This class models a scrolling list menu, from which items may be selected
+and unselected.
+
+=head1 INTERFACE
+
+The interface is the same as the one described in
+L<CGI::Test::Form::Widget::Menu>, with the following additional attribute:
+
+=over 4
+
+=item C<size>
+
+The amount of choices displayed.
+
+=back
+
+=head1 WEBSITE
+
+You can find information about CGI::Test and other related modules at:
+
+ http://cgi-test.sourceforge.net
+
+=head1 PUBLIC CVS SERVER
+
+CGI::Test now has a publicly accessible CVS server provided by
+SourceForge (www.sourceforge.net). You can access it by going to:
+
+ http://sourceforge.net/cvs/?group_id=89570
+
+=head1 AUTHORS
+
+The original author is Raphael Manfredi F<E<lt>Raphael_Manfredi at pobox.comE<gt>>.
+
+Send bug reports, hints, tips, suggestions to Steven Hilton at <mshiltonj at mshiltonj.com>
+
+=head1 SEE ALSO
+
+CGI::Test::Form::Widget::Menu(3).
+
+=cut
+
diff --git a/lib/CGI/Test/Form/Widget/Menu/Popup.pm b/lib/CGI/Test/Form/Widget/Menu/Popup.pm
new file mode 100644
index 0000000..c87a318
--- /dev/null
+++ b/lib/CGI/Test/Form/Widget/Menu/Popup.pm
@@ -0,0 +1,138 @@
+package CGI::Test::Form::Widget::Menu::Popup;
+use strict;
+##################################################################
+# $Id: Popup.pm 411 2011-09-26 11:19:30Z nohuhu at nohuhu.org $
+# $Name: cgi-test_0-104_t1 $
+##################################################################
+#
+# Copyright (c) 2001, Raphael Manfredi
+#
+# You may redistribute only under the terms of the Artistic License,
+# as specified in the README file that comes with the distribution.
+#
+
+#
+# This class models a FORM popup menu.
+#
+
+use CGI::Test::Form::Widget::Menu;
+use base qw(CGI::Test::Form::Widget::Menu);
+
+use Log::Agent;
+
+#
+# %attr
+#
+# Defines which HTML attributes we should look at within the node, and how
+# to translate that into class attributes.
+#
+
+my %attr = ('name' => 'name',
+ 'disabled' => 'is_disabled',);
+
+#
+# ->_init
+#
+# Per-widget initialization routine.
+# Parse HTML node to determine our specific parameters.
+#
+sub _init
+{
+ my $this = shift;
+ my ($node) = shift;
+ $this->_parse_attr($node, \%attr);
+ $this->_parse_options($node);
+ return;
+}
+
+#
+# ->set_selected -- redefined
+#
+# Change "selected" status for a menu value.
+# We can only "select" values from a popup, never unselect one.
+#
+sub set_selected
+{
+ my $this = shift;
+ my ($value, $state) = @_;
+
+ unless ($state)
+ {
+ logcarp "cannot unselect value \"%s\" from popup $this", $value;
+ return;
+ }
+
+ return $this->SUPER::set_selected($value, $state);
+}
+
+#
+# Attribute access
+#
+
+sub gui_type
+{
+ return "popup menu";
+}
+
+#
+# Defined predicates
+#
+
+sub is_popup
+{
+ return 1;
+}
+
+1;
+
+=head1 NAME
+
+CGI::Test::Form::Widget::Menu::Popup - A popup menu
+
+=head1 SYNOPSIS
+
+ # Inherits from CGI::Test::Form::Widget::Menu
+ # $form is a CGI::Test::Form
+
+ my $action = $form->menu_by_name("action");
+ $action->select("reboot");
+
+=head1 DESCRIPTION
+
+This class models a popup menu, from which one item at most may be selected,
+and for which there is at least one item selected, i.e. where exactly one
+item is chosen.
+
+If no item was explicitely selected, C<CGI::Test> arbitrarily chooses the
+first item in the popup (if not empty) and warns you via C<logwarn>.
+
+=head1 INTERFACE
+
+The interface is the same as the one described in
+L<CGI::Test::Form::Widget::Menu>.
+
+=head1 WEBSITE
+
+You can find information about CGI::Test and other related modules at:
+
+ http://cgi-test.sourceforge.net
+
+=head1 PUBLIC CVS SERVER
+
+CGI::Test now has a publicly accessible CVS server provided by
+SourceForge (www.sourceforge.net). You can access it by going to:
+
+ http://sourceforge.net/cvs/?group_id=89570
+
+=head1 AUTHORS
+
+The original author is Raphael Manfredi F<E<lt>Raphael_Manfredi at pobox.comE<gt>>.
+
+Send bug reports, hints, tips, suggestions to Steven Hilton at <mshiltonj at mshiltonj.com>
+
+=head1 SEE ALSO
+
+CGI::Test::Form::Widget::Menu(3).
+
+=cut
+
diff --git a/lib/CGI/Test/Input.pm b/lib/CGI/Test/Input.pm
new file mode 100644
index 0000000..8a2fcc1
--- /dev/null
+++ b/lib/CGI/Test/Input.pm
@@ -0,0 +1,395 @@
+package CGI::Test::Input;
+use strict;
+####################################################################
+# $Id: Input.pm 411 2011-09-26 11:19:30Z nohuhu at nohuhu.org $
+# $Name: cgi-test_0-104_t1 $
+#####################################################################
+#
+# Copyright (c) 2001, Raphael Manfredi
+#
+# You may redistribute only under the terms of the Artistic License,
+# as specified in the README file that comes with the distribution.
+#
+
+#
+# Abstract representation of the POST input data, which is a list of incoming
+# parameters that can be encoded differently.
+#
+
+use Carp;
+use Log::Agent;
+
+############################################################
+#
+# ->new
+#
+# Creation routine
+#
+############################################################
+sub new
+{
+ logconfess "deferred";
+}
+
+############################################################
+#
+# ->_init
+#
+# Initialization of common attributes
+#
+############################################################
+sub _init
+{
+ my $this = shift;
+ $this->{stale} = 0;
+ $this->{fields} = []; # list of [name, value]
+ $this->{files} = []; # list of [name, value, content or undef]
+ $this->{length} = 0;
+ $this->{data} = '';
+ return;
+}
+
+#
+# Attribute access
+#
+
+############################################################
+sub _stale
+{
+ my $this = shift;
+ $this->{stale};
+}
+############################################################
+sub _fields
+{
+ my $this = shift;
+ $this->{fields};
+}
+############################################################
+sub _files
+{
+ my $this = shift;
+ $this->{files};
+}
+############################################################
+sub length
+{
+ my $this = shift;
+ $this->_refresh() if $this->_stale();
+ $this->{length};
+}
+############################################################
+sub data
+{
+ my $this = shift;
+ $this->_refresh() if $this->_stale();
+ $this->{data};
+}
+
+############################################################
+#
+# ->add_widget
+#
+# Add new input widget.
+#
+# This routine is called to build input data for POST requests issued in
+# response to a submit button being pressed.
+#
+############################################################
+sub add_widget
+{
+ my $this = shift;
+ my ($w) = @_;
+
+ #
+ # Appart from the fact that file widgets get inserted in a dedicated list,
+ # the processing here is the same. The 3rd value of the entry for files
+ # will be undefined, meaning the file will be read at a later time, when
+ # the input data is built.
+ #
+
+ my @tuples = $w->submit_tuples;
+ my $array = $w->is_file ? $this->_files : $this->_fields;
+
+ while (my ($name, $value) = splice @tuples, 0, 2)
+ {
+ $value = '' unless defined $value;
+ push @$array, [ $name, $value ];
+ }
+
+ $this->{stale} = 1;
+
+ return;
+}
+
+############################################################
+#
+# ->add_field
+#
+# Add a new name/value pair to the input data.
+#
+# This routine is meant for manual input data building.
+#
+############################################################
+sub add_field
+{
+ my $this = shift;
+ my ($name, $value) = @_;
+
+ $value = '' unless defined $value;
+ push @{$this->_fields}, [ $name, $value ];
+ $this->{stale} = 1;
+
+ return;
+}
+
+############################################################
+#
+# ->add_file
+#
+# Add a new upload-file information to the input data.
+# The actual reading of the file is deferred up to the moment where we
+# need to build the input data.
+#
+# This routine is meant for manual input data building.
+#
+############################################################
+sub add_file
+{
+ my $this = shift;
+ my ($name, $value) = @_;
+
+ $value = '' unless defined $value;
+ push @{$this->_files}, [ $name, $value ];
+ $this->{stale} = 1;
+
+ return;
+}
+
+############################################################
+#
+# ->add_file_now
+#
+# Add a new upload-file information to the input data.
+# The file is read immediately, and can be disposed of once we return.
+#
+# This routine is meant for manual input data building.
+#
+############################################################
+sub add_file_now
+{
+ my $this = shift;
+ my ($name, $value) = @_;
+
+ croak "unreadable file '$value'" unless -r $value;
+
+ local *FILE;
+ open(FILE, $value);
+ binmode FILE;
+
+ local $_;
+ my $content = '';
+
+ while (<FILE>)
+ {
+ $content .= $_;
+ }
+ close FILE;
+
+ push @{$this->_files}, [ $name, $value, $content ];
+ $this->{stale} = 1;
+
+ return;
+}
+
+#
+# Interface to be implemented by heirs
+#
+
+############################################################
+sub mime_type
+{
+ logconfess "deferred";
+}
+############################################################
+sub _build_data
+{
+ logconfess "deferred";
+}
+
+#
+# Internal routines
+#
+
+############################################################
+#
+# ->_refresh
+#
+# Recomputes `data' and `length' attributes when stale
+#
+############################################################
+sub _refresh
+{
+ my $this = shift;
+
+ # internal pre-condition
+
+ my $data = $this->_build_data; # deferred
+
+ $this->{data} = $data;
+ $this->{length} = CORE::length $data;
+ $this->{stale} = 0;
+
+ return;
+}
+
+1;
+
+=head1 NAME
+
+CGI::Test::Input - Abstract representation of POST input
+
+=head1 SYNOPSIS
+
+ # Deferred class, only heirs can be created
+ # $input holds a CGI::Test::Input object
+
+ $input->add_widget($w); # done internally for you
+
+ $input->add_field("name", "value"); # manual input construction
+ $input->add_file("name", "path"); # deferred reading
+ $input->add_file_now("name", "/tmp/path"); # read file immediately
+
+ syswrite INPUT, $input->data, $input->length; # if you really have to
+
+ # $test is a CGI::Test object
+ $test->POST("http://server:70/cgi-bin/script", $input);
+
+=head1 DESCRIPTION
+
+The C<CGI::Test::Input> class is deferred. It is an abstract representation
+of HTTP POST request input, as expected by the C<POST> routine of C<CGI::Test>.
+
+Unless you wish to issue a C<POST> request manually to provide carefully
+crafted input, you do not need to learn the interface of this hierarchy,
+nor even bother knowing about it.
+
+Otherwise, you need to decide which MIME encoding you want, and create an
+object of the appropriate type. Note that file uploading requires the use
+of the C<multipart/form-data> encoding:
+
+ MIME Encoding Type to Create
+ --------------------------------- ---------------------------
+ application/x-www-form-urlencoded CGI::Test::Input::URL
+ multipart/form-data CGI::Test::Input::Multipart
+
+Once the object is created, you will be able to add name/value tuples
+corresponding to the CGI parameters to submit.
+
+For instance:
+
+ my $input = CGI::Test::Input::Multipart->new();
+ $input->add_field("login", "ram");
+ $input->add_field("password", "foobar");
+ $input->add_file("organization", "/etc/news/organization");
+
+Then, to inspect what is normally sent to the HTTP server:
+
+ print "Content-Type: ", $input->mime_type, "\015\012";
+ print "Content-Length: ", $input->length, "\015\012";
+ print "\015\012";
+ print $input->data;
+
+But usually you'll hand out the $input object to the C<POST> routine
+of C<CGI::Test>.
+
+=head1 INTERFACE
+
+=head2 Creation Routine
+
+It is called C<new> as usual. All subclasses have
+the same creation routine signature, which takes no parameter.
+
+=head2 Adding Parameters
+
+CGI parameter are name/value tuples. In case of file uploads, they can have
+a content as well, the value being the file path on the client machine.
+
+=over 4
+
+=item C<add_field> I<name>, I<value>
+
+Adds the CGI parameter I<name>, whose value is I<value>.
+
+=item add_file I<name>, I<path>
+
+Adds the file upload parameter I<name>, located at I<path>.
+
+The file is not read immediately, so it must remain available until
+the I<data> routine is called, at least. It is not an error if the file
+cannot be read at that time.
+
+When not using the C<multipart/form-data> encoding, only the name/path
+tuple will be transmitted to the script.
+
+=item add_file_now I<name>, I<path>
+
+Same as C<add_file>, but the file is immediately read and can therefore
+be disposed of afterwards. However, the file B<must> exist.
+
+=item add_widget I<widget>
+
+Add any widget, i.e. a C<CGI::Test::Form::Widget> object. This routine
+is called internally by C<CGI::Test> to construct the input data when
+submiting a form via POST.
+
+=back
+
+=head2 Generation
+
+=over 4
+
+=item C<data>
+
+Returns the data, under the proper encoding.
+
+=item C<mime_type>
+
+Returns the proper MIME encoding type, suitable for inclusion within
+a Content-Type header.
+
+=item C<length>
+
+Returns the data length.
+
+=back
+
+=head1 BUGS
+
+Please let me know about them.
+
+=head1 WEBSITE
+
+You can find information about CGI::Test and other related modules at:
+
+ http://cgi-test.sourceforge.net
+
+=head1 PUBLIC CVS SERVER
+
+CGI::Test now has a publicly accessible CVS server provided by
+SourceForge (www.sourceforge.net). You can access it by going to:
+
+ http://sourceforge.net/cvs/?group_id=89570
+
+=head1 AUTHORS
+
+The original author is Raphael Manfredi F<E<lt>Raphael_Manfredi at pobox.comE<gt>>.
+
+Send bug reports, hints, tips, suggestions to Steven Hilton at <mshiltonj at mshiltonj.com>
+
+=head1 SEE ALSO
+
+CGI::Test(3), CGI::Test::Input::URL(3), CGI::Test::Input::Multipart(3).
+
+=cut
+
diff --git a/lib/CGI/Test/Input/Multipart.pm b/lib/CGI/Test/Input/Multipart.pm
new file mode 100644
index 0000000..23c7e3d
--- /dev/null
+++ b/lib/CGI/Test/Input/Multipart.pm
@@ -0,0 +1,167 @@
+package CGI::Test::Input::Multipart;
+use strict;
+####################################################################
+# $Id: Multipart.pm 411 2011-09-26 11:19:30Z nohuhu at nohuhu.org $
+# $Name: cgi-test_0-104_t1 $
+####################################################################
+#
+# Copyright (c) 2001, Raphael Manfredi
+#
+# You may redistribute only under the terms of the Artistic License,
+# as specified in the README file that comes with the distribution.
+#
+
+#
+# POST input data to be encoded with "multipart/form-data".
+#
+
+use CGI::Test::Input;
+use base qw(CGI::Test::Input);
+
+use Log::Agent;
+
+#
+# ->new
+#
+# Creation routine
+#
+sub new
+{
+ my $this = bless {}, shift;
+ $this->_init;
+ $this->{boundary} =
+ "-------------cgi-test--------------"
+ . int(rand(1 << 31)) . '-'
+ . int(rand(1 << 31));
+ return $this;
+}
+
+# DEPRECATED METHOD
+sub make
+{ #
+ my $class = shift;
+ return $class->new(@_);
+}
+
+#
+# Attribute access
+#
+
+sub boundary
+{
+ my $this = shift;
+ return $this->{boundary};
+}
+
+#
+# Defined interface
+#
+
+sub mime_type
+{
+ my $this = shift;
+ "multipart/form-data; boundary=" . $this->boundary();
+}
+
+#
+# ->_build_data
+#
+# Rebuild data buffer from input fields.
+#
+sub _build_data
+{
+ my $this = shift;
+
+ my $CRLF = "\015\012";
+ my $data = '';
+ my $fmt = 'Content-Disposition: form-data; name="%s"';
+ my $boundary = "--" . $this->boundary(); # With extra "--" per MIME specs
+
+ # XXX field name encoding of special chars?
+ # XXX does not escape "" in filenames
+
+ foreach my $tuple (@{$this->_fields()})
+ {
+ my ($name, $value) = @$tuple;
+ $data .= $boundary . $CRLF;
+ $data .= sprintf($fmt, $name) . $CRLF . $CRLF;
+ $data .= $value . $CRLF;
+ }
+
+ foreach my $tuple (@{$this->_files()})
+ {
+ my ($name, $value, $content) = @$tuple;
+ $data .= $boundary . $CRLF;
+ $data .= sprintf($fmt, $name);
+ $data .= sprintf('; filename="%s"', $value) . $CRLF;
+ $data .= "Content-Type: application/octet-stream" . $CRLF . $CRLF;
+ if (defined $content)
+ {
+ $data .= $content;
+ }
+ else
+ {
+ local *FILE;
+ if (open(FILE, $value))
+ { # Might not exist, but that's OK
+ binmode FILE;
+ local $_;
+ while (<FILE>)
+ {
+ $data .= $_;
+ }
+ close FILE;
+ }
+ }
+ }
+
+ $data .= $boundary . $CRLF;
+
+ return $data;
+}
+
+1;
+
+=head1 NAME
+
+CGI::Test::Input::Multipart - POST input encoded as multipart/form-data
+
+=head1 SYNOPSIS
+
+ # Inherits from CGI::Test::Input
+ require CGI::Test::Input::Multipart;
+
+ my $input = CGI::Test::Input::Multipart->new();
+
+=head1 DESCRIPTION
+
+This class represents the input for HTTP POST requests, encoded
+as C<multipart/form-data>.
+
+Please see L<CGI::Test::Input> for interface details.
+
+=head1 WEBSITE
+
+You can find information about CGI::Test and other related modules at:
+
+ http://cgi-test.sourceforge.net
+
+=head1 PUBLIC CVS SERVER
+
+CGI::Test now has a publicly accessible CVS server provided by
+SourceForge (www.sourceforge.net). You can access it by going to:
+
+ http://sourceforge.net/cvs/?group_id=89570
+
+=head1 AUTHORS
+
+The original author is Raphael Manfredi F<E<lt>Raphael_Manfredi at pobox.comE<gt>>.
+
+Send bug reports, hints, tips, suggestions to Steven Hilton at <mshiltonj at mshiltonj.com>
+
+=head1 SEE ALSO
+
+CGI::Test::Input(3).
+
+=cut
+
diff --git a/lib/CGI/Test/Input/URL.pm b/lib/CGI/Test/Input/URL.pm
new file mode 100644
index 0000000..87fcbcb
--- /dev/null
+++ b/lib/CGI/Test/Input/URL.pm
@@ -0,0 +1,125 @@
+package CGI::Test::Input::URL;
+use strict;
+####################################################################
+# $Id: URL.pm 411 2011-09-26 11:19:30Z nohuhu at nohuhu.org $
+# $Name: cgi-test_0-104_t1 $
+####################################################################
+#
+# Copyright (c) 2001, Raphael Manfredi
+#
+# You may redistribute only under the terms of the Artistic License,
+# as specified in the README file that comes with the distribution.
+#
+#
+# POST input data to be encoded with "application/x-www-form-urlencoded".
+#
+
+require CGI::Test::Input;
+use base qw(CGI::Test::Input);
+
+use Log::Agent;
+
+#
+# ->new
+#
+# Creation routine
+#
+sub new
+{
+ my $this = bless {}, shift;
+ $this->_init;
+ return $this;
+}
+
+# DEPRECATED
+sub make
+{ #
+ my $class = shift;
+ return $class->new(@_);
+}
+
+#
+# Defined interface
+#
+
+sub mime_type
+{
+ return "application/x-www-form-urlencoded";
+}
+
+#
+# ->_build_data
+#
+# Rebuild data buffer from input fields.
+#
+sub _build_data
+{
+ my $this = shift;
+
+ #
+ # Note that file uploading fields get handled as any other field, meaning
+ # only the file path will be transmitted.
+ #
+
+ my $data = '';
+
+ # XXX field name encoding of special chars is the same as data?
+
+ foreach my $tuple (@{$this->_fields()}, @{$this->_files()})
+ {
+ my ($name, $value) = @$tuple;
+ $value =~ s/([^a-zA-Z0-9_. -])/uc sprintf("%%%02x",ord($1))/eg;
+ $value =~ s/ /+/g;
+ $name =~ s/([^a-zA-Z0-9_.-])/uc sprintf("%%%02x",ord($1))/eg;
+ $data .= '&' if length $data;
+ $data .= $name . '=' . $value;
+ }
+
+ return $data;
+}
+
+1;
+
+=head1 NAME
+
+CGI::Test::Input::URL - POST input encoded as application/x-www-form-urlencoded
+
+=head1 SYNOPSIS
+
+ # Inherits from CGI::Test::Input
+ require CGI::Test::Input::URL;
+
+ my $input = CGI::Test::Input::URL->new();
+
+=head1 DESCRIPTION
+
+This class represents the input for HTTP POST requests, encoded
+as C<application/x-www-form-urlencoded>.
+
+Please see L<CGI::Test::Input> for interface details.
+
+=head1 WEBSITE
+
+You can find information about CGI::Test and other related modules at:
+
+ http://cgi-test.sourceforge.net
+
+=head1 PUBLIC CVS SERVER
+
+CGI::Test now has a publicly accessible CVS server provided by
+SourceForge (www.sourceforge.net). You can access it by going to:
+
+ http://sourceforge.net/cvs/?group_id=89570
+
+=head1 AUTHORS
+
+The original author is Raphael Manfredi F<E<lt>Raphael_Manfredi at pobox.comE<gt>>.
+
+Send bug reports, hints, tips, suggestions to Steven Hilton at <mshiltonj at mshiltonj.com>
+
+=head1 SEE ALSO
+
+CGI::Test::Input(3).
+
+=cut
+
diff --git a/lib/CGI/Test/Page.pm b/lib/CGI/Test/Page.pm
new file mode 100644
index 0000000..205bd5d
--- /dev/null
+++ b/lib/CGI/Test/Page.pm
@@ -0,0 +1,251 @@
+package CGI::Test::Page;
+use strict;
+####################################################################
+# $Id: Page.pm 411 2011-09-26 11:19:30Z nohuhu at nohuhu.org $
+# $Name: cgi-test_0-104_t1 $
+####################################################################
+#
+# Copyright (c) 2001, Raphael Manfredi
+#
+# You may redistribute only under the terms of the Artistic License,
+# as specified in the README file that comes with the distribution.
+#
+
+#
+# An abstract representation of a page, returned by an HTTP request.
+# The page can be an error, or a real page, each with its own class hierarchy.
+#
+
+use Getargs::Long;
+use Log::Agent;
+######################################################################
+#
+# ->new
+#
+# Creation routine
+#
+######################################################################
+sub new
+{
+ logconfess "deferred";
+}
+
+#
+# Common attribute access
+#
+
+######################################################################
+sub content_type
+{
+ my $this = shift;
+ $this->{content_type};
+}
+
+######################################################################
+sub user
+{
+ my $this = shift;
+ $this->{user};
+}
+
+######################################################################
+sub server
+{
+ my $this = shift;
+ return $this->{server};
+}
+######################################################################
+
+#
+# Queries
+#
+
+######################################################################
+# Error code (0 = OK)
+######################################################################
+sub error_code
+{
+ 0
+}
+
+######################################################################
+# True if page indicates HTTP error
+######################################################################
+sub is_error
+{
+ 0
+}
+
+######################################################################
+sub form_count
+{
+ 0
+}
+
+######################################################################
+sub is_ok
+{
+ my $this = shift;
+ return !$this->is_error;
+}
+
+######################################################################
+#
+# ->forms
+#
+# Returns list ref of CGI::Test::Form objects, one per <FORM></FORM> in the
+# document. The order is the same as the one in the raw document.
+#
+# Meant to be redefined in CGI::Test::Page::HTML.
+#
+######################################################################
+sub forms
+{
+ my $this = shift;
+ return [];
+}
+
+######################################################################
+#
+# ->delete
+#
+# Done with this page, cleanup by breaking circular refs.
+#
+######################################################################
+sub delete
+{
+ my $this = shift;
+ $this->{server} = undef;
+ return;
+}
+
+1;
+
+=head1 NAME
+
+CGI::Test::Page - Abstract represention of an HTTP reply content
+
+=head1 SYNOPSIS
+
+ # Deferred class, only heirs can be created
+ # $page holds a CGI::Test::Page object
+
+ use CGI::Test;
+
+ ok 1, $page->is_ok;
+ ok 2, $page->user ne ''; # authenticated access
+
+ my $ctype = $page->content_type;
+ ok 3, $ctype eq "text/plain";
+
+ $page->delete;
+
+=head1 DESCRIPTION
+
+The C<CGI::Test::Page> class is deferred. It is an abstract representation
+of an HTTP reply content, which would be displayed on a browser, as a page.
+It does not necessarily hold HTML content.
+
+Here is an outline of the class hierarchy tree, with the leading C<CGI::Test::>
+string stripped for readability, and a trailing C<*> indicating deferred
+clases:
+
+ Page*
+ Page::Error
+ Page::Real*
+ Page::HTML
+ Page::Other
+ Page::Text
+
+Those classes are constructed as needed by C<CGI::Test>. You must always
+call I<delete> on them to break the circular references if you care about
+reclaiming unused memory.
+
+=head1 INTERFACE
+
+This is the interface defined at the C<CGI::Test::Page> level.
+Each subclass may add further specific features, but the following is
+available to the whole hierarchy:
+
+=over 4
+
+=item C<content_type>
+
+The MIME content type, along with parameters, as it appeared in the headers.
+For instance, it can be:
+
+ text/html; charset=ISO-8859-1
+
+Don't assume it to be just C<text/html> though. Use something like:
+
+ ok 1, $page->content_type =~ m|^text/html\b|;
+
+in your regression tests, which will match whether there are parameters
+following the content type or not.
+
+=item C<delete>
+
+Breaks circular references to allow proper reclaiming of unused memory.
+Must be the last thing to call on the object before forgetting about it.
+
+=item C<error_code>
+
+The error code. Will be 0 to mean OK, but otherwise HTTP error codes
+are used, as described by L<HTTP::Status>.
+
+=item C<forms>
+
+Returns a list reference containing all the CGI forms on the page,
+as C<CGI::Test::Form> objects. Will be an empty list for anything
+but C<CGI::Test::Page::HTML>, naturally.
+
+=item C<form_count>
+
+The amount of forms held in the C<forms> list.
+
+=item C<is_error>
+
+Returns I<true> when the page indicates an HTTP error.
+
+=item C<is_ok>
+
+Returns I<true> when the page is not the result of an HTTP error.
+
+=item C<server>
+
+Returns the server object that returned the page. Currently, this is
+the C<CGI::Test> object, but it might change one day. In any case, this
+is the place where GET/POST requests may be addresed.
+
+=item C<user>
+
+The authenticated user that requested this page, or C<undef> if no
+authentication was made.
+
+=back
+
+=head1 WEBSITE
+
+You can find information about CGI::Test and other related modules at:
+
+ http://cgi-test.sourceforge.net
+
+=head1 PUBLIC CVS SERVER
+
+CGI::Test now has a publicly accessible CVS server provided by
+SourceForge (www.sourceforge.net). You can access it by going to:
+
+ http://sourceforge.net/cvs/?group_id=89570
+
+=head1 AUTHORS
+
+The original author is Raphael Manfredi F<E<lt>Raphael_Manfredi at pobox.comE<gt>>.
+
+Send bug reports, hints, tips, suggestions to Steven Hilton at <mshiltonj at mshiltonj.com>
+
+=head1 SEE ALSO
+
+CGI::Test::Page::Error(3), CGI::Test::Page::Real(3).
+
+=cut
+
diff --git a/lib/CGI/Test/Page/Error.pm b/lib/CGI/Test/Page/Error.pm
new file mode 100644
index 0000000..c6050aa
--- /dev/null
+++ b/lib/CGI/Test/Page/Error.pm
@@ -0,0 +1,102 @@
+package CGI::Test::Page::Error;
+use strict;
+####################################################################
+# $Id: Error.pm 411 2011-09-26 11:19:30Z nohuhu at nohuhu.org $
+# $Name: cgi-test_0-104_t1 $
+####################################################################
+#
+# Copyright (c) 2001, Raphael Manfredi
+#
+# You may redistribute only under the terms of the Artistic License,
+# as specified in the README file that comes with the distribution.
+
+#
+# A reply to an HTTP request resulted in an error.
+#
+
+use Getargs::Long;
+
+require CGI::Test::Page;
+use base qw(CGI::Test::Page);
+
+############################################################
+#
+# ->new
+#
+# Creation routine
+#
+############################################################
+sub new
+{
+ my $this = bless {}, shift;
+ my ($errcode, $server) = @_;
+ $this->{error_code} = $errcode;
+ $this->{server} = $server;
+ return $this;
+}
+
+#
+# Attribute access
+#
+
+############################################################
+sub error_code
+{
+ my $this = shift;
+ return $this->{error_code};
+} # redefined as attribute
+
+#
+# Redefined features
+#
+############################################################
+sub is_error
+{
+ return 1;
+}
+############################################################
+sub content_type
+{
+ return "text/html";
+}
+
+1;
+
+=head1 NAME
+
+CGI::Test::Page::Error - An HTTP error page
+
+=head1 SYNOPSIS
+
+ # Inherits from CGI::Test::Page
+
+=head1 DESCRIPTION
+
+This class represents an HTTP error page.
+Its interface is the same as the one described in L<CGI::Test::Page>.
+
+=head1 WEBSITE
+
+You can find information about CGI::Test and other related modules at:
+
+ http://cgi-test.sourceforge.net
+
+=head1 PUBLIC CVS SERVER
+
+CGI::Test now has a publicly accessible CVS server provided by
+SourceForge (www.sourceforge.net). You can access it by going to:
+
+ http://sourceforge.net/cvs/?group_id=89570
+
+=head1 AUTHORS
+
+The original author is Raphael Manfredi F<E<lt>Raphael_Manfredi at pobox.comE<gt>>.
+
+Send bug reports, hints, tips, suggestions to Steven Hilton at <mshiltonj at mshiltonj.com>
+
+=head1 SEE ALSO
+
+CGI::Test::Page(3), CGI::Test::Page::Real(3).
+
+=cut
+
diff --git a/lib/CGI/Test/Page/HTML.pm b/lib/CGI/Test/Page/HTML.pm
new file mode 100644
index 0000000..a0aeea3
--- /dev/null
+++ b/lib/CGI/Test/Page/HTML.pm
@@ -0,0 +1,205 @@
+package CGI::Test::Page::HTML;
+use strict;
+####################################################################
+# $Id: HTML.pm 411 2011-09-26 11:19:30Z nohuhu at nohuhu.org $
+# $Name: cgi-test_0-104_t1 $
+####################################################################
+#
+# Copyright (c) 2001, Raphael Manfredi
+#
+# You may redistribute only under the terms of the Artistic License,
+# as specified in the README file that comes with the distribution.
+
+use Getargs::Long;
+
+require CGI::Test::Page::Real;
+use base qw(CGI::Test::Page::Real);
+
+#
+# ->new
+#
+# Creation routine
+#
+sub new
+{
+ my $this = bless {}, shift;
+ $this->_init(@_);
+ return $this;
+}
+
+#
+# Attribute access
+#
+
+sub tree
+{
+ my $this = shift;
+ return $this->{tree} || $this->_build_tree();
+}
+
+sub forms
+{
+ my $this = shift;
+ return $this->{forms} || $this->_xtract_forms();
+}
+
+sub form_count
+{
+ my $this = shift;
+ $this->_xtract_forms() unless exists $this->{form_count};
+ return $this->{form_count};
+}
+
+#
+# ->_build_tree
+#
+# Parse HTML content from `raw_content' into an HTML tree.
+# Only called the first time an access to `tree' is requested.
+#
+# Returns constructed tree object.
+#
+sub _build_tree
+{
+ my $this = shift;
+
+ require HTML::TreeBuilder;
+
+ my $tree = HTML::TreeBuilder->new();
+ $tree->ignore_unknown(0); # Keep everything, even unknown tags
+ $tree->store_comments(1); # Useful things may hide in "comments"
+ $tree->store_declarations(1); # Store everything that we may test
+ $tree->store_pis(1); # Idem
+ $tree->warn(1); # We want to know if there's a problem
+
+ $tree->parse($this->raw_content);
+ $tree->eof;
+
+ return $this->{tree} = $tree;
+}
+
+#
+# _xtract_forms
+#
+# Extract <FORMS> tags out of the tree, and for each form, build a
+# CGI::Test::Form object that represents it.
+# Only called the first time an access to `forms' is requested.
+#
+# Side effect: updates the `forms' and `form_count' attributes.
+#
+# Returns list ref of objects, in the order they were found.
+#
+sub _xtract_forms
+{
+ my $this = shift;
+ my $tree = $this->tree;
+
+ require CGI::Test::Form;
+
+ #
+ # The CGI::Test::Form objects we're about to create will refer back to
+ # us, because they are conceptually part of this page. Besides, their
+ # HTML tree is a direct reference into our own tree.
+ #
+
+ my @forms = $tree->look_down(sub {$_[ 0 ]->tag eq "form"});
+ @forms = map {CGI::Test::Form->new($_, $this)} @forms;
+
+ $this->{form_count} = scalar @forms;
+ return $this->{forms} = \@forms;
+}
+
+#
+# ->delete
+#
+# Break circular references
+#
+sub delete
+{
+ my $this = shift;
+
+ #
+ # The following attributes are "lazy", i.e. calculated on demand.
+ # Therefore, take precautions before de-referencing them.
+ #
+
+ $this->{tree} = $this->{tree}->delete if ref $this->{tree};
+ if (ref $this->{forms})
+ {
+ foreach my $form (@{$this->{forms}})
+ {
+ $form->delete;
+ }
+ delete $this->{forms};
+ }
+
+ $this->SUPER::delete;
+ return;
+}
+
+#
+# (DESTROY)
+#
+# Dispose of HTML tree properly
+#
+sub DESTROY
+{
+ my $this = shift;
+ return unless ref $this->{tree};
+ $this->{tree} = $this->{tree}->delete;
+ return;
+}
+
+1;
+
+=head1 NAME
+
+CGI::Test::Page::HTML - A HTML page reply
+
+=head1 SYNOPSIS
+
+ # Inherits from CGI::Test::Page::Real
+
+=head1 DESCRIPTION
+
+This class represents an HTTP reply containing C<text/html> data.
+When testing CGI scripts, this is usually what one gets back.
+
+=head1 INTERFACE
+
+The interface is the same as the one described in L<CGI::Test::Page::Real>,
+with the following addition:
+
+=over 4
+
+=item C<tree>
+
+Returns the root of the HTML tree of the page content, as an
+HTML::Element node.
+
+=back
+
+=head1 WEBSITE
+
+You can find information about CGI::Test and other related modules at:
+
+ http://cgi-test.sourceforge.net
+
+=head1 PUBLIC CVS SERVER
+
+CGI::Test now has a publicly accessible CVS server provided by
+SourceForge (www.sourceforge.net). You can access it by going to:
+
+ http://sourceforge.net/cvs/?group_id=89570
+
+=head1 AUTHORS
+
+The original author is Raphael Manfredi F<E<lt>Raphael_Manfredi at pobox.comE<gt>>.
+
+Send bug reports, hints, tips, suggestions to Steven Hilton at <mshiltonj at mshiltonj.com>
+
+=head1 SEE ALSO
+
+CGI::Test::Page::Real(3), HTML::Element(3).
+
+=cut
+
diff --git a/lib/CGI/Test/Page/Other.pm b/lib/CGI/Test/Page/Other.pm
new file mode 100644
index 0000000..0715dbd
--- /dev/null
+++ b/lib/CGI/Test/Page/Other.pm
@@ -0,0 +1,71 @@
+package CGI::Test::Page::Other;
+use strict;
+####################################################################
+# $Id: Other.pm 411 2011-09-26 11:19:30Z nohuhu at nohuhu.org $
+# $Name: cgi-test_0-104_t1 $
+####################################################################
+#
+# Copyright (c) 2001, Raphael Manfredi
+#
+# You may redistribute only under the terms of the Artistic License,
+# as specified in the README file that comes with the distribution.
+#
+
+use Getargs::Long;
+
+require CGI::Test::Page::Real;
+use base qw(CGI::Test::Page::Real);
+
+#
+# ->new
+#
+# Creation routine
+#
+sub new
+{
+ my $this = bless {}, shift;
+ $this->_init(@_);
+ return $this;
+}
+
+1;
+
+=head1 NAME
+
+CGI::Test::Page::Other - A real page, but neither text nor HTML
+
+=head1 SYNOPSIS
+
+ # Inherits from CGI::Test::Page::Real
+
+=head1 DESCRIPTION
+
+This class represents an HTTP reply containing neither C<text/hmtl>
+nor C<text/plain> data.
+Its interface is the same as the one described in L<CGI::Test::Page::Real>.
+
+=head1 WEBSITE
+
+You can find information about CGI::Test and other related modules at:
+
+ http://cgi-test.sourceforge.net
+
+=head1 PUBLIC CVS SERVER
+
+CGI::Test now has a publicly accessible CVS server provided by
+SourceForge (www.sourceforge.net). You can access it by going to:
+
+ http://sourceforge.net/cvs/?group_id=89570
+
+=head1 AUTHORS
+
+The original author is Raphael Manfredi F<E<lt>Raphael_Manfredi at pobox.comE<gt>>.
+
+Send bug reports, hints, tips, suggestions to Steven Hilton at <mshiltonj at mshiltonj.com>
+
+=head1 SEE ALSO
+
+CGI::Test::Page::Real(3).
+
+=cut
+
diff --git a/lib/CGI/Test/Page/Real.pm b/lib/CGI/Test/Page/Real.pm
new file mode 100644
index 0000000..ec09d2d
--- /dev/null
+++ b/lib/CGI/Test/Page/Real.pm
@@ -0,0 +1,182 @@
+package CGI::Test::Page::Real;
+use strict;
+####################################################################
+# $Id: Real.pm 411 2011-09-26 11:19:30Z nohuhu at nohuhu.org $
+# $Name: cgi-test_0-104_t1 $
+####################################################################
+#
+# Copyright (c) 2001, Raphael Manfredi
+#
+# You may redistribute only under the terms of the Artistic License,
+# as specified in the README file that comes with the distribution.
+
+#
+# An abstract interface to a real page, which is the result of a valid output
+# and not an HTTP error. The concrete representation is defined by heirs,
+# depending on the Content-Type.
+#
+
+use Getargs::Long;
+use Log::Agent;
+
+require CGI::Test::Page;
+use base qw(CGI::Test::Page);
+
+#
+# ->new
+#
+# Creation routine
+#
+sub new
+{
+ logconfess "deferred";
+}
+
+#
+# Attribute access
+#
+
+sub raw_content
+{
+ my $this = shift;
+ return $this->{raw_content};
+}
+
+sub uri
+{
+ my $this = shift;
+ return $this->{uri};
+}
+
+sub raw_content_ref
+{
+ my $this = shift;
+ return \$this->{raw_content};
+}
+
+#
+# ->_init
+#
+# Initialize common attributes
+#
+sub _init
+{
+ my $this = shift;
+ my ($server, $file, $ctype, $user, $uri) = cxgetargs(
+ @_, {-strict => 0, -extra => 0},
+ -server => 'CGI::Test', # XXX may be extended one day
+ -file => 's',
+ -content_type => 's',
+ -user => undef,
+ -uri => 'URI',
+ );
+ $this->{server} = $server;
+ $this->{content_type} = $ctype;
+ $this->{user} = $user;
+ $this->{uri} = $uri;
+ $this->_read_raw_content($file);
+ return;
+}
+
+#
+# ->_read_raw_content
+#
+# Read file content verbatim into `raw_content', skipping header.
+#
+# Even in the case of an HTML content, reading the whole thing into memory
+# as a big happy string means we can issue regexp queries.
+#
+sub _read_raw_content
+{
+ my $this = shift;
+ my ($file) = @_;
+
+ local *FILE;
+ open(FILE, $file) || logdie "can't open $file: $!";
+ my $size = -s FILE;
+
+ $this->{raw_content} = ' ' x -s (FILE); # Pre-extend buffer
+
+ local $_;
+ while (<FILE>)
+ { # Skip header
+ last if /^\r?$/;
+ }
+
+ local $/ = undef; # Will slurp remaining
+ $this->{raw_content} = <FILE>;
+ close FILE;
+
+ return;
+}
+
+1;
+
+=head1 NAME
+
+CGI::Test::Page::Real - Abstract representation of a real page
+
+=head1 SYNOPSIS
+
+ # Inherits from CGI::Test::Page
+ # $page holds a CGI::Test::Page::Real object
+
+ use CGI::Test;
+
+ ok 1, $page->raw_content =~ /test is ok/;
+ ok 2, $page->uri->scheme eq "http";
+ ok 3, $page->content_type !~ /html/;
+
+=head1 DESCRIPTION
+
+This class is the representation of a real page, i.e. something physically
+returned by the server and which is not an error.
+
+=head1 INTERFACE
+
+The interface is the same as the one described in L<CGI::Test::Page>, with
+the following additions:
+
+=over 4
+
+=item C<raw_content>
+
+Returns the raw content of the page, as a string.
+
+=item C<raw_content_ref>
+
+Returns a reference to the raw content of the page, to avoid making yet
+another copy.
+
+=item C<uri>
+
+The URI object, identifying the page we requested.
+
+=back
+
+=head1 WEBSITE
+
+You can find information about CGI::Test and other related modules at:
+
+ http://cgi-test.sourceforge.net
+
+=head1 PUBLIC CVS SERVER
+
+CGI::Test now has a publicly accessible CVS server provided by
+SourceForge (www.sourceforge.net). You can access it by going to:
+
+ http://sourceforge.net/cvs/?group_id=89570
+
+=head1 AUTHORS
+
+The original author is Raphael Manfredi F<E<lt>Raphael_Manfredi at pobox.comE<gt>>.
+
+Send bug reports, hints, tips, suggestions to Steven Hilton at <mshiltonj at mshiltonj.com>
+
+=head1 SEE ALSO
+
+CGI::Test::Page(3), CGI::Test::Page::HTML(3), CGI::Test::Page::Other(3),
+CGI::Test::Page::Text(3), URI(3).
+
+=cut
+
diff --git a/lib/CGI/Test/Page/Text.pm b/lib/CGI/Test/Page/Text.pm
new file mode 100644
index 0000000..c518cc5
--- /dev/null
+++ b/lib/CGI/Test/Page/Text.pm
@@ -0,0 +1,74 @@
+package CGI::Test::Page::Text;
+use strict;
+####################################################################
+# $Id: Text.pm 411 2011-09-26 11:19:30Z nohuhu at nohuhu.org $
+# $Name: cgi-test_0-104_t1 $
+####################################################################
+#
+# Copyright (c) 2001, Raphael Manfredi
+#
+# You may redistribute only under the terms of the Artistic License,
+# as specified in the README file that comes with the distribution.
+#
+
+use Getargs::Long;
+
+use CGI::Test::Page::Real;
+use base qw(CGI::Test::Page::Real);
+
+#
+# ->new
+#
+# Creation routine
+#
+sub new
+{
+ my $this = bless {}, shift;
+ $this->_init(@_);
+ return $this;
+}
+
+#
+# Attribute access
+#
+
+1;
+
+=head1 NAME
+
+CGI::Test::Page::Text - A text page reply
+
+=head1 SYNOPSIS
+
+ # Inherits from CGI::Test::Page::Real
+
+=head1 DESCRIPTION
+
+This class represents an HTTP reply containing C<text/plain> data.
+Its interface is the same as the one described in L<CGI::Test::Page::Real>.
+
+=head1 WEBSITE
+
+You can find information about CGI::Test and other related modules at:
+
+ http://cgi-test.sourceforge.net
+
+=head1 PUBLIC CVS SERVER
+
+CGI::Test now has a publicly accessible CVS server provided by
+SourceForge (www.sourceforge.net). You can access it by going to:
+
+ http://sourceforge.net/cvs/?group_id=89570
+
+=head1 AUTHORS
+
+The original author is Raphael Manfredi F<E<lt>Raphael_Manfredi at pobox.comE<gt>>.
+
+Send bug reports, hints, tips, suggestions to Steven Hilton at <mshiltonj at mshiltonj.com>
+
+=head1 SEE ALSO
+
+CGI::Test::Page::Real(3).
+
+=cut
+
diff --git a/t/browse.pl b/t/browse.pl
new file mode 100644
index 0000000..9523c63
--- /dev/null
+++ b/t/browse.pl
@@ -0,0 +1,145 @@
+#
+# $Id: browse.pl,v 1.2 2003/09/29 11:00:50 mshiltonj Exp $
+#
+# Copyright (c) 2001, Raphael Manfredi
+#
+# You may redistribute only under the terms of the Artistic License,
+# as specified in the README file that comes with the distribution.
+#
+# HISTORY
+# $Log: browse.pl,v $
+# Revision 1.2 2003/09/29 11:00:50 mshiltonj
+# CGI::Test has changed ownership. The new owner is Steven Hilton
+# <mshiltonj at mshiltonj.com>. Many thanks to Raphael Manfredi
+# and Steve Fink.
+#
+# CGI::Test is now hosted as a SourceForge project. It is located
+# at <http://cgi-test.sourceforge.net>.
+#
+# POD updated to reflect the above.
+#
+# make() method on various objects has been deprecated, and has been
+# replaced by more conventional (for me, at least) new() method.
+# Support for make() may be removed in a later release.
+#
+# Entire codebase reformatted using perltidy
+# Go to <http://perltidy.sourceforge.net/> to see how neat it is.
+#
+# Self-referential object variable name standardized to '$this'
+# throughout code.
+#
+# Revision 1.1.1.1 2003/09/23 09:47:26 mshiltonj
+# Initial Import
+#
+# Revision 0.1.1.1 2001/04/17 11:25:18 ram
+# patch3: changed test 22 to perform explicit sorting
+#
+# Revision 0.1 2001/03/31 10:54:03 ram
+# Baseline for first Alpha release.
+#
+# $EndLog$
+#
+
+use CGI::Test;
+use Getargs::Long;
+
+sub browse {
+ my ($method, $enctype) = getargs(@_, [qw(method enctype)]);
+
+ print "1..27\n";
+
+ my $BASE = "http://server:18/cgi-bin";
+ my $ct = CGI::Test->new(
+ -base_url => $BASE,
+ -cgi_dir => "t/cgi",
+ );
+
+ my $query = "action=/cgi-bin/dumpargs";
+ $query .= "&method=$method" if defined $method;
+ $query .= "&enctype=$enctype" if defined $enctype;
+
+ my $page = $ct->GET("$BASE/getform?$query");
+ my $form = $page->forms->[0];
+
+ ok 1, $form->action eq "/cgi-bin/dumpargs";
+
+ my $submit = $form->submit_by_name("Send");
+ ok 2, defined $submit;
+
+ my $page2 = $submit->press;
+ ok 3, $page2->is_ok;
+
+ my $args = parse_args($page2->raw_content);
+ ok 4, $args->{counter} == 1;
+ ok 5, $args->{title} eq "Mr";
+ ok 6, $args->{name} eq "";
+ ok 7, $args->{skills} eq "listening";
+ ok 8, $args->{new} eq "ON";
+ ok 9, $args->{color} eq "white";
+ ok 10, $args->{note} eq "";
+ ok 11, $args->{months} eq "Jul";
+ ok 12, $args->{passwd} eq "";
+ ok 13, $args->{Send} eq "Send";
+ ok 14, $args->{portrait} eq "";
+
+ my $r = $form->radio_by_name("title");
+ $r->check_tagged("Miss");
+
+ my $m = $form->menu_by_name("months");
+ $m->select("Jan");
+ $m->select("Feb");
+ $m->unselect("Jul");
+
+ $m = $form->menu_by_name("color");
+ $m->select("red");
+
+ my $b = $form->checkbox_by_name("new");
+ $b->uncheck;
+
+ my $t = $form->input_by_name("portrait");
+ $t->replace("this is ix");
+ $t->append(", disappointed?");
+ $t->filter(sub { s/\bix\b/it/ });
+
+ $t = $form->input_by_name("passwd");
+ $t->append("bar");
+ $t->prepend("foo");
+
+ $t = $form->input_by_name("note");
+ $t->replace("this\nis\nsome\ntext");
+
+ $page2 = $submit->press;
+ my $args2 = parse_args($page2->raw_content);
+
+ ok 15, $args2->{counter} == 1;
+ ok 16, $args2->{title} eq "Miss";
+ ok 17, $args2->{name} eq "";
+ ok 18, $args2->{skills} eq "listening";
+ ok 19, !exists $args2->{new}; # unchecked, not submitted
+ ok 20, $args2->{color} eq "red";
+ ok 21, $args2->{note} eq "this is some text";
+ ok 22, join(" ", sort split(' ', $args2->{months})) eq "Feb Jan";
+ ok 23, $args2->{passwd} eq "foobar";
+ ok 24, $args2->{Send} eq "Send";
+ ok 25, $args2->{portrait} eq "this is it, disappointed?";
+
+ # Ensure we tested what was requested
+ $method = "GET" unless defined $method;
+ ok 26, $form->method eq $method;
+ ok 27, substr($form->enctype, 0, 5) eq
+ (defined $enctype ? "multi" : "appli");
+}
+
+# Rebuild parameter list from the output of dumpargs into a HASH
+sub parse_args {
+ my ($content) = @_;
+ my %params;
+ foreach my $line (split(/\r?\n/, $content)) {
+ my ($name, $values) = split(/\t/, $line);
+ $params{$name} = $values;
+ }
+ return \%params;
+}
+
+1;
+
diff --git a/t/cgi/dumpargs b/t/cgi/dumpargs
new file mode 100755
index 0000000..afb7e79
--- /dev/null
+++ b/t/cgi/dumpargs
@@ -0,0 +1,33 @@
+: # feed this into perl
+ eval 'exec perl -S $0 ${1+"$@"}'
+ if $running_under_some_shell;
+
+#
+# $Id: dumpargs,v 1.1.1.1 2003/09/23 09:47:26 mshiltonj Exp $
+#
+# Copyright (c) 2001, Raphael Manfredi
+#
+# You may redistribute only under the terms of the Artistic License,
+# as specified in the README file that comes with the distribution.
+#
+# HISTORY
+# $Log: dumpargs,v $
+# Revision 1.1.1.1 2003/09/23 09:47:26 mshiltonj
+# Initial Import
+#
+# Revision 0.1 2001/03/31 10:54:03 ram
+# Baseline for first Alpha release.
+#
+# $EndLog$
+#
+
+use CGI qw/:standard/;
+
+print header(-type => "text/plain");
+
+foreach my $name (param()) {
+ my @value = param($name);
+ foreach (@value) { tr/\n/ /; }
+ print "$name\t at value\n";
+}
+
diff --git a/t/cgi/getform b/t/cgi/getform
new file mode 100755
index 0000000..4612248
--- /dev/null
+++ b/t/cgi/getform
@@ -0,0 +1,109 @@
+: # feed this into perl
+ eval 'exec perl -S $0 ${1+"$@"}'
+ if $running_under_some_shell;
+
+#
+# $Id: getform,v 1.1.1.1 2003/09/23 09:47:26 mshiltonj Exp $
+#
+# Copyright (c) 2001, Raphael Manfredi
+#
+# You may redistribute only under the terms of the Artistic License,
+# as specified in the README file that comes with the distribution.
+#
+# HISTORY
+# $Log: getform,v $
+# Revision 1.1.1.1 2003/09/23 09:47:26 mshiltonj
+# Initial Import
+#
+# Revision 0.1 2001/03/31 10:54:03 ram
+# Baseline for first Alpha release.
+#
+# $EndLog$
+#
+
+use CGI qw/:standard/;
+
+$\ = "\n";
+
+print header;
+my $method = param("method") || request_method();
+my $action = param("action") || url();
+print start_html("$method form"), h1("$method form");
+print startform(
+ -method => $method eq "POST" ? "POST" : "GET",
+ -enctype => param("enctype") eq "M" ?
+ "multipart/form-data" : "application/x-www-form-urlencoded",
+ -action => $action,
+);
+
+my $counter = param("counter") + 1;
+param("counter", $counter);
+print hidden("counter");
+print hidden("enctype");
+
+print "Title: ", radio_group(
+ -name => "title",
+ -values => [qw(Mr Ms Miss)],
+ -default => 'Mr'), br;
+
+print "Name: ", textfield("name"), br;
+
+print "Skills: ", checkbox_group(
+ -name => "skills",
+ -values => [qw(cooking drawing teaching listening)],
+ -defaults => ['listening'],
+), br;
+
+print "New here: ", checkbox(
+ -name => "new",
+ -checked => 1,
+ -value => "ON",
+ -label => "click me",
+), br;
+
+
+print "Color: ", popup_menu(
+ -name => "color",
+ -values => [qw(white black green red blue)],
+ -default => "white",
+), br;
+
+print "Note: ", textarea("note"), br;
+
+print "Prefers: ", scrolling_list(
+ -name => "months",
+ -values => [qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec)],
+ -size => 5,
+ -multiple => 1,
+ -default => [qw(Jul)],
+), br;
+
+print "Password: ", password_field(
+ -name => "passwd",
+ -size => 10,
+ -maxlength => 15,
+), br;
+
+print "Portrait: ", filefield(
+ -name => "portrait",
+ -size => 30,
+ -maxlength => 80,
+), br;
+
+print p(
+ reset(),
+ defaults("default"),
+ submit("Send"),
+ image_button(
+ -name => "img_send",
+ -alt => "GO!",
+ -src => "go.png",
+ -width => 50,
+ -height => 30,
+ -border => 0,
+ ),
+);
+
+print endform;
+print end_html;
+
diff --git a/t/cgi/printenv b/t/cgi/printenv
new file mode 100755
index 0000000..c5e3747
--- /dev/null
+++ b/t/cgi/printenv
@@ -0,0 +1,28 @@
+: # feed this into perl
+ eval 'exec perl -S $0 ${1+"$@"}'
+ if $running_under_some_shell;
+
+#
+# $Id: printenv,v 1.1.1.1 2003/09/23 09:47:26 mshiltonj Exp $
+#
+# Copyright (c) 2001, Raphael Manfredi
+#
+# You may redistribute only under the terms of the Artistic License,
+# as specified in the README file that comes with the distribution.
+#
+# HISTORY
+# $Log: printenv,v $
+# Revision 1.1.1.1 2003/09/23 09:47:26 mshiltonj
+# Initial Import
+#
+# Revision 0.1 2001/03/31 10:54:03 ram
+# Baseline for first Alpha release.
+#
+# $EndLog$
+#
+
+print "Content-type: text/plain\r\n\r\n";
+while (($key, $val) = each %ENV) {
+ print "$key = $val\n";
+}
+
diff --git a/t/env.t b/t/env.t
new file mode 100644
index 0000000..82b2b84
--- /dev/null
+++ b/t/env.t
@@ -0,0 +1,108 @@
+#
+# $Id: env.t,v 1.2 2003/09/29 11:00:50 mshiltonj Exp $
+#
+# Copyright (c) 2001, Raphael Manfredi
+#
+# You may redistribute only under the terms of the Artistic License,
+# as specified in the README file that comes with the distribution.
+#
+# HISTORY
+# $Log: env.t,v $
+# Revision 1.2 2003/09/29 11:00:50 mshiltonj
+# CGI::Test has changed ownership. The new owner is Steven Hilton
+# <mshiltonj at mshiltonj.com>. Many thanks to Raphael Manfredi
+# and Steve Fink.
+#
+# CGI::Test is now hosted as a SourceForge project. It is located
+# at <http://cgi-test.sourceforge.net>.
+#
+# POD updated to reflect the above.
+#
+# make() method on various objects has been deprecated, and has been
+# replaced by more conventional (for me, at least) new() method.
+# Support for make() may be removed in a later release.
+#
+# Entire codebase reformatted using perltidy
+# Go to <http://perltidy.sourceforge.net/> to see how neat it is.
+#
+# Self-referential object variable name standardized to '$this'
+# throughout code.
+#
+# Revision 1.1.1.1 2003/09/23 09:47:26 mshiltonj
+# Initial Import
+#
+# Revision 0.1 2001/03/31 10:54:03 ram
+# Baseline for first Alpha release.
+#
+# $EndLog$
+#
+
+use CGI::Test;
+
+print "1..15\n";
+
+my $SERVER = "some-server";
+my $PORT = 18;
+my $BASE = "http://${SERVER}:${PORT}/cgi-bin";
+
+my $ct = CGI::Test->new(
+ -base_url => $BASE,
+ -cgi_dir => "t/cgi",
+);
+
+ok 1, defined $ct;
+
+my $PATH_INFO = "path/info";
+my $QUERY = "query=1";
+my $USER = "ram";
+
+my $page = $ct->GET("$BASE/printenv/${PATH_INFO}?${QUERY}", $USER);
+ok 2, !$page->is_error;
+ok 3, length $page->raw_content;
+
+my %V;
+parse_content(\%V, $page->raw_content_ref);
+
+ok 4, $V{SCRIPT_NAME} eq "/cgi-bin/printenv";
+ok 5, $V{SERVER_PORT} == $PORT;
+ok 6, $V{REQUEST_METHOD} eq "GET";
+ok 7, $V{SCRIPT_FILENAME} eq "t/cgi/printenv";
+ok 8, $V{PATH_INFO} eq "/$PATH_INFO";
+ok 9, $V{QUERY_STRING} eq $QUERY;
+ok 10, $V{REMOTE_USER} eq $USER;
+ok 11, $V{HTTP_USER_AGENT} eq "CGI::Test";
+
+my $AGENT = "LWP::UserAgent";
+my $EXTRA = "is set";
+$page->delete;
+
+my $ct2 = CGI::Test->new(
+ -base_url => $BASE,
+ -cgi_dir => "t/cgi",
+ -cgi_env => {
+ EXTRA_IMPORTANT_VARIABLE => $EXTRA,
+ HTTP_USER_AGENT => $AGENT,
+ SCRIPT_FILENAME => "foo",
+ },
+);
+
+$page = $ct2->GET("$BASE/printenv");
+parse_content(\%V, $page->raw_content_ref);
+
+ok 12, $V{SCRIPT_NAME} eq "/cgi-bin/printenv";
+ok 13, $V{HTTP_USER_AGENT} eq $AGENT;
+ok 14, $V{EXTRA_IMPORTANT_VARIABLE} eq $EXTRA;
+ok 15, !exists $V{REMOTE_USER};
+$page->delete;
+
+exit 0; ## DONE
+
+sub parse_content {
+ my ($h, $cref) = @_;
+ %$h = ();
+ foreach my $l (split /\n/, $$cref) {
+ my ($k, $v) = split / = /, $l;
+ $h->{$k} = $v;
+ }
+}
+
diff --git a/t/get.t b/t/get.t
new file mode 100644
index 0000000..842a6e4
--- /dev/null
+++ b/t/get.t
@@ -0,0 +1,81 @@
+#
+# $Id: get.t,v 1.2 2003/09/29 11:00:50 mshiltonj Exp $
+#
+# Copyright (c) 2001, Raphael Manfredi
+#
+# You may redistribute only under the terms of the Artistic License,
+# as specified in the README file that comes with the distribution.
+#
+# HISTORY
+# $Log: get.t,v $
+# Revision 1.2 2003/09/29 11:00:50 mshiltonj
+# CGI::Test has changed ownership. The new owner is Steven Hilton
+# <mshiltonj at mshiltonj.com>. Many thanks to Raphael Manfredi
+# and Steve Fink.
+#
+# CGI::Test is now hosted as a SourceForge project. It is located
+# at <http://cgi-test.sourceforge.net>.
+#
+# POD updated to reflect the above.
+#
+# make() method on various objects has been deprecated, and has been
+# replaced by more conventional (for me, at least) new() method.
+# Support for make() may be removed in a later release.
+#
+# Entire codebase reformatted using perltidy
+# Go to <http://perltidy.sourceforge.net/> to see how neat it is.
+#
+# Self-referential object variable name standardized to '$this'
+# throughout code.
+#
+# Revision 1.1.1.1 2003/09/23 09:47:26 mshiltonj
+# Initial Import
+#
+# Revision 0.1 2001/03/31 10:54:03 ram
+# Baseline for first Alpha release.
+#
+# $EndLog$
+#
+
+use CGI::Test;
+
+print "1..13\n";
+
+my $BASE = "http://server:18/cgi-bin";
+
+my $ct = CGI::Test->new(
+ -base_url => $BASE,
+ -cgi_dir => "t/cgi",
+);
+
+ok 1, defined $ct;
+
+my $page = $ct->GET("$BASE/getform");
+ok 2, !$page->is_error;
+
+my $form = $page->forms->[0];
+ok 3, $form->method eq "GET";
+my @submit = $form->submits_named("Send");
+ok 4, @submit == 1;
+
+my $months = $form->widget_by_name("months");
+$months->select("Jan");
+
+my $send = $form->submit_by_name("Send");
+my $page2 = $send->press;
+ok 5, !$page2->is_error;
+
+ok 6, !$page2->is_error;
+ok 7, $page2->form_count == 1;
+my $form2 = $page2->forms->[0];
+
+ at submit = $form2->submits_named("Send");
+ok 8, @submit == 1;
+ok 9, $form2->method eq "GET";
+ok 10, $form2->enctype !~ /^multipart/;
+
+my $months2 = $form2->widget_by_name("months");
+ok 11, $months2->is_selected("Jul");
+ok 12, $months2->is_selected("Jan");
+ok 13, !$months2->is_selected("Feb");
+
diff --git a/t/parsing.t b/t/parsing.t
new file mode 100644
index 0000000..7613af8
--- /dev/null
+++ b/t/parsing.t
@@ -0,0 +1,127 @@
+#
+# $Id: parsing.t,v 1.2 2003/09/29 11:00:50 mshiltonj Exp $
+#
+# Copyright (c) 2001, Raphael Manfredi
+#
+# You may redistribute only under the terms of the Artistic License,
+# as specified in the README file that comes with the distribution.
+#
+# HISTORY
+# $Log: parsing.t,v $
+# Revision 1.2 2003/09/29 11:00:50 mshiltonj
+# CGI::Test has changed ownership. The new owner is Steven Hilton
+# <mshiltonj at mshiltonj.com>. Many thanks to Raphael Manfredi
+# and Steve Fink.
+#
+# CGI::Test is now hosted as a SourceForge project. It is located
+# at <http://cgi-test.sourceforge.net>.
+#
+# POD updated to reflect the above.
+#
+# make() method on various objects has been deprecated, and has been
+# replaced by more conventional (for me, at least) new() method.
+# Support for make() may be removed in a later release.
+#
+# Entire codebase reformatted using perltidy
+# Go to <http://perltidy.sourceforge.net/> to see how neat it is.
+#
+# Self-referential object variable name standardized to '$this'
+# throughout code.
+#
+# Revision 1.1.1.1 2003/09/23 09:47:26 mshiltonj
+# Initial Import
+#
+# Revision 0.1.1.1 2001/04/17 10:42:25 ram
+# patch2: fixed test 4 to match even if there are parameters in type
+#
+# Revision 0.1 2001/03/31 10:54:03 ram
+# Baseline for first Alpha release.
+#
+# $EndLog$
+#
+
+use CGI::Test;
+
+print "1..40\n";
+
+my $BASE = "http://server:18/cgi-bin";
+
+my $ct = CGI::Test->new(
+ -base_url => $BASE,
+ -cgi_dir => "t/cgi",
+);
+
+ok 1, defined $ct;
+
+my $page = $ct->GET("$BASE/getform");
+ok 2, $page->is_ok;
+ok 3, length $page->raw_content;
+ok 4, $page->content_type =~ m|^text/html\b|;
+
+my $forms = $page->forms;
+ok 5, @$forms == 1;
+
+my $form = $forms->[0];
+
+my @names;
+my $rg = $form->radio_groups;
+ok 6, ref $rg && (@names = $rg->names) && 1; # ok(x, 1, undef)
+ok 7, @names == 1;
+
+my $r_groupname = $names[0];
+ok 8, $rg->is_groupname($r_groupname);
+my @buttons = $rg->widgets_in($r_groupname);
+ok 9, @buttons == 3;
+
+my $cg = $form->checkbox_groups;
+ok 10, ref $cg && (@names = $cg->names) && 1;
+ok 11, @names == 2;
+
+my $c_groupname = "skills";
+ok 12, $cg->is_groupname($c_groupname);
+ at buttons = $cg->widgets_in($c_groupname);
+ok 13, @buttons == 4 && $cg->widget_count($c_groupname) == 4;
+
+ok 14, @{$form->inputs} == 4; # 1 of each (field, area, passwd, file)
+ok 15, @{$form->buttons} == 4;
+ok 16, @{$form->menus} == 2;
+ok 17, @{$form->checkboxes} == 5;
+
+my $months = $form->menu_by_name("months");
+ok 18, defined $months;
+ok 19, !$months->is_popup;
+ok 20, $months->selected_count == 1;
+ok 21, @{$months->option_values} == 12;
+ok 22, $months->is_selected("Jul");
+ok 23, !$months->is_selected("Jan");
+
+my $color = $form->menu_by_name("color");
+ok 24, defined $color;
+ok 25, $color->is_popup;
+ok 26, $color->is_selected("white"); # implicit selection
+ok 27, $color->selected_count == 1;
+ok 28, $color->option_values->[0] eq "white";
+ok 29, !$color->is_selected("black");
+
+my @menus = $form->widgets_matching(sub { $_[0]->is_menu });
+ok 30, @menus == 2;
+my @radio = $form->radios_named("title");
+ok 31, @radio == 3;
+
+require URI;
+ok 32, URI->new($form->action)->path eq "/cgi-bin/getform";
+ok 33, $form->method eq "GET";
+ok 34, $form->enctype eq "application/x-www-form-urlencoded";
+
+my @submit = grep { $_->name !~ /^\./ } $form->submit_list;
+ok 35, @submit == 2;
+
+ at buttons = $cg->widgets_in("no-such-group");
+ok 36, @buttons == 0;
+ok 37, 0 == $cg->widget_count("no-such-group");
+
+my $new = $form->checkbox_by_name("new");
+ok 38, defined $new;
+ok 39, $new->is_checked;
+ok 40, $new->is_standalone;
+
diff --git a/t/play_get.t b/t/play_get.t
new file mode 100644
index 0000000..c3c37ba
--- /dev/null
+++ b/t/play_get.t
@@ -0,0 +1,22 @@
+#
+# $Id: play_get.t,v 1.1.1.1 2003/09/23 09:47:26 mshiltonj Exp $
+#
+# Copyright (c) 2001, Raphael Manfredi
+#
+# You may redistribute only under the terms of the Artistic License,
+# as specified in the README file that comes with the distribution.
+#
+# HISTORY
+# $Log: play_get.t,v $
+# Revision 1.1.1.1 2003/09/23 09:47:26 mshiltonj
+# Initial Import
+#
+# Revision 0.1 2001/03/31 10:54:03 ram
+# Baseline for first Alpha release.
+#
+# $EndLog$
+#
+
+require "t/browse.pl";
+browse(); # submits via GET
+
diff --git a/t/play_multi.t b/t/play_multi.t
new file mode 100644
index 0000000..71f2509
--- /dev/null
+++ b/t/play_multi.t
@@ -0,0 +1,22 @@
+#
+# $Id: play_multi.t,v 1.1.1.1 2003/09/23 09:47:26 mshiltonj Exp $
+#
+# Copyright (c) 2001, Raphael Manfredi
+#
+# You may redistribute only under the terms of the Artistic License,
+# as specified in the README file that comes with the distribution.
+#
+# HISTORY
+# $Log: play_multi.t,v $
+# Revision 1.1.1.1 2003/09/23 09:47:26 mshiltonj
+# Initial Import
+#
+# Revision 0.1 2001/03/31 10:54:04 ram
+# Baseline for first Alpha release.
+#
+# $EndLog$
+#
+
+require "t/browse.pl";
+browse(-method => 'POST', -enctype => "M");
+
diff --git a/t/play_post.t b/t/play_post.t
new file mode 100644
index 0000000..0884bd2
--- /dev/null
+++ b/t/play_post.t
@@ -0,0 +1,22 @@
+#
+# $Id: play_post.t,v 1.1.1.1 2003/09/23 09:47:26 mshiltonj Exp $
+#
+# Copyright (c) 2001, Raphael Manfredi
+#
+# You may redistribute only under the terms of the Artistic License,
+# as specified in the README file that comes with the distribution.
+#
+# HISTORY
+# $Log: play_post.t,v $
+# Revision 1.1.1.1 2003/09/23 09:47:26 mshiltonj
+# Initial Import
+#
+# Revision 0.1 2001/03/31 10:54:04 ram
+# Baseline for first Alpha release.
+#
+# $EndLog$
+#
+
+require "t/browse.pl";
+browse(-method => 'POST');
+
diff --git a/t/pod.t b/t/pod.t
new file mode 100644
index 0000000..e5ac2c6
--- /dev/null
+++ b/t/pod.t
@@ -0,0 +1,6 @@
+use Test::More;
+
+eval "use Test::Pod 1.00";
+plan skip_all => "Test::Pod 1.00 required for testing POD" if $@;
+
+all_pod_files_ok();
diff --git a/t/post.t b/t/post.t
new file mode 100644
index 0000000..02a19e2
--- /dev/null
+++ b/t/post.t
@@ -0,0 +1,81 @@
+#
+# $Id: post.t,v 1.2 2003/09/29 11:00:51 mshiltonj Exp $
+#
+# Copyright (c) 2001, Raphael Manfredi
+#
+# You may redistribute only under the terms of the Artistic License,
+# as specified in the README file that comes with the distribution.
+#
+# HISTORY
+# $Log: post.t,v $
+# Revision 1.2 2003/09/29 11:00:51 mshiltonj
+# CGI::Test has changed ownership. The new owner is Steven Hilton
+# <mshiltonj at mshiltonj.com>. Many thanks to Raphael Manfredi
+# and Steve Fink.
+#
+# CGI::Test is now hosted as a SourceForge project. It is located
+# at <http://cgi-test.sourceforge.net>.
+#
+# POD updated to reflect the above.
+#
+# make() method on various objects has been deprecated, and has been
+# replaced by more conventional (for me, at least) new() method.
+# Support for make() may be removed in a later release.
+#
+# Entire codebase reformatted using perltidy
+# Go to <http://perltidy.sourceforge.net/> to see how neat it is.
+#
+# Self-referential object variable name standardized to '$this'
+# throughout code.
+#
+# Revision 1.1.1.1 2003/09/23 09:47:26 mshiltonj
+# Initial Import
+#
+# Revision 0.1 2001/03/31 10:54:04 ram
+# Baseline for first Alpha release.
+#
+# $EndLog$
+#
+
+use CGI::Test;
+
+print "1..13\n";
+
+my $BASE = "http://server:18/cgi-bin";
+
+my $ct = CGI::Test->new(
+ -base_url => $BASE,
+ -cgi_dir => "t/cgi",
+);
+
+ok 1, defined $ct;
+
+my $page = $ct->GET("$BASE/getform?method=POST&enctype=M");
+ok 2, !$page->is_error;
+
+my $form = $page->forms->[0];
+ok 3, $form->method eq "POST";
+my @submit = $form->submits_named("Send");
+ok 4, @submit == 1;
+
+my $months = $form->widget_by_name("months");
+$months->select("Jan");
+
+my $send = $form->submit_by_name("Send");
+my $page2 = $send->press;
+ok 5, !$page2->is_error;
+
+ok 6, !$page2->is_error;
+ok 7, $page2->form_count == 1;
+my $form2 = $page2->forms->[0];
+
+ at submit = $form2->submits_named("Send");
+ok 8, @submit == 1;
+ok 9, $form2->method eq "POST";
+ok 10, $form2->enctype =~ /^multipart/;
+
+my $months2 = $form2->widget_by_name("months");
+ok 11, $months2->is_selected("Jul");
+ok 12, $months2->is_selected("Jan");
+ok 13, !$months2->is_selected("Feb");
+
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/libcgi-test-perl.git
More information about the Pkg-perl-cvs-commits
mailing list