CGI::ValidOp - Simple validation of CGI parameters and runmodes.

    # given the following CGI parameters:
    # op=add_item; name=William Blake; ssn=345-21-6789; crackme=$ENV{EVIL_MEAT};

    use CGI::ValidOp;

    my $cgi = CGI::ValidOp->new({
        add_item => {   # using full syntax
            name => {
                label => 'Name',
                checks => [ 'required', 'text::words' ],
            },
            ssn => {
                label => 'Social Security number',
                checks => [ 'demographics::us_ssn' ],
            },
        },
        remove_item => {   # using shortcut syntax
            ssn => [ 'Social Security number', 'required', 'demographics::us_ssn' ],
            confirm => [ 'Confirmation checkbox', 'required', 'checkbox::boolean' ],
        },
        cgi_object => new CGI($fh),
    });

    my $name    = $cgi->param( 'name' );    # eq "William Blake"
    my $ssn     = $cgi->param( 'ssn' );     # eq "345-21-6789"
    my $crackme = $cgi->param( 'crackme' ); # is undef; it was removed by the check
    my $confirm = $cgi->param( 'confirm' ); # is undef; it doesn't exist

    my $op      = $cgi->op;                 # eq "add_item"
    my @errors  = $cgi->errors;             # eq ( 'Parameter "crackme" contained invalid data.' )
    my %vars    = $cgi->Vars;               # eq (
                                            #   name    => "William Blake",
                                            #   ssn     => "345-21-6789",
                                            #   crackme => undef,
                                            # )

    my $cgi = CGI::ValidOp->new({
        -allow_unexpected => 0,     # configuration option
        add => {},                  # op, or runmode definition
    );

    my $cgi = CGI::ValidOp->new({
        -allow_unexpected   => 0,
        -default_op         => 'home',
    });

    $cgi->default_op( 'view' );  # overrides 'home' above

    $cgi->error_decoration( '"' );
    # "Confirmation checkbox" is required.

    $cgi->error_decoration( '* ', undef );
    # * Confirmation checkbox is required.

    $cgi->error_decoration( undef, ':' );
    # Confirmation checkbox: is required.

    $cgi->error_decoration( '<strong>', '</strong>' );
    # <strong>Confirmation checkbox</strong> is required.

package CGI::ValidOp;
use strict;
use warnings;

our $VERSION = '0.56';

use base qw/ CGI::ValidOp::Base /;
use CGI::ValidOp::Op;
use CGI::ValidOp::Param;
use CGI::ValidOp::Object;
use CGI;
use Carp qw/ croak confess /;
use Data::Dumper;

# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sub PROPERTIES {
    {
        ops                 => undef,
        print_warnings      => 1,
        default_op          => 'default',
        runmode_name        => 'op',
        disable_uploads     => 1,
        post_max            => 25_000,
        -cgi_object         => new CGI,
        -error_decoration   => undef,
        -allow_unexpected   => 1,
        -on_error_return_undef   => 0,
        -on_error_return_encoded => 0,
        -on_error_return_tainted => 0,
        -return_only_received    => 0,
    }
}

# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# the argument parsing means:
# 1) if an argument is prefixed with a '-', take it as a config option
# 2) else take it as an op
sub init {
    my $self = shift;
    my( $args ) = @_;

    my( %ops, %config );
    if( ref $args eq 'HASH' ) {
        for( keys %$args ) {
            $_ =~ /^-(.*)$/
                ? $config{ $1 } = $args->{ $_ }
                : $ops{ $_ } = $args->{ $_ };
        }
        $config{ ops } = \%ops if keys %ops;
        $self->SUPER::init( \%config );
    }
    else {
        $self->SUPER::init;
    }

    # order of precedence for on_error arguments -- only one of the three
    # shold be active at once
    $self->on_error_return_undef( 1 )
        unless $self->on_error_return_encoded
        or $self->on_error_return_tainted;
    $self->on_error_return_tainted( 0 )
        if $self->on_error_return_undef
        or $self->on_error_return_encoded;
    $self->on_error_return_encoded( 0 )
        if $self->on_error_return_undef;

    $self->get_cgi_vars;
    $self;
}

# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sub cgi_object {
    my $self = shift;
    my( $value ) = @_;

    return $self->{ cgi_object }
        unless defined $value;

    $self->{cgi_object} = $value;
}


# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sub reset_on_error {
    my $self = shift;

    # we want object construction not to account for precedence
    return if $self->{ in_init };
    $self->{ $_ } = 0 for qw/
        on_error_return_undef
        on_error_return_encoded
        on_error_return_tainted
    /;
    return;
}

# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sub on_error_return_undef {
    my $self = shift;
    my( $value ) = @_;

    return $self->{ on_error_return_undef }
        unless defined $value;
    $self->reset_on_error if $value;
    $self->{ on_error_return_undef } = $value ? 1 : 0;
    return $self->{ on_error_return_undef };
}

# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sub on_error_return_encoded {
    my $self = shift;
    my( $value ) = @_;

    return $self->{ on_error_return_encoded }
        unless defined $value;
    $self->reset_on_error if $value;
    $self->{ on_error_return_encoded } = $value ? 1 : 0;
    return $self->{ on_error_return_encoded };
}

# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sub on_error_return_tainted {
    my $self = shift;
    my( $value ) = @_;

    return $self->{ on_error_return_tainted }
        unless defined $value;
    $self->reset_on_error if $value;
    $self->{ on_error_return_tainted } = $value ? 1 : 0;
    return $self->{ on_error_return_tainted };
}

# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# FIXME if you add a param and then change allow_unexpected, that param will go away
sub allow_unexpected {
    my $self = shift;

    return $self->{ allow_unexpected } unless @_;
    $self->{ allow_unexpected } = shift;
    $self->set_vars; # FIXME this is a hack; related to the above FIXME
}

# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sub return_only_received {
    my $self = shift;

    return $self->{ return_only_received } unless @_;
    $self->{ return_only_received } = shift;
    $self->{ return_only_received };
}

# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sub get_cgi_vars {
    my $self = shift;

    $CGI::POST_MAX = $self->post_max;
    $CGI::DISABLE_UPLOADS = $self->disable_uploads;
    $self->set_vars({ $self->cgi_object->Vars });
# next two lines may be necessary for file uploads, but break existing
# multi-value param functionality
#     my $cgi = CGI->new;
#     $self->set_vars({ map { $_ => $cgi->param( $_ )} $cgi->param });
    return; # so we can't get untainted user input
}

# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# an empty hashref {} resets vars
# TODO should accept arrayrefs as values
sub set_vars {
    my $self = shift;
    my( $vars ) = @_;

    return if $self->{ in_init }; # if we're still being initialized
    if( ref $vars eq 'HASH' ) {
        if( keys %$vars == 0 ) {
            delete $self->{ _vars };
        }
        else {
            $self->{ _vars } = $vars;
        }
    }
    $self->make_op;
    $self->make_params;
    return; # so we can't get untainted user input
}

# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# make the current Op object and add the defined params
sub make_op {
    my $self = shift;

    delete $self->{ Op };
    my $options = $self->ops;
    return unless my $params = $options->{ $self->op };
    for( keys %$params ) {
        next if /^-.*/;
        $self->add_param( $_, $params->{ $_ });
    }
    return;
}

# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# makes parameters using incoming vars
sub make_params {
    my $self = shift;

    my $vars = $self->{ _vars };
    # create params if we need to and are allowed
    if( $self->allow_unexpected ) {
        for( keys %$vars ) {
            next if $_ eq $self->runmode_name; # don't make one for runmode
            if (/\[/ || /^object--/) {
                $self->append_to_object($_);
            }
            # Make it available even if it is added to an object
            $self->add_param( $_ ) unless $self->Op->Param( $_ );
        }
    }
    # set all tainted values
    $_->tainted( $vars->{ $_->name }) for $self->Op->Param;
    return;
}

# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# appends a parameter to an object - takes a parameter name as an argument.
sub append_to_object {
    my $self = shift;
    my ($param_name) = @_;

    $self->{_objects} ||= { };

    $param_name =~ /^object--(\w+)--/ || $param_name =~ /^([^\[]+)/;
    my $name = $1;

    return unless ($self->{_objects}{$name});

    $self->{_objects}{$name}->set_var({ name => $param_name, value => $self->{_vars}{$param_name} });
    return $name;
}

# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# accepts:
# ( $name )
# ( \%options )
# ( $name, \%options )
# ( $name, [ $label, @checks ])
sub add_param {
    my $self = shift;

    my $param;
    if( @_ == 1 ) { # either a hashref or a single name
        $param = $self->Op->add_param( @_ );
    }
    else { # either a name and hashref or a name and arrayref
        my( $name, $vars ) = @_;
        my( $label, $checks );
        if ( ref $vars eq 'ARRAY' ) {
            $label = $vars->[0];
            # slice and take a reference to that, copying 1..-1
            $checks = [@{$vars}[1..$#$vars]];

            $param = $self->Op->add_param({
                    name    => $name,
                    label   => $label,
                    checks  => $checks,
            });
        }
        elsif( ref $vars eq 'HASH' ) {
            $self->{_objects} ||= { };
            $param = $self->{_objects}{$name} = CGI::ValidOp::Object->new($name, $vars);
        }
        else {
            croak qr/Incorrect param definition./;
        }
    }

    if ($param->isa('CGI::ValidOp::Param')) {
        $param->tainted( $self->{ _vars }{ $param->name })
            if defined $self->{ _vars };
    }

    $param;
}

# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# capitalized for CGI compatibility
sub Vars {
    my $self = shift;
    my %params;
    my @vars = keys %{ $self->{ _vars }}
        if $self->{ _vars };
    for( $self->Op->Param ) {
        my $name = $_->name;
        next
            if $self->return_only_received and not grep /^$name$/ => @vars;
        $params{ $name } = $_->value;
    }
    return unless keys %params;
    wantarray
        ? %params
        : \%params;
}

# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# fetches an object collection
sub objects {
    my $self = shift;
    my ($object_name) = @_;

    $self->{_objects} ||= { };

    if (defined($object_name)) {
        return $self->{_objects}{$object_name} ? $self->{_objects}{$object_name}->objects : []; 
    }

    my $hash = { };
    foreach my $key (keys %{$self->{_objects}}) {
        $hash->{$key} = $self->{_objects}{$key}->objects || [];
    }

    return $hash;
}

# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# fetches all the errors for object collections
sub object_errors {
    my $self = shift;
    my ($object_name) = @_;

    if (defined($object_name)) {
        # return the errors just for the requested object
        return $self->{_objects}{$object_name} ? $self->{_objects}{$object_name}->object_errors : {};
    }

    my $hash = { };
    # return all the object errors in a hash keyed by the object name
    foreach my $key (keys %{$self->{_objects}}) {
        $hash->{$key} = $self->{_objects}{$key}->object_errors;
    }

    return $hash;
}

# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sub op {
    my $self = shift;
    $self->Op( @_ )->name;
}

# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# given a scalar, returns the op for which that scalar is an alias
# accounts both for alias being a string and an arrayref
# alias is case-sensitive
sub op_alias {
    my $self = shift;
    my( $alias ) = @_;

    return unless $alias and $self->ops;
    for( keys %{ $self->ops }) {
        next unless $self->ops->{ $_ }{ -alias };
        return $_ if $self->ops->{ $_ }{ -alias } eq $alias;
        return $_ if ref $self->ops->{ $_ }{ -alias } eq 'ARRAY'
            and grep /^$alias$/, @{ $self->ops->{ $_ }{ -alias }};
    }
    return;
}

# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sub get_op_name {
    my $self = shift;

    my $op_name;
    if( $self->{ _vars } and $self->{ _vars }{ $self->runmode_name }) {
        $op_name = $self->{ _vars }{ $self->runmode_name };
        ( $op_name ) = split /\0/, $op_name;  # if we get more than one, use the first
        $op_name = $self->op_alias( $op_name )
            if $self->op_alias( $op_name );
        $op_name = $self->default_op
            unless $self->ops
            and grep /^$op_name$/i => keys %{ $self->ops };
    }
    else {
        $op_name = $self->default_op;
    }
    lc $op_name;
}

# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# FIXME if you add a param and then change op, that param will go away
sub Op {
    my $self = shift;
    my( $op_name ) = @_;

    croak 'Invalid op name; only a word is allowed.'
        if $op_name and $op_name !~ /^\w+$/;
    unless( $op_name ) {
        return $self->{ Op } if $self->{ Op };
        $op_name = $self->get_op_name;
    }

#     print STDERR Dumper[
#         $self->{ on_error_return_undef },
#         $self->{ on_error_return_encoded },
#         $self->{ on_error_return_tainted },
#         ];

    my $on_error_return = $self->on_error_return_encoded    ? 'encoded'
        : $self->on_error_return_tainted                    ? 'tainted'
        :                                                     'undef';
    $self->{ Op } = CGI::ValidOp::Op->new({
        name => $op_name,
        error_decoration    => [ $self->error_decoration ],
        on_error_return => $on_error_return,
    });
    $self->{ Op };
}

# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sub param {
    my $self = shift;
    my( $param_name, $checks ) = @_;

    # return all param names if we're not asked for one
    unless( $param_name ) {
        my @params = map $_->name, $self->Op->Param;
        return @params if @params;
        return;
    }
    my $param = $self->Op->Param( $param_name, $checks );
    if( !$param and $checks ) { # if we have checks create the param
        $param = $self->add_param($param_name, [ $param_name, @$checks ]);
    }
    return $param->value if $param;
    return;
}

# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sub errors {
    my $self = shift;

    return unless $self->Op->Param;
    my @errors;
    for( $self->Op->Param ) {
        $_->validate; # slightly nasty to have to do this
        next unless my $errors = $_->errors;
        push @errors => @$errors;
    }
    @errors = sort @errors;
    return \@errors if @errors;
    return;
}

1;

__END__

# $Id: ValidOp.pm 387 2005-04-21 23:45:27Z soh $