File Coverage

blib/lib/Ace/Model.pm
Criterion Covered Total %
statement 85 86 98.8
branch 19 22 86.4
condition 7 10 70.0
subroutine 11 12 91.7
pod 6 7 85.7
total 128 137 93.4


line stmt bran cond sub pod time code
1             package Ace::Model;
2             # file: Ace/Model.pm
3             # This is really just a placeholder class. It doesn't do anything interesting.
4 2     2   29 use strict;
  2         30  
  2         127  
5 2     2   34 use vars '$VERSION';
  2         20  
  2         35  
6 2     2   70 use Text::Tabs 'expand';
  2         21  
  2         52  
7              
8             use overload
9 2         39   '""' => 'asString',
10 2     2   35   fallback => 'TRUE';
  2         20  
11              
12             $VERSION = '1.51';
13              
14             my $TAG = '\b\w+\b';
15             my $KEYWORD = q[^(XREF|UNIQUE|ANY|FREE|REPEAT|Int|Text|Float|DateType)$];
16             my $METAWORD = q[^(XREF|UNIQUE|ANY|FREE|REPEAT|Int|Text|Float|DateType)$];
17              
18             # construct a new Ace::Model
19             sub new {
20 4     4 1 40   my $class = shift;
21 4         106   my ($data,$db,$break_cycle) = @_;
22 4   100     51   $break_cycle ||= {};
23              
24 4         205   $data=~s!\s+//.*$!!gm; # remove all comments
25 4         53   $data=~s!\0!!g;
26 4         60   my ($name) = $data =~ /\A[\?\#](\w+)/;
27 4         401   my $self = bless {
28             name      => $name,
29             raw       => $data,
30             submodels => [],
31             },$class;
32              
33 4 100 33     55   if (!$break_cycle->{$name} && $db && (my @hashes = grep {$_ ne $name} $data =~ /\#(\S+)/g)) {
  3   66     302  
34 1         11     $break_cycle->{$name}++;
35 1         34     my %seen;
36 1         11     my @submodels = map {$db->model($_,$break_cycle)} grep {!$seen{$_}++} @hashes;
  1         17  
  1         14  
37 1         17     $self->{submodels} = \@submodels;
38               }
39              
40 4         84   return $self;
41             }
42              
43             sub name {
44 0     0 1 0   return shift()->{name};
45             }
46              
47             # return all the tags in the model as a hashref.
48             # in a list context returns the tags as a long list result
49             sub tags {
50 10     10 1 88   my $self = shift;
51 81         988   $self->{tags} ||= { map {lc($_)=>1}
  119         2666  
52 177         2224 grep {!/^[\#\?]/o}
53 1         14 grep {!/$KEYWORD/o}
54             $self->{raw}=~m/(\S+)/g,
55 10   100     239 map {$_->tags} @{$self->{submodels}}
  3         32  
56             };
57 10 100       239   return wantarray ? keys %{$self->{tags}} : $self->{tags};
  1         14  
58             }
59              
60             # return the path to a particular tag
61             sub path {
62 4     4 1 45   my $self = shift;
63 4         42   my $tag = lc shift;
64 4         68   $self->parse;
65 4 50       54   return unless exists $self->{path}{$tag};
66 4         67   return @{$self->{path}{$tag}};
  4         67  
67             }
68              
69             # parse out the paths to each of the tags
70             sub parse {
71 4     4 0 36   my $self = shift;
72 4 100       48   return if exists $self->{path};
73 2         24   my @lines = grep { !m[^\s*//] } $self->_untabulate;
  26         255  
74              
75             # accumulate a list of all the paths
76 2         24   my (@paths,@path,@path_stack);
77 2         18   my $current_position = 0;
78              
79              LINE:
80 2         20   for my $line (@lines) {
81              
82               TOKEN:
83 26         289     while ($line =~ /(\S+)/g) { # get a token
84 58         554       my $tag = $1;
85 58         510       my $position = pos($line) - length $tag;
86 58 100       727       next TOKEN if $tag =~ /$METAWORD/o;
87 42 100       450       if ($tag =~ /^[?\#]/) {
88 14 100       168 next TOKEN if $position == 0; # the name of the model, so get next token
89 12         110 next LINE; # otherwise abandon this line
90                   }
91                   
92 28 100       321       if ($position > $current_position) { # here's a subtag
    100          
93 4         43 push @path_stack,[$current_position,[@path]]; # remember a copy of partial path
94 4         68 push @paths,[@path]; # remember current path
95 4         42 push @path,$tag; # append to the current path
96                   } elsif ($position == $current_position) { # here's a sibling tree
97 22         287 push @paths,[@path]; # remember current path
98 22         201 $path[-1] = $tag; # replace last item
99            
100             # otherwise, we're done with a subtree and need to restore context of parent
101                   } else {
102 2         23 push @paths,[@path]; # remember current path
103 2         20 @path = (); # nuke path
104 2         25 while (@path_stack) {
105 2         20 my $s = pop @path_stack; # pop off an earlier partial path
106 2 50       84 if ($s->[0] == $position) { # found correct context to restore
107 2         20 @path = @{$s->[1]}; # restore
  2         24  
108 2         22 last;
109             }
110             }
111 2         48 $path[-1] = $tag; # replace sibling
112                   }
113                   
114 28         308       $current_position = $position;
115                 }
116               }
117 2 50       31   push @paths,[@path] if @path;
118               
119             # at this point, @paths contains a list of paths to each terminal tag
120 2         21   foreach (@paths) {
121 30         258     my $tag = pop @{$_};
  30         331  
122 30         671     $self->{path}{lc($tag)} = $_;
123               }
124             }
125              
126             sub _untabulate {
127 2     2   19   my $self = shift;
128 2         106   my @lines = split "\n",$self->{raw};
129 2         31   return expand(@lines);
130             }
131              
132             # return true if the tag is a valid one
133             sub valid_tag {
134 9     9 1 78   my $self = shift;
135 9         88   my $tag = lc shift;
136 9         96   return $self->tags->{$tag};
137             }
138              
139             # just return the model as a string
140             sub asString {
141 107     107 1 2486   return shift()->{'raw'};
142             }
143              
144             1;
145              
146             __END__
147            
148             =head1 NAME
149            
150             Ace::Model - Get information about AceDB models
151            
152             =head1 SYNOPSIS
153            
154             use Ace;
155             my $db = Ace->connect(-path=>'/usr/local/acedb/elegans');
156             my $model = $db->model('Author');
157             print $model;
158             $name = $model->name;
159             @tags = $model->tags;
160             print "Paper is a valid tag" if $model->valid_tag('Paper');
161            
162             =head1 DESCRIPTION
163            
164             This class is provided for access to AceDB class models. It provides
165             the model in human-readable form, and does some limited but useful
166             parsing on your behalf.
167            
168             Ace::Model objects are obtained either by calling an Ace database
169             handle's model() method to retrieve the model of a named class, or by
170             calling an Ace::Object's model() method to retrieve the object's
171             particular model.
172            
173             =head1 METHODS
174            
175             =head2 new()
176            
177             $model = Ace::Model->new($model_data);
178            
179             This is a constructor intended only for use by Ace and Ace::Object
180             classes. It constructs a new Ace::Model object from the raw string
181             data in models.wrm.
182            
183             =head2 name()
184            
185             $name = $model->name;
186            
187             This returns the class name for the model.
188            
189             =head2 tags()
190            
191             @tags = $model->tags;
192            
193             This returns a list of all the valid tags in the model.
194            
195             =head2 valid_tag()
196            
197             $boolean = $model->valid_tag($tag);
198            
199             This returns true if the given tag is part of the model.
200            
201             =head2 path()
202            
203             @path = $model->path($tag)
204            
205             Returns the path to the indicated tag, returning a list of intermediate tags.
206             For example, in the C elegans ?Locus model, the path for 'Compelementation_data"
207             will return the list ('Type','Gene').
208            
209             =head2 asString()
210            
211             print $model->asString;
212            
213             asString() returns the human-readable representation of the model with
214             comments stripped out. Internally this method is called to
215             automatically convert the model into a string when appropriate. You
216             need only to start performing string operations on the model object in
217             order to convert it into a string automatically:
218            
219             print "Paper is unique" if $model=~/Paper ?Paper UNIQUE/;
220            
221             =head1 SEE ALSO
222            
223             L<Ace>
224            
225             =head1 AUTHOR
226            
227             Lincoln Stein <lstein@w3.org> with extensive help from Jean
228             Thierry-Mieg <mieg@kaa.crbm.cnrs-mop.fr>
229            
230             Copyright (c) 1997-1998, Lincoln D. Stein
231            
232             This library is free software;
233             you can redistribute it and/or modify it under the same terms as Perl itself.
234            
235             =cut
236            
237            
238