# ==================================================================
# 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                => \&GT::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;