padre 1.00+dfsg-3 / usr / share / perl5 / Padre / TaskHandle.pm

package Padre::TaskHandle;

use 5.008005;
use strict;
use warnings;
use threads;
use threads::shared;
use Scalar::Util             ();
use Params::Util             ();
use Storable                 ();
use Padre::Wx::Role::Conduit ();
use Padre::Logger;

our $VERSION  = '1.00';
our $SEQUENCE = 0;





######################################################################
# Constructor and Accessors

sub new {

	# TRACE( $_[0] ) if DEBUG;
	bless {
		hid  => ++$SEQUENCE,
		task => $_[1],
		},
		$_[0];
}

sub hid {
	$_[0]->{hid};
}

sub task {
	$_[0]->{task};
}

sub child {
	$_[0]->{child};
}

sub class {
	Scalar::Util::blessed( $_[0]->{task} );
}

sub has_owner {
	!!$_[0]->{task}->{owner};
}

sub owner {
	require Padre::Role::Task;
	Padre::Role::Task->task_owner( $_[0]->{task}->{owner} );
}

sub worker {
	my $self = shift;
	$self->{worker} = shift if @_;
	$self->{worker};
}

sub queue {
	$_[0]->{queue};
}

sub start_time {
	my $self = shift;
	$self->{start_time} = $self->{idle_time} = shift if @_;
	$self->{start_time};
}

sub idle_time {
	my $self = shift;
	$self->{idle_time} = shift if @_;
	$self->{idle_time};
}





######################################################################
# Setup and teardown

# Called in the child thread to set the task and handle up for processing.
sub start {

	# TRACE( $_[0] ) if DEBUG;
	my $self = shift;
	$self->{child} = 1;
	$self->{queue} = shift;
	$self->signal('STARTED');
}

# Signal the task has stopped
sub stop {
	TRACE( $_[0] ) if DEBUG;
	my $self = shift;
	$self->{child} = undef;
	$self->{queue} = undef;
	$self->signal( 'STOPPED' => $self->{task} );
}





######################################################################
# Serialisation

sub as_array {

	# TRACE( $_[0] ) if DEBUG;
	my $self = shift;
	my $task = $self->task;
	return [
		$self->hid,
		Scalar::Util::blessed($task),
		$task->as_string,
	];
}

sub from_array {

	# TRACE( $_[0] ) if DEBUG;
	my $class = shift;
	my $array = shift;

	# Load the task class first so we can deserialize
	TRACE("Loading $array->[1]") if DEBUG;
	(my $source = $array->[1].".pm") =~ s{::}{/}g;
	require $source;

	return bless {
		hid  => $array->[0] + 0,
		task => $array->[1]->from_string( $array->[2] ),
	}, $class;
}





######################################################################
# Parent-Only Methods

sub prepare {

	# TRACE( $_[0] ) if DEBUG;
	my $self = shift;
	my $task = $self->{task};

	unless ( defined $task ) {
		TRACE("Exception: task not defined") if DEBUG;
		return !1;
	}

	my $rv = eval { $task->prepare; };
	if ($@) {
		TRACE("Exception in task during 'prepare': $@") if DEBUG;
		return !1;
	}

	return !!$rv;
}

sub on_started {

	# TRACE( $_[0] ) if DEBUG;
	my $self = shift;
	my $task = $self->{task};

	# Does the task have an owner and can we call it
	my $owner  = $self->owner  or return;
	my $method = $task->on_run or return;
	$owner->$method( $task => @_ );
	return;
}

sub on_message {

	# TRACE( $_[0] ) if DEBUG;
	my $self   = shift;
	my $method = shift;
	my $task   = $self->{task};

	unless ( $self->child ) {

		# Special case for printing a simple message to the main window
		# status bar, without needing to pollute the task classes.
		if ( $method eq 'STATUS' ) {
			return $self->on_status(@_);
		}

		# Special case for routing messages to the owner of a task
		# rather than to the task itself.
		if ( $method eq 'OWNER' ) {
			require Padre::Role::Task;
			my $owner  = $self->owner      or return;
			my $method = $task->on_message or return;
			$owner->$method( $task => @_ );
			return;
		}
	}

	# Does the method exist
	unless ( $self->{task}->can($method) ) {

		# A method name provided directly by the Task
		# doesn't exist in the Task. Naughty Task!!!
		# Lacking anything more sane to do, squelch it.
		return;
	}

	# Pass the call down to the task and protect it from itself
	local $@;
	eval { $self->{task}->$method(@_); };
	if ($@) {

		# A method in the main thread blew up.
		# Beyond catching it and preventing it killing
		# Padre entirely, I'm not sure what else we can
		# really do about it at this point.
		return;
	}

	return;
}

sub on_status {

	# TRACE( $_[1] ) if DEBUG;
	my $self = shift;

	# If we don't have an owner, use the general status bar
	unless ( $self->has_owner ) {
		require Padre::Current;
		Padre::Current->main->status(@_);
		return;
	}

	# If we have an owner that is within the main window show normally
	my $owner = $self->owner or return;
	my $method = $self->{task}->on_status;
	return $owner->$method(@_) if $method;

	# Pass status messages up to the main window status if possible
	if ( $owner->isa('Padre::Wx::Role::Main') ) {
		$owner->main->status(@_);
		return;
	}

	# Nothing else to do
	return;
}

sub on_stopped {

	# TRACE( $_[0] ) if DEBUG;
	my $self = shift;

	# The first parameter is the updated Task object.
	# Replace all content in the stored version with that from the
	# event-provided version.
	my $new  = shift;
	my $task = $self->{task};
	%$task = %$new;
	%$new  = ();

	# Execute the finish method in the updated Task object first, before
	# the task owner is passed to the task owner (if any)
	$self->finish;

	# If the task has an owner it will get the finish method instead.
	my $owner = $self->owner or return;
	my $method = $self->{task}->on_finish;
	local $@;
	eval { $owner->$method( $self->{task} ); };

	return;
}

sub finish {

	# TRACE( $_[0] ) if DEBUG;
	my $self = shift;
	my $task = $self->{task};
	my $rv   = eval { $task->finish; };
	if ($@) {
		TRACE("Exception in task during 'finish': $@") if DEBUG;
		return !1;
	}
	return !!$rv;
}





######################################################################
# Worker-Only Methods

sub run {

	# TRACE( $_[0] ) if DEBUG;
	my $self = shift;
	my $task = $self->task;

	# Create the inbox for the handle
	local $self->{inbox} = [];

	# Create a circular reference back from the task
	# HACK: This is pretty damned evil, find a better way
	local $task->{handle} = $self;

	# Call the task's run method
	eval { $task->run; };
	if ($@) {

		# Save the exception
		TRACE("Exception in task during 'run': $@") if DEBUG;
		$self->{exception} = $@;
		return !1;
	}

	return 1;
}

# Poll the inbound queue and process them
sub poll {
	my $self  = shift;
	my $inbox = $self->{inbox} or return;
	my $queue = $self->{queue} or return;

	# Fetch from the queue until we run out of messages or get a cancel
	while ( my $item = $queue->dequeue1_nb ) {

		# Handle a valid parent -> task message
		if ( $item->[0] eq 'message' ) {
			my $message = Storable::thaw( $item->[1] );
			push @$inbox, $message;
			next;
		}

		# Handle aborting the task
		if ( $item->[0] eq 'cancel' ) {
			$self->{cancelled} = 1;
			delete $self->{queue};
			next;
		}

		die "Unknown or unexpected message type '$item->[0]'";
	}

	return;
}

# Block until we have an inbox message or have been cancelled
sub wait {
	my $self  = shift;
	my $inbox = $self->{inbox} or return;
	my $queue = $self->{queue} or return;

	# If something is in our inbox we don't need to wait
	return if @$inbox;

	# Fetch the next message from the queue, blocking if needed
	my $item = $queue->dequeue1;

	# Handle a valid parent -> task message
	if ( $item->[0] eq 'message' ) {
		my $message = Storable::thaw( $item->[1] );
		push @$inbox, $message;
		return;
	}

	# Handle aborting the task
	if ( $item->[0] eq 'cancel' ) {
		$self->{cancelled} = 1;
		delete $self->{queue};
		return;
	}

	die "Unknown or unexpected message type '$item->[0]'";
}

sub cancel {
	$_[0]->{cancelled} = 1;
}

# Has this task been cancelled by the parent?
sub cancelled {
	my $self = shift;

	# Shortcut if we can to avoid queue locking
	return 1 if $self->{cancelled};

	# Poll for new input
	$self->poll;

	# Check again now we have polled for new messages
	return !!$self->{cancelled};
}

# Fetch the next message from our inbox
sub inbox {
	my $self = shift;
	my $inbox = $self->{inbox} or return undef;

	# Shortcut if we can to avoid queue locking
	return shift @$inbox if @$inbox;

	# Poll for new messages
	$self->poll;

	# Check again now we have polled for new messages
	return shift @$inbox;
}





######################################################################
# Bidirectional Communication

sub signal {

	# TRACE( $_[0] ) if DEBUG;
	Padre::Wx::Role::Conduit->signal( [ shift->hid => @_ ] );
}

sub tell_parent {
	TRACE( $_[0] ) if DEBUG;
	shift->signal( PARENT => @_ );
}

sub tell_child {
	TRACE( $_[0] ) if DEBUG;
	my $self = shift;

	if ( $self->child ) {

		# Add the message directly to the inbox
		my $inbox = $self->{inbox} or next;
		push @$inbox, [@_];
	} else {
		$self->worker->send_message(@_);
	}

	return 1;
}

sub tell_owner {

	# TRACE( $_[0] ) if DEBUG;
	shift->signal( OWNER => @_ );
}

sub tell_status {

	# TRACE( $_[0] ) if DEBUG;
	shift->signal( STATUS => @_ ? @_ : '' );
}

1;

# Copyright 2008-2013 The Padre development team as listed in Padre.pm.
# LICENSE
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl 5 itself.