[Opensrf-commits] r992 - in trunk/src/perlmods/OpenSRF: .
DomainObject
svn at svn.open-ils.org
svn at svn.open-ils.org
Wed Jul 4 16:12:01 EDT 2007
Author: miker
Date: 2007-07-04 16:08:15 -0400 (Wed, 04 Jul 2007)
New Revision: 992
Removed:
trunk/src/perlmods/OpenSRF/DOM.pm
trunk/src/perlmods/OpenSRF/DOM/
trunk/src/perlmods/OpenSRF/DomainObject.pm
trunk/src/perlmods/OpenSRF/DomainObject/oilsMultiSearch.pm
trunk/src/perlmods/OpenSRF/DomainObject/oilsPrimitive.pm
trunk/src/perlmods/OpenSRF/DomainObject/oilsSearch.pm
trunk/src/perlmods/OpenSRF/DomainObjectCollection.pm
Modified:
trunk/src/perlmods/OpenSRF/AppSession.pm
trunk/src/perlmods/OpenSRF/System.pm
Log:
removing vestigial DOM code from back when opensrf talked XML
Modified: trunk/src/perlmods/OpenSRF/AppSession.pm
===================================================================
--- trunk/src/perlmods/OpenSRF/AppSession.pm 2007-07-02 22:07:02 UTC (rev 991)
+++ trunk/src/perlmods/OpenSRF/AppSession.pm 2007-07-04 20:08:15 UTC (rev 992)
@@ -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;
Deleted: trunk/src/perlmods/OpenSRF/DOM.pm
===================================================================
--- trunk/src/perlmods/OpenSRF/DOM.pm 2007-07-02 22:07:02 UTC (rev 991)
+++ trunk/src/perlmods/OpenSRF/DOM.pm 2007-07-04 20:08:15 UTC (rev 992)
@@ -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;
Deleted: trunk/src/perlmods/OpenSRF/DomainObject/oilsMultiSearch.pm
===================================================================
--- trunk/src/perlmods/OpenSRF/DomainObject/oilsMultiSearch.pm 2007-07-02 22:07:02 UTC (rev 991)
+++ trunk/src/perlmods/OpenSRF/DomainObject/oilsMultiSearch.pm 2007-07-04 20:08:15 UTC (rev 992)
@@ -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;
Deleted: trunk/src/perlmods/OpenSRF/DomainObject/oilsPrimitive.pm
===================================================================
--- trunk/src/perlmods/OpenSRF/DomainObject/oilsPrimitive.pm 2007-07-02 22:07:02 UTC (rev 991)
+++ trunk/src/perlmods/OpenSRF/DomainObject/oilsPrimitive.pm 2007-07-04 20:08:15 UTC (rev 992)
@@ -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;
Deleted: trunk/src/perlmods/OpenSRF/DomainObject/oilsSearch.pm
===================================================================
--- trunk/src/perlmods/OpenSRF/DomainObject/oilsSearch.pm 2007-07-02 22:07:02 UTC (rev 991)
+++ trunk/src/perlmods/OpenSRF/DomainObject/oilsSearch.pm 2007-07-04 20:08:15 UTC (rev 992)
@@ -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;
Deleted: trunk/src/perlmods/OpenSRF/DomainObject.pm
===================================================================
--- trunk/src/perlmods/OpenSRF/DomainObject.pm 2007-07-02 22:07:02 UTC (rev 991)
+++ trunk/src/perlmods/OpenSRF/DomainObject.pm 2007-07-04 20:08:15 UTC (rev 992)
@@ -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<OpenSRF::DomainObject::*>
-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;
Deleted: trunk/src/perlmods/OpenSRF/DomainObjectCollection.pm
===================================================================
--- trunk/src/perlmods/OpenSRF/DomainObjectCollection.pm 2007-07-02 22:07:02 UTC (rev 991)
+++ trunk/src/perlmods/OpenSRF/DomainObjectCollection.pm 2007-07-04 20:08:15 UTC (rev 992)
@@ -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<OpenSRF::DomainObjectCollection::*>
-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;
Modified: trunk/src/perlmods/OpenSRF/System.pm
===================================================================
--- trunk/src/perlmods/OpenSRF/System.pm 2007-07-02 22:07:02 UTC (rev 991)
+++ trunk/src/perlmods/OpenSRF/System.pm 2007-07-04 20:08:15 UTC (rev 992)
@@ -8,7 +8,7 @@
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;
More information about the opensrf-commits
mailing list