CGI
view release on metacpan or search on metacpan
$type = $type || 'text/html';
if ($charset) {
push(@header,"Content-Type: $type; charset=$charset");
} else {
push(@header,"Content-Type: $type");
}
# rearrange() was designed for the HTML portion, so we
# need to fix it up a little.
for (@other) {
# Don't use \s because of perl bug 21951
next unless my($header,$value) = /([^ \r\n\t=]+)=\"?(.+?)\"?$/;
($_ = $header) =~ s/^(\w)(.*)/$1 . lc ($2) . ': '.$self->unescapeHTML($value)/e;
}
push(@header,@other);
my $header = join($CRLF,@header)."${CRLF}${CRLF}";
return $header;
}
#### Method: multipart_end
# Return a MIME boundary separator for server-push, end of section
#
# Many thanks to Ed Jordan <ed@fidalgo.net> for this
# contribution
####
sub multipart_end {
my($self,@p) = self_or_default(@_);
return $self->{'separator'};
}
#### Method: multipart_final
# Return a MIME boundary separator for server-push, end of all sections
#
# Contributed by Andrew Benham (adsb@bigfoot.com)
####
sub multipart_final {
my($self,@p) = self_or_default(@_);
return $self->{'final_separator'} . "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY." . $CRLF;
}
#### Method: header
# Return a Content-Type: style header
#
####
sub header {
my($self,@p) = self_or_default(@_);
my(@header);
return "" if $self->{'.header_printed'}++ and $HEADERS_ONCE;
my($type,$status,$cookie,$target,$expires,$nph,$charset,$attachment,$p3p,@other) =
rearrange([['TYPE','CONTENT_TYPE','CONTENT-TYPE'],
'STATUS',['COOKIE','COOKIES','SET-COOKIE'],'TARGET',
'EXPIRES','NPH','CHARSET',
'ATTACHMENT','P3P'],@p);
# Since $cookie and $p3p may be array references,
# we must stringify them before CR escaping is done.
my @cookie;
for (ref($cookie) eq 'ARRAY' ? @{$cookie} : $cookie) {
my $cs = UNIVERSAL::isa($_,'CGI::Cookie') ? $_->as_string : $_;
push(@cookie,$cs) if defined $cs and $cs ne '';
}
$p3p = join ' ',@$p3p if ref($p3p) eq 'ARRAY';
# CR escaping for values, per RFC 822
for my $header ($type,$status,@cookie,$target,$expires,$nph,$charset,$attachment,$p3p,@other) {
if (defined $header) {
# From RFC 822:
# Unfolding is accomplished by regarding CRLF immediately
# followed by a LWSP-char as equivalent to the LWSP-char.
$header =~ s/$CRLF(\s)/$1/g;
# All other uses of newlines are invalid input.
if ($header =~ m/$CRLF|\015|\012/) {
# shorten very long values in the diagnostic
$header = substr($header,0,72).'...' if (length $header > 72);
die "Invalid header value contains a newline not followed by whitespace: $header";
}
}
}
$nph ||= $NPH;
$type ||= 'text/html' unless defined($type);
# sets if $charset is given, gets if not
$charset = $self->charset( $charset );
# rearrange() was designed for the HTML portion, so we
# need to fix it up a little.
for (@other) {
# Don't use \s because of perl bug 21951
next unless my($header,$value) = /([^ \r\n\t=]+)=\"?(.+?)\"?$/s;
($_ = $header) =~ s/^(\w)(.*)/"\u$1\L$2" . ': '.$self->unescapeHTML($value)/e;
}
$type .= "; charset=$charset"
if $type ne ''
and $type !~ /\bcharset\b/
and defined $charset
and $charset ne '';
# 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;
push(@header,"P3P: policyref=\"/w3c/p3p.xml\", CP=\"$p3p\"") if $p3p;
# push all the cookies -- there may be several
push(@header,map {"Set-Cookie: $_"} @cookie);
# if the user indicates an expiration time, then we need
# both an Expires and a Date header (so that the browser is
# uses OUR clock)
push(@header,"Expires: " . expires($expires))
if $expires;
push(@header,"Date: " . expires(0)) if $expires || $cookie || $nph;
push(@header,"Pragma: no-cache") if $self->cache();
push(@header,"Content-Disposition: attachment; filename=\"$attachment\"") if $attachment;
push(@header,map {ucfirst $_} @other);
push(@header,"Content-Type: $type") if $type ne '';
my $header = join($CRLF,@header)."${CRLF}${CRLF}";
if (($MOD_PERL >= 1) && !$nph) {
$self->r->send_cgi_header($header);
return '';
}
return $header;
}
#### Method: cache
# Control whether header() will produce the no-cache
# Pragma directive.
####
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'};
}
#### Method: redirect
# Return a Location: style header
#
####
sub redirect {
my($self,@p) = self_or_default(@_);
my($url,$target,$status,$cookie,$nph,@other) =
rearrange([[LOCATION,URI,URL],TARGET,STATUS,['COOKIE','COOKIES','SET-COOKIE'],NPH],@p);
$status = '302 Found' unless defined $status;
$url ||= $self->self_url;
my(@o);
for (@other) { tr/\"//d; push(@o,split("=",$_,2)); }
unshift(@o,
'-Status' => $status,
'-Location'=> $url,
'-nph' => $nph);
unshift(@o,'-Target'=>$target) if $target;
unshift(@o,'-Type'=>'');
my @unescaped;
unshift(@unescaped,'-Cookie'=>$cookie) if $cookie;
return $self->header((map {$self->unescapeHTML($_)} @o),@unescaped);
}
#### Method: start_html
# Canned HTML header
#
# Parameters:
# $title -> (optional) The title for this HTML document (-title)
# $author -> (optional) e-mail address of the author (-author)
# $base -> (optional) if set to true, will enter the BASE address of this document
# for resolving relative references (-base)
# $xbase -> (optional) alternative base at some remote location (-xbase)
# $target -> (optional) target window to load all links into (-target)
# $script -> (option) Javascript code (-script)
# $no_script -> (option) Javascript <noscript> tag (-noscript)
# $meta -> (optional) Meta information tags
# $head -> (optional) any other elements you'd like to incorporate into the <head> tag
# (a scalar or array ref)
# $style -> (optional) reference to an external style sheet
# @other -> (optional) any other named parameters you'd like to incorporate into
# the <body> tag.
####
sub start_html {
my($self,@p) = &self_or_default(@_);
my($title,$author,$base,$xbase,$script,$noscript,
$target,$meta,$head,$style,$dtd,$lang,$encoding,$declare_xml,@other) =
rearrange([TITLE,AUTHOR,BASE,XBASE,SCRIPT,NOSCRIPT,TARGET,
META,HEAD,STYLE,DTD,LANG,ENCODING,DECLARE_XML],@p);
$self->element_id(0);
$self->element_tab(0);
$encoding = lc($self->charset) unless defined $encoding;
# Need to sort out the DTD before it's okay to call escapeHTML().
my(@result,$xml_dtd);
if ($dtd) {
if (defined(ref($dtd)) and (ref($dtd) eq 'ARRAY')) {
$dtd = $DEFAULT_DTD unless $dtd->[0] =~ m|^-//|;
} else {
$dtd = $DEFAULT_DTD unless $dtd =~ 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,qq(<?xml version="1.0" encoding="$encoding"?>) if $xml_dtd && $declare_xml;
if (ref($dtd) && ref($dtd) eq 'ARRAY') {
push(@result,qq(<!DOCTYPE html\n\tPUBLIC "$dtd->[0]"\n\t "$dtd->[1]">));
$DTD_PUBLIC_IDENTIFIER = $dtd->[0];
} else {
push(@result,qq(<!DOCTYPE html\n\tPUBLIC "$dtd">));
$DTD_PUBLIC_IDENTIFIER = $dtd;
}
# Now that we know whether we're using the HTML 3.2 DTD or not, it's okay to
# call escapeHTML(). Strangely enough, the title needs to be escaped as
my $script_name = $self->script_name;
my $request_uri = $self->request_uri || '';
my $query_str = $query ? $self->query_string : '';
$script_name =~ s/\?.*$//s; # remove query string
$request_uri =~ s/\?.*$//s; # remove query string
$request_uri = unescape($request_uri);
my $uri = $rewrite && $request_uri ? $request_uri : $script_name;
if ( defined( $ENV{PATH_INFO} ) ) {
# IIS sometimes sets PATH_INFO to the same value as SCRIPT_NAME so only sub it out
# if SCRIPT_NAME isn't defined or isn't the same value as PATH_INFO
$uri =~ s/\Q$ENV{PATH_INFO}\E$//
if ( ! defined( $ENV{SCRIPT_NAME} ) or $ENV{PATH_INFO} ne $ENV{SCRIPT_NAME} );
# if we're not IIS then keep to spec, the relevant info is here:
# https://tools.ietf.org/html/rfc3875#section-4.1.13, namely
# "No PATH_INFO segment (see section 4.1.5) is included in the
# SCRIPT_NAME value." (see GH #126, GH #152, GH #176)
if ( ! $IIS ) {
$uri =~ s/\Q$ENV{PATH_INFO}\E$//;
}
}
if ($full) {
my $protocol = $self->protocol();
$url = "$protocol://";
my $vh = http('x_forwarded_host') || http('host') || '';
$vh =~ s/^.*,\s*//; # x_forwarded_host may be a comma-separated list (e.g. when the request has
# passed through multiple reverse proxies. Take the last one.
$vh =~ s/\:\d+$//; # some clients add the port number (incorrectly). Get rid of it.
$url .= $vh || server_name();
my $port = $self->virtual_port;
# add the port to the url unless it's the protocol's default port
$url .= ':' . $port unless (lc($protocol) eq 'http' && $port == 80)
or (lc($protocol) eq 'https' && $port == 443);
return $url if $base;
$url .= $uri;
} elsif ($relative) {
($url) = $uri =~ m!([^/]+)$!;
} elsif ($absolute) {
$url = $uri;
}
$url .= $path if $path_info and defined $path;
$url .= "?$query_str" if $query and $query_str ne '';
$url ||= '';
$url = URI->new( $url )->canonical->as_string;
return $url
}
#### Method: cookie
# Set or read a cookie from the specified name.
# Cookie can then be passed to header().
# Usual rules apply to the stickiness of -value.
# Parameters:
# -name -> name for this cookie (optional)
# -value -> value of this cookie (scalar, array or hash)
# -path -> paths for which this cookie is valid (optional)
# -domain -> internet domain in which this cookie is valid (optional)
# -secure -> if true, cookie only passed through secure channel (optional)
# -expires -> expiry date in format Wdy, DD Mon YYYY HH:MM:SS GMT (optional)
####
sub cookie {
my($self,@p) = self_or_default(@_);
my($name,$value,$path,$domain,$secure,$expires,$httponly,$max_age,$samesite,$priority) =
rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES,HTTPONLY,'MAX-AGE',SAMESITE,PRIORITY],@p);
require CGI::Cookie;
# if no value is supplied, then we retrieve the
# value of the cookie, if any. For efficiency, we cache the parsed
# cookies in our state variables.
unless ( defined($value) ) {
$self->{'.cookies'} = CGI::Cookie->fetch unless $COOKIE_CACHE && exists $self->{'.cookies'};
# If no name is supplied, then retrieve the names of all our cookies.
return () unless $self->{'.cookies'};
return keys %{$self->{'.cookies'}} unless $name;
return () unless $self->{'.cookies'}->{$name};
return $self->{'.cookies'}->{$name}->value if defined($name) && $name ne '';
}
# If we get here, we're creating a new cookie
return undef unless defined($name) && $name ne ''; # this is an error
my @param;
push(@param,'-name'=>$name);
push(@param,'-value'=>$value);
push(@param,'-domain'=>$domain) if $domain;
push(@param,'-path'=>$path) if $path;
push(@param,'-expires'=>$expires) if $expires;
push(@param,'-secure'=>$secure) if $secure;
push(@param,'-httponly'=>$httponly) if $httponly;
push(@param,'-max-age'=>$max_age) if $max_age;
push(@param,'-samesite'=>$samesite) if $samesite;
push(@param,'-priority'=>$priority) if $priority;
return CGI::Cookie->new(@param);
}
sub parse_keywordlist {
my($self,$tosplit) = @_;
$tosplit = unescape($tosplit); # unescape the keywords
$tosplit=~tr/+/ /; # pluses to spaces
my(@keywords) = split(/\s+/,$tosplit);
return @keywords;
}
sub param_fetch {
my($self,@p) = self_or_default(@_);
my($name) = rearrange([NAME],@p);
return [] unless defined $name;
unless (exists($self->{param}{$name})) {
$self->add_parameter($name);
$self->{param}{$name} = [];
}
return $self->{param}{$name};
}
###############################################
# OTHER INFORMATION PROVIDED BY THE ENVIRONMENT
###############################################
#### Method: path_info
# Return the extra virtual path information provided
# after the URL (if any)
####
sub path_info {
my ($self,$info) = self_or_default(@_);
if (defined($info)) {
$info = "/$info" if $info ne '' && substr($info,0,1) ne '/';
$self->{'.path_info'} = $info;
} elsif (! defined($self->{'.path_info'}) ) {
my (undef,$path_info) = $self->_name_and_path_from_env;
$self->{'.path_info'} = $path_info || '';
}
return $self->{'.path_info'};
}
# This function returns a potentially modified version of SCRIPT_NAME
# and PATH_INFO. Some HTTP servers do sanitise the paths in those
# variables. It is the case of at least Apache 2. If for instance the
# user requests: /path/./to/script.cgi/x//y/z/../x?y, Apache will set:
# REQUEST_URI=/path/./to/script.cgi/x//y/z/../x?y
# SCRIPT_NAME=/path/to/env.cgi
# PATH_INFO=/x/y/x
#
# This is all fine except that some bogus CGI scripts expect
# PATH_INFO=/http://foo when the user requests
# http://xxx/script.cgi/http://foo
#
# Old versions of this module used to accomodate with those scripts, so
# this is why we do this here to keep those scripts backward compatible.
# Basically, we accomodate with those scripts but within limits, that is
# we only try to preserve the number of / that were provided by the user
# if $REQUEST_URI and "$SCRIPT_NAME$PATH_INFO" only differ by the number
# This handles MIME type globs correctly.
####
sub Accept {
my($self,$search) = self_or_CGI(@_);
my(%prefs,$type,$pref,$pat);
my(@accept) = defined $self->http('accept')
? split(',',$self->http('accept'))
: ();
for (@accept) {
($pref) = /q=(\d\.\d+|\d+)/;
($type) = m#(\S+/[^;]+)#;
next unless $type;
$prefs{$type}=$pref || 1;
}
return keys %prefs unless $search;
# if a search type is provided, we may need to
# perform a pattern matching operation.
# The MIME types use a glob mechanism, which
# is easily translated into a perl pattern match
# First return the preference for directly supported
# types:
return $prefs{$search} if $prefs{$search};
# Didn't get it, so try pattern matching.
for (sort keys %prefs) {
next unless /\*/; # not a pattern match
($pat = $_) =~ s/([^\w*])/\\$1/g; # escape meta characters
$pat =~ s/\*/.*/g; # turn it into a pattern
return $prefs{$_} if $search=~/$pat/;
}
}
#### Method: user_agent
# If called with no parameters, returns the user agent.
# If called with one parameter, does a pattern match (case
# insensitive) on the user agent.
####
sub user_agent {
my($self,$match)=self_or_CGI(@_);
my $user_agent = $self->http('user_agent');
return $user_agent unless defined $match && $match && $user_agent;
return $user_agent =~ /$match/i;
}
#### Method: raw_cookie
# Returns the magic cookies for the session.
# The cookies are not parsed or altered in any way, i.e.
# cookies are returned exactly as given in the HTTP
# headers. If a cookie name is given, only that cookie's
# value is returned, otherwise the entire raw cookie
# is returned.
####
sub raw_cookie {
my($self,$key) = self_or_CGI(@_);
require CGI::Cookie;
if (defined($key)) {
$self->{'.raw_cookies'} = CGI::Cookie->raw_fetch
unless $self->{'.raw_cookies'};
return () unless $self->{'.raw_cookies'};
return () unless $self->{'.raw_cookies'}->{$key};
return $self->{'.raw_cookies'}->{$key};
}
return $self->http('cookie') || $ENV{'COOKIE'} || '';
}
#### Method: virtual_host
# Return the name of the virtual_host, which
# is not always the same as the server
######
sub virtual_host {
my $vh = http('x_forwarded_host') || http('host') || server_name();
$vh =~ s/:\d+$//; # get rid of port number
return $vh;
}
#### Method: remote_host
# Return the name of the remote host, or its IP
# address if unavailable. If this variable isn't
# defined, it returns "localhost" for debugging
# purposes.
####
sub remote_host {
return $ENV{'REMOTE_HOST'} || $ENV{'REMOTE_ADDR'}
|| 'localhost';
}
#### Method: remote_addr
# Return the IP addr of the remote host.
####
sub remote_addr {
return $ENV{'REMOTE_ADDR'} || '127.0.0.1';
}
#### Method: script_name
# Return the partial URL to this script for
# self-referencing scripts. Also see
# self_url(), which returns a URL with all state information
# preserved.
####
sub script_name {
my ($self,@p) = self_or_default(@_);
if (@p) {
$self->{'.script_name'} = shift @p;
} elsif (!exists $self->{'.script_name'}) {
my ($script_name,$path_info) = $self->_name_and_path_from_env();
$self->{'.script_name'} = $script_name;
}
return $self->{'.script_name'};
}
#### Method: referer
# Return the HTTP_REFERER: useful for generating
# a GO BACK button.
####
sub referer {
my($self) = self_or_CGI(@_);
( run in 0.951 second using v1.01-cache-2.11-cpan-39bf76dae61 )