#------------------------------------------------------------------------------
#$Author: andrius $
#$Date: 2020-02-12 05:49:29 -0500 (Wed, 12 Feb 2020) $ 
#$Revision: 138 $
#$URL: svn://saulius-grazulis.lt/libraries/trunk/perl/CGIParameters/lib/CGIParameters.pm $
#------------------------------------------------------------------------------
#*
#  Process CGI parameters with specified defaults.
#**

package CGIParameters;

use strict;
use warnings;
use URI::Escape;
use URL::Encode qw( url_params_multi );

our $VERSION = '0.1.0-dev';

require Exporter;
our @ISA = qw( Exporter );
our @EXPORT = qw( read_cgi_parameters hash2get );

# Process CGI parameters, extracting and sanitizing known ones and using
# default values for not supplied keys.
# Accepts:
# -- CGI handle, as returned by CGI.pm
# -- hash, describing required CGI parameters, for example:
#      { sessid => { re => '[0-9a-f]+',
#                    errmsg => 'session %s does not exist' },
#        method => { re => 'direct|babel|immediate',
#                    default => 'babel' },
#        smiles => { re => '[^\s\;\'"]+' } }
sub read_cgi_parameters
{
    my( $cgi, $description, $options ) = @_;
    my $par;
    my $par_hash = $cgi->Vars;
    $options = {} unless $options;

    # A temporary hash must be used due to some Perl gotchas:
    my $split = {};
    for my $key ( sort keys %$par_hash ) {
        $split->{$key} = [ split( "\0", $par_hash->{$key} ) ];
    }
    $par_hash = $split;

    my $QS_hash = {};
    if( $options->{query_string} ) {
        $QS_hash = url_params_multi( $options->{query_string} );
    }

    # Form parameters have precedence over query string ones:
    $par_hash = { %$QS_hash, %$par_hash };

    # Passing through (without untainting) variables that match
    # provided RE:
    if( $options->{passthrough_re} ) {
        for my $key ( sort keys %$par_hash ) {
            next if $key !~ $options->{passthrough_re};
            my @values = @{$par_hash->{$key}};
            if( !@values ) {
                $par->{$key} = ''; # restoring the original value
            } elsif( @values == 1 ) {
                $par->{$key} = shift @values;
            } else {
                $par->{$key} = \@values;
            }
        }
    }

    my @changed;
    for my $key ( sort keys %$description ) {
        next if !exists $description->{$key}{re};
        next if exists $par->{$key};
        if( !exists  $par_hash->{$key} ||
            !defined $par_hash->{$key} ||
            @{$par_hash->{$key}} == 0 ) {
            next if !exists $description->{$key}{default};
            $par->{$key} =  $description->{$key}{default};
            next;
        }
        my $re = $description->{$key}{re};
        my @values = @{$par_hash->{$key}};
        my @values_now;
        foreach( @values ) {
            if( /^($re)$/ ) {
                push @values_now, $1;
            } else {
                my $errmsg = "Malformed query variable '$key' " .
                             "(should match regular expression '^($re)\$')";
                if( exists $description->{$key}{errmsg} ) {
                    $errmsg = $description->{$key}{errmsg};
                    my @sprintf_parameters = ( $_, $key, $re );
                    my @replacements = $errmsg =~ /%s/g;
                    @sprintf_parameters = @sprintf_parameters[0..@replacements-1];
                    $errmsg = sprintf $errmsg, @sprintf_parameters;
                }
                die $errmsg . "\n";
            }
        }
        if( $description->{$key}{multiple} ) {
            $par->{$key} = \@values_now;
            push @changed, $key;
        } else {
            $par->{$key} = $values_now[0];
            if( !exists $description->{$key}{default} ||
                (defined $par->{$key} &&
                 $description->{$key}{default} ne $par->{$key}) ) {
                push @changed, $key;
            }
        }        
    }
    if( wantarray ) {
        return $par, { map { $_ => 1 } @changed };
    } else {
        return $par;
    }
}

# Converts Perl hash into GET query string.
sub hash2get
{
    my( $h, $exclude, $overwrite ) = @_;

    my %copy = map { $_ => $h->{$_} } keys %$h;
    $exclude = {} unless $exclude;
    $overwrite = {} unless $overwrite;

    foreach( keys %$exclude ) {
        delete $copy{$_};
    }

    foreach( keys %$overwrite ) {
        $copy{$_} = $overwrite->{$_};
    }

    my @kv_pairs;
    for my $key ( sort keys %copy ) {
        if( ref $copy{$key} eq 'ARRAY' ) {
            @kv_pairs = ( @kv_pairs, map { "$key=" . uri_escape( $_ ) }
                                         @{ $copy{$key} } );
        } else {
            push @kv_pairs, "$key=" . uri_escape( $copy{$key} );
        }
    }

    return join( '&', @kv_pairs );
}

1;