1033 lines
32 KiB
Perl
1033 lines
32 KiB
Perl
# ==================================================================
|
|
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
|
#
|
|
# GT::CGI
|
|
# Author : Aki Mimoto
|
|
# CVS Info : 087,071,086,086,085
|
|
# $Id: CGI.pm,v 1.159 2009/04/07 22:34:18 brewt Exp $
|
|
#
|
|
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
|
# ==================================================================
|
|
#
|
|
# Description:
|
|
# Implements CGI.pm's CGI functionality, but faster.
|
|
#
|
|
|
|
package GT::CGI;
|
|
# ===============================================================
|
|
use strict;
|
|
use GT::Base(':persist'); # Imports MOD_PERL, SPEEDY and PERSIST
|
|
use vars qw/@ISA $DEBUG $VERSION $ATTRIBS $ERRORS $PRINTED_HEAD $EOL $TAINTED
|
|
$FORM_PARSED %PARAMS @PARAMS %COOKIES @EXPORT_OK %EXPORT_TAGS/;
|
|
use GT::AutoLoader;
|
|
require Exporter;
|
|
|
|
@ISA = qw/GT::Base/;
|
|
$DEBUG = 0;
|
|
$VERSION = sprintf "%d.%03d", q$Revision: 1.159 $ =~ /(\d+)\.(\d+)/;
|
|
$ATTRIBS = {
|
|
nph => 0,
|
|
p => '',
|
|
upload_hook => undef
|
|
};
|
|
$ERRORS = {
|
|
INVALIDCOOKIE => "Invalid cookie passed to header: %s",
|
|
INVALIDDATE => "Date '%s' is not a valid date format.",
|
|
};
|
|
|
|
# Used to append to strings that need tainting because they were passed through
|
|
# a regex, but should be tainted.
|
|
{
|
|
local $^W = 0;
|
|
$TAINTED = substr("$0$^X", 0, 0);
|
|
}
|
|
|
|
$EOL = ($^O eq 'MSWin32') ? "\n" : "\015\012"; # IIS has problems with \015\012 on nph scripts.
|
|
$PRINTED_HEAD = 0;
|
|
$FORM_PARSED = 0;
|
|
%PARAMS = ();
|
|
@PARAMS = ();
|
|
%COOKIES = ();
|
|
@EXPORT_OK = qw/escape unescape html_escape html_unescape/;
|
|
%EXPORT_TAGS = (
|
|
escape => [qw/escape unescape html_escape html_unescape/]
|
|
);
|
|
|
|
# Pre load our compiled if under mod_perl/speedy.
|
|
if (PERSIST) {
|
|
require GT::CGI::Cookie;
|
|
require GT::CGI::MultiPart;
|
|
require GT::CGI::Fh;
|
|
}
|
|
|
|
sub load_data {
|
|
#--------------------------------------------------------------------------------
|
|
# Loads the form information into PARAMS. Data comes from either a multipart
|
|
# form, a GET Request, a POST request, or as arguments from command line.
|
|
#
|
|
my $self = shift;
|
|
unless ($FORM_PARSED) {
|
|
|
|
# If we are under mod_perl we let mod_perl know that it should call reset_env
|
|
# when a request is finished.
|
|
GT::Base->register_persistent_cleanup(\&reset_env);
|
|
|
|
# Reset all the cache variables
|
|
%PARAMS = @PARAMS = %COOKIES = ();
|
|
|
|
# Load form data.
|
|
my $method = defined $ENV{REQUEST_METHOD} ? uc $ENV{REQUEST_METHOD} : '';
|
|
my $content_length = defined $ENV{'CONTENT_LENGTH'} ? $ENV{'CONTENT_LENGTH'} : 0;
|
|
|
|
if ($method eq 'GET' or $method eq 'HEAD') {
|
|
$self->parse_str(defined $ENV{QUERY_STRING} ? $ENV{QUERY_STRING} : '');
|
|
}
|
|
elsif ($method eq 'POST') {
|
|
if ($content_length) {
|
|
if ($ENV{CONTENT_TYPE} and $ENV{CONTENT_TYPE} =~ /^multipart/) {
|
|
require GT::CGI::MultiPart;
|
|
GT::CGI::MultiPart->parse($self, $self->upload_hook);
|
|
}
|
|
else {
|
|
read(STDIN, my $data, $content_length, 0);
|
|
if ($ENV{CONTENT_TYPE} and $ENV{CONTENT_TYPE} !~ m|^application/x-www-form-urlencoded|) {
|
|
$self->{post_data} = $data . $TAINTED;
|
|
}
|
|
else {
|
|
$data =~ s/\r?\n/&/g;
|
|
$self->parse_str($data);
|
|
}
|
|
}
|
|
}
|
|
}
|
|
else {
|
|
my $data = join "&", @ARGV;
|
|
$self->parse_str($data);
|
|
}
|
|
|
|
# Load cookies.
|
|
if (defined $ENV{HTTP_COOKIE}) {
|
|
for (split /;\s*/, $ENV{HTTP_COOKIE}) {
|
|
/(.*)=(.*)/ or next;
|
|
my ($key, $val) = (unescape($1 . $TAINTED), unescape($2 . $TAINTED));
|
|
$val = [split '&', $val];
|
|
$self->{cookies}->{$key} = $val;
|
|
}
|
|
}
|
|
else {
|
|
%{$self->{cookies}} = ();
|
|
}
|
|
|
|
# Parse form buttons, allowing you to pass in name="foo=bar;a=b;c=d" as a name
|
|
# tag in the form.
|
|
for (keys %{$self->{params}}) {
|
|
if (index($_, '=') >= 0) {
|
|
next if substr($_, -2) eq '.y';
|
|
(my $key = $_) =~ s/\.x$//;
|
|
$self->parse_str($key);
|
|
}
|
|
}
|
|
|
|
# Save the data for caching
|
|
while (my ($k, $v) = each %{$self->{params}}) {
|
|
push @{$PARAMS{$k}}, @$v;
|
|
}
|
|
while (my ($k, $v) = each %{$self->{cookies}}) {
|
|
push @{$COOKIES{$k}}, @$v;
|
|
}
|
|
@PARAMS = @{$self->{param_order} || []};
|
|
|
|
# Make sure the form is not parsed again during this request
|
|
$FORM_PARSED = 1;
|
|
}
|
|
else { # Load the data from the cache
|
|
while (my ($k, $v) = each %PARAMS) {
|
|
push @{$self->{params}->{$k}}, @$v;
|
|
}
|
|
while (my ($k, $v) = each %COOKIES) {
|
|
push @{$self->{cookies}->{$k}}, @$v;
|
|
}
|
|
$self->{param_order} = [@PARAMS];
|
|
}
|
|
|
|
|
|
$self->{data_loaded} = 1;
|
|
}
|
|
|
|
sub class_new {
|
|
# --------------------------------------------------------------------------------
|
|
# Creates an object to be used for all class methods, this affects the global
|
|
# cookies and params.
|
|
#
|
|
my $self = bless {} => shift;
|
|
$self->load_data unless $self->{data_loaded};
|
|
|
|
$self->{cookies} = \%COOKIES;
|
|
$self->{params} = \%PARAMS;
|
|
$self->{param_order} = \@PARAMS;
|
|
|
|
for (keys %{$ATTRIBS}) { $self->{$_} = $ATTRIBS->{$_} }
|
|
|
|
return $self;
|
|
}
|
|
|
|
sub reset_env {
|
|
# --------------------------------------------------------------------------------
|
|
# Reset the global environment.
|
|
#
|
|
%PARAMS = @PARAMS = %COOKIES = ();
|
|
$PRINTED_HEAD = $FORM_PARSED = 0;
|
|
1;
|
|
}
|
|
|
|
sub init {
|
|
#--------------------------------------------------------------------------------
|
|
# Called from GT::Base when a new object is created.
|
|
#
|
|
my $self = shift;
|
|
|
|
# If we are passed a single argument, then we load our data from
|
|
# the input.
|
|
if (@_ == 1) {
|
|
my $p = $_[0];
|
|
if (ref $p eq 'GT::CGI') {
|
|
$p = $p->query_string;
|
|
}
|
|
$self->parse_str($p ? "&$p" : "");
|
|
if (defined $ENV{HTTP_COOKIE}) {
|
|
for (split /;\s*/, $ENV{HTTP_COOKIE}) {
|
|
/(.*)=(.*)/ or next;
|
|
my ($key, $val) = (unescape($1 . $TAINTED), unescape($2 . $TAINTED));
|
|
$val = [split '&', $val];
|
|
$self->{cookies}->{$key} = $val;
|
|
}
|
|
}
|
|
$self->{data_loaded} = 1;
|
|
$FORM_PARSED = 1;
|
|
}
|
|
elsif (@_) {
|
|
$self->set(@_);
|
|
}
|
|
return $self;
|
|
}
|
|
|
|
$COMPILE{get_hash} = __LINE__ . <<'END_OF_SUB';
|
|
sub get_hash {
|
|
#-------------------------------------------------------------------------------
|
|
# Returns the parameters as a HASH, with multiple values becoming an array
|
|
# reference.
|
|
#
|
|
my $self = shift;
|
|
$self = $self->class_new unless ref $self;
|
|
$self->load_data() unless $self->{data_loaded};
|
|
my $join = defined $_[0] ? $_[0] : 0;
|
|
|
|
keys %{$self->{params}} or return {};
|
|
|
|
# Construct hash ref and return it
|
|
my $opts = {};
|
|
foreach (keys %{$self->{params}}) {
|
|
my @vals = @{$self->{params}->{$_}};
|
|
$opts->{$_} = @vals > 1 ? \@vals : $vals[0];
|
|
}
|
|
return $opts;
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{delete} = __LINE__ . <<'END_OF_SUB';
|
|
sub delete {
|
|
#--------------------------------------------------------------------------------
|
|
# Remove an element from the parameters.
|
|
#
|
|
my ($self, $param) = @_;
|
|
$self = $self->class_new unless ref $self;
|
|
$self->load_data() unless $self->{data_loaded};
|
|
my @ret;
|
|
if (exists $self->{params}->{$param}) {
|
|
@ret = @{delete $self->{params}->{$param}};
|
|
for (my $i = 0; $i < @{$self->{param_order}}; $i++) {
|
|
if ($self->{param_order}->[$i] eq $param) {
|
|
splice @{$self->{param_order}}, $i, 1;
|
|
last;
|
|
}
|
|
}
|
|
}
|
|
return wantarray ? @ret : $ret[0];
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{cookie} = __LINE__ . <<'END_OF_SUB';
|
|
sub cookie {
|
|
#--------------------------------------------------------------------------------
|
|
# Creates a new cookie for the user, implemented just like CGI.pm.
|
|
#
|
|
my $self = shift;
|
|
$self = $self->class_new unless ref $self;
|
|
$self->load_data() unless $self->{data_loaded};
|
|
if (@_ == 0) { # Return keys.
|
|
return keys %{$self->{cookies}};
|
|
}
|
|
elsif (@_ == 1) { # Return value of param passed in.
|
|
my $param = shift;
|
|
return unless defined $param and $self->{cookies}->{$param};
|
|
return wantarray ? @{$self->{cookies}->{$param}} : $self->{cookies}->{$param}->[0];
|
|
}
|
|
elsif (@_ == 2) {
|
|
require GT::CGI::Cookie;
|
|
return GT::CGI::Cookie->new(-name => $_[0], -value => $_[1]);
|
|
}
|
|
elsif (@_ % 2 == 0) {
|
|
my %data = @_;
|
|
if (exists $data{'-value'}) {
|
|
require GT::CGI::Cookie;
|
|
return GT::CGI::Cookie->new(%data);
|
|
}
|
|
}
|
|
$self->fatal("Invalid arguments to cookie()");
|
|
}
|
|
END_OF_SUB
|
|
|
|
sub param {
|
|
#--------------------------------------------------------------------------------
|
|
# Mimick CGI's param function for get/set.
|
|
#
|
|
my $self = shift;
|
|
$self = $self->class_new unless ref $self;
|
|
$self->load_data() unless $self->{data_loaded};
|
|
if (@_ == 0) { # Return keys in the same order they were provided
|
|
return @{$self->{param_order} || []};
|
|
}
|
|
elsif (@_ == 1) { # Return value of param passed in.
|
|
my $param = shift;
|
|
return unless (defined($param) and $self->{params}->{$param});
|
|
return wantarray ? @{$self->{params}->{$param}} : $self->{params}->{$param}->[0];
|
|
}
|
|
else { # Set parameter.
|
|
my ($param, $value) = @_;
|
|
unless ($self->{params}->{$param}) {
|
|
# If we're not replacing/changing a parameter, we need to add the param to param_order
|
|
push @{$self->{param_order}}, $param;
|
|
}
|
|
$self->{params}->{$param} = [ref $value eq 'ARRAY' ? @$value : $value];
|
|
}
|
|
}
|
|
|
|
sub header {
|
|
#--------------------------------------------------------------------------------
|
|
# Mimick the header function.
|
|
#
|
|
my $self = shift;
|
|
$self = $self->class_new unless ref $self;
|
|
my %p = ref $_[0] eq 'HASH' ? %{$_[0]} : @_ % 2 ? () : @_;
|
|
my @headers;
|
|
|
|
# Don't print headers twice unless -force'd.
|
|
return '' if not delete $p{-force} and $PRINTED_HEAD;
|
|
|
|
# Start by adding NPH headers if requested.
|
|
my $status = $p{-permanent} ? 301 : 302;
|
|
if ($self->{nph} || $p{-nph}) {
|
|
if ($p{-url}) {
|
|
push @headers, "HTTP/1.0 $status Moved";
|
|
}
|
|
else {
|
|
my $protocol = $ENV{SERVER_PROTOCOL} || 'HTTP/1.0';
|
|
unless (MOD_PERL) {
|
|
push @headers, "$protocol 200 OK";
|
|
}
|
|
}
|
|
}
|
|
elsif ($p{-url}) {
|
|
push @headers, "Status: $status Moved";
|
|
}
|
|
delete @p{qw/nph -nph/};
|
|
|
|
# If requested, add a "Pragma: no-cache"
|
|
my $no_cache = $p{'no-cache'} || $p{'-no-cache'};
|
|
delete @p{qw/no-cache -no-cache/};
|
|
if ($no_cache) {
|
|
require GT::Date;
|
|
push @headers,
|
|
"Expires: Tue, 25 Jan 2000 12:00:00 GMT",
|
|
"Last-Modified: " . GT::Date::date_get_gm(time, "%ddd%, %dd% %mmm% %yyyy% %HH%:%MM%:%ss% GMT"),
|
|
"Cache-Control: no-store",
|
|
"Pragma: no-cache";
|
|
}
|
|
|
|
# Add any cookies, we accept either an array of cookies
|
|
# or a single cookie.
|
|
my $add_date = 0;
|
|
my $cookies = 0;
|
|
my $container = delete($p{-cookie}) || '';
|
|
require GT::CGI::Cookie if $container;
|
|
if (ref $container and UNIVERSAL::isa($container, 'GT::CGI::Cookie')) {
|
|
my $c = $container->cookie_header;
|
|
push @headers, $c;
|
|
$add_date = 1;
|
|
$cookies++;
|
|
}
|
|
elsif (ref $container eq 'ARRAY') {
|
|
foreach my $cookie (@$container) {
|
|
next unless (defined $cookie and (ref $cookie eq 'GT::CGI::Cookie'));
|
|
push @headers, $cookie->cookie_header;
|
|
$add_date = 1;
|
|
$cookies++;
|
|
}
|
|
}
|
|
elsif ($container) {
|
|
$self->error('INVALIDCOOKIE', 'WARN', $container);
|
|
}
|
|
|
|
# Print expiry if requested.
|
|
if (defined(my $expires = delete $p{-expires})) {
|
|
require GT::CGI::Cookie;
|
|
my $date = GT::CGI::Cookie->format_date(' ', $expires);
|
|
unless ($date) {
|
|
$self->error('INVALIDDATE', 'WARN', $expires);
|
|
}
|
|
else {
|
|
push @headers, "Expires: $date";
|
|
$add_date = 1;
|
|
}
|
|
}
|
|
|
|
# Add a Date header if we printed an expires tag or a cookie tag.
|
|
if ($add_date) {
|
|
require GT::CGI::Cookie;
|
|
my $now = GT::CGI::Cookie->format_date(' ');
|
|
push @headers, "Date: $now";
|
|
}
|
|
|
|
# Add Redirect Header.
|
|
my $iis_redirect;
|
|
if (my $url = delete $p{-url}) {
|
|
$url =~ s/[\x00-\x08\x0a-\x1f].*//s;
|
|
# IIS 3-5 will drop any cookie headers on a redirect
|
|
# http://support.microsoft.com/kb/q176113
|
|
if ($ENV{SERVER_SOFTWARE} =~ m|IIS/[3-5]|i and $cookies) {
|
|
$iis_redirect = $url;
|
|
# Remove the Status: 301/302 header
|
|
for (my $i = 0; $i < @headers; $i++) {
|
|
if ($headers[$i] =~ /^Status:\s*30[12]/i) {
|
|
splice @headers, $i, 1;
|
|
last;
|
|
}
|
|
}
|
|
}
|
|
else {
|
|
push @headers, "Location: $url";
|
|
}
|
|
}
|
|
|
|
# Add the Content-type header.
|
|
my $type = @_ == 1 && !ref($_[0]) ? $_[0] : delete($p{-type}) || 'text/html';
|
|
my $charset = delete $p{-charset};
|
|
if ($charset and $type =~ /^text\// and $type !~ /\bcharset\b/) {
|
|
$type .= "; charset=$charset";
|
|
}
|
|
push @headers, "Content-type: $type";
|
|
|
|
# Add any custom headers.
|
|
foreach my $key (keys %p) {
|
|
$key =~ /^\s*-?(.+)/;
|
|
push @headers, escape(ucfirst $1) . ": " . (ref $p{$key} eq 'SCALAR' ? ${$p{$key}} : escape($p{$key}));
|
|
}
|
|
$PRINTED_HEAD = 1;
|
|
|
|
my $headers = '';
|
|
for (@headers) {
|
|
# Control characters other than tab aren't allowed; remove any - but not \n, which we handle later:
|
|
y/\x00-\x08\x0b-\x1f//d;
|
|
|
|
# Newlines are allowed if followed by a space or tab (this is header
|
|
# folding - RFC 2616 § 2.2). If we encounter any *not* followed by a
|
|
# space, force one in - the alternative would be to delete it entirely,
|
|
# but that arguably isn't much better or worse.
|
|
s/\x0a+$//;
|
|
s/\x0a(?![ \t])/\x0a /g;
|
|
s/\x0a/$EOL/g unless $EOL eq "\x0a";
|
|
$headers .= $_ . $EOL;
|
|
}
|
|
$headers .= $EOL;
|
|
|
|
# Fun hack for IIS
|
|
if ($iis_redirect) {
|
|
$iis_redirect =~ y/;/&/; # You can't have semicolons in a meta http-equiv tag.
|
|
return $headers . <<END_OF_HTML;
|
|
<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/transitional.dtd">
|
|
<html><head><title>Document Moved</title><meta http-equiv="refresh" content="0;URL=$iis_redirect"><meta http-equiv="content-type" content="text/html; charset=us-ascii"></head>
|
|
<body><noscript><h1>Object Moved</h1>This document may be found <a HREF="$iis_redirect">here</a></noscript></body></html>
|
|
END_OF_HTML
|
|
}
|
|
return $headers;
|
|
}
|
|
|
|
$COMPILE{redirect} = __LINE__ . <<'END_OF_SUB';
|
|
sub redirect {
|
|
#-------------------------------------------------------------------------------
|
|
# Print a redirect header.
|
|
#
|
|
my $self = shift;
|
|
$self = $self->class_new unless ref $self;
|
|
|
|
my (@headers, $url);
|
|
if (@_ == 0) {
|
|
return $self->header({ -url => $self->self_url });
|
|
}
|
|
elsif (@_ == 1) {
|
|
return $self->header({ -url => shift });
|
|
}
|
|
else {
|
|
my $opts = ref $_[0] eq 'HASH' ? shift : {@_};
|
|
$opts->{'-url'} ||= $opts->{'-URL'} || $self->self_url;
|
|
return $self->header($opts);
|
|
}
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{file_headers} = __LINE__ . <<'END_OF_SUB';
|
|
sub file_headers {
|
|
# -----------------------------------------------------------------------------
|
|
# Returns a list of header arguments that can be passed into header() when
|
|
# sending a file. Takes a hash (not hash ref or GT::CGI object or ...) of
|
|
# options:
|
|
# filename - filename being sent; required
|
|
# mimetype - mime-type to send; defaults to using GT::MIMETypes with filename
|
|
# inline - set to true to send an inline content disposition, false to send
|
|
# attachment. Not specifying this key causes inline to be sent for
|
|
# common image and text types, and attachment to be sent for
|
|
# everything else. You generally should either not specify this, or
|
|
# set it to false (i.e. to force a download prompt).
|
|
# size - size of the data to be sent; optional, but recommended as
|
|
# Content-Length and Content-Disposition size won't be set without it.
|
|
#
|
|
my $self = __PACKAGE__;
|
|
$self = shift if @_ > 1 and UNIVERSAL::isa($_[0], __PACKAGE__);
|
|
my %args = @_;
|
|
my $filename = $args{filename};
|
|
defined $filename and length $filename or $self->fatal(BADARGS => "No filename passed to file_headers");
|
|
|
|
my $mimetype;
|
|
unless ($mimetype = $args{mimetype}) {
|
|
$mimetype = eval { require GT::MIMETypes; GT::MIMETypes::guess_type($filename) } || 'application/octet-stream';
|
|
}
|
|
my $cd;
|
|
if (exists $args{inline}) {
|
|
$cd = $args{inline} ? 'inline' : 'attachment';
|
|
}
|
|
else {
|
|
$cd = $mimetype =~ m{^(?:image/(?:gif|jpeg|png|bmp)|application/pdf|text/(?:plain|html))$}
|
|
? 'inline'
|
|
: 'attachment';
|
|
}
|
|
my $size = $args{size};
|
|
$size = int $size if defined $size;
|
|
|
|
# First, sanitize the filename so that people can't create extra HTTP headers by embedding
|
|
# a \n in the filename. So, strip out all control characters (except tab):
|
|
$filename =~ y/\x00-\x08\x0a-\x1f//d;
|
|
|
|
# As for filename escaping, every browser seems to want something different to get the
|
|
# filename correct. Mozilla and Opera appear to be the only browsers that gets things
|
|
# right - enclose the filename in "", and \escape every \\ and ". IE doesn't work with
|
|
# that - it needs the filename to be URL escaped. Konqueror and Safari cannot handle
|
|
# arbitrary filenames at all - it handles neither of the above escape methods, so you could
|
|
# easily break out of the quoted structure and send Content-Disposition values directly to
|
|
# the browser. So, Safari/Konqueror get "'s stripped out, as well as \'s (in case they
|
|
# ever fix their browser).
|
|
# Filename: asdf asdf"\foo"\zxc vxzcv
|
|
# Konqueror/Safari: filename="asdf adsf"\foo"\zxc vxzcv" # broken, we set: filename="asdf asdffoozxc vxzcv"
|
|
# IE: filename="asdf%20asdf%22%5Cfoo%22%5Czxc%20vxzcv"
|
|
# Mozilla/Opera/standard-compliant: filename="asdf asdf\"\\foo\"\\zxc vxzcv"
|
|
my %browser = browser_info();
|
|
if ($browser{is_ie}) {
|
|
$filename = escape($filename);
|
|
}
|
|
elsif ($browser{is_konqueror} or $browser{is_safari}) {
|
|
$filename =~ y/\\"//d;
|
|
}
|
|
else {
|
|
$filename =~ s/([\\"])/\\$1/g;
|
|
}
|
|
|
|
return (
|
|
-type => $mimetype,
|
|
"Content-Disposition" => \(qq/$cd; filename="$filename"/ . (defined($size) ? "; size=$size" : '')),
|
|
defined($size) ? ("Content-Length" => $size) : ()
|
|
);
|
|
}
|
|
END_OF_SUB
|
|
|
|
sub unescape {
|
|
#-------------------------------------------------------------------------------
|
|
# returns the url decoded string of the passed argument. Optionally takes an
|
|
# array reference of multiple strings to decode. The values of the array are
|
|
# modified directly, so you shouldn't need the return (which is the same array
|
|
# reference).
|
|
#
|
|
my $todecode = pop;
|
|
return unless defined $todecode;
|
|
for my $str (ref $todecode eq 'ARRAY' ? @$todecode : $todecode) {
|
|
$str =~ tr/+/ /; # pluses become spaces
|
|
$str =~ s/%([0-9a-fA-F]{2})/chr(hex($1))/ge;
|
|
}
|
|
$todecode;
|
|
}
|
|
|
|
$COMPILE{escape} = __LINE__ . <<'END_OF_SUB';
|
|
sub escape {
|
|
#--------------------------------------------------------------------------------
|
|
# return the url encoded string of the passed argument
|
|
#
|
|
my $toencode = pop;
|
|
return unless defined $toencode;
|
|
$toencode =~ s/([^\w\-.!~*'()])/sprintf("%%%02X",ord($1))/eg;
|
|
return $toencode;
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{html_escape} = __LINE__ . <<'END_OF_SUB';
|
|
sub html_escape {
|
|
#--------------------------------------------------------------------------------
|
|
# Return the string html_escaped.
|
|
#
|
|
my $toencode = pop;
|
|
return unless defined $toencode;
|
|
if (ref($toencode) eq 'SCALAR') {
|
|
$$toencode =~ s/&/&/g;
|
|
$$toencode =~ s/</</g;
|
|
$$toencode =~ s/>/>/g;
|
|
$$toencode =~ s/"/"/g;
|
|
$$toencode =~ s/'/'/g;
|
|
}
|
|
else {
|
|
$toencode =~ s/&/&/g;
|
|
$toencode =~ s/</</g;
|
|
$toencode =~ s/>/>/g;
|
|
$toencode =~ s/"/"/g;
|
|
$toencode =~ s/'/'/g;
|
|
}
|
|
return $toencode;
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{html_unescape} = __LINE__ . <<'END_OF_SUB';
|
|
sub html_unescape {
|
|
#--------------------------------------------------------------------------------
|
|
# Return the string html unescaped.
|
|
#
|
|
my $todecode = pop;
|
|
return unless defined $todecode;
|
|
if (ref $todecode eq 'SCALAR') {
|
|
$$todecode =~ s/</</g;
|
|
$$todecode =~ s/>/>/g;
|
|
$$todecode =~ s/"/"/g;
|
|
$$todecode =~ s/'/'/g;
|
|
$$todecode =~ s/&/&/g;
|
|
}
|
|
else {
|
|
$todecode =~ s/</</g;
|
|
$todecode =~ s/>/>/g;
|
|
$todecode =~ s/"/"/g;
|
|
$todecode =~ s/'/'/g;
|
|
$todecode =~ s/&/&/g;
|
|
}
|
|
return $todecode;
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{self_url} = __LINE__ . <<'END_OF_SUB';
|
|
sub self_url {
|
|
# -------------------------------------------------------------------
|
|
# Return full URL with query options as CGI.pm
|
|
#
|
|
return $_[0]->url(query_string => 1, absolute => 1);
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{url} = __LINE__ . <<'END_OF_SUB';
|
|
sub url {
|
|
# -------------------------------------------------------------------
|
|
# Return the current url. Can be called as GT::CGI->url() or $cgi->url().
|
|
#
|
|
my $self = shift;
|
|
$self = $self->class_new unless ref $self;
|
|
$self->load_data() unless $self->{data_loaded};
|
|
my $opts = $self->common_param(@_);
|
|
|
|
my $absolute = exists $opts->{absolute} ? $opts->{absolute} : 0;
|
|
my $query_string = exists $opts->{query_string} ? $opts->{query_string} : 1;
|
|
my $path_info = exists $opts->{path_info} ? $opts->{path_info} : 0;
|
|
my $remove_empty = exists $opts->{remove_empty} ? $opts->{remove_empty} : 0;
|
|
if ($opts->{relative}) {
|
|
$absolute = 0;
|
|
}
|
|
|
|
my $url = '';
|
|
my $script = $ENV{SCRIPT_NAME} || $0;
|
|
my ($path, $prog) = $script =~ m,^(.+?)[/\\]?([^/\\]*)$,;
|
|
|
|
if ($absolute) {
|
|
my ($protocol, $version) = split('/', $ENV{SERVER_PROTOCOL} || 'HTTP/1.0');
|
|
$url = lc $protocol . "://";
|
|
|
|
my $host = $ENV{HTTP_HOST} || $ENV{SERVER_NAME} || '';
|
|
$url .= $host;
|
|
|
|
$path =~ s{^[/\\]+}{};
|
|
$path =~ s{[/\\]+$}{};
|
|
$url .= "/$path/";
|
|
}
|
|
$prog =~ s{^[/\\]+}{};
|
|
$prog =~ s{[/\\]+$}{};
|
|
$url .= $prog;
|
|
|
|
if ($path_info and $ENV{PATH_INFO}) {
|
|
my $path = $ENV{PATH_INFO};
|
|
if (defined $ENV{SERVER_SOFTWARE} && $ENV{SERVER_SOFTWARE} =~ /IIS/) {
|
|
$path =~ s/\Q$ENV{SCRIPT_NAME}//;
|
|
}
|
|
$url .= $path;
|
|
}
|
|
if ($query_string) {
|
|
my $qs = $self->query_string(remove_empty => $remove_empty);
|
|
if ($qs) {
|
|
$url .= "?" . $qs;
|
|
}
|
|
}
|
|
return $url;
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{query_string} = __LINE__ . <<'END_OF_SUB';
|
|
sub query_string {
|
|
# -------------------------------------------------------------------
|
|
# Returns the query string url escaped.
|
|
#
|
|
my $self = shift;
|
|
$self = $self->class_new unless ref $self;
|
|
$self->load_data() unless $self->{data_loaded};
|
|
my $opts = $self->common_param(@_);
|
|
my $qs = '';
|
|
foreach my $key (@{$self->{param_order} || []}) {
|
|
my $esc_key = escape($key);
|
|
foreach my $val (@{$self->{params}->{$key}}) {
|
|
next if ($opts->{remove_empty} and ($val eq ''));
|
|
$qs .= $esc_key . "=" . escape($val) . ";";
|
|
}
|
|
}
|
|
$qs and chop $qs;
|
|
$qs ? return $qs : return '';
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{post_data} = __LINE__ . <<'END_OF_SUB';
|
|
sub post_data {
|
|
# -------------------------------------------------------------------
|
|
# Returns the POSTed data if it was not of type
|
|
# application/x-www-form-urlencoded or multipart/form-data.
|
|
#
|
|
my $self = shift;
|
|
$self = $self->class_new unless ref $self;
|
|
$self->load_data() unless $self->{data_loaded};
|
|
|
|
return $self->{post_data};
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{browser_info} = __LINE__ . <<'END_OF_SUB';
|
|
sub browser_info {
|
|
# -----------------------------------------------------------------------------
|
|
# my %tags = browser_info();
|
|
# --------------------------
|
|
# Returns various is_BROWSER, BROWSER_version tags.
|
|
#
|
|
return unless $ENV{HTTP_USER_AGENT};
|
|
|
|
my %browser_opts;
|
|
|
|
if ($ENV{HTTP_USER_AGENT} =~ m{Opera(?:\s+|/)(\d+\.\d+)}i) {
|
|
$browser_opts{is_opera} = 1;
|
|
$browser_opts{opera_version} = $1;
|
|
}
|
|
elsif ($ENV{HTTP_USER_AGENT} =~ m{AppleWebKit/(\d+.\d+)}i) {
|
|
$browser_opts{is_webkit} = 1;
|
|
$browser_opts{webkit_version} = $1;
|
|
|
|
if ($ENV{HTTP_USER_AGENT} =~ m{Chrome/(\d+(?:\.\d+){1,3})}i) {
|
|
$browser_opts{is_chrome} = 1;
|
|
$browser_opts{chrome_version} = $1;
|
|
}
|
|
elsif ($ENV{HTTP_USER_AGENT} =~ m{Version/(\d+(?:\.\d+){1,2})}i) {
|
|
$browser_opts{is_safari} = 1;
|
|
$browser_opts{safari_version} = $1;
|
|
}
|
|
}
|
|
elsif ($ENV{HTTP_USER_AGENT} =~ /MSIE (\d+(?:\.\d+)?)/i) {
|
|
$browser_opts{is_ie} = 1;
|
|
$browser_opts{ie_version} = $1;
|
|
}
|
|
elsif ($ENV{HTTP_USER_AGENT} =~ m{Mozilla/(\d+\.\d+)\s+\(.*\s+rv:(\d+\.\d+)}i) {
|
|
if ($1 >= 5.0) {
|
|
$browser_opts{is_mozilla} = 1;
|
|
$browser_opts{mozilla_version} = $2;
|
|
}
|
|
}
|
|
elsif ($ENV{HTTP_USER_AGENT} =~ m{Konqueror/(\d+\.\d+)}i) {
|
|
$browser_opts{is_konqueror} = 1;
|
|
$browser_opts{konqueror_version} = $1;
|
|
}
|
|
return %browser_opts;
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{upload_hook} = __LINE__ . <<'END_OF_SUB';
|
|
sub upload_hook {
|
|
#--------------------------------------------------------------------------------
|
|
# Provides a hook to access file upload data while it is being read from client.
|
|
#
|
|
my $self = shift;
|
|
$self->{upload_hook} = shift if @_;
|
|
return $self->{upload_hook};
|
|
}
|
|
END_OF_SUB
|
|
|
|
sub parse_str {
|
|
#--------------------------------------------------------------------------------
|
|
# parses a query string and add it to the parameter list
|
|
#
|
|
my $self = shift;
|
|
my @input;
|
|
for (split /[;&]/, shift) {
|
|
my ($key, $val) = /([^=]+)=(.*)/ or next;
|
|
|
|
# Re-taint the CGI input
|
|
$key .= $TAINTED;
|
|
$val .= $TAINTED;
|
|
|
|
# Need to remove cr's on windows.
|
|
if ($^O eq 'MSWin32') {
|
|
$key =~ s/%0D%0A/%0A/gi; # \x0d = \r, \x0a = \n
|
|
$val =~ s/%0D%0A/%0A/gi;
|
|
}
|
|
push @input, $key, $val;
|
|
}
|
|
unescape(\@input);
|
|
while (@input) {
|
|
my ($k, $v) = splice @input, 0, 2;
|
|
$self->{params}->{$k} or push @{$self->{param_order}}, $k;
|
|
unshift @{$self->{params}->{$k}}, $v;
|
|
}
|
|
}
|
|
|
|
1;
|
|
|
|
__END__
|
|
|
|
=head1 NAME
|
|
|
|
GT::CGI - a lightweight replacement for CGI.pm
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
use GT::CGI;
|
|
my $in = new GT::CGI;
|
|
foreach my $param ($in->param) {
|
|
print "VALUE: $param => ", $in->param($param), "\n";
|
|
}
|
|
|
|
use GT::CGI qw/-no_parse_buttons/;
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
GT::CGI is a lightweight replacement for CGI.pm. It implements most of the
|
|
functionality of CGI.pm, with the main difference being that GT::CGI does not
|
|
provide a function-based interface (with the exception of the escape/unescape
|
|
functions, which can be called as either function or method), nor does it
|
|
provide the HTML functionality provided by CGI.pm.
|
|
|
|
The primary motivation for this is to provide a CGI module that can be shipped
|
|
with Gossamer products, not having to depend on a recent version of CGI.pm
|
|
being installed on remote servers. The secondary motivation is to provide a
|
|
module that loads and runs faster, thus speeding up Gossamer products.
|
|
|
|
Credit and thanks goes to the author of CGI.pm. A lot of the code (especially
|
|
file upload) was taken from CGI.pm.
|
|
|
|
=head2 param - Accessing form input.
|
|
|
|
Can be called as either a class method or object method. When called with no
|
|
arguments a list of keys is returned.
|
|
|
|
When called with a single argument in scalar context the first (and possibly
|
|
only) value is returned. When called in list context an array of values is
|
|
returned.
|
|
|
|
When called with two arguments, it sets the key-value pair.
|
|
|
|
=head2 header() - Printing HTTP headers
|
|
|
|
Can be called as a class method or object method. When called with no
|
|
arguments, simply returns the HTTP header.
|
|
|
|
Other options include:
|
|
|
|
=over 4
|
|
|
|
=item -force => 1
|
|
|
|
Force printing of header even if it has already been displayed.
|
|
|
|
=item -type => 'text/plain'
|
|
|
|
Set the type of the header to something other then text/html.
|
|
|
|
=item -charset => 'iso-8859-1'
|
|
|
|
Set the character set that is sent to the browser. This is only applicable to
|
|
text types. If this option is not passed in, then no character set is sent.
|
|
|
|
=item -cookie => $cookie
|
|
|
|
Display any cookies. You can pass in a single GT::CGI::Cookie object, or an
|
|
array of them.
|
|
|
|
=item -nph => 1
|
|
|
|
Display full headers for nph scripts.
|
|
|
|
=item -no-cache => 1
|
|
|
|
Send the appropriate headers to prevent the browser from caching the resulting
|
|
page.
|
|
|
|
=item -url => $url
|
|
|
|
Redirect the user to the supplied url. By default, it performs a temporary
|
|
(302) redirect. Use the -permanent option to perform a permanent (301)
|
|
redirect.
|
|
|
|
=item -permanent => 1
|
|
|
|
Used with the -url option to perform a permanent (301) redirect.
|
|
|
|
=back
|
|
|
|
If called with a single argument, sets the Content-Type.
|
|
|
|
=head2 redirect - Redirecting to new URL.
|
|
|
|
Returns a Location: header to redirect a user.
|
|
|
|
=head2 cookie - Set/Get HTTP Cookies.
|
|
|
|
Sets or gets a cookie. To retrieve a cookie:
|
|
|
|
my $cookie = $cgi->cookie ('key');
|
|
my $cookie = $cgi->cookie (-name => 'key');
|
|
|
|
or to retrieve a hash of all cookies:
|
|
|
|
my $cookies = $cgi->cookie;
|
|
|
|
To set a cookie:
|
|
|
|
$c = $cgi->cookie (-name => 'foo', -value => 'bar')
|
|
|
|
You can also specify -expires for when the cookie should expire, -path for
|
|
which path the cookie valid, -domain for which domain the cookie is valid,
|
|
-secure if the cookie is only valid for secure sites, and -httponly to prevent
|
|
client side scripts from reading the cookie (for browsers that support it).
|
|
|
|
You would then set the cookie by passing it to the header function:
|
|
|
|
print $in->header ( -cookie => $c );
|
|
|
|
=head2 url - Retrieve the current URL.
|
|
|
|
Returns the current URL of the script. It defaults to display just the script
|
|
name and query string.
|
|
|
|
Options include:
|
|
|
|
=over 4
|
|
|
|
=item absolute => 1
|
|
|
|
Return the full URL: http://domain/path/to/script.cgi
|
|
|
|
=item relative => 1
|
|
|
|
Return only the script name: script.cgi
|
|
|
|
=item query_string => 1
|
|
|
|
Return the query string as well: script.cgi?a=b
|
|
|
|
=item path_info => 1
|
|
|
|
Returns the path info as well: script.cgi/foobar
|
|
|
|
=item remove_empty => 0
|
|
|
|
Removes empty query= from the query string.
|
|
|
|
=back
|
|
|
|
=head2 get_hash - Return all form input as hash.
|
|
|
|
This returns the current parameters as a hash. Any values that have the same
|
|
key will be returned as an array reference of the multiple values.
|
|
|
|
=head2 escape - URL escape a string.
|
|
|
|
Returns the passed in value URL escaped. Can be called as class method or
|
|
object method.
|
|
|
|
=head2 unescape - URL unescape a string.
|
|
|
|
Returns the passed in value URL un-escaped. Can be called as class method or
|
|
object method. Optionally can take an array reference of strings instead of a
|
|
string. If called in this method, the values of the array reference will be
|
|
directly altered.
|
|
|
|
=head2 html_escape - HTML escape a string
|
|
|
|
Returns the passed in value HTML escaped. Translates &, <, > and " to their
|
|
html equivalants.
|
|
|
|
=head2 html_unescape - HTML unescapes a string
|
|
|
|
Returns the passed in value HTML unescaped.
|
|
|
|
=head2 post_data - Return POSTed data.
|
|
|
|
If POSTed data is not of type application/x-www-form-urlencoded or
|
|
multipart/form-data, then the POSTed data will not be processed. You can
|
|
retrieve this data using this method.
|
|
|
|
=head2 upload_hook - Callback for file uploads
|
|
|
|
Takes a code reference, and for every file upload, runs the code reference
|
|
and passes it the filename, a reference to the data, and the total bytes
|
|
read.
|
|
|
|
Must be called before any other function, or as a parameter to new.
|
|
|
|
=head1 DEPENDENCIES
|
|
|
|
Note: GT::CGI depends on L<GT::Base> and L<GT::AutoLoader>, and if you are
|
|
performing file uploads, GT::CGI::MultiPart, GT::CGI::Fh, and L<GT::TempFile>.
|
|
The ability to set cookies requires GT::CGI::Cookie.
|
|
|
|
=head1 COPYRIGHT
|
|
|
|
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
|
http://www.gossamer-threads.com/
|
|
|
|
=head1 VERSION
|
|
|
|
Revision: $Id: CGI.pm,v 1.159 2009/04/07 22:34:18 brewt Exp $
|
|
|
|
=cut
|