| Current File : //var/wcp4/hkaw/public_html/file/file/file/private/lib/GT/CGI/EventLoop.pm |
# ==================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
# GT::CGI::EventLoop
# Author : Scott Beck
# $Id: EventLoop.pm,v 1.3 2002/04/12 21:14:59 sbeck Exp $
#
# Copyright (c) 2000 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' => '';
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;
use Exporter;
sub import;
*import = *Exporter::import;
$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;