503 lines
16 KiB
Perl
503 lines
16 KiB
Perl
# ==================================================================
|
|
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
|
#
|
|
# GT::CGI::EventLoop
|
|
# Author : Scott Beck
|
|
# CVS Info :
|
|
# $Id: EventLoop.pm,v 1.5 2004/09/07 23:35:14 jagerman Exp $
|
|
#
|
|
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
|
# ==================================================================
|
|
#
|
|
# Description: Impliments an EventLoop API for CGI programming
|
|
#
|
|
|
|
package GT::CGI::EventLoop;
|
|
# ==================================================================
|
|
|
|
use vars qw/$ATTRIBS $ERRORS @EXPORT_OK %EXPORT_TAGS/;
|
|
use strict;
|
|
use bases 'GT::Base' => ''; # GT::Base inherits from Exporter
|
|
use constants
|
|
STOP => 1,
|
|
EXIT => 2,
|
|
CONT => 3,
|
|
HEAP => 0,
|
|
EVENT => 1,
|
|
IN => 2,
|
|
CGI => 3,
|
|
ARG0 => 4,
|
|
ARG1 => 5,
|
|
ARG2 => 6,
|
|
ARG3 => 7,
|
|
ARG4 => 8,
|
|
ARG5 => 9,
|
|
ARG6 => 10,
|
|
ARG7 => 11,
|
|
ARG8 => 12,
|
|
ARG9 => 13;
|
|
|
|
use GT::CGI;
|
|
use GT::MIMETypes;
|
|
|
|
$ERRORS = {
|
|
NOACTION => 'No action was passed from CGI input and no default action was set',
|
|
NOFUNC => 'No function in %s'
|
|
};
|
|
|
|
$ATTRIBS = {
|
|
do => 'do',
|
|
format_page_tags => undef,
|
|
default_do => undef,
|
|
init_events => undef,
|
|
init_events_name => undef,
|
|
default_page => 'home',
|
|
default_group => undef,
|
|
default_page_pre_event => undef,
|
|
default_page_post_event => undef,
|
|
default_group_pre_event => undef,
|
|
default_group_post_event => undef,
|
|
needs_array_input => undef,
|
|
plugin_object => undef,
|
|
template_path => undef,
|
|
pre_package => '',
|
|
cgi => undef,
|
|
in => {},
|
|
heap => {},
|
|
page_events => {},
|
|
page_pre_events => {},
|
|
page_post_events => {},
|
|
group_pre_events => {},
|
|
group_post_events => {},
|
|
groups => {},
|
|
group => undef,
|
|
page => undef,
|
|
print_page => \>::CGI::EventLoop::print_page,
|
|
status => CONT,
|
|
cookies => []
|
|
};
|
|
|
|
@EXPORT_OK = qw/
|
|
STOP EXIT CONT
|
|
HEAP EVENT IN CGI
|
|
ARG0 ARG1 ARG2 ARG3 ARG4 ARG5 ARG6 ARG7 ARG8 ARG9
|
|
/;
|
|
|
|
%EXPORT_TAGS = (
|
|
all => [@EXPORT_OK],
|
|
status => [qw/STOP EXIT CONT/],
|
|
args => [qw/
|
|
HEAP EVENT IN CGI
|
|
ARG0 ARG1 ARG2 ARG3 ARG4 ARG5 ARG6 ARG7 ARG8 ARG9
|
|
/]
|
|
);
|
|
|
|
sub init {
|
|
# --------------------------------------------------------------------
|
|
my $self = shift;
|
|
$self->set( @_ ) if @_;
|
|
$self->{cgi} ||= new GT::CGI;
|
|
for ( $self->{cgi}->param ) {
|
|
my @val = $self->{cgi}->param($_);
|
|
my $val;
|
|
my $match;
|
|
for my $field ( @{$self->{needs_array_input}} ) {
|
|
if ( $_ eq $field ) {
|
|
$match = 1;
|
|
last;
|
|
}
|
|
}
|
|
if ( !$match ) {
|
|
$val = $val[0];
|
|
}
|
|
else {
|
|
$val = \@val;
|
|
}
|
|
$self->{in}{$_} = $val;
|
|
}
|
|
}
|
|
|
|
sub mainloop {
|
|
# --------------------------------------------------------------------
|
|
my $self = shift;
|
|
$self->init( @_ ) if @_;
|
|
|
|
if ( !defined $self->{in}{$self->{do}} ) {
|
|
if ( defined $self->{default_do} ) {
|
|
$self->{in}{$self->{do}} = $self->{default_do};
|
|
}
|
|
else {
|
|
$self->fatal( 'NOACTION' );
|
|
}
|
|
}
|
|
if ( $self->{init_events} ) {
|
|
local $self->{in}{$self->{do}} = $self->{init_events_name} if $self->{init_events_name};
|
|
|
|
$self->dispatch( $self->{init_events} );
|
|
return if $self->{status} == EXIT;
|
|
}
|
|
$self->_call_group;
|
|
$self->_call_page;
|
|
}
|
|
|
|
sub do_param {
|
|
# --------------------------------------------------------------------
|
|
my $self = shift;
|
|
if ( @_ ) {
|
|
$self->add_hidden( $self->{do} => $_[0] );
|
|
}
|
|
return $self->{in}{$self->{do}};
|
|
}
|
|
|
|
sub stop { $_[0]->{status} = STOP }
|
|
sub exit { $_[0]->{status} = EXIT }
|
|
sub cont { $_[0]->{status} = CONT }
|
|
|
|
sub _call_group {
|
|
# --------------------------------------------------------------------
|
|
my ( $self ) = @_;
|
|
$self->{group} ||= $self->{in}{$self->{do}} || $self->{default_do};
|
|
my $orig_group = $self->{group};
|
|
# FIXME Add infinite recursion checks!
|
|
for ( keys %{$self->{groups}} ) {
|
|
if ( index( $self->{group}, $_ ) == 0 ) {
|
|
if ( exists $self->{group_pre_events}{$_} ) {
|
|
$self->dispatch( $self->{group_pre_events}{$_} );
|
|
return if $self->{status} == EXIT;
|
|
|
|
if ( $self->{group} ne $orig_group ) {
|
|
return $self->_call_group;
|
|
}
|
|
}
|
|
elsif ( defined $self->{default_group_pre_event} ) {
|
|
$self->dispatch( $self->{default_group_pre_event} );
|
|
return if $self->{status} == EXIT;
|
|
if ( $self->{group} ne $orig_group ) {
|
|
return $self->_call_group;
|
|
}
|
|
}
|
|
$self->dispatch( $self->{groups}{$_} );
|
|
if ( $self->{group} ne $orig_group ) {
|
|
return $self->_call_group;
|
|
}
|
|
if ( exists $self->{group_post_events}{$_} ) {
|
|
$self->dispatch( $self->{group_post_events}{$_} );
|
|
return if $self->{status} == EXIT;
|
|
if ( $self->{group} ne $orig_group ) {
|
|
return $self->_call_group;
|
|
}
|
|
}
|
|
elsif ( defined $self->{default_group_post_event} ) {
|
|
$self->dispatch( $self->{default_group_post_event} );
|
|
return if $self->{status} == EXIT;
|
|
if ( $self->{group} ne $orig_group ) {
|
|
return $self->_call_group;
|
|
}
|
|
}
|
|
return;
|
|
}
|
|
}
|
|
|
|
# Default group
|
|
$self->dispatch( $self->{default_group} ) if $self->{default_group};
|
|
if ( $self->{default_group} and $self->{group} ne $orig_group ) {
|
|
return $self->_call_group;
|
|
}
|
|
}
|
|
|
|
sub _call_page {
|
|
# --------------------------------------------------------------------
|
|
my ( $self ) = @_;
|
|
if ( !$self->{page} ) {
|
|
$self->page( $self->{default_page} );
|
|
}
|
|
my $orig_page = $self->{page};
|
|
if ( exists $self->{page_pre_events}{$self->{page}} ) {
|
|
$self->dispatch( $self->{page_pre_events}{$self->{page}} );
|
|
return if $self->{status} == EXIT;
|
|
if ( $self->{page} ne $orig_page ) {
|
|
return $self->_call_page;
|
|
}
|
|
}
|
|
elsif ( defined $self->{default_page_pre_event} ) {
|
|
$self->dispatch( $self->{default_page_pre_event} );
|
|
return if $self->{status} == EXIT;
|
|
if ( $self->{page} ne $orig_page ) {
|
|
return $self->_call_page;
|
|
}
|
|
}
|
|
$self->{print_page}->( $self );
|
|
|
|
# Run post page events, can't change the page on a post event
|
|
if ( exists $self->{page_post_events}{$self->{page}} ) {
|
|
$self->dispatch( $self->{page_post_events}{$self->{page}} );
|
|
}
|
|
elsif ( defined $self->{default_page_post_event} ) {
|
|
$self->dispatch( $self->{default_page_post_event} );
|
|
}
|
|
}
|
|
|
|
sub cookie_jar {
|
|
# --------------------------------------------------------------------
|
|
# $obj->cookie_jar($cookie_object);
|
|
# ---------------------------------
|
|
# Stores cookies for printing when print_page is called.
|
|
# $cookie_object should be a GT::CGI::Cookie object. Passing undef
|
|
# will empty the cookies array ref.
|
|
#
|
|
my $self = shift;
|
|
if ( !defined( $_[0] ) and @_ > 0 ) {
|
|
$self->{cookies} = [];
|
|
}
|
|
elsif ( @_ > 0 ) {
|
|
push( @{$self->{cookies}}, $_[0] );
|
|
}
|
|
return $self->{cookies};
|
|
}
|
|
|
|
sub add_hidden {
|
|
# --------------------------------------------------------------------
|
|
my $self = shift;
|
|
if ( @_ and !defined( $_[0] ) ) {
|
|
$self->{hidden} = {};
|
|
}
|
|
elsif ( @_ ) {
|
|
$self->{hidden}{$_[0]} = $_[1];
|
|
}
|
|
}
|
|
|
|
sub remove_hidden {
|
|
# --------------------------------------------------------------------
|
|
my $self = shift;
|
|
return delete $self->{hidden}{$_[0]};
|
|
}
|
|
|
|
sub get_url_hidden {
|
|
# --------------------------------------------------------------------
|
|
my ( $self ) = @_;
|
|
my $ret = '';
|
|
for ( keys %{$self->{hidden}} ) {
|
|
next unless defined $self->{hidden}{$_};
|
|
$ret .= $self->{cgi}->escape( $_ ).'='.$self->{cgi}->escape( $self->{hidden}{$_} ).';';
|
|
}
|
|
return $ret;
|
|
}
|
|
|
|
sub get_form_hidden {
|
|
# --------------------------------------------------------------------
|
|
my ( $self ) = @_;
|
|
my $ret = '';
|
|
for ( keys %{$self->{hidden}} ) {
|
|
next unless defined $self->{hidden}{$_};
|
|
$ret .= '<input type="hidden" name="'.$self->{cgi}->html_escape( $_ ).'" value="'.$self->{cgi}->html_escape( $self->{hidden}{$_} ).'">';
|
|
}
|
|
return $ret;
|
|
}
|
|
|
|
sub page {
|
|
# --------------------------------------------------------------------
|
|
my $self = shift;
|
|
if ( @_ > 0 ) {
|
|
$self->{page} = $self->guess_page( $_[0] );
|
|
$self->debug( "Set page to $self->{page}" ) if $self->{_debug};
|
|
$self->yield( $self->{page_events} ) if $self->{page_events};
|
|
}
|
|
return $self->{page};
|
|
}
|
|
|
|
sub guess_page {
|
|
# --------------------------------------------------------------------
|
|
my ( $self, $page ) = @_;
|
|
if ( -e "$self->{template_path}/$page.htm" ) {
|
|
$page = "$page.htm";
|
|
}
|
|
elsif ( -e "$self->{template_path}/$page.html" ) {
|
|
$page = "$page.html";
|
|
}
|
|
return $page;
|
|
}
|
|
|
|
sub tags {
|
|
# --------------------------------------------------------------------
|
|
my $self = shift;
|
|
my ( %tags ) = ref( $_[0] ) eq 'HASH' ? %{$_[0]} : @_;
|
|
for ( keys %tags ) {
|
|
$self->{tags}{$_} = $tags{$_};
|
|
}
|
|
return $self->{tags};
|
|
}
|
|
|
|
sub default_tags {
|
|
# --------------------------------------------------------------------
|
|
my ( $self, %tags ) = @_;
|
|
|
|
my $set;
|
|
for ( keys %tags ) {
|
|
$set->{$_} = ( defined( $self->{in}{$_} ) and length( $self->{in}{$_} ) ? $self->{in}{$_} : $tags{$_} );
|
|
}
|
|
$self->tags( %$set );
|
|
}
|
|
|
|
sub print_page {
|
|
# --------------------------------------------------------------------
|
|
my ( $self ) = @_;
|
|
my $form_hidden = $self->get_form_hidden;
|
|
my $url_hidden = $self->get_url_hidden;
|
|
my $tags = $self->tags( url_hidden => \$url_hidden, form_hidden => \$form_hidden );
|
|
$tags = $self->yield( $self->{format_page_tags}, $tags ) if defined $self->{format_page_tags};
|
|
my $page = $self->page || 'index.htm';
|
|
|
|
# Cookies can be set with CGI input
|
|
my $cookies = [];
|
|
if ( $self->{in}{'set-cookie'} ) {
|
|
foreach my $key ( keys %{$self->{in}} ) {
|
|
if ( $key =~ /^cookie-(.*)/ ) {
|
|
push @$cookies, $self->{cgi}->cookie( -name => $1, -value => $self->{in}{$key}, -path => '/' );
|
|
}
|
|
}
|
|
}
|
|
|
|
# See if we have any cookies in out cookie jar (used through program operation to set cookies without printing
|
|
# a header)
|
|
if ( @{$self->cookie_jar} ) {
|
|
push @$cookies, @{$self->cookie_jar};
|
|
}
|
|
|
|
# If we have cookie header to print print them
|
|
print @{$cookies}
|
|
? $self->{cgi}->header(
|
|
-cookie => $cookies,
|
|
-type => GT::MIMETypes->guess_type( $page )
|
|
)
|
|
: $self->{cgi}->header( GT::MIMETypes->guess_type( $page ) );
|
|
|
|
my $base = $self->{template_path};
|
|
|
|
# Make sure the template exists and is readable
|
|
-e "$base/$page" or die "No page ($base/$page)";
|
|
-r _ or die "Page isn't readable by this process ($< $>) ($base/$page)";
|
|
|
|
require GT::Template;
|
|
GT::Template->parse( $page, $tags, {
|
|
root => $base,
|
|
escape => 1,
|
|
print => 1,
|
|
heap => [ $self->func_args ]
|
|
} );
|
|
|
|
}
|
|
|
|
sub page_pre_events {
|
|
# --------------------------------------------------------------------
|
|
my ( $self, %in ) = @_;
|
|
if ( keys %in ) {
|
|
$self->{page_pre_events} = {};
|
|
for ( keys %in ) {
|
|
my $val = ref( $in{$_} ) eq 'ARRAY' ? $in{$_} : [ $in{$_} ];
|
|
$self->{page_pre_events}{$self->guess_page( $_ )} = $val;
|
|
}
|
|
}
|
|
return $self->{page_pre_events};
|
|
}
|
|
|
|
sub page_post_events {
|
|
# --------------------------------------------------------------------
|
|
my ( $self, %in ) = @_;
|
|
if ( keys %in ) {
|
|
$self->{page_post_events} = {};
|
|
for ( keys %in ) {
|
|
my $val = ref( $in{$_} ) eq 'ARRAY' ? $in{$_} : [ $in{$_} ];
|
|
$self->{page_post_events}{$self->guess_page( $_ )} = $val;
|
|
}
|
|
}
|
|
return $self->{page_post_events};
|
|
}
|
|
|
|
sub group_pre_events {
|
|
# --------------------------------------------------------------------
|
|
my ( $self, %in ) = @_;
|
|
if ( keys %in ) {
|
|
$self->{group_pre_events} = {};
|
|
for ( keys %in ) {
|
|
my $val = ref( $in{$_} ) eq 'ARRAY' ? $in{$_} : [ $in{$_} ];
|
|
$self->{group_pre_events}{$_} = $val;
|
|
}
|
|
}
|
|
return $self->{group_pre_events};
|
|
}
|
|
|
|
sub group_post_events {
|
|
# --------------------------------------------------------------------
|
|
my ( $self, %in ) = @_;
|
|
if ( keys %in ) {
|
|
$self->{group_post_events} = {};
|
|
for ( keys %in ) {
|
|
my $val = ref( $in{$_} ) eq 'ARRAY' ? $in{$_} : [ $in{$_} ];
|
|
$self->{group_post_events}{$_} = $val;
|
|
}
|
|
}
|
|
return $self->{group_post_events};
|
|
}
|
|
|
|
sub dispatch {
|
|
# --------------------------------------------------------------------
|
|
my ( $self, $pfunc, @args ) = @_;
|
|
$pfunc = ref( $pfunc ) eq 'ARRAY' ? $pfunc : [ $pfunc ];
|
|
for ( @$pfunc ) {
|
|
$self->yield( $_, @args );
|
|
return if $self->{status} == EXIT or $self->{status} == STOP;
|
|
}
|
|
}
|
|
|
|
sub yield {
|
|
# --------------------------------------------------------------------
|
|
my ( $self, $pfunc, @args ) = @_;
|
|
if ( !ref( $pfunc ) ) {
|
|
$self->debug( "Yielding $pfunc" ) if $self->{_debug} > 1;
|
|
my ( $pkg, $func );
|
|
if ( index( $pfunc, '::' ) != -1 ) {
|
|
($pkg, $func) = $pfunc =~ /^(.*)::(.*)$/;
|
|
}
|
|
else {
|
|
$func = $pfunc;
|
|
}
|
|
defined( $func ) or $self->fatal( 'NOFUNC', $pfunc );
|
|
$pkg = $self->{pre_package}.$pkg if $self->{pre_package} and $pkg;
|
|
$pkg ||= $self->{pre_package} if $self->{pre_package};
|
|
$pkg ||= 'main';
|
|
$pkg =~ s/::$//;
|
|
no strict 'refs';
|
|
unless ( defined %{$pkg . '::'} ) {
|
|
eval "require $pkg";
|
|
die "Could not compile $pkg; Reason: $@" if $@;
|
|
}
|
|
if ( defined $self->{plugin_object} ) {
|
|
$self->debug( "dispatching --> $pkg\::$func" ) if $self->{_debug};
|
|
return $self->{plugin_object}->dispatch( $pkg.'::'.$func, \&{$pkg.'::'.$func}, $self->func_args(@args) );
|
|
}
|
|
else {
|
|
no strict 'refs';
|
|
$self->debug( "Calling $pkg\::$func" ) if $self->{_debug};
|
|
return &{$pkg.'::'.$func}( $self->func_args(@args) );
|
|
}
|
|
$self->yield( $_, @args );
|
|
}
|
|
elsif ( ref( $pfunc ) eq 'CODE' ) {
|
|
$self->debug( "In yeild with code ref.") if $self->{_debug};
|
|
if ( defined $self->{plugin_object} ) {
|
|
$self->debug( "dispatching --> $self->{in}{$self->{do}}" ) if $self->{_debug};
|
|
return $self->{plugin_object}->dispatch( $self->{in}{$self->{do}}, $pfunc, $self->func_args(@args) );
|
|
}
|
|
else {
|
|
$self->debug( "Calling code ref" ) if $self->{_debug};
|
|
return $pfunc->( $self->func_args(@args) );
|
|
}
|
|
}
|
|
}
|
|
|
|
sub func_args { $_[0]->{heap}, $_[0], $_[0]->{in}, $_[0]->{cgi}, @_[1 .. $#_] }
|
|
|
|
1;
|
|
|
|
|