Hide Show 57 lines of Pod
BEGIN {
$ID
=
"Genetics::Object"
;
$DEBUG
= 0 ;
$DEBUG
and $| = 1 ;
$DEBUG
and
warn
"Debugging in $ID (v$VERSION) is on"
;
}
Hide Show 25 lines of Pod
require
5.004 ;
use
vars
qw($ID $VERSION $DEBUG $AUTOLOAD
@OBJ_ATTRS @OBJ_REQD_ATTRS @OBJ_XML_ATTRS
$HTML_TEMPLATE_DIR)
;
@OBJ_ATTRS
=
qw(name id importID dateCreated dateModified url comment
NameAliases Contact DBXReferences Keywords)
;
@OBJ_REQD_ATTRS
=
qw(name)
;
@OBJ_XML_ATTRS
=
qw(name id)
;
$HTML_TEMPLATE_DIR
=
"/var/slm/work/GenPerl/templates"
;
Hide Show 14 lines of Pod
sub
new {
my
(
$pkg
,
%args
) =
@_
;
my
(
$self
) = {} ;
bless
$self
,
ref
(
$pkg
) ||
$pkg
;
$DEBUG
and carp
"\n==>Creating new $ID object: $self"
;
$self
->_initialize(
%args
) ;
$DEBUG
and carp
"==>Successfully created new $ID object: $self"
;
return
(
$self
) ;
}
Hide Show 10 lines of Pod
sub
type {
my
(
$self
) =
shift
;
my
$pkg
=
ref
(
$self
) ;
my
(
$type
) =
$pkg
=~ /\.*::(\w+)/ ;
return
$type
;
}
Hide Show 16 lines of Pod
sub
field {
my
(
$self
,
$field
,
$value
) =
@_
;
my
(
$class
,
$k
,
$v
,
@h
) ;
$class
=
ref
$self
;
@_
== 1 and
return
grep
(/^[^_]/,
sort
keys
%$self
) ;
@_
== 2 and !
defined
$self
->{
$field
} and
return
undef
;
if
(
@_
== 3) {
if
(not
ref
$value
) {
$self
->{
$field
} =
$value
;
$DEBUG
and (
$value
ne
""
) and carp
" ->Setting $class attribute '$field' to '$value'"
;
}
elsif
(
ref
$value
eq
"ARRAY"
) {
$self
->{
$field
} =
$value
;
$DEBUG
and carp
" ->Setting $class attribute '$field' to [ "
,
join
(
", "
,
@$value
),
" ]"
;
}
elsif
(
ref
$value
eq
"HASH"
) {
$self
->{
$field
} =
$value
;
if
(
$DEBUG
) {
while
((
$k
,
$v
) =
each
%$value
) {
push
(
@h
,
"$k => $v"
) ;
}
carp
" ->Setting $class attribute '$field' to { "
,
join
(
", "
,
@h
),
" }"
;
}
}
else
{
carp
" ->Value of $class attribute $field is a reference to an unsupported type"
;
}
}
return
$self
->{
$field
} ;
}
Hide Show 11 lines of Pod
sub
print
{
my
(
$self
) =
@_
;
my
(
$field
,
$value
,
$printString
) ;
print
"\n$self:\n"
;
foreach
$field
(
$self
->field()) {
$value
=
$self
->field(
$field
) ;
$printString
= _attr2String(
$value
) ;
printf
"%-22s:\t%s\n"
,
$field
,
$printString
;
}
print
"\n"
;
return
1 ;
}
Hide Show 11 lines of Pod
sub
dump
{
my
(
$self
) =
@_
;
my
(
$field
,
$value
,
$printString
,
$returnString
) ;
$returnString
=
"\n$self:\n"
;
foreach
$field
(
sort
$self
->field()) {
$value
=
$self
->field(
$field
) ;
$printString
= _attr2String(
$value
) ;
$returnString
.=
sprintf
"%-22s:\t%s\n"
,
$field
,
$printString
;
}
$returnString
.=
"\n"
;
return
$returnString
;
}
Hide Show 12 lines of Pod
sub
printObjectXML {
my
(
$self
,
$writer
) =
@_
;
my
(
$class
,
$attrName
,
%xmlAttr
,
$value
,
$hashPtr
,
$hashPtr2
) ;
$class
=
ref
$self
;
$class
=~ s/.*::// ;
foreach
$attrName
(
@OBJ_XML_ATTRS
) {
if
(
defined
(
$self
->field(
$attrName
))) {
$xmlAttr
{
$attrName
} =
$self
->field(
$attrName
) ;
}
}
$writer
->startTag(
$class
,
%xmlAttr
) ;
$writer
->dataElement(
'DateCreated'
,
$self
->field(
'dateCreated'
)) ;
$hashPtr
=
$self
->field(
'CreatedBy'
) ;
$writer
->startTag(
'CreatedBy'
) ;
$writer
->startTag(
'UserRef'
) ;
$writer
->dataElement(
'Name'
,
$$hashPtr
{name}) ;
$writer
->dataElement(
'ID'
,
$$hashPtr
{id}) ;
$writer
->endTag(
'UserRef'
) ;
$writer
->endTag(
'CreatedBy'
) ;
$writer
->dataElement(
'DateModified'
,
$self
->field(
'dateModified'
)) ;
$hashPtr
=
$self
->field(
'ModifiedBy'
) ;
$writer
->startTag(
'ModifiedBy'
) ;
$writer
->startTag(
'UserRef'
) ;
$writer
->dataElement(
'Name'
,
$$hashPtr
{name}) ;
$writer
->dataElement(
'ID'
,
$$hashPtr
{id}) ;
$writer
->endTag(
'UserRef'
) ;
$writer
->endTag(
'ModifiedBy'
) ;
if
(
defined
(
$value
=
$self
->field(
'DataContainer'
))) {
$writer
->dataElement(
'DataContainer'
,
$value
) ;
}
return
(1) ;
}
Hide Show 11 lines of Pod
sub
toStone {
my
(
$self
) =
@_
;
my
(
$stone
,
$field
,
$value
,
$valueAsString
,
%init
) ;
foreach
$field
(
$self
->field()) {
$value
=
$self
->field(
$field
) ;
$field
=
ucfirst
$field
;
$init
{
$field
} =
$value
;
}
$stone
= new Stone(
%init
) ;
return
$stone
;
}
Hide Show 12 lines of Pod
sub
AUTOLOAD {
my
$self
=
shift
;
my
$class
=
ref
$self
;
my
(
$package
,
$methodName
) =
$AUTOLOAD
=~ /(.+)::([^:]+)$/ ;
no
strict
'refs'
;
unless
(
grep
{
$methodName
eq
$_
} (
@OBJ_ATTRS
, @{
"${class}::ATTRS"
}) ) {
croak
"Can't locate object method \"$methodName\" via package \"$package\". \"$methodName\" must be a valid field in class \"$package\" in order to be invoked as a method in this way."
;
}
return
$self
->field(
$methodName
,
@_
) ;
}
Hide Show 12 lines of Pod
sub
DESTROY {
my
(
$self
) =
shift
;
my
$pkg
=
ref
$self
;
$DEBUG
and carp
"\n==>Destroyed $ID object: $self"
;
}
Hide Show 13 lines of Pod
sub
_initialize {
my
(
$self
,
%args
) =
@_
;
my
(
$class
,
$k
,
$v
,
$k2
,
$v2
,
@h
) ;
$class
=
ref
$self
;
no
strict
'refs'
;
while
((
$k
,
$v
) =
each
%args
) {
if
(not
ref
$v
) {
if
(
grep
{
$k
eq
$_
} (
@OBJ_ATTRS
, @{
"${class}::ATTRS"
} )) {
$self
->{
$k
} =
$v
;
$DEBUG
and carp
" ->Setting $class attribute '$k' to '$v'"
;
}
else
{
carp
"<<- WARNING ->> Skipping invalid $class attribute '$k'"
;
next
;
}
}
elsif
(
ref
$v
eq
"ARRAY"
) {
if
(
grep
{
$k
eq
$_
} (
@OBJ_ATTRS
, @{
"${class}::ATTRS"
} )) {
$self
->{
$k
} =
$v
;
$DEBUG
and carp
" ->Setting $class attribute '$k' to [ "
,
join
(
", "
,
@$v
),
" ]"
;
}
else
{
carp
"<<- WARNING ->> Skipping invalid $class attribute '$k'"
;
next
;
}
}
elsif
(
ref
$v
eq
"HASH"
) {
if
(
grep
{
$k
eq
$_
} (
@OBJ_ATTRS
, @{
"${class}::ATTRS"
} )) {
$self
->{
$k
} =
$v
;
if
(
$DEBUG
) {
while
((
$k2
,
$v2
) =
each
%$v
) {
push
(
@h
,
"$k2 => $v2"
) ;
}
carp
" ->Setting $class attribute '$k' to { "
,
join
(
", "
,
@h
),
" }"
;
}
}
else
{
carp
"<<- WARNING ->> Skipping invalid $class attribute '$k'"
;
next
;
}
}
else
{
carp
"<<- WARNING ->> Value of $class attribute $k is a reference to an unsupported type"
;
}
}
$self
->_setDefaults() ;
$self
->_verifyRequired() ;
$DEBUG
and carp
">=>Completed initialization of object: $self"
;
return
(1) ;
}
Hide Show 11 lines of Pod
sub
_setDefaults {
my
(
$self
) =
@_
;
my
(
$class
,
$k
,
$v
) ;
$class
=
ref
$self
;
no
strict
'refs'
;
while
( (
$k
,
$v
) =
each
%{
"${class}::DEFAULTS"
} ) {
unless
(
defined
$self
->field(
$k
) &&
$self
->field(
$k
) ne
""
) {
$self
->field(
$k
,
$v
) ;
$DEBUG
and carp
" ->Setting $ID field '$k' to default value '$v'"
;
}
}
$DEBUG
and carp
"==>Completed setting default attributes for object: $self"
;
return
(1) ;
}
Hide Show 11 lines of Pod
sub
_verifyRequired {
my
(
$self
) =
@_
;
my
(
$class
,
$field
,
$key
,
$id
,
$dumpStr
) ;
unless
( (
defined
(
$id
=
$self
->field(
"id"
)) &&
$id
ne
""
) or
((
defined
(
$id
=
$self
->field(
"importID"
)) &&
$id
ne
""
)) ) {
croak
"<<- FATAL ->> Required attribute id/importID is not defined for object $self"
;
}
$class
=
ref
$self
;
no
strict
'refs'
;
foreach
$field
(
@OBJ_REQD_ATTRS
, @{
"${class}::REQD_ATTRS"
} ) {
unless
(
defined
$self
->field(
$field
) &&
$self
->field(
$field
) ne
""
) {
$dumpStr
=
$self
->
dump
() ;
croak
"<<- FATAL ->> Required attribute/relationship '$field' is not defined for object: $dumpStr"
;
}
}
$DEBUG
and carp
"==>Completed verification of object: $self"
;
return
(1) ;
}
Hide Show 12 lines of Pod
sub
_generalHTMLParam {
my
(
$self
,
$paramPtr
) =
@_
;
my
(
$datem
,
$y
,
$m
,
$d
,
$h
,
$p
,
$s
,
$naListPtr
,
$naPtr
,
@nameAliases
,
$dbxrListPtr
,
$dbxrPtr
,
@dbXRefs
,
$kwListPtr
,
$kwPtr
,
@keywords
) ;
$$paramPtr
{NAME} =
$self
->name() ;
$$paramPtr
{ID} =
$self
->id() ;
$$paramPtr
{DATECREATED} =
$self
->dateCreated() ;
if
(
$datem
=
$self
->dateModified()) {
(
$y
,
$m
,
$d
,
$h
,
$p
,
$s
) =
$datem
=~ /(\d{4})(\d{2})(\d{2})(\d{2})(\d{2})(\d{2})/ ;
$$paramPtr
{DATEMODIFIED} =
$self
->dateModified(
"$y-$m-$d $h:$p:$s"
) ;
}
$self
->url() and
$$paramPtr
{URL} =
$self
->url() ;
$self
->comment() and
$$paramPtr
{COMMENT} =
$self
->comment() ;
if
(
$naListPtr
=
$self
->NameAliases()) {
foreach
$naPtr
(
@$naListPtr
) {
push
@nameAliases
,
"$$naPtr{name}($$naPtr{contactName})"
;
}
}
$$paramPtr
{NAMEALIASES} =
join
(
", "
,
@nameAliases
) ;
$self
->Contact() and
$$paramPtr
{CONTACT} = ${
$self
->Contact()}->{name} ;
if
(
$dbxrListPtr
=
$self
->DBXReferences()) {
foreach
$dbxrPtr
(
@$dbxrListPtr
) {
push
@dbXRefs
,
"$$dbxrPtr{accessionNumber }:$$dbxrPtr{databaseName}"
;
}
}
$$paramPtr
{DBXREFS} =
join
(
", "
,
@dbXRefs
) ;
if
(
$kwListPtr
=
$self
->Keywords()) {
foreach
$kwPtr
(
@$kwListPtr
) {
push
@keywords
,
"$$kwPtr{name}=$$kwPtr{value}"
;
}
}
$$paramPtr
{KEYWORDS} =
join
(
", "
,
@keywords
) ;
return
1 ;
}
Hide Show 13 lines of Pod
sub
_attr2String {
my
(
$value
) =
@_
;
my
(
$str
,
$k
,
$v
,
@data
) ;
if
(not
defined
$value
) {
$str
=
""
;
}
elsif
(not
ref
$value
) {
$str
=
$value
;
}
elsif
(
ref
$value
eq
"ARRAY"
) {
foreach
$v
(
@$value
) {
$str
= _attr2String(
$v
) ;
push
(
@data
,
$str
)
}
$str
=
"[ "
.
join
(
", "
,
@data
) .
" ]"
;
}
elsif
(
ref
$value
eq
"HASH"
) {
@data
= () ;
while
((
$k
,
$v
) =
each
%$value
) {
$str
= _attr2String(
$v
) ;
push
(
@data
,
"$k => $str"
) ;
}
$str
=
"{ "
.
join
(
", "
,
@data
) .
" }"
;
}
else
{
$str
=
"Reference to an unsupported type"
;
}
return
(
$str
) ;
}
1;