File Coverage

blib/lib/Thread/Queue/Queueable.pm

Criterion	Covered	Total	%
statement	1	3	33.3
branch			n/a
condition			n/a
subroutine	1	1	100.0
pod			n/a
total	2	4	50.0

#/**
# Abstract base class defining the interfaces, and providing
# simple marshalling methods, for complex object to be passed
# across a Thread::Queue::Duplex
# queue.
#
# Licensed under the Academic Free License version 2.1, as specified in the
# License.txt file included in this software package, or at
# OpenSource.org.
#
# @author D. Arnold
# @since 2005-12-01
# @self	$obj
#*/
package Thread::Queue::Queueable;
#
#	abstract class to permit an object to be
#	marshalled in some way before pushing onto
#	a Thread::Queue::Duplex queue
#
require 5.008;

use threads;
use threads::shared;

use strict;
use warnings;

our $VERSION = '0.90';

#/**
# Marshal an object for queueing to a Thread::Queue::Duplex
# queue. Called by any of TQD's enqueue() methods,
# as well as respond() method.
#
# The default implementation  the input
# object into either a shared array or shared hash (depending on the base structure
# of the object), and returns a list consisting of the object's class name, and the cursed object.
#
# @returnlist	list of (object's class, object's marshalled representation)
#*/
sub onEnqueue {
	my $obj = shift;
#
#	capture class name, and create cursed
#	version of object
#
	return (ref $obj, $obj->curse());
}

#/**
# Unmarshall an object after being dequeued. Called by any of TQD's
# dequeue() methods,
# as well as the various request side dequeueing
# methods (e.g., wait()).
#
# The default implementation redeem()'s the input object
# to copy the input shared arrayref or hashref into a nonshared equivalent, then
# blessing it into the specified class, returning the redeemed object.
#
# @param $object the marshalled representation of the object
# @return		the unmarshalled aka "redeemed" object
#*/
sub onDequeue {
	my ($class, $obj) = @_;
#
#	reconstruct as non-shared by redeeming
#
	return $class->redeem($obj);
}

#/**
# Pure virtual function to apply any object-specific cancel processing. Called by TQD's
# respond() method
# when a cancelled operation is detected.
#
# @return		1
#*/
sub onCancel {
	my $obj = shift;
	return 1;
}
#/**
# Marshal an object into a value that can be passed via
# a Thread::Queue::Duplex object.
#
# Called by TQD's various enqueue() and
# respond() methods
# when the TQQ object is being enqueue'd. Should return an unblessed,
# shared version of the input object.
#
# Default returns a shared
# arrayref or hashref, depending on the object's base structure, with
# copies of all scalar members.
#
# Note that objects with more complex members will need to
# implement an object specific curse() to do any deepcopying,
# including curse()ing any subordinate objects.
#
# @return		marshalled version of the object
#*/
sub curse {
	my $obj = shift;
#
#	if we're already shared, don't share again
#
	return $obj if threads::shared::_id($obj);

	if ($obj->isa('HASH')) {
		my %cursed : shared = ();
		$cursed{$_} = $obj->{$_}
			foreach (keys %$obj);
		return \%cursed;
	}

	my @cursed : shared = ();
	$cursed[$_] = $obj->[$_]
		foreach (0..$#$obj);
	return \@cursed;
}
#/**
# Unmarshall an object back into its blessed form.
#
# Called by TQD's various dequeue() and
# wait methods to
# "redeem" (i.e., rebless) the object into its original class.
#
# Default creates non-shared copy of the input object structure,
# copying its scalar contents, and blessing it into the specified class.
#
# Note that objects with complex members need to implement
# an object specific redeem(), possibly recursively
# redeem()ing subordinate objects (be careful
# of circular references!)
#
# @param $object	marshalled aka "cursed" version of the object
#
# @return		unmarshalled, blessed version of the object
#*/
sub redeem {
	my ($class, $obj) = @_;
#
#	if object is already shared, just rebless it
#	NOTE: we can only do this when threads::shared::_id() is defined
#
	return bless $obj, $class
		if threads::shared->can('_id') && threads::shared::_id($obj);
#
#	we *could* just return the blessed object,
#	which would be shared...but that might
#	not be the expected behavior...
#
	if (ref $obj eq 'HASH') {
		my $redeemed = {};
		$redeemed->{$_} = $obj->{$_}
			foreach (keys %$obj);
		return bless $redeemed, $class;
	}

	my $redeemed = [];
	$redeemed->[$_] = $obj->[$_]
		foreach (0..$#$obj);
	return bless $redeemed, $class;
}

1;