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(