diff options
| author | Lorry Tar Creator <lorry-tar-importer@lorry> | 2015-06-16 06:44:29 +0000 |
|---|---|---|
| committer | Lorry Tar Creator <lorry-tar-importer@lorry> | 2015-06-16 06:44:29 +0000 |
| commit | f9f3ab3056d94292adb4ab2e1451645bee989769 (patch) | |
| tree | cc5a62954d359d5aad449420bc7ec259b3edb79e | |
| download | CGI-tarball-master.tar.gz | |
88 files changed, 18260 insertions, 0 deletions
@@ -0,0 +1,2132 @@ +4.21 2015-06-16 + + [ RELEASE NOTES ] + - CGI.pm is now considered "done". See also "mature" and "legacy" + Features requests and none critical issues will be outright rejected. + The module is now in maintenance mode for critical issues only. + + - This release removes the AUTOLOAD and compile optimisations from CGI.pm + that were introduced into CGI.pm twenty (20) years ago as a response to + its large size, which meant there was a significant compile time penalty. + + - This optimisation is no longer relevant and makes the code difficult to + deal with as well as making test coverage metrics incorrect. Benchmarks + show that advantages of AUTOLOAD / lazy loading / deferred compile are + less than 0.05s, which will be dwarfed by just about any meaningful code + in a cgi script. If this is an issue for you then you should look at + running CGI.pm in a persistent environment (FCGI, etc) + + - To offset some of the time added by removing the AUTOLOAD functionality + the dependencies have been made runtime rather than compile time. The + POD has also been split into its own file. CGI.pm now contains around + 4000 lines of code, which compared to some modules on CPAN isn't really + that much + + - This essentially deprecates the -compile pragma and ->compile method. The + -compile pragma will no longer do anything, whereas the ->compile method + will raise a deprecation warning. More importantly this also REMOVES the + -any pragma because as per the documentation this pragma needed to be + "used with care or not at all" and allowing arbitrary HTML tags is almost + certainly a bad idea. If you are using the -any pragma and using arbitrary + tags (or have typo's in your code) your code will *BREAK* + + - Although this release should be back compatible (with the exception of any + code using the -any pragma) you are encouraged to test it throughly as if + you are doing anything out of the ordinary with CGI.pm (i.e. have bugs + that may have been masked by the AUTOLOAD feature) you may see some issues. + + - References: GH #162, GH #137, GH #164 + + [ SPEC / BUG FIXES ] + - make the list context warning in param show the filename rather than + the package so we have more information on exactly where the warning + has been raised from (GH #171) + - correct self_url when PATH_INFO and SCRIPT_NAME are the same but we + are not running under IIS (GH #176) + - Add the multi_param method to :cgi export (thanks to xblitz for the patch + and tests. GH #167) + - Fix warning for lack of HTTP_USER_AGENT in CGI::Carp (GH #168) + - Fix imports when called from CGI::Fast, restores the import of CGI functions + into the callers namespace for users of CGI::Fast (GH leejo/cgi-fast#11 and + GH leejo/cgi-fast#12) + - Fix regression of tmpFileName when calling with a plain string (GH #178, + thanks to Simon McVittie for the report and fix) + + [ FEATURES ] + - CGI::Carp now has $CGI::Carp::FULL_PATH for displaying the full path to the + offending script in error messages + - CGI now has env_query_string() for getting the value of QUERY_STRING from + the environment and not that fiddled with by CGI.pm (which is what + query_string() does) (GH #161) + - CGI::ENCODE_ENTITIES var added to control which chracters are encoded by + the call to the HTML::Entities module - defaults to &<>"' (GH #157 - the + \x8b and \x9b chars have been removed from this list as we are concerned + more about unicode compat these days than old browser support.) + + [ DOCUMENTATION ] + - Fix some typos (GH #173, GH #174) + - All *documentation* for HTML functionality in CGI has been moved into + its own namespace: CGI::HTML::Functions - although the functionality + continues to exist within CGI.pm so there are no code changes required + (GH #142) + - Add missing documentation for env variable fetching routines (GH #163) + + [ TESTING ] + - Increase test coverage (GH #3) + + [ INTERNALS ] + - Cwd made a TEST_REQUIRES rather than a BUILD_REQUIRES in Makefile.PL + (GH #170) + - AutoloadClass variables have been removed as AUTOLOAD was removed in + v4.14 so these are no longer necessary (GH #172 thanks to alexmv) + - Remove dependency on constant - internal DEBUG, XHTML_DTD and EBCDIC + constants changes to $_DEBUG, $_XHTML_DTD, and $_EBCDIC + +4.13 2014-12-18 + + [ RELEASE NOTES ] + - CGI::Pretty is now DEPRECATED and will be removed in a future release. + Please see GH #162 (https://github.com/leejo/CGI.pm/issues/162) for more + information and discussion (also GH #140 for HTML function deprecation + discussion: https://github.com/leejo/CGI.pm/issues/140) + + [ TESTING ] + - fix t\rt-84767.t for failures on Win32 platforms related to file paths + +4.11 2014-12-02 + + [ SPEC / BUG FIXES ] + - more hash key ordering bugs fixed in HTML attribute output (GH #158, + thanks to Marcus Meissner for the patch and test case) + + [ REFACTORING ] + - escapeHTML (and unescapeHTML) have been refactored to use the functions + exported by the HTML::Entities module (GH #157) + - change BUILD_REQUIRES to TEST_REQUIRES in Makefile.PL as these are test + dependencies not build dependencies (GH #159) + + [ DOCUMENTATION ] + - replace any remaining uses of indirect object notation (new Object) with + the safer Object->new syntax (GH #156) + +4.10 2014-11-27 + + [ SPEC / BUG FIXES ] + - favour -content-type arg in header if -type and -charset options are also + passed in (GH #155, thanks to kaoru for the test case). this change also + sorts the hash keys in the rearrange method in CGI::Util meaning the order + of the arrangement will always be the same for params that have multiple + aliases. really you shouldn't be passing in multiple aliases, but this will + make it consistent should you do that + + [ DOCUMENTATION ] + - fix some typos + +4.09 2014-10-21 + + [ RELEASE NOTES ] + - with this release the large backlog of issues against CGI.pm has been + cleared. All fixes have been made in the versions 4.00 and above so if + you are upgrading from 3.* you should thoroughly test your code against + recent versions of CGI.pm + - an effort has been made to retain back compatibility against previous + versions of CGI.pm for any fixes made, however some changes related to + the handling of temporary files may have consequences for your code + - please refer to the RELEASE NOTES for version 4.00 and above for all + recent changes and file an issue on github if there has been a regression. + - please do *NOT* file issues regarding HTML generating functions, these + are no longer being maintained (see perldoc for rationale) + + [ SPEC / BUG FIXES ] + - tweak url to DTRT when the web server is IIS (RT #89827 / GH #152) + - fix temporary file handling when dealing with multiple files in MIME uploads + (GH #154, thanks to GeJ for the test case) + +4.08 2014-10-18 + + [ DOCUMENTATION ] + - note that calling headers without a -charset may lead to a nonsensical + charset being added to certain content types due to the default and the + workaround + - remove documentation stating that calls to escapeHTML with a changed + charset force numeric encoding of all characters, because that does not + happen + - documentation tweaks for calling param() in list context and the addition + of multi_param() + + [ SPEC / BUG FIXES ] + - don't sub out PATH_INFO in url if PATH_INFO is the same as SCRIPT_NAME + (RT #89827) + - add multi_param() method to allow calling of param() in list context + without having to disable the $LIST_CONTEXT_WARN flag (see RELEASE NOTES + for version 4.05 on why calling param() in list context could be a bad + thing) + +4.07 2014-10-12 + + [ RELEASE NOTES ] + - please see changes for v4.05 + + [ TESTING ] + - typo and POD fixes, add test to check POD and compiles + +4.06 2014-10-10 + + [ RELEASE NOTES ] + - please see changes for v4.05 + + [ DOCUMENTATION ] + - make warning on list context call of ->param more lenient and don't + warn if called with no arguments + +4.05 2014-10-08 + + [ RELEASE NOTES ] + - this release includes *significant* refactoring of temporary file + handling in CGI.pm. See "Changes in temporary file handling" in perldoc + + - this release adds a warning for when the param method is called + in list context, see the Warning in the perldoc for the section + "Fetching the value or values of a single named parameter" for why + this has been added and how to disable this warning + + [ DOCUMENTATION ] + - change AUTHOR INFORMATION to LICENSE to please Kwalitee + + [ TESTING ] + - t/arbitrary_handles.t to check need for patch in RT #54055, it + turns out there is no need - the first argument to CGI->new can + be an arbitrary handle + - add test case for incorrect unescaping of redirect headers + (RT #61120) + - add tests for the handle method (RT #85074, thanks to TONYC@cpan.org) + + [ SPEC / BUG FIXES ] + - don't set binmode on STDOUT/STDERR/STDIN if a none standard layer + is already set on them on none UNIX platforms (RT #57524) + - make XForms:Model data accesible through POSTDATA/PUTDATA param + (RT #75628) + - prevent corruption of POSTDATA/PUTDATA when -utf8 flag is used and use + tempfiles to handle this data (RT #79102, thanks anonymous) + - unescape request URI *after* having removed the query string to prevent + removal of ? chars that are part of the original URI (and were encoded) + (RT #83265) + - fix q( to qq( in CGI::Carp so $@ is correct interpolated (RT #83360) + - don't call ->query_string in url unless -query is passed (RT #87790) + (optimisation and fits the current documented behaviour) + +4.04 2014-09-04 + + [ RELEASE NOTES ] + - this release removes some long deprecated modules/functions and + includes refactoring to the temporary file handling in CGI.pm. if + you are doing anything out of the ordinary with regards to temp + files you should test your code before deploying this update as + temp files may no longer be stored in previously used locations + + [ REMOVED / DEPRECATIONS ] + - startform and endform methods removed (previously deprecated, you + should be using the start_form and end_form methods) + - both CGI::Apache and CGI::Switch have been removed as these modules + 1) have been deprecated for *years*, and 2) do nothing whatsoever + + [ SPEC / BUG FIXES ] + - handle multiple values in X-Forwarded-Host header, we follow the + logic in most other frameworks and take the last value from the list + (RT #54487) + - reverse the order of TEMP dir placement for WINDOWS: TEMP > TMP > WINDIR + (RT #71799, thanks to jeff@math.tntech.edu), this returns the behaviour + to pre e24d04e9bc5fda7722444b02fec135d8cc2ff488 but with the undefined + fix still in place + - refactor CGITempFile::find_tempdir to use File::Spec->tmpdir + (related: RT #71799) + - fix warnings when QUERY_STRING has empty key=value pairs (RT #54511) + - pad custom 500 status response messages to > 512 for MSIE (RT #81946) + - make Vars tied hash delete method return the value deleted from the hash + making it act like perl's delete (RT #51020) + + [ TESTING ] + - add .travis.yml (https://travis-ci.org) + - test case for RT #53966 - disallow filenames with ~ char + - test case for RT #55166 - calling Vars to get the filename does not return + a filehandle, so this cannot be used in the call to uploadinfo, also + update documentation for the uploadInfo to show that ->Vars should not be + used to get the filename for this method + - fix t/url.t to pass on Win32 platforms that have the SCRIPT_NAME env + variable set (RT #89992) + - add procedural call tests for upload and uploadInfo to confirm these work + as should (RT #91136) + + [ DOCUMENTATION ] + - tweak perldoc for -utf8 option (RT #54341, thanks to Helmut Richter) + - explain the HTML generation functions should no longer be used and that + they may be deprecated in a future release + +4.03 2014-07-02 + + [ REMOVED / DEPRECATIONS ] + - the -multiple option to popup_menu is now IGNORED as this did not + function correctly. If you require a menu with multiple selections + use the scrolling_list method. (RT #30057) + + [ SPEC / BUG FIXES ] + - support redirects in mod_perl2, or fall back to using env variable + for up to 5 redirects, when getting the query string (RT #36312) + - CGI::Cookie now correctly supports the -max-age argument, previously + if this was passed the value of the -expires argument would be used + meaning there was no way to supply *only* this argument (RT #50576) + - make :all actually import all methods, except for :cgi-lib, and add + :ssl to the :standard import (RT #70337) + + [ DOCUMENTATION ] + - clarify documentation regarding query_string method (RT #48370) + - links fixed in some perldoc (Thanks to Michiel Beijen) + + [ TESTING ] + - add t/changes.t for testing this Changes file + - test case for RT #31107 confirming multipart parsing is to spec + - improve t/rt-52469.t by adding a timeout check + +4.02 2014-06-09 + + [ NEW FEATURES ] + - CGI::Carp learns noTimestamp / $CGI::Carp::NO_TIMESTAMP to prevent + timestamp in messages (RT #82364, EDAVIS@cpan.org) + - multipart_init and multipart_start learn -charset option (RT #22737) + + [ SPEC / BUG FIXES ] + - Support multiple cookies when passing an ARRAY ref with -set-cookie + (RT #15065, JWILLIAMS@cpan.org) + + [ DOCUMENTATION ] + - Made licencing information consistent and remove duplicate comments + about licence details, corrected location to report bugs (RT #38285) + +4.01 2014-05-27 + + [ DOCUMENTATION ] + - CGI.pm hasn't been removed from core *just* yet, but will be soon: + http://perl5.git.perl.org/perl.git/commitdiff/e9fa5a80 + +4.00 2014-05-22 + + [ INTERNALS ] + - CGI::Fast split out into its own distribution, related files and tests removed + - developer test added for building with perlbrew + + [ DOCUMENTATION ] + - Update perldoc to explain that CGI.pm has been removed from perl core + - Make =head2 perldoc less shouty (RT #91140) + - Tickets migrated from RT to github issues (both CGI and CGI.pm distributions) + - Repointing bugtracker at newly forked github repo and note that Lee Johnson + is the current maintainer. + - Bump version to 4.00 for clear boundary of above changes + +Version 3.65 Feb 11, 2014 + + [INTERNALS] + - Update Makefile to refine where CGI.pm gets installed + (Thanks to bingo, rjbs: https://github.com/markstos/CGI.pm/pull/30) + +Version 3.64 Nov 23, 2013 + + [BUG FIXES] + - Avoid warning about "undefined variable in user_agent in some cases (RT#72882) + + [INTERNALS] + - Avoiding warning about "unitialized value" in when calling user_agent() in some cases. (RT#72882, perl@max-maurer.de) + - Update minimum required version in Makefile.PL to 5.8.1. It had already been + updated to 5.8.1 in the CGI.pm module in 3.53. + - Fix POD errors reported by newer pod2man (Thanks to jmdh) + - Typo fixes, (dsteinbrunner). + - use deprecate.pm on perls 5.19.0 and later. (rjbs). + + [DOCUMENTATION] + - Update CGI::Cookie docs to reflect that HttpOnly is widely supported now. + + +Version 3.63 Nov 12, 2012 + + [SECURITY] + - CR escaping for Set-Cookie and P3P headers was improved. There was potential + for newline injection in these headers. + (Thanks to anazawa, https://github.com/markstos/CGI.pm/pull/23) + +Version 3.62, Nov 9th, 2012 + + [INTERNALS] + - Changed how the deprecated endform function was defined for compatibility + with the development version of Perl. + - Fix failures in t/tmpdir.t when run as root + https://github.com/markstos/CGI.pm/issues/22, RT#80659) + + - Made it possible to force a sorted order for things like hash + attributes so that tests are not dependent on a particular hash + ordering. This will be required in modern perls which will + change the ordering per process. (Yves, RT#80659) + +Version 3.61 Nov 2nd, 2012 + + (No code changes) + + [INTERNALS] + - formatting of CGI::Carp documentation was improved. Thanks to benkasminbullock. + - un-TODO some tests in t/tmpdir.t that were passing in most cases. + More on this: + https://github.com/markstos/CGI.pm/issues/19# + https://github.com/markstos/CGI.pm/commit/cc73dc9807b0fabb56b3cdf1a9726588b2eda0f7 + +Version 3.60 Aug 15th, 2012 + + [BUG FIXES] + - In some caes, When unescapeHTML() hit something it didn't recognize with an ampersand and + and semicolon, it would throw away the semicolon and ampersand. It now does a better job. + of preserving content it doesn't recognize. Thanks to CEBJYRE@cpan.org (RT#75595) + - Remove trailing newline after <form> tag inserted by startform and start_form. It can + cause rendering problems in some cases. Thanks to SJOHNSTON@cpan.org (RT#67719) + - Workaround "Insecure Dependency" warning generated by some versions of Perl (RT#53733). + Thanks to degatcpan@ntlworld.com, klchu@lbl.gov and Anonymous Monk + + [DOCUMENTATION] + - Clarify that when -status is used, the human-readable phase should be included, per RFC 2616. + Thanks to SREZIC@cpan.org (RT#76691). + + [INTERNALS] + - More tests for header(), thanks to Ryo Anazawa. + - t/url.t has been fixed on VMS. Thanks to cberry@cpan.org (RT#72380) + - MANIFEST patched so that t/multipart_init.t is included again. Thanks to shay@cpan.org (RT#76189) + +Version 3.59 Dec 29th, 2011 + + [BUG FIXES] + - We no longer read from STDIN when the Content-Length is not set, preventing + requests with no Content-Length from freezing in some cases. This is consistent + with the CGI RFC 3875, and is also consistent with CGI::Simple. However, the old + behavior may have been expected by some command-line uses of CGI.pm. + Thanks to Philip Potter and Yanick Champoux. See RT#52469 for details: + https://rt.cpan.org/Public/Bug/Display.html?id=52469 + + [INTERNALS] + - remove tmpdirs more aggressively. Thanks to rjbs (RT#73288) + - use Text::ParseWords instead of ancient shellwords.pl. Thanks to AlexBio. + - remove use of define(@arr). Thanks to rjbs. + - spelling fixes. Thanks to Gregor Herrmann and Alessandro Ghedini. + - fix test count and warning in t/fast.t. Thanks to Yanick. + +Version 3.58 Nov 11th, 2011 + + [DOCUMENTATION] + - Clarify that using query_string() only has defined behavior when using the GET method. (RT#60813) + +Version 3.57 Nov 9th, 2011 + [INTERNALS] + - test failure in t/fast.t introduced in 3.56 is fixed. (Thanks to zefram and chansen). + - Test::More requirement has been bumped to 0.98 + +Version 3.56 Nov 8th, 2011 + + [SECURITY] + Use public and documented FCGI.pm API in CGI::Fast + CGI::Fast was using an FCGI API that was deprecated and removed from + documentation more than ten years ago. Usage of this deprecated API with + FCGI >= 0.70 or FCGI <= 0.73 introduces a security issue. + <https://rt.cpan.org/Public/Bug/Display.html?id=68380> + <http://web.nvd.nist.gov/view/vuln/detail?vulnId=CVE-2011-2766> + (Thanks to chansen) + + [INTERNALS] + - tmp files are now cleaned up on VMS ( RT#69210, thanks to cberry@cpan.org ) + - Fixed test failure: done_testing() added to url.t (Thanks to Ryan Jendoubi) + - Clarify preferred bug submission location in docs, and note that Mark Stosberg + is the current maintainer. + +Version 3.55 June 3rd, 2011 + + [THINGS THAT MAY BREAK YOUR CODE] + url() was fixed to return "PATH_INFO" when it is explicitly requested + with either the path=>1 or path_info=>1 flag. + + If your code is running under mod_rewrite (or compatible) and you are calling self_url() or + you are calling url() and passing path_info=>1, These methods will actually be + returning PATH_INFO now, as you have explicitly requested, or has self_url() + has requested on your behalf. + + The PATH_INFO has been omitted in such URLs since the issue was introduced + in the 3.12 release in December, 2005. + + This bug is so old your application may have come to depend on it or + workaround it. Check for application before upgrading to this release. + + Examples of affected method calls: + + $q->url(-absolute => 1, -query => 1, -path_info => 1 ) + $q->url(-path=>1) + $q->url(-full=>1,-path=>1) + $q->url(-rewrite=>1,-path=>1) + $q->self_url(); + +Version 3.54, Apr 28, 2011 + No code changes + + [INTERNALS] + - Address test failures in t/tmpdir.t, thanks to Niko Tyni. + Some tests here are failing on some platforms and have been marked as TODO. + +Version 3.53, Apr 25, 2011 + + [NEW FEATURES] + - The DELETE HTTP verb is now supported. + (RT#52614, James Robson, Eduardo Ari�o de la Rubia) + + [INTERNALS] + - Correct t/tmpdir.t MANIFEST entry. (RT#64949) + - Update minimum required Perl version to be Perl 5.8.1, which + has been out since 2003. This allows us to drop some hacks + and exceptions (Mark Stosberg) + +Version 3.52, Jan 24, 2011 + + [DOCUMENTATION] + - The documentation for multi-line header handling was been updated to reflect + the changes in 3.51. (Mark Stosberg, ntyni@iki.fi) + + [INTERNALS] + - Add missing t/tmpfile.t file. (RT#64949) + - Fix warning in t/cookie.t (RT#64570, Chris Williams, Rainer Tammer, Mark Stosberg) + - Fixed logic bug in t/multipart_init.t (RT#64261, Niko Tyni) + +Version 3.51, Jan 5, 2011 + + [NEW FEATURES] + - A new option to set $CGI::Carp::TO_BROWSER = 0, allows you to explicitly + exclude a particular scope from triggering printing to the browser when + fatatlsToBrowser is set. (RT#62783, Thanks to papowell) + - The <script> tag now supports the "charset" attribute. + (RT#62907, Thanks to Fabrice Metge) + - In CGI::Cookie, "Max-Age" is now supported for better spec compliance. + (Mark Stosberg) + + [BUG FIXES] + - Setting charset() now works for all content types, not just "text/*". + (RT#57945, Thanks to Yanick and Gerv.) + - support for user temporary directories ($HOME/tmp) was commented out + in 2.61 but the documentation wasn't updated (Peter Gervai, Niko Tyni) + - setting $CGITempFile::TMPDIRECTORY before loading CGI.pm has been + working but undocumented since 3.12 (which listed it in Changes as + $CGI::TMPDIRECTORY) (Peter Gervai, Niko Tyni) + - unfortunately the previous change broke the runtime check for looking + for a new temporary directory if the current one suddenly became + unwritable (Peter Gervai, Niko Tyni) + - A bug was fixed in CGI::Carp triggered by certain death cases in + the BEGIN phase of parent classes. + (RT#57224, Thanks to UNERA, Yanick Champoux, Mark Stosberg) + - CGI::Cookie->new() now follows the documentation and returns undef + if the -name and -value args aren't provided. This new behavior is also + consistent with the docs and code of CGI::Simple::Cookie. (Mark Stosberg) + - CGI::Cookie->parse() now trims leading and trailing whitespace from cookie + elements as intended. The change also makes this part of the parsing + identical to CGI::Simple::Cookie (Mark Stosberg) + - Temp file handling was improved (RT#62762) + + [SECURITY] + - Further improvements have been made to guard against newline injections + in headers. (Thanks to Max Kanat-Alexander, Yanick Champoux, Mark Stosberg) + + [PERFORMANCE] + - Make EBCDIC a compile-time constant so there's zero overhead (and less + compiled code) in subroutines that test for it. (Tim Bunce) + - If you just want to use CGI::Cookie, CGI.pm will no longer be loaded + unless you call the bake() method, which requires it. (Mark Stosberg) + + [DOCUMENTATION] + - quit referring to the <link> tag as being "rarely used". (Victor Sanders) + - typo and whitespace fixes (RT#62785, thanks to scop@cpan.org) + - The -dtd argument to start_html() is now documented + (RT#60473, Thanks to giecrilj and steve@fisharerojo.org) + - CGI::Carp doc are updated to reflect that it can work with mod_perl 2.0. + - when creating a temporary file in the directory fails, the error message + could indicate the root of the problem better (Peter Gervai, Niko Tyni) + + [INTERNALS] + - Re-fixing https test in http.t. (RT#54768, thanks to SPROUT) + - param_fetch no longer triggers a warning when called with no arguments (ysth, Mark Stosberg) + +Version 3.50, Nov 8, 2010 + + [SECURITY] + 1. The MIME boundary in multipart_init is now random. + Thanks to Byron Jones, Masahiro Yamada, Reed Loden, and Mark Stosberg + 2. Further improvements to handling of newlines embedded in header values. + An exception is thrown if header values contain invalid newlines. + Thanks to Michal Zalewski, Max Kanat-Alexander, Yanick Champoux, + Lincoln Stein, Fr�d�ric Buclin and Mark Stosberg + + [DOCUMENTATION] + 1. Correcting/clarifying documentation for param_fetch(). Thanks to + Ren�e B�cker. (RT#59132) + + [INTERNALS] + 1. Fixing https test in http.t. (RT#54768) + 2. Tests were added for multipart_init(). Thanks to Mark Stosberg and CGI::Simple. + +Version 3.49, Feb 5th, 2010 + + [BUG FIXES] + 1. Fix a regression since 3.44 involving a case when the header includes "Content-Length: 0". + Thanks to Alex Vandiver (RT#51109) + 2. Suppress uninitialized warnings under -w. Thanks to burak. (RT#50301) + 3. url() now uses virtual_port() instead of server_port(). Thanks to MKANAT and Yanick Champoux. (RT#51562) + 4. CGI::Carp now properly handles stringifiable objects, like Exception::Class throws (RT#39904) + + [SECURITY] + 1. embedded newlines are now filtered out of header values in header(). + Thanks to Mark Stosberg and Yanick Champoux. + + [DOCUMENTATION] + 1. README was updated to reflect that CGI.pm was moved under ./lib. + Thanks to Alex Vandiver. + + [INTERNALS] + 1. More tests were added for autoescape, thanks to Bob Kuo. (RT#25485) + 2. Attempt to avoid test failures with t/fast, thanks to Steve Hay. (RT#49599) + +Version 3.48, Sep 25, 2009 + + [BUG FIXES] + 1. <optgroup> default values are now properly escaped. + Thanks to #raleigh.pm and Mark Stosberg. (RT#49606) + 2. The change to exception handling in CGI::Carp introduced in 3.47 has been + reverted for now. It caused regressions reported in RT#49630. + Thanks to mkanat for the report. + + [DOCUMENTATION] + 1. Documentation for upload() has been overhauled, thanks to Mark Stosberg. + 2. Documentation for tmpFileName has been added. Thanks to Mark Stosberg and Nathaniel K. Smith. + 3. URLS were updated, thanks to Leon Brocard and Yanick Champoux. (RT#49770) + + [INTERNALS] + 1. More tests were added for autoescape, thanks to Bob Kuo. (RT#25485) + +Version 3.47, Sep 9, 2009 + + No code changes. + + [INTERNALS] + Re-release of 3.46, which did not contain a proper MANIFEST + +Version 3.46 + + [BUG FIXES] + 1. In CGI::Pretty, we no longer add line breaks after tags we claim not to format. Thanks to rrt, Bob Kuo and + and Mark Stosberg. (RT#42114). + 2. unescapeHTML() no longer falsely recognizes certain text as entities. Thanks to Pete Gamanche, Mark Stosberg + and Bob Kuo. (RT#39122) + 3. checkbox_group() now correctly includes a space before the "checked" attribute. + Thanks to Andrew Speer and Bob Kuo. (RT#36583) + 4. Fix case-sensitivity in http() and https() according to docs. Make https() + return list of keys in list context. Thanks to riQyRoe and Rhesa Rozendaal. (RT#12909) + 5. XHTML is now automatically disabled for HTML 4, as well as HTML 2 and HTML 3. Thanks to + Dan Harkless and Yanick Champoux. (RT#27907) + 6. Pre-compiling 'end_form' with ':form' switch now works. Thanks to ryochin and Yanick Champoux. (RT#41530) + 7. Empty name/values pairs are now properly saved and restored from filehandles. Thanks to rlucas and + Rhesa Rozendaal (RT#13158) + 8. Some differences between startform() and start_form() have been fixed. Thanks to Slaven Rezic and + Shawn Corey. (RT#22046) + 9. url_param() has been updated to be more consistent with the documentation and param(). + Thanks to Britton Kerin and Yanick Campoux. (RT#43587) + 10.hidden() now correctly supports multiple default values. + Thanks to david@dierauer.net and Russell Jenkins. (RT#20436) + 11.Calling CGI->new() no longer clobbers the value of $_ in the current scope. + Thanks to Alexey Tourbin, Bob Kuo and Mark Stosberg. (RT#25131) + 12.UTF-8 params should not get double-decoded now. + Thanks to Yves, Bodo, Burak G�rsoy, and Michael Schout. (RT#19913) + 13.We now give objects passed to CGI::Carp::die a chance to be stringified. + Thanks to teek and Yanick Champoux (RT#41530) + 14.Turning off autoEscape() now only affects the behavior of built-in HTML + generation fuctions. Explicit calls to escapeHTML() always escape HTML regardless + of the setting. Thanks to vindex, Bob Kuo and Mark Stosberg (RT#40748) + 15.In CGI::Fast, preferences set via pragmas are now preserved. + Thanks to heinst and Mark Stosberg (RT#32119) + + [DOCUMENTATION] + 1. remote_addr() is now documented. Thanks to Yanick Champoux. (RT#38884) + 2. In CGI::Pretty in the list of tags left unformatted was updated to match the code. Thanks to Mark Stosberg. (RT#42114) + 3. In CGI::Pretty, performance concerns are now documented. Thanks to Jochen, Rhesa Rozendaal and Mark Stosberg (RT#13223) + 4. A number of outdated Netscape references have been removed. Thanks to Mark Stosberg. + 5. The documentation has been purged of examples of using indirect object notation. Thanks to Mark Stosberg. + 6. Some POD formatting was fixed. Thanks to Dave Mitchell (RT#48935). + 7. Docs and examples were updated to highlight start_form instead of startform. + Thanks to Slaven Rezic. + 8. Note that CGI::Carp::carpout() doesn't work with in-memory filehandles. + Thanks to rhubbell and Mark Stosberg. + 9. The documentation for the -newstyle_urls is now less confusing. + Thanks to Ryan Tate and Mark Stosberg (RT#49454) + + [INTERNALS] + 1. Quit bundling an ancient copy of Test::More and and using a custom 'lib' path for the tests. Instead, Test::More + is now a dependency. Thanks to Ansgar and Mark Stosberg (RT#48811) + 2. Automated tests for hidden() have been added, thanks to Russel Jenkins and Mark Stosberg (RT#20436) + 3. t/util.t has been updated to use Test::More instead of a home-grown test function. Thanks to Bob Kuo. + +Version 3.45, Aug 14, 2009 + + [BUG FIXES] + 1. Prevent warnings about "uninitialized values" for REQUEST_URI, HTTP_USER_AGENT and other environment variables. + Patches by Callum Gibson, heiko and Mark Stosberg. (RT#24684, RT#29065) + 2. Avoid death in some cases when running under Taint mode on Windows. + Patch by Peter Hancock (RT#43796) + 3. Allow 0 to be used as a default value in popup_menu(). This was broken starting in 3.37. + Thanks to Haze, who was the first to report this and supply a patch, and pfschill, who pinpointed + when the bug was introduced. A regression test for this was also added. (RT#37908) + 4. Allow "+" as a valid character in file names, which fixes temp file creation on OS X Leopard. + Thanks to Andy Armstrong, and alech for patches. (RT#30504) + 5. Set binmode() on the Netware platform, thanks to Guenter Knauf (RT#27455) + 6. Don't allow a CGI::Carp error handler to die recursively. Print a warning and exit instead. + Thanks to Marc Chantreux. (RT#45956) + 7. The Dump() method now is fixed to escape HTML properly. Thanks to Mark Stosberg (RT#21341) + 8. Support for <optgroup> with scrolling_list() now works the same way as it does for popup_menu(). + Thanks to Stuart Johnston (RT#30097) + 9. CGI::Pretty now works properly when $" is set to ''. Thanks to Jim Keenan (RT#12401) + 10. Fix crash when used in combination with PerlEx::DBI. Thanks to Burak G�rsoy (RT#19902) + + [DOCUMENTATION] + 1. Several typos were fixed, Thanks to ambs. (RT#41105) + 2. A typo related to the nosticky pragma was fixed, thanks to Britton Kerin. (RT#43220) + 3. examples/nph-clock.cgi is now more portable, by calling localtime() rather than `/bin/date`, + thanks to Guenter Knauf. (RT#27456). + 4. In CGI::Carp, the SEE ALSO section was cleaned up, thanks to Slaven Rezic. (RT#32769) + 5. The docs for redirect() were updated to reflect that most headers are + ignored during redirection. Thanks to Mark Stosberg (RT#44911) + + [INTERNALS] + 1. New t/unescapeHTML.t test script has been added. It includes a TODO test for a pre-existing + bug which could use a patch. Thanks to Pete Gamache and Mark Stosberg (RT#39122) + 2. New test scripts have been added for user_agent(), popup_menu() and query_string(), scrolling_list() and Dump() + Thanks to Mark Stosberg and Stuart Johnston. (RT#37908, RT#43006, RT#21341, RT#30097) + 3. CGI::Carp and CGI::Util have been updated to have non-developer version numbers. + Thanks to Slaven Rezic. (RT#48425) + 4. CGI::Switch and CGI::Apache now properly set their VERSION in their own name space. + Thanks to Alexey Tourbin (RT#11941,RT#11942) + +Version 3.44, Jul 30, 2009 + + 1. Patch from Kurt Jaeger to allow HTTP PUT even if the content length is unknown. + 2. Patch from Pavel merdin to fix a problem for one of the FireFox addons. + 3. Fixed issue in mod_perl & fastCGI environment of cookies returned from + CGI->cookie() leaking from one session to another. + +Version 3.43, Apr 06, 2009 + + 1. Documentation patch from MARKSTOS@cpan.org to replace all occurrences of + "new CGI" with CGI->new()" to reflect best perl practices. + 2. Patch from Stepan Kasal to fix utf-8 related problems in perl 5.10 + +Version 3.42, Sep 08, 2008 + + 1. Added patch from Renee Baecker that makes it possible to subclass + CGI::Pretty. + 2. Added patch from Nicholas Clark to allow ~ characters in temporary directories. + 3. Added patch from Renee Baecker that fixes the inappropriate escaping of fields + in multipart headers. + +Version 3.41, Aug 25, 2008 + + 1. Fix url() returning incorrect path when query string contains escaped newline. + 2. Added additional windows temporary directories and environment variables, courtesy patch from Renee Baecker + 3. Added a handle() method to the lightweight upload + filehandles. This method returns a real IO::Handle object. + 4. Added patch from Tony Vanlingen to fix deep recursion warnings in CGI::Pretty. + +Version 3.40, Aug 06, 2008 + + 1. Fixed CGI::Fast docs to eliminate references to a "special" + version of Perl. + 2. Makefile.PL now depends on FCGI so that CGI::Fast installs properly. + 3. Fix script_name() call from Stephane Chazelas. + +Version 3.39, Jun 29, 2008 + + 1. Fixed regression in "exists" function when using tied interface to CGI via $q->Vars. + +Version 3.38, Jun 25, 2008 + + 1. Fix annoying warning in http://rt.cpan.org/Ticket/Display.html?id=34551 + 2. Added nobr() function http://rt.cpan.org/Ticket/Display.html?id=35377 + 3. popup_menu() allows multiple items to be selected by default, satisfying + http://rt.cpan.org/Ticket/Display.html?id=35376 + 4. Patch from Renee Backer to avoid doubled <http-equiv> headers. + 5. Fixed documentation bug that describes what happens when a + parameter is empty (e.g. "?test1="). + 6. Fixed minor warning described at http://rt.cpan.org/Public/Bug/Display.html?id=36435 + 7. Fixed overlap of attribute and parameter space described in http://rt.perl.org/rt3//Ticket/Display.html?id=24294 + +Version 3.37, Apr 22, 2008 + + 1. Fix pragmas so that they persist over modperl invocations (e.g. RT 34761) + 2. Fixed handling of chunked multipart uploads; thanks to Michael Bernhardt + who reported and fixed the problem. + +Version 3.36 + + 1. Fix CGI::Cookie to support cookies that are separated by "," instead of ";". + +Version 3.35, Mar 27, 2008 + + 1. Resync with bleadperl, primarily fixing a bug in parsing semicolons in uploaded filenames. + +Version 3.34, Mar 18, 2008 + + 1. Handle Unicode %uXXXX escapes properly -- patch from DANKOGAI@cpan.org + 2. Fix url() method to not choke on path names that contain regex characters. + +Version 3.33, Jan 02, 2008 + + 1. Remove uninit variable warning when calling url(-relative=>1) + 2. Fix uninit variable warnings for two lc calls + 3. Fixed failure of tempfile upload due to sprintf() taint failure in perl 5.10 + +Version 3.32, Dec 27, 2007 + + 1. Patch from Miguel Santinho to prevent sending premature headers under mod_perl 2.0 + +Version 3.31, Nov 30, 2007 + + 1. Patch from Xavier Robin so that CGI::Carp issues a 500 Status code rather than a 200 status code. + 2. Patch from Alexander Klink to select correct temporary directory in OSX Leopard so that upload works. + 3. Possibly fixed "wrapped pack" error on 5.10 and higher. + +Version 3.30 + + 1. Patch from Mike Barry to handle POSTDATA in the same way as PUT. + 2. Patch from Rafael Garcia-Suarez to correctly reencode unicode values as byte values. + +Version 3.29, Apr 16, 2007 + + 1. The position of file handles is now reset to zero when CGI->new is called. + (Mark Stosberg) + 2. uploadInfo() now works across multiple object instances. Also, the first + tests for uploadInfo() were added as part of the fix. (CPAN bug 11895, with + contributions from drfrench and Mark Stosberg). + +Version 3.28, Mar 29, 2007 + + 1. Applied patch from Allen Day that makes Cookie parsing RFC2109 compliant + (attribute/values can be separated by commas as well as semicolons). + 2. Applied patch from Stephan Struckmann that allows script_name() to be set correctly. + 3. Fixed problem with url(-full) in which port number appears twice. + +Version 3.27, Feb 27, 2007 + + 1. Applied patch from Steve Taylor that allows checkbox_groups to be + disabled with a new -disabled=> option. + +Version 3.26 + + 1. Fixed alternate stylesheet behavior so that it is insensitive to order of declarations. + 2. Patch from John Binns to allow users to provide a callback to CGI::Carp. + 3. Added "~" as an unreserved character in escape(). + 4. Patch from Chris Fedde to prevent HTTP_HOST from inhibiting SERVER_PORT in url() generation. + 5. Fixed outdated documentation (and behavior) of -language in start_html -script option. + 6. Fixed bug in seconds calculation in CGI::Util::expire_calc. + +Version 3.25, Sep 28, 2006 + + 1. Fixed the link to the Netscape frames page. + 2. Added ability to specify an alternate stylesheet. + 3. Add support for XForms POST submssion both as application/xml or as multipart/related + +Version 3.24 + + 1. In startform(), if request_uri() returns undef, then falls back + to self_url(). This should rarely happen except when run outside of + the CGI environment. + 2. image button alignment options were mistakenly being capitalized, causing xhtml validation to fail. + +Version 3.23, Aug 23, 2006 + + 1. Typo in upload() persisted, now fixed for real. Thanks to + Emanuele Zeppieri for correct patch and regression test. + +Version 3.22, Aug 23, 2006 + + 1. Typo in upload() function broke uploads. Now fixed (CPAN bug 21126). + +Version 3.21, Aug 21, 2006 + + 1. Don't try to read data at all when POST > $POST_MAX. + 2. Fixed bug that caused $cgi->param('name',undef,'value') to unset param('name') entirely. + 3. Fixed bug in which upload() sometimes returns empty. (CPAN bug #12694). + 4. Incorporated patch from BURAK@cpan.org to support HTTPcookies (CPAN bug 21019). + +Version 3.20 + + 1. Patch from David Wheeler for CGI::Cookie->bake(). Uses mod_perl headers_out->add() + rather than headers_out->set(). + 2. Fixed problem identified by Andrei Voronkov in which start_form() output was screwed + up when initial argument begins with a dash and subsequent arguments do not. + 3. Quashed uninitialized variable warnings coming from script_name(), url() and other + functions that require access to the PATH_INFO environment variable. + +Version 3.19 + + 1. Added patch from Stephen Frost that allows one to suppress use of the temp file that is + created during uploads. + 2. Fixed problem noted by Martin Foster in which regular expression meta-character terms + in the path information were not quoted, causing URL parsing + to fail on URLs that contained metacharacters (such as +). + 3. More fixes to the url() method. + 4. Removed "hack to fix broken PATH_INFO in MSII". + +Version 3.18 + + 1. Doc typo fixes. + 2. Patch from Steve Peters to default the document type to match the charset. + 3. Fixed param() so that param(-name=>'foo',-values=>[]) sets the parameter to empty list. + +Version 3.17, Feb 24, 2006 + + 1. Added patch from Mike Hanafey which caused 0 arguments to CGI::Cookie->new() to + be treated as empty. + 2. Patch to CGI::Carp from Peter Whaite to fix the unfixable problem of CGI::Carp + not behaving correctly in an eval() context. + 3. CGI::Fast->new() calls CGI->_reset_globals to avoid contamination of one session + with another's variables. + 4. Fixed upload failure on files that contain semicolons in their names. + +Version 3.16, Feb 8, 2006 + + 1. header() -charset option now works even when the MIME type is not "text". + 2. Fixed documentation for cookie() function and fastCGI. + 3. Upload filehandles now only closed automatically on Windows systems. + 4. Apache::Cookie compatibility fix from David Wheeler + 5. CGI::Carp->fatalsToBrowser() does not work correctly with + mod_perl 2. No workaround is known. + 6. Fixed text status code associated with 302 redirects. Should be "Found" + but was "Moved". + 7. Fixed charset in start_html() and header() to be in synch. + +Version 3.15, Dec 7, 2005 + + 1. Remove extraneous "?" from self_url() when URI contains a ? but no query string. + +Version 3.14, Dec 6, 2005 + + 1. Fixed broken scrolling_list() select attribute. + +Version 3.13, Dec 4, 2005 + + 1. Removed extraneous empty "?" from end of self_url(). + +Version 3.12, Dec 4, 2005 + + 1. Fixed virtual_port so that it works properly with https protocol. + 2. Fixed documentation for upload_hook(). + 3. Added POSTDATA documentation. + 4. Made upload_hook() work in function-oriented mode. + 5. Fixed POST_MAX behavior so that it doesn't cause client to hang. + 6. Disabled automatic tab indexes and added new -tabindex pragma to + turn automatic indexes back on. + 7. The url() and self_url() methods now work better in the context of Apache + mod_rewrite. Be advised that path_info() may give you confusing results + when mod_rewrite is active because Apache calculates the path info *after* + rewriting. This is mostly worked around in url() and self_url(), but you + may notice some anomalies. + 8. Removed empty (and non-validating) <div> from code emitted by end_form(). + 9. Fixed CGI::Carp to work correctly with Mod_perl 1.29 in an Apache 2 environment. + 10. Setting $CGI::TMPDIRECTORY should now be effective. + +Version 3.11, Aug 3, 2005 + + 1. Killed warning in CGI::Cookie about MOD_PERL_API_VERSION + 2. Fixed append() so that it works in function mode. + 3. Workaround for a bug that appears in Apache2 versions through 2.0.54 + in which SCRIPT_NAME and PATH_INFO are incorrect if the additional path_info + contains a double slash. This workaround will handle the common case of + http://mysite.com/cgi-bin/log.cgi/http://www.some.other.site/args, but will + not handle the uncommon case of a ScriptAlias directive that adds additional + path information to the end of the translated URI. + +Version 3.10, May 13, 2005 + + 1. Added Apache2::RequestIO, which is necessary for mp2 interoperability. + +Version 3.09, May 5, 2005 + + 1. Fixed tabindex="0" when using CGI to create forms without a prior start_html + 2. Removed warning about non-numeric MOD_PERL_API_VERSION. + +Version 3.08, Apr 20, 2005 + + 1. update support for mod_perl 2.0. versions prior to + mod_perl 1.999_22 (2.0.0-RC5) are no longer supported. + +Version 3.07, Mar 14, 2005 + + 1. Fixed typo in mod_perl detection. + +Version 3.06, Mar 09, 2005 + + 1. Fixed bare call to script() in start_html + 2. Moved Fh::DESTROY out of autoloaded functions so as to avoid + clobbering $@ when CGI functions are executed in an eval{} + context. + 3. mod_perl 2.0 version detection patch in CGI::Cookie provided by + Allen Day. + 4. autoEscape() flag is now respected when generating extra + attributes. + 5. Tests for *tag start/end generation from Shlomi Fish. + 6. Support for can() method provided by Ron Savage. + 7. Fix for lang='' when outputting XHTML. + 8. Added support for chunked transfer encoding, as suggested by + Hakan Ardo + 9. Fixed clobbering of row and column headers in tableized radio + and checkbox groups, as reported by Nicolas Thierry-Mieg. + 10. <Label> tags are now associated with form elements, as suggested + by accessibility guidelines. + 11. The <?xml> directive produced by start_html is now turned off by + default and the charset is specified in a <meta> directive. Apparently + IE6 (and maybe some versions of Opera) were getting confused by this. + 12. Support for tab indexes. + 13. Retired the HTML docs. The POD docs are now primary documentation. + 14. CGI::Carp now correctly detects and handles Apache::Dispatch. + 15. CGI::Util::utf8_chr now correctly sets the UTF8 flag on 5.006 or + higher perls (fix courtesy Slaven Rezic). + + +Version 3.05, Apr 12, 2004 + + 1. Fixed uninitialized variable warning on start_form() when running + from command line. + 2. Fixed CGI::_set_attributes so that attributes with a - are handled + correctly. + 3. Fixed CGI::Carp::die() so as to avoid problems from _longmess() + clobbering @_. + 4. If HTTP_X_FORWARDED_HOST is defined (i.e. running under a proxy), + the various functions that return HOST will use that instead. + 5. Fix for undefined utf8() call in CGI::Util. + 6. Changed the call to warningsToBrowser() in + CGI::Carp::fatalsToBrowser to call only after HTTP header is sent + (thanks to Didier Lebrun for noticing). + 7. Patches from Dan Harkless to make CGI.pm validatable against HTML + 3.2. + 8. Fixed an extraneous "foo=bar" appearing when extra style + parameters passed to start_html; + 9. Fixed cross-site scripting bug in startform() pointed out by Dan + Harkless. + 10. Fixed documentation to discuss list context behavior of + form-element generators explicitly. + 11. Fixed incorrect results from end_form() when called in OO manner. + 12. Fixed query string stripping in order to handle URLs containing + escaped newlines. + 13. During server push, set NPH to 0 rather than 1. This is supposed + to fix problems with Apache. + 14. Fixed incorrect processing of multipart form fields that contain + embedded quotes. There's still the issue of how to handle ones + that contain embedded semicolons, but no one has complained (yet). + 15. Fixed documentation bug in -style argument to start_html() + 16. Added -status argument to redirect(). + +Version 3.04, Jan 18, 2004 + + 1. Fixed the problem with mod_perl crashing when "defaults" button + pressed. + +Version 3.03, Jan 13, 2004 + + 1. Fix upload hook functionality + 2. Workaround for CGI->unescape_html() + 3. Bumped version numbers in CGI::Fast and CGI::Util for 5.8.3-tobe + +Version 3.02 + + 1. Bring in Apache::Response just in case. + 2. File upload on EBCDIC systems now works. + +Version 3.01, Dec 10, 2003 + + 1. No fix yet for upload failures when running on EBCDIC server. + 2. Fixed uninitialized glob warnings that appeared when file + uploading under perl 5.8.2. + 3. Added patch from Schlomi Fish to allow debugging of PATH_INFO from + command line. + 4. Added patch from Steve Hay to correctly unlink tmp files under + mod_perl/windows + 5. Added upload_hook functionality from Jamie LeTaul + 6. Workarounds for mod_perl 2 IO issues. Check that file upload and + state saving still working. + 7. Added code for underreads. + 8. Fixed misleading description of redirect() and relative URLs in + the POD docs. + 9. Workaround for weird interaction of CGI::Carp with Safe module + reported by William McKee. + 10. Added patches from Ilmari Karonen to improve behavior of + CGI::Carp. + 11. Fixed documentation error in -style argument. + 12. Added virtual_port() method for finding out what port server is + listening on in a virtual-host aware fashion. + +Version 3.00, Aug 18, 2003 + + 1. Patch from Randal Schwartz to fix bug introduced by cross-site + scripting vulnerability "fix." + 2. Patch from JFreeman to replace UTF-8 escape constant of 0xfe with + 0xfc. Hope this is right! + + Version 2.99 + + 1. Patch from Steve Hay to fix extra Content-type: appearing on + browser screen when FatalsToBrowser invoked. + 2. Patch from Ewann Corvellec to fix cross-site scripting + vulnerability. + 3. Fixed tmpdir routine for file uploading to solve problem that + occurs under mod_perl when tmpdir is writable at startup time, but + not at session time. + + Version 2.98 + + 1. Fixed crash in Dump() function. + + Version 2.97 + + 1. Sigh. Uploaded wrong 2.96 to CPAN. + + Version 2.96 + + 1. More bugfixes to the -style argument. + + Version 2.95 + + 1. Fixed bugs in start_html(-style=>...) support introduced in 2.94. + + Version 2.94 + + 1. Removed warning from reset() method. + 2. Moved + + and tags into the :html3 group. Hope this removes undefined CGI::Area + errors. + + Changed CGI::Carp to play with mod_perl2 and to (hopefully) restore + reporting of compile-time errors. + + Fixed potential deadlock between web server and CGI.pm when aborting + a read due to POST_MAX (reported by Antti Lankila). + + Fixed issue with tag-generating function not incorporating content + when first variable undef. + + Fixed cross-site scripting bug reported by obscure. + + Fixed Dump() function to return correctly formed XHTML - bug + reported by Ralph Siemsen. + + Version 2.93 + + 1. Fixed embarassing bug in mp1 support. + + Version 2.92 + + 1. Fix to be P3P compliant submitted from MPREWITT. + 2. Added CGI->r() API for mod_perl1/mod_perl2. + 3. Fixed bug in redirect() that was corrupting cookies. + 4. Minor fix to behavior of reset() button to make it consistent with + submit() button (first time this has been changed in 9 years). + 5. Patch from Dan Kogai to handle UTF-8 correctly in 5.8 and higher. + 6. Patch from Steve Hay to make CGI::Carp's error messages appear on + MSIE browsers. + 7. Added Yair Lenga's patch for non-urlencoded postings. + 8. Added Stas Bekman's patches for mod_perl 2 compatibility. + 9. Fixed uninitialized escape behavior submitted by William Campbell. + 10. Fixed tied behavior so that you can pass arguments to tie() + 11. Fixed incorrect generation of URLs when the path_info contains + + and other odd characters. + 12. Fixed redirect(-cookies=>$cookie) problem. + 13. Fixed tag generation bug that affects -javascript passed to + start_html(). + + Version 2.91 + + 1. Attribute generation now correctly respects the value of + autoEscape(). + 2. Fixed endofrm() syntax error introduced by Ben Edgington's patch. + + Version 2.90 + + 1. Fixed bug in redirect header handling. + 2. Added P3P option to header(). + 3. Patches from Alexey Mahotkin to make CGI::Carp work correctly with + object-oriented exceptions. + 4. Removed inaccurate description of how to set multiple cookies from + CGI::Cookie pod file. + 5. Patch from Kevin Mahony to prevent running out of filehandles when + uploading lots of files. + 6. Documentation enhancement from Mark Fisher to note that the + import_names() method transforms the parameter names into valid + Perl names. + 7. Patch from Dan Harkless to suppress lang attribute in <html> tag + if specified as a null string. + 8. Patch from Ben Edgington to fix broken XHTML-transitional 1.0 + validation on endform(). + 9. Custom html header fix from Steffen Beyer (first letter correctly + upcased now) + 10. Added a -verbatim option to stylesheet generation from Michael + Dickson + 11. Faster delete() method from Neelam Gupta + 12. Fixed broken Cygwin support. + 13. Added empty charset support from Bradley Baetz + 14. Patches from Doug Perham and Kevin Mahoney to fix file upload + failures when uploaded file is a multiple of 4096. + + Version 2.89 + + 1. Fixed behavior of ACTION tag when POSTING to a URL that has a + query string. + 2. Added Patch from Michael Rommel to handle multipart/mixed uploads + from Opera + + Version 2.88 + + 1. Fixed problem with uploads being refused under Perl 5.8 when under + Taint mode. + 2. Fixed uninitialized variable warnings under Perl 5.8. + 3. Fixed CGI::Pretty regression test failures. + + Version 2.87 + + 1. Security hole patched: when processing multipart/form-data + postings, most arguments were being untainted silently. Returned + arguments are now tainted correctly. This may cause some scripts + to fail that used to work (thanks to Nick Cleaton for pointing + this out and persisting until it was fixed). + 2. Update for mod_perl 2.0. + 3. Pragmas such as -no_xhtml are now respected in mod_perl + environment. + + Version 2.86 + + 1. Fixes for broken CGI::Cookie expiration dates introduced in 2.84. + + Version 2.85 + + 1. Fix for broken autoEscape function introduced in 2.84. + + Version 2.84 + + 1. Fix for failed file uploads on Cygwin platforms. + 2. HTML escaping code now replaced 0x8b and 0x9b with unicode + references < and *#8250; + + Version 2.83 + + 1. Fixed autoEscape() documentation inconsistencies. + 2. Patch from Ville Skytt� to fix a number of XHTML inconsistencies. + 3. Added Max-Age to list of CGI::Cookie headers. + + Version 2.82 + + 1. Patch from Rudolf Troller to add attribute setting and option + groups to form fields. + 2. Patch from Simon Perreault for silent crashes when using CGI::Carp + under mod_perl. + 3. Patch from Scott Gifford allows you to set the program name for + CGI::Carp. + + Version 2.81 + + 1. Removed extraneous slash from end of stylesheet tags generated by + start_html in non-XHTML mode. + 2. Changed behavior of CGI::Carp with respect to eval{} contexts so + that output behaves properly in mod_perl environments. + 3. Fixed default DTD so that it validates with W3C validator. + + Version 2.80 + + 1. Fixed broken messages in CGI::Carp. + 2. Changed checked="1" to checked="checked" for real XHTML + compatibility. + 3. Resurrected REQUEST_URI code so that url() works correctly with + multiviews. + + Version 2.79 + + 1. Changes to CGI::Carp to avoid "subroutine redefined" error + messages. + 2. Default DTD is now XHTML 1.0 Transitional + 3. Patches to support all HTML4 tags. + + Version 2.78 + + 1. Added ability to change encoding in <?xml> assertion. + 2. Fixed the old escapeHTML('CGI') ne "CGI" bug + 3. In accordance with XHTML requirements, there are no longer any + minimized attributes, such as "checked". + 4. Patched bug which caused file uploads of exactly 4096 bytes to be + truncated to 4094 (thanks to Kevin Mahony) + 5. New tests and fixes to CGI::Pretty (thanks to Michael Schwern). + + Version 2.77 + + 1. No new features, but released in order to fix an apparent CPAN + bug. + + Version 2.76 + + 1. New esc.t regression test for EBCDIC translations courtesy Peter + Prymmer. + 2. Patches from James Jurach to make compatible with FCGI-ProcManager + 3. Additional fields passed to header() (like -Content_disposition) + now honor initial capitalization. + 4. Patch from Andrew McNaughton to handle utf-8 escapes (%uXXXX + codes) in URLs. + + Version 2.752 + + 1. Syntax error in the autoloaded Fh::new() subroutine. + 2. Better error reporting in autoloaded functions. + + Version 2.751 + + 1. Tiny tweak to filename regular expression function on line 3355. + + Version 2.75 + + 1. Fixed bug in server push boundary strings (CGI.pm and CGI::Push). + 2. Fixed bug that occurs when uploading files with funny characters + in the name + 3. Fixed non-XHTML-compliant attributes produced by textfield() + 4. Added EPOC support, courtesy Olaf Flebbe + 5. Fixed minor XHTML bugs. + 6. Made escape() and unescape() symmetric with respect to EBCDIC, + courtesy Roca, Ignasi <ignasi.roca@fujitsu.siemens.es> + 7. Removed uninitialized variable warning from CGI::Cookie, provided + by Atipat Rojnuckarin <rojnuca@yahoo.com> + 8. Fixed bug in CGI::Pretty that causes it to print partial end tags + when the $INDENT global is changed. + 9. Single quotes are changed to character entity ' for compatibility + with URLs. + + Version 2.74 + + September 13, 2000 + 1. Quashed one-character bug that caused CGI.pm to fail on file + uploads. + + Version 2.73 + + September 12, 2000 + 1. Added -base to the list of arguments accepted by url(). + 2. Fixes to XHTML support. + 3. POST parameters no longer show up in the Location box. + + Version 2.72 + + August 19, 2000 + 1. Fixed the defaults button so that it works again + 2. Charset is now correctly saved and restored when saving to files + 3. url() now works correctly when given scripts with %20 and other + escapes in the additional path info. This undoes a patch + introduced in version 2.47 that I no longer understand the + rationale for. + + Version 2.71 + + August 13, 2000 + 1. Newlines in the value attributes of hidden fields and other form + elements are now escaped when using ISO-Latin. + 2. Inline script and style sections are now protected as CDATA + sections when XHTML mode is on (the default). + + Version 2.70 + + August 4, 2000 + 1. Fixed bug in scrolling_list() which omitted a space in front of + the "multiple" attribute. + 2. Squashed the "useless use of string in void context" message from + redirects. + + Version 2.69 + + 1. startform() now creates default ACTION for POSTs as well as GETs. + This may break some browsers, but it no longer violates the HTML + spec. + 2. CGI.pm now emits XHTML by default. Disable with -no_xhtml. + 3. We no longer interpret &#ddd sequences in non-latin character + sets. + + Version 2.68 + + 1. No longer attempts to escape characters when dealing with non + ISO-8861 character sets. + 2. checkbox() function now defaults to using -value as its label, + rather than -name. The current behavior is what has been + documented from the beginning. + 3. -style accepts array reference to incorporate multiple stylesheets + into document. + + 1. Fixed two bugs that caused the -compile pragma to fail with a + syntax error. + + Version 2.67 + + 1. Added XHTML support (incomplete; tags need to be lowercased). + 2. Fixed CGI/Carp when running under mod_perl. Probably broke in + other contexts. + 3. Fixed problems when passing multiple cookies. + 4. Suppress warnings from _tableize() that were appearing when using + -w switch with radio_group() and checkbox_group(). + 5. Support for the header() -attachment argument, which can give + pages a default file name when saving to disk. + + Version 2.66 + + 1. 2.65 changes in make_attributes() broke HTTP header functions + (including redirect), so made it context sensitive. + + Version 2.65 + + 1. Fixed regression tests to skip tests that require implicit fork on + machines without fork(). + 2. Changed make_attributes() to automatically escape any HTML + reserved characters. + 3. Minor documentation fix in javascript example. + + Version 2.64 + + 1. Changes introduced in 2.63 broke param() when retrieving parameter + lists containing only a single argument. This is now fixed. + 2. self_url() now defaults to returning parameters delimited with + semicolon. Use the pragma -oldstyle_urls to get the old "&" + delimiter. + + Version 2.63 + + 1. Fixed CGI::Push to pull out parameters correctly. + 2. Fixed redirect() so that it works with default character set + 3. Changed param() so as to returned empty string '' when referring + to variables passed in query strings like 'name1=&name2' + + Version 2.62 + + 1. Fixed broken ReadParse() function, and added regression tests + 2. Fixed broken CGI::Pretty, and added regression tests + + Version 2.61 + + 1. Moved more functions from CGI.pm proper into CGI/Util.pm. + CGI/Cookie should now be standalone. + 2. Disabled per-user temporary directories, which were causing grief. + + Version 2.60 + + 1. Fixed junk appearing in autogenerated HTML functions when using + object-oriented mode. + + Version 2.59 + + 1. autoescape functionality breaks too much existing code, removed + it. + 2. use escapeHTML() manually + + Version 2.58 + + This is the release version of 2.57. + + Version 2.57 + + 1. Added -debug pragma and turned off auto reading of STDIN. + 2. Default DTD updated to HTML 4.01 transitional. + 3. Added charset() method and the -charset argument to header(). + 4. Fixed behavior of escapeHTML() to respect charset() and to escape + nasty Windows characters (thanks to Tom Christiansen). + 5. Handle REDIRECT_QUERY_STRING correctly. + 6. Removed use_named_parameters() because of dependency problems and + general lameness. + 7. Fixed problems with bad HREF links generated by url(-relative=>1) + when the url is like /people/. + 8. Silenced a warning on upload (patch provided by Jonas Liljegren) + 9. Fixed race condition in CGI::Carp when errors occur during parsing + (patch provided by Maurice Aubrey). + 10. Fixed failure of url(-path_info=>1) when path contains % signs. + 11. Fixed warning from CGI::Cookie when receiving foreign cookies that + don't use name=value format. + 12. Fixed incompatibilities with file uploading on VMS systems. + + Version 2.56 + + 1. Fixed bugs in file upload introduced in version 2.55 + 2. Fixed long-standing bug that prevented two files with identical + names from being uploaded. + + Version 2.55 + + 1. Fixed cookie regression test so as not to produce an error. + 2. Fixed path_info() and self_url() to work correctly together when + path_info() modified. + 3. Removed manify warnings from CGI::{Switch,Apache}. + + Version 2.54 + + 1. This will be the last release of the monolithic CGI.pm module. + Later versions will be modularized and optimized. + 2. DOMAIN tag no longer added to cookies by default. This will break + some versions of Internet Explorer, but will avoid breaking + networks which use host tables without fully qualified domain + names. For compatibility, please always add the -domain tag when + creating cookies. + 3. Fixed escape() method so that +'s are treated correctly. + 4. Updated CGI::Pretty module. + + Version 2.53 + + 1. Forgot to upgrade regression tests before releasing 2.52. NOTHING + ELSE HAS CHANGED IN LIBRARY + + Version 2.52 + + 1. Spurious newline in checkbox() routine removed. (courtesy John + Essen) + 2. TEXTAREA linebreaks now respected in dump() routine. (courtesy + John Essen) + 3. Patches for DOS ports (courtesy Robert Davies) + 4. Patches for VMS + 5. More fixes for cookie problems + 6. Fix CGI::Carp so that it doesn't affect eval{} blocks (courtesy + Byron Brummer) + + Version 2.51 + + 1. Fixed problems with cookies not being remembered when sent to IE + 5.0 (and Netscape 5.0 too?) + 2. Numerous HTML compliance problems in cgi_docs.html; fixed thanks + to Michael Leahy + + Version 2.50 + + 1. Added a new Vars() method to retrieve all parameters as a tied + hash. + 2. Untainted tainted tempfile name so that script doesn't fail on + terminal unlink. + 3. Made picking of upload tempfile name more intelligent so that + doesn't fail in case of name collision. + 4. Fixed handling of expire times when passed an absolute timestamp. + 5. Changed dump() to Dump() to avoid name clashes. + + Version 2.49 + + 1. Fixes for FastCGI (globals not getting reset) + 2. Fixed url() to correctly handle query string and path under + MOD_PERL + + Version 2.48 + + 1. Reverted detection of MOD_PERL to avoid breaking PerlEX. + + Version 2.47 + + 1. Patch to fix file upload bug appearing in IE 3.01 for + Macintosh/PowerPC. + 2. Replaced use of $ENV{SCRIPT_NAME} with $ENV{REQUEST_URI} when + running under Apache, to fix self-referencing URIs. + 3. Fixed bug in escapeHTML() which caused certain constructs, such as + CGI->image_button(), to fail. + 4. Fixed bug which caused strong('CGI') to fail. Be careful to use + CGI::strong('CGI') and not CGI->strong('CGI'). The latter will + produce confusing results. + 5. Added upload() function, as a preferred replacement for the + "filehandle as string" feature. + 6. Added cgi_error() function. + 7. Rewrote file upload handling to return undef rather than dieing + when an error is encountered. Be sure to call cgi_error() to find + out what went wrong. + + Version 2.46 + + 1. Fix for failure of the "include" tests under mod_perl + 2. Added end_multipart_form to prevent failures during qw(-compile + :all) + + Version 2.45 + + 1. Multiple small documentation fixes + 2. CGI::Pretty didn't get into 2.44. Fixed now. + + Version 2.44 + + 1. Fixed file descriptor leak in upload function. + 2. Fixed bug in header() that prevented fields from containing double + quotes. + 3. Added Brian Paulsen's CGI::Pretty package for pretty-printing + output HTML. + 4. Removed CGI::Apache and CGI::Switch from the distribution. + 5. Generated start_* shortcuts so that start_table(), end_table(), + start_ol(), end_ol(), and so forth now work (see the docs on how + to enable this feature). + 6. Changed accept() to Accept(), sub() to Sub(). There's still a + conflict with reset(), but this will break too many existing + scripts! + + Version 2.43 + + 1. Fixed problem with "use strict" and file uploads (thanks to Peter + Haworth) + 2. Fixed problem with not MSIE 3.01 for the power_mac not doing file + uploads right. + 3. Fixed problem with file upload on IIS 4.0 when authorization in + use. + 4. -content_type and '-content-type' can now be provided to header() + as synonyms for -type. + 5. CGI::Carp now escapes the ampersand BEFORE escaping the > and < + signs. + 6. Fixed "not an array reference" error when passing a hash reference + to radio_group(). + 7. Fixed non-removal of uploaded TMP files on NT platforms which + occurs when server runs on non-C drive (thanks to Steve Kilbane + for finding this one). + + Version 2.42 + + 1. Too many screams of anguish at changed behavior of url(). Is now + back to its old behavior by default, with options to generate all + the variants. + 2. Added regression tests. "make test" now works. + 3. Documentation fixes. + 4. Fixes for Macintosh uploads, but uploads STILL do not work pending + changes to MacPerl. + + Version 2.41 + + 1. url() method now includes the path info. Use script_name() to get + it without path info(). + 2. Changed handling of empty attributes in HTML tag generation. Be + warned! Use table({-border=>undef}) rather than + table({-border=>''}). + 3. Changes to allow uploaded filenames to be compared to other + strings with "eq", "cmp" and "ne". + 4. Changes to allow CGI.pm to coexist more peacefully with + ActiveState PerlEX. + 5. Changes to prevent exported variables from clashing when importing + ":all" set in combination with cookies. + + Version 2.40 + + 1. CGI::Carp patched to work better with mod_perl (thanks to Chris + Dean). + 2. Uploads of files whose names begin with numbers or the Windows + \\UNC\shared\file nomenclature should no longer fail. + 3. The <STYLE> tag (for cascading style sheets) now generates the + required TYPE attribute. + 4. Server push primitives added, thanks to Ed Jordan. + 5. Table and other HTML3 functions are now part of the :standard set. + 6. Small documentation fixes. + + TO DO: + 1. Do something about the DTD mess. The module should generate + correct DTDs, or at least offer the programmer a way to specify + the correct one. + 2. Split CGI.pm into CGI processing and HTML-generating modules. + 3. More robust file upload (?still not working on the Macintosh?). + 4. Bring in all the HTML4 functionality, particular the accessibility + features. + + Version 2.39 + + 1. file uploads failing because of VMS patch; fixed. + 2. -dtd parameter was not being properly processed. + + Version 2.38 + + I finally got tired of all the 2.37 betas and released 2.38. The main + difference between this version and the last 2.37 beta (2.37b30) are + some fixes for VMS. This should allow file upload to work properly on + all VMS Web servers. + + Version 2.37, various beta versions + + 1. Added a CGI::Cookie::parse() method for lucky mod_perl users. + 2. No longer need separate -values and -labels arguments for + multi-valued form elements. + 3. Added better interface to raw cookies (fix courtesy Ken Fox, + kfox@ford.com) + 4. Added param_fetch() function for direct access to parameter list. + 5. Fix to checkbox() to allow for multi-valued single checkboxes + (weird problem). + 6. Added a compile() method for those who want to compile without + importing. + 7. Documented the import pragmas a little better. + 8. Added a -compile switch to the use clause for the long-suffering + mod_perl and Perl compiler users. + 9. Fixed initialization routines so that FileHandle and type globs + work correctly (and hash initialization doesn't fail!). + 10. Better deletion of temporary files on NT systems. + 11. Added documentation on escape(), unescape(), unescapeHTML() and + unescapeHTML() subroutines. + 12. Added documentation on creating subclasses. + 13. Fixed problem when calling $self->SUPER::foo() from inheriting + subclasses. + 14. Fixed problem using filehandles from within subroutines. + 15. Fixed inability to use the string "CGI" as a parameter. + 16. Fixed exponentially growing $FILLUNIT bug + 17. Check for undef filehandle in read_from_client() + 18. Now requires the UNIVERSAL.pm module, present in Perl 5.003_7 or + higher. + 19. Fixed problem with uppercase-only parameters being ignored. + 20. Fixed vanishing cookie problem. + 21. Fixed warning in initialize_globals() under mod_perl. + 22. File uploads from Macintosh versions of MSIE should now work. + 23. Pragmas now preceded by dashes (-nph) rather than colons (:nph). + Old style is supported for backward compatibility. + 24. Can now pass arguments to all functions using {} brackets, + resolving historical inconsistencies. + 25. Removed autoloader warnings about absent MultipartBuffer::DESTROY. + 26. Fixed non-sticky checkbox() when -name used without -value. + 27. Hack to fix path_info() in IIS 2.0. Doesn't help with IIS 3.0. + 28. Parameter syntax for debugging from command line now more + straightforward. + 29. Added $DISABLE_UPLOAD to disable file uploads. + 30. Added $POST_MAX to error out if POSTings exceed some ceiling. + 31. Fixed url_param(), which wasn't working at all. + 32. Fixed variable suicide problem in s///e expressions, where the + autoloader was needed during evaluation. + 33. Removed excess spaces between elements of checkbox and radio + groups + 34. Can now create "valueless" submit buttons + 35. Can now set path_info as well as read it. + 36. ReadParse() now returns a useful function result. + 37. import_names() now allows you to optionally clear out the + namespace before importing (for mod_perl users) + 38. Made it possible to have a popup menu or radio button with a value + of "0". + 39. link() changed to Link() to avoid overriding native link function. + 40. Takes advantage of mod_perl's register_cleanup() function to clear + globals. + 41. <LAYER> and <ILAYER> added to :html3 functions. + 42. Fixed problems with private tempfiles and NT/IIS systems. + 43. No longer prints the DTD by default (I bet no one will complain). + 44. Allow underscores to replace internal hyphens in parameter names. + 45. CGI::Push supports heterogeneous MIME types and adjustable delays + between pages. + 46. url_param() method added for retrieving URL parameters even when a + fill-out form is POSTed. + 47. Got rid of warnings when radio_group() is called. + 48. Cookies now moved to their very own module. + 49. Fixed documentation bug in CGI::Fast. + 50. Added a :no_debug pragma to the import list. + + Version 2.36 + + 1. Expanded JavaScript functionality + 2. Preliminary support for cascading stylesheets + 3. Security fixes for file uploads: + + Module will bail out if its temporary file already exists + + Temporary files can now be made completely private to avoid + peeking by other users or CGI scripts. + 4. use CGI qw/:nph/ wasn't working correctly. Now it is. + 5. Cookie and HTTP date formats didn't meet spec. Thanks to Mark + Fisher (fisherm@indy.tce.com) for catching and fixing this. + + p + + Version 2.35 + + 1. Robustified multipart file upload against incorrect syntax in + POST. + 2. Fixed more problems with mod_perl. + 3. Added -noScript parameter to start_html(). + 4. Documentation fixes. + + Version 2.34 + + 1. Stupid typo fix + + Version 2.33 + + 1. Fixed a warning about an undefined environment variable. + 2. Doug's patch for redirect() under mod_perl + 3. Partial fix for busted inheritence from CGI::Apache + 4. Documentation fixes. + + Version 2.32 + + 1. Improved support for Apache's mod_perl. + 2. Changes to better support inheritance. + 3. Support for OS/2. + + Version 2.31 + + 1. New uploadInfo() method to obtain header information from uploaded + files. + 2. cookie() without any arguments returns all the cookies passed to a + script. + 3. Removed annoying warnings about $ENV{NPH} when running with the -w + switch. + 4. Removed operator overloading throughout to make compatible with + new versions of perl. + 5. -expires now implies the -date header, to avoid clock skew. + 6. WebSite passes cookies in $ENV{COOKIE} rather than + $ENV{HTTP_COOKIE}. We now handle this, even though it's O'Reilly's + fault. + 7. Tested successfully against new sfio I/O layer. + 8. Documentation fixes. + + Version 2.30 + + 1. Automatic detection of operating system at load time. + 2. Changed select() function to Select() in order to avoid conflict + with Perl built-in. + 3. Added Tr() as an alternative to TR(); some people think it looks + better that way. + 4. Fixed problem with autoloading of MultipartBuffer::DESTROY code. + 5. Added the following methods: + + virtual_host() + + server_software() + 6. Automatic NPH mode when running under Microsoft IIS server. + + Version 2.29 + + 1. Fixed cookie bugs + 2. Fixed problems that cropped up when useNamedParameters was set to + 1. + 3. Prevent CGI::Carp::fatalsToBrowser() from crapping out when + encountering a die() within an eval(). + 4. Fixed problems with filehandle initializers. + + Version 2.28 + + 1. Added support for NPH scripts; also fixes problems with Microsoft + IIS. + 2. Fixed a problem with checkbox() values not being correctly saved + and restored. + 3. Fixed a bug in which CGI objects created with empty string + initializers took on default values from earlier CGI objects. + 4. Documentation fixes. + + Version 2.27 + + 1. Small but important bug fix: the automatic capitalization of tag + attributes was accidentally capitalizing the VALUES as well as the + ATTRIBUTE names (oops). + + Version 2.26 + + 1. Changed behavior of scrolling_list(), checkbox() and + checkbox_group() methods so that defaults are honored correctly. + The "fix" causes endform() to generate additional <INPUT + TYPE="HIDDEN"> tags -- don't be surpised. + 2. Fixed bug involving the detection of the SSL protocol. + 3. Fixed documentation error in position of the -meta argument in + start_html(). + 4. HTML shortcuts now generate tags in ALL UPPERCASE. + 5. start_html() now generates correct SGML header: + <!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML//EN"> + + 6. CGI::Carp no longer fails "use strict refs" pragma. + + Version 2.25 + + 1. Fixed bug that caused bad redirection on destination URLs with + arguments. + 2. Fixed bug involving use_named_parameters() followed by + start_multipart_form() + 3. Fixed bug that caused incorrect determination of binmode for + Macintosh. + 4. Spelling fixes on documentation. + + Version 2.24 + + 1. Fixed bug that caused generation of lousy HTML for some form + elements + 2. Fixed uploading bug in Windows NT + 3. Some code cleanup (not enough) + + Version 2.23 + + 1. Fixed an obscure bug that caused scripts to fail mysteriously. + 2. Fixed auto-caching bug. + 3. Fixed bug that prevented HTML shortcuts from passing taint checks. + 4. Fixed some -w warning problems. + + Version 2.22 + + 1. New CGI::Fast module for use with FastCGI protocol. See pod + documentation for details. + 2. Fixed problems with inheritance and autoloading. + 3. Added TR() (<tr>) and PARAM() (<param>) methods to list of + exported HTML tag-generating functions. + 4. Moved all CGI-related I/O to a bottleneck method so that this can + be overridden more easily in mod_perl (thanks to Doug MacEachern). + 5. put() method as substitute for print() for use in mod_perl. + 6. Fixed crash in tmpFileName() method. + 7. Added tmpFileName(), startform() and endform() to export list. + 8. Fixed problems with attributes in HTML shortcuts. + 9. Functions that don't actually need access to the CGI object now no + longer generate a default one. May speed things up slightly. + 10. Aesthetic improvements in generated HTML. + 11. New examples. + + Version 2.21 + + 1. Added the -meta argument to start_html(). + 2. Fixed hidden fields (again). + 3. Radio_group() and checkbox_group() now return an appropriate + scalar value when called in a scalar context, rather than + returning a numeric value! + 4. Cleaned up the formatting of form elements to avoid unesthetic + extra spaces within the attributes. + 5. HTML elements now correctly include the closing tag when + parameters are present but null: em('') + 6. Added password_field() to the export list. + + Version 2.20 + + 1. Dumped the SelfLoader because of problems with running with taint + checks and rolled my own. Performance is now significantly + improved. + 2. Added HTML shortcuts. + 3. import() now adheres to the Perl module conventions, allowing + CGI.pm to import any or all method names into the user's name + space. + 4. Added the ability to initialize CGI objects from strings and + associative arrays. + 5. Made it possible to initialize CGI objects with filehandle + references rather than filehandle strings. + 6. Added the delete_all() and append() methods. + 7. CGI objects correctly initialize from filehandles on NT/95 systems + now. + 8. Fixed the problem with binary file uploads on NT/95 systems. + 9. Fixed bug in redirect(). + 10. Added '-Window-target' parameter to redirect(). + 11. Fixed import_names() so that parameter names containing funny + characters work. + 12. Broke the unfortunate connection between cookie and CGI parameter + name space. + 13. Fixed problems with hidden fields whose values are 0. + 14. Cleaned up the documentation somewhat. + + Version 2.19 + + 1. Added cookie() support routines. + 2. Added -expires parameter to header(). + 3. Added cgi-lib.pl compatibility mode. + 4. Made the module more configurable for different operating systems. + 5. Fixed a dumb bug in JavaScript button() method. + + Version 2.18 + + 1. Fixed a bug that corrects a hang that occurs on some platforms + when processing file uploads. Unfortunately this disables the + check for bad Netscape uploads. + 2. Fixed bizarre problem involving the inability to process uploaded + files that begin with a non alphabetic character in the file name. + 3. Fixed a bug in the hidden fields involving the -override directive + being ignored when scalar defaults were passed. + 4. Added documentation on how to disable the SelfLoader features. + + Version 2.17 + + 1. Added support for the SelfLoader module. + 2. Added oodles of JavaScript support routines. + 3. Fixed bad bug in query_string() method that caused some parameters + to be silently dropped. + 4. Robustified file upload code to handle premature termination by + the client. + 5. Exported temporary file names on file upload. + 6. Removed spurious "uninitialized variable" warnings that appeared + when running under 5.002. + 7. Added the Carp.pm library to the standard distribution. + 8. Fixed a number of errors in this documentation, and probably added + a few more. + 9. Checkbox_group() and radio_group() now return the buttons as + arrays, so that you can incorporate the individual buttons into + specialized tables. + 10. Added the '-nolabels' option to checkbox_group() and + radio_group(). Probably should be added to all the other + HTML-generating routines. + 11. Added the url() method to recover the URL without the entire query + string appended. + 12. Added request_method() to list of environment variables available. + 13. Would you believe it? Fixed hidden fields again! + + Version 2.16 + + 1. Fixed hidden fields yet again. + 2. Fixed subtle problems in the file upload method that caused + intermittent failures (thanks to Keven Hendrick for this one). + 3. Made file upload more robust in the face of bizarre behavior by + the Macintosh and Windows Netscape clients. + 4. Moved the POD documentation to the bottom of the module at the + request of Stephen Dahmen. + 5. Added the -xbase parameter to the start_html() method, also at the + request of Stephen Dahmen. + 6. Added JavaScript form buttons at Stephen's request. I'm not sure + how to use this Netscape extension correctly, however, so for now + the form() method is in the module as an undocumented feature. Use + at your own risk! + + Version 2.15 + + 1. Added the -override parameter to all field-generating methods. + 2. Documented the user_name() and remote_user() methods. + 3. Fixed bugs that prevented empty strings from being recognized as + valid textfield contents. + 4. Documented the use of framesets and added a frameset example. + + Version 2.14 + + This was an internal experimental version that was never released. + + Version 2.13 + + 1. Fixed a bug that interfered with the value "0" being entered into + text fields. + + Version 2.01 + + 1. Added -rows and -columns to the radio and checkbox groups. No + doubt this will cause much grief because it seems to promise a + level of meta-organization that it doesn't actually provide. + 2. Fixed a bug in the redirect() method -- it was not truly HTTP/1.0 + compliant. + + Version 2.0 + + The changes seemed to touch every line of code, so I decided to bump + up the major version number. + 1. Support for named parameter style method calls. This turns out + to be a big win for extending CGI.pm when Netscape adds new HTML + "features". + 2. Changed behavior of hidden fields back to the correct "sticky" + behavior. This is going to break some programs, but it is for + the best in the long run. + 3. Netscape 2.0b2 broke the file upload feature. CGI.pm now handles + both 2.0b1 and 2.0b2-style uploading. It will probably break again + in 2.0b3. + 4. There were still problems with library being unable to distinguish + between a form being loaded for the first time, and a subsequent + loading with all fields blank. We now forcibly create a default + name for the Submit button (if not provided) so that there's + always at least one parameter. + 5. More workarounds to prevent annoying spurious warning messages + when run under the -w switch. -w is seriously broken in perl + 5.001! + + Version 1.57 + + 1. Support for the Netscape 2.0 "File upload" field. + 2. The handling of defaults for selected items in scrolling lists and + multiple checkboxes is now consistent. + + Version 1.56 + + 1. Created true "pod" documentation for the module. + 2. Cleaned up the code to avoid many of the spurious "use of + uninitialized variable" warnings when running with the -w switch. + 3. Added the autoEscape() method. v + 4. Added string interpolation of the CGI object. + 5. Added the ability to pass additional parameters to the <BODY> tag. + 6. Added the ability to specify the status code in the HTTP header. + + Bug fixes in version 1.55 + + 1. Every time self_url() was called, the parameter list would grow. + This was a bad "feature". + 2. Documented the fact that you can pass "-" to radio_group() in + order to prevent any button from being highlighted by default. + + Bug fixes in version 1.54 + + 1. The user_agent() method is now documented; + 2. A potential security hole in import() is now plugged. + 3. Changed name of import() to import_names() for compatibility with + CGI:: modules. + + Bug fixes in version 1.53 + + 1. Fixed several typos in the code that were causing the following + subroutines to fail in some circumstances + 1. checkbox() + 2. hidden() + 2. No features added + + New features added in version 1.52 + + 1. Added backslashing, quotation marks, and other shell-style escape + sequences to the parameters passed in during debugging off-line. + 2. Changed the way that the hidden() method works so that the default + value always overrides the current one. + 3. Improved the handling of sticky values in forms. It's now less + likely that sticky values will get stuck. + 4. If you call server_name(), script_name() and several other methods + when running offline, the methods now create "dummy" values to + work with. + + Bugs fixed in version 1.51 + + 1. param() when called without arguments was returning an array of + length 1 even when there were no parameters to be had. Bad bug! + Bad! + 2. The HTML code generated would break if input fields contained the + forbidden characters ">< or &. You can now use these characters + freely. + + New features added in version 1.50 + + 1. import() method allows all the parameters to be imported into a + namespace in one fell swoop. + 2. Parameters are now returned in the same order in which they were + defined. + + Bugs fixed in version 1.45 + + 1. delete() method didn't work correctly. This is now fixed. + 2. reset() method didn't allow you to set the name of the button. + Fixed. + + Bugs fixed in version 1.44 + + 1. self_url() didn't include the path information. This is now fixed. + + New features added in version 1.43 + + 1. Added the delete() method. + + New features added in version 1.42 + + 1. The image_button() method to create clickable images. + 2. A few bug fixes involving forms embedded in <PRE> blocks. + + New features added in version 1.4 + + 1. New header shortcut methods + + redirect() to create HTTP redirection messages. + + start_html() to create the HTML title, complete with the + recommended <LINK> tag that no one ever remembers to include. + + end_html() for completeness' sake. + 2. A new save() method that allows you to write out the state of an + script to a file or pipe. + 3. An improved version of the new() method that allows you to restore + the state of a script from a file or pipe. With (2) this gives you + dump and restore capabilities! (Wow, you can put a "121,931 + customers served" banner at the bottom of your pages!) + 4. A self_url() method that allows you to create state-maintaining + hypertext links. In addition to allowing you to maintain the state + of your scripts between invocations, this lets you work around a + problem that some browsers have when jumping to internal links in + a document that contains a form -- the form information gets lost. + 5. The user-visible labels in checkboxes, radio buttons, popup menus + and scrolling lists have now been decoupled from the values sent + to your CGI script. Your script can know a checkbox by the name of + "cb1" while the user knows it by a more descriptive name. I've + also added some parameters that were missing from the text fields, + such as MAXLENGTH. + 6. A whole bunch of methods have been added to get at environment + variables involved in user verification and other obscure + features. + + Bug fixes + + 1. The problems with the hidden fields have (I hope at last) been + fixed. + 2. You can create multiple query objects and they will all be + initialized correctly. This simplifies the creation of multiple + forms on one page. + 3. The URL unescaping code works correctly now. diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..f481e58 --- /dev/null +++ b/MANIFEST @@ -0,0 +1,88 @@ +Changes +examples/clickable_image.cgi +examples/cookie.cgi +examples/crash.cgi +examples/file_upload.cgi +examples/mojo_proxy.pl +examples/wikipedia_example.cgi +examples/wilogo.gif +lib/CGI.pm +lib/CGI.pod +lib/Fh.pm +lib/CGI/Carp.pm +lib/CGI/Cookie.pm +lib/CGI/Pretty.pm +lib/CGI/Push.pm +lib/CGI/Util.pm +lib/CGI/File/Temp.pm +lib/CGI/HTML/Functions.pm +lib/CGI/HTML/Functions.pod +Makefile.PL +MANIFEST This list of files +README.md +t/Dump.t +t/arbitrary_handles.t +t/autoescape.t +t/can.t +t/carp.t +t/cgi.t +t/changes.t +t/charset.t +t/checkbox_group.t +t/compiles_pod.t +t/cookie.t +t/delete.t +t/end_form.t +t/form.t +t/function.t +t/gh-155.t +t/headers.t +t/headers/attachment.t +t/headers/charset.t +t/headers/cookie.t +t/headers/default.t +t/headers/nph.t +t/headers/p3p.t +t/headers/target.t +t/headers/type.t +t/hidden.t +t/html.t +t/html_functions.t +t/http.t +t/init.t +t/init_test.txt +t/multipart_init.t +t/multipart_start.t +t/no_tabindex.t +t/param_fetch.t +t/param_list_context.t +t/popup_menu.t +t/postdata.t +t/pretty.t +t/push.t +t/query_string.t +t/redirect_query_string.t +t/request.t +t/rt-31107.t +t/rt-52469.t +t/rt-57524.t +t/rt-75628.t +t/rt-84767.t +t/rt_31107.txt +t/rt_75628.txt +t/save_read_roundtrip.t +t/sorted.t +t/start_end_asterisk.t +t/start_end_end.t +t/start_end_start.t +t/unescapeHTML.t +t/upload.t +t/uploadInfo.t +t/upload_post_text.txt +t/url.t +t/user_agent.t +t/utf8.t +t/util-58.t +t/util.t +META.yml Module YAML meta-data (added by MakeMaker) +META.json Module JSON meta-data (added by MakeMaker) diff --git a/META.json b/META.json new file mode 100644 index 0000000..304d045 --- /dev/null +++ b/META.json @@ -0,0 +1,64 @@ +{ + "abstract" : "Handle Common Gateway Interface requests and responses", + "author" : [ + "unknown" + ], + "dynamic_config" : 1, + "generated_by" : "ExtUtils::MakeMaker version 7.0401, CPAN::Meta::Converter version 2.150001", + "license" : [ + "unknown" + ], + "meta-spec" : { + "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", + "version" : "2" + }, + "name" : "CGI", + "no_index" : { + "directory" : [ + "t", + "inc", + "t" + ] + }, + "prereqs" : { + "build" : { + "requires" : {} + }, + "configure" : { + "requires" : {} + }, + "runtime" : { + "requires" : { + "Carp" : "0", + "Config" : "0", + "Encode" : "0", + "Exporter" : "0", + "File::Spec" : "0.82", + "File::Temp" : "0", + "HTML::Entities" : "3.69", + "base" : "0", + "if" : "0", + "overload" : "0", + "parent" : "0.225", + "perl" : "5.008001", + "strict" : "0", + "utf8" : "0", + "warnings" : "0" + } + } + }, + "release_status" : "stable", + "resources" : { + "bugtracker" : { + "web" : "https://github.com/leejo/CGI.pm/issues" + }, + "homepage" : "https://metacpan.org/module/CGI", + "license" : [ + "http://dev.perl.org/licenses/" + ], + "repository" : { + "url" : "https://github.com/leejo/CGI.pm" + } + }, + "version" : "4.21" +} diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..2a51f1e --- /dev/null +++ b/META.yml @@ -0,0 +1,40 @@ +--- +abstract: 'Handle Common Gateway Interface requests and responses' +author: + - unknown +build_requires: {} +configure_requires: {} +dynamic_config: 1 +generated_by: 'ExtUtils::MakeMaker version 7.0401, CPAN::Meta::Converter version 2.150001' +license: unknown +meta-spec: + url: http://module-build.sourceforge.net/META-spec-v1.4.html + version: '1.4' +name: CGI +no_index: + directory: + - t + - inc + - t +requires: + Carp: '0' + Config: '0' + Encode: '0' + Exporter: '0' + File::Spec: '0.82' + File::Temp: '0' + HTML::Entities: '3.69' + base: '0' + if: '0' + overload: '0' + parent: '0.225' + perl: '5.008001' + strict: '0' + utf8: '0' + warnings: '0' +resources: + bugtracker: https://github.com/leejo/CGI.pm/issues + homepage: https://metacpan.org/module/CGI + license: http://dev.perl.org/licenses/ + repository: https://github.com/leejo/CGI.pm +version: '4.21' diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..b06ef59 --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,69 @@ +use ExtUtils::MakeMaker; +my $mm = $ExtUtils::MakeMaker::VERSION; + +# See lib/ExtUtils/MakeMaker.pm for details of how to influence +# the contents of the Makefile that is written. +WriteMakefile( + INSTALLDIRS => ( $] >= 5.012 ? 'site' : 'perl' ), + ABSTRACT_FROM => 'lib/CGI.pod', + VERSION_FROM => 'lib/CGI.pm', + NAME => 'CGI', + DISTNAME => 'CGI', + VERSION_FROM => 'lib/CGI.pm', + MIN_PERL_VERSION => '5.8.1', + PREREQ_PM => { + 'Carp' => 0, # Carp was first released with perl 5 + 'Exporter' => 0, # Exporter was first released with perl 5 + 'base' => 0, # base was first released with perl 5.00405 + 'overload' => 0, # overload was first released with perl 5.002 + 'strict' => 0, # strict was first released with perl 5 + 'utf8' => 0, # utf8 was first released with perl v5.6.0 + 'warnings' => 0, # warnings was first released with perl v5.6.0 + 'File::Spec' => 0.82, + 'if' => 0, # core in 5.6.2 and later, for deprecate.pm + 'parent' => 0.225, # parent was first released with perl v5.10.1 + 'File::Temp' => 0, # was first released with perl v5.6.1' + 'HTML::Entities' => 3.69, + 'Encode' => 0, # Encode was first released with perl v5.7.3 + 'Config' => 0, # Config was first released with perl 5.00307 + }, + TEST_REQUIRES => { + 'Cwd' => 0, # Cwd was first released with perl 5 + 'POSIX' => 0, # POSIX was first released with perl 5 + 'IO::File' => 0, # IO::File was first released with perl 5.00307 + 'IO::Handle' => 0, # IO::Handle was first released with perl 5.00307 + 'File::Find' => 0, # File::Find was first released with perl 5 + 'Test::Deep' => 0.11, + 'Test::More' => 0.98, + 'Test::Warn' => 0.30, + 'Test::NoWarnings' => 1.04, + }, + test => { TESTS => 't/*.t t/headers/*.t' }, + linkext => { LINKTYPE => '' }, # no link needed + dist => { + COMPRESS => 'gzip -9f', + SUFFIX => 'gz', + ZIP => '/usr/bin/zip', + ZIPFLAGS => '-rl' + }, + ( + $mm < 6.46 + ? () + : ( + META_MERGE => { + requires => { perl => '5.008001' }, + resources => { + license => 'http://dev.perl.org/licenses/', + homepage => 'https://metacpan.org/module/CGI', + repository => 'https://github.com/leejo/CGI.pm', + bugtracker => 'https://github.com/leejo/CGI.pm/issues', + }, + no_index => { directory => [qw/t/] }, + }, + META_ADD => { + build_requires => {}, + configure_requires => {} + }, + ) + ), +); diff --git a/README.md b/README.md new file mode 100644 index 0000000..69bff30 --- /dev/null +++ b/README.md @@ -0,0 +1,1781 @@ +# NAME + +CGI - Handle Common Gateway Interface requests and responses + +<div> + + <a href='https://travis-ci.org/leejo/CGI.pm?branch=master'><img src='https://travis-ci.org/leejo/CGI.pm.svg?branch=master' alt='Build Status' /></a> + <a href='https://coveralls.io/r/leejo/CGI.pm'><img src='https://coveralls.io/repos/leejo/CGI.pm/badge.png?branch=master' alt='Coverage Status' /></a> +</div> + +# SYNOPSIS + + use strict; + use warnings; + + use CGI; + + my $q = CGI->new; + + # Process an HTTP request + my @values = $q->multi_param('form_field'); + my $value = $q->param('param_name'); + + my $fh = $q->upload('file_field'); + + my $riddle = $query->cookie('riddle_name'); + my %answers = $query->cookie('answers'); + + # Prepare various HTTP responses + print $q->header(); + print $q->header('application/json'); + + my $cookie1 = $q->cookie( + -name => 'riddle_name', + -value => "The Sphynx's Question" + ); + + my $cookie2 = $q->cookie( + -name => 'answers', + -value => \%answers + ); + + print $q->header( + -type => 'image/gif', + -expires => '+3d', + -cookie => [ $cookie1,$cookie2 ] + ); + + print $q->redirect('http://somewhere.else/in/movie/land'); + +# DESCRIPTION + +CGI.pm is a stable, complete and mature solution for processing and preparing +HTTP requests and responses. Major features including processing form +submissions, file uploads, reading and writing cookies, query string generation +and manipulation, and processing and preparing HTTP headers. + +CGI.pm performs very well in a vanilla CGI.pm environment and also comes +with built-in support for mod\_perl and mod\_perl2 as well as FastCGI. + +It has the benefit of having developed and refined over 20 years with input +from dozens of contributors and being deployed on thousands of websites. +CGI.pm was included in the perl distribution from perl v5.4 to v5.20, however +is has now been removed from the perl core... + +# CGI.pm HAS BEEN REMOVED FROM THE PERL CORE + +[http://perl5.git.perl.org/perl.git/commitdiff/e9fa5a80](http://perl5.git.perl.org/perl.git/commitdiff/e9fa5a80) + +If you upgrade to a new version of perl or if you rely on a +system or vendor perl and get an updated version of perl through a system +update, then you will have to install CGI.pm yourself with cpan/cpanm/a vendor +package/manually. To make this a little easier the [CGI::Fast](https://metacpan.org/pod/CGI::Fast) module has been +split into its own distribution, meaning you do not need access to a compiler +to install CGI.pm + +The rationale for this decision is that CGI.pm is no longer considered good +practice for developing web applications, **including** quick prototyping and +small web scripts. There are far better, cleaner, quicker, easier, safer, +more scalable, more extensible, more modern alternatives available at this point +in time. These will be documented with [CGI::Alternatives](https://metacpan.org/pod/CGI::Alternatives). + +For more discussion on the removal of CGI.pm from core please see: + +[http://www.nntp.perl.org/group/perl.perl5.porters/2013/05/msg202130.html](http://www.nntp.perl.org/group/perl.perl5.porters/2013/05/msg202130.html) + +Note that the v4 releases of CGI.pm will retain back compatibility **as much** +**as possible**, however you may need to make some minor changes to your code +if you are using deprecated methods or some of the more obscure features of the +module. If you plan to upgrade to v4.00 and beyond you should read the Changes +file for more information and **test your code** against CGI.pm before deploying +it. + +# HTML Generation functions should no longer be used + +**All** HTML generation functions within CGI.pm are no longer being +maintained. Any issues, bugs, or patches will be rejected unless +they relate to fundamentally broken page rendering. + +The rationale for this is that the HTML generation functions of CGI.pm +are an obfuscation at best and a maintenance nightmare at worst. You +should be using a template engine for better separation of concerns. +See [CGI::Alternatives](https://metacpan.org/pod/CGI::Alternatives) for an example of using CGI.pm with the +[Template::Toolkit](https://metacpan.org/pod/Template::Toolkit) module. + +These functions, and perldoc for them, will continue to exist in the +v4 releases of CGI.pm but may be deprecated (soft) in v5 and beyond. +All documentation for these functions has been moved to [CGI::HTML::Functions](https://metacpan.org/pod/CGI::HTML::Functions). + +# Programming style + +There are two styles of programming with CGI.pm, an object-oriented (OO) +style and a function-oriented style. You are recommended to use the OO +style as CGI.pm will create an internal default object when the functions +are called procedurally and you will not have to worry about method names +clashing with perl builtins. + +In the object-oriented style you create one or more CGI objects and then +use object methods to create the various elements of the page. Each CGI +object starts out with the list of named parameters that were passed to +your CGI script by the server. You can modify the objects, save them to a +file or database and recreate them. Because each object corresponds to the +"state" of the CGI script, and because each object's parameter list is +independent of the others, this allows you to save the state of the +script and restore it later. + +For example, using the object oriented style: + + #!/usr/bin/env perl + + use strict; + use warnings; + + use CGI; # load CGI routines + + my $q = CGI->new; # create new CGI object + print $q->header; # create the HTTP header + + ... + +In the function-oriented style, there is one default CGI object that +you rarely deal with directly. Instead you just call functions to +retrieve CGI parameters, manage cookies, and so on. The following example +is identical to above, in terms of output, but uses the function-oriented +interface. The main differences are that we now need to import a set of +functions into our name space (usually the "standard" functions), and we don't +need to create the CGI object. + + #!/usr/bin/env perl + + use strict; + use warnings; + + use CGI qw/:standard/; # load standard CGI routines + print header(); # create the HTTP header + + ... + +The examples in this document mainly use the object-oriented style. See HOW +TO IMPORT FUNCTIONS for important information on function-oriented programming +in CGI.pm + +## Calling CGI.pm routines + +Most CGI.pm routines accept several arguments, sometimes as many as 20 +optional ones! To simplify this interface, all routines use a named +argument calling style that looks like this: + + print $q->header( + -type => 'image/gif', + -expires => '+3d', + ); + +Each argument name is preceded by a dash. Neither case nor order matters in +the argument list: -type, -Type, and -TYPE are all acceptable. In fact, only +the first argument needs to begin with a dash. If a dash is present in the +first argument CGI.pm assumes dashes for the subsequent ones. + +Several routines are commonly called with just one argument. In the case +of these routines you can provide the single argument without an argument +name. header() happens to be one of these routines. In this case, the single +argument is the document type. + + print $q->header('text/html'); + +Other such routines are documented below. + +Sometimes named arguments expect a scalar, sometimes a reference to an array, +and sometimes a reference to a hash. Often, you can pass any type of argument +and the routine will do whatever is most appropriate. For example, the param() +routine is used to set a CGI parameter to a single or a multi-valued value. +The two cases are shown below: + + $q->param( + -name => 'veggie', + -value => 'tomato', + ); + + $q->param( + -name => 'veggie', + -value => [ qw/tomato tomahto potato potahto/ ], + ); + +Many routines will do something useful with a named argument that it doesn't +recognize. For example, you can produce non-standard HTTP header fields by +providing them as named arguments: + + print $q->header( + -type => 'text/html', + -cost => 'Three smackers', + -annoyance_level => 'high', + -complaints_to => 'bit bucket', + ); + +This will produce the following nonstandard HTTP header: + + HTTP/1.0 200 OK + Cost: Three smackers + Annoyance-level: high + Complaints-to: bit bucket + Content-type: text/html + +Notice the way that underscores are translated automatically into hyphens. + +## Creating a new query object (object-oriented style) + + my $query = CGI->new; + +This will parse the input (from POST, GET and DELETE methods) and store +it into a perl5 object called $query. Note that because the input parsing +happens at object instantiation you have to set any CGI package variables +that control parsing **before** you call CGI->new. + +Any filehandles from file uploads will have their position reset to the +beginning of the file. + +## Creating a new query object from an input file + + my $query = CGI->new( $input_filehandle ); + +If you provide a file handle to the new() method, it will read parameters +from the file (or STDIN, or whatever). The file can be in any of the forms +describing below under debugging (i.e. a series of newline delimited +TAG=VALUE pairs will work). Conveniently, this type of file is created by +the save() method (see below). Multiple records can be saved and restored. + +Perl purists will be pleased to know that this syntax accepts references to +file handles, or even references to filehandle globs, which is the "official" +way to pass a filehandle. You can also initialize the CGI object with a +FileHandle or IO::File object. + +If you are using the function-oriented interface and want to initialize CGI +state from a file handle, the way to do this is with **restore\_parameters()**. +This will (re)initialize the default CGI object from the indicated file handle. + + open( my $in_fh,'<',"test.in") || die "Couldn't open test.in for read: $!"; + restore_parameters( $in_fh ); + close( $in_fh ); + +You can also initialize the query object from a hash reference: + + my $query = CGI->new( { + 'dinosaur' => 'barney', + 'song' => 'I love you', + 'friends' => [ qw/ Jessica George Nancy / ] + } ); + +or from a properly formatted, URL-escaped query string: + + my $query = CGI->new('dinosaur=barney&color=purple'); + +or from a previously existing CGI object (currently this clones the parameter +list, but none of the other object-specific fields, such as autoescaping): + + my $old_query = CGI->new; + my $new_query = CGI->new($old_query); + +To create an empty query, initialize it from an empty string or hash: + + my $empty_query = CGI->new(""); + + -or- + + my $empty_query = CGI->new({}); + +## Fetching a list of keywords from the query + + my @keywords = $query->keywords + +If the script was invoked as the result of an ISINDEX search, the parsed +keywords can be obtained as an array using the keywords() method. + +## Fetching the names of all the parameters passed to your script + + my @names = $query->multi_param + + my @names = $query->param + +If the script was invoked with a parameter list +(e.g. "name1=value1&name2=value2&name3=value3"), the param() / multi\_param() +methods will return the parameter names as a list. If the script was invoked +as an ISINDEX script and contains a string without ampersands +(e.g. "value1+value2+value3"), there will be a single parameter named +"keywords" containing the "+"-delimited keywords. + +The array of parameter names returned will be in the same order as they were +submitted by the browser. Usually this order is the same as the order in which +the parameters are defined in the form (however, this isn't part of the spec, +and so isn't guaranteed). + +## Fetching the value or values of a single named parameter + + my @values = $query->multi_param('foo'); + + -or- + + my $value = $query->param('foo'); + +Pass the param() / multi\_param() method a single argument to fetch the value +of the named parameter. If the parameter is multivalued (e.g. from multiple +selections in a scrolling list), you can ask to receive an array. Otherwise +the method will return a single value. + +**Warning** - calling param() in list context can lead to vulnerabilities if +you do not sanitise user input as it is possible to inject other param +keys and values into your code. This is why the multi\_param() method exists, +to make it clear that a list is being returned, note that param() can still +be called in list context and will return a list for back compatibility. + +The following code is an example of a vulnerability as the call to param will +be evaluated in list context and thus possibly inject extra keys and values +into the hash: + + my %user_info = ( + id => 1, + name => $query->param('name'), + ); + +The fix for the above is to force scalar context on the call to ->param by +prefixing it with "scalar" + + name => scalar $query->param('name'), + +If you call param() in list context with an argument a warning will be raised +by CGI.pm, you can disable this warning by setting $CGI::LIST\_CONTEXT\_WARN to 0 +or by using the multi\_param() method instead + +If a value is not given in the query string, as in the queries "name1=&name2=", +it will be returned as an empty string. + +If the parameter does not exist at all, then param() will return undef in scalar +context, and the empty list in a list context. + +## Setting the value(s) of a named parameter + + $query->param('foo','an','array','of','values'); + +This sets the value for the named parameter 'foo' to an array of values. This +is one way to change the value of a field AFTER the script has been invoked +once before. + +param() also recognizes a named parameter style of calling described in more +detail later: + + $query->param( + -name => 'foo', + -values => ['an','array','of','values'], + ); + + -or- + + $query->param( + -name => 'foo', + -value => 'the value', + ); + +## Appending additional values to a named parameter + + $query->append( + -name =>'foo', + -values =>['yet','more','values'], + ); + +This adds a value or list of values to the named parameter. The values are +appended to the end of the parameter if it already exists. Otherwise the +parameter is created. Note that this method only recognizes the named argument +calling syntax. + +## Importing all parameters into a namespace + + $query->import_names('R'); + +This creates a series of variables in the 'R' namespace. For example, $R::foo, +@R:foo. For keyword lists, a variable @R::keywords will appear. If no namespace +is given, this method will assume 'Q'. **WARNING**: don't import anything into +'main'; this is a major security risk! + +NOTE 1: Variable names are transformed as necessary into legal perl variable +names. All non-legal characters are transformed into underscores. If you need +to keep the original names, you should use the param() method instead to access +CGI variables by name. + +In fact, you should probably not use this method at all given the above caveats +and security risks. + +## Deleting a parameter completely + + $query->delete('foo','bar','baz'); + +This completely clears a list of parameters. It sometimes useful for resetting +parameters that you don't want passed down between script invocations. + +If you are using the function call interface, use "Delete()" instead to avoid +conflicts with perl's built-in delete operator. + +## Deleting all parameters + + $query->delete_all(); + +This clears the CGI object completely. It might be useful to ensure that all +the defaults are taken when you create a fill-out form. + +Use Delete\_all() instead if you are using the function call interface. + +## Handling non-urlencoded arguments + +If POSTed data is not of type application/x-www-form-urlencoded or +multipart/form-data, then the POSTed data will not be processed, but instead +be returned as-is in a parameter named POSTDATA. To retrieve it, use code like +this: + + my $data = $query->param('POSTDATA'); + +Likewise if PUTed data can be retrieved with code like this: + + my $data = $query->param('PUTDATA'); + +(If you don't know what the preceding means, worry not. It only affects people +trying to use CGI for XML processing and other specialized tasks) + +PUTDATA/POSTDATA are also available via +[upload\_hook](#progress-bars-for-file-uploads-and-avoiding-temp-files), +and as [file uploads](#processing-a-file-upload-field) via ["-putdata\_upload"](#putdata_upload) +option. + +## Direct access to the parameter list + + $q->param_fetch('address')->[1] = '1313 Mockingbird Lane'; + unshift @{$q->param_fetch(-name=>'address')},'George Munster'; + +If you need access to the parameter list in a way that isn't covered by the +methods given in the previous sections, you can obtain a direct reference to +it by calling the **param\_fetch()** method with the name of the parameter. This +will return an array reference to the named parameter, which you then can +manipulate in any way you like. + +You can also use a named argument style using the **-name** argument. + +## Fetching the parameter list as a hash + + my $params = $q->Vars; + print $params->{'address'}; + my @foo = split("\0",$params->{'foo'}); + my %params = $q->Vars; + + use CGI ':cgi-lib'; + my $params = Vars(); + +Many people want to fetch the entire parameter list as a hash in which the keys +are the names of the CGI parameters, and the values are the parameters' values. +The Vars() method does this. Called in a scalar context, it returns the +parameter list as a tied hash reference. Changing a key changes the value of +the parameter in the underlying CGI parameter list. Called in a list context, +it returns the parameter list as an ordinary hash. This allows you to read the +contents of the parameter list, but not to change it. + +When using this, the thing you must watch out for are multivalued CGI +parameters. Because a hash cannot distinguish between scalar and list context, +multivalued parameters will be returned as a packed string, separated by the +"\\0" (null) character. You must split this packed string in order to get at the +individual values. This is the convention introduced long ago by Steve Brenner +in his cgi-lib.pl module for perl version 4, and may be replaced in future +versions with array references. + +If you wish to use Vars() as a function, import the _:cgi-lib_ set of function +calls (also see the section on CGI-LIB compatibility). + +## Saving the state of the script to a file + + $query->save(\*FILEHANDLE) + +This will write the current state of the form to the provided filehandle. You +can read it back in by providing a filehandle to the new() method. Note that +the filehandle can be a file, a pipe, or whatever. + +The format of the saved file is: + + NAME1=VALUE1 + NAME1=VALUE1' + NAME2=VALUE2 + NAME3=VALUE3 + = + +Both name and value are URL escaped. Multi-valued CGI parameters are represented +as repeated names. A session record is delimited by a single = symbol. You can +write out multiple records and read them back in with several calls to **new**. +You can do this across several sessions by opening the file in append mode, +allowing you to create primitive guest books, or to keep a history of users' +queries. Here's a short example of creating multiple session records: + + use strict; + use warnings; + use CGI; + + open (my $out_fh,'>>','test.out') || die "Can't open test.out: $!"; + my $records = 5; + for ( 0 .. $records ) { + my $q = CGI->new; + $q->param( -name => 'counter',-value => $_ ); + $q->save( $out_fh ); + } + close( $out_fh ); + + # reopen for reading + open (my $in_fh,'<','test.out') || die "Can't open test.out: $!"; + while (!eof($in_fh)) { + my $q = CGI->new($in_fh); + print $q->param('counter'),"\n"; + } + +The file format used for save/restore is identical to that used by the Whitehead +Genome Center's data exchange format "Boulderio", and can be manipulated and +even databased using Boulderio utilities. See [Boulder](https://metacpan.org/pod/Boulder) for further details. + +If you wish to use this method from the function-oriented (non-OO) interface, +the exported name for this method is **save\_parameters()**. + +## Retrieving cgi errors + +Errors can occur while processing user input, particularly when processing +uploaded files. When these errors occur, CGI will stop processing and return +an empty parameter list. You can test for the existence and nature of errors +using the _cgi\_error()_ function. The error messages are formatted as HTTP +status codes. You can either incorporate the error text into a page, or use +it as the value of the HTTP status: + + if ( my $error = $q->cgi_error ) { + print $q->header( -status => $error ); + print "Error: $error"; + exit 0; + } + +When using the function-oriented interface (see the next section), errors may +only occur the first time you call _param()_. Be ready for this! + +## Using the function-oriented interface + +To use the function-oriented interface, you must specify which CGI.pm +routines or sets of routines to import into your script's namespace. +There is a small overhead associated with this importation, but it +isn't much. + + use strict; + use warnings; + + use CGI qw/ list of methods /; + +The listed methods will be imported into the current package; you can +call them directly without creating a CGI object first. This example +shows how to import the **param()** and **header()** +methods, and then use them directly: + + use strict; + use warnings; + + use CGI qw/ param header /; + print header('text/plain'); + my $zipcode = param('zipcode'); + +More frequently, you'll import common sets of functions by referring +to the groups by name. All function sets are preceded with a ":" +character as in ":cgi" (for CGI protocol handling methods). + +Here is a list of the function sets you can import: + +- **:cgi** + + Import all CGI-handling methods, such as **param()**, **path\_info()** + and the like. + +- **:all** + + Import all the available methods. For the full list, see the CGI.pm + code, where the variable %EXPORT\_TAGS is defined. (N.B. the :cgi-lib + imports will **not** be included in the :all import, you will have to + import :cgi-lib to get those) + +Note that in the interests of execution speed CGI.pm does **not** use +the standard [Exporter](https://metacpan.org/pod/Exporter) syntax for specifying load symbols. This may +change in the future. + +## Pragmas + +In addition to the function sets, there are a number of pragmas that you can +import. Pragmas, which are always preceded by a hyphen, change the way that +CGI.pm functions in various ways. Pragmas, function sets, and individual +functions can all be imported in the same use() line. For example, the +following use statement imports the cgi set of functions and enables +debugging mode (pragma -debug): + + use strict; + use warninigs; + use CGI qw/ :cgi -debug /; + +The current list of pragmas is as follows: + +- -no\_undef\_params + + This keeps CGI.pm from including undef params in the parameter list. + +- -utf8 + + This makes CGI.pm treat all parameters as text strings rather than binary + strings (see [perlunitut](https://metacpan.org/pod/perlunitut) for the distinction), assuming UTF-8 for the + encoding. + + CGI.pm does the decoding from the UTF-8 encoded input data, restricting this + decoding to input text as distinct from binary upload data which are left + untouched. Therefore, a ':utf8' layer must **not** be used on STDIN. + + If you do not use this option you can manually select which fields are + expected to return utf-8 strings and convert them using code like this: + + use strict; + use warnings; + + use CGI; + use Encode qw/ decode /; + + my $cgi = CGI->new; + my $param = $cgi->param('foo'); + $param = decode( 'UTF-8',$param ); + +- -putdata\_upload + + Makes `$cgi->param('PUTDATA');` and `$cgi->param('POSTDATA');` + act like file uploads named PUTDATA and POSTDATA. See + ["Handling non-urlencoded arguments"](#handling-non-urlencoded-arguments) and ["Processing a file upload field"](#processing-a-file-upload-field) + PUTDATA/POSTDATA are also available via + [upload\_hook](#progress-bars-for-file-uploads-and-avoiding-temp-files). + +- -nph + + This makes CGI.pm produce a header appropriate for an NPH (no parsed header) + script. You may need to do other things as well to tell the server that the + script is NPH. See the discussion of NPH scripts below. + +- -newstyle\_urls + + Separate the name=value pairs in CGI parameter query strings with semicolons + rather than ampersands. For example: + + ?name=fred;age=24;favorite_color=3 + + Semicolon-delimited query strings are always accepted, and will be emitted by + self\_url() and query\_string(). newstyle\_urls became the default in version + 2.64. + +- -oldstyle\_urls + + Separate the name=value pairs in CGI parameter query strings with ampersands + rather than semicolons. This is no longer the default. + +- -no\_debug + + This turns off the command-line processing features. If you want to run a CGI.pm + script from the command line, and you don't want it to read CGI parameters from + the command line or STDIN, then use this pragma: + + use CGI qw/ -no_debug :standard /; + +- -debug + + This turns on full debugging. In addition to reading CGI arguments from the + command-line processing, CGI.pm will pause and try to read arguments from STDIN, + producing the message "(offline mode: enter name=value pairs on standard input)" + features. + + See the section on debugging for more details. + +# GENERATING DYNAMIC DOCUMENTS + +Most of CGI.pm's functions deal with creating documents on the fly. Generally +you will produce the HTTP header first, followed by the document itself. CGI.pm +provides functions for generating HTTP headers of various types. + +Each of these functions produces a fragment of HTTP which you can print out +directly so that it is processed by the browser, appended to a string, or saved +to a file for later use. + +## Creating a standard http header + +Normally the first thing you will do in any CGI script is print out an HTTP +header. This tells the browser what type of document to expect, and gives other +optional information, such as the language, expiration date, and whether to +cache the document. The header can also be manipulated for special purposes, +such as server push and pay per view pages. + + use strict; + use warnings; + + use CGI; + + my $cgi = CGI->new; + + print $cgi->header; + + -or- + + print $cgi->header('image/gif'); + + -or- + + print $cgi->header('text/html','204 No response'); + + -or- + + print $cgi->header( + -type => 'image/gif', + -nph => 1, + -status => '402 Payment required', + -expires => '+3d', + -cookie => $cookie, + -charset => 'utf-8', + -attachment => 'foo.gif', + -Cost => '$2.00' + ); + +header() returns the Content-type: header. You can provide your own MIME type +if you choose, otherwise it defaults to text/html. An optional second parameter +specifies the status code and a human-readable message. For example, you can +specify 204, "No response" to create a script that tells the browser to do +nothing at all. Note that RFC 2616 expects the human-readable phase to be there +as well as the numeric status code. + +The last example shows the named argument style for passing arguments to the CGI +methods using named parameters. Recognized parameters are **-type**, **-status**, +**-expires**, and **-cookie**. Any other named parameters will be stripped of +their initial hyphens and turned into header fields, allowing you to specify +any HTTP header you desire. Internal underscores will be turned into hyphens: + + print $cgi->header( -Content_length => 3002 ); + +Most browsers will not cache the output from CGI scripts. Every time the browser +reloads the page, the script is invoked anew. You can change this behavior with +the **-expires** parameter. When you specify an absolute or relative expiration +interval with this parameter, some browsers and proxy servers will cache the +script's output until the indicated expiration date. The following forms are all +valid for the -expires field: + + +30s 30 seconds from now + +10m ten minutes from now + +1h one hour from now + -1d yesterday (i.e. "ASAP!") + now immediately + +3M in three months + +10y in ten years time + Thursday, 25-Apr-2018 00:40:33 GMT at the indicated time & date + +The **-cookie** parameter generates a header that tells the browser to provide +a "magic cookie" during all subsequent transactions with your script. Some +cookies have a special format that includes interesting attributes such as +expiration time. Use the cookie() method to create and retrieve session cookies. + +The **-nph** parameter, if set to a true value, will issue the correct headers +to work with a NPH (no-parse-header) script. This is important to use with +certain servers that expect all their scripts to be NPH. + +The **-charset** parameter can be used to control the character set sent to the +browser. If not provided, defaults to ISO-8859-1. As a side effect, this sets +the charset() method as well. **Note** that the default being ISO-8859-1 may not +make sense for all content types, e.g.: + + Content-Type: image/gif; charset=ISO-8859-1 + +In the above case you need to pass -charset => '' to prevent the default being +used. + +The **-attachment** parameter can be used to turn the page into an attachment. +Instead of displaying the page, some browsers will prompt the user to save it +to disk. The value of the argument is the suggested name for the saved file. In +order for this to work, you may have to set the **-type** to +"application/octet-stream". + +The **-p3p** parameter will add a P3P tag to the outgoing header. The parameter +can be an arrayref or a space-delimited string of P3P tags. For example: + + print $cgi->header( -p3p => [ qw/ CAO DSP LAW CURa / ] ); + print $cgi->header( -p3p => 'CAO DSP LAW CURa' ); + +In either case, the outgoing header will be formatted as: + + P3P: policyref="/w3c/p3p.xml" cp="CAO DSP LAW CURa" + +CGI.pm will accept valid multi-line headers when each line is separated with a +CRLF value ("\\r\\n" on most platforms) followed by at least one space. For +example: + + print $cgi->header( -ingredients => "ham\r\n\seggs\r\n\sbacon" ); + +Invalid multi-line header input will trigger in an exception. When multi-line +headers are received, CGI.pm will always output them back as a single line, +according to the folding rules of RFC 2616: the newlines will be removed, while +the white space remains. + +## Generating a redirection header + + print $q->redirect( 'http://somewhere.else/in/movie/land' ); + +Sometimes you don't want to produce a document yourself, but simply redirect +the browser elsewhere, perhaps choosing a URL based on the time of day or the +identity of the user. + +The redirect() method redirects the browser to a different URL. If you use +redirection like this, you should **not** print out a header as well. + +You should always use full URLs (including the http: or ftp: part) in +redirection requests. Relative URLs will not work correctly. + +You can also use named arguments: + + print $q->redirect( + -uri => 'http://somewhere.else/in/movie/land', + -nph => 1, + -status => '301 Moved Permanently' + ); + +All names arguments recognized by header() are also recognized by redirect(). +However, most HTTP headers, including those generated by -cookie and -target, +are ignored by the browser. + +The **-nph** parameter, if set to a true value, will issue the correct headers +to work with a NPH (no-parse-header) script. This is important to use with +certain servers, such as Microsoft IIS, which expect all their scripts to be +NPH. + +The **-status** parameter will set the status of the redirect. HTTP defines +several different possible redirection status codes, and the default if not +specified is 302, which means "moved temporarily." You may change the status +to another status code if you wish. + +Note that the human-readable phrase is also expected to be present to conform +with RFC 2616, section 6.1. + +## Creating a self-referencing url that preserves state information + + my $myself = $q->self_url; + print qq(<a href="$myself">I'm talking to myself.</a>); + +self\_url() will return a URL, that, when selected, will re-invoke this script +with all its state information intact. This is most useful when you want to +jump around within the document using internal anchors but you don't want to +disrupt the current contents of the form(s). Something like this will do the +trick: + + my $myself = $q->self_url; + print "<a href=\"$myself#table1\">See table 1</a>"; + print "<a href=\"$myself#table2\">See table 2</a>"; + print "<a href=\"$myself#yourself\">See for yourself</a>"; + +If you want more control over what's returned, using the **url()** method +instead. + +You can also retrieve a query string representation of the current object +state with query\_string(): + + my $the_string = $q->query_string(); + +The behavior of calling query\_string is currently undefined when the HTTP method +is something other than GET. + +If you want to retrieved the query string as set in the webserver, namely the +environment variable, you can call env\_query\_string() + +## Obtaining the script's url + + my $full_url = url(); + my $full_url = url( -full =>1 ); # alternative syntax + my $relative_url = url( -relative => 1 ); + my $absolute_url = url( -absolute =>1 ); + my $url_with_path = url( -path_info => 1 ); + my $url_path_qry = url( -path_info => 1, -query =>1 ); + my $netloc = url( -base => 1 ); + +**url()** returns the script's URL in a variety of formats. Called without any +arguments, it returns the full form of the URL, including host name and port +number + + http://your.host.com/path/to/script.cgi + +You can modify this format with the following named arguments: + +- **-absolute** + + If true, produce an absolute URL, e.g. + + /path/to/script.cgi + +- **-relative** + + Produce a relative URL. This is useful if you want to re-invoke your + script with different parameters. For example: + + script.cgi + +- **-full** + + Produce the full URL, exactly as if called without any arguments. This overrides + the -relative and -absolute arguments. + +- **-path** (**-path\_info**) + + Append the additional path information to the URL. This can be combined with + **-full**, **-absolute** or **-relative**. **-path\_info** is provided as a synonym. + +- **-query** (**-query\_string**) + + Append the query string to the URL. This can be combined with **-full**, + **-absolute** or **-relative**. **-query\_string** is provided as a synonym. + +- **-base** + + Generate just the protocol and net location, as in http://www.foo.com:8000 + +- **-rewrite** + + If Apache's mod\_rewrite is turned on, then the script name and path info + probably won't match the request that the user sent. Set -rewrite => 1 (default) + to return URLs that match what the user sent (the original request URI). Set + \-rewrite => 0 to return URLs that match the URL after the mod\_rewrite rules have + run. + +## Mixing post and url parameters + + my $color = url_param('color'); + +It is possible for a script to receive CGI parameters in the URL as well as in +the fill-out form by creating a form that POSTs to a URL containing a query +string (a "?" mark followed by arguments). The **param()** method will always +return the contents of the POSTed fill-out form, ignoring the URL's query +string. To retrieve URL parameters, call the **url\_param()** method. Use it in +the same way as **param()**. The main difference is that it allows you to read +the parameters, but not set them. + +Under no circumstances will the contents of the URL query string interfere with +similarly-named CGI parameters in POSTed forms. If you try to mix a URL query +string with a form submitted with the GET method, the results will not be what +you expect. + +## Processing a file upload field + +### Basics + +When the form is processed, you can retrieve an [IO::File](https://metacpan.org/pod/IO::File) compatible handle +for a file upload field like this: + + use autodie; + + # undef may be returned if it's not a valid file handle + if ( my $io_handle = $q->upload('field_name') ) { + open ( my $out_file,'>>','/usr/local/web/users/feedback' ); + while ( my $bytesread = $io_handle->read($buffer,1024) ) { + print $out_file $buffer; + } + } + +In a list context, upload() will return an array of filehandles. This makes it +possible to process forms that use the same name for multiple upload fields. + +If you want the entered file name for the file, you can just call param(): + + my $filename = $q->param('field_name'); + +Different browsers will return slightly different things for the name. Some +browsers return the filename only. Others return the full path to the file, +using the path conventions of the user's machine. Regardless, the name returned +is always the name of the file on the _user's_ machine, and is unrelated to +the name of the temporary file that CGI.pm creates during upload spooling +(see below). + +When a file is uploaded the browser usually sends along some information along +with it in the format of headers. The information usually includes the MIME +content type. To retrieve this information, call uploadInfo(). It returns a +reference to a hash containing all the document headers. + + my $filehandle = $q->upload( 'uploaded_file' ); + my $type = $q->uploadInfo( $filehandle )->{'Content-Type'}; + if ( $type ne 'text/html' ) { + die "HTML FILES ONLY!"; + } + +Note that you must use ->upload or ->param to get the file-handle to pass into +uploadInfo as internally this is represented as a File::Temp object (which is +what will be returned by ->upload or ->param). When using ->Vars you will get +the literal filename rather than the File::Temp object, which will not return +anything when passed to uploadInfo. So don't use ->Vars. + +If you are using a machine that recognizes "text" and "binary" data modes, be +sure to understand when and how to use them (see the Camel book). Otherwise +you may find that binary files are corrupted during file uploads. + +### Accessing the temp files directly + +When processing an uploaded file, CGI.pm creates a temporary file on your hard +disk and passes you a file handle to that file. After you are finished with the +file handle, CGI.pm unlinks (deletes) the temporary file. If you need to you +can access the temporary file directly. You can access the temp file for a file +upload by passing the file name to the tmpFileName() method: + + my $filehandle = $query->upload( 'uploaded_file' ); + my $tmpfilename = $query->tmpFileName( $filehandle ); + +As with ->uploadInfo, using the reference returned by ->upload or ->param is +preferred, although unlike ->uploadInfo, plain filenames also work if possible +for backwards compatibility. + +The temporary file will be deleted automatically when your program exits unless +you manually rename it or set $CGI::UNLINK\_TMP\_FILES to 0. On some operating +systems (such as Windows NT), you will need to close the temporary file's +filehandle before your program exits. Otherwise the attempt to delete the +temporary file will fail. + +### Changes in temporary file handling (v4.05+) + +CGI.pm had its temporary file handling significantly refactored, this logic is +now all deferred to File::Temp (which is wrapped in a compatibility object, +CGI::File::Temp - **DO NOT USE THIS PACKAGE DIRECTLY**). As a consequence the +PRIVATE\_TEMPFILES variable has been removed along with deprecation of the +private\_tempfiles routine and **complete** removal of the CGITempFile package. +The $CGITempFile::TMPDIRECTORY is no longer used to set the temp directory, +refer to the perldoc for File::Temp if you want to override the default +settings in that package (the TMPDIR env variable is still available on some +platforms). For Windows platforms the temporary directory order remains +as before: TEMP > TMP > WINDIR ( > TMPDIR ) so if you have any of these in +use in existing scripts they should still work. + +The Fh package still exists but does nothing, the CGI::File::Temp class is +a subclass of both File::Temp and the empty Fh package, so if you have any +code that checks that the filehandle isa Fh this should still work. + +When you get the internal file handle you will receive a File::Temp object, +this should be transparent as File::Temp isa IO::Handle and isa IO::Seekable +meaning it behaves as previously. If you are doing anything out of the ordinary +with regards to temp files you should test your code before deploying this +update and refer to the File::Temp documentation for more information. + +### Handling interrupted file uploads + +There are occasionally problems involving parsing the uploaded file. This +usually happens when the user presses "Stop" before the upload is finished. In +this case, CGI.pm will return undef for the name of the uploaded file and set +_cgi\_error()_ to the string "400 Bad request (malformed multipart POST)". This +error message is designed so that you can incorporate it into a status code to +be sent to the browser. Example: + + my $file = $q->upload( 'uploaded_file' ); + if ( !$file && $q->cgi_error ) { + print $q->header( -status => $q->cgi_error ); + exit 0; + } + +### Progress bars for file uploads and avoiding temp files + +CGI.pm gives you low-level access to file upload management through a file +upload hook. You can use this feature to completely turn off the temp file +storage of file uploads, or potentially write your own file upload progress +meter. + +This is much like the UPLOAD\_HOOK facility available in [Apache::Request](https://metacpan.org/pod/Apache::Request), +with the exception that the first argument to the callback is an +[Apache::Upload](https://metacpan.org/pod/Apache::Upload) object, here it's the remote filename. + + my $q = CGI->new( \&hook [,$data [,$use_tempfile]] ); + + sub hook { + my ( $filename, $buffer, $bytes_read, $data ) = @_; + print "Read $bytes_read bytes of $filename\n"; + } + +The `$data` field is optional; it lets you pass configuration information +(e.g. a database handle) to your hook callback. + +The `$use_tempfile` field is a flag that lets you turn on and off CGI.pm's +use of a temporary disk-based file during file upload. If you set this to a +FALSE value (default true) then $q->param('uploaded\_file') will no longer work, +and the only way to get at the uploaded data is via the hook you provide. + +If using the function-oriented interface, call the CGI::upload\_hook() method +before calling param() or any other CGI functions: + + CGI::upload_hook( \&hook [,$data [,$use_tempfile]] ); + +This method is not exported by default. You will have to import it explicitly +if you wish to use it without the CGI:: prefix. + +### Troubleshooting file uploads on Windows + +If you are using CGI.pm on a Windows platform and find that binary files get +slightly larger when uploaded but that text files remain the same, then you +have forgotten to activate binary mode on the output filehandle. Be sure to call +binmode() on any handle that you create to write the uploaded file to disk. + +### Older ways to process file uploads + +This section is here for completeness. if you are building a new application +with CGI.pm, you can skip it. + +The original way to process file uploads with CGI.pm was to use param(). The +value it returns has a dual nature as both a file name and a lightweight +filehandle. This dual nature is problematic if you following the recommended +practice of having `use strict` in your code. perl will complain when you try +to use a string as a filehandle. More seriously, it is possible for the remote +user to type garbage into the upload field, in which case what you get from +param() is not a filehandle at all, but a string. + +To solve this problem the upload() method was added, which always returns a +lightweight filehandle. This generally works well, but will have trouble +interoperating with some other modules because the file handle is not derived +from [IO::File](https://metacpan.org/pod/IO::File). So that brings us to current recommendation given above, +which is to call the handle() method on the file handle returned by upload(). +That upgrades the handle to an IO::File. It's a big win for compatibility for +a small penalty of loading IO::File the first time you call it. + +# HTTP COOKIES + +CGI.pm has several methods that support cookies. + +A cookie is a name=value pair much like the named parameters in a CGI query +string. CGI scripts create one or more cookies and send them to the browser +in the HTTP header. The browser maintains a list of cookies that belong to a +particular Web server, and returns them to the CGI script during subsequent +interactions. + +In addition to the required name=value pair, each cookie has several optional +attributes: + +- 1. an expiration time + + This is a time/date string (in a special GMT format) that indicates when a + cookie expires. The cookie will be saved and returned to your script until this + expiration date is reached if the user exits the browser and restarts it. If an + expiration date isn't specified, the cookie will remain active until the user + quits the browser. + +- 2. a domain + + This is a partial or complete domain name for which the cookie is valid. The + browser will return the cookie to any host that matches the partial domain name. + For example, if you specify a domain name of ".capricorn.com", then the browser + will return the cookie to Web servers running on any of the machines + "www.capricorn.com", "www2.capricorn.com", "feckless.capricorn.com", etc. Domain + names must contain at least two periods to prevent attempts to match on top + level domains like ".edu". If no domain is specified, then the browser will + only return the cookie to servers on the host the cookie originated from. + +- 3. a path + + If you provide a cookie path attribute, the browser will check it against your + script's URL before returning the cookie. For example, if you specify the path + "/cgi-bin", then the cookie will be returned to each of the scripts + "/cgi-bin/tally.pl", "/cgi-bin/order.pl", and + "/cgi-bin/customer\_service/complain.pl", but not to the script + "/cgi-private/site\_admin.pl". By default, path is set to "/", which causes the + cookie to be sent to any CGI script on your site. + +- 4. a "secure" flag + + If the "secure" attribute is set, the cookie will only be sent to your script + if the CGI request is occurring on a secure channel, such as SSL. + +The interface to HTTP cookies is the **cookie()** method: + + my $cookie = $q->cookie( + -name => 'sessionID', + -value => 'xyzzy', + -expires => '+1h', + -path => '/cgi-bin/database', + -domain => '.capricorn.org', + -secure => 1 + ); + + print $q->header( -cookie => $cookie ); + +**cookie()** creates a new cookie. Its parameters include: + +- **-name** + + The name of the cookie (required). This can be any string at all. Although + browsers limit their cookie names to non-whitespace alphanumeric characters, + CGI.pm removes this restriction by escaping and unescaping cookies behind the + scenes. + +- **-value** + + The value of the cookie. This can be any scalar value, array reference, or even + hash reference. For example, you can store an entire hash into a cookie this + way: + + my $cookie = $q->cookie( + -name => 'family information', + -value => \%childrens_ages + ); + +- **-path** + + The optional partial path for which this cookie will be valid, as described + above. + +- **-domain** + + The optional partial domain for which this cookie will be valid, as described + above. + +- **-expires** + + The optional expiration date for this cookie. The format is as described in the + section on the **header()** method: + + "+1h" one hour from now + +- **-secure** + + If set to true, this cookie will only be used within a secure SSL session. + +The cookie created by cookie() must be incorporated into the HTTP header within +the string returned by the header() method: + + use strict; + use warnings; + + use CGI; + + my $q = CGI->new; + my $cookie = ... + print $q->header( -cookie => $cookie ); + +To create multiple cookies, give header() an array reference: + + my $cookie1 = $q->cookie( + -name => 'riddle_name', + -value => "The Sphynx's Question" + ); + + my $cookie2 = $q->cookie( + -name => 'answers', + -value => \%answers + ); + + print $q->header( -cookie => [ $cookie1,$cookie2 ] ); + +To retrieve a cookie, request it by name by calling cookie() method without the +**-value** parameter. This example uses the object-oriented form: + + my $riddle = $q->cookie('riddle_name'); + my %answers = $query->cookie('answers'); + +Cookies created with a single scalar value, such as the "riddle\_name" cookie, +will be returned in that form. Cookies with array and hash values can also be +retrieved. + +The cookie and CGI namespaces are separate. If you have a parameter named +'answers' and a cookie named 'answers', the values retrieved by param() and +cookie() are independent of each other. However, it's simple to turn a CGI +parameter into a cookie, and vice-versa: + + # turn a CGI parameter into a cookie + my $c = cookie( -name => 'answers',-value => [$q->param('answers')] ); + # vice-versa + $q->param( -name => 'answers',-value => [ $q->cookie('answers')] ); + +If you call cookie() without any parameters, it will return a list of +the names of all cookies passed to your script: + + my @cookies = $q->cookie(); + +See the **cookie.cgi** example script for some ideas on how to use cookies +effectively. + +# DEBUGGING + +If you are running the script from the command line or in the perl debugger, +you can pass the script a list of keywords or parameter=value pairs on the +command line or from standard input (you don't have to worry about tricking +your script into reading from environment variables). You can pass keywords +like this: + + your_script.pl keyword1 keyword2 keyword3 + +or this: + + your_script.pl keyword1+keyword2+keyword3 + +or this: + + your_script.pl name1=value1 name2=value2 + +or this: + + your_script.pl name1=value1&name2=value2 + +To turn off this feature, use the -no\_debug pragma. + +To test the POST method, you may enable full debugging with the -debug pragma. +This will allow you to feed newline-delimited name=value pairs to the script on +standard input. + +When debugging, you can use quotes and backslashes to escape characters in the +familiar shell manner, letting you place spaces and other funny characters in +your parameter=value pairs: + + your_script.pl "name1='I am a long value'" "name2=two\ words" + +Finally, you can set the path info for the script by prefixing the first +name/value parameter with the path followed by a question mark (?): + + your_script.pl /your/path/here?name1=value1&name2=value2 + +# FETCHING ENVIRONMENT VARIABLES + +Some of the more useful environment variables can be fetched through this +interface. The methods are as follows: + +- **Accept()** + + Return a list of MIME types that the remote browser accepts. If you give this + method a single argument corresponding to a MIME type, as in + Accept('text/html'), it will return a floating point value corresponding to the + browser's preference for this type from 0.0 (don't want) to 1.0. Glob types + (e.g. text/\*) in the browser's accept list are handled correctly. + + Note that the capitalization changed between version 2.43 and 2.44 in order to + avoid conflict with perl's accept() function. + +- **raw\_cookie()** + + Returns the HTTP\_COOKIE variable. Cookies have a special format, and this + method call just returns the raw form (?cookie dough). See cookie() for ways + of setting and retrieving cooked cookies. + + Called with no parameters, raw\_cookie() returns the packed cookie structure. + You can separate it into individual cookies by splitting on the character + sequence "; ". Called with the name of a cookie, retrieves the **unescaped** + form of the cookie. You can use the regular cookie() method to get the names, + or use the raw\_fetch() method from the CGI::Cookie module. + +- **env\_query\_string()** + + Returns the QUERY\_STRING variable, note that this is the original value as set + in the environment by the webserver and (possibly) not the same value as + returned by query\_string(), which represents the object state + +- **user\_agent()** + + Returns the HTTP\_USER\_AGENT variable. If you give this method a single + argument, it will attempt to pattern match on it, allowing you to do something + like user\_agent(Mozilla); + +- **path\_info()** + + Returns additional path information from the script URL. E.G. fetching + /cgi-bin/your\_script/additional/stuff will result in path\_info() returning + "/additional/stuff". + + NOTE: The Microsoft Internet Information Server is broken with respect to + additional path information. If you use the perl DLL library, the IIS server + will attempt to execute the additional path information as a perl script. If + you use the ordinary file associations mapping, the path information will be + present in the environment, but incorrect. The best thing to do is to avoid + using additional path information in CGI scripts destined for use with IIS. A + best attempt has been made to make CGI.pm do the right thing. + +- **path\_translated()** + + As per path\_info() but returns the additional path information translated into + a physical path, e.g. "/usr/local/etc/httpd/htdocs/additional/stuff". + + The Microsoft IIS is broken with respect to the translated path as well. + +- **remote\_host()** + + Returns either the remote host name or IP address if the former is unavailable. + +- **remote\_ident()** + + Returns the name of the remote user (as returned by identd) or undef if not set + +- **remote\_addr()** + + Returns the remote host IP address, or 127.0.0.1 if the address is unavailable. + +- **request\_uri()** + + Returns the interpreted pathname of the requested document or CGI (relative to + the document root). Or undef if not set. + +- **script\_name()** + + Return the script name as a partial URL, for self-referring scripts. + +- **referer()** + + Return the URL of the page the browser was viewing prior to fetching your + script. + +- **auth\_type()** + + Return the authorization/verification method in use for this script, if any. + +- **server\_name()** + + Returns the name of the server, usually the machine's host name. + +- **virtual\_host()** + + When using virtual hosts, returns the name of the host that the browser + attempted to contact + +- **server\_port()** + + Return the port that the server is listening on. + +- **server\_protocol()** + + Returns the protocol and revision of the incoming request, or defaults to + HTTP/1.0 if this is not set + +- **virtual\_port()** + + Like server\_port() except that it takes virtual hosts into account. Use this + when running with virtual hosts. + +- **server\_software()** + + Returns the server software and version number. + +- **remote\_user()** + + Return the authorization/verification name used for user verification, if this + script is protected. + +- **user\_name()** + + Attempt to obtain the remote user's name, using a variety of different + techniques. May not work in all browsers. + +- **request\_method()** + + Returns the method used to access your script, usually one of 'POST', 'GET' + or 'HEAD'. + +- **content\_type()** + + Returns the content\_type of data submitted in a POST, generally + multipart/form-data or application/x-www-form-urlencoded + +- **http()** + + Called with no arguments returns the list of HTTP environment variables, + including such things as HTTP\_USER\_AGENT, HTTP\_ACCEPT\_LANGUAGE, and + HTTP\_ACCEPT\_CHARSET, corresponding to the like-named HTTP header fields in the + request. Called with the name of an HTTP header field, returns its value. + Capitalization and the use of hyphens versus underscores are not significant. + + For example, all three of these examples are equivalent: + + my $requested_language = $q->http('Accept-language'); + + my $requested_language = $q->http('Accept_language'); + + my $requested_language = $q->http('HTTP_ACCEPT_LANGUAGE'); + +- **https()** + + The same as _http()_, but operates on the HTTPS environment variables present + when the SSL protocol is in effect. Can be used to determine whether SSL is + turned on. + +# USING NPH SCRIPTS + +NPH, or "no-parsed-header", scripts bypass the server completely by sending the +complete HTTP header directly to the browser. This has slight performance +benefits, but is of most use for taking advantage of HTTP extensions that are +not directly supported by your server, such as server push and PICS headers. + +Servers use a variety of conventions for designating CGI scripts as NPH. Many +Unix servers look at the beginning of the script's name for the prefix "nph-". +The Macintosh WebSTAR server and Microsoft's Internet Information Server, in +contrast, try to decide whether a program is an NPH script by examining the +first line of script output. + +CGI.pm supports NPH scripts with a special NPH mode. When in this mode, CGI.pm +will output the necessary extra header information when the header() and +redirect() methods are called. + +The Microsoft Internet Information Server requires NPH mode. As of version 2.30, +CGI.pm will automatically detect when the script is running under IIS and put +itself into this mode. You do not need to do this manually, although it won't +hurt anything if you do. + +- In the **use** statement + + Simply add the "-nph" pragma to the list of symbols to be imported into + your script: + + use CGI qw(:standard -nph) + +- By calling the **nph()** method: + + Call **nph()** with a non-zero parameter at any point after using CGI.pm in your + program. + + CGI->nph(1) + +- By using **-nph** parameters + + in the **header()** and **redirect()** statements: + + print header(-nph=>1); + +# SERVER PUSH + +CGI.pm provides four simple functions for producing multipart documents of the +type needed to implement server push. These functions were graciously provided +by Ed Jordan <ed@fidalgo.net>. To import these into your namespace, you must +import the ":push" set. You are also advised to put the script into NPH mode +and to set $| to 1 to avoid buffering problems. + +Here is a simple script that demonstrates server push: + + #!/usr/bin/env perl + + use strict; + use warnings; + + use CGI qw/:push -nph/; + + $| = 1; + print multipart_init( -boundary=>'----here we go!' ); + for (0 .. 4) { + print multipart_start( -type=>'text/plain' ), + "The current time is ",scalar( localtime ),"\n"; + if ($_ < 4) { + print multipart_end(); + } else { + print multipart_final(); + } + sleep 1; + } + +This script initializes server push by calling **multipart\_init()**. It then +enters a loop in which it begins a new multipart section by calling +**multipart\_start()**, prints the current local time, and ends a multipart +section with **multipart\_end()**. It then sleeps a second, and begins again. +On the final iteration, it ends the multipart section with +**multipart\_final()** rather than with **multipart\_end()**. + +- multipart\_init() + + multipart_init( -boundary => $boundary, -charset => $charset ); + + Initialize the multipart system. The -boundary argument specifies what MIME + boundary string to use to separate parts of the document. If not provided, + CGI.pm chooses a reasonable boundary for you. + + The -charset provides the character set, if not provided this will default to + ISO-8859-1 + +- multipart\_start() + + multipart_start( -type => $type, -charset => $charset ); + + Start a new part of the multipart document using the specified MIME type and + charset. If not specified, text/html ISO-8859-1 is assumed. + +- multipart\_end() + + multipart_end() + + End a part. You must remember to call multipart\_end() once for each + multipart\_start(), except at the end of the last part of the multipart document + when multipart\_final() should be called instead of multipart\_end(). + +- multipart\_final() + + multipart_final() + + End all parts. You should call multipart\_final() rather than multipart\_end() + at the end of the last part of the multipart document. + +Users interested in server push applications should also have a look at the +CGI::Push module. + +# AVOIDING DENIAL OF SERVICE ATTACKS + +A potential problem with CGI.pm is that, by default, it attempts to process +form POSTings no matter how large they are. A wily hacker could attack your +site by sending a CGI script a huge POST of many gigabytes. CGI.pm will attempt +to read the entire POST into a variable, growing hugely in size until it runs +out of memory. While the script attempts to allocate the memory the system may +slow down dramatically. This is a form of denial of service attack. + +Another possible attack is for the remote user to force CGI.pm to accept a huge +file upload. CGI.pm will accept the upload and store it in a temporary directory +even if your script doesn't expect to receive an uploaded file. CGI.pm will +delete the file automatically when it terminates, but in the meantime the remote +user may have filled up the server's disk space, causing problems for other +programs. + +The best way to avoid denial of service attacks is to limit the amount of +memory, CPU time and disk space that CGI scripts can use. Some Web servers come +with built-in facilities to accomplish this. In other cases, you can use the +shell _limit_ or _ulimit_ commands to put ceilings on CGI resource usage. + +CGI.pm also has some simple built-in protections against denial of service +attacks, but you must activate them before you can use them. These take the +form of two global variables in the CGI name space: + +- **$CGI::POST\_MAX** + + If set to a non-negative integer, this variable puts a ceiling on the size of + POSTings, in bytes. If CGI.pm detects a POST that is greater than the ceiling, + it will immediately exit with an error message. This value will affect both + ordinary POSTs and multipart POSTs, meaning that it limits the maximum size of + file uploads as well. You should set this to a reasonably high + value, such as 10 megabytes. + +- **$CGI::DISABLE\_UPLOADS** + + If set to a non-zero value, this will disable file uploads completely. Other + fill-out form values will work as usual. + +To use these variables, set the variable at the top of the script, right after +the "use" statement: + + #!/usr/bin/env perl + + use strict; + use warnings; + + use CGI; + + $CGI::POST_MAX = 1024 * 1024 * 10; # max 10MB posts + $CGI::DISABLE_UPLOADS = 1; # no uploads + +An attempt to send a POST larger than $POST\_MAX bytes will cause _param()_ to +return an empty CGI parameter list. You can test for this event by checking +_cgi\_error()_, either after you create the CGI object or, if you are using the +function-oriented interface, call <param()> for the first time. If the POST was +intercepted, then cgi\_error() will return the message "413 POST too large". + +This error message is actually defined by the HTTP protocol, and is designed to +be returned to the browser as the CGI script's status code. For example: + + my $uploaded_file = $q->param('upload'); + if ( !$uploaded_file && $q->cgi_error() ) { + print $q->header( -status => $q->cgi_error() ); + exit 0; + } + +However it isn't clear that any browser currently knows what to do with this +status code. It might be better just to create a page that warns the user of +the problem. + +# COMPATIBILITY WITH CGI-LIB.PL + +To make it easier to port existing programs that use cgi-lib.pl the +compatibility routine "ReadParse" is provided. Porting is simple: + +OLD VERSION + + require "cgi-lib.pl"; + &ReadParse; + print "The value of the antique is $in{antique}.\n"; + +NEW VERSION + + use CGI; + CGI::ReadParse(); + print "The value of the antique is $in{antique}.\n"; + +CGI.pm's ReadParse() routine creates a tied variable named %in, which can be +accessed to obtain the query variables. Like ReadParse, you can also provide +your own variable. Infrequently used features of ReadParse, such as the creation +of @in and $in variables, are not supported. + +Once you use ReadParse, you can retrieve the query object itself this way: + + my $q = $in{CGI}; + +This allows you to start using the more interesting features of CGI.pm without +rewriting your old scripts from scratch. + +An even simpler way to mix cgi-lib calls with CGI.pm calls is to import both the +`:cgi-lib` and `:standard` method: + + use CGI qw(:cgi-lib :standard); + &ReadParse; + print "The price of your purchase is $in{price}.\n"; + print textfield(-name=>'price', -default=>'$1.99'); + +## Cgi-lib functions that are available in CGI.pm + +In compatibility mode, the following cgi-lib.pl functions are +available for your use: + + ReadParse() + PrintHeader() + SplitParam() + MethGet() + MethPost() + +# LICENSE + +The CGI.pm distribution is copyright 1995-2007, Lincoln D. Stein. It is +distributed under GPL and the Artistic License 2.0. It is currently maintained +by Lee Johnson (LEEJO) with help from many contributors. + +# CREDITS + +Thanks very much to: + +- Mark Stosberg (mark@stosberg.com) +- Matt Heffron (heffron@falstaff.css.beckman.com) +- James Taylor (james.taylor@srs.gov) +- Scott Anguish <sanguish@digifix.com> +- Mike Jewell (mlj3u@virginia.edu) +- Timothy Shimmin (tes@kbs.citri.edu.au) +- Joergen Haegg (jh@axis.se) +- Laurent Delfosse (delfosse@delfosse.com) +- Richard Resnick (applepi1@aol.com) +- Craig Bishop (csb@barwonwater.vic.gov.au) +- Tony Curtis (tc@vcpc.univie.ac.at) +- Tim Bunce (Tim.Bunce@ig.co.uk) +- Tom Christiansen (tchrist@convex.com) +- Andreas Koenig (k@franz.ww.TU-Berlin.DE) +- Tim MacKenzie (Tim.MacKenzie@fulcrum.com.au) +- Kevin B. Hendricks (kbhend@dogwood.tyler.wm.edu) +- Stephen Dahmen (joyfire@inxpress.net) +- Ed Jordan (ed@fidalgo.net) +- David Alan Pisoni (david@cnation.com) +- Doug MacEachern (dougm@opengroup.org) +- Robin Houston (robin@oneworld.org) +- ...and many many more... + + for suggestions and bug fixes. + +# BUGS + +Address bug reports and comments to: [https://github.com/leejo/CGI.pm/issues](https://github.com/leejo/CGI.pm/issues) + +The original bug tracker can be found at: +[https://rt.cpan.org/Public/Dist/Display.html?Queue=CGI.pm](https://rt.cpan.org/Public/Dist/Display.html?Queue=CGI.pm) + +When sending bug reports, please provide the version of CGI.pm, the version of +perl, the name and version of your Web server, and the name and version of the +operating system you are using. If the problem is even remotely browser +dependent, please provide information about the affected browsers as well. + +Failing tests cases are appreciated with issues, and if you submit a patch then +it will \*not\* be accepted unless you provide a reasonable automated test case +with it (please see the existing tests in t/ for examples). + +Please note the CGI.pm is now considered "done". See also "mature" and "legacy". +Feature requests and none critical issues will be outright rejected. The module +is now in maintenance mode for critical issues only. + +# SEE ALSO + +[CGI::Carp](https://metacpan.org/pod/CGI::Carp) - provides [Carp](https://metacpan.org/pod/Carp) implementation tailored to the CGI environment. + +[CGI::Fast](https://metacpan.org/pod/CGI::Fast) - supports running CGI applications under FastCGI diff --git a/examples/clickable_image.cgi b/examples/clickable_image.cgi new file mode 100755 index 0000000..78d874f --- /dev/null +++ b/examples/clickable_image.cgi @@ -0,0 +1,56 @@ +#!/usr/bin/env perl + +use strict; +use warnings; + +use CGI; +use Template; + +my $cgi = CGI->new; +my $template_vars; + +if ( $cgi->param ) { + foreach my $var ( qw/ magnification letter x y / ) { + $template_vars->{$var} = $cgi->param( + $var =~ /^[xy]$/ ? "picture.$var" : $var + ); + } +} + +my $tt = Template->new; +print $cgi->header( + -type => 'text/html', + -charset => 'utf-8', +); + +$tt->process( \*DATA,$template_vars ) or warn $tt->error; + +__DATA__ +<!DOCTYPE html> +<html> + <head> + <meta charset="UTF-8"> + <title>A Clickable Image</title> + </head> + <body> + <h1>A Clickable Image</h1> + </a> + <p>Sorry, this isn't very exciting!</p> + <form method="post" action="/clickable_image/"> + <input type="image" name="picture" src="/wilogo.gif" /> + <p>Give me a: + <select name="letter" >[%- FOREACH letter_opt IN [ 'A','B','C','D','E','W' ] %] + <option value="[% letter_opt %]" [% IF letter == letter_opt %]selected[% END %]>[% letter_opt %]</option> + [%- END %]</select> + </p> + <p>Magnification: + [% FOREACH magnification_opt IN [ 1,2,4,20 ] -%] + [%- %]<label><input type="radio" name="magnification" value="[% magnification_opt %]"[% + IF magnification.defined AND magnification == magnification_opt %] checked="checked"[% END + %]/>[% magnification_opt %]X</label> + [% END -%] + [%- IF x.defined AND y.defined %] + <p>Selected Position <strong>([% x %],[% y %])</strong></p> + [% END %] + </body> +</html> diff --git a/examples/cookie.cgi b/examples/cookie.cgi new file mode 100755 index 0000000..1908238 --- /dev/null +++ b/examples/cookie.cgi @@ -0,0 +1,111 @@ +#!/usr/bin/env perl + +use strict; +use warnings; + +use CGI; +use Template; + +my $cgi = CGI->new; + +my $template_vars = { + animals => [ + sort qw/lion tiger bear pig porcupine ferret zebra gnu ostrich + emu moa goat weasel yak chicken sheep hyena dodo lounge-lizard + squirrel rat mouse hedgehog racoon baboon kangaroo hippopotamus + giraffe + / + ], +}; + +# Recover the previous animals from the magic cookie. +# The cookie has been formatted as an associative array +# mapping animal name to the number of animals. +my %zoo = $cgi->cookie( 'animals' ); + +# Recover the new animal(s) from the parameter 'new_animal' +if ( my @new = $cgi->multi_param( 'new_animals' ) ) { + + # If the action is 'add', then add new animals to the zoo. Otherwise + # delete them. + foreach ( @new ) { + if ( $cgi->param('action') eq 'Add' ) { + $zoo{$_}++; + } elsif ( $cgi->param('action') eq 'Delete' ) { + $zoo{$_}-- if $zoo{$_}; + delete $zoo{$_} unless $zoo{$_}; + } + } + + $template_vars->{zoo} = \%zoo if keys( %zoo ); +} + +# Add new animals to old, and put them in a cookie +my $the_cookie = $cgi->cookie( + -name => 'animals', + -value => \%zoo, + -expires => '+1h' +); + +my $tt = Template->new; + +# Print the header, incorporating the cookie and the expiration date... +print $cgi->header( + -cookie => $the_cookie, + -type => 'text/html', + -charset => 'utf-8', +); + +$tt->process( \*DATA,$template_vars ) or warn $tt->error; + +__DATA__ +<!DOCTYPE html> +<html> + <head> + <meta charset="UTF-8"> + <title>Animal crackers</title> + </head> + <body> + <h1>Animal Crackers</h1> + <p> + Choose the animals you want to add to the zoo, and click "add". + Come back to this page any time within the next hour and the list of + animals in the zoo will be resurrected. You can even quit the browser + completely! + </p> + <p> + Try adding the same animal several times to the list. Does this + remind you vaguely of a shopping cart? + </p> + <p> + <center> + <table border> + <tr><th>Add/Delete<th>Current Contents + <tr><td><form method="post" action="https://127.0.0.1:3333/cookie/" enctype="multipart/form-data"> + <select name="new_animals" size="10" multiple="multiple"> + [% FOREACH animal IN animals %] + <option value="[% animal %]">[% animal %]</option> + [% END %] + </select> + <br> + <input type="submit" name="action" value="Delete" /> + <input type="submit" name="action" value="Add" /> + <div> + <input type="hidden" name=".cgifields" value="new_animals" /> + </div> + </form> + <td> + [% IF zoo.defined %] + <ul> + [% FOREACH animal IN zoo.keys.sort %] + <li>[% zoo.$animal %] [% animal %]</li> + [% END %] + </ul> + [% ELSE %] + <strong>The zoo is empty.</strong> + [% END %] + </table> + </center> + <hr> + </body> +</html> diff --git a/examples/crash.cgi b/examples/crash.cgi new file mode 100755 index 0000000..9ae97b1 --- /dev/null +++ b/examples/crash.cgi @@ -0,0 +1,9 @@ +#!/usr/bin/env perl + +use strict; +use warnings; + +use CGI::Carp qw/ fatalsToBrowser /; + +# This line invokes a fatal error message at compile time. +foo bar baz; diff --git a/examples/file_upload.cgi b/examples/file_upload.cgi new file mode 100755 index 0000000..b48d737 --- /dev/null +++ b/examples/file_upload.cgi @@ -0,0 +1,74 @@ +#!/usr/bin/env perl + +use strict; +use warnings; + +use CGI; +use CGI::Carp qw/ fatalsToBrowser /; +use Template; + +my $cgi = CGI->new; +my $template_vars = { + cgi_version => $CGI::VERSION, +}; + +# Process the form if there is a file name entered +if ( my $file = $cgi->param( 'filename' ) ) { + + my $tmpfile = $cgi->tmpFileName( $file ); + my $mimetype = $cgi->uploadInfo( $file )->{'Content-Type'} || ''; + + @{$template_vars}{qw/file temp_file mimetype/} + = ( $file,$tmpfile,$mimetype ); + + my %wanted = map { $_ => 1 } $cgi->multi_param( 'count' ); + + while ( <$file> ) { + $template_vars->{lines}++ if $wanted{"count lines"}; + $template_vars->{words} += split(/\s+/) if $wanted{"count words"}; + $template_vars->{chars} += length if $wanted{"count chars"}; + } + close( $file ); +} + +print $cgi->header( + -type => 'text/html', + -charset => 'utf-8', +); + +my $tt = Template->new; +$tt->process( \*DATA,$template_vars ) or warn $tt->error; + +__DATA__ +<!DOCTYPE html> +<html> + <head> + <meta charset="UTF-8"> + <title>File Upload Example</title> + </head> + <body> + <b>Version</b> [% cgi_version %] + <h1>File Upload Example</h1> + <p>This example demonstrates how to prompt the remote user to select a remote file for uploading.</p> + <p>Select the <cite>browser</cite> button to choose a text file to upload.</p> + <p>When you press the submit button, this script will count the number of lines, words, and characters in the file.</p> + <form method="post" action="file_upload" enctype="multipart/form-data">Enter the file to process: + <input type="file" name="filename" size="45" /><br /> + <label><input type="checkbox" name="count" value="count lines" checked="checked" />count lines</label> + <label><input type="checkbox" name="count" value="count words" checked="checked" />count words</label> + <label><input type="checkbox" name="count" value="count chars" checked="checked" />count characters</label> + <input type="reset" name=".reset" /> + <input type="submit" name="submit" value="Process File" /> + <input type="hidden" name=".cgifields" value="count" /> + </form> + <hr /> + [% IF file.defined %] + <h2>[% file %]</h2> + <h3>[% temp_file %]</h3> + <h4>MIME Type: <i>[% mime_type %]</i></h4> + <b>Lines: </b>[% lines %]<br /> + <b>Words: </b>[% words %]<br /> + <b>Characters: </b>[% chars %]<br /> + [% END %] + </body> +</html> diff --git a/examples/mojo_proxy.pl b/examples/mojo_proxy.pl new file mode 100644 index 0000000..f973f8a --- /dev/null +++ b/examples/mojo_proxy.pl @@ -0,0 +1,36 @@ +#!/usr/bin/env perl + +use Mojolicious::Lite; +use Mojolicious::Plugin::CGI; + +my %cgi_scripts = ( + '/clickable_image' => "clickable_image.cgi", + '/cookie' => "cookie.cgi", + '/crash' => "crash.cgi", + '/file_upload' => "file_upload.cgi", + '/wikipedia_ex' => "wikipedia_example.cgi", +); + +foreach my $route ( sort keys( %cgi_scripts ) ) { + plugin CGI => [ $route => $cgi_scripts{$route} ]; +} + +any '/' => sub { + my ( $c ) = @_; + $c->stash( { cgi_scripts => { %cgi_scripts } } ); + $c->render( 'index' ); +}; + +app->start; + +__DATA__ +@@ index.html.ep +<!doctype html><html> + <head><title>CGI Examples</title></head> + <body> + <h3>CGI Examples</h3> + % for my $route ( sort keys( %{ $cgi_scripts } ) ) { + <a href="<%= $route %>"><%= $cgi_scripts->{$route} %></a><br /> + % } + </body> +</html> diff --git a/examples/wikipedia_example.cgi b/examples/wikipedia_example.cgi new file mode 100755 index 0000000..fe17a79 --- /dev/null +++ b/examples/wikipedia_example.cgi @@ -0,0 +1,40 @@ +#!/usr/bin/env perl + +use strict; +use warnings; + +use CGI; + +my $cgi = CGI->new; + +print $cgi->header('text/html'); + +print << "EndOfHTML"; +<!DOCTYPE html + PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" + "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd" +> +<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US" xml:lang="en-US"> + <head> + <title>A Simple CGI Page</title> + <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1" /> + </head> + <body> + <h1>A Simple CGI Page</h1> + <form method="post" enctype="multipart/form-data"> + Name: <input type="text" name="name" /><br /> + Age: <input type="text" name="age" /><p /> + <input type="submit" name="Submit!" value="Submit!" /> + </form> + <hr /> +EndOfHTML + +if ( my $name = $cgi->param('name') ) { + print "Your name is $name.<br />"; +} + +if ( my $age = $cgi->param('age') ) { + print "You are $age years old."; +} + +print '</body></html>'; diff --git a/examples/wilogo.gif b/examples/wilogo.gif Binary files differnew file mode 100644 index 0000000..a7c309e --- /dev/null +++ b/examples/wilogo.gif diff --git a/lib/CGI.pm b/lib/CGI.pm new file mode 100644 index 0000000..3ed0d0e --- /dev/null +++ b/lib/CGI.pm @@ -0,0 +1,3856 @@ +package CGI; +require 5.008001; +use if $] >= 5.019, 'deprecate'; +use Carp 'croak'; + +$CGI::VERSION='4.21'; + +use CGI::Util qw(rearrange rearrange_header make_attributes unescape escape expires ebcdic2ascii ascii2ebcdic); + +$_XHTML_DTD = ['-//W3C//DTD XHTML 1.0 Transitional//EN', + 'http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd']; + +{ + local $^W = 0; + $TAINTED = substr("$0$^X",0,0); +} + +$MOD_PERL = 0; # no mod_perl by default + +#global settings +$POST_MAX = -1; # no limit to uploaded files +$DISABLE_UPLOADS = 0; +$UNLINK_TMP_FILES = 1; +$LIST_CONTEXT_WARN = 1; +$ENCODE_ENTITIES = q{&<>"'}; + +@SAVED_SYMBOLS = (); + +# >>>>> Here are some globals that you might want to adjust <<<<<< +sub initialize_globals { + # Set this to 1 to generate XTML-compatible output + $XHTML = 1; + + # Change this to the preferred DTD to print in start_html() + # or use default_dtd('text of DTD to use'); + $DEFAULT_DTD = [ '-//W3C//DTD HTML 4.01 Transitional//EN', + 'http://www.w3.org/TR/html4/loose.dtd' ] ; + + # Set this to 1 to enable NOSTICKY scripts + # or: + # 1) use CGI '-nosticky'; + # 2) $CGI::NOSTICKY = 1; + $NOSTICKY = 0; + + # Set this to 1 to enable NPH scripts + # or: + # 1) use CGI qw(-nph) + # 2) CGI::nph(1) + # 3) print header(-nph=>1) + $NPH = 0; + + # Set this to 1 to enable debugging from @ARGV + # Set to 2 to enable debugging from STDIN + $DEBUG = 1; + + # Set this to 1 to generate automatic tab indexes + $TABINDEX = 0; + + # Set this to 1 to cause files uploaded in multipart documents + # to be closed, instead of caching the file handle + # or: + # 1) use CGI qw(:close_upload_files) + # 2) $CGI::close_upload_files(1); + # Uploads with many files run out of file handles. + # Also, for performance, since the file is already on disk, + # it can just be renamed, instead of read and written. + $CLOSE_UPLOAD_FILES = 0; + + # Automatically determined -- don't change + $EBCDIC = 0; + + # Change this to 1 to suppress redundant HTTP headers + $HEADERS_ONCE = 0; + + # separate the name=value pairs by semicolons rather than ampersands + $USE_PARAM_SEMICOLONS = 1; + + # Do not include undefined params parsed from query string + # use CGI qw(-no_undef_params); + $NO_UNDEF_PARAMS = 0; + + # return everything as utf-8 + $PARAM_UTF8 = 0; + + # make param('PUTDATA') act like file upload + $PUTDATA_UPLOAD = 0; + + # Other globals that you shouldn't worry about. + undef $Q; + $BEEN_THERE = 0; + $DTD_PUBLIC_IDENTIFIER = ""; + undef @QUERY_PARAM; + undef %EXPORT; + undef $QUERY_CHARSET; + undef %QUERY_FIELDNAMES; + undef %QUERY_TMPFILES; + + # prevent complaints by mod_perl + 1; +} + +# ------------------ START OF THE LIBRARY ------------ + +# make mod_perlhappy +initialize_globals(); + +# FIGURE OUT THE OS WE'RE RUNNING UNDER +# Some systems support the $^O variable. If not +# available then require() the Config library +unless ($OS) { + unless ($OS = $^O) { + require Config; + $OS = $Config::Config{'osname'}; + } +} +if ($OS =~ /^MSWin/i) { + $OS = 'WINDOWS'; +} elsif ($OS =~ /^VMS/i) { + $OS = 'VMS'; +} elsif ($OS =~ /^dos/i) { + $OS = 'DOS'; +} elsif ($OS =~ /^MacOS/i) { + $OS = 'MACINTOSH'; +} elsif ($OS =~ /^os2/i) { + $OS = 'OS2'; +} elsif ($OS =~ /^epoc/i) { + $OS = 'EPOC'; +} elsif ($OS =~ /^cygwin/i) { + $OS = 'CYGWIN'; +} elsif ($OS =~ /^NetWare/i) { + $OS = 'NETWARE'; +} else { + $OS = 'UNIX'; +} + +# Some OS logic. Binary mode enabled on DOS, NT and VMS +$needs_binmode = $OS=~/^(WINDOWS|DOS|OS2|MSWin|CYGWIN|NETWARE)/; + +# This is the default class for the CGI object to use when all else fails. +$DefaultClass = 'CGI' unless defined $CGI::DefaultClass; + +# The path separator is a slash, backslash or semicolon, depending +# on the platform. +$SL = { + UNIX => '/', OS2 => '\\', EPOC => '/', CYGWIN => '/', NETWARE => '/', + WINDOWS => '\\', DOS => '\\', MACINTOSH => ':', VMS => '/' + }->{$OS}; + +# This no longer seems to be necessary +# Turn on NPH scripts by default when running under IIS server! +# $NPH++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/; +$IIS++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/; + +# Turn on special checking for ActiveState's PerlEx +$PERLEX++ if defined($ENV{'GATEWAY_INTERFACE'}) && $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-PerlEx/; + +# Turn on special checking for Doug MacEachern's modperl +# PerlEx::DBI tries to fool DBI by setting MOD_PERL +if (exists $ENV{MOD_PERL} && ! $PERLEX) { + # mod_perl handlers may run system() on scripts using CGI.pm; + # Make sure so we don't get fooled by inherited $ENV{MOD_PERL} + if (exists $ENV{MOD_PERL_API_VERSION} && $ENV{MOD_PERL_API_VERSION} == 2) { + $MOD_PERL = 2; + require Apache2::Response; + require Apache2::RequestRec; + require Apache2::RequestUtil; + require Apache2::RequestIO; + require APR::Pool; + } else { + $MOD_PERL = 1; + require Apache; + } +} + +# Define the CRLF sequence. I can't use a simple "\r\n" because the meaning +# of "\n" is different on different OS's (sometimes it generates CRLF, sometimes LF +# and sometimes CR). The most popular VMS web server +# doesn't accept CRLF -- instead it wants a LR. EBCDIC machines don't +# use ASCII, so \015\012 means something different. I find this all +# really annoying. +$EBCDIC = "\t" ne "\011"; +if ($OS eq 'VMS') { + $CRLF = "\n"; +} elsif ($EBCDIC) { + $CRLF= "\r\n"; +} else { + $CRLF = "\015\012"; +} + +_set_binmode() if ($needs_binmode); + +sub _set_binmode { + + # rt #57524 - don't set binmode on filehandles if there are + # already none default layers set on them + my %default_layers = ( + unix => 1, + perlio => 1, + stdio => 1, + crlf => 1, + ); + + foreach my $fh ( + \*main::STDOUT, + \*main::STDIN, + \*main::STDERR, + ) { + my @modes = grep { ! $default_layers{$_} } + PerlIO::get_layers( $fh ); + + if ( ! @modes ) { + $CGI::DefaultClass->binmode( $fh ); + } + } +} + +%EXPORT_TAGS = ( + ':html2' => [ 'h1' .. 'h6', qw/ + p br hr ol ul li dl dt dd menu code var strong em + tt u i b blockquote pre img a address cite samp dfn html head + base body Link nextid title meta kbd start_html end_html + input Select option comment charset escapeHTML + / ], + ':html3' => [ qw/ + div table caption th td TR Tr sup Sub strike applet Param nobr + embed basefont style span layer ilayer font frameset frame script small big Area Map + / ], + ':html4' => [ qw/ + abbr acronym bdo col colgroup del fieldset iframe + ins label legend noframes noscript object optgroup Q + thead tbody tfoot + / ], + ':form' => [ qw/ + textfield textarea filefield password_field hidden checkbox checkbox_group + submit reset defaults radio_group popup_menu button autoEscape + scrolling_list image_button start_form end_form + start_multipart_form end_multipart_form isindex tmpFileName uploadInfo URL_ENCODED MULTIPART + / ], + ':cgi' => [ qw/ + param multi_param upload path_info path_translated request_uri url self_url script_name + cookie Dump raw_cookie request_method query_string Accept user_agent remote_host content_type + remote_addr referer server_name server_software server_port server_protocol virtual_port + virtual_host remote_ident auth_type http append save_parameters restore_parameters param_fetch + remote_user user_name header redirect import_names put Delete Delete_all url_param cgi_error env_query_string + / ], + ':netscape' => [qw/blink fontsize center/], + ':ssl' => [qw/https/], + ':cgi-lib' => [qw/ReadParse PrintHeader HtmlTop HtmlBot SplitParam Vars/], + ':push' => [qw/multipart_init multipart_start multipart_end multipart_final/], + + # bulk export/import + ':html' => [qw/:html2 :html3 :html4 :netscape/], + ':standard' => [qw/:html2 :html3 :html4 :form :cgi :ssl/], + ':all' => [qw/:html2 :html3 :html4 :netscape :form :cgi :ssl :push/] +); + +# to import symbols into caller +sub import { + my $self = shift; + + # This causes modules to clash. + undef %EXPORT_OK; + undef %EXPORT; + + $self->_setup_symbols(@_); + my ($callpack, $callfile, $callline) = caller; + + if ( $callpack eq 'CGI::Fast' ) { + # fixes GH #11 (and GH #12 in CGI::Fast since + # sub import was added to CGI::Fast in 9537f90 + # so we need to move up a level to export the + # routines to the namespace of whatever is using + # CGI::Fast + ($callpack, $callfile, $callline) = caller(1); + } + + # To allow overriding, search through the packages + # Till we find one in which the correct subroutine is defined. + my @packages = ($self,@{"$self\:\:ISA"}); + for $sym (keys %EXPORT) { + my $pck; + my $def = $DefaultClass; + for $pck (@packages) { + if (defined(&{"$pck\:\:$sym"})) { + $def = $pck; + last; + } + } + *{"${callpack}::$sym"} = \&{"$def\:\:$sym"}; + } +} + +sub expand_tags { + my($tag) = @_; + return ("start_$1","end_$1") if $tag=~/^(?:\*|start_|end_)(.+)/; + my(@r); + return ($tag) unless $EXPORT_TAGS{$tag}; + for (@{$EXPORT_TAGS{$tag}}) { + push(@r,&expand_tags($_)); + } + return @r; +} + +#### Method: new +# The new routine. This will check the current environment +# for an existing query string, and initialize itself, if so. +#### +sub new { + my($class,@initializer) = @_; + my $self = {}; + + bless $self,ref $class || $class || $DefaultClass; + + # always use a tempfile + $self->{'use_tempfile'} = 1; + + if (ref($initializer[0]) + && (UNIVERSAL::isa($initializer[0],'Apache') + || + UNIVERSAL::isa($initializer[0],'Apache2::RequestRec') + )) { + $self->r(shift @initializer); + } + if (ref($initializer[0]) + && (UNIVERSAL::isa($initializer[0],'CODE'))) { + $self->upload_hook(shift @initializer, shift @initializer); + $self->{'use_tempfile'} = shift @initializer if (@initializer > 0); + } + if ($MOD_PERL) { + if ($MOD_PERL == 1) { + $self->r(Apache->request) unless $self->r; + my $r = $self->r; + $r->register_cleanup(\&CGI::_reset_globals); + $self->_setup_symbols(@SAVED_SYMBOLS) if @SAVED_SYMBOLS; + } + else { + # XXX: once we have the new API + # will do a real PerlOptions -SetupEnv check + $self->r(Apache2::RequestUtil->request) unless $self->r; + my $r = $self->r; + $r->subprocess_env unless exists $ENV{REQUEST_METHOD}; + $r->pool->cleanup_register(\&CGI::_reset_globals); + $self->_setup_symbols(@SAVED_SYMBOLS) if @SAVED_SYMBOLS; + } + undef $NPH; + } + $self->_reset_globals if $PERLEX; + $self->init(@initializer); + return $self; +} + +sub r { + my $self = shift; + my $r = $self->{'.r'}; + $self->{'.r'} = shift if @_; + $r; +} + +sub upload_hook { + my $self; + if (ref $_[0] eq 'CODE') { + $CGI::Q = $self = $CGI::DefaultClass->new(@_); + } else { + $self = shift; + } + my ($hook,$data,$use_tempfile) = @_; + $self->{'.upload_hook'} = $hook; + $self->{'.upload_data'} = $data; + $self->{'use_tempfile'} = $use_tempfile if defined $use_tempfile; +} + +#### Method: param / multi_param +# Returns the value(s)of a named parameter. +# If invoked in a list context, returns the +# entire list. Otherwise returns the first +# member of the list. +# If name is not provided, return a list of all +# the known parameters names available. +# If more than one argument is provided, the +# second and subsequent arguments are used to +# set the value of the parameter. +# +# note that calling param() in list context +# will raise a warning about potential bad +# things, hence the multi_param method +#### +sub multi_param { + # we don't need to set $LIST_CONTEXT_WARN to 0 here + # because param() will check the caller before warning + my @list_of_params = param( @_ ); + return @list_of_params; +} + +sub param { + my($self,@p) = self_or_default(@_); + + return $self->all_parameters unless @p; + + # list context can be dangerous so warn: + # http://blog.gerv.net/2014.10/new-class-of-vulnerability-in-perl-web-applications + if ( wantarray && $LIST_CONTEXT_WARN ) { + my ( $package, $filename, $line ) = caller; + if ( $package ne 'CGI' ) { + warn "CGI::param called in list context from $filename line $line, this can lead to vulnerabilities. " + . 'See the warning in "Fetching the value or values of a single named parameter"'; + } + } + + my($name,$value,@other); + + # For compatibility between old calling style and use_named_parameters() style, + # we have to special case for a single parameter present. + if (@p > 1) { + ($name,$value,@other) = rearrange([NAME,[DEFAULT,VALUE,VALUES]],@p); + my(@values); + + if (substr($p[0],0,1) eq '-') { + @values = defined($value) ? (ref($value) && ref($value) eq 'ARRAY' ? @{$value} : $value) : (); + } else { + for ($value,@other) { + push(@values,$_) if defined($_); + } + } + # If values is provided, then we set it. + if (@values or defined $value) { + $self->add_parameter($name); + $self->{param}{$name}=[@values]; + } + } else { + $name = $p[0]; + } + + return unless defined($name) && $self->{param}{$name}; + + my @result = @{$self->{param}{$name}}; + + if ($PARAM_UTF8 && $name ne 'PUTDATA' && $name ne 'POSTDATA') { + eval "require Encode; 1;" unless Encode->can('decode'); # bring in these functions + @result = map {ref $_ ? $_ : $self->_decode_utf8($_) } @result; + } + + return wantarray ? @result : $result[0]; +} + +sub _decode_utf8 { + my ($self, $val) = @_; + + if (Encode::is_utf8($val)) { + return $val; + } + else { + return Encode::decode(utf8 => $val); + } +} + +sub self_or_default { + return @_ if defined($_[0]) && (!ref($_[0])) &&($_[0] eq 'CGI'); + unless (defined($_[0]) && + (ref($_[0]) eq 'CGI' || UNIVERSAL::isa($_[0],'CGI')) # slightly optimized for common case + ) { + $Q = $CGI::DefaultClass->new unless defined($Q); + unshift(@_,$Q); + } + return wantarray ? @_ : $Q; +} + +sub self_or_CGI { + local $^W=0; # prevent a warning + if (defined($_[0]) && + (substr(ref($_[0]),0,3) eq 'CGI' + || UNIVERSAL::isa($_[0],'CGI'))) { + return @_; + } else { + return ($DefaultClass,@_); + } +} + +######################################## +# THESE METHODS ARE MORE OR LESS PRIVATE +# GO TO THE __DATA__ SECTION TO SEE MORE +# PUBLIC METHODS +######################################## + +# Initialize the query object from the environment. +# If a parameter list is found, this object will be set +# to a hash in which parameter names are keys +# and the values are stored as lists +# If a keyword list is found, this method creates a bogus +# parameter list with the single parameter 'keywords'. + +sub init { + my $self = shift; + my($query_string,$meth,$content_length,$fh,@lines) = ('','','',''); + + my $is_xforms; + + my $initializer = shift; # for backward compatibility + local($/) = "\n"; + + # set autoescaping on by default + $self->{'escape'} = 1; + + # if we get called more than once, we want to initialize + # ourselves from the original query (which may be gone + # if it was read from STDIN originally.) + if (@QUERY_PARAM && !defined($initializer)) { + for my $name (@QUERY_PARAM) { + my $val = $QUERY_PARAM{$name}; # always an arrayref; + $self->param('-name'=>$name,'-value'=> $val); + if (defined $val and ref $val eq 'ARRAY') { + for my $fh (grep {defined($_) && ref($_) && defined(fileno($_))} @$val) { + seek($fh,0,0); # reset the filehandle. + } + + } + } + $self->charset($QUERY_CHARSET); + $self->{'.fieldnames'} = {%QUERY_FIELDNAMES}; + $self->{'.tmpfiles'} = {%QUERY_TMPFILES}; + return; + } + + $meth=$ENV{'REQUEST_METHOD'} if defined($ENV{'REQUEST_METHOD'}); + $content_length = defined($ENV{'CONTENT_LENGTH'}) ? $ENV{'CONTENT_LENGTH'} : 0; + + $fh = to_filehandle($initializer) if $initializer; + + # set charset to the safe ISO-8859-1 + $self->charset('ISO-8859-1'); + + METHOD: { + + # avoid unreasonably large postings + if (($POST_MAX > 0) && ($content_length > $POST_MAX)) { + #discard the post, unread + $self->cgi_error("413 Request entity too large"); + last METHOD; + } + + # Process multipart postings, but only if the initializer is + # not defined. + if ($meth eq 'POST' + && defined($ENV{'CONTENT_TYPE'}) + && $ENV{'CONTENT_TYPE'}=~m|^multipart/form-data| + && !defined($initializer) + ) { + my($boundary) = $ENV{'CONTENT_TYPE'} =~ /boundary=\"?([^\";,]+)\"?/; + $self->read_multipart($boundary,$content_length); + last METHOD; + } + + # Process XForms postings. We know that we have XForms in the + # following cases: + # method eq 'POST' && content-type eq 'application/xml' + # method eq 'POST' && content-type =~ /multipart\/related.+start=/ + # There are more cases, actually, but for now, we don't support other + # methods for XForm posts. + # In a XForm POST, the QUERY_STRING is parsed normally. + # If the content-type is 'application/xml', we just set the param + # XForms:Model (referring to the xml syntax) param containing the + # unparsed XML data. + # In the case of multipart/related we set XForms:Model as above, but + # the other parts are available as uploads with the Content-ID as the + # the key. + # See the URL below for XForms specs on this issue. + # http://www.w3.org/TR/2006/REC-xforms-20060314/slice11.html#submit-options + if ($meth eq 'POST' && defined($ENV{'CONTENT_TYPE'})) { + if ($ENV{'CONTENT_TYPE'} eq 'application/xml') { + my($param) = 'XForms:Model'; + my($value) = ''; + $self->add_parameter($param); + $self->read_from_client(\$value,$content_length,0) + if $content_length > 0; + push (@{$self->{param}{$param}},$value); + $is_xforms = 1; + } elsif ($ENV{'CONTENT_TYPE'} =~ /multipart\/related.+boundary=\"?([^\";,]+)\"?.+start=\"?\<?([^\"\>]+)\>?\"?/) { + my($boundary,$start) = ($1,$2); + my($param) = 'XForms:Model'; + $self->add_parameter($param); + my($value) = $self->read_multipart_related($start,$boundary,$content_length,0); + push (@{$self->{param}{$param}},$value); + $query_string = $self->_get_query_string_from_env; + $is_xforms = 1; + } + } + + + # If initializer is defined, then read parameters + # from it. + if (!$is_xforms && defined($initializer)) { + if (UNIVERSAL::isa($initializer,'CGI')) { + $query_string = $initializer->query_string; + last METHOD; + } + if (ref($initializer) && ref($initializer) eq 'HASH') { + for (keys %$initializer) { + $self->param('-name'=>$_,'-value'=>$initializer->{$_}); + } + last METHOD; + } + + if (defined($fh) && ($fh ne '')) { + while (my $line = <$fh>) { + chomp $line; + last if $line =~ /^=$/; + push(@lines,$line); + } + # massage back into standard format + if ("@lines" =~ /=/) { + $query_string=join("&",@lines); + } else { + $query_string=join("+",@lines); + } + last METHOD; + } + + # last chance -- treat it as a string + $initializer = $$initializer if ref($initializer) eq 'SCALAR'; + $query_string = $initializer; + + last METHOD; + } + + # If method is GET, HEAD or DELETE, fetch the query from + # the environment. + if ($is_xforms || $meth=~/^(GET|HEAD|DELETE)$/) { + $query_string = $self->_get_query_string_from_env; + $self->param($meth . 'DATA', $self->param('XForms:Model')) + if $is_xforms; + last METHOD; + } + + if ($meth eq 'POST' || $meth eq 'PUT') { + if ( $content_length > 0 ) { + if ( ( $PUTDATA_UPLOAD || $self->{'.upload_hook'} ) && !$is_xforms && ($meth eq 'POST' || $meth eq 'PUT') + && defined($ENV{'CONTENT_TYPE'}) + && $ENV{'CONTENT_TYPE'} !~ m|^application/x-www-form-urlencoded| + && $ENV{'CONTENT_TYPE'} !~ m|^multipart/form-data| ){ + my $postOrPut = $meth . 'DATA' ; # POSTDATA/PUTDATA + $self->read_postdata_putdata( $postOrPut, $content_length, $ENV{'CONTENT_TYPE'} ); + $meth = ''; # to skip xform testing + undef $query_string ; + } else { + $self->read_from_client(\$query_string,$content_length,0); + } + } + # Some people want to have their cake and eat it too! + # Uncomment this line to have the contents of the query string + # APPENDED to the POST data. + # $query_string .= (length($query_string) ? '&' : '') . $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'}; + last METHOD; + } + + # If $meth is not of GET, POST, PUT or HEAD, assume we're + # being debugged offline. + # Check the command line and then the standard input for data. + # We use the shellwords package in order to behave the way that + # UN*X programmers expect. + if ($DEBUG) + { + my $cmdline_ret = read_from_cmdline(); + $query_string = $cmdline_ret->{'query_string'}; + if (defined($cmdline_ret->{'subpath'})) + { + $self->path_info($cmdline_ret->{'subpath'}); + } + } + } + +# YL: Begin Change for XML handler 10/19/2001 + if (!$is_xforms && ($meth eq 'POST' || $meth eq 'PUT') + && defined($ENV{'CONTENT_TYPE'}) + && $ENV{'CONTENT_TYPE'} !~ m|^application/x-www-form-urlencoded| + && $ENV{'CONTENT_TYPE'} !~ m|^multipart/form-data| ) { + my($param) = $meth . 'DATA' ; + $self->add_parameter($param) ; + push (@{$self->{param}{$param}},$query_string); + undef $query_string ; + } +# YL: End Change for XML handler 10/19/2001 + + # We now have the query string in hand. We do slightly + # different things for keyword lists and parameter lists. + if (defined $query_string && length $query_string) { + if ($query_string =~ /[&=;]/) { + $self->parse_params($query_string); + } else { + $self->add_parameter('keywords'); + $self->{param}{'keywords'} = [$self->parse_keywordlist($query_string)]; + } + } + + # Special case. Erase everything if there is a field named + # .defaults. + if ($self->param('.defaults')) { + $self->delete_all(); + } + + # hash containing our defined fieldnames + $self->{'.fieldnames'} = {}; + for ($self->param('.cgifields')) { + $self->{'.fieldnames'}->{$_}++; + } + + # Clear out our default submission button flag if present + $self->delete('.submit'); + $self->delete('.cgifields'); + + $self->save_request unless defined $initializer; +} + +sub _get_query_string_from_env { + my $self = shift; + my $query_string = ''; + + if ( $MOD_PERL ) { + $query_string = $self->r->args; + if ( ! $query_string && $MOD_PERL == 2 ) { + # possibly a redirect, inspect prev request + # (->prev only supported under mod_perl2) + if ( my $prev = $self->r->prev ) { + $query_string = $prev->args; + } + } + } + + $query_string ||= $ENV{'QUERY_STRING'} + if defined $ENV{'QUERY_STRING'}; + + if ( ! $query_string ) { + # try to get from REDIRECT_ env variables, support + # 5 levels of redirect and no more (RT #36312) + REDIRECT: foreach my $r ( 1 .. 5 ) { + my $key = join( '',( 'REDIRECT_' x $r ) ); + $query_string ||= $ENV{"${key}QUERY_STRING"} + if defined $ENV{"${key}QUERY_STRING"}; + last REDIRECT if $query_string; + } + } + + return $query_string; +} + +# FUNCTIONS TO OVERRIDE: +# Turn a string into a filehandle +sub to_filehandle { + my $thingy = shift; + return undef unless $thingy; + return $thingy if UNIVERSAL::isa($thingy,'GLOB'); + return $thingy if UNIVERSAL::isa($thingy,'FileHandle'); + if (!ref($thingy)) { + my $caller = 1; + while (my $package = caller($caller++)) { + my($tmp) = $thingy=~/[\':]/ ? $thingy : "$package\:\:$thingy"; + return $tmp if defined(fileno($tmp)); + } + } + return undef; +} + +# send output to the browser +sub put { + my($self,@p) = self_or_default(@_); + $self->print(@p); +} + +# print to standard output (for overriding in mod_perl) +sub print { + shift; + CORE::print(@_); +} + +# get/set last cgi_error +sub cgi_error { + my ($self,$err) = self_or_default(@_); + $self->{'.cgi_error'} = $err if defined $err; + return $self->{'.cgi_error'}; +} + +sub save_request { + my($self) = @_; + # We're going to play with the package globals now so that if we get called + # again, we initialize ourselves in exactly the same way. This allows + # us to have several of these objects. + @QUERY_PARAM = $self->param; # save list of parameters + for (@QUERY_PARAM) { + next unless defined $_; + $QUERY_PARAM{$_}=$self->{param}{$_}; + } + $QUERY_CHARSET = $self->charset; + %QUERY_FIELDNAMES = %{$self->{'.fieldnames'}}; + %QUERY_TMPFILES = %{ $self->{'.tmpfiles'} || {} }; +} + +sub parse_params { + my($self,$tosplit) = @_; + my(@pairs) = split(/[&;]/,$tosplit); + my($param,$value); + for (@pairs) { + ($param,$value) = split('=',$_,2); + next unless defined $param; + next if $NO_UNDEF_PARAMS and not defined $value; + $value = '' unless defined $value; + $param = unescape($param); + $value = unescape($value); + $self->add_parameter($param); + push (@{$self->{param}{$param}},$value); + } +} + +sub add_parameter { + my($self,$param)=@_; + return unless defined $param; + push (@{$self->{'.parameters'}},$param) + unless defined($self->{param}{$param}); +} + +sub all_parameters { + my $self = shift; + return () unless defined($self) && $self->{'.parameters'}; + return () unless @{$self->{'.parameters'}}; + return @{$self->{'.parameters'}}; +} + +# put a filehandle into binary mode (DOS) +sub binmode { + return unless defined($_[1]) && ref ($_[1]) && defined fileno($_[1]); + CORE::binmode($_[1]); +} + +# back compatibility html tag generation functions - noop +# since this is now the default having removed AUTOLOAD +sub compile { 1; } + +sub _all_html_tags { + return qw/ + a abbr acronym address applet Area + b base basefont bdo big blink blockquote body br + caption center cite code col colgroup + dd del dfn div dl dt + em embed + fieldset font fontsize frame frameset + h1 h2 h3 h4 h5 h6 head hr html + i iframe ilayer img input ins + kbd + label layer legend li Link + Map menu meta + nextid nobr noframes noscript + object ol option + p Param pre + Q + samp script Select small span + strike strong style Sub sup + table tbody td tfoot th thead title Tr TR tt + u ul + var + / +} + +foreach my $tag ( _all_html_tags() ) { + *$tag = sub { return _tag_func($tag,@_); }; + + # start_html and end_html already exist as custom functions + next if ($tag eq 'html'); + + foreach my $start_end ( qw/ start end / ) { + my $start_end_function = "${start_end}_${tag}"; + *$start_end_function = sub { return _tag_func($start_end_function,@_); }; + } +} + +sub _tag_func { + my $tagname = shift; + my ($q,$a,@rest) = self_or_default(@_); + + my($attr) = ''; + + if (ref($a) && ref($a) eq 'HASH') { + my(@attr) = make_attributes($a,$q->{'escape'}); + $attr = " @attr" if @attr; + } else { + unshift @rest,$a if defined $a; + } + + $tagname = lc( $tagname ); + + if ($tagname=~/start_(\w+)/i) { + return "<$1$attr>"; + } elsif ($tagname=~/end_(\w+)/i) { + return "</$1>"; + } else { + return $XHTML ? "<$tagname$attr />" : "<$tagname$attr>" unless @rest; + my($tag,$untag) = ("<$tagname$attr>","</$tagname>"); + my @result = map { "$tag$_$untag" } + (ref($rest[0]) eq 'ARRAY') ? @{$rest[0]} : "@rest"; + return "@result"; + } +} + +sub _selected { + my $self = shift; + my $value = shift; + return '' unless $value; + return $XHTML ? qq(selected="selected" ) : qq(selected ); +} + +sub _checked { + my $self = shift; + my $value = shift; + return '' unless $value; + return $XHTML ? qq(checked="checked" ) : qq(checked ); +} + +sub _reset_globals { initialize_globals(); } + +sub _setup_symbols { + my $self = shift; + + # to avoid reexporting unwanted variables + undef %EXPORT; + + for (@_) { + + if ( /^[:-]any$/ ) { + warn "CGI -any pragma has been REMOVED. You should audit your code for any use " + . "of none supported / incorrectly spelled tags and remove them" + ; + next; + } + $HEADERS_ONCE++, next if /^[:-]unique_headers$/; + $NPH++, next if /^[:-]nph$/; + $NOSTICKY++, next if /^[:-]nosticky$/; + $DEBUG=0, next if /^[:-]no_?[Dd]ebug$/; + $DEBUG=2, next if /^[:-][Dd]ebug$/; + $USE_PARAM_SEMICOLONS++, next if /^[:-]newstyle_urls$/; + $PUTDATA_UPLOAD++, next if /^[:-](?:putdata_upload|postdata_upload)$/; + $PARAM_UTF8++, next if /^[:-]utf8$/; + $XHTML++, next if /^[:-]xhtml$/; + $XHTML=0, next if /^[:-]no_?xhtml$/; + $USE_PARAM_SEMICOLONS=0, next if /^[:-]oldstyle_urls$/; + $TABINDEX++, next if /^[:-]tabindex$/; + $CLOSE_UPLOAD_FILES++, next if /^[:-]close_upload_files$/; + $NO_UNDEF_PARAMS++, next if /^[:-]no_undef_params$/; + + for (&expand_tags($_)) { + tr/a-zA-Z0-9_//cd; # don't allow weird function names + $EXPORT{$_}++; + } + } + @SAVED_SYMBOLS = @_; +} + +sub charset { + my ($self,$charset) = self_or_default(@_); + $self->{'.charset'} = $charset if defined $charset; + $self->{'.charset'}; +} + +sub element_id { + my ($self,$new_value) = self_or_default(@_); + $self->{'.elid'} = $new_value if defined $new_value; + sprintf('%010d',$self->{'.elid'}++); +} + +sub element_tab { + my ($self,$new_value) = self_or_default(@_); + $self->{'.etab'} ||= 1; + $self->{'.etab'} = $new_value if defined $new_value; + my $tab = $self->{'.etab'}++; + return '' unless $TABINDEX or defined $new_value; + return qq(tabindex="$tab" ); +} + +##### +# subroutine: read_postdata_putdata +# +# Unless file uploads are disabled +# Reads BODY of POST/PUT request and stuffs it into tempfile +# accessible as param POSTDATA/PUTDATA +# +# Also respects upload_hook +# +# based on subroutine read_multipart_related +##### +sub read_postdata_putdata { + my ( $self, $postOrPut, $content_length, $content_type ) = @_; + my %header = ( + "Content-Type" => $content_type, + ); + my $param = $postOrPut; + # add this parameter to our list + $self->add_parameter($param); + + + UPLOADS: { + + # If we get here, then we are dealing with a potentially large + # uploaded form. Save the data to a temporary file, then open + # the file for reading. + + # skip the file if uploads disabled + if ($DISABLE_UPLOADS) { + + # while (defined($data = $buffer->read)) { } + my $buff; + my $unit = $MultipartBuffer::INITIAL_FILLUNIT; + my $len = $content_length; + while ( $len > 0 ) { + my $read = $self->read_from_client( \$buf, $unit, 0 ); + $len -= $read; + } + last UPLOADS; + } + + # SHOULD PROBABLY SKIP THIS IF NOT $self->{'use_tempfile'} + # BUT THE REST OF CGI.PM DOESN'T, SO WHATEVER + my $tmp_dir = $CGI::OS eq 'WINDOWS' + ? ( $ENV{TEMP} || $ENV{TMP} || ( $ENV{WINDIR} ? ( $ENV{WINDIR} . $SL . 'TEMP' ) : undef ) ) + : undef; # File::Temp defaults to TMPDIR + + require CGI::File::Temp; + my $filehandle = CGI::File::Temp->new( + UNLINK => $UNLINK_TMP_FILES, + DIR => $tmp_dir, + ); + $filehandle->_mp_filename( $postOrPut ); + + $CGI::DefaultClass->binmode($filehandle) + if $CGI::needs_binmode + && defined fileno($filehandle); + + my ($data); + local ($\) = ''; + my $totalbytes; + my $unit = $MultipartBuffer::INITIAL_FILLUNIT; + my $len = $content_length; + $unit = $len; + my $ZERO_LOOP_COUNTER =0; + + while( $len > 0 ) + { + + my $bytesRead = $self->read_from_client( \$data, $unit, 0 ); + $len -= $bytesRead ; + + # An apparent bug in the Apache server causes the read() + # to return zero bytes repeatedly without blocking if the + # remote user aborts during a file transfer. I don't know how + # they manage this, but the workaround is to abort if we get + # more than SPIN_LOOP_MAX consecutive zero reads. + if ($bytesRead <= 0) { + die "CGI.pm: Server closed socket during read_postdata_putdata (client aborted?).\n" if $ZERO_LOOP_COUNTER++ >= $SPIN_LOOP_MAX; + } else { + $ZERO_LOOP_COUNTER = 0; + } + + if ( defined $self->{'.upload_hook'} ) { + $totalbytes += length($data); + &{ $self->{'.upload_hook'} }( $param, $data, $totalbytes, + $self->{'.upload_data'} ); + } + print $filehandle $data if ( $self->{'use_tempfile'} ); + undef $data; + } + + # back up to beginning of file + seek( $filehandle, 0, 0 ); + + ## Close the filehandle if requested this allows a multipart MIME + ## upload to contain many files, and we won't die due to too many + ## open file handles. The user can access the files using the hash + ## below. + close $filehandle if $CLOSE_UPLOAD_FILES; + $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode; + + # Save some information about the uploaded file where we can get + # at it later. + # Use the typeglob + filename as the key, as this is guaranteed to be + # unique for each filehandle. Don't use the file descriptor as + # this will be re-used for each filehandle if the + # close_upload_files feature is used. + $self->{'.tmpfiles'}->{$$filehandle . $filehandle} = { + hndl => $filehandle, + name => $filehandle->filename, + info => {%header}, + }; + push( @{ $self->{param}{$param} }, $filehandle ); + } + return; +} + +sub URL_ENCODED { 'application/x-www-form-urlencoded'; } + +sub MULTIPART { 'multipart/form-data'; } + +sub SERVER_PUSH { 'multipart/x-mixed-replace;boundary="' . shift() . '"'; } + +# Create a new multipart buffer +sub new_MultipartBuffer { + my($self,$boundary,$length) = @_; + return MultipartBuffer->new($self,$boundary,$length); +} + +# Read data from a file handle +sub read_from_client { + my($self, $buff, $len, $offset) = @_; + local $^W=0; # prevent a warning + return $MOD_PERL + ? $self->r->read($$buff, $len, $offset) + : read(\*STDIN, $$buff, $len, $offset); +} + +#### Method: delete +# Deletes the named parameter entirely. +#### +sub delete { + my($self,@p) = self_or_default(@_); + my(@names) = rearrange([NAME],@p); + my @to_delete = ref($names[0]) eq 'ARRAY' ? @$names[0] : @names; + my %to_delete; + for my $name (@to_delete) + { + CORE::delete $self->{param}{$name}; + CORE::delete $self->{'.fieldnames'}->{$name}; + $to_delete{$name}++; + } + @{$self->{'.parameters'}}=grep { !exists($to_delete{$_}) } $self->param(); + return; +} + +#### Method: import_names +# Import all parameters into the given namespace. +# Assumes namespace 'Q' if not specified +#### +sub import_names { + my($self,$namespace,$delete) = self_or_default(@_); + $namespace = 'Q' unless defined($namespace); + die "Can't import names into \"main\"\n" if \%{"${namespace}::"} == \%::; + if ($delete || $MOD_PERL || exists $ENV{'FCGI_ROLE'}) { + # can anyone find an easier way to do this? + for (keys %{"${namespace}::"}) { + local *symbol = "${namespace}::${_}"; + undef $symbol; + undef @symbol; + undef %symbol; + } + } + my($param,@value,$var); + for $param ($self->param) { + # protect against silly names + ($var = $param)=~tr/a-zA-Z0-9_/_/c; + $var =~ s/^(?=\d)/_/; + local *symbol = "${namespace}::$var"; + @value = $self->param($param); + @symbol = @value; + $symbol = $value[0]; + } +} + +#### Method: keywords +# Keywords acts a bit differently. Calling it in a list context +# returns the list of keywords. +# Calling it in a scalar context gives you the size of the list. +#### +sub keywords { + my($self,@values) = self_or_default(@_); + # If values is provided, then we set it. + $self->{param}{'keywords'}=[@values] if @values; + my(@result) = defined($self->{param}{'keywords'}) ? @{$self->{param}{'keywords'}} : (); + @result; +} + +# These are some tie() interfaces for compatibility +# with Steve Brenner's cgi-lib.pl routines +sub Vars { + my $q = shift; + my %in; + tie(%in,CGI,$q); + return %in if wantarray; + return \%in; +} + +# These are some tie() interfaces for compatibility +# with Steve Brenner's cgi-lib.pl routines +sub ReadParse { + local(*in); + if (@_) { + *in = $_[0]; + } else { + my $pkg = caller(); + *in=*{"${pkg}::in"}; + } + tie(%in,CGI); + return scalar(keys %in); +} + +sub PrintHeader { + my($self) = self_or_default(@_); + return $self->header(); +} + +sub HtmlTop { + my($self,@p) = self_or_default(@_); + return $self->start_html(@p); +} + +sub HtmlBot { + my($self,@p) = self_or_default(@_); + return $self->end_html(@p); +} + +sub SplitParam { + my ($param) = @_; + my (@params) = split ("\0", $param); + return (wantarray ? @params : $params[0]); +} + +sub MethGet { + return request_method() eq 'GET'; +} + +sub MethPost { + return request_method() eq 'POST'; +} + +sub MethPut { + return request_method() eq 'PUT'; +} + +sub TIEHASH { + my $class = shift; + my $arg = $_[0]; + if (ref($arg) && UNIVERSAL::isa($arg,'CGI')) { + return $arg; + } + return $Q ||= $class->new(@_); +} + +sub STORE { + my $self = shift; + my $tag = shift; + my $vals = shift; + my @vals = index($vals,"\0")!=-1 ? split("\0",$vals) : $vals; + $self->param(-name=>$tag,-value=>\@vals); +} + +sub FETCH { + return $_[0] if $_[1] eq 'CGI'; + return undef unless defined $_[0]->param($_[1]); + return join("\0",$_[0]->param($_[1])); +} + +sub FIRSTKEY { + $_[0]->{'.iterator'}=0; + $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++]; +} + +sub NEXTKEY { + $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++]; +} + +sub EXISTS { + exists $_[0]->{param}{$_[1]}; +} + +sub DELETE { + my ($self, $param) = @_; + my $value = $self->FETCH($param); + $self->delete($param); + return $value; +} + +sub CLEAR { + %{$_[0]}=(); +} +#### + +#### +# Append a new value to an existing query +#### +sub append { + my($self,@p) = self_or_default(@_); + my($name,$value) = rearrange([NAME,[VALUE,VALUES]],@p); + my(@values) = defined($value) ? (ref($value) ? @{$value} : $value) : (); + if (@values) { + $self->add_parameter($name); + push(@{$self->{param}{$name}},@values); + } + return $self->param($name); +} + +#### Method: delete_all +# Delete all parameters +#### +sub delete_all { + my($self) = self_or_default(@_); + my @param = $self->param(); + $self->delete(@param); +} + +sub Delete { + my($self,@p) = self_or_default(@_); + $self->delete(@p); +} + +sub Delete_all { + my($self,@p) = self_or_default(@_); + $self->delete_all(@p); +} + +#### Method: autoescape +# If you want to turn off the autoescaping features, +# call this method with undef as the argument +sub autoEscape { + my($self,$escape) = self_or_default(@_); + my $d = $self->{'escape'}; + $self->{'escape'} = $escape; + $d; +} + +#### Method: version +# Return the current version +#### +sub version { + return $VERSION; +} + +#### Method: url_param +# Return a parameter in the QUERY_STRING, regardless of +# whether this was a POST or a GET +#### +sub url_param { + my ($self,@p) = self_or_default(@_); + my $name = shift(@p); + return undef unless exists($ENV{QUERY_STRING}); + unless (exists($self->{'.url_param'})) { + $self->{'.url_param'}={}; # empty hash + if ($ENV{QUERY_STRING} =~ /=/) { + my(@pairs) = split(/[&;]/,$ENV{QUERY_STRING}); + my($param,$value); + for (@pairs) { + ($param,$value) = split('=',$_,2); + next if ! defined($param); + $param = unescape($param); + $value = unescape($value); + push(@{$self->{'.url_param'}->{$param}},$value); + } + } else { + my @keywords = $self->parse_keywordlist($ENV{QUERY_STRING}); + $self->{'.url_param'}{'keywords'} = \@keywords if @keywords; + } + } + return keys %{$self->{'.url_param'}} unless defined($name); + return () unless $self->{'.url_param'}->{$name}; + return wantarray ? @{$self->{'.url_param'}->{$name}} + : $self->{'.url_param'}->{$name}->[0]; +} + +#### Method: Dump +# Returns a string in which all the known parameter/value +# pairs are represented as nested lists, mainly for the purposes +# of debugging. +#### +sub Dump { + my($self) = self_or_default(@_); + my($param,$value,@result); + return '<ul></ul>' unless $self->param; + push(@result,"<ul>"); + for $param ($self->param) { + my($name)=$self->_maybe_escapeHTML($param); + push(@result,"<li><strong>$name</strong></li>"); + push(@result,"<ul>"); + for $value ($self->param($param)) { + $value = $self->_maybe_escapeHTML($value); + $value =~ s/\n/<br \/>\n/g; + push(@result,"<li>$value</li>"); + } + push(@result,"</ul>"); + } + push(@result,"</ul>"); + return join("\n",@result); +} + +#### Method as_string +# +# synonym for "dump" +#### +sub as_string { + &Dump(@_); +} + +#### Method: save +# Write values out to a filehandle in such a way that they can +# be reinitialized by the filehandle form of the new() method +#### +sub save { + my($self,$filehandle) = self_or_default(@_); + $filehandle = to_filehandle($filehandle); + my($param); + local($,) = ''; # set print field separator back to a sane value + local($\) = ''; # set output line separator to a sane value + for $param ($self->param) { + my($escaped_param) = escape($param); + my($value); + for $value ($self->param($param)) { + print $filehandle "$escaped_param=",escape("$value"),"\n" + if length($escaped_param) or length($value); + } + } + for (keys %{$self->{'.fieldnames'}}) { + print $filehandle ".cgifields=",escape("$_"),"\n"; + } + print $filehandle "=\n"; # end of record +} + +#### Method: save_parameters +# An alias for save() that is a better name for exportation. +# Only intended to be used with the function (non-OO) interface. +#### +sub save_parameters { + my $fh = shift; + return save(to_filehandle($fh)); +} + +#### Method: restore_parameters +# A way to restore CGI parameters from an initializer. +# Only intended to be used with the function (non-OO) interface. +#### +sub restore_parameters { + $Q = $CGI::DefaultClass->new(@_); +} + +#### Method: multipart_init +# Return a Content-Type: style header for server-push +# This has to be NPH on most web servers, and it is advisable to set $| = 1 +# +# Many thanks to Ed Jordan <ed@fidalgo.net> for this +# contribution, updated by Andrew Benham (adsb@bigfoot.com) +#### +sub multipart_init { + my($self,@p) = self_or_default(@_); + my($boundary,$charset,@other) = rearrange_header([BOUNDARY,CHARSET],@p); + if (!$boundary) { + $boundary = '------- =_'; + my @chrs = ('0'..'9', 'A'..'Z', 'a'..'z'); + for (1..17) { + $boundary .= $chrs[rand(scalar @chrs)]; + } + } + + $self->{'separator'} = "$CRLF--$boundary$CRLF"; + $self->{'final_separator'} = "$CRLF--$boundary--$CRLF"; + $type = SERVER_PUSH($boundary); + return $self->header( + -nph => 0, + -type => $type, + -charset => $charset, + (map { split "=", $_, 2 } @other), + ) . "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY." . $self->multipart_end; +} + +#### Method: multipart_start +# Return a Content-Type: style header for server-push, start of section +# +# Many thanks to Ed Jordan <ed@fidalgo.net> for this +# contribution, updated by Andrew Benham (adsb@bigfoot.com) +#### +sub multipart_start { + my(@header); + my($self,@p) = self_or_default(@_); + my($type,$charset,@other) = rearrange([TYPE,CHARSET],@p); + $type = $type || 'text/html'; + if ($charset) { + push(@header,"Content-Type: $type; charset=$charset"); + } else { + push(@header,"Content-Type: $type"); + } + + # rearrange() was designed for the HTML portion, so we + # need to fix it up a little. + for (@other) { + # Don't use \s because of perl bug 21951 + next unless my($header,$value) = /([^ \r\n\t=]+)=\"?(.+?)\"?$/; + ($_ = $header) =~ s/^(\w)(.*)/$1 . lc ($2) . ': '.$self->unescapeHTML($value)/e; + } + push(@header,@other); + my $header = join($CRLF,@header)."${CRLF}${CRLF}"; + return $header; +} + +#### Method: multipart_end +# Return a MIME boundary separator for server-push, end of section +# +# Many thanks to Ed Jordan <ed@fidalgo.net> for this +# contribution +#### +sub multipart_end { + my($self,@p) = self_or_default(@_); + return $self->{'separator'}; +} + +#### Method: multipart_final +# Return a MIME boundary separator for server-push, end of all sections +# +# Contributed by Andrew Benham (adsb@bigfoot.com) +#### +sub multipart_final { + my($self,@p) = self_or_default(@_); + return $self->{'final_separator'} . "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY." . $CRLF; +} + +#### Method: header +# Return a Content-Type: style header +# +#### +sub header { + my($self,@p) = self_or_default(@_); + my(@header); + + return "" if $self->{'.header_printed'}++ and $HEADERS_ONCE; + + my($type,$status,$cookie,$target,$expires,$nph,$charset,$attachment,$p3p,@other) = + rearrange([['TYPE','CONTENT_TYPE','CONTENT-TYPE'], + 'STATUS',['COOKIE','COOKIES','SET-COOKIE'],'TARGET', + 'EXPIRES','NPH','CHARSET', + 'ATTACHMENT','P3P'],@p); + + # Since $cookie and $p3p may be array references, + # we must stringify them before CR escaping is done. + my @cookie; + for (ref($cookie) eq 'ARRAY' ? @{$cookie} : $cookie) { + my $cs = UNIVERSAL::isa($_,'CGI::Cookie') ? $_->as_string : $_; + push(@cookie,$cs) if defined $cs and $cs ne ''; + } + $p3p = join ' ',@$p3p if ref($p3p) eq 'ARRAY'; + + # CR escaping for values, per RFC 822 + for my $header ($type,$status,@cookie,$target,$expires,$nph,$charset,$attachment,$p3p,@other) { + if (defined $header) { + # From RFC 822: + # Unfolding is accomplished by regarding CRLF immediately + # followed by a LWSP-char as equivalent to the LWSP-char. + $header =~ s/$CRLF(\s)/$1/g; + + # All other uses of newlines are invalid input. + if ($header =~ m/$CRLF|\015|\012/) { + # shorten very long values in the diagnostic + $header = substr($header,0,72).'...' if (length $header > 72); + die "Invalid header value contains a newline not followed by whitespace: $header"; + } + } + } + + $nph ||= $NPH; + + $type ||= 'text/html' unless defined($type); + + # sets if $charset is given, gets if not + $charset = $self->charset( $charset ); + + # rearrange() was designed for the HTML portion, so we + # need to fix it up a little. + for (@other) { + # Don't use \s because of perl bug 21951 + next unless my($header,$value) = /([^ \r\n\t=]+)=\"?(.+?)\"?$/s; + ($_ = $header) =~ s/^(\w)(.*)/"\u$1\L$2" . ': '.$self->unescapeHTML($value)/e; + } + + $type .= "; charset=$charset" + if $type ne '' + and $type !~ /\bcharset\b/ + and defined $charset + and $charset ne ''; + + # Maybe future compatibility. Maybe not. + my $protocol = $ENV{SERVER_PROTOCOL} || 'HTTP/1.0'; + push(@header,$protocol . ' ' . ($status || '200 OK')) if $nph; + push(@header,"Server: " . &server_software()) if $nph; + + push(@header,"Status: $status") if $status; + push(@header,"Window-Target: $target") if $target; + push(@header,"P3P: policyref=\"/w3c/p3p.xml\", CP=\"$p3p\"") if $p3p; + # push all the cookies -- there may be several + push(@header,map {"Set-Cookie: $_"} @cookie); + # if the user indicates an expiration time, then we need + # both an Expires and a Date header (so that the browser is + # uses OUR clock) + push(@header,"Expires: " . expires($expires,'http')) + if $expires; + push(@header,"Date: " . expires(0,'http')) if $expires || $cookie || $nph; + push(@header,"Pragma: no-cache") if $self->cache(); + push(@header,"Content-Disposition: attachment; filename=\"$attachment\"") if $attachment; + push(@header,map {ucfirst $_} @other); + push(@header,"Content-Type: $type") if $type ne ''; + my $header = join($CRLF,@header)."${CRLF}${CRLF}"; + if (($MOD_PERL >= 1) && !$nph) { + $self->r->send_cgi_header($header); + return ''; + } + return $header; +} + +#### Method: cache +# Control whether header() will produce the no-cache +# Pragma directive. +#### +sub cache { + my($self,$new_value) = self_or_default(@_); + $new_value = '' unless $new_value; + if ($new_value ne '') { + $self->{'cache'} = $new_value; + } + return $self->{'cache'}; +} + +#### Method: redirect +# Return a Location: style header +# +#### +sub redirect { + my($self,@p) = self_or_default(@_); + my($url,$target,$status,$cookie,$nph,@other) = + rearrange([[LOCATION,URI,URL],TARGET,STATUS,['COOKIE','COOKIES','SET-COOKIE'],NPH],@p); + $status = '302 Found' unless defined $status; + $url ||= $self->self_url; + my(@o); + for (@other) { tr/\"//d; push(@o,split("=",$_,2)); } + unshift(@o, + '-Status' => $status, + '-Location'=> $url, + '-nph' => $nph); + unshift(@o,'-Target'=>$target) if $target; + unshift(@o,'-Type'=>''); + my @unescaped; + unshift(@unescaped,'-Cookie'=>$cookie) if $cookie; + return $self->header((map {$self->unescapeHTML($_)} @o),@unescaped); +} + +#### Method: start_html +# Canned HTML header +# +# Parameters: +# $title -> (optional) The title for this HTML document (-title) +# $author -> (optional) e-mail address of the author (-author) +# $base -> (optional) if set to true, will enter the BASE address of this document +# for resolving relative references (-base) +# $xbase -> (optional) alternative base at some remote location (-xbase) +# $target -> (optional) target window to load all links into (-target) +# $script -> (option) Javascript code (-script) +# $no_script -> (option) Javascript <noscript> tag (-noscript) +# $meta -> (optional) Meta information tags +# $head -> (optional) any other elements you'd like to incorporate into the <head> tag +# (a scalar or array ref) +# $style -> (optional) reference to an external style sheet +# @other -> (optional) any other named parameters you'd like to incorporate into +# the <body> tag. +#### +sub start_html { + my($self,@p) = &self_or_default(@_); + my($title,$author,$base,$xbase,$script,$noscript, + $target,$meta,$head,$style,$dtd,$lang,$encoding,$declare_xml,@other) = + rearrange([TITLE,AUTHOR,BASE,XBASE,SCRIPT,NOSCRIPT,TARGET, + META,HEAD,STYLE,DTD,LANG,ENCODING,DECLARE_XML],@p); + + $self->element_id(0); + $self->element_tab(0); + + $encoding = lc($self->charset) unless defined $encoding; + + # Need to sort out the DTD before it's okay to call escapeHTML(). + my(@result,$xml_dtd); + if ($dtd) { + if (defined(ref($dtd)) and (ref($dtd) eq 'ARRAY')) { + $dtd = $DEFAULT_DTD unless $dtd->[0] =~ m|^-//|; + } else { + $dtd = $DEFAULT_DTD unless $dtd =~ m|^-//|; + } + } else { + $dtd = $XHTML ? $_XHTML_DTD : $DEFAULT_DTD; + } + + $xml_dtd++ if ref($dtd) eq 'ARRAY' && $dtd->[0] =~ /\bXHTML\b/i; + $xml_dtd++ if ref($dtd) eq '' && $dtd =~ /\bXHTML\b/i; + push @result,qq(<?xml version="1.0" encoding="$encoding"?>) if $xml_dtd && $declare_xml; + + if (ref($dtd) && ref($dtd) eq 'ARRAY') { + push(@result,qq(<!DOCTYPE html\n\tPUBLIC "$dtd->[0]"\n\t "$dtd->[1]">)); + $DTD_PUBLIC_IDENTIFIER = $dtd->[0]; + } else { + push(@result,qq(<!DOCTYPE html\n\tPUBLIC "$dtd">)); + $DTD_PUBLIC_IDENTIFIER = $dtd; + } + + # Now that we know whether we're using the HTML 3.2 DTD or not, it's okay to + # call escapeHTML(). Strangely enough, the title needs to be escaped as + # HTML while the author needs to be escaped as a URL. + $title = $self->_maybe_escapeHTML($title || 'Untitled Document'); + $author = $self->escape($author); + + if ($DTD_PUBLIC_IDENTIFIER =~ /[^X]HTML (2\.0|3\.2|4\.01?)/i) { + $lang = "" unless defined $lang; + $XHTML = 0; + } + else { + $lang = 'en-US' unless defined $lang; + } + + my $lang_bits = $lang ne '' ? qq( lang="$lang" xml:lang="$lang") : ''; + my $meta_bits = qq(<meta http-equiv="Content-Type" content="text/html; charset=$encoding" />) + if $XHTML && $encoding && !$declare_xml; + + push(@result,$XHTML ? qq(<html xmlns="http://www.w3.org/1999/xhtml"$lang_bits>\n<head>\n<title>$title</title>) + : ($lang ? qq(<html lang="$lang">) : "<html>") + . "<head><title>$title</title>"); + if (defined $author) { + push(@result,$XHTML ? "<link rev=\"made\" href=\"mailto:$author\" />" + : "<link rev=\"made\" href=\"mailto:$author\">"); + } + + if ($base || $xbase || $target) { + my $href = $xbase || $self->url('-path'=>1); + my $t = $target ? qq/ target="$target"/ : ''; + push(@result,$XHTML ? qq(<base href="$href"$t />) : qq(<base href="$href"$t>)); + } + + if ($meta && ref($meta) && (ref($meta) eq 'HASH')) { + for (sort keys %$meta) { push(@result,$XHTML ? qq(<meta name="$_" content="$meta->{$_}" />) + : qq(<meta name="$_" content="$meta->{$_}">)); } + } + + my $meta_bits_set = 0; + if( $head ) { + if( ref $head ) { + push @result, @$head; + $meta_bits_set = 1 if grep { /http-equiv=["']Content-Type/i }@$head; + } + else { + push @result, $head; + $meta_bits_set = 1 if $head =~ /http-equiv=["']Content-Type/i; + } + } + + # handle the infrequently-used -style and -script parameters + push(@result,$self->_style($style)) if defined $style; + push(@result,$self->_script($script)) if defined $script; + push(@result,$meta_bits) if defined $meta_bits and !$meta_bits_set; + + # handle -noscript parameter + push(@result,<<END) if $noscript; +<noscript> +$noscript +</noscript> +END + ; + my($other) = @other ? " @other" : ''; + push(@result,"</head>\n<body$other>\n"); + return join("\n",@result); +} + +### Method: _style +# internal method for generating a CSS style section +#### +sub _style { + my ($self,$style) = @_; + my (@result); + + my $type = 'text/css'; + my $rel = 'stylesheet'; + + + my $cdata_start = $XHTML ? "\n<!--/* <![CDATA[ */" : "\n<!-- "; + my $cdata_end = $XHTML ? "\n/* ]]> */-->\n" : " -->\n"; + + my @s = ref($style) eq 'ARRAY' ? @$style : $style; + my $other = ''; + + for my $s (@s) { + if (ref($s)) { + my($src,$code,$verbatim,$stype,$alternate,$foo,@other) = + rearrange([qw(SRC CODE VERBATIM TYPE ALTERNATE FOO)], + ('-foo'=>'bar', + ref($s) eq 'ARRAY' ? @$s : %$s)); + my $type = defined $stype ? $stype : 'text/css'; + my $rel = $alternate ? 'alternate stylesheet' : 'stylesheet'; + $other = "@other" if @other; + + if (ref($src) eq "ARRAY") # Check to see if the $src variable is an array reference + { # If it is, push a LINK tag for each one + for $src (@$src) + { + push(@result,$XHTML ? qq(<link rel="$rel" type="$type" href="$src" $other/>) + : qq(<link rel="$rel" type="$type" href="$src"$other>)) if $src; + } + } + else + { # Otherwise, push the single -src, if it exists. + push(@result,$XHTML ? qq(<link rel="$rel" type="$type" href="$src" $other/>) + : qq(<link rel="$rel" type="$type" href="$src"$other>) + ) if $src; + } + if ($verbatim) { + my @v = ref($verbatim) eq 'ARRAY' ? @$verbatim : $verbatim; + push(@result, "<style type=\"text/css\">\n$_\n</style>") for @v; + } + if ($code) { + my @c = ref($code) eq 'ARRAY' ? @$code : $code; + push(@result,style({'type'=>$type},"$cdata_start\n$_\n$cdata_end")) for @c; + } + + } else { + my $src = $s; + push(@result,$XHTML ? qq(<link rel="$rel" type="$type" href="$src" $other/>) + : qq(<link rel="$rel" type="$type" href="$src"$other>)); + } + } + @result; +} + +sub _script { + my ($self,$script) = @_; + my (@result); + + my (@scripts) = ref($script) eq 'ARRAY' ? @$script : ($script); + for $script (@scripts) { + my($src,$code,$language,$charset); + if (ref($script)) { # script is a hash + ($src,$code,$type,$charset) = + rearrange(['SRC','CODE',['LANGUAGE','TYPE'],'CHARSET'], + '-foo'=>'bar', # a trick to allow the '-' to be omitted + ref($script) eq 'ARRAY' ? @$script : %$script); + $type ||= 'text/javascript'; + unless ($type =~ m!\w+/\w+!) { + $type =~ s/[\d.]+$//; + $type = "text/$type"; + } + } else { + ($src,$code,$type,$charset) = ('',$script, 'text/javascript', ''); + } + + my $comment = '//'; # javascript by default + $comment = '#' if $type=~/perl|tcl/i; + $comment = "'" if $type=~/vbscript/i; + + my ($cdata_start,$cdata_end); + if ($XHTML) { + $cdata_start = "$comment<![CDATA[\n"; + $cdata_end .= "\n$comment]]>"; + } else { + $cdata_start = "\n<!-- Hide script\n"; + $cdata_end = $comment; + $cdata_end .= " End script hiding -->\n"; + } + my(@satts); + push(@satts,'src'=>$src) if $src; + push(@satts,'type'=>$type); + push(@satts,'charset'=>$charset) if ($src && $charset); + $code = $cdata_start . $code . $cdata_end if defined $code; + push(@result,$self->script({@satts},$code || '')); + } + @result; +} + +#### Method: end_html +# End an HTML document. +# Trivial method for completeness. Just returns "</body>" +#### +sub end_html { + return "\n</body>\n</html>"; +} + +################################ +# METHODS USED IN BUILDING FORMS +################################ + +#### Method: isindex +# Just prints out the isindex tag. +# Parameters: +# $action -> optional URL of script to run +# Returns: +# A string containing a <isindex> tag +sub isindex { + my($self,@p) = self_or_default(@_); + my($action,@other) = rearrange([ACTION],@p); + $action = qq/ action="$action"/ if $action; + my($other) = @other ? " @other" : ''; + return $XHTML ? "<isindex$action$other />" : "<isindex$action$other>"; +} + +#### Method: start_form +# Start a form +# Parameters: +# $method -> optional submission method to use (GET or POST) +# $action -> optional URL of script to run +# $enctype ->encoding to use (URL_ENCODED or MULTIPART) +sub start_form { + my($self,@p) = self_or_default(@_); + + my($method,$action,$enctype,@other) = + rearrange([METHOD,ACTION,ENCTYPE],@p); + + $method = $self->_maybe_escapeHTML(lc($method || 'post')); + + if( $XHTML ){ + $enctype = $self->_maybe_escapeHTML($enctype || &MULTIPART); + }else{ + $enctype = $self->_maybe_escapeHTML($enctype || &URL_ENCODED); + } + + if (defined $action) { + $action = $self->_maybe_escapeHTML($action); + } + else { + $action = $self->_maybe_escapeHTML($self->request_uri || $self->self_url); + } + $action = qq(action="$action"); + my($other) = @other ? " @other" : ''; + $self->{'.parametersToAdd'}={}; + return qq/<form method="$method" $action enctype="$enctype"$other>/; +} + +#### Method: start_multipart_form +sub start_multipart_form { + my($self,@p) = self_or_default(@_); + if (defined($p[0]) && substr($p[0],0,1) eq '-') { + return $self->start_form(-enctype=>&MULTIPART,@p); + } else { + my($method,$action,@other) = + rearrange([METHOD,ACTION],@p); + return $self->start_form($method,$action,&MULTIPART,@other); + } +} + +#### Method: end_form +# End a form +# Note: This repeated below under the older name. +sub end_form { + my($self,@p) = self_or_default(@_); + if ( $NOSTICKY ) { + return wantarray ? ("</form>") : "\n</form>"; + } else { + if (my @fields = $self->get_fields) { + return wantarray ? ("<div>",@fields,"</div>","</form>") + : "<div>".(join '',@fields)."</div>\n</form>"; + } else { + return "</form>"; + } + } +} + +#### Method: end_multipart_form +# end a multipart form +sub end_multipart_form { + &end_form; +} + +sub _textfield { + my($self,$tag,@p) = self_or_default(@_); + my($name,$default,$size,$maxlength,$override,$tabindex,@other) = + rearrange([NAME,[DEFAULT,VALUE,VALUES],SIZE,MAXLENGTH,[OVERRIDE,FORCE],TABINDEX],@p); + + my $current = $override ? $default : + (defined($self->param($name)) ? $self->param($name) : $default); + + $current = defined($current) ? $self->_maybe_escapeHTML($current,1) : ''; + $name = defined($name) ? $self->_maybe_escapeHTML($name) : ''; + my($s) = defined($size) ? qq/ size="$size"/ : ''; + my($m) = defined($maxlength) ? qq/ maxlength="$maxlength"/ : ''; + my($other) = @other ? " @other" : ''; + # this entered at cristy's request to fix problems with file upload fields + # and WebTV -- not sure it won't break stuff + my($value) = $current ne '' ? qq(value="$current") : ''; + $tabindex = $self->element_tab($tabindex); + return $XHTML ? qq(<input type="$tag" name="$name" $tabindex$value$s$m$other />) + : qq(<input type="$tag" name="$name" $value$s$m$other>); +} + +#### Method: textfield +# Parameters: +# $name -> Name of the text field +# $default -> Optional default value of the field if not +# already defined. +# $size -> Optional width of field in characaters. +# $maxlength -> Optional maximum number of characters. +# Returns: +# A string containing a <input type="text"> field +# +sub textfield { + my($self,@p) = self_or_default(@_); + $self->_textfield('text',@p); +} + +#### Method: filefield +# Parameters: +# $name -> Name of the file upload field +# $size -> Optional width of field in characaters. +# $maxlength -> Optional maximum number of characters. +# Returns: +# A string containing a <input type="file"> field +# +sub filefield { + my($self,@p) = self_or_default(@_); + $self->_textfield('file',@p); +} + +#### Method: password +# Create a "secret password" entry field +# Parameters: +# $name -> Name of the field +# $default -> Optional default value of the field if not +# already defined. +# $size -> Optional width of field in characters. +# $maxlength -> Optional maximum characters that can be entered. +# Returns: +# A string containing a <input type="password"> field +# +sub password_field { + my ($self,@p) = self_or_default(@_); + $self->_textfield('password',@p); +} + +#### Method: textarea +# Parameters: +# $name -> Name of the text field +# $default -> Optional default value of the field if not +# already defined. +# $rows -> Optional number of rows in text area +# $columns -> Optional number of columns in text area +# Returns: +# A string containing a <textarea></textarea> tag +# +sub textarea { + my($self,@p) = self_or_default(@_); + my($name,$default,$rows,$cols,$override,$tabindex,@other) = + rearrange([NAME,[DEFAULT,VALUE],ROWS,[COLS,COLUMNS],[OVERRIDE,FORCE],TABINDEX],@p); + + my($current)= $override ? $default : + (defined($self->param($name)) ? $self->param($name) : $default); + + $name = defined($name) ? $self->_maybe_escapeHTML($name) : ''; + $current = defined($current) ? $self->_maybe_escapeHTML($current) : ''; + my($r) = $rows ? qq/ rows="$rows"/ : ''; + my($c) = $cols ? qq/ cols="$cols"/ : ''; + my($other) = @other ? " @other" : ''; + $tabindex = $self->element_tab($tabindex); + return qq{<textarea name="$name" $tabindex$r$c$other>$current</textarea>}; +} + +#### Method: button +# Create a javascript button. +# Parameters: +# $name -> (optional) Name for the button. (-name) +# $value -> (optional) Value of the button when selected (and visible name) (-value) +# $onclick -> (optional) Text of the JavaScript to run when the button is +# clicked. +# Returns: +# A string containing a <input type="button"> tag +#### +sub button { + my($self,@p) = self_or_default(@_); + + my($label,$value,$script,$tabindex,@other) = rearrange([NAME,[VALUE,LABEL], + [ONCLICK,SCRIPT],TABINDEX],@p); + + $label=$self->_maybe_escapeHTML($label); + $value=$self->_maybe_escapeHTML($value,1); + $script=$self->_maybe_escapeHTML($script); + + $script ||= ''; + + my($name) = ''; + $name = qq/ name="$label"/ if $label; + $value = $value || $label; + my($val) = ''; + $val = qq/ value="$value"/ if $value; + $script = qq/ onclick="$script"/ if $script; + my($other) = @other ? " @other" : ''; + $tabindex = $self->element_tab($tabindex); + return $XHTML ? qq(<input type="button" $tabindex$name$val$script$other />) + : qq(<input type="button"$name$val$script$other>); +} + +#### Method: submit +# Create a "submit query" button. +# Parameters: +# $name -> (optional) Name for the button. +# $value -> (optional) Value of the button when selected (also doubles as label). +# $label -> (optional) Label printed on the button(also doubles as the value). +# Returns: +# A string containing a <input type="submit"> tag +#### +sub submit { + my($self,@p) = self_or_default(@_); + + my($label,$value,$tabindex,@other) = rearrange([NAME,[VALUE,LABEL],TABINDEX],@p); + + $label=$self->_maybe_escapeHTML($label); + $value=$self->_maybe_escapeHTML($value,1); + + my $name = $NOSTICKY ? '' : 'name=".submit" '; + $name = qq/name="$label" / if defined($label); + $value = defined($value) ? $value : $label; + my $val = ''; + $val = qq/value="$value" / if defined($value); + $tabindex = $self->element_tab($tabindex); + my($other) = @other ? "@other " : ''; + return $XHTML ? qq(<input type="submit" $tabindex$name$val$other/>) + : qq(<input type="submit" $name$val$other>); +} + +#### Method: reset +# Create a "reset" button. +# Parameters: +# $name -> (optional) Name for the button. +# Returns: +# A string containing a <input type="reset"> tag +#### +sub reset { + my($self,@p) = self_or_default(@_); + my($label,$value,$tabindex,@other) = rearrange(['NAME',['VALUE','LABEL'],TABINDEX],@p); + $label=$self->_maybe_escapeHTML($label); + $value=$self->_maybe_escapeHTML($value,1); + my ($name) = ' name=".reset"'; + $name = qq/ name="$label"/ if defined($label); + $value = defined($value) ? $value : $label; + my($val) = ''; + $val = qq/ value="$value"/ if defined($value); + my($other) = @other ? " @other" : ''; + $tabindex = $self->element_tab($tabindex); + return $XHTML ? qq(<input type="reset" $tabindex$name$val$other />) + : qq(<input type="reset"$name$val$other>); +} + +#### Method: defaults +# Create a "defaults" button. +# Parameters: +# $name -> (optional) Name for the button. +# Returns: +# A string containing a <input type="submit" name=".defaults"> tag +# +# Note: this button has a special meaning to the initialization script, +# and tells it to ERASE the current query string so that your defaults +# are used again! +#### +sub defaults { + my($self,@p) = self_or_default(@_); + + my($label,$tabindex,@other) = rearrange([[NAME,VALUE],TABINDEX],@p); + + $label=$self->_maybe_escapeHTML($label,1); + $label = $label || "Defaults"; + my($value) = qq/ value="$label"/; + my($other) = @other ? " @other" : ''; + $tabindex = $self->element_tab($tabindex); + return $XHTML ? qq(<input type="submit" name=".defaults" $tabindex$value$other />) + : qq/<input type="submit" NAME=".defaults"$value$other>/; +} + +#### Method: comment +# Create an HTML <!-- comment --> +# Parameters: a string +sub comment { + my($self,@p) = self_or_CGI(@_); + return "<!-- @p -->"; +} + +#### Method: checkbox +# Create a checkbox that is not logically linked to any others. +# The field value is "on" when the button is checked. +# Parameters: +# $name -> Name of the checkbox +# $checked -> (optional) turned on by default if true +# $value -> (optional) value of the checkbox, 'on' by default +# $label -> (optional) a user-readable label printed next to the box. +# Otherwise the checkbox name is used. +# Returns: +# A string containing a <input type="checkbox"> field +#### +sub checkbox { + my($self,@p) = self_or_default(@_); + + my($name,$checked,$value,$label,$labelattributes,$override,$tabindex,@other) = + rearrange([NAME,[CHECKED,SELECTED,ON],VALUE,LABEL,LABELATTRIBUTES, + [OVERRIDE,FORCE],TABINDEX],@p); + + $value = defined $value ? $value : 'on'; + + if (!$override && ($self->{'.fieldnames'}->{$name} || + defined $self->param($name))) { + $checked = grep($_ eq $value,$self->param($name)) ? $self->_checked(1) : ''; + } else { + $checked = $self->_checked($checked); + } + my($the_label) = defined $label ? $label : $name; + $name = $self->_maybe_escapeHTML($name); + $value = $self->_maybe_escapeHTML($value,1); + $the_label = $self->_maybe_escapeHTML($the_label); + my($other) = @other ? "@other " : ''; + $tabindex = $self->element_tab($tabindex); + $self->register_parameter($name); + return $XHTML ? CGI::label($labelattributes, + qq{<input type="checkbox" name="$name" value="$value" $tabindex$checked$other/>$the_label}) + : qq{<input type="checkbox" name="$name" value="$value"$checked$other>$the_label}; +} + +# Escape HTML +sub escapeHTML { + require HTML::Entities; + # hack to work around earlier hacks + push @_,$_[0] if @_==1 && $_[0] eq 'CGI'; + my ($self,$toencode,$newlinestoo) = CGI::self_or_default(@_); + return undef unless defined($toencode); + my $encode_entities = $ENCODE_ENTITIES; + $encode_entities .= "\012\015" if ( $encode_entities && $newlinestoo ); + return HTML::Entities::encode_entities($toencode,$encode_entities); +} + +# unescape HTML -- used internally +sub unescapeHTML { + require HTML::Entities; + # hack to work around earlier hacks + push @_,$_[0] if @_==1 && $_[0] eq 'CGI'; + my ($self,$string) = CGI::self_or_default(@_); + return undef unless defined($string); + return HTML::Entities::decode_entities($string); +} + +# Internal procedure - don't use +sub _tableize { + my($rows,$columns,$rowheaders,$colheaders,@elements) = @_; + my @rowheaders = $rowheaders ? @$rowheaders : (); + my @colheaders = $colheaders ? @$colheaders : (); + my($result); + + if (defined($columns)) { + $rows = int(0.99 + @elements/$columns) unless defined($rows); + } + if (defined($rows)) { + $columns = int(0.99 + @elements/$rows) unless defined($columns); + } + + # rearrange into a pretty table + $result = "<table>"; + my($row,$column); + unshift(@colheaders,'') if @colheaders && @rowheaders; + $result .= "<tr>" if @colheaders; + for (@colheaders) { + $result .= "<th>$_</th>"; + } + for ($row=0;$row<$rows;$row++) { + $result .= "<tr>"; + $result .= "<th>$rowheaders[$row]</th>" if @rowheaders; + for ($column=0;$column<$columns;$column++) { + $result .= "<td>" . $elements[$column*$rows + $row] . "</td>" + if defined($elements[$column*$rows + $row]); + } + $result .= "</tr>"; + } + $result .= "</table>"; + return $result; +} + +#### Method: radio_group +# Create a list of logically-linked radio buttons. +# Parameters: +# $name -> Common name for all the buttons. +# $values -> A pointer to a regular array containing the +# values for each button in the group. +# $default -> (optional) Value of the button to turn on by default. Pass '-' +# to turn _nothing_ on. +# $linebreak -> (optional) Set to true to place linebreaks +# between the buttons. +# $labels -> (optional) +# A pointer to a hash of labels to print next to each checkbox +# in the form $label{'value'}="Long explanatory label". +# Otherwise the provided values are used as the labels. +# Returns: +# An ARRAY containing a series of <input type="radio"> fields +#### +sub radio_group { + my($self,@p) = self_or_default(@_); + $self->_box_group('radio',@p); +} + +#### Method: checkbox_group +# Create a list of logically-linked checkboxes. +# Parameters: +# $name -> Common name for all the check boxes +# $values -> A pointer to a regular array containing the +# values for each checkbox in the group. +# $defaults -> (optional) +# 1. If a pointer to a regular array of checkbox values, +# then this will be used to decide which +# checkboxes to turn on by default. +# 2. If a scalar, will be assumed to hold the +# value of a single checkbox in the group to turn on. +# $linebreak -> (optional) Set to true to place linebreaks +# between the buttons. +# $labels -> (optional) +# A pointer to a hash of labels to print next to each checkbox +# in the form $label{'value'}="Long explanatory label". +# Otherwise the provided values are used as the labels. +# Returns: +# An ARRAY containing a series of <input type="checkbox"> fields +#### + +sub checkbox_group { + my($self,@p) = self_or_default(@_); + $self->_box_group('checkbox',@p); +} + +sub _box_group { + my $self = shift; + my $box_type = shift; + + my($name,$values,$defaults,$linebreak,$labels,$labelattributes, + $attributes,$rows,$columns,$rowheaders,$colheaders, + $override,$nolabels,$tabindex,$disabled,@other) = + rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LINEBREAK,LABELS,LABELATTRIBUTES, + ATTRIBUTES,ROWS,[COLUMNS,COLS],[ROWHEADERS,ROWHEADER],[COLHEADERS,COLHEADER], + [OVERRIDE,FORCE],NOLABELS,TABINDEX,DISABLED + ],@_); + + + my($result,$checked,@elements,@values); + + @values = $self->_set_values_and_labels($values,\$labels,$name); + my %checked = $self->previous_or_default($name,$defaults,$override); + + # If no check array is specified, check the first by default + $checked{$values[0]}++ if $box_type eq 'radio' && !%checked; + + $name=$self->_maybe_escapeHTML($name); + + my %tabs = (); + if ($TABINDEX && $tabindex) { + if (!ref $tabindex) { + $self->element_tab($tabindex); + } elsif (ref $tabindex eq 'ARRAY') { + %tabs = map {$_=>$self->element_tab} @$tabindex; + } elsif (ref $tabindex eq 'HASH') { + %tabs = %$tabindex; + } + } + %tabs = map {$_=>$self->element_tab} @values unless %tabs; + my $other = @other ? "@other " : ''; + my $radio_checked; + + # for disabling groups of radio/checkbox buttons + my %disabled; + for (@{$disabled}) { + $disabled{$_}=1; + } + + for (@values) { + my $disable=""; + if ($disabled{$_}) { + $disable="disabled='1'"; + } + + my $checkit = $self->_checked($box_type eq 'radio' ? ($checked{$_} && !$radio_checked++) + : $checked{$_}); + my($break); + if ($linebreak) { + $break = $XHTML ? "<br />" : "<br>"; + } + else { + $break = ''; + } + my($label)=''; + unless (defined($nolabels) && $nolabels) { + $label = $_; + $label = $labels->{$_} if defined($labels) && defined($labels->{$_}); + $label = $self->_maybe_escapeHTML($label,1); + $label = "<span style=\"color:gray\">$label</span>" if $disabled{$_}; + } + my $attribs = $self->_set_attributes($_, $attributes); + my $tab = $tabs{$_}; + $_=$self->_maybe_escapeHTML($_); + + if ($XHTML) { + push @elements, + CGI::label($labelattributes, + qq(<input type="$box_type" name="$name" value="$_" $checkit$other$tab$attribs$disable/>$label)).${break}; + } else { + push(@elements,qq/<input type="$box_type" name="$name" value="$_" $checkit$other$tab$attribs$disable>${label}${break}/); + } + } + $self->register_parameter($name); + return wantarray ? @elements : "@elements" + unless defined($columns) || defined($rows); + return _tableize($rows,$columns,$rowheaders,$colheaders,@elements); +} + +#### Method: popup_menu +# Create a popup menu. +# Parameters: +# $name -> Name for all the menu +# $values -> A pointer to a regular array containing the +# text of each menu item. +# $default -> (optional) Default item to display +# $labels -> (optional) +# A pointer to a hash of labels to print next to each checkbox +# in the form $label{'value'}="Long explanatory label". +# Otherwise the provided values are used as the labels. +# Returns: +# A string containing the definition of a popup menu. +#### +sub popup_menu { + my($self,@p) = self_or_default(@_); + + my($name,$values,$default,$labels,$attributes,$override,$tabindex,@other) = + rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LABELS, + ATTRIBUTES,[OVERRIDE,FORCE],TABINDEX],@p); + my($result,%selected); + + if (!$override && defined($self->param($name))) { + $selected{$self->param($name)}++; + } elsif (defined $default) { + %selected = map {$_=>1} ref($default) eq 'ARRAY' + ? @$default + : $default; + } + $name=$self->_maybe_escapeHTML($name); + # RT #30057 - ignore -multiple, if you need this + # then use scrolling_list + @other = grep { $_ !~ /^multiple=/i } @other; + my($other) = @other ? " @other" : ''; + + my(@values); + @values = $self->_set_values_and_labels($values,\$labels,$name); + $tabindex = $self->element_tab($tabindex); + $name = q{} if ! defined $name; + $result = qq/<select name="$name" $tabindex$other>\n/; + for (@values) { + if (/<optgroup/) { + for my $v (split(/\n/)) { + my $selectit = $XHTML ? 'selected="selected"' : 'selected'; + for my $selected (keys %selected) { + $v =~ s/(value="\Q$selected\E")/$selectit $1/; + } + $result .= "$v\n"; + } + } + else { + my $attribs = $self->_set_attributes($_, $attributes); + my($selectit) = $self->_selected($selected{$_}); + my($label) = $_; + $label = $labels->{$_} if defined($labels) && defined($labels->{$_}); + my($value) = $self->_maybe_escapeHTML($_); + $label = $self->_maybe_escapeHTML($label,1); + $result .= "<option${attribs} ${selectit}value=\"$value\">$label</option>\n"; + } + } + + $result .= "</select>"; + return $result; +} + +#### Method: optgroup +# Create a optgroup. +# Parameters: +# $name -> Label for the group +# $values -> A pointer to a regular array containing the +# values for each option line in the group. +# $labels -> (optional) +# A pointer to a hash of labels to print next to each item +# in the form $label{'value'}="Long explanatory label". +# Otherwise the provided values are used as the labels. +# $labeled -> (optional) +# A true value indicates the value should be used as the label attribute +# in the option elements. +# The label attribute specifies the option label presented to the user. +# This defaults to the content of the <option> element, but the label +# attribute allows authors to more easily use optgroup without sacrificing +# compatibility with browsers that do not support option groups. +# $novals -> (optional) +# A true value indicates to suppress the val attribute in the option elements +# Returns: +# A string containing the definition of an option group. +#### +sub optgroup { + my($self,@p) = self_or_default(@_); + my($name,$values,$attributes,$labeled,$noval,$labels,@other) + = rearrange([NAME,[VALUES,VALUE],ATTRIBUTES,LABELED,NOVALS,LABELS],@p); + + my($result,@values); + @values = $self->_set_values_and_labels($values,\$labels,$name,$labeled,$novals); + my($other) = @other ? " @other" : ''; + + $name = $self->_maybe_escapeHTML($name) || q{}; + $result = qq/<optgroup label="$name"$other>\n/; + for (@values) { + if (/<optgroup/) { + for (split(/\n/)) { + my $selectit = $XHTML ? 'selected="selected"' : 'selected'; + s/(value="$selected")/$selectit $1/ if defined $selected; + $result .= "$_\n"; + } + } + else { + my $attribs = $self->_set_attributes($_, $attributes); + my($label) = $_; + $label = $labels->{$_} if defined($labels) && defined($labels->{$_}); + $label=$self->_maybe_escapeHTML($label); + my($value)=$self->_maybe_escapeHTML($_,1); + $result .= $labeled ? $novals ? "<option$attribs label=\"$value\">$label</option>\n" + : "<option$attribs label=\"$value\" value=\"$value\">$label</option>\n" + : $novals ? "<option$attribs>$label</option>\n" + : "<option$attribs value=\"$value\">$label</option>\n"; + } + } + $result .= "</optgroup>"; + return $result; +} + +#### Method: scrolling_list +# Create a scrolling list. +# Parameters: +# $name -> name for the list +# $values -> A pointer to a regular array containing the +# values for each option line in the list. +# $defaults -> (optional) +# 1. If a pointer to a regular array of options, +# then this will be used to decide which +# lines to turn on by default. +# 2. Otherwise holds the value of the single line to turn on. +# $size -> (optional) Size of the list. +# $multiple -> (optional) If set, allow multiple selections. +# $labels -> (optional) +# A pointer to a hash of labels to print next to each checkbox +# in the form $label{'value'}="Long explanatory label". +# Otherwise the provided values are used as the labels. +# Returns: +# A string containing the definition of a scrolling list. +#### +sub scrolling_list { + my($self,@p) = self_or_default(@_); + my($name,$values,$defaults,$size,$multiple,$labels,$attributes,$override,$tabindex,@other) + = rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT], + SIZE,MULTIPLE,LABELS,ATTRIBUTES,[OVERRIDE,FORCE],TABINDEX],@p); + + my($result,@values); + @values = $self->_set_values_and_labels($values,\$labels,$name); + + $size = $size || scalar(@values); + + my(%selected) = $self->previous_or_default($name,$defaults,$override); + + my($is_multiple) = $multiple ? qq/ multiple="multiple"/ : ''; + my($has_size) = $size ? qq/ size="$size"/: ''; + my($other) = @other ? " @other" : ''; + + $name=$self->_maybe_escapeHTML($name); + $tabindex = $self->element_tab($tabindex); + $result = qq/<select name="$name" $tabindex$has_size$is_multiple$other>\n/; + for (@values) { + if (/<optgroup/) { + for my $v (split(/\n/)) { + my $selectit = $XHTML ? 'selected="selected"' : 'selected'; + for my $selected (keys %selected) { + $v =~ s/(value="$selected")/$selectit $1/; + } + $result .= "$v\n"; + } + } + else { + my $attribs = $self->_set_attributes($_, $attributes); + my($selectit) = $self->_selected($selected{$_}); + my($label) = $_; + $label = $labels->{$_} if defined($labels) && defined($labels->{$_}); + my($value) = $self->_maybe_escapeHTML($_); + $label = $self->_maybe_escapeHTML($label,1); + $result .= "<option${attribs} ${selectit}value=\"$value\">$label</option>\n"; + } + } + + $result .= "</select>"; + $self->register_parameter($name); + return $result; +} + +#### Method: hidden +# Parameters: +# $name -> Name of the hidden field +# @default -> (optional) Initial values of field (may be an array) +# or +# $default->[initial values of field] +# Returns: +# A string containing a <input type="hidden" name="name" value="value"> +#### +sub hidden { + my($self,@p) = self_or_default(@_); + + # this is the one place where we departed from our standard + # calling scheme, so we have to special-case (darn) + my(@result,@value); + my($name,$default,$override,@other) = + rearrange([NAME,[DEFAULT,VALUE,VALUES],[OVERRIDE,FORCE]],@p); + + my $do_override = 0; + if ( ref($p[0]) || substr($p[0],0,1) eq '-') { + @value = ref($default) ? @{$default} : $default; + $do_override = $override; + } else { + for ($default,$override,@other) { + push(@value,$_) if defined($_); + } + undef @other; + } + + # use previous values if override is not set + my @prev = $self->param($name); + @value = @prev if !$do_override && @prev; + + $name=$self->_maybe_escapeHTML($name); + for (@value) { + $_ = defined($_) ? $self->_maybe_escapeHTML($_,1) : ''; + push @result,$XHTML ? qq(<input type="hidden" name="$name" value="$_" @other />) + : qq(<input type="hidden" name="$name" value="$_" @other>); + } + return wantarray ? @result : join('',@result); +} + +#### Method: image_button +# Parameters: +# $name -> Name of the button +# $src -> URL of the image source +# $align -> Alignment style (TOP, BOTTOM or MIDDLE) +# Returns: +# A string containing a <input type="image" name="name" src="url" align="alignment"> +#### +sub image_button { + my($self,@p) = self_or_default(@_); + + my($name,$src,$alignment,@other) = + rearrange([NAME,SRC,ALIGN],@p); + + my($align) = $alignment ? " align=\L\"$alignment\"" : ''; + my($other) = @other ? " @other" : ''; + $name=$self->_maybe_escapeHTML($name); + return $XHTML ? qq(<input type="image" name="$name" src="$src"$align$other />) + : qq/<input type="image" name="$name" src="$src"$align$other>/; +} + +#### Method: self_url +# Returns a URL containing the current script and all its +# param/value pairs arranged as a query. You can use this +# to create a link that, when selected, will reinvoke the +# script with all its state information preserved. +#### +sub self_url { + my($self,@p) = self_or_default(@_); + return $self->url('-path_info'=>1,'-query'=>1,'-full'=>1,@p); +} + +# This is provided as a synonym to self_url() for people unfortunate +# enough to have incorporated it into their programs already! +sub state { + &self_url; +} + +#### Method: url +# Like self_url, but doesn't return the query string part of +# the URL. +#### +sub url { + my($self,@p) = self_or_default(@_); + my ($relative,$absolute,$full,$path_info,$query,$base,$rewrite) = + rearrange(['RELATIVE','ABSOLUTE','FULL',['PATH','PATH_INFO'],['QUERY','QUERY_STRING'],'BASE','REWRITE'],@p); + my $url = ''; + $full++ if $base || !($relative || $absolute); + $rewrite++ unless defined $rewrite; + + my $path = $self->path_info; + my $script_name = $self->script_name; + my $request_uri = $self->request_uri || ''; + my $query_str = $query ? $self->query_string : ''; + + $request_uri =~ s/\?.*$//s; # remove query string + $request_uri = unescape($request_uri); + + my $uri = $rewrite && $request_uri ? $request_uri : $script_name; + $uri =~ s/\?.*$//s; # remove query string + + if ( defined( $ENV{PATH_INFO} ) ) { + # IIS sometimes sets PATH_INFO to the same value as SCRIPT_NAME so only sub it out + # if SCRIPT_NAME isn't defined or isn't the same value as PATH_INFO + $uri =~ s/\Q$ENV{PATH_INFO}\E$// + if ( ! defined( $ENV{SCRIPT_NAME} ) or $ENV{PATH_INFO} ne $ENV{SCRIPT_NAME} ); + + # if we're not IIS then keep to spec, the relevant info is here: + # https://tools.ietf.org/html/rfc3875#section-4.1.13, namely + # "No PATH_INFO segment (see section 4.1.5) is included in the + # SCRIPT_NAME value." (see GH #126, GH #152, GH #176) + if ( ! $IIS ) { + $uri =~ s/\Q$ENV{PATH_INFO}\E$//; + } + } + + if ($full) { + my $protocol = $self->protocol(); + $url = "$protocol://"; + my $vh = http('x_forwarded_host') || http('host') || ''; + $vh =~ s/^.*,\s*//; # x_forwarded_host may be a comma-separated list (e.g. when the request has + # passed through multiple reverse proxies. Take the last one. + $vh =~ s/\:\d+$//; # some clients add the port number (incorrectly). Get rid of it. + + $url .= $vh || server_name(); + + my $port = $self->virtual_port; + + # add the port to the url unless it's the protocol's default port + $url .= ':' . $port unless (lc($protocol) eq 'http' && $port == 80) + or (lc($protocol) eq 'https' && $port == 443); + + return $url if $base; + + $url .= $uri; + } elsif ($relative) { + ($url) = $uri =~ m!([^/]+)$!; + } elsif ($absolute) { + $url = $uri; + } + + $url .= $path if $path_info and defined $path; + $url .= "?$query_str" if $query and $query_str ne ''; + $url ||= ''; + $url =~ s/([^a-zA-Z0-9_.%;&?\/\\:+=~-])/sprintf("%%%02X",ord($1))/eg; + return $url; +} + +#### Method: cookie +# Set or read a cookie from the specified name. +# Cookie can then be passed to header(). +# Usual rules apply to the stickiness of -value. +# Parameters: +# -name -> name for this cookie (optional) +# -value -> value of this cookie (scalar, array or hash) +# -path -> paths for which this cookie is valid (optional) +# -domain -> internet domain in which this cookie is valid (optional) +# -secure -> if true, cookie only passed through secure channel (optional) +# -expires -> expiry date in format Wdy, DD-Mon-YYYY HH:MM:SS GMT (optional) +#### +sub cookie { + my($self,@p) = self_or_default(@_); + my($name,$value,$path,$domain,$secure,$expires,$httponly) = + rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES,HTTPONLY],@p); + + require CGI::Cookie; + + # if no value is supplied, then we retrieve the + # value of the cookie, if any. For efficiency, we cache the parsed + # cookies in our state variables. + unless ( defined($value) ) { + $self->{'.cookies'} = CGI::Cookie->fetch; + + # If no name is supplied, then retrieve the names of all our cookies. + return () unless $self->{'.cookies'}; + return keys %{$self->{'.cookies'}} unless $name; + return () unless $self->{'.cookies'}->{$name}; + return $self->{'.cookies'}->{$name}->value if defined($name) && $name ne ''; + } + + # If we get here, we're creating a new cookie + return undef unless defined($name) && $name ne ''; # this is an error + + my @param; + push(@param,'-name'=>$name); + push(@param,'-value'=>$value); + push(@param,'-domain'=>$domain) if $domain; + push(@param,'-path'=>$path) if $path; + push(@param,'-expires'=>$expires) if $expires; + push(@param,'-secure'=>$secure) if $secure; + push(@param,'-httponly'=>$httponly) if $httponly; + + return CGI::Cookie->new(@param); +} + +sub parse_keywordlist { + my($self,$tosplit) = @_; + $tosplit = unescape($tosplit); # unescape the keywords + $tosplit=~tr/+/ /; # pluses to spaces + my(@keywords) = split(/\s+/,$tosplit); + return @keywords; +} + +sub param_fetch { + my($self,@p) = self_or_default(@_); + my($name) = rearrange([NAME],@p); + return [] unless defined $name; + + unless (exists($self->{param}{$name})) { + $self->add_parameter($name); + $self->{param}{$name} = []; + } + + return $self->{param}{$name}; +} + +############################################### +# OTHER INFORMATION PROVIDED BY THE ENVIRONMENT +############################################### + +#### Method: path_info +# Return the extra virtual path information provided +# after the URL (if any) +#### +sub path_info { + my ($self,$info) = self_or_default(@_); + if (defined($info)) { + $info = "/$info" if $info ne '' && substr($info,0,1) ne '/'; + $self->{'.path_info'} = $info; + } elsif (! defined($self->{'.path_info'}) ) { + my (undef,$path_info) = $self->_name_and_path_from_env; + $self->{'.path_info'} = $path_info || ''; + } + return $self->{'.path_info'}; +} + +# This function returns a potentially modified version of SCRIPT_NAME +# and PATH_INFO. Some HTTP servers do sanitise the paths in those +# variables. It is the case of at least Apache 2. If for instance the +# user requests: /path/./to/script.cgi/x//y/z/../x?y, Apache will set: +# REQUEST_URI=/path/./to/script.cgi/x//y/z/../x?y +# SCRIPT_NAME=/path/to/env.cgi +# PATH_INFO=/x/y/x +# +# This is all fine except that some bogus CGI scripts expect +# PATH_INFO=/http://foo when the user requests +# http://xxx/script.cgi/http://foo +# +# Old versions of this module used to accomodate with those scripts, so +# this is why we do this here to keep those scripts backward compatible. +# Basically, we accomodate with those scripts but within limits, that is +# we only try to preserve the number of / that were provided by the user +# if $REQUEST_URI and "$SCRIPT_NAME$PATH_INFO" only differ by the number +# of consecutive /. +# +# So for instance, in: http://foo/x//y/script.cgi/a//b, we'll return a +# script_name of /x//y/script.cgi and a path_info of /a//b, but in: +# http://foo/./x//z/script.cgi/a/../b//c, we'll return the versions +# possibly sanitised by the HTTP server, so in the case of Apache 2: +# script_name == /foo/x/z/script.cgi and path_info == /b/c. +# +# Future versions of this module may no longer do that, so one should +# avoid relying on the browser, proxy, server, and CGI.pm preserving the +# number of consecutive slashes as no guarantee can be made there. +sub _name_and_path_from_env { + my $self = shift; + my $script_name = $ENV{SCRIPT_NAME} || ''; + my $path_info = $ENV{PATH_INFO} || ''; + my $uri = $self->request_uri || ''; + + $uri =~ s/\?.*//s; + $uri = unescape($uri); + + if ( $IIS ) { + # IIS doesn't set $ENV{PATH_INFO} correctly. It sets it to + # $ENV{SCRIPT_NAME}path_info + # IIS also doesn't set $ENV{REQUEST_URI} so we don't want to do + # the test below, hence this comes first + $path_info =~ s/^\Q$script_name\E(.*)/$1/; + } elsif ($uri ne "$script_name$path_info") { + my $script_name_pattern = quotemeta($script_name); + my $path_info_pattern = quotemeta($path_info); + $script_name_pattern =~ s{(?:\\/)+}{/+}g; + $path_info_pattern =~ s{(?:\\/)+}{/+}g; + + if ($uri =~ /^($script_name_pattern)($path_info_pattern)$/s) { + # REQUEST_URI and SCRIPT_NAME . PATH_INFO only differ by the + # numer of consecutive slashes, so we can extract the info from + # REQUEST_URI: + ($script_name, $path_info) = ($1, $2); + } + } + return ($script_name,$path_info); +} + +#### Method: request_method +# Returns 'POST', 'GET', 'PUT' or 'HEAD' +#### +sub request_method { + return (defined $ENV{'REQUEST_METHOD'}) ? $ENV{'REQUEST_METHOD'} : undef; +} + +#### Method: content_type +# Returns the content_type string +#### +sub content_type { + return (defined $ENV{'CONTENT_TYPE'}) ? $ENV{'CONTENT_TYPE'} : undef; +} + +#### Method: path_translated +# Return the physical path information provided +# by the URL (if any) +#### +sub path_translated { + return (defined $ENV{'PATH_TRANSLATED'}) ? $ENV{'PATH_TRANSLATED'} : undef; +} + +#### Method: request_uri +# Return the literal request URI +#### +sub request_uri { + return (defined $ENV{'REQUEST_URI'}) ? $ENV{'REQUEST_URI'} : undef; +} + +#### Method: query_string +# Synthesize a query string from our current +# parameters +#### +sub query_string { + my($self) = self_or_default(@_); + my($param,$value,@pairs); + for $param ($self->param) { + my($eparam) = escape($param); + for $value ($self->param($param)) { + $value = escape($value); + next unless defined $value; + push(@pairs,"$eparam=$value"); + } + } + for (keys %{$self->{'.fieldnames'}}) { + push(@pairs,".cgifields=".escape("$_")); + } + return join($USE_PARAM_SEMICOLONS ? ';' : '&',@pairs); +} + +sub env_query_string { + return (defined $ENV{'QUERY_STRING'}) ? $ENV{'QUERY_STRING'} : undef; +} + +#### Method: accept +# Without parameters, returns an array of the +# MIME types the browser accepts. +# With a single parameter equal to a MIME +# type, will return undef if the browser won't +# accept it, 1 if the browser accepts it but +# doesn't give a preference, or a floating point +# value between 0.0 and 1.0 if the browser +# declares a quantitative score for it. +# This handles MIME type globs correctly. +#### +sub Accept { + my($self,$search) = self_or_CGI(@_); + my(%prefs,$type,$pref,$pat); + + my(@accept) = defined $self->http('accept') + ? split(',',$self->http('accept')) + : (); + + for (@accept) { + ($pref) = /q=(\d\.\d+|\d+)/; + ($type) = m#(\S+/[^;]+)#; + next unless $type; + $prefs{$type}=$pref || 1; + } + + return keys %prefs unless $search; + + # if a search type is provided, we may need to + # perform a pattern matching operation. + # The MIME types use a glob mechanism, which + # is easily translated into a perl pattern match + + # First return the preference for directly supported + # types: + return $prefs{$search} if $prefs{$search}; + + # Didn't get it, so try pattern matching. + for (keys %prefs) { + next unless /\*/; # not a pattern match + ($pat = $_) =~ s/([^\w*])/\\$1/g; # escape meta characters + $pat =~ s/\*/.*/g; # turn it into a pattern + return $prefs{$_} if $search=~/$pat/; + } +} + +#### Method: user_agent +# If called with no parameters, returns the user agent. +# If called with one parameter, does a pattern match (case +# insensitive) on the user agent. +#### +sub user_agent { + my($self,$match)=self_or_CGI(@_); + my $user_agent = $self->http('user_agent'); + return $user_agent unless defined $match && $match && $user_agent; + return $user_agent =~ /$match/i; +} + +#### Method: raw_cookie +# Returns the magic cookies for the session. +# The cookies are not parsed or altered in any way, i.e. +# cookies are returned exactly as given in the HTTP +# headers. If a cookie name is given, only that cookie's +# value is returned, otherwise the entire raw cookie +# is returned. +#### +sub raw_cookie { + my($self,$key) = self_or_CGI(@_); + + require CGI::Cookie; + + if (defined($key)) { + $self->{'.raw_cookies'} = CGI::Cookie->raw_fetch + unless $self->{'.raw_cookies'}; + + return () unless $self->{'.raw_cookies'}; + return () unless $self->{'.raw_cookies'}->{$key}; + return $self->{'.raw_cookies'}->{$key}; + } + return $self->http('cookie') || $ENV{'COOKIE'} || ''; +} + +#### Method: virtual_host +# Return the name of the virtual_host, which +# is not always the same as the server +###### +sub virtual_host { + my $vh = http('x_forwarded_host') || http('host') || server_name(); + $vh =~ s/:\d+$//; # get rid of port number + return $vh; +} + +#### Method: remote_host +# Return the name of the remote host, or its IP +# address if unavailable. If this variable isn't +# defined, it returns "localhost" for debugging +# purposes. +#### +sub remote_host { + return $ENV{'REMOTE_HOST'} || $ENV{'REMOTE_ADDR'} + || 'localhost'; +} + +#### Method: remote_addr +# Return the IP addr of the remote host. +#### +sub remote_addr { + return $ENV{'REMOTE_ADDR'} || '127.0.0.1'; +} + +#### Method: script_name +# Return the partial URL to this script for +# self-referencing scripts. Also see +# self_url(), which returns a URL with all state information +# preserved. +#### +sub script_name { + my ($self,@p) = self_or_default(@_); + if (@p) { + $self->{'.script_name'} = shift @p; + } elsif (!exists $self->{'.script_name'}) { + my ($script_name,$path_info) = $self->_name_and_path_from_env(); + $self->{'.script_name'} = $script_name; + } + return $self->{'.script_name'}; +} + +#### Method: referer +# Return the HTTP_REFERER: useful for generating +# a GO BACK button. +#### +sub referer { + my($self) = self_or_CGI(@_); + return $self->http('referer'); +} + +#### Method: server_name +# Return the name of the server +#### +sub server_name { + return $ENV{'SERVER_NAME'} || 'localhost'; +} + +#### Method: server_software +# Return the name of the server software +#### +sub server_software { + return $ENV{'SERVER_SOFTWARE'} || 'cmdline'; +} + +#### Method: virtual_port +# Return the server port, taking virtual hosts into account +#### +sub virtual_port { + my($self) = self_or_default(@_); + my $vh = $self->http('x_forwarded_host') || $self->http('host'); + my $protocol = $self->protocol; + if ($vh) { + return ($vh =~ /:(\d+)$/)[0] || ($protocol eq 'https' ? 443 : 80); + } else { + return $self->server_port(); + } +} + +#### Method: server_port +# Return the tcp/ip port the server is running on +#### +sub server_port { + return $ENV{'SERVER_PORT'} || 80; # for debugging +} + +#### Method: server_protocol +# Return the protocol (usually HTTP/1.0) +#### +sub server_protocol { + return $ENV{'SERVER_PROTOCOL'} || 'HTTP/1.0'; # for debugging +} + +#### Method: http +# Return the value of an HTTP variable, or +# the list of variables if none provided +#### +sub http { + my ($self,$parameter) = self_or_CGI(@_); + if ( defined($parameter) ) { + $parameter =~ tr/-a-z/_A-Z/; + if ( $parameter =~ /^HTTP(?:_|$)/ ) { + return $ENV{$parameter}; + } + return $ENV{"HTTP_$parameter"}; + } + return grep { /^HTTP(?:_|$)/ } keys %ENV; +} + +#### Method: https +# Return the value of HTTPS, or +# the value of an HTTPS variable, or +# the list of variables +#### +sub https { + my ($self,$parameter) = self_or_CGI(@_); + if ( defined($parameter) ) { + $parameter =~ tr/-a-z/_A-Z/; + if ( $parameter =~ /^HTTPS(?:_|$)/ ) { + return $ENV{$parameter}; + } + return $ENV{"HTTPS_$parameter"}; + } + return wantarray + ? grep { /^HTTPS(?:_|$)/ } keys %ENV + : $ENV{'HTTPS'}; +} + +#### Method: protocol +# Return the protocol (http or https currently) +#### +sub protocol { + local($^W)=0; + my $self = shift; + return 'https' if uc($self->https()) eq 'ON'; + return 'https' if $self->server_port == 443; + my $prot = $self->server_protocol; + my($protocol,$version) = split('/',$prot); + return "\L$protocol\E"; +} + +#### Method: remote_ident +# Return the identity of the remote user +# (but only if his host is running identd) +#### +sub remote_ident { + return (defined $ENV{'REMOTE_IDENT'}) ? $ENV{'REMOTE_IDENT'} : undef; +} + +#### Method: auth_type +# Return the type of use verification/authorization in use, if any. +#### +sub auth_type { + return (defined $ENV{'AUTH_TYPE'}) ? $ENV{'AUTH_TYPE'} : undef; +} + +#### Method: remote_user +# Return the authorization name used for user +# verification. +#### +sub remote_user { + return (defined $ENV{'REMOTE_USER'}) ? $ENV{'REMOTE_USER'} : undef; +} + +#### Method: user_name +# Try to return the remote user's name by hook or by +# crook +#### +sub user_name { + my ($self) = self_or_CGI(@_); + return $self->http('from') || $ENV{'REMOTE_IDENT'} || $ENV{'REMOTE_USER'}; +} + +#### Method: nosticky +# Set or return the NOSTICKY global flag +#### +sub nosticky { + my ($self,$param) = self_or_CGI(@_); + $CGI::NOSTICKY = $param if defined($param); + return $CGI::NOSTICKY; +} + +#### Method: nph +# Set or return the NPH global flag +#### +sub nph { + my ($self,$param) = self_or_CGI(@_); + $CGI::NPH = $param if defined($param); + return $CGI::NPH; +} + +#### Method: private_tempfiles +# Set or return the private_tempfiles global flag +#### +sub private_tempfiles { + warn "private_tempfiles has been deprecated"; + return 0; +} +#### Method: close_upload_files +# Set or return the close_upload_files global flag +#### +sub close_upload_files { + my ($self,$param) = self_or_CGI(@_); + $CGI::CLOSE_UPLOAD_FILES = $param if defined($param); + return $CGI::CLOSE_UPLOAD_FILES; +} + +#### Method: default_dtd +# Set or return the default_dtd global +#### +sub default_dtd { + my ($self,$param,$param2) = self_or_CGI(@_); + if (defined $param2 && defined $param) { + $CGI::DEFAULT_DTD = [ $param, $param2 ]; + } elsif (defined $param) { + $CGI::DEFAULT_DTD = $param; + } + return $CGI::DEFAULT_DTD; +} + +# -------------- really private subroutines ----------------- +sub _maybe_escapeHTML { + # hack to work around earlier hacks + push @_,$_[0] if @_==1 && $_[0] eq 'CGI'; + my ($self,$toencode,$newlinestoo) = CGI::self_or_default(@_); + return undef unless defined($toencode); + return $toencode if ref($self) && !$self->{'escape'}; + return $self->escapeHTML($toencode, $newlinestoo); +} + +sub previous_or_default { + my($self,$name,$defaults,$override) = @_; + my(%selected); + + if (!$override && ($self->{'.fieldnames'}->{$name} || + defined($self->param($name)) ) ) { + $selected{$_}++ for $self->param($name); + } elsif (defined($defaults) && ref($defaults) && + (ref($defaults) eq 'ARRAY')) { + $selected{$_}++ for @{$defaults}; + } else { + $selected{$defaults}++ if defined($defaults); + } + + return %selected; +} + +sub register_parameter { + my($self,$param) = @_; + $self->{'.parametersToAdd'}->{$param}++; +} + +sub get_fields { + my($self) = @_; + return $self->CGI::hidden('-name'=>'.cgifields', + '-values'=>[keys %{$self->{'.parametersToAdd'}}], + '-override'=>1); +} + +sub read_from_cmdline { + my($input,@words); + my($query_string); + my($subpath); + if ($DEBUG && @ARGV) { + @words = @ARGV; + } elsif ($DEBUG > 1) { + require Text::ParseWords; + print STDERR "(offline mode: enter name=value pairs on standard input; press ^D or ^Z when done)\n"; + chomp(@lines = <STDIN>); # remove newlines + $input = join(" ",@lines); + @words = &Text::ParseWords::old_shellwords($input); + } + for (@words) { + s/\\=/%3D/g; + s/\\&/%26/g; + } + + if ("@words"=~/=/) { + $query_string = join('&',@words); + } else { + $query_string = join('+',@words); + } + if ($query_string =~ /^(.*?)\?(.*)$/) + { + $query_string = $2; + $subpath = $1; + } + return { 'query_string' => $query_string, 'subpath' => $subpath }; +} + +##### +# subroutine: read_multipart +# +# Read multipart data and store it into our parameters. +# An interesting feature is that if any of the parts is a file, we +# create a temporary file and open up a filehandle on it so that the +# caller can read from it if necessary. +##### +sub read_multipart { + my($self,$boundary,$length) = @_; + my($buffer) = $self->new_MultipartBuffer($boundary,$length); + return unless $buffer; + my(%header,$body); + my $filenumber = 0; + while (!$buffer->eof) { + %header = $buffer->readHeader; + + unless (%header) { + $self->cgi_error("400 Bad request (malformed multipart POST)"); + return; + } + + $header{'Content-Disposition'} ||= ''; # quench uninit variable warning + + my($param)= $header{'Content-Disposition'}=~/[\s;]name="([^"]*)"/; + $param .= $TAINTED; + + # See RFC 1867, 2183, 2045 + # NB: File content will be loaded into memory should + # content-disposition parsing fail. + my ($filename) = $header{'Content-Disposition'} + =~/ filename=(("[^"]*")|([a-z\d!\#'\*\+,\.^_\`\{\}\|\~]*))/i; + + $filename ||= ''; # quench uninit variable warning + + $filename =~ s/^"([^"]*)"$/$1/; + # Test for Opera's multiple upload feature + my($multipart) = ( defined( $header{'Content-Type'} ) && + $header{'Content-Type'} =~ /multipart\/mixed/ ) ? + 1 : 0; + + # add this parameter to our list + $self->add_parameter($param); + + # If no filename specified, then just read the data and assign it + # to our parameter list. + if ( ( !defined($filename) || $filename eq '' ) && !$multipart ) { + my($value) = $buffer->readBody; + $value .= $TAINTED; + push(@{$self->{param}{$param}},$value); + next; + } + + UPLOADS: { + # If we get here, then we are dealing with a potentially large + # uploaded form. Save the data to a temporary file, then open + # the file for reading. + + # skip the file if uploads disabled + if ($DISABLE_UPLOADS) { + while (defined($data = $buffer->read)) { } + last UPLOADS; + } + + # set the filename to some recognizable value + if ( ( !defined($filename) || $filename eq '' ) && $multipart ) { + $filename = "multipart/mixed"; + } + + my $tmp_dir = $CGI::OS eq 'WINDOWS' + ? ( $ENV{TEMP} || $ENV{TMP} || ( $ENV{WINDIR} ? ( $ENV{WINDIR} . $SL . 'TEMP' ) : undef ) ) + : undef; # File::Temp defaults to TMPDIR + + require CGI::File::Temp; + my $filehandle = CGI::File::Temp->new( + UNLINK => $UNLINK_TMP_FILES, + DIR => $tmp_dir, + ); + $filehandle->_mp_filename( $filename ); + + $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode + && defined fileno($filehandle); + + # if this is an multipart/mixed attachment, save the header + # together with the body for later parsing with an external + # MIME parser module + if ( $multipart ) { + for ( keys %header ) { + print $filehandle "$_: $header{$_}${CRLF}"; + } + print $filehandle "${CRLF}"; + } + + my ($data); + local($\) = ''; + my $totalbytes = 0; + while (defined($data = $buffer->read)) { + if (defined $self->{'.upload_hook'}) + { + $totalbytes += length($data); + &{$self->{'.upload_hook'}}($filename ,$data, $totalbytes, $self->{'.upload_data'}); + } + print $filehandle $data if ($self->{'use_tempfile'}); + } + + # back up to beginning of file + seek($filehandle,0,0); + + ## Close the filehandle if requested this allows a multipart MIME + ## upload to contain many files, and we won't die due to too many + ## open file handles. The user can access the files using the hash + ## below. + close $filehandle if $CLOSE_UPLOAD_FILES; + $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode; + + # Save some information about the uploaded file where we can get + # at it later. + # Use the typeglob + filename as the key, as this is guaranteed to be + # unique for each filehandle. Don't use the file descriptor as + # this will be re-used for each filehandle if the + # close_upload_files feature is used. + $self->{'.tmpfiles'}->{$$filehandle . $filehandle} = { + hndl => $filehandle, + name => $filehandle->filename, + info => {%header}, + }; + push(@{$self->{param}{$param}},$filehandle); + } + } +} + +##### +# subroutine: read_multipart_related +# +# Read multipart/related data and store it into our parameters. The +# first parameter sets the start of the data. The part identified by +# this Content-ID will not be stored as a file upload, but will be +# returned by this method. All other parts will be available as file +# uploads accessible by their Content-ID +##### +sub read_multipart_related { + my($self,$start,$boundary,$length) = @_; + my($buffer) = $self->new_MultipartBuffer($boundary,$length); + return unless $buffer; + my(%header,$body); + my $filenumber = 0; + my $returnvalue; + while (!$buffer->eof) { + %header = $buffer->readHeader; + + unless (%header) { + $self->cgi_error("400 Bad request (malformed multipart POST)"); + return; + } + + my($param) = $header{'Content-ID'}=~/\<([^\>]*)\>/; + $param .= $TAINTED; + + # If this is the start part, then just read the data and assign it + # to our return variable. + if ( $param eq $start ) { + $returnvalue = $buffer->readBody; + $returnvalue .= $TAINTED; + next; + } + + # add this parameter to our list + $self->add_parameter($param); + + UPLOADS: { + # If we get here, then we are dealing with a potentially large + # uploaded form. Save the data to a temporary file, then open + # the file for reading. + + # skip the file if uploads disabled + if ($DISABLE_UPLOADS) { + while (defined($data = $buffer->read)) { } + last UPLOADS; + } + + my $tmp_dir = $CGI::OS eq 'WINDOWS' + ? ( $ENV{TEMP} || $ENV{TMP} || ( $ENV{WINDIR} ? ( $ENV{WINDIR} . $SL . 'TEMP' ) : undef ) ) + : undef; # File::Temp defaults to TMPDIR + + require CGI::File::Temp; + my $filehandle = CGI::File::Temp->new( + UNLINK => $UNLINK_TMP_FILES, + DIR => $tmp_dir, + ); + $filehandle->_mp_filename( $filehandle->filename ); + + $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode + && defined fileno($filehandle); + + my ($data); + local($\) = ''; + my $totalbytes; + while (defined($data = $buffer->read)) { + if (defined $self->{'.upload_hook'}) + { + $totalbytes += length($data); + &{$self->{'.upload_hook'}}($param ,$data, $totalbytes, $self->{'.upload_data'}); + } + print $filehandle $data if ($self->{'use_tempfile'}); + } + + # back up to beginning of file + seek($filehandle,0,0); + + ## Close the filehandle if requested this allows a multipart MIME + ## upload to contain many files, and we won't die due to too many + ## open file handles. The user can access the files using the hash + ## below. + close $filehandle if $CLOSE_UPLOAD_FILES; + $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode; + + # Save some information about the uploaded file where we can get + # at it later. + # Use the typeglob + filename as the key, as this is guaranteed to be + # unique for each filehandle. Don't use the file descriptor as + # this will be re-used for each filehandle if the + # close_upload_files feature is used. + $self->{'.tmpfiles'}->{$$filehandle . $filehandle} = { + hndl => $filehandle, + name => $filehandle->filename, + info => {%header}, + }; + push(@{$self->{param}{$param}},$filehandle); + } + } + return $returnvalue; +} + +sub upload { + my($self,$param_name) = self_or_default(@_); + my @param = grep {ref($_) && defined(fileno($_))} $self->param($param_name); + return unless @param; + return wantarray ? @param : $param[0]; +} + +sub tmpFileName { + my($self,$filename) = self_or_default(@_); + + # preferred calling convention: $filename came directly from param or upload + if (ref $filename) { + return $self->{'.tmpfiles'}->{$$filename . $filename}->{name} || ''; + } + + # backwards compatible with older versions: $filename is merely equal to + # one of our filenames when compared as strings + foreach my $param_name ($self->param) { + foreach my $filehandle ($self->multi_param($param_name)) { + if ($filehandle eq $filename) { + return $self->{'.tmpfiles'}->{$$filehandle . $filehandle}->{name} || ''; + } + } + } + + return ''; +} + +sub uploadInfo { + my($self,$filename) = self_or_default(@_); + return if ! defined $$filename; + return $self->{'.tmpfiles'}->{$$filename . $filename}->{info}; +} + +# internal routine, don't use +sub _set_values_and_labels { + my $self = shift; + my ($v,$l,$n) = @_; + $$l = $v if ref($v) eq 'HASH' && !ref($$l); + return $self->param($n) if !defined($v); + return $v if !ref($v); + return ref($v) eq 'HASH' ? keys %$v : @$v; +} + +# internal routine, don't use +sub _set_attributes { + my $self = shift; + my($element, $attributes) = @_; + return '' unless defined($attributes->{$element}); + $attribs = ' '; + for my $attrib (keys %{$attributes->{$element}}) { + (my $clean_attrib = $attrib) =~ s/^-//; + $attribs .= "@{[lc($clean_attrib)]}=\"$attributes->{$element}{$attrib}\" "; + } + $attribs =~ s/ $//; + return $attribs; +} + +######################################################### +# Globals and stubs for other packages that we use. +######################################################### + +######################## MultipartBuffer #################### + +package MultipartBuffer; + +$_DEBUG = 0; + +# how many bytes to read at a time. We use +# a 4K buffer by default. +$INITIAL_FILLUNIT = 1024 * 4; +$TIMEOUT = 240*60; # 4 hour timeout for big files +$SPIN_LOOP_MAX = 2000; # bug fix for some Netscape servers +$CRLF=$CGI::CRLF; + +sub new { + my($package,$interface,$boundary,$length) = @_; + $FILLUNIT = $INITIAL_FILLUNIT; + $CGI::DefaultClass->binmode($IN); # if $CGI::needs_binmode; # just do it always + + # If the user types garbage into the file upload field, + # then Netscape passes NOTHING to the server (not good). + # We may hang on this read in that case. So we implement + # a read timeout. If nothing is ready to read + # by then, we return. + + # Netscape seems to be a little bit unreliable + # about providing boundary strings. + my $boundary_read = 0; + if ($boundary) { + + # Under the MIME spec, the boundary consists of the + # characters "--" PLUS the Boundary string + + # BUG: IE 3.01 on the Macintosh uses just the boundary -- not + # the two extra hyphens. We do a special case here on the user-agent!!!! + $boundary = "--$boundary" unless CGI::user_agent('MSIE\s+3\.0[12];\s*Mac|DreamPassport'); + + } else { # otherwise we find it ourselves + my($old); + ($old,$/) = ($/,$CRLF); # read a CRLF-delimited line + $boundary = <STDIN>; # BUG: This won't work correctly under mod_perl + $length -= length($boundary); + chomp($boundary); # remove the CRLF + $/ = $old; # restore old line separator + $boundary_read++; + } + + my $self = {LENGTH=>$length, + CHUNKED=>!$length, + BOUNDARY=>$boundary, + INTERFACE=>$interface, + BUFFER=>'', + }; + + $FILLUNIT = length($boundary) + if length($boundary) > $FILLUNIT; + + my $retval = bless $self,ref $package || $package; + + # Read the preamble and the topmost (boundary) line plus the CRLF. + unless ($boundary_read) { + while ($self->read(0)) { } + } + die "Malformed multipart POST: data truncated\n" if $self->eof; + + return $retval; +} + +sub readHeader { + my($self) = @_; + my($end); + my($ok) = 0; + my($bad) = 0; + + local($CRLF) = "\015\012" if $CGI::OS eq 'VMS' || $CGI::EBCDIC; + + do { + $self->fillBuffer($FILLUNIT); + $ok++ if ($end = index($self->{BUFFER},"${CRLF}${CRLF}")) >= 0; + $ok++ if $self->{BUFFER} eq ''; + $bad++ if !$ok && $self->{LENGTH} <= 0; + # this was a bad idea + # $FILLUNIT *= 2 if length($self->{BUFFER}) >= $FILLUNIT; + } until $ok || $bad; + return () if $bad; + + #EBCDIC NOTE: translate header into EBCDIC, but watch out for continuation lines! + + my($header) = substr($self->{BUFFER},0,$end+2); + substr($self->{BUFFER},0,$end+4) = ''; + my %return; + + if ($CGI::EBCDIC) { + warn "untranslated header=$header\n" if $_DEBUG; + $header = CGI::Util::ascii2ebcdic($header); + warn "translated header=$header\n" if $_DEBUG; + } + + # See RFC 2045 Appendix A and RFC 822 sections 3.4.8 + # (Folding Long Header Fields), 3.4.3 (Comments) + # and 3.4.5 (Quoted-Strings). + + my $token = '[-\w!\#$%&\'*+.^_\`|{}~]'; + $header=~s/$CRLF\s+/ /og; # merge continuation lines + + while ($header=~/($token+):\s+([^$CRLF]*)/mgox) { + my ($field_name,$field_value) = ($1,$2); + $field_name =~ s/\b(\w)/uc($1)/eg; #canonicalize + $return{$field_name}=$field_value; + } + return %return; +} + +# This reads and returns the body as a single scalar value. +sub readBody { + my($self) = @_; + my($data); + my($returnval)=''; + + #EBCDIC NOTE: want to translate returnval into EBCDIC HERE + + while (defined($data = $self->read)) { + $returnval .= $data; + } + + if ($CGI::EBCDIC) { + warn "untranslated body=$returnval\n" if $_DEBUG; + $returnval = CGI::Util::ascii2ebcdic($returnval); + warn "translated body=$returnval\n" if $_DEBUG; + } + return $returnval; +} + +# This will read $bytes or until the boundary is hit, whichever happens +# first. After the boundary is hit, we return undef. The next read will +# skip over the boundary and begin reading again; +sub read { + my($self,$bytes) = @_; + + # default number of bytes to read + $bytes = $bytes || $FILLUNIT; + + # Fill up our internal buffer in such a way that the boundary + # is never split between reads. + $self->fillBuffer($bytes); + + my $boundary_start = $CGI::EBCDIC ? CGI::Util::ebcdic2ascii($self->{BOUNDARY}) : $self->{BOUNDARY}; + my $boundary_end = $CGI::EBCDIC ? CGI::Util::ebcdic2ascii($self->{BOUNDARY}.'--') : $self->{BOUNDARY}.'--'; + + # Find the boundary in the buffer (it may not be there). + my $start = index($self->{BUFFER},$boundary_start); + + warn "boundary=$self->{BOUNDARY} length=$self->{LENGTH} start=$start\n" if $_DEBUG; + + # protect against malformed multipart POST operations + die "Malformed multipart POST\n" unless $self->{CHUNKED} || ($start >= 0 || $self->{LENGTH} > 0); + + #EBCDIC NOTE: want to translate boundary search into ASCII here. + + # If the boundary begins the data, then skip past it + # and return undef. + if ($start == 0) { + + # clear us out completely if we've hit the last boundary. + if (index($self->{BUFFER},$boundary_end)==0) { + $self->{BUFFER}=''; + $self->{LENGTH}=0; + return undef; + } + + # just remove the boundary. + substr($self->{BUFFER},0,length($boundary_start))=''; + $self->{BUFFER} =~ s/^\012\015?//; + return undef; + } + + my $bytesToReturn; + if ($start > 0) { # read up to the boundary + $bytesToReturn = $start-2 > $bytes ? $bytes : $start; + } else { # read the requested number of bytes + # leave enough bytes in the buffer to allow us to read + # the boundary. Thanks to Kevin Hendrick for finding + # this one. + $bytesToReturn = $bytes - (length($boundary_start)+1); + } + + my $returnval=substr($self->{BUFFER},0,$bytesToReturn); + substr($self->{BUFFER},0,$bytesToReturn)=''; + + # If we hit the boundary, remove the CRLF from the end. + return ($bytesToReturn==$start) + ? substr($returnval,0,-2) : $returnval; +} + +# This fills up our internal buffer in such a way that the +# boundary is never split between reads +sub fillBuffer { + my($self,$bytes) = @_; + return unless $self->{CHUNKED} || $self->{LENGTH}; + + my($boundaryLength) = length($self->{BOUNDARY}); + my($bufferLength) = length($self->{BUFFER}); + my($bytesToRead) = $bytes - $bufferLength + $boundaryLength + 2; + $bytesToRead = $self->{LENGTH} if !$self->{CHUNKED} && $self->{LENGTH} < $bytesToRead; + + # Try to read some data. We may hang here if the browser is screwed up. + my $bytesRead = $self->{INTERFACE}->read_from_client(\$self->{BUFFER}, + $bytesToRead, + $bufferLength); + warn "bytesToRead=$bytesToRead, bufferLength=$bufferLength, buffer=$self->{BUFFER}\n" if $_DEBUG; + $self->{BUFFER} = '' unless defined $self->{BUFFER}; + + # An apparent bug in the Apache server causes the read() + # to return zero bytes repeatedly without blocking if the + # remote user aborts during a file transfer. I don't know how + # they manage this, but the workaround is to abort if we get + # more than SPIN_LOOP_MAX consecutive zero reads. + if ($bytesRead <= 0) { + die "CGI.pm: Server closed socket during multipart read (client aborted?).\n" + if ($self->{ZERO_LOOP_COUNTER}++ >= $SPIN_LOOP_MAX); + } else { + $self->{ZERO_LOOP_COUNTER}=0; + } + + $self->{LENGTH} -= $bytesRead if !$self->{CHUNKED} && $bytesRead; +} + +# Return true when we've finished reading +sub eof { + my($self) = @_; + return 1 if (length($self->{BUFFER}) == 0) + && ($self->{LENGTH} <= 0); + undef; +} + +1; + +package CGI; + +# We get a whole bunch of warnings about "possibly uninitialized variables" +# when running with the -w switch. Touch them all once to get rid of the +# warnings. This is ugly and I hate it. +if ($^W) { + $CGI::CGI = ''; + $CGI::CGI=<<EOF; + $CGI::VERSION; + $MultipartBuffer::SPIN_LOOP_MAX; + $MultipartBuffer::CRLF; + $MultipartBuffer::TIMEOUT; + $MultipartBuffer::INITIAL_FILLUNIT; +EOF + ; +} + +1; diff --git a/lib/CGI.pod b/lib/CGI.pod new file mode 100644 index 0000000..1528ac6 --- /dev/null +++ b/lib/CGI.pod @@ -0,0 +1,1843 @@ +=head1 NAME + +CGI - Handle Common Gateway Interface requests and responses + +=for html +<a href='https://travis-ci.org/leejo/CGI.pm?branch=master'><img src='https://travis-ci.org/leejo/CGI.pm.svg?branch=master' alt='Build Status' /></a> +<a href='https://coveralls.io/r/leejo/CGI.pm'><img src='https://coveralls.io/repos/leejo/CGI.pm/badge.png?branch=master' alt='Coverage Status' /></a> + +=head1 SYNOPSIS + + use strict; + use warnings; + + use CGI; + + my $q = CGI->new; + + # Process an HTTP request + my @values = $q->multi_param('form_field'); + my $value = $q->param('param_name'); + + my $fh = $q->upload('file_field'); + + my $riddle = $query->cookie('riddle_name'); + my %answers = $query->cookie('answers'); + + # Prepare various HTTP responses + print $q->header(); + print $q->header('application/json'); + + my $cookie1 = $q->cookie( + -name => 'riddle_name', + -value => "The Sphynx's Question" + ); + + my $cookie2 = $q->cookie( + -name => 'answers', + -value => \%answers + ); + + print $q->header( + -type => 'image/gif', + -expires => '+3d', + -cookie => [ $cookie1,$cookie2 ] + ); + + print $q->redirect('http://somewhere.else/in/movie/land'); + +=head1 DESCRIPTION + +CGI.pm is a stable, complete and mature solution for processing and preparing +HTTP requests and responses. Major features including processing form +submissions, file uploads, reading and writing cookies, query string generation +and manipulation, and processing and preparing HTTP headers. + +CGI.pm performs very well in a vanilla CGI.pm environment and also comes +with built-in support for mod_perl and mod_perl2 as well as FastCGI. + +It has the benefit of having developed and refined over 20 years with input +from dozens of contributors and being deployed on thousands of websites. +CGI.pm was included in the perl distribution from perl v5.4 to v5.20, however +is has now been removed from the perl core... + +=head1 CGI.pm HAS BEEN REMOVED FROM THE PERL CORE + +L<http://perl5.git.perl.org/perl.git/commitdiff/e9fa5a80> + +If you upgrade to a new version of perl or if you rely on a +system or vendor perl and get an updated version of perl through a system +update, then you will have to install CGI.pm yourself with cpan/cpanm/a vendor +package/manually. To make this a little easier the L<CGI::Fast> module has been +split into its own distribution, meaning you do not need access to a compiler +to install CGI.pm + +The rationale for this decision is that CGI.pm is no longer considered good +practice for developing web applications, B<including> quick prototyping and +small web scripts. There are far better, cleaner, quicker, easier, safer, +more scalable, more extensible, more modern alternatives available at this point +in time. These will be documented with L<CGI::Alternatives>. + +For more discussion on the removal of CGI.pm from core please see: + +L<http://www.nntp.perl.org/group/perl.perl5.porters/2013/05/msg202130.html> + +Note that the v4 releases of CGI.pm will retain back compatibility B<as much> +B<as possible>, however you may need to make some minor changes to your code +if you are using deprecated methods or some of the more obscure features of the +module. If you plan to upgrade to v4.00 and beyond you should read the Changes +file for more information and B<test your code> against CGI.pm before deploying +it. + +=head1 HTML Generation functions should no longer be used + +B<All> HTML generation functions within CGI.pm are no longer being +maintained. Any issues, bugs, or patches will be rejected unless +they relate to fundamentally broken page rendering. + +The rationale for this is that the HTML generation functions of CGI.pm +are an obfuscation at best and a maintenance nightmare at worst. You +should be using a template engine for better separation of concerns. +See L<CGI::Alternatives> for an example of using CGI.pm with the +L<Template::Toolkit> module. + +These functions, and perldoc for them, will continue to exist in the +v4 releases of CGI.pm but may be deprecated (soft) in v5 and beyond. +All documentation for these functions has been moved to L<CGI::HTML::Functions>. + +=head1 Programming style + +There are two styles of programming with CGI.pm, an object-oriented (OO) +style and a function-oriented style. You are recommended to use the OO +style as CGI.pm will create an internal default object when the functions +are called procedurally and you will not have to worry about method names +clashing with perl builtins. + +In the object-oriented style you create one or more CGI objects and then +use object methods to create the various elements of the page. Each CGI +object starts out with the list of named parameters that were passed to +your CGI script by the server. You can modify the objects, save them to a +file or database and recreate them. Because each object corresponds to the +"state" of the CGI script, and because each object's parameter list is +independent of the others, this allows you to save the state of the +script and restore it later. + +For example, using the object oriented style: + + #!/usr/bin/env perl + + use strict; + use warnings; + + use CGI; # load CGI routines + + my $q = CGI->new; # create new CGI object + print $q->header; # create the HTTP header + + ... + +In the function-oriented style, there is one default CGI object that +you rarely deal with directly. Instead you just call functions to +retrieve CGI parameters, manage cookies, and so on. The following example +is identical to above, in terms of output, but uses the function-oriented +interface. The main differences are that we now need to import a set of +functions into our name space (usually the "standard" functions), and we don't +need to create the CGI object. + + #!/usr/bin/env perl + + use strict; + use warnings; + + use CGI qw/:standard/; # load standard CGI routines + print header(); # create the HTTP header + + ... + +The examples in this document mainly use the object-oriented style. See HOW +TO IMPORT FUNCTIONS for important information on function-oriented programming +in CGI.pm + +=head2 Calling CGI.pm routines + +Most CGI.pm routines accept several arguments, sometimes as many as 20 +optional ones! To simplify this interface, all routines use a named +argument calling style that looks like this: + + print $q->header( + -type => 'image/gif', + -expires => '+3d', + ); + +Each argument name is preceded by a dash. Neither case nor order matters in +the argument list: -type, -Type, and -TYPE are all acceptable. In fact, only +the first argument needs to begin with a dash. If a dash is present in the +first argument CGI.pm assumes dashes for the subsequent ones. + +Several routines are commonly called with just one argument. In the case +of these routines you can provide the single argument without an argument +name. header() happens to be one of these routines. In this case, the single +argument is the document type. + + print $q->header('text/html'); + +Other such routines are documented below. + +Sometimes named arguments expect a scalar, sometimes a reference to an array, +and sometimes a reference to a hash. Often, you can pass any type of argument +and the routine will do whatever is most appropriate. For example, the param() +routine is used to set a CGI parameter to a single or a multi-valued value. +The two cases are shown below: + + $q->param( + -name => 'veggie', + -value => 'tomato', + ); + + $q->param( + -name => 'veggie', + -value => [ qw/tomato tomahto potato potahto/ ], + ); + + +Many routines will do something useful with a named argument that it doesn't +recognize. For example, you can produce non-standard HTTP header fields by +providing them as named arguments: + + print $q->header( + -type => 'text/html', + -cost => 'Three smackers', + -annoyance_level => 'high', + -complaints_to => 'bit bucket', + ); + +This will produce the following nonstandard HTTP header: + + HTTP/1.0 200 OK + Cost: Three smackers + Annoyance-level: high + Complaints-to: bit bucket + Content-type: text/html + +Notice the way that underscores are translated automatically into hyphens. + +=head2 Creating a new query object (object-oriented style) + + my $query = CGI->new; + +This will parse the input (from POST, GET and DELETE methods) and store +it into a perl5 object called $query. Note that because the input parsing +happens at object instantiation you have to set any CGI package variables +that control parsing B<before> you call CGI->new. + +Any filehandles from file uploads will have their position reset to the +beginning of the file. + +=head2 Creating a new query object from an input file + + my $query = CGI->new( $input_filehandle ); + +If you provide a file handle to the new() method, it will read parameters +from the file (or STDIN, or whatever). The file can be in any of the forms +describing below under debugging (i.e. a series of newline delimited +TAG=VALUE pairs will work). Conveniently, this type of file is created by +the save() method (see below). Multiple records can be saved and restored. + +Perl purists will be pleased to know that this syntax accepts references to +file handles, or even references to filehandle globs, which is the "official" +way to pass a filehandle. You can also initialize the CGI object with a +FileHandle or IO::File object. + +If you are using the function-oriented interface and want to initialize CGI +state from a file handle, the way to do this is with B<restore_parameters()>. +This will (re)initialize the default CGI object from the indicated file handle. + + open( my $in_fh,'<',"test.in") || die "Couldn't open test.in for read: $!"; + restore_parameters( $in_fh ); + close( $in_fh ); + +You can also initialize the query object from a hash reference: + + my $query = CGI->new( { + 'dinosaur' => 'barney', + 'song' => 'I love you', + 'friends' => [ qw/ Jessica George Nancy / ] + } ); + +or from a properly formatted, URL-escaped query string: + + my $query = CGI->new('dinosaur=barney&color=purple'); + +or from a previously existing CGI object (currently this clones the parameter +list, but none of the other object-specific fields, such as autoescaping): + + my $old_query = CGI->new; + my $new_query = CGI->new($old_query); + +To create an empty query, initialize it from an empty string or hash: + + my $empty_query = CGI->new(""); + + -or- + + my $empty_query = CGI->new({}); + +=head2 Fetching a list of keywords from the query + + my @keywords = $query->keywords + +If the script was invoked as the result of an ISINDEX search, the parsed +keywords can be obtained as an array using the keywords() method. + +=head2 Fetching the names of all the parameters passed to your script + + my @names = $query->multi_param + + my @names = $query->param + +If the script was invoked with a parameter list +(e.g. "name1=value1&name2=value2&name3=value3"), the param() / multi_param() +methods will return the parameter names as a list. If the script was invoked +as an ISINDEX script and contains a string without ampersands +(e.g. "value1+value2+value3"), there will be a single parameter named +"keywords" containing the "+"-delimited keywords. + +The array of parameter names returned will be in the same order as they were +submitted by the browser. Usually this order is the same as the order in which +the parameters are defined in the form (however, this isn't part of the spec, +and so isn't guaranteed). + +=head2 Fetching the value or values of a single named parameter + + my @values = $query->multi_param('foo'); + + -or- + + my $value = $query->param('foo'); + +Pass the param() / multi_param() method a single argument to fetch the value +of the named parameter. If the parameter is multivalued (e.g. from multiple +selections in a scrolling list), you can ask to receive an array. Otherwise +the method will return a single value. + +B<Warning> - calling param() in list context can lead to vulnerabilities if +you do not sanitise user input as it is possible to inject other param +keys and values into your code. This is why the multi_param() method exists, +to make it clear that a list is being returned, note that param() can still +be called in list context and will return a list for back compatibility. + +The following code is an example of a vulnerability as the call to param will +be evaluated in list context and thus possibly inject extra keys and values +into the hash: + + my %user_info = ( + id => 1, + name => $query->param('name'), + ); + +The fix for the above is to force scalar context on the call to ->param by +prefixing it with "scalar" + + name => scalar $query->param('name'), + +If you call param() in list context with an argument a warning will be raised +by CGI.pm, you can disable this warning by setting $CGI::LIST_CONTEXT_WARN to 0 +or by using the multi_param() method instead + +If a value is not given in the query string, as in the queries "name1=&name2=", +it will be returned as an empty string. + +If the parameter does not exist at all, then param() will return undef in scalar +context, and the empty list in a list context. + +=head2 Setting the value(s) of a named parameter + + $query->param('foo','an','array','of','values'); + +This sets the value for the named parameter 'foo' to an array of values. This +is one way to change the value of a field AFTER the script has been invoked +once before. + +param() also recognizes a named parameter style of calling described in more +detail later: + + $query->param( + -name => 'foo', + -values => ['an','array','of','values'], + ); + + -or- + + $query->param( + -name => 'foo', + -value => 'the value', + ); + +=head2 Appending additional values to a named parameter + + $query->append( + -name =>'foo', + -values =>['yet','more','values'], + ); + +This adds a value or list of values to the named parameter. The values are +appended to the end of the parameter if it already exists. Otherwise the +parameter is created. Note that this method only recognizes the named argument +calling syntax. + +=head2 Importing all parameters into a namespace + + $query->import_names('R'); + +This creates a series of variables in the 'R' namespace. For example, $R::foo, +@R:foo. For keyword lists, a variable @R::keywords will appear. If no namespace +is given, this method will assume 'Q'. B<WARNING>: don't import anything into +'main'; this is a major security risk! + +NOTE 1: Variable names are transformed as necessary into legal perl variable +names. All non-legal characters are transformed into underscores. If you need +to keep the original names, you should use the param() method instead to access +CGI variables by name. + +In fact, you should probably not use this method at all given the above caveats +and security risks. + +=head2 Deleting a parameter completely + + $query->delete('foo','bar','baz'); + +This completely clears a list of parameters. It sometimes useful for resetting +parameters that you don't want passed down between script invocations. + +If you are using the function call interface, use "Delete()" instead to avoid +conflicts with perl's built-in delete operator. + +=head2 Deleting all parameters + + $query->delete_all(); + +This clears the CGI object completely. It might be useful to ensure that all +the defaults are taken when you create a fill-out form. + +Use Delete_all() instead if you are using the function call interface. + +=head2 Handling non-urlencoded arguments + +If POSTed data is not of type application/x-www-form-urlencoded or +multipart/form-data, then the POSTed data will not be processed, but instead +be returned as-is in a parameter named POSTDATA. To retrieve it, use code like +this: + + my $data = $query->param('POSTDATA'); + +Likewise if PUTed data can be retrieved with code like this: + + my $data = $query->param('PUTDATA'); + +(If you don't know what the preceding means, worry not. It only affects people +trying to use CGI for XML processing and other specialized tasks) + +PUTDATA/POSTDATA are also available via +L<upload_hook|/Progress bars for file uploads and avoiding temp files>, +and as L<file uploads|/Processing a file upload field> via L</-putdata_upload> +option. + +=head2 Direct access to the parameter list + + $q->param_fetch('address')->[1] = '1313 Mockingbird Lane'; + unshift @{$q->param_fetch(-name=>'address')},'George Munster'; + +If you need access to the parameter list in a way that isn't covered by the +methods given in the previous sections, you can obtain a direct reference to +it by calling the B<param_fetch()> method with the name of the parameter. This +will return an array reference to the named parameter, which you then can +manipulate in any way you like. + +You can also use a named argument style using the B<-name> argument. + +=head2 Fetching the parameter list as a hash + + my $params = $q->Vars; + print $params->{'address'}; + my @foo = split("\0",$params->{'foo'}); + my %params = $q->Vars; + + use CGI ':cgi-lib'; + my $params = Vars(); + +Many people want to fetch the entire parameter list as a hash in which the keys +are the names of the CGI parameters, and the values are the parameters' values. +The Vars() method does this. Called in a scalar context, it returns the +parameter list as a tied hash reference. Changing a key changes the value of +the parameter in the underlying CGI parameter list. Called in a list context, +it returns the parameter list as an ordinary hash. This allows you to read the +contents of the parameter list, but not to change it. + +When using this, the thing you must watch out for are multivalued CGI +parameters. Because a hash cannot distinguish between scalar and list context, +multivalued parameters will be returned as a packed string, separated by the +"\0" (null) character. You must split this packed string in order to get at the +individual values. This is the convention introduced long ago by Steve Brenner +in his cgi-lib.pl module for perl version 4, and may be replaced in future +versions with array references. + +If you wish to use Vars() as a function, import the I<:cgi-lib> set of function +calls (also see the section on CGI-LIB compatibility). + +=head2 Saving the state of the script to a file + + $query->save(\*FILEHANDLE) + +This will write the current state of the form to the provided filehandle. You +can read it back in by providing a filehandle to the new() method. Note that +the filehandle can be a file, a pipe, or whatever. + +The format of the saved file is: + + NAME1=VALUE1 + NAME1=VALUE1' + NAME2=VALUE2 + NAME3=VALUE3 + = + +Both name and value are URL escaped. Multi-valued CGI parameters are represented +as repeated names. A session record is delimited by a single = symbol. You can +write out multiple records and read them back in with several calls to B<new>. +You can do this across several sessions by opening the file in append mode, +allowing you to create primitive guest books, or to keep a history of users' +queries. Here's a short example of creating multiple session records: + + use strict; + use warnings; + use CGI; + + open (my $out_fh,'>>','test.out') || die "Can't open test.out: $!"; + my $records = 5; + for ( 0 .. $records ) { + my $q = CGI->new; + $q->param( -name => 'counter',-value => $_ ); + $q->save( $out_fh ); + } + close( $out_fh ); + + # reopen for reading + open (my $in_fh,'<','test.out') || die "Can't open test.out: $!"; + while (!eof($in_fh)) { + my $q = CGI->new($in_fh); + print $q->param('counter'),"\n"; + } + +The file format used for save/restore is identical to that used by the Whitehead +Genome Center's data exchange format "Boulderio", and can be manipulated and +even databased using Boulderio utilities. See L<Boulder> for further details. + +If you wish to use this method from the function-oriented (non-OO) interface, +the exported name for this method is B<save_parameters()>. + +=head2 Retrieving cgi errors + +Errors can occur while processing user input, particularly when processing +uploaded files. When these errors occur, CGI will stop processing and return +an empty parameter list. You can test for the existence and nature of errors +using the I<cgi_error()> function. The error messages are formatted as HTTP +status codes. You can either incorporate the error text into a page, or use +it as the value of the HTTP status: + + if ( my $error = $q->cgi_error ) { + print $q->header( -status => $error ); + print "Error: $error"; + exit 0; + } + +When using the function-oriented interface (see the next section), errors may +only occur the first time you call I<param()>. Be ready for this! + +=head2 Using the function-oriented interface + +To use the function-oriented interface, you must specify which CGI.pm +routines or sets of routines to import into your script's namespace. +There is a small overhead associated with this importation, but it +isn't much. + + use strict; + use warnings; + + use CGI qw/ list of methods /; + +The listed methods will be imported into the current package; you can +call them directly without creating a CGI object first. This example +shows how to import the B<param()> and B<header()> +methods, and then use them directly: + + use strict; + use warnings; + + use CGI qw/ param header /; + print header('text/plain'); + my $zipcode = param('zipcode'); + +More frequently, you'll import common sets of functions by referring +to the groups by name. All function sets are preceded with a ":" +character as in ":cgi" (for CGI protocol handling methods). + +Here is a list of the function sets you can import: + +=over 4 + +=item B<:cgi> + +Import all CGI-handling methods, such as B<param()>, B<path_info()> +and the like. + +=item B<:all> + +Import all the available methods. For the full list, see the CGI.pm +code, where the variable %EXPORT_TAGS is defined. (N.B. the :cgi-lib +imports will B<not> be included in the :all import, you will have to +import :cgi-lib to get those) + +=back + +Note that in the interests of execution speed CGI.pm does B<not> use +the standard L<Exporter> syntax for specifying load symbols. This may +change in the future. + +=head2 Pragmas + +In addition to the function sets, there are a number of pragmas that you can +import. Pragmas, which are always preceded by a hyphen, change the way that +CGI.pm functions in various ways. Pragmas, function sets, and individual +functions can all be imported in the same use() line. For example, the +following use statement imports the cgi set of functions and enables +debugging mode (pragma -debug): + + use strict; + use warninigs; + use CGI qw/ :cgi -debug /; + +The current list of pragmas is as follows: + +=over 4 + +=item -no_undef_params + +This keeps CGI.pm from including undef params in the parameter list. + +=item -utf8 + +This makes CGI.pm treat all parameters as text strings rather than binary +strings (see L<perlunitut> for the distinction), assuming UTF-8 for the +encoding. + +CGI.pm does the decoding from the UTF-8 encoded input data, restricting this +decoding to input text as distinct from binary upload data which are left +untouched. Therefore, a ':utf8' layer must B<not> be used on STDIN. + +If you do not use this option you can manually select which fields are +expected to return utf-8 strings and convert them using code like this: + + use strict; + use warnings; + + use CGI; + use Encode qw/ decode /; + + my $cgi = CGI->new; + my $param = $cgi->param('foo'); + $param = decode( 'UTF-8',$param ); + +=item -putdata_upload + +Makes C<<< $cgi->param('PUTDATA'); >>> and C<<< $cgi->param('POSTDATA'); >>> +act like file uploads named PUTDATA and POSTDATA. See +L</Handling non-urlencoded arguments> and L</Processing a file upload field> +PUTDATA/POSTDATA are also available via +L<upload_hook|/Progress bars for file uploads and avoiding temp files>. + +=item -nph + +This makes CGI.pm produce a header appropriate for an NPH (no parsed header) +script. You may need to do other things as well to tell the server that the +script is NPH. See the discussion of NPH scripts below. + +=item -newstyle_urls + +Separate the name=value pairs in CGI parameter query strings with semicolons +rather than ampersands. For example: + + ?name=fred;age=24;favorite_color=3 + +Semicolon-delimited query strings are always accepted, and will be emitted by +self_url() and query_string(). newstyle_urls became the default in version +2.64. + +=item -oldstyle_urls + +Separate the name=value pairs in CGI parameter query strings with ampersands +rather than semicolons. This is no longer the default. + +=item -no_debug + +This turns off the command-line processing features. If you want to run a CGI.pm +script from the command line, and you don't want it to read CGI parameters from +the command line or STDIN, then use this pragma: + + use CGI qw/ -no_debug :standard /; + +=item -debug + +This turns on full debugging. In addition to reading CGI arguments from the +command-line processing, CGI.pm will pause and try to read arguments from STDIN, +producing the message "(offline mode: enter name=value pairs on standard input)" +features. + +See the section on debugging for more details. + +=back + +=head1 GENERATING DYNAMIC DOCUMENTS + +Most of CGI.pm's functions deal with creating documents on the fly. Generally +you will produce the HTTP header first, followed by the document itself. CGI.pm +provides functions for generating HTTP headers of various types. + +Each of these functions produces a fragment of HTTP which you can print out +directly so that it is processed by the browser, appended to a string, or saved +to a file for later use. + +=head2 Creating a standard http header + +Normally the first thing you will do in any CGI script is print out an HTTP +header. This tells the browser what type of document to expect, and gives other +optional information, such as the language, expiration date, and whether to +cache the document. The header can also be manipulated for special purposes, +such as server push and pay per view pages. + + use strict; + use warnings; + + use CGI; + + my $cgi = CGI->new; + + print $cgi->header; + + -or- + + print $cgi->header('image/gif'); + + -or- + + print $cgi->header('text/html','204 No response'); + + -or- + + print $cgi->header( + -type => 'image/gif', + -nph => 1, + -status => '402 Payment required', + -expires => '+3d', + -cookie => $cookie, + -charset => 'utf-8', + -attachment => 'foo.gif', + -Cost => '$2.00' + ); + +header() returns the Content-type: header. You can provide your own MIME type +if you choose, otherwise it defaults to text/html. An optional second parameter +specifies the status code and a human-readable message. For example, you can +specify 204, "No response" to create a script that tells the browser to do +nothing at all. Note that RFC 2616 expects the human-readable phase to be there +as well as the numeric status code. + +The last example shows the named argument style for passing arguments to the CGI +methods using named parameters. Recognized parameters are B<-type>, B<-status>, +B<-expires>, and B<-cookie>. Any other named parameters will be stripped of +their initial hyphens and turned into header fields, allowing you to specify +any HTTP header you desire. Internal underscores will be turned into hyphens: + + print $cgi->header( -Content_length => 3002 ); + +Most browsers will not cache the output from CGI scripts. Every time the browser +reloads the page, the script is invoked anew. You can change this behavior with +the B<-expires> parameter. When you specify an absolute or relative expiration +interval with this parameter, some browsers and proxy servers will cache the +script's output until the indicated expiration date. The following forms are all +valid for the -expires field: + + +30s 30 seconds from now + +10m ten minutes from now + +1h one hour from now + -1d yesterday (i.e. "ASAP!") + now immediately + +3M in three months + +10y in ten years time + Thursday, 25-Apr-2018 00:40:33 GMT at the indicated time & date + +The B<-cookie> parameter generates a header that tells the browser to provide +a "magic cookie" during all subsequent transactions with your script. Some +cookies have a special format that includes interesting attributes such as +expiration time. Use the cookie() method to create and retrieve session cookies. + +The B<-nph> parameter, if set to a true value, will issue the correct headers +to work with a NPH (no-parse-header) script. This is important to use with +certain servers that expect all their scripts to be NPH. + +The B<-charset> parameter can be used to control the character set sent to the +browser. If not provided, defaults to ISO-8859-1. As a side effect, this sets +the charset() method as well. B<Note> that the default being ISO-8859-1 may not +make sense for all content types, e.g.: + + Content-Type: image/gif; charset=ISO-8859-1 + +In the above case you need to pass -charset => '' to prevent the default being +used. + +The B<-attachment> parameter can be used to turn the page into an attachment. +Instead of displaying the page, some browsers will prompt the user to save it +to disk. The value of the argument is the suggested name for the saved file. In +order for this to work, you may have to set the B<-type> to +"application/octet-stream". + +The B<-p3p> parameter will add a P3P tag to the outgoing header. The parameter +can be an arrayref or a space-delimited string of P3P tags. For example: + + print $cgi->header( -p3p => [ qw/ CAO DSP LAW CURa / ] ); + print $cgi->header( -p3p => 'CAO DSP LAW CURa' ); + +In either case, the outgoing header will be formatted as: + + P3P: policyref="/w3c/p3p.xml" cp="CAO DSP LAW CURa" + +CGI.pm will accept valid multi-line headers when each line is separated with a +CRLF value ("\r\n" on most platforms) followed by at least one space. For +example: + + print $cgi->header( -ingredients => "ham\r\n\seggs\r\n\sbacon" ); + +Invalid multi-line header input will trigger in an exception. When multi-line +headers are received, CGI.pm will always output them back as a single line, +according to the folding rules of RFC 2616: the newlines will be removed, while +the white space remains. + +=head2 Generating a redirection header + + print $q->redirect( 'http://somewhere.else/in/movie/land' ); + +Sometimes you don't want to produce a document yourself, but simply redirect +the browser elsewhere, perhaps choosing a URL based on the time of day or the +identity of the user. + +The redirect() method redirects the browser to a different URL. If you use +redirection like this, you should B<not> print out a header as well. + +You should always use full URLs (including the http: or ftp: part) in +redirection requests. Relative URLs will not work correctly. + +You can also use named arguments: + + print $q->redirect( + -uri => 'http://somewhere.else/in/movie/land', + -nph => 1, + -status => '301 Moved Permanently' + ); + +All names arguments recognized by header() are also recognized by redirect(). +However, most HTTP headers, including those generated by -cookie and -target, +are ignored by the browser. + +The B<-nph> parameter, if set to a true value, will issue the correct headers +to work with a NPH (no-parse-header) script. This is important to use with +certain servers, such as Microsoft IIS, which expect all their scripts to be +NPH. + +The B<-status> parameter will set the status of the redirect. HTTP defines +several different possible redirection status codes, and the default if not +specified is 302, which means "moved temporarily." You may change the status +to another status code if you wish. + +Note that the human-readable phrase is also expected to be present to conform +with RFC 2616, section 6.1. + +=head2 Creating a self-referencing url that preserves state information + + my $myself = $q->self_url; + print qq(<a href="$myself">I'm talking to myself.</a>); + +self_url() will return a URL, that, when selected, will re-invoke this script +with all its state information intact. This is most useful when you want to +jump around within the document using internal anchors but you don't want to +disrupt the current contents of the form(s). Something like this will do the +trick: + + my $myself = $q->self_url; + print "<a href=\"$myself#table1\">See table 1</a>"; + print "<a href=\"$myself#table2\">See table 2</a>"; + print "<a href=\"$myself#yourself\">See for yourself</a>"; + +If you want more control over what's returned, using the B<url()> method +instead. + +You can also retrieve a query string representation of the current object +state with query_string(): + + my $the_string = $q->query_string(); + +The behavior of calling query_string is currently undefined when the HTTP method +is something other than GET. + +If you want to retrieved the query string as set in the webserver, namely the +environment variable, you can call env_query_string() + +=head2 Obtaining the script's url + + my $full_url = url(); + my $full_url = url( -full =>1 ); # alternative syntax + my $relative_url = url( -relative => 1 ); + my $absolute_url = url( -absolute =>1 ); + my $url_with_path = url( -path_info => 1 ); + my $url_path_qry = url( -path_info => 1, -query =>1 ); + my $netloc = url( -base => 1 ); + +B<url()> returns the script's URL in a variety of formats. Called without any +arguments, it returns the full form of the URL, including host name and port +number + + http://your.host.com/path/to/script.cgi + +You can modify this format with the following named arguments: + +=over 4 + +=item B<-absolute> + +If true, produce an absolute URL, e.g. + + /path/to/script.cgi + +=item B<-relative> + +Produce a relative URL. This is useful if you want to re-invoke your +script with different parameters. For example: + + script.cgi + +=item B<-full> + +Produce the full URL, exactly as if called without any arguments. This overrides +the -relative and -absolute arguments. + +=item B<-path> (B<-path_info>) + +Append the additional path information to the URL. This can be combined with +B<-full>, B<-absolute> or B<-relative>. B<-path_info> is provided as a synonym. + +=item B<-query> (B<-query_string>) + +Append the query string to the URL. This can be combined with B<-full>, +B<-absolute> or B<-relative>. B<-query_string> is provided as a synonym. + +=item B<-base> + +Generate just the protocol and net location, as in http://www.foo.com:8000 + +=item B<-rewrite> + +If Apache's mod_rewrite is turned on, then the script name and path info +probably won't match the request that the user sent. Set -rewrite => 1 (default) +to return URLs that match what the user sent (the original request URI). Set +-rewrite => 0 to return URLs that match the URL after the mod_rewrite rules have +run. + +=back + +=head2 Mixing post and url parameters + + my $color = url_param('color'); + +It is possible for a script to receive CGI parameters in the URL as well as in +the fill-out form by creating a form that POSTs to a URL containing a query +string (a "?" mark followed by arguments). The B<param()> method will always +return the contents of the POSTed fill-out form, ignoring the URL's query +string. To retrieve URL parameters, call the B<url_param()> method. Use it in +the same way as B<param()>. The main difference is that it allows you to read +the parameters, but not set them. + +Under no circumstances will the contents of the URL query string interfere with +similarly-named CGI parameters in POSTed forms. If you try to mix a URL query +string with a form submitted with the GET method, the results will not be what +you expect. + +=head2 Processing a file upload field + +=head3 Basics + +When the form is processed, you can retrieve an L<IO::File> compatible handle +for a file upload field like this: + + use autodie; + + # undef may be returned if it's not a valid file handle + if ( my $io_handle = $q->upload('field_name') ) { + open ( my $out_file,'>>','/usr/local/web/users/feedback' ); + while ( my $bytesread = $io_handle->read($buffer,1024) ) { + print $out_file $buffer; + } + } + +In a list context, upload() will return an array of filehandles. This makes it +possible to process forms that use the same name for multiple upload fields. + +If you want the entered file name for the file, you can just call param(): + + my $filename = $q->param('field_name'); + +Different browsers will return slightly different things for the name. Some +browsers return the filename only. Others return the full path to the file, +using the path conventions of the user's machine. Regardless, the name returned +is always the name of the file on the I<user's> machine, and is unrelated to +the name of the temporary file that CGI.pm creates during upload spooling +(see below). + +When a file is uploaded the browser usually sends along some information along +with it in the format of headers. The information usually includes the MIME +content type. To retrieve this information, call uploadInfo(). It returns a +reference to a hash containing all the document headers. + + my $filehandle = $q->upload( 'uploaded_file' ); + my $type = $q->uploadInfo( $filehandle )->{'Content-Type'}; + if ( $type ne 'text/html' ) { + die "HTML FILES ONLY!"; + } + +Note that you must use ->upload or ->param to get the file-handle to pass into +uploadInfo as internally this is represented as a File::Temp object (which is +what will be returned by ->upload or ->param). When using ->Vars you will get +the literal filename rather than the File::Temp object, which will not return +anything when passed to uploadInfo. So don't use ->Vars. + +If you are using a machine that recognizes "text" and "binary" data modes, be +sure to understand when and how to use them (see the Camel book). Otherwise +you may find that binary files are corrupted during file uploads. + +=head3 Accessing the temp files directly + +When processing an uploaded file, CGI.pm creates a temporary file on your hard +disk and passes you a file handle to that file. After you are finished with the +file handle, CGI.pm unlinks (deletes) the temporary file. If you need to you +can access the temporary file directly. You can access the temp file for a file +upload by passing the file name to the tmpFileName() method: + + my $filehandle = $query->upload( 'uploaded_file' ); + my $tmpfilename = $query->tmpFileName( $filehandle ); + +As with ->uploadInfo, using the reference returned by ->upload or ->param is +preferred, although unlike ->uploadInfo, plain filenames also work if possible +for backwards compatibility. + +The temporary file will be deleted automatically when your program exits unless +you manually rename it or set $CGI::UNLINK_TMP_FILES to 0. On some operating +systems (such as Windows NT), you will need to close the temporary file's +filehandle before your program exits. Otherwise the attempt to delete the +temporary file will fail. + +=head3 Changes in temporary file handling (v4.05+) + +CGI.pm had its temporary file handling significantly refactored, this logic is +now all deferred to File::Temp (which is wrapped in a compatibility object, +CGI::File::Temp - B<DO NOT USE THIS PACKAGE DIRECTLY>). As a consequence the +PRIVATE_TEMPFILES variable has been removed along with deprecation of the +private_tempfiles routine and B<complete> removal of the CGITempFile package. +The $CGITempFile::TMPDIRECTORY is no longer used to set the temp directory, +refer to the perldoc for File::Temp if you want to override the default +settings in that package (the TMPDIR env variable is still available on some +platforms). For Windows platforms the temporary directory order remains +as before: TEMP > TMP > WINDIR ( > TMPDIR ) so if you have any of these in +use in existing scripts they should still work. + +The Fh package still exists but does nothing, the CGI::File::Temp class is +a subclass of both File::Temp and the empty Fh package, so if you have any +code that checks that the filehandle isa Fh this should still work. + +When you get the internal file handle you will receive a File::Temp object, +this should be transparent as File::Temp isa IO::Handle and isa IO::Seekable +meaning it behaves as previously. If you are doing anything out of the ordinary +with regards to temp files you should test your code before deploying this +update and refer to the File::Temp documentation for more information. + +=head3 Handling interrupted file uploads + +There are occasionally problems involving parsing the uploaded file. This +usually happens when the user presses "Stop" before the upload is finished. In +this case, CGI.pm will return undef for the name of the uploaded file and set +I<cgi_error()> to the string "400 Bad request (malformed multipart POST)". This +error message is designed so that you can incorporate it into a status code to +be sent to the browser. Example: + + my $file = $q->upload( 'uploaded_file' ); + if ( !$file && $q->cgi_error ) { + print $q->header( -status => $q->cgi_error ); + exit 0; + } + +=head3 Progress bars for file uploads and avoiding temp files + +CGI.pm gives you low-level access to file upload management through a file +upload hook. You can use this feature to completely turn off the temp file +storage of file uploads, or potentially write your own file upload progress +meter. + +This is much like the UPLOAD_HOOK facility available in L<Apache::Request>, +with the exception that the first argument to the callback is an +L<Apache::Upload> object, here it's the remote filename. + + my $q = CGI->new( \&hook [,$data [,$use_tempfile]] ); + + sub hook { + my ( $filename, $buffer, $bytes_read, $data ) = @_; + print "Read $bytes_read bytes of $filename\n"; + } + +The C<< $data >> field is optional; it lets you pass configuration information +(e.g. a database handle) to your hook callback. + +The C<< $use_tempfile >> field is a flag that lets you turn on and off CGI.pm's +use of a temporary disk-based file during file upload. If you set this to a +FALSE value (default true) then $q->param('uploaded_file') will no longer work, +and the only way to get at the uploaded data is via the hook you provide. + +If using the function-oriented interface, call the CGI::upload_hook() method +before calling param() or any other CGI functions: + + CGI::upload_hook( \&hook [,$data [,$use_tempfile]] ); + +This method is not exported by default. You will have to import it explicitly +if you wish to use it without the CGI:: prefix. + +=head3 Troubleshooting file uploads on Windows + +If you are using CGI.pm on a Windows platform and find that binary files get +slightly larger when uploaded but that text files remain the same, then you +have forgotten to activate binary mode on the output filehandle. Be sure to call +binmode() on any handle that you create to write the uploaded file to disk. + +=head3 Older ways to process file uploads + +This section is here for completeness. if you are building a new application +with CGI.pm, you can skip it. + +The original way to process file uploads with CGI.pm was to use param(). The +value it returns has a dual nature as both a file name and a lightweight +filehandle. This dual nature is problematic if you following the recommended +practice of having C<use strict> in your code. perl will complain when you try +to use a string as a filehandle. More seriously, it is possible for the remote +user to type garbage into the upload field, in which case what you get from +param() is not a filehandle at all, but a string. + +To solve this problem the upload() method was added, which always returns a +lightweight filehandle. This generally works well, but will have trouble +interoperating with some other modules because the file handle is not derived +from L<IO::File>. So that brings us to current recommendation given above, +which is to call the handle() method on the file handle returned by upload(). +That upgrades the handle to an IO::File. It's a big win for compatibility for +a small penalty of loading IO::File the first time you call it. + +=head1 HTTP COOKIES + +CGI.pm has several methods that support cookies. + +A cookie is a name=value pair much like the named parameters in a CGI query +string. CGI scripts create one or more cookies and send them to the browser +in the HTTP header. The browser maintains a list of cookies that belong to a +particular Web server, and returns them to the CGI script during subsequent +interactions. + +In addition to the required name=value pair, each cookie has several optional +attributes: + +=over 4 + +=item 1. an expiration time + +This is a time/date string (in a special GMT format) that indicates when a +cookie expires. The cookie will be saved and returned to your script until this +expiration date is reached if the user exits the browser and restarts it. If an +expiration date isn't specified, the cookie will remain active until the user +quits the browser. + +=item 2. a domain + +This is a partial or complete domain name for which the cookie is valid. The +browser will return the cookie to any host that matches the partial domain name. +For example, if you specify a domain name of ".capricorn.com", then the browser +will return the cookie to Web servers running on any of the machines +"www.capricorn.com", "www2.capricorn.com", "feckless.capricorn.com", etc. Domain +names must contain at least two periods to prevent attempts to match on top +level domains like ".edu". If no domain is specified, then the browser will +only return the cookie to servers on the host the cookie originated from. + +=item 3. a path + +If you provide a cookie path attribute, the browser will check it against your +script's URL before returning the cookie. For example, if you specify the path +"/cgi-bin", then the cookie will be returned to each of the scripts +"/cgi-bin/tally.pl", "/cgi-bin/order.pl", and +"/cgi-bin/customer_service/complain.pl", but not to the script +"/cgi-private/site_admin.pl". By default, path is set to "/", which causes the +cookie to be sent to any CGI script on your site. + +=item 4. a "secure" flag + +If the "secure" attribute is set, the cookie will only be sent to your script +if the CGI request is occurring on a secure channel, such as SSL. + +=back + +The interface to HTTP cookies is the B<cookie()> method: + + my $cookie = $q->cookie( + -name => 'sessionID', + -value => 'xyzzy', + -expires => '+1h', + -path => '/cgi-bin/database', + -domain => '.capricorn.org', + -secure => 1 + ); + + print $q->header( -cookie => $cookie ); + +B<cookie()> creates a new cookie. Its parameters include: + +=over 4 + +=item B<-name> + +The name of the cookie (required). This can be any string at all. Although +browsers limit their cookie names to non-whitespace alphanumeric characters, +CGI.pm removes this restriction by escaping and unescaping cookies behind the +scenes. + +=item B<-value> + +The value of the cookie. This can be any scalar value, array reference, or even +hash reference. For example, you can store an entire hash into a cookie this +way: + + my $cookie = $q->cookie( + -name => 'family information', + -value => \%childrens_ages + ); + +=item B<-path> + +The optional partial path for which this cookie will be valid, as described +above. + +=item B<-domain> + +The optional partial domain for which this cookie will be valid, as described +above. + +=item B<-expires> + +The optional expiration date for this cookie. The format is as described in the +section on the B<header()> method: + + "+1h" one hour from now + +=item B<-secure> + +If set to true, this cookie will only be used within a secure SSL session. + +=back + +The cookie created by cookie() must be incorporated into the HTTP header within +the string returned by the header() method: + + use strict; + use warnings; + + use CGI; + + my $q = CGI->new; + my $cookie = ... + print $q->header( -cookie => $cookie ); + +To create multiple cookies, give header() an array reference: + + my $cookie1 = $q->cookie( + -name => 'riddle_name', + -value => "The Sphynx's Question" + ); + + my $cookie2 = $q->cookie( + -name => 'answers', + -value => \%answers + ); + + print $q->header( -cookie => [ $cookie1,$cookie2 ] ); + +To retrieve a cookie, request it by name by calling cookie() method without the +B<-value> parameter. This example uses the object-oriented form: + + my $riddle = $q->cookie('riddle_name'); + my %answers = $query->cookie('answers'); + +Cookies created with a single scalar value, such as the "riddle_name" cookie, +will be returned in that form. Cookies with array and hash values can also be +retrieved. + +The cookie and CGI namespaces are separate. If you have a parameter named +'answers' and a cookie named 'answers', the values retrieved by param() and +cookie() are independent of each other. However, it's simple to turn a CGI +parameter into a cookie, and vice-versa: + + # turn a CGI parameter into a cookie + my $c = cookie( -name => 'answers',-value => [$q->param('answers')] ); + # vice-versa + $q->param( -name => 'answers',-value => [ $q->cookie('answers')] ); + +If you call cookie() without any parameters, it will return a list of +the names of all cookies passed to your script: + + my @cookies = $q->cookie(); + +See the B<cookie.cgi> example script for some ideas on how to use cookies +effectively. + +=head1 DEBUGGING + +If you are running the script from the command line or in the perl debugger, +you can pass the script a list of keywords or parameter=value pairs on the +command line or from standard input (you don't have to worry about tricking +your script into reading from environment variables). You can pass keywords +like this: + + your_script.pl keyword1 keyword2 keyword3 + +or this: + + your_script.pl keyword1+keyword2+keyword3 + +or this: + + your_script.pl name1=value1 name2=value2 + +or this: + + your_script.pl name1=value1&name2=value2 + +To turn off this feature, use the -no_debug pragma. + +To test the POST method, you may enable full debugging with the -debug pragma. +This will allow you to feed newline-delimited name=value pairs to the script on +standard input. + +When debugging, you can use quotes and backslashes to escape characters in the +familiar shell manner, letting you place spaces and other funny characters in +your parameter=value pairs: + + your_script.pl "name1='I am a long value'" "name2=two\ words" + +Finally, you can set the path info for the script by prefixing the first +name/value parameter with the path followed by a question mark (?): + + your_script.pl /your/path/here?name1=value1&name2=value2 + +=head1 FETCHING ENVIRONMENT VARIABLES + +Some of the more useful environment variables can be fetched through this +interface. The methods are as follows: + +=over 4 + +=item B<Accept()> + +Return a list of MIME types that the remote browser accepts. If you give this +method a single argument corresponding to a MIME type, as in +Accept('text/html'), it will return a floating point value corresponding to the +browser's preference for this type from 0.0 (don't want) to 1.0. Glob types +(e.g. text/*) in the browser's accept list are handled correctly. + +Note that the capitalization changed between version 2.43 and 2.44 in order to +avoid conflict with perl's accept() function. + +=item B<raw_cookie()> + +Returns the HTTP_COOKIE variable. Cookies have a special format, and this +method call just returns the raw form (?cookie dough). See cookie() for ways +of setting and retrieving cooked cookies. + +Called with no parameters, raw_cookie() returns the packed cookie structure. +You can separate it into individual cookies by splitting on the character +sequence "; ". Called with the name of a cookie, retrieves the B<unescaped> +form of the cookie. You can use the regular cookie() method to get the names, +or use the raw_fetch() method from the CGI::Cookie module. + +=item B<env_query_string()> + +Returns the QUERY_STRING variable, note that this is the original value as set +in the environment by the webserver and (possibly) not the same value as +returned by query_string(), which represents the object state + +=item B<user_agent()> + +Returns the HTTP_USER_AGENT variable. If you give this method a single +argument, it will attempt to pattern match on it, allowing you to do something +like user_agent(Mozilla); + +=item B<path_info()> + +Returns additional path information from the script URL. E.G. fetching +/cgi-bin/your_script/additional/stuff will result in path_info() returning +"/additional/stuff". + +NOTE: The Microsoft Internet Information Server is broken with respect to +additional path information. If you use the perl DLL library, the IIS server +will attempt to execute the additional path information as a perl script. If +you use the ordinary file associations mapping, the path information will be +present in the environment, but incorrect. The best thing to do is to avoid +using additional path information in CGI scripts destined for use with IIS. A +best attempt has been made to make CGI.pm do the right thing. + +=item B<path_translated()> + +As per path_info() but returns the additional path information translated into +a physical path, e.g. "/usr/local/etc/httpd/htdocs/additional/stuff". + +The Microsoft IIS is broken with respect to the translated path as well. + +=item B<remote_host()> + +Returns either the remote host name or IP address if the former is unavailable. + +=item B<remote_ident()> + +Returns the name of the remote user (as returned by identd) or undef if not set + +=item B<remote_addr()> + +Returns the remote host IP address, or 127.0.0.1 if the address is unavailable. + +=item B<request_uri()> + +Returns the interpreted pathname of the requested document or CGI (relative to +the document root). Or undef if not set. + +=item B<script_name()> + +Return the script name as a partial URL, for self-referring scripts. + +=item B<referer()> + +Return the URL of the page the browser was viewing prior to fetching your +script. + +=item B<auth_type()> + +Return the authorization/verification method in use for this script, if any. + +=item B<server_name()> + +Returns the name of the server, usually the machine's host name. + +=item B<virtual_host()> + +When using virtual hosts, returns the name of the host that the browser +attempted to contact + +=item B<server_port()> + +Return the port that the server is listening on. + +=item B<server_protocol()> + +Returns the protocol and revision of the incoming request, or defaults to +HTTP/1.0 if this is not set + +=item B<virtual_port()> + +Like server_port() except that it takes virtual hosts into account. Use this +when running with virtual hosts. + +=item B<server_software()> + +Returns the server software and version number. + +=item B<remote_user()> + +Return the authorization/verification name used for user verification, if this +script is protected. + +=item B<user_name()> + +Attempt to obtain the remote user's name, using a variety of different +techniques. May not work in all browsers. + +=item B<request_method()> + +Returns the method used to access your script, usually one of 'POST', 'GET' +or 'HEAD'. + +=item B<content_type()> + +Returns the content_type of data submitted in a POST, generally +multipart/form-data or application/x-www-form-urlencoded + +=item B<http()> + +Called with no arguments returns the list of HTTP environment variables, +including such things as HTTP_USER_AGENT, HTTP_ACCEPT_LANGUAGE, and +HTTP_ACCEPT_CHARSET, corresponding to the like-named HTTP header fields in the +request. Called with the name of an HTTP header field, returns its value. +Capitalization and the use of hyphens versus underscores are not significant. + +For example, all three of these examples are equivalent: + + my $requested_language = $q->http('Accept-language'); + + my $requested_language = $q->http('Accept_language'); + + my $requested_language = $q->http('HTTP_ACCEPT_LANGUAGE'); + +=item B<https()> + +The same as I<http()>, but operates on the HTTPS environment variables present +when the SSL protocol is in effect. Can be used to determine whether SSL is +turned on. + +=back + +=head1 USING NPH SCRIPTS + +NPH, or "no-parsed-header", scripts bypass the server completely by sending the +complete HTTP header directly to the browser. This has slight performance +benefits, but is of most use for taking advantage of HTTP extensions that are +not directly supported by your server, such as server push and PICS headers. + +Servers use a variety of conventions for designating CGI scripts as NPH. Many +Unix servers look at the beginning of the script's name for the prefix "nph-". +The Macintosh WebSTAR server and Microsoft's Internet Information Server, in +contrast, try to decide whether a program is an NPH script by examining the +first line of script output. + +CGI.pm supports NPH scripts with a special NPH mode. When in this mode, CGI.pm +will output the necessary extra header information when the header() and +redirect() methods are called. + +The Microsoft Internet Information Server requires NPH mode. As of version 2.30, +CGI.pm will automatically detect when the script is running under IIS and put +itself into this mode. You do not need to do this manually, although it won't +hurt anything if you do. + +=over 4 + +=item In the B<use> statement + +Simply add the "-nph" pragma to the list of symbols to be imported into +your script: + + use CGI qw(:standard -nph) + +=item By calling the B<nph()> method: + +Call B<nph()> with a non-zero parameter at any point after using CGI.pm in your +program. + + CGI->nph(1) + +=item By using B<-nph> parameters + +in the B<header()> and B<redirect()> statements: + + print header(-nph=>1); + +=back + +=head1 SERVER PUSH + +CGI.pm provides four simple functions for producing multipart documents of the +type needed to implement server push. These functions were graciously provided +by Ed Jordan <ed@fidalgo.net>. To import these into your namespace, you must +import the ":push" set. You are also advised to put the script into NPH mode +and to set $| to 1 to avoid buffering problems. + +Here is a simple script that demonstrates server push: + + #!/usr/bin/env perl + + use strict; + use warnings; + + use CGI qw/:push -nph/; + + $| = 1; + print multipart_init( -boundary=>'----here we go!' ); + for (0 .. 4) { + print multipart_start( -type=>'text/plain' ), + "The current time is ",scalar( localtime ),"\n"; + if ($_ < 4) { + print multipart_end(); + } else { + print multipart_final(); + } + sleep 1; + } + +This script initializes server push by calling B<multipart_init()>. It then +enters a loop in which it begins a new multipart section by calling +B<multipart_start()>, prints the current local time, and ends a multipart +section with B<multipart_end()>. It then sleeps a second, and begins again. +On the final iteration, it ends the multipart section with +B<multipart_final()> rather than with B<multipart_end()>. + +=over 4 + +=item multipart_init() + + multipart_init( -boundary => $boundary, -charset => $charset ); + +Initialize the multipart system. The -boundary argument specifies what MIME +boundary string to use to separate parts of the document. If not provided, +CGI.pm chooses a reasonable boundary for you. + +The -charset provides the character set, if not provided this will default to +ISO-8859-1 + +=item multipart_start() + + multipart_start( -type => $type, -charset => $charset ); + +Start a new part of the multipart document using the specified MIME type and +charset. If not specified, text/html ISO-8859-1 is assumed. + +=item multipart_end() + + multipart_end() + +End a part. You must remember to call multipart_end() once for each +multipart_start(), except at the end of the last part of the multipart document +when multipart_final() should be called instead of multipart_end(). + +=item multipart_final() + + multipart_final() + +End all parts. You should call multipart_final() rather than multipart_end() +at the end of the last part of the multipart document. + +=back + +Users interested in server push applications should also have a look at the +CGI::Push module. + +=head1 AVOIDING DENIAL OF SERVICE ATTACKS + +A potential problem with CGI.pm is that, by default, it attempts to process +form POSTings no matter how large they are. A wily hacker could attack your +site by sending a CGI script a huge POST of many gigabytes. CGI.pm will attempt +to read the entire POST into a variable, growing hugely in size until it runs +out of memory. While the script attempts to allocate the memory the system may +slow down dramatically. This is a form of denial of service attack. + +Another possible attack is for the remote user to force CGI.pm to accept a huge +file upload. CGI.pm will accept the upload and store it in a temporary directory +even if your script doesn't expect to receive an uploaded file. CGI.pm will +delete the file automatically when it terminates, but in the meantime the remote +user may have filled up the server's disk space, causing problems for other +programs. + +The best way to avoid denial of service attacks is to limit the amount of +memory, CPU time and disk space that CGI scripts can use. Some Web servers come +with built-in facilities to accomplish this. In other cases, you can use the +shell I<limit> or I<ulimit> commands to put ceilings on CGI resource usage. + +CGI.pm also has some simple built-in protections against denial of service +attacks, but you must activate them before you can use them. These take the +form of two global variables in the CGI name space: + +=over 4 + +=item B<$CGI::POST_MAX> + +If set to a non-negative integer, this variable puts a ceiling on the size of +POSTings, in bytes. If CGI.pm detects a POST that is greater than the ceiling, +it will immediately exit with an error message. This value will affect both +ordinary POSTs and multipart POSTs, meaning that it limits the maximum size of +file uploads as well. You should set this to a reasonably high +value, such as 10 megabytes. + +=item B<$CGI::DISABLE_UPLOADS> + +If set to a non-zero value, this will disable file uploads completely. Other +fill-out form values will work as usual. + +=back + +To use these variables, set the variable at the top of the script, right after +the "use" statement: + + #!/usr/bin/env perl + + use strict; + use warnings; + + use CGI; + + $CGI::POST_MAX = 1024 * 1024 * 10; # max 10MB posts + $CGI::DISABLE_UPLOADS = 1; # no uploads + +An attempt to send a POST larger than $POST_MAX bytes will cause I<param()> to +return an empty CGI parameter list. You can test for this event by checking +I<cgi_error()>, either after you create the CGI object or, if you are using the +function-oriented interface, call <param()> for the first time. If the POST was +intercepted, then cgi_error() will return the message "413 POST too large". + +This error message is actually defined by the HTTP protocol, and is designed to +be returned to the browser as the CGI script's status code. For example: + + my $uploaded_file = $q->param('upload'); + if ( !$uploaded_file && $q->cgi_error() ) { + print $q->header( -status => $q->cgi_error() ); + exit 0; + } + +However it isn't clear that any browser currently knows what to do with this +status code. It might be better just to create a page that warns the user of +the problem. + +=head1 COMPATIBILITY WITH CGI-LIB.PL + +To make it easier to port existing programs that use cgi-lib.pl the +compatibility routine "ReadParse" is provided. Porting is simple: + +OLD VERSION + + require "cgi-lib.pl"; + &ReadParse; + print "The value of the antique is $in{antique}.\n"; + +NEW VERSION + + use CGI; + CGI::ReadParse(); + print "The value of the antique is $in{antique}.\n"; + +CGI.pm's ReadParse() routine creates a tied variable named %in, which can be +accessed to obtain the query variables. Like ReadParse, you can also provide +your own variable. Infrequently used features of ReadParse, such as the creation +of @in and $in variables, are not supported. + +Once you use ReadParse, you can retrieve the query object itself this way: + + my $q = $in{CGI}; + +This allows you to start using the more interesting features of CGI.pm without +rewriting your old scripts from scratch. + +An even simpler way to mix cgi-lib calls with CGI.pm calls is to import both the +C<:cgi-lib> and C<:standard> method: + + use CGI qw(:cgi-lib :standard); + &ReadParse; + print "The price of your purchase is $in{price}.\n"; + print textfield(-name=>'price', -default=>'$1.99'); + +=head2 Cgi-lib functions that are available in CGI.pm + +In compatibility mode, the following cgi-lib.pl functions are +available for your use: + + ReadParse() + PrintHeader() + SplitParam() + MethGet() + MethPost() + +=head1 LICENSE + +The CGI.pm distribution is copyright 1995-2007, Lincoln D. Stein. It is +distributed under GPL and the Artistic License 2.0. It is currently maintained +by Lee Johnson (LEEJO) with help from many contributors. + +=head1 CREDITS + +Thanks very much to: + +=over 4 + +=item Mark Stosberg (mark@stosberg.com) + +=item Matt Heffron (heffron@falstaff.css.beckman.com) + +=item James Taylor (james.taylor@srs.gov) + +=item Scott Anguish <sanguish@digifix.com> + +=item Mike Jewell (mlj3u@virginia.edu) + +=item Timothy Shimmin (tes@kbs.citri.edu.au) + +=item Joergen Haegg (jh@axis.se) + +=item Laurent Delfosse (delfosse@delfosse.com) + +=item Richard Resnick (applepi1@aol.com) + +=item Craig Bishop (csb@barwonwater.vic.gov.au) + +=item Tony Curtis (tc@vcpc.univie.ac.at) + +=item Tim Bunce (Tim.Bunce@ig.co.uk) + +=item Tom Christiansen (tchrist@convex.com) + +=item Andreas Koenig (k@franz.ww.TU-Berlin.DE) + +=item Tim MacKenzie (Tim.MacKenzie@fulcrum.com.au) + +=item Kevin B. Hendricks (kbhend@dogwood.tyler.wm.edu) + +=item Stephen Dahmen (joyfire@inxpress.net) + +=item Ed Jordan (ed@fidalgo.net) + +=item David Alan Pisoni (david@cnation.com) + +=item Doug MacEachern (dougm@opengroup.org) + +=item Robin Houston (robin@oneworld.org) + +=item ...and many many more... + +for suggestions and bug fixes. + +=back + +=head1 BUGS + +Address bug reports and comments to: L<https://github.com/leejo/CGI.pm/issues> + +The original bug tracker can be found at: +L<https://rt.cpan.org/Public/Dist/Display.html?Queue=CGI.pm> + +When sending bug reports, please provide the version of CGI.pm, the version of +perl, the name and version of your Web server, and the name and version of the +operating system you are using. If the problem is even remotely browser +dependent, please provide information about the affected browsers as well. + +Failing tests cases are appreciated with issues, and if you submit a patch then +it will *not* be accepted unless you provide a reasonable automated test case +with it (please see the existing tests in t/ for examples). + +Please note the CGI.pm is now considered "done". See also "mature" and "legacy". +Feature requests and none critical issues will be outright rejected. The module +is now in maintenance mode for critical issues only. + +=head1 SEE ALSO + +L<CGI::Carp> - provides L<Carp> implementation tailored to the CGI environment. + +L<CGI::Fast> - supports running CGI applications under FastCGI + +=cut diff --git a/lib/CGI/Carp.pm b/lib/CGI/Carp.pm new file mode 100644 index 0000000..d215732 --- /dev/null +++ b/lib/CGI/Carp.pm @@ -0,0 +1,615 @@ +package CGI::Carp; +use if $] >= 5.019, 'deprecate'; + +=head1 NAME + +B<CGI::Carp> - CGI routines for writing to the HTTPD (or other) error log + +=head1 SYNOPSIS + + use CGI::Carp; + + croak "We're outta here!"; + confess "It was my fault: $!"; + carp "It was your fault!"; + warn "I'm confused"; + die "I'm dying.\n"; + + use CGI::Carp qw(cluck); + cluck "I wouldn't do that if I were you"; + + use CGI::Carp qw(fatalsToBrowser); + die "Fatal error messages are now sent to browser"; + +=head1 DESCRIPTION + +CGI scripts have a nasty habit of leaving warning messages in the error +logs that are neither time stamped nor fully identified. Tracking down +the script that caused the error is a pain. This fixes that. Replace +the usual + + use Carp; + +with + + use CGI::Carp + +The standard warn(), die (), croak(), confess() and carp() calls will +be replaced with functions that write time-stamped messages to the +HTTP server error log. + +For example: + + [Fri Nov 17 21:40:43 1995] test.pl: I'm confused at test.pl line 3. + [Fri Nov 17 21:40:43 1995] test.pl: Got an error message: Permission denied. + [Fri Nov 17 21:40:43 1995] test.pl: I'm dying. + +=head1 REDIRECTING ERROR MESSAGES + +By default, error messages are sent to STDERR. Most HTTPD servers +direct STDERR to the server's error log. Some applications may wish +to keep private error logs, distinct from the server's error log, or +they may wish to direct error messages to STDOUT so that the browser +will receive them. + +The C<carpout()> function is provided for this purpose. Since +carpout() is not exported by default, you must import it explicitly by +saying + + use CGI::Carp qw(carpout); + +The carpout() function requires one argument, a reference to an open +filehandle for writing errors. It should be called in a C<BEGIN> +block at the top of the CGI application so that compiler errors will +be caught. Example: + + BEGIN { + use CGI::Carp qw(carpout); + open(LOG, ">>/usr/local/cgi-logs/mycgi-log") or + die("Unable to open mycgi-log: $!\n"); + carpout(LOG); + } + +carpout() does not handle file locking on the log for you at this +point. Also, note that carpout() does not work with in-memory file +handles, although a patch would be welcome to address that. + +The real STDERR is not closed -- it is moved to CGI::Carp::SAVEERR. +Some servers, when dealing with CGI scripts, close their connection to +the browser when the script closes STDOUT and STDERR. +CGI::Carp::SAVEERR is there to prevent this from happening +prematurely. + +You can pass filehandles to carpout() in a variety of ways. The "correct" +way according to Tom Christiansen is to pass a reference to a filehandle +GLOB: + + carpout(\*LOG); + +This looks weird to mere mortals however, so the following syntaxes are +accepted as well: + + carpout(LOG); + carpout(main::LOG); + carpout(main'LOG); + carpout(\LOG); + carpout(\'main::LOG'); + + ... and so on + +FileHandle and other objects work as well. + +Use of carpout() is not great for performance, so it is recommended +for debugging purposes or for moderate-use applications. A future +version of this module may delay redirecting STDERR until one of the +CGI::Carp methods is called to prevent the performance hit. + +=head1 MAKING PERL ERRORS APPEAR IN THE BROWSER WINDOW + +If you want to send fatal (die, confess) errors to the browser, import +the special "fatalsToBrowser" subroutine: + + use CGI::Carp qw(fatalsToBrowser); + die "Bad error here"; + +Fatal errors will now be echoed to the browser as well as to the log. +CGI::Carp arranges to send a minimal HTTP header to the browser so +that even errors that occur in the early compile phase will be seen. +Nonfatal errors will still be directed to the log file only (unless +redirected with carpout). + +Note that fatalsToBrowser may B<not> work well with mod_perl version 2.0 +and higher. + +=head2 Changing the default message + +By default, the software error message is followed by a note to +contact the Webmaster by e-mail with the time and date of the error. +If this message is not to your liking, you can change it using the +set_message() routine. This is not imported by default; you should +import it on the use() line: + + use CGI::Carp qw(fatalsToBrowser set_message); + set_message("It's not a bug, it's a feature!"); + +You may also pass in a code reference in order to create a custom +error message. At run time, your code will be called with the text +of the error message that caused the script to die. Example: + + use CGI::Carp qw(fatalsToBrowser set_message); + BEGIN { + sub handle_errors { + my $msg = shift; + print "<h1>Oh gosh</h1>"; + print "<p>Got an error: $msg</p>"; + } + set_message(\&handle_errors); + } + +In order to correctly intercept compile-time errors, you should call +set_message() from within a BEGIN{} block. + +=head1 DOING MORE THAN PRINTING A MESSAGE IN THE EVENT OF PERL ERRORS + +If fatalsToBrowser in conjunction with set_message does not provide +you with all of the functionality you need, you can go one step +further by specifying a function to be executed any time a script +calls "die", has a syntax error, or dies unexpectedly at runtime +with a line like "undef->explode();". + + use CGI::Carp qw(set_die_handler); + BEGIN { + sub handle_errors { + my $msg = shift; + print "content-type: text/html\n\n"; + print "<h1>Oh gosh</h1>"; + print "<p>Got an error: $msg</p>"; + + #proceed to send an email to a system administrator, + #write a detailed message to the browser and/or a log, + #etc.... + } + set_die_handler(\&handle_errors); + } + +Notice that if you use set_die_handler(), you must handle sending +HTML headers to the browser yourself if you are printing a message. + +If you use set_die_handler(), you will most likely interfere with +the behavior of fatalsToBrowser, so you must use this or that, not +both. + +Using set_die_handler() sets SIG{__DIE__} (as does fatalsToBrowser), +and there is only one SIG{__DIE__}. This means that if you are +attempting to set SIG{__DIE__} yourself, you may interfere with +this module's functionality, or this module may interfere with +your module's functionality. + +=head1 SUPPRESSING PERL ERRORS APPEARING IN THE BROWSER WINDOW + +A problem sometimes encountered when using fatalsToBrowser is +when a C<die()> is done inside an C<eval> body or expression. +Even though the +fatalsToBrower support takes precautions to avoid this, +you still may get the error message printed to STDOUT. +This may have some undesirable effects when the purpose of doing the +eval is to determine which of several algorithms is to be used. + +By setting C<$CGI::Carp::TO_BROWSER> to 0 you can suppress printing +the C<die> messages but without all of the complexity of using +C<set_die_handler>. You can localize this effect to inside C<eval> +bodies if this is desirable: For example: + + eval { + local $CGI::Carp::TO_BROWSER = 0; + die "Fatal error messages not sent browser" + } + # $@ will contain error message + + +=head1 MAKING WARNINGS APPEAR AS HTML COMMENTS + +It is also possible to make non-fatal errors appear as HTML comments +embedded in the output of your program. To enable this feature, +export the new "warningsToBrowser" subroutine. Since sending warnings +to the browser before the HTTP headers have been sent would cause an +error, any warnings are stored in an internal buffer until you call +the warningsToBrowser() subroutine with a true argument: + + use CGI::Carp qw(fatalsToBrowser warningsToBrowser); + use CGI qw(:standard); + print header(); + warningsToBrowser(1); + +You may also give a false argument to warningsToBrowser() to prevent +warnings from being sent to the browser while you are printing some +content where HTML comments are not allowed: + + warningsToBrowser(0); # disable warnings + print "<script type=\"text/javascript\"><!--\n"; + print_some_javascript_code(); + print "//--></script>\n"; + warningsToBrowser(1); # re-enable warnings + +Note: In this respect warningsToBrowser() differs fundamentally from +fatalsToBrowser(), which you should never call yourself! + +=head1 OVERRIDING THE NAME OF THE PROGRAM + +CGI::Carp includes the name of the program that generated the error or +warning in the messages written to the log and the browser window. +Sometimes, Perl can get confused about what the actual name of the +executed program was. In these cases, you can override the program +name that CGI::Carp will use for all messages. + +The quick way to do that is to tell CGI::Carp the name of the program +in its use statement. You can do that by adding +"name=cgi_carp_log_name" to your "use" statement. For example: + + use CGI::Carp qw(name=cgi_carp_log_name); + +. If you want to change the program name partway through the program, +you can use the C<set_progname()> function instead. It is not +exported by default, you must import it explicitly by saying + + use CGI::Carp qw(set_progname); + +Once you've done that, you can change the logged name of the program +at any time by calling + + set_progname(new_program_name); + +You can set the program back to the default by calling + + set_progname(undef); + +Note that this override doesn't happen until after the program has +compiled, so any compile-time errors will still show up with the +non-overridden program name + +=head1 TURNING OFF TIMESTAMPS IN MESSAGES + +If your web server automatically adds a timestamp to each log line, +you may not need CGI::Carp to add its own. You can disable timestamping +by importing "noTimestamp": + + use CGI::Carp qw(noTimestamp); + +Alternatively you can set C<$CGI::Carp::NO_TIMESTAMP> to 1. + +Note that the name of the program is still automatically included in +the message. + +=head1 GETTING THE FULL PATH OF THE SCRIPT IN MESSAGES + +Set C<$CGI::Carp::FULL_PATH> to 1. + +=head1 AUTHOR INFORMATION + +The CGI.pm distribution is copyright 1995-2007, Lincoln D. Stein. It is +distributed under GPL and the Artistic License 2.0. It is currently +maintained by Lee Johnson with help from many contributors. + +Address bug reports and comments to: https://github.com/leejo/CGI.pm/issues + +The original bug tracker can be found at: https://rt.cpan.org/Public/Dist/Display.html?Queue=CGI.pm + +When sending bug reports, please provide the version of CGI.pm, the version of +Perl, the name and version of your Web server, and the name and version of the +operating system you are using. If the problem is even remotely browser +dependent, please provide information about the affected browsers as well. + +=head1 SEE ALSO + +L<Carp>, L<CGI::Base>, L<CGI::BasePlus>, L<CGI::Request>, +L<CGI::MiniSvr>, L<CGI::Form>, L<CGI::Response>. + +=cut + +require 5.000; +use Exporter; +#use Carp; +BEGIN { + require Carp; + *CORE::GLOBAL::die = \&CGI::Carp::die; +} + +use File::Spec; + +@ISA = qw(Exporter); +@EXPORT = qw(confess croak carp); +@EXPORT_OK = qw(carpout fatalsToBrowser warningsToBrowser wrap noTimestamp set_message set_die_handler set_progname cluck ^name= die); + +$main::SIG{__WARN__}=\&CGI::Carp::warn; + +$CGI::Carp::VERSION = '4.21'; +$CGI::Carp::CUSTOM_MSG = undef; +$CGI::Carp::DIE_HANDLER = undef; +$CGI::Carp::TO_BROWSER = 1; +$CGI::Carp::NO_TIMESTAMP= 0; +$CGI::Carp::FULL_PATH = 0; + +# fancy import routine detects and handles 'errorWrap' specially. +sub import { + my $pkg = shift; + my(%routines); + my(@name); + if (@name=grep(/^name=/,@_)) + { + my($n) = (split(/=/,$name[0]))[1]; + set_progname($n); + @_=grep(!/^name=/,@_); + } + + grep($routines{$_}++,@_,@EXPORT); + $WRAP++ if $routines{'fatalsToBrowser'} || $routines{'wrap'}; + $WARN++ if $routines{'warningsToBrowser'}; + my($oldlevel) = $Exporter::ExportLevel; + $Exporter::ExportLevel = 1; + Exporter::import($pkg,keys %routines); + $Exporter::ExportLevel = $oldlevel; + $main::SIG{__DIE__} =\&CGI::Carp::die if $routines{'fatalsToBrowser'}; + $CGI::Carp::NO_TIMESTAMP = 1 if $routines{'noTimestamp'}; +} + +# These are the originals +sub realwarn { CORE::warn(@_); } +sub realdie { CORE::die(@_); } + +sub id { + my $level = shift; + my($pack,$file,$line,$sub) = caller($level); + my($dev,$dirs,$id) = File::Spec->splitpath($file); + return ($file,$line,$id); +} + +sub stamp { + my $frame = 0; + my ($id,$pack,$file,$dev,$dirs); + if (defined($CGI::Carp::PROGNAME)) { + $id = $CGI::Carp::PROGNAME; + } else { + do { + $id = $file; + ($pack,$file) = caller($frame++); + } until !$file; + } + if (! $CGI::Carp::FULL_PATH) { + ($dev,$dirs,$id) = File::Spec->splitpath($id); + } + return "$id: " if $CGI::Carp::NO_TIMESTAMP; + my $time = scalar(localtime); + return "[$time] $id: "; +} + +sub set_progname { + $CGI::Carp::PROGNAME = shift; + return $CGI::Carp::PROGNAME; +} + + +sub warn { + my $message = shift; + my($file,$line,$id) = id(1); + $message .= " at $file line $line.\n" unless $message=~/\n$/; + _warn($message) if $WARN; + my $stamp = stamp; + $message=~s/^/$stamp/gm; + realwarn $message; +} + +sub _warn { + my $msg = shift; + if ($EMIT_WARNINGS) { + # We need to mangle the message a bit to make it a valid HTML + # comment. This is done by substituting similar-looking ISO + # 8859-1 characters for <, > and -. This is a hack. + $msg =~ tr/<>-/\253\273\255/; + chomp $msg; + print STDOUT "<!-- warning: $msg -->\n"; + } else { + push @WARNINGS, $msg; + } +} + + +# The mod_perl package Apache::Registry loads CGI programs by calling +# eval. These evals don't count when looking at the stack backtrace. +sub _longmess { + my $message = Carp::longmess(); + $message =~ s,eval[^\n]+(ModPerl|Apache)/(?:Registry|Dispatch)\w*\.pm.*,,s + if exists $ENV{MOD_PERL}; + return $message; +} + +sub ineval { + (exists $ENV{MOD_PERL} ? 0 : $^S) || _longmess() =~ /eval [\{\']/m +} + +sub die { + # if no argument is passed, propagate $@ like + # the real die + my ($arg,@rest) = @_ ? @_ + : $@ ? "$@\t...propagated" + : "Died" + ; + + &$DIE_HANDLER($arg,@rest) if $DIE_HANDLER; + + # the "$arg" is done on purpose! + # if called as die( $object, 'string' ), + # all is stringified, just like with + # the real 'die' + $arg = join '' => "$arg", @rest if @rest; + + my($file,$line,$id) = id(1); + + $arg .= " at $file line $line.\n" unless ref $arg or $arg=~/\n$/; + + realdie $arg if ineval(); + &fatalsToBrowser($arg) if ($WRAP and $CGI::Carp::TO_BROWSER); + + $arg=~s/^/ stamp() /gme if $arg =~ /\n$/ or not exists $ENV{MOD_PERL}; + + $arg .= "\n" unless $arg =~ /\n$/; + + realdie $arg; +} + +sub set_message { + $CGI::Carp::CUSTOM_MSG = shift; + return $CGI::Carp::CUSTOM_MSG; +} + +sub set_die_handler { + + my ($handler) = shift; + + #setting SIG{__DIE__} here is necessary to catch runtime + #errors which are not called by literally saying "die", + #such as the line "undef->explode();". however, doing this + #will interfere with fatalsToBrowser, which also sets + #SIG{__DIE__} in the import() function above (or the + #import() function above may interfere with this). for + #this reason, you should choose to either set the die + #handler here, or use fatalsToBrowser, not both. + $main::SIG{__DIE__} = $handler; + + $CGI::Carp::DIE_HANDLER = $handler; + + return $CGI::Carp::DIE_HANDLER; +} + +sub confess { CGI::Carp::die Carp::longmess @_; } +sub croak { CGI::Carp::die Carp::shortmess @_; } +sub carp { CGI::Carp::warn Carp::shortmess @_; } +sub cluck { CGI::Carp::warn Carp::longmess @_; } + +# We have to be ready to accept a filehandle as a reference +# or a string. +sub carpout { + my($in) = @_; + my($no) = fileno(to_filehandle($in)); + realdie("Invalid filehandle $in\n") unless defined $no; + + open(SAVEERR, ">&STDERR"); + open(STDERR, ">&$no") or + ( print SAVEERR "Unable to redirect >&$no: $!\n" and exit(1) ); +} + +sub warningsToBrowser { + $EMIT_WARNINGS = @_ ? shift : 1; + _warn(shift @WARNINGS) while $EMIT_WARNINGS and @WARNINGS; +} + +# headers +sub fatalsToBrowser { + my $msg = shift; + + $msg = "$msg" if ref $msg; + + $msg=~s/&/&/g; + $msg=~s/>/>/g; + $msg=~s/</</g; + $msg=~s/"/"/g; + + my($wm) = $ENV{SERVER_ADMIN} ? + qq[the webmaster (<a href="mailto:$ENV{SERVER_ADMIN}">$ENV{SERVER_ADMIN}</a>)] : + "this site's webmaster"; + my ($outer_message) = <<END; +For help, please send mail to $wm, giving this error message +and the time and date of the error. +END + ; + my $mod_perl = exists $ENV{MOD_PERL}; + + if ($CUSTOM_MSG) { + if (ref($CUSTOM_MSG) eq 'CODE') { + print STDOUT "Content-type: text/html\n\n" + unless $mod_perl; + eval { + &$CUSTOM_MSG($msg); # nicer to perl 5.003 users + }; + if ($@) { print STDERR qq(error while executing the error handler: $@); } + + return; + } else { + $outer_message = $CUSTOM_MSG; + } + } + + my $mess = <<END; +<h1>Software error:</h1> +<pre>$msg</pre> +<p> +$outer_message +</p> +END + ; + + if ($mod_perl) { + my $r; + if ($ENV{MOD_PERL_API_VERSION} && $ENV{MOD_PERL_API_VERSION} == 2) { + $mod_perl = 2; + require Apache2::RequestRec; + require Apache2::RequestIO; + require Apache2::RequestUtil; + require APR::Pool; + require ModPerl::Util; + require Apache2::Response; + $r = Apache2::RequestUtil->request; + } + else { + $r = Apache->request; + } + # If bytes have already been sent, then + # we print the message out directly. + # Otherwise we make a custom error + # handler to produce the doc for us. + if ($r->bytes_sent) { + $r->print($mess); + $mod_perl == 2 ? ModPerl::Util::exit(0) : $r->exit; + } else { + # MSIE won't display a custom 500 response unless it is >512 bytes! + if (defined($ENV{HTTP_USER_AGENT}) && $ENV{HTTP_USER_AGENT} =~ /MSIE/) { + $mess = "<!-- " . (' ' x 513) . " -->\n$mess"; + } + $r->custom_response(500,$mess); + } + } else { + my $bytes_written = eval{tell STDOUT}; + if (defined $bytes_written && $bytes_written > 0) { + print STDOUT $mess; + } + else { + print STDOUT "Status: 500\n"; + print STDOUT "Content-type: text/html\n\n"; + # MSIE won't display a custom 500 response unless it is >512 bytes! + if (defined($ENV{HTTP_USER_AGENT}) && $ENV{HTTP_USER_AGENT} =~ /MSIE/) { + $mess = "<!-- " . (' ' x 513) . " -->\n$mess"; + } + print STDOUT $mess; + } + } + + warningsToBrowser(1); # emit warnings before dying +} + +# Cut and paste from CGI.pm so that we don't have the overhead of +# always loading the entire CGI module. +sub to_filehandle { + my $thingy = shift; + return undef unless $thingy; + return $thingy if UNIVERSAL::isa($thingy,'GLOB'); + return $thingy if UNIVERSAL::isa($thingy,'FileHandle'); + if (!ref($thingy)) { + my $caller = 1; + while (my $package = caller($caller++)) { + my($tmp) = $thingy=~/[\':]/ ? $thingy : "$package\:\:$thingy"; + return $tmp if defined(fileno($tmp)); + } + } + return undef; +} + +1; diff --git a/lib/CGI/Cookie.pm b/lib/CGI/Cookie.pm new file mode 100644 index 0000000..d403b95 --- /dev/null +++ b/lib/CGI/Cookie.pm @@ -0,0 +1,537 @@ +package CGI::Cookie; + +use strict; +use warnings; + +use if $] >= 5.019, 'deprecate'; + +our $VERSION='4.21'; + +use CGI::Util qw(rearrange unescape escape); +use overload '""' => \&as_string, 'cmp' => \&compare, 'fallback' => 1; + +my $PERLEX = 0; +# Turn on special checking for ActiveState's PerlEx +$PERLEX++ if defined($ENV{'GATEWAY_INTERFACE'}) && $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-PerlEx/; + +# Turn on special checking for mod_perl +# PerlEx::DBI tries to fool DBI by setting MOD_PERL +my $MOD_PERL = 0; +if (exists $ENV{MOD_PERL} && ! $PERLEX) { + if (exists $ENV{MOD_PERL_API_VERSION} && $ENV{MOD_PERL_API_VERSION} == 2) { + $MOD_PERL = 2; + require Apache2::RequestUtil; + require APR::Table; + } else { + $MOD_PERL = 1; + require Apache; + } +} + +# fetch a list of cookies from the environment and +# return as a hash. the cookies are parsed as normal +# escaped URL data. +sub fetch { + my $class = shift; + my $raw_cookie = get_raw_cookie(@_) or return; + return $class->parse($raw_cookie); +} + +# Fetch a list of cookies from the environment or the incoming headers and +# return as a hash. The cookie values are not unescaped or altered in any way. + sub raw_fetch { + my $class = shift; + my $raw_cookie = get_raw_cookie(@_) or return; + my %results; + my($key,$value); + + my @pairs = split("[;,] ?",$raw_cookie); + for my $pair ( @pairs ) { + $pair =~ s/^\s+|\s+$//g; # trim leading trailing whitespace + my ( $key, $value ) = split "=", $pair; + + $value = defined $value ? $value : ''; + $results{$key} = $value; + } + return wantarray ? %results : \%results; +} + +sub get_raw_cookie { + my $r = shift; + $r ||= eval { $MOD_PERL == 2 ? + Apache2::RequestUtil->request() : + Apache->request } if $MOD_PERL; + + return $r->headers_in->{'Cookie'} if $r; + + die "Run $r->subprocess_env; before calling fetch()" + if $MOD_PERL and !exists $ENV{REQUEST_METHOD}; + + return $ENV{HTTP_COOKIE} || $ENV{COOKIE}; +} + + +sub parse { + my ($self,$raw_cookie) = @_; + return wantarray ? () : {} unless $raw_cookie; + + my %results; + + my @pairs = split("[;,] ?",$raw_cookie); + for (@pairs) { + s/^\s+//; + s/\s+$//; + + my($key,$value) = split("=",$_,2); + + # Some foreign cookies are not in name=value format, so ignore + # them. + next if !defined($value); + my @values = (); + if ($value ne '') { + @values = map unescape($_),split(/[&;]/,$value.'&dmy'); + pop @values; + } + $key = unescape($key); + # A bug in Netscape can cause several cookies with same name to + # appear. The FIRST one in HTTP_COOKIE is the most recent version. + $results{$key} ||= $self->new(-name=>$key,-value=>\@values); + } + return wantarray ? %results : \%results; +} + +sub new { + my ( $class, @params ) = @_; + $class = ref( $class ) || $class; + # Ignore mod_perl request object--compatibility with Apache::Cookie. + shift if ref $params[0] + && eval { $params[0]->isa('Apache::Request::Req') || $params[0]->isa('Apache') }; + my ( $name, $value, $path, $domain, $secure, $expires, $max_age, $httponly ) + = rearrange( + [ + 'NAME', [ 'VALUE', 'VALUES' ], + 'PATH', 'DOMAIN', + 'SECURE', 'EXPIRES', + 'MAX-AGE','HTTPONLY' + ], + @params + ); + return undef unless defined $name and defined $value; + my $self = {}; + bless $self, $class; + $self->name( $name ); + $self->value( $value ); + $path ||= "/"; + $self->path( $path ) if defined $path; + $self->domain( $domain ) if defined $domain; + $self->secure( $secure ) if defined $secure; + $self->expires( $expires ) if defined $expires; + $self->max_age( $max_age ) if defined $max_age; + $self->httponly( $httponly ) if defined $httponly; + return $self; +} + +sub as_string { + my $self = shift; + return "" unless $self->name; + + no warnings; # some things may be undefined, that's OK. + + my $name = escape( $self->name ); + my $value = join "&", map { escape($_) } $self->value; + my @cookie = ( "$name=$value" ); + + push @cookie,"domain=".$self->domain if $self->domain; + push @cookie,"path=".$self->path if $self->path; + push @cookie,"expires=".$self->expires if $self->expires; + push @cookie,"max-age=".$self->max_age if $self->max_age; + push @cookie,"secure" if $self->secure; + push @cookie,"HttpOnly" if $self->httponly; + + return join "; ", @cookie; +} + +sub compare { + my ( $self, $value ) = @_; + return "$self" cmp $value; +} + +sub bake { + my ($self, $r) = @_; + + $r ||= eval { + $MOD_PERL == 2 + ? Apache2::RequestUtil->request() + : Apache->request + } if $MOD_PERL; + if ($r) { + $r->headers_out->add('Set-Cookie' => $self->as_string); + } else { + require CGI; + print CGI::header(-cookie => $self); + } + +} + +# accessors +sub name { + my ( $self, $name ) = @_; + $self->{'name'} = $name if defined $name; + return $self->{'name'}; +} + +sub value { + my ( $self, $value ) = @_; + if ( defined $value ) { + my @values + = ref $value eq 'ARRAY' ? @$value + : ref $value eq 'HASH' ? %$value + : ( $value ); + $self->{'value'} = [@values]; + } + return wantarray ? @{ $self->{'value'} } : $self->{'value'}->[0]; +} + +sub domain { + my ( $self, $domain ) = @_; + $self->{'domain'} = lc $domain if defined $domain; + return $self->{'domain'}; +} + +sub secure { + my ( $self, $secure ) = @_; + $self->{'secure'} = $secure if defined $secure; + return $self->{'secure'}; +} + +sub expires { + my ( $self, $expires ) = @_; + $self->{'expires'} = CGI::Util::expires($expires,'cookie') if defined $expires; + return $self->{'expires'}; +} + +sub max_age { + my ( $self, $max_age ) = @_; + $self->{'max-age'} = CGI::Util::expire_calc($max_age)-time() if defined $max_age; + return $self->{'max-age'}; +} + +sub path { + my ( $self, $path ) = @_; + $self->{'path'} = $path if defined $path; + return $self->{'path'}; +} + + +sub httponly { # HttpOnly + my ( $self, $httponly ) = @_; + $self->{'httponly'} = $httponly if defined $httponly; + return $self->{'httponly'}; +} + +1; + +=head1 NAME + +CGI::Cookie - Interface to HTTP Cookies + +=head1 SYNOPSIS + + use CGI qw/:standard/; + use CGI::Cookie; + + # Create new cookies and send them + $cookie1 = CGI::Cookie->new(-name=>'ID',-value=>123456); + $cookie2 = CGI::Cookie->new(-name=>'preferences', + -value=>{ font => Helvetica, + size => 12 } + ); + print header(-cookie=>[$cookie1,$cookie2]); + + # fetch existing cookies + %cookies = CGI::Cookie->fetch; + $id = $cookies{'ID'}->value; + + # create cookies returned from an external source + %cookies = CGI::Cookie->parse($ENV{COOKIE}); + +=head1 DESCRIPTION + +CGI::Cookie is an interface to HTTP/1.1 cookies, a mechanism +that allows Web servers to store persistent information on +the browser's side of the connection. Although CGI::Cookie is +intended to be used in conjunction with CGI.pm (and is in fact used by +it internally), you can use this module independently. + +For full information on cookies see + + https://tools.ietf.org/html/rfc6265 + +=head1 USING CGI::Cookie + +CGI::Cookie is object oriented. Each cookie object has a name and a +value. The name is any scalar value. The value is any scalar or +array value (associative arrays are also allowed). Cookies also have +several optional attributes, including: + +=over 4 + +=item B<1. expiration date> + +The expiration date tells the browser how long to hang on to the +cookie. If the cookie specifies an expiration date in the future, the +browser will store the cookie information in a disk file and return it +to the server every time the user reconnects (until the expiration +date is reached). If the cookie species an expiration date in the +past, the browser will remove the cookie from the disk file. If the +expiration date is not specified, the cookie will persist only until +the user quits the browser. + +=item B<2. domain> + +This is a partial or complete domain name for which the cookie is +valid. The browser will return the cookie to any host that matches +the partial domain name. For example, if you specify a domain name +of ".capricorn.com", then the browser will return the cookie to +Web servers running on any of the machines "www.capricorn.com", +"ftp.capricorn.com", "feckless.capricorn.com", etc. Domain names +must contain at least two periods to prevent attempts to match +on top level domains like ".edu". If no domain is specified, then +the browser will only return the cookie to servers on the host the +cookie originated from. + +=item B<3. path> + +If you provide a cookie path attribute, the browser will check it +against your script's URL before returning the cookie. For example, +if you specify the path "/cgi-bin", then the cookie will be returned +to each of the scripts "/cgi-bin/tally.pl", "/cgi-bin/order.pl", and +"/cgi-bin/customer_service/complain.pl", but not to the script +"/cgi-private/site_admin.pl". By default, the path is set to "/", so +that all scripts at your site will receive the cookie. + +=item B<4. secure flag> + +If the "secure" attribute is set, the cookie will only be sent to your +script if the CGI request is occurring on a secure channel, such as SSL. + +=item B<5. httponly flag> + +If the "httponly" attribute is set, the cookie will only be accessible +through HTTP Requests. This cookie will be inaccessible via JavaScript +(to prevent XSS attacks). + +This feature is supported by nearly all modern browsers. + +See these URLs for more information: + + http://msdn.microsoft.com/en-us/library/ms533046.aspx + http://www.browserscope.org/?category=security&v=top + +=back + +=head2 Creating New Cookies + + my $c = CGI::Cookie->new(-name => 'foo', + -value => 'bar', + -expires => '+3M', + '-max-age' => '+3M', + -domain => '.capricorn.com', + -path => '/cgi-bin/database', + -secure => 1 + ); + +Create cookies from scratch with the B<new> method. The B<-name> and +B<-value> parameters are required. The name must be a scalar value. +The value can be a scalar, an array reference, or a hash reference. +(At some point in the future cookies will support one of the Perl +object serialization protocols for full generality). + +B<-expires> accepts any of the relative or absolute date formats +recognized by CGI.pm, for example "+3M" for three months in the +future. See CGI.pm's documentation for details. + +B<-max-age> accepts the same data formats as B<< -expires >>, but sets a +relative value instead of an absolute like B<< -expires >>. This is intended to be +more secure since a clock could be changed to fake an absolute time. In +practice, as of 2011, C<< -max-age >> still does not enjoy the widespread support +that C<< -expires >> has. You can set both, and browsers that support +C<< -max-age >> should ignore the C<< Expires >> header. The drawback +to this approach is the bit of bandwidth for sending an extra header on each cookie. + +B<-domain> points to a domain name or to a fully qualified host name. +If not specified, the cookie will be returned only to the Web server +that created it. + +B<-path> points to a partial URL on the current server. The cookie +will be returned to all URLs beginning with the specified path. If +not specified, it defaults to '/', which returns the cookie to all +pages at your site. + +B<-secure> if set to a true value instructs the browser to return the +cookie only when a cryptographic protocol is in use. + +B<-httponly> if set to a true value, the cookie will not be accessible +via JavaScript. + +For compatibility with Apache::Cookie, you may optionally pass in +a mod_perl request object as the first argument to C<new()>. It will +simply be ignored: + + my $c = CGI::Cookie->new($r, + -name => 'foo', + -value => ['bar','baz']); + +=head2 Sending the Cookie to the Browser + +The simplest way to send a cookie to the browser is by calling the bake() +method: + + $c->bake; + +This will print the Set-Cookie HTTP header to STDOUT using CGI.pm. CGI.pm +will be loaded for this purpose if it is not already. Otherwise CGI.pm is not +required or used by this module. + +Under mod_perl, pass in an Apache request object: + + $c->bake($r); + +If you want to set the cookie yourself, Within a CGI script you can send +a cookie to the browser by creating one or more Set-Cookie: fields in the +HTTP header. Here is a typical sequence: + + my $c = CGI::Cookie->new(-name => 'foo', + -value => ['bar','baz'], + -expires => '+3M'); + + print "Set-Cookie: $c\n"; + print "Content-Type: text/html\n\n"; + +To send more than one cookie, create several Set-Cookie: fields. + +If you are using CGI.pm, you send cookies by providing a -cookie +argument to the header() method: + + print header(-cookie=>$c); + +Mod_perl users can set cookies using the request object's header_out() +method: + + $r->headers_out->set('Set-Cookie' => $c); + +Internally, Cookie overloads the "" operator to call its as_string() +method when incorporated into the HTTP header. as_string() turns the +Cookie's internal representation into an RFC-compliant text +representation. You may call as_string() yourself if you prefer: + + print "Set-Cookie: ",$c->as_string,"\n"; + +=head2 Recovering Previous Cookies + + %cookies = CGI::Cookie->fetch; + +B<fetch> returns an associative array consisting of all cookies +returned by the browser. The keys of the array are the cookie names. You +can iterate through the cookies this way: + + %cookies = CGI::Cookie->fetch; + for (keys %cookies) { + do_something($cookies{$_}); + } + +In a scalar context, fetch() returns a hash reference, which may be more +efficient if you are manipulating multiple cookies. + +CGI.pm uses the URL escaping methods to save and restore reserved characters +in its cookies. If you are trying to retrieve a cookie set by a foreign server, +this escaping method may trip you up. Use raw_fetch() instead, which has the +same semantics as fetch(), but performs no unescaping. + +You may also retrieve cookies that were stored in some external +form using the parse() class method: + + $COOKIES = `cat /usr/tmp/Cookie_stash`; + %cookies = CGI::Cookie->parse($COOKIES); + +If you are in a mod_perl environment, you can save some overhead by +passing the request object to fetch() like this: + + CGI::Cookie->fetch($r); + +If the value passed to parse() is undefined, an empty array will returned in list +context, and an empty hashref will be returned in scalar context. + +=head2 Manipulating Cookies + +Cookie objects have a series of accessor methods to get and set cookie +attributes. Each accessor has a similar syntax. Called without +arguments, the accessor returns the current value of the attribute. +Called with an argument, the accessor changes the attribute and +returns its new value. + +=over 4 + +=item B<name()> + +Get or set the cookie's name. Example: + + $name = $c->name; + $new_name = $c->name('fred'); + +=item B<value()> + +Get or set the cookie's value. Example: + + $value = $c->value; + @new_value = $c->value(['a','b','c','d']); + +B<value()> is context sensitive. In a list context it will return +the current value of the cookie as an array. In a scalar context it +will return the B<first> value of a multivalued cookie. + +=item B<domain()> + +Get or set the cookie's domain. + +=item B<path()> + +Get or set the cookie's path. + +=item B<expires()> + +Get or set the cookie's expiration time. + +=item B<max_age()> + +Get or set the cookie's max_age value. + +=back + + +=head1 AUTHOR INFORMATION + +The CGI.pm distribution is copyright 1995-2007, Lincoln D. Stein. It is +distributed under GPL and the Artistic License 2.0. It is currently +maintained by Lee Johnson with help from many contributors. + +Address bug reports and comments to: https://github.com/leejo/CGI.pm/issues + +The original bug tracker can be found at: https://rt.cpan.org/Public/Dist/Display.html?Queue=CGI.pm + +When sending bug reports, please provide the version of CGI.pm, the version of +Perl, the name and version of your Web server, and the name and version of the +operating system you are using. If the problem is even remotely browser +dependent, please provide information about the affected browsers as well. + +=head1 BUGS + +This section intentionally left blank. + +=head1 SEE ALSO + +L<CGI::Carp>, L<CGI> + +L<RFC 2109|http://www.ietf.org/rfc/rfc2109.txt>, L<RFC 2695|http://www.ietf.org/rfc/rfc2965.txt> + +=cut diff --git a/lib/CGI/File/Temp.pm b/lib/CGI/File/Temp.pm new file mode 100644 index 0000000..0c8136a --- /dev/null +++ b/lib/CGI/File/Temp.pm @@ -0,0 +1,39 @@ +# this is a back compatibility wrapper around File::Temp. DO NOT +# use this package outside of CGI, i won't provide any help if +# you use it directly and your code breaks horribly. +package CGI::File::Temp; + +$CGI::File::Temp::VERSION = '4.21'; + +use parent File::Temp; +use parent Fh; + +use overload + '""' => \&asString, + 'cmp' => \&compare, + 'fallback'=>1; + +# back compatibility method since we now return a File::Temp object +# as the filehandle (which isa IO::Handle) so calling ->handle on +# it will fail. FIXME: deprecate this method in v5+ +sub handle { return shift; }; + +sub compare { + my ( $self,$value ) = @_; + return "$self" cmp $value; +} + +sub _mp_filename { + my ( $self,$filename ) = @_; + ${*$self}->{ _mp_filename } = $filename + if $filename; + return ${*$self}->{_mp_filename}; +} + +sub asString { + my ( $self ) = @_; + return $self->_mp_filename; +} + +1; + diff --git a/lib/CGI/HTML/Functions.pm b/lib/CGI/HTML/Functions.pm new file mode 100644 index 0000000..e4983ca --- /dev/null +++ b/lib/CGI/HTML/Functions.pm @@ -0,0 +1,8 @@ +package CGI::HTML::Functions; + +use strict; +use warnings; + +# nothing here yet... may move functions here in the long term + +1; diff --git a/lib/CGI/HTML/Functions.pod b/lib/CGI/HTML/Functions.pod new file mode 100644 index 0000000..8c00c27 --- /dev/null +++ b/lib/CGI/HTML/Functions.pod @@ -0,0 +1,1927 @@ +=head1 NAME + +CGI::HTML::Functions - Documentation for CGI.pm Legacy HTML Functionality + +=head1 SYNOPSIS + +Nothing here - please do not use this functionality, it is considered to +be legacy and essentially deprecated. This documentation exists solely to +aid in maintenance and migration of legacy code using this functionality. + +This functionality is likely to be removed in future versions of CGI.pm so +you are strongly encouraged to migrate away from it. If you are working +on new code you should be using a template engine. For more information see +L<CGI::Alternatives>. + +=head1 DESCRIPTION + +The documentation here should be considered an addendum to the sections in the +L<CGI> documentation - the sections here are named the same as those within the +CGI perldoc. + +=head1 Calling CGI.pm routines + +HTML tag functions have both attributes (the attribute="value" pairs within the +tag itself) and contents (the part between the opening and closing pairs). To +distinguish between attributes and contents, CGI.pm uses the convention of +passing HTML attributes as a hash reference as the first argument, and the +contents, if any, as any subsequent arguments. It works out like +this: + + Code Generated HTML + ---- -------------- + h1() <h1 /> + h1('some','contents'); <h1>some contents</h1> + h1({-align=>left}); <h1 align="LEFT"> + h1({-align=>left},'contents'); <h1 align="LEFT">contents</h1> + +Many newcomers to CGI.pm are puzzled by the difference between the calling +conventions for the HTML shortcuts, which require curly braces around the HTML +tag attributes, and the calling conventions for other routines, which manage +to generate attributes without the curly brackets. Don't be confused. As a +convenience the curly braces are optional in all but the HTML shortcuts. If you +like, you can use curly braces when calling any routine that takes named +arguments. For example: + + print $q->header( { -type => 'image/gif', -expires => '+3d' } ); + +If you use warnings, you will be warned that some CGI.pm argument names +conflict with built-in perl functions. The most frequent of these is the +-values argument, used to create multi-valued menus, radio button clusters +and the like. To get around this warning, you have several choices: + +=over 4 + +=item 1. + +Use another name for the argument, if one is available. +For example, -value is an alias for -values. + +=item 2. + +Change the capitalization, e.g. -Values + +=item 3. + +Put quotes around the argument name, e.g. '-values' + +=back + +=head2 Function-oriented interface HTML exports + +Here is a list of the HTML related function sets you can import: + +=over 4 + +=item B<:form> + +Import all fill-out form generating methods, such as B<textfield()>. + +=item B<:html2> + +Import all methods that generate HTML 2.0 standard elements. + +=item B<:html3> + +Import all methods that generate HTML 3.0 elements (such as +<table>, <super> and <sub>). + +=item B<:html4> + +Import all methods that generate HTML 4 elements (such as +<abbrev>, <acronym> and <thead>). + +=item B<:netscape> + +Import the <blink>, <fontsize> and <center> tags. + +=item B<:html> + +Import all HTML-generating shortcuts (i.e. 'html2', 'html3', 'html4' and 'netscape') + +=item B<:standard> + +Import "standard" features, 'html2', 'html3', 'html4', 'ssl', 'form' and 'cgi'. + +=back + +If you import any of the state-maintaining CGI or form-generating methods, +a default CGI object will be created and initialized automatically the first +time you use any of the methods that require one to be present. This includes +B<param()>, B<textfield()>, B<submit()> and the like. (If you need direct access +to the CGI object, you can find it in the global variable B<$CGI::Q>). + +=head2 Pragmas + +Additional HTML generation related pragms: + +=over 4 + +=item -nosticky + +By default the CGI module implements a state-preserving behavior called +"sticky" fields. The way this works is that if you are regenerating a form, +the methods that generate the form field values will interrogate param() +to see if similarly-named parameters are present in the query string. If +they find a like-named parameter, they will use it to set their default values. + +Sometimes this isn't what you want. The B<-nosticky> pragma prevents this +behavior. You can also selectively change the sticky behavior in each element +that you generate. + +=item -tabindex + +Automatically add tab index attributes to each form field. With this option +turned off, you can still add tab indexes manually by passing a -tabindex +option to each field-generating method. + +=item -no_xhtml + +By default, CGI.pm versions 2.69 and higher emit XHTML +(http://www.w3.org/TR/xhtml1/). The -no_xhtml pragma disables this feature. +Thanks to Michalis Kabrianis <kabrianis@hellug.gr> for this feature. + +If start_html()'s -dtd parameter specifies an HTML 2.0, 3.2, 4.0 or 4.01 DTD, +XHTML will automatically be disabled without needing to use this pragma. + +=back + +=head2 Special forms for importing HTML-tag functions + +Many of the methods generate HTML tags. As described below, tag functions +automatically generate both the opening and closing tags. For example: + + print h1('Level 1 Header'); + +produces + + <h1>Level 1 Header</h1> + +There will be some times when you want to produce the start and end tags +yourself. In this case, you can use the form start_I<tag_name> and +end_I<tag_name>, as in: + + print start_h1,'Level 1 Header',end_h1; + +=head2 Creating the HTML document header + + print start_html( + -title => 'Secrets of the Pyramids', + -author => 'fred@capricorn.org', + -base => 'true', + -target => '_blank', + -meta => {'keywords'=>'pharaoh secret mummy', + 'copyright' => 'copyright 1996 King Tut'}, + -style => {'src'=>'/styles/style1.css'}, + -BGCOLOR => 'blue' + ); + +The start_html() routine creates the top of the page, along with a lot of +optional information that controls the page's appearance and behavior. + +This method returns a canned HTML header and the opening <body> tag. All +parameters are optional. In the named parameter form, recognized parameters +are -title, -author, -base, -xbase, -dtd, -lang and -target (see below for the +explanation). Any additional parameters you provide, such as the unofficial +BGCOLOR attribute, are added to the <body> tag. Additional parameters must be +proceeded by a hyphen. + +The argument B<-xbase> allows you to provide an HREF for the <base> tag different +from the current location, as in + + -xbase => "http://home.mcom.com/" + +All relative links will be interpreted relative to this tag. + +The argument B<-target> allows you to provide a default target frame for all the +links and fill-out forms on the page. B<This is a non-standard HTTP feature> +B<which only works with some browsers!> + + -target => "answer_window" + +All relative links will be interpreted relative to this tag. You add arbitrary +meta information to the header with the B<-meta> argument. This argument expects +a reference to a hash containing name/value pairs of meta information. These will +be turned into a series of header <meta> tags that look something like this: + + <meta name="keywords" content="pharaoh secret mummy"> + <meta name="description" content="copyright 1996 King Tut"> + +To create an HTTP-EQUIV type of <meta> tag, use B<-head>, described below. + +The B<-style> argument is used to incorporate cascading stylesheets into your +code. See the section on CASCADING STYLESHEETS for more information. + +The B<-lang> argument is used to incorporate a language attribute into the <html> +tag. For example: + + print $q->start_html( -lang => 'fr-CA' ); + +The default if not specified is "en-US" for US English, unless the -dtd parameter +specifies an HTML 2.0 or 3.2 DTD, in which case the lang attribute is left off. +You can force the lang attribute to left off in other cases by passing an empty +string (-lang=>''). + +The B<-encoding> argument can be used to specify the character set for XHTML. It +defaults to iso-8859-1 if not specified. + +The B<-dtd> argument can be used to specify a public DTD identifier string. For +example: + + -dtd => '-//W3C//DTD HTML 4.01 Transitional//EN') + +Alternatively, it can take public and system DTD identifiers as an array: + + -dtd => [ + '-//W3C//DTD HTML 4.01 Transitional//EN', + 'http://www.w3.org/TR/html4/loose.dtd' + ] + +For the public DTD identifier to be considered, it must be valid. Otherwise it +will be replaced by the default DTD. If the public DTD contains 'XHTML', CGI.pm +will emit XML. + +The B<-declare_xml> argument, when used in conjunction with XHTML, will put a +<?xml> declaration at the top of the HTML header. The sole purpose of this +declaration is to declare the character set encoding. In the absence of +-declare_xml, the output HTML will contain a <meta> tag that specifies the +encoding, allowing the HTML to pass most validators. The default for -declare_xml +is false. + +You can place other arbitrary HTML elements to the <head> section with the +B<-head> tag. For example, to place a <link> element in the head section, use +this: + + print start_html( + -head => Link({ + -rel => 'shortcut icon', + -href => 'favicon.ico' + }) + ); + +To incorporate multiple HTML elements into the <head> section, just pass an +array reference: + + print start_html( + -head => [ + Link({ + -rel => 'next', + -href => 'http://www.capricorn.com/s2.html' + }), + Link({ + -rel => 'previous', + -href => 'http://www.capricorn.com/s1.html' + }) + ] + ); + +And here's how to create an HTTP-EQUIV <meta> tag: + + print start_html( + -head => meta({ + -http_equiv => 'Content-Type', + -content => 'text/html' + }) + ); + + +JAVASCRIPTING: The B<-script>, B<-noScript>, B<-onLoad>, B<-onMouseOver>, +B<-onMouseOut> and B<-onUnload> parameters are used to add JavaScript calls to +your pages. B<-script> should point to a block of text containing JavaScript +function definitions. This block will be placed within a <script> block inside +the HTML (not HTTP) header. The block is placed in the header in order to give +your page a fighting chance of having all its JavaScript functions in place even +if the user presses the stop button before the page has loaded completely. CGI.pm +attempts to format the script in such a way that JavaScript-naive browsers will +not choke on the code: unfortunately there are some browsers that get confused by +it nevertheless. + +The B<-onLoad> and B<-onUnload> parameters point to fragments of JavaScript code +to execute when the page is respectively opened and closed by the browser. +Usually these parameters are calls to functions defined in the B<-script> field: + + $query = CGI->new; + print header; + $JSCRIPT = <<END; + // Ask a silly question + function riddle_me_this() { + var r = prompt( + "What walks on four legs in the morning, " + + "two legs in the afternoon, " + + "and three legs in the evening?" + ); + response(r); + } + // Get a silly answer + function response(answer) { + if (answer == "man") + alert("Right you are!"); + else + alert("Wrong! Guess again."); + } + END + print start_html( + -title => 'The Riddle of the Sphinx', + -script => $JSCRIPT + ); + +Use the B<-noScript> parameter to pass some HTML text that will be displayed on +browsers that do not have JavaScript (or browsers where JavaScript is turned +off). + +The <script> tag, has several attributes including "type", "charset" and "src". +"src" allows you to keep JavaScript code in an external file. To use these +attributes pass a HASH reference in the B<-script> parameter containing one or +more of -type, -src, or -code: + + print $q->start_html( + -title => 'The Riddle of the Sphinx', + -script => { + -type => 'JAVASCRIPT', + -src => '/javascript/sphinx.js'} + ); + + print $q->( + -title => 'The Riddle of the Sphinx', + -script => { + -type => 'PERLSCRIPT', + -code => 'print "hello world!\n;"' + } + ); + +A final feature allows you to incorporate multiple <script> sections into the +header. Just pass the list of script sections as an array reference. This allows +you to specify different source files for different dialects of JavaScript. +Example: + + print $q->start_html( + -title => 'The Riddle of the Sphinx', + -script => [ + { + -type => 'text/javascript', + -src => '/javascript/utilities10.js' + }, + { + -type => 'text/javascript', + -src => '/javascript/utilities11.js' + }, + { + -type => 'text/jscript', + -src => '/javascript/utilities12.js' + }, + { + -type => 'text/ecmascript', + -src => '/javascript/utilities219.js' + } + ] + ); + +The option "-language" is a synonym for -type, and is supported for backwards +compatibility. + +The old-style positional parameters are as follows: + +B<Parameters:> + +=over 4 + +=item 1. + +The title + +=item 2. + +The author's e-mail address (will create a <link rev="MADE"> tag if present + +=item 3. + +A 'true' flag if you want to include a <base> tag in the header. This helps +resolve relative addresses to absolute ones when the document is moved, but +makes the document hierarchy non-portable. Use with care! + +=back + +Other parameters you want to include in the <body> tag may be appended to these. +This is a good place to put HTML extensions, such as colors and wallpaper +patterns. + +=head2 Ending the Html document: + + print $q->end_html; + +This ends an HTML document by printing the </body></html> tags. + +=head1 CREATING STANDARD HTML ELEMENTS: + +CGI.pm defines general HTML shortcut methods for many HTML tags. HTML shortcuts are named after a single +HTML element and return a fragment of HTML text. Example: + + print $q->blockquote( + "Many years ago on the island of", + $q->a({href=>"http://crete.org/"},"Crete"), + "there lived a Minotaur named", + $q->strong("Fred."), + ), + $q->hr; + +This results in the following HTML code (extra newlines have been +added for readability): + + <blockquote> + Many years ago on the island of + <a href="http://crete.org/">Crete</a> there lived + a minotaur named <strong>Fred.</strong> + </blockquote> + <hr> + +If you find the syntax for calling the HTML shortcuts awkward, you can +import them into your namespace and dispense with the object syntax +completely (see the next section for more details): + + use CGI ':standard'; + print blockquote( + "Many years ago on the island of", + a({href=>"http://crete.org/"},"Crete"), + "there lived a minotaur named", + strong("Fred."), + ), + hr; + +=head2 Providing arguments to HTML shortcuts + +The HTML methods will accept zero, one or multiple arguments. If you +provide no arguments, you get a single tag: + + print hr; # <hr> + +If you provide one or more string arguments, they are concatenated +together with spaces and placed between opening and closing tags: + + print h1("Chapter","1"); # <h1>Chapter 1</h1>" + +If the first argument is a hash reference, then the keys +and values of the hash become the HTML tag's attributes: + + print a({-href=>'fred.html',-target=>'_new'}, + "Open a new frame"); + + <a href="fred.html",target="_new">Open a new frame</a> + +You may dispense with the dashes in front of the attribute names if +you prefer: + + print img {src=>'fred.gif',align=>'LEFT'}; + + <img align="LEFT" src="fred.gif"> + +Sometimes an HTML tag attribute has no argument. For example, ordered +lists can be marked as COMPACT. The syntax for this is an argument that +that points to an undef string: + + print ol({compact=>undef},li('one'),li('two'),li('three')); + +Prior to CGI.pm version 2.41, providing an empty ('') string as an +attribute argument was the same as providing undef. However, this has +changed in order to accommodate those who want to create tags of the form +<img alt="">. The difference is shown in these two pieces of code: + + CODE RESULT + img({alt=>undef}) <img alt> + img({alt=>''}) <img alt=""> + +=head2 The distributive property of HTML shortcuts + +One of the cool features of the HTML shortcuts is that they are +distributive. If you give them an argument consisting of a +B<reference> to a list, the tag will be distributed across each +element of the list. For example, here's one way to make an ordered +list: + + print ul( + li({-type=>'disc'},['Sneezy','Doc','Sleepy','Happy']) + ); + +This example will result in HTML output that looks like this: + + <ul> + <li type="disc">Sneezy</li> + <li type="disc">Doc</li> + <li type="disc">Sleepy</li> + <li type="disc">Happy</li> + </ul> + +This is extremely useful for creating tables. For example: + + print table({-border=>undef}, + caption('When Should You Eat Your Vegetables?'), + Tr({-align=>'CENTER',-valign=>'TOP'}, + [ + th(['Vegetable', 'Breakfast','Lunch','Dinner']), + td(['Tomatoes' , 'no', 'yes', 'yes']), + td(['Broccoli' , 'no', 'no', 'yes']), + td(['Onions' , 'yes','yes', 'yes']) + ] + ) + ); + +=head2 HTML shortcuts and list interpolation + +Consider this bit of code: + + print blockquote(em('Hi'),'mom!')); + +It will ordinarily return the string that you probably expect, namely: + + <blockquote><em>Hi</em> mom!</blockquote> + +Note the space between the element "Hi" and the element "mom!". +CGI.pm puts the extra space there using array interpolation, which is +controlled by the magic $" variable. Sometimes this extra space is +not what you want, for example, when you are trying to align a series +of images. In this case, you can simply change the value of $" to an +empty string. + + { + local($") = ''; + print blockquote(em('Hi'),'mom!')); + } + +I suggest you put the code in a block as shown here. Otherwise the +change to $" will affect all subsequent code until you explicitly +reset it. + +=head2 Non-standard HTML shortcuts + +A few HTML tags don't follow the standard pattern for various +reasons. + +B<comment()> generates an HTML comment (<!-- comment -->). Call it +like + + print comment('here is my comment'); + +Because of conflicts with built-in perl functions, the following functions +begin with initial caps: + + Select + Tr + Link + Delete + Accept + Sub + +In addition, start_html(), end_html(), start_form(), end_form(), +start_multipart_form() and all the fill-out form tags are special. +See their respective sections. + +=head2 Autoescaping HTML + +By default, all HTML that is emitted by the form-generating functions +is passed through a function called escapeHTML(): + +=over 4 + +=item $escaped_string = escapeHTML("unescaped string"); + +Escape HTML formatting characters in a string. Internally this calls +L<HTML::Entities> (encode_entities) so really you should just use that +instead - the default list of chars that will be encoded (passed to the +HTML::Entities encode_entities method) is: + + & < > " \x8b \x9b ' + +you can control this list by setting the value of $CGI::ENCODE_ENTITIES: + + # only encode < > + $CGI::ENCODE_ENTITIES = q{<>} + +if you want to encode B<all> entities then undef $CGI::ENCODE_ENTITIES: + + # encode all entities + $CGI::ENCODE_ENTITIES = undef; + +=back + +The automatic escaping does not apply to other shortcuts, such as +h1(). You should call escapeHTML() yourself on untrusted data in +order to protect your pages against nasty tricks that people may enter +into guestbooks, etc.. To change the character set, use charset(). +To turn autoescaping off completely, use autoEscape(0): + +=over 4 + +=item $charset = charset([$charset]); + +Get or set the current character set. + +=item $flag = autoEscape([$flag]); + +Get or set the value of the autoescape flag. + +=back + +=head1 CREATING FILL-OUT FORMS: + +I<General note> The various form-creating methods all return strings +to the caller, containing the tag or tags that will create the requested +form element. You are responsible for actually printing out these strings. +It's set up this way so that you can place formatting tags +around the form elements. + +I<Another note> The default values that you specify for the forms are only +used the B<first> time the script is invoked (when there is no query +string). On subsequent invocations of the script (when there is a query +string), the former values are used even if they are blank. + +If you want to change the value of a field from its previous value, you have two +choices: + +(1) call the param() method to set it. + +(2) use the -override (alias -force) parameter (a new feature in version 2.15). +This forces the default value to be used, regardless of the previous value: + + print textfield(-name=>'field_name', + -default=>'starting value', + -override=>1, + -size=>50, + -maxlength=>80); + +I<Yet another note> By default, the text and labels of form elements are +escaped according to HTML rules. This means that you can safely use +"<CLICK ME>" as the label for a button. However, it also interferes with +your ability to incorporate special HTML character sequences, such as Á, +into your fields. If you wish to turn off automatic escaping, call the +autoEscape() method with a false value immediately after creating the CGI object: + + $query = CGI->new; + $query->autoEscape(0); + +Note that autoEscape() is exclusively used to effect the behavior of how some +CGI.pm HTML generation functions handle escaping. Calling escapeHTML() +explicitly will always escape the HTML. + +I<A Lurking Trap!> Some of the form-element generating methods return +multiple tags. In a scalar context, the tags will be concatenated +together with spaces, or whatever is the current value of the $" +global. In a list context, the methods will return a list of +elements, allowing you to modify them if you wish. Usually you will +not notice this behavior, but beware of this: + + printf("%s\n",end_form()) + +end_form() produces several tags, and only the first of them will be +printed because the format only expects one value. + +<p> + + +=head2 Creating an isindex tag + + print isindex(-action=>$action); + + -or- + + print isindex($action); + +Prints out an <isindex> tag. Not very exciting. The parameter +-action specifies the URL of the script to process the query. The +default is to process the query with the current script. + +=head2 Starting and ending a form + + print start_form(-method=>$method, + -action=>$action, + -enctype=>$encoding); + <... various form stuff ...> + print end_form; + + -or- + + print start_form($method,$action,$encoding); + <... various form stuff ...> + print end_form; + +start_form() will return a <form> tag with the optional method, +action and form encoding that you specify. The defaults are: + + method: POST + action: this script + enctype: application/x-www-form-urlencoded for non-XHTML + multipart/form-data for XHTML, see multipart/form-data below. + +end_form() returns the closing </form> tag. + +start_form()'s enctype argument tells the browser how to package the various +fields of the form before sending the form to the server. Two +values are possible: + +=over 4 + +=item B<application/x-www-form-urlencoded> + +This is the older type of encoding. It is compatible with many CGI scripts and is +suitable for short fields containing text data. For your +convenience, CGI.pm stores the name of this encoding +type in B<&CGI::URL_ENCODED>. + +=item B<multipart/form-data> + +This is the newer type of encoding. +It is suitable for forms that contain very large fields or that +are intended for transferring binary data. Most importantly, +it enables the "file upload" feature. For +your convenience, CGI.pm stores the name of this encoding type +in B<&CGI::MULTIPART> + +Forms that use this type of encoding are not easily interpreted +by CGI scripts unless they use CGI.pm or another library designed +to handle them. + +If XHTML is activated (the default), then forms will be automatically +created using this type of encoding. + +=back + +The start_form() method uses the older form of encoding by +default unless XHTML is requested. If you want to use the +newer form of encoding by default, you can call +B<start_multipart_form()> instead of B<start_form()>. The +method B<end_multipart_form()> is an alias to B<end_form()>. + +JAVASCRIPTING: The B<-name> and B<-onSubmit> parameters are provided +for use with JavaScript. The -name parameter gives the +form a name so that it can be identified and manipulated by +JavaScript functions. -onSubmit should point to a JavaScript +function that will be executed just before the form is submitted to your +server. You can use this opportunity to check the contents of the form +for consistency and completeness. If you find something wrong, you +can put up an alert box or maybe fix things up yourself. You can +abort the submission by returning false from this function. + +Usually the bulk of JavaScript functions are defined in a <script> +block in the HTML header and -onSubmit points to one of these function +call. See start_html() for details. + +=head2 Form elements + +After starting a form, you will typically create one or more +textfields, popup menus, radio groups and other form elements. Each +of these elements takes a standard set of named arguments. Some +elements also have optional arguments. The standard arguments are as +follows: + +=over 4 + +=item B<-name> + +The name of the field. After submission this name can be used to +retrieve the field's value using the param() method. + +=item B<-value>, B<-values> + +The initial value of the field which will be returned to the script +after form submission. Some form elements, such as text fields, take +a single scalar -value argument. Others, such as popup menus, take a +reference to an array of values. The two arguments are synonyms. + +=item B<-tabindex> + +A numeric value that sets the order in which the form element receives +focus when the user presses the tab key. Elements with lower values +receive focus first. + +=item B<-id> + +A string identifier that can be used to identify this element to +JavaScript and DHTML. + +=item B<-override> + +A boolean, which, if true, forces the element to take on the value +specified by B<-value>, overriding the sticky behavior described +earlier for the B<-nosticky> pragma. + +=item B<-onChange>, B<-onFocus>, B<-onBlur>, B<-onMouseOver>, B<-onMouseOut>, B<-onSelect> + +These are used to assign JavaScript event handlers. See the +JavaScripting section for more details. + +=back + +Other common arguments are described in the next section. In addition +to these, all attributes described in the HTML specifications are +supported. + +=head2 Creating a text field + + print textfield(-name=>'field_name', + -value=>'starting value', + -size=>50, + -maxlength=>80); + -or- + + print textfield('field_name','starting value',50,80); + +textfield() will return a text input field. + +B<Parameters> + +=over 4 + +=item 1. + +The first parameter is the required name for the field (-name). + +=item 2. + +The optional second parameter is the default starting value for the field +contents (-value, formerly known as -default). + +=item 3. + +The optional third parameter is the size of the field in + characters (-size). + +=item 4. + +The optional fourth parameter is the maximum number of characters the + field will accept (-maxlength). + +=back + +As with all these methods, the field will be initialized with its +previous contents from earlier invocations of the script. +When the form is processed, the value of the text field can be +retrieved with: + + $value = param('foo'); + +If you want to reset it from its initial value after the script has been +called once, you can do so like this: + + param('foo',"I'm taking over this value!"); + +=head2 Creating a big text field + + print textarea(-name=>'foo', + -default=>'starting value', + -rows=>10, + -columns=>50); + + -or + + print textarea('foo','starting value',10,50); + +textarea() is just like textfield, but it allows you to specify +rows and columns for a multiline text entry box. You can provide +a starting value for the field, which can be long and contain +multiple lines. + +=head2 Creating a password field + + print password_field(-name=>'secret', + -value=>'starting value', + -size=>50, + -maxlength=>80); + -or- + + print password_field('secret','starting value',50,80); + +password_field() is identical to textfield(), except that its contents +will be starred out on the web page. + +=head2 Creating a file upload field + + print filefield(-name=>'uploaded_file', + -default=>'starting value', + -size=>50, + -maxlength=>80); + -or- + + print filefield('uploaded_file','starting value',50,80); + +filefield() will return a file upload field. +In order to take full advantage of this I<you must use the new +multipart encoding scheme> for the form. You can do this either +by calling B<start_form()> with an encoding type of B<&CGI::MULTIPART>, +or by calling the new method B<start_multipart_form()> instead of +vanilla B<start_form()>. + +B<Parameters> + +=over 4 + +=item 1. + +The first parameter is the required name for the field (-name). + +=item 2. + +The optional second parameter is the starting value for the field contents +to be used as the default file name (-default). + +For security reasons, browsers don't pay any attention to this field, +and so the starting value will always be blank. Worse, the field +loses its "sticky" behavior and forgets its previous contents. The +starting value field is called for in the HTML specification, however, +and possibly some browser will eventually provide support for it. + +=item 3. + +The optional third parameter is the size of the field in +characters (-size). + +=item 4. + +The optional fourth parameter is the maximum number of characters the +field will accept (-maxlength). + +=back + +JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur>, +B<-onMouseOver>, B<-onMouseOut> and B<-onSelect> parameters are +recognized. See textfield() for details. + +=head2 Creating a popup menu + + print popup_menu('menu_name', + ['eenie','meenie','minie'], + 'meenie'); + + -or- + + %labels = ('eenie'=>'your first choice', + 'meenie'=>'your second choice', + 'minie'=>'your third choice'); + %attributes = ('eenie'=>{'class'=>'class of first choice'}); + print popup_menu('menu_name', + ['eenie','meenie','minie'], + 'meenie',\%labels,\%attributes); + + -or (named parameter style)- + + print popup_menu(-name=>'menu_name', + -values=>['eenie','meenie','minie'], + -default=>['meenie','minie'], + -labels=>\%labels, + -attributes=>\%attributes); + +popup_menu() creates a menu. Please note that the -multiple option will be +ignored if passed - use scrolling_list() if you want to create a menu that +supports multiple selections + +=over 4 + +=item 1. + +The required first argument is the menu's name (-name). + +=item 2. + +The required second argument (-values) is an array B<reference> +containing the list of menu items in the menu. You can pass the +method an anonymous array, as shown in the example, or a reference to +a named array, such as "\@foo". + +=item 3. + +The optional third parameter (-default) is the name of the default +menu choice. If not specified, the first item will be the default. +The values of the previous choice will be maintained across +queries. Pass an array reference to select multiple defaults. + +=item 4. + +The optional fourth parameter (-labels) is provided for people who +want to use different values for the user-visible label inside the +popup menu and the value returned to your script. It's a pointer to an +hash relating menu values to user-visible labels. If you +leave this parameter blank, the menu values will be displayed by +default. (You can also leave a label undefined if you want to). + +=item 5. + +The optional fifth parameter (-attributes) is provided to assign +any of the common HTML attributes to an individual menu item. It's +a pointer to a hash relating menu values to another +hash with the attribute's name as the key and the +attribute's value as the value. + +=back + +When the form is processed, the selected value of the popup menu can +be retrieved using: + + $popup_menu_value = param('menu_name'); + +=head2 Creating an option group + +Named parameter style + + print popup_menu(-name=>'menu_name', + -values=>[qw/eenie meenie minie/, + optgroup(-name=>'optgroup_name', + -values => ['moe','catch'], + -attributes=>{'catch'=>{'class'=>'red'}})], + -labels=>{'eenie'=>'one', + 'meenie'=>'two', + 'minie'=>'three'}, + -default=>'meenie'); + + Old style + print popup_menu('menu_name', + ['eenie','meenie','minie', + optgroup('optgroup_name', ['moe', 'catch'], + {'catch'=>{'class'=>'red'}})],'meenie', + {'eenie'=>'one','meenie'=>'two','minie'=>'three'}); + +optgroup() creates an option group within a popup menu. + +=over 4 + +=item 1. + +The required first argument (B<-name>) is the label attribute of the +optgroup and is B<not> inserted in the parameter list of the query. + +=item 2. + +The required second argument (B<-values>) is an array reference +containing the list of menu items in the menu. You can pass the +method an anonymous array, as shown in the example, or a reference +to a named array, such as \@foo. If you pass a HASH reference, +the keys will be used for the menu values, and the values will be +used for the menu labels (see -labels below). + +=item 3. + +The optional third parameter (B<-labels>) allows you to pass a reference +to a hash containing user-visible labels for one or more +of the menu items. You can use this when you want the user to see one +menu string, but have the browser return your program a different one. +If you don't specify this, the value string will be used instead +("eenie", "meenie" and "minie" in this example). This is equivalent +to using a hash reference for the -values parameter. + +=item 4. + +An optional fourth parameter (B<-labeled>) can be set to a true value +and indicates that the values should be used as the label attribute +for each option element within the optgroup. + +=item 5. + +An optional fifth parameter (-novals) can be set to a true value and +indicates to suppress the val attribute in each option element within +the optgroup. + +See the discussion on optgroup at W3C +(http://www.w3.org/TR/REC-html40/interact/forms.html#edef-OPTGROUP) +for details. + +=item 6. + +An optional sixth parameter (-attributes) is provided to assign +any of the common HTML attributes to an individual menu item. It's +a pointer to a hash relating menu values to another +hash with the attribute's name as the key and the +attribute's value as the value. + +=back + +=head2 Creating a scrolling list + + print scrolling_list('list_name', + ['eenie','meenie','minie','moe'], + ['eenie','moe'],5,'true',{'moe'=>{'class'=>'red'}}); + -or- + + print scrolling_list('list_name', + ['eenie','meenie','minie','moe'], + ['eenie','moe'],5,'true', + \%labels,%attributes); + + -or- + + print scrolling_list(-name=>'list_name', + -values=>['eenie','meenie','minie','moe'], + -default=>['eenie','moe'], + -size=>5, + -multiple=>'true', + -labels=>\%labels, + -attributes=>\%attributes); + +scrolling_list() creates a scrolling list. + +B<Parameters:> + +=over 4 + +=item 1. + +The first and second arguments are the list name (-name) and values +(-values). As in the popup menu, the second argument should be an +array reference. + +=item 2. + +The optional third argument (-default) can be either a reference to a +list containing the values to be selected by default, or can be a +single value to select. If this argument is missing or undefined, +then nothing is selected when the list first appears. In the named +parameter version, you can use the synonym "-defaults" for this +parameter. + +=item 3. + +The optional fourth argument is the size of the list (-size). + +=item 4. + +The optional fifth argument can be set to true to allow multiple +simultaneous selections (-multiple). Otherwise only one selection +will be allowed at a time. + +=item 5. + +The optional sixth argument is a pointer to a hash +containing long user-visible labels for the list items (-labels). +If not provided, the values will be displayed. + +=item 6. + +The optional sixth parameter (-attributes) is provided to assign +any of the common HTML attributes to an individual menu item. It's +a pointer to a hash relating menu values to another +hash with the attribute's name as the key and the +attribute's value as the value. + +When this form is processed, all selected list items will be returned as +a list under the parameter name 'list_name'. The values of the +selected items can be retrieved with: + + @selected = param('list_name'); + +=back + +=head2 Creating a group of related checkboxes + + print checkbox_group(-name=>'group_name', + -values=>['eenie','meenie','minie','moe'], + -default=>['eenie','moe'], + -linebreak=>'true', + -disabled => ['moe'], + -labels=>\%labels, + -attributes=>\%attributes); + + print checkbox_group('group_name', + ['eenie','meenie','minie','moe'], + ['eenie','moe'],'true',\%labels, + {'moe'=>{'class'=>'red'}}); + + HTML3-COMPATIBLE BROWSERS ONLY: + + print checkbox_group(-name=>'group_name', + -values=>['eenie','meenie','minie','moe'], + -rows=2,-columns=>2); + + +checkbox_group() creates a list of checkboxes that are related +by the same name. + +B<Parameters:> + +=over 4 + +=item 1. + +The first and second arguments are the checkbox name and values, +respectively (-name and -values). As in the popup menu, the second +argument should be an array reference. These values are used for the +user-readable labels printed next to the checkboxes as well as for the +values passed to your script in the query string. + +=item 2. + +The optional third argument (-default) can be either a reference to a +list containing the values to be checked by default, or can be a +single value to checked. If this argument is missing or undefined, +then nothing is selected when the list first appears. + +=item 3. + +The optional fourth argument (-linebreak) can be set to true to place +line breaks between the checkboxes so that they appear as a vertical +list. Otherwise, they will be strung together on a horizontal line. + +=back + +The optional B<-labels> argument is a pointer to a hash +relating the checkbox values to the user-visible labels that will be +printed next to them. If not provided, the values will be used as the +default. + + +The optional parameters B<-rows>, and B<-columns> cause +checkbox_group() to return an HTML3 compatible table containing the +checkbox group formatted with the specified number of rows and +columns. You can provide just the -columns parameter if you wish; +checkbox_group will calculate the correct number of rows for you. + +The option B<-disabled> takes an array of checkbox values and disables +them by greying them out (this may not be supported by all browsers). + +The optional B<-attributes> argument is provided to assign any of the +common HTML attributes to an individual menu item. It's a pointer to +a hash relating menu values to another hash +with the attribute's name as the key and the attribute's value as the +value. + +The optional B<-tabindex> argument can be used to control the order in which +radio buttons receive focus when the user presses the tab button. If +passed a scalar numeric value, the first element in the group will +receive this tab index and subsequent elements will be incremented by +one. If given a reference to an array of radio button values, then +the indexes will be jiggered so that the order specified in the array +will correspond to the tab order. You can also pass a reference to a +hash in which the hash keys are the radio button values and the values +are the tab indexes of each button. Examples: + + -tabindex => 100 # this group starts at index 100 and counts up + -tabindex => ['moe','minie','eenie','meenie'] # tab in this order + -tabindex => {meenie=>100,moe=>101,minie=>102,eenie=>200} # tab in this order + +The optional B<-labelattributes> argument will contain attributes +attached to the <label> element that surrounds each button. + +When the form is processed, all checked boxes will be returned as +a list under the parameter name 'group_name'. The values of the +"on" checkboxes can be retrieved with: + + @turned_on = param('group_name'); + +The value returned by checkbox_group() is actually an array of button +elements. You can capture them and use them within tables, lists, +or in other creative ways: + + @h = checkbox_group(-name=>'group_name',-values=>\@values); + &use_in_creative_way(@h); + +=head2 Creating a standalone checkbox + + print checkbox(-name=>'checkbox_name', + -checked=>1, + -value=>'ON', + -label=>'CLICK ME'); + + -or- + + print checkbox('checkbox_name','checked','ON','CLICK ME'); + +checkbox() is used to create an isolated checkbox that isn't logically +related to any others. + +B<Parameters:> + +=over 4 + +=item 1. + +The first parameter is the required name for the checkbox (-name). It +will also be used for the user-readable label printed next to the +checkbox. + +=item 2. + +The optional second parameter (-checked) specifies that the checkbox +is turned on by default. Synonyms are -selected and -on. + +=item 3. + +The optional third parameter (-value) specifies the value of the +checkbox when it is checked. If not provided, the word "on" is +assumed. + +=item 4. + +The optional fourth parameter (-label) is the user-readable label to +be attached to the checkbox. If not provided, the checkbox name is +used. + +=back + +The value of the checkbox can be retrieved using: + + $turned_on = param('checkbox_name'); + +=head2 Creating a radio button group + + print radio_group(-name=>'group_name', + -values=>['eenie','meenie','minie'], + -default=>'meenie', + -linebreak=>'true', + -labels=>\%labels, + -attributes=>\%attributes); + + -or- + + print radio_group('group_name',['eenie','meenie','minie'], + 'meenie','true',\%labels,\%attributes); + + + HTML3-COMPATIBLE BROWSERS ONLY: + + print radio_group(-name=>'group_name', + -values=>['eenie','meenie','minie','moe'], + -rows=2,-columns=>2); + +radio_group() creates a set of logically-related radio buttons +(turning one member of the group on turns the others off) + +B<Parameters:> + +=over 4 + +=item 1. + +The first argument is the name of the group and is required (-name). + +=item 2. + +The second argument (-values) is the list of values for the radio +buttons. The values and the labels that appear on the page are +identical. Pass an array I<reference> in the second argument, either +using an anonymous array, as shown, or by referencing a named array as +in "\@foo". + +=item 3. + +The optional third parameter (-default) is the name of the default +button to turn on. If not specified, the first item will be the +default. You can provide a nonexistent button name, such as "-" to +start up with no buttons selected. + +=item 4. + +The optional fourth parameter (-linebreak) can be set to 'true' to put +line breaks between the buttons, creating a vertical list. + +=item 5. + +The optional fifth parameter (-labels) is a pointer to an associative +array relating the radio button values to user-visible labels to be +used in the display. If not provided, the values themselves are +displayed. + +=back + +All modern browsers can take advantage of the optional parameters +B<-rows>, and B<-columns>. These parameters cause radio_group() to +return an HTML3 compatible table containing the radio group formatted +with the specified number of rows and columns. You can provide just +the -columns parameter if you wish; radio_group will calculate the +correct number of rows for you. + +To include row and column headings in the returned table, you +can use the B<-rowheaders> and B<-colheaders> parameters. Both +of these accept a pointer to an array of headings to use. +The headings are just decorative. They don't reorganize the +interpretation of the radio buttons -- they're still a single named +unit. + +The optional B<-tabindex> argument can be used to control the order in which +radio buttons receive focus when the user presses the tab button. If +passed a scalar numeric value, the first element in the group will +receive this tab index and subsequent elements will be incremented by +one. If given a reference to an array of radio button values, then +the indexes will be jiggered so that the order specified in the array +will correspond to the tab order. You can also pass a reference to a +hash in which the hash keys are the radio button values and the values +are the tab indexes of each button. Examples: + + -tabindex => 100 # this group starts at index 100 and counts up + -tabindex => ['moe','minie','eenie','meenie'] # tab in this order + -tabindex => {meenie=>100,moe=>101,minie=>102,eenie=>200} # tab in this order + + +The optional B<-attributes> argument is provided to assign any of the +common HTML attributes to an individual menu item. It's a pointer to +a hash relating menu values to another hash +with the attribute's name as the key and the attribute's value as the +value. + +The optional B<-labelattributes> argument will contain attributes +attached to the <label> element that surrounds each button. + +When the form is processed, the selected radio button can +be retrieved using: + + $which_radio_button = param('group_name'); + +The value returned by radio_group() is actually an array of button +elements. You can capture them and use them within tables, lists, +or in other creative ways: + + @h = radio_group(-name=>'group_name',-values=>\@values); + &use_in_creative_way(@h); + +=head2 Creating a submit button + + print submit(-name=>'button_name', + -value=>'value'); + + -or- + + print submit('button_name','value'); + +submit() will create the query submission button. Every form +should have one of these. + +B<Parameters:> + +=over 4 + +=item 1. + +The first argument (-name) is optional. You can give the button a +name if you have several submission buttons in your form and you want +to distinguish between them. + +=item 2. + +The second argument (-value) is also optional. This gives the button +a value that will be passed to your script in the query string. The +name will also be used as the user-visible label. + +=item 3. + +You can use -label as an alias for -value. I always get confused +about which of -name and -value changes the user-visible label on the +button. + +=back + +You can figure out which button was pressed by using different +values for each one: + + $which_one = param('button_name'); + +=head2 Creating a reset button + + print reset + +reset() creates the "reset" button. Note that it restores the +form to its value from the last time the script was called, +NOT necessarily to the defaults. + +Note that this conflicts with the perl reset() built-in. Use +CORE::reset() to get the original reset function. + +=head2 Creating a default button + + print defaults('button_label') + +defaults() creates a button that, when invoked, will cause the +form to be completely reset to its defaults, wiping out all the +changes the user ever made. + +=head2 Creating a hidden field + + print hidden(-name=>'hidden_name', + -default=>['value1','value2'...]); + + -or- + + print hidden('hidden_name','value1','value2'...); + +hidden() produces a text field that can't be seen by the user. It +is useful for passing state variable information from one invocation +of the script to the next. + +B<Parameters:> + +=over 4 + +=item 1. + +The first argument is required and specifies the name of this +field (-name). + +=item 2. + +The second argument is also required and specifies its value +(-default). In the named parameter style of calling, you can provide +a single value here or a reference to a whole list + +=back + +Fetch the value of a hidden field this way: + + $hidden_value = param('hidden_name'); + +Note, that just like all the other form elements, the value of a +hidden field is "sticky". If you want to replace a hidden field with +some other values after the script has been called once you'll have to +do it manually: + + param('hidden_name','new','values','here'); + +=head2 Creating a clickable image button + + print image_button(-name=>'button_name', + -src=>'/source/URL', + -align=>'MIDDLE'); + + -or- + + print image_button('button_name','/source/URL','MIDDLE'); + +image_button() produces a clickable image. When it's clicked on the +position of the click is returned to your script as "button_name.x" +and "button_name.y", where "button_name" is the name you've assigned +to it. + +B<Parameters:> + +=over 4 + +=item 1. + +The first argument (-name) is required and specifies the name of this +field. + +=item 2. + +The second argument (-src) is also required and specifies the URL + +=item 3. + +The third option (-align, optional) is an alignment type, and may be +TOP, BOTTOM or MIDDLE + +=back + +Fetch the value of the button this way: + $x = param('button_name.x'); + $y = param('button_name.y'); + +=head2 Creating a javascript action button + + print button(-name=>'button_name', + -value=>'user visible label', + -onClick=>"do_something()"); + + -or- + + print button('button_name',"user visible value","do_something()"); + +button() produces an C<< <input> >> tag with C<type="button">. When it's +pressed the fragment of JavaScript code pointed to by the B<-onClick> parameter +will be executed. + +=head1 WORKING WITH FRAMES + +It's possible for CGI.pm scripts to write into several browser panels +and windows using the HTML 4 frame mechanism. There are three +techniques for defining new frames programmatically: + +=over 4 + +=item 1. Create a <Frameset> document + +After writing out the HTTP header, instead of creating a standard +HTML document using the start_html() call, create a <frameset> +document that defines the frames on the page. Specify your script(s) +(with appropriate parameters) as the SRC for each of the frames. + +There is no specific support for creating <frameset> sections +in CGI.pm, but the HTML is very simple to write. + +=item 2. Specify the destination for the document in the HTTP header + +You may provide a B<-target> parameter to the header() method: + + print header(-target=>'ResultsWindow'); + +This will tell the browser to load the output of your script into the +frame named "ResultsWindow". If a frame of that name doesn't already +exist, the browser will pop up a new window and load your script's +document into that. There are a number of magic names that you can +use for targets. See the HTML C<< <frame> >> documentation for details. + +=item 3. Specify the destination for the document in the <form> tag + +You can specify the frame to load in the FORM tag itself. With +CGI.pm it looks like this: + + print start_form(-target=>'ResultsWindow'); + +When your script is reinvoked by the form, its output will be loaded +into the frame named "ResultsWindow". If one doesn't already exist +a new window will be created. + +=back + +The script "frameset.cgi" in the examples directory shows one way to +create pages in which the fill-out form and the response live in +side-by-side frames. + +=head1 SUPPORT FOR JAVASCRIPT + +The usual way to use JavaScript is to define a set of functions in a +<SCRIPT> block inside the HTML header and then to register event +handlers in the various elements of the page. Events include such +things as the mouse passing over a form element, a button being +clicked, the contents of a text field changing, or a form being +submitted. When an event occurs that involves an element that has +registered an event handler, its associated JavaScript code gets +called. + +The elements that can register event handlers include the <BODY> of an +HTML document, hypertext links, all the various elements of a fill-out +form, and the form itself. There are a large number of events, and +each applies only to the elements for which it is relevant. Here is a +partial list: + +=over 4 + +=item B<onLoad> + +The browser is loading the current document. Valid in: + + + The HTML <BODY> section only. + +=item B<onUnload> + +The browser is closing the current page or frame. Valid for: + + + The HTML <BODY> section only. + +=item B<onSubmit> + +The user has pressed the submit button of a form. This event happens +just before the form is submitted, and your function can return a +value of false in order to abort the submission. Valid for: + + + Forms only. + +=item B<onClick> + +The mouse has clicked on an item in a fill-out form. Valid for: + + + Buttons (including submit, reset, and image buttons) + + Checkboxes + + Radio buttons + +=item B<onChange> + +The user has changed the contents of a field. Valid for: + + + Text fields + + Text areas + + Password fields + + File fields + + Popup Menus + + Scrolling lists + +=item B<onFocus> + +The user has selected a field to work with. Valid for: + + + Text fields + + Text areas + + Password fields + + File fields + + Popup Menus + + Scrolling lists + +=item B<onBlur> + +The user has deselected a field (gone to work somewhere else). Valid +for: + + + Text fields + + Text areas + + Password fields + + File fields + + Popup Menus + + Scrolling lists + +=item B<onSelect> + +The user has changed the part of a text field that is selected. Valid +for: + + + Text fields + + Text areas + + Password fields + + File fields + +=item B<onMouseOver> + +The mouse has moved over an element. + + + Text fields + + Text areas + + Password fields + + File fields + + Popup Menus + + Scrolling lists + +=item B<onMouseOut> + +The mouse has moved off an element. + + + Text fields + + Text areas + + Password fields + + File fields + + Popup Menus + + Scrolling lists + +=back + +In order to register a JavaScript event handler with an HTML element, +just use the event name as a parameter when you call the corresponding +CGI method. For example, to have your validateAge() JavaScript code +executed every time the textfield named "age" changes, generate the +field like this: + + print textfield(-name=>'age',-onChange=>"validateAge(this)"); + +This example assumes that you've already declared the validateAge() +function by incorporating it into a <SCRIPT> block. The CGI.pm +start_html() method provides a convenient way to create this section. + +Similarly, you can create a form that checks itself over for +consistency and alerts the user if some essential value is missing by +creating it this way: + print start_form(-onSubmit=>"validateMe(this)"); + +See the javascript.cgi script for a demonstration of how this all +works. + + +=head1 LIMITED SUPPORT FOR CASCADING STYLE SHEETS + +CGI.pm has limited support for HTML3's cascading style sheets (css). +To incorporate a stylesheet into your document, pass the +start_html() method a B<-style> parameter. The value of this +parameter may be a scalar, in which case it is treated as the source +URL for the stylesheet, or it may be a hash reference. In the latter +case you should provide the hash with one or more of B<-src> or +B<-code>. B<-src> points to a URL where an externally-defined +stylesheet can be found. B<-code> points to a scalar value to be +incorporated into a <style> section. Style definitions in B<-code> +override similarly-named ones in B<-src>, hence the name "cascading." + +You may also specify the type of the stylesheet by adding the optional +B<-type> parameter to the hash pointed to by B<-style>. If not +specified, the style defaults to 'text/css'. + +To refer to a style within the body of your document, add the +B<-class> parameter to any HTML element: + + print h1({-class=>'Fancy'},'Welcome to the Party'); + +Or define styles on the fly with the B<-style> parameter: + + print h1({-style=>'Color: red;'},'Welcome to Hell'); + +You may also use the new B<span()> element to apply a style to a +section of text: + + print span({-style=>'Color: red;'}, + h1('Welcome to Hell'), + "Where did that handbasket get to?" + ); + +Note that you must import the ":html3" definitions to have the +B<span()> method available. Here's a quick and dirty example of using +CSS's. See the CSS specification at +http://www.w3.org/Style/CSS/ for more information. + + use CGI qw/:standard :html3/; + + #here's a stylesheet incorporated directly into the page + $newStyle=<<END; + <!-- + P.Tip { + margin-right: 50pt; + margin-left: 50pt; + color: red; + } + P.Alert { + font-size: 30pt; + font-family: sans-serif; + color: red; + } + --> + END + print header(); + print start_html( -title=>'CGI with Style', + -style=>{-src=>'http://www.capricorn.com/style/st1.css', + -code=>$newStyle} + ); + print h1('CGI with Style'), + p({-class=>'Tip'}, + "Better read the cascading style sheet spec before playing with this!"), + span({-style=>'color: magenta'}, + "Look Mom, no hands!", + p(), + "Whooo wee!" + ); + print end_html; + +Pass an array reference to B<-code> or B<-src> in order to incorporate +multiple stylesheets into your document. + +Should you wish to incorporate a verbatim stylesheet that includes +arbitrary formatting in the header, you may pass a -verbatim tag to +the -style hash, as follows: + +print start_html (-style => {-verbatim => '@import url("/server-common/css/'.$cssFile.'");', + -src => '/server-common/css/core.css'}); + + +This will generate an HTML header that contains this: + + <link rel="stylesheet" type="text/css" href="/server-common/css/core.css"> + <style type="text/css"> + @import url("/server-common/css/main.css"); + </style> + +Any additional arguments passed in the -style value will be +incorporated into the <link> tag. For example: + + start_html(-style=>{-src=>['/styles/print.css','/styles/layout.css'], + -media => 'all'}); + +This will give: + + <link rel="stylesheet" type="text/css" href="/styles/print.css" media="all"/> + <link rel="stylesheet" type="text/css" href="/styles/layout.css" media="all"/> + +<p> + +To make more complicated <link> tags, use the Link() function +and pass it to start_html() in the -head argument, as in: + + @h = (Link({-rel=>'stylesheet',-type=>'text/css',-src=>'/ss/ss.css',-media=>'all'}), + Link({-rel=>'stylesheet',-type=>'text/css',-src=>'/ss/fred.css',-media=>'paper'})); + print start_html({-head=>\@h}) + +To create primary and "alternate" stylesheet, use the B<-alternate> option: + + start_html(-style=>{-src=>[ + {-src=>'/styles/print.css'}, + {-src=>'/styles/alt.css',-alternate=>1} + ] + }); + +=head2 Dumping out all the name/value pairs + +The Dump() method produces a string consisting of all the query's name/value +pairs formatted nicely as a nested list. This is useful for debugging purposes: + + print Dump + +Produces something that looks like: + + <ul> + <li>name1 + <ul> + <li>value1 + <li>value2 + </ul> + <li>name2 + <ul> + <li>value1 + </ul> + </ul> + +As a shortcut, you can interpolate the entire CGI object into a string +and it will be replaced with the a nice HTML dump shown above: + + $query=CGI->new; + print "<h2>Current Values</h2> $query\n"; + + +=head1 BUGS + +Address bug reports and comments to: L<https://github.com/leejo/CGI.pm/issues> + +The original bug tracker can be found at: L<https://rt.cpan.org/Public/Dist/Display.html?Queue=CGI.pm> + +However as stated this functionality is no longer being maintained and is +considered deprecated. Any feature requests, bug reports, issues, pull +requests, etc, for this functionality will almost certainly be rejected without +any action being taken place - this includes fixes to utterly broken page +rendering, invalid HTML, nonsensical output, and annoyances. + +=head1 SEE ALSO + +L<CGI> - The original source of this documentation / functionality + +=cut diff --git a/lib/CGI/Pretty.pm b/lib/CGI/Pretty.pm new file mode 100644 index 0000000..2247438 --- /dev/null +++ b/lib/CGI/Pretty.pm @@ -0,0 +1,85 @@ +package CGI::Pretty; + +use strict; +use if $] >= 5.019, 'deprecate'; +use CGI (); + +$CGI::Pretty::VERSION = '4.21'; +$CGI::DefaultClass = __PACKAGE__; +@CGI::Pretty::ISA = qw( CGI ); + +sub new { + my $class = shift; + my $this = $class->SUPER::new( @_ ); + return bless $this, $class; +} + +sub import { + + warn "CGI::Pretty is DEPRECATED and will be removed in a future release. Please see https://github.com/leejo/CGI.pm/issues/162 for more information"; + + my $self = shift; + no strict 'refs'; + + # This causes modules to clash. + undef %CGI::EXPORT; + undef %CGI::EXPORT; + + $self->_setup_symbols(@_); + my ($callpack, $callfile, $callline) = caller; + + # To allow overriding, search through the packages + # Till we find one in which the correct subroutine is defined. + my @packages = ($self,@{"$self\:\:ISA"}); + foreach my $sym (keys %CGI::EXPORT) { + my $pck; + my $def = $CGI::DefaultClass; + foreach $pck (@packages) { + if (defined(&{"$pck\:\:$sym"})) { + $def = $pck; + last; + } + } + *{"${callpack}::$sym"} = \&{"$def\:\:$sym"}; + } +} + +1; + +=head1 NAME + +CGI::Pretty - module to produce nicely formatted HTML code + +=head1 CGI::Pretty IS DEPRECATED + +It will be removed from the CGI distribution in a future release, so you +should no longer use it and remove it from any code that currently uses it. + +For now it has been reduced to a shell to prevent your code breaking, but +the "pretty" functions will no longer output "pretty" HTML. + +=head1 Alternatives + +L<HTML::HTML5::Parser> + L<HTML::HTML5::Writer> + L<XML::LibXML::PrettyPrint>: + + use HTML::HTML5::Parser qw(); + use HTML::HTML5::Writer qw(); + use XML::LibXML::PrettyPrint qw(); + + print HTML::HTML5::Writer->new( + start_tags => 'force', + end_tags => 'force', + )->document( + XML::LibXML::PrettyPrint->new_for_html( indent_string => "\t" ) + ->pretty_print( + HTML::HTML5::Parser->new->parse_string( $html_string ) + ) + ); + +L<Marpa::R2::HTML> (see the html_fmt script for examples) + +L<HTML::Tidy> + +L<HTML::Parser> + +=cut diff --git a/lib/CGI/Push.pm b/lib/CGI/Push.pm new file mode 100644 index 0000000..f1d4574 --- /dev/null +++ b/lib/CGI/Push.pm @@ -0,0 +1,306 @@ +package CGI::Push; +use if $] >= 5.019, 'deprecate'; + +$CGI::Push::VERSION='4.21'; +use CGI; +use CGI::Util 'rearrange'; +@ISA = ('CGI'); + +$CGI::DefaultClass = 'CGI::Push'; + +# add do_push() and push_delay() to exported tags +push(@{$CGI::EXPORT_TAGS{':standard'}},'do_push','push_delay'); + +sub do_push { + my ($self,@p) = CGI::self_or_default(@_); + + # unbuffer output + $| = 1; + srand; + my ($random) = sprintf("%08.0f",rand()*1E8); + my ($boundary) = "----=_NeXtPaRt$random"; + + my (@header); + my ($type,$callback,$delay,$last_page,$cookie,$target,$expires,$nph,@other) = rearrange([TYPE,NEXT_PAGE,DELAY,LAST_PAGE,[COOKIE,COOKIES],TARGET,EXPIRES,NPH],@p); + $type = 'text/html' unless $type; + $callback = \&simple_counter unless $callback && ref($callback) eq 'CODE'; + $delay = 1 unless defined($delay); + $self->push_delay($delay); + $nph = 1 unless defined($nph); + + my(@o); + foreach (@other) { push(@o,split("=")); } + push(@o,'-Target'=>$target) if defined($target); + push(@o,'-Cookie'=>$cookie) if defined($cookie); + push(@o,'-Type'=>"multipart/x-mixed-replace;boundary=\"$boundary\""); + push(@o,'-Server'=>"CGI.pm Push Module") if $nph; + push(@o,'-Status'=>'200 OK'); + push(@o,'-nph'=>1) if $nph; + print $self->header(@o); + + $boundary = "$CGI::CRLF--$boundary"; + + print "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY.${boundary}$CGI::CRLF"; + + my (@contents) = &$callback($self,++$COUNTER); + + # now we enter a little loop + while (1) { + print "Content-type: ${type}$CGI::CRLF$CGI::CRLF" unless $type =~ /^dynamic|heterogeneous$/i; + print @contents; + @contents = &$callback($self,++$COUNTER); + if ((@contents) && defined($contents[0])) { + print "${boundary}$CGI::CRLF"; + do_sleep($self->push_delay()) if $self->push_delay(); + } else { + if ($last_page && ref($last_page) eq 'CODE') { + print "${boundary}$CGI::CRLF"; + do_sleep($self->push_delay()) if $self->push_delay(); + print "Content-type: ${type}$CGI::CRLF$CGI::CRLF" unless $type =~ /^dynamic|heterogeneous$/i; + print &$last_page($self,$COUNTER); + } + print "${boundary}--$CGI::CRLF"; + last; + } + } + print "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY.$CGI::CRLF"; +} + +sub simple_counter { + my ($self,$count) = @_; + return $self->start_html("CGI::Push Default Counter"), + $self->h1("CGI::Push Default Counter"), + "This page has been updated ",$self->strong($count)," times.", + $self->hr(), + $self->a({'-href'=>'http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html'},'CGI.pm home page'), + $self->end_html; +} + +sub do_sleep { + my $delay = shift; + if ( ($delay >= 1) && ($delay!~/\./) ){ + sleep($delay); + } else { + select(undef,undef,undef,$delay); + return $delay; + } +} + +sub push_delay { + my ($self,$delay) = CGI::self_or_default(@_); + return defined($delay) ? $self->{'.delay'} = + $delay : $self->{'.delay'}; +} + +1; + +=head1 NAME + +CGI::Push - Simple Interface to Server Push + +=head1 SYNOPSIS + + use strict; + use warnings; + + use CGI::Push qw(:standard); + + do_push( + -next_page => \&next_page, + -last_page => \&last_page, + -delay => 0.5 + ); + + sub next_page { + my($q,$counter) = @_; + return undef if $counter >= 10; + .... + } + + sub last_page { + my($q,$counter) = @_; + return ... + } + +=head1 DESCRIPTION + +CGI::Push is a subclass of the CGI object created by CGI.pm. It is +specialized for server push operations, which allow you to create +animated pages whose content changes at regular intervals. + +You provide CGI::Push with a pointer to a subroutine that will draw +one page. Every time your subroutine is called, it generates a new +page. The contents of the page will be transmitted to the browser +in such a way that it will replace what was there beforehand. The +technique will work with HTML pages as well as with graphics files, +allowing you to create animated GIFs. + +Only Netscape Navigator supports server push. Internet Explorer +browsers do not. + +=head1 USING CGI::Push + +CGI::Push adds one new method to the standard CGI suite, do_push(). +When you call this method, you pass it a reference to a subroutine +that is responsible for drawing each new page, an interval delay, and +an optional subroutine for drawing the last page. Other optional +parameters include most of those recognized by the CGI header() +method. + +You may call do_push() in the object oriented manner or not, as you +prefer: + + use CGI::Push; + $q = CGI::Push->new; + $q->do_push(-next_page=>\&draw_a_page); + + -or- + + use CGI::Push qw(:standard); + do_push(-next_page=>\&draw_a_page); + +Parameters are as follows: + +=over 4 + +=item -next_page + + do_push(-next_page=>\&my_draw_routine); + +This required parameter points to a reference to a subroutine responsible for +drawing each new page. The subroutine should expect two parameters +consisting of the CGI object and a counter indicating the number +of times the subroutine has been called. It should return the +contents of the page as an B<array> of one or more items to print. +It can return a false value (or an empty array) in order to abort the +redrawing loop and print out the final page (if any) + + sub my_draw_routine { + my($q,$counter) = @_; + return undef if $counter > 100; + ... + } + +You are of course free to refer to create and use global variables +within your draw routine in order to achieve special effects. + +=item -last_page + +This optional parameter points to a reference to the subroutine +responsible for drawing the last page of the series. It is called +after the -next_page routine returns a false value. The subroutine +itself should have exactly the same calling conventions as the +-next_page routine. + +=item -type + +This optional parameter indicates the content type of each page. It +defaults to "text/html". Normally the module assumes that each page +is of a homogeneous MIME type. However if you provide either of the +magic values "heterogeneous" or "dynamic" (the latter provided for the +convenience of those who hate long parameter names), you can specify +the MIME type -- and other header fields -- on a per-page basis. See +"heterogeneous pages" for more details. + +=item -delay + +This indicates the delay, in seconds, between frames. Smaller delays +refresh the page faster. Fractional values are allowed. + +B<If not specified, -delay will default to 1 second> + +=item -cookie, -target, -expires, -nph + +These have the same meaning as the like-named parameters in +CGI::header(). + +If not specified, -nph will default to 1 (as needed for many servers, see below). + +=back + +=head2 Heterogeneous Pages + +Ordinarily all pages displayed by CGI::Push share a common MIME type. +However by providing a value of "heterogeneous" or "dynamic" in the +do_push() -type parameter, you can specify the MIME type of each page +on a case-by-case basis. + +If you use this option, you will be responsible for producing the +HTTP header for each page. Simply modify your draw routine to +look like this: + + sub my_draw_routine { + my($q,$counter) = @_; + return header('text/html'), # note we're producing the header here + .... + } + +You can add any header fields that you like, but some (cookies and +status fields included) may not be interpreted by the browser. One +interesting effect is to display a series of pages, then, after the +last page, to redirect the browser to a new URL. Because redirect() +does b<not> work, the easiest way is with a -refresh header field, +as shown below: + + sub my_draw_routine { + my($q,$counter) = @_; + return undef if $counter > 10; + return header('text/html'), # note we're producing the header here + ... + } + + sub my_last_page { + return header(-refresh=>'5; URL=http://somewhere.else/finished.html', + -type=>'text/html'), + ... + } + +=head2 Changing the Page Delay on the Fly + +If you would like to control the delay between pages on a page-by-page +basis, call push_delay() from within your draw routine. push_delay() +takes a single numeric argument representing the number of seconds you +wish to delay after the current page is displayed and before +displaying the next one. The delay may be fractional. Without +parameters, push_delay() just returns the current delay. + +=head1 INSTALLING CGI::Push SCRIPTS + +Server push scripts must be installed as no-parsed-header (NPH) +scripts in order to work correctly on many servers. On Unix systems, +this is most often accomplished by prefixing the script's name with "nph-". +Recognition of NPH scripts happens automatically with WebSTAR and +Microsoft IIS. Users of other servers should see their documentation +for help. + +Apache web server from version 1.3b2 on does not need server +push scripts installed as NPH scripts: the -nph parameter to do_push() +may be set to a false value to disable the extra headers needed by an +NPH script. + +=head1 AUTHOR INFORMATION + +The CGI.pm distribution is copyright 1995-2007, Lincoln D. Stein. It is +distributed under GPL and the Artistic License 2.0. It is currently +maintained by Lee Johnson with help from many contributors. + +Address bug reports and comments to: https://github.com/leejo/CGI.pm/issues + +The original bug tracker can be found at: https://rt.cpan.org/Public/Dist/Display.html?Queue=CGI.pm + +When sending bug reports, please provide the version of CGI.pm, the version of +Perl, the name and version of your Web server, and the name and version of the +operating system you are using. If the problem is even remotely browser +dependent, please provide information about the affected browsers as well. +Copyright 1995-1998, Lincoln D. Stein. All rights reserved. + +=head1 BUGS + +This section intentionally left blank. + +=head1 SEE ALSO + +L<CGI::Carp>, L<CGI> + +=cut + diff --git a/lib/CGI/Util.pm b/lib/CGI/Util.pm new file mode 100644 index 0000000..308cf56 --- /dev/null +++ b/lib/CGI/Util.pm @@ -0,0 +1,354 @@ +package CGI::Util; +use base 'Exporter'; +require 5.008001; +use strict; +use if $] >= 5.019, 'deprecate'; +our @EXPORT_OK = qw(rearrange rearrange_header make_attributes unescape escape + expires ebcdic2ascii ascii2ebcdic); + +our $VERSION = '4.21'; + +our $_EBCDIC = "\t" ne "\011"; + +# This option is not documented and may change or go away. +# The HTML spec does not require attributes to be sorted, +# but it's useful for testing to get a predictable order back. +our $SORT_ATTRIBUTES; + +# (ord('^') == 95) for codepage 1047 as on os390, vmesa +our @A2E = ( + 0, 1, 2, 3, 55, 45, 46, 47, 22, 5, 21, 11, 12, 13, 14, 15, + 16, 17, 18, 19, 60, 61, 50, 38, 24, 25, 63, 39, 28, 29, 30, 31, + 64, 90,127,123, 91,108, 80,125, 77, 93, 92, 78,107, 96, 75, 97, + 240,241,242,243,244,245,246,247,248,249,122, 94, 76,126,110,111, + 124,193,194,195,196,197,198,199,200,201,209,210,211,212,213,214, + 215,216,217,226,227,228,229,230,231,232,233,173,224,189, 95,109, + 121,129,130,131,132,133,134,135,136,137,145,146,147,148,149,150, + 151,152,153,162,163,164,165,166,167,168,169,192, 79,208,161, 7, + 32, 33, 34, 35, 36, 37, 6, 23, 40, 41, 42, 43, 44, 9, 10, 27, + 48, 49, 26, 51, 52, 53, 54, 8, 56, 57, 58, 59, 4, 20, 62,255, + 65,170, 74,177,159,178,106,181,187,180,154,138,176,202,175,188, + 144,143,234,250,190,160,182,179,157,218,155,139,183,184,185,171, + 100,101, 98,102, 99,103,158,104,116,113,114,115,120,117,118,119, + 172,105,237,238,235,239,236,191,128,253,254,251,252,186,174, 89, + 68, 69, 66, 70, 67, 71,156, 72, 84, 81, 82, 83, 88, 85, 86, 87, + 140, 73,205,206,203,207,204,225,112,221,222,219,220,141,142,223 + ); +our @E2A = ( + 0, 1, 2, 3,156, 9,134,127,151,141,142, 11, 12, 13, 14, 15, + 16, 17, 18, 19,157, 10, 8,135, 24, 25,146,143, 28, 29, 30, 31, + 128,129,130,131,132,133, 23, 27,136,137,138,139,140, 5, 6, 7, + 144,145, 22,147,148,149,150, 4,152,153,154,155, 20, 21,158, 26, + 32,160,226,228,224,225,227,229,231,241,162, 46, 60, 40, 43,124, + 38,233,234,235,232,237,238,239,236,223, 33, 36, 42, 41, 59, 94, + 45, 47,194,196,192,193,195,197,199,209,166, 44, 37, 95, 62, 63, + 248,201,202,203,200,205,206,207,204, 96, 58, 35, 64, 39, 61, 34, + 216, 97, 98, 99,100,101,102,103,104,105,171,187,240,253,254,177, + 176,106,107,108,109,110,111,112,113,114,170,186,230,184,198,164, + 181,126,115,116,117,118,119,120,121,122,161,191,208, 91,222,174, + 172,163,165,183,169,167,182,188,189,190,221,168,175, 93,180,215, + 123, 65, 66, 67, 68, 69, 70, 71, 72, 73,173,244,246,242,243,245, + 125, 74, 75, 76, 77, 78, 79, 80, 81, 82,185,251,252,249,250,255, + 92,247, 83, 84, 85, 86, 87, 88, 89, 90,178,212,214,210,211,213, + 48, 49, 50, 51, 52, 53, 54, 55, 56, 57,179,219,220,217,218,159 + ); + +if ($_EBCDIC && ord('^') == 106) { # as in the BS2000 posix-bc coded character set + $A2E[91] = 187; $A2E[92] = 188; $A2E[94] = 106; $A2E[96] = 74; + $A2E[123] = 251; $A2E[125] = 253; $A2E[126] = 255; $A2E[159] = 95; + $A2E[162] = 176; $A2E[166] = 208; $A2E[168] = 121; $A2E[172] = 186; + $A2E[175] = 161; $A2E[217] = 224; $A2E[219] = 221; $A2E[221] = 173; + $A2E[249] = 192; + + $E2A[74] = 96; $E2A[95] = 159; $E2A[106] = 94; $E2A[121] = 168; + $E2A[161] = 175; $E2A[173] = 221; $E2A[176] = 162; $E2A[186] = 172; + $E2A[187] = 91; $E2A[188] = 92; $E2A[192] = 249; $E2A[208] = 166; + $E2A[221] = 219; $E2A[224] = 217; $E2A[251] = 123; $E2A[253] = 125; + $E2A[255] = 126; + } +elsif ($_EBCDIC && ord('^') == 176) { # as in codepage 037 on os400 + $A2E[10] = 37; $A2E[91] = 186; $A2E[93] = 187; $A2E[94] = 176; + $A2E[133] = 21; $A2E[168] = 189; $A2E[172] = 95; $A2E[221] = 173; + + $E2A[21] = 133; $E2A[37] = 10; $E2A[95] = 172; $E2A[173] = 221; + $E2A[176] = 94; $E2A[186] = 91; $E2A[187] = 93; $E2A[189] = 168; +} + +# Smart rearrangement of parameters to allow named parameter +# calling. We do the rearrangement if: +# the first parameter begins with a - + +sub rearrange { + my ($order,@param) = @_; + my ($result, $leftover) = _rearrange_params( $order, @param ); + push @$result, make_attributes( $leftover, defined $CGI::Q ? $CGI::Q->{escape} : 1 ) + if keys %$leftover; + @$result; +} + +sub rearrange_header { + my ($order,@param) = @_; + + my ($result,$leftover) = _rearrange_params( $order, @param ); + push @$result, make_attributes( $leftover, 0, 1 ) if keys %$leftover; + + @$result; +} + +sub _rearrange_params { + my($order,@param) = @_; + return [] unless @param; + + if (ref($param[0]) eq 'HASH') { + @param = %{$param[0]}; + } else { + return \@param + unless (defined($param[0]) && substr($param[0],0,1) eq '-'); + } + + # map parameters into positional indices + my ($i,%pos); + $i = 0; + foreach (@$order) { + foreach (ref($_) eq 'ARRAY' ? @$_ : $_) { $pos{lc($_)} = $i; } + $i++; + } + + my %params_as_hash = ( @param ); + + my (@result,%leftover); + $#result = $#$order; # preextend + + foreach my $k ( + # sort keys alphabetically but favour certain keys before others + # specifically for the case where there could be several options + # for a param key, but one should be preferred (see GH #155) + sort { + if ( $a =~ /content/i ) { return 1 } + elsif ( $b =~ /content/i ) { return -1 } + else { $a cmp $b } + } + keys( %params_as_hash ) + ) { + my $key = lc($k); + $key =~ s/^\-//; + if (exists $pos{$key}) { + $result[$pos{$key}] = $params_as_hash{$k}; + } else { + $leftover{$key} = $params_as_hash{$k}; + } + } + + return \@result, \%leftover; +} + +sub make_attributes { + my $attr = shift; + return () unless $attr && ref($attr) && ref($attr) eq 'HASH'; + my $escape = shift || 0; + my $do_not_quote = shift; + + my $quote = $do_not_quote ? '' : '"'; + + my @attr_keys= keys %$attr; + if ($SORT_ATTRIBUTES) { + @attr_keys= sort @attr_keys; + } + my(@att); + foreach (@attr_keys) { + my($key) = $_; + $key=~s/^\-//; # get rid of initial - if present + + # old way: breaks EBCDIC! + # $key=~tr/A-Z_/a-z-/; # parameters are lower case, use dashes + + ($key="\L$key") =~ tr/_/-/; # parameters are lower case, use dashes + + my $value = $escape ? simple_escape($attr->{$_}) : $attr->{$_}; + push(@att,defined($attr->{$_}) ? qq/$key=$quote$value$quote/ : qq/$key/); + } + return sort @att; +} + +sub simple_escape { + return unless defined(my $toencode = shift); + $toencode =~ s{&}{&}gso; + $toencode =~ s{<}{<}gso; + $toencode =~ s{>}{>}gso; + $toencode =~ s{\"}{"}gso; +# Doesn't work. Can't work. forget it. +# $toencode =~ s{\x8b}{‹}gso; +# $toencode =~ s{\x9b}{›}gso; + $toencode; +} + +sub utf8_chr { + my $c = shift(@_); + my $u = chr($c); + utf8::encode($u); # drop utf8 flag + return $u; +} + +# unescape URL-encoded data +sub unescape { + shift() if @_ > 0 and (ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass)); + my $todecode = shift; + return undef unless defined($todecode); + $todecode =~ tr/+/ /; # pluses become spaces + if ($_EBCDIC) { + $todecode =~ s/%([0-9a-fA-F]{2})/chr $A2E[hex($1)]/ge; + } else { + # handle surrogate pairs first -- dankogai. Ref: http://unicode.org/faq/utf_bom.html#utf16-2 + $todecode =~ s{ + %u([Dd][89a-bA-B][0-9a-fA-F]{2}) # hi + %u([Dd][c-fC-F][0-9a-fA-F]{2}) # lo + }{ + utf8_chr( + 0x10000 + + (hex($1) - 0xD800) * 0x400 + + (hex($2) - 0xDC00) + ) + }gex; + $todecode =~ s/%(?:([0-9a-fA-F]{2})|u([0-9a-fA-F]{4}))/ + defined($1)? chr hex($1) : utf8_chr(hex($2))/ge; + } + return $todecode; +} + +# URL-encode data +# +# We cannot use the %u escapes, they were rejected by W3C, so the official +# way is %XX-escaped utf-8 encoding. +# Naturally, Unicode strings have to be converted to their utf-8 byte +# representation. +# Byte strings were traditionally used directly as a sequence of octets. +# This worked if they actually represented binary data (i.e. in CGI::Compress). +# This also worked if these byte strings were actually utf-8 encoded; e.g., +# when the source file used utf-8 without the appropriate "use utf8;". +# This fails if the byte string is actually a Latin 1 encoded string, but it +# was always so and cannot be fixed without breaking the binary data case. +# -- Stepan Kasal <skasal@redhat.com> +# + +sub escape { + # If we being called in an OO-context, discard the first argument. + shift() if @_ > 1 and ( ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass)); + my $toencode = shift; + return undef unless defined($toencode); + utf8::encode($toencode) if utf8::is_utf8($toencode); + if ($_EBCDIC) { + $toencode=~s/([^a-zA-Z0-9_.~-])/uc sprintf("%%%02x",$E2A[ord($1)])/eg; + } else { + $toencode=~s/([^a-zA-Z0-9_.~-])/uc sprintf("%%%02x",ord($1))/eg; + } + return $toencode; +} + +# This internal routine creates date strings suitable for use in +# cookies and HTTP headers. (They differ, unfortunately.) +# Thanks to Mark Fisher for this. +sub expires { + my($time,$format) = @_; + $format ||= 'http'; + + my(@MON)=qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/; + my(@WDAY) = qw/Sun Mon Tue Wed Thu Fri Sat/; + + # pass through preformatted dates for the sake of expire_calc() + $time = expire_calc($time); + return $time unless $time =~ /^\d+$/; + + # make HTTP/cookie date string from GMT'ed time + # (cookies use '-' as date separator, HTTP uses ' ') + my($sc) = ' '; + $sc = '-' if $format eq "cookie"; + my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime($time); + $year += 1900; + return sprintf("%s, %02d$sc%s$sc%04d %02d:%02d:%02d GMT", + $WDAY[$wday],$mday,$MON[$mon],$year,$hour,$min,$sec); +} + +# This internal routine creates an expires time exactly some number of +# hours from the current time. It incorporates modifications from +# Mark Fisher. +sub expire_calc { + my($time) = @_; + my(%mult) = ('s'=>1, + 'm'=>60, + 'h'=>60*60, + 'd'=>60*60*24, + 'M'=>60*60*24*30, + 'y'=>60*60*24*365); + # format for time can be in any of the forms... + # "now" -- expire immediately + # "+180s" -- in 180 seconds + # "+2m" -- in 2 minutes + # "+12h" -- in 12 hours + # "+1d" -- in 1 day + # "+3M" -- in 3 months + # "+2y" -- in 2 years + # "-3m" -- 3 minutes ago(!) + # If you don't supply one of these forms, we assume you are + # specifying the date yourself + my($offset); + if (!$time || (lc($time) eq 'now')) { + $offset = 0; + } elsif ($time=~/^\d+/) { + return $time; + } elsif ($time=~/^([+-]?(?:\d+|\d*\.\d*))([smhdMy])/) { + $offset = ($mult{$2} || 1)*$1; + } else { + return $time; + } + my $cur_time = time; + return ($cur_time+$offset); +} + +sub ebcdic2ascii { + my $data = shift; + $data =~ s/(.)/chr $E2A[ord($1)]/ge; + $data; +} + +sub ascii2ebcdic { + my $data = shift; + $data =~ s/(.)/chr $A2E[ord($1)]/ge; + $data; +} + +1; + +__END__ + +=head1 NAME + +CGI::Util - Internal utilities used by CGI module + +=head1 SYNOPSIS + +none + +=head1 DESCRIPTION + +no public subroutines + +=head1 AUTHOR INFORMATION + +The CGI.pm distribution is copyright 1995-2007, Lincoln D. Stein. It is +distributed under GPL and the Artistic License 2.0. It is currently +maintained by Lee Johnson with help from many contributors. + +Address bug reports and comments to: https://github.com/leejo/CGI.pm/issues + +The original bug tracker can be found at: https://rt.cpan.org/Public/Dist/Display.html?Queue=CGI.pm + +When sending bug reports, please provide the version of CGI.pm, the version of +Perl, the name and version of your Web server, and the name and version of the +operating system you are using. If the problem is even remotely browser +dependent, please provide information about the affected browsers as well. + +=head1 SEE ALSO + +L<CGI> + +=cut diff --git a/lib/Fh.pm b/lib/Fh.pm new file mode 100644 index 0000000..b798769 --- /dev/null +++ b/lib/Fh.pm @@ -0,0 +1,7 @@ +# back compatibility package for any code explicitly checking +# that the filehandle object is a Fh +package Fh; + +$Fh::VERSION = '4.21'; + +1; diff --git a/t/Dump.t b/t/Dump.t new file mode 100644 index 0000000..fafb5b2 --- /dev/null +++ b/t/Dump.t @@ -0,0 +1,5 @@ +use Test::More 'no_plan'; +use CGI; +my $cgi = CGI->new('<a>=<b>'); +like($cgi->Dump, qr/\Q<a>/, 'param names are HTML escaped by Dump()'); +like($cgi->Dump, qr/\Q<b>/, 'param values are HTML escaped by Dump()'); diff --git a/t/arbitrary_handles.t b/t/arbitrary_handles.t new file mode 100644 index 0000000..eaaea0c --- /dev/null +++ b/t/arbitrary_handles.t @@ -0,0 +1,30 @@ +#!perl + +use strict; +use warnings; + +use Test::More tests => 4; +use IO::File; +use CGI; + +my $test_string = 'game=soccer&game=baseball&weather=nice'; +my $handle = IO::File->new_tmpfile; +$handle->write( $test_string ); +$handle->flush; +$handle->seek( 0,0 ); + +{ + local $ENV{REQUEST_METHOD} = 'POST'; + + ok( my $q = CGI->new( $handle ),"CGI->new from POST" ); + is( $q->param( 'weather' ),'nice', "param() from POST with IO::File" ); +} + +$handle->seek( 0,0 ); + +{ + local $ENV{REQUEST_METHOD} = 'GET'; + + ok( my $q = CGI->new( $handle ),"CGI->new from GET" ); + is( $q->param( 'weather' ),'nice', "param() from GET with IO::File" ); +} diff --git a/t/autoescape.t b/t/autoescape.t new file mode 100644 index 0000000..3a25c2d --- /dev/null +++ b/t/autoescape.t @@ -0,0 +1,200 @@ +#!perl + +use strict; +use warnings; + +use Test::More tests => 18; + +use CGI qw/ autoEscape escapeHTML button textfield password_field textarea popup_menu scrolling_list checkbox_group optgroup checkbox radio_group submit image_button button /; +$CGI::Util::SORT_ATTRIBUTES = 1; + +is (button(-name => 'test<'), '<input type="button" name="test<" value="test<" />', "autoEscape defaults to On"); + +my $before = escapeHTML("test<"); +autoEscape(undef); +my $after = escapeHTML("test<"); + + +is($before, "test<", "reality check escapeHTML"); + +is ($before, $after, "passing undef to autoEscape doesn't break escapeHTML"); +is (button(-name => 'test<'), '<input type="button" name="test<" value="test<" />', "turning off autoescape actually works"); +autoEscape(1); +is (button(-name => 'test<'), '<input type="button" name="test<" value="test<" />', "autoescape turns back on"); +$before = escapeHTML("test<"); +autoEscape(0); +$after = escapeHTML("test<"); + +is ($before, $after, "passing 0 to autoEscape doesn't break escapeHTML"); + +# RT #25485: Needs Tests: autoEscape() bypassed for Javascript handlers, except in button() +autoEscape(undef); + +is(textfield( +{ +default => 'text field', +onclick => 'alert("===> text field")', +}, +), +qq{<input type="text" name="" value="text field" onclick="alert("===> text field")" />}, +'autoescape javascript turns off for textfield' +); + +is(password_field( +{ +default => 'password field', +onclick => 'alert("===> password +field")', +}, +), +qq{<input type="password" name="" value="password field" onclick="alert("===> password +field")" />}, +'autoescape javascript turns off for password field' +); + +is(textarea( +{ +name => 'foo', +default => 'text area', +rows => 10, +columns => 50, +onclick => 'alert("===> text area")', +}, +), +qq{<textarea name="foo" rows="10" cols="50" onclick="alert("===> text area")">text area</textarea>}, +'autoescape javascript turns off for textarea' +); + +is(popup_menu( +{ +name => 'menu_name', +values => ['eenie','meenie','minie'], +default => 'meenie', +onclick => 'alert("===> popup menu")', +} +), +qq{<select name="menu_name" onclick="alert("===> popup menu")"> +<option value="eenie">eenie</option> +<option selected="selected" value="meenie">meenie</option> +<option value="minie">minie</option> +</select>}, +'autoescape javascript turns off for popup_menu' +); + +is(popup_menu( +-name=>'menu_name', +onclick => 'alert("===> menu group")', +-values=>[ +qw/eenie meenie minie/, +optgroup( +-name=>'optgroup_name', +onclick => +'alert("===> menu group option")', +-values => ['moe','catch'], +-attributes=>{'catch'=>{'class'=>'red'}} +) +], +-labels=>{ +'eenie'=>'one', +'meenie'=>'two', +'minie'=>'three' +}, +-default=>'meenie' +), +qq{<select name="menu_name" onclick="alert("===> menu group")"> +<option value="eenie">one</option> +<option selected="selected" value="meenie">two</option> +<option value="minie">three</option> +<optgroup label="optgroup_name" onclick="alert("===> menu group option")"> +<option value="moe">moe</option> +<option class="red" value="catch">catch</option> +</optgroup> +</select>}, +'autoescape javascript turns off for popup_menu #2' +); + +is(scrolling_list( +-name=>'list_name', +onclick => 'alert("===> scrolling +list")', +-values=>['eenie','meenie','minie','moe'], +-default=>['eenie','moe'], +-size=>5, +-multiple=>'true', +), +qq{<select name="list_name" size="5" multiple="multiple" onclick="alert("===> scrolling +list")"> +<option selected="selected" value="eenie">eenie</option> +<option value="meenie">meenie</option> +<option value="minie">minie</option> +<option selected="selected" value="moe">moe</option> +</select>}, +'autoescape javascript turns off for scrolling list' +); + +is(checkbox_group( +-name=>'group_name', +onclick => 'alert("===> checkbox group")', +-values=>['eenie','meenie','minie','moe'], +-default=>['eenie','moe'], +-linebreak=>'true', +), +qq{<label><input type="checkbox" name="group_name" value="eenie" checked="checked" onclick="alert("===> checkbox group")" />eenie</label><br /> <label><input type="checkbox" name="group_name" value="meenie" onclick="alert("===> checkbox group")" />meenie</label><br /> <label><input type="checkbox" name="group_name" value="minie" onclick="alert("===> checkbox group")" />minie</label><br /> <label><input type="checkbox" name="group_name" value="moe" checked="checked" onclick="alert("===> checkbox group")" />moe</label><br />}, +'autoescape javascript turns off for checkbox group' +); + +is(checkbox( +-name=>'checkbox_name', +onclick => 'alert("===> single checkbox")', +onchange => 'alert("===> single checkbox +changed")', +-checked=>1, +-value=>'ON', +-label=>'CLICK ME' +), +qq{<label><input type="checkbox" name="checkbox_name" value="ON" checked="checked" onchange="alert("===> single checkbox +changed")" onclick="alert("===> single checkbox")" />CLICK ME</label>}, +'autoescape javascript turns off for checkbox' +); + +is(radio_group( +{ +name=>'group_name', +onclick => 'alert("===> radio group")', +values=>['eenie','meenie','minie','moe'], +rows=>2, +columns=>2, +} +), +qq{<table><tr><td><label><input type="radio" name="group_name" value="eenie" checked="checked" onclick="alert("===> radio group")" />eenie</label></td><td><label><input type="radio" name="group_name" value="minie" onclick="alert("===> radio group")" />minie</label></td></tr><tr><td><label><input type="radio" name="group_name" value="meenie" onclick="alert("===> radio group")" />meenie</label></td><td><label><input type="radio" name="group_name" value="moe" onclick="alert("===> radio group")" />moe</label></td></tr></table>}, +'autoescape javascript turns off for radio group' +); + +is(submit( +-name=>'button_name', +onclick => 'alert("===> submit button")', +-value=>'value' +), +qq{<input type="submit" name="button_name" value="value" onclick="alert("===> submit button")" />}, +'autoescape javascript turns off for submit' +); + +is(image_button( +-name=>'button_name', +onclick => 'alert("===> image button")', +-src=>'/source/URL', +-align=>'MIDDLE' +), +qq{<input type="image" name="button_name" src="/source/URL" align="middle" onclick="alert("===> image button")" />}, +'autoescape javascript turns off for image_button' +); + +is(button( +{ +onclick => 'alert("===> Button")', +title => 'Button', +}, +), +qq{<input type="button" onclick="alert("===> Button")" title="Button" />}, +'autoescape javascript turns off for button' +); @@ -0,0 +1,7 @@ +#!/usr/local/bin/perl -w + +use Test::More tests => 2; + +BEGIN{ use_ok('CGI'); } + +can_ok('CGI', qw/cookie param/); diff --git a/t/carp.t b/t/carp.t new file mode 100644 index 0000000..307fc61 --- /dev/null +++ b/t/carp.t @@ -0,0 +1,440 @@ +# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 2 -*- +#!perl -w + +use strict; + +use Test::More tests => 71; +use IO::Handle; + +use CGI::Carp; +use Cwd; + +#----------------------------------------------------------------------------- +# Test id +#----------------------------------------------------------------------------- + +# directly invoked +my $expect_f = __FILE__; +my $expect_l = __LINE__ + 1; +my ($file, $line, $id) = CGI::Carp::id(0); +is($file, $expect_f, "file"); +is($line, $expect_l, "line"); +is($id, "carp.t", "id"); + +# one level of indirection +sub id1 { my $level = shift; return CGI::Carp::id($level); }; + +$expect_l = __LINE__ + 1; +($file, $line, $id) = id1(1); +is($file, $expect_f, "file"); +is($line, $expect_l, "line"); +is($id, "carp.t", "id"); + +# two levels of indirection +sub id2 { my $level = shift; return id1($level); }; + +$expect_l = __LINE__ + 1; +($file, $line, $id) = id2(2); +is($file, $expect_f, "file"); +is($line, $expect_l, "line"); +is($id, "carp.t", "id"); + +#----------------------------------------------------------------------------- +# Test stamp +#----------------------------------------------------------------------------- + +my $stamp = "/^\\[ + ([a-z]{3}\\s){2}\\s? + [\\s\\d:]+ + \\]\\s$id:/ix"; + +like(CGI::Carp::stamp(), + $stamp, + "Time in correct format"); + +sub stamp1 {return CGI::Carp::stamp()}; +sub stamp2 {return stamp1()}; + +like(stamp2(), $stamp, "Time in correct format"); + +$CGI::Carp::FULL_PATH = 1; +# really should test the full path here, but platform differnces +# will make the regexp hideous. this may well fail if anything +# using it chdirs into t/ so using Cwd to dry to catch this +my $cwd = getcwd; +if ( $cwd !~ /t$/ ) { + unlike(stamp2(), $stamp, "Time in correct format (FULL_PATH)"); +} else { + pass( "Can't run FULL_PATH test when cwd is t/" ); +} +$CGI::Carp::FULL_PATH = 0; + +#----------------------------------------------------------------------------- +# Test warn and _warn +#----------------------------------------------------------------------------- + +# set some variables to control what's going on. +$CGI::Carp::WARN = 0; +$CGI::Carp::EMIT_WARNINGS = 0; +my $q_file = quotemeta($file); + + +# Test that realwarn is called +{ + local $^W = 0; + eval "sub CGI::Carp::realwarn {return 'Called realwarn'};"; +} + +$expect_l = __LINE__ + 1; +is(CGI::Carp::warn("There is a problem"), + "Called realwarn", + "CGI::Carp::warn calls CORE::warn"); + +# Test that message is constructed correctly +eval 'sub CGI::Carp::realwarn {my $mess = shift; return $mess};'; + +$expect_l = __LINE__ + 1; +like(CGI::Carp::warn("There is a problem"), + "/] $id: There is a problem at $q_file line $expect_l.".'$/', + "CGI::Carp::warn builds correct message"); + +# Test that _warn is called at the correct time +$CGI::Carp::WARN = 1; + +my $warn_expect_l = $expect_l = __LINE__ + 1; +like(CGI::Carp::warn("There is a problem"), + "/] $id: There is a problem at $q_file line $expect_l.".'$/', + "CGI::Carp::warn builds correct message"); + +# Test $NO_TIMESTAMP +{ + local $CGI::Carp::NO_TIMESTAMP = 1; + $expect_l = __LINE__ + 1; + like(CGI::Carp::warn("There is a problem"), + qr/\A\Q$id: There is a problem at $file line $expect_l.\E\s*\z/, + "noTimestamp"); + + local $CGI::Carp::NO_TIMESTAMP = 0; + $expect_l = __LINE__ + 2; + import CGI::Carp 'noTimestamp'; + like(CGI::Carp::warn("There is a problem"), + qr/\A\Q$id: There is a problem at $file line $expect_l.\E\s*\z/, + "noTimestamp"); +} + +#----------------------------------------------------------------------------- +# Test ineval +#----------------------------------------------------------------------------- + +ok(!CGI::Carp::ineval, 'ineval returns false when not in eval'); +eval {ok(CGI::Carp::ineval, 'ineval returns true when in eval');}; + +#----------------------------------------------------------------------------- +# Test die +#----------------------------------------------------------------------------- + +# set some variables to control what's going on. +$CGI::Carp::WRAP = 0; + +$expect_l = __LINE__ + 1; +eval { CGI::Carp::die('There is a problem'); }; +like($@, + '/^There is a problem/', + 'CGI::Carp::die calls CORE::die without altering argument in eval'); + +# Test that realwarn is called +{ + local $^W = 0; + local *CGI::Carp::realdie = sub { my $mess = shift; return $mess }; + + like(CGI::Carp::die('There is a problem'), + $stamp, + 'CGI::Carp::die calls CORE::die, but adds stamp'); + +} + +#----------------------------------------------------------------------------- +# Test set_message +#----------------------------------------------------------------------------- + +is(CGI::Carp::set_message('My new Message'), + 'My new Message', + 'CGI::Carp::set_message returns new message'); + +is($CGI::Carp::CUSTOM_MSG, + 'My new Message', + 'CGI::Carp::set_message message set correctly'); + +# set the message back to the empty string so that the tests later +# work properly. +CGI::Carp::set_message(''), + +#----------------------------------------------------------------------------- +# Test set_progname +#----------------------------------------------------------------------------- + +import CGI::Carp qw(name=new_progname); +is($CGI::Carp::PROGNAME, + 'new_progname', + 'CGI::Carp::import set program name correctly'); + +is(CGI::Carp::set_progname('newer_progname'), + 'newer_progname', + 'CGI::Carp::set_progname returns new program name'); + +is($CGI::Carp::PROGNAME, + 'newer_progname', + 'CGI::Carp::set_progname program name set correctly'); + +# set the message back to the empty string so that the tests later +# work properly. +is (CGI::Carp::set_progname(undef),undef,"CGI::Carp::set_progname returns unset name correctly"); +is ($CGI::Carp::PROGNAME,undef,"CGI::Carp::set_progname program name unset correctly"); + +#----------------------------------------------------------------------------- +# Test warnings_to_browser +#----------------------------------------------------------------------------- + +CGI::Carp::warningsToBrowser(0); +is($CGI::Carp::EMIT_WARNINGS, 0, "Warnings turned off"); + +# turn off STDOUT (prevents spurious warnings to screen +tie *STDOUT, 'StoreStuff' or die "Can't tie STDOUT"; +CGI::Carp::warningsToBrowser(1); +my $fake_out = join '', <STDOUT>; +untie *STDOUT; + +open(STDOUT, ">&REAL_STDOUT"); +my $fname = $0; +$fname =~ tr/<>-/\253\273\255/; # _warn does this so we have to also +is( $fake_out, "<!-- warning: There is a problem at $fname line $warn_expect_l. -->\n", + 'warningsToBrowser() on' ); + +is($CGI::Carp::EMIT_WARNINGS, 1, "Warnings turned off"); + +#----------------------------------------------------------------------------- +# Test fatals_to_browser +#----------------------------------------------------------------------------- + +package StoreStuff; + +sub TIEHANDLE { + my $class = shift; + bless [], $class; +} + +sub PRINT { + my $self = shift; + push @$self, @_; +} + +sub READLINE { + my $self = shift; + shift @$self; +} + +package main; + +tie *STDOUT, "StoreStuff"; + +# do tests +my @result; + +CGI::Carp::fatalsToBrowser(); +$result[0] .= $_ while (<STDOUT>); + +CGI::Carp::fatalsToBrowser('Message to the world'); +$result[1] .= $_ while (<STDOUT>); + +$ENV{SERVER_ADMIN} = 'foo@bar.com'; +CGI::Carp::fatalsToBrowser(); +$result[2] .= $_ while (<STDOUT>); + +CGI::Carp::set_message('Override the message passed in'), + +CGI::Carp::fatalsToBrowser('Message to the world'); +$result[3] .= $_ while (<STDOUT>); +CGI::Carp::set_message(''), +delete $ENV{SERVER_ADMIN}; + +# now restore STDOUT +untie *STDOUT; + + +like($result[0], + '/Content-type: text/html/', + "Default string has header"); + +ok($result[0] !~ /Message to the world/, "Custom message not in default string"); + +like($result[1], + '/Message to the world/', + "Custom Message appears in output"); + +ok($result[0] !~ /foo\@bar.com/, "Server Admin does not appear in default message"); + +like($result[2], + '/foo@bar.com/', + "Server Admin appears in output"); + +like($result[3], + '/Message to the world/', + "Custom message not in result"); + +like($result[3], + '/Override the message passed in/', + "Correct message in string"); + +#----------------------------------------------------------------------------- +# Test to_filehandle +#----------------------------------------------------------------------------- + +sub buffer { + CGI::Carp::to_filehandle (@_); +} + +tie *STORE, "StoreStuff"; + +require FileHandle; +my $fh = FileHandle->new; + +ok( defined buffer(\*STORE), '\*STORE returns proper filehandle'); +ok( defined buffer( $fh ), '$fh returns proper filehandle'); +ok( defined buffer('::STDOUT'), 'STDIN returns proper filehandle'); +ok( defined buffer(*main::STDOUT), 'STDIN returns proper filehandle'); +ok(!defined buffer("WIBBLE"), '"WIBBLE" doesn\'t returns proper filehandle'); + +# Calling die with code refs with no WRAP +{ + local $CGI::Carp::WRAP = 0; + + eval { CGI::Carp::die( 'regular string' ) }; + like $@ => qr/regular string/, 'die with string'; + + eval { CGI::Carp::die( [ 1..10 ] ) }; + like $@ => qr/ARRAY\(0x[\da-f]+\)/, 'die with array ref'; + + eval { CGI::Carp::die( { a => 1 } ) }; + like $@ => qr/HASH\(0x[\da-f]+\)/, 'die with hash ref'; + + eval { CGI::Carp::die( sub { 'Farewell' } ) }; + like $@ => qr/CODE\(0x[\da-f]+\)/, 'die with code ref'; + + eval { CGI::Carp::die( My::Plain::Object->new ) }; + isa_ok $@, 'My::Plain::Object'; + + eval { CGI::Carp::die( My::Plain::Object->new, ' and another argument' ) }; + like $@ => qr/My::Plain::Object/, 'object is stringified'; + like $@ => qr/and another argument/, 'second argument is present'; + + eval { CGI::Carp::die( My::Stringified::Object->new ) }; + isa_ok $@, 'My::Stringified::Object'; + + eval { CGI::Carp::die( My::Stringified::Object->new, ' and another argument' ) }; + like $@ => qr/stringified/, 'object is stringified'; + like $@ => qr/and another argument/, 'second argument is present'; + + eval { CGI::Carp::die() }; + like $@ => qr/Died at/, 'die with no argument'; +} + +# Calling die with code refs when WRAPped +{ + local $CGI::Carp::WRAP = 1; + local *CGI::Carp::realdie = sub { return @_ }; + local *STDOUT; + + tie *STDOUT, 'StoreStuff'; + + my %result; # store results because stdout is kidnapped + + CGI::Carp::die( 'regular string' ); + $result{string} .= $_ while <STDOUT>; + + CGI::Carp::die( [ 1..10 ] ); + $result{array_ref} .= $_ while <STDOUT>; + + CGI::Carp::die( { a => 1 } ); + $result{hash_ref} .= $_ while <STDOUT>; + + CGI::Carp::die( sub { 'Farewell' } ); + $result{code_ref} .= $_ while <STDOUT>; + + CGI::Carp::die( My::Plain::Object->new ); + $result{plain_object} .= $_ while <STDOUT>; + + CGI::Carp::die( My::Stringified::Object->new ); + $result{string_object} .= $_ while <STDOUT>; + + undef $@; + CGI::Carp::die(); + $result{no_args} .= $_ while <STDOUT>; + + $@ = "I think I caught a virus"; + CGI::Carp::die(); + $result{propagated} .= $_ while <STDOUT>; + + untie *STDOUT; + + like $result{string} => qr/regular string/, 'regular string, wrapped'; + like $result{array_ref} => qr/ARRAY\(\w+?\)/, 'array ref, wrapped'; + like $result{hash_ref} => qr/HASH\(\w+?\)/, 'hash ref, wrapped'; + like $result{code_ref} => qr/CODE\(\w+?\)/, 'code ref, wrapped'; + like $result{plain_object} => qr/My::Plain::Object/, + 'plain object, wrapped'; + like $result{string_object} => qr/stringified/, + 'stringified object, wrapped'; + like $result{no_args} => qr/Died at/, 'no args, wrapped'; + + like $result{propagated} => qr/I think I caught a virus\t\.{3}propagated/, + 'propagating $@ if no argument'; + +} + +{ + package My::Plain::Object; + + sub new { + return bless {}, shift; + } +} + +{ + package My::Stringified::Object; + + use overload '""' => sub { 'stringified' }; + + sub new { + return bless {}, shift; + } +} + + +@result = (); +tie *STDOUT, 'StoreStuff' or die "Can't tie STDOUT"; + { + eval { + $CGI::Carp::TO_BROWSER = 0; + die 'Message ToBrowser = 0'; + }; + $result[0] = $@; + $result[1] .= $_ while (<STDOUT>); + } +untie *STDOUT; + + like $result[0] => qr/Message ToBrowser/, 'die message for ToBrowser = 0 is OK'; + ok !$result[1], 'No output for ToBrowser = 0'; + +*CGI::Carp::die = sub { &$CGI::Carp::DIE_HANDLER; return 1 }; +*CGI::Carp::warn = sub { return 1 }; + +CGI::Carp::set_die_handler( sub { pass( "die handler" ); return 1 } ); +ok( CGI::Carp::confess(),'confess' ); +ok( CGI::Carp::croak(),'croak' ); +ok( CGI::Carp::carp(),'carp' ); +ok( CGI::Carp::cluck(),'cluck' ); + +use File::Temp; +my $fh = File::Temp->new; + +ok( CGI::Carp::carpout( $fh ),'carpout' ); @@ -0,0 +1,73 @@ +#!/usr/local/bin/perl + +# coverage for testing that doesn't sit elsewhere + +use strict; +use warnings; + +use Test::More tests => 25; +use Test::Deep; +use Test::Warn; + +use CGI (); + +# Set up a CGI environment +$ENV{REQUEST_METHOD} = 'GET'; +$ENV{QUERY_STRING} = 'game=chess&game=checkers&weather=dull'; + +isa_ok( my $q = CGI->new,'CGI' ); + +# undocumented ->r method, seems to be a temp store? +$q->r( 'foo' ); +is( $q->r,'foo','r' ); + +diag( "cgi-lib.pl routines" ); + +ok( $q->ReadParse,'ReadParse' ); +is( $q->PrintHeader,$q->header,'PrintHeader' ); +is( $q->HtmlTop,$q->start_html,'HtmlTop' ); +is( $q->HtmlBot,$q->end_html,'HtmlBot' ); + +cmp_deeply( + [ my @params = CGI::SplitParam( "foo\0bar" ) ], + [ qw/ foo bar /], + 'SplitParam' +); + +ok( $q->MethGet,'MethGet' ); +ok( ! $q->MethPost,'MethPost' ); +ok( ! $q->MethPut,'MethPut' ); + +note( "TIE methods" ); +ok( ! $q->FIRSTKEY,'FIRSTKEY' ); +ok( ! $q->NEXTKEY,'NEXTKEY' ); +ok( ! $q->CLEAR,'CLEAR' ); + +is( $q->version,$CGI::VERSION,'version' ); +is( $q->as_string,'<ul></ul>','as_string' ); + +is( ( $q->_style )[0],'<link rel="stylesheet" type="text/css" href="" />','_style' ); +is( $q->state,'http://localhost','state' ); + +$CGI::NOSTICKY = 0; +ok( $q->nosticky( 1 ),'nosticky' ); +is( $CGI::NOSTICKY,1,' ... sets $CGI::NOSTICKY' ); + +$CGI::NPH = 0; +ok( $q->nph( 1 ),'nph' ); +is( $CGI::NPH,1,' ... sets $CGI::NPH' ); + +$CGI::CLOSE_UPLOAD_FILES = 0; +ok( $q->close_upload_files( 1 ),'close_upload_files' ); +is( $CGI::CLOSE_UPLOAD_FILES,1,' ... sets $CGI::CLOSE_UPLOAD_FILES' ); + +cmp_deeply( + $q->default_dtd, + [ + '-//W3C//DTD HTML 4.01 Transitional//EN', + 'http://www.w3.org/TR/html4/loose.dtd' + ], + 'default_dtd' +); + +ok( ! $q->private_tempfiles,'private_tempfiles' ); diff --git a/t/changes.t b/t/changes.t new file mode 100644 index 0000000..1f40250 --- /dev/null +++ b/t/changes.t @@ -0,0 +1,12 @@ +#!perl + +use strict; +use warnings; + +use Test::More; + +eval 'use Test::CPAN::Changes'; + +plan skip_all => 'Test::CPAN::Changes required for this test' if $@; + +changes_ok(); diff --git a/t/charset.t b/t/charset.t new file mode 100644 index 0000000..7459797 --- /dev/null +++ b/t/charset.t @@ -0,0 +1,27 @@ +#!perl + +use strict; +use warnings; + +use Test::More 'no_plan'; + +use CGI; + +my $q = CGI->new; + +like( $q->header + , qr/charset=ISO-8859-1/, "charset ISO-8859-1 is set by default for default content-type"); +like( $q->header('application/json') + , qr/charset=ISO-8859-1/, "charset ISO-8859-1 is set by default for application/json content-type"); + +{ + $q->charset('UTF-8'); + my $out = $q->header('text/plain'); + like($out, qr{Content-Type: text/plain; charset=UTF-8}, "setting charset alters header of text/plain"); +} +{ + $q->charset('UTF-8'); + my $out = $q->header('application/json'); + like($out, qr{Content-Type: application/json; charset=UTF-8}, "setting charset alters header of application/json"); +} + diff --git a/t/checkbox_group.t b/t/checkbox_group.t new file mode 100644 index 0000000..ea5ad08 --- /dev/null +++ b/t/checkbox_group.t @@ -0,0 +1,21 @@ +#!/usr/local/bin/perl -w + +use Test::More tests => 3; + +BEGIN { use_ok('CGI'); }; +use CGI (':standard','-no_debug','-no_xhtml'); + +# no_xhtml test on checkbox_group() +is(checkbox_group(-name => 'game', + '-values' => [qw/checkers chess cribbage/], + '-defaults' => ['cribbage']), + qq(<input type="checkbox" name="game" value="checkers" >checkers <input type="checkbox" name="game" value="chess" >chess <input type="checkbox" name="game" value="cribbage" checked >cribbage), + 'checkbox_group()'); + +# xhtml test on checkbox_group() +$CGI::XHTML = 1; +is(checkbox_group(-name => 'game', + '-values' => [qw/checkers chess cribbage/], + '-defaults' => ['cribbage']), + qq(<label><input type="checkbox" name="game" value="checkers" />checkers</label> <label><input type="checkbox" name="game" value="chess" />chess</label> <label><input type="checkbox" name="game" value="cribbage" checked="checked" />cribbage</label>), + 'checkbox_group()'); diff --git a/t/compiles_pod.t b/t/compiles_pod.t new file mode 100644 index 0000000..076d016 --- /dev/null +++ b/t/compiles_pod.t @@ -0,0 +1,42 @@ +#!perl + +use strict; +use warnings; + +use Test::More; +use File::Find; + +if(($ENV{HARNESS_PERL_SWITCHES} || '') =~ /Devel::Cover/) { + plan skip_all => 'HARNESS_PERL_SWITCHES =~ /Devel::Cover/'; +} +if(!eval 'use Test::Pod; 1') { + *Test::Pod::pod_file_ok = sub { SKIP: { skip "pod_file_ok(@_) (Test::Pod is required)", 1 } }; +} +if(!eval 'use Test::Pod::Coverage; 1') { + *Test::Pod::Coverage::pod_coverage_ok = sub { SKIP: { skip "pod_coverage_ok(@_) (Test::Pod::Coverage is required)", 1 } }; +} + +my @files; + +find( + { + wanted => sub { /\.pm$/ and push @files, $File::Find::name }, + no_chdir => 1 + }, + -e 'blib' ? 'blib' : 'lib', +); + +plan tests => @files * 3; + +for my $file (@files) { + my $module = $file; $module =~ s,\.pm$,,; $module =~ s,.*/?lib/,,; $module =~ s,/,::,g; + ok eval "use $module; 1", "use $module" or diag $@; + Test::Pod::pod_file_ok($file); + TODO: { + # not enough POD coverage yet by a long way, also the nature + # of CGI.pm at present (most subs eval'd as strings) means + # this test isn't that much use - so mark as TODO for now + local $TODO = 'POD coverage'; + Test::Pod::Coverage::pod_coverage_ok($module); + } +} diff --git a/t/cookie.t b/t/cookie.t new file mode 100644 index 0000000..dda2f82 --- /dev/null +++ b/t/cookie.t @@ -0,0 +1,441 @@ +#!perl -w + +use strict; + +# to have a consistent baseline, we nail the current time +# to 100 seconds after the epoch +BEGIN { + *CORE::GLOBAL::time = sub { 100 }; +} + +use Test::More 'no_plan'; +use CGI::Util qw(escape unescape); +use POSIX qw(strftime); +use CGI::Cookie; + +#----------------------------------------------------------------------------- +# make sure module loaded +#----------------------------------------------------------------------------- + +my @test_cookie = ( + # including leading and trailing whitespace in first cookie + ' foo=123 ; bar=qwerty; baz=wibble; qux=a1', + 'foo=123; bar=qwerty; baz=wibble;', + 'foo=vixen; bar=cow; baz=bitch; qux=politician', + 'foo=a%20phrase; bar=yes%2C%20a%20phrase; baz=%5Ewibble; qux=%27', + ); + +#----------------------------------------------------------------------------- +# Test parse +#----------------------------------------------------------------------------- + +{ + my $result = CGI::Cookie->parse($test_cookie[0]); + is(ref($result), 'HASH', "Hash ref returned in scalar context"); + + my @result = CGI::Cookie->parse($test_cookie[0]); + is(@result, 8, "returns correct number of fields"); + + @result = CGI::Cookie->parse($test_cookie[1]); + is(@result, 6, "returns correct number of fields"); + + my %result = CGI::Cookie->parse($test_cookie[0]); + is($result{foo}->value, '123', "cookie foo is correct"); + is($result{bar}->value, 'qwerty', "cookie bar is correct"); + is($result{baz}->value, 'wibble', "cookie baz is correct"); + is($result{qux}->value, 'a1', "cookie qux is correct"); + + my @array = CGI::Cookie->parse(''); + my $scalar = CGI::Cookie->parse(''); + is_deeply(\@array, [], " parse('') returns an empty array in list context (undocumented)"); + is_deeply($scalar, {}, " parse('') returns an empty hashref in scalar context (undocumented)"); + + @array = CGI::Cookie->parse(undef); + $scalar = CGI::Cookie->parse(undef); + is_deeply(\@array, [], " parse(undef) returns an empty array in list context (undocumented)"); + is_deeply($scalar, {}, " parse(undef) returns an empty hashref in scalar context (undocumented)"); +} + +#----------------------------------------------------------------------------- +# Test fetch +#----------------------------------------------------------------------------- + +{ + # make sure there are no cookies in the environment + delete $ENV{HTTP_COOKIE}; + delete $ENV{COOKIE}; + + my %result = CGI::Cookie->fetch(); + ok(keys %result == 0, "No cookies in environment, returns empty list"); + + # now set a cookie in the environment and try again + $ENV{HTTP_COOKIE} = $test_cookie[2]; + %result = CGI::Cookie->fetch(); + ok(eq_set([keys %result], [qw(foo bar baz qux)]), + "expected cookies extracted"); + + is(ref($result{foo}), 'CGI::Cookie', 'Type of objects returned is correct'); + is($result{foo}->value, 'vixen', "cookie foo is correct"); + is($result{bar}->value, 'cow', "cookie bar is correct"); + is($result{baz}->value, 'bitch', "cookie baz is correct"); + is($result{qux}->value, 'politician', "cookie qux is correct"); + + # Delete that and make sure it goes away + delete $ENV{HTTP_COOKIE}; + %result = CGI::Cookie->fetch(); + ok(keys %result == 0, "No cookies in environment, returns empty list"); + + # try another cookie in the other environment variable thats supposed to work + $ENV{COOKIE} = $test_cookie[3]; + %result = CGI::Cookie->fetch(); + ok(eq_set([keys %result], [qw(foo bar baz qux)]), + "expected cookies extracted"); + + is(ref($result{foo}), 'CGI::Cookie', 'Type of objects returned is correct'); + is($result{foo}->value, 'a phrase', "cookie foo is correct"); + is($result{bar}->value, 'yes, a phrase', "cookie bar is correct"); + is($result{baz}->value, '^wibble', "cookie baz is correct"); + is($result{qux}->value, "'", "cookie qux is correct"); +} + +#----------------------------------------------------------------------------- +# Test raw_fetch +#----------------------------------------------------------------------------- + +{ + # make sure there are no cookies in the environment + delete $ENV{HTTP_COOKIE}; + delete $ENV{COOKIE}; + + my %result = CGI::Cookie->raw_fetch(); + ok(keys %result == 0, "No cookies in environment, returns empty list"); + + # now set a cookie in the environment and try again + $ENV{HTTP_COOKIE} = $test_cookie[2]; + %result = CGI::Cookie->raw_fetch(); + ok(eq_set([keys %result], [qw(foo bar baz qux)]), + "expected cookies extracted"); + + is(ref($result{foo}), '', 'Plain scalar returned'); + is($result{foo}, 'vixen', "cookie foo is correct"); + is($result{bar}, 'cow', "cookie bar is correct"); + is($result{baz}, 'bitch', "cookie baz is correct"); + is($result{qux}, 'politician', "cookie qux is correct"); + + # Delete that and make sure it goes away + delete $ENV{HTTP_COOKIE}; + %result = CGI::Cookie->raw_fetch(); + ok(keys %result == 0, "No cookies in environment, returns empty list"); + + # try another cookie in the other environment variable thats supposed to work + $ENV{COOKIE} = $test_cookie[3]; + %result = CGI::Cookie->raw_fetch(); + ok(eq_set([keys %result], [qw(foo bar baz qux)]), + "expected cookies extracted"); + + is(ref($result{foo}), '', 'Plain scalar returned'); + is($result{foo}, 'a%20phrase', "cookie foo is correct"); + is($result{bar}, 'yes%2C%20a%20phrase', "cookie bar is correct"); + is($result{baz}, '%5Ewibble', "cookie baz is correct"); + is($result{qux}, '%27', "cookie qux is correct"); + + $ENV{COOKIE} = '$Version=1; foo; $Path="/test"'; + %result = CGI::Cookie->raw_fetch(); + is($result{foo}, '', 'no value translates to empty string'); +} + +#----------------------------------------------------------------------------- +# Test new +#----------------------------------------------------------------------------- + +{ + # Try new with full information provided + my $c = CGI::Cookie->new(-name => 'foo', + -value => 'bar', + -expires => '+3M', + -domain => '.capricorn.com', + -path => '/cgi-bin/database', + -secure => 1, + -httponly=> 1 + ); + is(ref($c), 'CGI::Cookie', 'new returns objects of correct type'); + is($c->name , 'foo', 'name is correct'); + is($c->value , 'bar', 'value is correct'); + like($c->expires, '/^[a-z]{3},\s*\d{2}-[a-z]{3}-\d{4}/i', 'expires in correct format'); + is($c->domain , '.capricorn.com', 'domain is correct'); + is($c->path , '/cgi-bin/database', 'path is correct'); + ok($c->secure , 'secure attribute is set'); + ok( $c->httponly, 'httponly attribute is set' ); + + # now try it with the only two manditory values (should also set the default path) + $c = CGI::Cookie->new(-name => 'baz', + -value => 'qux', + ); + is(ref($c), 'CGI::Cookie', 'new returns objects of correct type'); + is($c->name , 'baz', 'name is correct'); + is($c->value , 'qux', 'value is correct'); + ok(!defined $c->expires, 'expires is not set'); + ok(!defined $c->max_age, 'max_age is not set'); + ok(!defined $c->domain , 'domain attributeis not set'); + is($c->path, '/', 'path atribute is set to default'); + ok(!defined $c->secure , 'secure attribute is set'); + ok( !defined $c->httponly, 'httponly attribute is not set' ); + +# I'm really not happy about the restults of this section. You pass +# the new method invalid arguments and it just merilly creates a +# broken object :-) +# I've commented them out because they currently pass but I don't +# think they should. I think this is testing broken behaviour :-( + +# # This shouldn't work +# $c = CGI::Cookie->new(-name => 'baz' ); +# +# is(ref($c), 'CGI::Cookie', 'new returns objects of correct type'); +# is($c->name , 'baz', 'name is correct'); +# ok(!defined $c->value, "Value is undefined "); +# ok(!defined $c->expires, 'expires is not set'); +# ok(!defined $c->domain , 'domain attributeis not set'); +# is($c->path , '/', 'path atribute is set to default'); +# ok(!defined $c->secure , 'secure attribute is set'); + +} + +#----------------------------------------------------------------------------- +# Test as_string +#----------------------------------------------------------------------------- + +{ + my $c = CGI::Cookie->new(-name => 'Jam', + -value => 'Hamster', + -expires => '+3M', + '-max-age' => '+3M', + -domain => '.pie-shop.com', + -path => '/', + -secure => 1, + -httponly=> 1 + ); + + my $name = $c->name; + like($c->as_string, "/$name/", "Stringified cookie contains name"); + + my $value = $c->value; + like($c->as_string, "/$value/", "Stringified cookie contains value"); + + my $expires = $c->expires; + like($c->as_string, "/$expires/", "Stringified cookie contains expires"); + + my $max_age = $c->max_age; + like($c->as_string, "/$max_age/", "Stringified cookie contains max_age"); + + my $domain = $c->domain; + like($c->as_string, "/$domain/", "Stringified cookie contains domain"); + + my $path = $c->path; + like($c->as_string, "/$path/", "Stringified cookie contains path"); + + like($c->as_string, '/secure/', "Stringified cookie contains secure"); + + like( $c->as_string, '/HttpOnly/', + "Stringified cookie contains HttpOnly" ); + + $c = CGI::Cookie->new(-name => 'Hamster-Jam', + -value => 'Tulip', + ); + + $name = $c->name; + like($c->as_string, "/$name/", "Stringified cookie contains name"); + + $value = $c->value; + like($c->as_string, "/$value/", "Stringified cookie contains value"); + + ok($c->as_string !~ /expires/, "Stringified cookie has no expires field"); + + ok($c->as_string !~ /max-age/, "Stringified cookie has no max-age field"); + + ok($c->as_string !~ /domain/, "Stringified cookie has no domain field"); + + $path = $c->path; + like($c->as_string, "/$path/", "Stringified cookie contains path"); + + ok($c->as_string !~ /secure/, "Stringified cookie does not contain secure"); + + ok( $c->as_string !~ /HttpOnly/, + "Stringified cookie does not contain HttpOnly" ); +} + +#----------------------------------------------------------------------------- +# Test compare +#----------------------------------------------------------------------------- + +{ + my $c1 = CGI::Cookie->new(-name => 'Jam', + -value => 'Hamster', + -expires => '+3M', + -domain => '.pie-shop.com', + -path => '/', + -secure => 1 + ); + + # have to use $c1->expires because the time will occasionally be + # different between the two creates causing spurious failures. + my $c2 = CGI::Cookie->new(-name => 'Jam', + -value => 'Hamster', + -expires => $c1->expires, + -domain => '.pie-shop.com', + -path => '/', + -secure => 1 + ); + + # This looks titally whacked, but it does the -1, 0, 1 comparison + # thing so 0 means they match + is($c1->compare("$c1"), 0, "Cookies are identical"); + is( "$c1", "$c2", "Cookies are identical"); + + $c1 = CGI::Cookie->new(-name => 'Jam', + -value => 'Hamster', + -domain => '.foo.bar.com' + ); + + # have to use $c1->expires because the time will occasionally be + # different between the two creates causing spurious failures. + $c2 = CGI::Cookie->new(-name => 'Jam', + -value => 'Hamster', + ); + + # This looks titally whacked, but it does the -1, 0, 1 comparison + # thing so 0 (i.e. false) means they match + is($c1->compare("$c1"), 0, "Cookies are identical"); + ok($c1->compare("$c2"), "Cookies are not identical"); + + $c2->domain('.foo.bar.com'); + is($c1->compare("$c2"), 0, "Cookies are identical"); +} + +#----------------------------------------------------------------------------- +# Test name, value, domain, secure, expires and path +#----------------------------------------------------------------------------- + +{ + my $c = CGI::Cookie->new(-name => 'Jam', + -value => 'Hamster', + -expires => '+3M', + -domain => '.pie-shop.com', + -path => '/', + -secure => 1 + ); + + is($c->name, 'Jam', 'name is correct'); + is($c->name('Clash'), 'Clash', 'name is set correctly'); + is($c->name, 'Clash', 'name now returns updated value'); + + # this is insane! it returns a simple scalar but can't accept one as + # an argument, you have to give it an arrary ref. It's totally + # inconsitent with these other methods :-( + is($c->value, 'Hamster', 'value is correct'); + is($c->value(['Gerbil']), 'Gerbil', 'value is set correctly'); + is($c->value, 'Gerbil', 'value now returns updated value'); + + my $exp = $c->expires; + like($c->expires, '/^[a-z]{3},\s*\d{2}-[a-z]{3}-\d{4}/i', 'expires is correct'); + like($c->expires('+12h'), '/^[a-z]{3},\s*\d{2}-[a-z]{3}-\d{4}/i', 'expires is set correctly'); + like($c->expires, '/^[a-z]{3},\s*\d{2}-[a-z]{3}-\d{4}/i', 'expires now returns updated value'); + isnt($c->expires, $exp, "Expiry time has changed"); + + is($c->domain, '.pie-shop.com', 'domain is correct'); + is($c->domain('.wibble.co.uk'), '.wibble.co.uk', 'domain is set correctly'); + is($c->domain, '.wibble.co.uk', 'domain now returns updated value'); + + is($c->path, '/', 'path is correct'); + is($c->path('/basket/'), '/basket/', 'path is set correctly'); + is($c->path, '/basket/', 'path now returns updated value'); + + ok($c->secure, 'secure attribute is set'); + ok(!$c->secure(0), 'secure attribute is cleared'); + ok(!$c->secure, 'secure attribute is cleared'); +} + +#---------------------------------------------------------------------------- +# Max-age +#---------------------------------------------------------------------------- + +MAX_AGE: { + my $cookie = CGI::Cookie->new( -name=>'a', value=>'b', '-expires' => 'now',); + is $cookie->expires, 'Thu, 01-Jan-1970 00:01:40 GMT'; + is $cookie->max_age => undef, 'max-age is undefined when setting expires'; + + $cookie = CGI::Cookie->new( -name=>'a', 'value'=>'b' ); + $cookie->max_age( '+4d' ); + + is $cookie->expires, undef, 'expires is undef when setting max_age'; + is $cookie->max_age => 4*24*60*60, 'setting via max-age'; + + $cookie->max_age( '113' ); + is $cookie->max_age => 13, 'max_age(num) as delta'; + + $cookie = CGI::Cookie->new( -name=>'a', value=>'b', '-max-age' => '+3d'); + is( $cookie->max_age,3*24*60*60,'-max-age in constructor' ); + ok( !$cookie->expires,' ... lack of expires' ); + + $cookie = CGI::Cookie->new( -name=>'a', value=>'b', '-expires' => 'now', '-max-age' => '+3d'); + is( $cookie->max_age,3*24*60*60,'-max-age in constructor' ); + ok( $cookie->expires,'-expires in constructor' ); +} + + +#---------------------------------------------------------------------------- +# bake +#---------------------------------------------------------------------------- + +BAKE: { + my $cookie = CGI::Cookie->new( -name=>'a', value=>'b', '-expires' => 'now',); + eval { $cookie->bake }; + is($@,'', "calling bake() without mod_perl should survive"); +} + +#----------------------------------------------------------------------------- +# Apache2?::Cookie compatibility. +#----------------------------------------------------------------------------- +APACHEREQ: { + my $r = Apache::Faker->new; + isa_ok $r, 'Apache'; + ok my $c = CGI::Cookie->new( + $r, + -name => 'Foo', + -value => 'Bar', + ), 'Pass an Apache object to the CGI::Cookie constructor'; + isa_ok $c, 'CGI::Cookie'; + ok $c->bake($r), 'Bake the cookie'; + ok eq_array( $r->{check}, [ 'Set-Cookie', $c->as_string ]), + 'bake() should call headers_out->set()'; + + $r = Apache2::Faker->new; + isa_ok $r, 'Apache2::RequestReq'; + ok $c = CGI::Cookie->new( + $r, + -name => 'Foo', + -value => 'Bar', + ), 'Pass an Apache::RequestReq object to the CGI::Cookie constructor'; + isa_ok $c, 'CGI::Cookie'; + ok $c->bake($r), 'Bake the cookie'; + ok eq_array( $r->{check}, [ 'Set-Cookie', $c->as_string ]), + 'bake() should call headers_out->set()'; +} + + +package Apache::Faker; +sub new { bless {}, shift } +sub isa { + my ($self, $pkg) = @_; + return $pkg eq 'Apache'; +} +sub headers_out { shift } +sub add { shift->{check} = \@_; } + +package Apache2::Faker; +sub new { bless {}, shift } +sub isa { + my ($self, $pkg) = @_; + return $pkg eq 'Apache2::RequestReq'; +} +sub headers_out { shift } +sub add { shift->{check} = \@_; } diff --git a/t/delete.t b/t/delete.t new file mode 100644 index 0000000..0fabad7 --- /dev/null +++ b/t/delete.t @@ -0,0 +1,59 @@ +#!/usr/local/bin/perl + +use strict; +use warnings; + +use Test::More; + +use CGI (); +use Config; + +my $loaded = 1; + +$| = 1; + +$CGI::LIST_CONTEXT_WARN = 0; + +######################### End of black magic. + +# Set up a CGI environment +$ENV{REQUEST_METHOD} = 'DELETE'; +$ENV{QUERY_STRING} = 'game=chess&game=checkers&weather=dull'; +$ENV{PATH_INFO} = '/somewhere/else'; +$ENV{PATH_TRANSLATED} = '/usr/local/somewhere/else'; +$ENV{SCRIPT_NAME} = '/cgi-bin/foo.cgi'; +$ENV{SERVER_PROTOCOL} = 'HTTP/1.0'; +$ENV{SERVER_PORT} = 8080; +$ENV{SERVER_NAME} = 'the.good.ship.lollypop.com'; +$ENV{REQUEST_URI} = "$ENV{SCRIPT_NAME}$ENV{PATH_INFO}?$ENV{QUERY_STRING}"; +$ENV{HTTP_LOVE} = 'true'; + +my $q = CGI->new; +ok $q,"CGI::new()"; +is $q->request_method => 'DELETE',"CGI::request_method()"; +is $q->query_string => 'game=chess;game=checkers;weather=dull',"CGI::query_string()"; +is $q->param(), 2,"CGI::param()"; +is join(' ',sort $q->param()), 'game weather',"CGI::param()"; +is $q->param('game'), 'chess',"CGI::param()"; +is $q->param('weather'), 'dull',"CGI::param()"; +is join(' ',$q->param('game')), 'chess checkers',"CGI::param()"; +ok $q->param(-name=>'foo',-value=>'bar'),'CGI::param() put'; +is $q->param(-name=>'foo'), 'bar','CGI::param() get'; +is $q->query_string, 'game=chess;game=checkers;weather=dull;foo=bar',"CGI::query_string() redux"; +is $q->http('love'), 'true',"CGI::http()"; +is $q->script_name, '/cgi-bin/foo.cgi',"CGI::script_name()"; +is $q->url, 'http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi',"CGI::url()"; +is $q->self_url, + 'http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi/somewhere/else?game=chess;game=checkers;weather=dull;foo=bar', + "CGI::url()"; +is $q->url(-absolute=>1), '/cgi-bin/foo.cgi','CGI::url(-absolute=>1)'; +is $q->url(-relative=>1), 'foo.cgi','CGI::url(-relative=>1)'; +is $q->url(-relative=>1,-path=>1), 'foo.cgi/somewhere/else','CGI::url(-relative=>1,-path=>1)'; +is $q->url(-relative=>1,-path=>1,-query=>1), + 'foo.cgi/somewhere/else?game=chess;game=checkers;weather=dull;foo=bar', + 'CGI::url(-relative=>1,-path=>1,-query=>1)'; +$q->delete('foo'); +ok !$q->param('foo'),'CGI::delete()'; + + +done_testing(); diff --git a/t/end_form.t b/t/end_form.t new file mode 100644 index 0000000..6a13e0b --- /dev/null +++ b/t/end_form.t @@ -0,0 +1,9 @@ + +use strict; +use warnings; + +use Test::More tests => 2; + +BEGIN { use_ok 'CGI', qw/ :form / }; + +is end_form() => '</form>', 'end_form()'; diff --git a/t/form.t b/t/form.t new file mode 100644 index 0000000..0a90b9c --- /dev/null +++ b/t/form.t @@ -0,0 +1,235 @@ +#!perl -w + +# Form-related tests for CGI.pm +# If you are adding or updated tests, please put tests for each methods in +# their own file, rather than growing this file any larger. + +use Test::More 'no_plan'; +use CGI (':standard','-no_debug','-tabindex'); + +my $CRLF = "\015\012"; +if ($^O eq 'VMS') { + $CRLF = "\n"; # via web server carriage is inserted automatically +} +if (ord("\t") != 9) { # EBCDIC? + $CRLF = "\r\n"; +} + + +# Set up a CGI environment +$ENV{REQUEST_METHOD} = 'GET'; +$ENV{QUERY_STRING} = 'game=chess&game=checkers&weather=dull'; +$ENV{PATH_INFO} = '/somewhere/else'; +$ENV{PATH_TRANSLATED} = '/usr/local/somewhere/else'; +$ENV{SCRIPT_NAME} ='/cgi-bin/foo.cgi'; +$ENV{SERVER_PROTOCOL} = 'HTTP/1.0'; +$ENV{SERVER_PORT} = 8080; +$ENV{SERVER_NAME} = 'the.good.ship.lollypop.com'; + +is(start_form(-action=>'foobar',-method=>'get'), + qq(<form method="get" action="foobar" enctype="multipart/form-data">), + "start_form()"); + +is(submit(), + qq(<input type="submit" tabindex="1" name=".submit" />), + "submit()"); + +is(submit(-name => 'foo', + -value => 'bar'), + qq(<input type="submit" tabindex="2" name="foo" value="bar" />), + "submit(-name,-value)"); + +is(submit({-name => 'foo', + -value => 'bar'}), + qq(<input type="submit" tabindex="3" name="foo" value="bar" />), + "submit({-name,-value})"); + +is(textfield(-name => 'weather'), + qq(<input type="text" name="weather" tabindex="4" value="dull" />), + "textfield({-name})"); + +is(textfield(-name => 'weather', + -value => 'nice'), + qq(<input type="text" name="weather" tabindex="5" value="dull" />), + "textfield({-name,-value})"); + +is(textfield(-name => 'weather', + -value => 'nice', + -override => 1), + qq(<input type="text" name="weather" tabindex="6" value="nice" />), + "textfield({-name,-value,-override})"); + +is(checkbox(-name => 'weather', + -value => 'nice'), + qq(<label><input type="checkbox" name="weather" value="nice" tabindex="7" />weather</label>), + "checkbox()"); + +is(checkbox(-name => 'weather', + -value => 'nice', + -label => 'forecast'), + qq(<label><input type="checkbox" name="weather" value="nice" tabindex="8" />forecast</label>), + "checkbox()"); + +is(checkbox(-name => 'weather', + -value => 'nice', + -label => 'forecast', + -checked => 1, + -override => 1), + qq(<label><input type="checkbox" name="weather" value="nice" tabindex="9" checked="checked" />forecast</label>), + "checkbox()"); + +is(checkbox(-name => 'weather', + -value => 'dull', + -label => 'forecast'), + qq(<label><input type="checkbox" name="weather" value="dull" tabindex="10" checked="checked" />forecast</label>), + "checkbox()"); + +is(radio_group(-name => 'game'), + qq(<label><input type="radio" name="game" value="chess" checked="checked" tabindex="11" />chess</label> <label><input type="radio" name="game" value="checkers" tabindex="12" />checkers</label>), + 'radio_group()'); + +is(radio_group(-name => 'game', + -labels => {'chess' => 'ping pong'}), + qq(<label><input type="radio" name="game" value="chess" checked="checked" tabindex="13" />ping pong</label> <label><input type="radio" name="game" value="checkers" tabindex="14" />checkers</label>), + 'radio_group()'); + +is(checkbox_group(-name => 'game', + -Values => [qw/checkers chess cribbage/]), + qq(<label><input type="checkbox" name="game" value="checkers" checked="checked" tabindex="15" />checkers</label> <label><input type="checkbox" name="game" value="chess" checked="checked" tabindex="16" />chess</label> <label><input type="checkbox" name="game" value="cribbage" tabindex="17" />cribbage</label>), + 'checkbox_group()'); + +is(checkbox_group(-name => 'game', + '-values' => [qw/checkers chess cribbage/], + '-defaults' => ['cribbage'], + -override=>1), + qq(<label><input type="checkbox" name="game" value="checkers" tabindex="18" />checkers</label> <label><input type="checkbox" name="game" value="chess" tabindex="19" />chess</label> <label><input type="checkbox" name="game" value="cribbage" checked="checked" tabindex="20" />cribbage</label>), + 'checkbox_group()'); + +is(popup_menu(-name => 'game', + '-values' => [qw/checkers chess cribbage/], + -default => 'cribbage', + -override => 1), + '<select name="game" tabindex="21" > +<option value="checkers">checkers</option> +<option value="chess">chess</option> +<option selected="selected" value="cribbage">cribbage</option> +</select>', + 'popup_menu()'); +is(scrolling_list(-name => 'game', + '-values' => [qw/checkers chess cribbage/], + -default => 'cribbage', + -override=>1), + '<select name="game" tabindex="22" size="3"> +<option value="checkers">checkers</option> +<option value="chess">chess</option> +<option selected="selected" value="cribbage">cribbage</option> +</select>', + 'scrolling_list()'); + +is(checkbox_group(-name => 'game', + -Values => [qw/checkers chess cribbage/], + -disabled => ['checkers']), + qq(<label><input type="checkbox" name="game" value="checkers" checked="checked" tabindex="23" disabled='1'/><span style="color:gray">checkers</span></label> <label><input type="checkbox" name="game" value="chess" checked="checked" tabindex="24" />chess</label> <label><input type="checkbox" name="game" value="cribbage" tabindex="25" />cribbage</label>), + 'checkbox_group()'); + +my $optgroup = optgroup(-name=>'optgroup_name', + -Values => ['moe','catch'], + -attributes=>{'catch'=>{'class'=>'red'}}); + +is($optgroup, + qq(<optgroup label="optgroup_name"> +<option value="moe">moe</option> +<option class="red" value="catch">catch</option> +</optgroup>), + 'optgroup()'); + +is(popup_menu(-name=>'menu_name', + -Values=>[qw/eenie meenie minie/, $optgroup], + -labels=>{'eenie'=>'one', + 'meenie'=>'two', + 'minie'=>'three'}, + -default=>'meenie'), + qq(<select name="menu_name" tabindex="26" > +<option value="eenie">one</option> +<option selected="selected" value="meenie">two</option> +<option value="minie">three</option> +<optgroup label="optgroup_name"> +<option value="moe">moe</option> +<option class="red" value="catch">catch</option> +</optgroup> +</select>), + 'popup_menu() + optgroup()'); + +is(scrolling_list(-name=>'menu_name', + -Values=>[qw/eenie meenie minie/, $optgroup], + -labels=>{'eenie'=>'one', + 'meenie'=>'two', + 'minie'=>'three'}, + -default=>'meenie'), + qq(<select name="menu_name" tabindex="27" size="4"> +<option value="eenie">one</option> +<option selected="selected" value="meenie">two</option> +<option value="minie">three</option> +<optgroup label="optgroup_name"> +<option value="moe">moe</option> +<option class="red" value="catch">catch</option> +</optgroup> +</select>), + 'scrolling_list() + optgroup()'); + +# ---------- START 22046 ---------- +# The following tests were added for +# https://rt.cpan.org/Public/Bug/Display.html?id=22046 +# SHCOREY at cpan.org +# Saved whether working with XHTML because need to test both +# with it and without. +my $saved_XHTML = $CGI::XHTML; + +# set XHTML +$CGI::XHTML = 1; + +is(start_form("GET","/foobar"), + qq{<form method="get" action="/foobar" enctype="multipart/form-data">}, + 'start_form() + XHTML'); + +is(start_form("GET", "/foobar",&CGI::URL_ENCODED), + qq{<form method="get" action="/foobar" enctype="application/x-www-form-urlencoded">}, + 'start_form() + XHTML + URL_ENCODED'); + +is(start_form("GET", "/foobar",&CGI::MULTIPART), + qq{<form method="get" action="/foobar" enctype="multipart/form-data">}, + 'start_form() + XHTML + MULTIPART'); + +is(start_multipart_form("GET", "/foobar"), + qq{<form method="get" action="/foobar" enctype="multipart/form-data">}, + 'start_multipart_form() + XHTML'); + +is(start_multipart_form("GET", "/foobar","name=\"foobar\""), + qq{<form method="get" action="/foobar" enctype="multipart/form-data" name="foobar">}, + 'start_multipart_form() + XHTML + additional args'); + +# set no XHTML +$CGI::XHTML = 0; + +is(start_form("GET","/foobar"), + qq{<form method="get" action="/foobar" enctype="application/x-www-form-urlencoded">}, + 'start_form() + NO_XHTML'); + +is(start_form("GET", "/foobar",&CGI::URL_ENCODED), + qq{<form method="get" action="/foobar" enctype="application/x-www-form-urlencoded">}, + 'start_form() + NO_XHTML + URL_ENCODED'); + +is(start_form("GET", "/foobar",&CGI::MULTIPART), + qq{<form method="get" action="/foobar" enctype="multipart/form-data">}, + 'start_form() + NO_XHTML + MULTIPART'); + +is(start_multipart_form("GET", "/foobar"), + qq{<form method="get" action="/foobar" enctype="multipart/form-data">}, + 'start_multipart_form() + NO_XHTML'); + +is(start_multipart_form("GET", "/foobar","name=\"foobar\""), + qq{<form method="get" action="/foobar" enctype="multipart/form-data" name="foobar">}, + 'start_multipart_form() + NO_XHTML + additional args'); + +# restoring value +$CGI::XHTML = $saved_XHTML; diff --git a/t/function.t b/t/function.t new file mode 100644 index 0000000..56fa0c1 --- /dev/null +++ b/t/function.t @@ -0,0 +1,110 @@ +#!/usr/local/bin/perl -w + +BEGIN {$| = 1; print "1..33\n"; } +END {print "not ok 1\n" unless $loaded;} +use Config; +use CGI (':standard','keywords'); +$loaded = 1; +$CGI::Util::SORT_ATTRIBUTES = 1; +$CGI::LIST_CONTEXT_WARN = 0; +print "ok 1\n"; + +######################### End of black magic. + +# util +sub test { + local($^W) = 0; + my($num, $true,$msg) = @_; + print($true ? "ok $num\n" : "not ok $num $msg\n"); +} + +my $CRLF = "\015\012"; + +# A peculiarity of sending "\n" through MBX|Socket|web-server on VMS +# is that a CR character gets inserted automatically in the web server +# case but not internal to perl's double quoted strings "\n". This +# test would need to be modified to use the "\015\012" on VMS if it +# were actually run through a web server. +# Thanks to Peter Prymmer for this + +if ($^O eq 'VMS') { $CRLF = "\n"; } + +# Web servers on EBCDIC hosts are typically set up to do an EBCDIC -> ASCII +# translation hence CRLF is used as \r\n within CGI.pm on such machines. + +if (ord("\t") != 9) { $CRLF = "\r\n"; } + +# Set up a CGI environment +$ENV{REQUEST_METHOD}='GET'; +$ENV{QUERY_STRING} ='game=chess&game=checkers&weather=dull'; +$ENV{PATH_INFO} ='/somewhere/else'; +$ENV{PATH_TRANSLATED} ='/usr/local/somewhere/else'; +$ENV{SCRIPT_NAME} ='/cgi-bin/foo.cgi'; +$ENV{SERVER_PROTOCOL} = 'HTTP/1.0'; +$ENV{SERVER_PORT} = 8080; +$ENV{SERVER_NAME} = 'the.good.ship.lollypop.com'; +$ENV{HTTP_LOVE} = 'true'; + +test(2,request_method() eq 'GET',"CGI::request_method()"); +test(3,query_string() eq 'game=chess;game=checkers;weather=dull',"CGI::query_string()"); +test(4,param() == 2,"CGI::param()"); +test(5,join(' ',sort {$a cmp $b} param()) eq 'game weather',"CGI::param()"); +test(6,param('game') eq 'chess',"CGI::param()"); +test(7,param('weather') eq 'dull',"CGI::param()"); +test(8,join(' ',param('game')) eq 'chess checkers',"CGI::param()"); +test(9,param(-name=>'foo',-value=>'bar'),'CGI::param() put'); +test(10,param(-name=>'foo') eq 'bar','CGI::param() get'); +test(11,query_string() eq 'game=chess;game=checkers;weather=dull;foo=bar',"CGI::query_string() redux"); +test(12,http('love') eq 'true',"CGI::http()"); +test(13,script_name() eq '/cgi-bin/foo.cgi',"CGI::script_name()"); +test(14,url() eq 'http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi',"CGI::url()"); +test(15,self_url() eq + 'http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi/somewhere/else?game=chess;game=checkers;weather=dull;foo=bar', + "CGI::url()"); +test(16,url(-absolute=>1) eq '/cgi-bin/foo.cgi','CGI::url(-absolute=>1)'); +test(17,url(-relative=>1) eq 'foo.cgi','CGI::url(-relative=>1)'); +test(18,url(-relative=>1,-path=>1) eq 'foo.cgi/somewhere/else','CGI::url(-relative=>1,-path=>1)'); +test(19,url(-relative=>1,-path=>1,-query=>1) eq + 'foo.cgi/somewhere/else?game=chess;game=checkers;weather=dull;foo=bar', + 'CGI::url(-relative=>1,-path=>1,-query=>1)'); +Delete('foo'); +test(20,!param('foo'),'CGI::delete()'); + +CGI::_reset_globals(); +$ENV{QUERY_STRING}='mary+had+a+little+lamb'; +test(21,join(' ',keywords()) eq 'mary had a little lamb','CGI::keywords'); +test(22,join(' ',param('keywords')) eq 'mary had a little lamb','CGI::keywords'); + +CGI::_reset_globals; +if ($Config{d_fork}) { + $test_string = 'game=soccer&game=baseball&weather=nice'; + $ENV{REQUEST_METHOD}='POST'; + $ENV{CONTENT_LENGTH}=length($test_string); + $ENV{QUERY_STRING}='big_balls=basketball&small_balls=golf'; + if (open(CHILD,"|-")) { # cparent + print CHILD $test_string; + close CHILD; + exit 0; + } + # at this point, we're in a new (child) process + test(23,param('weather') eq 'nice',"CGI::param() from POST"); + test(24,(url_param('big_balls') eq 'basketball'),"CGI::url_param()"); +} else { + print "ok 23 # Skip\n"; + print "ok 24 # Skip\n"; +} +test(25,redirect('http://somewhere.else') eq "Status: 302 Found${CRLF}Location: http://somewhere.else${CRLF}${CRLF}","CGI::redirect() 1"); +my $h = redirect(-Location=>'http://somewhere.else',-Type=>'text/html'); +test(26,$h eq "Status: 302 Found${CRLF}Location: http://somewhere.else${CRLF}Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}","CGI::redirect() 2"); +test(27,redirect(-Location=>'http://somewhere.else/bin/foo&bar',-Type=>'text/html') eq "Status: 302 Found${CRLF}Location: http://somewhere.else/bin/foo&bar${CRLF}Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}","CGI::redirect() 2"); + +test(28,escapeHTML('CGI') eq 'CGI','escapeHTML(CGI) failing again'); + +test(29, charset("UTF-8") && header() eq "Content-Type: text/html; charset=UTF-8${CRLF}${CRLF}", "UTF-8 charset"); +test(30, !charset("") && header() eq "Content-Type: text/html${CRLF}${CRLF}", "Empty charset"); + +test(31, header(-foo=>'bar') eq "Foo: bar${CRLF}Content-Type: text/html${CRLF}${CRLF}", "Custom header"); + +test(32, start_form(-action=>'one',name=>'two',onsubmit=>'three') eq qq(<form method="post" action="one" enctype="multipart/form-data" name="two" onsubmit="three">), "initial dash followed by undashed arguments"); +$ENV{QUERY_STRING} ='game=chess&game=checkers&weather=dull'; +test(33,env_query_string() eq $ENV{QUERY_STRING},"CGI::env_query_string()"); diff --git a/t/gh-155.t b/t/gh-155.t new file mode 100644 index 0000000..0c198b0 --- /dev/null +++ b/t/gh-155.t @@ -0,0 +1,23 @@ +use strict; +use warnings; +use Test::More; + +use CGI; + +for (1 .. 20) { + my $q = CGI->new; + + my %args = ( + '-charset' => 'UTF-8', + '-type' => 'text/html', + '-content-type' => 'text/html; charset=iso-8859-1', + ); + + like( + $q->header(%args), + qr!Content-Type: text/html; charset=iso-8859-1!, + 'favour content type over charset/type' + ); +} + +done_testing(); diff --git a/t/headers.t b/t/headers.t new file mode 100644 index 0000000..a062f47 --- /dev/null +++ b/t/headers.t @@ -0,0 +1,54 @@ + +# Test that header generation is spec compliant. +# References: +# http://www.w3.org/Protocols/rfc2616/rfc2616.html +# http://www.w3.org/Protocols/rfc822/3_Lexical.html + +use strict; +use warnings; + +use Test::More 'no_plan'; + +use CGI; + +my $cgi = CGI->new; + +like $cgi->header( -type => "text/html" ), + qr#Type: text/html#, 'known header, basic case: type => "text/html"'; + +eval { $cgi->header( -type => "text/html".$CGI::CRLF."evil: stuff" ) }; +like($@,qr/contains a newline/,'invalid header blows up'); + +like $cgi->header( -type => "text/html".$CGI::CRLF." evil: stuff " ), + qr#Content-Type: text/html evil: stuff#, 'known header, with leading and trailing whitespace on the continuation line'; + +eval { $cgi->header( -p3p => ["foo".$CGI::CRLF."bar"] ) }; +like($@,qr/contains a newline/,'P3P header with CRLF embedded blows up'); + +eval { $cgi->header( -cookie => ["foo".$CGI::CRLF."bar"] ) }; +like($@,qr/contains a newline/,'Set-Cookie header with CRLF embedded blows up'); + +eval { $cgi->header( -foobar => "text/html".$CGI::CRLF."evil: stuff" ) }; +like($@,qr/contains a newline/,'unknown header with CRLF embedded blows up'); + +eval { $cgi->header( -foobar => $CGI::CRLF."Content-type: evil/header" ) }; +like($@,qr/contains a newline/, 'unknown header with leading newlines blows up'); + +eval { $cgi->redirect( -type => "text/html".$CGI::CRLF."evil: stuff" ) }; +like($@,qr/contains a newline/,'redirect with known header with CRLF embedded blows up'); + +eval { $cgi->redirect( -foobar => "text/html".$CGI::CRLF."evil: stuff" ) }; +like($@,qr/contains a newline/,'redirect with unknown header with CRLF embedded blows up'); + +eval { $cgi->redirect( $CGI::CRLF.$CGI::CRLF."Content-Type: text/html") }; +like($@,qr/contains a newline/,'redirect with leading newlines blows up'); + +{ + my $cgi = CGI->new('t=bogus%0A%0A<html>'); + my $out; + $CGI::LIST_CONTEXT_WARN = 0; + eval { $out = $cgi->redirect( $cgi->param('t') ) }; + like($@,qr/contains a newline/, "redirect does not allow double-newline injection"); +} + + diff --git a/t/headers/attachment.t b/t/headers/attachment.t new file mode 100644 index 0000000..967e9b8 --- /dev/null +++ b/t/headers/attachment.t @@ -0,0 +1,23 @@ +use strict; +use CGI; +use Test::More; + +{ + my $cgi = CGI->new; + my $got = $cgi->header( -attachment => 'foo.png' ); + my $expected = 'Content-Disposition: attachment; filename="foo.png"' + . $CGI::CRLF + . 'Content-Type: text/html; charset=ISO-8859-1' + . $CGI::CRLF x 2; + is $got, $expected, 'attachment'; +} + +{ + my $cgi = CGI->new; + my $got = $cgi->header( -attachment => q{} ); + my $expected = "Content-Type: text/html; charset=ISO-8859-1" + . $CGI::CRLF x 2; + is $got, $expected, 'attachment empty string'; +} + +done_testing; diff --git a/t/headers/charset.t b/t/headers/charset.t new file mode 100644 index 0000000..500bd9b --- /dev/null +++ b/t/headers/charset.t @@ -0,0 +1,20 @@ +use strict; +use CGI; +use Test::More; + +{ + my $cgi = CGI->new; + my $got = $cgi->header( -charset => 'utf-8' ); + my $expected = 'Content-Type: text/html; charset=utf-8' + . $CGI::CRLF x 2; + is $got, $expected, 'charset'; +} + +{ + my $cgi = CGI->new; + my $got = $cgi->header( -charset => q{} ); + my $expected = 'Content-Type: text/html' . $CGI::CRLF x 2; + is $got, $expected, 'charset empty string'; +} + +done_testing; diff --git a/t/headers/cookie.t b/t/headers/cookie.t new file mode 100644 index 0000000..a62f6fd --- /dev/null +++ b/t/headers/cookie.t @@ -0,0 +1,34 @@ +use strict; +use CGI; +use Test::More; + +{ + my $cgi = CGI->new; + my $got = $cgi->header( -cookie => 'foo' ); + my $expected = "^Set-Cookie: foo$CGI::CRLF" + . "Date: [^$CGI::CRLF]+$CGI::CRLF" + . 'Content-Type: text/html; charset=ISO-8859-1' + . $CGI::CRLF x 2; + like $got, qr($expected), 'cookie'; +} + +{ + my $cgi = CGI->new; + my $got = $cgi->header( -cookie => [ 'foo', 'bar' ] ); + my $expected = "^Set-Cookie: foo$CGI::CRLF" + . "Set-Cookie: bar$CGI::CRLF" + . "Date: [^$CGI::CRLF]+$CGI::CRLF" + . 'Content-Type: text/html; charset=ISO-8859-1' + . $CGI::CRLF x 2; + like $got, qr($expected), 'cookie arrayref'; +} + +{ + my $cgi = CGI->new; + my $got = $cgi->header( -cookie => q{} ); + my $expected = 'Content-Type: text/html; charset=ISO-8859-1' + . $CGI::CRLF x 2; + is $got, $expected, 'cookie empty string'; +} + +done_testing; diff --git a/t/headers/default.t b/t/headers/default.t new file mode 100644 index 0000000..007c6ea --- /dev/null +++ b/t/headers/default.t @@ -0,0 +1,13 @@ +use strict; +use CGI; +use Test::More; + +{ + my $cgi = CGI->new; + my $got = $cgi->header(); + my $expected = 'Content-Type: text/html; charset=ISO-8859-1' + . $CGI::CRLF x 2; + is $got, $expected, 'default'; +} + +done_testing; diff --git a/t/headers/nph.t b/t/headers/nph.t new file mode 100644 index 0000000..5d0e5e7 --- /dev/null +++ b/t/headers/nph.t @@ -0,0 +1,24 @@ +use strict; +use CGI; +use Test::More; + +{ + my $cgi = CGI->new; + my $got = $cgi->header( -nph => 1 ); + my $expected = "^HTTP/1.0 200 OK$CGI::CRLF" + . "Server: cmdline$CGI::CRLF" + . "Date: [^$CGI::CRLF]+$CGI::CRLF" + . 'Content-Type: text/html; charset=ISO-8859-1' + . $CGI::CRLF x 2; + like $got, qr($expected), 'nph'; +} + +{ + my $cgi = CGI->new; + my $got = $cgi->header( -nph => 0 ); + my $expected = 'Content-Type: text/html; charset=ISO-8859-1' + . $CGI::CRLF x 2; + is $got, $expected, 'nph'; +} + +done_testing; diff --git a/t/headers/p3p.t b/t/headers/p3p.t new file mode 100644 index 0000000..e10c073 --- /dev/null +++ b/t/headers/p3p.t @@ -0,0 +1,33 @@ +use strict; +use CGI; +use Test::More; + +{ + my $cgi = CGI->new; + my $got = $cgi->header( -p3p => "CAO DSP LAW CURa" ); + my $expected = 'P3P: policyref="/w3c/p3p.xml", CP="CAO DSP LAW CURa"' + . $CGI::CRLF + . 'Content-Type: text/html; charset=ISO-8859-1' + . $CGI::CRLF x 2; + is $got, $expected, 'p3p'; +} + +{ + my $cgi = CGI->new; + my $got = $cgi->header( -p3p => [ qw/CAO DSP LAW CURa/ ] ); + my $expected = 'P3P: policyref="/w3c/p3p.xml", CP="CAO DSP LAW CURa"' + . $CGI::CRLF + . 'Content-Type: text/html; charset=ISO-8859-1' + . $CGI::CRLF x 2; + is $got, $expected, 'p3p arrayref'; +} + +{ + my $cgi = CGI->new; + my $got = $cgi->header( -p3p => q{} ); + my $expected = 'Content-Type: text/html; charset=ISO-8859-1' + . $CGI::CRLF x 2; + is $got, $expected, 'p3p empty string'; +} + +done_testing; diff --git a/t/headers/target.t b/t/headers/target.t new file mode 100644 index 0000000..96c95d1 --- /dev/null +++ b/t/headers/target.t @@ -0,0 +1,22 @@ +use strict; +use CGI; +use Test::More; + +{ + my $cgi = CGI->new; + my $got = $cgi->header( -target => 'ResultsWindow' ); + my $expected = "Window-Target: ResultsWindow$CGI::CRLF" + . 'Content-Type: text/html; charset=ISO-8859-1' + . $CGI::CRLF x 2; + is $got, $expected, 'target'; +} + +{ + my $cgi = CGI->new; + my $got = $cgi->header( -target => q{} ); + my $expected = 'Content-Type: text/html; charset=ISO-8859-1' + . $CGI::CRLF x 2; + is $got, $expected, 'target empty string'; +} + +done_testing; diff --git a/t/headers/type.t b/t/headers/type.t new file mode 100644 index 0000000..536a8b7 --- /dev/null +++ b/t/headers/type.t @@ -0,0 +1,101 @@ +use strict; +use CGI; +use Test::More; + +{ + my $cgi = CGI->new; + my $got = $cgi->header( -type => 'text/plain' ); + my $expected = 'Content-Type: text/plain; charset=ISO-8859-1' + . $CGI::CRLF x 2; + is $got, $expected, 'type'; +} + +{ + my $cgi = CGI->new; + my $got = $cgi->header( -type => q{} ); + my $expected = $CGI::CRLF x 2; + is $got, $expected, 'type empty string'; +} + +{ + my $cgi = CGI->new; + my $got = $cgi->header( -type => 'text/plain; charset=utf-8' ); + my $expected = 'Content-Type: text/plain; charset=utf-8' + . $CGI::CRLF x 2; + is $got, $expected, 'type defines charset'; +} + +{ + my $cgi = CGI->new; + my $got = $cgi->header( + '-type' => 'text/plain', + '-charset' => 'utf-8', + ); + my $expected = 'Content-Type: text/plain; charset=utf-8' + . $CGI::CRLF x 2; + is $got, $expected, 'type and charset'; +} + +{ + my $cgi = CGI->new; + my $got = $cgi->header( + '-type' => q{}, + '-charset' => 'utf-8', + ); + my $expected = $CGI::CRLF x 2; + is $got, $expected, 'type and charset, type is empty string'; +} + +{ + my $cgi = CGI->new; + my $got = $cgi->header( + '-type' => 'text/plain; charset=utf-8', + '-charset' => q{}, + ); + my $expected = 'Content-Type: text/plain; charset=utf-8' + . $CGI::CRLF x 2; + is $got, $expected, 'type and charset, charset is empty string'; +} + +{ + my $cgi = CGI->new; + my $got = $cgi->header( + '-type' => 'text/plain; charset=utf-8', + '-charset' => 'EUC-JP', + ); + my $expected = 'Content-Type: text/plain; charset=utf-8' + . $CGI::CRLF x 2; + is $got, $expected, 'type and charset, type defines charset'; +} + +{ + my $cgi = CGI->new; + my $got = $cgi->header( -type => 'image/gif' ); + my $expected = 'Content-Type: image/gif; charset=ISO-8859-1' + . $CGI::CRLF x 2; + is $got, $expected, 'image type, no charset'; +} + +{ + my $cgi = CGI->new; + my $got = $cgi->header( + -type => 'image/gif', + -charset => '', + ); + my $expected = 'Content-Type: image/gif' + . $CGI::CRLF x 2; + is $got, $expected, 'image type, no charset'; +} + +{ + my $cgi = CGI->new; + my $got = $cgi->header( + -type => 'image/gif', + -charset => 'utf-8', + ); + my $expected = 'Content-Type: image/gif; charset=utf-8' + . $CGI::CRLF x 2; + is $got, $expected, 'image type, forced charset'; +} + +done_testing; diff --git a/t/hidden.t b/t/hidden.t new file mode 100644 index 0000000..e8291d7 --- /dev/null +++ b/t/hidden.t @@ -0,0 +1,38 @@ +#!perl -w + +use Test::More 'no_plan'; +use CGI; + +my $q = CGI->new; + +is( $q->hidden( 'hidden_name', 'foo' ), + qq(<input type="hidden" name="hidden_name" value="foo" />), + 'hidden() with single default value, positional'); + +is( $q->hidden( -name => 'hidden_name', -default =>'foo' ), + qq(<input type="hidden" name="hidden_name" value="foo" />), + 'hidden() with single default value, named'); + +is( $q->hidden( 'hidden_name', qw(foo bar baz fie) ), + qq(<input type="hidden" name="hidden_name" value="foo" /><input type="hidden" name="hidden_name" value="bar" /><input type="hidden" name="hidden_name" value="baz" /><input type="hidden" name="hidden_name" value="fie" />), + 'hidden() with default array, positional'); + +is( $q->hidden( -name=>'hidden_name', + -Values =>[qw/foo bar baz fie/], + -Title => "hidden_field"), + qq(<input type="hidden" name="hidden_name" value="foo" title="hidden_field" /><input type="hidden" name="hidden_name" value="bar" title="hidden_field" /><input type="hidden" name="hidden_name" value="baz" title="hidden_field" /><input type="hidden" name="hidden_name" value="fie" title="hidden_field" />), + 'hidden() default array, named as "Values"'); + +is( $q->hidden( -name=>'hidden_name', + -default =>[qw/foo bar baz fie/], + -Title => "hidden_field"), + qq(<input type="hidden" name="hidden_name" value="foo" title="hidden_field" /><input type="hidden" name="hidden_name" value="bar" title="hidden_field" /><input type="hidden" name="hidden_name" value="baz" title="hidden_field" /><input type="hidden" name="hidden_name" value="fie" title="hidden_field" />), + 'hidden() default array, named as "default"'); + +is( $q->hidden( -name=>'hidden_name', + '-value' =>[qw/foo bar baz fie/], + -Title => "hidden_field"), + qq(<input type="hidden" name="hidden_name" value="foo" title="hidden_field" /><input type="hidden" name="hidden_name" value="bar" title="hidden_field" /><input type="hidden" name="hidden_name" value="baz" title="hidden_field" /><input type="hidden" name="hidden_name" value="fie" title="hidden_field" />), + 'hidden() default array, named as "value"'); + + diff --git a/t/html.t b/t/html.t new file mode 100644 index 0000000..4d3904f --- /dev/null +++ b/t/html.t @@ -0,0 +1,220 @@ +#!/usr/local/bin/perl -w + +use Test::More tests => 40; + +END { ok $loaded; } +use CGI ( ':standard', '-no_debug', '*h3', 'start_table' ); +$loaded = 1; +$CGI::Util::SORT_ATTRIBUTES= 1; +ok 1; + +BEGIN { + $| = 1; + if ( $] > 5.006 ) { + + # no utf8 + require utf8; # we contain Latin-1 + utf8->unimport; + } +} + +######################### End of black magic. + +my $CRLF = "\015\012"; +if ( $^O eq 'VMS' ) { + $CRLF = "\n"; # via web server carriage is inserted automatically +} +if ( ord("\t") != 9 ) { # EBCDIC? + $CRLF = "\r\n"; +} + +# util +sub test { + local ($^W) = 0; + my ( undef, $true, $msg ) = @_; + ok $true => $msg; +} + +# all the automatic tags +is h1(), '<h1 />', "single tag"; + +is h1('fred'), '<h1>fred</h1>', "open/close tag"; + +is h1( 'fred', 'agnes', 'maura' ), '<h1>fred agnes maura</h1>', + "open/close tag multiple"; + +is h1( { -align => 'CENTER' }, 'fred' ), '<h1 align="CENTER">fred</h1>', + "open/close tag with attribute"; + +is h1( { -align => undef }, 'fred' ), '<h1 align>fred</h1>', + "open/close tag with orphan attribute"; + +is h1( { -align => 'CENTER' }, [ 'fred', 'agnes' ] ), + '<h1 align="CENTER">fred</h1> <h1 align="CENTER">agnes</h1>', + "distributive tag with attribute"; + +{ + local $" = '-'; + + is h1( 'fred', 'agnes', 'maura' ), '<h1>fred-agnes-maura</h1>', + "open/close tag \$\" interpolation"; + +} + +is header(), "Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}", + "header()"; + +is header( -type => 'image/gif', -charset => '' ), "Content-Type: image/gif${CRLF}${CRLF}", + "header()"; + +is header( -type => 'image/gif', -status => '500 Sucks' ), + "Status: 500 Sucks${CRLF}Content-Type: image/gif${CRLF}${CRLF}", "header()"; + +# return to normal +charset( 'ISO-8859-1' ); + +like header( -nph => 1 ), + qr!HTTP/1.0 200 OK${CRLF}Server: cmdline${CRLF}Date:.+${CRLF}Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}!, + "header()"; + +is start_html(), <<END, "start_html()"; +<!DOCTYPE html + PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" + "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US" xml:lang="en-US"> +<head> +<title>Untitled Document</title> +<meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1" /> +</head> +<body> +END + +is start_html( + -Title => 'The world of foo' , + -Script => [ {-src=> 'foo.js', -charset=>'utf-8'} ], + ), <<END, "start_html()"; +<!DOCTYPE html + PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" + "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US" xml:lang="en-US"> +<head> +<title>The world of foo</title> +<script charset="utf-8" src="foo.js" type="text/javascript"></script> +<meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1" /> +</head> +<body> +END + +for my $v (qw/ 2.0 3.2 4.0 4.01 /) { + local $CGI::XHTML = 1; + is + start_html( -dtd => "-//IETF//DTD HTML $v//FR", -lang => 'fr' ), + <<"END", 'start_html()'; +<!DOCTYPE html + PUBLIC "-//IETF//DTD HTML $v//FR"> +<html lang="fr"><head><title>Untitled Document</title> +</head> +<body> +END +} + +is + start_html( -dtd => "-//IETF//DTD HTML 9.99//FR", -lang => 'fr' ), + <<"END", 'start_html()'; +<!DOCTYPE html + PUBLIC "-//IETF//DTD HTML 9.99//FR"> +<html xmlns="http://www.w3.org/1999/xhtml" lang="fr" xml:lang="fr"> +<head> +<title>Untitled Document</title> +<meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1" /> +</head> +<body> +END + +my $cookie = + cookie( -name => 'fred', -value => [ 'chocolate', 'chip' ], -path => '/' ); + +is $cookie, 'fred=chocolate&chip; path=/', "cookie()"; + +my $h = header( -Cookie => $cookie ); + +like $h, + qr!^Set-Cookie: fred=chocolate&chip\; path=/${CRLF}Date:.*${CRLF}Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}!s, + "header(-cookie)"; + +$h = header( '-set-cookie' => $cookie ); +like $h, + qr!^Set-[Cc]ookie: fred=chocolate&chip\; path=/${CRLF}(Date:.*${CRLF})?Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}!s, + "header(-set-cookie)"; + +my $cookie2 = + cookie( -name => 'ginger', -value => 'snap' , -path => '/' ); +is $cookie2, 'ginger=snap; path=/', "cookie2()"; + +$h = header( -cookie => [ $cookie, $cookie2 ] ); +like $h, + qr!^Set-Cookie: fred=chocolate&chip\; path=/${CRLF}Set-Cookie: ginger=snap\; path=/${CRLF}(Date:.*${CRLF})?Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}!s, + "header(-cookie=>[cookies])"; + +$h = header( '-set-cookie' => [ $cookie, $cookie2 ] ); +like $h, + qr!^Set-Cookie: fred=chocolate&chip\; path=/${CRLF}Set-Cookie: ginger=snap\; path=/${CRLF}(Date:.*${CRLF})?Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}!s, + "header(-set-cookie=>[cookies])"; + +$h = redirect('http://elsewhere.org/'); +like $h, + qr!Status: 302 Found${CRLF}Location: http://elsewhere.org/!s, + "redirect"; + +$h = redirect(-url=>'http://elsewhere.org/', -cookie=>[$cookie,$cookie2]); +like $h, + qr!Status: 302 Found${CRLF}Set-[Cc]ookie: \Q$cookie\E${CRLF}Set-[Cc]ookie: \Q$cookie2\E${CRLF}(Date:.*${CRLF})?Location: http://elsewhere.org/!s, + "redirect with cookies"; + +$h = redirect(-url=>'http://elsewhere.org/', '-set-cookie'=>[$cookie,$cookie2]); +like $h, + qr!Status: 302 Found${CRLF}Set-[Cc]ookie: \Q$cookie\E${CRLF}Set-[Cc]ookie: \Q$cookie2\E${CRLF}(Date:.*${CRLF})?Location: http://elsewhere.org/!s, + "redirect with set-cookies"; + +is start_h3, '<h3>'; + +is end_h3, '</h3>'; + +is start_table( { -border => undef } ), '<table border>'; + +charset('utf-8'); + +my $old_encode = $CGI::ENCODE_ENTITIES; +$CGI::ENCODE_ENTITIES = '<'; + +isnt h1( escapeHTML("this is <not> \x8bright\x9b") ), + '<h1>this is <not> ‹right›</h1>'; + +undef( $CGI::ENCODE_ENTITIES ); + +is h1( escapeHTML("this is <not> \x8bright\x9b") ), + '<h1>this is <not> ‹right›</h1>'; + + +$CGI::ENCODE_ENTITIES = $old_encode; + +is i( p('hello there') ), '<i><p>hello there</p></i>'; + +my $q = CGI->new; +is $q->h1('hi'), '<h1>hi</h1>'; + +$q->autoEscape(1); + +is $q->p( { title => "hello worldè" }, 'hello á' ), + '<p title="hello world&egrave;">hello á</p>'; + +$q->autoEscape(0); + +is $q->p( { title => "hello worldè" }, 'hello á' ), + '<p title="hello worldè">hello á</p>'; + +is p( { title => "hello worldè" }, 'hello á' ), + '<p title="hello world&egrave;">hello á</p>'; + +is header( -type => 'image/gif', -charset => 'UTF-8' ), + "Content-Type: image/gif; charset=UTF-8${CRLF}${CRLF}", "header()"; diff --git a/t/html_functions.t b/t/html_functions.t new file mode 100644 index 0000000..e5fcbeb --- /dev/null +++ b/t/html_functions.t @@ -0,0 +1,53 @@ +#!perl + +use strict; +use warnings; + +use Test::More 'no_plan'; + +use CGI qw/ -compile :all /; + +# check html functions are imported into this namespace +# with the -compile pragma +is( a({ bar => "boz" }),"<a bar=\"boz\" />","-compile" ); + +my $q = CGI->new; + +foreach my $tag ( $q->_all_html_tags ) { + + my $expected_tag = lc( $tag ); + + is( + $q->$tag(), + "<$expected_tag />", + "$tag function (no args)" + ); + + is( + $q->$tag( 'some','contents' ), + "<$expected_tag>some contents</$expected_tag>", + "$tag function (content)" + ); + + is( + $q->$tag( { bar => 'boz', biz => 'baz' } ), + "<$expected_tag bar=\"boz\" biz=\"baz\" />", + "$tag function (attributes)" + ); + + is( + $q->$tag( { bar => 'boz' },'some','contents' ), + "<$expected_tag bar=\"boz\">some contents</$expected_tag>", + "$tag function (attributes and content)" + ); + + next if ($tag eq 'html'); + + my $start = "start_$tag"; + is( $q->$start( 'foo' ),"<$expected_tag>","$start function" ); + + my $end = "end_$tag"; + is( $q->$end( 'foo' ),"</$expected_tag>","$end function" ); +} + +ok( $q->compile,'compile' ); diff --git a/t/http.t b/t/http.t new file mode 100644 index 0000000..2ed3863 --- /dev/null +++ b/t/http.t @@ -0,0 +1,44 @@ +#!./perl -w + +# Fixes RT 12909 + +use lib qw(t/lib); + +use Test::More tests => 7; +use CGI; + +my $cgi = CGI->new(); + +{ + # http() without arguments should not cause warnings + local $SIG{__WARN__} = sub { die @_ }; + ok eval { $cgi->http(); 1 }, "http() without arguments doesn't warn"; + ok eval { $cgi->https(); 1 }, "https() without arguments doesn't warn"; +} + +{ + # Capitalization and the use of hyphens versus underscores are not significant. + local $ENV{'HTTP_HOST'} = 'foo'; + is $cgi->http('Host'), 'foo', 'http("Host") returns $ENV{HTTP_HOST}'; + is $cgi->http('http-host'), 'foo', 'http("http-host") returns $ENV{HTTP_HOST}'; +} + +{ + # Called with no arguments returns the list of HTTP environment variables + local $ENV{'HTTPS_FOO'} = 'bar'; + my @http = $cgi->http(); + is scalar( grep /^HTTPS/, @http), 0, "http() doesn't return HTTPS variables"; +} + +{ + # https() + # The same as http(), but operates on the HTTPS environment variables present when the SSL protocol is in + # effect. Can be used to determine whether SSL is turned on. + my @expect = grep /^HTTPS/, keys %ENV; + push @expect, 'HTTPS' if not exists $ENV{HTTPS}; + push @expect, 'HTTPS_KEYSIZE' if not exists $ENV{HTTPS_KEYSIZE}; + local $ENV{'HTTPS'} = 'ON'; + local $ENV{'HTTPS_KEYSIZE'} = 512; + is $cgi->https(), 'ON', 'scalar context to check SSL is on'; + ok eq_set( [$cgi->https()], \@expect), 'list context returns https keys'; +} diff --git a/t/init.t b/t/init.t new file mode 100644 index 0000000..532a277 --- /dev/null +++ b/t/init.t @@ -0,0 +1,13 @@ +#!/usr/bin perl -w + +use strict; +use Test::More tests => 1; + +use CGI; + + +$_ = "abcdefghijklmnopq"; +my $IN; +open ($IN, "t/init_test.txt"); +my $q = CGI->new($IN); +is($_, 'abcdefghijklmnopq', 'make sure not to clobber $_ on init'); diff --git a/t/init_test.txt b/t/init_test.txt new file mode 100644 index 0000000..3101583 --- /dev/null +++ b/t/init_test.txt @@ -0,0 +1,3 @@ +A=B +D=F +G=H diff --git a/t/multipart_init.t b/t/multipart_init.t new file mode 100644 index 0000000..20cd3f2 --- /dev/null +++ b/t/multipart_init.t @@ -0,0 +1,25 @@ +use Test::More 'no_plan'; + +use CGI; + +my $q = CGI->new; + +my $sv = $q->multipart_init; +like( $sv, qr|Content-Type: multipart/x-mixed-replace;boundary="------- =.*?; charset=ISO-8859-1|, 'multipart_init(), basic'); + +$sv = $q->multipart_init(-charset=>'utf-8'); +like( $sv, qr|Content-Type: multipart/x-mixed-replace;boundary="------- =.*?; charset=utf-8|, 'multipart_init(), -charset'); + +like( $sv, qr/$CGI::CRLF$/, 'multipart_init(), ends in CRLF' ); + +$sv = $q->multipart_init( 'this_is_the_boundary' ); +like( $sv, qr/boundary="this_is_the_boundary"/, 'multipart_init("simple_boundary")' ); +$sv = $q->multipart_init( -boundary => 'this_is_another_boundary' ); +like($sv, + qr/boundary="this_is_another_boundary"/, "multipart_init( -boundary => 'this_is_another_boundary')"); + +{ + my $sv = $q->multipart_init; + my $sv2 = $q->multipart_init; + isnt($sv,$sv2,"due to random boundaries, multiple calls produce different results"); +} diff --git a/t/multipart_start.t b/t/multipart_start.t new file mode 100644 index 0000000..42ade75 --- /dev/null +++ b/t/multipart_start.t @@ -0,0 +1,34 @@ +#!perl + +use strict; +use warnings; +use Test::More 'no_plan'; + +use CGI; + +my $q = CGI->new; +my $CRLF = $MultipartBuffer::CRLF; + +like( + $q->multipart_start, + qr!^Content-Type: text/html$CRLF$CRLF$!, + 'multipart_start with no args' +); + +like( + $q->multipart_start( -type => 'text/plain' ), + qr!^Content-Type: text/plain$CRLF$CRLF$!, + 'multipart_start with type' +); + +like( + $q->multipart_start( -charset => 'utf-8' ), + qr!^Content-Type: text/html; charset=utf-8$CRLF$CRLF$!, + 'multipart_start with charset' +); + +like( + $q->multipart_start( -type => 'text/plain', -charset => 'utf-8' ), + qr!^Content-Type: text/plain; charset=utf-8$CRLF$CRLF$!, + 'multipart_start with type and charset' +); diff --git a/t/no_tabindex.t b/t/no_tabindex.t new file mode 100644 index 0000000..66ea21c --- /dev/null +++ b/t/no_tabindex.t @@ -0,0 +1,122 @@ +#!/usr/local/bin/perl -w + +use Test::More tests => 18; + +BEGIN { use_ok('CGI'); }; +use CGI (':standard','-no_debug'); + +my $CRLF = "\015\012"; +if ($^O eq 'VMS') { + $CRLF = "\n"; # via web server carriage is inserted automatically +} +if (ord("\t") != 9) { # EBCDIC? + $CRLF = "\r\n"; +} + + +# Set up a CGI environment +$ENV{REQUEST_METHOD} = 'GET'; +$ENV{QUERY_STRING} = 'game=chess&game=checkers&weather=dull'; +$ENV{PATH_INFO} = '/somewhere/else'; +$ENV{PATH_TRANSLATED} = '/usr/local/somewhere/else'; +$ENV{SCRIPT_NAME} ='/cgi-bin/foo.cgi'; +$ENV{SERVER_PROTOCOL} = 'HTTP/1.0'; +$ENV{SERVER_PORT} = 8080; +$ENV{SERVER_NAME} = 'the.good.ship.lollypop.com'; + +ok( (not $CGI::TABINDEX), "Tab index turned off."); + +is(submit(), + qq(<input type="submit" name=".submit" />), + "submit()"); + +is(submit(-name => 'foo', + -value => 'bar'), + qq(<input type="submit" name="foo" value="bar" />), + "submit(-name,-value)"); + +is(submit({-name => 'foo', + -value => 'bar'}), + qq(<input type="submit" name="foo" value="bar" />), + "submit({-name,-value})"); + +is(textfield(-name => 'weather'), + qq(<input type="text" name="weather" value="dull" />), + "textfield({-name})"); + +is(textfield(-name => 'weather', + -value => 'nice'), + qq(<input type="text" name="weather" value="dull" />), + "textfield({-name,-value})"); + +is(textfield(-name => 'weather', + -value => 'nice', + -override => 1), + qq(<input type="text" name="weather" value="nice" />), + "textfield({-name,-value,-override})"); + +is(checkbox(-name => 'weather', + -value => 'nice'), + qq(<label><input type="checkbox" name="weather" value="nice" />weather</label>), + "checkbox()"); + +is(checkbox(-name => 'weather', + -value => 'nice', + -label => 'forecast'), + qq(<label><input type="checkbox" name="weather" value="nice" />forecast</label>), + "checkbox()"); + +is(checkbox(-name => 'weather', + -value => 'nice', + -label => 'forecast', + -checked => 1, + -override => 1), + qq(<label><input type="checkbox" name="weather" value="nice" checked="checked" />forecast</label>), + "checkbox()"); + +is(checkbox(-name => 'weather', + -value => 'dull', + -label => 'forecast'), + qq(<label><input type="checkbox" name="weather" value="dull" checked="checked" />forecast</label>), + "checkbox()"); + +is(radio_group(-name => 'game'), + qq(<label><input type="radio" name="game" value="chess" checked="checked" />chess</label> <label><input type="radio" name="game" value="checkers" />checkers</label>), + 'radio_group()'); + +is(radio_group(-name => 'game', + -labels => {'chess' => 'ping pong'}), + qq(<label><input type="radio" name="game" value="chess" checked="checked" />ping pong</label> <label><input type="radio" name="game" value="checkers" />checkers</label>), + 'radio_group()'); + +is(checkbox_group(-name => 'game', + -Values => [qw/checkers chess cribbage/]), + qq(<label><input type="checkbox" name="game" value="checkers" checked="checked" />checkers</label> <label><input type="checkbox" name="game" value="chess" checked="checked" />chess</label> <label><input type="checkbox" name="game" value="cribbage" />cribbage</label>), + 'checkbox_group()'); + +is(checkbox_group(-name => 'game', + '-values' => [qw/checkers chess cribbage/], + '-defaults' => ['cribbage'], + -override=>1), + qq(<label><input type="checkbox" name="game" value="checkers" />checkers</label> <label><input type="checkbox" name="game" value="chess" />chess</label> <label><input type="checkbox" name="game" value="cribbage" checked="checked" />cribbage</label>), + 'checkbox_group()'); + +is(popup_menu(-name => 'game', + '-values' => [qw/checkers chess cribbage/], + -default => 'cribbage', + -override => 1), + '<select name="game" > +<option value="checkers">checkers</option> +<option value="chess">chess</option> +<option selected="selected" value="cribbage">cribbage</option> +</select>', + 'popup_menu()'); + + +is(textarea(-name=>'foo', + -default=>'starting value', + -rows=>10, + -columns=>50), + '<textarea name="foo" rows="10" cols="50">starting value</textarea>', + 'textarea()'); + diff --git a/t/param_fetch.t b/t/param_fetch.t new file mode 100644 index 0000000..a3756cd --- /dev/null +++ b/t/param_fetch.t @@ -0,0 +1,26 @@ +#!perl + +# Tests for the param_fetch() method. + +use Test::More 'no_plan'; +use CGI; + +{ + my $q = CGI->new('b=baz;a=foo;a=bar'); + + is $q->param_fetch('a')->[0] => 'foo', 'first "a" is "foo"'; + is $q->param_fetch( -name => 'a' )->[0] => 'foo', + 'first "a" is "foo", with -name'; + is $q->param_fetch('a')->[1] => 'bar', 'second "a" is "bar"'; + is_deeply $q->param_fetch('a') => [qw/ foo bar /], 'a is array ref'; + is_deeply $q->param_fetch( -name => 'a' ) => [qw/ foo bar /], + 'a is array ref, w/ name'; + + is $q->param_fetch('b')->[0] => 'baz', '"b" is "baz"'; + is_deeply $q->param_fetch('b') => [qw/ baz /], 'b is array ref too'; + + is_deeply $q->param_fetch, [], "param_fetch without parameters"; + + is_deeply $q->param_fetch( 'a', 'b' ), [qw/ foo bar /], + "param_fetch only take first argument"; +} diff --git a/t/param_list_context.t b/t/param_list_context.t new file mode 100644 index 0000000..04f2dd6 --- /dev/null +++ b/t/param_list_context.t @@ -0,0 +1,57 @@ +#!/usr/local/bin/perl + +use strict; +use warnings; + +use Test::More tests => 7; +use Test::Deep; +use Test::Warn; + +use CGI (); + +# Set up a CGI environment +$ENV{REQUEST_METHOD} = 'GET'; +$ENV{QUERY_STRING} = 'game=chess&game=checkers&weather=dull'; + +my $q = CGI->new; +ok $q,"CGI::new()"; + +my @params; + +warnings_are + { @params = $q->param } + [], + "calling ->param with no args in list does not warn" +; + +warning_like + { @params = $q->param('game') } + qr/CGI::param called in list context from .+param_list_context\.t line 28, this can lead to vulnerabilities/, + "calling ->param with args in list context warns" +; + +cmp_deeply( + [ sort @params ], + [ qw/ checkers chess / ], + 'CGI::param()', +); + +warnings_are + { @params = $q->multi_param('game') } + [], + "no warnings calling multi_param" +; + +cmp_deeply( + [ sort @params ], + [ qw/ checkers chess / ], + 'CGI::multi_param' +); + +$CGI::LIST_CONTEXT_WARN = 0; + +warnings_are + { @params = $q->param } + [], + "no warnings when LIST_CONTEXT_WARN set to 0" +; diff --git a/t/popup_menu.t b/t/popup_menu.t new file mode 100644 index 0000000..bffba64 --- /dev/null +++ b/t/popup_menu.t @@ -0,0 +1,33 @@ +#!perl +# Tests for popup_menu(); +use Test::More 'no_plan'; +use CGI; + +my $q = CGI->new; + +is ( $q->popup_menu(-name=>"foo", - values=>[0,1], -default=>0), +'<select name="foo" > +<option selected="selected" value="0">0</option> +<option value="1">1</option> +</select>' +, 'popup_menu(): basic test, including 0 as a default value'); + +is( + CGI::popup_menu(-values=>[CGI::optgroup(-values=>["b+"])],-default=>"b+"), + '<select name="" > +<optgroup label=""> +<option selected="selected" value="b+">b+</option> +</optgroup> +</select>' + , "<optgroup> selections work when the default values contain regex characters (RT#49606)"); + +unlike( + $q->popup_menu( + -name =>"foo", + -values =>[0,1], + -multiple => 'true', + -MULTIPLE => 'true', + ), + qr/multiple/, + 'popup_menu ignores -multiple option', +); diff --git a/t/postdata.t b/t/postdata.t new file mode 100644 index 0000000..bd6263d --- /dev/null +++ b/t/postdata.t @@ -0,0 +1,121 @@ +#!/usr/local/bin/perl -w + +################################################################# +# Emanuele Zeppieri, Mark Stosberg # +# Shamelessly stolen from Data::FormValidator and CGI::Upload # +# Anonymous Monk says me too # +################################################################# + +use strict; +use Test::More tests => 28; + +use CGI; +$CGI::DEBUG=1; + +#----------------------------------------------------------------------------- +# %ENV setup. +#----------------------------------------------------------------------------- + +my %myenv; + +BEGIN { + %myenv = ( + 'SCRIPT_NAME' => '/test.cgi', + 'SERVER_NAME' => 'perl.org', + 'HTTP_CONNECTION' => 'TE, close', + 'REQUEST_METHOD' => 'POST', + 'SCRIPT_URI' => 'http://www.perl.org/test.cgi', + 'CONTENT_LENGTH' => 35, + 'SCRIPT_FILENAME' => '/home/usr/test.cgi', + 'SERVER_SOFTWARE' => 'Apache/1.3.27 (Unix) ', + 'HTTP_TE' => 'deflate,gzip;q=0.3', + 'QUERY_STRING' => '', + 'REMOTE_PORT' => '1855', + 'HTTP_USER_AGENT' => 'Mozilla/5.0 (compatible; Konqueror/2.1.1; X11)', + 'SERVER_PORT' => '80', + 'REMOTE_ADDR' => '127.0.0.1', + 'CONTENT_TYPE' => 'application/octet-stream', ##dd + 'X_File_Name' => 'tiny.gif', ##dd + 'SERVER_PROTOCOL' => 'HTTP/1.1', + 'PATH' => '/usr/local/bin:/usr/bin:/bin', + 'REQUEST_URI' => '/test.cgi', + 'GATEWAY_INTERFACE' => 'CGI/1.1', + 'SCRIPT_URL' => '/test.cgi', + 'SERVER_ADDR' => '127.0.0.1', + 'DOCUMENT_ROOT' => '/home/develop', + 'HTTP_HOST' => 'www.perl.org' + ); + + for my $key (keys %myenv) { + $ENV{$key} = $myenv{$key}; + } +} + +END { + for my $key (keys %myenv) { + delete $ENV{$key}; + } +} + + + +for my $pdata ( qw' POST PUT ' ){ + local $ENV{REQUEST_METHOD} = $pdata; + my $pdata = $pdata.'DATA'; + CGI::initialize_globals(); #### IMPORTANT + ok( ! $CGI::PUTDATA_UPLOAD , "-\L$pdata\E_upload default is off"); + local *STDIN; + open STDIN, "<", \"GIF89a\1\0\1\0\x90\0\0\xFF\0\0\0\0\0,\0\0\0\0\1\0\1\0\0\2\2\4\1\0;" + or die "In-memory filehandle failed\n"; + binmode STDIN; + my $q = CGI->new; + ok( scalar $q->param( $pdata ), "we have $pdata param" ); + ok( ! ref $q->param( $pdata ), 'and it is not filehandle'); + ok( "GIF89a\1\0\1\0\x90\0\0\xFF\0\0\0\0\0,\0\0\0\0\1\0\1\0\0\2\2\4\1\0;" eq $q->param( $pdata ), "and the value isn't corrupted" ); +} + +for my $pdata ( qw' POST PUT ' ){ + local $ENV{REQUEST_METHOD} = $pdata; + my $pdata = $pdata.'DATA'; + local *STDIN; + open STDIN, "<", \"GIF89a\1\0\1\0\x90\0\0\xFF\0\0\0\0\0,\0\0\0\0\1\0\1\0\0\2\2\4\1\0;" + or die "In-memory filehandle failed\n"; + binmode STDIN; + + CGI::initialize_globals(); #### IMPORTANT + local $CGI::PUTDATA_UPLOAD; + CGI->import( lc "-$pdata\_upload" ); + ok( !!$CGI::PUTDATA_UPLOAD, "-\L$pdata\E_upload default is on"); + + my $q = CGI->new; + foreach my $class ( 'File::Temp','CGI::File::Temp','Fh' ) { + isa_ok( $q->param( $pdata ),$class,"$pdata param" ); + } + + my $filename = $q->param($pdata); + my $tmpfilename = $q->tmpFileName( $filename ); + ok( $tmpfilename , "and tmpFileName returns the filename" ); +} + + +for my $pdata ( qw' POST PUT ' ){ + local $ENV{REQUEST_METHOD} = $pdata; + my $pdata = $pdata.'DATA'; + local *STDIN; + open STDIN, "<", \"GIF89a\1\0\1\0\x90\0\0\xFF\0\0\0\0\0,\0\0\0\0\1\0\1\0\0\2\2\4\1\0;" + or die "In-memory filehandle failed\n"; + binmode STDIN; + + CGI::initialize_globals(); #### IMPORTANT + + my $yourang = 0; + my $callback = sub { + $yourang++; + }; + my $q = CGI->new( $callback ); + ok( ref $q, "got query"); + foreach my $class ( 'File::Temp','CGI::File::Temp','Fh' ) { + isa_ok( $q->param( $pdata ),$class,"$pdata param" ); + } + ok( $yourang, "and callback invoked"); +} diff --git a/t/pretty.t b/t/pretty.t new file mode 100644 index 0000000..b57baed --- /dev/null +++ b/t/pretty.t @@ -0,0 +1,13 @@ +#!/bin/perl -w + +use strict; +use Test::More tests => 6; +use CGI::Pretty ':all'; + +is(h1(), '<h1 />',"single tag (pretty turned off)"); +is(h1('fred'), '<h1>fred</h1>',"open/close tag (pretty turned off)"); +is(h1('fred','agnes','maura'), '<h1>fred agnes maura</h1>',"open/close tag multiple (pretty turned off)"); +is(h1({-align=>'CENTER'},'fred'), '<h1 align="CENTER">fred</h1>',"open/close tag with attribute (pretty turned off)"); +is(h1({-align=>undef},'fred'), '<h1 align>fred</h1>',"open/close tag with orphan attribute (pretty turned off)"); +is(h1({-align=>'CENTER'},['fred','agnes']), '<h1 align="CENTER">fred</h1> <h1 align="CENTER">agnes</h1>', + "distributive tag with attribute (pretty turned off)"); diff --git a/t/push.t b/t/push.t new file mode 100644 index 0000000..0274aa9 --- /dev/null +++ b/t/push.t @@ -0,0 +1,68 @@ +#!./perl -wT + +use Test::More tests => 12; + +use_ok( 'CGI::Push' ); + +ok( my $q = CGI::Push->new(), 'create a new CGI::Push object' ); + +# test the simple_counter() method +like( join('', $q->simple_counter(10)) , '/updated.+?10.+?times./', 'counter' ); + +ok( CGI::Push::do_sleep(0.01),'do_sleep' ); + +# test push_delay() +ok( ! defined $q->push_delay(), 'no initial delay' ); +is( $q->push_delay(.5), .5, 'set a delay' ); + +my $out = tie *STDOUT, 'TieOut'; + +# next_page() to be called twice, last_page() once, no delay +my %vars = ( + -next_page => sub { return if $_[1] > 2; 'next page' }, + -last_page => sub { 'last page' }, + -delay => 0, +); + +$q->do_push(%vars); + +# this seems to appear on every page +like( $$out, '/WARNING: YOUR BROWSER/', 'unsupported browser warning' ); + +# these should appear correctly +is( ($$out =~ s/next page//g), 2, 'next_page callback called appropriately' ); +is( ($$out =~ s/last page//g), 1, 'last_page callback called appropriately' ); + +# send a fake content type (header capitalization varies in CGI, CGI::Push) +$$out = ''; +$q->do_push(%vars, -type => 'fake' ); +like( $$out, '/Content-[Tt]ype: fake/', 'set custom Content-type' ); + +# use our own counter, as $COUNTER in CGI::Push is now off +my $i; +$$out = ''; + +# no delay, custom headers from callback, only call callback once +$q->do_push( + -delay => 0, + -type => 'dynamic', + -next_page => sub { + return if $i++; + return $_[0]->header('text/plain'), 'arduk'; + }, +); + +# header capitalization again, our word should appear only once +like( $$out, '/ype: text\/plain/', 'set custom Content-type in next_page()' ); +is( $$out =~ s/arduk//g, 1, 'found text from next_page()' ); + +package TieOut; + +sub TIEHANDLE { + bless( \(my $text), $_[0] ); +} + +sub PRINT { + my $self = shift; + $$self .= join( $/, @_ ); +} diff --git a/t/query_string.t b/t/query_string.t new file mode 100644 index 0000000..a7efbe9 --- /dev/null +++ b/t/query_string.t @@ -0,0 +1,15 @@ +#!perl + +# Tests for the query_string() method. + +use Test::More 'no_plan'; +use CGI; + +{ + my $q1 = CGI->new('b=2;a=1;a=1'); + my $q2 = CGI->new('b=2&a=1&a=1'); + + is($q1->query_string + ,$q2->query_string + , "query string format is returned with the same delimiter regardless of input."); +} diff --git a/t/redirect_query_string.t b/t/redirect_query_string.t new file mode 100644 index 0000000..28cc521 --- /dev/null +++ b/t/redirect_query_string.t @@ -0,0 +1,72 @@ +#!perl + +use strict; +use warnings; + +use Test::More 'no_plan'; +use CGI; + +# monkey patching to make testing easier +no warnings 'once'; +no warnings 'redefine'; +*CGI::read_multipart_related = sub {}; +*CGI::save_request = sub {}; + +my $q_string = 'foo=bar'; + +$ENV{REQUEST_METHOD} = 'POST'; +$ENV{CONTENT_TYPE} = 'multipart/related;boundary="------- =A; start=X'; + +{ + $ENV{QUERY_STRING} = $q_string; + my $q = CGI->new; + is( $q->query_string,$q_string,'query_string' ); +} + +{ + $ENV{REDIRECT_QUERY_STRING} + = delete( $ENV{QUERY_STRING} ); + + my $q = CGI->new; + is( $q->query_string,$q_string,'query_string (redirect)' ); +} + +{ + $ENV{REDIRECT_REDIRECT_QUERY_STRING} + = delete( $ENV{REDIRECT_QUERY_STRING} ); + + my $q = CGI->new; + is( $q->query_string,$q_string,'query_string (redirect x 2)' ); +} + +{ + $ENV{REDIRECT_REDIRECT_REDIRECT_QUERY_STRING} + = delete( $ENV{REDIRECT_REDIRECT_QUERY_STRING} ); + + my $q = CGI->new; + is( $q->query_string,$q_string,'query_string (redirect x 3)' ); +} + +{ + $ENV{REDIRECT_REDIRECT_REDIRECT_REDIRECT_QUERY_STRING} + = delete( $ENV{REDIRECT_REDIRECT_REDIRECT_QUERY_STRING} ); + + my $q = CGI->new; + is( $q->query_string,$q_string,'query_string (redirect x 4)' ); +} + +{ + $ENV{REDIRECT_REDIRECT_REDIRECT_REDIRECT_REDIRECT_QUERY_STRING} + = delete( $ENV{REDIRECT_REDIRECT_REDIRECT_REDIRECT_QUERY_STRING} ); + + my $q = CGI->new; + is( $q->query_string,$q_string,'query_string (redirect x 5)' ); +} + +{ + $ENV{REDIRECT_REDIRECT_REDIRECT_REDIRECT_REDIRECT_REDIRECT_QUERY_STRING} + = delete( $ENV{REDIRECT_REDIRECT_REDIRECT_REDIRECT_REDIRECT_QUERY_STRING} ); + + my $q = CGI->new; + is( $q->query_string,'','no more than 5 redirects supported' ); +} diff --git a/t/request.t b/t/request.t new file mode 100644 index 0000000..2c5974d --- /dev/null +++ b/t/request.t @@ -0,0 +1,130 @@ +#!/usr/local/bin/perl + +use strict; +use warnings; + +use Test::More tests => 45; +use Test::Deep; +use Test::NoWarnings; + +use CGI (); +use Config; + +my $loaded = 1; + +$| = 1; + +$CGI::LIST_CONTEXT_WARN = 0; + +######################### End of black magic. + +# Set up a CGI environment +$ENV{REQUEST_METHOD} = 'GET'; +$ENV{QUERY_STRING} = 'game=chess&game=checkers&weather=dull'; +$ENV{PATH_INFO} = '/somewhere/else'; +$ENV{PATH_TRANSLATED} = '/usr/local/somewhere/else'; +$ENV{SCRIPT_NAME} = '/cgi-bin/foo.cgi'; +$ENV{SERVER_PROTOCOL} = 'HTTP/1.0'; +$ENV{SERVER_PORT} = 8080; +$ENV{SERVER_NAME} = 'the.good.ship.lollypop.com'; +$ENV{REQUEST_URI} = "$ENV{SCRIPT_NAME}$ENV{PATH_INFO}?$ENV{QUERY_STRING}"; +$ENV{HTTP_LOVE} = 'true'; + +my $q = CGI->new; +ok $q,"CGI::new()"; +is $q->request_method => 'GET',"CGI::request_method()"; +is $q->query_string => 'game=chess;game=checkers;weather=dull',"CGI::query_string()"; +is $q->param(), 2,"CGI::param()"; +is join(' ',sort $q->param()), 'game weather',"CGI::param()"; +is $q->param('game'), 'chess',"CGI::param()"; +is $q->param('weather'), 'dull',"CGI::param()"; +is join(' ',$q->param('game')), 'chess checkers',"CGI::param()"; +ok $q->param(-name=>'foo',-value=>'bar'),'CGI::param() put'; +is $q->param(-name=>'foo'), 'bar','CGI::param() get'; +is $q->query_string, 'game=chess;game=checkers;weather=dull;foo=bar',"CGI::query_string() redux"; +is $q->http('love'), 'true',"CGI::http()"; +is $q->script_name, '/cgi-bin/foo.cgi',"CGI::script_name()"; +is $q->url, 'http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi',"CGI::url()"; +is $q->self_url, + 'http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi/somewhere/else?game=chess;game=checkers;weather=dull;foo=bar', + "CGI::url()"; +is $q->url(-absolute=>1), '/cgi-bin/foo.cgi','CGI::url(-absolute=>1)'; +is $q->url(-relative=>1), 'foo.cgi','CGI::url(-relative=>1)'; +is $q->url(-relative=>1,-path=>1), 'foo.cgi/somewhere/else','CGI::url(-relative=>1,-path=>1)'; +is $q->url(-relative=>1,-path=>1,-query=>1), + 'foo.cgi/somewhere/else?game=chess;game=checkers;weather=dull;foo=bar', + 'CGI::url(-relative=>1,-path=>1,-query=>1)'; +$q->delete('foo'); +ok !$q->param('foo'),'CGI::delete()'; + +$q->_reset_globals; +$ENV{QUERY_STRING}='mary+had+a+little+lamb'; +ok $q=CGI->new,"CGI::new() redux"; +is join(' ',$q->keywords), 'mary had a little lamb','CGI::keywords'; +is join(' ',$q->param('keywords')), 'mary had a little lamb','CGI::keywords'; +ok $q=CGI->new('foo=bar&foo=baz'),"CGI::new() redux"; +is $q->param('foo'), 'bar','CGI::param() redux'; +ok $q=CGI->new({'foo'=>'bar','bar'=>'froz'}),"CGI::new() redux 2"; +is $q->param('bar'), 'froz',"CGI::param() redux 2"; + +# test tied interface +my $p = $q->Vars; +is $p->{bar}, 'froz',"tied interface fetch"; +$p->{bar} = join("\0",qw(foo bar baz)); +is join(' ',$q->param('bar')), 'foo bar baz','tied interface store'; +ok exists $p->{bar}; +is delete $p->{bar}, "foo\0bar\0baz",'tied interface delete'; + +# test posting +$q->_reset_globals; +{ + my $test_string = 'game=soccer&game=baseball&weather=nice'; + local $ENV{REQUEST_METHOD}='POST'; + local $ENV{CONTENT_LENGTH}=length($test_string); + local $ENV{QUERY_STRING}='big_balls=basketball&small_balls=golf'; + + local *STDIN; + open STDIN, '<', \$test_string; + + ok $q=CGI->new,"CGI::new() from POST"; + is $q->param('weather'), 'nice',"CGI::param() from POST"; + is $q->url_param('big_balls'), 'basketball',"CGI::url_param()"; +} + +# test url_param +{ + local $ENV{QUERY_STRING} = 'game=chess&game=checkers&weather=dull'; + + CGI::_reset_globals; + my $q = CGI->new; + # params present, param and url_param should return true + ok $q->param, 'param() is true if parameters'; + ok $q->url_param, 'url_param() is true if parameters'; + + $ENV{QUERY_STRING} = ''; + + CGI::_reset_globals; + $q = CGI->new; + ok !$q->param, 'param() is false if no parameters'; + ok !$q->url_param, 'url_param() is false if no parameters'; + + $ENV{QUERY_STRING} = 'tiger dragon'; + CGI::_reset_globals; + $q = CGI->new; + + is_deeply [$q->$_] => [ 'keywords' ], "$_ with QS='$ENV{QUERY_STRING}'" + for qw/ param url_param /; + + is_deeply [ sort $q->$_( 'keywords' ) ], [ qw/ dragon tiger / ], + "$_ keywords" for qw/ param url_param /; + + { + $^W++; + + CGI::_reset_globals; + $q = CGI->new; + $ENV{QUERY_STRING} = 'p1=1&&&;;&;&&;;p2;p3;p4=4&=p5'; + ok $q->url_param, 'url_param() is true if parameters'; + cmp_deeply( [ $q->url_param ],bag( qw/p1 p2 p3 p4/,'' ),'url_param' ); + } +} diff --git a/t/rt-31107.t b/t/rt-31107.t new file mode 100644 index 0000000..e09c24e --- /dev/null +++ b/t/rt-31107.t @@ -0,0 +1,43 @@ +#!/usr/local/bin/perl -w + +use strict; + +use Test::More 'no_plan'; + +use CGI; + +$ENV{REQUEST_METHOD} = 'POST'; +$ENV{CONTENT_TYPE} = 'multipart/related;boundary="----=_Part_0.7772611529786723.1196412625897" type="text/xml"; start="cid:mm7-submit"'; + +my $q; + +{ + local *STDIN; + open STDIN, '<t/rt_31107.txt' + or die 'missing test file t/rt_31107.txt'; + binmode STDIN; + $q = CGI->new; +} + +foreach my $class ( 'File::Temp','CGI::File::Temp','Fh' ) { + isa_ok( $q->param( 'capabilities.zip' ),$class,'capabilities.zip' ); + isa_ok( $q->param( 'mm7-submit' ),$class,'mm7-submit' ); +} + +my $fh = $q->param( 'mm7-submit' ); + +my @content = $fh->getlines; +like( + $content[9], + qr!<CapRequestId>4401196412625869430</CapRequestId>!, + 'multipart data read' +); + +# test back compatibility handle method +seek( $fh,0,0 ); +@content = $fh->handle->getlines; +like( + $content[9], + qr!<CapRequestId>4401196412625869430</CapRequestId>!, + 'multipart data read' +); diff --git a/t/rt-52469.t b/t/rt-52469.t new file mode 100644 index 0000000..740012d --- /dev/null +++ b/t/rt-52469.t @@ -0,0 +1,19 @@ +use strict; +use warnings; + +use Test::More tests => 1; # last test to print + +use CGI; + +$ENV{REQUEST_METHOD} = 'PUT'; + +eval { + local $SIG{ALRM} = sub { die "timeout!" }; + alarm 10; + my $cgi = CGI->new; + alarm 0; + pass( 'new() returned' ); +}; +$@ && do { + fail( "CGI->new did not return" ); +}; diff --git a/t/rt-57524.t b/t/rt-57524.t new file mode 100644 index 0000000..784d23f --- /dev/null +++ b/t/rt-57524.t @@ -0,0 +1,19 @@ +use strict; +use warnings; + +use Test::More tests => 6; + +use CGI; + +foreach my $fh ( \*STDOUT,\*STDIN,\*STDERR ) { + binmode( STDOUT,':utf8' ); + my %layers = map { $_ => 1 } PerlIO::get_layers( \*STDOUT ); + ok( $layers{utf8},'set utf8 on STDOUT' ); +} + +CGI::_set_binmode(); + +foreach my $fh ( \*STDOUT,\*STDIN,\*STDERR ) { + my %layers = map { $_ => 1 } PerlIO::get_layers( \*STDOUT ); + ok( $layers{utf8},'layers were not lost in call to _set_binmode' ); +} diff --git a/t/rt-75628.t b/t/rt-75628.t new file mode 100644 index 0000000..c0611d6 --- /dev/null +++ b/t/rt-75628.t @@ -0,0 +1,27 @@ +#!/usr/local/bin/perl -w + +use strict; + +use Test::More 'no_plan'; + +use CGI; + +$ENV{REQUEST_METHOD} = 'POST'; +$ENV{CONTENT_TYPE} = 'application/xml'; +$ENV{CONTENT_LENGTH} = 792; + +my $q; + +{ + local *STDIN; + open STDIN, '<t/rt_75628.txt' + or die 'missing test file t/rt_75628.txt'; + binmode STDIN; + $q = CGI->new; +} + +like( + $q->param( 'POSTDATA' ), + qr!<MM7Version>5.3.0</MM7Version>!, + 'POSTDATA access to XForms:Model' +); diff --git a/t/rt-84767.t b/t/rt-84767.t new file mode 100644 index 0000000..e1ed361 --- /dev/null +++ b/t/rt-84767.t @@ -0,0 +1,25 @@ +#!perl + +use strict; +use warnings; + +use Test::More; +use FindBin qw/$Bin $Script/; + +plan tests => 1; + +use CGI::Carp; + +chdir( $Bin ); + +open( my $fh,"<","$Script" ) + || die "Can't open $Script for read: $!"; + +while ( <$fh> ) { + eval { die("error") if /error/; }; + $@ && do { + like( $@,qr!at \Q$0\E line 19!,'die with input line number' ); + last; + } +} +close( $fh ); diff --git a/t/rt_31107.txt b/t/rt_31107.txt new file mode 100644 index 0000000..d99f15f --- /dev/null +++ b/t/rt_31107.txt @@ -0,0 +1,31 @@ +------=_Part_0.7772611529786723.1196412625897
+Content-Type: text/xml
+Content-Transfer-Encoding: 7bit
+Content-ID: <mm7-submit>
+
+<?xml version="1.0" encoding="UTF-8" ?> +<env:Envelope xmlns:env="http://schemas.xmlsoap.org/soap/envelope/"> + <env:Header> + <mm7:TransactionID env:mustUnderstand="1" xmlns:mm7="http://www.3gpp.org/ftp/Specs/archive/23_series/23.140/schema/REL-5-MM7-1-0">4401196412625869430</mm7:TransactionID> + </env:Header> + <env:Body> + <mm7:CapabilityASReplyReq xmlns:mm7="http://www.3gpp.org/ftp/Specs/archive/23_series/23.140/schema/REL-5-MM7-1-0"> + <MM7Version>5.3.0</MM7Version> + <SenderAddress>XXXXX</SenderAddress> + <CapRequestId>4401196412625869430</CapRequestId> + <TimeStamp>2007-11-30 09:50:25</TimeStamp> + <StatusCode>1000</StatusCode> + <StatusText>Request Received</StatusText> + <Content href="cid:generic_content_id"/> + </mm7:CapabilityASReplyReq> + </env:Body> +</env:Envelope> +
+------=_Part_0.7772611529786723.1196412625897
+Content-Type: application/x-zip; name=capabilities.zip
+Content-Transfer-Encoding: base64
+Content-Disposition: attachment; filename=capabilities.zip
+Content-ID: <capabilities.zip>
+
+UEsDBBQACAAIA
+------=_Part_0.7772611529786723.1196412625897--
diff --git a/t/rt_75628.txt b/t/rt_75628.txt new file mode 100644 index 0000000..3634e52 --- /dev/null +++ b/t/rt_75628.txt @@ -0,0 +1,17 @@ +<?xml version="1.0" encoding="UTF-8" ?> +<env:Envelope xmlns:env="http://schemas.xmlsoap.org/soap/envelope/"> + <env:Header> + <mm7:TransactionID env:mustUnderstand="1" xmlns:mm7="http://www.3gpp.org/ftp/Specs/archive/23_series/23.140/schema/REL-5-MM7-1-0">4401196412625869430</mm7:TransactionID> + </env:Header> + <env:Body> + <mm7:CapabilityASReplyReq xmlns:mm7="http://www.3gpp.org/ftp/Specs/archive/23_series/23.140/schema/REL-5-MM7-1-0"> + <MM7Version>5.3.0</MM7Version> + <SenderAddress>XXXXX</SenderAddress> + <CapRequestId>4401196412625869430</CapRequestId> + <TimeStamp>2007-11-30 09:50:25</TimeStamp> + <StatusCode>1000</StatusCode> + <StatusText>Request Received</StatusText> + <Content href="cid:generic_content_id"/> + </mm7:CapabilityASReplyReq> + </env:Body> +</env:Envelope> diff --git a/t/save_read_roundtrip.t b/t/save_read_roundtrip.t new file mode 100644 index 0000000..a329b8e --- /dev/null +++ b/t/save_read_roundtrip.t @@ -0,0 +1,26 @@ + +use strict; +use warnings; + +# Reference: RT#13158: Needs test: empty name/value, when saved, prevents proper restore from filehandle. +# https://rt.cpan.org/Ticket/Display.html?id=13158 + +use Test::More tests => 3; + +use IO::File; +use CGI; + +$CGI::LIST_CONTEXT_WARN = 0; + +my $cgi = CGI->new('a=1;=;b=2;=3'); +ok eq_set (['a', '', 'b'], [$cgi->param]); + +# not File::Temp, since that wasn't in core at 5.6.0 +my $tmp = IO::File->new_tmpfile; +$cgi->save($tmp); +$tmp->seek(0,0); + +$cgi = CGI->new($tmp); +ok eq_set (['a', '', 'b'], [$cgi->param]); +is $cgi->param(''), 3; # '=' is lost, '=3' is retained + diff --git a/t/sorted.t b/t/sorted.t new file mode 100644 index 0000000..805a07b --- /dev/null +++ b/t/sorted.t @@ -0,0 +1,30 @@ +#!/bin/perl -w + +use strict; +use Test::More tests => 5; +use CGI qw /a start_html/; + +# Test that constructs fed from hashes generate unchanging HTML output + +# HTML Attributes within tags +is(a({-href=>'frog',-alt => 'Frog'},'frog'),'<a alt="Frog" href="frog">frog</a>',"sorted attributes 1"); +is(a({-href=>'frog',-alt => 'Frog', -frog => 'green'},'frog'),'<a alt="Frog" frog="green" href="frog">frog</a>',"sorted attributes 2"); +is(a({-href=>'frog',-alt => 'Frog', -frog => 'green', -type => 'water'},'frog'),'<a alt="Frog" frog="green" href="frog" type="water">frog</a>',"sorted attributes 3"); + +# List of meta attributes in the HTML header +my %meta = ( + 'frog1' => 'frog1', + 'frog2' => 'frog2', + 'frog3' => 'frog3', + 'frog4' => 'frog4', + 'frog5' => 'frog5', +); + +is(join("",grep (/frog\d/,split("\n",start_html( -meta => \%meta )))), +'<meta name="frog1" content="frog1" /><meta name="frog2" content="frog2" /><meta name="frog3" content="frog3" /><meta name="frog4" content="frog4" /><meta name="frog5" content="frog5" />', +"meta tags are sorted alphabetically by name 1"); + +$meta{'frog6'} = 'frog6'; +is(join("",grep (/frog\d/,split("\n",start_html( -meta => \%meta )))), +'<meta name="frog1" content="frog1" /><meta name="frog2" content="frog2" /><meta name="frog3" content="frog3" /><meta name="frog4" content="frog4" /><meta name="frog5" content="frog5" /><meta name="frog6" content="frog6" />', +"meta tags are sorted alphabetically by name 2"); diff --git a/t/start_end_asterisk.t b/t/start_end_asterisk.t new file mode 100644 index 0000000..0d67c9d --- /dev/null +++ b/t/start_end_asterisk.t @@ -0,0 +1,72 @@ +#!/usr/local/bin/perl -w + +use lib qw(t/lib); +use strict; + +# Due to a bug in older versions of MakeMaker & Test::Harness, we must +# ensure the blib's are in @INC, else we might use the core CGI.pm +use lib qw(blib/lib blib/arch); +use Test::More tests => 45; + +use CGI qw(:standard *h1 *h2 *h3 *h4 *h5 *h6 *table *ul *li *ol *td *b *i *u *div); + +is(start_h1(), "<h1>", "start_h1"); # TEST +is(start_h1({class => 'hello'}), "<h1 class=\"hello\">", "start_h1 with param"); # TEST +is(end_h1(), "</h1>", "end_h1"); # TEST + +is(start_h2(), "<h2>", "start_h2"); # TEST +is(start_h2({class => 'hello'}), "<h2 class=\"hello\">", "start_h2 with param"); # TEST +is(end_h2(), "</h2>", "end_h2"); # TEST + +is(start_h3(), "<h3>", "start_h3"); # TEST +is(start_h3({class => 'hello'}), "<h3 class=\"hello\">", "start_h3 with param"); # TEST +is(end_h3(), "</h3>", "end_h3"); # TEST + +is(start_h4(), "<h4>", "start_h4"); # TEST +is(start_h4({class => 'hello'}), "<h4 class=\"hello\">", "start_h4 with param"); # TEST +is(end_h4(), "</h4>", "end_h4"); # TEST + +is(start_h5(), "<h5>", "start_h5"); # TEST +is(start_h5({class => 'hello'}), "<h5 class=\"hello\">", "start_h5 with param"); # TEST +is(end_h5(), "</h5>", "end_h5"); # TEST + +is(start_h6(), "<h6>", "start_h6"); # TEST +is(start_h6({class => 'hello'}), "<h6 class=\"hello\">", "start_h6 with param"); # TEST +is(end_h6(), "</h6>", "end_h6"); # TEST + +is(start_table(), "<table>", "start_table"); # TEST +is(start_table({class => 'hello'}), "<table class=\"hello\">", "start_table with param"); # TEST +is(end_table(), "</table>", "end_table"); # TEST + +is(start_ul(), "<ul>", "start_ul"); # TEST +is(start_ul({class => 'hello'}), "<ul class=\"hello\">", "start_ul with param"); # TEST +is(end_ul(), "</ul>", "end_ul"); # TEST + +is(start_li(), "<li>", "start_li"); # TEST +is(start_li({class => 'hello'}), "<li class=\"hello\">", "start_li with param"); # TEST +is(end_li(), "</li>", "end_li"); # TEST + +is(start_ol(), "<ol>", "start_ol"); # TEST +is(start_ol({class => 'hello'}), "<ol class=\"hello\">", "start_ol with param"); # TEST +is(end_ol(), "</ol>", "end_ol"); # TEST + +is(start_td(), "<td>", "start_td"); # TEST +is(start_td({class => 'hello'}), "<td class=\"hello\">", "start_td with param"); # TEST +is(end_td(), "</td>", "end_td"); # TEST + +is(start_b(), "<b>", "start_b"); # TEST +is(start_b({class => 'hello'}), "<b class=\"hello\">", "start_b with param"); # TEST +is(end_b(), "</b>", "end_b"); # TEST + +is(start_i(), "<i>", "start_i"); # TEST +is(start_i({class => 'hello'}), "<i class=\"hello\">", "start_i with param"); # TEST +is(end_i(), "</i>", "end_i"); # TEST + +is(start_u(), "<u>", "start_u"); # TEST +is(start_u({class => 'hello'}), "<u class=\"hello\">", "start_u with param"); # TEST +is(end_u(), "</u>", "end_u"); # TEST + +is(start_div(), "<div>", "start_div"); # TEST +is(start_div({class => 'hello'}), "<div class=\"hello\">", "start_div with param"); # TEST +is(end_div(), "</div>", "end_div"); # TEST + diff --git a/t/start_end_end.t b/t/start_end_end.t new file mode 100644 index 0000000..2eeed60 --- /dev/null +++ b/t/start_end_end.t @@ -0,0 +1,72 @@ +#!/usr/local/bin/perl -w + +use lib qw(t/lib); +use strict; + +# Due to a bug in older versions of MakeMaker & Test::Harness, we must +# ensure the blib's are in @INC, else we might use the core CGI.pm +use lib qw(blib/lib blib/arch); +use Test::More tests => 45; + +use CGI qw(:standard end_h1 end_h2 end_h3 end_h4 end_h5 end_h6 end_table end_ul end_li end_ol end_td end_b end_i end_u end_div); + +is(start_h1(), "<h1>", "start_h1"); # TEST +is(start_h1({class => 'hello'}), "<h1 class=\"hello\">", "start_h1 with param"); # TEST +is(end_h1(), "</h1>", "end_h1"); # TEST + +is(start_h2(), "<h2>", "start_h2"); # TEST +is(start_h2({class => 'hello'}), "<h2 class=\"hello\">", "start_h2 with param"); # TEST +is(end_h2(), "</h2>", "end_h2"); # TEST + +is(start_h3(), "<h3>", "start_h3"); # TEST +is(start_h3({class => 'hello'}), "<h3 class=\"hello\">", "start_h3 with param"); # TEST +is(end_h3(), "</h3>", "end_h3"); # TEST + +is(start_h4(), "<h4>", "start_h4"); # TEST +is(start_h4({class => 'hello'}), "<h4 class=\"hello\">", "start_h4 with param"); # TEST +is(end_h4(), "</h4>", "end_h4"); # TEST + +is(start_h5(), "<h5>", "start_h5"); # TEST +is(start_h5({class => 'hello'}), "<h5 class=\"hello\">", "start_h5 with param"); # TEST +is(end_h5(), "</h5>", "end_h5"); # TEST + +is(start_h6(), "<h6>", "start_h6"); # TEST +is(start_h6({class => 'hello'}), "<h6 class=\"hello\">", "start_h6 with param"); # TEST +is(end_h6(), "</h6>", "end_h6"); # TEST + +is(start_table(), "<table>", "start_table"); # TEST +is(start_table({class => 'hello'}), "<table class=\"hello\">", "start_table with param"); # TEST +is(end_table(), "</table>", "end_table"); # TEST + +is(start_ul(), "<ul>", "start_ul"); # TEST +is(start_ul({class => 'hello'}), "<ul class=\"hello\">", "start_ul with param"); # TEST +is(end_ul(), "</ul>", "end_ul"); # TEST + +is(start_li(), "<li>", "start_li"); # TEST +is(start_li({class => 'hello'}), "<li class=\"hello\">", "start_li with param"); # TEST +is(end_li(), "</li>", "end_li"); # TEST + +is(start_ol(), "<ol>", "start_ol"); # TEST +is(start_ol({class => 'hello'}), "<ol class=\"hello\">", "start_ol with param"); # TEST +is(end_ol(), "</ol>", "end_ol"); # TEST + +is(start_td(), "<td>", "start_td"); # TEST +is(start_td({class => 'hello'}), "<td class=\"hello\">", "start_td with param"); # TEST +is(end_td(), "</td>", "end_td"); # TEST + +is(start_b(), "<b>", "start_b"); # TEST +is(start_b({class => 'hello'}), "<b class=\"hello\">", "start_b with param"); # TEST +is(end_b(), "</b>", "end_b"); # TEST + +is(start_i(), "<i>", "start_i"); # TEST +is(start_i({class => 'hello'}), "<i class=\"hello\">", "start_i with param"); # TEST +is(end_i(), "</i>", "end_i"); # TEST + +is(start_u(), "<u>", "start_u"); # TEST +is(start_u({class => 'hello'}), "<u class=\"hello\">", "start_u with param"); # TEST +is(end_u(), "</u>", "end_u"); # TEST + +is(start_div(), "<div>", "start_div"); # TEST +is(start_div({class => 'hello'}), "<div class=\"hello\">", "start_div with param"); # TEST +is(end_div(), "</div>", "end_div"); # TEST + diff --git a/t/start_end_start.t b/t/start_end_start.t new file mode 100644 index 0000000..94768c1 --- /dev/null +++ b/t/start_end_start.t @@ -0,0 +1,72 @@ +#!/usr/local/bin/perl -w + +use lib qw(t/lib); +use strict; + +# Due to a bug in older versions of MakeMaker & Test::Harness, we must +# ensure the blib's are in @INC, else we might use the core CGI.pm +use lib qw(blib/lib blib/arch); +use Test::More tests => 45; + +use CGI qw(:standard start_h1 start_h2 start_h3 start_h4 start_h5 start_h6 start_table start_ul start_li start_ol start_td start_b start_i start_u start_div); + +is(start_h1(), "<h1>", "start_h1"); # TEST +is(start_h1({class => 'hello'}), "<h1 class=\"hello\">", "start_h1 with param"); # TEST +is(end_h1(), "</h1>", "end_h1"); # TEST + +is(start_h2(), "<h2>", "start_h2"); # TEST +is(start_h2({class => 'hello'}), "<h2 class=\"hello\">", "start_h2 with param"); # TEST +is(end_h2(), "</h2>", "end_h2"); # TEST + +is(start_h3(), "<h3>", "start_h3"); # TEST +is(start_h3({class => 'hello'}), "<h3 class=\"hello\">", "start_h3 with param"); # TEST +is(end_h3(), "</h3>", "end_h3"); # TEST + +is(start_h4(), "<h4>", "start_h4"); # TEST +is(start_h4({class => 'hello'}), "<h4 class=\"hello\">", "start_h4 with param"); # TEST +is(end_h4(), "</h4>", "end_h4"); # TEST + +is(start_h5(), "<h5>", "start_h5"); # TEST +is(start_h5({class => 'hello'}), "<h5 class=\"hello\">", "start_h5 with param"); # TEST +is(end_h5(), "</h5>", "end_h5"); # TEST + +is(start_h6(), "<h6>", "start_h6"); # TEST +is(start_h6({class => 'hello'}), "<h6 class=\"hello\">", "start_h6 with param"); # TEST +is(end_h6(), "</h6>", "end_h6"); # TEST + +is(start_table(), "<table>", "start_table"); # TEST +is(start_table({class => 'hello'}), "<table class=\"hello\">", "start_table with param"); # TEST +is(end_table(), "</table>", "end_table"); # TEST + +is(start_ul(), "<ul>", "start_ul"); # TEST +is(start_ul({class => 'hello'}), "<ul class=\"hello\">", "start_ul with param"); # TEST +is(end_ul(), "</ul>", "end_ul"); # TEST + +is(start_li(), "<li>", "start_li"); # TEST +is(start_li({class => 'hello'}), "<li class=\"hello\">", "start_li with param"); # TEST +is(end_li(), "</li>", "end_li"); # TEST + +is(start_ol(), "<ol>", "start_ol"); # TEST +is(start_ol({class => 'hello'}), "<ol class=\"hello\">", "start_ol with param"); # TEST +is(end_ol(), "</ol>", "end_ol"); # TEST + +is(start_td(), "<td>", "start_td"); # TEST +is(start_td({class => 'hello'}), "<td class=\"hello\">", "start_td with param"); # TEST +is(end_td(), "</td>", "end_td"); # TEST + +is(start_b(), "<b>", "start_b"); # TEST +is(start_b({class => 'hello'}), "<b class=\"hello\">", "start_b with param"); # TEST +is(end_b(), "</b>", "end_b"); # TEST + +is(start_i(), "<i>", "start_i"); # TEST +is(start_i({class => 'hello'}), "<i class=\"hello\">", "start_i with param"); # TEST +is(end_i(), "</i>", "end_i"); # TEST + +is(start_u(), "<u>", "start_u"); # TEST +is(start_u({class => 'hello'}), "<u class=\"hello\">", "start_u with param"); # TEST +is(end_u(), "</u>", "end_u"); # TEST + +is(start_div(), "<div>", "start_div"); # TEST +is(start_div({class => 'hello'}), "<div class=\"hello\">", "start_div with param"); # TEST +is(end_div(), "</div>", "end_div"); # TEST + diff --git a/t/unescapeHTML.t b/t/unescapeHTML.t new file mode 100644 index 0000000..952cce8 --- /dev/null +++ b/t/unescapeHTML.t @@ -0,0 +1,19 @@ +use Test::More tests => 7; +use CGI 'unescapeHTML'; + +is( unescapeHTML( '&'), '&', 'unescapeHTML: &'); +is( unescapeHTML( '"'), '"', 'unescapeHTML: "'); +is( unescapeHTML( '<'), '<', 'unescapeHTML: < (using a numbered sequence)'); +is( unescapeHTML( 'Bob & Tom went to the store; Where did you go?'), + 'Bob & Tom went to the store; Where did you go?', 'unescapeHTML: a case where &...; should not be escaped.'); +is( unescapeHTML( 'This_string_contains_both_escaped_&_unescaped_<entities>'), + 'This_string_contains_both_escaped_&_unescaped_<entities>', 'unescapeHTML: partially-escaped string.'); +is( unescapeHTML( 'This escaped string kind of looks like it has an escaped entity &x; it does not'), + 'This escaped string kind of looks like it has an escaped entity &x; it does not', 'unescapeHTML: Another case where &...; should not be escaped.'); + +# rt #61120 +is( + unescapeHTML( 'ies_detection:&any_non_whitespace;results_in' ), + 'ies_detection:&any_non_whitespace;results_in', + "none white space doesn't cause unescape" +); diff --git a/t/upload.t b/t/upload.t new file mode 100644 index 0000000..ee926f3 --- /dev/null +++ b/t/upload.t @@ -0,0 +1,185 @@ +#!/usr/local/bin/perl -w + +################################################################# +# Emanuele Zeppieri, Mark Stosberg # +# Shamelessly stolen from Data::FormValidator and CGI::Upload # +################################################################# + +use strict; + +use Test::More 'no_plan'; + +use CGI qw/ :cgi /; +$CGI::LIST_CONTEXT_WARN = 0; + +#----------------------------------------------------------------------------- +# %ENV setup. +#----------------------------------------------------------------------------- + +my %myenv; + +BEGIN { + %myenv = ( + 'SCRIPT_NAME' => '/test.cgi', + 'SERVER_NAME' => 'perl.org', + 'HTTP_CONNECTION' => 'TE, close', + 'REQUEST_METHOD' => 'POST', + 'SCRIPT_URI' => 'http://www.perl.org/test.cgi', + 'CONTENT_LENGTH' => 3285, + 'SCRIPT_FILENAME' => '/home/usr/test.cgi', + 'SERVER_SOFTWARE' => 'Apache/1.3.27 (Unix) ', + 'HTTP_TE' => 'deflate,gzip;q=0.3', + 'QUERY_STRING' => '', + 'REMOTE_PORT' => '1855', + 'HTTP_USER_AGENT' => 'Mozilla/5.0 (compatible; Konqueror/2.1.1; X11)', + 'SERVER_PORT' => '80', + 'REMOTE_ADDR' => '127.0.0.1', + 'CONTENT_TYPE' => 'multipart/form-data; boundary=xYzZY', + 'SERVER_PROTOCOL' => 'HTTP/1.1', + 'PATH' => '/usr/local/bin:/usr/bin:/bin', + 'REQUEST_URI' => '/test.cgi', + 'GATEWAY_INTERFACE' => 'CGI/1.1', + 'SCRIPT_URL' => '/test.cgi', + 'SERVER_ADDR' => '127.0.0.1', + 'DOCUMENT_ROOT' => '/home/develop', + 'HTTP_HOST' => 'www.perl.org' + ); + + for my $key (keys %myenv) { + $ENV{$key} = $myenv{$key}; + } +} + +END { + for my $key (keys %myenv) { + delete $ENV{$key}; + } +} + +#----------------------------------------------------------------------------- +# Simulate the upload (really, multiple uploads contained in a single stream). +#----------------------------------------------------------------------------- + +my $q; + +{ + local *STDIN; + open STDIN, '<t/upload_post_text.txt' + or die 'missing test file t/upload_post_text.txt'; + binmode STDIN; + $q = CGI->new; +} + +#----------------------------------------------------------------------------- +# Check that the file names retrieved by CGI are correct. +#----------------------------------------------------------------------------- + +is( $q->param('does_not_exist_gif'), 'does_not_exist.gif', 'filename_2' ); +is( $q->param('100;100_gif') , '100;100.gif' , 'filename_3' ); +is( $q->param('300x300_gif') , '300x300.gif' , 'filename_4' ); + +{ + my $test = "multiple file names are handled right with same-named upload fields"; + my @hello_names = $q->param('hello_world'); + is ($hello_names[0],'goodbye_world.txt',$test. "...first file"); + is ($hello_names[1],'hello_world.txt',$test. "...second file"); +} + +#----------------------------------------------------------------------------- +# Now check that the upload method works. +#----------------------------------------------------------------------------- + +isa_ok( upload('does_not_exist_gif'),'File::Temp','upload_basic_2 (no object)' ); +isa_ok( upload('does_not_exist_gif'),'Fh','upload_basic_2 (no object)' ); +ok( defined $q->upload('does_not_exist_gif'), 'upload_basic_2' ); +ok( defined $q->upload('100;100_gif') , 'upload_basic_3' ); +ok( defined $q->upload('300x300_gif') , 'upload_basic_4' ); + +{ + my $test = "file handles have expected length for multi-valued field. "; + my ($goodbye_fh,$hello_fh) = $q->upload('hello_world'); + + # Go to end of file; + seek($goodbye_fh,0,2); + # How long is the file? + is(tell($goodbye_fh), 15, "$test..first file"); + + # Go to end of file; + seek($hello_fh,0,2); + # How long is the file? + is(tell($hello_fh), 13, "$test..second file"); + +} + + + +{ + my $test = "300x300_gif has expected length"; + my $fh1 = $q->upload('300x300_gif'); + is(tell($fh1), 0, "First object: filehandle starts with position set at zero"); + + # Go to end of file; + seek($fh1,0,2); + # How long is the file? + is(tell($fh1), 1656, $test); +} + +{ # test handle() method + my $fh1 = $q->upload("300x300_gif"); + my $rawhandle = $fh1->handle; + ok($rawhandle, "check handle()"); + isnt($rawhandle, "300x300_gif", "no string overload"); + # check it acts like a handle + seek($rawhandle, 0, 2); + is(tell($rawhandle), 1656, "check it acts like a handle"); + ok(eval { $rawhandle->seek(0, 2); 1 }, "can call seek() on handle result"); +} + +# param returns a blessed reference, so this always worked +{ + ok($q->tmpFileName($q->param("300x300_gif")), 'tmpFileName(param(field)) works'); + my $fn = $q->tmpFileName($q->param("300x300_gif")); + ok(-s $fn == 1656, 'tmpFileName(param(field)) result has desired size'); +} +# upload returns a blessed reference, so this always worked +{ + ok($q->tmpFileName($q->upload("300x300_gif")), 'tmpFileName(upload(field)) works'); + my $fn = $q->tmpFileName($q->upload("300x300_gif")); + ok(-s $fn == 1656, 'tmpFileName result has desired size'); +} +# the API and documentation make it look as though this ought to work, and +# it did in some versions, but is non-optimal; using the ref is better +{ + ok($q->tmpFileName($q->param("300x300_gif").""), 'tmpFileName(stringified param) works'); + my $fn = $q->tmpFileName($q->param("300x300_gif").""); + ok(-s $fn == 1656, 'tmpFileName(stringified param) result has desired size'); + # equivalent to the above + ok($q->tmpFileName("300x300.gif"), 'tmpFileName(string) works'); + $fn = $q->tmpFileName("300x300.gif"); + ok(-s $fn == 1656, 'tmpFileName(string) result has desired size'); +} + +my $q2 = CGI->new; + +{ + my $test = "Upload filehandles still work after calling CGI->new a second time"; + $q->param('new','zoo'); + + is($q2->param('new'),undef, + "Reality Check: params set in one object instance don't appear in another instance"); + + my $fh2 = $q2->upload('300x300_gif'); + is(tell($fh2), 0, "...so the state of a file handle shouldn't be carried to a new object instance, either."); + # Go to end of file; + seek($fh2,0,2); + # How long is the file? + is(tell($fh2), 1656, $test); +} + +{ + my $test = "multi-valued uploads are reset properly"; + my ($dont_care, $hello_fh2) = $q2->upload('hello_world'); + is(tell($hello_fh2), 0, $test); +} + +# vim: nospell diff --git a/t/uploadInfo.t b/t/uploadInfo.t new file mode 100644 index 0000000..f486447 --- /dev/null +++ b/t/uploadInfo.t @@ -0,0 +1,114 @@ +#!/usr/local/bin/perl -w + +################################################################# +# Emanuele Zeppieri, Mark Stosberg # +# Shamelessly stolen from Data::FormValidator and CGI::Upload # +################################################################# + +use strict; +use Test::More 'no_plan'; + +use CGI qw/ :form /; + +#----------------------------------------------------------------------------- +# %ENV setup. +#----------------------------------------------------------------------------- + +my %myenv; + +BEGIN { + %myenv = ( + 'SCRIPT_NAME' => '/test.cgi', + 'SERVER_NAME' => 'perl.org', + 'HTTP_CONNECTION' => 'TE, close', + 'REQUEST_METHOD' => 'POST', + 'SCRIPT_URI' => 'http://www.perl.org/test.cgi', + 'CONTENT_LENGTH' => 3285, + 'SCRIPT_FILENAME' => '/home/usr/test.cgi', + 'SERVER_SOFTWARE' => 'Apache/1.3.27 (Unix) ', + 'HTTP_TE' => 'deflate,gzip;q=0.3', + 'QUERY_STRING' => '', + 'REMOTE_PORT' => '1855', + 'HTTP_USER_AGENT' => 'Mozilla/5.0 (compatible; Konqueror/2.1.1; X11)', + 'SERVER_PORT' => '80', + 'REMOTE_ADDR' => '127.0.0.1', + 'CONTENT_TYPE' => 'multipart/form-data; boundary=xYzZY', + 'SERVER_PROTOCOL' => 'HTTP/1.1', + 'PATH' => '/usr/local/bin:/usr/bin:/bin', + 'REQUEST_URI' => '/test.cgi', + 'GATEWAY_INTERFACE' => 'CGI/1.1', + 'SCRIPT_URL' => '/test.cgi', + 'SERVER_ADDR' => '127.0.0.1', + 'DOCUMENT_ROOT' => '/home/develop', + 'HTTP_HOST' => 'www.perl.org' + ); + + for my $key (keys %myenv) { + $ENV{$key} = $myenv{$key}; + } +} + +END { + for my $key (keys %myenv) { + delete $ENV{$key}; + } +} + + +#----------------------------------------------------------------------------- +# Simulate the upload (really, multiple uploads contained in a single stream). +#----------------------------------------------------------------------------- + +my $q; + +{ + local *STDIN; + open STDIN, '<t/upload_post_text.txt' + or die 'missing test file t/upload_post_text.txt'; + binmode STDIN; + $q = CGI->new; +} + +{ + # That's cheating! We shouldn't do that! + my $test = "All temp files are present"; + is( scalar(keys %{$q->{'.tmpfiles'}}), 5, $test); +} + +my %uploadinfo_for = ( + 'does_not_exist_gif' => {type => 'application/octet-stream', size => undef, }, + '100;100_gif' => {type => 'image/gif', size => 896, }, + '300x300_gif' => {type => 'image/gif', size => 1656, }, +); + + +foreach my $param_name (sort keys %uploadinfo_for) { + my $f_type = $uploadinfo_for{$param_name}->{type}; + my $f_size = $uploadinfo_for{$param_name}->{size}; + my $test = "uploadInfo: $param_name"; + + my $fh = $q->upload($param_name); + is( uploadInfo($fh)->{'Content-Type'}, $f_type, $test); + is( $q->uploadInfo($fh)->{'Content-Type'}, $f_type, $test); + is( $q->uploadInfo($fh)->{'Content-Length'}, $f_size, $test); + + # access using param + my $param_value = $q->param($param_name); + ok( ref( $param_value ),'param returns filehandle' ); + is( $q->uploadInfo( $param_value )->{'Content-Type'}, $f_type, $test . ' via param'); + is( $q->uploadInfo( $param_value )->{'Content-Length'}, $f_size, $test . ' via param'); + + # access using Vars (is not possible) + my $vars = $q->Vars; + ok( ! ref( $vars->{$param_name} ),'Vars does not return filehandle' ); + ok( ! $q->uploadInfo( $vars->{$param_name} ), $test . ' via Vars'); +} + +my $q2 = CGI->new; + +{ + my $test = "uploadInfo: works with second object instance"; + my $fh = $q2->upload('300x300_gif'); + is( $q2->uploadInfo($fh)->{'Content-Type'}, "image/gif", $test); +} + diff --git a/t/upload_post_text.txt b/t/upload_post_text.txt Binary files differnew file mode 100644 index 0000000..10d6238 --- /dev/null +++ b/t/upload_post_text.txt @@ -0,0 +1,100 @@ +use strict; +use warnings; + +use Test::More; + +use CGI ':all'; + +delete( $ENV{SCRIPT_NAME} ); # Win32 fix, see RT 89992 +$ENV{HTTP_X_FORWARDED_HOST} = 'proxy:8484'; +$ENV{SERVER_PROTOCOL} = 'HTTP/1.0'; +$ENV{SERVER_PORT} = 8080; +$ENV{SERVER_NAME} = 'the.good.ship.lollypop.com'; + +is virtual_port() => 8484, 'virtual_port()'; +is server_port() => 8080, 'server_port()'; + +is url() => 'http://proxy:8484', 'url()'; + +$ENV{HTTP_X_FORWARDED_HOST} = '192.169.1.1, proxy1:80, 127.0.0.1, proxy2:8484'; + +is url() => 'http://proxy2:8484', 'url() with multiple proxies'; + +# let's see if we do the defaults right + +$ENV{HTTP_X_FORWARDED_HOST} = 'proxy:80'; + +is url() => 'http://proxy', 'url() with default port'; + +subtest 'rewrite_interactions' => sub { + # Reference: RT#45019 + + local $ENV{HTTP_X_FORWARDED_HOST} = undef; + local $ENV{SERVER_PROTOCOL} = undef; + local $ENV{SERVER_PORT} = undef; + local $ENV{SERVER_NAME} = undef; + + # These two are always set + local $ENV{'SCRIPT_NAME'} = '/real/cgi-bin/dispatch.cgi'; + local $ENV{'SCRIPT_FILENAME'} = '/home/mark/real/path/cgi-bin/dispatch.cgi'; + + # These two are added by mod_rewrite Ref: http://httpd.apache.org/docs/2.2/mod/mod_rewrite.html + + local $ENV{'SCRIPT_URL'} = '/real/path/info'; + local $ENV{'SCRIPT_URI'} = 'http://example.com/real/path/info'; + + local $ENV{'PATH_INFO'} = '/path/info'; + local $ENV{'REQUEST_URI'} = '/real/path/info'; + local $ENV{'HTTP_HOST'} = 'example.com'; + + my $q = CGI->new; + + is( + $q->url( -absolute => 1, -query => 1, -path_info => 1 ), + '/real/path/info', + '$q->url( -absolute => 1, -query => 1, -path_info => 1 ) should return complete path, even when mod_rewrite is detected.' + ); + is( $q->url(), 'http://example.com/real', '$q->url(), with rewriting detected' ); + is( $q->url(-full=>1), 'http://example.com/real', '$q->url(-full=>1), with rewriting detected' ); + is( $q->url(-path=>1), 'http://example.com/real/path/info', '$q->url(-path=>1), with rewriting detected' ); + is( $q->url(-path=>0), 'http://example.com/real', '$q->url(-path=>0), with rewriting detected' ); + is( $q->url(-full=>1,-path=>1), 'http://example.com/real/path/info', '$q->url(-full=>1,-path=>1), with rewriting detected' ); + is( $q->url(-rewrite=>1,-path=>0), 'http://example.com/real', '$q->url(-rewrite=>1,-path=>0), with rewriting detected' ); + is( $q->url(-rewrite=>1), 'http://example.com/real', + '$q->url(-rewrite=>1), with rewriting detected' ); + is( $q->url(-rewrite=>0), 'http://example.com/real/cgi-bin/dispatch.cgi', + '$q->url(-rewrite=>0), with rewriting detected' ); + is( $q->url(-rewrite=>0,-path=>1), 'http://example.com/real/cgi-bin/dispatch.cgi/path/info', + '$q->url(-rewrite=>0,-path=>1), with rewriting detected' ); + is( $q->url(-rewrite=>1,-path=>1), 'http://example.com/real/path/info', + '$q->url(-rewrite=>1,-path=>1), with rewriting detected' ); + is( $q->url(-rewrite=>0,-path=>0), 'http://example.com/real/cgi-bin/dispatch.cgi', + '$q->url(-rewrite=>0,-path=>1), with rewriting detected' ); +}; + +subtest 'RT#58377: + in PATH_INFO' => sub { + local $ENV{PATH_INFO} = '/hello+world'; + local $ENV{HTTP_X_FORWARDED_HOST} = undef; + local $ENV{'HTTP_HOST'} = 'example.com'; + local $ENV{'SCRIPT_NAME'} = '/script/plus+name.cgi'; + local $ENV{'SCRIPT_FILENAME'} = '/script/plus+filename.cgi'; + + my $q = CGI->new; + is($q->url(), 'http://example.com/script/plus+name.cgi', 'a plus sign in a script name is preserved when calling url()'); + is($q->path_info(), '/hello+world', 'a plus sign in a script name is preserved when calling path_info()'); +}; + +subtest 'IIS PATH_INFO eq SCRIPT_NAME' => sub { + $CGI::IIS++; + local $ENV{PATH_INFO} = '/hello+world'; + local $ENV{HTTP_X_FORWARDED_HOST} = undef; + local $ENV{HTTP_HOST} = 'example.com'; + local $ENV{SCRIPT_NAME} = '/hello+world'; + + my $q = CGI->new; + is( $q->url,'http://example.com/hello+world','PATH_INFO being the same as SCRIPT_NAME'); +}; + +done_testing(); + + diff --git a/t/user_agent.t b/t/user_agent.t new file mode 100644 index 0000000..b861afb --- /dev/null +++ b/t/user_agent.t @@ -0,0 +1,14 @@ +# Test the user_agent method. +use Test::More 'no_plan'; +use CGI; + +my $q = CGI->new; + +is($q->user_agent, undef, 'user_agent: undef test'); + +$ENV{HTTP_USER_AGENT} = 'mark'; +is($q->user_agent, 'mark', 'user_agent: basic test'); +ok($q->user_agent('ma.*'), 'user_agent: positive regex test'); +ok(!$q->user_agent('BOOM.*'), 'user_agent: negative regex test'); + + diff --git a/t/utf8.t b/t/utf8.t new file mode 100644 index 0000000..016dc3b --- /dev/null +++ b/t/utf8.t @@ -0,0 +1,34 @@ +#!perl -T + +use strict; +use warnings; + +use utf8; + +use Test::More tests => 7; +use Encode; + +use_ok( 'CGI' ); + +ok( my $q = CGI->new, 'create a new CGI object' ); + +{ + no warnings qw/ once /; + $CGI::PARAM_UTF8 = 1; +} + +my $data = 'áéíóúµ'; +ok Encode::is_utf8($data), "created UTF-8 encoded data string"; + +# now set the param. +$q->param(data => $data); + +# if param() runs the data through Encode::decode(), this will fail. +is $q->param('data'), $data; + +# make sure setting bytes decodes properly +my $bytes = Encode::encode(utf8 => $data); +ok !Encode::is_utf8($bytes), "converted UTF-8 to bytes"; +$q->param(data => $bytes); +is $q->param('data'), $data; +ok Encode::is_utf8($q->param('data')), 'param() decoded UTF-8'; diff --git a/t/util-58.t b/t/util-58.t new file mode 100644 index 0000000..c478d5d --- /dev/null +++ b/t/util-58.t @@ -0,0 +1,29 @@ +# test CGI::Util::escape +use Test::More tests => 4; +use_ok("CGI::Util"); + +# Byte strings should be escaped byte by byte: +# 1) not a valid utf-8 sequence: +my $uri = "pe\x{f8}\x{ed}\x{e8}ko.ogg"; +is(CGI::Util::escape($uri), "pe%F8%ED%E8ko.ogg", "Escape a Latin-2 string"); + +# 2) is a valid utf-8 sequence, but not an UTF-8-flagged string +# This happens often: people write utf-8 strings to source, but forget +# to tell perl about it by "use utf8;"--this is obviously wrong, but we +# have to handle it gracefully, for compatibility with CGI.pm under +# perl-5.8.x +# +$uri = "pe\x{c5}\x{99}\x{c3}\x{ad}\x{c4}\x{8d}ko.ogg"; +is(CGI::Util::escape($uri), "pe%C5%99%C3%AD%C4%8Dko.ogg", + "Escape an utf-8 byte string"); + +SKIP: +{ + # This tests CGI::Util::escape() when fed with UTF-8-flagged string + # -- dankogai + skip("Unicode strings not available in $]", 1) if ($] < 5.008); + $uri = "\x{5c0f}\x{98fc} \x{5f3e}.txt"; # KOGAI, Dan, in Kanji + is(CGI::Util::escape($uri), "%E5%B0%8F%E9%A3%BC%20%E5%BC%BE.txt", + "Escape string with UTF-8 flag"); +} +__END__ diff --git a/t/util.t b/t/util.t new file mode 100644 index 0000000..a0791ee --- /dev/null +++ b/t/util.t @@ -0,0 +1,90 @@ +#!/usr/local/bin/perl -w + +# Test ability to escape() and unescape() punctuation characters +# except for qw(- . _). + +$| = 1; + +use Test::More tests => 80; +use Test::Deep; +use Config; +use_ok ( 'CGI::Util', qw( + escape + unescape + rearrange + ebcdic2ascii + ascii2ebcdic +) ); + +# ASCII order, ASCII codepoints, ASCII repertoire + +my %punct = ( + ' ' => '20', '!' => '21', '"' => '22', '#' => '23', + '$' => '24', '%' => '25', '&' => '26', '\'' => '27', + '(' => '28', ')' => '29', '*' => '2A', '+' => '2B', + ',' => '2C', '/' => '2F', # '-' => '2D', '.' => '2E' + ':' => '3A', ';' => '3B', '<' => '3C', '=' => '3D', + '>' => '3E', '?' => '3F', '[' => '5B', '\\' => '5C', + ']' => '5D', '^' => '5E', '`' => '60', # '_' => '5F', + '{' => '7B', '|' => '7C', '}' => '7D', # '~' => '7E', + ); + +# The sort order may not be ASCII on EBCDIC machines: + +my $i = 1; + +foreach(sort(keys(%punct))) { + $i++; + my $escape = "AbC\%$punct{$_}dEF"; + my $cgi_escape = escape("AbC$_" . "dEF"); + is($escape, $cgi_escape , "# $escape ne $cgi_escape"); + $i++; + my $unescape = "AbC$_" . "dEF"; + my $cgi_unescape = unescape("AbC\%$punct{$_}dEF"); + is($unescape, $cgi_unescape , "# $unescape ne $cgi_unescape"); +} + +# rearrange should return things in a consistent order, so when we pass through +# a hash reference it should sort the keys +for ( 1 .. 20 ) { + my %args = ( + '-charset' => 'UTF-8', + '-type' => 'text/html', + '-content-type' => 'text/html; charset=iso-8859-1', + ); + + my @ordered = rearrange( + [ + [ 'TYPE','CONTENT_TYPE','CONTENT-TYPE' ], + 'STATUS', + [ 'COOKIE','COOKIES','SET-COOKIE' ], + 'TARGET', + 'EXPIRES', + 'NPH', + 'CHARSET', + 'ATTACHMENT', + 'P3P' + ], + %args, + ); + + cmp_deeply( + [ @ordered ], + [ + 'text/html; charset=iso-8859-1', + undef, + undef, + undef, + undef, + undef, + 'UTF-8', + undef, + undef + ], + 'rearrange not sensitive to hash key ordering' + ); +} + +ok( CGI::Util::utf8_chr( "1",1 ),'utf8_chr' ); +ok( my $ebcdic = ascii2ebcdic( "A" ),'ascii2ebcdic' ); +is( ebcdic2ascii( $ebcdic ),'A','ebcdic2ascii' ); |
