package CGI;
require 5.004;
+use Carp 'croak';
# See the bottom of this file for the POD documentation. Search for the
# string '=head'.
# 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 {
# 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
':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/]
);
# 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 {
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};
$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
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',
#### 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 <ed@fidalgo.net> 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
# Return a Content-Type: style header for server-push, start of section
#
# Many thanks to Ed Jordan <ed@fidalgo.net> 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 <ed@fidalgo.net> for this
# contribution
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
#
# 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;
# 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);
$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|^-//|;
} 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(<?xml version="1.0" encoding="utf-8"?>) if $xml_dtd;
+
if (ref($dtd) && ref($dtd) eq 'ARRAY') {
push(@result,qq(<!DOCTYPE html\n\tPUBLIC "$dtd->[0]"\n\t"$dtd->[1]">));
} else {
{ # If it is, push a LINK tag for each one.
foreach $src (@$src)
{
- push(@result,qq/<link rel="stylesheet" type="$type" href="$src">/) if $src;
+ push(@result,$XHTML ? qq(<link rel="stylesheet" type="$type" href="$src" />)
+ : qq(<link rel="stylesheet" type="$type" href="$src">/)) if $src;
}
}
else
{ # Otherwise, push the single -src, if it exists.
- push(@result,qq/<link rel="stylesheet" type="$type" href="$src">/) if $src;
+ push(@result,$XHTML ? qq(<link rel="stylesheet" type="$type" href="$src" />)
+ : qq(<link rel="stylesheet" type="$type" href="$src">)
+ ) if $src;
}
push(@result,style({'type'=>$type},"$cdata_start\n$code\n$cdata_end")) if $code;
} else {
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;
$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
$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;
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) {
my($checkit) = $checked eq $_ ? qq/ checked/ : '';
my($break);
if ($linebreak) {
- $break = $XHTML ? "<br />" : "<br>";
+ $break = $XHTML ? "<br />" : "<br>";
}
else {
- $break = '';
+ $break = '';
}
my($label)='';
unless (defined($nolabels) && $nolabels) {
$name=$self->escapeHTML($name);
foreach (@value) {
$_ = defined($_) ? $self->escapeHTML($_,1) : '';
- push @result,$XHTMl ? qq(<input type="hidden" name="$name" value="$_" />)
+ push @result,$XHTML ? qq(<input type="hidden" name="$name" value="$_" />)
: qq(<input type="hidden" name="$name" value="$_">);
}
return wantarray ? @result : join('',@result);
}
# 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);
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".
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;
@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
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;
}
the <HTML> 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 <HEAD> section with the
B<-head> tag. For example, to place the rarely-used <LINK> element in the
And here's how to create an HTTP-EQUIV <META> 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>,
=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 <ed@fidalgo.net>. To
import these into your namespace, you must import the ":push" set.
#!/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<multipart_init()>.
-It then enters an infinite loop in which it begins a new multipart
-section by calling B<multipart_start()>, prints the current local time,
+It then enters a loop in which it begins a new multipart section by
+calling B<multipart_start()>, prints the current local time,
and ends a multipart section with B<multipart_end()>. It then sleeps
-a second, and begins again.
+a second, and begins again. On the final iteration, it ends the
+multipart section with B<multipart_final()> rather than with
+B<multipart_end()>.
=over 4
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
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"
# 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,
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 {
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));
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 );
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;
}
(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);
\@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 = \$_;
# 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
# 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');
# 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;
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
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
B<If not specified, -delay will default to 1 second>
-=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
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
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
=head1 INSTALLING CGI::Push SCRIPTS
-Server push scripts B<must> 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.
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 {
}
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<CGI>
+
+=cut
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';
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 <<END,"start_html()");
+<?xml version="1.0" encoding="utf-8"?>
<!DOCTYPE html
- PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
- "DTD/xhtml1-transitional.dtd">
+ PUBLIC "-//W3C//DTD XHTML Basic 1.0//EN"
+ "http://www.w3.org/TR/xhtml-basic/xhtml-basic10.dtd">
<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US"><head><title>Untitled Document</title>
</head><body>
END
END
;
test(15,start_html(-Title=>'The world of foo') ."\n" eq <<END,"start_html()");
+<?xml version="1.0" encoding="utf-8"?>
<!DOCTYPE html
- PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
- "DTD/xhtml1-transitional.dtd">
+ PUBLIC "-//W3C//DTD XHTML Basic 1.0//EN"
+ "http://www.w3.org/TR/xhtml-basic/xhtml-basic10.dtd">
<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US"><head><title>The world of foo</title>
</head><body>
END
projects / p5sagit/p5-mst-13.2.git / commitdiff