src/perlmods/OpenSRF/DomainObject/oilsPrimitive.pm

   1 package OpenSRF::DomainObject::oilsScalar;
   2 use base 'OpenSRF::DomainObject';
   3 use OpenSRF::DomainObject;
   4
   5 =head1 NAME
   6
   7 OpenSRF::DomainObject::oilsScalar
   8
   9 =head1 SYNOPSIS
  10
  11   use OpenSRF::DomainObject::oilsScalar;
  12
  13   my $text = OpenSRF::DomainObject::oilsScalar->new( 'a string or number' );
  14   $text->value( 'replacement value' );
  15   print "$text"; # stringify
  16
  17    ...
  18
  19   $text->value( 1 );
  20   if( $text ) { # boolify
  21
  22    ...
  23
  24   $text->value( rand() * 1000 );
  25   print 10 + $text; # numify
  26
  27     Or, using the TIE interface:
  28
  29   my $scalar;
  30   my $real_object = tie($scalar, 'OpenSRF::DomainObject::oilsScalar', "a string to store...");
  31
  32   $scalar = "a new string";
  33   print $scalar . "\n";
  34   print $real_object->toString . "\n";
  35
  36 =head1 METHODS
  37
  38 =head2 OpenSRF::DomainObject::oilsScalar->value( [$new_value] )
  39
  40 =over 4
  41
  42 Sets or gets the value of the scalar.  As above, this can be specified
  43 as a build attribute as well as added to a prebuilt oilsScalar object.
  44
  45 =back
  46
  47 =cut
  48
  49 use overload '""'   => sub { return ''.$_[0]->value };
  50 use overload '0+'   => sub { return int($_[0]->value) };
  51 use overload '<=>'   => sub { return int($_[0]->value) <=> $_[1] };
  52 use overload 'bool' => sub { return 1 if ($_[0]->value); return 0 };
  53
  54 sub new {
  55         my $class = shift;
  56         $class = ref($class) || $class;
  57
  58         my $value = shift;
  59
  60         return $value
  61                 if (    defined $value and
  62                         ref $value and $value->can('base_type') and
  63                         UNIVERSAL::isa($value->class, __PACKAGE__) and
  64                         !scalar(@_)
  65                 );
  66
  67         my $self = $class->SUPER::new;
  68
  69         if (ref($value) and ref($value) eq 'SCALAR') {
  70                 $self->value($$value);
  71                 tie( $$value, ref($self->upcast), $self);
  72         } else {
  73                 $self->value($value) if (defined $value);
  74         }
  75
  76         return $self;
  77 }
  78
  79 sub TIESCALAR {
  80         return CORE::shift()->new(@_);
  81 }
  82
  83 sub value {
  84         my $self = shift;
  85         my $value = shift;
  86
  87         if ( defined $value ) {
  88                 $self->removeChild($_) for ($self->childNodes);
  89                 if (ref($value) && $value->isa('XML::LibXML::Node')) {
  90                         #throw OpenSRF::EX::NotADomainObject
  91                         #       unless ($value->nodeName =~ /^oils:domainObject/o);
  92                         $self->appendChild($value);
  93                 } elsif (defined $value) {
  94                         $self->appendText( ''.$value );
  95                 }
  96
  97                 return $value
  98         } else {
  99                 $value = $self->firstChild;
 100                 if ($value) {
 101                         if ($value->nodeType == 3) {
 102                                 return $value->textContent;
 103                         } else {
 104                                 return $value;
 105                         }
 106                 }
 107                 return undef;
 108         }
 109 }
 110
 111 sub FETCH { $_[0]->value }
 112 sub STORE { $_[0]->value($_[1]) }
 113
 114 package OpenSRF::DomainObject::oilsPair;
 115 use base 'OpenSRF::DomainObject::oilsScalar';
 116
 117 =head1 NAME
 118
 119 OpenSRF::DomainObject::oilsPair
 120
 121 =head1 SYNOPSIS
 122
 123   use OpenSRF::DomainObject::oilsPair;
 124
 125   my $pair = OpenSRF::DomainObject::oilsPair->new( 'key_for_pair' => 'a string or number' );
 126
 127   $pair->key( 'replacement key' );
 128   $pair->value( 'replacement value' );
 129
 130   print "$pair"; # stringify 'value'
 131
 132    ...
 133
 134   $pair->value( 1 );
 135
 136   if( $pair ) { # boolify
 137
 138    ...
 139
 140   $pair->value( rand() * 1000 );
 141
 142   print 10 + $pair; # numify 'value'
 143
 144 =head1 ABSTRACT
 145
 146 This class impliments a "named pair" object.  This is the basis for
 147 hash-type domain objects.
 148
 149 =head1 METHODS
 150
 151 =head2 OpenSRF::DomainObject::oilsPair->value( [$new_value] )
 152
 153 =over 4
 154
 155 Sets or gets the value of the pair.  As above, this can be specified
 156 as a build attribute as well as added to a prebuilt oilsPair object.
 157
 158 =back
 159
 160 =head2 OpenSRF::DomainObject::oilsPair->key( [$new_key] )
 161
 162 =over 4
 163
 164 Sets or gets the key of the pair.  As above, this can be specified
 165 as a build attribute as well as added to a prebuilt oilsPair object.
 166 This must be a perlish scalar; any string or number that is valid as the
 167 attribute on an XML node will work.
 168
 169 =back
 170
 171 =cut
 172
 173 use overload '""'   => sub { return ''.$_[0]->value };
 174 use overload '0+'   => sub { return int($_[0]->value) };
 175 use overload 'bool' => sub { return 1 if ($_[0]->value); return 0 };
 176
 177 sub new {
 178         my $class = shift;
 179         my ($key, $value) = @_;
 180
 181         my $self = $class->SUPER::new($value);
 182         $self->setAttribute( key => $key);
 183
 184         return $self;
 185 }
 186
 187 sub key {
 188         my $self = shift;
 189         my $key = shift;
 190
 191         $self->setAttribute( key => $key) if ($key);
 192         return $self->getAttribute( 'key' );
 193 }
 194
 195 package OpenSRF::DomainObjectCollection::oilsArray;
 196 use base qw/OpenSRF::DomainObjectCollection Tie::Array/;
 197 use OpenSRF::DomainObjectCollection;
 198
 199 =head1 NAME
 200
 201 OpenSRF::DomainObjectCollection::oilsArray
 202
 203 =head1 SYNOPSIS
 204
 205   use OpenSRF::DomainObject::oilsPrimitive;
 206
 207   my $collection = OpenSRF::DomainObjectCollection::oilsArray->new( $domain_object, $another_domain_object, ...);
 208
 209   $collection->push( 'appended value' );
 210   $collection->unshift( 'prepended vaule' );
 211   my $first = $collection->shift;
 212   my $last = $collection->pop;
 213
 214    ...
 215
 216   my @values = $collection->list;
 217
 218     Or, using the TIE interface:
 219
 220   my @array;
 221   my $real_object = tie(@array, 'OpenSRF::DomainObjectCollection::oilsArray', $domain, $objects, 'to', $store);
 222
 223       or to tie an existing $collection object
 224
 225   my @array;
 226   tie(@array, 'OpenSRF::DomainObjectCollection::oilsArray', $collection);
 227
 228       or even....
 229
 230   my @array;
 231   tie(@array, ref($collection), $collection);
 232
 233
 234   $array[2] = $DomainObject; # replaces 'to' (which is now an OpenSRF::DomainObject::oilsScalar) above
 235   delete( $array[3] ); # removes '$store' above.
 236   my $size = scalar( @array );
 237
 238   print $real_object->toString;
 239
 240 =head1 ABSTRACT
 241
 242 This package impliments array-like domain objects.  A full tie interface
 243 is also provided.  If elements are passed in as strings (or numbers) they
 244 are turned into oilsScalar objects.  Any simple scalar or Domain Object may
 245 be stored in the array.
 246
 247 =head1 METHODS
 248
 249 =head2 OpenSRF::DomainObjectCollection::oilsArray->list()
 250
 251 =over 4
 252
 253 Returns the array of 'OpenSRF::DomainObject's that this collection contains.
 254
 255 =back
 256
 257 =cut
 258
 259 sub tie_me {
 260         my $class = shift;
 261         $class = ref($class) || $class;
 262         my $node = shift;
 263         my @array;
 264         tie @array, $class, $node;
 265         return \@array;
 266 }
 267
 268 # an existing DomainObjectCollection::oilsArray can now be tied
 269 sub TIEARRAY {
 270         return CORE::shift()->new(@_);
 271 }
 272
 273 sub new {
 274         my $class = CORE::shift;
 275         $class = ref($class) || $class;
 276
 277         my $first = CORE::shift;
 278
 279         return $first
 280                 if (    defined $first and
 281                         ref $first and $first->can('base_type') and
 282                         UNIVERSAL::isa($first->class, __PACKAGE__) and
 283                         !scalar(@_)
 284                 );
 285
 286         my $self = $class->SUPER::new;
 287
 288         my @args = @_;
 289         if (ref($first) and ref($first) eq 'ARRAY') {
 290                 push @args, @$first;
 291                 tie( @$first, ref($self->upcast), $self);
 292         } else {
 293                 unshift @args, $first if (defined $first);
 294         }
 295
 296         $self->STORE($self->FETCHSIZE, $_) for (@args);
 297         return $self;
 298 }
 299
 300 sub STORE {
 301         my $self = CORE::shift;
 302         my ($index, $value) = @_;
 303
 304         $value = OpenSRF::DomainObject::oilsScalar->new($value)
 305                 unless ( ref $value and $value->nodeName =~ /^oils:domainObject/o );
 306
 307         $self->_expand($index) unless ($self->EXISTS($index));
 308
 309         ($self->childNodes)[$index]->replaceNode( $value );
 310
 311         return $value->upcast;
 312 }
 313
 314 sub push {
 315         my $self = CORE::shift;
 316         my @values = @_;
 317         $self->STORE($self->FETCHSIZE, $_) for (@values);
 318 }
 319
 320 sub pop {
 321         my $self = CORE::shift;
 322         my $node = $self->SUPER::pop;
 323         if ($node) {
 324                 if ($node->base_type eq 'oilsScalar') {
 325                         return $node->value;
 326                 }
 327                 return $node->upcast;
 328         }
 329 }
 330
 331 sub unshift {
 332         my $self = CORE::shift;
 333         my @values = @_;
 334         $self->insertBefore($self->firstChild, $_ ) for (reverse @values);
 335 }
 336
 337 sub shift {
 338         my $self = CORE::shift;
 339         my $node = $self->SUPER::shift;
 340         if ($node) {
 341                 if ($node->base_type eq 'oilsScalar') {
 342                         return $node->value;
 343                 }
 344                 return $node->upcast;
 345         }
 346 }
 347
 348 sub FETCH {
 349         my $self = CORE::shift;
 350         my $index = CORE::shift;
 351         my $node =  ($self->childNodes)[$index]->upcast;
 352         if ($node) {
 353                 if ($node->base_type eq 'oilsScalar') {
 354                         return $node->value;
 355                 }
 356                 return $node->upcast;
 357         }
 358 }
 359
 360 sub size {
 361         my $self = CORE::shift;
 362         scalar($self->FETCHSIZE)
 363 }
 364
 365 sub FETCHSIZE {
 366         my $self = CORE::shift;
 367         my @a = $self->childNodes;
 368         return scalar(@a);
 369 }
 370
 371 sub _expand {
 372         my $self = CORE::shift;
 373         my $count = CORE::shift;
 374         my $size = $self->FETCHSIZE;
 375         for ($size..$count) {
 376                 $self->SUPER::push( new OpenSRF::DomainObject::oilsScalar );
 377         }
 378 }
 379
 380 sub STORESIZE {
 381         my $self = CORE::shift;
 382         my $count = CORE::shift;
 383         my $size = $self->FETCHSIZE - 1;
 384
 385         if (defined $count and $count != $size) {
 386                 if ($size < $count) {
 387                         $self->_expand($count);
 388                         $size = $self->FETCHSIZE - 1;
 389                 } else {
 390                         while ($size > $count) {
 391                                 $self->SUPER::pop;
 392                                 $size = $self->FETCHSIZE - 1;
 393                         }
 394                 }
 395         }
 396
 397         return $size
 398 }
 399
 400 sub EXISTS {
 401         my $self = CORE::shift;
 402         my $index = CORE::shift;
 403         return $self->FETCHSIZE > abs($index) ? 1 : 0;
 404 }
 405
 406 sub CLEAR {
 407         my $self = CORE::shift;
 408         $self->STORESIZE(0);
 409         return $self;
 410 }
 411
 412 sub DELETE {
 413         my $self = CORE::shift;
 414         my $index = CORE::shift;
 415         return $self->removeChild( ($self->childNodes)[$index] );
 416 }
 417
 418 package OpenSRF::DomainObjectCollection::oilsHash;
 419 use base qw/OpenSRF::DomainObjectCollection Tie::Hash/;
 420
 421 =head1 NAME
 422
 423 OpenSRF::DomainObjectCollection::oilsHash
 424
 425 =head1 SYNOPSIS
 426
 427   use OpenSRF::DomainObject::oilsPrimitive;
 428
 429   my $collection = OpenSRF::DomainObjectCollection::oilsHash->new( key1 => $domain_object, key2 => $another_domain_object, ...);
 430
 431   $collection->set( key =>'value' );
 432   my $value = $collection->find( $key );
 433   my $dead_value = $collection->remove( $key );
 434   my @keys = $collection->keys;
 435   my @values = $collection->values;
 436
 437     Or, using the TIE interface:
 438
 439   my %hash;
 440   my $real_object = tie(%hash, 'OpenSRF::DomainObjectCollection::oilsHash', domain => $objects, to => $store);
 441
 442       or to tie an existing $collection object
 443
 444   my %hash;
 445   tie(%hash, 'OpenSRF::DomainObjectCollection::oilsHash', $collection);
 446
 447       or even....
 448
 449   my %hash;
 450   tie(%hash, ref($collection), $collection);
 451
 452       or perhaps ...
 453
 454   my $content = $session->recv->content; # eh? EH?!?!
 455   tie(my %hash, ref($content), $content);
 456
 457   $hash{domain} = $DomainObject; # replaces value for key 'domain' above
 458   delete( $hash{to} ); # removes 'to => $store' above.
 459   for my $key ( keys %hash ) {
 460     ... do stuff ...
 461   }
 462
 463   print $real_object->toString;
 464
 465 =head1 ABSTRACT
 466
 467 This package impliments hash-like domain objects.  A full tie interface
 468 is also provided.  If elements are passed in as strings (or numbers) they
 469 are turned into oilsScalar objects.  Any simple scalar or Domain Object may
 470 be stored in the hash.
 471
 472 =back
 473
 474 =cut
 475
 476 sub tie_me {
 477         my $class = shift;
 478         $class = ref($class) || $class;
 479         my $node = shift;
 480         my %hash;
 481         tie %hash, $class, $node;
 482         return %hash;
 483 }
 484
 485
 486 sub keys {
 487         my $self = shift;
 488         return map { $_->key } $self->childNodes;
 489 }
 490
 491 sub values {
 492         my $self = shift;
 493         return map { $_->value } $self->childNodes;
 494 }
 495
 496 # an existing DomainObjectCollection::oilsHash can now be tied
 497 sub TIEHASH {
 498         return shift()->new(@_);
 499 }
 500
 501 sub new {
 502         my $class = shift;
 503         $class = ref($class) || $class;
 504         my $first = shift;
 505
 506         return $first
 507                 if (    defined $first and
 508                         ref $first and $first->can('base_type') and
 509                         UNIVERSAL::isa($first->class, __PACKAGE__) and
 510                         !scalar(@_)
 511                 );
 512
 513         my $self = $class->SUPER::new;
 514
 515         my @args = @_;
 516         if (ref($first) and ref($first) eq 'HASH') {
 517                 push @args, %$first;
 518                 tie( %$first, ref($self->upcast), $self);
 519         } else {
 520                 unshift @args, $first if (defined $first);
 521         }
 522
 523         my %arg_hash = @args;
 524         while ( my ($key, $value) = each(%arg_hash) ) {
 525                 $self->STORE($key => $value);
 526         }
 527         return $self;
 528 }
 529
 530 sub STORE {
 531         shift()->set(@_);
 532 }
 533
 534 sub set {
 535         my $self = shift;
 536         my ($key, $value) = @_;
 537
 538         my $node = $self->find_node($key);
 539
 540         return $node->value( $value ) if (defined $node);
 541         return $self->appendChild( OpenSRF::DomainObject::oilsPair->new($key => $value) );
 542 }
 543
 544 sub _accessor {
 545         my $self = shift;
 546         my $key = shift;
 547         my $node = find_node($self, $key);
 548         return $node->value if ($node);
 549 }
 550
 551 sub find_node {
 552         my $self = shift;
 553         my $key = shift;
 554         return ($self->findnodes("oils:domainObject[\@name=\"oilsPair\" and \@key=\"$key\"]", $self))[0];
 555 }
 556
 557 sub find {
 558         my $self = shift;
 559         my $key = shift;
 560         my $node = $self->find_node($key);
 561         my $value = $node->value if (defined $node);
 562         return $value;
 563 }
 564
 565 sub size {
 566         my $self = CORE::shift;
 567         my @a = $self->childNodes;
 568         return scalar(@a);
 569 }
 570
 571 sub FETCH {
 572         my $self = shift;
 573         my $key = shift;
 574         return $self->find($key);
 575 }
 576
 577 sub EXISTS {
 578         my $self = shift;
 579         my $key = shift;
 580         return $self->find_node($key);
 581 }
 582
 583 sub CLEAR {
 584         my $self = shift;
 585         $self->removeChild for ($self->childNodes);
 586         return $self;
 587 }
 588
 589 sub DELETE {
 590         shift()->remove(@_);
 591 }
 592
 593 sub remove {
 594         my $self = shift;
 595         my $key = shift;
 596         return $self->removeChild( $self->find_node($key) );
 597 }
 598
 599 sub FIRSTKEY {
 600         my $self = shift;
 601         return $self->firstChild->key;
 602 }
 603
 604 sub NEXTKEY {
 605         my $self = shift;
 606         my $key = shift;
 607         my ($prev_node) = $self->find_node($key);
 608         my $last_node = $self->lastChild;
 609
 610         if ($last_node and $last_node->key eq $prev_node->key) {
 611                 return undef;
 612         } else {
 613                 return $prev_node->nextSibling->key;
 614         }
 615 }
 616
 617 package OpenSRF::DomainObject::oilsHash;
 618 use base qw/OpenSRF::DomainObjectCollection::oilsHash/;
 619
 620 package OpenSRF::DomainObject::oilsArray;
 621 use base qw/OpenSRF::DomainObjectCollection::oilsArray/;
 622
 623 1;