# vim: set cindent expandtab ts=4 sw=4:
#
# Copyright (c) 1998-2005 Chi-Keung Ho. All rights reserved.
#
# This programe is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; either version 2
# of the License, or (at your option) any later version.
#
# Extmail - a high-performance webmail to maildir
# $Id$

package Ext::CGI;
# Update: 2005-02-22, major change. We should completely advoid
# multiple calling 'new Ext::CGI' crash the form data!
use strict;
use Exporter;
use Ext::Utils;
use vars qw(%IN @ISA @EXPORT @EXPORT_OK $CRLF %CGIDATA);
use vars qw($LOADED $COOKIE %COOKIE_SESS);

@ISA = qw(Exporter);
@EXPORT = qw($CRLF);

%IN = ();

local $/ = $CRLF;

sub new {
    my $this = shift;
    my $self = bless {@_}, ref $this || $this;
    $self->init(@_);
    $self; # does not need new more obj ?
}

sub init {
    my $self = shift;
    my %opt = @_;

    # Currently for the reason to simplify, only support
    # Unix CRLF, sorry for M$ or VMS user
    $CRLF = "\015\012"; # \r\n
    $self->read_params unless ($self->{loaded});
}

sub read_params {
    my $self = shift;
    unless($self->{loaded}) { # XXX hack, works under CGI/FCGI
        $self->{loaded} = 1; # for class use
        %IN = %{$self->_read_params};
        $self->{in} = \%IN;
    }
    \%IN;
}

# Technology tricks: we shold not call read_params more times,
# because POST data can get only once, for later use, we should
# cache the result :)
sub _read_params
{
    my $self = shift;
    if ($LOADED) {
        return \%CGIDATA;
    }

    # XXX experimental code for persistent envirement
    if ($ENV{FCGI_ROLE} || $ENV{FCGI_APACHE_ROLE}) {
        require Ext::FCGI;
        Ext::FCGI::register_cleanup(\&cleanup);
    }

    %CGIDATA = ();
    my $in;
    my $meth = $_[1] ? $_[1] : $ENV{'REQUEST_METHOD'};

    $COOKIE = $self->raw_cookie;

METHOD: {
    if ($meth=~/post/i && defined $ENV{'CONTENT_TYPE'}
        && $ENV{'CONTENT_TYPE'}=~m#^multipart/form-data#) {
        my($bdr) = $ENV{'CONTENT_TYPE'} =~ /boundary=\"?([^\";,]+)\"?/;
        #$self->_debug_read($bdr);
        $self->_read_multiparts($bdr, $ENV{'CONTENT_LENGTH'});
        last METHOD;
    }

    if ($meth=~/post/i) { # XXX not multipart?
        read(STDIN, $in, $ENV{'CONTENT_LENGTH'});
        #print "in='$in'<br>\n";
    }

    if ($ENV{'QUERY_STRING'}) {
        if ($in) { $in .= "&".$ENV{'QUERY_STRING'}; }
        else { $in = $ENV{'QUERY_STRING'}; }
    }
 } # END of METHOD

    if(!$in) {
        $LOADED = 1;
        return \%CGIDATA;
    }

    foreach my $i (split(/\&/, $in)) {
        my ($k, $v) = split(/=/, $i, 2);
        $k = url2str($k);
        $v = url2str($v);

        #print "key=$k, val=$v<br>\n";
        $CGIDATA{$k} = defined($CGIDATA{$k}) ? $CGIDATA{$k}."\0".$v : $v;
    }
    # return a HASH reference
    # $self->{in} = $a;
    $LOADED = 1;
    \%CGIDATA;
}

## XXX Debug use only!
sub _debug_read {
    my $self = shift;
    my ($boundary) = @_;
    while(<STDIN>) {
        print $_;
    }
}

use vars qw($curline);
$curline = "";
### Multipart handers, curline and $ref will only effect inside these
# functions, and don't try to access them
sub _read_multiparts {
    no warnings; # XXX ouch :-(
    my $self = shift;
    my ($boundary, $length) = ($_[0], $_[1]);
    my $curbuf = "";
    my $num = 0;

    while($curbuf = _read_stdin($curline)) {
        # XXX XXX XXX XXX perl will complain the following error:
        # Use of uninitialized value in pattern match (m//) at line xx,
        # <STDIN> line yy, currently we can only disable the warning..
        #
        # Upate: 2005-08-03, strange regexp error here, some null file-upload
        # will cause un-match error, may be due to the special character, ouch:(
        #
        # The old code:
        # if($curbuf=~/^--$boundary/) and $curbuf=~!/^--$boundary--/) sucks!
        if($curbuf=~/^--$boundary$CRLF/) {
            my $buf = <STDIN>;
            if (length($buf)>0) {
                if($buf=~/^Content-Disposition:\s*.*;\s*filename="(.*)"/) {
                    my $filename = $1;
                    my $seq = _gen_tmpfile($num);

                    # ignore null or not fill filename :)
                    next if (not defined $filename or $filename eq "");
                    my $rv = _read_mimeparts($boundary, $buf, $seq);
                    $curbuf = $rv;
                    if($rv) {
                        $CGIDATA{UPLOAD_FILES}->{'part'.$num} =
                        {
                            path => $seq,
                            filename => $filename
                        };
                    }
                    $num++;
                }elsif($buf=~/^Content-Disposition:\s*.*;\s*name="([^:]+)"/) {
                    <STDIN>;
                    my ($k, $v) = ($1, _read_mimeparams($boundary));
                    #$k = url2str($k);
                    #$v = url2str($v);
                    $CGIDATA{$k} = $v; # XXX
                }
            } else { last; }
        }
        last if($curbuf=~/--$boundary--/);
    }
}

sub _read_mimeparts {
    my($boundary, $firstline, $seq) = @_;
    my $lastline = undef;

    $seq = untaint ($seq); # XXX useful under taint mode
    open(FD, ">$seq") or die "Failt to open $seq, $!\n";
    print FD $firstline;
    while(1) {
        my $buf = <STDIN>;
        last if length($buf)<1;
        if($buf=~/^--$boundary/) {
            $curline = $buf;
            $lastline =~ s/\r*\n$//g; # remove the last cr*lf
            print FD $lastline;
            close FD;
            return $buf;
        }else {
            print FD (defined $lastline ? $lastline : $buf);
        }
        $lastline = $buf;
    }
    close FD;
}

sub _read_mimeparams {
    my($boundary) = @_;
    my $buf = "";
    while(1) {
        my $s = <STDIN>;
        last if length($s)<1;
        if($s=~/^--$boundary/) {
            $curline = $s;
            last;
        }else { $buf .= $s; }
    }
    # return the correct value not include the
    # last CRLF tag.
    $buf =~s/$CRLF$//;
    $buf =~s/$CRLF/\n/g; # ouch ?
    $buf;
}

sub _read_stdin {
    my $sig = shift;
    if($sig) {
        undef $curline;
        return $sig;
    }
    <STDIN>;
}

sub _gen_tmpfile {
    my $seq = shift;
    my $sid = $CGIDATA{sid} ? $CGIDATA{sid} : "";
    my $seed = time.'-'.$$.'-'.$seq.'.msg'; # XXX

    if($sid) {
        if(!-d '/tmp/'.$sid) {
            mkdir untaint("/tmp/$sid"), 0700;
        }
        return '/tmp/'.$sid.'/'.$seed;
    }
    return '/tmp/'.$seed;
}

### END of multipar handlers

sub cgi {
    my $self = shift;
    my $name = $_[0];
    my $in = $self->read_params;

    #use Data::Dumper;
    #print Dumper($in);
    #printf "call from %s<br>\n", caller;
    defined $in->{$name} ? $in->{$name} : "";
}

# cgi_blist - get a bunch of cgi params, return it's value
# as array.
sub cgi_blist {
    my $self = shift;
    my @name = @_;
    my $in = $self->read_params;
    foreach (0...scalar @name) {
        if (defined $in->{$name[$_]}) {
            $name[$_]=$in->{$name[$_]};
        }else {
            $name[$_]="";
        }
    }
    @name; # return value map to the name
}

# cgi_full_names - return all name of parameters, not include
# values, use cgi_full_list if you want values
sub cgi_full_names {
    my $in = shift->read_params;
    my @names = ();
    for(keys %$in) {
        push @names, $_;
    }
    \@names;
}

# cgi_full_list - return the $in struct
sub cgi_full_list {
    shift->read_params;
}

# XXX experimental cookie support
#
# set_cookie - set a bunch of parameters for a cookie
sub set_cookie {
    my $self = shift;
    my %opt = @_;
    return 'Need cookie name' unless ($opt{name});

    my $name = delete $opt{name};

    $opt{expires} = $self->expires($opt{expires})       if defined $opt{expires};
    $opt{max_age} = expire_calc($opt{expires})-time()   if defined $opt{max_age};

    $COOKIE_SESS{$name} = \%opt;
    0;
}

sub get_cookie {
    my $self = shift;
    my $name = $_[0];
    my $cookie = $self->{_cookie} || $self->_parse_cookie;

    return unless $name;
    return $cookie->{$name};
}

sub raw_cookie {
    my $self = shift;
    my @parms = @_;
    my $cookie = $ENV{HTTP_COOKIE} || $ENV{COOKIE};
    $cookie;
}

sub _parse_cookie {
    my $self = shift;
    my $parsed = $self->{parsed_cookie};
    my %cookie = ();

    return $self->{_cookie} if $parsed;

    my @lists = split ("; ?", $COOKIE);

    for (@lists) {
        s/^\s*//;
        s/\s*$//;
        my ($k, $v) = split(/=/, $_, 2);
        next unless defined $v;
        my @values;
        $k = url2str($k);

        if ($v ne '') {
            @values = map url2str($_), split(/[&;]/, $v.'&dmy');
            pop @values;
        }
        $cookie{$k} = ($v eq '' ? $v : (scalar @values>1?\@values:$values[0]));
    }
    $self->{_cookie} = \%cookie;
}

sub expires {
    my $self = shift;
    my ($time, $format) = @_;
    $format ||= 'http';

    my(@MON)=qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
    my(@WDAY) = qw/Sun Mon Tue Wed Thu Fri Sat/;

    $time = expire_calc($time);
    return $time unless $time =~ /^\d+$/;

    my $sp = ' ';
    $sp = '-' if ($format eq 'cookie');
    my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime($time);
    $year += 1900;
    return sprintf("%s, %02d$sp%s$sp%04d %02d:%02d:%02d GMT",
        $WDAY[$wday],$mday,$MON[$mon],$year,$hour,$min,$sec);
}

sub cookie_string {
    my $self = shift;
    my $name = shift;

    if (defined $COOKIE_SESS{$name}) {
        my $h = $COOKIE_SESS{$name};
        my @arr;

        push @arr, "domain=$h->{domain}"    if ($h->{domain});
        push @arr, "path=$h->{path}"        if ($h->{path});
        push @arr, "expires=$h->{expires}"  if ($h->{expires});
        push @arr, "max-age=$h->{max_age}"  if ($h->{max_age});
        push @arr, "secure"                 if ($h->{secure});
        $name = str2url($name);
        my $cookie = join ('=', $name, join('&',map str2url($_), $h->{value}));
        return join("; ", $cookie, @arr);
    }
    '';
}

sub send_cookie {
    my $self = shift;

    return if $self->{cookie_sent};

    for my $key (keys %COOKIE_SESS) {
        my $val = $COOKIE_SESS{$key};
        print "Set-Cookie: ", $self->cookie_string($key), "\r\n";
    }
    $self->{cookie_sent} = 1;
    1;
}

# we will do cleanup in DESTROY(), this is the last chance
# to do it in a sigle object, but if we need per request
# cleanup, please refer to the cleanup() function below
sub DESTROY {
    my $self = shift;

    _cleantmp();

    undef %CGIDATA;
    undef $COOKIE;
    undef %COOKIE_SESS;
}

# per request cleanup function, called by FCGI/MOD_PERL or
# SPEEDY persistent implemention at the end of a request
sub cleanup {

    # call _cleantmp to do some cleanup, but this function should be
    # rewritten in the future, to adovid some race condition.
    _cleantmp();

    %CGIDATA = ();
    $LOADED = 0;
    $COOKIE = undef;
    %COOKIE_SESS = ();
}

sub _cleantmp {
    return unless ($CGIDATA{sid} && -d '/tmp/'.$CGIDATA{sid});

    opendir DIR, '/tmp/'.$CGIDATA{sid}; # ignore error
    my @f = grep { !/^\./ } readdir DIR;
    unlink untaint('/tmp/'.$CGIDATA{sid}.'/'.$_) for(@f);
    rmdir untaint('/tmp/'.$CGIDATA{sid});
}

1;