File Coverage

blib/lib/Gantry/Engine/CGI.pm

Criterion	Covered	Total	%
statement	48	326	14.7
branch	7	106	6.6
condition	7	71	9.8
subroutine	10	59	16.9
pod	53	53	100.0
total	125	615	20.3

package Gantry::Engine::CGI;
require Exporter;

use strict;
use Carp qw( croak );
use CGI::Simple;
use File::Basename;
use Gantry::Utils::DBConnHelper::Script;

use vars qw( @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS );

############################################################
# Variables                                                #
############################################################
@ISA        = qw( Exporter );
@EXPORT     = qw(
    apache_param_hash
    apache_uf_param_hash
    apache_request
    base_server
    cgi_obj
    config
    cast_custom_error
    consume_post_body
    declined_response
    dispatch_location
    engine
    engine_init
    err_header_out
    fish_location
    fish_method
    fish_path_info
    fish_uri
    fish_user
    fish_config
    get_auth_dbh
    get_cached_config
    get_config
    get_dbh
    get_post_body
    locations
    log_error
    get_arg_hash
    header_in
    header_out
    hostname
    is_connection_secure
    is_status_declined
    port
    print_output
    redirect_response
    remote_ip
    send_http_header
    set_cached_config
    set_content_type
    set_no_cache
    set_req_params
    status_const
    send_error_output
    success_code
    server_root
    file_upload
);

@EXPORT_OK  = qw( );

############################################################
# Functions                                                #
############################################################

#--------------------------------------------------
# $self->new( { locations => {..}, config => {..} } );
#--------------------------------------------------
sub new {
    my( $class, $self ) = ( shift, shift || {} );

    bless $self, $class;

    my $config = $self->{config};

    if ( $self->{config}{ GantryConfInstance } ) {
        $config = $self->get_config(
                        $self->{config}{ GantryConfInstance },
                        $self->{config}{ GantryConfFile     },
                  );
    }

    Gantry::Utils::DBConnHelper::Script->set_conn_info(
        {
            dbconn => $config->{dbconn},
            dbuser => $config->{dbuser},
            dbpass => $config->{dbpass},
        }
    );

    Gantry::Utils::DBConnHelper::Script->set_auth_conn_info(
        {
            auth_dbconn => $config->{auth_dbconn},
            auth_dbuser => $config->{auth_dbuser},
            auth_dbpass => $config->{auth_dbpass},
        }
    );

    $CGI::Simple::DISABLE_UPLOADS = $config->{disable_uploads} || 0;
    $CGI::Simple::POST_MAX        = $config->{post_max} ||'20000000000';

    return $self;

} # end new

#--------------------------------------------------
# $self->add_config( key, value );
#--------------------------------------------------
sub add_config {
    my( $self, $key, $val ) = @_;
    $self->{cgi_obj}{config}->{$key} = $val;

} # end add_config

#--------------------------------------------------
# $self->add_location( key, value )
#--------------------------------------------------
sub add_location {
    my( $self, $key, $val ) = @_;

    $self->{locations}->{$key} = $val;

} # end add_location

#--------------------------------------------------
# $self->consume_post_body();
#--------------------------------------------------
sub consume_post_body {
    my $self = shift;
    my $cgi  = shift;

    my $content_length = $ENV{ CONTENT_LENGTH };

    return unless $content_length; # nothing to consume

    $content_length    = 1e6 if $content_length > 1e6; # limit to ~ 1Meg

    # just read STDIN
    my $content;
    my $buffer;
    while ( read( STDIN, $buffer, $content_length ) ) {
        $content .= $buffer;

        $content_length -= length $buffer;
    }

    $self->{__POST_BODY__} = $content;
}

#--------------------------------------------------
# $self->get_post_body();
#--------------------------------------------------
sub get_post_body {
    my $self = shift;

    return $self->{__POST_BODY__} || $self->{ cgi_obj }->{__POST_BODY__};
    # the value is in the cgi_obj during testing
}

#--------------------------------------------------
# $self->dispatch();
#--------------------------------------------------
sub dispatch {
    my( $self ) = @_;

    my @path = ( split( m|/|, $ENV{PATH_INFO}||'' ) );

    LOOP:
    while ( @path ) {

        $self->{config}->{location} = join( '/', @path );

        if ( defined $self->{locations}->{ $self->{config}->{location} } ) {
            my $mod = $self->{locations}->{ $self->{config}->{location} };

            die "module not defined for location $self->{config}->{location}"
                unless $mod;

            eval "use $mod";
            if ( $@ ) { die $@; }

            return $mod->handler( $self );

        }

        pop( @path );

    } # end while path

    $self->{config}->{location} = '/';
    my $mod = $self->{locations}->{ '/' };

    eval "use $mod" if $mod;
    if ( $@ ) { die $@; }

    return $mod->handler( $self );

} # end dispatch

#-------------------------------------------------
# Exported methods
#-------------------------------------------------

#-------------------------------------------------
# $self->file_upload( param_name )
#-------------------------------------------------
sub file_upload {
    my( $self, $param ) = @_;

    die "file param required" if ! $param;

    my $q = $self->cgi();
    my $filename = $q->param( $param );
    $filename =~ s/\\/\//g;

    my( $name, $path, $suffix ) = fileparse(
        $filename,
        qr/\.(tar\.gz$|[^.]*)/
    );

    return( {
        unique_key => time . rand( 6 ),
        fullname   => ( $name . $suffix ),
        name       => $name,
        suffix     => $suffix,
        size       => ( $q->upload_info( $filename, 'size' ) || 0 ),
        mime       => $q->upload_info( $filename, 'mime' ),
        filehandle => $q->upload( $filename ),
    } );

}

#-------------------------------------------------
# $self->cast_custom_error( error )
#-------------------------------------------------
sub cast_custom_error {
    my( $self, $error_page, $die_msg ) = @_;

    my $status = $self->status() ? $self->status() : '400 Bad Request';

    eval {
        print $self->cgi->header(
            -type => 'text/html',
            -status => $status,
        );
    };
    if ( $@ ) {
        die "Error encountered in cast_custom_error: $@\n"
            .   "I was trying to say $error_page\n";
    }

    $self->print_output( $error_page );

    return $status;

}

#-------------------------------------------------
# $self->apache_param_hash( $req )
#-------------------------------------------------
sub apache_param_hash {
    my( $self ) = @_;

    #my %hash_ref = $self->cgi->Vars;
    #return( \%hash_ref );
    return( $self->cgi_obj->{params} );

} # end: apache_param_hash

#-------------------------------------------------
# $self->apache_uf_param_hash( $req )
#-------------------------------------------------
sub apache_uf_param_hash {
    my( $self ) = @_;

    return( $self->cgi_obj->{uf_params} );

} # end: apache_uf_param_hash

#-------------------------------------------------
# $self->apache_request( )
#-------------------------------------------------
sub apache_request {
    my( $self, $r ) = @_;

} # end: apache_request

#-------------------------------------------------
# $self->base_server( $r )
#-------------------------------------------------
sub base_server {
    my( $self ) = ( shift );

    return( $ENV{HTTP_SERVER} || $ENV{HTTP_HOST} );

} # end base_server

#-------------------------------------------------
# $self->hostname( )
#-------------------------------------------------
sub hostname {
    my( $self ) = ( shift );

    return( $ENV{HTTP_SERVER} || $ENV{HTTP_HOST} );

} # end hostname

#--------------------------------------------------
# $self->cgi_obj( $hash_ref )
#--------------------------------------------------
sub cgi_obj {
    my( $self, $hash_ref ) = @_;

    if ( defined $hash_ref ) {
        $self->{cgi_obj} = $hash_ref;
    }

    return $self->{cgi_obj};
} # end cgi_obj

#--------------------------------------------------
# $self->config( $hash_ref )
#--------------------------------------------------
sub config {
    my( $self, $hash_ref ) = @_;

    if ( defined $hash_ref ) {
        $self->{cgi_obj}{config} = $hash_ref;
    }

    return $self->{cgi_obj}{config};
} # end config

#-------------------------------------------------
# $self->declined_response( )
#-------------------------------------------------
sub declined_response {
    my( $self, $action )  = @_;

    print $self->cgi->header(
            -type => 'text/html',
            -status => '404 Not Found',
    );

    my $current_location = $self->config->{ location };

    print( $self->custom_error(
                "Declined - undefined method"
                . ""
                . "Method: $action"
                . "Location: " . $current_location . ""
                . "Module: " . (
                    $self->locations->{ $current_location }
                    || 'No module defined for this location' )
                . ""
           )
    );

    return '404 Not Found';

} # END declined_response

#-------------------------------------------------
# $self->dispatch_location( )
#-------------------------------------------------
sub dispatch_location {
    my $self   = shift;

    return( $ENV{ PATH_INFO }, $self->config->{location} );
} # END dispatch_location

#--------------------------------------------------
# $self->engine
#--------------------------------------------------
sub engine {
    return __PACKAGE__;
} # engine

#-------------------------------------------------
# $self->engine_init( $cgi_obj )
#-------------------------------------------------
sub engine_init {
    my $self    = shift;
    my $cgi_obj = shift;
    my $c = new CGI::Simple();

    $c->parse_query_string() if $ENV{ REQUEST_METHOD } eq 'POST';
    $self->cgi( $c );

    # check for CGI::Simple errors
    if ( $c->{'.cgi_error'} ) {
        my $error = $c->{'.cgi_error'};
        my ( $status ) = ( $error =~ s/^(\d+)\s+// );
        $self->status( $status || 400 );
        die( "$error\n" );
    }

    # fix up params so the multiselects are arraays
    my $params    = {};
    my $uf_params = {};

    foreach my $field ( $c->param ) {
        my @values = $c->param( $field );

        if ( scalar @values > 1 ) {
            $uf_params->{$field} = [ @values ];

            # Replace angle brackets and quotes with named-entity equivalents.
            $_ =~ s/
            $_ =~ s/>/>/g foreach @values;
            $_ =~ s/"/"/g foreach @values;
            $_ =~ s/'/'/g foreach @values;

            # Trim leading / trailing whitespace.
            $_ =~ s/^\s+//o foreach @values;
            $_ =~ s/\s+$//o foreach @values;

            $params->{$field} = [ @values ];
        }

        else {
            $params->{$field} = $c->param( $field );
            $uf_params->{$field} = $params->{$field};

            # Replace angle brackets and quotes with named-entity equivalents.
            $params->{$field} =~ s/
            $params->{$field} =~ s/>/>/g;
            $params->{$field} =~ s/"/"/g;
            $params->{$field} =~ s/'/'/g;

            # Trim leading / trailing whitespace.
            $params->{$field} =~ s/^\s+//o;
            $params->{$field} =~ s/\s+$//o;
        }
    }

    # add in the fieldnames
    $params->{'.fieldnames'} = [ $c->param ];
    $uf_params->{'.fieldnames'} = [ $c->param ];

    # If the application has specified that it wants the unfiltered params
    # by default, then make it happen.
    if ($self->fish_config( 'unfiltered_params' ) && $self->fish_config( 'unfiltered_params' ) =~ /(1|on)/i) {
        $cgi_obj->{params} = $uf_params;
    }

    # Else, the application gets the request parameters filtered by default.
    # NOTE: It's got access to the unfiltered hash, in case it needs a
    # request/field to have the parameters in such a way.
    else {
        $cgi_obj->{params} = $params;
        $cgi_obj->{uf_params} = $uf_params;
    }

    $self->cgi_obj( $cgi_obj );

} # END engine_init

#-------------------------------------------------
# $self->err_header_out( $header_key, $header_value )
#-------------------------------------------------
sub err_header_out {
    # Gantry.pm calls this for mod_perl's benefit.
} # end err_header_out

#-------------------------------------------------
# $self->fish_location( )
#-------------------------------------------------
sub fish_location {
    my $self = shift;

    my $app_rootp = $self->fish_config( 'app_rootp' ) || '';
    my $location  = $self->fish_config( 'location' )  || '';

    return( $app_rootp . $location );
} # END fish_location

#-------------------------------------------------
# $self->fish_method( )
#-------------------------------------------------
sub fish_method {
    my $self = shift;

    return $ENV{ REQUEST_METHOD };
} # END fish_method

#-------------------------------------------------
# $self->fish_path_info( )
#-------------------------------------------------
sub fish_path_info {
    my $self = shift;

    return $ENV{ PATH_INFO };
} # END fish_path_info

#-------------------------------------------------
# $self->fish_uri( )
#-------------------------------------------------
sub fish_uri {
    my $self = shift;

    my $sn = $ENV{SCRIPT_NAME} || '';
    my $pi = $ENV{PATH_INFO}   || '';

    return( "${sn}${pi}" );
} # END fish_uri

#-------------------------------------------------
# $self->fish_user( )
#-------------------------------------------------
sub fish_user {
    my $self = shift;

    return $self->user() || $self->{cgi_obj}{config}{user} || '';
} # END fish_user

#--------------------------------------------------
# $self->fish_config( $param )
#--------------------------------------------------
sub fish_config {
    my $self     = shift;
    my $param    = shift;

    # see if there is Gantry::Conf data
    my $conf     = $self->get_config();

    return $$conf{ $param } if ( defined $conf and defined $$conf{ $param } );

    # otherwise, look in the cgi engine object
    # ... starting at the location levels
    if ( $self->{ cgi_obj }{ config }{ GantryLocation } ) {
        my $glocs = $self->{ cgi_obj }{ config }{ GantryLocation };
        my $loc   = $self->location;
        my @path  = split( '/', $loc );

        while( @path ) {

            my $path = join( '/', @path );

            if ( defined $glocs->{ $path }
                    and
                 defined $glocs->{ $path }{ $param }
            ) {
                return $glocs->{ $path }{ $param };
            }

            pop @path;
        }
    }

    # ... then defaulting to the top level
    return $self->{cgi_obj}{config}{ $param };

}

#--------------------------------------------------
# $self->get_config
#--------------------------------------------------
sub get_config {
    my $self     = shift;
    my $instance = shift || $self->{cgi_obj}{config}{ GantryConfInstance };

    return unless defined $instance;

    my $file     = shift || $self->{cgi_obj}{config}{ GantryConfFile };

    my $conf;
    my $cached   = 0;
    my $location = '';


    eval {
        $location = $self->location;
    };

    $conf = $self->get_cached_config( $instance, $location );
    if ( defined $conf ) {
        return $conf;
    }

    my $gantry_cache     = 0;
    my $gantry_cache_key = '';
    my $gantry_cache_hit = 0;
    eval {
        ++$gantry_cache if $self->cache_inited();
    };

    # are we using gantry cache ?
    if ( $gantry_cache ) {

        $self->cache_namespace('gantry');

        # blow the gantry conf cache when server starts
        if ( $self->engine_cycle() == 1 ) {

            eval {
                foreach my $key ( @{ $self->cache_keys() } ) {
                    my @a = split( ':', $key );
                    if ( $a[0] eq 'gantryconf' ) {
                        $self->cache_del( $key );
                    }
                }
            };
        }

        # build cache key
        $gantry_cache_key = join( ':',
            "gantryconf",
            ( $self->namespace() || '' ),
            $instance,
            $location
        );

        $conf = $self->cache_get( $gantry_cache_key );

        ++$gantry_cache_hit if defined $conf;
    }

    # There will be an error if this method was called during construction
    # that is before their is a Gantry descended object as the invocant.
    # In that case, we don't care about the location anyway.
    require Gantry::Conf;

    $conf      ||= Gantry::Conf->retrieve(
        {
            instance    => $instance,
            config_file => $file,
            location    => $location
        }
    );

    if ( defined $conf ) {
        $self->set_cached_config( $instance, $location, $conf );

        if ( $gantry_cache && ! $gantry_cache_hit ) {
            $self->cache_set( $gantry_cache_key, $conf );
        }
    }

    return $conf;

} # END get_config

my %conf_cache;

sub get_cached_config {
    my $self     = shift;
    my $instance = shift;
    my $location = shift;

    return $conf_cache{ $instance . $location } || undef;
}

sub set_cached_config {
    my $self     = shift;
    my $instance = shift;
    my $location = shift;                 # not using location, this cache good for one page
    my $conf     = shift;

    $conf_cache{ $instance . $location } = $conf;
}

#-------------------------------------------------
# $self->get_arg_hash
#-------------------------------------------------
sub get_arg_hash {
    my( $self ) = @_;

    #my %hash_ref = $self->cgi->Vars;

    return wantarray ? %{ $self->cgi_obj->{params} }
                     :    $self->cgi_obj->{params};

} # end get_arg_hash

#-------------------------------------------------
# $self->get_auth_dbh( )
#-------------------------------------------------
sub get_auth_dbh {
    Gantry::Utils::DBConnHelper::Script->get_auth_dbh;
}

#-------------------------------------------------
# $self->get_dbh( )
#-------------------------------------------------
sub get_dbh {
    Gantry::Utils::DBConnHelper::Script->get_dbh;
}

#-------------------------------------------------
# $self->header_in( )
#-------------------------------------------------
sub header_in {
    my( $self, $key ) = @_;

    return $ENV{uc $key} || $ENV{$key} || '';
} # end header_in

#-------------------------------------------------
# $self->header_out( $header_key, $header_value )
#-------------------------------------------------
sub header_out {
    my( $self, $k, $v ) = @_;

    # $self->{__HEADERS_OUT__}->{$k} = $v if defined $k;
    # return( $self->{__HEADERS_OUT__} );

    return $self->response_headers( $k, $v );

} # end header_out

#--------------------------------------------------
# $self->locations( $hash_ref )
#--------------------------------------------------
sub locations {
    my( $self, $hash_ref ) = @_;

    if ( defined $hash_ref ) {
        $self->{cgi_obj}{locations} = $hash_ref;
    }

    return $self->{cgi_obj}{locations};
} # end locations

#--------------------------------------------------
# $self->log_error( $text )
#--------------------------------------------------
sub log_error {
    my ( $self, $text ) = @_;

    warn "$text\n";
}

#-------------------------------------------------
# $self->redirect_response( )
#-------------------------------------------------
sub redirect_response {
    my $self = shift;

    my $cookies = '';
    foreach my $cookie ( @{ $self->cookie_stash() } ) {
        print "Set-Cookie: $cookie\n";
    }

    my $p = {};
    $p->{uri} = $self->response_headers->{location};

    print $self->cgi->redirect( $p );

    return 302;
} # END redirect_response

#-------------------------------------------------
# $self->remote_ip( $r )
#-------------------------------------------------
sub remote_ip {
    my( $self ) = ( shift, shift );

    return( $ENV{REMOTE_ADDR} );

} # end remote_ip

#-------------------------------------------------
# $self->print_output( $response_page )
#-------------------------------------------------
sub print_output {
    my $self          = shift;
    my $response_page = shift;

    print $response_page;

} # print_output

#-------------------------------------------------
# $self->port( $r )
#-------------------------------------------------
sub port {
    my( $self ) = ( shift );

    return( $ENV{SERVER_PORT} );

} # end port

#-------------------------------------------------
# $self->server_root( $r )
#-------------------------------------------------
sub server_root {
    my( $self ) = ( shift );

    return( $ENV{HTTP_SERVER} );

} # end server_root

#-------------------------------------------------
# $self->status_const( 'OK | DECLINED | REDIRECT' )
#-------------------------------------------------
sub status_const {
    my( $self, $status ) = @_;

    return '404'         if uc $status eq 'DECLINED';
    return '200'         if uc $status eq 'OK';
    return '301'         if uc $status eq 'MOVED_PERMANENTLY';
    return '302'         if uc $status eq 'REDIRECT';
    return '403'         if uc $status eq 'FORBIDDEN';
    return '401'         if uc $status eq 'AUTH_REQUIRED';
    return '401'         if uc $status eq 'HTTP_UNAUTHORIZED';
    return '400'         if uc $status eq 'BAD_REQUEST';
    return '500'         if uc $status eq 'SERVER_ERROR';

    die( "Undefined constant $status" );


} # end status_const

#-------------------------------------------------
# $self->is_connection_secure()
#-------------------------------------------------
sub is_connection_secure {
    my $self = shift;

    return $ENV{'SSL_PROTOCOL'} ? 1 : 0;
} # END is_connection_secure

#-------------------------------------------------
# $self->is_status_declined( $status )
#-------------------------------------------------
sub is_status_declined {
    my $self = shift;

    my $status = $self->status || '';

    return 1 if ( $status eq 'DECLINED' );
} # END is_status_declined

#-------------------------------------------------
# $self->send_error_output( $@ )
#-------------------------------------------------
sub send_error_output {
    my $self     = shift;

    print $self->cgi->header(
            -type   => 'text/html',
            -status => '500 Server Error',
    );

    $self->do_error( $@ );
    print( $self->custom_error( $@ ) );

} # END send_error_output

#-------------------------------------------------
# $self->send_http_header( )
#-------------------------------------------------
sub send_http_header {
    my $self = shift;

    my $cookies = '';
    foreach my $cookie ( @{ $self->cookie_stash() } ) {
        print "Set-Cookie: $cookie\n";
    }

    my $header_for = $self->response_headers();

    foreach my $variable ( keys %{ $header_for } ) {
        print "$variable: $header_for->{ $variable }\n";
    }

    print $self->cgi->header(
        -type => ( $self->content_type ? $self->content_type : 'text/html' ),
        -status => ( $self->status() ? $self->status() : '200 OK' ),
    );

} # send_http_header

#-------------------------------------------------
# $self->set_content_type( )
#-------------------------------------------------
sub set_content_type {


# This method is for mod_perl engines.  They need to transfer
# the content_type from the site object to the apache request object.
# We don't need to do that.

} # set_content_type

#-------------------------------------------------
# $self->set_no_cache( )
#-------------------------------------------------
sub set_no_cache {
    my $self = shift;

    $self->cgi->no_cache( 1 ) if $self->no_cache;
} # set_no_cache

#-------------------------------------------------
# $self->set_req_params( )
#-------------------------------------------------
sub set_req_params {
    my $self = shift;

    $self->params( $self->cgi_obj->{params} );
    $self->uf_params( $self->cgi_obj->{uf_params} );

} # END set_req_params

#-------------------------------------------------
# $self->success_code( )
#-------------------------------------------------
sub success_code {

    return '200';
# This is for mod_perl engines.  They need to tell apache that
# things went well.

} # END success_code

sub parse_env {
    my $data;
    my $hash = {};

    my $ParamSeparator = '&';

    if ( defined $ENV{REQUEST_METHOD}
            && $ENV{REQUEST_METHOD} eq "POST" ) {

        read STDIN , $data , $ENV{CONTENT_LENGTH} ,0;

        if ( $ENV{QUERY_STRING} ) {
            $data .= $ParamSeparator . $ENV{QUERY_STRING};
        }

    }
    elsif ( defined $ENV{REQUEST_METHOD}
        && $ENV{REQUEST_METHOD} eq "GET" ) {

        $data = $ENV{QUERY_STRING};
    }
    elsif ( defined $ENV{REQUEST_METHOD} ) {
        print "Status: 405 Method Not Allowed\r\n\r\n";
        exit;
    }

    return {} unless (defined $data and $data ne '');


    $data =~ s/\?$//;
    my $i=0;

    my @items = grep {!/^$/} (split /$ParamSeparator/o, $data);
    my $thing;

    foreach $thing (@items) {

        my @res = $thing=~/^(.*?)=(.*)$/;
        my ( $name, $value, @value );

        if ( $#res <= 0 ) {
            $name  = $i++;
            $value = $thing;
        }
        else {
            ( $name, $value ) = @res;
        }

        $name =~ tr/+/ /;
        $name =~ s/%(\w\w)/chr(hex $1)/ge;

        $value =~ tr/+/ /;
        $value =~ s/%(\w\w)/chr(hex $1)/ge;

        if ( $hash->{$name} ) {
            if ( ref $hash->{$name} ) {
                push( @{$hash->{$name}}, $value );
            }
            else {
                $hash->{$name} = [ $hash->{$name}, $value];
            }
        }
        else {
            $hash->{$name} = $value;
        }
    }

    return( $hash );
}

#-------------------------------------------------
# $self->url_encode( )
#-------------------------------------------------
sub url_encode {
    my $self = shift;
    my $value = shift;

    return CGI::Simple::Util::escape( $value );
} # END url_encode

#-------------------------------------------------
# $self->url_decode( )
#-------------------------------------------------
sub url_decode {
    my $self = shift;
    my $value = shift;

    return CGI::Simple::Util::unescape( $value );
} # END url_decode

# EOF
1;

__END__