# ==================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
#   GT::CGI
#   Author  : Aki Mimoto
#   $Id: CGI.pm,v 1.106 2002/06/04 22:39:12 jagerman Exp $
# 
# Copyright (c) 2002 Gossamer Threads Inc.  All Rights Reserved.
# ==================================================================
#
# Description:
#   Implements CGI.pm's CGI functionality, but faster.
#

package GT::CGI;
# ===============================================================
use strict;
use GT::Base(':all'); # Imports $MOD_PERL, $SPEEDY and $PERSIST
use vars qw/@ISA $DEBUG $VERSION $ATTRIBS $ERRORS $PRINTED_HEAD
            $FORM_PARSED %PARAMS %COOKIES @EXPORT_OK %EXPORT_TAGS/;
use GT::AutoLoader;
require Exporter;

@ISA     = qw/GT::Base/;
$DEBUG   = 0;
$VERSION = sprintf "%d.%03d", q$Revision: 1.106 $ =~ /(\d+)\.(\d+)/;
$ATTRIBS = {
    nph  => 0,
    p    => ''
};
$ERRORS  = {
    INVALIDCOOKIE => "Invalid cookie passed to header: %s",
    INVALIDDATE   => "Date '%s' is not a valid date format.",
};
use constants CRLF => "\015\012";
$PRINTED_HEAD = 0;
$FORM_PARSED  = 0;
%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;
    %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') {
        $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);
            }
            else {
                read(STDIN, my $data, $content_length, 0);
                $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), unescape($2));
            $val = [split '&', $val];
            $self->{cookies}->{$key} = $val;
        }
    }
    else {
        %{$self->{cookies}} = ();
    }

# If we are under mod_perl we let mod_perl know that it should call reset_param
# when a request is finished.
    $MOD_PERL and require Apache and $Apache::ServerStarting != 1 and Apache->request->register_cleanup(\&reset_env);
    $SPEEDY   and require CGI::SpeedyCGI and CGI::SpeedyCGI->new->register_cleanup (\&reset_env );

# 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;
    }
    $FORM_PARSED = 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 ($FORM_PARSED);
    
    $self->{cookies} = \%COOKIES;
    $self->{params}  = \%PARAMS;
    for (keys %{$ATTRIBS}) { $self->{$_} = $ATTRIBS->{$_} }

    return $self;
}

sub reset_env {
# --------------------------------------------------------------------------------
# Reset the global environment.
#
    %PARAMS         = ();
    %COOKIES        = ();
    $PRINTED_HEAD   = 0; 
    $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), unescape($2));
                $val = [split '&', $val];
                $self->{cookies}->{$key} = $val;
            }
        }
        $FORM_PARSED = 1;
    }
    else {
        $self->set(@_) if @_;

# If we have the form parsed, then we need to copy the data into self.
        if ($FORM_PARSED) {
            while (my ($k, $v) = each %PARAMS) {
                push @{$self->{params}->{$k}}, @$v;
            }
            while (my ($k, $v) = each %COOKIES) {
                push @{$self->{cookies}->{$k}}, @$v;
            }
        }
    }
    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;
    $FORM_PARSED or $self->load_data();
    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;
    $FORM_PARSED or $self->load_data();
    exists $self->{params}->{$param} and return wantarray ? @{delete $self->{params}->{$param}} : (@{delete $self->{params}->{$param}})[0];
    return;
}
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; # Not used, don't care if it's self/class.;
    $self = $self->class_new unless ref $self;
    $FORM_PARSED or $self->load_data();
    my %data = ( @_ ) if ( @_ and @_ % 2 == 0 );
    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 (defined $data{'-value'}) {
        require GT::CGI::Cookie;
        return GT::CGI::Cookie->new(%data);
    }
    else {                  # Set parameter.
        my ($param, $value) = @_;
        $self->{cookies}->{$param} = (ref $value eq 'ARRAY' ? $value : [$value]);
    }
}
END_OF_SUB

$COMPILE{set} = __LINE__ . <<'END_OF_SUB';
sub set {
#--------------------------------------------------------------------------------
# Let's you set a key/val parameter.
#
    my $self    = shift;
    $self = $self->class_new unless ref $self;
    $FORM_PARSED or $self->load_data();
    my $params  = $self->common_param(@_);

    foreach my $key (keys %$params) {
        $self->{params}->{$key} = $params->{$key};
    }
    return {%{$self->{params}}};
}
END_OF_SUB

sub param {
#--------------------------------------------------------------------------------
# Mimick CGI's param function for get/set.
#
    my $self = shift; # Not used, don't care if it's self/class.;
    $self = $self->class_new unless ref $self;
    $FORM_PARSED or $self->load_data();
    if (@_ == 0) {    # Return keys.
        return keys %{$self->{params}};
    }
    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) = @_;
        $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.
    if ($self->{nph} || $p{-nph}) {
        if ($p{-url}) {
            push @headers, "HTTP/1.0 302 Moved";
        }
        else {
            my $protocol = $ENV{SERVER_PROTOCOL} || 'HTTP/1.0';
            push @headers, "$protocol 200 OK" unless ($MOD_PERL);
        }
    }
    delete $p{-nph};

# If requested, add a "Pragma: no-cache" if requested
    if ($p{'no-cache'} or $p{'-no-cache'}) {
        delete @p{qw/no-cache -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-cache",
            "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}) {
        if ($cookies and $ENV{SERVER_SOFTWARE} =~ /IIS/i) {
            $iis_redirect = $url;
        }
        else {
            push @headers, "Location: $url";
        }
    }

# Add the Content-type header.
    my $type = @_ == 1 && !ref($_[0]) ? $_[0] : delete($p{-type}) || 'text/html';
    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 = join(CRLF, @headers) . CRLF . CRLF;

# 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;
<html><head><title>Document Moved</title><meta http-equiv="refresh" content="0;URL=$iis_redirect"></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

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;
    }
    else {
        $toencode =~ s/&/&amp;/g;
        $toencode =~ s/</&lt;/g;
        $toencode =~ s/>/&gt;/g;
        $toencode =~ s/"/&quot;/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/&amp;/&/g;
    }
    else {
        $todecode =~ s/&lt;/</g;
        $todecode =~ s/&gt;/>/g;
        $todecode =~ s/&quot;/"/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;
    $FORM_PARSED or $self->load_data();
    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,^[/\\]*|[/\\]*$,,g;
        $url .= "/$path/";      
    }
    $prog =~ s,^[/\\]*|[/\\]*$,,g;
    $url .= $prog;
    
    if ($path_info and $ENV{PATH_INFO}) {
        if (defined $ENV{SERVER_SOFTWARE} && ($ENV{SERVER_SOFTWARE} =~ /IIS/)) {
            $ENV{PATH_INFO} =~ s,$ENV{SCRIPT_NAME},,;
        }
        $url .= $ENV{PATH_INFO};
    }
    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;
    $FORM_PARSED or $self->load_data();
    my $opts = $self->common_param(@_);
    my $qs = '';
    foreach my $key (keys %{$self->{params}}) {
        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

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;

# 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) {
        unshift @{$self->{params}->{shift @input}}, shift @input;
    }
}

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 -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.

=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, and
-secure if the cookie is only valid for secure sites.

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.

=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) 2002 Gossamer Threads Inc.  All Rights Reserved.
http://www.gossamer-threads.com/

=head1 VERSION

Revision: $Id: CGI.pm,v 1.106 2002/06/04 22:39:12 jagerman Exp $

=cut