File Coverage

blib/lib/Ace/Object.pm

Criterion	Covered	Total	%
statement	388	539	72.0
branch	166	286	58.0
condition	39	111	35.1
subroutine	48	61	78.7
pod	21	37	56.8
total	662	1034	64.0

line	stmt	bran	cond	sub	pod	time	code
1							package Ace::Object;
2	4			4		58	use strict;
	4					55
	4					57
3	4			4		75	use Carp qw(:DEFAULT cluck);
	4					65
	4					75
4
5							# $Id: Object.pm,v 1.60 2005/04/13 14:26:08 lstein Exp $
6
7							use overload
8	4					64	'""' => 'name',
9							'==' => 'eq',
10							'!=' => 'ne',
11	4			4		99	'fallback' => 'TRUE';
	4					37
12	4			4		60	use vars qw($AUTOLOAD $DEFAULT_WIDTH %MO $VERSION);
	4					34
	4					57
13	4			4		60	use Ace 1.50 qw(:DEFAULT rearrange);
	4					83
	4					59
14
15							# if set to 1, will conflate tags in XML output
16	4			4		68	use constant XML_COLLAPSE_TAGS => 1;
	4					36
	4					61
17	4			4		97	use constant XML_SUPPRESS_CONTENT=>1;
	4					37
	4					49
18	4			4		78	use constant XML_SUPPRESS_CLASS=>1;
	4					38
	4					51
19	4			4		57	use constant XML_SUPPRESS_VALUE=>0;
	4					37
	4					47
20	4			4		144	use constant XML_SUPPRESS_TIMESTAMPS=>0;
	4					36
	4					50
21
22							require AutoLoader;
23
24							$DEFAULT_WIDTH=25; # column width for pretty-printing
25							$VERSION = '1.66';
26
27							# Pseudonyms and deprecated methods.
28							*isClass = \&isObject;
29							*pick = \&fetch;
30							*get = \&search;
31							*add = \&add_row;
32
33							sub AUTOLOAD {
34	22			22		660	my($pack,$func_name) = $AUTOLOAD=~/(.+)::([^:]+)$/;
35	22					219	my $self = $_[0];
36
37							# This section works with Autoloader
38	22		66			540	my $presumed_tag = $func_name =~ /^[A-Z]/ && $self->isObject; # initial_cap
39
40	22	100	33			338	if ($presumed_tag) {
		50
41	9	50	33			94	croak "Invalid object tag \"$func_name\""
			33
42							if $self->db && $self->model && !$self->model->valid_tag($func_name);
43
44	9					105	shift(); # get rid of the object
45	9					76	my $no_dereference;
46	9	100				94	if (defined($_[0])) {
47	5	50				102	if ($_[0] eq '@') {
		50
48	0					0	$no_dereference++;
49	0					0	shift();
50							} elsif ($_[0] =~ /^\d+$/) {
51	5					48	$no_dereference++;
52							}
53							}
54
55	9	50	66			111	$self = $self->fetch if !$no_dereference &&
			33
56							!$self->isRoot && $self->db; # dereference, if need be
57	9	50				96	croak "Null object tag \"$func_name\"" unless $self;
58
59	9	100				111	return $self->search($func_name,@_) if wantarray;
60	6	100				99	my ($obj) = @_ ? $self->search($func_name,@_) : $self->search($func_name,1);
61
62							# these nasty heuristics simulate aql semantics.
63							# undefined return
64	6	50				59	return unless defined $obj;
65
66							# don't dereference object if '@' symbol specified
67	6	100				89	return $obj if $no_dereference;
68
69							# don't dereference if an offset was explicitly specified
70	3	50	33			35	return $obj if defined($_[0]) && $_[0] =~ /\d+/;
71
72							# otherwise dereference if the current thing is an object or we are at a tag
73							# and the thing to the right is an object.
74	3	100	66			32	return $obj->fetch if $obj->isObject && !$obj->isRoot; # always dereference objects
75
76							# otherwise return the thing itself
77	2					24	return $obj;
78							} elsif ($func_name =~ /^[A-Z]/ && $self->isTag) { # follow tag
79	0					0	return $self->search($func_name);
80							} else {
81	13					139	$AutoLoader::AUTOLOAD = __PACKAGE__ . "::$func_name";
82	13					189	goto &AutoLoader::AUTOLOAD;
83							}
84							}
85
86							sub DESTROY {
87	99			99		1656	my $self = shift;
88
89	99	50				1189	return unless defined $self->{class}; # avoid working with temp objects from a search()
90	99	50				1312	return if caller() =~ /^(Cache\:\:\|DB)/; # prevent recursion in FileCache code
91	99	100				1065	my $db = $self->db or return;
92	80	100				1085	return if $self->{'.nocache'};
93	77	100				807	return unless $self->isRoot;
94
95	51	100				506	if ($self->_dirty) {
96	1	50				14	warn "Destroy for ",overload::StrVal($self)," ",$self->class,':',$self->name if Ace->debug;
97	1					12	$self->_dirty(0);
98	1					14	$db->file_cache_store($self);
99							}
100
101							# remove our in-memory cache
102							# shouldn't be necessary with weakref
103							# $db->memory_cache_delete($self);
104							}
105
106							###################### object constructor #################
107							# IMPORTANT: The _clone subroutine will copy all instance variables that
108							# do NOT begin with a dot (.). If you do not want an instance variable
109							# shared with cloned copies, proceed them with a dot!!!
110							#
111							sub new {
112	416			416	1	14633	my $pack = shift;
113	416					8064	my($class,$name,$db,$isRoot) = rearrange([qw/CLASS NAME/,[qw/DATABASE DB/],'ROOT'],@_);
114	416	100				6014	$pack = ref($pack) if ref($pack);
115	416					9409	my $self = bless { 'name' => $name,
116							'class' => $class
117							},$pack;
118	416	100				4717	$self->db($db) if $self->isObject;
119	416	100	100			7175	$self->{'.root'}++ if defined $isRoot && $isRoot;
120							# $self->_dirty(1) if $isRoot;
121	416					4723	return $self
122							}
123
124							######### construct object from serialized input, not usually called directly ########
125							sub newFromText {
126	23			23	0	244	my ($pack,$text,$db) = @_;
127	23	100				218	$pack = ref($pack) if ref($pack);
128
129	23					179	my @array;
130	23					1348	foreach (split("\n",$text)) {
131	2404	100				26738	next unless $_;
132							# this is a hack to fix some txt fields with unescaped tabs
133							# unfortunately it breaks other things
134	2400					29451	s/\?txt\?([^?]?)\t([^?]?)\?/?txt?$1\\t$2?/g;
135	2400					41963	push(@array,[split("\t")]);
136							}
137	23					641	my $obj = $pack->_fromRaw(\@array,0,0,$#array,$db);
138	23					249	$obj->_dirty(1);
139	23					295	$obj;
140							}
141
142
143							################### name of the object #################
144							sub name {
145	2880			2880	1	35092	my $self = shift;
146	2880	50				40661	$self->{'name'} = shift if defined($_[0]);
147	2880					35205	my $name = $self->_ace_format($self->{'class'},$self->{'name'});
148	2880					34218	$name;
149							}
150
151							################### class of the object #################
152							sub class {
153	959			959	1	9549	my $self = shift;
154	959	50				12852	defined($_[0])
155							? $self->{'class'} = shift
156							: $self->{'class'};
157							}
158
159							################### name and class together #################
160							sub id {
161	0			0	0	0	my $self = shift;
162	0					0	return "$self->{class}:$self->{name}";
163							}
164
165							############## return true if two objects are equivalent ##################
166							# to be equivalent, they must have identical names, classes and databases #
167							# We handle comparisons between objects and numbers ourselves, and let #
168							# Perl handle comparisons between objects and strings #
169							sub eq {
170	0			0	0	0	my ($a,$b,$rev) = @_;
171	0	0				0	unless (UNIVERSAL::isa($b,'Ace::Object')) {
172	0					0	$a = $a->name + 0; # convert to numeric
173	0					0	return $a == $b; # do a numeric comparison
174							}
175	0	0	0			0	return 1 if ($a->name eq $b->name)
			0
176							&& ($a->class eq $b->class)
177							&& ($a->db eq $b->db);
178	0					0	return;
179							}
180
181							sub ne {
182	0			0	0	0	return !&eq;
183							}
184
185
186							############ returns true if this is a top-level object #######
187							sub isRoot {
188	129			129	1	1712	return exists shift()->{'.root'};
189							}
190
191							################### handle to ace database #################
192							sub db {
193	961			961	1	10781	my $self = shift;
194	961	100				13210	if (@_) {
195	369					4374	my $db = shift;
196	369					5160	$self->{db} = "$db"; # store string representation, not object
197							}
198	961					15685	Ace->name2db($self->{db});
199							}
200
201							### Return a portion of the tree at the indicated tag path ###
202							#### In a list context returns the column. In an array context ###
203							#### returns a pointer to the subtree ####
204							#### Usually returns what is pointed to by the tag. Will return
205							#### the parent object if you pass a true value as the second argument
206							sub at {
207	13			13	1	118	my $self = shift;
208	13					176	my($tag,$pos,$return_parent) = rearrange(['TAG','POS','PARENT'],@_);
209	13	100				148	return $self->right unless $tag;
210	12					114	$tag = lc $tag;
211
212							# Removed a $` here to increase speed -- tim.cutts@incyte.com 2 Sep 1999
213
214	12	50	33			168	if (!defined($pos) and $tag=~/(.*?)\[(\d+)\]$/) {
215	0					0	$pos = $2;
216	0					0	$tag = $1;
217							}
218
219	12					101	my $o = $self;
220	12					98	my ($parent,$above,$left);
221	12					130	my (@tags) = $self->_split_tags($tag);
222	12					125	foreach $tag (@tags) {
223	24					235	$tag=~s/$;/./g; # unprotect backslashed dots
224	24					194	my $p = $o;
225	24					247	($o,$above,$left) = $o->_at($tag);
226	24	100				1990	return unless defined($o);
227							}
228	3	100	66			34	return $above \|\| $left if $return_parent;
229	1	50				18	return defined $pos ? $o->right($pos) : $o unless wantarray;
		50
230	0					0	return $o->col($pos);
231							}
232
233							### Flatten out part of the tree into an array ####
234							### along the row. Will not follow object references. ###
235							sub row {
236	2			2	1	19	my $self = shift;
237	2					19	my $pos = shift;
238	2					18	my @r;
239	2	100				27	my $o = defined $pos ? $self->right($pos) : $self;
240	2					24	while (defined($o)) {
241	5					44	push(@r,$o);
242	5					52	$o = $o->right;
243							}
244	2					29	return @r;
245							}
246
247							### Flatten out part of the tree into an array ####
248							### along the column. Will not follow object references. ###
249							sub col {
250	20			20	1	202	my $self = shift;
251	20					171	my $pos = shift;
252	20	100				205	$pos = 1 unless defined $pos;
253	20	50				188	croak "Position must be positive" unless $pos >= 0;
254
255	20	100				262	return ($self) unless $pos > 0;
256
257	17					149	my @r;
258							# This is for tag[1] semantics
259	17	100				157	if ($pos == 1) {
260							for (my $o=$self->right; defined($o); $o=$o->down) {
261	37					632	push (@r,$o);
262	15					223	}
263							} else {
264							# This is for tag[2] semantics
265							for (my $o=$self->right; defined($o); $o=$o->down) {
266	8	50				82	next unless defined(my $right = $o->right($pos-2));
267	8					4385	push (@r,$right->col);
268	2					22	}
269							}
270	17					220	return @r;
271							}
272
273							#### Search for a tag, and return the column ####
274							#### Uses a breadth-first search (cols then rows) ####
275							sub search {
276	10			10	1	88	my $self = shift;
277	10	50				119	my $tag = shift unless $_[0]=~/^-/;
278	10					161	my ($subtag,$pos,$filled) = rearrange(['SUBTAG','POS',['FILL','FILLED']],@_);
279	10					115	my $lctag = lc $tag;
280
281							# With caching, the old way of following ends up cloning the object
282							# -- which we don't want. So more-or-less emulate the earlier
283							# behavior with an explicit get and fetch
284							# return $self->follow(-tag=>$tag,-filled=>$filled) if $filled;
285	10	50				96	if ($filled) {
286	0	0				0	my @node = $self->search($tag) or return; # watch out for recursion!
287	0					0	my @obj = map {$_->fetch} @node;
	0					0
288	0	0				0	foreach (@obj) {$_->right if defined $_}; # trigger a fill
	0					0
289	0	0				0	return wantarray ? @obj : $obj[0];
290							}
291
292							TRY: {
293
294							# look in our tag cache first
295	10	100				86	if (exists $self->{'.PATHS'}) {
	10					148
296
297							# we've already cached the desired tree
298	8	100				108	last TRY if exists $self->{'.PATHS'}{$lctag};
299
300							# not cached, so try parents of tag
301	2					20	my $m = $self->model;
302	2	50				80	my @parents = $m->path($lctag) if $m;
303	2					21	my $tree;
304	2					21	foreach (@parents) {
305	0	0				0	($tree = $self->{'.PATHS'}{lc $_}) && last;
306							}
307	2	50				23	if ($tree) {
308	0					0	$self->{'.PATHS'}{$lctag} = $tree->search($tag);
309	0					0	$self->_dirty(1);
310	0					0	last TRY;
311							}
312							}
313
314							# If the object hasn't been filled already, then we can use
315							# acedb's query mechanism to fetch the subobject. This is a
316							# big win for large objects. ...However, we have to disable
317							# this feature if timestamps are active.
318	4	100				47	unless ($self->filled) {
319	1					13	my $subobject = $self->newFromText(
320							$self->db->show($self->class,$self->name,$tag),
321							$self->db
322							);
323	1	50				11	if ($subobject) {
324	1					14	$subobject->{'.nocache'}++;
325	1					13	$self->_attach_subtree($lctag => $subobject);
326							} else {
327	0					0	$self->{'.PATHS'}{$lctag} = undef;
328							}
329	1					27	$self->_dirty(1);
330	1					32	last TRY;
331							}
332
333	3					33	my @col = $self->col;
334	3					31	foreach (@col) {
335	6	50				72	next unless $_->isTag;
336	6	100				66	if (lc $_ eq $lctag) {
337	3					45	$self->{'.PATHS'}{$lctag} = $_;
338	3					31	$self->_dirty(1);
339	3					34	last TRY;
340							}
341							}
342
343							# if we get here, we didn't find it in the column,
344							# so we call ourselves recursively to find it
345	0					0	foreach (@col) {
346	0	0				0	next unless $_->isTag;
347	0	0				0	if (my $r = $_->search($tag)) {
348	0					0	$self->{'.PATHS'}{$lctag} = $r;
349	0					0	$self->_dirty(1);
350	0					0	last TRY;
351							}
352							}
353
354							# If we got here, we just didn't find it. So tag the cache
355							# as empty so that we don't try again
356	0					0	$self->{'.PATHS'}{$lctag} = undef;
357	0					0	$self->_dirty(1);
358							}
359
360	10					113	my $t = $self->{'.PATHS'}{$lctag};
361	10	50				103	return unless $t;
362
363	10	100				115	if (defined $subtag) {
364	8	50				110	if ($subtag =~ /^\d+$/) {
365	8					94	$pos = $subtag;
366							} else { # position on subtag and search again
367	0	0	0			0	return $t->fetch->search($subtag,$pos)
			0
368							if $t->isObject \|\| (defined($t->right) and $t->right->isObject);
369	0					0	return $t->search($subtag,$pos);
370							}
371							}
372
373	10	50				1746	return defined $pos ? $t->right($pos) : $t unless wantarray;
		100
374
375							# We do something verrrry interesting in an array context.
376							# If no position is defined, we return the column to the right.
377							# If a position is defined, we return everything $POS tags
378							# to the right (so-called tag[2] system).
379	9					117	return $t->col($pos);
380							}
381
382							# utility routine used in partial tree caching
383							sub _attach_subtree {
384	1			1		10	my $self = shift;
385	1					11	my ($tag,$subobject) = @_;
386	1					10	my $lctag = lc($tag);
387	1					9	my $obj;
388	1	50				12	if (lc($subobject->right) eq $lctag) { # new version of aceserver as of 11/30/98
389	1					15	$obj = $subobject->right;
390							} else { # old version of aceserver
391	0					0	$obj = $self->new('tag',$tag,$self->db);
392	0					0	$obj->{'.right'} = $subobject->right;
393							}
394	1					128	$self->{'.PATHS'}->{$lctag} = $obj;
395							}
396
397							sub _dirty {
398	98			98		868	my $self = shift;
399	98	100	100			1127	$self->{'.dirty'} = shift if @_ && $self->isRoot;
400	98					2262	$self->{'.dirty'};
401							}
402
403							#### return true if tree is populated, without populating it #####
404							sub filled {
405	106			106	0	939	my $self = shift;
406	106		100			2223	return exists($self->{'.right'}) \|\| exists($self->{'.raw'});
407							}
408
409							#### return true if you can follow the object in the database (i.e. a class ###
410							sub isPickable {
411	0			0	0	0	return shift->isObject;
412							}
413
414							#### Return a string representation of the object subject to Ace escaping rules ###
415							sub escape {
416	0			0	0	0	my $self = shift;
417	0					0	my $name = $self->name;
418	0		0			0	my $needs_escaping = $name=~/[^\w.-]/ \|\| $self->isClass;
419	0	0				0	return $name unless $needs_escaping;
420	0					0	$name=~s/\"/\\"/g; #escape quotes"
421	0					0	return qq/"$name"/;
422							}
423
424							############### object on the right of the tree #############
425							sub right {
426	95			95	1	1246	my ($self,$pos) = @_;
427
428	95					1107	$self->_fill;
429	95					1100	$self->_parse;
430
431	95	100				1283	return $self->{'.right'} unless defined $pos;
432	24	50				260	croak "Position must be positive" unless $pos >= 0;
433
434	24					235	my $node = $self;
435	24					257	while ($pos--) {
436	1	50				14	defined($node = $node->right) \|\| return;
437							}
438	24					387	$node;
439							}
440
441							################# object below on the tree #################
442							sub down {
443	92			92	1	874	my ($self,$pos) = @_;
444	92					910	$self->_parse;
445	92	50				1193	return $self->{'.down'} unless defined $pos;
446	0					0	my $node = $self;
447	0					0	while ($pos--) {
448	0	0				0	defined($node = $node->down) \|\| return;
449							}
450	0					0	$node;
451							}
452
453							#############################################
454							# fetch current node from the database #
455							sub fetch {
456	3			3	1	47	my ($self,$tag) = @_;
457	3	100				36	return $self->search($tag) if defined $tag;
458	2	50	33			20	my $thing_to_pick = ($self->isTag and defined($self->right)) ? $self->right : $self;
459	2	100				20	return $thing_to_pick unless $thing_to_pick->isObject;
460	1	50				12	my $obj = $self->db->get($thing_to_pick->class,$thing_to_pick->name) if $self->db;
461	1					2226	return $obj;
462							}
463
464							#############################################
465							# follow a tag into the database, returning a
466							# list of followed objects.
467							sub follow {
468	1			1	1	102	my $self = shift;
469	1					19	my ($tag,$filled) = rearrange(['TAG','FILLED'],@_);
470
471	1	50				15	return unless $self->db;
472	1	50				16	return $self->fetch() unless $tag;
473	1					12	my $class = $self->class;
474	1					12	my $name = Ace->freeprotect($self->name);
475	1					9	my @options;
476	1	50				185	if ($filled) {
477	0	0				0	@options = $filled =~ /^[a-zA-Z]/ ? ('filltag' => $filled) : ('filled'=>1);
478							}
479	1					50	return $self->db->fetch(-query=>"find $class $name ; follow $tag",@options);
480							}
481
482							# returns true if the object has a Model, i.e, can be followed into
483							# the database.
484							sub isObject {
485	456			456	0	4988	my $self = shift;
486	456					4765	return _isObject($self->class);
487	0					0	1;
488							}
489
490							# returns true if the object is a tag.
491							sub isTag {
492	8			8	1	69	my $self = shift;
493	8	100				76	return 1 if $self->class eq 'tag';
494	2					27	return;
495							}
496
497							# return the most recent error message
498							sub error {
499	1			1	1	13	$Ace::Error=~s/\0//g; # get rid of nulls
500	1					24	return $Ace::Error;
501							}
502
503							### Returns the object's model (as an Ace::Model object)
504							sub model {
505	22			22	1	270	my $self = shift;
506	22	50	33			213	return unless $self->db && $self->isObject;
507	22					279	return $self->db->model($self->class);
508							}
509
510							### Return the class in which to bless all objects retrieved from
511							# database. Might want to override in other classes
512							sub factory {
513	0			0	1	0	return __PACKAGE__;
514							}
515
516							#####################################################################
517							#####################################################################
518							############### mostly private functions from here down #############
519							#####################################################################
520							#####################################################################
521							# simple clone
522							sub clone {
523	0			0	0	0	my $self = shift;
524	0					0	return bless {%$self},ref $self;
525							}
526
527							# selective clone
528							sub _clone {
529	0			0		0	my $self = shift;
530	0					0	my $pack = ref($self);
531	0					0	my @public_keys = grep {substr($_,0,1) ne '.'} keys %$self;
	0					0
532	0					0	my %newobj;
533	0					0	@newobj{@public_keys} = @{$self}{@public_keys};
	0					0
534
535							# Turn into a toplevel object
536	0					0	$newobj{'.root'}++;
537	0					0	return bless \%newobj,$pack;
538							}
539
540							sub _fill {
541	100			100		876	my $self = shift;
542	100	100				984	return if $self->filled;
543	4	50	33			45	return unless $self->db && $self->isObject;
544
545	4					47	my $data = $self->db->pick($self->class,$self->name);
546	4	100				52	return unless $data;
547
548							# temporary object, don't cache it.
549	2					29	my $new = $self->newFromText($data,$self->db);
550	2					18	%{$self}=%{$new};
	2					46
	2					28
551
552	2					31	$new->{'.nocache'}++; # this line prevents the thing from being cached
553
554	2					49	$self->_dirty(1);
555							}
556
557							sub _parse {
558	192			192		1625	my $self = shift;
559	192	100				3536	return unless my $raw = $self->{'.raw'};
560	15					146	my $ts = $self->db->timestamps;
561	15					157	my $col = $self->{'.col'};
562	15					124	my $current_obj = $self;
563	15					138	my $current_row = $self->{'.start_row'};
564	15					143	my $db = $self->db;
565	15					127	my $changed;
566
567							for (my $r=$current_row+1; $r<=$self->{'.end_row'}; $r++) {
568	6355	100				102775	next unless $raw->[$r][$col] ne '';
569	17					144	$changed++;
570
571	17					311	my $obj_right = $self->_fromRaw($raw,$current_row,$col+1,$r-1,$db);
572
573							# comment handling
574	17	100				168	if ( defined($obj_right) ) {
575	12					97	my ($t,$i);
576	12					107	my $row = $current_row+1;
577	12					137	while ($obj_right->isComment) {
578	0	0				0	$current_obj->comment($obj_right) if $obj_right->isComment;
579	0					0	$t = $obj_right;
580	0	0				0	last unless defined ($obj_right = $self->_fromRaw($raw,$row++,$col+1,$r-1,$db));
581							}
582							}
583	17					170	$current_obj->{'.right'} = $obj_right;
584
585	17					260	my ($class,$name,$timestamp) = Ace->split($raw->[$r][$col]);
586	17					175	my $obj_down = $self->new($class,$name,$db);
587	17	50	33			413	$obj_down->timestamp($timestamp) if $ts && $timestamp;
588
589							# comments never occur at down pointers
590	17					192	$current_obj = $current_obj->{'.down'} = $obj_down;
591	17					257	$current_row = $r;
592	15					141	}
593
594	15					183	my $obj_right = $self->_fromRaw($raw,$current_row,$col+1,$self->{'.end_row'},$db);
595
596							# comment handling
597	15	100				148	if (defined($obj_right)) {
598	8					66	my ($t,$i);
599	8					68	my $row = $current_row + 1;
600	8					102	while ($obj_right->isComment) {
601	0	0				0	$current_obj->comment($obj_right) if $obj_right->isComment;
602	0					0	$t = $obj_right;
603	0	0				0	last unless defined($obj_right = $self->_fromRaw($raw,$row++,$col+1,$self->{'.end_row'},$db));
604							}
605							}
606	15					150	$current_obj->{'.right'} = $obj_right;
607	15	100				157	$self->_dirty(1) if $changed;
608	15					127	delete @{$self}{qw[.raw .start_row .end_row .col]};
	15					214
609							}
610
611							sub _fromRaw {
612	55			55		526	my $pack = shift;
613
614							# this breaks inheritance...
615							# $pack = $pack->factory();
616
617	55					587	my ($raw,$start_row,$col,$end_row,$db) = @_;
618	55	50				800	$db = "$db" if ref $db;
619	55	100				863	return unless defined $raw->[$start_row][$col];
620
621							# HACK! Some LongText entries may begin with newlines. This is within the Acedb spec.
622							# Let's purge text entries of leading space and format them appropriate.
623							# This should probably be handled in Freesubs.xs / Ace::split
624	43					400	my $temp = $raw->[$start_row][$col];
625							# if ($temp =~ /^\?txt\?\s\n/) {
626							# $temp =~ s/^\?txt\?(\s\\n)/\?txt\?/;
627							# $temp .= '?';
628							# }
629	43					610	my ($class,$name,$ts) = Ace->split($temp);
630
631	43		100			694	my $self = $pack->new($class,$name,$db,!($start_row \|\| $col));
632	43					385	@{$self}{qw(.raw .start_row .end_row .col db)} = ($raw,$start_row,$end_row,$col,$db);
	43					622
633	43	50				542	$self->{'.timestamp'} = $ts if defined $ts;
634	43					435	return $self;
635							}
636
637
638							# Return partial ace subtree at indicated tag
639							sub _at {
640	24			24		222	my ($self,$tag) = @_;
641	24					2235	my $pos=0;
642
643							# Removed a $` here to increase speed -- tim.cutts@incyte.com 2 Sep 1999
644
645	24	50				271	if ($tag=~/(.*?)\[(\d+)\]$/) {
646	0					0	$pos=$2;
647	0					0	$tag=$1;
648							}
649	24					230	my $p;
650	24					322	my $o = $self->right;
651	24					662	while ($o) {
652	44	100				496	return ($o->right($pos),$p,$self) if (lc($o) eq lc($tag));
653	29					408	$p = $o;
654	29					966	$o = $o->down;
655							}
656	9					89	return;
657							}
658
659
660							# Used to munge special data types. Right now dates are the
661							# only examples.
662							sub _ace_format {
663	2880			2880		39555	my $self = shift;
664	2880					39620	my ($class,$name) = @_;
665	2880	100	66			40325	return undef unless defined $class && defined $name;
666	2876	50				35704	return $class eq 'date' ? $self->_to_ace_date($name) : $name;
667							}
668
669							# It's an object unless it is one of these things
670							sub _isObject {
671	456	50		456		4728	return unless defined $_[0];
672	456					7761	$_[0] !~ /^(float\|int\|date\|tag\|txt\|peptide\|dna\|scalar\|[Tt]ext\|comment)$/;
673							}
674
675							# utility routine used to split a tag path into individual components
676							# allows components to contain dots.
677							sub _split_tags {
678	23			23		204	my $self = shift;
679	23					266	my $tag = shift;
680	23					215	$tag =~ s/\\\./$;/g; # protect backslashed dots
681	23					4227	return map { (my $x=$_)=~s/$;/./g; $x } split(/\./,$tag);
	52					545
	52					584
682							}
683
684
685							1;
686
687							__END__
688
689							=head1 NAME
690
691							Ace::Object - Manipulate Ace Data Objects
692
693							=head1 SYNOPSIS
694
695							# open database connection and get an object
696							use Ace;
697							$db = Ace->connect(-host => 'beta.crbm.cnrs-mop.fr',
698							-port => 20000100);
699							$sequence = $db->fetch(Sequence => 'D12345');
700
701							# Inspect the object
702							$r = $sequence->at('Visible.Overlap_Right');
703							@row = $sequence->row;
704							@col = $sequence->col;
705							@tags = $sequence->tags;
706
707							# Explore object substructure
708							@more_tags = $sequence->at('Visible')->tags;
709							@col = $sequence->at("Visible.$more_tags[1]")->col;
710
711							# Follow a pointer into database
712							$r = $sequence->at('Visible.Overlap_Right')->fetch;
713							$next = $r->at('Visible.Overlap_left')->fetch;
714
715							# Classy way to do the same thing
716							$r = $sequence->Overlap_right;
717							$next = $sequence->Overlap_left;
718
719							# Pretty-print object
720							print $sequence->asString;
721							print $sequence->asTabs;
722							print $sequence->asHTML;
723
724							# Update object
725							$sequence->replace('Visible.Overlap_Right',$r,'M55555');
726							$sequence->add('Visible.Homology','GR91198');
727							$sequence->delete('Source.Clone','MBR122');
728							$sequence->commit();
729
730							# Rollback changes
731							$sequence->rollback()
732
733							# Get errors
734							print $sequence->error;
735
736							=head1 DESCRIPTION
737
738							I<Ace::Object> is the base class for objects returned from ACEDB
739							databases. Currently there is only one type of I<Ace::Object>, but
740							this may change in the future to support more interesting
741							object-specific behaviors.
742
743							Using the I<Ace::Object> interface, you can explore the internal
744							structure of an I<Ace::Object>, retrieve its content, and convert it
745							into various types of text representation. You can also fetch a
746							representation of any object as a GIF image.
747
748							If you have write access to the databases, add new data to an object,
749							replace existing data, or kill it entirely. You can also create a new
750							object de novo and write it into the database.
751
752							For information on connecting to ACEDB databases and querying them,
753							see L<Ace>.
754
755							=head1 ACEDB::OBJECT METHODS
756
757							The structure of an Ace::Object is very similar to that of an Acedb
758							object. It is a tree structure like this one (an Author object):
759
760							Thierry-Mieg J->Full_name ->Jean Thierry-Mieg
761							\|
762							Laboratory->FF
763							\|
764							Address->Mail->CRBM duCNRS
765							\| \| \|
766							\| \| BP 5051
767							\| \| \|
768							\| \| 34033 Montpellier
769							\| \| \|
770							\| \| FRANCE
771							\| \|
772							\| E_mail->mieg@kaa.cnrs-mop.fr
773							\| \|
774							\| Phone ->33-67-613324
775							\| \|
776							\| Fax ->33-67-521559
777							\|
778							Paper->The C. elegans sequencing project
779							\|
780							Genome Project Database
781							\|
782							Genome Sequencing
783							\|
784							How to get ACEDB for your Sun
785							\|
786							ACEDB is Hungry
787
788							Each object in the tree has two pointers, a "right" pointer to the
789							node on its right, and a "down" pointer to the node beneath it. Right
790							pointers are used to store hierarchical relationships, such as
791							Address->Mail->E_mail, while down pointers are used to store lists,
792							such as the multiple papers written by the Author.
793
794							Each node in the tree has a type and a name. Types include integers,
795							strings, text, floating point numbers, as well as specialized
796							biological types, such as "dna" and "peptide." Another fundamental
797							type is "tag," which is a text identifier used to label portions of
798							the tree. Examples of tags include "Paper" and "Laboratory" in the
799							example above.
800
801							In addition to these built-in types, there are constructed types known
802							as classes. These types are specified by the data model. In the
803							above example, "Thierry-Mieg J" is an object of the "Author" class,
804							and "Genome Project Database" is an object of the "Paper" class. An
805							interesting feature of objects is that you can follow them into the
806							database, retrieving further information. For example, after
807							retrieving the "Genome Project Database" Paper from the Author object,
808							you could fetch more information about it, either by following B<its>
809							right pointer, or by using one of the specialized navigation routines
810							described below.
811
812							=head2 new() method
813
814							$object = new Ace::Object($class,$name,$database);
815							$object = new Ace::Object(-class=>$class,
816							-name=>$name,
817							-db=>database);
818
819							You can create a new Ace::Object from scratch by calling the new()
820							routine with the object's class, its identifier and a handle to the
821							database to create it in. The object won't actually be created in the
822							database until you add() one or more tags to it and commit() it (see
823							below). If you do not provide a database handle, the object will be
824							created in memory only.
825
826							Arguments can be passed positionally, or as named parameters, as shown
827							above.
828
829							This routine is usually used internally. See also add_row(),
830							add_tree(), delete() and replace() for ways to manipulate this object.
831
832							=head2 name() method
833
834							$name = $object->name();
835
836							Return the name of the Ace::Object. This happens automatically
837							whenever you use the object in a context that requires a string or a
838							number. For example:
839
840							$object = $db->fetch(Author,"Thierry-Mieg J");
841							print "$object did not write 'Pride and Prejudice.'\n";
842
843							=head2 class() method
844
845							$class = $object->class();
846
847							Return the class of the object. The return value may be one of
848							"float," "int," "date," "tag," "txt," "dna," "peptide," and "scalar."
849							(The last is used internally by Perl to represent objects created
850							programatically prior to committing them to the database.) The class
851							may also be a user-constructed type such as Sequence, Clone or
852							Author. These user-constructed types usually have an initial capital
853							letter.
854
855							=head2 db() method
856
857							$db = $object->db();
858
859							Return the database that the object is associated with.
860
861							=head2 isClass() method
862
863							$bool = $object->isClass();
864
865							Returns true if the object is a class (can be fetched from the
866							database).
867
868							=head2 isTag() method
869
870							$bool = $object->isTag();
871
872							Returns true if the object is a tag.
873
874							=head2 tags() method
875
876							@tags = $object->tags();
877
878							Return all the top-level tags in the object as a list. In the Author
879							example above, the returned list would be
880							('Full_name','Laboratory','Address','Paper').
881
882							You can fetch tags more deeply nested in the structure by navigating
883							inwards using the methods listed below.
884
885							=head2 right() and down() methods
886
887							$subtree = $object->right;
888							$subtree = $object->right($position);
889							$subtree = $object->down;
890							$subtree = $object->down($position);
891
892							B<right()> and B<down()> provide a low-level way of traversing the
893							tree structure by following the tree's right and down pointers.
894							Called without any arguments, these two methods will move one step.
895							Called with a numeric argument >= 0 they will move the indicated
896							number of steps (zero indicates no movement).
897
898							$full_name = $object->right->right;
899							$full_name = $object->right(2);
900
901							$city = $object->right->down->down->right->right->down->down;
902							$city = $object->right->down(2)->right(2)->down(2);
903
904							If $object contains the "Thierry-Mieg J" Author object, then the first
905							series of accesses shown above retrieves the string "Jean
906							Thierry-Mieg" and the second retrieves "34033 Montpellier." If the
907							right or bottom pointers are NULL, these methods will return undef.
908
909							In addition to being somewhat awkard, you will probably never need to
910							use these methods. A simpler way to retrieve the same information
911							would be to use the at() method described in the next section.
912
913							The right() and down() methods always walk through the tree of the
914							current object. They do not follow object pointers into the database.
915							Use B<fetch()> (or the deprecated B<pick()> or B<follow()> methods)
916							instead.
917
918							=head2 at() method
919
920							$subtree = $object->at($tag_path);
921							@values = $object->at($tag_path);
922
923							at() is a simple way to fetch the portion of the tree that you are
924							interested in. It takes a single argument, a simple tag or a path. A
925							simple tag, such as "Full_name", must correspond to a tag in the
926							column immediately to the right of the root of the tree. A path such
927							as "Address.Mail" is a dot-delimited path to the subtree. Some
928							examples are given below.
929
930							($full_name) = $object->at('Full_name');
931							@address_lines = $object->at('Address.Mail');
932
933							The second line above is equivalent to:
934
935							@address = $object->at('Address')->at('Mail');
936
937							Called without a tag name, at() just dereferences the object,
938							returning whatever is to the right of it, the same as
939							$object->right
940
941							If a path component already has a dot in it, you may escape the dot
942							with a backslash, as in:
943
944							$s=$db->fetch('Sequence','M4');
945							@homologies = $s->at('Homol.DNA_homol.yk192f7\.3';
946
947							This also demonstrates that path components don't necessarily have to
948							be tags, although in practice they usually are.
949
950							at() returns slightly different results depending on the context in
951							which it is called. In a list context, it returns the column of
952							values to the B<right> of the tag. However, in a scalar context, it
953							returns the subtree rooted at the tag. To appreciate the difference,
954							consider these two cases:
955
956							$name1 = $object->at('Full_name');
957							($name2) = $object->at('Full_name');
958
959							After these two statements run, $name1 will be the tag object named
960							"Full_name", and $name2 will be the text object "Jean Thierry-Mieg",
961							The relationship between the two is that $name1->right leads to
962							$name2. This is a powerful and useful construct, but it can be a trap
963							for the unwary. If this behavior drives you crazy, use this
964							construct:
965
966							$name1 = $object->at('Full_name')->at();
967
968							For finer control over navigation, path components can include
969							optional indexes to indicate navigation to the right of the current
970							path component. Here is the syntax:
971
972							$object->at('tag1[index1].tag2[index2].tag3[index3]...');
973
974							Indexes are zero-based. An index of [0] indicates no movement
975							relative to the current component, and is the same as not using an
976							index at all. An index of [1] navigates one step to the right, [2]
977							moves two steps to the right, and so on. Using the Thierry-Mieg
978							object as an example again, here are the results of various indexes:
979
980							$object = $db->fetch(Author,"Thierry-Mieg J");
981							$a = $object->at('Address[0]') --> "Address"
982							$a = $object->at('Address[1]') --> "Mail"
983							$a = $object->at('Address[2]') --> "CRBM duCNRS"
984
985							In an array context, the last index in the path does something very
986							interesting. It returns the entire column of data K steps to the
987							right of the path, where K is the index. This is used to implement
988							so-called "tag[2]" syntax, and is very useful in some circumstances.
989							For example, here is a fragment of code to return the Thierry-Mieg
990							object's full address without having to refer to each of the
991							intervening "Mail", "E_Mail" and "Phone" tags explicitly.
992
993							@address = $object->at('Address[2]');
994							--> ('CRBM duCNRS','BP 5051','34033 Montpellier','FRANCE',
995							'mieg@kaa.cnrs-mop.fr,'33-67-613324','33-67-521559')
996
997							Similarly, "tag[3]" will return the column of data three hops to the
998							right of the tag. "tag[1]" is identical to "tag" (with no index), and
999							will return the column of data to the immediate right. There is no
1000							special behavior associated with using "tag[0]" in an array context;
1001							it will always return the subtree rooted at the indicated tag.
1002
1003							Internal indices such as "Homol[2].BLASTN", do not have special
1004							behavior in an array context. They are always treated as if they were
1005							called in a scalar context.
1006
1007							Also see B<col()> and B<get()>.
1008
1009							=head2 get() method
1010
1011							$subtree = $object->get($tag);
1012							@values = $object->get($tag);
1013							@values = $object->get($tag, $position);
1014							@values = $object->get($tag => $subtag, $position);
1015
1016							The get() method will perform a breadth-first search through the
1017							object (columns first, followed by rows) for the tag indicated by the
1018							argument, returning the column of the portion of the subtree it points
1019							to. For example, this code fragment will return the value of the
1020							"Fax" tag.
1021
1022							($fax_no) = $object->get('Fax');
1023							--> "33-67-521559"
1024
1025							The list versus scalar context semantics are the same as in at(), so
1026							if you want to retrieve the scalar value pointed to by the indicated
1027							tag, either use a list context as shown in the example, above, or a
1028							dereference, as in:
1029
1030							$fax_no = $object->get('Fax');
1031							--> "Fax"
1032							$fax_no = $object->get('Fax')->at;
1033							--> "33-67-521559"
1034
1035							An optional second argument to B<get()>, $position, allows you to
1036							navigate the tree relative to the retrieved subtree. Like the B<at()>
1037							navigational indexes, $position must be a number greater than or equal
1038							to zero. In a scalar context, $position moves rightward through the
1039							tree. In an array context, $position implements "tag[2]" semantics.
1040
1041							For example:
1042
1043							$fax_no = $object->get('Fax',0);
1044							--> "Fax"
1045
1046							$fax_no = $object->get('Fax',1);
1047							--> "33-67-521559"
1048
1049							$fax_no = $object->get('Fax',2);
1050							--> undef # nothing beyond the fax number
1051
1052							@address = $object->get('Address',2);
1053							--> ('CRBM duCNRS','BP 5051','34033 Montpellier','FRANCE',
1054							'mieg@kaa.cnrs-mop.fr,'33-67-613324','33-67-521559')
1055
1056							It is important to note that B<get()> only traverses tags. It will
1057							not traverse nodes that aren't tags, such as strings, integers or
1058							objects. This is in keeping with the behavior of the Ace query
1059							language "show" command.
1060
1061							This restriction can lead to confusing results. For example, consider
1062							the following object:
1063
1064							Clone: B0280 Position Map Sequence-III Ends Left 3569
1065							Right 3585
1066							Pmap ctg377 -1040 -1024
1067							Positive Positive_locus nhr-10
1068							Sequence B0280
1069							Location RW
1070							FingerPrint Gel_Number 0
1071							Canonical_for T20H1
1072							K10E5
1073							Bands 1354 18
1074
1075
1076							The following attempt to fetch the left and right positions of the
1077							clone will fail, because the search for the "Left" and "Right" tags
1078							cannot traverse "Sequence-III", which is an object, not a tag:
1079
1080							my $left = $clone->get('Left'); # will NOT work
1081							my $right = $clone->get('Right'); # neither will this one
1082
1083							You must explicitly step over the non-tag node in order to make this
1084							query work. This syntax will work:
1085
1086							my $left = $clone->get('Map',1)->get('Left'); # works
1087							my $left = $clone->get('Map',1)->get('Right'); # works
1088
1089							Or you might prefer to use the tag[2] syntax here:
1090
1091							my($left,$right) = $clone->get('Map',1)->at('Ends[2]');
1092
1093							Although not frequently used, there is a form of get() which allows
1094							you to stack subtags:
1095
1096							$locus = $object->get('Positive'=>'Positive_locus');
1097
1098							Only on subtag is allowed. You can follow this by a position if wish
1099							to offset from the subtag.
1100
1101							$locus = $object->get('Positive'=>'Positive_locus',1);
1102
1103							=head2 search() method
1104
1105							This is a deprecated synonym for get().
1106
1107							=head2 Autogenerated Access Methods
1108
1109							$scalar = $object->Name_of_tag;
1110							$scalar = $object->Name_of_tag($position);
1111							@array = $object->Name_of_tag;
1112							@array = $object->Name_of_tag($position);
1113							@array = $object->Name_of_tag($subtag=>$position);
1114							@array = $object->Name_of_tag(-fill=>$tag);
1115
1116							The module attempts to autogenerate data access methods as needed.
1117							For example, if you refer to a method named "Fax" (which doesn't
1118							correspond to any of the built-in methods), then the code will call
1119							the B<get()> method to find a tag named "Fax" and return its
1120							contents.
1121
1122							Unlike get(), this method will B<always step into objects>. This
1123							means that:
1124
1125							$map = $clone->Map;
1126
1127							will return the Sequence_Map object pointed to by the Clone's Map tag
1128							and not simply a pointer to a portion of the Clone tree. Therefore
1129							autogenerated methods are functionally equivalent to the following:
1130
1131							$map = $clone->get('Map')->fetch;
1132
1133							The scalar context semantics are also slightly different. In a scalar
1134							context, the autogenerated function will always move one step to the
1135							right.
1136
1137							The list context semantics are identical to get(). If you want to
1138							dereference all members of a multivalued tag, you have to do so manually:
1139
1140							@papers = $author->Paper;
1141							foreach (@papers) {
1142							my $paper = $_->fetch;
1143							print $paper->asString;
1144							}
1145
1146							You can provide an optional positional index to rapidly navigate
1147							through the tree or to obtain tag[2] behavior. In the following
1148							examples, the first two return the object's Fax number, and the third
1149							returns all data two hops to the right of Address.
1150
1151							$object = $db->fetch(Author => 'Thierry-Mieg J');
1152							($fax_no) = $object->Fax;
1153							$fax_no = $object->Fax(1);
1154							@address = $object->Address(2);
1155
1156							You may also position at a subtag, using this syntax:
1157
1158							$representative = $object->Laboratory('Representative');
1159
1160							Both named tags and positions can be combined as follows:
1161
1162							$lab_address = $object->Laboratory(Address=>2);
1163
1164							If you provide a -fill=>$tag argument, then the object fetch will
1165							automatically fill the specified subtree, greatly improving
1166							performance. For example:
1167
1168							$lab_address = $object->Laboratory(-filled=>'Address');
1169
1170							** NOTE: In a scalar context, if the node to the right of the tag is
1171							** an object, the method will perform an implicit dereference of the
1172							** object. For example, in the case of:
1173
1174							$lab = $author->Laboratory;
1175
1176							**NOTE: The object returned is the dereferenced Laboratory object, not
1177							a node in the Author object. You can control this by giving the
1178							autogenerated method a numeric offset, such as Laboratory(0) or
1179							Laboratory(1). For backwards compatibility, Laboratory('@') is
1180							equivalent to Laboratory(1).
1181
1182							The semantics of the autogenerated methods have changed subtly between
1183							version 1.57 (the last stable release) and version 1.62. In earlier
1184							versions, calling an autogenerated method in a scalar context returned
1185							the subtree rooted at the tag. In the current version, an implicit
1186							right() and dereference is performed.
1187
1188
1189							=head2 fetch() method
1190
1191							$new_object = $object->fetch;
1192							$new_object = $object->fetch($tag);
1193
1194							Follow object into the database, returning a new object. This is
1195							the best way to follow object references. For example:
1196
1197							$laboratory = $object->at('Laboratory')->fetch;
1198							print $laboratory->asString;
1199
1200							Because the previous example is a frequent idiom, the optional $tag
1201							argument allows you to combine the two operations into a single one:
1202
1203							$laboratory = $object->fetch('Laboratory');
1204
1205							=head2 follow() method
1206
1207							@papers = $object->follow('Paper');
1208							@filled_papers = $object->follow(-tag=>'Paper',-filled=>1);
1209							@filled_papers = $object->follow(-tag=>'Paper',-filled=>'Author');
1210
1211							The follow() method will follow a tag into the database, dereferencing
1212							the column to its right and returning the objects resulting from this
1213							operation. Beware! If you follow a tag that points to an object,
1214							such as the Author "Paper" tag, you will get a list of all the Paper
1215							objects. If you follow a tag that points to a scalar, such as
1216							"Full_name", you will get an empty string. In a scalar context, this
1217							method will return the number of objects that would have been
1218							followed.
1219
1220							The full named-argument form of this call accepts the arguments
1221							B<-tag> (mandatory) and B<-filled> (optional). The former points to
1222							the tag to follow. The latter accepts a boolean argument or the name
1223							of a subtag. A numeric true argument will return completely "filled"
1224							objects, increasing network and memory usage, but possibly boosting
1225							performance if you have a high database access latency.
1226							Alternatively, you may provide the name of a tag to follow, in which
1227							case just the named portion of the subtree in the followed objects
1228							will be filled (v.g.)
1229
1230							For backward compatability, if follow() is called without any
1231							arguments, it will act like fetch().
1232
1233							=head2 pick() method
1234
1235							Deprecated method. This has the same semantics as fetch(), which
1236							should be used instead.
1237
1238							=head2 col() method
1239
1240							@column = $object->col;
1241							@column = $object->col($position);
1242
1243
1244							B<col()> flattens a portion of the tree by returning the column one
1245							hop to the right of the current subtree. You can provide an additional
1246							positional index to navigate through the tree using "tag[2]" behavior.
1247							This example returns the author's mailing address:
1248
1249							@mailing_address = $object->at('Address.Mail')->col();
1250
1251							This example returns the author's entire address including mail,
1252							e-mail and phone:
1253
1254							@address = $object->at('Address')->col(2);
1255
1256							It is equivalent to any of these calls:
1257
1258							$object->at('Address[2]');
1259							$object->get('Address',2);
1260							$object->Address(2);
1261
1262							Use whatever syntax is most comfortable for you.
1263
1264							In a scalar context, B<col()> returns the number of items in the
1265							column.
1266
1267							=head2 row() method
1268
1269							@row=$object->row();
1270							@row=$object->row($position);
1271
1272							B<row()> will return the row of data to the right of the object. The
1273							first member of the list will be the object itself. In the case of
1274							the "Thierry-Mieg J" object, the example below will return the list
1275							('Address','Mail','CRBM duCNRS').
1276
1277							@row = $object->Address->row();
1278
1279							You can provide an optional position to move rightward one or more
1280							places before retrieving the row. This code fragment will return
1281							('Mail','CRBM duCNRS'):
1282
1283							@row = $object->Address->row(1);
1284
1285							In a scalar context, B<row()> returns the number of items in the row.
1286
1287							=head2 asString() method
1288
1289							$object->asString;
1290
1291							asString() returns a pretty-printed ASCII representation of the object
1292							tree.
1293
1294							=head2 asTable() method
1295
1296							$object->asTable;
1297
1298							asTable() returns the object as a tab-delimited text table.
1299
1300							=head2 asAce() method
1301
1302							$object->asAce;
1303
1304							asAce() returns the object as a tab-delimited text table in ".ace"
1305							format.
1306
1307							=head2 asHTML() method
1308
1309							$object->asHTML;
1310							$object->asHTML(\&tree_traversal_code);
1311
1312							asHTML() returns an HTML 3 table representing the object, suitable for
1313							incorporation into a Web browser page. The callback routine, if
1314							provided, will have a chance to modify the object representation
1315							before it is incorporated into the table, for example by turning it
1316							into an HREF link. The callback takes a single argument containing
1317							the object, and must return a string-valued result. It may also
1318							return a list as its result, in which case the first member of the
1319							list is the string representation of the object, and the second
1320							member is a boolean indicating whether to prune the table at this
1321							level. For example, you can prune large repetitive lists.
1322
1323							Here's a complete example:
1324
1325							sub process_cell {
1326							my $obj = shift;
1327							return "$obj" unless $obj->isObject \|\| $obj->isTag;
1328
1329							my @col = $obj->col;
1330							my $cnt = scalar(@col);
1331							return ("$obj -- $cnt members",1); # prune
1332							if $cnt > 10 # if subtree to big
1333
1334							# tags are bold
1335							return "<B>$obj</B>" if $obj->isTag;
1336
1337							# objects are blue
1338							return qq{<FONT COLOR="blue">$obj</FONT>} if $obj->isObject;
1339							}
1340
1341							$object->asHTML(\&process_cell);
1342
1343							=head2 asXML() method
1344
1345							$result = $object->asXML;
1346
1347							asXML() returns a well-formed XML representation of the object. The
1348							particular representation is still under discussion, so this feature
1349							is primarily for demonstration.
1350
1351							=head2 asGIF() method
1352
1353							($gif,$boxes) = $object->asGIF();
1354							($gif,$boxes) = $object->asGIF(-clicks=>[[$x1,$y1],[$x2,$y2]...]
1355							-dimensions=> [$width,$height],
1356							-coords => [$top,$bottom],
1357							-display => $display_type,
1358							-view => $view_type,
1359							-getcoords => $true_or_false
1360							);
1361
1362							asGIF() returns the object as a GIF image. The contents of the GIF
1363							will be whatever xace would ordinarily display in graphics mode, and
1364							will vary for different object classes.
1365
1366							You can optionally provide asGIF with a B<-clicks> argument to
1367							simulate the action of a user clicking on the image. The click
1368							coordinates should be formatted as an array reference that contains a
1369							series of two-element subarrays, each corresponding to the X and Y
1370							coordinates of a single mouse click. There is currently no way to
1371							pass information about middle or right mouse clicks, dragging
1372							operations, or keystrokes. You may also specify a B<-dimensions> to
1373							control the width and height of the returned GIF. Since there is no
1374							way of obtaining the preferred size of the image in advance, this is
1375							not usually useful.
1376
1377							The optional B<-display> argument allows you to specify an alternate
1378							display for the object. For example, Clones can be displayed either
1379							with the PMAP display or with the TREE display. If not specified, the
1380							default display is used.
1381
1382							The optional B<-view> argument allows you to specify an alternative
1383							view for MAP objects only. If not specified, you'll get the default
1384							view.
1385
1386							The option B<-coords> argument allows you to provide the top and
1387							bottom of the display for MAP objects only. These coordinates are in
1388							the map's native coordinate system (cM, bp). By default, AceDB will
1389							show most (but not necessarily all) of the map according to xace's
1390							display rules. If you call this method with the B<-getcoords>
1391							argument and a true value, it will return a two-element array
1392							containing the coordinates of the top and bottom of the map.
1393
1394							asGIF() returns a two-element array. The first element is the GIF
1395							data. The second element is an array reference that indicates special
1396							areas of the image called "boxes." Boxes are rectangular areas that
1397							surround buttons, and certain displayed objects. Using the contents
1398							of the boxes array, you can turn the GIF image into a client-side
1399							image map. Unfortunately, not everything that is clickable is
1400							represented as a box. You still have to pass clicks on unknown image
1401							areas back to the server for processing.
1402
1403							Each box in the array is a hash reference containing the following
1404							keys:
1405
1406							'coordinates' => [$left,$top,$right,$bottom]
1407							'class' => object class or "BUTTON"
1408							'name' => object name, if any
1409							'comment' => a text comment of some sort
1410
1411							I<coordinates> points to an array of points indicating the top-left and
1412							bottom-right corners of the rectangle. I<class> indicates the class
1413							of the object this rectangle surrounds. It may be a database object,
1414							or the special word "BUTTON" for one of the display action buttons.
1415							I<name> indicates the name of the object or the button. I<comment> is
1416							some piece of information about the object in question. You can
1417							display it in the status bar of the browser or in a popup window if
1418							your browser provides that facility.
1419
1420							=head2 asDNA() and asPeptide() methods
1421
1422							$dna = $object->asDNA();
1423							$peptide = $object->asPeptide();
1424
1425							If you are dealing with a sequence object of some sort, these methods
1426							will return strings corresponding to the DNA or peptide sequence in
1427							FASTA format.
1428
1429							=head2 add_row() method
1430
1431							$result_code = $object->add_row($tag=>$value);
1432							$result_code = $object->add_row($tag=>[list,of,values]);
1433							$result_code = $object->add(-path=>$tag,
1434							-value=>$value);
1435
1436							add_row() updates the tree by adding data to the indicated tag path. The
1437							example given below adds the value "555-1212" to a new Address entry
1438							named "Pager". You may call add_row() a second time to add a new value
1439							under this tag, creating multi-valued entries.
1440
1441							$object->add_row('Address.Pager'=>'555-1212');
1442
1443							You may provide a list of values to add an entire row of data. For
1444							example:
1445
1446							$sequence->add_row('Assembly_tags'=>['Finished Left',38949,38952,'AC3']);
1447
1448							Actually, the array reference is not entirely necessary, and if you
1449							prefer you can use this more concise notation:
1450
1451							$sequence->add_row('Assembly_tags','Finished Left',38949,38952,'AC3');
1452
1453							No check is done against the database model for the correct data type
1454							or tag path. The update isn't actually performed until you call
1455							commit(), at which time a result code indicates whether the database
1456							update was successful.
1457
1458							You may create objects that reference other objects this way:
1459
1460							$lab = new Ace::Object('Laboratory','LM',$db);
1461							$lab->add_row('Full_name','The Laboratory of Medicine');
1462							$lab->add_row('City','Cincinatti');
1463							$lab->add_row('Country','USA');
1464
1465							$author = new Ace::Object('Author','Smith J',$db);
1466							$author->add_row('Full_name','Joseph M. Smith');
1467							$author->add_row('Laboratory',$lab);
1468
1469							$lab->commit();
1470							$author->commit();
1471
1472							The result code indicates whether the addition was syntactically
1473							correct. add_row() will fail if you attempt to add a duplicate entry
1474							(that is, one with exactly the same tag and value). In this case, use
1475							replace() instead. Currently there is no checking for an attempt to
1476							add multiple values to a single-valued (UNIQUE) tag. The error will
1477							be detected and reported at commit() time however.
1478
1479							The add() method is an alias for add_row().
1480
1481							See also the Ace->new() method.
1482
1483							=head2 add_tree()
1484
1485							$result_code = $object->add_tree($tag=>$ace_object);
1486							$result_code = $object->add_tree(-tag=>$tag,-tree=>$ace_object);
1487
1488							The add_tree() method will insert an entire Ace subtree into the object
1489							to the right of the indicated tag. This can be used to build up
1490							complex Ace objects, or to copy portions of objects from one database
1491							to another. The first argument is a tag path, and the second is the
1492							tree that you wish to insert. As with add_row() the database will
1493							only be updated when you call commit().
1494
1495							When inserting a subtree, you must be careful to remember that
1496							everything to the right of the node that you are pointing at will be
1497							inserted; not the node itself. For example, given this Sequence
1498							object:
1499
1500							Sequence AC3
1501							DB_info Database EMBL
1502							Assembly_tags Finished Left 1 4 AC3
1503							Clone left end 1 4 AC3
1504							Clone right end 5512 5515 K07C5
1505							38949 38952 AC3
1506							Finished Right 38949 38952 AC3
1507
1508							If we use at('Assembly_tags') to fetch the subtree rooted on the
1509							"Assembly_tags" tag, it is the tree to the right of this tag,
1510							beginning with "Finished Left", that will be inserted.
1511
1512							Here is an example of copying the "Assembly_tags" subtree
1513							from one database object to another:
1514
1515							$remote = Ace->connect(-port=>200005) \|\| die "can't connect";
1516							$ac3 = $remote->fetch(Sequence=>'AC3') \|\| die "can't get AC7";
1517							my $assembly = $ac3->at('Assembly_tags');
1518
1519							$local = Ace->connect(-path=>'~acedb') \|\| die "can't connect";
1520							$AC3copy = Ace::Object->new(Sequence=>'AC3copy',$local);
1521							$AC3copy->add_tree('Assembly_tags'=>$tags);
1522							$AC3copy->commit \|\| warn $AC3copy->error;
1523
1524							Notice that this syntax will not work the way you think it should:
1525
1526							$AC3copy->add_tree('Assembly_tags'=>$ac3->at('Assembly_tags'));
1527
1528							This is because call at() in an array context returns the column to
1529							the right of the tag, not the tag itself.
1530
1531							Here's an example of building up a complex structure from scratch
1532							using a combination of add() and add_tree():
1533
1534							$newObj = Ace::Object->new(Sequence=>'A555',$local);
1535							my $assembly = Ace::Object->new(tag=>'Assembly_tags');
1536							$assembly->add('Finished Left'=>[10,20,'ABC']);
1537