CGI-Test-1.111/000755 000765 000024 00000000000 12654307361 013514 5ustar00nohuhustaff000000 000000 CGI-Test-1.111/Changes000644 000765 000024 00000021030 12654306467 015011 0ustar00nohuhustaff000000 000000 Tue Feb 2 21:15:03 PST 2016 Alex Tokarev Version 1.111 Accept HTTPS scheme in base URL Fixed license in Makefile.PL Thu Apr 30 22:23:51 PDT 2015 Alex Tokarev Version 1.110 $ENV{TMPDIR} for CGI scripts is now forcibly set to whatever temporary directory value was resolved when creating a new CGI::Test instance. This is to work around an issue with older CGI.pm in Windows when $ENV{TMP} and $ENV{TEMP} are unavailable for some reason. Fri Mar 20 21:50:04 PDT 2015 Alex Tokarev Version 1.100 Response headers were never handled before; they are now. Also refactored the old code that read responses while I was at it. Mon Mar 2 20:21:30 PST 2015 Alex Tokarev Version 1.002 Some of the fixes in 1.001 were too advanced for older Perls, so reverting them. Added 'use warnings' to all Perl scripts in the distro; thanks to Hunter McMillen for the pull request. Updated license notice to include Perl version that the corresponding Artistic License was contained in, added LICENSE section in the main pod. Fri Feb 27 23:11:34 PST 2015 Alex Tokarev Version 1.001 Fixed test CGI scripts to be more compatible with old Solaris /bin/sh. Sun Oct 26 22:06:02 PDT 2014 Alex Tokarev Version 1.000 Windows support looks good, and the codebase is stable enough to call it a release. Also fixed a bug that caused test failures in Perls older than 5.8.9. Sat Sep 13 10:52:26 PDT 2014 Alex Tokarev Version 0.52 Fixed a bug that caused test failures in Windows. Fixed a bug in Makefile.PL that made Github repository gone missing. Sat Sep 6 23:15:57 PDT 2014 Alex Tokarev Version 0.51 Recently released CGI.pm deprecated some function exports which broke test scripts for CGI::Test. This minor update fixes the breakage. Fri Sep 5 22:02:29 PDT 2014 Alex Tokarev Version 0.50 Windows compatibility! Tested with ActiveState and Strawberry Perls 5.18.2. ok() method exported by CGI::Test was deprecated and removed. All tests rebased to Test::More, somewhat improved, and made compatible with Windows environment. Fri May 16 20:03:11 PSD 2014 Alex Tokarev Version 0.32 Makefile.PL will now bail out in Windows with CPAN Testers friendly message to avoid bogus FAIL reports. Fri Apr 11 21:58:37 PSD 2014 Alex Tokarev Version 0.31 Added methods that return base URI to CGI::Test. An error page is now returned if the script failed with 5xx HTTP status; an ordinary page was returned previously. Besides PERL5LIB, a new environment variable PERL will be populated now for CGI scripts, containing the path to perl binary. CGI scripts can use it to ensure they are running under the same Perl version as CGI::Test itself. It is now possible to set raw POST data and MIME type in the Input field objects. Mon May 28 18:37:24 PSD 2012 Alex Tokarev Version 0.3 Completely removed all traces of dependency on Log::Agent and Getargs::Long. Both are long obsolete, hardly maintained anymore and at least one of these (Log::Agent) is failing its tests. Changed bugtracker attribute in Makefile.PL to point to Git tracker. Sun Mar 25 15:49:33 PSD 2012 Alex Tokarev Version 0.2.4 Fixed a bug in test CGI scripts that cause them to be executed with perl from $PATH rather than the one used to test the module itself. This sometimes resulted in weird errors deep within Carp module. Mon Nov 21 00:17:38 MSD 2011 Alex Tokarev Version 0.2.3 Made an attempt to fix a nasty bug that manifests itself with custom Perl builds: test suite fails saying that it can't load Fcntl shared object. I don't think this is exactly *my* problem but it seems that majority of CPAN testers are using customized Perl builds so FAIL to PASS rate is like 2:1, which is clearly not good. The fix is quite simple: I'm adding path to Perl executable to PATH environment variable before anything else. This seems to fix the problem on my machine, will see how it fares with CPAN testers. No other changes were made. Sun Oct 16 23:46:11 MSD 2011 Alex Tokarev Version 0.2.2 Bumping version up a notch to have CPAN indexer accept this module. No other changes were made. Wed Oct 5 22:21:38 MSD 2011 Alex Tokarev Version 0.2.1 I am new maintainer of this module as of today; this little bump of a release deals with changes in documentation following ownership changes. Fri Sep 30 14:22:14 MSD 2011 Alex Tokarev Version 0.2.0 Forked from unauthorized 0.1.4 version, using Github as repository: http://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 . Description: Version 0.1.4. CGI::Test has changed ownership. The new owner is Steven Hilton . Many thanks to Raphael Manfredi and Steve Fink. CGI::Test is now hosted as a SourceForge project. It is located at . 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 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 . 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 . 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 . 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 Version 0.1.0. Initial public alpha relase. CGI-Test-1.111/lib/000755 000765 000024 00000000000 12654307361 014262 5ustar00nohuhustaff000000 000000 CGI-Test-1.111/Makefile.PL000644 000765 000024 00000005402 12654306227 015467 0ustar00nohuhustaff000000 000000 # # Copyright (c) 2001, Raphael Manfredi # Copyright (c) 2003, Steven Hilton # Copyright (c) 2011-2016, Alex Tokarev # # You may redistribute only under the terms of the Artistic License, # as specified in the README file that comes with the distribution. # # use strict; use warnings; use ExtUtils::MakeMaker; use Config; # Add the `devtest` target to run regression and POD tests in one go sub MY::postamble { return <<'END'; devtest : REGRESSION_TESTS=1 POD_TESTS=1 $(MAKE) test END } # Override `disttest` so it would behave as `devtest` sub MY::dist_test { return <<'END'; disttest : distdir cd $(DISTVNAME) && $(ABSPERLRUN) Makefile.PL cd $(DISTVNAME) && $(MAKE) $(PASTHRU) cd $(DISTVNAME) && $(MAKE) devtest $(PASTHRU) END } my $MM_VERSION = $ExtUtils::MakeMaker::VERSION; my $github_repo = 'https://github.com/nohuhu/CGI-Test'; my %MAIN_REQ = ( # Perl 5.20 warns that CGI is going to be removed # from the core in 5.22, so we require it here CGI => 0, Storable => '1.00', URI => '1.10', ($] >= 5.008 # HTTP::Status is now in ? ('HTTP::Message' => 0, ) # HTTP::Message bundle that : ('LWP' => 0, ) # requires 5.8+ ), 'HTML::TreeBuilder' => 0, 'File::Temp' => 0, 'File::Spec' => 0, ); my %TEST_REQ = ( 'Test::More' => '0.82', # for explain() ); WriteMakefile( NAME => 'CGI::Test', ABSTRACT => 'CGI regression test framework', LICENSE => 'artistic_1', VERSION_FROM => 'lib/CGI/Test.pm', ($MM_VERSION >= 6.64 ? ( TEST_REQUIRES => \%TEST_REQ, PREREQ_PM => \%MAIN_REQ, ) : ( ($MM_VERSION >= 6.5503 ? ( BUILD_REQUIRES => \%TEST_REQ, PREREQ_PM => \%MAIN_REQ, ) : ( PREREQ_PM => { %TEST_REQ, %MAIN_REQ, }, ), ), ), ), ($MM_VERSION >= 6.57 ? ( AUTHOR => [ 'Alex Tokarev ', 'Steven Hilton ', 'Raphael Manfredi ', ] ) : ( AUTHOR => 'Alex Tokarev ', ), ), ($MM_VERSION >= 6.48 ? ( MIN_PERL_VERSION => 5.006000 ) : () ), ($MM_VERSION >= 6.46 ? ( META_MERGE => { resources => { bugtracker => "$github_repo/issues", repository => "$github_repo", }, }, ) : (), ), ); CGI-Test-1.111/MANIFEST000644 000765 000024 00000002603 12654307361 014646 0ustar00nohuhustaff000000 000000 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/01_env.t t/02_parsing.t t/03_get.t t/04_post.t t/05_play_get.t t/06_play_post.t t/07_play_multi.t t/cgi/dumpargs t/cgi/dumpargs.bat t/cgi/getform t/cgi/getform.bat t/cgi/printenv t/cgi/printenv.bat t/lib/browse.pm t/pod.t META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) CGI-Test-1.111/META.json000644 000765 000024 00000002572 12654307361 015143 0ustar00nohuhustaff000000 000000 { "abstract" : "CGI regression test framework", "author" : [ "Alex Tokarev ", "Steven Hilton ", "Raphael Manfredi " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 6.6302, CPAN::Meta::Converter version 2.120921", "license" : [ "artistic_1" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "CGI-Test", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "Test::More" : "0.82" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "CGI" : "0", "File::Spec" : "0", "File::Temp" : "0", "HTML::TreeBuilder" : "0", "HTTP::Message" : "0", "Storable" : "1.00", "URI" : "1.10", "perl" : "5.006" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/nohuhu/CGI-Test/issues" }, "repository" : { "url" : "https://github.com/nohuhu/CGI-Test" } }, "version" : "1.111" } CGI-Test-1.111/META.yml000644 000765 000024 00000001451 12654307361 014766 0ustar00nohuhustaff000000 000000 --- abstract: 'CGI regression test framework' author: - 'Alex Tokarev ' - 'Steven Hilton ' - 'Raphael Manfredi ' build_requires: Test::More: 0.82 configure_requires: ExtUtils::MakeMaker: 0 dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 6.6302, CPAN::Meta::Converter version 2.120921' license: artistic meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: CGI-Test no_index: directory: - t - inc requires: CGI: 0 File::Spec: 0 File::Temp: 0 HTML::TreeBuilder: 0 HTTP::Message: 0 Storable: 1.00 URI: 1.10 perl: 5.006 resources: bugtracker: https://github.com/nohuhu/CGI-Test/issues repository: https://github.com/nohuhu/CGI-Test version: 1.111 CGI-Test-1.111/README000644 000765 000024 00000003154 12654306126 014375 0ustar00nohuhustaff000000 000000 CGI::Test ========= Copyright (c) 2001, Raphael Manfredi Copyright (c) 2011-2016, Alex Tokarev Current maintainer: Alex Tokarev ------------------------------------------------------------------------ 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 5.6.0. 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. ------------------------------------------------------------------------ The CGI::Test framework is an 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 data 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. CGI-Test-1.111/t/000755 000765 000024 00000000000 12654307361 013757 5ustar00nohuhustaff000000 000000 CGI-Test-1.111/t/01_env.t000644 000765 000024 00000005267 12520606650 015241 0ustar00nohuhustaff000000 000000 use strict; use warnings; use Config; use File::Temp (); use Test::More tests => 18; use CGI::Test; use constant WINDOWS => eval { $^O =~ /Win32|cygwin/ }; # # This is a workaround for a nasty Fcntl loading problem: it seems that # certain custom Perl builds fail to allocate some kind of resources, or # just try to load wrong shared objects. This results in tests # failing miserably; considering that custom builds are very common # among CPAN testers, this could be considered a serious problem. # $ENV{PATH} = $Config{bin} . (WINDOWS ? ';' : ':') . $ENV{PATH}; my $SERVER = "some-server"; my $PORT = 18; my $BASE = "http://${SERVER}:${PORT}/cgi-bin"; my $SCRIPT = WINDOWS ? 'printenv.bat' : 'printenv'; my $SCRIPT_FNAME = WINDOWS ? "t\\cgi\\$SCRIPT" : "t/cgi/$SCRIPT"; my $ct = CGI::Test->new( -base_url => $BASE, -cgi_dir => "t/cgi", ); ok defined $ct, "Got CGI::Test object"; isa_ok $ct, 'CGI::Test', 'isa'; my $PATH_INFO = "path/info"; my $QUERY = "query=1"; my $USER = "ram"; my $page = $ct->GET("$BASE/$SCRIPT/${PATH_INFO}?${QUERY}", $USER); my $raw_length = length $page->raw_content; ok !$page->is_error, "No errors in page " . $page->error_code; ok $raw_length, "Got raw length: $raw_length"; my %V; parse_content(\%V, $page->raw_content_ref); cmp_ok $V{SCRIPT_NAME}, 'eq', "/cgi-bin/$SCRIPT", "SCRIPT_NAME"; cmp_ok $V{SERVER_PORT}, '==', $PORT, "SERVER_PORT"; cmp_ok $V{REQUEST_METHOD}, 'eq', "GET", "REQUEST_METHOD"; cmp_ok $V{SCRIPT_FILENAME}, 'eq', $SCRIPT_FNAME, "SCRIPT_FILENAME"; cmp_ok $V{PATH_INFO}, 'eq', "/$PATH_INFO", "PATH_INFO"; cmp_ok $V{QUERY_STRING}, 'eq', $QUERY, "QUERY_STRING"; cmp_ok $V{REMOTE_USER}, 'eq', $USER, "REMOTE_USER"; cmp_ok $V{HTTP_USER_AGENT}, 'eq', "CGI::Test", "HTTP_USER_AGENT"; cmp_ok $V{TMPDIR}, 'eq', $ct->tmp_dir, "TMPDIR default"; my $AGENT = "LWP::UserAgent"; my $EXTRA = "is set"; $page->delete; my $tmpdir = File::Temp->newdir(); my $ct2 = CGI::Test->new( -base_url => $BASE, -tmp_dir => $tmpdir->dirname, -cgi_dir => "t/cgi", -cgi_env => { EXTRA_IMPORTANT_VARIABLE => $EXTRA, HTTP_USER_AGENT => $AGENT, SCRIPT_FILENAME => "foo", }, ); $page = $ct2->GET("$BASE/$SCRIPT"); parse_content(\%V, $page->raw_content_ref); cmp_ok $V{SCRIPT_NAME}, 'eq', "/cgi-bin/$SCRIPT", "SCRIPT_NAME"; cmp_ok $V{HTTP_USER_AGENT}, 'eq', $AGENT, "HTTP_USER_AGENT"; cmp_ok $V{EXTRA_IMPORTANT_VARIABLE}, 'eq', $EXTRA, "EXTRA_IMPORTANT_VARIABLE"; cmp_ok $V{TMPDIR}, 'eq', $tmpdir->dirname, "TMPDIR custom"; ok !exists $V{REMOTE_USER}, "REMOTE_USER not set"; $page->delete; exit 0; ## DONE sub parse_content { my ($h, $cref) = @_; %$h = (); foreach my $l (split /\n/, $$cref) { my ($k, $v) = $l =~ /^([^\s=]+)\s*=\s*(.*)$/; $h->{$k} = $v; } } CGI-Test-1.111/t/02_parsing.t000644 000765 000024 00000007706 12475523231 016117 0ustar00nohuhustaff000000 000000 use strict; use warnings; use Config; use URI; use Test::More tests => 49; use CGI::Test; use constant WINDOWS => eval { $^O =~ /Win32|cygwin/ }; $ENV{PATH} = $Config{bin} . (WINDOWS ? ';' : ':') . $ENV{PATH}; my $BASE = "http://server:18/cgi-bin"; my $SCRIPT = WINDOWS ? "getform.bat" : "getform"; my $ct = CGI::Test->new( -base_url => $BASE, -cgi_dir => "t/cgi", ); ok defined $ct, "Got CGI::Test object"; isa_ok $ct, 'CGI::Test', 'isa'; my $page = $ct->GET("$BASE/$SCRIPT"); my $raw_length = length $page->raw_content; ok $page->is_ok, "Page OK"; ok !$page->is_error, "No errors in page " . $page->error_code; ok $raw_length, "Got raw content length: $raw_length"; my $content_length = $page->content_length; is $content_length, $raw_length, "Page content-length matches"; my $headers = $page->headers; is 'HASH', ref($headers), "Headers hashref defined"; ok exists $headers->{'Content-Type'}, "Content-Type header exists in hashref"; $content_length = $page->header('CoNtEnT-LenGTh'); is $content_length, $raw_length, "Header content-length matches"; my $content_type = $page->header('content-type'); like $content_type, qr|^text/html\b|, "Header Content-Type matches"; like $page->content_type, qr|^text/html\b|, "Page content type matches"; my $forms = $page->forms; cmp_ok @$forms, '==', 1, "Number of forms"; my $form = $forms->[0]; my $rg = $form->radio_groups; my @names = $rg->names; ok $rg, "Radio groups defined"; is @names, 1, "Number of radio groups"; my $r_groupname = $names[0]; ok $rg->is_groupname($r_groupname), "Got radio group name: $r_groupname"; my @buttons = $rg->widgets_in($r_groupname); is @buttons, 3, "Number of buttons in radio group"; is $rg->widget_count($r_groupname), 3, "Number of widgets in radio group"; my $cg = $form->checkbox_groups; @names = $cg->names; ok $cg, "Checkbox groups defined"; is @names, 2, "Number of checkbox groups"; my $c_groupname = "skills"; ok $cg->is_groupname($c_groupname), "Got checkbox group name: $c_groupname"; @buttons = $cg->widgets_in($c_groupname); is @buttons, 4, "Number of buttons in cbox group"; is $cg->widget_count($c_groupname), 4, "Number of widgets in cbox group"; # 1 of each: field, area, passwd, file my @wants = qw/ 4 4 2 5 /; for my $type ( qw/ inputs buttons menus checkboxes / ) { my $want = shift @wants; my $have = $form->$type; is @$have, $want, "Number of $type in form"; } my $months = $form->menu_by_name("months"); ok defined $months, "Months menu defined"; ok !$months->is_popup, "Months menu is not popup"; is $months->selected_count, 1, "Months menu selected count"; is @{$months->option_values}, 12, "Months menu option values"; ok $months->is_selected("Jul"), "Months menu Jul is selected"; ok !$months->is_selected("Jan"), "Months menu Jan is not selected"; my $color = $form->menu_by_name("color"); ok defined $color, "Color menu defined"; ok $color->is_popup, "Color menu is popup"; ok $color->is_selected("white"), "Color menu implicit selection"; is $color->selected_count, 1, "Color menu selected count"; is $color->option_values->[0], "white", "Color menu option value"; ok !$color->is_selected("black"), "Color menu black is not selected"; my @menus = $form->widgets_matching(sub { $_[0]->is_menu }); is @menus, 2, "Number of menus"; my @radio = $form->radios_named("title"); is @radio, 3, "Number of title radios"; is( URI->new($form->action)->path, "/cgi-bin/$SCRIPT", "Script path" ); is $form->method, "GET", "HTTP method"; is $form->enctype, "application/x-www-form-urlencoded", "Encoding"; my @submit = grep { $_->name !~ /^\./ } $form->submit_list; is @submit, 2, "Number of submit buttons"; @buttons = $cg->widgets_in("no-such-group"); is @buttons, 0, "Number of buttons in no-such-group"; is $cg->widget_count("no-such-group"), 0, "Number of widgets in no-such-group"; my $new = $form->checkbox_by_name("new"); ok defined $new, "New checkbox defined"; ok $new->is_checked, "New checkbox is checked"; ok $new->is_standalone, "New checkbox is standalone"; CGI-Test-1.111/t/03_get.t000644 000765 000024 00000002666 12475233542 015237 0ustar00nohuhustaff000000 000000 use strict; use warnings; use Config; use Test::More tests => 14; use CGI::Test; use constant WINDOWS => eval { $^O =~ /Win32|cygwin/ }; $ENV{PATH} = $Config{bin} . (WINDOWS ? ';' : ':') . $ENV{PATH}; my $BASE = "http://server:18/cgi-bin"; my $SCRIPT = WINDOWS ? "getform.bat" : "getform"; my $ct = CGI::Test->new( -base_url => $BASE, -cgi_dir => "t/cgi", ); ok defined $ct, "Got CGI::Test object"; isa_ok $ct, 'CGI::Test', 'isa'; my $page = $ct->GET("$BASE/$SCRIPT"); ok $page->is_ok, "Page 1 OK"; ok !$page->is_error, "Page 1 error code " . $page->error_code; my $form = $page->forms->[0]; is $form->method, 'GET', "Page 1 form method"; my @submit = $form->submits_named("Send"); is @submit, 1, "Number of Send submits in page 1"; my $months = $form->widget_by_name("months"); $months->select("Jan"); my $send = $form->submit_by_name("Send"); my $page2 = $send->press; ok !$page2->is_error, "Page 2 error code " . $page2->error_code; is $page2->form_count, 1, "Page 2 form count"; my $form2 = $page2->forms->[0]; @submit = $form2->submits_named("Send"); is @submit, 1, "Number of Send submits in page 2"; is $form2->method, 'GET', "Form 2 method"; like $form2->enctype, qr/urlencoded/, "Form 2 encoding"; my $months2 = $form2->widget_by_name("months"); ok $months2->is_selected("Jul"), "Form 2 Jul is selected"; ok $months2->is_selected("Jan"), "Form 2 Jan is selected"; ok !$months2->is_selected("Feb"), "Form 2 Feb is not selected"; CGI-Test-1.111/t/04_post.t000644 000765 000024 00000002706 12475233542 015441 0ustar00nohuhustaff000000 000000 use strict; use warnings; use Config; use Test::More tests => 14; use CGI::Test; use constant WINDOWS => eval { $^O =~ /Win32|cygwin/ }; $ENV{PATH} = $Config{bin} . (WINDOWS ? ';' : ':') . $ENV{PATH}; my $BASE = "http://server:18/cgi-bin"; my $SCRIPT = WINDOWS ? 'getform.bat' : 'getform'; my $ct = CGI::Test->new( -base_url => $BASE, -cgi_dir => "t/cgi", ); ok defined $ct, "Got CGI::Test object"; isa_ok $ct, 'CGI::Test', 'isa'; my $page = $ct->GET("$BASE/$SCRIPT?method=POST&enctype=M"); ok $page->is_ok, "Page 1 OK"; ok !$page->is_error, "Page 1 error code " . $page->error_code; my $form = $page->forms->[0]; is $form->method, "POST", "Page 1 form method"; my @submit = $form->submits_named("Send"); is @submit, 1, "Page 1 number of Send submits"; my $months = $form->widget_by_name("months"); $months->select("Jan"); my $send = $form->submit_by_name("Send"); my $page2 = $send->press; ok !$page2->is_error, "Page 2 error code " . $page2->error_code; is $page2->form_count, 1, "Page 2 form count"; my $form2 = $page2->forms->[0]; @submit = $form2->submits_named("Send"); is @submit, 1, "Page 2 number of Send submits"; is $form2->method, 'POST', "Form 2 method"; like $form2->enctype, qr/multipart/, "Form 2 encoding"; my $months2 = $form2->widget_by_name("months"); ok $months2->is_selected("Jul"), "Form 2 Jul is selected"; ok $months2->is_selected("Jan"), "Form 2 Jan is selected"; ok !$months2->is_selected("Feb"), "Form 2 Feb is not selected"; CGI-Test-1.111/t/05_play_get.t000644 000765 000024 00000000140 12475233542 016247 0ustar00nohuhustaff000000 000000 use strict; use warnings; use lib 't/lib'; use browse; browse::browse(); # submits via GET CGI-Test-1.111/t/06_play_post.t000644 000765 000024 00000000137 12475233542 016464 0ustar00nohuhustaff000000 000000 use strict; use warnings; use lib 't/lib'; use browse; browse::browse(-method => 'POST'); CGI-Test-1.111/t/07_play_multi.t000644 000765 000024 00000000161 12475233542 016627 0ustar00nohuhustaff000000 000000 use strict; use warnings; use lib 't/lib'; use browse; browse::browse(-method => 'POST', -enctype => "M"); CGI-Test-1.111/t/cgi/000755 000765 000024 00000000000 12654307361 014521 5ustar00nohuhustaff000000 000000 CGI-Test-1.111/t/lib/000755 000765 000024 00000000000 12654307361 014525 5ustar00nohuhustaff000000 000000 CGI-Test-1.111/t/pod.t000644 000765 000024 00000000403 12475233542 014723 0ustar00nohuhustaff000000 000000 use strict; use warnings; use Test::More; if ( $ENV{POD_TESTS} ) { eval "use Test::Pod 1.00"; plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; all_pod_files_ok(); } else { plan skip_all => 'POD tests are not enabled.'; } CGI-Test-1.111/t/lib/browse.pm000644 000765 000024 00000007044 12404730475 016370 0ustar00nohuhustaff000000 000000 package browse; use Config; use Test::More; use CGI::Test; use constant WINDOWS => eval { $^O =~ /Win32|cygwin/ }; # # This is a workaround for a nasty Fcntl loading problem: it seems that # certain custom Perl builds fail to allocate some kind of resources, or # just try to load wrong shared objects. This results in tests # failing miserably; considering that custom builds are very common # among CPAN testers, this could be considered a serious problem. # $ENV{PATH} = $Config{bin} . (WINDOWS ? ';' : ':') . $ENV{PATH}; sub browse { my %params = @_; my $method = $params{method}; my $enctype = $params{enctype}; plan tests => 27; my $BASE = "http://server:18/cgi-bin"; my $SCRIPT = WINDOWS ? 'getform.bat' : 'getform'; my $ACTION = WINDOWS ? 'dumpargs.bat' : 'dumpargs'; my $ct = CGI::Test->new( -base_url => $BASE, -cgi_dir => "t/cgi", ); my $query = "action=/cgi-bin/$ACTION"; $query .= "&method=$method" if defined $method; $query .= "&enctype=$enctype" if defined $enctype; my $page = $ct->GET("$BASE/$SCRIPT?$query"); my $form = $page->forms->[0]; is $form->action, "/cgi-bin/$ACTION", "Action: " . $form->action; my $submit = $form->submit_by_name("Send"); ok defined $submit, "Send submit defined"; my $page2 = $submit->press; ok $page2->is_ok, "Page 2 OK"; my $args = parse_args($page2->raw_content); is $args->{counter}, 1, "Page 2 counter"; is $args->{title}, "Mr", "Page 2 title"; is $args->{name}, "", "Page 2 name"; is $args->{skills}, "listening", "Page 2 skills"; is $args->{new}, "ON", "Page 2 new"; is $args->{color}, "white", "Page 2 color"; is $args->{note}, "", "Page 2 note"; is $args->{months}, "Jul", "Page 2 months"; is $args->{passwd}, "", "Page 2 passwd"; is $args->{Send}, "Send", "Page 2 send"; is $args->{portrait}, "", "Page 2 portrait"; 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"); my $page3 = $submit->press; my $args3 = parse_args($page3->raw_content); is $args3->{counter}, 1, "Page 3 counter"; is $args3->{title}, "Miss", "Page 3 title"; is $args3->{name}, "", "Page 3 name"; is $args3->{skills}, "listening", "Page 3 skills"; ok !exists $args3->{new}, "Page 3 new"; # unchecked, not submitted is $args3->{color}, "red", "Page 3 color"; is $args3->{note}, "this is some text", "Page 3 note"; is join(" ", sort split(' ', $args3->{months})), "Feb Jan", "Page 3 months"; is $args3->{passwd}, "foobar", "Page 3 passwd"; is $args3->{Send}, "Send", "Page 3 send"; is $args3->{portrait}, "this is it, disappointed?", "Page 3 portrait"; # Ensure we tested what was requested $method = "GET" unless defined $method; my $enctype_qr = defined $enctype ? qr/multipart/ : qr/urlencoded/; is $form->method, $method, "Form method"; like $form->enctype, $enctype_qr, "Form encoding"; } # 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; CGI-Test-1.111/t/cgi/dumpargs000755 000765 000024 00000000557 12475523640 016301 0ustar00nohuhustaff000000 000000 #!/bin/sh $PERL -x 3<&0 <<'END_OF_SCRIPT' #!perl use CGI qw/:standard/; # 2 argument open here for older Perls open STDIN, '<&3' or die "Can't reopen STDIN"; print header(-type => "text/plain"); local $CGI::LIST_CONTEXT_WARN = 0; foreach my $name (param()) { my @value = param($name); foreach (@value) { tr/\n/ /; } print "$name\t@value\n"; } END_OF_SCRIPT CGI-Test-1.111/t/cgi/dumpargs.bat000644 000765 000024 00000001215 12475523634 017036 0ustar00nohuhustaff000000 000000 @rem = '--*-Perl-*-- @echo off if "%OS%" == "Windows_NT" goto WinNT perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9 goto endofperl :WinNT perl -x -S %0 %* if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl if %errorlevel% == 9009 echo You do not have Perl in your PATH. if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul goto endofperl @rem '; #!perl #line 15 use CGI qw/:standard/; print header(-type => "text/plain"); local $CGI::LIST_CONTEXT_WARN = 0; foreach my $name (param()) { my @value = param($name); foreach (@value) { tr/\n/ /; } print "$name\t@value\n"; } __END__ :endofperl CGI-Test-1.111/t/cgi/getform000755 000765 000024 00000004034 12475523667 016125 0ustar00nohuhustaff000000 000000 #!/bin/sh $PERL -x 3<&0 <<'END_OF_SCRIPT' #!perl use CGI qw/:standard :no_xhtml/; # 2 argument open here for older Perls open STDIN, '<&3' or die "Can't reopen STDIN"; local $CGI::LIST_CONTEXT_WARN = 0; my $content = ''; my $method = param("method") || request_method(); my $action = param("action") || url(); $content .= start_html("$method form"); $content .= h1("$method form"); $content .= start_form( -action => $action, -method => $method eq "POST" ? "POST" : "GET", -enctype => param("enctype") eq "M" ? "multipart/form-data" : "application/x-www-form-urlencoded", ); my $counter = param("counter") + 1; param("counter", $counter); $content .= hidden("counter"); $content .= hidden("enctype"); $content .= "Title: " . radio_group( -name => "title", -values => [qw(Mr Ms Miss)], -default => 'Mr' ) . br; $content .= "Name: " . textfield("name") . br; $content .= "Skills: " . checkbox_group( -name => "skills", -values => [qw(cooking drawing teaching listening)], -defaults => ['listening'], ) . br; $content .= "New here: " . checkbox( -name => "new", -checked => 1, -value => "ON", -label => "click me", ) . br; $content .= "Color: " . popup_menu( -name => "color", -values => [qw(white black green red blue)], -default => "white", ) . br; $content .= "Note: " . textarea("note") . br; $content .= "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; $content .= "Password: " . password_field( -name => "passwd", -size => 10, -maxlength => 15, ) . br; $content .= "Portrait: " . filefield( -name => "portrait", -size => 30, -maxlength => 80, ) . br; $content .= p( reset(), defaults("default"), submit("Send"), image_button( -name => "img_send", -alt => "GO!", -src => "go.png", -width => 50, -height => 30, -border => 0, ), ); $content .= end_form; $content .= end_html; print header( -Content_Length => length $content, ); print $content; END_OF_SCRIPT CGI-Test-1.111/t/cgi/getform.bat000644 000765 000024 00000004616 12475523664 016672 0ustar00nohuhustaff000000 000000 @rem = '--*-Perl-*-- @echo off if "%OS%" == "Windows_NT" goto WinNT perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9 goto endofperl :WinNT perl -x -S %0 %* if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl if %errorlevel% == 9009 echo You do not have Perl in your PATH. if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul goto endofperl @rem '; #!perl #line 15 use CGI qw/:standard :no_xhtml/; local $CGI::LIST_CONTEXT_WARN = 0; my $content = ''; my $method = param("method") || request_method(); my $action = param("action") || url(); $content .= start_html("$method form"); $content .= h1("$method form"); $content .= start_form( -action => $action, -method => $method eq "POST" ? "POST" : "GET", -enctype => param("enctype") eq "M" ? "multipart/form-data" : "application/x-www-form-urlencoded", ); my $counter = param("counter") + 1; param("counter", $counter); $content .= hidden("counter"); $content .= hidden("enctype"); $content .= "Title: " . radio_group( -name => "title", -values => [qw(Mr Ms Miss)], -default => 'Mr' ) . br; $content .= "Name: " . textfield("name") . br; $content .= "Skills: " . checkbox_group( -name => "skills", -values => [qw(cooking drawing teaching listening)], -defaults => ['listening'], ) . br; $content .= "New here: " . checkbox( -name => "new", -checked => 1, -value => "ON", -label => "click me", ) . br; $content .= "Color: " . popup_menu( -name => "color", -values => [qw(white black green red blue)], -default => "white", ) . br; $content .= "Note: " . textarea("note") . br; $content .= "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; $content .= "Password: " . password_field( -name => "passwd", -size => 10, -maxlength => 15, ) . br; $content .= "Portrait: " . filefield( -name => "portrait", -size => 30, -maxlength => 80, ) . br; $content .= p( reset(), defaults("default"), submit("Send"), image_button( -name => "img_send", -alt => "GO!", -src => "go.png", -width => 50, -height => 30, -border => 0, ), ); $content .= end_form; $content .= end_html; print header( -Content_Length => length $content, ); print $content; __END__ :endofperl CGI-Test-1.111/t/cgi/printenv000755 000765 000024 00000000245 12402505142 016301 0ustar00nohuhustaff000000 000000 #!/bin/sh $PERL -x <<'END_OF_SCRIPT' #!perl print "Content-type: text/plain\r\n\r\n"; while (($key, $val) = each %ENV) { print "$key = $val\n"; } END_OF_SCRIPT CGI-Test-1.111/t/cgi/printenv.bat000644 000765 000024 00000001041 12402505142 017036 0ustar00nohuhustaff000000 000000 @rem = '--*-Perl-*-- @echo off if "%OS%" == "Windows_NT" goto WinNT perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9 goto endofperl :WinNT perl -x -S %0 %* if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl if %errorlevel% == 9009 echo You do not have Perl in your PATH. if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul goto endofperl @rem '; #!perl #line 15 #!PERL print "Content-type: text/plain\r\n\r\n"; while (($key, $val) = each %ENV) { print "$key = $val\n"; } __END__ :endofperl CGI-Test-1.111/lib/CGI/000755 000765 000024 00000000000 12654307361 014664 5ustar00nohuhustaff000000 000000 CGI-Test-1.111/lib/CGI/Test/000755 000765 000024 00000000000 12654307361 015603 5ustar00nohuhustaff000000 000000 CGI-Test-1.111/lib/CGI/Test.pm000644 000765 000024 00000102343 12654306501 016137 0ustar00nohuhustaff000000 000000 ################################################################# # Copyright (c) 2001, Raphael Manfredi # Copyright (c) 2011-2016, Alex Tokarev # # You may redistribute only under the terms of the Artistic License, # as specified in the README file that comes with the distribution. # package CGI::Test; use strict; use warnings; use Carp; use HTTP::Status; use URI; use File::Temp qw(mkstemp); use File::Spec; use File::Basename; use Cwd qw(abs_path); use vars qw($VERSION); $VERSION = '1.111'; use constant WINDOWS => eval { $^O =~ /Win32|cygwin/ }; ############################################################################# # # ->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 %params = @_; my $ubase = $params{-base_url}; my $dir = $params{-cgi_dir}; my $doc = $params{-doc_dir} || "."; my $tmp = $params{-tmp_dir} || $ENV{TMPDIR} || $ENV{TEMP} || "/tmp"; my $env = $params{-cgi_env}; my $uri = URI->new($ubase); croak "-base_url $ubase is not within the http scheme" unless ( $uri->scheme eq 'http' || $uri->scheme eq 'https' ); my ($server, $path) = $this->split_uri($uri); $this->{host_port} = $server; $this->{scheme} = $uri->scheme; $this->{host} = $uri->host; $this->{port} = $uri->port; $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_uri { my $this = shift; my $scheme = $this->{scheme}; my $host = $this->{host}; my $port = $this->{port}; my $base = $this->{base_path}; return $scheme . '://' . $host . ':' . $port . $base; } ###################################################################### sub host { my $this = shift; return $this->{host}; } ###################################################################### sub port { my $this = shift; return $this->{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) = ''; # # 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 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); my ($in_fh, $out_fh, $in_fname, $out_fname); if (defined $input) { # In Windows, we use temp files instead of pipes to avoid # stream duplication errors if ( WINDOWS ) { ($in_fh, $in_fname) = mkstemp(File::Spec->catfile($this->tmp_dir, "cgi_in.XXXXXX")); binmode $in_fh; syswrite $in_fh, $input->data, $input->length; close $in_fh; @post = ( -in_fname => $in_fname, -input => $input, ); } else { if ( not pipe(PREAD, PWRITE) ) { warn "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. # ($out_fh, $out_fname) = mkstemp(File::Spec->catfile($this->tmp_dir, "cgi_out.XXXXXX")); close $out_fh if WINDOWS; select((select(STDOUT), $| = 1)[ 0 ]); print STDOUT ""; # Flush STDOUT before forking # # Fork... # my $pid = fork; die "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 in Unixy systems, or through a temp file # in Windows. # if ($pid == 0) { close PWRITE if defined $input && !WINDOWS; # 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 => $out_fh, -out_fname => $out_fname, -uri => $u, -path_info => $path, @post, # Additional params for POST ); confess "not reachable!"; } # # Parent process # close $out_fh unless WINDOWS; if (defined $input && !WINDOWS) { # Send POST input data close PREAD; syswrite PWRITE, $input->data, $input->length; close PWRITE or warn "failure while closing pipe: $!"; } my $child = waitpid $pid, 0; if ($pid != $child) { warn "waitpid returned with pid=$child, but expected pid=$pid"; kill 'TERM', $pid or warn "can't SIGTERM pid $pid: $!"; unlink $in_fname or warn "can't unlink $in_fname: $!"; unlink $out_fname or warn "can't unlink $out_fname: $!"; return $error->new(RC_NO_CONTENT, $this); } # # Get header within generated response, and determine Content-Type. # my $header = $this->_parse_header($out_fname); unless (scalar keys %$header) { warn "script $script_name generated no valid headers"; unlink $in_fname or warn "can't unlink $in_fname: $!"; unlink $out_fname or warn "can't unlink $out_fname: $!"; return $error->new(RC_INTERNAL_SERVER_ERROR, $this); } # # Return error page if we got 5xx status # if ( my ($status) = ($header->{Status} || '') =~ /^(5\d\d)/ ) { return $error->new($status, $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"; die "can't load module $objtype: $@" if chop $@; my $page = $objtype->new( -server => $this, -file => $out_fname, -content_type => $type, # raw type, with parameters -user => $user, -uri => $u, ); if ($in_fname) { unlink $in_fname or warn "can't unlink $in_fname: $!"; } unlink $out_fname or warn "can't unlink $out_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 %params = @_; my $script = $params{-script_file}; my $name = $params{-script_name}; my $user = $params{-user}; my $in = $params{-in}; my $in_fname = $params{-in_fname}; my $out = $params{-out}; my $out_fname = $params{-out_fname}; my $u = $params{-uri}; my $path = $params{-path_info}; my $input = $params{-input}; # # Connect file descriptors. # if ( !WINDOWS ) { if (defined $in) { open(STDIN, '<&=' . fileno($in)) || die "can't redirect STDIN: $!"; } else { my $devnull = File::Spec->devnull; open(STDIN, $devnull) || die "can't open $devnull: $!"; } open(STDOUT, '>&=' . fileno($out)) || die "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 $input) { $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 $input ? "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}; } # # This is a way of letting Perl test scripts to run under # the same Perl version that CGI::Test is running with # $ENV{PERL} = $^X; # # 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. # my $path_sep = WINDOWS ? ';' : ':'; $ENV{PERL5LIB} = join($path_sep, map {-e $_ ? abs_path($_) : $_} @INC); # Also make sure that temp directory is available for the script, # else older CGI.pm may choke and default to some not-quite-sane # values that do not work in Windows $ENV{TMPDIR} = $this->tmp_dir; # # 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 die "can't cd to $directory: $!"; if ( WINDOWS ) { my $cmd_line = $input ? "$basename < ${in_fname} > ${out_fname}" : "$basename < NUL >${out_fname}" ; exec $cmd_line; } else { exec "./$basename"; } die "could not exec $script: $!"; } ###################################################################### # # ->_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) || warn "can't open $file: $!"; local $_; my $field; while () { 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}) { warn "duplicate $field header in $file"; $header{$field} .= " "; } $header{$field} .= $value; } else { warn "mangled header in $file"; %header = (); # Discard what we read sofar last; } } close FILE; return \%header; } 1; =head1 NAME CGI::Test - CGI regression test framework =head1 SYNOPSIS # In some t/script.t regression test, for instance use CGI::Test; use Test::More tests => 7; 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"); like $page->content_type, qr|text/html\b|, "Content type"; my $form = $page->forms->[0]; is $form->action, "/cgi-bin/some_target", "Form action URI"; my $menu = $form->menu_by_name("months"); ok $menu->is_selected("January"), "January selected"; ok !$menu->is_selected("March"), "March not selected"; ok $menu->multiple, "Menu is multi-choice"; my $send = $form->submit_by_name("send_form"); ok defined $send, "Send form defined"; # # Now interact with the CGI # $menu->select("March"); # "click" on the March label my $answer = $send->press; # "click" on the send button # and make sure we don't get an HTTP error ok $answer->is_ok, "Answer response"; =head1 DESCRIPTION The C 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 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 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 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 framework, you need to configure a C 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 object representing the outcome of the request. This page may be an error, plain text, some binary data, or an HTML page (see L for details). The latter (an HTML page) can contain one or more CGI forms (identified by CFORME> tags), which are described by instances of C objects (see L 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 type. The specific interaction that is offered depends on the dynamic type of the object (see L 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 framework, and the CGI script is ran through a proper call to one of the GET/POST method on the C object. =head1 INTERFACE =head2 Creation Interface The creation routine C takes the following mandatory parameters: =over 4 =item C<-base_url> => I Defines the URL domain which is handled by C. This is the URL of the C 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 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, without contacting C on port 70... =item C<-cgi_dir> => I Defines the physical path corresponding to the C 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 Defines additional environment variables that must be set, or changes hardwirted defaults. Some variables like C really depend on the request and will be dynamically computed by C. For instance: -cgi_env => { HTTP_USER_AGENT => "Mozilla/4.76", AUTH_TYPE => "Digest", } See L for more details on which environment variables are defined, and which may be superseded. =item C<-doc_dir> => I This defines the root directory of the HTTP server, for path translation. It defaults to C. B: C only serves CGI scripts for now, so this setting is not terribly useful, unless you care about C. =item C<-tmp_dir> => I The temporary directory to use for internal files created while processing requests. Defaults to the value of the environment variable C, or C if it is not set. =back =head2 Object Interface The following methods, listed in alphabetical order, are available: =over 4 =item C I [, I] Issues an HTTP GET request of the specified URL, given as the string I. 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 string. C will simply setup the CGI environment variable C accordingly. Since we're in a testing framework, you can pretend to be anyone you like. See L for more information on environment variables, and in particular C. C returns a C polymorphic object, i.e. an object whose dynamic type is an heir of C. See L for more information on this class hierarchy. =item C I, I [, I] Issues an HTTP POST request of the specified URL. See C above for a discussion on I and I, which applies to C as well. The I parameter must be a C 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 to learn how to construct suitable input. C returns a C polymorphic object, like C does. =item C 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 The configured CGI root directory where scripts to be run are held. =item C The configured document root directory. =item C The host and port of the base URL you configured at creation time. =item C I 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 The temporary directory that is being used. =item C 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 conforms to the CGI/1.1 specifications. Here is a list of all the known variables. Some of those are marked I. It means you may choose to set them via the C<-cgi_env> switch of the C routine, but your settings will have no effect and C will always compute a suitable value. Variables are listed in alphabetical order: =over 4 =item C The authentication scheme used to authenticate the user given by C. 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 Read-only variable, giving the length of data to be read on STDIN by POST requests (as told by C). If is not present for GET requests. =item C Read-only variable, giving the MIME type of data to be read on STDIN by POST requests (as told by C). If is not present for GET requests. =item C The Common Gateway Interface (CGI) version specification. Defaults to "CGI/1.1". =item C 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 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 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 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 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 Read-only variable set to the extra path information part of the requested URL. Always present, even if empty. =item C This read-only variable is only present when there is a non-empty C variable. It is simply set to the value of C with the document rootdir path prepended to it (the value of the C<-doc_dir> creation argument). =item C 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 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 The DNS-translated hostname of the IP address held in C. Here, for testing purposes, it is not computed after C but can be freely set. Defaults to "localhost". =item C 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. =item C Read-only variable, whose value is either C or C. =item C Read-only variable set to the filesystem path of the CGI script being run. =item C 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 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 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 The protocol which must be followed when replying to the client request. Set to "HTTP/1.1" by default. =item C 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 plain document retrieval: only CGI scripts can be fetched by an HTTP request for now. =back =head1 PUBLIC REPOSITORY CGI::Test now has a publicly accessible Git server provided by Github.com: L =head1 REPORTING BUGS Please use Github issue tracker to open bug reports and maintenance requests. =head1 AUTHORS The original author is Raphael Manfredi. Steven Hilton was long time maintainer of this module. Current maintainer is Alex Tokarev Ftokarev@cpan.orgE>. =head1 LICENSE 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 5.6.0. 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. =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 CGI-Test-1.111/lib/CGI/Test/Form/000755 000765 000024 00000000000 12654307361 016506 5ustar00nohuhustaff000000 000000 CGI-Test-1.111/lib/CGI/Test/Form.pm000644 000765 000024 00000103054 12475233542 017047 0ustar00nohuhustaff000000 000000 package CGI::Test::Form; use strict; use warnings; #################################################################### # $Id: Form.pm 411 2011-09-26 11:19:30Z nohuhu@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
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; # # 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; # 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") { confess "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 { confess "unsupported method $method for FORM action"; } return $result; } ###################################################################### # # ->_xtract # # Widget extraction routine: traverse the 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") { warn "ISINDEX is deprecated, ignoring %s", $node->starttag; next; } else { confess "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 and