From: Jarkko Hietaniemi Date: Wed, 21 Feb 2001 00:34:20 +0000 (+0000) Subject: Upgrade to CGI.pm 2.752, from Lincoln Stein. X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=ba05675547134d242d93611530d62f98d944bc27;p=p5sagit%2Fp5-mst-13.2.git Upgrade to CGI.pm 2.752, from Lincoln Stein. (Note: there were some conflicts due to EBCDIC and EPOC patches, in general I preferred the repository code.) (When 2.753 comes out, we need to synchronize.) p4raw-id: //depot/perl@8866 --- diff --git a/lib/CGI.pm b/lib/CGI.pm index 6b87054..1c9d2d4 100644 --- a/lib/CGI.pm +++ b/lib/CGI.pm @@ -1,5 +1,6 @@ package CGI; require 5.004; +use Carp 'croak'; # See the bottom of this file for the POD documentation. Search for the # string '=head'. @@ -17,16 +18,16 @@ require 5.004; # The most recent version and complete docs are available at: # http://stein.cshl.org/WWW/software/CGI/ -$CGI::revision = '$Id: CGI.pm,v 1.45 2000/09/13 02:55:41 lstein Exp $'; -$CGI::VERSION='2.74'; +$CGI::revision = '$Id: CGI.pm,v 1.49 2001/02/04 23:08:39 lstein Exp $'; +$CGI::VERSION='2.752'; # HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES. # UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING. # $TempFile::TMPDIRECTORY = '/usr/tmp'; use CGI::Util qw(rearrange make_attributes unescape escape expires); -use constant XHTML_DTD => ['-//W3C//DTD XHTML 1.0 Transitional//EN', - 'DTD/xhtml1-transitional.dtd']; +use constant XHTML_DTD => ['-//W3C//DTD XHTML Basic 1.0//EN', + 'http://www.w3.org/TR/xhtml-basic/xhtml-basic10.dtd']; # >>>>> Here are some globals that you might want to adjust <<<<<< sub initialize_globals { @@ -135,7 +136,8 @@ $AutoloadClass = $DefaultClass unless defined $CGI::AutoloadClass; # The path separator is a slash, backslash or semicolon, depending # on the paltform. $SL = { - UNIX=>'/', EPOC=>'/', OS2=>'\\', WINDOWS=>'\\', DOS=>'\\', MACINTOSH=>':', VMS=>'/' + UNIX=>'/', OS2=>'\\', EPOC=>'/', + WINDOWS=>'\\', DOS=>'\\', MACINTOSH=>':', VMS=>'/' }->{$OS}; # This no longer seems to be necessary @@ -199,7 +201,7 @@ if ($needs_binmode) { ':cgi-lib' => [qw/ReadParse PrintHeader HtmlTop HtmlBot SplitParam Vars/], ':html' => [qw/:html2 :html3 :netscape/], ':standard' => [qw/:html2 :html3 :form :cgi/], - ':push' => [qw/multipart_init multipart_start multipart_end/], + ':push' => [qw/multipart_init multipart_start multipart_end multipart_final/], ':all' => [qw/:html2 :html3 :netscape :form :cgi :internal/] ); @@ -456,7 +458,7 @@ sub init { # We now have the query string in hand. We do slightly # different things for keyword lists and parameter lists. - if (defined $query_string && $query_string) { + if (defined $query_string && length $query_string) { if ($query_string =~ /[&=;]/) { $self->parse_params($query_string); } else { @@ -618,7 +620,7 @@ sub _compile { unless (%$sub) { my($auto) = \${"$pack\:\:AUTOLOADED_ROUTINES"}; eval "package $pack; $$auto"; - die $@ if $@; + croak("$AUTOLOAD: $@") if $@; $$auto = ''; # Free the unneeded storage (but don't undef it!!!) } my($code) = $sub->{$func_name}; @@ -634,11 +636,11 @@ sub _compile { $code = $CGI::DefaultClass->_make_tag_func($func_name); } } - die "Undefined subroutine $AUTOLOAD\n" unless $code; + croak("Undefined subroutine $AUTOLOAD\n") unless $code; eval "package $pack; $code"; if ($@) { $@ =~ s/ at .*\n//; - die $@; + croak("$AUTOLOAD: $@"); } } CORE::delete($sub->{$func_name}); #free storage @@ -706,7 +708,7 @@ sub MULTIPART { 'multipart/form-data'; } END_OF_FUNC 'SERVER_PUSH' => <<'END_OF_FUNC', -sub SERVER_PUSH { 'multipart/x-mixed-replace; boundary="' . shift() . '"'; } +sub SERVER_PUSH { 'multipart/x-mixed-replace;boundary="' . shift() . '"'; } END_OF_FUNC 'new_MultipartBuffer' => <<'END_OF_FUNC', @@ -1090,23 +1092,24 @@ END_OF_FUNC #### Method: multipart_init # Return a Content-Type: style header for server-push -# This has to be NPH, and it is advisable to set $| = 1 +# This has to be NPH on most web servers, and it is advisable to set $| = 1 # # Many thanks to Ed Jordan for this -# contribution +# contribution, updated by Andrew Benham (adsb@bigfoot.com) #### 'multipart_init' => <<'END_OF_FUNC', sub multipart_init { my($self,@p) = self_or_default(@_); my($boundary,@other) = rearrange([BOUNDARY],@p); $boundary = $boundary || '------- =_aaaaaaaaaa0'; - $self->{'separator'} = "\n--$boundary\n"; + $self->{'separator'} = "$CRLF--$boundary$CRLF"; + $self->{'final_separator'} = "$CRLF--$boundary--$CRLF"; $type = SERVER_PUSH($boundary); return $self->header( -nph => 1, -type => $type, (map { split "=", $_, 2 } @other), - ) . $self->multipart_end; + ) . "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY." . $self->multipart_end; } END_OF_FUNC @@ -1115,23 +1118,31 @@ END_OF_FUNC # Return a Content-Type: style header for server-push, start of section # # Many thanks to Ed Jordan for this -# contribution +# contribution, updated by Andrew Benham (adsb@bigfoot.com) #### 'multipart_start' => <<'END_OF_FUNC', sub multipart_start { + my(@header); my($self,@p) = self_or_default(@_); my($type,@other) = rearrange([TYPE],@p); $type = $type || 'text/html'; - return $self->header( - -type => $type, - (map { split "=", $_, 2 } @other), - ); + push(@header,"Content-Type: $type"); + + # rearrange() was designed for the HTML portion, so we + # need to fix it up a little. + foreach (@other) { + next unless my($header,$value) = /([^\s=]+)=\"?(.+?)\"?$/; + ($_ = $header) =~ s/^(\w)(.*)/$1 . lc ($2) . ': '.$self->unescapeHTML($value)/e; + } + push(@header,@other); + my $header = join($CRLF,@header)."${CRLF}${CRLF}"; + return $header; } END_OF_FUNC #### Method: multipart_end -# Return a Content-Type: style header for server-push, end of section +# Return a MIME boundary separator for server-push, end of section # # Many thanks to Ed Jordan for this # contribution @@ -1144,6 +1155,19 @@ sub multipart_end { END_OF_FUNC +#### Method: multipart_final +# Return a MIME boundary separator for server-push, end of all sections +# +# Contributed by Andrew Benham (adsb@bigfoot.com) +#### +'multipart_final' => <<'END_OF_FUNC', +sub multipart_final { + my($self,@p) = self_or_default(@_); + return $self->{'final_separator'} . "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY." . $CRLF; +} +END_OF_FUNC + + #### Method: header # Return a Content-Type: style header # @@ -1181,6 +1205,7 @@ sub header { # Maybe future compatibility. Maybe not. my $protocol = $ENV{SERVER_PROTOCOL} || 'HTTP/1.0'; push(@header,$protocol . ' ' . ($status || '200 OK')) if $nph; + push(@header,"Server: " . &server_software()) if $nph; push(@header,"Status: $status") if $status; push(@header,"Window-Target: $target") if $target; @@ -1197,7 +1222,7 @@ sub header { # uses OUR clock) push(@header,"Expires: " . expires($expires,'http')) if $expires; - push(@header,"Date: " . expires(0,'http')) if $expires || $cookie; + push(@header,"Date: " . expires(0,'http')) if $expires || $cookie || $nph; push(@header,"Pragma: no-cache") if $self->cache(); push(@header,"Content-Disposition: attachment; filename=\"$attachment\"") if $attachment; push(@header,@other); @@ -1283,7 +1308,7 @@ sub start_html { $title = $self->escapeHTML($title || 'Untitled Document'); $author = $self->escape($author); $lang ||= 'en-US'; - my(@result); + my(@result,$xml_dtd); if ($dtd) { if (defined(ref($dtd)) and (ref($dtd) eq 'ARRAY')) { $dtd = $DEFAULT_DTD unless $dtd->[0] =~ m|^-//|; @@ -1293,6 +1318,11 @@ sub start_html { } else { $dtd = $XHTML ? XHTML_DTD : $DEFAULT_DTD; } + + $xml_dtd++ if ref($dtd) eq 'ARRAY' && $dtd->[0] =~ /\bXHTML\b/i; + $xml_dtd++ if ref($dtd) eq '' && $dtd =~ /\bXHTML\b/i; + push @result,q() if $xml_dtd; + if (ref($dtd) && ref($dtd) eq 'ARRAY') { push(@result,qq([0]"\n\t"$dtd->[1]">)); } else { @@ -1357,12 +1387,15 @@ sub _style { { # If it is, push a LINK tag for each one. foreach $src (@$src) { - push(@result,qq//) if $src; + push(@result,$XHTML ? qq() + : qq(/)) if $src; } } else { # Otherwise, push the single -src, if it exists. - push(@result,qq//) if $src; + push(@result,$XHTML ? qq() + : qq() + ) if $src; } push(@result,style({'type'=>$type},"$cdata_start\n$code\n$cdata_end")) if $code; } else { @@ -1409,7 +1442,7 @@ sub _script { push(@satts,'src'=>$src) if $src; push(@satts,'language'=>$language); push(@satts,'type'=>$type); - $code = "$cdata_start$code$cdata_end"; + $code = "$cdata_start$code$cdata_end" if defined $code; push(@result,script({@satts},$code || '')); } @result; @@ -1542,8 +1575,8 @@ sub _textfield { $current = defined($current) ? $self->escapeHTML($current,1) : ''; $name = defined($name) ? $self->escapeHTML($name) : ''; - my($s) = defined($size) ? qq/ size=$size/ : ''; - my($m) = defined($maxlength) ? qq/ maxlength=$maxlength/ : ''; + my($s) = defined($size) ? qq/ size="$size"/ : ''; + my($m) = defined($maxlength) ? qq/ maxlength="$maxlength"/ : ''; my($other) = @other ? " @other" : ''; # this entered at cristy's request to fix problems with file upload fields # and WebTV -- not sure it won't break stuff @@ -1657,7 +1690,7 @@ sub button { $script=$self->escapeHTML($script); my($name) = ''; - $name = qq/ NAME="$label"/ if $label; + $name = qq/ name="$label"/ if $label; $value = $value || $label; my($val) = ''; $val = qq/ value="$value"/ if $value; @@ -1877,6 +1910,7 @@ sub escapeHTML { my $latin = uc $self->{'.charset'} eq 'ISO-8859-1' || uc $self->{'.charset'} eq 'WINDOWS-1252'; if ($latin) { # bug in some browsers + $toencode =~ s{'}{'}gso; $toencode =~ s{\x8b}{‹}gso; $toencode =~ s{\x9b}{›}gso; if (defined $newlinestoo && $newlinestoo) { @@ -1994,10 +2028,10 @@ sub radio_group { my($checkit) = $checked eq $_ ? qq/ checked/ : ''; my($break); if ($linebreak) { - $break = $XHTML ? "
" : "
"; + $break = $XHTML ? "
" : "
"; } else { - $break = ''; + $break = ''; } my($label)=''; unless (defined($nolabels) && $nolabels) { @@ -2156,7 +2190,7 @@ sub hidden { $name=$self->escapeHTML($name); foreach (@value) { $_ = defined($_) ? $self->escapeHTML($_,1) : ''; - push @result,$XHTMl ? qq() + push @result,$XHTML ? qq() : qq(); } return wantarray ? @result : join('',@result); @@ -2306,7 +2340,7 @@ sub cookie { } # If we get here, we're creating a new cookie - return undef unless $name; # this is an error + return undef unless defined($name) && $name ne ''; # this is an error my @param; push(@param,'-name'=>$name); @@ -2975,7 +3009,7 @@ sub asString { my $self = shift; # get rid of package name (my $i = $$self) =~ s/^\*(\w+::fh\d{5})+//; - $i =~ s/\\(.)/$1/g; + $i =~ s/%(..)/ chr(hex($1)) /eg; return $i; # BEGIN DEAD CODE # This was an extremely clever patch that allowed "use strict refs". @@ -3000,7 +3034,8 @@ END_OF_FUNC sub new { my($pack,$name,$file,$delete) = @_; require Fcntl unless defined &Fcntl::O_RDWR; - my $fv = ++$FH . quotemeta($name); + (my $safename = $name) =~ s/([':%])/ sprintf '%%%02X', ord $1 /eg; + my $fv = ++$FH . $safename; my $ref = \*{"Fh::$fv"}; sysopen($ref,$file,Fcntl::O_RDWR()|Fcntl::O_CREAT()|Fcntl::O_EXCL(),0600) || return; unlink($file) if $delete; @@ -3274,7 +3309,8 @@ unless ($TMPDIRECTORY) { @TEMP=("${SL}usr${SL}tmp","${SL}var${SL}tmp", "C:${SL}temp","${SL}tmp","${SL}temp", "${vol}${SL}Temporary Items", - "${SL}WWW_ROOT", "${SL}SYS\$SCRATCH", "C:${SL}system${SL}temp"); + "${SL}WWW_ROOT", "${SL}SYS\$SCRATCH", + "C:${SL}system${SL}temp"); unshift(@TEMP,$ENV{'TMPDIR'}) if exists $ENV{'TMPDIR'}; # this feature was supposed to provide per-user tmpfiles, but @@ -3313,7 +3349,7 @@ sub new { last if ! -f ($filename = sprintf("${TMPDIRECTORY}${SL}CGItemp%d",$sequence++)); } # untaint the darn thing - return unless $filename =~ m!^([a-zA-Z0-9_ '":/.\$\\]+)$!; + return unless $filename =~ m!^([a-zA-Z0-9_ '":/.\$\\-]+)$!; $filename = $1; return bless \$filename; } @@ -4348,7 +4384,7 @@ The B<-lang> argument is used to incorporate a language attribute into the tag. The default if not specified is "en-US" for US English. For example: - print $q->header(-lang=>'fr-CA'); + print $q->start_html(-lang=>'fr-CA'); You can place other arbitrary HTML elements to the section with the B<-head> tag. For example, to place the rarely-used element in the @@ -4370,8 +4406,8 @@ array reference: And here's how to create an HTTP-EQUIV tag: - print header(-head=>meta({-http_equiv => 'Content-Type', - -content => 'text/html'})) + print start_html(-head=>meta({-http_equiv => 'Content-Type', + -content => 'text/html'})) JAVASCRIPTING: The B<-script>, B<-noScript>, B<-onLoad>, @@ -6238,7 +6274,7 @@ in the B and B statements: =head1 Server Push -CGI.pm provides three simple functions for producing multipart +CGI.pm provides four simple functions for producing multipart documents of the type needed to implement server push. These functions were graciously provided by Ed Jordan . To import these into your namespace, you must import the ":push" set. @@ -6250,19 +6286,25 @@ Here is a simple script that demonstrates server push: #!/usr/local/bin/perl use CGI qw/:push -nph/; $| = 1; - print multipart_init(-boundary=>'----------------here we go!'); - while (1) { + print multipart_init(-boundary=>'----here we go!'); + foreach (0 .. 4) { print multipart_start(-type=>'text/plain'), - "The current time is ",scalar(localtime),"\n", - multipart_end; + "The current time is ",scalar(localtime),"\n"; + if ($_ < 4) { + print multipart_end; + } else { + print multipart_final; + } sleep 1; } This script initializes server push by calling B. -It then enters an infinite loop in which it begins a new multipart -section by calling B, prints the current local time, +It then enters a loop in which it begins a new multipart section by +calling B, prints the current local time, and ends a multipart section with B. It then sleeps -a second, and begins again. +a second, and begins again. On the final iteration, it ends the +multipart section with B rather than with +B. =over 4 @@ -6286,13 +6328,24 @@ type. If not specified, text/html is assumed. multipart_end() End a part. You must remember to call multipart_end() once for each -multipart_start(). +multipart_start(), except at the end of the last part of the multipart +document when multipart_final() should be called instead of multipart_end(). + +=item multipart_final() + + multipart_final() + +End all parts. You should call multipart_final() rather than +multipart_end() at the end of the last part of the multipart document. =back Users interested in server push applications should also have a look at the CGI::Push module. +Only Netscape Navigator supports server push. Internet Explorer +browsers do not. + =head1 Avoiding Denial of Service Attacks A potential problem with CGI.pm is that, by default, it attempts to diff --git a/lib/CGI/Carp.pm b/lib/CGI/Carp.pm index 5aea198..3af2e9f 100644 --- a/lib/CGI/Carp.pm +++ b/lib/CGI/Carp.pm @@ -71,9 +71,9 @@ compiler errors will be caught. Example: carpout() does not handle file locking on the log for you at this point. -The real STDERR is not closed -- it is moved to SAVEERR. Some +The real STDERR is not closed -- it is moved to CGI::Carp::SAVEERR. Some servers, when dealing with CGI scripts, close their connection to the -browser when the script closes STDOUT and STDERR. SAVEERR is used to +browser when the script closes STDOUT and STDERR. CGI::Carp::SAVEERR is there to prevent this from happening prematurely. You can pass filehandles to carpout() in a variety of ways. The "correct" diff --git a/lib/CGI/Cookie.pm b/lib/CGI/Cookie.pm index 6737832..de91be2 100644 --- a/lib/CGI/Cookie.pm +++ b/lib/CGI/Cookie.pm @@ -13,7 +13,7 @@ package CGI::Cookie; # wish, but if you redistribute a modified version, please attach a note # listing the modifications you have made. -$CGI::Cookie::VERSION='1.16'; +$CGI::Cookie::VERSION='1.18'; use CGI::Util qw(rearrange unescape escape); use overload '""' => \&as_string, @@ -57,61 +57,67 @@ sub raw_fetch { return %results; } -sub parse { - my ($self,$raw_cookie) = @_; - my %results; - my(@pairs) = split("; ?",$raw_cookie); - foreach (@pairs) { - s/\s*(.*?)\s*/$1/; - my($key,$value) = split("="); - my(@values) = map unescape($_),split('&',$value); - $key = unescape($key); - # Some foreign cookies are not in name=value format, so ignore - # them. - next if !defined($value); - # A bug in Netscape can cause several cookies with same name to - # appear. The FIRST one in HTTP_COOKIE is the most recent version. - $results{$key} ||= $self->new(-name=>$key,-value=>\@values); +sub parse { + my ($self,$raw_cookie) = @_; + my %results; + + my(@pairs) = split("; ?",$raw_cookie); + foreach (@pairs) { + s/\s*(.*?)\s*/$1/; + my($key,$value) = split("="); + + # Some foreign cookies are not in name=value format, so ignore + # them. + next if !defined($value); + my @values = (); + if ($value ne '') { + @values = map CGI::unescape($_),split(/[&;]/,$value.'&dmy'); + pop @values; } - return \%results unless wantarray; - return %results; + $key = unescape($key); + # A bug in Netscape can cause several cookies with same name to + # appear. The FIRST one in HTTP_COOKIE is the most recent version. + $results{$key} ||= $self->new(-name=>$key,-value=>\@values); + } + return \%results unless wantarray; + return %results; } sub new { - my $class = shift; - $class = ref($class) if ref($class); - my($name,$value,$path,$domain,$secure,$expires) = - rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES],@_); - - # Pull out our parameters. - my @values; - if (ref($value)) { - if (ref($value) eq 'ARRAY') { - @values = @$value; - } elsif (ref($value) eq 'HASH') { - @values = %$value; - } - } else { - @values = ($value); + my $class = shift; + $class = ref($class) if ref($class); + my($name,$value,$path,$domain,$secure,$expires) = + rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES],@_); + + # Pull out our parameters. + my @values; + if (ref($value)) { + if (ref($value) eq 'ARRAY') { + @values = @$value; + } elsif (ref($value) eq 'HASH') { + @values = %$value; } - - bless my $self = { - 'name'=>$name, - 'value'=>[@values], - },$class; - - # IE requires the path and domain to be present for some reason. - $path ||= '/'; -# however, this breaks networks which use host tables without fully qualified -# names, so we comment it out. -# $domain = CGI::virtual_host() unless defined $domain; - - $self->path($path) if defined $path; - $self->domain($domain) if defined $domain; - $self->secure($secure) if defined $secure; - $self->expires($expires) if defined $expires; - return $self; + } else { + @values = ($value); + } + + bless my $self = { + 'name'=>$name, + 'value'=>[@values], + },$class; + + # IE requires the path and domain to be present for some reason. + $path ||= "/"; + # however, this breaks networks which use host tables without fully qualified + # names, so we comment it out. + # $domain = CGI::virtual_host() unless defined $domain; + + $self->path($path) if defined $path; + $self->domain($domain) if defined $domain; + $self->secure($secure) if defined $secure; + $self->expires($expires) if defined $expires; + return $self; } sub as_string { @@ -123,7 +129,7 @@ sub as_string { push(@constant_values,"domain=$domain") if $domain = $self->domain; push(@constant_values,"path=$path") if $path = $self->path; push(@constant_values,"expires=$expires") if $expires = $self->expires; - push(@constant_values,'secure') if $secure = $self->secure; + push(@constant_values,"secure") if $secure = $self->secure; my($key) = escape($self->name); my($cookie) = join("=",$key,join("&",map escape($_),$self->value)); diff --git a/lib/CGI/Pretty.pm b/lib/CGI/Pretty.pm index d348807..a26ab81 100644 --- a/lib/CGI/Pretty.pm +++ b/lib/CGI/Pretty.pm @@ -10,7 +10,7 @@ package CGI::Pretty; use strict; use CGI (); -$CGI::Pretty::VERSION = '1.04'; +$CGI::Pretty::VERSION = '1.05'; $CGI::DefaultClass = __PACKAGE__; $CGI::Pretty::AutoloadClass = 'CGI'; @CGI::Pretty::ISA = qw( CGI ); @@ -30,14 +30,14 @@ sub _prettyPrint { return; } } - $$input =~ s/$CGI::Pretty::LINEBREAK/$CGI::Pretty::LINEBREAK$CGI::Pretty::INDENT/g; + $$input =~ s/$CGI::Pretty::LINEBREAK/$CGI::Pretty::LINEBREAK$CGI::Pretty::INDENT/g if $CGI::Pretty::LINEBREAK; } sub comment { my($self,@p) = CGI::self_or_CGI(@_); my $s = "@p"; - $s =~ s/$CGI::Pretty::LINEBREAK/$CGI::Pretty::LINEBREAK$CGI::Pretty::INDENT/g; + $s =~ s/$CGI::Pretty::LINEBREAK/$CGI::Pretty::LINEBREAK$CGI::Pretty::INDENT/g if $CGI::Pretty::LINEBREAK; return $self->SUPER::comment( "$CGI::Pretty::LINEBREAK$CGI::Pretty::INDENT$s$CGI::Pretty::LINEBREAK" ) . $CGI::Pretty::LINEBREAK; } @@ -66,6 +66,7 @@ sub _make_tag_func { (ref(\$_[0]) && (substr(ref(\$_[0]),0,3) eq 'CGI' || UNIVERSAL::isa(\$_[0],'CGI'))); + my(\$attr) = ''; if (ref(\$_[0]) && ref(\$_[0]) eq 'HASH') { my(\@attr) = make_attributes(shift); @@ -86,7 +87,7 @@ sub _make_tag_func { \@result = map { chomp; if ( \$_ !~ /<\\// ) { - s/\$CGI::Pretty::LINEBREAK/\$CGI::Pretty::LINEBREAK\$CGI::Pretty::INDENT/g; + s/\$CGI::Pretty::LINEBREAK/\$CGI::Pretty::LINEBREAK\$CGI::Pretty::INDENT/g if \$CGI::Pretty::LINEBREAK; } else { my \$tmp = \$_; diff --git a/lib/CGI/Push.pm b/lib/CGI/Push.pm index 83002f2..9e72abd 100644 --- a/lib/CGI/Push.pm +++ b/lib/CGI/Push.pm @@ -7,7 +7,7 @@ package CGI::Push; # documentation in manual or html file format (these utilities are part of the # Perl 5 distribution). -# Copyright 1995,1996, Lincoln D. Stein. All rights reserved. +# Copyright 1995-2000, 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 # wish, but if you redistribute a modified version, please attach a note @@ -16,7 +16,7 @@ package CGI::Push; # The most recent version and complete docs are available at: # http://stein.cshl.org/WWW/software/CGI/ -$CGI::Push::VERSION='1.03'; +$CGI::Push::VERSION='1.04'; use CGI; use CGI::Util 'rearrange'; @ISA = ('CGI'); @@ -33,71 +33,78 @@ sub do_push { # unbuffer output $| = 1; srand; - my ($random) = sprintf("%16.0f",rand()*1E16); - my ($boundary) = "----------------------------------$random"; + my ($random) = sprintf("%08.0f",rand()*1E8); + my ($boundary) = "----=_NeXtPaRt$random"; my (@header); - my ($type,$callback,$delay,$last_page,$cookie,$target,$expires,@other) = - rearrange([TYPE,NEXT_PAGE,DELAY,LAST_PAGE,[COOKIE,COOKIES],TARGET,EXPIRES],@p); + my ($type,$callback,$delay,$last_page,$cookie,$target,$expires,$nph,@other) = rearrange([TYPE,NEXT_PAGE,DELAY,LAST_PAGE,[COOKIE,COOKIES],TARGET,EXPIRES,NPH],@p); $type = 'text/html' unless $type; $callback = \&simple_counter unless $callback && ref($callback) eq 'CODE'; $delay = 1 unless defined($delay); $self->push_delay($delay); + $nph = 1 unless defined($nph); my(@o); foreach (@other) { push(@o,split("=")); } push(@o,'-Target'=>$target) if defined($target); push(@o,'-Cookie'=>$cookie) if defined($cookie); - push(@o,'-Type'=>"multipart/x-mixed-replace; boundary=$boundary"); - push(@o,'-Server'=>"CGI.pm Push Module"); + push(@o,'-Type'=>"multipart/x-mixed-replace;boundary=\"$boundary\""); + push(@o,'-Server'=>"CGI.pm Push Module") if $nph; push(@o,'-Status'=>'200 OK'); - push(@o,'-nph'=>1); + push(@o,'-nph'=>1) if $nph; print $self->header(@o); - print "${boundary}$CGI::CRLF"; + + $boundary = "$CGI::CRLF--$boundary"; + + print "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY.${boundary}$CGI::CRLF"; + + my (@contents) = &$callback($self,++$COUNTER); # now we enter a little loop - my @contents; while (1) { - last unless (@contents = &$callback($self,++$COUNTER)) && defined($contents[0]); - print "Content-type: ${type}$CGI::CRLF$CGI::CRLF" - unless $type =~ /^dynamic|heterogeneous$/i; - print @contents,"$CGI::CRLF"; - print "${boundary}$CGI::CRLF"; - do_sleep($self->push_delay()) if $self->push_delay(); - } - - # Optional last page - if ($last_page && ref($last_page) eq 'CODE') { - print "Content-type: ${type}$CGI::CRLF$CGI::CRLF" unless $type =~ /^dynamic|heterogeneous$/i; - print &$last_page($self,$COUNTER),"$CGI::CRLF${boundary}$CGI::CRLF"; + print "Content-type: ${type}$CGI::CRLF$CGI::CRLF" unless $type =~ /^dynamic|heterogeneous$/i; + print @contents; + @contents = &$callback($self,++$COUNTER); + if ((@contents) && defined($contents[0])) { + print "${boundary}$CGI::CRLF"; + do_sleep($self->push_delay()) if $self->push_delay(); + } else { + if ($last_page && ref($last_page) eq 'CODE') { + print "${boundary}$CGI::CRLF"; + do_sleep($self->push_delay()) if $self->push_delay(); + print "Content-type: ${type}$CGI::CRLF$CGI::CRLF" unless $type =~ /^dynamic|heterogeneous$/i; + print &$last_page($self,$COUNTER); + } + print "${boundary}--$CGI::CRLF"; + last; + } } + print "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY.$CGI::CRLF"; } sub simple_counter { my ($self,$count) = @_; - return ( - CGI->start_html("CGI::Push Default Counter"), - CGI->h1("CGI::Push Default Counter"), - "This page has been updated ",CGI->strong($count)," times.", - CGI->hr(), - CGI->a({'-href'=>'http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html'},'CGI.pm home page'), - CGI->end_html - ); + return $self->start_html("CGI::Push Default Counter"), + $self->h1("CGI::Push Default Counter"), + "This page has been updated ",$self->strong($count)," times.", + $self->hr(), + $self->a({'-href'=>'http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html'},'CGI.pm home page'), + $self->end_html; } sub do_sleep { my $delay = shift; if ( ($delay >= 1) && ($delay!~/\./) ){ - sleep($delay); + sleep($delay); } else { - select(undef,undef,undef,$delay); + select(undef,undef,undef,$delay); } } sub push_delay { - my ($self,$delay) = CGI::self_or_default(@_); - return defined($delay) ? $self->{'.delay'} = - $delay : $self->{'.delay'}; + my ($self,$delay) = CGI::self_or_default(@_); + return defined($delay) ? $self->{'.delay'} = + $delay : $self->{'.delay'}; } 1; @@ -118,18 +125,18 @@ CGI::Push - Simple Interface to Server Push my($q,$counter) = @_; return undef if $counter >= 10; return start_html('Test'), - h1('Visible'),"\n", + h1('Visible'),"\n", "This page has been called ", strong($counter)," times", end_html(); - } + } - sub last_page { - my($q,$counter) = @_; - return start_html('Done'), - h1('Finished'), - strong($counter),' iterations.', - end_html; - } + sub last_page { + my($q,$counter) = @_; + return start_html('Done'), + h1('Finished'), + strong($counter - 1),' iterations.', + end_html; + } =head1 DESCRIPTION @@ -189,7 +196,7 @@ redrawing loop and print out the final page (if any) return undef if $counter > 100; return start_html('testing'), h1('testing'), - "This page called $counter times"; + "This page called $counter times"; } You are of course free to refer to create and use global variables @@ -220,11 +227,13 @@ refresh the page faster. Fractional values are allowed. B -=item -cookie, -target, -expires +=item -cookie, -target, -expires, -nph These have the same meaning as the like-named parameters in CGI::header(). +If not specified, -nph will default to 1 (as needed for many servers, see below). + =back =head2 Heterogeneous Pages @@ -241,9 +250,9 @@ look like this: sub my_draw_routine { my($q,$counter) = @_; return header('text/html'), # note we're producing the header here - start_html('testing'), + start_html('testing'), h1('testing'), - "This page called $counter times"; + "This page called $counter times"; } You can add any header fields that you like, but some (cookies and @@ -255,21 +264,21 @@ as shown below: sub my_draw_routine { my($q,$counter) = @_; - return undef if $counter > 10; + return undef if $counter > 10; return header('text/html'), # note we're producing the header here - start_html('testing'), + start_html('testing'), h1('testing'), - "This page called $counter times"; + "This page called $counter times"; } sub my_last_page { - header(-refresh=>'5; URL=http://somewhere.else/finished.html', - -type=>'text/html'), - start_html('Moved'), - h1('This is the last page'), - 'Goodbye!' - hr, - end_html; + return header(-refresh=>'5; URL=http://somewhere.else/finished.html', + -type=>'text/html'), + start_html('Moved'), + h1('This is the last page'), + 'Goodbye!' + hr, + end_html; } =head2 Changing the Page Delay on the Fly @@ -283,13 +292,18 @@ parameters, push_delay() just returns the current delay. =head1 INSTALLING CGI::Push SCRIPTS -Server push scripts B be installed as no-parsed-header (NPH) -scripts in order to work correctly. On Unix systems, this is most -often accomplished by prefixing the script's name with "nph-". +Server push scripts must be installed as no-parsed-header (NPH) +scripts in order to work correctly on many servers. On Unix systems, +this is most often accomplished by prefixing the script's name with "nph-". Recognition of NPH scripts happens automatically with WebSTAR and Microsoft IIS. Users of other servers should see their documentation for help. +Apache web server from version 1.3b2 on does not need server +push scripts installed as NPH scripts: the -nph parameter to do_push() +may be set to a false value to disable the extra headers needed by an +NPH script. + =head1 AUTHOR INFORMATION Copyright 1995-1998, Lincoln D. Stein. All rights reserved. diff --git a/lib/CGI/Util.pm b/lib/CGI/Util.pm index 0049667..aba0ba5 100644 --- a/lib/CGI/Util.pm +++ b/lib/CGI/Util.pm @@ -140,6 +140,7 @@ sub unescape { my $todecode = shift; return undef unless defined($todecode); $todecode =~ tr/+/ /; # pluses become spaces + $EBCDIC = "\t" ne "\011"; if ($EBCDIC) { $todecode =~ s/%([0-9a-fA-F]{2})/chr $A2E[hex($1)]/ge; } else { @@ -221,3 +222,37 @@ sub expire_calc { } 1; + +__END__ + +=head1 NAME + +CGI::Util - Internal utilities used by CGI module + +=head1 SYNOPSIS + +none + +=head1 DESCRIPTION + +no public subroutines + +=head1 AUTHOR INFORMATION + +Copyright 1995-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. + +Address bug reports and comments to: lstein@cshl.org. When sending +bug reports, please provide the version of CGI.pm, the version of +Perl, the name and version of your Web server, and the name and +version of the operating system you are using. If the problem is even +remotely browser dependent, please provide information about the +affected browers as well. + +=head1 SEE ALSO + +L + +=cut diff --git a/t/lib/cgi-form.t b/t/lib/cgi-form.t index 6bdd7de..2922903 100755 --- a/t/lib/cgi-form.t +++ b/t/lib/cgi-form.t @@ -24,6 +24,15 @@ sub test { print($true ? "ok $num\n" : "not ok $num $msg\n"); } +my $CRLF = "\015\012"; +if ($^O eq 'VMS') { + $CRLF = "\n"; # via web server carriage is inserted automatically +} +if (ord("\t") != 9) { # EBCDIC? + $CRLF = "\r\n"; +} + + # Set up a CGI environment $ENV{REQUEST_METHOD}='GET'; $ENV{QUERY_STRING} ='game=chess&game=checkers&weather=dull'; diff --git a/t/lib/cgi-html.t b/t/lib/cgi-html.t index 3d3da10..93e5dac 100755 --- a/t/lib/cgi-html.t +++ b/t/lib/cgi-html.t @@ -49,11 +49,12 @@ test(7,h1({-align=>'CENTER'},['fred','agnes']) eq 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) eq "HTTP/1.0 200 OK${CRLF}Content-Type: text/html; charset=ISO-8859-1${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() ."\n" eq < + PUBLIC "-//W3C//DTD XHTML Basic 1.0//EN" + "http://www.w3.org/TR/xhtml-basic/xhtml-basic10.dtd"> Untitled Document END @@ -66,9 +67,10 @@ test(14,start_html(-dtd=>"-//IETF//DTD HTML 3.2//FR") ."\n" eq <'The world of foo') ."\n" eq < + PUBLIC "-//W3C//DTD XHTML Basic 1.0//EN" + "http://www.w3.org/TR/xhtml-basic/xhtml-basic10.dtd"> The world of foo END