《../CGI.pm》檔案內容

View 《../CGI.pm》

package CGI;
require 5.001;
$AUTOLOAD_DEBUG=0;
$NPH=0;
$CGI::revision = '$Id: CGI.pm,v 2.30 1997/1/01 12:12 lstein Exp $';
$CGI::VERSION='2.30';
unless ($OS) {
    unless ($OS = $^O) {
	require Config;
	$OS = $Config::Config{'osname'};
    }
}
if ($OS=~/Win/i) {
    $OS = 'WINDOWS';
} elsif ($OS=~/vms/i) {
    $OS = 'VMS';
} elsif ($OS=~/Mac/i) {
    $OS = 'MACINTOSH';
} else {
    $OS = 'UNIX';
}
$needs_binmode = $OS=~/^(WINDOWS|VMS)/;
$DefaultClass = 'CGI' unless defined $CGI::DefaultClass;
$SL = {
    UNIX=>'/',
    WINDOWS=>'\\',
    MACINTOSH=>':',
    VMS=>'\\'
    }->{$OS};
$NPH++ if $ENV{'SERVER_SOFTWARE'}=~/IIS/;
$CRLF = "\015\012";
if ($needs_binmode) {
    $CGI::DefaultClass->binmode(main::STDOUT);
    $CGI::DefaultClass->binmode(main::STDIN);
    $CGI::DefaultClass->binmode(main::STDERR);
}
%OVERLOAD = ('""'=>'as_string');
%EXPORT_TAGS = (
	      ':html2'=>[h1..h6,qw/p br hr ol ul li dl dt dd menu code var strong em
			 tt i b blockquote pre img a address cite samp dfn html head
			 base body link nextid title meta kbd start_html end_html
			 input Select option/],
	      ':html3'=>[qw/div table caption th td TR Tr super sub strike applet PARAM embed basefont/],
	      ':netscape'=>[qw/blink frameset frame script font fontsize center/],
	      ':form'=>[qw/textfield textarea filefield password_field hidden checkbox checkbox_group 
		       submit reset defaults radio_group popup_menu button autoEscape
		       scrolling_list image_button start_form end_form startform endform
		       start_multipart_form isindex tmpFileName URL_ENCODED MULTIPART/],
	      ':cgi'=>[qw/param path_info path_translated url self_url script_name cookie 
		       raw_cookie request_method query_string accept user_agent remote_host 
		       remote_addr referer server_name server_software server_port server_protocol
		       virtual_host remote_ident auth_type http
		       remote_user user_name header redirect import_names put/],
	      ':ssl' => [qw/https/],
	      ':cgi-lib' => [qw/ReadParse PrintHeader HtmlTop HtmlBot SplitParam/],
	      ':html' => [qw/:html2 :html3 :netscape/],
	      ':standard' => [qw/:html2 :form :cgi/],
	      ':all' => [qw/:html2 :html3 :netscape :form :cgi/]
	 );
sub import {
    my $self = shift;
    my ($callpack, $callfile, $callline) = caller;
    foreach (@_) {
	$NPH++, next if $_ eq ':nph';
	foreach (&expand_tags($_)) {
	    tr/a-zA-Z0-9_//cd;  
	    $EXPORT{$_}++;
	}
    }
    my @packages = ($self,@{"$self\:\:ISA"});
    foreach $sym (keys %EXPORT) {
	my $pck;
	my $def = $DefaultClass;
	foreach $pck (@packages) {
	    if (defined(&{"$pck\:\:$sym"})) {
		$def = $pck;
		last;
	    }
	}
	*{"${callpack}::$sym"} = \&{"$def\:\:$sym"};
    }
}
sub expand_tags {
    my($tag) = @_;
    my(@r);
    return ($tag) unless $EXPORT_TAGS{$tag};
    foreach (@{$EXPORT_TAGS{$tag}}) {
	push(@r,&expand_tags($_));
    }
    return @r;
}
sub new {
    my($class,$initializer) = @_;
    my $self = {};
    bless $self,ref $class || $class || $DefaultClass;
    $initializer = to_filehandle($initializer) if $initializer;
    $self->init($initializer);
    return $self;
}
sub DESTROY { }
sub param {
    my($self,@p) = self_or_default(@_);
    return $self->all_parameters unless @p;
    my($name,$value,@other);
    if (@p > 1) {
	($name,$value,@other) = $self->rearrange([NAME,[DEFAULT,VALUE,VALUES]],@p);
	my(@values);
	if (substr($p[0],0,1) eq '-' || $self->use_named_parameters) {
	    @values = defined($value) ? (ref($value) && ref($value) eq 'ARRAY' ? @{$value} : $value) : ();
	} else {
	    foreach ($value,@other) {
		push(@values,$_) if defined($_);
	    }
	}
	if (@values) {
	    $self->add_parameter($name);
	    $self->{$name}=[@values];
	}
    } else {
	$name = $p[0];
    }
    return () unless defined($name) && $self->{$name};
    return wantarray ? @{$self->{$name}} : $self->{$name}->[0];
}
sub delete {
    my($self,$name) = self_or_default(@_);
    delete $self->{$name};
    delete $self->{'.fieldnames'}->{$name};
    @{$self->{'.parameters'}}=grep($_ ne $name,$self->param());
    return wantarray ? () : undef;
}
sub self_or_default {
    return @_ if defined($_[0]) && !ref($_[0]) && ($_[0] eq 'CGI');
    unless (defined($_[0]) && 
	    ref($_[0]) &&
	    (ref($_[0]) eq 'CGI' ||
	     eval "\$_[0]->isaCGI()")) { 
	$Q = $CGI::DefaultClass->new unless defined($Q);
	unshift(@_,$Q);
    }
    return @_;
}
sub self_or_CGI {
    local $^W=0;                
    if (defined($_[0]) &&
	(substr(ref($_[0]),0,3) eq 'CGI' 
	 || eval "\$_[0]->isaCGI()")) {
	return @_;
    } else {
	return ($DefaultClass,@_);
    }
}
sub isaCGI {
    return 1;
}
sub import_names {
    my($self,$namespace) = self_or_default(@_);
    $namespace = 'Q' unless defined($namespace);
    die "Can't import names into 'main'\n"
	if $namespace eq 'main';
    my($param,@value,$var);
    foreach $param ($self->param) {
	($var = $param)=~tr/a-zA-Z0-9_/_/c;
	$var = "${namespace}::$var";
	@value = $self->param($param);
	@{$var} = @value;
	${$var} = $value[0];
    }
}
sub use_named_parameters {
    my($self,$use_named) = self_or_default(@_);
    return $self->{'.named'} unless defined ($use_named);
    return $self->{'.named'}=$use_named;
}
sub init {
    my($self,$initializer) = @_;
    my($query_string,@lines);
    my($meth) = '';
    if (defined(@QUERY_PARAM) && !defined($initializer)) {
	foreach (@QUERY_PARAM) {
	    $self->param('-name'=>$_,'-value'=>$QUERY_PARAM{$_});
	}
	return;
    }
    $meth=$ENV{'REQUEST_METHOD'} if defined($ENV{'REQUEST_METHOD'});
  METHOD: {
      if (defined($initializer)) {
	  if (ref($initializer) && ref($initializer) eq 'HASH') {
	      foreach (keys %$initializer) {
		  $self->param('-name'=>$_,'-value'=>$initializer->{$_});
	      }
	      last METHOD;
	  }
	  $initializer = $$initializer if ref($initializer);
	  if (defined(fileno($initializer))) {
	      while (<$initializer>) {
		  chomp;
		  last if /^=/;
		  push(@lines,$_);
	      }
	      if ("@lines" =~ /=/) {
		  $query_string=join("&",@lines);
	      } else {
		  $query_string=join("+",@lines);
	      }
	      last METHOD;
	  }
	  $query_string = $initializer;
	  last METHOD;
      }
      if ($meth=~/^(GET|HEAD)$/) {
	$query_string = $ENV{'QUERY_STRING'};
	last METHOD;
    }
      if ($meth eq 'POST') {
	  if ($ENV{'CONTENT_TYPE'}=~m|^multipart/form-data|) {
	      my($boundary) = $ENV{'CONTENT_TYPE'}=~/boundary=(\S+)/;
	      $self->read_multipart($boundary,$ENV{'CONTENT_LENGTH'});
	  } else {
	      $self->read_from_client(\*STDIN,\$query_string,$ENV{'CONTENT_LENGTH'},0)
		  if $ENV{'CONTENT_LENGTH'} > 0;
	  }
	  last METHOD;
      }
      $query_string = &read_from_cmdline;
  }
    if ($query_string) {
	if ($query_string =~ /=/) {
	    $self->parse_params($query_string);
	} else {
	    $self->add_parameter('keywords');
	    $self->{'keywords'} = [$self->parse_keywordlist($query_string)];
	}
    }
    if ($self->param('.defaults')) {
	undef %{$self};
    }
    $self->{'.fieldnames'} = {};
    foreach ($self->param('.cgifields')) {
	$self->{'.fieldnames'}->{$_}++;
    }
    $self->delete('.submit');
    $self->delete('.cgifields');
    $self->save_request unless $initializer;
}
sub to_filehandle {
    my $string = shift;
    if ($string && !ref($string)) {
	my($package) = caller(1);
	my($tmp) = $string=~/[':]/ ? $string : "$package\:\:$string"; 
	return $tmp if defined(fileno($tmp));
    }
    return $string;
}
sub new_MultipartBuffer {
    my($self,$boundary,$length,$filehandle) = @_;
    return MultipartBuffer->new($self,$boundary,$length,$filehandle);
}
sub read_from_client {
    my($self, $fh, $buff, $len, $offset) = @_;
    local $^W=0;                
    return read($fh, $$buff, $len, $offset);
}
sub binmode {
    binmode($_[1]);
}
sub put {
    my($self,@p) = self_or_default(@_);
    $self->print(@p);
}
sub print {
    shift;
    CORE::print(@_);
}
sub unescape {
    my($todecode) = @_;
    $todecode =~ tr/+/ /;       
    $todecode =~ s/%([0-9a-fA-F]{2})/pack("c",hex($1))/ge;
    return $todecode;
}
sub escape {
    my($toencode) = @_;
    $toencode=~s/([^a-zA-Z0-9_\-.])/uc sprintf("%%%02x",ord($1))/eg;
    return $toencode;
}
sub save_request {
    my($self) = @_;
    @QUERY_PARAM = $self->param; 
    foreach (@QUERY_PARAM) {
	$QUERY_PARAM{$_}=$self->{$_};
    }
}
sub parse_keywordlist {
    my($self,$tosplit) = @_;
    $tosplit = &unescape($tosplit); 
    $tosplit=~tr/+/ /;          
    my(@keywords) = split(/\s+/,$tosplit);
    return @keywords;
}
sub parse_params {
    my($self,$tosplit) = @_;
    my(@pairs) = split('&',$tosplit);
    my($param,$value);
    foreach (@pairs) {
	($param,$value) = split('=');
	$param = &unescape($param);
	$value = &unescape($value);
	$self->add_parameter($param);
	push (@{$self->{$param}},$value);
    }
}
sub add_parameter {
    my($self,$param)=@_;
    push (@{$self->{'.parameters'}},$param) 
	unless defined($self->{$param});
}
sub all_parameters {
    my $self = shift;
    return () unless defined($self) && $self->{'.parameters'};
    return () unless @{$self->{'.parameters'}};
    return @{$self->{'.parameters'}};
}
sub as_string {
    &dump(@_);
}
AUTOLOAD {
    print STDERR "CGI::AUTOLOAD for $AUTOLOAD\n" if $CGI::AUTOLOAD_DEBUG;
    my($func) = $AUTOLOAD;
    my($pack,$func_name) = $func=~/(.+)::([^:]+)$/;
    $pack = $CGI::DefaultClass
	unless defined(${"$pack\:\:AUTOLOADED_ROUTINES"});
    my($sub) = \%{"$pack\:\:SUBS"};
    unless (%$sub) {
	my($auto) = \${"$pack\:\:AUTOLOADED_ROUTINES"};
	eval "package $pack; $$auto";
	die $@ if $@;
    }
    my($code)= $sub->{$func_name};
    $code = "sub $AUTOLOAD { }" if (!$code and $func_name eq 'DESTROY');
    if (!$code) {
	if ($EXPORT{':any'} || 
	    $EXPORT{$func_name} || 
	    (%EXPORT_OK || grep(++$EXPORT_OK{$_},&expand_tags(':html')))
	    && $EXPORT_OK{$func_name}) {
	    $code = $sub->{'HTML_FUNC'};
	    $code=~s/func_name/$func_name/mg;
	}
    }
    die "Undefined subroutine $AUTOLOAD" unless $code;
    eval "package $pack; $code";
    if ($@) {
	$@ =~ s/ at .*\n//;
	die $@;
    }
    goto &{"$pack\:\:$func_name"};
}
$AUTOLOADED_ROUTINES = '';      
$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
%SUBS = (
'URL_ENCODED'=> <<'END_OF_FUNC',
sub URL_ENCODED { 'application/x-www-form-urlencoded'; }
END_OF_FUNC
'MULTIPART' => <<'END_OF_FUNC',
sub MULTIPART {  'multipart/form-data'; }
END_OF_FUNC
'HTML_FUNC' => <<'END_OF_FUNC',
sub func_name { 
    shift if $_[0] && 
	(!ref($_[0]) && $_[0] eq $CGI::DefaultClass) ||
	    (ref($_[0]) &&
	     (substr(ref($_[0]),0,3) eq 'CGI' ||
	      eval "\$_[0]->isaCGI()"));
    my($attr) = '';
    if (ref($_[0]) && ref($_[0]) eq 'HASH') {
	my(@attr) = CGI::make_attributes('',shift);
	$attr = " @attr" if @attr;
    }
    my($tag,$untag) = ("\U<func_name\E$attr>","\U</func_name>\E");
    return $tag unless @_;
    if (ref($_[0]) eq 'ARRAY') {
	my(@r);
	foreach (@{$_[0]}) {
	    push(@r,"$tag$_$untag");
	}
	return "@r";
    } else {
	return "$tag@_$untag";
    }
}
END_OF_FUNC
'keywords' => <<'END_OF_FUNC',
sub keywords {
    my($self,@values) = self_or_default(@_);
    $self->{'keywords'}=[@values] if @values;
    my(@result) = @{$self->{'keywords'}};
    @result;
}
END_OF_FUNC
'ReadParse' => <<'END_OF_FUNC',
sub ReadParse {
    local(*in);
    if (@_) {
	*in = $_[0];
    } else {
	my $pkg = caller();
	*in=*{"${pkg}::in"};
    }
    tie(%in,CGI);
}
END_OF_FUNC
'PrintHeader' => <<'END_OF_FUNC',
sub PrintHeader {
    my($self) = self_or_default(@_);
    return $self->header();
}
END_OF_FUNC
'HtmlTop' => <<'END_OF_FUNC',
sub HtmlTop {
    my($self,@p) = self_or_default(@_);
    return $self->start_html(@p);
}
END_OF_FUNC
'HtmlBot' => <<'END_OF_FUNC',
sub HtmlBot {
    my($self,@p) = self_or_default(@_);
    return $self->end_html(@p);
}
END_OF_FUNC
'SplitParam' => <<'END_OF_FUNC',
sub SplitParam {
    my ($param) = @_;
    my (@params) = split ("\0", $param);
    return (wantarray ? @params : $params[0]);
}
END_OF_FUNC
'MethGet' => <<'END_OF_FUNC',
sub MethGet {
    return request_method() eq 'GET';
}
END_OF_FUNC
'MethPost' => <<'END_OF_FUNC',
sub MethPost {
    return request_method() eq 'POST';
}
END_OF_FUNC
'TIEHASH' => <<'END_OF_FUNC',
sub TIEHASH { 
    return new CGI;
}
END_OF_FUNC
'STORE' => <<'END_OF_FUNC',
sub STORE {
    $_[0]->param($_[1],split("\0",$_[2]));
}
END_OF_FUNC
'FETCH' => <<'END_OF_FUNC',
sub FETCH {
    return $_[0] if $_[1] eq 'CGI';
    return undef unless defined $_[0]->param($_[1]);
    return join("\0",$_[0]->param($_[1]));
}
END_OF_FUNC
'FIRSTKEY' => <<'END_OF_FUNC',
sub FIRSTKEY {
    $_[0]->{'.iterator'}=0;
    $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++];
}
END_OF_FUNC
'NEXTKEY' => <<'END_OF_FUNC',
sub NEXTKEY {
    $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++];
}
END_OF_FUNC
'EXISTS' => <<'END_OF_FUNC',
sub EXISTS {
    exists $_[0]->{$_[1]};
}
END_OF_FUNC
'DELETE' => <<'END_OF_FUNC',
sub DELETE {
    $_[0]->delete($_[1]);
}
END_OF_FUNC
'CLEAR' => <<'END_OF_FUNC',
sub CLEAR {
    %{$_[0]}=();
}
END_OF_FUNC
'append' => <<'EOF',
sub append {
    my($self,@p) = @_;
    my($name,$value) = $self->rearrange([NAME,[VALUE,VALUES]],@p);
    my(@values) = defined($value) ? (ref($value) ? @{$value} : $value) : ();
    if (@values) {
	$self->add_parameter($name);
	push(@{$self->{$name}},@values);
    }
    return $self->param($name);
}
EOF
'delete_all' => <<'EOF',
sub delete_all {
    my($self) = self_or_default(@_);
    undef %{$self};
}
EOF
'autoEscape' => <<'END_OF_FUNC',
sub autoEscape {
    my($self,$escape) = self_or_default(@_);
    $self->{'dontescape'}=!$escape;
}
END_OF_FUNC
'version' => <<'END_OF_FUNC',
sub version {
    return $VERSION;
}
END_OF_FUNC
'make_attributes' => <<'END_OF_FUNC',
sub make_attributes {
    my($self,$attr) = @_;
    return () unless $attr && ref($attr) && ref($attr) eq 'HASH';
    my(@att);
    foreach (keys %{$attr}) {
	my($key) = $_;
	$key=~s/^\-//;     
	$key=~tr/a-z/A-Z/; 
	push(@att,$attr->{$_} ne '' ? qq/$key="$attr->{$_}"/ : qq/$key/);
    }
    return @att;
}
END_OF_FUNC
'dump' => <<'END_OF_FUNC',
sub dump {
    my($self) = @_;
    my($param,$value,@result);
    return '<UL></UL>' unless $self->param;
    push(@result,"<UL>");
    foreach $param ($self->param) {
	my($name)=$self->escapeHTML($param);
	push(@result,"<LI><STRONG>$param</STRONG>");
	push(@result,"<UL>");
	foreach $value ($self->param($param)) {
	    $value = $self->escapeHTML($value);
	    push(@result,"<LI>$value");
	}
	push(@result,"</UL>");
    }
    push(@result,"</UL>\n");
    return join("\n",@result);
}
END_OF_FUNC
'save' => <<'END_OF_FUNC',
sub save {
    my($self,$filehandle) = self_or_default(@_);
    my($param);
    my($package) = caller;
    $filehandle = $filehandle=~/[':]/ ? $filehandle : "$package\:\:$filehandle";
    foreach $param ($self->param) {
	my($escaped_param) = &escape($param);
	my($value);
	foreach $value ($self->param($param)) {
	    print $filehandle "$escaped_param=",escape($value),"\n";
	}
    }
    print $filehandle "=\n";    
}
END_OF_FUNC
'header' => <<'END_OF_FUNC',
sub header {
    my($self,@p) = self_or_default(@_);
    my(@header);
    my($type,$status,$cookie,$target,$expires,$nph,@other) = 
	$self->rearrange([TYPE,STATUS,[COOKIE,COOKIES],TARGET,EXPIRES,NPH],@p);
    foreach (@other) {
	next unless my($header,$value) = /([^\s=]+)=(.+)/;
	substr($header,1,1000)=~tr/A-Z/a-z/;
	($value)=$value=~/^"(.*)"$/;
	$_ = "$header: $value";
    }
    $type = $type || 'text/html';
    push(@header,'HTTP/1.0 ' . ($status || '200 OK')) if $nph || $NPH;
    push(@header,"Status: $status") if $status;
    push(@header,"Window-target: $target") if $target;
    if ($cookie) {
	my(@cookie) = ref($cookie) ? @{$cookie} : $cookie;
	foreach (@cookie) {
	    push(@header,"Set-cookie: $_");
	}
    }
    push(@header,"Expires: " . &expires($expires)) if $expires;
    push(@header,"Pragma: no-cache") if $self->cache();
    push(@header,@other);
    push(@header,"Content-type: $type");
    my $header = join($CRLF,@header);
    return $header . "${CRLF}${CRLF}";
}
END_OF_FUNC
'cache' => <<'END_OF_FUNC',
sub cache {
    my($self,$new_value) = self_or_default(@_);
    $new_value = '' unless $new_value;
    if ($new_value ne '') {
	$self->{'cache'} = $new_value;
    }
    return $self->{'cache'};
}
END_OF_FUNC
'redirect' => <<'END_OF_FUNC',
sub redirect {
    my($self,@p) = self_or_default(@_);
    my($url,$target,$cookie,$nph,@other) = $self->rearrange([[URI,URL],TARGET,COOKIE,NPH],@p);
    $url = $url || $self->self_url;
    my(@o);
    foreach (@other) { push(@o,split("=")); }
    push(@o,
	 '-Status'=>'302 Found',
	 '-Location'=>$url,
	 '-URI'=>$url,
	 '-nph'=>($nph||$NPH));
    push(@o,'-Target'=>$target) if $target;
    push(@o,'-Cookie'=>$cookie) if $cookie;
    return $self->header(@o);
}
END_OF_FUNC
'start_html' => <<'END_OF_FUNC',
sub start_html {
    my($self,@p) = &self_or_default(@_);
    my($title,$author,$base,$xbase,$script,$meta,@other) = 
	$self->rearrange([TITLE,AUTHOR,BASE,XBASE,SCRIPT,META],@p);
    $title = $self->escapeHTML($title || 'Untitled Document');
    $author = $self->escapeHTML($author);
    my(@result);
    push(@result,'<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML//EN">');
    push(@result,"<HTML><HEAD><TITLE>$title</TITLE>");
    push(@result,"<LINK REV=MADE HREF=\"mailto:$author\">") if $author;
    push(@result,"<BASE HREF=\"http://".$self->server_name.":".$self->server_port.$self->script_name."\">")
	if $base && !$xbase;
    push(@result,"<BASE HREF=\"$xbase\">") if $xbase;
    if ($meta && ref($meta) && (ref($meta) eq 'HASH')) {
	foreach (keys %$meta) { push(@result,qq(<META NAME="$_" CONTENT="$meta->{$_}">)); }
    }
    push(@result,<<END) if $script;
<SCRIPT>

</SCRIPT>
END
    ;
    my($other) = @other ? " @other" : '';
    push(@result,"</HEAD><BODY$other>");
    return join("\n",@result);
}
END_OF_FUNC
'end_html' => <<'END_OF_FUNC',
sub end_html {
    return "</BODY></HTML>";
}
END_OF_FUNC
'isindex' => <<'END_OF_FUNC',
sub isindex {
    my($self,@p) = self_or_default(@_);
    my($action,@other) = $self->rearrange([ACTION],@p);
    $action = qq/ACTION="$action"/ if $action;
    my($other) = @other ? " @other" : '';
    return "<ISINDEX $action$other>";
}
END_OF_FUNC
'startform' => <<'END_OF_FUNC',
sub startform {
    my($self,@p) = self_or_default(@_);
    my($method,$action,$enctype,@other) = 
	$self->rearrange([METHOD,ACTION,ENCTYPE],@p);
    $method = $method || 'POST';
    $enctype = $enctype || &URL_ENCODED;
    $action = $action ? qq/ACTION="$action"/ : $method eq 'GET' ?
	'ACTION="'.$self->script_name.'"' : '';
    my($other) = @other ? " @other" : '';
    $self->{'.parametersToAdd'}={};
    return qq/<FORM METHOD="$method" $action ENCTYPE="$enctype"$other>\n/;
}
END_OF_FUNC
'start_form' => <<'END_OF_FUNC',
sub start_form {
    &startform(@_);
}
END_OF_FUNC
'start_multipart_form' => <<'END_OF_FUNC',
sub start_multipart_form {
    my($self,@p) = self_or_default(@_);
    if ($self->use_named_parameters || 
	(defined($param[0]) && substr($param[0],0,1) eq '-')) {
	my(%p) = @p;
	$p{'-enctype'}=&MULTIPART;
	return $self->startform(%p);
    } else {
	my($method,$action,@other) = 
	    $self->rearrange([METHOD,ACTION],@p);
	return $self->startform($method,$action,&MULTIPART,@other);
    }
}
END_OF_FUNC
'endform' => <<'END_OF_FUNC',
sub endform {
    my($self,@p) = self_or_default(@_);    
    return ($self->get_fields,"</FORM>");
}
END_OF_FUNC
'end_form' => <<'END_OF_FUNC',
sub end_form {
    &endform(@_);
}
END_OF_FUNC
'textfield' => <<'END_OF_FUNC',
sub textfield {
    my($self,@p) = self_or_default(@_);
    my($name,$default,$size,$maxlength,$override,@other) = 
	$self->rearrange([NAME,[DEFAULT,VALUE],SIZE,MAXLENGTH,[OVERRIDE,FORCE]],@p);
    my $current = $override ? $default : 
	(defined($self->param($name)) ? $self->param($name) : $default);
    $current = defined($current) ? $self->escapeHTML($current) : '';
    $name = defined($name) ? $self->escapeHTML($name) : '';
    my($s) = defined($size) ? qq/ SIZE=$size/ : '';
    my($m) = defined($maxlength) ? qq/ MAXLENGTH=$maxlength/ : '';
    my($other) = @other ? " @other" : '';    
    return qq/<INPUT TYPE="text" NAME="$name" VALUE="$current"$s$m$other>/;
}
END_OF_FUNC
'filefield' => <<'END_OF_FUNC',
sub filefield {
    my($self,@p) = self_or_default(@_);
    my($name,$default,$size,$maxlength,$override,@other) = 
	$self->rearrange([NAME,[DEFAULT,VALUE],SIZE,MAXLENGTH,[OVERRIDE,FORCE]],@p);
    $current = $override ? $default :
	(defined($self->param($name)) ? $self->param($name) : $default);
    $name = defined($name) ? $self->escapeHTML($name) : '';
    my($s) = defined($size) ? qq/ SIZE=$size/ : '';
    my($m) = defined($maxlength) ? qq/ MAXLENGTH=$maxlength/ : '';
    $current = defined($current) ? $self->escapeHTML($current) : '';
    $other = ' ' . join(" ",@other);
    return qq/<INPUT TYPE="file" NAME="$name" VALUE="$current"$s$m$other>/;
}
END_OF_FUNC
'password_field' => <<'END_OF_FUNC',
sub password_field {
    my ($self,@p) = self_or_default(@_);
    my($name,$default,$size,$maxlength,$override,@other) = 
	$self->rearrange([NAME,[DEFAULT,VALUE],SIZE,MAXLENGTH,[OVERRIDE,FORCE]],@p);
    my($current) =  $override ? $default :
	(defined($self->param($name)) ? $self->param($name) : $default);
    $name = defined($name) ? $self->escapeHTML($name) : '';
    $current = defined($current) ? $self->escapeHTML($current) : '';
    my($s) = defined($size) ? qq/ SIZE=$size/ : '';
    my($m) = defined($maxlength) ? qq/ MAXLENGTH=$maxlength/ : '';
    my($other) = @other ? " @other" : '';
    return qq/<INPUT TYPE="password" NAME="$name" VALUE="$current"$s$m$other>/;
}
END_OF_FUNC
'textarea' => <<'END_OF_FUNC',
sub textarea {
    my($self,@p) = self_or_default(@_);
    my($name,$default,$rows,$cols,$override,@other) =
	$self->rearrange([NAME,[DEFAULT,VALUE],ROWS,[COLS,COLUMNS],[OVERRIDE,FORCE]],@p);
    my($current)= $override ? $default :
	(defined($self->param($name)) ? $self->param($name) : $default);
    $name = defined($name) ? $self->escapeHTML($name) : '';
    $current = defined($current) ? $self->escapeHTML($current) : '';
    my($r) = $rows ? " ROWS=$rows" : '';
    my($c) = $cols ? " COLS=$cols" : '';
    my($other) = @other ? " @other" : '';
    return qq{<TEXTAREA NAME="$name"$r$c$other>$current

}; } END_OF_FUNC 'button' => <<'END_OF_FUNC', sub button { my($self,@p) = self_or_default(@_); my($label,$value,$script,@other) = $self->rearrange([NAME,[VALUE,LABEL], [ONCLICK,SCRIPT]],@p); $label=$self->escapeHTML($label); $value=$self->escapeHTML($value); $script=$self->escapeHTML($script); my($name) = ''; $name = qq/ NAME="$label"/ if $label; $value = $value || $label; my($val) = ''; $val = qq/ VALUE="$value"/ if $value; $script = qq/ ONCLICK="$script"/ if $script; my($other) = @other ? " @other" : ''; return qq//; } END_OF_FUNC 'submit' => <<'END_OF_FUNC', sub submit { my($self,@p) = self_or_default(@_); my($label,$value,@other) = $self->rearrange([NAME,[VALUE,LABEL]],@p); $label=$self->escapeHTML($label); $value=$self->escapeHTML($value); my($name) = ' NAME=".submit"'; $name = qq/ NAME="$label"/ if $label; $value = $value || $label; my($val) = ''; $val = qq/ VALUE="$value"/ if defined($value); my($other) = @other ? " @other" : ''; return qq//; } END_OF_FUNC 'reset' => <<'END_OF_FUNC', sub reset { my($self,@p) = self_or_default(@_); my($label,@other) = $self->rearrange([NAME],@p); $label=$self->escapeHTML($label); my($value) = defined($label) ? qq/ VALUE="$label"/ : ''; my($other) = @other ? " @other" : ''; return qq//; } END_OF_FUNC 'defaults' => <<'END_OF_FUNC', sub defaults { my($self,@p) = self_or_default(@_); my($label,@other) = $self->rearrange([[NAME,VALUE]],@p); $label=$self->escapeHTML($label); $label = $label || "Defaults"; my($value) = qq/ VALUE="$label"/; my($other) = @other ? " @other" : ''; return qq//; } END_OF_FUNC 'checkbox' => <<'END_OF_FUNC', sub checkbox { my($self,@p) = self_or_default(@_); my($name,$checked,$value,$label,$override,@other) = $self->rearrange([NAME,[CHECKED,SELECTED,ON],VALUE,LABEL,[OVERRIDE,FORCE]],@p); if (!$override && defined($self->param($name))) { $value = $self->param($name) unless defined $value; $checked = $self->param($name) eq $value ? ' CHECKED' : ''; } else { $checked = $checked ? ' CHECKED' : ''; $value = defined $value ? $value : 'on'; } my($the_label) = defined $label ? $label : $name; $name = $self->escapeHTML($name); $value = $self->escapeHTML($value); $the_label = $self->escapeHTML($the_label); my($other) = @other ? " @other" : ''; $self->register_parameter($name); return <$the_label END } END_OF_FUNC 'checkbox_group' => <<'END_OF_FUNC', sub checkbox_group { my($self,@p) = self_or_default(@_); my($name,$values,$defaults,$linebreak,$labels,$rows,$columns, $rowheaders,$colheaders,$override,$nolabels,@other) = $self->rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT], LINEBREAK,LABELS,ROWS,[COLUMNS,COLS], ROWHEADERS,COLHEADERS, [OVERRIDE,FORCE],NOLABELS],@p); my($checked,$break,$result,$label); my(%checked) = $self->previous_or_default($name,$defaults,$override); $break = $linebreak ? "
" : ''; $name=$self->escapeHTML($name); my(@elements); my(@values) = $values ? @$values : $self->param($name); my($other) = @other ? " @other" : ''; foreach (@values) { $checked = $checked{$_} ? ' CHECKED' : ''; $label = ''; unless (defined($nolabels) && $nolabels) { $label = $_; $label = $labels->{$_} if defined($labels) && $labels->{$_}; $label = $self->escapeHTML($label); } $_ = $self->escapeHTML($_); push(@elements,qq/${label} ${break}/); } $self->register_parameter($name); return wantarray ? @elements : join('',@elements) unless $columns; return _tableize($rows,$columns,$rowheaders,$colheaders,@elements); } END_OF_FUNC 'escapeHTML' => <<'END_OF_FUNC', sub escapeHTML { my($self,$toencode) = @_; return undef unless defined($toencode); return $toencode if $self->{'dontescape'}; $toencode=~s/&/&/g; $toencode=~s/\"/"/g; $toencode=~s/>/>/g; $toencode=~s/ <<'END_OF_FUNC', sub _tableize { my($rows,$columns,$rowheaders,$colheaders,@elements) = @_; my($result); $rows = int(0.99 + @elements/$columns) unless $rows; $result = ""; my($row,$column); unshift(@$colheaders,'') if @$colheaders && @$rowheaders; $result .= "" if @{$colheaders}; foreach (@{$colheaders}) { $result .= ""; } for ($row=0;$row<$rows;$row++) { $result .= ""; $result .= "" if @$rowheaders; for ($column=0;$column<$columns;$column++) { $result .= ""; } $result .= ""; } $result .= "

$_
$rowheaders->[$row]	" . $elements[$column*$rows + $row] . "

"; return $result; } END_OF_FUNC 'radio_group' => <<'END_OF_FUNC', sub radio_group { my($self,@p) = self_or_default(@_); my($name,$values,$default,$linebreak,$labels, $rows,$columns,$rowheaders,$colheaders,$override,$nolabels,@other) = $self->rearrange([NAME,[VALUES,VALUE],DEFAULT,LINEBREAK,LABELS, ROWS,[COLUMNS,COLS], ROWHEADERS,COLHEADERS, [OVERRIDE,FORCE],NOLABELS],@p); my($result,$checked); if (!$override && defined($self->param($name))) { $checked = $self->param($name); } else { $checked = $default; } $checked = $values->[0] unless defined($checked) && $checked ne ''; $name=$self->escapeHTML($name); my(@elements); my(@values) = $values ? @$values : $self->param($name); my($other) = @other ? " @other" : ''; foreach (@values) { my($checkit) = $checked eq $_ ? ' CHECKED' : ''; my($break) = $linebreak ? '
' : ''; my($label)=''; unless (defined($nolabels) && $nolabels) { $label = $_; $label = $labels->{$_} if defined($labels) && $labels->{$_}; $label = $self->escapeHTML($label); } $_=$self->escapeHTML($_); push(@elements,qq/${label} ${break}/); } $self->register_parameter($name); return wantarray ? @elements : join('',@elements) unless $columns; return _tableize($rows,$columns,$rowheaders,$colheaders,@elements); } END_OF_FUNC 'popup_menu' => <<'END_OF_FUNC', sub popup_menu { my($self,@p) = self_or_default(@_); my($name,$values,$default,$labels,$override,@other) = $self->rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LABELS,[OVERRIDE,FORCE]],@p); my($result,$selected); if (!$override && defined($self->param($name))) { $selected = $self->param($name); } else { $selected = $default; } $name=$self->escapeHTML($name); my($other) = @other ? " @other" : ''; my(@values) = $values ? @$values : $self->param($name); $result = qq/\n"; return $result; } END_OF_FUNC 'scrolling_list' => <<'END_OF_FUNC', sub scrolling_list { my($self,@p) = self_or_default(@_); my($name,$values,$defaults,$size,$multiple,$labels,$override,@other) = $self->rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT], SIZE,MULTIPLE,LABELS,[OVERRIDE,FORCE]],@p); my($result); my(@values) = $values ? @$values : $self->param($name); $size = $size || scalar(@values); my(%selected) = $self->previous_or_default($name,$defaults,$override); my($is_multiple) = $multiple ? ' MULTIPLE' : ''; my($has_size) = $size ? " SIZE=$size" : ''; my($other) = @other ? " @other" : ''; $name=$self->escapeHTML($name); $result = qq/\n"; $self->register_parameter($name); return $result; } END_OF_FUNC 'hidden' => <<'END_OF_FUNC', sub hidden { my($self,@p) = self_or_default(@_); my(@result,@value); my($name,$default,$override,@other) = $self->rearrange([NAME,[DEFAULT,VALUE,VALUES],[OVERRIDE,FORCE]],@p); my $do_override = 0; if ( substr($p[0],0,1) eq '-' || $self->use_named_parameters ) { @value = ref($default) ? @{$default} : $default; $do_override = $override; } else { foreach ($default,$override,@other) { push(@value,$_) if defined($_); } } my @prev = $self->param($name); @value = @prev if !$do_override && @prev; $name=$self->escapeHTML($name); foreach (@value) { $_=$self->escapeHTML($_); push(@result,qq//); } return wantarray ? @result : join('',@result); } END_OF_FUNC 'image_button' => <<'END_OF_FUNC', sub image_button { my($self,@p) = self_or_default(@_); my($name,$src,$alignment,@other) = $self->rearrange([NAME,SRC,ALIGN],@p); my($align) = $alignment ? " ALIGN=\U$alignment" : ''; my($other) = @other ? " @other" : ''; $name=$self->escapeHTML($name); return qq//; } END_OF_FUNC 'self_url' => <<'END_OF_FUNC', sub self_url { my($self) = self_or_default(@_); my($query_string) = $self->query_string; my $protocol = $self->protocol(); my $name = "$protocol://" . $self->server_name; $name .= ":" . $self->server_port unless $self->server_port == 80; $name .= $self->script_name; $name .= $self->path_info if $self->path_info; return $name unless $query_string; return "$name?$query_string"; } END_OF_FUNC 'state' => <<'END_OF_FUNC', sub state { &self_url; } END_OF_FUNC 'url' => <<'END_OF_FUNC', sub url { my($self) = self_or_default(@_); my $protocol = $self->protocol(); my $name = "$protocol://" . $self->server_name; $name .= ":" . $self->server_port unless $self->server_port == 80; $name .= $self->script_name; return $name; } END_OF_FUNC 'cookie' => <<'END_OF_FUNC', sub cookie { my($self,@p) = self_or_default(@_); my($name,$value,$path,$domain,$secure,$expires) = $self->rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES],@p); unless (defined($value)) { unless ($self->{'.cookies'}) { my(@pairs) = split("; ",$self->raw_cookie); foreach (@pairs) { my($key,$value) = split("="); my(@values) = map unescape($_),split('&',$value); $self->{'.cookies'}->{unescape($key)} = [@values]; } } return wantarray ? @{$self->{'.cookies'}->{$name}} : $self->{'.cookies'}->{$name}->[0]; } my(@values); if (ref($value)) { if (ref($value) eq 'ARRAY') { @values = @$value; } elsif (ref($value) eq 'HASH') { @values = %$value; } } else { @values = ($value); } @values = map escape($_),@values; my(@constant_values); push(@constant_values,"domain=$domain") if $domain; push(@constant_values,"path=$path") if $path; push(@constant_values,"expires=".&expires($expires)) if $expires; push(@constant_values,'secure') if $secure; my($key) = &escape($name); my($cookie) = join("=",$key,join("&",@values)); return join("; ",$cookie,@constant_values); } END_OF_FUNC 'expires' => <<'END_OF_FUNC', sub expires { my($time) = @_; my(@MON)=qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/; my(@WDAY) = qw/Sunday Monday Tuesday Wednesday Thursday Friday Saturday/; my(%mult) = ('s'=>1, 'm'=>60, 'h'=>60*60, 'd'=>60*60*24, 'M'=>60*60*24*30, 'y'=>60*60*24*365); my($offset); if (!$time || ($time eq 'now')) { $offset = 0; } elsif ($time=~/^([+-]?\d+)([mhdMy]?)/) { $offset = ($mult{$2} || 1)*$1; } else { return $time; } my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime(time+$offset); $year += 1900 unless $year < 100; return sprintf("%s, %02d-%s-%02d %02d:%02d:%02d GMT", $WDAY[$wday],$mday,$MON[$mon],$year,$hour,$min,$sec); } END_OF_FUNC 'path_info' => <<'END_OF_FUNC', sub path_info { return $ENV{'PATH_INFO'}; } END_OF_FUNC 'request_method' => <<'END_OF_FUNC', sub request_method { return $ENV{'REQUEST_METHOD'}; } END_OF_FUNC 'path_translated' => <<'END_OF_FUNC', sub path_translated { return $ENV{'PATH_TRANSLATED'}; } END_OF_FUNC 'query_string' => <<'END_OF_FUNC', sub query_string { my($self) = self_or_default(@_); my($param,$value,@pairs); foreach $param ($self->param) { my($eparam) = &escape($param); foreach $value ($self->param($param)) { $value = &escape($value); push(@pairs,"$eparam=$value"); } } return join("&",@pairs); } END_OF_FUNC 'accept' => <<'END_OF_FUNC', sub accept { my($self,$search) = self_or_CGI(@_); my(%prefs,$type,$pref,$pat); my(@accept) = split(',',$self->http('accept')); foreach (@accept) { ($pref) = /q=(\d\.\d+|\d+)/; ($type) = m next unless $type; $prefs{$type}=$pref || 1; } return keys %prefs unless $search; return $prefs{$search} if $prefs{$search}; foreach (keys %prefs) { next unless /\*/; ($pat = $_) =~ s/([^\w*])/\\$1/g; $pat =~ s/\*/.*/g; return $prefs{$_} if $search=~/$pat/; } } END_OF_FUNC 'user_agent' => <<'END_OF_FUNC', sub user_agent { my($self,$match)=self_or_CGI(@_); return $self->http('user_agent') unless $match; return $self->http('user_agent') =~ /$match/i; } END_OF_FUNC 'raw_cookie' => <<'END_OF_FUNC', sub raw_cookie { my($self) = self_or_CGI(@_); return $self->http('cookie') || ''; } END_OF_FUNC 'virtual_host' => <<'END_OF_FUNC', sub virtual_host { return http('host') || server_name(); } END_OF_FUNC 'remote_host' => <<'END_OF_FUNC', sub remote_host { return $ENV{'REMOTE_HOST'} || $ENV{'REMOTE_ADDR'} || 'localhost'; } END_OF_FUNC 'remote_addr' => <<'END_OF_FUNC', sub remote_addr { return $ENV{'REMOTE_ADDR'} || '127.0.0.1'; } END_OF_FUNC 'script_name' => <<'END_OF_FUNC', sub script_name { return $ENV{'SCRIPT_NAME'} if $ENV{'SCRIPT_NAME'}; return "/$0" unless $0=~/^\//; return $0; } END_OF_FUNC 'referer' => <<'END_OF_FUNC', sub referer { my($self) = self_or_CGI(@_); return $self->http('referer'); } END_OF_FUNC 'server_name' => <<'END_OF_FUNC', sub server_name { return $ENV{'SERVER_NAME'} || 'localhost'; } END_OF_FUNC 'server_software' => <<'END_OF_FUNC', sub server_software { return $ENV{'SERVER_SOFTWARE'} || 'cmdline'; } END_OF_FUNC 'server_port' => <<'END_OF_FUNC', sub server_port { return $ENV{'SERVER_PORT'} || 80; } END_OF_FUNC 'server_protocol' => <<'END_OF_FUNC', sub server_protocol { return $ENV{'SERVER_PROTOCOL'} || 'HTTP/1.0'; } END_OF_FUNC 'http' => <<'END_OF_FUNC', sub http { my ($self,$parameter) = self_or_CGI(@_); return $ENV{$parameter} if $parameter=~/^HTTP/; return $ENV{"HTTP_\U$parameter\E"} if $parameter; my(@p); foreach (keys %ENV) { push(@p,$_) if /^HTTP/; } return @p; } END_OF_FUNC '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/; return $ENV{"HTTPS_\U$parameter\E"} if $parameter; my(@p); foreach (keys %ENV) { push(@p,$_) if /^HTTPS/; } return @p; } END_OF_FUNC 'protocol' => <<'END_OF_FUNC', sub protocol { local($^W)=0; my $self = shift; return 'https' if $self->https() eq 'ON'; return 'https' if $self->server_port == 443; my $prot = $self->server_protocol; my($protocol,$version) = split('/',$prot); return "\L$protocol\E"; } END_OF_FUNC 'remote_ident' => <<'END_OF_FUNC', sub remote_ident { return $ENV{'REMOTE_IDENT'}; } END_OF_FUNC 'auth_type' => <<'END_OF_FUNC', sub auth_type { return $ENV{'AUTH_TYPE'}; } END_OF_FUNC 'remote_user' => <<'END_OF_FUNC', sub remote_user { return $ENV{'REMOTE_USER'}; } END_OF_FUNC 'user_name' => <<'END_OF_FUNC', sub user_name { my ($self) = self_or_CGI(@_); return $self->http('from') || $ENV{'REMOTE_IDENT'} || $ENV{'REMOTE_USER'}; } END_OF_FUNC 'nph' => <<'END_OF_FUNC', sub nph { my ($self,$param) = self_or_CGI(@_); $CGI::nph = $param if defined($param); return $CGI::nph; } END_OF_FUNC 'rearrange' => <<'END_OF_FUNC', sub rearrange { my($self,$order,@param) = @_; return () unless @param; return @param unless (defined($param[0]) && substr($param[0],0,1) eq '-') || $self->use_named_parameters; my $i; for ($i=0;$i<@param;$i+=2) { $param[$i]=~s/^\-//; $param[$i]=~tr/a-z/A-Z/; } my(%param) = @param; my(@return_array); my($key)=''; foreach $key (@$order) { my($value); if (ref($key) && ref($key) eq 'ARRAY') { foreach (@$key) { last if defined($value); $value = $param{$_}; delete $param{$_}; } } else { $value = $param{$key}; delete $param{$key}; } push(@return_array,$value); } push (@return_array,$self->make_attributes(\%param)) if %param; return (@return_array); } END_OF_FUNC 'previous_or_default' => <<'END_OF_FUNC', sub previous_or_default { my($self,$name,$defaults,$override) = @_; my(%selected); if (!$override && ($self->{'.fieldnames'}->{$name} || defined($self->param($name)) ) ) { grep($selected{$_}++,$self->param($name)); } elsif (defined($defaults) && ref($defaults) && (ref($defaults) eq 'ARRAY')) { grep($selected{$_}++,@{$defaults}); } else { $selected{$defaults}++ if defined($defaults); } return %selected; } END_OF_FUNC 'register_parameter' => <<'END_OF_FUNC', sub register_parameter { my($self,$param) = @_; $self->{'.parametersToAdd'}->{$param}++; } END_OF_FUNC 'get_fields' => <<'END_OF_FUNC', sub get_fields { my($self) = @_; return $self->hidden('-name'=>'.cgifields', '-values'=>[keys %{$self->{'.parametersToAdd'}}], '-override'=>1); } END_OF_FUNC 'read_from_cmdline' => <<'END_OF_FUNC', sub read_from_cmdline { require "shellwords.pl"; my($input,@words); my($query_string); if (@ARGV) { $input = join(" ",@ARGV); } else { print STDERR "(offline mode: enter name=value pairs on standard input)\n"; chomp(@lines = <>); $input = join(" ",@lines); } $input=~s/\\=/%3D/g; $input=~s/\\&/%26/g; @words = &shellwords($input); if ("@words"=~/=/) { $query_string = join('&',@words); } else { $query_string = join('+',@words); } return $query_string; } END_OF_FUNC 'read_multipart' => <<'END_OF_FUNC', sub read_multipart { my($self,$boundary,$length) = @_; my($buffer) = $self->new_MultipartBuffer($boundary,$length); return unless $buffer; my(%header,$body); while (!$buffer->eof) { %header = $buffer->readHeader; my($key) = $header{'Content-disposition'} ? 'Content-disposition' : 'Content-Disposition'; my($param)= $header{$key}=~/ name="([^\"]*)"/; my($filename) = $header{$key}=~/ filename="(.*)"$/; $self->add_parameter($param); unless ($filename) { my($value) = $buffer->readBody; push(@{$self->{$param}},$value); next; } my($tmpfile) = new TempFile; open (OUT,">$tmpfile") || die "CGI open of $tmpfile: $!\n"; $CGI::DefaultClass->binmode(OUT) if $CGI::needs_binmode; chmod 0666,$tmpfile; my $data; while ($data = $buffer->read) { print OUT $data; } close OUT; my($filehandle); if ($filename=~/^[a-zA-Z_]/) { my($frame,$cp)=(1); do { $cp = caller($frame++); } until !eval("$cp->isaCGI()"); $filehandle = "$cp\:\:$filename"; } else { $filehandle = "\:\:$filename"; } open($filehandle,$tmpfile) || die "CGI open of $tmpfile: $!\n"; $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode; push(@{$self->{$param}},$filename); $self->{'.tmpfiles'}->{$filename}=$tmpfile; } } END_OF_FUNC 'tmpFileName' => <<'END_OF_FUNC' sub tmpFileName { my($self,$filename) = self_or_default(@_); return $self->{'.tmpfiles'}->{$filename}; } END_OF_FUNC ); END_OF_AUTOLOAD ; package MultipartBuffer; $FILLUNIT = 1024 * 5; $TIMEOUT = 10*60; $SPIN_LOOP_MAX = 1000; $CRLF=$CGI::CRLF; *MultipartBuffer::AUTOLOAD = \&CGI::AUTOLOAD; $AUTOLOADED_ROUTINES = ''; $AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD'; %SUBS = ( 'new' => <<'END_OF_FUNC', sub new { my($package,$interface,$boundary,$length,$filehandle) = @_; my $IN; if ($filehandle) { my($package) = caller; $IN = $filehandle=~/[':]/ ? $filehandle : "$package\:\:$filehandle"; } $IN = "main::STDIN" unless $IN; $CGI::DefaultClass->binmode($IN) if $CGI::needs_binmode; if ($boundary) { $boundary = "--$boundary"; my($null) = ''; $length -= $interface->read_from_client($IN,\$null,length($boundary)+2,0); } else { my($old); ($old,$/) = ($/,$CRLF); $boundary = <$IN>; $length -= length($boundary); chomp($boundary); $/ = $old; } my $self = {LENGTH=>$length, BOUNDARY=>$boundary, IN=>$IN, INTERFACE=>$interface, BUFFER=>'', }; $FILLUNIT = length($boundary) if length($boundary) > $FILLUNIT; return bless $self,ref $package || $package; } END_OF_FUNC 'readHeader' => <<'END_OF_FUNC', sub readHeader { my($self) = @_; my($end); my($ok) = 0; do { $self->fillBuffer($FILLUNIT); $ok++ if ($end = index($self->{BUFFER},"${CRLF}${CRLF}")) >= 0; $ok++ if $self->{BUFFER} eq ''; $FILLUNIT *= 2 if length($self->{BUFFER}) >= $FILLUNIT; } until $ok; my($header) = substr($self->{BUFFER},0,$end+2); substr($self->{BUFFER},0,$end+4) = ''; my %return; while ($header=~/^([\w-]+): (.*)$CRLF/mog) { $return{$1}=$2; } return %return; } END_OF_FUNC 'readBody' => <<'END_OF_FUNC', sub readBody { my($self) = @_; my($data); my($returnval)=''; while (defined($data = $self->read)) { $returnval .= $data; } return $returnval; } END_OF_FUNC 'read' => <<'END_OF_FUNC', sub read { my($self,$bytes) = @_; $bytes = $bytes || $FILLUNIT; $self->fillBuffer($bytes); my $start = index($self->{BUFFER},$self->{BOUNDARY}); if ($start == 0) { if (index($self->{BUFFER},"$self->{BOUNDARY}--")==0) { $self->{BUFFER}=''; $self->{LENGTH}=0; return undef; } substr($self->{BUFFER},0,length($self->{BOUNDARY})+2)=''; return undef; } my $bytesToReturn; if ($start > 0) { $bytesToReturn = $start > $bytes ? $bytes : $start; } else { $bytesToReturn = $bytes - (length($self->{BOUNDARY})+1); } my $returnval=substr($self->{BUFFER},0,$bytesToReturn); substr($self->{BUFFER},0,$bytesToReturn)=''; return ($start > 0) ? substr($returnval,0,-2) : $returnval; } END_OF_FUNC 'fillBuffer' => <<'END_OF_FUNC', sub fillBuffer { my($self,$bytes) = @_; return unless $self->{LENGTH}; my($boundaryLength) = length($self->{BOUNDARY}); my($bufferLength) = length($self->{BUFFER}); my($bytesToRead) = $bytes - $bufferLength + $boundaryLength + 2; $bytesToRead = $self->{LENGTH} if $self->{LENGTH} < $bytesToRead; my $bytesRead = $self->{INTERFACE}->read_from_client($self->{IN}, \$self->{BUFFER}, $bytesToRead, $bufferLength); if ($bytesRead == 0) { die "CGI.pm: Server closed socket during multipart read (client aborted?).\n" if ($self->{ZERO_LOOP_COUNTER}++ >= $SPIN_LOOP_MAX); } else { $self->{ZERO_LOOP_COUNTER}=0; } $self->{LENGTH} -= $bytesRead; } END_OF_FUNC 'eof' => <<'END_OF_FUNC' sub eof { my($self) = @_; return 1 if (length($self->{BUFFER}) == 0) && ($self->{LENGTH} <= 0); } END_OF_FUNC ); END_OF_AUTOLOAD package TempFile; $SL = $CGI::SL; unless ($TMPDIRECTORY) { @TEMP=("${SL}usr${SL}tmp","${SL}var${SL}tmp","${SL}tmp","${SL}temp","${SL}Temporary Items"); foreach (@TEMP) { do {$TMPDIRECTORY = $_; last} if -d $_ && -w _; } } $TMPDIRECTORY = "." unless $TMPDIRECTORY; $SEQUENCE="CGItemp$$0000"; %OVERLOAD = ('""'=>'as_string'); *TempFile::AUTOLOAD = \&CGI::AUTOLOAD; sub as_string { my($self) = @_; return $$self; } $AUTOLOADED_ROUTINES = ''; $AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD'; %SUBS = ( 'new' => <<'END_OF_FUNC', sub new { my($package) = @_; $SEQUENCE++; my $directory = "${TMPDIRECTORY}${SL}${SEQUENCE}"; return bless \$directory; } END_OF_FUNC 'DESTROY' => <<'END_OF_FUNC' sub DESTROY { my($self) = @_; unlink $$self; } END_OF_FUNC ); END_OF_AUTOLOAD package CGI; if ($^W) { $CGI::CGI = ''; $CGI::CGI=<