From f9f3ab3056d94292adb4ab2e1451645bee989769 Mon Sep 17 00:00:00 2001 From: Lorry Tar Creator Date: Tue, 16 Jun 2015 06:44:29 +0000 Subject: CGI-4.21 --- Changes | 2132 ++++++++++++++++++++++ MANIFEST | 88 + META.json | 64 + META.yml | 40 + Makefile.PL | 69 + README.md | 1781 +++++++++++++++++++ examples/clickable_image.cgi | 56 + examples/cookie.cgi | 111 ++ examples/crash.cgi | 9 + examples/file_upload.cgi | 74 + examples/mojo_proxy.pl | 36 + examples/wikipedia_example.cgi | 40 + examples/wilogo.gif | Bin 0 -> 458 bytes lib/CGI.pm | 3856 ++++++++++++++++++++++++++++++++++++++++ lib/CGI.pod | 1843 +++++++++++++++++++ lib/CGI/Carp.pm | 615 +++++++ lib/CGI/Cookie.pm | 537 ++++++ lib/CGI/File/Temp.pm | 39 + lib/CGI/HTML/Functions.pm | 8 + lib/CGI/HTML/Functions.pod | 1927 ++++++++++++++++++++ lib/CGI/Pretty.pm | 85 + lib/CGI/Push.pm | 306 ++++ lib/CGI/Util.pm | 354 ++++ lib/Fh.pm | 7 + t/Dump.t | 5 + t/arbitrary_handles.t | 30 + t/autoescape.t | 200 +++ t/can.t | 7 + t/carp.t | 440 +++++ t/cgi.t | 73 + t/changes.t | 12 + t/charset.t | 27 + t/checkbox_group.t | 21 + t/compiles_pod.t | 42 + t/cookie.t | 441 +++++ t/delete.t | 59 + t/end_form.t | 9 + t/form.t | 235 +++ t/function.t | 110 ++ t/gh-155.t | 23 + t/headers.t | 54 + t/headers/attachment.t | 23 + t/headers/charset.t | 20 + t/headers/cookie.t | 34 + t/headers/default.t | 13 + t/headers/nph.t | 24 + t/headers/p3p.t | 33 + t/headers/target.t | 22 + t/headers/type.t | 101 ++ t/hidden.t | 38 + t/html.t | 220 +++ t/html_functions.t | 53 + t/http.t | 44 + t/init.t | 13 + t/init_test.txt | 3 + t/multipart_init.t | 25 + t/multipart_start.t | 34 + t/no_tabindex.t | 122 ++ t/param_fetch.t | 26 + t/param_list_context.t | 57 + t/popup_menu.t | 33 + t/postdata.t | 121 ++ t/pretty.t | 13 + t/push.t | 68 + t/query_string.t | 15 + t/redirect_query_string.t | 72 + t/request.t | 130 ++ t/rt-31107.t | 43 + t/rt-52469.t | 19 + t/rt-57524.t | 19 + t/rt-75628.t | 27 + t/rt-84767.t | 25 + t/rt_31107.txt | 31 + t/rt_75628.txt | 17 + t/save_read_roundtrip.t | 26 + t/sorted.t | 30 + t/start_end_asterisk.t | 72 + t/start_end_end.t | 72 + t/start_end_start.t | 72 + t/unescapeHTML.t | 19 + t/upload.t | 185 ++ t/uploadInfo.t | 114 ++ t/upload_post_text.txt | Bin 0 -> 3284 bytes t/url.t | 100 ++ t/user_agent.t | 14 + t/utf8.t | 34 + t/util-58.t | 29 + t/util.t | 90 + 88 files changed, 18260 insertions(+) create mode 100644 Changes create mode 100644 MANIFEST create mode 100644 META.json create mode 100644 META.yml create mode 100644 Makefile.PL create mode 100644 README.md create mode 100755 examples/clickable_image.cgi create mode 100755 examples/cookie.cgi create mode 100755 examples/crash.cgi create mode 100755 examples/file_upload.cgi create mode 100644 examples/mojo_proxy.pl create mode 100755 examples/wikipedia_example.cgi create mode 100644 examples/wilogo.gif create mode 100644 lib/CGI.pm create mode 100644 lib/CGI.pod create mode 100644 lib/CGI/Carp.pm create mode 100644 lib/CGI/Cookie.pm create mode 100644 lib/CGI/File/Temp.pm create mode 100644 lib/CGI/HTML/Functions.pm create mode 100644 lib/CGI/HTML/Functions.pod create mode 100644 lib/CGI/Pretty.pm create mode 100644 lib/CGI/Push.pm create mode 100644 lib/CGI/Util.pm create mode 100644 lib/Fh.pm create mode 100644 t/Dump.t create mode 100644 t/arbitrary_handles.t create mode 100644 t/autoescape.t create mode 100644 t/can.t create mode 100644 t/carp.t create mode 100644 t/cgi.t create mode 100644 t/changes.t create mode 100644 t/charset.t create mode 100644 t/checkbox_group.t create mode 100644 t/compiles_pod.t create mode 100644 t/cookie.t create mode 100644 t/delete.t create mode 100644 t/end_form.t create mode 100644 t/form.t create mode 100644 t/function.t create mode 100644 t/gh-155.t create mode 100644 t/headers.t create mode 100644 t/headers/attachment.t create mode 100644 t/headers/charset.t create mode 100644 t/headers/cookie.t create mode 100644 t/headers/default.t create mode 100644 t/headers/nph.t create mode 100644 t/headers/p3p.t create mode 100644 t/headers/target.t create mode 100644 t/headers/type.t create mode 100644 t/hidden.t create mode 100644 t/html.t create mode 100644 t/html_functions.t create mode 100644 t/http.t create mode 100644 t/init.t create mode 100644 t/init_test.txt create mode 100644 t/multipart_init.t create mode 100644 t/multipart_start.t create mode 100644 t/no_tabindex.t create mode 100644 t/param_fetch.t create mode 100644 t/param_list_context.t create mode 100644 t/popup_menu.t create mode 100644 t/postdata.t create mode 100644 t/pretty.t create mode 100644 t/push.t create mode 100644 t/query_string.t create mode 100644 t/redirect_query_string.t create mode 100644 t/request.t create mode 100644 t/rt-31107.t create mode 100644 t/rt-52469.t create mode 100644 t/rt-57524.t create mode 100644 t/rt-75628.t create mode 100644 t/rt-84767.t create mode 100644 t/rt_31107.txt create mode 100644 t/rt_75628.txt create mode 100644 t/save_read_roundtrip.t create mode 100644 t/sorted.t create mode 100644 t/start_end_asterisk.t create mode 100644 t/start_end_end.t create mode 100644 t/start_end_start.t create mode 100644 t/unescapeHTML.t create mode 100644 t/upload.t create mode 100644 t/uploadInfo.t create mode 100644 t/upload_post_text.txt create mode 100644 t/url.t create mode 100644 t/user_agent.t create mode 100644 t/utf8.t create mode 100644 t/util-58.t create mode 100644 t/util.t diff --git a/Changes b/Changes new file mode 100644 index 0000000..8301d6d --- /dev/null +++ b/Changes @@ -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
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. + + + (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 \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 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, L, L, L, +L, L, L. + +=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 "\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/$ENV{SERVER_ADMIN})] : + "this site's webmaster"; + my ($outer_message) = <Software error: +
$msg
+

+$outer_message +

+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 = "\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 = "\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 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. 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 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 + +Get or set the cookie's name. Example: + + $name = $c->name; + $new_name = $c->name('fred'); + +=item B + +Get or set the cookie's value. Example: + + $value = $c->value; + @new_value = $c->value(['a','b','c','d']); + +B 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 value of a multivalued cookie. + +=item B + +Get or set the cookie's domain. + +=item B + +Get or set the cookie's path. + +=item B + +Get or set the cookie's expiration time. + +=item B + +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, L + +L, L + +=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. + +=head1 DESCRIPTION + +The documentation here should be considered an addendum to the sections in the +L 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('some','contents');

some contents

+ h1({-align=>left});

+ h1({-align=>left},'contents');

contents

+ +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. + +=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 +, and ). + +=item B<:html4> + +Import all methods that generate HTML 4 elements (such as +, and ). + +=item B<:netscape> + +Import the , and
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, B, B 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 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 + +

Level 1 Header

+ +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 and +end_I, 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 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 tag. Additional parameters must be +proceeded by a hyphen. + +The argument B<-xbase> allows you to provide an HREF for the 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 +B + + -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 tags that look something like this: + + + + +To create an HTTP-EQUIV type of 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 +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 + 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 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 section with the +B<-head> tag. For example, to place a 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 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 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 + + + +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()'; + +Untitled Document + + +END +} + +is + start_html( -dtd => "-//IETF//DTD HTML 9.99//FR", -lang => 'fr' ), + <<"END", 'start_html()'; + + + +Untitled Document + + + +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, '

'; + +is end_h3, '

'; + +is start_table( { -border => undef } ), '
'; + +charset('utf-8'); + +my $old_encode = $CGI::ENCODE_ENTITIES; +$CGI::ENCODE_ENTITIES = '<'; + +isnt h1( escapeHTML("this is \x8bright\x9b") ), + '

this is <not> ‹right›

'; + +undef( $CGI::ENCODE_ENTITIES ); + +is h1( escapeHTML("this is \x8bright\x9b") ), + '

this is <not> ‹right›

'; + + +$CGI::ENCODE_ENTITIES = $old_encode; + +is i( p('hello there') ), '

hello there

'; + +my $q = CGI->new; +is $q->h1('hi'), '

hi

'; + +$q->autoEscape(1); + +is $q->p( { title => "hello worldè" }, 'hello á' ), + '

hello á

'; + +$q->autoEscape(0); + +is $q->p( { title => "hello worldè" }, 'hello á' ), + '

hello á

'; + +is p( { title => "hello worldè" }, 'hello á' ), + '

hello á

'; + +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" }),"","-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", + "$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", + "$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' ),"","$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(), + "submit()"); + +is(submit(-name => 'foo', + -value => 'bar'), + qq(), + "submit(-name,-value)"); + +is(submit({-name => 'foo', + -value => 'bar'}), + qq(), + "submit({-name,-value})"); + +is(textfield(-name => 'weather'), + qq(), + "textfield({-name})"); + +is(textfield(-name => 'weather', + -value => 'nice'), + qq(), + "textfield({-name,-value})"); + +is(textfield(-name => 'weather', + -value => 'nice', + -override => 1), + qq(), + "textfield({-name,-value,-override})"); + +is(checkbox(-name => 'weather', + -value => 'nice'), + qq(), + "checkbox()"); + +is(checkbox(-name => 'weather', + -value => 'nice', + -label => 'forecast'), + qq(), + "checkbox()"); + +is(checkbox(-name => 'weather', + -value => 'nice', + -label => 'forecast', + -checked => 1, + -override => 1), + qq(), + "checkbox()"); + +is(checkbox(-name => 'weather', + -value => 'dull', + -label => 'forecast'), + qq(), + "checkbox()"); + +is(radio_group(-name => 'game'), + qq( ), + 'radio_group()'); + +is(radio_group(-name => 'game', + -labels => {'chess' => 'ping pong'}), + qq( ), + 'radio_group()'); + +is(checkbox_group(-name => 'game', + -Values => [qw/checkers chess cribbage/]), + qq( ), + 'checkbox_group()'); + +is(checkbox_group(-name => 'game', + '-values' => [qw/checkers chess cribbage/], + '-defaults' => ['cribbage'], + -override=>1), + qq( ), + 'checkbox_group()'); + +is(popup_menu(-name => 'game', + '-values' => [qw/checkers chess cribbage/], + -default => 'cribbage', + -override => 1), + '', + 'popup_menu()'); + + +is(textarea(-name=>'foo', + -default=>'starting value', + -rows=>10, + -columns=>50), + '', + '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), +'' +, 'popup_menu(): basic test, including 0 as a default value'); + +is( + CGI::popup_menu(-values=>[CGI::optgroup(-values=>["b+"])],-default=>"b+"), + '' + , " 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(), '

',"single tag (pretty turned off)"); +is(h1('fred'), '

fred

',"open/close tag (pretty turned off)"); +is(h1('fred','agnes','maura'), '

fred agnes maura

',"open/close tag multiple (pretty turned off)"); +is(h1({-align=>'CENTER'},'fred'), '

fred

',"open/close tag with attribute (pretty turned off)"); +is(h1({-align=>undef},'fred'), '

fred

',"open/close tag with orphan attribute (pretty turned off)"); +is(h1({-align=>'CENTER'},['fred','agnes']), '

fred

agnes

', + "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, '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!4401196412625869430!, + 'multipart data read' +); + +# test back compatibility handle method +seek( $fh,0,0 ); +@content = $fh->handle->getlines; +like( + $content[9], + qr!4401196412625869430!, + '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, 'new; +} + +like( + $q->param( 'POSTDATA' ), + qr!5.3.0!, + '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: + + + + + 4401196412625869430 + + + + 5.3.0 + XXXXX + 4401196412625869430 + 2007-11-30 09:50:25 + 1000 + Request Received + + + + + +------=_Part_0.7772611529786723.1196412625897 +Content-Type: application/x-zip; name=capabilities.zip +Content-Transfer-Encoding: base64 +Content-Disposition: attachment; filename=capabilities.zip +Content-ID: + +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 @@ + + + + 4401196412625869430 + + + + 5.3.0 + XXXXX + 4401196412625869430 + 2007-11-30 09:50:25 + 1000 + Request Received + + + + 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'),'frog',"sorted attributes 1"); +is(a({-href=>'frog',-alt => 'Frog', -frog => 'green'},'frog'),'frog',"sorted attributes 2"); +is(a({-href=>'frog',-alt => 'Frog', -frog => 'green', -type => 'water'},'frog'),'frog',"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 tags are sorted alphabetically by name 1"); + +$meta{'frog6'} = 'frog6'; +is(join("",grep (/frog\d/,split("\n",start_html( -meta => \%meta )))), +'', +"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(), "

", "start_h1"); # TEST +is(start_h1({class => 'hello'}), "

", "start_h1 with param"); # TEST +is(end_h1(), "

", "end_h1"); # TEST + +is(start_h2(), "

", "start_h2"); # TEST +is(start_h2({class => 'hello'}), "

", "start_h2 with param"); # TEST +is(end_h2(), "

", "end_h2"); # TEST + +is(start_h3(), "

", "start_h3"); # TEST +is(start_h3({class => 'hello'}), "

", "start_h3 with param"); # TEST +is(end_h3(), "

", "end_h3"); # TEST + +is(start_h4(), "

", "start_h4"); # TEST +is(start_h4({class => 'hello'}), "

", "start_h4 with param"); # TEST +is(end_h4(), "

", "end_h4"); # TEST + +is(start_h5(), "
", "start_h5"); # TEST +is(start_h5({class => 'hello'}), "
", "start_h5 with param"); # TEST +is(end_h5(), "
", "end_h5"); # TEST + +is(start_h6(), "
", "start_h6"); # TEST +is(start_h6({class => 'hello'}), "
", "start_h6 with param"); # TEST +is(end_h6(), "
", "end_h6"); # TEST + +is(start_table(), "
", "start_table"); # TEST +is(start_table({class => 'hello'}), "
", "start_table with param"); # TEST +is(end_table(), "
", "end_table"); # TEST + +is(start_ul(), "
    ", "start_ul"); # TEST +is(start_ul({class => 'hello'}), "
      ", "start_ul with param"); # TEST +is(end_ul(), "
    ", "end_ul"); # TEST + +is(start_li(), "
  • ", "start_li"); # TEST +is(start_li({class => 'hello'}), "
  • ", "start_li with param"); # TEST +is(end_li(), "
    • ", "end_li"); # TEST + +is(start_ol(), "
      ", "start_ol"); # TEST +is(start_ol({class => 'hello'}), "
        ", "start_ol with param"); # TEST +is(end_ol(), "
      ", "end_ol"); # TEST + +is(start_td(), "", "start_td"); # TEST +is(start_td({class => 'hello'}), "", "start_td with param"); # TEST +is(end_td(), "", "end_td"); # TEST + +is(start_b(), "", "start_b"); # TEST +is(start_b({class => 'hello'}), "", "start_b with param"); # TEST +is(end_b(), "", "end_b"); # TEST + +is(start_i(), "", "start_i"); # TEST +is(start_i({class => 'hello'}), "", "start_i with param"); # TEST +is(end_i(), "", "end_i"); # TEST + +is(start_u(), "", "start_u"); # TEST +is(start_u({class => 'hello'}), "", "start_u with param"); # TEST +is(end_u(), "", "end_u"); # TEST + +is(start_div(), "
      ", "start_div"); # TEST +is(start_div({class => 'hello'}), "
      ", "start_div with param"); # TEST +is(end_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(), "

      ", "start_h1"); # TEST +is(start_h1({class => 'hello'}), "

      ", "start_h1 with param"); # TEST +is(end_h1(), "

      ", "end_h1"); # TEST + +is(start_h2(), "

      ", "start_h2"); # TEST +is(start_h2({class => 'hello'}), "

      ", "start_h2 with param"); # TEST +is(end_h2(), "

      ", "end_h2"); # TEST + +is(start_h3(), "

      ", "start_h3"); # TEST +is(start_h3({class => 'hello'}), "

      ", "start_h3 with param"); # TEST +is(end_h3(), "

      ", "end_h3"); # TEST + +is(start_h4(), "

      ", "start_h4"); # TEST +is(start_h4({class => 'hello'}), "

      ", "start_h4 with param"); # TEST +is(end_h4(), "

      ", "end_h4"); # TEST + +is(start_h5(), "
      ", "start_h5"); # TEST +is(start_h5({class => 'hello'}), "
      ", "start_h5 with param"); # TEST +is(end_h5(), "
      ", "end_h5"); # TEST + +is(start_h6(), "
      ", "start_h6"); # TEST +is(start_h6({class => 'hello'}), "
      ", "start_h6 with param"); # TEST +is(end_h6(), "
      ", "end_h6"); # TEST + +is(start_table(), "", "start_table"); # TEST +is(start_table({class => 'hello'}), "
      ", "start_table with param"); # TEST +is(end_table(), "
      ", "end_table"); # TEST + +is(start_ul(), "
        ", "start_ul"); # TEST +is(start_ul({class => 'hello'}), "
          ", "start_ul with param"); # TEST +is(end_ul(), "
        ", "end_ul"); # TEST + +is(start_li(), "
      • ", "start_li"); # TEST +is(start_li({class => 'hello'}), "
      • ", "start_li with param"); # TEST +is(end_li(), "
        • ", "end_li"); # TEST + +is(start_ol(), "
          ", "start_ol"); # TEST +is(start_ol({class => 'hello'}), "
            ", "start_ol with param"); # TEST +is(end_ol(), "
          ", "end_ol"); # TEST + +is(start_td(), "", "start_td"); # TEST +is(start_td({class => 'hello'}), "", "start_td with param"); # TEST +is(end_td(), "", "end_td"); # TEST + +is(start_b(), "", "start_b"); # TEST +is(start_b({class => 'hello'}), "", "start_b with param"); # TEST +is(end_b(), "", "end_b"); # TEST + +is(start_i(), "", "start_i"); # TEST +is(start_i({class => 'hello'}), "", "start_i with param"); # TEST +is(end_i(), "", "end_i"); # TEST + +is(start_u(), "", "start_u"); # TEST +is(start_u({class => 'hello'}), "", "start_u with param"); # TEST +is(end_u(), "", "end_u"); # TEST + +is(start_div(), "
          ", "start_div"); # TEST +is(start_div({class => 'hello'}), "
          ", "start_div with param"); # TEST +is(end_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(), "

          ", "start_h1"); # TEST +is(start_h1({class => 'hello'}), "

          ", "start_h1 with param"); # TEST +is(end_h1(), "

          ", "end_h1"); # TEST + +is(start_h2(), "

          ", "start_h2"); # TEST +is(start_h2({class => 'hello'}), "

          ", "start_h2 with param"); # TEST +is(end_h2(), "

          ", "end_h2"); # TEST + +is(start_h3(), "

          ", "start_h3"); # TEST +is(start_h3({class => 'hello'}), "

          ", "start_h3 with param"); # TEST +is(end_h3(), "

          ", "end_h3"); # TEST + +is(start_h4(), "

          ", "start_h4"); # TEST +is(start_h4({class => 'hello'}), "

          ", "start_h4 with param"); # TEST +is(end_h4(), "

          ", "end_h4"); # TEST + +is(start_h5(), "
          ", "start_h5"); # TEST +is(start_h5({class => 'hello'}), "
          ", "start_h5 with param"); # TEST +is(end_h5(), "
          ", "end_h5"); # TEST + +is(start_h6(), "
          ", "start_h6"); # TEST +is(start_h6({class => 'hello'}), "
          ", "start_h6 with param"); # TEST +is(end_h6(), "
          ", "end_h6"); # TEST + +is(start_table(), "", "start_table"); # TEST +is(start_table({class => 'hello'}), "
          ", "start_table with param"); # TEST +is(end_table(), "
          ", "end_table"); # TEST + +is(start_ul(), "
            ", "start_ul"); # TEST +is(start_ul({class => 'hello'}), "
              ", "start_ul with param"); # TEST +is(end_ul(), "
            ", "end_ul"); # TEST + +is(start_li(), "
          • ", "start_li"); # TEST +is(start_li({class => 'hello'}), "
          • ", "start_li with param"); # TEST +is(end_li(), "
            • ", "end_li"); # TEST + +is(start_ol(), "
              ", "start_ol"); # TEST +is(start_ol({class => 'hello'}), "
                ", "start_ol with param"); # TEST +is(end_ol(), "
              ", "end_ol"); # TEST + +is(start_td(), "", "start_td"); # TEST +is(start_td({class => 'hello'}), "", "start_td with param"); # TEST +is(end_td(), "", "end_td"); # TEST + +is(start_b(), "", "start_b"); # TEST +is(start_b({class => 'hello'}), "", "start_b with param"); # TEST +is(end_b(), "", "end_b"); # TEST + +is(start_i(), "", "start_i"); # TEST +is(start_i({class => 'hello'}), "", "start_i with param"); # TEST +is(end_i(), "", "end_i"); # TEST + +is(start_u(), "", "start_u"); # TEST +is(start_u({class => 'hello'}), "", "start_u with param"); # TEST +is(end_u(), "", "end_u"); # TEST + +is(start_div(), "
              ", "start_div"); # TEST +is(start_div({class => 'hello'}), "
              ", "start_div with param"); # TEST +is(end_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_', '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, '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, '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 new file mode 100644 index 0000000..10d6238 Binary files /dev/null and b/t/upload_post_text.txt differ diff --git a/t/url.t b/t/url.t new file mode 100644 index 0000000..1e46ef0 --- /dev/null +++ b/t/url.t @@ -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' ); -- cgit v1.2.1