Initial revision
[OpenSRF.git] / src / perlmods / OpenSRF / DomainObject / oilsPrimitive.pm
1 package OpenILS::DomainObject::oilsScalar;
2 use base 'OpenILS::DomainObject';
3 use OpenILS::DomainObject;
4
5 =head1 NAME
6
7 OpenILS::DomainObject::oilsScalar
8
9 =head1 SYNOPSIS
10
11   use OpenILS::DomainObject::oilsScalar;
12
13   my $text = OpenILS::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, 'OpenILS::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 OpenILS::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 OpenILS::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 OpenILS::DomainObject::oilsPair;
115 use base 'OpenILS::DomainObject::oilsScalar';
116
117 =head1 NAME
118
119 OpenILS::DomainObject::oilsPair
120
121 =head1 SYNOPSIS
122
123   use OpenILS::DomainObject::oilsPair;
124
125   my $pair = OpenILS::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 OpenILS::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 OpenILS::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 OpenILS::DomainObjectCollection::oilsArray;
196 use base qw/OpenILS::DomainObjectCollection Tie::Array/;
197 use OpenILS::DomainObjectCollection;
198
199 =head1 NAME
200
201 OpenILS::DomainObjectCollection::oilsArray
202
203 =head1 SYNOPSIS
204
205   use OpenILS::DomainObject::oilsPrimitive;
206
207   my $collection = OpenILS::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, 'OpenILS::DomainObjectCollection::oilsArray', $domain, $objects, 'to', $store);
222
223       or to tie an existing $collection object
224
225   my @array;
226   tie(@array, 'OpenILS::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 OpenILS::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 OpenILS::DomainObjectCollection::oilsArray->list()
250
251 =over 4
252
253 Returns the array of 'OpenILS::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 = OpenILS::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 OpenILS::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 OpenILS::DomainObjectCollection::oilsHash;
419 use base qw/OpenILS::DomainObjectCollection Tie::Hash/;
420
421 =head1 NAME
422
423 OpenILS::DomainObjectCollection::oilsHash
424
425 =head1 SYNOPSIS
426
427   use OpenILS::DomainObject::oilsPrimitive;
428
429   my $collection = OpenILS::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, 'OpenILS::DomainObjectCollection::oilsHash', domain => $objects, to => $store);
441
442       or to tie an existing $collection object
443
444   my %hash;
445   tie(%hash, 'OpenILS::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( OpenILS::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 OpenILS::DomainObject::oilsHash;
618 use base qw/OpenILS::DomainObjectCollection::oilsHash/;
619
620 package OpenILS::DomainObject::oilsArray;
621 use base qw/OpenILS::DomainObjectCollection::oilsArray/;
622
623 1;