From fce76471d2b6d959f038ad7200036ebd3b1fd5a7 Mon Sep 17 00:00:00 2001 From: miker Date: Wed, 4 Jul 2007 20:08:15 +0000 Subject: [PATCH] removing vestigial DOM code from back when opensrf talked XML git-svn-id: svn://svn.open-ils.org/OpenSRF/trunk@992 9efc2488-bf62-4759-914b-345cdb29e865 --- src/perlmods/OpenSRF/AppSession.pm | 2 +- src/perlmods/OpenSRF/DOM.pm | 289 -------- .../OpenSRF/DOM/Element/domainObject.pm | 118 ---- .../OpenSRF/DOM/Element/domainObjectAttr.pm | 15 - .../DOM/Element/domainObjectCollection.pm | 116 ---- src/perlmods/OpenSRF/DOM/Element/params.pm | 4 - src/perlmods/OpenSRF/DomainObject.pm | 85 --- .../OpenSRF/DomainObject/oilsMultiSearch.pm | 186 ------ .../OpenSRF/DomainObject/oilsPrimitive.pm | 623 ------------------ .../OpenSRF/DomainObject/oilsSearch.pm | 106 --- .../OpenSRF/DomainObjectCollection.pm | 35 - src/perlmods/OpenSRF/System.pm | 2 +- 12 files changed, 2 insertions(+), 1579 deletions(-) delete mode 100644 src/perlmods/OpenSRF/DOM.pm delete mode 100644 src/perlmods/OpenSRF/DOM/Element/domainObject.pm delete mode 100644 src/perlmods/OpenSRF/DOM/Element/domainObjectAttr.pm delete mode 100644 src/perlmods/OpenSRF/DOM/Element/domainObjectCollection.pm delete mode 100644 src/perlmods/OpenSRF/DOM/Element/params.pm delete mode 100644 src/perlmods/OpenSRF/DomainObject.pm delete mode 100644 src/perlmods/OpenSRF/DomainObject/oilsMultiSearch.pm delete mode 100644 src/perlmods/OpenSRF/DomainObject/oilsPrimitive.pm delete mode 100644 src/perlmods/OpenSRF/DomainObject/oilsSearch.pm delete mode 100644 src/perlmods/OpenSRF/DomainObjectCollection.pm diff --git a/src/perlmods/OpenSRF/AppSession.pm b/src/perlmods/OpenSRF/AppSession.pm index 3dcfc61..6d663bf 100644 --- a/src/perlmods/OpenSRF/AppSession.pm +++ b/src/perlmods/OpenSRF/AppSession.pm @@ -1,5 +1,5 @@ package OpenSRF::AppSession; -use OpenSRF::DOM; +#use OpenSRF::DOM; #use OpenSRF::DOM::Element::userAuth; use OpenSRF::DomainObject::oilsMessage; use OpenSRF::DomainObject::oilsMethod; diff --git a/src/perlmods/OpenSRF/DOM.pm b/src/perlmods/OpenSRF/DOM.pm deleted file mode 100644 index 8ddb095..0000000 --- a/src/perlmods/OpenSRF/DOM.pm +++ /dev/null @@ -1,289 +0,0 @@ -use XML::LibXML; -use OpenSRF::Utils::Logger qw(:level); - -package XML::LibXML::Element; -use OpenSRF::EX; - -sub AUTOLOAD { - my $self = shift; - (my $name = $AUTOLOAD) =~ s/.*://; # strip fully-qualified portion - - ### Check for recursion - my $calling_method = (caller(1))[3]; - my @info = caller(1); - - if( @info ) { - if ($info[0] =~ /AUTOLOAD/) { @info = caller(2); } - } - unless( @info ) { @info = caller(); } - if( $calling_method and $calling_method eq "XML::LibXML::Element::AUTOLOAD" ) { - throw OpenSRF::EX::PANIC ( "RECURSION! Caller [ @info ] | Object [ ".ref($self)." ]\n ** Trying to call $name", ERROR ); - } - ### Check for recursion - - #OpenSRF::Utils::Logger->debug( "Autoloading method for DOM: $AUTOLOAD on ".$self->toString, INTERNAL ); - - my $new_node = OpenSRF::DOM::upcast($self); - OpenSRF::Utils::Logger->debug( "Autoloaded to: ".ref($new_node), INTERNAL ); - - return $new_node->$name(@_); -} - - - -#-------------------------------------------------------------------------------- -package OpenSRF::DOM; -use base qw/XML::LibXML OpenSRF/; - -our %_NAMESPACE_MAP = ( - 'http://open-ils.org/xml/namespaces/oils_v1' => 'oils', -); - -our $_one_true_parser; - -sub new { - my $self = shift; - return $_one_true_parser if (defined $_one_true_parser); - $_one_true_parser = $self->SUPER::new(@_); - $_one_true_parser->keep_blanks(0); - $XML::LibXML::skipXMLDeclaration = 0; - return $_one_true_parser = $self->SUPER::new(@_); -} - -sub createDocument { - my $self = shift; - - # DOM API: createDocument(namespaceURI, qualifiedName, doctype?) - my $doc = XML::LibXML::Document->new("1.0", "UTF-8"); - my $el = $doc->createElement('root'); - - $el->setNamespace('http://open-ils.org/xml/namespaces/oils_v1', 'oils', 1); - $doc->setDocumentElement($el); - - return $doc; -} - -my %_loaded_classes; -sub upcast { - my $node = shift; - return undef unless $node; - - my ($ns,$tag) = split ':' => $node->nodeName; - - return $node unless ($ns eq 'oils'); - - my $class = "OpenSRF::DOM::Element::$tag"; - unless (exists $_loaded_classes{$class}) { - $class->use; - $_loaded_classes{$class} = 1; - } - if ($@) { - OpenSRF::Utils::Logger->error("Couldn't use $class! $@"); - } - - #OpenSRF::Utils::Logger->debug("Upcasting ".$node->toString." to $class", INTERNAL); - - return bless $node => $class; -} - -#-------------------------------------------------------------------------------- -package OpenSRF::DOM::Node; -use base 'XML::LibXML::Node'; - -sub new { - my $class = shift; - return bless $class->SUPER::new(@_) => $class; -} - -sub childNodes { - my $self = shift; - my @children = $self->_childNodes(); - return wantarray ? @children : OpenSRF::DOM::NodeList->new( @children ); -} - -sub attributes { - my $self = shift; - my @attr = $self->_attributes(); - return wantarray ? @attr : OpenSRF::DOM::NamedNodeMap->new( @attr ); -} - -sub findnodes { - my ($node, $xpath) = @_; - my @nodes = $node->_findnodes($xpath); - if (wantarray) { - return @nodes; - } else { - return OpenSRF::DOM::NodeList->new(@nodes); - } -} - - -#-------------------------------------------------------------------------------- -package OpenSRF::DOM::NamedNodeMap; -use base 'XML::LibXML::NamedNodeMap'; - -#-------------------------------------------------------------------------------- -package OpenSRF::DOM::NodeList; -use base 'XML::LibXML::NodeList'; - -#-------------------------------------------------------------------------------- -package OpenSRF::DOM::Element; -use base 'XML::LibXML::Element'; - -sub new { - my $class = shift; - - # magically create the element (tag) name, or build a blank element - (my $name = $class) =~ s/^OpenSRF::DOM::Element:://; - if ($name) { - $name = "oils:$name"; - } else { - undef $name; - } - - my $self = $class->SUPER::new($name); - - my %attrs = @_; - for my $aname (keys %attrs) { - $self->setAttribute($aname, $attrs{$aname}); - } - - return $self; -} - -sub getElementsByTagName { - my ( $node , $name ) = @_; - my $xpath = "descendant::$name"; - my @nodes = $node->_findnodes($xpath); - return wantarray ? @nodes : OpenSRF::DOM::NodeList->new(@nodes); -} - -sub getElementsByTagNameNS { - my ( $node, $nsURI, $name ) = @_; - my $xpath = "descendant::*[local-name()='$name' and namespace-uri()='$nsURI']"; - my @nodes = $node->_findnodes($xpath); - return wantarray ? @nodes : OpenSRF::DOM::NodeList->new(@nodes); -} - -sub getElementsByLocalName { - my ( $node,$name ) = @_; - my $xpath = "descendant::*[local-name()='$name']"; - my @nodes = $node->_findnodes($xpath); - return wantarray ? @nodes : OpenSRF::DOM::NodeList->new(@nodes); -} - -sub getChildrenByLocalName { - my ( $node,$name ) = @_; - my $xpath = "./*[local-name()='$name']"; - my @nodes = $node->_findnodes($xpath); - return @nodes; -} - -sub getChildrenByTagName { - my ( $node, $name ) = @_; - my @nodes = grep { $_->nodeName eq $name } $node->childNodes(); - return @nodes; -} - -sub getChildrenByTagNameNS { - my ( $node, $nsURI, $name ) = @_; - my $xpath = "*[local-name()='$name' and namespace-uri()='$nsURI']"; - my @nodes = $node->_findnodes($xpath); - return @nodes; -} - -sub appendWellBalancedChunk { - my ( $self, $chunk ) = @_; - - my $local_parser = OpenSRF::DOM->new(); - my $frag = $local_parser->parse_xml_chunk( $chunk ); - - $self->appendChild( $frag ); -} - -package OpenSRF::DOM::Element::root; -use base 'OpenSRF::DOM::Element'; - -#-------------------------------------------------------------------------------- -package OpenSRF::DOM::Text; -use base 'XML::LibXML::Text'; - - -#-------------------------------------------------------------------------------- -package OpenSRF::DOM::Comment; -use base 'XML::LibXML::Comment'; - -#-------------------------------------------------------------------------------- -package OpenSRF::DOM::CDATASection; -use base 'XML::LibXML::CDATASection'; - -#-------------------------------------------------------------------------------- -package OpenSRF::DOM::Document; -use base 'XML::LibXML::Document'; - -sub empty { - my $self = shift; - return undef unless (ref($self)); - $self->documentElement->removeChild($_) for $self->documentElement->childNodes; - return $self; -} - -sub new { - my $class = shift; - return bless $class->SUPER::new(@_) => $class; -} - -sub getElementsByTagName { - my ( $doc , $name ) = @_; - my $xpath = "descendant-or-self::node()/$name"; - my @nodes = $doc->_findnodes($xpath); - return wantarray ? @nodes : OpenSRF::DOM::NodeList->new(@nodes); -} - -sub getElementsByTagNameNS { - my ( $doc, $nsURI, $name ) = @_; - my $xpath = "descendant-or-self::*[local-name()='$name' and namespace-uri()='$nsURI']"; - my @nodes = $doc->_findnodes($xpath); - return wantarray ? @nodes : OpenSRF::DOM::NodeList->new(@nodes); -} - -sub getElementsByLocalName { - my ( $doc,$name ) = @_; - my $xpath = "descendant-or-self::*[local-name()='$name']"; - my @nodes = $doc->_findnodes($xpath); - return wantarray ? @nodes : OpenSRF::DOM::NodeList->new(@nodes); -} - -#-------------------------------------------------------------------------------- -package OpenSRF::DOM::DocumentFragment; -use base 'XML::LibXML::DocumentFragment'; - -#-------------------------------------------------------------------------------- -package OpenSRF::DOM::Attr; -use base 'XML::LibXML::Attr'; - -#-------------------------------------------------------------------------------- -package OpenSRF::DOM::Dtd; -use base 'XML::LibXML::Dtd'; - -#-------------------------------------------------------------------------------- -package OpenSRF::DOM::PI; -use base 'XML::LibXML::PI'; - -#-------------------------------------------------------------------------------- -package OpenSRF::DOM::Namespace; -use base 'XML::LibXML::Namespace'; - -sub isEqualNode { - my ( $self, $ref ) = @_; - if ( $ref->isa("XML::LibXML::Namespace") ) { - return $self->_isEqual($ref); - } - return 0; -} - -#-------------------------------------------------------------------------------- -package OpenSRF::DOM::Schema; -use base 'XML::LibXML::Schema'; - -1; diff --git a/src/perlmods/OpenSRF/DOM/Element/domainObject.pm b/src/perlmods/OpenSRF/DOM/Element/domainObject.pm deleted file mode 100644 index 4b98512..0000000 --- a/src/perlmods/OpenSRF/DOM/Element/domainObject.pm +++ /dev/null @@ -1,118 +0,0 @@ -package OpenSRF::DOM::Element::domainObject; -use strict; use warnings; -use base 'OpenSRF::DOM::Element'; -use OpenSRF::DOM; -use OpenSRF::DOM::Element::domainObjectAttr; -use OpenSRF::Utils::Logger qw(:level); -use OpenSRF::EX qw(:try); -use Carp; -#use OpenSRF::DomainObject::oilsPrimitive; -#use OpenSRF::DomainObject::oilsResponse; -use vars qw($AUTOLOAD); - -sub AUTOLOAD { - my $self = shift; - (my $name = $AUTOLOAD) =~ s/.*://; # strip fully-qualified portion - - return class($self) if ($name eq 'class'); - if ($self->can($name)) { - return $self->$name(@_); - } - - if (1) { - ### Check for recursion - my $calling_method = (caller(1))[3]; - my @info = caller(1); - - if( @info ) { - if ($info[0] =~ /AUTOLOAD/) { @info = caller(2); } - } - unless( @info ) { @info = caller(); } - - if( $calling_method and $calling_method eq "OpenSRF::DOM::Element::domainObject::AUTOLOAD" ) { - warn Carp::cluck; - throw OpenSRF::EX::PANIC ( "RECURSION! Caller [ @info[0..2] ] | Object [ ".ref($self)." ]\n ** Trying to call $name", ERROR ); - } - ### Check for recursion - } - - my @args = @_; - my $meth = class($self).'::'.$name; - - try { - return $self->$meth(@args); - } catch Error with { - my $e = shift; - if( $e ) { - OpenSRF::Utils::Logger->error( $@ . $e); - } else { - OpenSRF::Utils::Logger->error( $@ ); - } - die $@; - }; - - - my $node = OpenSRF::DOM::Element::domainObject::upcast($self); - OpenSRF::Utils::Logger->debug( "Autoloaded to: ".ref($node), INTERNAL ); - - return $node->$name(@_); -} - -sub downcast { - my $obj = shift; - return bless $obj => 'XML::LibXML::Element'; -} - -sub upcast { - my $self = shift; - return bless $self => class($self); -} - -sub new { - my $class = shift; - my $type = shift; - my $obj = $class->SUPER::new( name => $type ); - while (@_) { - my ($attr,$val) = (shift,shift); - last unless ($attr and $val); - $obj->addAttr( $attr, $val ); - #$obj->appendChild( OpenSRF::DOM::Element::domainObjectAttr->new($attr, $val) ); - } - return $obj; -} - -sub class { - my $self = shift; - return 'OpenSRF::DomainObject::'.$self->getAttribute('name'); -} - -sub base_type { - my $self = shift; - return $self->getAttribute('name'); -} - -sub addAttr { - my $self = shift; - $self->appendChild( $_ ) for OpenSRF::DOM::Element::domainObjectAttr->new(@_); - return $self; -} - -sub attrNode { - my $self = shift; - my $type = shift; - return (grep { $_->getAttribute('name') eq $type } $self->getChildrenByTagName("oils:domainObjectAttr"))[0]; -} - -sub attrHash { - my $self = shift; - my %attrs = map { ( $_->getAttribute('name') => $_->getAttribute('value') ) } $self->getChildrenByTagName('oils:domainObjectAttr'); - - return \%attrs; -} - -sub attrValue { - my $self = shift; - return $self->attrHash->{shift}; -} - -1; diff --git a/src/perlmods/OpenSRF/DOM/Element/domainObjectAttr.pm b/src/perlmods/OpenSRF/DOM/Element/domainObjectAttr.pm deleted file mode 100644 index fbdc28e..0000000 --- a/src/perlmods/OpenSRF/DOM/Element/domainObjectAttr.pm +++ /dev/null @@ -1,15 +0,0 @@ -package OpenSRF::DOM::Element::domainObjectAttr; -use base 'OpenSRF::DOM::Element'; - -sub new { - my $class = shift; - my @nodes; - while (@_) { - my ($name,$val) = (shift,shift); - push @nodes, $class->SUPER::new(name => $name, value => $val); - } - return @nodes if (wantarray); - return $nodes[0]; -} - -1; diff --git a/src/perlmods/OpenSRF/DOM/Element/domainObjectCollection.pm b/src/perlmods/OpenSRF/DOM/Element/domainObjectCollection.pm deleted file mode 100644 index 264c435..0000000 --- a/src/perlmods/OpenSRF/DOM/Element/domainObjectCollection.pm +++ /dev/null @@ -1,116 +0,0 @@ -package OpenSRF::DOM::Element::domainObjectCollection; -use base 'OpenSRF::DOM::Element'; -use OpenSRF::DOM::Element::domainObjectAttr; -use OpenSRF::EX; - -sub AUTOLOAD { - my $self = CORE::shift; - (my $name = $AUTOLOAD) =~ s/.*://; # strip fully-qualified portion - - return class($self) if ($name eq 'class'); - - my @args = @_; - my $meth = class($self).'::'.$name; - - ### Check for recursion - my $calling_method = (caller(1))[3]; - my @info = caller(1); - - if( @info ) { - if ($info[0] =~ /AUTOLOAD/) { @info = caller(2); } - } - unless( @info ) { @info = caller(); } - if( $calling_method and $calling_method eq "OpenSRF::DOM::Element::domainObjectCollection::AUTOLOAD" ) { - throw OpenSRF::EX::PANIC ( "RECURSION! Caller [ @info ] | Object [ ".ref($self)." ]\n ** Trying to call $name", ERROR ); - } - ### Check for recursion - - try { - return $self->$meth(@args);; - } catch Error with { - my $e = shift; - OpenSRF::Utils::Logger->error( $@ . $e); - die $@; - }; - - return upcast($self)->$name(@_); -} - -sub downcast { - my $obj = CORE::shift; - return bless $obj => 'XML::LibXML::Element'; -} - -sub upcast { - my $self = CORE::shift; - return bless $self => class($self); -} - -sub new { - my $class = CORE::shift; - my $type = CORE::shift; - my $obj = $class->SUPER::new( name => $type ); - while ( my $val = shift) { - throw OpenSRF::EX::NotADomainObject - if (ref $val and $val->nodeName !~ /^oils:domainObject/o); - $obj->appendChild( $val ); - } - return $obj; -} - -sub class { - my $self = shift; - return 'OpenSRF::DomainObjectCollection::'.$self->getAttribute('name'); -} - -sub base_type { - my $self = shift; - return $self->getAttribute('name'); -} - -sub pop { - my $self = CORE::shift; - return $self->removeChild( $self->lastChild )->upcast; -} - -sub push { - my $self = CORE::shift; - my @args = @_; - for my $node (@args) { - #throw OpenSRF::EX::NotADomainObject ( "$_ must be a oils:domainOjbect*, it's a ".$_->nodeName ) - # unless ($_->nodeName =~ /^oils:domainObject/o); - - unless ($node->nodeName =~ /^oils:domainObject/o) { - $node = OpenSRF::DomainObject::oilsScalar->new($node); - } - - $self->appendChild( $node ); - } -} - -sub shift { - my $self = CORE::shift; - return $self->removeChild( $self->firstChild )->upcast; -} - -sub unshift { - my $self = CORE::shift; - my @args = @_; - for (reverse @args) { - throw OpenSRF::EX::NotADomainObject - unless ($_->nodeName =~ /^oils:domainObject/o); - $self->insertBefore( $_, $self->firstChild ); - } -} - -sub first { - my $self = CORE::shift; - return $self->firstChild->upcast; -} - -sub list { - my $self = CORE::shift; - return map {(bless($_ => 'OpenSRF::DomainObject::'.$_->getAttribute('name')))} $self->childNodes; -} - -1; diff --git a/src/perlmods/OpenSRF/DOM/Element/params.pm b/src/perlmods/OpenSRF/DOM/Element/params.pm deleted file mode 100644 index ee3755a..0000000 --- a/src/perlmods/OpenSRF/DOM/Element/params.pm +++ /dev/null @@ -1,4 +0,0 @@ -package OpenSRF::DOM::Element::params; -use base 'OpenSRF::DOM::Element'; - -1; diff --git a/src/perlmods/OpenSRF/DomainObject.pm b/src/perlmods/OpenSRF/DomainObject.pm deleted file mode 100644 index 4dc4258..0000000 --- a/src/perlmods/OpenSRF/DomainObject.pm +++ /dev/null @@ -1,85 +0,0 @@ -package OpenSRF::DomainObject; -use base 'OpenSRF::DOM::Element::domainObject'; -use OpenSRF::DOM; -use OpenSRF::Utils::Logger qw(:level); -use OpenSRF::DomainObject::oilsPrimitive; -my $logger = "OpenSRF::Utils::Logger"; - -=head1 NAME - -OpenSRF::DomainObject - -=head1 SYNOPSIS - -OpenSRF::DomainObject is an abstract base class. It -should not be used directly. See C -for details. - -=cut - -my $tmp_doc; - -sub object_castor { - my $self = shift; - my $node = shift; - - return unless (defined $node); - - if (ref($node) eq 'HASH') { - return new OpenSRF::DomainObject::oilsHash (%$node); - } elsif (ref($node) eq 'ARRAY') { - return new OpenSRF::DomainObject::oilsArray (@$node); - } - - return $node; -} - -sub native_castor { - my $self = shift; - my $node = shift; - - return unless (defined $node); - - if ($node->nodeType == 3) { - return $node->nodeValue; - } elsif ($node->nodeName =~ /domainObject/o) { - return $node->tie_me if ($node->class->can('tie_me')); - } - return $node; -} - -sub new { - my $class = shift; - $class = ref($class) || $class; - - (my $type = $class) =~ s/^.+://o; - - $tmp_doc ||= OpenSRF::DOM->createDocument; - my $dO = OpenSRF::DOM::Element::domainObject->new( $type, @_ ); - - $tmp_doc->documentElement->appendChild($dO); - - return $dO; -} - -sub _attr_get_set { - my $self = shift; - my $part = shift; - - my $node = $self->attrNode($part); - - if (defined(my $new_value = shift)) { - if (defined $node) { - my $old_val = $node->getAttribute( "value" ); - $node->setAttribute(value => $new_value); - return $old_val; - } else { - $self->addAttr( $part => $new_value ); - return $new_value; - } - } elsif ( $node ) { - return $node->getAttribute( "value" ); - } -} - -1; diff --git a/src/perlmods/OpenSRF/DomainObject/oilsMultiSearch.pm b/src/perlmods/OpenSRF/DomainObject/oilsMultiSearch.pm deleted file mode 100644 index fda4523..0000000 --- a/src/perlmods/OpenSRF/DomainObject/oilsMultiSearch.pm +++ /dev/null @@ -1,186 +0,0 @@ -package OpenSRF::DomainObjectCollection::oilsMultiSearch; -use OpenSRF::DomainObjectCollection; -use OpenSRF::DomainObject::oilsPrimitive; -use OpenSRF::DomainObject::oilsSearch; -use OpenSRF::DOM::Element::searchCriteria; -use OpenSRF::DOM::Element::searchCriterium; -use base 'OpenSRF::DomainObjectCollection::oilsHash'; - -sub new { - my $class = shift; - my %args = @_; - - $class = ref($class) || $class; - - my $self = $class->SUPER::new; - - tie my %hash, 'OpenSRF::DomainObjectCollection::oilsHash', $self; - - $self->set( bind_count => 1 ); - $self->set( searches => new OpenSRF::DomainObjectCollection::oilsHash ); - $self->set( relators => new OpenSRF::DomainObjectCollection::oilsArray ); - $self->set( fields => new OpenSRF::DomainObjectCollection::oilsArray ); - $self->set( group_by => new OpenSRF::DomainObjectCollection::oilsArray ); - $self->set( order_by => new OpenSRF::DomainObjectCollection::oilsArray ); - - return $self; -} - -sub add_subsearch { - my $self = shift; - my $alias = shift; - my $search = shift; - my $relator = shift; - - $search = OpenSRF::DomainObject::oilsSearch->new($search) if (ref($search) eq 'ARRAY'); - - $self->searches->set( $alias => $search ); - - if ($self->searches->size > 1) { - throw OpenSRF::EX::InvalidArg ('You need to pass a relator searchCriterium') - unless (defined $relator); - } - - $relator = OpenSRF::DOM::Element::searchCriterium->new( @$relator ) - if (ref($relator) eq 'ARRAY'); - - $self->relators->push( $relator ) if (defined $relator); - - return $self; -} - -sub relators { - return $_[0]->_accessor('relators'); -} - -sub searches { - return $_[0]->_accessor('searches'); -} - -sub fields { - my $self = shift; - my @parts = @_; - if (@parts) { - $self->set( fields => OpenSRF::DomainObjectCollection::oilsArray->new(@_) ); - } - return $self->_accessor('fields')->list; -} - -sub format { - $_[0]->set( format => $_[1] ) if (defined $_[1]); - return $_[0]->_accessor('format'); -} - -sub limit { - $_[0]->set( limit => $_[1] ) if (defined $_[1]); - return $_[0]->_accessor('limit'); -} - -sub offset { - $_[0]->set( offset => $_[1] ) if (defined $_[1]); - return $_[0]->_accessor('offset'); -} - -sub chunk_key { - $_[0]->set( chunk_key => $_[1] ) if (defined $_[1]); - return $_[0]->_accessor('chunk_key'); -} - -sub order_by { - my $self = shift; - my @parts = @_; - if (@parts) { - $self->set( order_by => OpenSRF::DomainObjectCollection::oilsArray->new(@_) ); - } - return $self->_accessor('order_by')->list; -} - -sub group_by { - my $self = shift; - my @parts = @_; - if (@parts) { - $self->set( group_by => OpenSRF::DomainObjectCollection::oilsArray->new(@_) ); - } - return $self->_accessor('group_by')->list; -} - -sub SQL_select_list { - my $self = shift; - - if (my $sql = $self->_accessor('sql_select_list')) { - return $sql; - } - - $self->set( sql_select_list => 'SELECT '.join(', ', $self->fields) ) if defined($self->fields); - return $self->_accessor('sql_select_list'); -} - -sub SQL_group_by { - my $self = shift; - - if (my $sql = $self->_accessor('sql_group_by')) { - return $sql; - } - - $self->set( sql_group_by => 'GROUP BY '.join(', ', $self->group_by) ) if defined($self->group_by); - return $self->_accessor('sql_group_by'); -} - -sub SQL_order_by { - my $self = shift; - - if (my $sql = $self->_accessor('sql_order_by')) { - return $sql; - } - - $self->set( sql_order_by => 'ORDER BY '.join(', ', $self->order_by) ) if defined($self->order_by); - return $self->_accessor('sql_order_by'); -} - -sub SQL_offset { - my $self = shift; - - if (my $sql = $self->_accessor('sql_offset')) { - return $sql; - } - - $self->set( sql_offset => 'OFFSET '.$self->offset ) if defined($self->offset); - return $self->_accessor('sql_offset'); -} - -sub SQL_limit { - my $self = shift; - - if (my $sql = $self->_accessor('sql_limit')) { - return $sql; - } - - $self->set( sql_limit => 'LIMIT '.$self->limit ) if defined($self->limit); - return $self->_accessor('sql_limit'); -} - -sub toSQL { - my $self = shift; - - my $SQL = $self->SQL_select_list.' FROM '; - - my @subselects; - for my $search ( $self->searches->keys ) { - push @subselects, '('.$self->searches->_accessor($search)->toSQL.') '.$search; - } - $SQL .= join(', ', @subselects).' WHERE '; - - my @relators; - for my $rel ( $self->relators->list ) { - push @relators, $rel->value->toSQL( no_quote => 1 ); - } - $SQL .= join(' AND ', @relators).' '; - $SQL .= join ' ', ($self->SQL_group_by, $self->SQL_order_by, $self->SQL_limit, $self->SQL_offset); - - return $SQL; -} - -#this is just to allow DomainObject to "upcast" nicely -package OpenSRF::DomainObject::oilsMultiSearch; -use base OpenSRF::DomainObjectCollection::oilsMultiSearch; -1; diff --git a/src/perlmods/OpenSRF/DomainObject/oilsPrimitive.pm b/src/perlmods/OpenSRF/DomainObject/oilsPrimitive.pm deleted file mode 100644 index bf9507a..0000000 --- a/src/perlmods/OpenSRF/DomainObject/oilsPrimitive.pm +++ /dev/null @@ -1,623 +0,0 @@ -package OpenSRF::DomainObject::oilsScalar; -use base 'OpenSRF::DomainObject'; -use OpenSRF::DomainObject; - -=head1 NAME - -OpenSRF::DomainObject::oilsScalar - -=head1 SYNOPSIS - - use OpenSRF::DomainObject::oilsScalar; - - my $text = OpenSRF::DomainObject::oilsScalar->new( 'a string or number' ); - $text->value( 'replacement value' ); - print "$text"; # stringify - - ... - - $text->value( 1 ); - if( $text ) { # boolify - - ... - - $text->value( rand() * 1000 ); - print 10 + $text; # numify - - Or, using the TIE interface: - - my $scalar; - my $real_object = tie($scalar, 'OpenSRF::DomainObject::oilsScalar', "a string to store..."); - - $scalar = "a new string"; - print $scalar . "\n"; - print $real_object->toString . "\n"; - -=head1 METHODS - -=head2 OpenSRF::DomainObject::oilsScalar->value( [$new_value] ) - -=over 4 - -Sets or gets the value of the scalar. As above, this can be specified -as a build attribute as well as added to a prebuilt oilsScalar object. - -=back - -=cut - -use overload '""' => sub { return ''.$_[0]->value }; -use overload '0+' => sub { return int($_[0]->value) }; -use overload '<=>' => sub { return int($_[0]->value) <=> $_[1] }; -use overload 'bool' => sub { return 1 if ($_[0]->value); return 0 }; - -sub new { - my $class = shift; - $class = ref($class) || $class; - - my $value = shift; - - return $value - if ( defined $value and - ref $value and $value->can('base_type') and - UNIVERSAL::isa($value->class, __PACKAGE__) and - !scalar(@_) - ); - - my $self = $class->SUPER::new; - - if (ref($value) and ref($value) eq 'SCALAR') { - $self->value($$value); - tie( $$value, ref($self->upcast), $self); - } else { - $self->value($value) if (defined $value); - } - - return $self; -} - -sub TIESCALAR { - return CORE::shift()->new(@_); -} - -sub value { - my $self = shift; - my $value = shift; - - if ( defined $value ) { - $self->removeChild($_) for ($self->childNodes); - if (ref($value) && $value->isa('XML::LibXML::Node')) { - #throw OpenSRF::EX::NotADomainObject - # unless ($value->nodeName =~ /^oils:domainObject/o); - $self->appendChild($value); - } elsif (defined $value) { - $self->appendText( ''.$value ); - } - - return $value - } else { - $value = $self->firstChild; - if ($value) { - if ($value->nodeType == 3) { - return $value->textContent; - } else { - return $value; - } - } - return undef; - } -} - -sub FETCH { $_[0]->value } -sub STORE { $_[0]->value($_[1]) } - -package OpenSRF::DomainObject::oilsPair; -use base 'OpenSRF::DomainObject::oilsScalar'; - -=head1 NAME - -OpenSRF::DomainObject::oilsPair - -=head1 SYNOPSIS - - use OpenSRF::DomainObject::oilsPair; - - my $pair = OpenSRF::DomainObject::oilsPair->new( 'key_for_pair' => 'a string or number' ); - - $pair->key( 'replacement key' ); - $pair->value( 'replacement value' ); - - print "$pair"; # stringify 'value' - - ... - - $pair->value( 1 ); - - if( $pair ) { # boolify - - ... - - $pair->value( rand() * 1000 ); - - print 10 + $pair; # numify 'value' - -=head1 ABSTRACT - -This class impliments a "named pair" object. This is the basis for -hash-type domain objects. - -=head1 METHODS - -=head2 OpenSRF::DomainObject::oilsPair->value( [$new_value] ) - -=over 4 - -Sets or gets the value of the pair. As above, this can be specified -as a build attribute as well as added to a prebuilt oilsPair object. - -=back - -=head2 OpenSRF::DomainObject::oilsPair->key( [$new_key] ) - -=over 4 - -Sets or gets the key of the pair. As above, this can be specified -as a build attribute as well as added to a prebuilt oilsPair object. -This must be a perlish scalar; any string or number that is valid as the -attribute on an XML node will work. - -=back - -=cut - -use overload '""' => sub { return ''.$_[0]->value }; -use overload '0+' => sub { return int($_[0]->value) }; -use overload 'bool' => sub { return 1 if ($_[0]->value); return 0 }; - -sub new { - my $class = shift; - my ($key, $value) = @_; - - my $self = $class->SUPER::new($value); - $self->setAttribute( key => $key); - - return $self; -} - -sub key { - my $self = shift; - my $key = shift; - - $self->setAttribute( key => $key) if ($key); - return $self->getAttribute( 'key' ); -} - -package OpenSRF::DomainObjectCollection::oilsArray; -use base qw/OpenSRF::DomainObjectCollection Tie::Array/; -use OpenSRF::DomainObjectCollection; - -=head1 NAME - -OpenSRF::DomainObjectCollection::oilsArray - -=head1 SYNOPSIS - - use OpenSRF::DomainObject::oilsPrimitive; - - my $collection = OpenSRF::DomainObjectCollection::oilsArray->new( $domain_object, $another_domain_object, ...); - - $collection->push( 'appended value' ); - $collection->unshift( 'prepended vaule' ); - my $first = $collection->shift; - my $last = $collection->pop; - - ... - - my @values = $collection->list; - - Or, using the TIE interface: - - my @array; - my $real_object = tie(@array, 'OpenSRF::DomainObjectCollection::oilsArray', $domain, $objects, 'to', $store); - - or to tie an existing $collection object - - my @array; - tie(@array, 'OpenSRF::DomainObjectCollection::oilsArray', $collection); - - or even.... - - my @array; - tie(@array, ref($collection), $collection); - - - $array[2] = $DomainObject; # replaces 'to' (which is now an OpenSRF::DomainObject::oilsScalar) above - delete( $array[3] ); # removes '$store' above. - my $size = scalar( @array ); - - print $real_object->toString; - -=head1 ABSTRACT - -This package impliments array-like domain objects. A full tie interface -is also provided. If elements are passed in as strings (or numbers) they -are turned into oilsScalar objects. Any simple scalar or Domain Object may -be stored in the array. - -=head1 METHODS - -=head2 OpenSRF::DomainObjectCollection::oilsArray->list() - -=over 4 - -Returns the array of 'OpenSRF::DomainObject's that this collection contains. - -=back - -=cut - -sub tie_me { - my $class = shift; - $class = ref($class) || $class; - my $node = shift; - my @array; - tie @array, $class, $node; - return \@array; -} - -# an existing DomainObjectCollection::oilsArray can now be tied -sub TIEARRAY { - return CORE::shift()->new(@_); -} - -sub new { - my $class = CORE::shift; - $class = ref($class) || $class; - - my $first = CORE::shift; - - return $first - if ( defined $first and - ref $first and $first->can('base_type') and - UNIVERSAL::isa($first->class, __PACKAGE__) and - !scalar(@_) - ); - - my $self = $class->SUPER::new; - - my @args = @_; - if (ref($first) and ref($first) eq 'ARRAY') { - push @args, @$first; - tie( @$first, ref($self->upcast), $self); - } else { - unshift @args, $first if (defined $first); - } - - $self->STORE($self->FETCHSIZE, $_) for (@args); - return $self; -} - -sub STORE { - my $self = CORE::shift; - my ($index, $value) = @_; - - $value = OpenSRF::DomainObject::oilsScalar->new($value) - unless ( ref $value and $value->nodeName =~ /^oils:domainObject/o ); - - $self->_expand($index) unless ($self->EXISTS($index)); - - ($self->childNodes)[$index]->replaceNode( $value ); - - return $value->upcast; -} - -sub push { - my $self = CORE::shift; - my @values = @_; - $self->STORE($self->FETCHSIZE, $_) for (@values); -} - -sub pop { - my $self = CORE::shift; - my $node = $self->SUPER::pop; - if ($node) { - if ($node->base_type eq 'oilsScalar') { - return $node->value; - } - return $node->upcast; - } -} - -sub unshift { - my $self = CORE::shift; - my @values = @_; - $self->insertBefore($self->firstChild, $_ ) for (reverse @values); -} - -sub shift { - my $self = CORE::shift; - my $node = $self->SUPER::shift; - if ($node) { - if ($node->base_type eq 'oilsScalar') { - return $node->value; - } - return $node->upcast; - } -} - -sub FETCH { - my $self = CORE::shift; - my $index = CORE::shift; - my $node = ($self->childNodes)[$index]->upcast; - if ($node) { - if ($node->base_type eq 'oilsScalar') { - return $node->value; - } - return $node->upcast; - } -} - -sub size { - my $self = CORE::shift; - scalar($self->FETCHSIZE) -} - -sub FETCHSIZE { - my $self = CORE::shift; - my @a = $self->childNodes; - return scalar(@a); -} - -sub _expand { - my $self = CORE::shift; - my $count = CORE::shift; - my $size = $self->FETCHSIZE; - for ($size..$count) { - $self->SUPER::push( new OpenSRF::DomainObject::oilsScalar ); - } -} - -sub STORESIZE { - my $self = CORE::shift; - my $count = CORE::shift; - my $size = $self->FETCHSIZE - 1; - - if (defined $count and $count != $size) { - if ($size < $count) { - $self->_expand($count); - $size = $self->FETCHSIZE - 1; - } else { - while ($size > $count) { - $self->SUPER::pop; - $size = $self->FETCHSIZE - 1; - } - } - } - - return $size -} - -sub EXISTS { - my $self = CORE::shift; - my $index = CORE::shift; - return $self->FETCHSIZE > abs($index) ? 1 : 0; -} - -sub CLEAR { - my $self = CORE::shift; - $self->STORESIZE(0); - return $self; -} - -sub DELETE { - my $self = CORE::shift; - my $index = CORE::shift; - return $self->removeChild( ($self->childNodes)[$index] ); -} - -package OpenSRF::DomainObjectCollection::oilsHash; -use base qw/OpenSRF::DomainObjectCollection Tie::Hash/; - -=head1 NAME - -OpenSRF::DomainObjectCollection::oilsHash - -=head1 SYNOPSIS - - use OpenSRF::DomainObject::oilsPrimitive; - - my $collection = OpenSRF::DomainObjectCollection::oilsHash->new( key1 => $domain_object, key2 => $another_domain_object, ...); - - $collection->set( key =>'value' ); - my $value = $collection->find( $key ); - my $dead_value = $collection->remove( $key ); - my @keys = $collection->keys; - my @values = $collection->values; - - Or, using the TIE interface: - - my %hash; - my $real_object = tie(%hash, 'OpenSRF::DomainObjectCollection::oilsHash', domain => $objects, to => $store); - - or to tie an existing $collection object - - my %hash; - tie(%hash, 'OpenSRF::DomainObjectCollection::oilsHash', $collection); - - or even.... - - my %hash; - tie(%hash, ref($collection), $collection); - - or perhaps ... - - my $content = $session->recv->content; # eh? EH?!?! - tie(my %hash, ref($content), $content); - - $hash{domain} = $DomainObject; # replaces value for key 'domain' above - delete( $hash{to} ); # removes 'to => $store' above. - for my $key ( keys %hash ) { - ... do stuff ... - } - - print $real_object->toString; - -=head1 ABSTRACT - -This package impliments hash-like domain objects. A full tie interface -is also provided. If elements are passed in as strings (or numbers) they -are turned into oilsScalar objects. Any simple scalar or Domain Object may -be stored in the hash. - -=back - -=cut - -sub tie_me { - my $class = shift; - $class = ref($class) || $class; - my $node = shift; - my %hash; - tie %hash, $class, $node; - return %hash; -} - - -sub keys { - my $self = shift; - return map { $_->key } $self->childNodes; -} - -sub values { - my $self = shift; - return map { $_->value } $self->childNodes; -} - -# an existing DomainObjectCollection::oilsHash can now be tied -sub TIEHASH { - return shift()->new(@_); -} - -sub new { - my $class = shift; - $class = ref($class) || $class; - my $first = shift; - - return $first - if ( defined $first and - ref $first and $first->can('base_type') and - UNIVERSAL::isa($first->class, __PACKAGE__) and - !scalar(@_) - ); - - my $self = $class->SUPER::new; - - my @args = @_; - if (ref($first) and ref($first) eq 'HASH') { - push @args, %$first; - tie( %$first, ref($self->upcast), $self); - } else { - unshift @args, $first if (defined $first); - } - - my %arg_hash = @args; - while ( my ($key, $value) = each(%arg_hash) ) { - $self->STORE($key => $value); - } - return $self; -} - -sub STORE { - shift()->set(@_); -} - -sub set { - my $self = shift; - my ($key, $value) = @_; - - my $node = $self->find_node($key); - - return $node->value( $value ) if (defined $node); - return $self->appendChild( OpenSRF::DomainObject::oilsPair->new($key => $value) ); -} - -sub _accessor { - my $self = shift; - my $key = shift; - my $node = find_node($self, $key); - return $node->value if ($node); -} - -sub find_node { - my $self = shift; - my $key = shift; - return ($self->findnodes("oils:domainObject[\@name=\"oilsPair\" and \@key=\"$key\"]", $self))[0]; -} - -sub find { - my $self = shift; - my $key = shift; - my $node = $self->find_node($key); - my $value = $node->value if (defined $node); - return $value; -} - -sub size { - my $self = CORE::shift; - my @a = $self->childNodes; - return scalar(@a); -} - -sub FETCH { - my $self = shift; - my $key = shift; - return $self->find($key); -} - -sub EXISTS { - my $self = shift; - my $key = shift; - return $self->find_node($key); -} - -sub CLEAR { - my $self = shift; - $self->removeChild for ($self->childNodes); - return $self; -} - -sub DELETE { - shift()->remove(@_); -} - -sub remove { - my $self = shift; - my $key = shift; - return $self->removeChild( $self->find_node($key) ); -} - -sub FIRSTKEY { - my $self = shift; - return $self->firstChild->key; -} - -sub NEXTKEY { - my $self = shift; - my $key = shift; - my ($prev_node) = $self->find_node($key); - my $last_node = $self->lastChild; - - if ($last_node and $last_node->key eq $prev_node->key) { - return undef; - } else { - return $prev_node->nextSibling->key; - } -} - -package OpenSRF::DomainObject::oilsHash; -use base qw/OpenSRF::DomainObjectCollection::oilsHash/; - -package OpenSRF::DomainObject::oilsArray; -use base qw/OpenSRF::DomainObjectCollection::oilsArray/; - -1; diff --git a/src/perlmods/OpenSRF/DomainObject/oilsSearch.pm b/src/perlmods/OpenSRF/DomainObject/oilsSearch.pm deleted file mode 100644 index b2e23e4..0000000 --- a/src/perlmods/OpenSRF/DomainObject/oilsSearch.pm +++ /dev/null @@ -1,106 +0,0 @@ -package OpenSRF::DomainObject::oilsSearch; -use OpenSRF::DomainObject; -use OpenSRF::DomainObject::oilsPrimitive; -use OpenSRF::DOM::Element::searchCriteria; -use base 'OpenSRF::DomainObject'; - -sub new { - my $class = shift; - $class = ref($class) || $class; - - unshift @_, 'table' if (@_ == 1); - my %args = @_; - - my $self = $class->SUPER::new; - - for my $part ( keys %args ) { - if ($part ne 'criteria') { - $self->$part( $args{$part} ); - next; - } - $self->criteria( OpenSRF::DOM::Element::searchCriteria->new( @{$args{$part}} ) ); - } - return $self; -} - -sub format { - my $self = shift; - return $self->_attr_get_set( format => shift ); -} - -sub table { - my $self = shift; - return $self->_attr_get_set( table => shift ); -} - -sub fields { - my $self = shift; - my $new_fields_ref = shift; - - my ($old_fields) = $self->getChildrenByTagName("oils:domainObjectCollection"); - - if ($new_fields_ref) { - my $do = OpenSRF::DomainObjectCollection::oilsArray->new( @$new_fields_ref ); - if (defined $old_fields) { - $old_fields->replaceNode($do); - } else { - $self->appendChild($do); - return $do->list; - } - } - - return $old_fields->list if ($old_fields); -} - -sub limit { - my $self = shift; - return $self->_attr_get_set( limit => shift ); -} - -sub offset { - my $self = shift; - return $self->_attr_get_set( offset => shift ); -} - -sub group_by { - my $self = shift; - return $self->_attr_get_set( group_by => shift ); -} - -sub criteria { - my $self = shift; - my $new_crit = shift; - - if (@_) { - unshift @_, $new_crit; - $new_crit = OpenSRF::DOM::Element::searchCriteria->new(@_); - } - - my ($old_crit) = $self->getChildrenByTagName("oils:searchCriteria"); - - if (defined $new_crit) { - if (defined $old_crit) { - $old_crit->replaceNode($new_crit); - } else { - $self->appendChild($new_crit); - return $new_crit; - } - } - - return $old_crit; -} - -sub toSQL { - my $self = shift; - - my $SQL = 'SELECT ' . join(',', $self->fields); - $SQL .= ' FROM ' . $self->table; - $SQL .= ' WHERE ' . $self->criteria->toSQL if ($self->criteria); - $SQL .= ' GROUP BY ' . $self->group_by if ($self->group_by); - $SQL .= ' LIMIT ' . $self->limit if ($self->limit); - $SQL .= ' OFFSET ' . $self->offset if ($self->offset); - - return $SQL; -} - -1; diff --git a/src/perlmods/OpenSRF/DomainObjectCollection.pm b/src/perlmods/OpenSRF/DomainObjectCollection.pm deleted file mode 100644 index 7049af7..0000000 --- a/src/perlmods/OpenSRF/DomainObjectCollection.pm +++ /dev/null @@ -1,35 +0,0 @@ -package OpenSRF::DomainObjectCollection; -use base 'OpenSRF::DOM::Element::domainObjectCollection'; -use OpenSRF::DOM; -use OpenSRF::Utils::Logger qw(:level); -my $logger = "OpenSRF::Utils::Logger"; - -=head1 NAME - -OpenSRF::DomainObjectCollection - -=head1 SYNOPSIS - -OpenSRF::DomainObjectCollection is an abstract base class. It -should not be used directly. See C -for details. - -=cut - -sub new { - my $class = shift; - $class = ref($class) || $class; - - my @args = shift; - - (my $type = $class) =~ s/^.+://o; - - my $doc = OpenSRF::DOM->createDocument; - my $dO = OpenSRF::DOM::Element::domainObjectCollection->new( $type, @args ); - - $doc->documentElement->appendChild($dO); - - return $dO; -} - -1; diff --git a/src/perlmods/OpenSRF/System.pm b/src/perlmods/OpenSRF/System.pm index 1f0f6dc..c0bee05 100644 --- a/src/perlmods/OpenSRF/System.pm +++ b/src/perlmods/OpenSRF/System.pm @@ -8,7 +8,7 @@ use OpenSRF::Transport; use OpenSRF::UnixServer; use OpenSRF::Utils; use OpenSRF::Utils::LogServer; -use OpenSRF::DOM; +#use OpenSRF::DOM; use OpenSRF::EX qw/:try/; use POSIX ":sys_wait_h"; use OpenSRF::Utils::Config; -- 2.43.2