File Coverage

blib/lib/AppConfig/CGI.pm

Criterion	Covered	Total	%
statement	37	49	75.5
branch	10	20	50.0
condition			n/a
subroutine	6	7	85.7
pod	0	2	0.0
total	53	78	67.9

#============================================================================
#
# AppConfig::CGI.pm
#
# Perl5 module to provide a CGI interface to AppConfig.  Internal variables
# may be set through the CGI "arguments" appended to a URL.
#
# Written by Andy Wardley
#
# Copyright (C) 1997-2003 Andy Wardley.  All Rights Reserved.
# Copyright (C) 1997,1998 Canon Research Centre Europe Ltd.
#
#============================================================================

package AppConfig::CGI;
use strict;
use warnings;
use AppConfig::State;
our $VERSION = '1.70';


#------------------------------------------------------------------------
# new($state, $query)
#
# Module constructor.  The first, mandatory parameter should be a
# reference to an AppConfig::State object to which all actions should
# be applied.  The second parameter may be a string containing a CGI
# QUERY_STRING which is then passed to parse() to process.  If no second
# parameter is specifiied then the parse() process is skipped.
#
# Returns a reference to a newly created AppConfig::CGI object.
#------------------------------------------------------------------------

sub new {
    my $class = shift;
    my $state = shift;
    my $self  = {
        STATE    => $state,                # AppConfig::State ref
        DEBUG    => $state->_debug(),      # store local copy of debug
        PEDANTIC => $state->_pedantic,     # and pedantic flags
    };
    bless $self, $class;

    # call parse(@_) to parse any arg list passed
    $self->parse(@_)
        if @_;

    return $self;
}


#------------------------------------------------------------------------
# parse($query)
#
# Method used to parse a CGI QUERY_STRING and set internal variable
# values accordingly.  If a query is not passed as the first parameter,
# then _get_cgi_query() is called to try to determine the query by
# examing the environment as per CGI protocol.
#
# Returns 0 if one or more errors or warnings were raised or 1 if the
# string parsed successfully.
#------------------------------------------------------------------------

sub parse {
    my $self     = shift;
    my $query    = shift;
    my $warnings = 0;
    my ($variable, $value, $nargs);


    # take a local copy of the state to avoid much hash dereferencing
    my ($state, $debug, $pedantic) = @$self{ qw( STATE DEBUG PEDANTIC ) };

    # get the cgi query if not defined
    $query = $ENV{ QUERY_STRING }
        unless defined $query;

    # no query to process
    return 1 unless defined $query;

    # we want to install a custom error handler into the AppConfig::State
    # which appends filename and line info to error messages and then
    # calls the previous handler;  we start by taking a copy of the
    # current handler..
    my $errhandler = $state->_ehandler();

    # install a closure as a new error handler
    $state->_ehandler(
        sub {
            # modify the error message
            my $format  = shift;
            $format =~ s/
            $format =~ s/>/>/g;
            $format  = "\n[ AppConfig::CGI error: $format ] \n\n";
            # send error to stdout for delivery to web client
            printf($format, @_);
        }
    );


    PARAM: foreach (split('&', $query)) {

        # extract parameter and value from query token
        ($variable, $value) = map { _unescape($_) } split('=');

        # check an argument was provided if one was expected
        if ($nargs = $state->_argcount($variable)) {
            unless (defined $value) {
                $state->_error("$variable expects an argument");
                $warnings++;
                last PARAM if $pedantic;
                next;
            }
        }
        # default an undefined value to 1 if ARGCOUNT_NONE
        else {
            $value = 1 unless defined $value;
        }

        # set the variable, noting any error
        unless ($state->set($variable, $value)) {
            $warnings++;
            last PARAM if $pedantic;
        }
    }

    # restore original error handler
    $state->_ehandler($errhandler);

    # return $warnings => 0, $success => 1
    return $warnings ? 0 : 1;
}



# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# The following sub-routine was lifted from Lincoln Stein's CGI.pm
# module, version 2.36.  Name has been prefixed by a '_'.

# unescape URL-encoded data
sub _unescape {
    my($todecode) = @_;
    $todecode =~ tr/+/ /;       # pluses become spaces
    $todecode =~ s/%([0-9a-fA-F]{2})/pack("c",hex($1))/ge;
    return $todecode;
}

#
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -




1;

__END__