libmagpie-perl 1.140280-1 / usr / share / perl5 / Magpie / Event.pm

package Magpie::Event;
{
  $Magpie::Event::VERSION = '1.140280';
}
# ABSTRACT: Core Event Role Shared By All Magpie Classes
use Moose::Role;

with qw( Magpie::Event::Symbol Magpie::Types );

use Magpie::Constants;
use Magpie::SymbolTable;
use Magpie::Util;
use Class::Load;
use Plack::Request;
use Plack::Response;
use Try::Tiny;

BEGIN { $SIG{__DIE__} = sub { Carp::confess(@_) } }


has plack_request => (
    is          => 'rw',
    isa         => 'Plack::Request',
    default     => sub { Plack::Request->new({}); },
    reader      => 'request',
);

has plack_response => (
    is          => 'rw',
    isa         => 'Plack::Response',
    default     => sub { Plack::Response->new(200); },
    reader      => 'response',
    predicate   => 'has_response',
    trigger     => sub { shift->response_changed(1) },
);

has response_changed => (
    is          => 'rw',
    isa         => 'Bool',
    default     => 0,
);

has parent_handler => (
    is          => 'rw',
    predicate   => 'has_parent_handler',
    weak_ref    => 1,
);

has error => (
    is          => 'rw',
    isa         => 'SmartHTTPError',
    coerce      => 1,
    predicate   => 'has_error',
    writer      => 'set_error',
    clearer     => 'clear_error',
);

has handlers => (
    traits      => ['Array'],
    is          => 'rw',
    isa         => 'ArrayRef[ArrayRef]',
    default     => sub { [] },
    handles     => {
        push_handlers      => 'push',
        pop_handlers       => 'pop',
        shift_handlers     => 'shift',
        unshift_handlers   => 'unshift',
        clear_handlers     => 'clear',
    },

);

has event_queue => (
    traits  => ['Array'],
    is      => 'rw',
    isa     => 'ArrayRef[Str]',
    default => sub { [] },
    handles => {
        push_queue      => 'push',
        pop_queue       => 'pop',
        shift_queue     => 'shift',
        unshift_queue   => 'unshift',
        free_queue      => 'clear',
    },
);

has registered_handlers => (
    traits    => ['Hash'],
    is        => 'rw',
    isa       => 'HashRef[Object]',
    default   => sub { {} },
    handles   => {
        register_handler    => 'set',
        fetch_handler       => 'get',
        unregister_handler  => 'delete',
    },
);

has current_handler => (
    is        => 'rw',
    predicate => 'has_current_handler',
);

has current_handler_args => (
    is        => 'rw',
    predicate => 'has_current_handler_args',
);

sub BUILD{
    my $self = shift;
    $self->init_common_symbols();
    $self->init_symbols() if $self->can('init_symbols');
};

# Class methods
our %registered_events = ();

__PACKAGE__->register_events(qw( next_in_pipe load_handler run_handler ) );

sub register_events {
    my $pkg = shift;
    if ( scalar @_ ) {
        $registered_events{$pkg} ||= [];
        push @{ $registered_events{$pkg} }, @_;
    }
    return $pkg->registered_events;
}

sub registered_events {
    my $thing = shift;
    my $pkg = blessed( $thing ) ? $thing->meta->name : $thing;
    my $ref = $registered_events{$pkg} || [];
    return @{ $ref };
}

#-------------------------------------------------------------------------------
# stop_application() stops everything dead in its tracks, potentially
# calling itself for all parent handlers as well.
# DO NOT confuse this with the harmless end_application() which only adds
# a hook for doing clean-up, etc.
#-------------------------------------------------------------------------------
sub stop_application  {
    my $self = shift;
    my $ctxt = shift;

    $self->free_queue();
    $self->clear_handlers();
    if ($self->has_parent_handler) {
        if ($self->isa('Magpie::Resource')) {
            $self->parent_handler->resource($self) if $self->parent_handler->can('resource');
        }
        else {
            $self->parent_handler->resource($self->resource) if $self->can('resource') && $self->parent_handler->can('resource');
        }
        $self->parent_handler->stop_application;
    }
}

#-------------------------------------------------------------------------------
# next_in_pipe
# Event queue method for transitioning from one handler to the next.
#-------------------------------------------------------------------------------
sub next_in_pipe {
    my $self = shift;
    my $ctxt = shift;

    my $tuple = $self->shift_handlers;
    if ( defined $tuple ) {
        $self->current_handler( $tuple->[0] );
        $self->current_handler_args( $tuple->[1] );
        $self->add_to_queue( 'load_handler' );
    }

    return OK;
}

#-------------------------------------------------------------------------------
# load_handler($context)
# Event queue method that checks to see if the currently selected handler
# class has been instantiated and registered in the loaded_handler table. If
# not, it loads that class, calls its constructor, sets the current Machine
# as the parent handler, and registers the handler in loaded_handler.
# It then adds the 'run_handler' method to the event queue to keep the pipline
# "moving" forward.
#-------------------------------------------------------------------------------
sub load_handler {
    my $self = shift;
    my $ctxt = shift;

    my $handler = $self->current_handler;
    my $handler_args = $self->current_handler_args || {};
    #warn "load: current handler: $handler " . $self->has_error ." \n";

    unless ( defined $self->fetch_handler( $handler ) ) {
        # we only make it here if the app class was passed
        # to the pipeline as the *name* of a class, rather
        # than a blessed instance
        my $new_handler;
        my $handler_error = undef;

        try {
            Class::Load::load_class( $handler );
        }
        catch {
            $handler_error = "Fatal error loading handler class '$handler': $_ \n";
            #$self->set_error({ status_code => 500, reason => $error });

        };

        if ( $handler_error ) {
            $self->set_error({ status_code => 500, reason => $handler_error });
            return HANDLER_ERROR;
        }

		if ( $handler->isa('Plack::Middleware') ) {
            Class::Load::load_class( 'Magpie::Transformer::Middleware' );
			my $munged_args = {
				middleware_args => $handler_args,
				middleware_class => $handler,
			};
			$handler = 'Magpie::Transformer::Middleware';
			$handler_args = $munged_args;
			$self->current_handler($handler);
			$self->current_handler_args($handler_args);
		}

        my $constructor = defined($handler_args->{traits}) ? 'new_with_traits' : 'new';

        try {
            $new_handler = $handler->$constructor(
                %{ $handler_args },
                parent_handler => $self,
                plack_request  => $self->plack_request,
                plack_response => $self->plack_response,
                breadboard     => ($self->has_parent_handler  ? $self->parent_handler->breadboard : $self->breadboard),
                resource       => $self->resource,
            ) || die "Error loading handler $!";

        }
        catch {
            $handler_error = "Fatal error during build for class '$handler': $_\n";
            #$self->set_error({ status_code => 500, reason => $error });
        };

        if ( $handler_error ) {
            $self->set_error({ status_code => 500, reason => $handler_error });
            return HANDLER_ERROR;
        }
        #return HANDLER_ERROR if $self->has_error;

        #$new_handler->parent_handler( $self );
        $self->register_handler( $handler => $new_handler );
    }

    if ($self->fetch_handler( $handler )) {
        $self->add_to_queue( "run_handler" );
    }

    return OK;
}

#-------------------------------------------------------------------------------
# run_handler($context)
# Run the instance of the currently selected handler class, passing in the
# application's context member. This method is called by the parent classes'
# event queue (see init_queue() in this class)
#-------------------------------------------------------------------------------
sub run_handler {
    my $self = shift;
    my $ctxt = shift;
    my $handler = $self->current_handler;
    my $handler_args = $self->current_handler_args || {};
    #warn "run handler: $handler\n";

    if ( my $h = $self->fetch_handler( $handler ) ) {
        # class may be loaded but params may be different
        my @attributes = $h->meta->get_all_attributes;
        foreach my $param (keys( %{$handler_args})) {
            foreach my $attr (@attributes) {
                next unless $attr->has_writer || $attr->has_accessor;
                my $method = $attr->get_write_method || $attr->accessor;
                next unless $param eq $method;
                $h->$method( $handler_args->{$param} );
            }
        }
        # "Running handler $handler \n";
        try {
            $h->run( $ctxt );
        }
        catch {
            my $error = "Fatal error running handler '$handler': $_";
            $self->set_error({ status_code => 500, reason => $_ });
        };

        # propagate errors up the handler stack
        if ( $h->has_error ) {
            $self->set_error( $h->error );
        }

        # remember, nesting.
        $self->plack_response( $h->plack_response );
        $self->breadboard( $h->breadboard );
        $self->add_to_queue( "next_in_pipe" );

    }
    else {
        return QUEUE_ERROR;
    }
    return OK;
}

#-------------------------------------------------------------------------------
# add_handler()
# Add a handler into the end of the event queue.
#-------------------------------------------------------------------------------
sub add_handler {
    my $self    = shift;
    my $handler = shift;
    my $args    = shift || {};
    if ( defined $handler && length $handler ) {
        $self->push_handlers([ $handler, $args ]);
    }
}

#-------------------------------------------------------------------------------
# add_next_handler()
# Add a handler into the front of the event queue.
#-------------------------------------------------------------------------------
sub add_next_handler {
    my $self    = shift;
    my $handler = shift;
    my $args    = shift || {};

    if ( defined $handler && length $handler ) {
        $self->unshift_handlers([$handler, $args]);
    }
}

#-------------------------------------------------------------------------------
# add_handlers( @list )
# Add a list of handlers to the event queue.
#-------------------------------------------------------------------------------
sub add_handlers {
    my $self = shift;
    my @handlers = @_;
    @handlers = Magpie::Util::make_tuples( @handlers );
    $self->push_handlers(@handlers);
}

#-------------------------------------------------------------------------------
# reset_handlers( @list )
# Replaces the current list of handlers with @list .
#-------------------------------------------------------------------------------
sub reset_handlers {
    my $self    = shift;
    my @handlers = @_;
    $self->clear_handlers;
    return $self->add_handlers( @handlers );
}

sub end_application {
    #warn "implement end_application already, will you?\n";
}

has server_status => (
    is          => 'rw',
    isa         => 'Int',
    default     => sub { 200 },
);

sub init_common_symbols {
    my $self = shift;
    $self->add_symbol_handler( next_in_pipe => \&next_in_pipe );
    $self->add_symbol_handler( load_handler => \&load_handler );
    $self->add_symbol_handler( run_handler  => \&run_handler );
}

#-------------------------------------------------------------------------------
# handle_symbol( $context, $symbol_name )
# Here's teh beef!
# Accepting the current context member and a symbol name as arguments, this
# method fetches the list of handler subs associated with $symbol_name and
# fires each of them in turn (passing in the $context). The return codes from
# each sub is examined (see Magpie::Constants, and the handle_* subs below)
# and the handler's program flow is controlled accordingly. If all subs
# return OK (200) this method does not intervene-- each sub is fired and
# we return OK to the main event loop (which will then move to the next symbol
# in the queue).
#-------------------------------------------------------------------------------
sub handle_symbol {
    my $self        = shift;
    my $ctxt        = shift;
    my $symbol      = shift;
    my $return_code = undef;

    # warn "Handling symbol: $symbol \n";
    # load each handler associated with $symbol, run them,
    # and manipulate program flow if need be based on their
    # return values
    foreach my $h ( $self->get_symbol_handler( $symbol ) ) {
        try {
            $return_code = $h->($self, $ctxt);
        }
        catch {
            $self->set_error({ status_code => 500, reason => $_ });
            #warn "Error running symbol '$symbol': $_";
        };

        if ( (!length $return_code) or ($return_code >= SERVER_ERROR) ) {
            unless ( $self->has_error ) {
                $self->set_error({
                    status_code => 500,
                    reason => "Internal error or unknown return code from symbol '$symbol'"
                });
            }
            $return_code = DONE;
        }

        return $self->control_done()     if $return_code == DONE;
        return $self->control_declined() if $return_code == DECLINED;
        return $self->control_output()   if $return_code == OUTPUT;
    }
    return OK;
}

sub init_queue {
    my $self = shift;
    my $ctxt = shift;

    # always first
    $self->add_to_queue( 'next_in_pipe' );
    my $pkg = $self->meta->name;
    my @event_names = ();

    if ( $self->can('load_queue') ) {
        @event_names = $self->load_queue($ctxt);
    }

    foreach my $event_name ( @event_names ) {
        $self->add_to_queue( $event_name );
    }

    return OK;
}

#-------------------------------------------------------------------------------
# add_to_queue( $symbol, $priority )
#-------------------------------------------------------------------------------
sub add_to_queue      {
    my $self     = shift;
    my $symbol   = shift;
    my $priority = shift;

    #warn "add to queue $symbol";
    $symbol = $self->_qualify_symbol_name( $symbol );

    unless ( $self->has_symbol($symbol) ) {
        warn "Warning: '$symbol' could not be added to the queue. Are you sure you registered it via register_events?";
        #XXX: should we die or set_error here instead?
        return;
    }

    # add events with high priority to the beginning of the stack.
    if ( defined $priority and $priority == 1 ) {
        $self->unshift_queue( $symbol );
    }
    else {
        $self->free_queue() if defined $priority and $priority == -1;
        $self->push_queue( $symbol );
    }
}

#-------------------------------------------------------------------------------
# remove_from_queue( $symbol, $priority )
#-------------------------------------------------------------------------------
sub remove_from_queue {
    my $self     = shift;
    my $symbol   = shift;
    my $priority = shift || 0;

    $symbol = $self->_qualify_symbol_name( $symbol );

    unless ( $self->has_symbol($symbol) ) {
        warn "Warning: Unregistered event '$symbol' could not be removed from the queue because it does not exist. Are you sure you registered it via register_events?";
        return;
    }

    my $f = 0;

    if ($priority == 0 ) {
        my @new = grep { $_ ne $symbol } @{$self->event_queue};
        $self->event_queue(\@new);
    }

    # remove the last occourence of $symbol
    elsif ( $priority == -1 ) {
        my @new = reverse grep { defined $_ } map {
            $_ ne $symbol ?
                $_ :
                $f == 1 ?
                    $_ : do{ $f=1; undef }
              } reverse( @{$self->event_queue} );
        $self->event_queue(\@new);
    }

    # otherwise, drop the first occourence of $symbol
    else {
        my @new = grep { defined $_ } map {
            $_ ne $symbol ?
                $_ :
                $f == 1 ?
                    $_ : do{ $f=1; undef }
            } @{$self->event_queue};
        $self->event_queue(\@new);
    }
}


################################################################################
# Control handlers.
################################################################################
# Event handlers that manage program flow in response to the control
# codes returned from the various handler subs.
#-------------------------------------------------------------------------------

#-------------------------------------------------------------------------------
# control_done()
# Fires when user returns DONE (299) from their handler sub. Is expected to
# stop the application immediately.
#-------------------------------------------------------------------------------
sub control_done {
    my $self = shift;
    $self->stop_application;
    return DONE;
}

#-------------------------------------------------------------------------------
# control_declined()
# Fires when user returns DECLINED (199) from their handler sub. Is expected to
# nukes the rest of the events associated with the current handler and move
# to the next handler class in the queue.
#-------------------------------------------------------------------------------
sub control_declined {
    my $self = shift;
    $self->free_queue;
    return OK;
}

#-------------------------------------------------------------------------------
# control_output()
# Fires when user returns DECLINED (300) from their handler sub. Is expected to
# cause the queue to jump immediately to the Output handler and its queued subs.
#-------------------------------------------------------------------------------
sub control_output {
    my $self = shift;

    my $new_handlers = [];
    if ( defined $self->{parent_handler}{handlers} ) {

        # XXX: this is lame because it assumes that the last
        # parent handler is the Output class
        # I'll fix it if it really becomes an issue in Real Life(tm)
        # -ubu

        push @{$new_handlers}, $self->{parent_handler}{handlers}->[-1];
        $self->free_queue;
        $self->{parent_handler}{handlers} = $new_handlers;
    }
    return OK;
}

sub run {
    my $self  = shift;
    my $ctxt  = shift;
    my $state = OK;

    $ctxt ||= {};

    # reinit per each run required for pipelining
    $self->init_queue($ctxt);

    while ( my $symbol = $self->shift_queue() ) {
        $state = $self->handle_symbol( $ctxt, $symbol );
        # if an error occours here we must stop!
        # warn "state is $state from $symbol";
        last unless $state == OK;
    }
    $self->end_application( $ctxt );
    return $self->server_status;
}

# SEEALSO: Magpie

1;

__END__
=pod

=head1 NAME

Magpie::Event - Core Event Role Shared By All Magpie Classes

=head1 VERSION

version 1.140280

=head1 AUTHORS

=over 4

=item *

Kip Hampton <kip.hampton@tamarou.com>

=item *

Chris Prather <chris.prather@tamarou.com>

=back

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011 by Tamarou, LLC.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut