1# ----------------- Stone --------------- 2# This is basic unit of the boulder stream, and defines a 3# multi-valued hash array type of structure. 4 5package Stone; 6use strict; 7use vars qw($VERSION $AUTOLOAD $Fetchlast); 8use overload '""' => 'toString', 9 'fallback' =>' TRUE'; 10 11$VERSION = '1.30'; 12require 5.004; 13 14=head1 NAME 15 16Stone - In-memory storage for hierarchical tag/value data structures 17 18=head1 SYNOPSIS 19 20 use Stone; 21 my $stone = Stone->new( Jim => { First_name => 'James', 22 Last_name => 'Hill', 23 Age => 34, 24 Address => { 25 Street => ['The Manse', 26 '19 Chestnut Ln'], 27 City => 'Garden City', 28 State => 'NY', 29 Zip => 11291 } 30 }, 31 Sally => { First_name => 'Sarah', 32 Last_name => 'James', 33 Age => 30, 34 Address => { 35 Street => 'Hickory Street', 36 City => 'Katonah', 37 State => 'NY', 38 Zip => 10578 } 39 } 40 ); 41 42 @tags = $stone->tags; # yields ('James','Sally'); 43 $address = $stone->Jim->Address; # gets the address subtree 44 @street = $address->Street; # yeilds ('The Manse','19 Chestnut Ln') 45 46 $address = $stone->get('Jim')->get('Address'); # same as $stone->Jim->Address 47 $address = $stone->get('Jim.Address'); # another way to express same thing 48 49 # first Street tag in Jim's address 50 $address = $stone->get('Jim.Address.Street[0]'); 51 # second Street tag in Jim's address 52 $address = $stone->get('Jim.Address.Street[1]'); 53 # last Street tag in Jim's address 54 $address = $stone->get('Jim.Address.Street[#]'); 55 56 # insert a tag/value pair 57 $stone->insert(Martha => { First_name => 'Martha', Last_name => 'Steward'} ); 58 59 # find the first Address 60 $stone->search('Address'); 61 62 # change an existing subtree 63 $martha = $stone->Martha; 64 $martha->replace(Last_name => 'Stewart'); # replace a value 65 66 # iterate over the tree with a cursor 67 $cursor = $stone->cursor; 68 while (my ($key,$value) = $cursor->each) { 69 print "$value: Go Bluejays!\n" if $key eq 'State' and $value eq 'Katonah'; 70 } 71 72 # various format conversions 73 print $stone->asTable; 74 print $stone->asString; 75 print $stone->asHTML; 76 print $stone->asXML('Person'); 77 78=head1 DESCRIPTION 79 80A L<Stone> consists of a series of tag/value pairs. Any given tag may 81be single-valued or multivalued. A value can be another Stone, 82allowing nested components. A big Stone can be made up of a lot of 83little stones (pebbles?). You can obtain a Stone from a 84L<Boulder::Stream> or L<Boulder::Store> persistent database. 85Alternatively you can build your own Stones bit by bit. 86 87Stones can be exported into string, XML and HTML representations. In 88addition, they are flattened into a linearized representation when 89reading from or writing to a L<Boulder::Stream> or one of its 90descendents. 91 92L<Stone> was designed for subclassing. You should be able to create 93subclasses which create or require particular tags and data formats. 94Currently only L<Stone::GB_Sequence> subclasses L<Stone>. 95 96=head1 CONSTRUCTORS 97 98Stones are either created by calling the new() method, or by reading 99them from a L<Boulder::Stream> or persistent database. 100 101=head2 $stone = Stone->new() 102 103This is the main constructor for the Stone class. It can be called 104without any parameters, in which case it creates an empty Stone object 105(no tags or values), or it may passed an associative array in order to 106initialize it with a set of tags. A tag's value may be a scalar, an 107anonymous array reference (constructed using [] brackets), or a hash 108references (constructed using {} brackets). In the first case, the 109tag will be single-valued. In the second, the tag will be 110multivalued. In the third case, a subsidiary Stone will be generated 111automatically and placed into the tree at the specified location. 112 113Examples: 114 115 $myStone = new Stone; 116 $myStone = new Stone(Name=>'Fred',Age=>30); 117 $myStone = new Stone(Name=>'Fred', 118 Friend=>['Jill','John','Jerry']); 119 $myStone = new Stone(Name=>'Fred', 120 Friend=>['Jill', 121 'John', 122 'Gerald' 123 ], 124 Attributes => { Hair => 'blonde', 125 Eyes => 'blue' } 126 ); 127 128In the last example, a Stone with the following structure is created: 129 130 Name Fred 131 Friend Jill 132 Friend John 133 Friend Gerald 134 Attributes Eyes blue 135 Hair blonde 136 137Note that the value corresponding to the tag "Attributes" is itself a 138Stone with two tags, "Eyes" and "Hair". 139 140The XML representation (which could be created with asXML()) looks like this: 141 142 <?xml version="1.0" standalone="yes"?> 143 <Stone> 144 <Attributes> 145 <Eyes>blue</Eyes> 146 <Hair>blonde</Hair> 147 </Attributes> 148 <Friend>Jill</Friend> 149 <Friend>John</Friend> 150 <Friend>Gerald</Friend> 151 <Name>Fred</Name> 152 </Stone> 153 154More information on Stone initialization is given in the description 155of the insert() method. 156 157=head1 OBJECT METHODS 158 159Once a Stone object is created or retrieved, you can manipulate it 160with the following methods. 161 162=head2 $stone->insert(%hash) 163 164=head2 $stone->insert(\%hash) 165 166This is the main method for adding tags to a Stone. This method 167expects an associative array as an argument or a reference to one. 168The contents of the associative array will be inserted into the Stone. 169If a particular tag is already present in the Stone, the tag's current 170value will be appended to the list of values for that tag. Several 171types of values are legal: 172 173=over 4 174 175=item * A B<scalar> value 176 177The value will be inserted into the C<Stone>. 178 179 $stone->insert(name=>Fred, 180 age=>30, 181 sex=>M); 182 $stone->dump; 183 184 name[0]=Fred 185 age[0]=30 186 sex[0]=M 187 188=item * An B<ARRAY> reference 189 190A multi-valued tag will be created: 191 192 $stone->insert(name=>Fred, 193 children=>[Tom,Mary,Angelique]); 194 $stone->dump; 195 196 name[0]=Fred 197 children[0]=Tom 198 children[1]=Mary 199 children[2]=Angelique 200 201=item * A B<HASH> reference 202 203A subsidiary C<Stone> object will be created and inserted into the 204object as a nested structure. 205 206 $stone->insert(name=>Fred, 207 wife=>{name=>Agnes,age=>40}); 208 $stone->dump; 209 210 name[0]=Fred 211 wife[0].name[0]=Agnes 212 wife[0].age[0]=40 213 214=item * A C<Stone> object or subclass 215 216The C<Stone> object will be inserted into the object as a nested 217structure. 218 219 $wife = new Stone(name=>agnes, 220 age=>40); 221 $husband = new Stone; 222 $husband->insert(name=>fred, 223 wife=>$wife); 224 $husband->dump; 225 226 name[0]=fred 227 wife[0].name[0]=agnes 228 wife[0].age[0]=40 229 230=back 231 232=head2 $stone->replace(%hash) 233 234=head2 $stone->replace(\%hash) 235 236The B<replace()> method behaves exactly like C<insert()> with the 237exception that if the indicated key already exists in the B<Stone>, 238its value will be replaced. Use B<replace()> when you want to enforce 239a single-valued tag/value relationship. 240 241=head2 $stone->insert_list($key,@list) 242=head2 $stone->insert_hash($key,%hash) 243=head2 $stone->replace_list($key,@list) 244=head2 $stone->replace_hash($key,%hash) 245 246These are primitives used by the C<insert()> and C<replace()> methods. 247Override them if you need to modify the default behavior. 248 249=head2 $stone->delete($tag) 250 251This removes the indicated tag from the Stone. 252 253=head2 @values = $stone->get($tag [,$index]) 254 255This returns the value at the indicated tag and optional index. What 256you get depends on whether it is called in a scalar or list context. 257In a list context, you will receive all the values for that tag. You 258may receive a list of scalar values or (for a nested record) or a list 259of Stone objects. If called in a scalar context, you will either 260receive the first or the last member of the list of values assigned to 261the tag. Which one you receive depends on the value of the package 262variable C<$Stone::Fetchlast>. If undefined, you will receive the 263first member of the list. If nonzero, you will receive the last 264member. 265 266You may provide an optional index in order to force get() to return a 267particular member of the list. Provide a 0 to return the first member 268of the list, or '#' to obtain the last member. 269 270If the tag contains a period (.), get() will call index() on your 271behalf (see below). 272 273If the tag begins with an uppercase letter, then you can use the 274autogenerated method to access it: 275 276 $stone->Tag_name([$index]) 277 278This is exactly equivalent to: 279 280 $stone->get('Teg_name' [,$index]) 281 282=head2 @values = $stone->search($tag) 283 284Searches for the first occurrence of the tag, traversing the tree in a 285breadth-first manner, and returns it. This allows you to retrieve the 286value of a tag in a deeply nested structure without worrying about all 287the intermediate nodes. For example: 288 289 $myStone = new Stone(Name=>'Fred', 290 Friend=>['Jill', 291 'John', 292 'Gerald' 293 ], 294 Attributes => { Hair => 'blonde', 295 Eyes => 'blue' } 296 ); 297 298 $hair_colour = $stone->search('Hair'); 299 300The disadvantage of this is that if there is a tag named "Hair" higher 301in the hierarchy, this tag will be retrieved rather than the lower 302one. In an array context this method returns the complete list of 303values from the matching tag. In a scalar context, it returns either 304the first or the last value of multivalued tags depending as usual on 305the value of C<$Stone::Fetchlast>. 306 307C<$Stone::Fetchlast> is also consulted during the depth-first 308traversal. If C<$Fetchlast> is set to a true value, multivalued 309intermediate tags will be searched from the last to the first rather 310than the first to the last. 311 312The Stone object has an AUTOLOAD method that invokes get() when you 313call a method that is not predefined. This allows a very convenient 314type of shortcut: 315 316 $name = $stone->Name; 317 @friends = $stone->Friend; 318 $eye_color = $stone->Attributes->Eyes 319 320In the first example, we retrieve the value of the top-level tag Name. 321In the second example, we retrieve the value of the Friend tag.. In 322the third example, we retrieve the attributes stone first, then the 323Eyes value. 324 325NOTE: By convention, methods are only autogenerated for tags that 326begin with capital letters. This is necessary to avoid conflict with 327hard-coded methods, all of which are lower case. 328 329=head2 @values = $stone->index($indexstr) 330 331You can access the contents of even deeply-nested B<Stone> objects 332with the C<index> method. You provide a B<tag path>, and receive 333a value or list of values back. 334 335Tag paths look like this: 336 337 tag1[index1].tag2[index2].tag3[index3] 338 339Numbers in square brackets indicate which member of a multivalued tag 340you're interested in getting. You can leave the square brackets out 341in order to return just the first or the last tag of that name, in a scalar 342context (depending on the setting of B<$Stone::Fetchlast>). In an 343array context, leaving the square brackets out will return B<all> 344multivalued members for each tag along the path. 345 346You will get a scalar value in a scalar context and an array value in 347an array context following the same rules as B<get()>. You can 348provide an index of '#' in order to get the last member of a list or 349a [?] to obtain a randomly chosen member of the list (this uses the rand() call, 350so be sure to call srand() at the beginning of your program in order 351to get different sequences of pseudorandom numbers. If 352there is no tag by that name, you will receive undef or an empty list. 353If the tag points to a subrecord, you will receive a B<Stone> object. 354 355Examples: 356 357 # Here's what the data structure looks like. 358 $s->insert(person=>{name=>Fred, 359 age=>30, 360 pets=>[Fido,Rex,Lassie], 361 children=>[Tom,Mary]}, 362 person=>{name=>Harry, 363 age=>23, 364 pets=>[Rover,Spot]}); 365 366 # Return all of Fred's children 367 @children = $s->index('person[0].children'); 368 369 # Return Harry's last pet 370 $pet = $s->index('person[1].pets[#]'); 371 372 # Return first person's first child 373 $child = $s->index('person.children'); 374 375 # Return children of all person's 376 @children = $s->index('person.children'); 377 378 # Return last person's last pet 379 $Stone::Fetchlast++; 380 $pet = $s->index('person.pets'); 381 382 # Return any pet from any person 383 $pet = $s->index('person[?].pet[?]'); 384 385I<Note> that B<index()> may return a B<Stone> object if the tag path 386points to a subrecord. 387 388=head2 $array = $stone->at($tag) 389 390This returns an ARRAY REFERENCE for the tag. It is useful to prevent 391automatic dereferencing. Use with care. It is equivalent to: 392 393 $stone->{'tag'} 394 395at() will always return an array reference. Single-valued tags will 396return a reference to an array of size 1. 397 398=head2 @tags = $stone->tags() 399 400Return all the tags in the Stone. You can then use this list with 401get() to retrieve values or recursively traverse the stone. 402 403=head2 $string = $stone->asTable() 404 405Return the data structure as a tab-delimited table suitable for 406printing. 407 408=head2 $string = $stone->asXML([$tagname]) 409 410Return the data structure in XML format. The entire data structure 411will be placed inside a top-level tag called <Stone>. If you wish to 412change this top-level tag, pass it as an argument to asXML(). 413 414An example follows: 415 416 print $stone->asXML('Address_list'); 417 # yields: 418 <?xml version="1.0" standalone="yes"?> 419 420 <Address_list> 421 <Sally> 422 <Address> 423 <Zip>10578</Zip> 424 <City>Katonah</City> 425 <Street>Hickory Street</Street> 426 <State>NY</State> 427 </Address> 428 <Last_name>Smith</Last_name> 429 <Age>30</Age> 430 <First_name>Sarah</First_name> 431 </Sally> 432 <Jim> 433 <Address> 434 <Zip>11291</Zip> 435 <City>Garden City</City> 436 <Street>The Manse</Street> 437 <Street>19 Chestnut Ln</Street> 438 <State>NY</State> 439 </Address> 440 <Last_name>Hill</Last_name> 441 <Age>34</Age> 442 <First_name>James</First_name> 443 </Jim> 444 </Address_list> 445 446=head2 $hash = $stone->attributes([$att_name, [$att_value]]]) 447 448attributes() returns the "attributes" of a tag. Attributes are a 449series of unique tag/value pairs which are associated with a tag, but 450are not contained within it. Attributes can only be expressed in the 451XML representation of a Stone: 452 453 <Sally id="sally_tate" version="2.0"> 454 <Address type="postal"> 455 <Zip>10578</Zip> 456 <City>Katonah</City> 457 <Street>Hickory Street</Street> 458 <State>NY</State> 459 </Address> 460 </Sally> 461 462Called with no arguments, attributes() returns the current attributes 463as a hash ref: 464 465 my $att = $stone->Address->attributes; 466 my $type = $att->{type}; 467 468Called with a single argument, attributes() returns the value of the 469named attribute, or undef if not defined: 470 471 my $type = $stone->Address->attributes('type'); 472 473Called with two arguments, attributes() sets the named attribute: 474 475 my $type = $stone->Address->attributes(type => 'Rural Free Delivery'); 476 477You may also change all attributes in one fell swoop by passing a hash 478reference as the single argument: 479 480 $stone->attributes({id=>'Sally Mae',version=>'2.1'}); 481 482=head2 $string = $stone->toString() 483 484toString() returns a simple version of the Stone that shows just the 485topmost tags and the number of each type of tag. For example: 486 487 print $stone->Jim->Address; 488 #yields => Zip(1),City(1),Street(2),State(1) 489 490This method is used internally for string interpolation. If you try 491to print or otherwise manipulate a Stone object as a string, you will 492obtain this type of string as a result. 493 494=head2 $string = $stone->asHTML([\&callback]) 495 496Return the data structure as a nicely-formatted HTML 3.2 table, 497suitable for display in a Web browser. You may pass this method a 498callback routine which will be called for every tag/value pair in the 499object. It will be passed a two-item list containing the current tag 500and value. It can make any modifications it likes and return the 501modified tag and value as a return result. You can use this to modify 502tags or values on the fly, for example to turn them into HTML links. 503 504For example, this code fragment will turn all tags named "Sequence" 505blue: 506 507 my $callback = sub { 508 my ($tag,$value) = @_; 509 return ($tag,$value) unless $tag eq 'Sequence'; 510 return ( qq(<FONT COLOR="blue">$tag</FONT>),$value ); 511 } 512 print $stone->asHTML($callback); 513 514=head2 Stone::dump() 515 516This is a debugging tool. It iterates through the B<Stone> object and 517prints out all the tags and values. 518 519Example: 520 521 $s->dump; 522 523 person[0].children[0]=Tom 524 person[0].children[1]=Mary 525 person[0].name[0]=Fred 526 person[0].pets[0]=Fido 527 person[0].pets[1]=Rex 528 person[0].pets[2]=Lassie 529 person[0].age[0]=30 530 person[1].name[0]=Harry 531 person[1].pets[0]=Rover 532 person[1].pets[1]=Spot 533 person[1].age[0]=23 534 535=head2 $cursor = $stone->cursor() 536 537Retrieves an iterator over the object. You can call this several 538times in order to return independent iterators. The following brief 539example is described in more detail in L<Stone::Cursor>. 540 541 my $curs = $stone->cursor; 542 while (my($tag,$value) = $curs->next_pair) { 543 print "$tag => $value\n"; 544 } 545 # yields: 546 Sally[0].Address[0].Zip[0] => 10578 547 Sally[0].Address[0].City[0] => Katonah 548 Sally[0].Address[0].Street[0] => Hickory Street 549 Sally[0].Address[0].State[0] => NY 550 Sally[0].Last_name[0] => James 551 Sally[0].Age[0] => 30 552 Sally[0].First_name[0] => Sarah 553 Jim[0].Address[0].Zip[0] => 11291 554 Jim[0].Address[0].City[0] => Garden City 555 Jim[0].Address[0].Street[0] => The Manse 556 Jim[0].Address[0].Street[1] => 19 Chestnut Ln 557 Jim[0].Address[0].State[0] => NY 558 Jim[0].Last_name[0] => Hill 559 Jim[0].Age[0] => 34 560 Jim[0].First_name[0] => James 561 562=head1 AUTHOR 563 564Lincoln D. Stein <lstein@cshl.org>. 565 566=head1 COPYRIGHT 567 568Copyright 1997-1999, Cold Spring Harbor Laboratory, Cold Spring Harbor 569NY. This module can be used and distributed on the same terms as Perl 570itself. 571 572=head1 SEE ALSO 573 574L<Boulder::Blast>, L<Boulder::Genbank>, L<Boulder::Medline>, L<Boulder::Unigene>, 575L<Boulder::Omim>, L<Boulder::SwissProt> 576 577=cut 578 579use Stone::Cursor; 580use Carp; 581use constant DEFAULT_WIDTH=>25; # column width for pretty-printing 582 583# This global controls whether you will get the first or the 584# last member of a multi-valued attribute when you invoke 585# get() in a scalar context. 586$Stone::Fetchlast=0; 587 588sub AUTOLOAD { 589 my($pack,$func_name) = $AUTOLOAD=~/(.+)::([^:]+)$/; 590 my $self = shift; 591 croak "Can't locate object method \"$func_name\" via package \"$pack\". ", 592 "Tag names must begin with a capital letter in order to be called this way" 593 unless $func_name =~ /^[A-Z]/; 594 return $self->get($func_name,@_); 595} 596 597# Create a new Stone object, filling it with the 598# provided tag/value pairs, if any 599sub new { 600 my($pack,%initial_values) = @_; 601 my($self) = bless {},$pack; 602 $self->insert(%initial_values) if %initial_values; 603 return $self; 604} 605 606# Insert the key->value pairs into the Stone object, 607# appending to any similarly-named keys that were there before. 608sub insert { 609 my($self,@arg) = @_; 610 611 my %hash; 612 if (ref $arg[0] and ref $arg[0] eq 'HASH') { 613 %hash = %{$arg[0]}; 614 } else { 615 %hash = @arg; 616 } 617 618 foreach (keys %hash) { 619 $self->insert_list($_,$hash{$_}); 620 } 621} 622 623# Add the key->value pairs to the Stone object, 624# replacing any similarly-named keys that were there before. 625sub replace { 626 my($self,@arg) = @_; 627 628 my %hash; 629 if (ref $arg[0] and ref $arg[0] eq 'HASH') { 630 %hash = %{$arg[0]}; 631 } else { 632 %hash = @arg; 633 } 634 635 foreach (keys %hash) { 636 $self->replace_list($_,$hash{$_}); 637 } 638} 639 640# Fetch the value at the specified key. In an array 641# context, this will return the entire array. In a scalar 642# context, this will return either the first or the last member 643# of the array, depending on the value of the global Fetchlast. 644# You can specify an optional index to index into the resultant 645# array. 646# Codes: 647# digit (12) returns the 12th item 648# hash sign (#) returns the last item 649# question mark (?) returns a random item 650# zero (0) returns the first item 651sub get { 652 my($self,$key,$index) = @_; 653 return $self->index($key) if $key=~/[.\[\]]/; 654 655 if (defined $index) { 656 return $self->get_last($key) if $index eq '#' || $index == -1; 657 if ($index eq '?') { 658 my $size = scalar(@{$self->{$key}}); 659 return $self->{$key}->[rand($size)]; 660 } 661 return $self->{$key}->[$index] if $index ne ''; 662 } 663 664 if (wantarray) { 665 return @{$self->{$key}} if $self->{$key}; 666 return my(@empty); 667 } 668 return $self->get_first($key) unless $Fetchlast; 669 return $self->get_last($key); 670} 671 672# Returns 1 if the key exists. 673sub exists { 674 my($self,$key,$index) = @_; 675 return 1 if defined($self->{$key}) && !$index; 676 return 1 if defined($self->{$key}->[$index]); 677 return undef; 678} 679 680# return an array reference at indicated tag. 681# Equivalent to $stone->{'tag'} 682sub at { 683 my $self = shift; 684 return $self->{$_[0]}; 685} 686 # 687# Delete the indicated key entirely. 688sub delete { 689 my($self,$key) = @_; 690 delete $self->{$key}; 691 $self->_fix_cursors; 692} 693 694# Return all the tags in the stone. 695sub tags { 696 my $self = shift; 697 return grep (!/^\./,keys %{$self}); 698} 699 700# Return attributes as a hash reference 701# (only used by asXML) 702sub attributes { 703 my $self = shift; 704 my ($tag,$value) = @_; 705 if (defined $tag) { 706 return $self->{'.att'} = $tag if ref $tag eq 'HASH'; 707 return $self->{'.att'}{$tag} = $value if defined $value; 708 return $self->{'.att'}{$tag}; 709 } 710 return $self->{'.att'} ||= {}; 711} 712 713 714# Fetch an Iterator on the Stone. 715sub cursor { 716 my $self = shift; 717 return new Stone::Cursor($self); 718} 719 720# Convert a stone into a straight hash 721sub to_hash { 722 my ($self) = shift; 723 my ($key,%result); 724 foreach $key (keys %$self) { 725 next if substr($key,0,1) eq '.'; 726 my ($value,@values); 727 foreach $value (@{$self->{$key}}) { 728 # NG 00-10-04 changed to convert values with .name into those names 729 # NG 00-10-04 and to convert recursive results to HASH ref 730 push(@values,!ref($value)? $value: 731 defined ($value->{'.name'})? $value->{'.name'}: 732 {$value->to_hash()}); 733 } 734 $result{$key} = @values > 1 ? [@values] : $values[0]; 735 } 736 return %result; 737} 738 739# Search for a particular tag and return it using a breadth-first search 740sub search { 741 my ($self,$tag) = @_; 742 return $self->get($tag) if $self->{$tag}; 743 foreach ($self->tags()) { 744 my @objects = $self->get($_); 745 @objects = reverse(@objects) if $Fetchlast; 746 foreach my $obj (@objects) { 747 next unless ref($obj) and $obj->isa('Stone'); 748 my @result = $obj->search($tag); 749 return wantarray ? @result : ($Fetchlast ? $result[$#result] : $result[0]); 750 } 751 } 752 return wantarray ? () : undef; 753} 754 755# Extended indexing, using a compound index that 756# looks like: 757# key1[index].key2[index].key3[index] 758# If indices are left out, then you can get 759# multiple values out: 760# 1. In a scalar context, you'll get the first or last 761# value from each position. 762# 2. In an array context, you'll get all the values! 763sub index { 764 my($self,$index) = @_; 765 return &_index($self,split(/\./,$index)); 766} 767 768sub _index { 769 my($self,@indices) = @_; 770 my(@value,$key,$position,$i); 771 my(@results); 772 $i = shift @indices; 773 774 if (($key,$position) = $i=~/(.+)\[([\d\#\?]+)\]/) { # has a position 775 @value = $self->get($key,$position); # always a scalar 776 } elsif (wantarray) { 777 @value = $self->get($i); 778 } else { 779 @value = scalar($self->get($i)); 780 } 781 782 foreach (@value) { 783 next unless ref $_; 784 if (@indices) { 785 push @results,&_index($_,@indices) if $_->isa('Stone') && !exists($_->{'.name'}); 786 } else{ 787 push @results,$_; 788 } 789 } 790 return wantarray ? @results : $results[0]; 791} 792 793# Return the data structure as a nicely-formatted tab-delimited table 794sub asTable { 795 my $self = shift; 796 my $string = ''; 797 $self->_asTable(\$string,0,0); 798 return $string; 799} 800 801# Return the data structure as a nice string representation (problematic) 802sub asString { 803 my $self = shift; 804 my $MAXWIDTH = shift || DEFAULT_WIDTH; 805 my $tabs = $self->asTable; 806 return '' unless $tabs; 807 my(@lines) = split("\n",$tabs); 808 my($result,@max); 809 foreach (@lines) { 810 my(@fields) = split("\t"); 811 for (my $i=0;$i<@fields;$i++) { 812 $max[$i] = length($fields[$i]) if 813 !defined($max[$i]) or $max[$i] < length($fields[$i]); 814 } 815 } 816 foreach (@max) { $_ = $MAXWIDTH if $_ > $MAXWIDTH; } # crunch long lines 817 my $format1 = join(' ',map { "^"."<"x $max[$_] } (0..$#max)) . "\n"; 818 my $format2 = ' ' . join(' ',map { "^"."<"x ($max[$_]-1) } (0..$#max)) . "~~\n"; 819 $^A = ''; 820 foreach (@lines) { 821 my @data = split("\t"); 822 push(@data,('')x(@max-@data)); 823 formline ($format1,@data); 824 formline ($format2,@data); 825 } 826 return ($result = $^A,$^A='')[0]; 827} 828 829# Return the data structure as an HTML table 830sub asHTML { 831 my $self = shift; 832 my $modify = shift; 833 $modify ||= \&_default_modify_html; 834 my $string = "<TABLE BORDER>\n"; 835 $self->_asHTML(\$string,$modify,0,0); 836 $string .= "</TR>\n</TABLE>"; 837 return $string; 838} 839 840# Return data structure using XML syntax 841# Top-level tag is <Stone> unless otherwise specified 842sub asXML { 843 my $self = shift; 844 my $top = shift || "Stone"; 845 my $modify = shift || \&_default_modify_xml; 846 my $att; 847 if (exists($self->{'.att'})) { 848 my $a = $self->attributes; 849 foreach (keys %$a) { 850 $att .= qq( $_="$a->{$_}"); 851 } 852 } 853 my $string = "<${top}${att}>\n"; 854 $self->_asXML(\$string,$modify,0,1); 855 $string .="</$top>\n"; 856 return $string; 857} 858 859# This is the method used for string interpolation 860sub toString { 861 my $self = shift; 862 return $self->{'.name'} if exists $self->{'.name'}; 863 my @tags = map { my @v = $self->get($_); 864 my $cnt = scalar @v; 865 "$_($cnt)" 866 } $self->tags; 867 return '<empty>' unless @tags; 868 return join ',',@tags; 869} 870 871 872sub _asTable { 873 my $self = shift; 874 my ($string,$position,$level) = @_; 875 my $pos = $position; 876 foreach my $tag ($self->tags) { 877 my @values = $self->get($tag); 878 foreach my $value (@values) { 879 $$string .= "\t" x ($level-$pos) . "$tag\t"; 880 $pos = $level+1; 881 if (exists $value->{'.name'}) { 882 $$string .= "\t" x ($level-$pos+1) . "$value\n"; 883 $pos=0; 884 } else { 885 $pos = $value->_asTable($string,$pos,$level+1); 886 } 887 } 888 } 889 return $pos; 890} 891 892sub _asXML { 893 my $self = shift; 894 my ($string,$modify,$pos,$level) = @_; 895 foreach my $tag ($self->tags) { 896 my @values = $self->get($tag); 897 foreach my $value (@values) { 898 my($title,$contents) = $modify ? $modify->($tag,$value) : ($tag,$value); 899 my $att; 900 901 if (exists $value->{'.att'}) { 902 my $a = $value->{'.att'}; 903 foreach (keys %$a) { 904 $att .= qq( $_="$a->{$_}"); 905 } 906 } 907 908 $$string .= ' ' x ($level-$pos) . "<${title}${att}>"; 909 $pos = $level+1; 910 911 if (exists $value->{'.name'}) { 912 $$string .= ' ' x ($level-$pos+1) . "$contents</$title>\n"; 913 $pos=0; 914 } else { 915 $$string .= "\n" . ' ' x ($level+1); 916 $pos = $value->_asXML($string,$modify,$pos,$level+1); 917 $$string .= ' ' x ($level-$pos) . "</$title>\n"; 918 } 919 } 920 } 921 return $pos; 922} 923 924sub _asHTML { 925 my $self = shift; 926 my ($string,$modify,$position,$level) = @_; 927 my $pos = $position; 928 foreach my $tag ($self->tags) { 929 my @values = $self->get($tag); 930 foreach my $value (@values) { 931 my($title,$contents) = $modify->($tag,$value); 932 $$string .= "<TR ALIGN=LEFT VALIGN=TOP>" unless $position; 933 $$string .= "<TD></TD>" x ($level-$pos) . "<TD ALIGN=LEFT VALIGN=TOP>$title</TD>"; 934 $pos = $level+1; 935 if (exists $value->{'.name'}) { 936 $$string .= "<TD></TD>" x ($level-$pos+1) . "<TD ALIGN=LEFT VALIGN=TOP>$contents</TD></TR>\n"; 937 $pos=0; 938 } else { 939 $pos = $value->_asHTML($string,$modify,$pos,$level+1); 940 } 941 } 942 } 943 944 return $pos; 945} 946 947sub _default_modify_html { 948 my ($tag,$value) = @_; 949 return ("<B>$tag</B>",$value); 950} 951 952sub _default_modify_xml { 953 my ($tag,$value) = @_; 954 $value =~ s/&/&/g; 955 $value =~ s/>/>/g; 956 $value =~ s/</</g; 957 ($tag,$value); 958} 959 960# Dump the entire data structure, for debugging purposes 961sub dump { 962 my($self) = shift; 963 my $i = $self->cursor; 964 my ($key,$value); 965 while (($key,$value)=$i->each) { 966 print "$key=$value\n"; 967 } 968 # this has to be done explicitly here or it won't happen. 969 $i->DESTROY; 970} 971 972# return the name of the Stone 973sub name { 974 $_[0]->{'.name'} = $_[1] if defined $_[1]; 975 return $_[0]->{'.name'} 976} 977 978 979# --------- LOW LEVEL DATA INSERTION ROUTINES --------- 980# Append a set of values to the key. 981# One or more values may be other Stones. 982# You can pass the same value multiple times 983# to enter multiple values, or alternatively 984# pass an anonymous array. 985sub insert_list { 986 my($self,$key,@values) = @_; 987 988 foreach (@values) { 989 my $ref = ref($_); 990 991 if (!$ref) { # Inserting a scalar 992 my $s = new Stone; 993 $s->{'.name'} = $_; 994 push(@{$self->{$key}},$s); 995 next; 996 } 997 998 if ($ref=~/Stone/) { # A simple insertion 999 push(@{$self->{$key}},$_); 1000 next; 1001 } 1002 1003 if ($ref eq 'ARRAY') { # A multivalued insertion 1004 $self->insert_list($key,@{$_}); # Recursive insertion 1005 next; 1006 } 1007 1008 if ($ref eq 'HASH') { # Insert a record, potentially recursively 1009 $self->insert_hash($key,%{$_}); 1010 next; 1011 } 1012 1013 warn "Attempting to insert a $ref into a Stone. Be alert.\n"; 1014 push(@{$self->{$key}},$_); 1015 1016 } 1017 $self->_fix_cursors; 1018} 1019 1020# Put the values into the key, replacing 1021# whatever was there before. 1022sub replace_list { 1023 my($self,$key,@values) = @_; 1024 $self->{$key}=[]; # clear it out 1025 $self->insert_list($key,@values); # append the values 1026} 1027 1028# Similar to put_record, but doesn't overwrite the 1029# previous value of the key. 1030sub insert_hash { 1031 my($self,$key,%values) = @_; 1032 my($newrecord) = $self->new_record($key); 1033 foreach (keys %values) { 1034 $newrecord->insert_list($_,$values{$_}); 1035 } 1036} 1037 1038# Put a new associative array at the indicated key, 1039# replacing whatever was there before. Multiple values 1040# can be represented with an anonymous ARRAY reference. 1041sub replace_hash { 1042 my($self,$key,%values) = @_; 1043 $self->{$key}=[]; # clear it out 1044 $self->insert_hash($key,%values); 1045} 1046 1047#------------------- PRIVATE SUBROUTINES----------- 1048# Create a new record at indicated key 1049# and return it. 1050sub new_record { 1051 my($self,$key) = @_; 1052 my $stone = new Stone(); 1053 push(@{$self->{$key}},$stone); 1054 return $stone; 1055} 1056 1057sub get_first { 1058 my($self,$key) = @_; 1059 return $self->{$key}->[0]; 1060} 1061 1062sub get_last { 1063 my($self,$key) = @_; 1064 return $self->{$key}->[$#{$self->{$key}}]; 1065} 1066 1067# This is a private subroutine used for registering 1068# and unregistering cursors 1069sub _register_cursor { 1070 my($self,$cursor,$register) = @_; 1071 if ($register) { 1072 $self->{'.cursors'}->{$cursor}=$cursor; 1073 } else { 1074 delete $self->{'.cursors'}->{$cursor}; 1075 delete $self->{'.cursors'} unless %{$self->{'.cursors'}}; 1076 } 1077} 1078 1079# This is a private subroutine used to alert cursors that 1080# our contents have changed. 1081sub _fix_cursors { 1082 my($self) = @_; 1083 return unless $self->{'.cursors'}; 1084 my($cursor); 1085 foreach $cursor (values %{$self->{'.cursors'}}) { 1086 $cursor->reset; 1087 } 1088} 1089 1090# This is a private subroutine. It indexes 1091# all the way into the structure. 1092#sub _index { 1093# my($self,@indices) = @_; 1094# my $stone = $self; 1095# my($key,$index,@h); 1096# while (($key,$index) = splice(@indices,0,2)) { 1097# unless (defined($index)) { 1098# return scalar($stone->get($key)) unless wantarray; 1099# return @h = $stone->get($key) if wantarray; 1100# } else { 1101# $stone= ($index eq "\#") ? $stone->get_last($key): 1102# $stone->get($key,$index); 1103# last unless ref($stone)=~/Stone/; 1104# } 1105# } 1106# return $stone; 1107#} 1108 1109sub DESTROY { 1110 my $self = shift; 1111 undef %{$self->{'.cursor'}}; # not really necessary ? 1112} 1113 1114 11151; 1116