#
# GTx : medium level Generitrack API
#       incorporating the User package
#
# Author: Jennifer Liddle (js10)
#
# $Id: GTx.pm,v 1.23 2006/11/27 15:25:53 js10 Exp $
#
# $Log: GTx.pm,v $
# Revision 1.23  2006/11/27 15:25:53  js10
# Removed #! line so that webpublish will not barf
#
# Revision 1.22  2005/08/03 10:42:25  js10
# Now accepts -includeNonCurrent flag to getAttribute()
#
# Revision 1.21  2005/06/14 09:30:57  mca
# indirect GT adoptions and creations through do_adopt/do_create
# methods, which can be overridden by subclasses where necessary.
# (e.g. ATR::GTx maintains an app-wide PE cache)
#
# Revision 1.20  2005/06/14 09:27:06  mca
# turn _getProgram into a method
#
# Revision 1.19  2005/05/27 08:55:31  las
# modified getSeByAttribute/getPeByAttribute to consider only current
# attributes
# ----------------------------------------------------------------------
#
# Revision 1.18  2005/05/16 15:24:10  js10
# getPeByAttribute() and getSeByAttribute() now allow -value=>0
#
# Revision 1.17  2005/05/11 14:30:33  js10
# allow getStatus() to take -idPe parameter
#
# Revision 1.16  2005/05/11 10:34:48  js10
# Fairly major changes and additions. Enough to up the minor version numbers if we had any.
#
# Revision 1.15  2005/04/08 16:46:20  js10
# now uses GTx::Constants
#
# Revision 1.14  2005/04/06 16:01:37  js10
# Added new constant CONT_TYPE_SOURCEPLATE_MAP
#
# Revision 1.13  2005/03/03 17:22:52  js10
# Added new changeAttribute() function
#
# Revision 1.12  2005/03/01 16:07:01  las
# removed 2 debug print statments
# ----------------------------------------------------------------------
#
# Revision 1.11  2005/02/25 15:05:58  js10
# Improved getInfo() and added getPhysicalEntityId()
#
# Revision 1.10  2005/02/17 15:02:47  las
# modify getPeByInfo, getPeByAttribute, getSeByInfo, getSeByAttribute to
# accept an optional id reason parameter
# ----------------------------------------------------------------------
#
# Revision 1.9  2005/02/07 17:09:24  js10
# Added getAttributeValue()
#
# Revision 1.8  2005/01/31 16:02:15  las
# Added getSeByInfo function
# ----------------------------------------------------------------------
#
# Revision 1.7  2005/01/27 12:06:01  las
# Added getPeByAttribute, getPeByInfo and getSeByAttribute
# ----------------------------------------------------------------------
#
# Revision 1.6  2005/01/11 14:37:55  js10
# Store database name accessible as $gtx->{dbname}
#
# Revision 1.5  2005/01/10 15:35:08  js10
# Added new function: getSubEntityId()
#
# Revision 1.4  2005/01/07 11:35:52  js10
# Meep! Emergency fix
#
# Revision 1.3  2005/01/07 10:32:07  js10
# Added various new constants
#
# Revision 1.2  2005/01/04 16:42:00  js10
# Added new constants for cORF and GeneTrap
#
# Revision 1.1  2004/12/03 09:45:56  holroyd
# Moved from PSG/lib/GTx to new project area GTx/ in cvs repository.
#
# Revision 1.2  2004/12/01 11:28:52  js10
# No longer requires a gt_process login for checking patterns
#
# Revision 1.1  2004/11/26 17:19:07  holroyd
# moved files within badger CVS,
#  from libs/*
#  to PSG/lib/*
#
# Revision 1.16  2004/11/18 10:28:41  js10
# Implemented the -suppressNonCurr flag
# Changed a few constant names
#
# Revision 1.15  2004/11/17 14:36:42  js10
# Added several new constants
#
# Revision 1.14  2004/11/10 10:19:09  js10
# getPhysicalEntity(): -entityType no longer required iff -idPe is specified
#
# Revision 1.13  2004/11/04 10:18:34  js10
# Another minor bug fix
#
# Revision 1.12  2004/11/01 16:06:29  js10
# Bug fix to _program()
# Added optional -suppressNonCurr flag to getPhysicalEntity() and
# getSubEntity()
#
# Revision 1.11  2004/10/22 09:10:46  js10
# checkPattern() now copes with pattern not found in the database
#
# Revision 1.10  2004/10/21 13:06:09  js10
# Added new function makeDate().
# Extended getSubEntity() to allow -idEntityContent
#
# Revision 1.9  2004/10/18 13:32:48  js10
# Added new function makeDate()
#
# Revision 1.8  2004/10/18 08:17:59  js10
# Added an optional -idAttribute paramater to getAttribute()
#
# Revision 1.7  2004/10/15 13:15:51  js10
# Added optional 'remarks' to getStatus() and changeStatus()
#
# Revision 1.6  2004/10/15 10:08:33  js10
# Added support for sub-entities
#
# Revision 1.5  2004/10/15 08:00:45  js10
# Implemented add sub attributes and sub entities, and createSubEntity.
#
# Revision 1.4  2004/10/14 15:17:05  js10
# Process methods now implemented
#
# Revision 1.3  2004/10/12 13:55:31  js10
# Added more functions
#
# Revision 1.2  2004/10/08 14:04:03  js10
# Added changeStatus() method
#
# Revision 1.1.1.1  2004/10/06 14:12:41  js10
# Initial import
#
#

#
# This is the User package, which is incorporated here for...err...historical reasons.
#
package GTx::User;
use strict;
use warnings;
use Carp;
use Checkbarcode2;
use Mail;

use vars qw($AUTOLOAD);

{
	my %attributes = (idperson => 1, forename => 1, id => 1, surname => 1, room => 1, phone => 1, email => 1);

	sub _accessible {
		my ($self, $attr) = @_;
		return defined $attributes{$attr}
	}

	sub _standardKeys {
		keys %attributes;
	}

}

sub new 
{
	my ($class, %attr) = @_;

	my $self = bless {}, $class;
	foreach my $attr ($self->_standardKeys()) {
		$self->{$attr} = $attr{-$attr} if defined  $attr{-$attr};
	}
	return $self;
}

sub AUTOLOAD 
{
	no strict 'refs';
	my ($self, $newval) = @_;

	return if $AUTOLOAD =~ /::DESTROY$/;
	if ($AUTOLOAD =~ /.*::get([A-Z]\w+)/ and $self->_accessible(lc($1))) {
		my $attrName = lc($1);
		*{$AUTOLOAD} = sub {return $_[0]->{$attrName}};
		return $self->{$attrName};
	}
	croak "No such method: $AUTOLOAD";
}




#
# The GTx package proper
#

package GTx;
use strict;
use warnings;

#use FindBin;
#use lib "$FindBin::Bin";

use Carp;

use GT::Physical::Entity;
use GT::Physical::Entity::Contents;
use GT::Physical::Entity::Contents::Info;
use GT::Physical::Entity::Contents::Attribute;

use SqlEngine2;
use GTx::Constants;

sub GTxDump
{
	my $txt = shift;
	my %args = @_;
	print "$txt: ";
	foreach my $key (keys %args) {
		print "$key => $args{$key},  ";
	}
	print "\n";
}


sub new
{
	my $class = shift;
	my $self = {};

	bless($self, $class);
	$self->_init(@_);

	croak "-login not specified" if (!$self->{-login});

	return $self;
}

sub _init
{
	my $self = shift;
	if (@_) {
		my %extra = @_;
		@$self{keys %extra} = values %extra;
	}

	return if (!$self->{-login});

	GT::Physical::Entity->import(-login => $self->{-login});
	GT::Physical::Entity::Contents->import(-login => $self->{-login});
	GT::Physical::Entity::Contents::Info->import(-login => $self->{-login});
	GT::Physical::Entity::Contents::Attribute->import(-login => $self->{-login});

	$self->{se} = new SqlEngine2;
	$self->{dbh} = SqlEngine2::getDbh($self->{-login});
	$SqlEngine2::verbosity=0;

	my $q = $self->{se}->virtualSqlLib('GTx','getDatabase',
	                                   "select sys_context('USERENV','db_name') from dual");
	my $dbname = $self->{se}->getRow($q, [], $self->{dbh});
	$self->{dbname} = $dbname;
}

#
# get the top level calling program
#
sub _getProgram
{
	my $self = shift; # needs to be a method solely so it can be overridden
	my $program;
	my $i=0;
	while ((caller($i))[1]) { $program = (caller($i++))[1]; }
	$program =~ s:.*/([^/]+)$:$1:;	# strip path information leaving basename
	return $program;
}

#
# create a date in a format that Attribute->setEndDate() is happy with
#
sub makeDate
{
    my ($self, $time) = @_;
	return Class::Abstract::Status::Entity::Bean::makeDate($time);
}

#
# Return a Physical Entity corresponding to an Entity Type and one of:
# - internal Id (ie a barcode)
# - external id
# - physical entity id
#
sub getPhysicalEntity
{
	my $self = shift;
	my %args = @_;
	my $peId;
	my $pe;

	croak "id not specified" unless $args{-idInt} || $args{-idExt} || $args{-idPe};

	if ($args{-idInt}) {
		croak "-entityType not specified" if (!$args{-entityType});
		$args{-idInt} =~ s/\D//g;	# remove prefix and checksum if present
		$peId = $self->{se}->getRow('GTx::getPeFromId', [GTx::ATT_TYPE_INT_ID, $args{-idInt}, $args{-entityType}], $self->{dbh});
	}

	if ($args{-idExt}) {
		croak "-entityType not specified" if (!$args{-entityType});
		$args{-idExt} =~ s/\D//g;	# remove prefix and checksum if present
		$peId = $self->{se}->getRow('GTx::getPeFromId', [GTx::ATT_TYPE_EXT_ID, $args{-idExt}, $args{-entityType}], $self->{dbh});
	}

	if ($args{-idPe}) {
		$peId = $args{-idPe};
	}

	return undef if (!$peId);

	# just return undef if this fails
	eval {
		$pe = $self->do_adopt('GT::Physical::Entity', -id=>$peId, -suppressNonCurr => $args{-suppressNonCurr});
#		$pe = $self->do_adopt('GT::Physical::Entity', -id=>$peId);
	};
	throw $@ if $@ and ref $@;	# this indicates an SqlEngine2 error
	return $pe;
}

#
# Return a Physical Entity ID corresponding to an Entity Type and one of:
# - internal Id (ie a barcode)
# - external id
#
sub getPhysicalEntityId
{
	my $self = shift;
	my %args = @_;
	my $peId;

	croak "id not specified" unless $args{-idInt} || $args{-idExt};

	if ($args{-idInt}) {
		croak "-entityType not specified" if (!$args{-entityType});
		$args{-idInt} =~ s/\D//g;	# remove prefix and checksum if present
		$peId = $self->{se}->getRow('GTx::getPeFromId', [GTx::ATT_TYPE_INT_ID, $args{-idInt}, $args{-entityType}], $self->{dbh});
	}

	if ($args{-idExt}) {
		croak "-entityType not specified" if (!$args{-entityType});
		$args{-idExt} =~ s/\D//g;	# remove prefix and checksum if present
		$peId = $self->{se}->getRow('GTx::getPeFromId', [GTx::ATT_TYPE_EXT_ID, $args{-idExt}, $args{-entityType}], $self->{dbh});
	}

	throw $@ if $@ and ref $@;	# this indicates an SqlEngine2 error
	return $peId;
}

#
# get subEntity IDs
#
sub getSubEntityId
{
	my $self = shift;
	my %args = @_;

	croak "-idEntityContentsType not specified" unless $args{-idEntityContentsType};

	if (!$args{-pe} && !$args{-idPe}) {
		croak "neither -pe nor -idPe specified";
	}

	$args{-idPe} = $args{-pe}->getId() if (!$args{-idPe});

	my $res = $self->{se}->getAll('GTx::getSubEntityId', 
	                           [$args{-idPe}, $args{-idEntityContentsType}],
	                           $self->{dbh});

	return $res;
}

#
# get a subEntity 
#
sub getSubEntity
{
	my $self = shift;
	my %args = @_;


	if (!$args{-idEntityContent}) {
		croak "-pe not specified" unless $args{-pe};
		croak "-idEntityContentsType not specified" unless $args{-idEntityContentsType};
	}

	if ($args{-idEntityContent}) {
		my ($id_entity, $id_entity_contents_type) 
			= $self->{se}->getRow('GTx::getEntityContents',[$args{-idEntityContent}], $self->{dbh});
		croak "invalid -idEntityContent" unless $id_entity;
		return $self->do_adopt('GT::Physical::Entity::Contents',
				       -idEntity => $id_entity,
				       -id => $args{-idEntityContent},
				       -idEntityContentsType => $id_entity_contents_type,
				       -suppressNonCurr => $args{-suppressNonCurr});
#		return $self->do_adopt('GT::Physical::Entity::Contents', -idEntity => $id_entity,
#		                                             -id => $args{-idEntityContent},
#		                                             -idEntityContentsType => $id_entity_contents_type);
	}

	my @ec = grep $_->getIdEntityContentsType == $args{-idEntityContentsType}, 
	              values %{$args{-pe}->getSubEntities()->getContents()};


	return wantarray ? \@ec : $ec[0];
}

#
# get a session id
#
sub getSessionId
{
	my $self = shift;
	my $sessionId = $self->{se}->getRow('GT/Physical/EntityClass::getSessionId', [], $self->{dbh});
	croak "getSessionId() failed" unless $sessionId;
	return $sessionId;
}

#
# get the next sequence number to use for a given entity type
#
sub getSequenceNumber
{
    my $self = shift;
	my %args = @_;

	croak "-entityType not specified" unless $args{-entityType};

	# which sequence should we be using for this entity type?
	my $sequence = $self->{se}->getRow('GTx::getSequence', [$args{-entityType}], $self->{dbh});
	croak "Can't find sequence for PE of type " . $args{-entityType} unless $sequence;

	# get the next sequence number
	my $sth = $self->{se}->virtualSqlLib('GTx', 'getSeqNum', "select $sequence.nextval from dual");
	my $seq = $self->{se}->getRow($sth, [], $self->{dbh});
	return $seq;
}

#
# return a role id from a user id, team, and roletype
#
sub getIdRole
{
	my $self = shift;
	my %args = @_;

	croak "-userId not specified" unless $args{-userId};
	croak "-team not specified" unless $args{-team};
	croak "-roleType not specified" unless $args{-roleType};

    my $idRole = $self->{se}->getRow('GTx::getIdRole', [$args{-userId},$args{-team},$args{-roleType}],$self->{dbh});
    return $idRole;
}

#
# Return status name given a status code
#
sub _getStatusName
{
	my $self = shift;
	my %args = @_;

	croak "-id not specified" if (!$args{-id});

	my $name = $self->{se}->getRow('GTx::statusName', [$args{-id}], $self->{dbh});
	return $name;
}

#
# return the status code corresponding to a status name
#
sub _getStatusId
{
	my $self = shift;
	my %args = @_;

	croak "-status not specified" unless $args{-status};
	croak "-entityType not specified" unless $args{-entityType};

	my $id = $self->{se}->getRow('GTx::statusId', [$args{-status}, $args{-entityType}], $self->{dbh});
	return $id;
}

#
# Return an attribute of a physical entity
#
# If this starts to show performance problems, we may want to optimise it by 
# replacing the low-level api calls with some SQL.
#
sub getAttribute
{
	my $self = shift;
	my %args = @_;
	my @a;
	my @info;

	if (!$args{-idAttribute}) {
		$args{-idPe} = $args{-pe}->getId() if $args{-pe};
		croak "neither -pe nor -idPe specified" unless $args{-idPe};
		croak "-attributeType not specified" unless $args{-attributeType};
		croak "-reason not supplied" unless $args{-reason};
	}

#	print GTxDump('getAttribute',%args);

	if ($args{-idAttribute}) {
		return $self->do_adopt('GT::Physical::Entity::Contents::Attribute',
				       -id => $args{-idAttribute});
	}

	if ($args{-pe}) {
		# read from the physical entity (or subentity)
		my $ec;
		if ($args{-pe}->isa('GT::Physical::Entity')) {
			$ec = $args{-pe}->getEntireEntity()->getInfo()->getContents();
		} else {
			$ec = $args{-pe}->getInfo()->getContents();
		}
		if ($args{-includeNonCurrent}) {
			@info = grep $_->getAttribute() &&
			             $_->getAttribute()->getIdAttributeType()==$args{-attributeType} &&
			             $_->getIdReason() == $args{-reason}, values %{$ec};
		} else {
			@info = grep $_->getAttribute() &&
			             $_->getAttribute()->getIsCurrent() &&
			             $_->getAttribute()->getIdAttributeType()==$args{-attributeType} &&
			             $_->getIdReason() == $args{-reason}, values %{$ec};
		}
		foreach my $i (@info) {
			push @a, $i->getAttribute();
		}

	} else {
		# read directly from the database by physical entity ID (or subentity ID)
		my $res;
		my $isCurrent = ($args{-includeNonCurrent} ? 0 : 1);
		if ($args{-sub}) {
			$res = $self->{se}->getAll('GTx::getSubAttribute', 
			                              [$args{-idPe}, $args{-attributeType}, $args{-reason}, $isCurrent],
			                              $self->{dbh});
		} else {
			$res = $self->{se}->getAll('GTx::getAttribute', 
			                              [$args{-idPe}, $args{-attributeType}, $args{-reason}, $isCurrent],
			                              $self->{dbh});
		}

		foreach my $r (@$res) {
			my $attr = $self->getAttribute(-idAttribute => $r->[0]);
			push @a, $attr;
		}
	}

	return wantarray ? \@a : $a[0];
}

#
# Return the current status of a physical entity
#
sub getStatus
{
	my $self = shift;
	my %args = @_;
	my ($idStatus, $a);

	croak "neither -pe nor -idPe specified" if (!$args{-pe} && !$args{-idPe});

	if ($args{-pe}) {
		$a = $self->getAttribute(-pe => $args{-pe}, 
		                         -attributeType => GTx::ATT_TYPE_STATUS, 
		                         -reason => GTx::REASON_STATE);
	} else {
		$a = $self->getAttribute(-idPe => $args{-idPe}, 
		                         -attributeType => GTx::ATT_TYPE_STATUS, 
		                         -reason => GTx::REASON_STATE);
	}

	my $status = $self->_getStatusName(-id => $a->getValue());
	my $remark = $a->getRemark();
	return wantarray ? ($status, $remark) : $status;
}


#
# Create a new physical entity
#
sub createPhysicalEntity
{
	my $self = shift;
	my %args = @_;

	croak "-entityType not specified" if (!$args{-entityType});
	croak "-sessionId not specified" if (!$args{-sessionId});

	if (!$args{-idRole}) {
		if ($args{-roleType} && $args{-userId} && $args{-team}) {
			$args{-idRole} = $self->getIdRole(-roleType => $args{-roleType},
			                                  -userId => $args{-userId},
			                                  -team => $args{-team});
			croak "Invalid combination of user, team, role" if (!$args{-idRole});
		}
	}

	croak "-idRole not specified" if (!$args{-idRole});

	my $pe = $self->do_create('GT::Physical::Entity',
				  -idEntityType => $args{-entityType},
				  -sessionId => $args{-sessionId},
				  -idRole => $args{-idRole});

	return $pe;
}

#
# Create a new sub-entity
#
sub createSubEntity
{
	my $self = shift;
	my %args = @_;

	croak "-pe not specified" unless $args{-pe};
	croak "-idEntityContentsType not specified" unless $args{-idEntityContentsType};

	my $ec = $self->do_create('GT::Physical::Entity::Contents', -idEntityContentsType=>$args{-idEntityContentsType});
	$args{-pe}->addSubUnit($ec);
	return $ec;
}


#
# Add a new attribute to an entity or sub-entity
#
sub addAttribute
{
	my $self = shift;
	my %args = @_;

	croak "-pe not specified" unless $args{-pe};
#    croak "-pe is not a GT::Physical::Entity" unless $args{-pe}->isa('GT::Physical::Entity');
    croak '-attributeType not specified' unless $args{-attributeType};
    croak '-value not specified' unless defined $args{-value};
    croak '-reason not specified' unless $args{-reason};
    croak '-idRole not specified' unless $args{-idRole};
    croak '-sessionId not specified' unless $args{-sessionId};

    my $attrib = $self->do_create('GT::Physical::Entity::Contents::Attribute',
				  -idAttributeType => $args{-attributeType},
				  -value => $args{-value},
				  -isCurrent => 1,
				  -idRole => $args{-idRole},
				  -sessionId => $args{-sessionId},
				  -program => $self->_getProgram()
				 );
    my $info = $self->do_create('GT::Physical::Entity::Contents::Info',
				-idContent => $attrib->getId(),
				-idContentType => CONT_TYPE_ATTRIBUTE,
				-idReason => $args{-reason},
				-debug => $args{-debug} || 0,
			       );
    $info->addAttribute($attrib);
	if ($args{-pe}->isa('GT::Physical::Entity')) {
	    $args{-pe}->getEntireEntity()->addInfo($info);
	} else {
		$args{-pe}->addInfo($info);
	}
#	return wantarray ? ($attrib, $info) : $attrib;
	return $attrib;
}

sub addEntityAttribute
{
	my $self = shift;
	$self->addAttribute(@_);
}

#
# change an attribute value of a physical entity or sub-entity
#
sub changeAttribute
{
	my $self = shift;
	my %args = @_;

	croak "-pe not specified" unless $args{-pe};
    croak '-attributeType not specified' unless $args{-attributeType};
    croak '-value not specified' unless defined $args{-value};
    croak '-reason not specified' unless $args{-reason};
    croak '-idRole not specified' unless $args{-idRole};
    croak '-sessionId not specified' unless $args{-sessionId};

	my $a = $self->getAttribute(-pe=>$args{-pe}, -attributeType=>$args{-attributeType}, -reason=>$args{-reason});
#	croak "Can't find attribute" unless $a;

	$a->setIsCurrent(0) if $a;	# make the attribute non-current

	# add the new changed attribute
	$self->addAttribute(-pe => $args{-pe},
	                    -attributeType => $args{-attributeType},
	                    -value => $args{-value},
	                    -reason => $args{-reason},
	                    -idRole => $args{-idRole},
	                    -sessionId => $args{-sessionId});
}

#
# change the status of a physical entity
#
sub changeStatus
{
	my $self = shift;
	my %args = @_;

	croak "-pe not specified" unless $args{-pe};
	croak "-status not specified" unless $args{-status};
	croak "-idRole not specified" unless $args{-idRole};
	croak "-sessionId not specified" unless $args{-sessionId};

	my $idStatus = $self->_getStatusId(-status => $args{-status}, -entityType => $args{-pe}->getIdEntityType());
	croak "Invalid status: '$args{-status}'" unless $idStatus;

	my $a = $self->getAttribute(-pe => $args{-pe}, -attributeType => GTx::ATT_TYPE_STATUS, -reason => REASON_STATE);
	$a->setIsCurrent(0);
	$a = $self->addAttribute(-pe => $args{-pe},
	                         -attributeType => GTx::ATT_TYPE_STATUS, 
	                         -reason => REASON_STATE, 
	                         -value => $idStatus,
	                         -idRole => $args{-idRole},
	                         -sessionId => $args{-sessionId});
	if ($args{-remark}) {
		$a->setRemark($args{-remark});
	}
}

#
# Add a new info to an entity or sub-entity
#
sub addInfo
{
	my $self = shift;
	my %args = @_;

	croak "-pe not specified" unless $args{-pe};
#    croak "-pe not a GT::Physical::Entity" unless $args{-pe}->isa('GT::Physical::Entity');
    croak '-idContentType required' unless $args{-idContentType};
    croak '-idContent required' unless $args{-idContent};
    croak '-reason required' unless $args{-reason};

    my $info = $self->do_create('GT::Physical::Entity::Contents::Info',
				-idContent => $args{-idContent},
				-idContentType => $args{-idContentType},
				-idReason => $args{-reason}
			       );

	if ($args{-pe}->isa('GT::Physical::Entity')) {
    	$args{-pe}->getEntireEntity()->addInfo($info);
	} else {
		$args{-pe}->addInfo($info);
	}
    return $info;
}

sub addEntityInfo
{
	my $self = shift;
	$self->addInfo(@_);
}

#
# get an entity info from either a physical entity (or subentity)
# or from a physical entity ID (or subentity ID)
#
sub getInfo
{
	my $self = shift;
	my %args = @_;
	my @info;

	croak "Neither -pe nor -idPe specified" unless $args{-pe} || $args{-idPe};
	croak "-idContentType not specified" unless $args{-idContentType};
	croak "-reason not supplied" unless $args{-reason};

	my $ec;
	if ($args{-pe}) {
		# read from the physical entity (or subentity)
		if ($args{-pe}->isa('GT::Physical::Entity')) {
			$ec = $args{-pe}->getEntireEntity()->getInfo()->getContents();
		} else {
			$ec = $args{-pe}->getInfo()->getContents();;
		}

		@info = grep $_->getIdContentType() == $args{-idContentType} && 
		             $_->getIdReason() == $args{-reason}, values %{$ec};

	} else {
		# read directly from the database by physical entity ID (or subentity ID)
		if ($args{-sub}) {
			my $sub = $self->getSubEntity(-idEntityContent => $args{-idPe});
			my ($i) = $self->getInfo(-pe=>$sub,-idContentType=>$args{-idContentType},-reason=>$args{-reason});
			push @info, @$i;
		} else {
			my $res = $self->{se}->getAll('GTx::getContentsInfo', 
			                              [$args{-idPe}, $args{-reason}, $args{-idContentType}],
			                              $self->{dbh});
			foreach my $r (@$res) {
				my $sub = $self->getSubEntity(-idEntityContent => $r->[0]);
				my ($i) = $self->getInfo(-pe=>$sub,-idContentType=>$args{-idContentType},-reason=>$args{-reason});
				push @info, @$i;
			}
		}
	}

	return wantarray ? \@info : $info[0];
}

#
# provided for backwards compatibility only - please use getInfo() instead
#
sub getEntityInfo
{
	my $self = shift;
	return $self->getInfo(@_);
}

#
# get a list of physical entity number matching a given status
#
sub getPeByStatus
{
	my $self = shift;
	my %args = @_;
	my @peIdList;

	croak "-status not specified" unless $args{-status};
	croak "-entityType not specified" unless $args{-entityType};

	my $id = $self->_getStatusId(-entityType => $args{-entityType}, -status => $args{-status});
	croak "invalid status '$args{-status}'" unless $id;

	my $rows = $self->{se}->getAll('GTx::getPeByStatus', [$args{-entityType}, $id], $self->{dbh});
	foreach my $x (@$rows) { 
		push @peIdList, $x->[0];
	}

	return \@peIdList;
}


#
# get a list of physical entity ids with a given info
#
sub getPeByInfo {

    my $pkg = shift;
    my %args = @_;

    croak "-idContentType not specified" unless $args{-idContentType};
    croak "-idContent not specified" unless $args{-idContent};
    croak "-entityType not specified" unless $args{-entityType};

    my @peIds = ();
    my $pes;

    if ($args{-reason}) {
        $pes = $pkg->{se}->getAll('GTx::getPeByInfoReason', [$args{-idContentType}, $args{-reason}, $args{-idContent}, $args{-entityType}],$pkg->{dbh});
    }
    else {
        $pes = $pkg->{se}->getAll('GTx::getPeByInfo', [$args{-idContentType}, $args{-idContent}, $args{-entityType}],$pkg->{dbh});
    }

    foreach (@$pes) { 
        push @peIds, $_->[0];
    }

    return(\@peIds);
}



#
# get a list of physical entity ids with a given attribute type and value
#
sub getPeByAttribute {

    my $pkg = shift;
    my %args = @_;

    croak "-attributeType not specified" unless $args{-attributeType};
    croak "-entityType not specified" unless $args{-entityType};
    croak "-value not specified" unless defined $args{-value};

    my @peIds = ();
    my $pes;

    if ($args{-allAtts}) {
        if ($args{-reason}) {
            $pes = $pkg->{se}->getAll('GTx::getAllPeByAttributeReason', [ $args{-reason}, $args{-entityType}, $args{-attributeType}, $args{-value}],$pkg->{dbh});
        }
        else {
            $pes = $pkg->{se}->getAll('GTx::getAllPeByAttribute', [ $args{-entityType}, $args{-attributeType}, $args{-value}],$pkg->{dbh});
        }
    }
    else {
        if ($args{-reason}) {
            $pes = $pkg->{se}->getAll('GTx::getPeByAttributeReason', [ $args{-reason}, $args{-entityType}, $args{-attributeType}, $args{-value}],$pkg->{dbh});
        }
        else {
            $pes = $pkg->{se}->getAll('GTx::getPeByAttribute', [ $args{-entityType}, $args{-attributeType}, $args{-value}],$pkg->{dbh});
        }
    }

    foreach my $pe (@$pes) { 
	push @peIds, $pe->[0];
    }

    return(\@peIds);
}

#
# gets a list of sub entity idContents with a given attribute value which are associated with a given physical entity
#
sub getSeByAttribute {

    my $pkg = shift;
    my %args = @_;

#    croak "-pe or -idPe not specified" unless ($args{-pe} || $args{-idPe});
    croak "-attributeType not specified" unless $args{-attributeType};
    croak "-entityType not specified" unless $args{-entityType};
    croak "-value not specified" unless defined $args{-value};

    # get the id_entity for the pe if necessary
    if ($args{-pe} && !($args{-idPe})) {
        $args{-idPe} = $args{-pe}->getId();
    }

    my $ses = ();
    my @seIds = ();


    if ($args{-allAtts}) {
        if ($args{-reason}) {
            if ($args{-idPe}) {
                $ses = $pkg->{se}->getAll('GTx::getAllSeByAttributePeReason', [$args{-reason}, $args{-idPe}, $args{-attributeType}, $args{-value}, $args{-entityType}],$pkg->{dbh});
            }
            else {
                $ses = $pkg->{se}->getAll('GTx::getAllSeByAttributeReason', [$args{-reason}, $args{-attributeType}, $args{-value}, $args{-entityType}],$pkg->{dbh});
            }
        }

        else {
            if ($args{-idPe}) {
                $ses = $pkg->{se}->getAll('GTx::getAllSeByAttributePe', [$args{-idPe}, $args{-attributeType}, $args{-value}, $args{-entityType}],$pkg->{dbh});
            }
            else {
                $ses = $pkg->{se}->getAll('GTx::getAllSeByAttribute', [$args{-attributeType}, $args{-value}, $args{-entityType}],$pkg->{dbh});
            }
        }
    }

    else {
        if ($args{-reason}) {
            if ($args{-idPe}) {
                $ses = $pkg->{se}->getAll('GTx::getSeByAttributePeReason', [$args{-reason}, $args{-idPe}, $args{-attributeType}, $args{-value}, $args{-entityType}],$pkg->{dbh});
            }
            else {
                $ses = $pkg->{se}->getAll('GTx::getSeByAttributeReason', [$args{-reason}, $args{-attributeType}, $args{-value}, $args{-entityType}],$pkg->{dbh});
            }
        }

        else {
            if ($args{-idPe}) {
                $ses = $pkg->{se}->getAll('GTx::getSeByAttributePe', [$args{-idPe}, $args{-attributeType}, $args{-value}, $args{-entityType}],$pkg->{dbh});
            }
            else {
                $ses = $pkg->{se}->getAll('GTx::getSeByAttribute', [$args{-attributeType}, $args{-value}, $args{-entityType}],$pkg->{dbh});
            }
        }
    }

    foreach (@$ses) { 
        push @seIds,  $_->[0];
    }
#	print "se ids are @seIds\n";
    return(\@seIds);
}


#
# get a user
#
#
# gets a list of sub entity idContents with a given contents info value which are associated with a given physical entity
#
sub getSeByInfo {

    my $pkg = shift;
    my %args = @_;

#    croak "-pe or -idPe not specified" unless ($args{-pe} || $args{-idPe});
    croak "-idContentType not specified" unless $args{-idContentType};
    croak "-idContent not specified" unless $args{-idContent};
    croak "-entityType not specified" unless $args{-entityType};

    # get the id_entity for the pe if necessary
    if ($args{-pe} && !($args{-idPe})) {
        $args{-idPe} = $args{-pe}->getId();
    }

    my $ses = ();
    my @seIds = ();

    if ($args{-reason}) {
        if ($args{-idPe}) {
            $ses = $pkg->{se}->getAll('GTx::getSeByInfoPeReason', [$args{-idPe}, $args{-idContentType}, $args{-reason}, $args{-idContent}, $args{-entityType}],$pkg->{dbh});
        }
        else {
            $ses = $pkg->{se}->getAll('GTx::getSeByInfoReason', [$args{-idContentType}, $args{-reason}, $args{-idContent}, $args{-entityType}],$pkg->{dbh});
        }
    }
    else {
        if ($args{-idPe}) {
            $ses = $pkg->{se}->getAll('GTx::getSeByInfoPe', [$args{-idPe}, $args{-idContentType}, $args{-idContent}, $args{-entityType}],$pkg->{dbh});
        }
        else {
            $ses = $pkg->{se}->getAll('GTx::getSeByInfo', [$args{-idContentType}, $args{-idContent}, $args{-entityType}],$pkg->{dbh});
        }
    }

    foreach (@$ses) { 
        push @seIds,  $_->[0];
    }
#    print "se ids are @seIds\n";
    return(\@seIds);
}


#
# get a user
#
sub getUser
{
	my $self = shift;
	my %args = @_;

	if ($args{-userBarcode}) {
		my $result = Checkbarcode2::Verifynumber($args{-userBarcode});
		croak $result->{Process} . " user barcode" unless $result->{Process} eq 'Good';
		croak "Not a user id" unless $result->{Type} eq 'ID';
		$args{-idPerson} = $result->{Number};
	}

	if ($args{-idRole}) {
		$args{-idPerson} = $self->{se}->getRow('GTx::getPersonFromIdRole', [$args{-idRole}], $self->{dbh});
	}

    croak "-idPerson required" unless $args{-idPerson};

    my ($fname, $sname, $email, $phone, $room) = $self->{se}->getRow('GTx::getPersonFromId', [$args{-idPerson}], $self->{dbh});
    return undef unless $sname;
    return new GTx::User(-forename => $fname, -surname => $sname, -email => $email,
            -phone => $phone, -room => $room, -idperson => $args{-idPerson});
}

#
# get teams
#
sub getTeams 
{
	my $self = shift;
	my %args = @_;

	croak "-roleType required" unless $args{-roleType};
	my @teams = ();
	my $ref;
	if ($args{-idPerson}) {
		$ref = $self->{se}->getAll('GTx::getTeamsFromRoleTypeAndId', [$args{-roleType}, $args{-idPerson}], $self->{dbh});
	} else {
		$ref = $self->{se}->getAll('GTx::getTeamsFromRoleType', [$args{-roleType}], $self->{dbh});
	}

	foreach (@{$ref}) {
		my ($team) = @{$_};
		push @teams, $team;
	}
	return \@teams if @teams;
	return undef;
}


#
# Flush 
#
sub flush
{
	my $self = shift;
	my %args = @_;

	croak "-pe not specified" unless $args{-pe};
	# surpress all those 'Flushing...' progress messages
	local $SIG{__WARN__} = sub { warn "$_[0]" unless $_[0] =~ /^Flushing /; } if $args{-quiet};
	$args{-pe}->flush();
}

#
# begin a transaction
#
sub beginTransaction
{
	my $self = shift;
	$self->{se}->beginTransaction($self->{dbh});
}

#
# roll back a transaction
#
sub rollbackTransaction
{
	my $self = shift;
	$self->{se}->rollbackTransaction($self->{dbh});
}

#
# commit a transaction
#
sub commitTransaction
{
	my $self = shift;
	$self->{se}->commitTransaction($self->{dbh});
}

#
# report a process error
#
sub reportProcessError
{
	my $self = shift;
	my %args = @_;

	Mail::sendMail(-to => $args{-email},
	               -subject => "Process Error in process $args{-processCode} of " . $self->_getProgram,
	               -message => $args{-message})
	unless $args{-noEmail};
	die $@;
}

#
# Check a pattern
#
sub checkPattern
{
	my $self = shift;
	my %args = @_;

	croak "-pe not specified" unless $args{-pe};
	croak "-processCode not specified" unless $args{-processCode};
	croak "-isInput not specified" unless defined $args{-isInput};

	# read the pattern from the database
	my ($pattern, $idConcreteIo) = $self->{se}->getRow('GTx::getPattern', 
	                                                   [$args{-processCode}, $args{-isInput}],
	                                                   $self->{dbh});

	if (!$pattern) {
		eval { 
			croak "Pattern for " 
			      . ($args{-isInput} ? 'Input ' : 'Output ' ) 
			      . "process code $args{-processCode} not found in database";
		};
		$self->reportProcessError(%args, -message=>"$@");
	}

	# create the shape of the physical entity
	my $shape = $args{-pe}->makeShape(-idConcreteIo => $idConcreteIo, -dirty=>1, -pretty=>1);

	# and compare the two
	if (! ($shape =~ /$pattern/)) {
		$args{-email} = 'bug' unless $args{-email};
		eval { confess "Checking pattern:\n$pattern\nagainst shape:\n$shape\n"; };
		$self->reportProcessError(%args, -message=>"$@");
	}
}


#
# Validate a process
#
sub validateProcess
{
	my $self = shift;
	my %args = @_;

	croak "-processCode not specified" unless $args{-processCode};

	my $ceIn = $self->{se}->getRow('GTx::getConcreteEntity', 
	                               [$args{-processCode}, '1'],
	                               $self->{dbh});

	my $ceOut = $self->{se}->getRow('GTx::getConcreteEntity', 
	                                [$args{-processCode}, '0'],
	                                $self->{dbh});

	croak "-peIdIn not specified" unless ($args{-peIdIn} || !$ceIn);
	croak "-peIdOut not specified" unless ($args{-peIdOut} || !$ceOut);

	if ($ceIn && $ceOut) {
		if ( ($ceIn == $ceOut && $args{-peIdIn} != $args{-peIdOut}) ||
		     ($ceIn != $ceOut && $args{-peIdIn} == $args{-peIdOut}) ) {
			$args{-email} = 'bug' unless $args{-email};
			eval { confess "validateProcess() failed for process $args{-processCode}"; };
			$self->reportProcessError(%args, -message=>"$@");
		}
	}
}


#
# get Attribute Value 
#
# return an attribute value given a PE id and an attribute type and reason.
# Useful for looking up an internal ID of a PE (for example)
#
sub getAttributeValue
{
	my $self = shift;
	my %args = @_;

	$args{-idPe} = $args{-pe}->getId() if ($args{-pe});
	croak '-idPe not specified' unless $args{-idPe};
	croak '-attributeType not specified' unless $args{-attributeType};
	croak '-reason not specified' unless $args{-reason};

	my $res;
	if ($args{-pe}) {
		# read from the physical entity (or subentity)
		my $a = $self->getAttribute(-pe => $args{-pe},
		                            -attributeType => $args{-attributeType},
		                            -reason => $args{-reason});
		$res = $a->getValue() if $a;
	} else {
		# read directly from the database
		if ($args{-sub}) {
			$res = $self->{se}->getRow('GTx::getSubAttributeValue',
			                              [$args{-idPe}, $args{-attributeType}, $args{-reason}],
			                              $self->{dbh});
		} else {
			$res = $self->{se}->getRow('GTx::getAttributeValue',
			                              [$args{-idPe}, $args{-attributeType}, $args{-reason}],
			                              $self->{dbh});
		}
	}

	return $res;
}


#
# get Info Value 
#
# return an info value given a PE or sub-entity and a contents type and reason.
#
sub getInfoValue
{
	my $self = shift;
	my %args = @_;

	$args{-idPe} = $args{-pe}->getId() if ($args{-pe});
	croak '-idPe not specified' unless $args{-idPe};
	croak '-idContentType not specified' unless $args{-idContentType};
	croak '-reason not specified' unless $args{-reason};

	my $res;
	if ($args{-pe}) {
		# read from physical entity (or subentity)
		my $info = $self->getInfo(-pe => $args{-pe},
		                          -idContentType => $args{-idContentType},
		                          -reason=>$args{-reason});
		$res =  $info->getIdContent();
	} else {
		# read directly from the database
		if ($args{-sub}) {
			$res = $self->{se}->getRow('GTx::getSubInfoValue',
			                              [$args{-idPe}, $args{-idContentType}, $args{-reason}],
			                              $self->{dbh});
		} else {
			$res = $self->{se}->getRow('GTx::getInfoValue',
			                              [$args{-idPe}, $args{-idContentType}, $args{-reason}],
			                              $self->{dbh});
		}
	}

	return $res;
}


#
# get Entity Type and (optinally) prefix
#
sub getEntityType
{
	my $self = shift;
	my %args = @_;

	$args{-idPe} = $args{-pe}->getId() if $args{-pe};
	die "neither -pe not -idPe specified" unless $args{-idPe};

	my ($et,$prefix) = $self->{se}->getRow('GTx::getEntityType',[$args{-idPe}],$self->{dbh});
	return wantarray ? ($et,$prefix) : $et;
}

#----------------------------------------------------------------------------

=head2 Indirection of GT adoption and creation methods

To allow GTx subclasses to replace or modify the creation/adoption
behaviour after GTx has done some processing.

GTx will make method calls on itself, e.g.

 my $pe = $self->do_adopt('GT::Physical::Entity', -id => $peid);

 my $p2 = $self->do_create('GT::Physical::Entity', @stuff);

Because they are method calls, the subclass may override them to do
something before or after the adoption; also it may do the adoption
itself or call the superclass in the usual way.

The default wrappers (in the base GTx class) are very thin, so there
should be no speed penalty.

=cut

sub do_adopt {
    my ($self, $gtClass, @args) = @_;
    return $gtClass->adopt(@args);
}

sub do_create {
    my ($self, $gtClass, @args) = @_;
    return $gtClass->create(@args);
}


1;

