src/perlmods/OpenSRF/DOM/Element/domainObject.pm

   1 package OpenSRF::DOM::Element::domainObject;
   2 use strict; use warnings;
   3 use base 'OpenSRF::DOM::Element';
   4 use OpenSRF::DOM;
   5 use OpenSRF::DOM::Element::domainObjectAttr;
   6 use OpenSRF::Utils::Logger qw(:level);
   7 use OpenSRF::EX;
   8 use Carp;
   9 #use OpenSRF::DomainObject::oilsPrimitive;
  10 #use OpenSRF::DomainObject::oilsResponse;
  11 use vars qw($AUTOLOAD);
  12
  13 sub AUTOLOAD {
  14         my $self = shift;
  15         (my $name = $AUTOLOAD) =~ s/.*://;   # strip fully-qualified portion
  16
  17         return class($self) if ($name eq 'class');
  18         if ($self->can($name)) {
  19                 return $self->$name(@_);
  20         }
  21
  22         if (1) {
  23                 ### Check for recursion
  24                 my $calling_method = (caller(1))[3];
  25                 my @info = caller(1);
  26
  27                 if( @info ) {
  28                         if ($info[0] =~ /AUTOLOAD/) { @info = caller(2); }
  29                 }
  30                 unless( @info ) { @info = caller(); }
  31
  32                 if( $calling_method  and $calling_method eq "OpenSRF::DOM::Element::domainObject::AUTOLOAD" ) {
  33                         warn Carp::cluck;
  34                         throw OpenSRF::EX::PANIC ( "RECURSION! Caller [ @info[0..2] ] | Object [ ".ref($self)." ]\n ** Trying to call $name", ERROR );
  35                 }
  36                 ### Check for recursion
  37         }
  38
  39         my @args = @_;
  40         my $meth = class($self).'::'.$name;
  41
  42         try {
  43                 return $self->$meth(@args);
  44         } catch Error with {
  45                 my $e = shift;
  46                 OpenSRF::Utils::Logger->error( $@ . $e);
  47                 die $@;
  48         };
  49
  50
  51         my $node = OpenSRF::DOM::Element::domainObject::upcast($self);
  52         OpenSRF::Utils::Logger->debug( "Autoloaded to: ".ref($node), INTERNAL );
  53
  54         return $node->$name(@_);
  55 }
  56
  57 sub downcast {
  58         my $obj = shift;
  59         return bless $obj => 'XML::LibXML::Element';
  60 }
  61
  62 sub upcast {
  63         my $self = shift;
  64         return bless $self => class($self);
  65 }
  66
  67 sub new {
  68         my $class = shift;
  69         my $type = shift;
  70         my $obj = $class->SUPER::new( name => $type );
  71         while (@_) {
  72                 my ($attr,$val) = (shift,shift);
  73                 last unless ($attr and $val);
  74                 $obj->addAttr( $attr, $val );
  75                 #$obj->appendChild( OpenSRF::DOM::Element::domainObjectAttr->new($attr, $val) );
  76         }
  77         return $obj;
  78 }
  79
  80 sub class {
  81         my $self = shift;
  82         return 'OpenSRF::DomainObject::'.$self->getAttribute('name');
  83 }
  84
  85 sub base_type {
  86         my $self = shift;
  87         return $self->getAttribute('name');
  88 }
  89
  90 sub addAttr {
  91         my $self = shift;
  92         $self->appendChild( $_ ) for OpenSRF::DOM::Element::domainObjectAttr->new(@_);
  93         return $self;
  94 }
  95
  96 sub attrNode {
  97         my $self = shift;
  98         my $type = shift;
  99         return (grep { $_->getAttribute('name') eq $type } $self->getChildrenByTagName("oils:domainObjectAttr"))[0];
 100 }
 101
 102 sub attrHash {
 103         my $self = shift;
 104         my %attrs = map { ( $_->getAttribute('name') => $_->getAttribute('value') ) } $self->getChildrenByTagName('oils:domainObjectAttr');
 105
 106         return \%attrs;
 107 }
 108
 109 sub attrValue {
 110         my $self = shift;
 111         return $self->attrHash->{shift};
 112 }
 113
 114 1;