cpan/CGI/lib/CGI/Switch.pm Simple interface for multiple server types
cpan/CGI/lib/CGI/Util.pm Utility functions
cpan/CGI/t/apache.t See if CGI::Apache still loads
+cpan/CGI/t/autoescape.t See if CGI.pm works
cpan/CGI/t/can.t See if CGI.pm works
cpan/CGI/t/carp.t See if CGI::Carp works
+cpan/CGI/t/checkbox_group.t See if CGI.pm works
cpan/CGI/t/cookie.t See if CGI::Cookie works
cpan/CGI/t/Dump.t See if CGI->Dump works
+cpan/CGI/t/end_form.t See if CGI.pm works
cpan/CGI/t/fast.t See if CGI::Fast works (if FCGI is installed)
cpan/CGI/t/form.t See if CGI.pm works
cpan/CGI/t/function.t See if CGI.pm works
+cpan/CGI/t/hidden.t See if CGI.pm works
cpan/CGI/t/html.t See if CGI.pm works
+cpan/CGI/t/http.t See if CGI.pm works
+cpan/CGI/t/init.t See if CGI.pm works
+cpan/CGI/t/init_test.txt See if CGI.pm works
cpan/CGI/t/no_tabindex.t See if CGI.pm works
cpan/CGI/t/popup_menu.t See if CGI pop menus work
cpan/CGI/t/pretty.t See if CGI.pm works
cpan/CGI/t/push.t See if CGI::Push works
cpan/CGI/t/query_string.t See if CGI->query_string() works
cpan/CGI/t/request.t See if CGI.pm works
+cpan/CGI/t/save_read_roundtrip.t See if CGI.pm works
cpan/CGI/t/start_end_asterisk.t See if CGI.pm works
cpan/CGI/t/start_end_end.t See if CGI.pm works
cpan/CGI/t/start_end_start.t See if CGI.pm works
cpan/CGI/t/upload_post_text.txt Test data for CGI.pm
cpan/CGI/t/upload.t See if CGI.pm works
cpan/CGI/t/user_agent.t See if CGI->user_agent() works
+cpan/CGI/t/utf8.t See if CGI.pm works
cpan/CGI/t/util-58.t See if 5.8-dependent features work
cpan/CGI/t/util.t See if CGI.pm works
cpan/Class-ISA/ChangeLog Changes for Class::ISA
'CGI' =>
{
'MAINTAINER' => 'lstein',
- 'DISTRIBUTION' => 'LDS/CGI.pm-3.45.tar.gz',
+ 'DISTRIBUTION' => 'LDS/CGI.pm-3.48.tar.gz',
'FILES' => q[cpan/CGI],
'EXCLUDED' => [ qr{^t/lib/Test},
qw( cgi-lib_porting.html
)
],
'CPAN' => 1,
- 'UPSTREAM' => undef,
+ 'UPSTREAM' => 'cpan',
},
'Class::ISA' =>
+Version 3.48
+
+ [BUG FIXES]
+ 1. <optgroup> default values are now properly escaped.
+ Thanks to #raleigh.pm and Mark Stosberg. (RT#49606)
+ 2. The change to exception handling in CGI::Carp introduced in 3.47 has been
+ reverted for now. It caused regressions reported in RT#49630.
+ Thanks to mkanat for the report.
+
+ [DOCUMENTATION]
+ 1. Documentation for upload() has been overhauled, thanks to Mark Stosberg.
+ 2. Documentation for tmpFileName has been added. Thanks to Mark Stosberg and Nathaniel K. Smith.
+ 3. URLS were updated, thanks to Leon Brocard and Yanick Champoux. (RT#49770)
+
+ [INTERNALS]
+ 1. More tests were added for autoescape, thanks to Bob Kuo. (RT#25485)
+
+Version 3.47
+ Released September 9th, 2009.
+ No code changes.
+
+ [INTERNALS]
+ Re-release of 3.46, which did not contain a proper MANIFEST
+
+Version 3.46
+ [BUG FIXES]
+ 1. In CGI::Pretty, we no longer add line breaks after tags we claim not to format. Thanks to rrt, Bob Kuo and
+ and Mark Stosberg. (RT#42114).
+ 2. unescapeHTML() no longer falsely recognizes certain text as entities. Thanks to Pete Gamanche, Mark Stosberg
+ and Bob Kuo. (RT#39122)
+ 3. checkbox_group() now correctly includes a space before the "checked" attribute.
+ Thanks to Andrew Speer and Bob Kuo. (RT#36583)
+ 4. Fix case-sensitivity in http() and https() according to docs. Make https()
+ return list of keys in list context. Thanks to riQyRoe and Rhesa Rozendaal. (RT#12909)
+ 5. XHTML is now automatically disabled for HTML 4, as well as HTML 2 and HTML 3. Thanks to
+ Dan Harkless and Yanick Champoux. (RT#27907)
+ 6. Pre-compiling 'end_form' with ':form' switch now works. Thanks to ryochin and Yanick Champoux. (RT#41530)
+ 7. Empty name/values pairs are now properly saved and restored from filehandles. Thanks to rlucas and
+ Rhesa Rozendaal (RT#13158)
+ 8. Some differences between startform() and start_form() have been fixed. Thanks to Slaven Rezic and
+ Shawn Corey. (RT#22046)
+ 9. url_param() has been updated to be more consistent with the documentation and param().
+ Thanks to Britton Kerin and Yanick Campoux. (RT#43587)
+ 10.hidden() now correctly supports multiple default values.
+ Thanks to david@dierauer.net and Russell Jenkins. (RT#20436)
+ 11.Calling CGI->new() no longer clobbers the value of $_ in the current scope.
+ Thanks to Alexey Tourbin, Bob Kuo and Mark Stosberg. (RT#25131)
+ 12.UTF-8 params should not get double-decoded now.
+ Thanks to Yves, Bodo, Burak Gürsoy, and Michael Schout. (RT#19913)
+ 13.We now give objects passed to CGI::Carp::die a chance to be stringified.
+ Thanks to teek and Yanick Champoux (RT#41530)
+ 14.Turning off autoEscape() now only affects the behavior of built-in HTML
+ generation fuctions. Explicit calls to escapeHTML() always escape HTML regardless
+ of the setting. Thanks to vindex, Bob Kuo and Mark Stosberg (RT#40748)
+ 15.In CGI::Fast, preferences set via pragmas are now preserved.
+ Thanks to heinst and Mark Stosberg (RT#32119)
+
+ [DOCUMENTATION]
+ 1. remote_addr() is now documented. Thanks to Yanick Champoux. (RT#38884)
+ 2. In CGI::Pretty in the list of tags left unformatted was updated to match the code. Thanks to Mark Stosberg. (RT#42114)
+ 3. In CGI::Pretty, performance concerns are now documented. Thanks to Jochen, Rhesa Rozendaal and Mark Stosberg (RT#13223)
+ 4. A number of outdated Netscape references have been removed. Thanks to Mark Stosberg.
+ 5. The documentation has been purged of examples of using indirect object notation. Thanks to Mark Stosberg.
+ 6. Some POD formatting was fixed. Thanks to Dave Mitchell (RT#48935).
+ 7. Docs and examples were updated to highlight start_form instead of startform.
+ Thanks to Slaven Rezic.
+ 8. Note that CGI::Carp::carpout() doesn't work with in-memory filehandles.
+ Thanks to rhubbell and Mark Stosberg.
+ 9. The documentation for the -newstyle_urls is now less confusing.
+ Thanks to Ryan Tate and Mark Stosberg (RT#49454)
+
+ [INTERNALS]
+ 1. Quit bundling an ancient copy of Test::More and and using a custom 'lib' path for the tests. Instead, Test::More
+ is now a dependency. Thanks to Ansgar and Mark Stosberg (RT#48811)
+ 2. Automated tests for hidden() have been added, thanks to Russel Jenkins and Mark Stosberg (RT#20436)
+ 3. t/util.t has been updated to use Test::More instead of a home-grown test function. Thanks to Bob Kuo.
+
Version 3.45
[BUG FIXES]
1. Prevent warnings about "uninitialized values" for REQUEST_URI, HTTP_USER_AGENT and other environment variables.
Patches by Callum Gibson, heiko and Mark Stosberg. (RT#24684, RT#29065)
- 2. Avoid death in some cases when running under Taint mode on Windows.
+ 2. Avoid death in some cases when running under Taint mode on Windows.
Patch by Peter Hancock (RT#43796)
3. Allow 0 to be used as a default value in popup_menu(). This was broken starting in 3.37.
Thanks to Haze, who was the first to report this and supply a patch, and pfschill, who pinpointed
when the bug was introduced. A regression test for this was also added. (RT#37908)
- 4. Allow "+" as a valid character in file names, which fixes temp file creation on OS X Leopard.
- Thanks to Andy Armstrong, and alech for patches. (RT#30504)
+ 4. Allow "+" as a valid character in file names, which fixes temp file creation on OS X Leopard.
+ Thanks to Andy Armstrong, and alech for patches. (RT#30504)
5. Set binmode() on the Netware platform, thanks to Guenter Knauf (RT#27455)
- 6. Don't allow a CGI::Carp error handler to die recursively. Print a warning and exit instead.
+ 6. Don't allow a CGI::Carp error handler to die recursively. Print a warning and exit instead.
Thanks to Marc Chantreux. (RT#45956)
7. The Dump() method now is fixed to escape HTML properly. Thanks to Mark Stosberg (RT#21341)
8. Support for <optgroup> with scrolling_list() now works the same way as it does for popup_menu().
5. The docs for redirect() were updated to reflect that most headers are
ignored during redirection. Thanks to Mark Stosberg (RT#44911)
- [INTERNALS]
+ [INTERNALS]
1. New t/unescapeHTML.t test script has been added. It includes a TODO test for a pre-existing
bug which could use a patch. Thanks to Pete Gamache and Mark Stosberg (RT#39122)
2. New test scripts have been added for user_agent(), popup_menu() and query_string(), scrolling_list() and Dump()
Thanks to Mark Stosberg and Stuart Johnston. (RT#37908, RT#43006, RT#21341, RT#30097)
- 3. CGI::Carp and CGI::Util have been updated to have non-developer version numbers.
+ 3. CGI::Carp and CGI::Util have been updated to have non-developer version numbers.
Thanks to Slaven Rezic. (RT#48425)
- 4. CGI::Switch and CGI::Apache now properly set their VERSION in their own name space.
+ 4. CGI::Switch and CGI::Apache now properly set their VERSION in their own name space.
Thanks to Alexey Tourbin (RT#11941,RT#11942)
Version 3.44
1. Patch from Kurt Jaeger to allow HTTP PUT even if the content length is unknown.
2. Patch from Pavel merdin to fix a problem for one of the FireFox addons.
- 3. Fixed issue in mod_perl & fastCGI environment of cookies returned from
+ 3. Fixed issue in mod_perl & fastCGI environment of cookies returned from
CGI->cookie() leaking from one session to another.
Version 3.43
Version 3.14 Tue Dec 6 17:12:03 EST 2005
1. Fixed broken scrolling_list() select attribute.
-
+
Version 3.13
1. Removed extraneous empty "?" from end of self_url().
Version 3.11
1. Killed warning in CGI::Cookie about MOD_PERL_API_VERSION
2. Fixed append() so that it works in function mode.
- 3. Workaround for a bug that appears in Apache2 versions through 2.0.54
+ 3. Workaround for a bug that appears in Apache2 versions through 2.0.54
in which SCRIPT_NAME and PATH_INFO are incorrect if the additional path_info
contains a double slash. This workaround will handle the common case of
http://mysite.com/cgi-bin/log.cgi/http://www.some.other.site/args, but will
5. Tests for *tag start/end generation from Shlomi Fish.
6. Support for can() method provided by Ron Savage.
7. Fix for lang='' when outputting XHTML.
- 8. Added support for chunked transfer encoding, as suggested by
+ 8. Added support for chunked transfer encoding, as suggested by
Hakan Ardo
9. Fixed clobbering of row and column headers in tableized radio
and checkbox groups, as reported by Nicolas Thierry-Mieg.
4. HTML shortcuts now generate tags in ALL UPPERCASE.
5. start_html() now generates correct SGML header:
<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML//EN">
-
+
6. CGI::Carp no longer fails "use strict refs" pragma.
Version 2.25
END
print "Sorry, this isn't very exciting!\n";
-print $query->startform;
+print $query->start_form;
print $query->image_button('picture',"./wilogo.gif");
print "Give me a: ",$query->popup_menu('letter',['A','B','C','D','E','W']),"\n"; #
print "<P>Magnification: ",$query->radio_group('magnification',['1X','2X','4X','20X']),"\n";
sub print_query {
$script_name = $query->script_name;
print "<H1>Frameset Query</H1>\n";
- print $query->startform(-action=>"$script_name/response",-TARGET=>"response");
+ print $query->start_form(-action=>"$script_name/response",-TARGET=>"response");
print "What's your name? ",$query->textfield('name');
print "<P>What's the combination?<P>",
$query->checkbox_group(-name=>'words',
# pick a default starting value;
$query->param('amenu','FOO1') unless $query->param('amenu');
-print $query->startform;
+print $query->start_form;
print $query->popup_menu('amenu',[('FOO1'..'FOO9')]);
print $query->submit,$query->endform;
print "<H1>Multiple Forms</H1>\n";
# Print the first form
-print $query->startform;
+print $query->start_form;
$name = $query->remote_user || 'anonymous@' . $query->remote_host;
print "What's your name? ",$query->textfield('name',$name,50);
# Print the second form
print "<HR>\n";
-print $query->startform;
+print $query->start_form;
print "Some radio buttons: ",$query->radio_group('radio buttons',
[qw{one two three four five}],'three'),"\n";
print "<P>What's the password? ",$query->password_field('pass','secret');
if (!$query->param) {
print "<H1>Ask your Question</H1>\n";
- print $query->startform(-target=>'_new');
+ print $query->start_form(-target=>'_new');
print "What's your name? ",$query->textfield('name');
print "<P>What's the combination?<P>",
$query->checkbox_group(-name=>'words',
# http://stein.cshl.org/WWW/software/CGI/
$CGI::revision = '$Id: CGI.pm,v 1.266 2009/07/30 16:32:34 lstein Exp $';
-$CGI::VERSION='3.45';
+$CGI::VERSION='3.48';
# HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES.
# UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING.
# ------------------ START OF THE LIBRARY ------------
-*end_form = \&endform;
+#### Method: endform
+# This method is DEPRECATED
+*endform = \&end_form;
# make mod_perlhappy
initialize_globals();
if ($PARAM_UTF8) {
eval "require Encode; 1;" unless Encode->can('decode'); # bring in these functions
- @result = map {ref $_ ? $_ : Encode::decode(utf8=>$_) } @result;
+ @result = map {ref $_ ? $_ : $self->_decode_utf8($_) } @result;
}
return wantarray ? @result : $result[0];
}
+sub _decode_utf8 {
+ my ($self, $val) = @_;
+
+ if (Encode::is_utf8($val)) {
+ return $val;
+ }
+ else {
+ return Encode::decode(utf8 => $val);
+ }
+}
+
sub self_or_default {
return @_ if defined($_[0]) && (!ref($_[0])) &&($_[0] eq 'CGI');
unless (defined($_[0]) &&
}
if (defined($fh) && ($fh ne '')) {
- while (<$fh>) {
- chomp;
- last if /^=/;
- push(@lines,$_);
+ while (my $line = <$fh>) {
+ chomp $line;
+ last if $line =~ /^=$/;
+ push(@lines,$line);
}
# massage back into standard format
if ("@lines" =~ /=/) {
push(@{$self->{'.url_param'}->{$param}},$value);
}
} else {
- $self->{'.url_param'}->{'keywords'} = [$self->parse_keywordlist($ENV{QUERY_STRING})];
+ my @keywords = $self->parse_keywordlist($ENV{QUERY_STRING});
+ $self->{'.url_param'}{'keywords'} = \@keywords if @keywords;
}
}
return keys %{$self->{'.url_param'}} unless defined($name);
return '<ul></ul>' unless $self->param;
push(@result,"<ul>");
for $param ($self->param) {
- my($name)=$self->escapeHTML($param);
+ my($name)=$self->_maybe_escapeHTML($param);
push(@result,"<li><strong>$name</strong></li>");
push(@result,"<ul>");
for $value ($self->param($param)) {
- $value = $self->escapeHTML($value);
+ $value = $self->_maybe_escapeHTML($value);
$value =~ s/\n/<br \/>\n/g;
push(@result,"<li>$value</li>");
}
my($escaped_param) = escape($param);
my($value);
for $value ($self->param($param)) {
- print $filehandle "$escaped_param=",escape("$value"),"\n";
+ print $filehandle "$escaped_param=",escape("$value"),"\n"
+ if length($escaped_param) or length($value);
}
}
for (keys %{$self->{'.fieldnames'}}) {
# Now that we know whether we're using the HTML 3.2 DTD or not, it's okay to
# call escapeHTML(). Strangely enough, the title needs to be escaped as
# HTML while the author needs to be escaped as a URL.
- $title = $self->escapeHTML($title || 'Untitled Document');
+ $title = $self->_maybe_escapeHTML($title || 'Untitled Document');
$author = $self->escape($author);
- if ($DTD_PUBLIC_IDENTIFIER =~ /[^X]HTML (2\.0|3\.2)/i) {
+ if ($DTD_PUBLIC_IDENTIFIER =~ /[^X]HTML (2\.0|3\.2|4\.01?)/i) {
$lang = "" unless defined $lang;
$XHTML = 0;
}
#### Method: startform
+# This method is DEPRECATED
# Start a form
# Parameters:
# $method -> optional submission method to use (GET or POST)
my($method,$action,$enctype,@other) =
rearrange([METHOD,ACTION,ENCTYPE],@p);
- $method = $self->escapeHTML(lc($method || 'post'));
- $enctype = $self->escapeHTML($enctype || &URL_ENCODED);
+ $method = $self->_maybe_escapeHTML(lc($method || 'post'));
+ $enctype = $self->_maybe_escapeHTML($enctype || &URL_ENCODED);
if (defined $action) {
- $action = $self->escapeHTML($action);
+ $action = $self->_maybe_escapeHTML($action);
}
else {
- $action = $self->escapeHTML($self->request_uri || $self->self_url);
+ $action = $self->_maybe_escapeHTML($self->request_uri || $self->self_url);
}
$action = qq(action="$action");
my($other) = @other ? " @other" : '';
}
END_OF_FUNC
-
#### Method: start_form
-# synonym for startform
+# Start a form
+# Parameters:
+# $method -> optional submission method to use (GET or POST)
+# $action -> optional URL of script to run
+# $enctype ->encoding to use (URL_ENCODED or MULTIPART)
'start_form' => <<'END_OF_FUNC',
sub start_form {
- $XHTML ? &start_multipart_form : &startform;
-}
-END_OF_FUNC
+ my($self,@p) = self_or_default(@_);
-'end_multipart_form' => <<'END_OF_FUNC',
-sub end_multipart_form {
- &endform;
+ my($method,$action,$enctype,@other) =
+ rearrange([METHOD,ACTION,ENCTYPE],@p);
+
+ $method = $self->_maybe_escapeHTML(lc($method || 'post'));
+
+ if( $XHTML ){
+ $enctype = $self->_maybe_escapeHTML($enctype || &MULTIPART);
+ }else{
+ $enctype = $self->_maybe_escapeHTML($enctype || &URL_ENCODED);
+ }
+
+ if (defined $action) {
+ $action = $self->_maybe_escapeHTML($action);
+ }
+ else {
+ $action = $self->_maybe_escapeHTML($self->request_uri || $self->self_url);
+ }
+ $action = qq(action="$action");
+ my($other) = @other ? " @other" : '';
+ $self->{'.parametersToAdd'}={};
+ return qq/<form method="$method" $action enctype="$enctype"$other>\n/;
}
END_OF_FUNC
#### Method: start_multipart_form
-# synonym for startform
'start_multipart_form' => <<'END_OF_FUNC',
sub start_multipart_form {
my($self,@p) = self_or_default(@_);
if (defined($p[0]) && substr($p[0],0,1) eq '-') {
- return $self->startform(-enctype=>&MULTIPART,@p);
+ return $self->start_form(-enctype=>&MULTIPART,@p);
} else {
my($method,$action,@other) =
rearrange([METHOD,ACTION],@p);
- return $self->startform($method,$action,&MULTIPART,@other);
+ return $self->start_form($method,$action,&MULTIPART,@other);
}
}
END_OF_FUNC
-#### Method: endform
+
+#### Method: end_form
# End a form
-'endform' => <<'END_OF_FUNC',
-sub endform {
+'end_form' => <<'END_OF_FUNC',
+sub end_form {
my($self,@p) = self_or_default(@_);
if ( $NOSTICKY ) {
- return wantarray ? ("</form>") : "\n</form>";
+ return wantarray ? ("</form>") : "\n</form>";
} else {
- if (my @fields = $self->get_fields) {
- return wantarray ? ("<div>",@fields,"</div>","</form>")
- : "<div>".(join '',@fields)."</div>\n</form>";
- } else {
- return "</form>";
- }
+ if (my @fields = $self->get_fields) {
+ return wantarray ? ("<div>",@fields,"</div>","</form>")
+ : "<div>".(join '',@fields)."</div>\n</form>";
+ } else {
+ return "</form>";
+ }
}
}
END_OF_FUNC
+#### Method: end_multipart_form
+# end a multipart form
+'end_multipart_form' => <<'END_OF_FUNC',
+sub end_multipart_form {
+ &end_form;
+}
+END_OF_FUNC
+
'_textfield' => <<'END_OF_FUNC',
sub _textfield {
my $current = $override ? $default :
(defined($self->param($name)) ? $self->param($name) : $default);
- $current = defined($current) ? $self->escapeHTML($current,1) : '';
- $name = defined($name) ? $self->escapeHTML($name) : '';
+ $current = defined($current) ? $self->_maybe_escapeHTML($current,1) : '';
+ $name = defined($name) ? $self->_maybe_escapeHTML($name) : '';
my($s) = defined($size) ? qq/ size="$size"/ : '';
my($m) = defined($maxlength) ? qq/ maxlength="$maxlength"/ : '';
my($other) = @other ? " @other" : '';
my($current)= $override ? $default :
(defined($self->param($name)) ? $self->param($name) : $default);
- $name = defined($name) ? $self->escapeHTML($name) : '';
- $current = defined($current) ? $self->escapeHTML($current) : '';
+ $name = defined($name) ? $self->_maybe_escapeHTML($name) : '';
+ $current = defined($current) ? $self->_maybe_escapeHTML($current) : '';
my($r) = $rows ? qq/ rows="$rows"/ : '';
my($c) = $cols ? qq/ cols="$cols"/ : '';
my($other) = @other ? " @other" : '';
my($label,$value,$script,$tabindex,@other) = rearrange([NAME,[VALUE,LABEL],
[ONCLICK,SCRIPT],TABINDEX],@p);
- $label=$self->escapeHTML($label);
- $value=$self->escapeHTML($value,1);
- $script=$self->escapeHTML($script);
+ $label=$self->_maybe_escapeHTML($label);
+ $value=$self->_maybe_escapeHTML($value,1);
+ $script=$self->_maybe_escapeHTML($script);
+
+ $script ||= '';
my($name) = '';
$name = qq/ name="$label"/ if $label;
my($label,$value,$tabindex,@other) = rearrange([NAME,[VALUE,LABEL],TABINDEX],@p);
- $label=$self->escapeHTML($label);
- $value=$self->escapeHTML($value,1);
+ $label=$self->_maybe_escapeHTML($label);
+ $value=$self->_maybe_escapeHTML($value,1);
my $name = $NOSTICKY ? '' : 'name=".submit" ';
$name = qq/name="$label" / if defined($label);
sub reset {
my($self,@p) = self_or_default(@_);
my($label,$value,$tabindex,@other) = rearrange(['NAME',['VALUE','LABEL'],TABINDEX],@p);
- $label=$self->escapeHTML($label);
- $value=$self->escapeHTML($value,1);
+ $label=$self->_maybe_escapeHTML($label);
+ $value=$self->_maybe_escapeHTML($value,1);
my ($name) = ' name=".reset"';
$name = qq/ name="$label"/ if defined($label);
$value = defined($value) ? $value : $label;
my($label,$tabindex,@other) = rearrange([[NAME,VALUE],TABINDEX],@p);
- $label=$self->escapeHTML($label,1);
+ $label=$self->_maybe_escapeHTML($label,1);
$label = $label || "Defaults";
my($value) = qq/ value="$label"/;
my($other) = @other ? " @other" : '';
$checked = $self->_checked($checked);
}
my($the_label) = defined $label ? $label : $name;
- $name = $self->escapeHTML($name);
- $value = $self->escapeHTML($value,1);
- $the_label = $self->escapeHTML($the_label);
+ $name = $self->_maybe_escapeHTML($name);
+ $value = $self->_maybe_escapeHTML($value,1);
+ $the_label = $self->_maybe_escapeHTML($the_label);
my($other) = @other ? "@other " : '';
$tabindex = $self->element_tab($tabindex);
$self->register_parameter($name);
-# Escape HTML -- used internally
+# Escape HTML
'escapeHTML' => <<'END_OF_FUNC',
sub escapeHTML {
- # hack to work around earlier hacks
- push @_,$_[0] if @_==1 && $_[0] eq 'CGI';
- my ($self,$toencode,$newlinestoo) = CGI::self_or_default(@_);
- return undef unless defined($toencode);
- return $toencode if ref($self) && !$self->{'escape'};
- $toencode =~ s{&}{&}gso;
- $toencode =~ s{<}{<}gso;
- $toencode =~ s{>}{>}gso;
- if ($DTD_PUBLIC_IDENTIFIER =~ /[^X]HTML 3\.2/i) {
- # $quot; was accidentally omitted from the HTML 3.2 DTD -- see
- # <http://validator.w3.org/docs/errors.html#bad-entity> /
- # <http://lists.w3.org/Archives/Public/www-html/1997Mar/0003.html>.
- $toencode =~ s{"}{"}gso;
- }
- else {
- $toencode =~ s{"}{"}gso;
- }
- # Handle bug in some browsers with Latin charsets
- if ($self->{'.charset'} &&
- (uc($self->{'.charset'}) eq 'ISO-8859-1' ||
- uc($self->{'.charset'}) eq 'WINDOWS-1252'))
- {
+ # hack to work around earlier hacks
+ push @_,$_[0] if @_==1 && $_[0] eq 'CGI';
+ my ($self,$toencode,$newlinestoo) = CGI::self_or_default(@_);
+ return undef unless defined($toencode);
+ $toencode =~ s{&}{&}gso;
+ $toencode =~ s{<}{<}gso;
+ $toencode =~ s{>}{>}gso;
+ if ($DTD_PUBLIC_IDENTIFIER =~ /[^X]HTML 3\.2/i) {
+ # $quot; was accidentally omitted from the HTML 3.2 DTD -- see
+ # <http://validator.w3.org/docs/errors.html#bad-entity> /
+ # <http://lists.w3.org/Archives/Public/www-html/1997Mar/0003.html>.
+ $toencode =~ s{"}{"}gso;
+ }
+ else {
+ $toencode =~ s{"}{"}gso;
+ }
+
+ # Handle bug in some browsers with Latin charsets
+ if ($self->{'.charset'}
+ && (uc($self->{'.charset'}) eq 'ISO-8859-1'
+ || uc($self->{'.charset'}) eq 'WINDOWS-1252')) {
$toencode =~ s{'}{'}gso;
$toencode =~ s{\x8b}{‹}gso;
$toencode =~ s{\x9b}{›}gso;
- if (defined $newlinestoo && $newlinestoo) {
- $toencode =~ s{\012}{ }gso;
- $toencode =~ s{\015}{ }gso;
- }
- }
- return $toencode;
+ if (defined $newlinestoo && $newlinestoo) {
+ $toencode =~ s{\012}{ }gso;
+ $toencode =~ s{\015}{ }gso;
+ }
+ }
+ return $toencode;
}
END_OF_FUNC
my $latin = defined $self->{'.charset'} ? $self->{'.charset'} =~ /^(ISO-8859-1|WINDOWS-1252)$/i
: 1;
# thanks to Randal Schwartz for the correct solution to this one
- $string=~ s[&(.*?);]{
+ $string=~ s[&(\S*?);]{
local $_ = $1;
/^amp$/i ? "&" :
/^quot$/i ? '"' :
# If no check array is specified, check the first by default
$checked{$values[0]}++ if $box_type eq 'radio' && !%checked;
- $name=$self->escapeHTML($name);
+ $name=$self->_maybe_escapeHTML($name);
my %tabs = ();
if ($TABINDEX && $tabindex) {
unless (defined($nolabels) && $nolabels) {
$label = $_;
$label = $labels->{$_} if defined($labels) && defined($labels->{$_});
- $label = $self->escapeHTML($label,1);
+ $label = $self->_maybe_escapeHTML($label,1);
$label = "<span style=\"color:gray\">$label</span>" if $disabled{$_};
}
my $attribs = $self->_set_attributes($_, $attributes);
my $tab = $tabs{$_};
- $_=$self->escapeHTML($_);
+ $_=$self->_maybe_escapeHTML($_);
if ($XHTML) {
push @elements,
CGI::label($labelattributes,
qq(<input type="$box_type" name="$name" value="$_" $checkit$other$tab$attribs$disable/>$label)).${break};
} else {
- push(@elements,qq/<input type="$box_type" name="$name" value="$_"$checkit$other$tab$attribs$disable>${label}${break}/);
+ push(@elements,qq/<input type="$box_type" name="$name" value="$_" $checkit$other$tab$attribs$disable>${label}${break}/);
}
}
$self->register_parameter($name);
? @$default
: $default;
}
- $name=$self->escapeHTML($name);
+ $name=$self->_maybe_escapeHTML($name);
my($other) = @other ? " @other" : '';
my(@values);
for my $v (split(/\n/)) {
my $selectit = $XHTML ? 'selected="selected"' : 'selected';
for my $selected (keys %selected) {
- $v =~ s/(value="$selected")/$selectit $1/;
+ $v =~ s/(value="\Q$selected\E")/$selectit $1/;
}
$result .= "$v\n";
}
my($selectit) = $self->_selected($selected{$_});
my($label) = $_;
$label = $labels->{$_} if defined($labels) && defined($labels->{$_});
- my($value) = $self->escapeHTML($_);
- $label = $self->escapeHTML($label,1);
+ my($value) = $self->_maybe_escapeHTML($_);
+ $label = $self->_maybe_escapeHTML($label,1);
$result .= "<option${attribs} ${selectit}value=\"$value\">$label</option>\n";
}
}
@values = $self->_set_values_and_labels($values,\$labels,$name,$labeled,$novals);
my($other) = @other ? " @other" : '';
- $name=$self->escapeHTML($name);
+ $name=$self->_maybe_escapeHTML($name);
$result = qq/<optgroup label="$name"$other>\n/;
for (@values) {
if (/<optgroup/) {
my $attribs = $self->_set_attributes($_, $attributes);
my($label) = $_;
$label = $labels->{$_} if defined($labels) && defined($labels->{$_});
- $label=$self->escapeHTML($label);
- my($value)=$self->escapeHTML($_,1);
+ $label=$self->_maybe_escapeHTML($label);
+ my($value)=$self->_maybe_escapeHTML($_,1);
$result .= $labeled ? $novals ? "<option$attribs label=\"$value\">$label</option>\n"
: "<option$attribs label=\"$value\" value=\"$value\">$label</option>\n"
: $novals ? "<option$attribs>$label</option>\n"
my($has_size) = $size ? qq/ size="$size"/: '';
my($other) = @other ? " @other" : '';
- $name=$self->escapeHTML($name);
+ $name=$self->_maybe_escapeHTML($name);
$tabindex = $self->element_tab($tabindex);
$result = qq/<select name="$name" $tabindex$has_size$is_multiple$other>\n/;
for (@values) {
my($selectit) = $self->_selected($selected{$_});
my($label) = $_;
$label = $labels->{$_} if defined($labels) && defined($labels->{$_});
- my($value) = $self->escapeHTML($_);
- $label = $self->escapeHTML($label,1);
+ my($value) = $self->_maybe_escapeHTML($_);
+ $label = $self->_maybe_escapeHTML($label,1);
$result .= "<option${attribs} ${selectit}value=\"$value\">$label</option>\n";
}
}
for ($default,$override,@other) {
push(@value,$_) if defined($_);
}
+ undef @other;
}
# use previous values if override is not set
my @prev = $self->param($name);
@value = @prev if !$do_override && @prev;
- $name=$self->escapeHTML($name);
+ $name=$self->_maybe_escapeHTML($name);
for (@value) {
- $_ = defined($_) ? $self->escapeHTML($_,1) : '';
+ $_ = defined($_) ? $self->_maybe_escapeHTML($_,1) : '';
push @result,$XHTML ? qq(<input type="hidden" name="$name" value="$_" @other />)
: qq(<input type="hidden" name="$name" value="$_" @other>);
}
my($align) = $alignment ? " align=\L\"$alignment\"" : '';
my($other) = @other ? " @other" : '';
- $name=$self->escapeHTML($name);
+ $name=$self->_maybe_escapeHTML($name);
return $XHTML ? qq(<input type="image" name="$name" src="$src"$align$other />)
: qq/<input type="image" name="$name" src="$src"$align$other>/;
}
push(@param,'-secure'=>$secure) if $secure;
push(@param,'-httponly'=>$httponly) if $httponly;
- return new CGI::Cookie(@param);
+ return CGI::Cookie->new(@param);
}
END_OF_FUNC
sub http {
my ($self,$parameter) = self_or_CGI(@_);
if ( defined($parameter) ) {
- if ( $parameter =~ /^HTTP/ ) {
- return $ENV{$parameter};
- }
- $parameter =~ tr/-/_/;
- }
- return $ENV{"HTTP_\U$parameter\E"} if $parameter;
- my(@p);
- for (keys %ENV) {
- push(@p,$_) if /^HTTP/;
+ $parameter =~ tr/-a-z/_A-Z/;
+ if ( $parameter =~ /^HTTP(?:_|$)/ ) {
+ return $ENV{$parameter};
+ }
+ return $ENV{"HTTP_$parameter"};
}
- return @p;
+ return grep { /^HTTP(?:_|$)/ } keys %ENV;
}
END_OF_FUNC
#### Method: https
-# Return the value of HTTPS
+# Return the value of HTTPS, or
+# the value of an HTTPS variable, or
+# the list of variables
####
'https' => <<'END_OF_FUNC',
sub https {
- local($^W)=0;
my ($self,$parameter) = self_or_CGI(@_);
- return $ENV{HTTPS} unless $parameter;
- return $ENV{$parameter} if $parameter=~/^HTTPS/;
- $parameter =~ tr/-/_/;
- return $ENV{"HTTPS_\U$parameter\E"} if $parameter;
- my(@p);
- for (keys %ENV) {
- push(@p,$_) if /^HTTPS/;
+ if ( defined($parameter) ) {
+ $parameter =~ tr/-a-z/_A-Z/;
+ if ( $parameter =~ /^HTTPS(?:_|$)/ ) {
+ return $ENV{$parameter};
+ }
+ return $ENV{"HTTPS_$parameter"};
}
- return @p;
+ return wantarray
+ ? grep { /^HTTPS(?:_|$)/ } keys %ENV
+ : $ENV{'HTTPS'};
}
END_OF_FUNC
END_OF_FUNC
# -------------- really private subroutines -----------------
+'_maybe_escapeHTML' => <<'END_OF_FUNC',
+sub _maybe_escapeHTML {
+ # hack to work around earlier hacks
+ push @_,$_[0] if @_==1 && $_[0] eq 'CGI';
+ my ($self,$toencode,$newlinestoo) = CGI::self_or_default(@_);
+ return undef unless defined($toencode);
+ return $toencode if ref($self) && !$self->{'escape'};
+ return $self->escapeHTML($toencode, $newlinestoo);
+}
+END_OF_FUNC
+
'previous_or_default' => <<'END_OF_FUNC',
sub previous_or_default {
my($self,$name,$defaults,$override) = @_;
# choose a relatively unpredictable tmpfile sequence number
my $seqno = unpack("%16C*",join('',localtime,grep {defined $_} values %ENV));
for (my $cnt=10;$cnt>0;$cnt--) {
- next unless $tmpfile = new CGITempFile($seqno);
+ next unless $tmpfile = CGITempFile->new($seqno);
$tmp = $tmpfile->as_string;
last if defined($filehandle = Fh->new($filename,$tmp,$PRIVATE_TEMPFILES));
$seqno += int rand(100);
# choose a relatively unpredictable tmpfile sequence number
my $seqno = unpack("%16C*",join('',localtime,grep {defined $_} values %ENV));
for (my $cnt=10;$cnt>0;$cnt--) {
- next unless $tmpfile = new CGITempFile($seqno);
+ next unless $tmpfile = CGITempFile->new($seqno);
$tmp = $tmpfile->as_string;
last if defined($filehandle = Fh->new($param,$tmp,$PRIVATE_TEMPFILES));
$seqno += int rand(100);
#!/usr/local/bin/perl -w
use CGI; # load CGI routines
- $q = new CGI; # create new CGI object
+ $q = CGI->new; # create new CGI object
print $q->header, # create the HTTP header
$q->start_html('hello world'), # start the HTML
$q->h1('hello world'), # level 1 header
=head2 CREATING A NEW QUERY OBJECT (OBJECT-ORIENTED STYLE):
- $query = new CGI;
+ $query = CGI->new;
This will parse the input (from both POST and GET methods) and store
it into a perl5 object called $query.
=head2 CREATING A NEW QUERY OBJECT FROM AN INPUT FILE
- $query = new CGI(INPUTFILE);
+ $query = CGI->new(INPUTFILE);
If you provide a file handle to the new() method, it will read
parameters from the file (or STDIN, or whatever). The file can be in
references to file handles, or even references to filehandle globs,
which is the "official" way to pass a filehandle:
- $query = new CGI(\*STDIN);
+ $query = CGI->new(\*STDIN);
You can also initialize the CGI object with a FileHandle or IO::File
object.
You can also initialize the query object from a hash
reference:
- $query = new CGI( {'dinosaur'=>'barney',
+ $query = CGI->new( {'dinosaur'=>'barney',
'song'=>'I love you',
'friends'=>[qw/Jessica George Nancy/]}
);
or from a properly formatted, URL-escaped query string:
- $query = new CGI('dinosaur=barney&color=purple');
+ $query = CGI->new('dinosaur=barney&color=purple');
or from a previously existing CGI object (currently this clones the
parameter list, but none of the other object-specific fields, such as
autoescaping):
- $old_query = new CGI;
- $new_query = new CGI($old_query);
+ $old_query = CGI->new;
+ $new_query = CGI->new($old_query);
To create an empty query, initialize it from an empty string or hash:
- $empty_query = new CGI("");
+ $empty_query = CGI->new("");
-or-
- $empty_query = new CGI({});
+ $empty_query = CGI->new({});
=head2 FETCHING A LIST OF KEYWORDS FROM THE QUERY:
open (OUT,">>test.out") || die;
$records = 5;
for (0..$records) {
- my $q = new CGI;
+ my $q = CGI->new;
$q->param(-name=>'counter',-value=>$_);
$q->save(\*OUT);
}
# reopen for reading
open (IN,"test.out") || die;
while (!eof(IN)) {
- my $q = new CGI(\*IN);
+ my $q = CGI->new(\*IN);
print $q->param('counter'),"\n";
}
=item B<:netscape>
-Import all methods that generate Netscape-specific HTML extensions.
+Import the <blink>, <fontsize> and <center> tags.
=item B<:html>
-Import all HTML-generating shortcuts (i.e. 'html2' + 'html3' +
-'netscape')...
+Import all HTML-generating shortcuts (i.e. 'html2', 'html3', 'html4' and 'netscape')
=item B<:standard>
When you I<use CGI -any>, then any method that the query object
doesn't recognize will be interpreted as a new HTML tag. This allows
-you to support the next I<ad hoc> Netscape or Microsoft HTML
+you to support the next I<ad hoc> HTML
extension. This lets you go wild with new and unsupported tags:
use CGI qw(-any);
- $q=new CGI;
+ $q=CGI->new;
print $q->gradient({speed=>'fast',start=>'red',end=>'blue'});
Since using <cite>any</cite> causes any mistyped method name
feature. Thanks to Michalis Kabrianis <kabrianis@hellug.gr> for this
feature.
-If start_html()'s -dtd parameter specifies an HTML 2.0 or 3.2 DTD,
+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.
?name=fred;age=24;favorite_color=3
-Semicolon-delimited query strings are always accepted, but will not be
-emitted by self_url() and query_string() unless the -newstyle_urls
-pragma is specified.
-
-This became the default in version 2.64.
+Semicolon-delimited query strings are always accepted, and will be emitted by
+self_url() and query_string(). newstyle_urls became the default in version
+2.64.
=item -oldstyle_urls
The B<-cookie> parameter generates a header that tells the browser to provide
a "magic cookie" during all subsequent transactions with your script.
-Netscape cookies have a special format that includes interesting attributes
+Some cookies have a special format that includes interesting attributes
such as expiration time. Use the cookie() method to create and retrieve
session cookies.
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 Netscape unofficial BGCOLOR attribute, are added
+provide, such as the unofficial BGCOLOR attribute, are added
to the <body> tag. Additional parameters must be proceeded by a
hyphen.
The argument B<-target> allows you to provide a default target frame
for all the links and fill-out forms on the page. B<This is a
-non-standard HTTP feature which only works with Netscape browsers!>
-See the Netscape documentation on frames for details of how to
-manipulate this.
+non-standard HTTP feature which only works with some browsers!>
-target=>"answer_window"
JAVASCRIPTING: The B<-script>, B<-noScript>, B<-onLoad>,
B<-onMouseOver>, B<-onMouseOut> and B<-onUnload> parameters are used
-to add Netscape JavaScript calls to your pages. B<-script> should
+to add JavaScript calls to your pages. B<-script> should
point to a block of text containing JavaScript function definitions.
This block will be placed within a <script> block inside the HTML (not
HTTP) header. The block is placed in the header in order to give your
browser. Usually these parameters are calls to functions defined in the
B<-script> field:
- $query = new CGI;
+ $query = CGI->new;
print header;
$JSCRIPT=<<END;
// Ask a silly question
=item 4, 5, 6...
Any other parameters you want to include in the <body> tag. This is a good
-place to put Netscape extensions, such as colors and wallpaper patterns.
+place to put HTML extensions, such as colors and wallpaper patterns.
=back
be replaced by their numeric entities, since CGI.pm has no lookup
table for all the possible encodings.
+C<escapeHTML()> expects the supplied string to be a character string. This means you
+should Encode::decode data received from "outside" and Encode::encode your
+strings before sending them back outside. If your source code UTF-8 encoded and
+you want to upgrade string literals in your source to character strings, you
+can use "use utf8". See L<perlunitut>, L<perlunifaq> and L<perlunicode> for more
+information on how Perl handles the difference between bytes and characters.
+
The automatic escaping does not apply to other shortcuts, such as
h1(). You should call escapeHTML() yourself on untrusted data in
order to protect your pages against nasty tricks that people may enter
into your fields. If you wish to turn off automatic escaping, call the
autoEscape() method with a false value immediately after creating the CGI object:
- $query = new CGI;
- autoEscape(undef);
+ $query = CGI->new;
+ $query->autoEscape(0);
+
+Note that autoEscape() is exclusively used to effect the behavior of how some
+CGI.pm HTML generation fuctions handle escaping. Calling escapeHTML()
+explicitly will always escape the HTML.
I<A Lurking Trap!> Some of the form-element generating methods return
multiple tags. In a scalar context, the tags will be concatenated
method: POST
action: this script
- enctype: application/x-www-form-urlencoded
+ enctype: application/x-www-form-urlencoded for non-XHTML
+ multipart/form-data for XHTML, see mulitpart/form-data below.
end_form() returns the closing </form> tag.
fields of the form before sending the form to the server. Two
values are possible:
-B<Note:> These methods were previously named startform() and endform(), and they
-are still recognized as aliases of start_form() and end_form().
+B<Note:> These methods were previously named startform() and endform().
+These methods are now DEPRECATED.
+Please use start_form() and end_form() instead.
=over 4
=item B<application/x-www-form-urlencoded>
-This is the older type of encoding used by all browsers prior to
-Netscape 2.0. It is compatible with many CGI scripts and is
+This is the older type of encoding. It is compatible with many CGI scripts and is
suitable for short fields containing text data. For your
convenience, CGI.pm stores the name of this encoding
type in B<&CGI::URL_ENCODED>.
=item B<multipart/form-data>
-This is the newer type of encoding introduced by Netscape 2.0.
+This is the newer type of encoding.
It is suitable for forms that contain very large fields or that
are intended for transferring binary data. Most importantly,
-it enables the "file upload" feature of Netscape 2.0 forms. For
+it enables the "file upload" feature. For
your convenience, CGI.pm stores the name of this encoding type
in B<&CGI::MULTIPART>
=back
-For compatibility, the start_form() method uses the older form of
-encoding by default. If you want to use the newer form of encoding
-by default, you can call B<start_multipart_form()> instead of
-B<start_form()>.
+The start_form() method uses the older form of encoding by
+default unless XHTML is requested. If you want to use the
+newer form of encoding by default, you can call
+B<start_multipart_form()> instead of B<start_form()>. The
+method B<end_multipart_form()> is an alias to B<end_form()>.
JAVASCRIPTING: The B<-name> and B<-onSubmit> parameters are provided
for use with JavaScript. The -name parameter gives the
print filefield('uploaded_file','starting value',50,80);
-filefield() will return a file upload field for Netscape 2.0 browsers.
+filefield() will return a file upload field.
In order to take full advantage of this I<you must use the new
multipart encoding scheme> for the form. You can do this either
by calling B<start_form()> with an encoding type of B<&CGI::MULTIPART>,
=back
-When the form is processed, you can retrieve the entered filename
-by calling param():
+JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur>,
+B<-onMouseOver>, B<-onMouseOut> and B<-onSelect> parameters are
+recognized. See textfield() for details.
- $filename = param('uploaded_file');
+=head2 PROCESSING A FILE UPLOAD FIELD
-Different browsers will return slightly different things for the
-name. Some browsers return the filename only. Others return the full
-path to the file, using the path conventions of the user's machine.
-Regardless, the name returned is always the name of the file on the
-I<user's> machine, and is unrelated to the name of the temporary file
-that CGI.pm creates during upload spooling (see below).
+=head3 Basics
-The filename returned is also a file handle. You can read the contents
-of the file using standard Perl file reading calls:
+When the form is processed, you can retrieve an L<IO::Handle> compatibile
+handle for a file upload field like this:
- # Read a text file and print it out
- while (<$filename>) {
- print;
- }
+ $lightweight_fh = $q->upload('field_name');
+
+ # undef may be returned if it's not a valid file handle
+ if (defined $lightweight_fh) {
+ # Upgrade the handle to one compatible with IO::Handle:
+ my $io_handle = $lightweight_fh->handle;
- # Copy a binary file to somewhere safe
open (OUTFILE,">>/usr/local/web/users/feedback");
- while ($bytesread=read($filename,$buffer,1024)) {
+ while ($bytesread = $io_handle->read($buffer,1024)) {
print OUTFILE $buffer;
}
-
-However, there are problems with the dual nature of the upload fields.
-If you C<use strict>, then Perl will complain when you try to use a
-string as a filehandle. You can get around this by placing the file
-reading code in a block containing the C<no strict> pragma. More
-seriously, it is possible for the remote user to type garbage into the
-upload field, in which case what you get from param() is not a
-filehandle at all, but a string.
-
-To be safe, use the I<upload()> function (new in version 2.47). When
-called with the name of an upload field, I<upload()> returns a
-filehandle-like object, or undef if the parameter is not a valid
-filehandle.
-
- $fh = upload('uploaded_file');
- while (<$fh>) {
- print;
- }
+ }
In a list context, upload() will return an array of filehandles.
-This makes it possible to create forms that use the same name for
+This makes it possible to process forms that use the same name for
multiple upload fields.
-This is the recommended idiom.
+If you want the entered file name for the file, you can just call param():
-The lightweight filehandle returned by CGI.pm is not compatible with
-IO::Handle; for example, it does not have read() or getline()
-functions, but instead must be manipulated using read($fh) or
-<$fh>. To get a compatible IO::Handle object, call the handle's
-handle() method:
+ $filename = $q->param('field_name');
- my $real_io_handle = upload('uploaded_file')->handle;
+Different browsers will return slightly different things for the
+name. Some browsers return the filename only. Others return the full
+path to the file, using the path conventions of the user's machine.
+Regardless, the name returned is always the name of the file on the
+I<user's> machine, and is unrelated to the name of the temporary file
+that CGI.pm creates during upload spooling (see below).
When a file is uploaded the browser usually sends along some
information along with it in the format of headers. The information
-usually includes the MIME content type. Future browsers may send
-other information as well (such as modification date and size). To
+usually includes the MIME content type. To
retrieve this information, call uploadInfo(). It returns a reference to
a hash containing all the document headers.
- $filename = param('uploaded_file');
- $type = uploadInfo($filename)->{'Content-Type'};
+ $filename = $q->param('uploaded_file');
+ $type = $q->uploadInfo($filename)->{'Content-Type'};
unless ($type eq 'text/html') {
- die "HTML FILES ONLY!";
+ die "HTML FILES ONLY!";
}
If you are using a machine that recognizes "text" and "binary" data
Otherwise you may find that binary files are corrupted during file
uploads.
+=head3 Accessing the temp files directly
+
+When processing an uploaded file, CGI.pm creates a temporary file on your hard
+disk and passes you a file handle to that file. After you are finished with the
+file handle, CGI.pm unlinks (deletes) the temporary file. If you need to you
+can access the temporary file directly. You can access the temp file for a file
+upload by passing the file name to the tmpFileName() method:
+
+ $filename = $query->param('uploaded_file');
+ $tmpfilename = $query->tmpFileName($filename);
+
+The temporary file will be deleted automatically when your program exits unless
+you manually rename it. On some operating systems (such as Windows NT), you
+will need to close the temporary file's filehandle before your program exits.
+Otherwise the attempt to delete the temporary file will fail.
+
+=head3 Handling interrupted file uploads
+
There are occasionally problems involving parsing the uploaded file.
This usually happens when the user presses "Stop" before the upload is
finished. In this case, CGI.pm will return undef for the name of the
you can incorporate it into a status code to be sent to the browser.
Example:
- $file = upload('uploaded_file');
- if (!$file && cgi_error) {
- print header(-status=>cgi_error);
+ $file = $q->upload('uploaded_file');
+ if (!$file && $q->cgi_error) {
+ print $q->header(-status=>$q->cgi_error);
exit 0;
}
You are free to create a custom HTML page to complain about the error,
if you wish.
-You can set up a callback that will be called whenever a file upload
-is being read during the form processing. This is much like the
-UPLOAD_HOOK facility available in Apache::Request, with the exception
-that the first argument to the callback is an Apache::Upload object,
-here it's the remote filename.
+=head3 Progress bars for file uploads and avoiding temp files
+
+CGI.pm gives you low-level access to file upload management through
+a file upload hook. You can use this feature to completely turn off
+the temp file storage of file uploads, or potentially write your own
+file upload progess meter.
+
+This is much like the UPLOAD_HOOK facility available in L<Apache::Request>, with
+the exception that the first argument to the callback is an L<Apache::Upload>
+object, here it's the remote filename.
$q = CGI->new(\&hook [,$data [,$use_tempfile]]);
- sub hook
- {
+ sub hook {
my ($filename, $buffer, $bytes_read, $data) = @_;
- print "Read $bytes_read bytes of $filename\n";
+ print "Read $bytes_read bytes of $filename\n";
}
-The $data field is optional; it lets you pass configuration
+The C<< $data >> field is optional; it lets you pass configuration
information (e.g. a database handle) to your hook callback.
-The $use_tempfile field is a flag that lets you turn on and off
+The C<< $use_tempfile >> field is a flag that lets you turn on and off
CGI.pm's use of a temporary disk-based file during file upload. If you
-set this to a FALSE value (default true) then param('uploaded_file')
+set this to a FALSE value (default true) then $q->param('uploaded_file')
will no longer work, and the only way to get at the uploaded data is
via the hook you provide.
This method is not exported by default. You will have to import it
explicitly if you wish to use it without the CGI:: prefix.
+=head3 Troubleshooting file uploads on Windows
+
If you are using CGI.pm on a Windows platform and find that binary
files get slightly larger when uploaded but that text files remain the
same, then you have forgotten to activate binary mode on the output
filehandle. Be sure to call binmode() on any handle that you create
to write the uploaded file to disk.
-JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur>,
-B<-onMouseOver>, B<-onMouseOut> and B<-onSelect> parameters are
-recognized. See textfield() for details.
+=head3 Older ways to process file uploads
+
+( This section is here for completeness. if you are building a new application with CGI.pm, you can skip it. )
+
+The original way to process file uploads with CGI.pm was to use param(). The
+value it returns has a dual nature as both a file name and a lightweight
+filehandle. This dual nature is problematic if you following the recommended
+practice of having C<use strict> in your code. Perl will complain when you try
+to use a string as a filehandle. More seriously, it is possible for the remote
+user to type garbage into the upload field, in which case what you get from
+param() is not a filehandle at all, but a string.
+
+To solve this problem the upload() method was added, which always returns a
+lightweight filehandle. This generally works well, but will have trouble
+interoperating with some other modules because the file handle is not derived
+from L<IO::Handle>. So that brings us to current recommedation given above,
+which is to call the handle() method on the file handle returned by upload().
+That upgrades the handle to an IO::Handle. It's a big win for compatibility for
+a small penalty of loading IO::Handle the first time you call it.
+
=head2 CREATING A POPUP MENU
=back
-The optional b<-labels> argument is a pointer to a hash
+The optional B<-labels> argument is a pointer to a hash
relating the checkbox values to the user-visible labels that will be
printed next to them. If not provided, the values will be used as the
default.
columns. You can provide just the -columns parameter if you wish;
checkbox_group will calculate the correct number of rows for you.
-The option b<-disabled> takes an array of checkbox values and disables
+The option B<-disabled> takes an array of checkbox values and disables
them by greying them out (this may not be supported by all browsers).
The optional B<-attributes> argument is provided to assign any of the
-or-
- print button('button_name',"do_something()");
+ print button('button_name',"user visible value","do_something()");
-button() produces a button that is compatible with Netscape 2.0's
-JavaScript. When it's pressed the fragment of JavaScript code
-pointed to by the B<-onClick> parameter will be executed.
+button() produces an C<< <input> >> tag with C<type="button">. When it's
+pressed the fragment of JavaScript code pointed to by the B<-onClick> parameter
+will be executed.
=head1 HTTP COOKIES
form:
use CGI;
- $query = new CGI;
+ $query = CGI->new;
$riddle = $query->cookie('riddle_name');
%answers = $query->cookie('answers');
(with appropriate parameters) as the SRC for each of the frames.
There is no specific support for creating <frameset> sections
-in CGI.pm, but the HTML is very simple to write. See the frame
-documentation in Netscape's home pages for details
-
- http://wp.netscape.com/assist/net_sites/frames.html
+in CGI.pm, but the HTML is very simple to write.
=item 2. Specify the destination for the document in the HTTP header
frame named "ResultsWindow". If a frame of that name doesn't already
exist, the browser will pop up a new window and load your script's
document into that. There are a number of magic names that you can
-use for targets. See the frame documents on Netscape's home pages for
-details.
+use for targets. See the HTML C<< <frame> >> documentation for details.
=item 3. Specify the destination for the document in the <form> tag
Similarly, you can create a form that checks itself over for
consistency and alerts the user if some essential value is missing by
creating it this way:
- print startform(-onSubmit=>"validateMe(this)");
+ print start_form(-onSubmit=>"validateMe(this)");
See the javascript.cgi script for a demonstration of how this all
works.
Note that you must import the ":html3" definitions to have the
B<span()> method available. Here's a quick and dirty example of using
CSS's. See the CSS specification at
-http://www.w3.org/pub/WWW/TR/Wd-css-1.html for more information.
+http://www.w3.org/Style/CSS/ for more information.
use CGI qw/:standard :html3/;
As a shortcut, you can interpolate the entire CGI object into a string
and it will be replaced with the a nice HTML dump shown above:
- $query=new CGI;
+ $query=CGI->new;
print "<h2>Current Values</h2> $query\n";
=head1 FETCHING ENVIRONMENT VARIABLES
Returns either the remote host name or IP address.
if the former is unavailable.
+=item B<remote_addr()>
+
+Returns the remote host IP address, or
+127.0.0.1 if the address is unavailable.
+
=item B<script_name()>
Return the script name as a partial URL, for self-refering
scripts.
do this manually, although it won't hurt anything if you do. However,
note that if you have applied Service Pack 6, much of the
functionality of NPH scripts, including the ability to redirect while
-setting a cookie, b<do not work at all> on IIS without a special patch
+setting a cookie, B<do not work at all> on IIS without a special patch
from Microsoft. See
-http://support.microsoft.com/support/kb/articles/Q280/3/41.ASP:
+http://web.archive.org/web/20010812012030/http://support.microsoft.com/support/kb/articles/Q280/3/41.ASP
Non-Parsed Headers Stripped From CGI Applications That Have nph-
Prefix in Name.
=head1 SEE ALSO
-L<CGI::Carp>, L<CGI::Fast>, L<CGI::Pretty>
+L<CGI::Carp> - provides a L<Carp> implementation tailored to the CGI environment.
+
+L<CGI::Fast> - supports running CGI applications under FastCGI
+
+L<CGI::Pretty> - pretty prints HTML generated by CGI.pm (with a performance penalty)
=cut
}
carpout() does not handle file locking on the log for you at this point.
+Also, note that carpout() does not work with in-memory file handles, although
+a patch would be welcome to address that.
The real STDERR is not closed -- it is moved to CGI::Carp::SAVEERR. Some
servers, when dealing with CGI scripts, close their connection to the
prevent this from happening prematurely.
You can pass filehandles to carpout() in a variety of ways. The "correct"
-way according to Tom Christiansen is to pass a reference to a filehandle
+way according to Tom Christiansen is to pass a reference to a filehandle
GLOB:
carpout(\*LOG);
See this URL for more information:
-L<http://msdn.microsoft.com/workshop/author/dhtml/httponly_cookies.asp>
+L<http://msdn.microsoft.com/en-us/library/ms533046%28VS.85%29.aspx>
=back
package CGI::Fast;
+use strict;
+$^W=1; # A way to say "use warnings" that's compatible with even older perls.
# See the bottom of this file for the POD documentation. Search for the
# string '=head'.
# Copyright 1995,1996, Lincoln D. Stein. All rights reserved.
# It may be used and modified freely, but I do request that this copyright
-# notice remain attached to the file. You may modify this module as you
+# notice remain attached to the file. You may modify this module as you
# wish, but if you redistribute a modified version, please attach a note
# listing the modifications you have made.
use CGI;
use FCGI;
+# use vars works like "our", but is compatible with older Perls.
+use vars qw(
+ @ISA
+ $ignore
+);
@ISA = ('CGI');
# workaround for known bug in libfcgi
while (($ignore) = each %ENV) { }
# override the initialization behavior so that
-# state is NOT maintained between invocations
+# state is NOT maintained between invocations
sub save_request {
# no-op
}
my $path = $ENV{FCGI_SOCKET_PATH};
my $backlog = $ENV{FCGI_LISTEN_QUEUE} || 100;
my $socket = FCGI::OpenSocket( $path, $backlog );
- $Ext_Request = FCGI::Request( \*STDIN, \*STDOUT, \*STDERR,
+ $Ext_Request = FCGI::Request( \*STDIN, \*STDOUT, \*STDERR,
\%ENV, $socket, 1 );
}
}
}
}
CGI->_reset_globals;
- $self->_setup_symbols(@SAVED_SYMBOLS) if @CGI::SAVED_SYMBOLS;
+ $self->_setup_symbols(@CGI::SAVED_SYMBOLS) if @CGI::SAVED_SYMBOLS;
return $CGI::Q = $self->SUPER::new($initializer, @param);
}
=head1 WRITING FASTCGI PERL SCRIPTS
-FastCGI scripts are persistent: one or more copies of the script
+FastCGI scripts are persistent: one or more copies of the script
are started up when the server initializes, and stay around until
the server exits or they die a natural death. After performing
-whatever one-time initialization it needs, the script enters a
+whatever one-time initialization it needs, the script enters a
loop waiting for incoming connections, processing the request, and
waiting some more.
FastCgiServer /usr/etc/httpd/fcgi-bin/file_upload.fcgi -processes 2
-This instructs Apache to launch two copies of file_upload.fcgi at
+This instructs Apache to launch two copies of file_upload.fcgi at
startup time.
=head1 USING FASTCGI SCRIPTS AS CGI SCRIPTS
=item FCGI_LISTEN_QUEUE
-Maximum length of the queue of pending connections.
+Maximum length of the queue of pending connections.
=back
=head1 AUTHOR INFORMATION
-Copyright 1996-1998, Lincoln D. Stein. All rights reserved.
+Copyright 1996-1998, Lincoln D. Stein. All rights reserved.
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
use strict;
use CGI ();
-$CGI::Pretty::VERSION = '3.44';
+$CGI::Pretty::VERSION = '3.46';
$CGI::DefaultClass = __PACKAGE__;
$CGI::Pretty::AutoloadClass = 'CGI';
@CGI::Pretty::ISA = qw( CGI );
my \@result;
if ( exists \$ASIS{ "\L$tagname\E" } ) {
- \@result = map { "\$tag\$_\$untag\$CGI::Pretty::LINEBREAK" }
- \@args;
- }
+ \@result = map { "\$tag\$_\$untag" } \@args;
+ }
else {
\@result = map {
chomp;
$CGI::Pretty::LINEBREAK = $/;
# These tags are not prettify'd.
+ # When this list is updated, also update the docs.
@CGI::Pretty::AS_IS = qw( a pre code script textarea td );
1;
now produces the following output:
<TABLE>
<TR>
- <TD>
- foo
- </TD>
+ <TD>foo</TD>
</TR>
</TABLE>
+=head2 Recommendation for when to use CGI::Pretty
+
+CGI::Pretty is far slower than using CGI.pm directly. A benchmark showed that
+it could be about 10 times slower. Adding newslines and spaces may alter the
+rendered appearance of HTML. Also, the extra newlines and spaces also make the
+file size larger, making the files take longer to download.
+
+With all those considerations, it is recommended that CGI::Pretty be used
+primarily for debugging.
=head2 Tags that won't be formatted
-The <A> and <PRE> tags are not formatted. If these tags were formatted, the
+The following tags are not formatted: <a>, <pre>, <code>, <script>, <textarea>, and <td>.
+If these tags were formatted, the
user would see the extra indentation on the web browser causing the page to
look different than what would be expected. If you wish to add more tags to
the list of tags that are not to be touched, push them onto the C<@AS_IS> array:
- push @CGI::Pretty::AS_IS,qw(CODE XMP);
+ push @CGI::Pretty::AS_IS,qw(XMP);
=head2 Customizing the Indenting
$CGI::Pretty::INDENT = $CGI::Pretty::LINEBREAK = "";
-=head1 BUGS
-
-This section intentionally left blank.
-
=head1 AUTHOR
Brian Paulsen <Brian@ThePaulsens.com>, with minor modifications by
@EXPORT_OK = qw(rearrange rearrange_header make_attributes unescape escape
expires ebcdic2ascii ascii2ebcdic);
-$VERSION = '3.45';
+$VERSION = '3.48';
$EBCDIC = "\t" ne "\011";
# (ord('^') == 95) for codepage 1047 as on os390, vmesa
shift() if @_ > 1 and ( ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass));
my $toencode = shift;
return undef unless defined($toencode);
- utf8::encode($toencode) if ($] > 5.007 && utf8::is_utf8($toencode));
+ utf8::encode($toencode) if ($] > 5.008001 && utf8::is_utf8($toencode));
if ($EBCDIC) {
$toencode=~s/([^a-zA-Z0-9_.~-])/uc sprintf("%%%02x",$E2A[ord($1)])/eg;
} else {
#!/usr/local/bin/perl -w
-use lib qw(t/lib);
-
-# 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 strict;
use Test::More tests => 1;
--- /dev/null
+#!perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 18;
+
+use CGI qw/ autoEscape escapeHTML button textfield password_field textarea popup_menu scrolling_list checkbox_group optgroup checkbox radio_group submit image_button button /;
+
+is (button(-name => 'test<'), '<input type="button" name="test<" value="test<" />', "autoEscape defaults to On");
+
+my $before = escapeHTML("test<");
+autoEscape(undef);
+my $after = escapeHTML("test<");
+
+
+is($before, "test<", "reality check escapeHTML");
+
+is ($before, $after, "passing undef to autoEscape doesn't break escapeHTML");
+is (button(-name => 'test<'), '<input type="button" name="test<" value="test<" />', "turning off autoescape actually works");
+autoEscape(1);
+is (button(-name => 'test<'), '<input type="button" name="test<" value="test<" />', "autoescape turns back on");
+$before = escapeHTML("test<");
+autoEscape(0);
+$after = escapeHTML("test<");
+
+is ($before, $after, "passing 0 to autoEscape doesn't break escapeHTML");
+
+# RT #25485: Needs Tests: autoEscape() bypassed for Javascript handlers, except in button()
+autoEscape(undef);
+
+is(textfield(
+{
+default => 'text field',
+onclick => 'alert("===> text field")',
+},
+),
+qq{<input type="text" name="" value="text field" onclick="alert("===> text field")" />},
+'autoescape javascript turns off for textfield'
+);
+
+is(password_field(
+{
+default => 'password field',
+onclick => 'alert("===> password
+field")',
+},
+),
+qq{<input type="password" name="" value="password field" onclick="alert("===> password
+field")" />},
+'autoescape javascript turns off for password field'
+);
+
+is(textarea(
+{
+name => 'foo',
+default => 'text area',
+rows => 10,
+columns => 50,
+onclick => 'alert("===> text area")',
+},
+),
+qq{<textarea name="foo" rows="10" cols="50" onclick="alert("===> text area")">text area</textarea>},
+'autoescape javascript turns off for textarea'
+);
+
+is(popup_menu(
+{
+name => 'menu_name',
+values => ['eenie','meenie','minie'],
+default => 'meenie',
+onclick => 'alert("===> popup menu")',
+}
+),
+qq{<select name="menu_name" onclick="alert("===> popup menu")">
+<option value="eenie">eenie</option>
+<option selected="selected" value="meenie">meenie</option>
+<option value="minie">minie</option>
+</select>},
+'autoescape javascript turns off for popup_menu'
+);
+
+is(popup_menu(
+-name=>'menu_name',
+onclick => 'alert("===> menu group")',
+-values=>[
+qw/eenie meenie minie/,
+optgroup(
+-name=>'optgroup_name',
+onclick =>
+'alert("===> menu group option")',
+-values => ['moe','catch'],
+-attributes=>{'catch'=>{'class'=>'red'}}
+)
+],
+-labels=>{
+'eenie'=>'one',
+'meenie'=>'two',
+'minie'=>'three'
+},
+-default=>'meenie'
+),
+qq{<select name="menu_name" onclick="alert("===> menu group")">
+<option value="eenie">one</option>
+<option selected="selected" value="meenie">two</option>
+<option value="minie">three</option>
+<optgroup label="optgroup_name" onclick="alert("===> menu group option")">
+<option value="moe">moe</option>
+<option class="red" value="catch">catch</option>
+</optgroup>
+</select>},
+'autoescape javascript turns off for popup_menu #2'
+);
+
+is(scrolling_list(
+-name=>'list_name',
+onclick => 'alert("===> scrolling
+list")',
+-values=>['eenie','meenie','minie','moe'],
+-default=>['eenie','moe'],
+-size=>5,
+-multiple=>'true',
+),
+qq{<select name="list_name" size="5" multiple="multiple" onclick="alert("===> scrolling
+list")">
+<option selected="selected" value="eenie">eenie</option>
+<option value="meenie">meenie</option>
+<option value="minie">minie</option>
+<option selected="selected" value="moe">moe</option>
+</select>},
+'autoescape javascript turns off for scrolling list'
+);
+
+is(checkbox_group(
+-name=>'group_name',
+onclick => 'alert("===> checkbox group")',
+-values=>['eenie','meenie','minie','moe'],
+-default=>['eenie','moe'],
+-linebreak=>'true',
+),
+qq{<label><input type="checkbox" name="group_name" value="eenie" checked="checked" onclick="alert("===> checkbox group")" />eenie</label><br /> <label><input type="checkbox" name="group_name" value="meenie" onclick="alert("===> checkbox group")" />meenie</label><br /> <label><input type="checkbox" name="group_name" value="minie" onclick="alert("===> checkbox group")" />minie</label><br /> <label><input type="checkbox" name="group_name" value="moe" checked="checked" onclick="alert("===> checkbox group")" />moe</label><br />},
+'autoescape javascript turns off for checkbox group'
+);
+
+is(checkbox(
+-name=>'checkbox_name',
+onclick => 'alert("===> single checkbox")',
+onchange => 'alert("===> single checkbox
+changed")',
+-checked=>1,
+-value=>'ON',
+-label=>'CLICK ME'
+),
+qq{<label><input type="checkbox" name="checkbox_name" value="ON" checked="checked" onchange="alert("===> single checkbox
+changed")" onclick="alert("===> single checkbox")" />CLICK ME</label>},
+'autoescape javascript turns off for checkbox'
+);
+
+is(radio_group(
+{
+name=>'group_name',
+onclick => 'alert("===> radio group")',
+values=>['eenie','meenie','minie','moe'],
+rows=>2,
+columns=>2,
+}
+),
+qq{<table><tr><td><label><input type="radio" name="group_name" value="eenie" checked="checked" onclick="alert("===> radio group")" />eenie</label></td><td><label><input type="radio" name="group_name" value="minie" onclick="alert("===> radio group")" />minie</label></td></tr><tr><td><label><input type="radio" name="group_name" value="meenie" onclick="alert("===> radio group")" />meenie</label></td><td><label><input type="radio" name="group_name" value="moe" onclick="alert("===> radio group")" />moe</label></td></tr></table>},
+'autoescape javascript turns off for radio group'
+);
+
+is(submit(
+-name=>'button_name',
+onclick => 'alert("===> submit button")',
+-value=>'value'
+),
+qq{<input type="submit" name="button_name" value="value" onclick="alert("===> submit button")" />},
+'autoescape javascript turns off for submit'
+);
+
+is(image_button(
+-name=>'button_name',
+onclick => 'alert("===> image button")',
+-src=>'/source/URL',
+-align=>'MIDDLE'
+),
+qq{<input type="image" name="button_name" src="/source/URL" align="middle" onclick="alert("===> image button")" />},
+'autoescape javascript turns off for image_button'
+);
+
+is(button(
+{
+onclick => 'alert("===> Button")',
+title => 'Button',
+},
+),
+qq{<input type="button" onclick="alert("===> Button")" title="Button" />},
+'autoescape javascript turns off for button'
+);
#!/usr/local/bin/perl -w
-# 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 => 2;
BEGIN{ use_ok('CGI'); }
-can_ok('CGI', qw/cookie param/);
\ No newline at end of file
+can_ok('CGI', qw/cookie param/);
#!/usr/local/bin/perl -w
use strict;
-use lib qw(t/lib);
-
-# 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 => 41;
use IO::Handle;
--- /dev/null
+#!/usr/local/bin/perl -w
+
+use Test::More tests => 3;
+
+BEGIN { use_ok('CGI'); };
+use CGI (':standard','-no_debug','-no_xhtml');
+
+# no_xhtml test on checkbox_group()
+is(checkbox_group(-name => 'game',
+ '-values' => [qw/checkers chess cribbage/],
+ '-defaults' => ['cribbage']),
+ qq(<input type="checkbox" name="game" value="checkers" >checkers <input type="checkbox" name="game" value="chess" >chess <input type="checkbox" name="game" value="cribbage" checked >cribbage),
+ 'checkbox_group()');
+
+# xhtml test on checkbox_group()
+$CGI::XHTML = 1;
+is(checkbox_group(-name => 'game',
+ '-values' => [qw/checkers chess cribbage/],
+ '-defaults' => ['cribbage']),
+ qq(<label><input type="checkbox" name="game" value="checkers" />checkers</label> <label><input type="checkbox" name="game" value="chess" />chess</label> <label><input type="checkbox" name="game" value="cribbage" checked="checked" />cribbage</label>),
+ 'checkbox_group()');
#!/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 => 96;
use CGI::Util qw(escape unescape);
use POSIX qw(strftime);
--- /dev/null
+
+use strict;
+use warnings;
+
+use Test::More tests => 3;
+
+BEGIN { use_ok 'CGI', qw/ -compile :form / };
+
+is end_form() => '</form>', 'end_form()';
+is endform() => '</form>', 'endform()';
+
+
+
#!./perl -w
-use lib qw(t/lib);
-
-# 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);
-
my $fcgi;
BEGIN {
local $@;
$fcgi = $@ ? 0 : 1;
}
-use Test::More tests => 7;
+use Test::More tests => 10;
# Shut up "used only once" warnings.
() = $CGI::Q;
SKIP: {
skip( 'FCGI not installed, cannot continue', 7 ) unless $fcgi;
- use_ok( CGI::Fast );
+ use CGI::Fast;
ok( my $q = CGI::Fast->new(), 'created new CGI::Fast object' );
is( $q, $CGI::Q, 'checking to see if the object was stored properly' );
is( $q->param(), (), 'no params' );
- ok( $q = CGI::Fast->new({ foo => 'bar' }), 'creating obect with params' );
+ ok( $q = CGI::Fast->new({ foo => 'bar' }), 'creating object with params' );
is( $q->param('foo'), 'bar', 'checking passed param' );
# if this is false, the package var will be empty
$ENV{FCGI_SOCKET_PATH} = 0;
- is( $CGI::Fast::Ext_Request, '', 'checking no active request' );
+ is( $CGI::Fast::Ext_Request, undef, 'checking no active request' );
-}
+ is($CGI::PRIVATE_TEMPFILES,0, "reality check default value for CGI::PRIVATE_TEMPFILES");
+ import CGI::Fast '-private_tempfiles';
+ CGI::Fast->new;
+ is($CGI::PRIVATE_TEMPFILES,1, "pragma in subclass set package variable in parent class. ");
+ $q = CGI::Fast->new({ a => 1 });
+ ok($q, "reality check: something was returned from CGI::Fast->new besides undef");
+ is($CGI::PRIVATE_TEMPFILES,1, "package variable in parent class persists through multiple calls to CGI::Fast->new ");
+
+};
-#!/usr/local/bin/perl -w
+#!perl -w
-use Test::More tests => 22;
+# Form-related tests for CGI.pm
+# If you are adding or updated tests, please put tests for each methods in
+# their own file, rather than growing this file any larger.
-BEGIN { use_ok('CGI'); };
+use Test::More 'no_plan';
use CGI (':standard','-no_debug','-tabindex');
my $CRLF = "\015\012";
</select>),
'scrolling_list() + optgroup()');
+# ---------- START 22046 ----------
+# The following tests were added for
+# https://rt.cpan.org/Public/Bug/Display.html?id=22046
+# SHCOREY at cpan.org
+# Saved whether working with XHTML because need to test both
+# with it and without.
+my $saved_XHTML = $CGI::XHTML;
+
+# set XHTML
+$CGI::XHTML = 1;
+
+is(start_form("GET","/foobar"),
+ qq{<form method="get" action="/foobar" enctype="multipart/form-data">
+},
+ 'start_form() + XHTML');
+
+is(start_form("GET", "/foobar",&CGI::URL_ENCODED),
+ qq{<form method="get" action="/foobar" enctype="application/x-www-form-urlencoded">
+},
+ 'start_form() + XHTML + URL_ENCODED');
+
+is(start_form("GET", "/foobar",&CGI::MULTIPART),
+ qq{<form method="get" action="/foobar" enctype="multipart/form-data">
+},
+ 'start_form() + XHTML + MULTIPART');
+
+is(start_multipart_form("GET", "/foobar"),
+ qq{<form method="get" action="/foobar" enctype="multipart/form-data">
+},
+ 'start_multipart_form() + XHTML');
+
+is(start_multipart_form("GET", "/foobar","name=\"foobar\""),
+ qq{<form method="get" action="/foobar" enctype="multipart/form-data" name="foobar">
+},
+ 'start_multipart_form() + XHTML + additional args');
+
+# set no XHTML
+$CGI::XHTML = 0;
+
+is(start_form("GET","/foobar"),
+ qq{<form method="get" action="/foobar" enctype="application/x-www-form-urlencoded">
+},
+ 'start_form() + NO_XHTML');
+
+is(start_form("GET", "/foobar",&CGI::URL_ENCODED),
+ qq{<form method="get" action="/foobar" enctype="application/x-www-form-urlencoded">
+},
+ 'start_form() + NO_XHTML + URL_ENCODED');
+
+is(start_form("GET", "/foobar",&CGI::MULTIPART),
+ qq{<form method="get" action="/foobar" enctype="multipart/form-data">
+},
+ 'start_form() + NO_XHTML + MULTIPART');
+
+is(start_multipart_form("GET", "/foobar"),
+ qq{<form method="get" action="/foobar" enctype="multipart/form-data">
+},
+ 'start_multipart_form() + NO_XHTML');
+
+is(start_multipart_form("GET", "/foobar","name=\"foobar\""),
+ qq{<form method="get" action="/foobar" enctype="multipart/form-data" name="foobar">
+},
+ 'start_multipart_form() + NO_XHTML + additional args');
+
+# restoring value
+$CGI::XHTML = $saved_XHTML;
#!/usr/local/bin/perl -w
-use lib qw(t/lib);
-
-# Test ability to retrieve HTTP request info
-######################### We start with some black magic to print on failure.
-use lib '.','..','../blib/lib','../blib/arch';
-
BEGIN {$| = 1; print "1..32\n"; }
END {print "not ok 1\n" unless $loaded;}
use Config;
--- /dev/null
+#!perl -w
+
+use Test::More 'no_plan';
+use CGI;
+
+my $q = CGI->new;
+
+is( $q->hidden( 'hidden_name', 'foo' ),
+ qq(<input type="hidden" name="hidden_name" value="foo" />),
+ 'hidden() with single default value, positional');
+
+is( $q->hidden( -name => 'hidden_name', -default =>'foo' ),
+ qq(<input type="hidden" name="hidden_name" value="foo" />),
+ 'hidden() with single default value, named');
+
+is( $q->hidden( 'hidden_name', qw(foo bar baz fie) ),
+ qq(<input type="hidden" name="hidden_name" value="foo" /><input type="hidden" name="hidden_name" value="bar" /><input type="hidden" name="hidden_name" value="baz" /><input type="hidden" name="hidden_name" value="fie" />),
+ 'hidden() with default array, positional');
+
+is( $q->hidden( -name=>'hidden_name',
+ -Values =>[qw/foo bar baz fie/],
+ -Title => "hidden_field"),
+ qq(<input type="hidden" name="hidden_name" value="foo" title="hidden_field" /><input type="hidden" name="hidden_name" value="bar" title="hidden_field" /><input type="hidden" name="hidden_name" value="baz" title="hidden_field" /><input type="hidden" name="hidden_name" value="fie" title="hidden_field" />),
+ 'hidden() default array, named as "Values"');
+
+is( $q->hidden( -name=>'hidden_name',
+ -default =>[qw/foo bar baz fie/],
+ -Title => "hidden_field"),
+ qq(<input type="hidden" name="hidden_name" value="foo" title="hidden_field" /><input type="hidden" name="hidden_name" value="bar" title="hidden_field" /><input type="hidden" name="hidden_name" value="baz" title="hidden_field" /><input type="hidden" name="hidden_name" value="fie" title="hidden_field" />),
+ 'hidden() default array, named as "default"');
+
+is( $q->hidden( -name=>'hidden_name',
+ '-value' =>[qw/foo bar baz fie/],
+ -Title => "hidden_field"),
+ qq(<input type="hidden" name="hidden_name" value="foo" title="hidden_field" /><input type="hidden" name="hidden_name" value="bar" title="hidden_field" /><input type="hidden" name="hidden_name" value="baz" title="hidden_field" /><input type="hidden" name="hidden_name" value="fie" title="hidden_field" />),
+ 'hidden() default array, named as "value"');
+
+
#!/usr/local/bin/perl -w
-# Test ability to retrieve HTTP request info
-######################### We start with some black magic to print on failure.
-use lib '../blib/lib','../blib/arch';
+use Test::More tests => 33;
-END {print "not ok 1\n" unless $loaded;}
-use CGI (':standard','-no_debug','*h3','start_table');
+END { ok $loaded; }
+use CGI ( ':standard', '-no_debug', '*h3', 'start_table' );
$loaded = 1;
-print "ok 1\n";
+ok 1;
BEGIN {
- $| = 1; print "1..28\n";
- if( $] > 5.006 ) {
- # no utf8
- require utf8; # we contain Latin-1
- utf8->unimport;
- }
+ $| = 1;
+ if ( $] > 5.006 ) {
+
+ # no utf8
+ require utf8; # we contain Latin-1
+ utf8->unimport;
+ }
}
######################### End of black magic.
my $CRLF = "\015\012";
-if ($^O eq 'VMS') {
- $CRLF = "\n"; # via web server carriage is inserted automatically
+if ( $^O eq 'VMS' ) {
+ $CRLF = "\n"; # via web server carriage is inserted automatically
}
-if (ord("\t") != 9) { # EBCDIC?
- $CRLF = "\r\n";
+if ( ord("\t") != 9 ) { # EBCDIC?
+ $CRLF = "\r\n";
}
-
# util
sub test {
- local($^W) = 0;
- my($num, $true,$msg) = @_;
- print($true ? "ok $num\n" : "not ok $num $msg\n");
+ local ($^W) = 0;
+ my ( undef, $true, $msg ) = @_;
+ ok $true => $msg;
}
# all the automatic tags
-test(2,h1() eq '<h1 />',"single tag");
-test(3,h1('fred') eq '<h1>fred</h1>',"open/close tag");
-test(4,h1('fred','agnes','maura') eq '<h1>fred agnes maura</h1>',"open/close tag multiple");
-test(5,h1({-align=>'CENTER'},'fred') eq '<h1 align="CENTER">fred</h1>',"open/close tag with attribute");
-test(6,h1({-align=>undef},'fred') eq '<h1 align>fred</h1>',"open/close tag with orphan attribute");
-test(7,h1({-align=>'CENTER'},['fred','agnes']) eq
- '<h1 align="CENTER">fred</h1> <h1 align="CENTER">agnes</h1>',
- "distributive tag with attribute");
+is h1(), '<h1 />', "single tag";
+
+is h1('fred'), '<h1>fred</h1>', "open/close tag";
+
+is h1( 'fred', 'agnes', 'maura' ), '<h1>fred agnes maura</h1>',
+ "open/close tag multiple";
+
+is h1( { -align => 'CENTER' }, 'fred' ), '<h1 align="CENTER">fred</h1>',
+ "open/close tag with attribute";
+
+is h1( { -align => undef }, 'fred' ), '<h1 align>fred</h1>',
+ "open/close tag with orphan attribute";
+
+is h1( { -align => 'CENTER' }, [ 'fred', 'agnes' ] ),
+ '<h1 align="CENTER">fred</h1> <h1 align="CENTER">agnes</h1>',
+ "distributive tag with attribute";
+
{
- local($") = '-';
- test(8,h1('fred','agnes','maura') eq '<h1>fred-agnes-maura</h1>',"open/close tag \$\" interpolation");
+ local $" = '-';
+
+ is h1( 'fred', 'agnes', 'maura' ), '<h1>fred-agnes-maura</h1>',
+ "open/close tag \$\" interpolation";
+
}
-test(9,header() eq "Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}","header()");
-test(10,header(-type=>'image/gif') eq "Content-Type: image/gif${CRLF}${CRLF}","header()");
-test(11,header(-type=>'image/gif',-status=>'500 Sucks') eq "Status: 500 Sucks${CRLF}Content-Type: image/gif${CRLF}${CRLF}","header()");
-test(12,header(-nph=>1) =~ m!HTTP/1.0 200 OK${CRLF}Server: cmdline${CRLF}Date:.+${CRLF}Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}!,"header()");
-test(13,start_html() eq <<END,"start_html()");
+
+is header(), "Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}",
+ "header()";
+
+is header( -type => 'image/gif' ), "Content-Type: image/gif${CRLF}${CRLF}",
+ "header()";
+
+is header( -type => 'image/gif', -status => '500 Sucks' ),
+ "Status: 500 Sucks${CRLF}Content-Type: image/gif${CRLF}${CRLF}", "header()";
+
+like header( -nph => 1 ),
+ qr!HTTP/1.0 200 OK${CRLF}Server: cmdline${CRLF}Date:.+${CRLF}Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}!,
+ "header()";
+
+is start_html(), <<END, "start_html()";
<!DOCTYPE html
PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
</head>
<body>
END
- ;
-test(14,start_html(-Title=>'The world of foo') eq <<END,"start_html()");
+
+is start_html( -Title => 'The world of foo' ), <<END, "start_html()";
<!DOCTYPE html
PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
</head>
<body>
END
- ;
-# Note that this test will turn off XHTML until we make a new CGI object.
-test(15,start_html(-dtd=>"-//IETF//DTD HTML 3.2//FR",-lang=>'fr') eq <<END,"start_html()");
+
+for my $v (qw/ 2.0 3.2 4.0 4.01 /) {
+ local $CGI::XHTML = 1;
+ is
+ start_html( -dtd => "-//IETF//DTD HTML $v//FR", -lang => 'fr' ),
+ <<"END", 'start_html()';
<!DOCTYPE html
- PUBLIC "-//IETF//DTD HTML 3.2//FR">
+ PUBLIC "-//IETF//DTD HTML $v//FR">
<html lang="fr"><head><title>Untitled Document</title>
</head>
<body>
END
- ;
-test(16,($cookie=cookie(-name=>'fred',-value=>['chocolate','chip'],-path=>'/')) eq 'fred=chocolate&chip; path=/',"cookie()");
-my $h = header(-Cookie=>$cookie);
-test(17,$h =~ m!^Set-Cookie: fred=chocolate&chip\; path=/${CRLF}Date:.*${CRLF}Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}!s,
- "header(-cookie)");
-test(18,start_h3 eq '<h3>');
-test(19,end_h3 eq '</h3>');
-test(20,start_table({-border=>undef}) eq '<table border>');
-test(21,h1(escapeHTML("this is <not> \x8bright\x9b")) eq '<h1>this is <not> ‹right›</h1>');
-charset('utf-8');
-if (ord("\t") == 9) {
-test(22,h1(escapeHTML("this is <not> \x8bright\x9b")) eq '<h1>this is <not> right</h1>');
-}
-else {
-test(22,h1(escapeHTML("this is <not> \x8bright\x9b")) eq '<h1>this is <not> »rightº</h1>');
}
-test(23,i(p('hello there')) eq '<i><p>hello there</p></i>');
-my $q = new CGI;
-test(24,$q->h1('hi') eq '<h1>hi</h1>');
+
+is
+ start_html( -dtd => "-//IETF//DTD HTML 9.99//FR", -lang => 'fr' ),
+ <<"END", 'start_html()';
+<!DOCTYPE html
+ PUBLIC "-//IETF//DTD HTML 9.99//FR">
+<html xmlns="http://www.w3.org/1999/xhtml" lang="fr" xml:lang="fr">
+<head>
+<title>Untitled Document</title>
+<meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1" />
+</head>
+<body>
+END
+
+my $cookie =
+ cookie( -name => 'fred', -value => [ 'chocolate', 'chip' ], -path => '/' );
+
+is $cookie, 'fred=chocolate&chip; path=/', "cookie()";
+
+my $h = header( -Cookie => $cookie );
+
+like $h,
+ qr!^Set-Cookie: fred=chocolate&chip\; path=/${CRLF}Date:.*${CRLF}Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}!s,
+ "header(-cookie)";
+
+is start_h3, '<h3>';
+
+is end_h3, '</h3>';
+
+is start_table( { -border => undef } ), '<table border>';
+is h1( escapeHTML("this is <not> \x8bright\x9b") ),
+ '<h1>this is <not> ‹right›</h1>';
+
+charset('utf-8');
+
+is h1( escapeHTML("this is <not> \x8bright\x9b") ),
+ ord("\t") == 9
+ ? '<h1>this is <not> right</h1>'
+ : '<h1>this is <not> »rightº</h1>';
+
+is i( p('hello there') ), '<i><p>hello there</p></i>';
+
+my $q = CGI->new;
+is $q->h1('hi'), '<h1>hi</h1>';
$q->autoEscape(1);
-test(25,$q->p({title=>"hello worldè"},'hello á') eq '<p title="hello world&egrave;">hello á</p>');
+
+is $q->p( { title => "hello worldè" }, 'hello á' ),
+ '<p title="hello world&egrave;">hello á</p>';
+
$q->autoEscape(0);
-test(26,$q->p({title=>"hello worldè"},'hello á') eq '<p title="hello worldè">hello á</p>');
-test(27,p({title=>"hello worldè"},'hello á') eq '<p title="hello world&egrave;">hello á</p>');
-test(28,header(-type=>'image/gif',-charset=>'UTF-8') eq "Content-Type: image/gif; charset=UTF-8${CRLF}${CRLF}","header()");
+
+is $q->p( { title => "hello worldè" }, 'hello á' ),
+ '<p title="hello worldè">hello á</p>';
+
+is p( { title => "hello worldè" }, 'hello á' ),
+ '<p title="hello world&egrave;">hello á</p>';
+
+is header( -type => 'image/gif', -charset => 'UTF-8' ),
+ "Content-Type: image/gif; charset=UTF-8${CRLF}${CRLF}", "header()";
--- /dev/null
+#!./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.
+ 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()], [qw(HTTPS HTTPS_KEYSIZE)]), 'list context returns https keys';
+}
--- /dev/null
+#!/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');
--- /dev/null
+A=B
+D=F
+G=H
#!/usr/local/bin/perl -w
-# 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 => 18;
BEGIN { use_ok('CGI'); };
#!perl
# Tests for popup_menu();
-use lib 't/lib';
use Test::More 'no_plan';
use CGI;
<option selected="selected" value="0">0</option>
<option value="1">1</option>
</select>'
-, 'popup_menu(): basic test, including 0 as a default value');
+, 'popup_menu(): basic test, including 0 as a default value');
+is(
+ CGI::popup_menu(-values=>[CGI::optgroup(-values=>["b+"])],-default=>"b+"),
+ '<select name="" >
+<optgroup label="">
+<option selected="selected" value="b+">b+</option>
+</optgroup>
+</select>'
+ , "<optgroup> selections work when the default values contain regex characters (RT#49606)");
#!/bin/perl -w
use strict;
-use lib '.', 't/lib','../blib/lib','./blib/lib';
-use Test::More tests => 18;
-
-BEGIN { use_ok('CGI::Pretty') };
-
-# This is silly use_ok should take arguments
-use CGI::Pretty (':all');
+use Test::More tests => 17;
+use CGI::Pretty ':all';
is(h1(), '<h1 />
',"single tag");
is(p('hi',pre('there'),'frog'), <<HTML, "<pre> tags");
<p>
- hi <pre>there</pre>
- frog
+ hi <pre>there</pre> frog
</p>
HTML
is(p('hi',a({-href=>'frog'},'there'),'frog'), <<HTML, "as-is");
<p>
- hi <a href="frog">there</a>
- frog
+ hi <a href="frog">there</a> frog
</p>
HTML
<tr>
<td><table>
<tr>
- <td>hi</td>
- <td>there</td>
- <td>frog</td>
+ <td>hi</td><td>there</td><td>frog</td>
</tr>
</table></td>
</tr>
#!./perl -wT
-use lib qw(t/lib);
-
-# 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 => 12;
use_ok( 'CGI::Push' );
# Tests for the query_string() method.
-use lib 't/lib';
use Test::More 'no_plan';
use CGI;
-#!/usr/local/bin/perl -w
+#!/usr/local/bin/perl
-# Test ability to retrieve HTTP request info
-######################### We start with some black magic to print on failure.
-use lib '.','../blib/lib','../blib/arch';
+use strict;
+use warnings;
+
+use Test::More tests => 41;
-BEGIN {$| = 1; print "1..34\n"; }
-END {print "not ok 1\n" unless $loaded;}
use CGI ();
use Config;
-$loaded = 1;
-print "ok 1\n";
-######################### End of black magic.
+my $loaded = 1;
-# util
-sub test {
- local($^W) = 0;
- my($num, $true,$msg) = @_;
- print($true ? "ok $num\n" : "not ok $num $msg\n");
-}
+$| = 1;
+
+######################### End of black magic.
# Set up a CGI environment
$ENV{REQUEST_METHOD} = 'GET';
$ENV{REQUEST_URI} = "$ENV{SCRIPT_NAME}$ENV{PATH_INFO}?$ENV{QUERY_STRING}";
$ENV{HTTP_LOVE} = 'true';
-$q = new CGI;
-test(2,$q,"CGI::new()");
-test(3,$q->request_method eq 'GET',"CGI::request_method()");
-test(4,$q->query_string eq 'game=chess;game=checkers;weather=dull',"CGI::query_string()");
-test(5,$q->param() == 2,"CGI::param()");
-test(6,join(' ',sort $q->param()) eq 'game weather',"CGI::param()");
-test(7,$q->param('game') eq 'chess',"CGI::param()");
-test(8,$q->param('weather') eq 'dull',"CGI::param()");
-test(9,join(' ',$q->param('game')) eq 'chess checkers',"CGI::param()");
-test(10,$q->param(-name=>'foo',-value=>'bar'),'CGI::param() put');
-test(11,$q->param(-name=>'foo') eq 'bar','CGI::param() get');
-test(12,$q->query_string eq 'game=chess;game=checkers;weather=dull;foo=bar',"CGI::query_string() redux");
-test(13,$q->http('love') eq 'true',"CGI::http()");
-test(14,$q->script_name eq '/cgi-bin/foo.cgi',"CGI::script_name()");
-test(15,$q->url eq 'http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi',"CGI::url()");
-test(16,$q->self_url eq
+my $q = new CGI;
+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()");
-test(17,$q->url(-absolute=>1) eq '/cgi-bin/foo.cgi','CGI::url(-absolute=>1)');
-test(18,$q->url(-relative=>1) eq 'foo.cgi','CGI::url(-relative=>1)');
-test(19,$q->url(-relative=>1,-path=>1) eq 'foo.cgi/somewhere/else','CGI::url(-relative=>1,-path=>1)');
-test(20,$q->url(-relative=>1,-path=>1,-query=>1) eq
+ "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)');
+ 'CGI::url(-relative=>1,-path=>1,-query=>1)';
$q->delete('foo');
-test(21,!$q->param('foo'),'CGI::delete()');
+ok !$q->param('foo'),'CGI::delete()';
$q->_reset_globals;
$ENV{QUERY_STRING}='mary+had+a+little+lamb';
-test(22,$q=new CGI,"CGI::new() redux");
-test(23,join(' ',$q->keywords) eq 'mary had a little lamb','CGI::keywords');
-test(24,join(' ',$q->param('keywords')) eq 'mary had a little lamb','CGI::keywords');
-test(25,$q=new CGI('foo=bar&foo=baz'),"CGI::new() redux");
-test(26,$q->param('foo') eq 'bar','CGI::param() redux');
-test(27,$q=new CGI({'foo'=>'bar','bar'=>'froz'}),"CGI::new() redux 2");
-test(28,$q->param('bar') eq 'froz',"CGI::param() redux 2");
+ok $q=new CGI,"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=new CGI('foo=bar&foo=baz'),"CGI::new() redux";
+is $q->param('foo'), 'bar','CGI::param() redux';
+ok $q=new CGI({'foo'=>'bar','bar'=>'froz'}),"CGI::new() redux 2";
+is $q->param('bar'), 'froz',"CGI::param() redux 2";
# test tied interface
my $p = $q->Vars;
-test(29,$p->{bar} eq 'froz',"tied interface fetch");
+is $p->{bar}, 'froz',"tied interface fetch";
$p->{bar} = join("\0",qw(foo bar baz));
-test(30,join(' ',$q->param('bar')) eq 'foo bar baz','tied interface store');
-test(31,exists $p->{bar});
+is join(' ',$q->param('bar')), 'foo bar baz','tied interface store';
+ok exists $p->{bar};
# test posting
$q->_reset_globals;
-if ($Config{d_fork}) {
- $test_string = 'game=soccer&game=baseball&weather=nice';
- $ENV{REQUEST_METHOD}='POST';
- $ENV{CONTENT_LENGTH}=length($test_string);
- $ENV{QUERY_STRING}='big_balls=basketball&small_balls=golf';
- if (open(CHILD,"|-")) { # cparent
- print CHILD $test_string;
- close CHILD;
- exit 0;
- }
- # at this point, we're in a new (child) process
- test(32,$q=new CGI,"CGI::new() from POST");
- test(33,$q->param('weather') eq 'nice',"CGI::param() from POST");
- test(34,$q->url_param('big_balls') eq 'basketball',"CGI::url_param()");
-} else {
- print "ok 32 # Skip\n";
- print "ok 33 # Skip\n";
- print "ok 34 # Skip\n";
+{
+ 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=new CGI,"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 /;
}
--- /dev/null
+
+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;
+
+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
+
#!/usr/local/bin/perl -w
-use lib qw(t/lib);
-
-# 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 strict;
use Test::More tests => 1;
-use lib 't/lib';
-use Test::More 'no_plan';
+use Test::More tests => 4;
use CGI 'unescapeHTML';
-is( unescapeHTML( '&'), '&', 'unescapeHTML: &');
-is( unescapeHTML( '"'), '"', 'unescapeHTML: "');
-TODO: {
- local $TODO = 'waiting on patch. Reference: https://rt.cpan.org/Ticket/Display.html?id=39122';
- 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( '&'), '&', '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.');
# Shamelessly stolen from Data::FormValidator and CGI::Upload #
#################################################################
-# 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 strict;
use Test::More 'no_plan';
# Shamelessly stolen from Data::FormValidator and CGI::Upload #
#################################################################
-# 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 strict;
-
use Test::More 'no_plan';
use CGI;
# Test the user_agent method.
-use lib 't/lib';
use Test::More 'no_plan';
use CGI;
--- /dev/null
+#!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';
# 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 GCI.pm under
+# 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";
# Test ability to escape() and unescape() punctuation characters
# except for qw(- . _).
-######################### We start with some black magic to print on failure.
-use lib '../blib/lib','../blib/arch';
-BEGIN {$| = 1; print "1..57\n"; }
-END {print "not ok 1\n" unless $loaded;}
-use Config;
-use CGI::Util qw(escape unescape);
-$loaded = 1;
-print "ok 1\n";
-
-######################### End of black magic.
+$| = 1;
-# util
-sub test {
- local($^W) = 0;
- my($num, $true,$msg) = @_;
- print($true ? "ok $num\n" : "not ok $num $msg\n");
-}
+use Test::More tests => 57;
+use Config;
+use_ok ( 'CGI::Util', qw(escape unescape) );
# ASCII order, ASCII codepoints, ASCII repertoire
$i++;
my $escape = "AbC\%$punct{$_}dEF";
my $cgi_escape = escape("AbC$_" . "dEF");
- test($i, $escape eq $cgi_escape , "# $escape ne $cgi_escape");
+ is($escape, $cgi_escape , "# $escape ne $cgi_escape");
$i++;
my $unescape = "AbC$_" . "dEF";
my $cgi_unescape = unescape("AbC\%$punct{$_}dEF");
- test($i, $unescape eq $cgi_unescape , "# $unescape ne $cgi_unescape");
+ is($unescape, $cgi_unescape , "# $unescape ne $cgi_unescape");
}
projects / p5sagit/p5-mst-13.2.git / commitdiff