#!/usr/bin/perl -w

# CGI common functions
package mmCGI;
use strict;
use warnings;
use Crypt;

my $HeadPrinted = 0;

BEGIN {
    use Exporter ();
    our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
    $VERSION = 1.00;                    # version for version checking
    @ISA = qw(Exporter);
    @EXPORT = qw(CGIPrintHead);
    @EXPORT_OK = qw();                  # optionally exported functions


    if( defined( $ENV{'REQUEST_METHOD'} ) ) {
        if( defined( &main::DEBUG ) and main::DEBUG() )
        {
            $SIG{'__WARN__'} = \&CGIWarnFull;
            $SIG{'__DIE__'} = \&CGIErrFull;
        }
        else
        {
            $SIG{'__WARN__'} = \&CGIWarn;
            $SIG{'__DIE__'} = \&CGIErr;
        }
    }
}

#           our @EXPORT_OK;

sub CGIPrintHead
{
    my %Opt = ref( $_[0] ) ? %{$_[0]} : @_;

    $HeadPrinted or do {
        print "Content-type: text/html";
        if( defined( $Opt{ 'charset' } ) )
        { print '; charset=' . $Opt{ 'charset' }; }
        print "\n";
        if( defined( $Opt{ 'lang' } ) )
        { print "Content-language: $Opt{ 'lang' }\n" }
        print "\n";
    };
    $HeadPrinted = 1;
}

sub Decode
{
    my $Text = $_[ 0 ];
#    print  $Text . "<br>\n";

    $Text =~ s/\+/ /g; # Convert + to spaces
    $Text =~ s/%(..)/chr(hex($1))/ge; # Convert %XX from hex to character
#    print  $Text . "<br>\n";
    return $Text;
}

sub Encode
{
    my $Text = $_[ 0 ];
    
    $Text =~ s/([\x00-\x20+%=&\'\"\\\/])/sprintf( "%%%x", ord( $1 ) )/ge;
    return $Text;
}

sub FormEncode
{
    my $Text = $_[ 0 ];
    
    $Text =~ s/\"/&quot;/g;
    $Text =~ s/\'/&apos;/g;

    $Text;
}



sub qpartf
{
    my ($query, $addtag, $key, $val) = @_;

    defined( $val ) or return;
    if( ref( $val ) eq 'ARRAY' ) {
        $_ = '@' . FormEncode( $key );
        foreach my $v ( @{$val} ) {
            ref( $v ) and die;
            $$query .= "<input type=\'hidden\' name='$_' " .
                ( defined( $v ) ? "value='" . FormEncode( $v ) . "'" : '' )
                . ">\n";
        }
    } elsif( ref( $val ) eq 'HASH' ) {
        $_ = FormEncode( '%' . $key );
        foreach my $k ( keys( %{$val} ) ) {
            ref( $val->{$k} ) and die;
            $$query .= "<input type=\'hidden\' name='$_->" . Encode( $k ) .
                "' " .
                ( defined( $val->{$k} ) ? "value='" .
                  FormEncode( $val->{$k} ) . "'" : '' )
                . ">\n";
        }
    } else {
        ref( $val ) and die ;
        $$query .= "<input type=\'hidden\' name='" .
            FormEncode( $key ) . "' value='" . FormEncode( $val ) . "'>\n";
    }
}

sub qpart
{
    my ($query, $addtag, $key, $val) = @_;

    defined( $val ) or return;
    if( ref( $val ) eq 'ARRAY' ) {
        $_ = '@' . Encode( $key );
        foreach my $v ( @{$val} ) {
            ref( $v ) and die;
            $$query .=  $$addtag . $_ . '=' . Encode( $v );
            $$addtag = '&';
        }
    } elsif( ref( $val ) eq 'HASH' ) {
        $_ = Encode( '%' . $key );
        foreach my $k ( keys( %{$val} ) ) {
            ref( $val->{$k} ) and die;
            $$query .=  $$addtag . "$_->" . Encode( $k ) . '=' . 
                Encode( $val->{$k} );
            $$addtag = '&';
        }
    } else {
        ref( $val ) and die ;
        $$query .= $$addtag . Encode( $key );
        defined( $val ) and $$query .=  '=' . Encode( $val );
        $$addtag = '&';
    }
}

# qonly (\$query,...
sub qonly
{
    my ( $qpart, $query, $only, $arg ) = @_;
    my %keyset = ();
    @keyset{@{$only}} = @{$only};
    my $addtag = $$query ? '&' : '';

    for( my $inx = 0; $inx < $#{$arg}; $inx += 2 ) {
        $keyset{$arg->[$inx]} and
            $qpart->( $query, \$addtag, @{$arg}[$inx,$inx+1]);
    }
}

sub qexcept
{
    my ( $qpart, $query, $except, $arg ) = @_;
    my %keyset = ();
    @keyset{@{$except}} = @{$except};
    my $addtag = $$query ? '&' : '';

    for( my $inx = 0; $inx < $#{$arg}; $inx += 2 ) {
        $keyset{$arg->[$inx]} or
            $qpart->( $query, \$addtag, @{$arg}[$inx,$inx+1]);
    }
}

sub qall
{
    my ( $qpart, $query, $arg ) = @_;
    my $addtag = $$query ? '&' : '';

    for( my $inx = 0; $inx < $#{$arg}; $inx += 2 ) {
        $qpart->( $query, \$addtag, @{$arg}[$inx,$inx+1]);
    }
}

sub parseopts
{
    my ($arg) = @_;
    my $current = [];
    my $parsed = [];

    my $inx = 0;
    while( $inx < $#{$arg} || $inx== 0 ) {  #inx == 0 .. one argument case
        $_ = ref( $arg->[$inx] );
        $_ or do {
            $arg->[$inx] eq '_opts' and do {
                push @{$parsed}, $arg->[$inx+1], $current;
                $inx += 2;
                $current = [];
                next;
            };
            push @{$current}, @{$arg}[$inx, $inx+1];
            $inx += 2;
            next;
        };
        
        /^HASH$/ and do {
            push @{$current}, %{$arg->[$inx++]};
            next;
        };
        
        die;
        
    }

    if( $inx == $#{$arg} ) { # one arg remaining - opts
        push @{$parsed}, $arg->[$inx], $current;
    } elsif( $#{$current} < 0 ) { 
        # key-val '_opts' pair was last, nothing to do
    } else{  # key-val pair was the last, no options
        push @{$parsed}, {}, $current;
    }        
    return ($parsed, $parsed->[-2]);
}


# CombineQuery( values ......  '_opts' => \%options ...... \%options )
#
# values:  'key' => 'value'
#          { 'key' => 'value', ... }
#
# options: {  'only'   => [ fieldlist ] or
#             'except' => [ fieldlist ] or default all,
#             'ckey' => 'string'
#             'action' => 'string'
#          }
# ckey, action -- from last options.
# first argument -- always values if it is hash,
# last argument  -- always opts if it's a hash
#                    (i.e without _opts: ($opts,$opts,{})
sub CombineQuery
{
    my $Query = '';
    local $_;
    my ($pairs, $gopts) = parseopts( \@_ );
 
    for( my $inx = 0; $inx < $#{$pairs}; $inx += 2 ) {
#        print %{$pairs->[$inx]};
#        print @{$pairs->[$inx+1]};

        if( $pairs->[$inx]{'only'} ) {
            qonly( \&qpart, \$Query, $pairs->[$inx]{'only'}, $pairs->[$inx+1] );
        } elsif( $pairs->[$inx]{'except'} ) {
            qexcept( \&qpart, \$Query, $pairs->[$inx]{'except'},
                     $pairs->[$inx+1] );
        } else {
            qall( \&qpart, \$Query, $pairs->[$inx+1] );
        }
    }

    if( $gopts->{'ckey'} ) { 
       my $val = encrypt( $gopts->{'ckey'}, $Query );
       $Query = ''; my $t = '';
       qpart( \$Query, \$t, 'copts', $val );
    }

    return ( $gopts->{'action'} || '' ) . '?' . $Query;
}

sub CombineFormOpts 
{
    my $Query = '';
    local $_;
    my ($pairs, $gopts) = parseopts( \@_ );
    my $qp = $gopts->{'ckey'} ? \&qpart : \&qpartf;

    for( my $inx = 0; $inx < $#{$pairs}; $inx += 2 ) {
        if( $pairs->[$inx]{'only'} ) {
            qonly( $qp, \$Query, $pairs->[$inx]{'only'}, $pairs->[$inx+1] );
        } elsif( $pairs->[$inx]{'except'} ) {
            qexcept( $qp, \$Query, $pairs->[$inx]{'except'},
                     $pairs->[$inx+1] );
        } else {
            qall( $qp, \$Query, $pairs->[$inx+1] );
        }
    }

    if( $gopts->{'ckey'} ) { 
        my $val = encrypt( $gopts->{'ckey'}, $Query );
        $Query = '';
        qpartf( \$Query, undef, 'copts', $val );
    }

    return $Query;
}

# keys beginning with '@' - arrays

sub ParseInput
{
    my $_opts = ref( $_[0] ) ? shift : {};
    my ( $Row, @Values, $Values, $val, $arr, $hsh );

    # Read input, separate into @Values list
    if( $ENV{ 'REQUEST_METHOD' } and $ENV{ 'REQUEST_METHOD' } eq "GET") {
        @Values = split "&", $ENV{ 'QUERY_STRING' };
    } elsif( $ENV{ 'REQUEST_METHOD' } and $ENV{ 'REQUEST_METHOD' } eq "POST" ) {
        $Row = <>;
        @Values = split "&", $Row;        
    } else {
        @Values = split "&", $ARGV[0] || '';
    }

#    print "$Row\n";
    # Make hash with key->value pairs
    $Values = {};
    foreach my $key (@Values) 
    {
        if( $key =~ /^([^=]+)=/ ) {
            $key = $1;
            $val = Decode( $' ); #');
        } else {
            $val = $_opts->{ 'defval' };
        }
        $key = Decode( $key ); #');
        
        if( $key eq 'copts' and $_opts->{ 'ckey' } ) {
            my $copts = decrypt( $_opts->{ 'ckey' }, $val );
            push @Values, split "&", $copts;   
            next;
        }

        $_opts->{ 'utf8' }and utf8::decode( $val );

        $arr = 0;
        $hsh = undef;
        $key =~ /^\@/ and do { $key = $', $arr = 1 };  #';}
        $key =~ /^\%(.+)->(.+)/ and do { $key = $1, $hsh = $2; }; 
        if( defined( $Values->{ $key } ) ) {
            if( ref( $Values->{ $key } ) eq 'ARRAY' ) {
                $arr or warn "Next array value of $key without '\@'.";
                push @{ $Values->{ $key } }, $val; 
            } elsif( ref( $Values->{ $key } ) eq 'HASH' ) {
                defined($hsh) or die "Wrong next hash entry $key.";
                $Values->{ $key }{ $hsh } = $val;
            } else {
                defined($hsh) and die "Wrong hash entry $key.";
                warn "Array value of $key without '\@'.";
                $Values->{ $key } = [ $Values->{ $key }, $val ]; 
            }
        } elsif( $arr ) {
            $Values->{ $key } = [ $val ]; 
        } elsif( defined($hsh) ) {
            $Values->{ $key } = { $hsh => $val }; 
        } else {
            $Values->{ $key } = $val; 
        }
    }

#    if( $_opts->{ 'ckey' } and $Values->{ 'copts' } ) {
#        my $copts = decrypt( $_opts->{ 'ckey' }, $Values->{ 'copts' } );
#        delete( $Values->{ 'copts' } );
#        my @k = keys( %{$copts} );
#        @{$Values}{ @k } = @{$copts}{ @k };
#    }
    return $Values;
}

# Error handling ---------------------------------------------------------------

sub stack_trace
{
    my $t = '';
    my $i = 0;

    while( my ($p, $f, $l, $s) = caller( $i ) )
    {
        $t = "[$i] $s at $f:$l\n$t";
        ++ $i;
    }
    $t;
}

sub error_report
{
    
    print "<pre>", stack_trace(), "</pre>";

    if( defined( &main::DEBUG ) and main::DEBUG()->{'env'} )
    {
        print "<pre style='background-color:#DDFFDD'>ENV\n"; 
        foreach my $key (sort keys(%ENV)) {
            print "$key: $ENV{$key}\n";
        }
        print "\n</pre>";
    }
}

sub CGIWarn
{
}

sub CGIWarnFull
{
    CGIPrintHead();
    print "<h3 style=\"background-color: yellow;color:navy\">Internal warning</h3>\n";

    my $tx = "<span style=\"background-color: yellow;color: navy\">";
    foreach $_ (@_) { 
        my $t = $_;
        $t =~ s/</&lt;/g;
        $t =~ s/>/&gt;/g;
        $tx .= $t };
    $tx =~ s/\n/<br>/g;
    print $tx, "</span>\n";
    error_report;
}

sub CGIErr
{
    die @_ if $^S;
    CGIPrintHead();
    print "<h3 style=\"background-color: yellow;color:red\">Internal error</h3>\n";
    exit;
}

sub CGIErrFull
{
    die @_ if $^S;
    CGIPrintHead();
    print "<h3 style=\"background-color: yellow;color:red\">Internal error</h3>\n";
    my $tx = "<span style=\"background-color: yellow;color: maroon\">";
    foreach $_ (@_) { $tx .= $_ };
    $tx =~ s/\n/<br>/g;
    print $tx, "</span>\n";
    error_report;
    exit;
}

1;
