# ==================================================================
# 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/&/&amp;/g;
        $$toencode =~ s/</&lt;/g;
        $$toencode =~ s/>/&gt;/g;
        $$toencode =~ s/"/&quot;/g;
        $$toencode =~ s/'/&#039;/g;
    }
    else {
        $toencode =~ s/&/&amp;/g;
        $toencode =~ s/</&lt;/g;
        $toencode =~ s/>/&gt;/g;
        $toencode =~ s/"/&quot;/g;
        $toencode =~ s/'/&#039;/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/&lt;/</g;
        $$todecode =~ s/&gt;/>/g;
        $$todecode =~ s/&quot;/"/g;
        $$todecode =~ s/&#039;/'/g;
        $$todecode =~ s/&amp;/&/g;
    }
    else {
        $todecode =~ s/&lt;/</g;
        $todecode =~ s/&gt;/>/g;
        $todecode =~ s/&quot;/"/g;
        $todecode =~ s/&#039;/'/g;
        $todecode =~ s/&amp;/&/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
