File Coverage

blib/lib/POE/XUL/Event.pm

Criterion	Covered	Total	%
statement	139	166	83.7
branch	40	60	66.6
condition	13	14	92.8
subroutine	28	36	77.7
pod	6	24	25.0
total	226	300	75.3

package POE::XUL::Event;
# $Id: Event.pm 1566 2010-11-03 03:13:32Z fil $
# Copyright Philip Gwyn 2007-2010.  All rights reserved.
# Based on code Copyright 2003-2004 Ran Eilam. All rights reserved.

use strict;
use warnings;

use Carp;
use POE::XUL::Logging;

use constant DEBUG => 0;

our $VERSION = '0.0601';

##############################################################
sub new
{
	my( $package, $event_type, $CM, $response ) = @_;

    croak "Why didn't you give me a ChangeManager" unless $CM;
    croak "Why didn't you give me a HTTP::Response" unless $response;

    my $self = bless {
            event_type  => $event_type,
            CM          => $CM,
            response    => $response,
            canceled    => 0,
            done        => 0
        }, $package;

    $CM->request_start( $self );

    DEBUG and xwarn "$self.CM=$self->{CM}";

    return $self;
}

##############################################################
sub __init
{
    my( $self, $req ) = @_;

    $self->{app} = $req->param( 'app' );
    if( $self->{event_type} ne 'connect' and
                $self->{event_type} ne 'disconnect' and
                $self->{event_type} ne 'boot' ) {

        my $source_id = $req->param( 'source_id' );
        my $rc = $self->__source_id( $source_id );
        die $rc if $rc;
    }
    foreach my $f ( $req->params ) {
        next if $f eq 'source_id';
        $self->set( $f => $req->param( $f ) );
        # warn "$f=", $self->get( $f );
    }

    if( $self->{event_type} ne 'connect' and
                $self->{event_type} ne 'boot' ) {
        my $winID = $req->param( 'window' );
        my $rc = $self->__window_id( $winID );
        die $rc if $rc;
    }
}


##############################################################
sub __source_id
{
    my( $self, $id ) = @_;

    my $node = $self->{CM}->getElementById( $id );
    unless( $node ) {
        # xwarn "known = ", join ',', grep { $_ !~ /PXN/ }
        #                             keys %{ $self->{CM}{nodes} };
        return "Can't find source node $id";
    }
    $self->{source} = $node;
    $self->{source_id} = $id;
    return;
}

##############################################################
sub __window_id
{
    my( $self, $id ) = @_;

    my $node;
    if( $id ) {
        $node = $self->{CM}->getElementById( $id );
        DEBUG and xwarn "winID=$id node=$node";
        return "Can't find window node $id" unless $node;
    }
    elsif( $self->{CM} ) {
        $node = $self->{CM}->window;
    }
    $id ||= '';
    $self->{window} = $node;
    $self->{window_id} = $id;
    return;
}

##############################################################
# Accessors
sub set { $_[0]->{ $_[1] } = $_[2] }
sub get { $_[0]->{ $_[1] } }
sub name {
    return $_[0]->{event_type} unless 2==@_;
    $_[0]->{event_type} = $_[1];
}
*event = \&name;
sub type { $_[0]->{event_type} }
sub session {
    carp "Please use SID() instead of session()";
    shift->SID( @_ )
}

sub resp { $_[0]->{response} }
sub response { $_[0]->{response} }
sub req  { $_[0]->{response}->connection->request }
sub request { $_[0]->{response}->connection->request }

# general accessor/mutator
sub AUTOLOAD {
	my $self = shift;
	my $key  = our $AUTOLOAD;
	return if $key =~ /DESTROY$/;
	$key =~ s/^.*:://;
	return $self->{$key} if @_ == 0;
	$self->{$key} = shift;
}

*target = \&source;

##############################################################
sub coderef
{
    my( $self, $coderef ) = @_;
    $self->{coderef} = $coderef;
}




##############################################################
sub run
{
    my( $self ) = @_;

    local $POE::XUL::Logging::SINGLETON->{app} = $self->{app};

    # Tell the ChangeManager to keep the Node in sync with the browser
    # elements.  This is where event "side-effects" happen
    my $method = "handle_" . $self->event;
    my $CMm = $self->{CM}->can( $method );

    if( $CMm ) {
        DEBUG and xdebug "$method = $CMm";
        $self->wrap( sub { $CMm->( $self->{CM}, $self ) } ) ;
        return if $self->{CM}{responded};
    }

    # Call code that our builder thinks we should execute
    if( $self->{coderef} ) {
        DEBUG and
            xdebug "coderef";
        $self->wrap( delete $self->{coderef} );
    }
    # Call code that the application thinks we should execute
    else {
        DEBUG and
            xdebug "do_event";
        $self->do_event();
    }
}

sub do_event
{
    my( $self ) = @_;
    local $POE::XUL::Logging::SINGLETON->{app} = $self->{app};

    my $bt = delete $self->{bubble_to};
    foreach my $N ( $self->{source}, $bt ) {
        next unless $N;

        my $listener = $N->event( $self->{event_type} );
        DEBUG and
            xdebug "========== $N listener=$listener";
        next unless $listener;

        $self->{source} = $N;

        $self->wrap( sub {
                if( ref $listener ) {
                    $listener->( $self );
                }
                else {
                    DEBUG and xdebug "Posting to $self->{SID}/$listener";
                    $POE::Kernel::poe_kernel->call( $self->{SID},
                                                    $listener,
                                                    $self
                                                  );
                }
            } );
        last;
    }
}


##############################################################
sub wrap
{
    my( $self, $coderef ) = @_;
    local $POE::XUL::Logging::SINGLETON->{app} = $self->{app};

    eval {
        local $SIG{__DIE__} = 'DEFAULT';
        DEBUG and
            xcarp "Wrapping user code CM=$self->{CM}";
        local $POE::XUL::Node::CM = $self->{CM};
        $coderef->( $self );
    };

    if( $@ ) {
        my $err = "APPLICATION ERROR: $@";
        $self->wrapped_error( $err );
        return;
    }
}

##############################################################
## Make sure it is still possible to respond to this event
sub __respondable
{
    my( $self, $action ) = @_;
    if( $self->{canceled} ) {
        xcarp2 "Attempt to $action a canceled event";
        return;
    }
    if( $self->has_response ) {
        xcarp2 "Attempt to $action to a responded event";
        return;
    }
    return 1;
}


##############################################################
sub cancel
{
    my( $self ) = @_;
    $self->{canceled} = 1;
    unless( $self->has_response ) {
        xlog "Event canceled before CM responded";
        $self->{done} = 1;
    }
    else {
        xlog "Event canceled";
    }
}

##############################################################
sub canceled
{
    my( $self ) = @_;
    return $self->{canceled};
}

##############################################################
sub handled
{
    my( $self ) = @_;
    local $POE::XUL::Logging::SINGLETON->{app} = $self->{app};

    $self->done( 1 );
    DEBUG and xcarp "Event finished";

    $self->flush();
}
*finish = \&handled;

##############################################################
sub has_response
{
    my( $self ) = @_;
    return 1 unless $self->{CM};
    return 1 if $self->{CM}->responded;
    return;
}

##############################################################
sub defer
{
    my( $self ) = @_;
    return unless $self->__respondable( 'defer' );
    $self->done( 0 );
}

##############################################################
sub flushed
{
    my( $self ) = @_;
    return $self->{is_flushed};
}

##############################################################
# Flush is called from Controler->xul_request or from Event->finish/flush
sub flush
{
    my( $self ) = @_;
    local $POE::XUL::Logging::SINGLETON->{app} = $self->{app};

    if( $self->{is_flushed} or not $self->{CM} ) {
        Carp::confess "This event was already flushed!";
#        $self->dispose if $self->{CM}; # TODO is this a good idea?
        return;
    }

    return unless $self->__respondable( 'flush' );
    $self->{is_flushed} = 1;

    DEBUG and xdebug "$self->flush";

    # TODO don't do this in case of error
    $self->{CM}->response( $self->{response} );
}

##############################################################
sub wrapped_error
{
    my( $self, $err ) = @_;
    local $POE::XUL::Logging::SINGLETON->{app} = $self->{app};
    DEBUG and xdebug "wrapped_error via $self->{CM} ($err)";
    unless( $self->{CM} ) {
        xlog "No CM for error response: ", Dumper $err;
        return;
    }
    $self->{CM}->error_response( $self->{response}, $err );
}


##############################################################
sub data_response
{
    my( $self, $data ) = @_;
    local $POE::XUL::Logging::SINGLETON->{app} = $self->{app};
    $self->{CM}->data_response( $self->{response}, $data );
}

##############################################################
sub dispose
{
    my( $self ) = @_;
    $self->{is_flushed} = 1;
    delete $self->{CM};
    delete $self->{response};
    DEBUG and xdebug "$self->dispose";
}

1;

__DATA__