CGI
view release on metacpan or search on metacpan
}
}
%EXPORT_TAGS = (
':html2' => [ 'h1' .. 'h6', qw/
p br hr ol ul li dl dt dd menu code var strong em
tt u 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 comment charset escapeHTML
/ ],
':html3' => [ qw/
div table caption th td TR Tr sup Sub strike applet Param nobr
embed basefont style span layer ilayer font frameset frame script small big Area Map
/ ],
':html4' => [ qw/
abbr acronym bdo col colgroup del fieldset iframe
ins label legend noframes noscript object optgroup Q
thead tbody tfoot
/ ],
':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
start_multipart_form end_multipart_form isindex tmpFileName uploadInfo URL_ENCODED MULTIPART
/ ],
':cgi' => [ qw/
param multi_param upload path_info path_translated request_uri url self_url script_name
cookie Dump raw_cookie request_method query_string Accept user_agent remote_host content_type
remote_addr referer server_name server_software server_port server_protocol virtual_port
virtual_host remote_ident auth_type http append save_parameters restore_parameters param_fetch
remote_user user_name header redirect import_names put Delete Delete_all url_param cgi_error env_query_string
/ ],
':netscape' => [qw/blink fontsize center/],
':ssl' => [qw/https/],
':cgi-lib' => [qw/ReadParse PrintHeader HtmlTop HtmlBot SplitParam Vars/],
':push' => [qw/multipart_init multipart_start multipart_end multipart_final/],
# bulk export/import
':html' => [qw/:html2 :html3 :html4 :netscape/],
':standard' => [qw/:html2 :html3 :html4 :form :cgi :ssl/],
':all' => [qw/:html2 :html3 :html4 :netscape :form :cgi :ssl :push/]
);
# to import symbols into caller
sub import {
my $self = shift;
# This causes modules to clash.
undef %EXPORT_OK;
undef %EXPORT;
$self->_setup_symbols(@_);
my ($callpack, $callfile, $callline) = caller;
if ( $callpack eq 'CGI::Fast' ) {
# fixes GH #11 (and GH #12 in CGI::Fast since
# sub import was added to CGI::Fast in 9537f90
# so we need to move up a level to export the
# routines to the namespace of whatever is using
# CGI::Fast
($callpack, $callfile, $callline) = caller(1);
}
# To allow overriding, search through the packages
# Till we find one in which the correct subroutine is defined.
my @packages = ($self,@{"$self\:\:ISA"});
for $sym (sort keys %EXPORT) {
my $pck;
my $def = $DefaultClass;
for $pck (@packages) {
if (defined(&{"$pck\:\:$sym"})) {
$def = $pck;
last;
}
}
*{"${callpack}::$sym"} = \&{"$def\:\:$sym"};
}
}
sub expand_tags {
my($tag) = @_;
return ("start_$1","end_$1") if $tag=~/^(?:\*|start_|end_)(.+)/;
my(@r);
return ($tag) unless $EXPORT_TAGS{$tag};
for (@{$EXPORT_TAGS{$tag}}) {
push(@r,&expand_tags($_));
}
return @r;
}
#### Method: new
# The new routine. This will check the current environment
# for an existing query string, and initialize itself, if so.
####
sub new {
my($class,@initializer) = @_;
my $self = {};
bless $self,ref $class || $class || $DefaultClass;
# always use a tempfile
$self->{'use_tempfile'} = 1;
if (ref($initializer[0])
&& (UNIVERSAL::isa($initializer[0],'Apache')
||
UNIVERSAL::isa($initializer[0],'Apache2::RequestRec')
)) {
$self->r(shift @initializer);
}
if (ref($initializer[0])
&& (UNIVERSAL::isa($initializer[0],'CODE'))) {
$self->upload_hook(shift @initializer, shift @initializer);
$self->{'use_tempfile'} = shift @initializer if (@initializer > 0);
}
if ($MOD_PERL) {
if ($MOD_PERL == 1) {
$self->r(Apache->request) unless $self->r;
my $r = $self->r;
$r->register_cleanup(\&CGI::_reset_globals);
$self->_setup_symbols(@SAVED_SYMBOLS) if @SAVED_SYMBOLS;
# Special case. Erase everything if there is a field named
# .defaults.
if ($self->param('.defaults')) {
$self->delete_all();
}
# hash containing our defined fieldnames
$self->{'.fieldnames'} = {};
for ($self->param('.cgifields')) {
$self->{'.fieldnames'}->{$_}++;
}
# Clear out our default submission button flag if present
$self->delete('.submit');
$self->delete('.cgifields');
$self->save_request unless defined $initializer;
}
sub _get_query_string_from_env {
my $self = shift;
my $query_string = '';
if ( $MOD_PERL ) {
$query_string = $self->r->args;
if ( ! $query_string && $MOD_PERL == 2 ) {
# possibly a redirect, inspect prev request
# (->prev only supported under mod_perl2)
if ( my $prev = $self->r->prev ) {
$query_string = $prev->args;
}
}
}
$query_string ||= $ENV{'QUERY_STRING'}
if defined $ENV{'QUERY_STRING'};
if ( ! $query_string ) {
# try to get from REDIRECT_ env variables, support
# 5 levels of redirect and no more (RT #36312)
REDIRECT: foreach my $r ( 1 .. 5 ) {
my $key = join( '',( 'REDIRECT_' x $r ) );
$query_string ||= $ENV{"${key}QUERY_STRING"}
if defined $ENV{"${key}QUERY_STRING"};
last REDIRECT if $query_string;
}
}
return $query_string;
}
# FUNCTIONS TO OVERRIDE:
# Turn a string into a filehandle
sub to_filehandle {
my $thingy = shift;
return undef unless $thingy;
return $thingy if UNIVERSAL::isa($thingy,'GLOB');
return $thingy if UNIVERSAL::isa($thingy,'FileHandle');
if (!ref($thingy)) {
my $caller = 1;
while (my $package = caller($caller++)) {
my($tmp) = $thingy=~/[\':]/ ? $thingy : "$package\:\:$thingy";
return $tmp if defined(fileno($tmp));
}
}
return undef;
}
# send output to the browser
sub put {
my($self,@p) = self_or_default(@_);
$self->print(@p);
}
# print to standard output (for overriding in mod_perl)
sub print {
shift;
CORE::print(@_);
}
# get/set last cgi_error
sub cgi_error {
my ($self,$err) = self_or_default(@_);
$self->{'.cgi_error'} = $err if defined $err;
return $self->{'.cgi_error'};
}
sub save_request {
my($self) = @_;
# We're going to play with the package globals now so that if we get called
# again, we initialize ourselves in exactly the same way. This allows
# us to have several of these objects.
@QUERY_PARAM = $self->param; # save list of parameters
for (@QUERY_PARAM) {
next unless defined $_;
$QUERY_PARAM{$_}=$self->{param}{$_};
}
$QUERY_CHARSET = $self->charset;
%QUERY_FIELDNAMES = %{$self->{'.fieldnames'}};
%QUERY_TMPFILES = %{ $self->{'.tmpfiles'} || {} };
}
sub parse_params {
my($self,$tosplit) = @_;
my(@pairs) = split(/[&;]/,$tosplit);
my($param,$value);
for (@pairs) {
($param,$value) = split('=',$_,2);
next unless defined $param;
next if $NO_UNDEF_PARAMS and not defined $value;
$value = '' unless defined $value;
$param = unescape($param);
$value = unescape($value);
$self->add_parameter($param);
push (@{$self->{param}{$param}},$value);
}
}
sub add_parameter {
my($self,$param)=@_;
return unless defined $param;
#### Method: import_names
# Import all parameters into the given namespace.
# Assumes namespace 'Q' if not specified
####
sub import_names {
my($self,$namespace,$delete) = self_or_default(@_);
$namespace = 'Q' unless defined($namespace);
die "Can't import names into \"main\"\n" if \%{"${namespace}::"} == \%::;
if ($delete || $MOD_PERL || exists $ENV{'FCGI_ROLE'}) {
# can anyone find an easier way to do this?
for (sort keys %{"${namespace}::"}) {
local *symbol = "${namespace}::${_}";
undef $symbol;
undef @symbol;
undef %symbol;
}
}
my($param,@value,$var);
for $param ($self->param) {
# protect against silly names
($var = $param)=~tr/a-zA-Z0-9_/_/c;
$var =~ s/^(?=\d)/_/;
local *symbol = "${namespace}::$var";
@value = $self->param($param);
@symbol = @value;
$symbol = $value[0];
}
}
#### Method: keywords
# Keywords acts a bit differently. Calling it in a list context
# returns the list of keywords.
# Calling it in a scalar context gives you the size of the list.
####
sub keywords {
my($self,@values) = self_or_default(@_);
# If values is provided, then we set it.
$self->{param}{'keywords'}=[@values] if @values;
my(@result) = defined($self->{param}{'keywords'}) ? @{$self->{param}{'keywords'}} : ();
@result;
}
# These are some tie() interfaces for compatibility
# with Steve Brenner's cgi-lib.pl routines
sub Vars {
my $q = shift;
my %in;
tie(%in,CGI,$q);
return %in if wantarray;
return \%in;
}
# These are some tie() interfaces for compatibility
# with Steve Brenner's cgi-lib.pl routines
sub ReadParse {
local(*in);
if (@_) {
*in = $_[0];
} else {
my $pkg = caller();
*in=*{"${pkg}::in"};
}
tie(%in,CGI);
return scalar(keys %in);
}
sub PrintHeader {
my($self) = self_or_default(@_);
return $self->header();
}
sub HtmlTop {
my($self,@p) = self_or_default(@_);
return $self->start_html(@p);
}
sub HtmlBot {
my($self,@p) = self_or_default(@_);
return $self->end_html(@p);
}
sub SplitParam {
my ($param) = @_;
my (@params) = split ("\0", $param);
return (wantarray ? @params : $params[0]);
}
sub MethGet {
return request_method() eq 'GET';
}
sub MethPatch {
return request_method() eq 'PATCH';
}
sub MethPost {
return request_method() eq 'POST';
}
sub MethPut {
return request_method() eq 'PUT';
}
sub TIEHASH {
my $class = shift;
my $arg = $_[0];
if (ref($arg) && UNIVERSAL::isa($arg,'CGI')) {
return $arg;
}
return $Q ||= $class->new(@_);
}
sub STORE {
my $self = shift;
my $tag = shift;
my $vals = shift;
my @vals = defined($vals) && index($vals,"\0")!=-1 ? split("\0",$vals) : $vals;
$self->param(-name=>$tag,-value=>\@vals);
}
( run in 1.399 second using v1.01-cache-2.11-cpan-ad19def0cd9 )