File Coverage

blib/lib/PomBase/Chobo/OntologyConf.pm
Criterion Covered Total %
statement 6 6 100.0
branch n/a
condition n/a
subroutine 2 2 100.0
pod n/a
total 8 8 100.0


line stmt bran cond sub pod time code
1             package PomBase::Chobo::OntologyConf;
2              
3             =head1 NAME
4              
5             PomBase::Chobo::OntologyConf - Configuration for ontology data
6              
7             =head1 AUTHOR
8              
9             Kim Rutherford C<< >>
10              
11             =head1 BUGS
12              
13             Please report any bugs or feature requests to C.
14              
15             =head1 SUPPORT
16              
17             You can find documentation for this module with the perldoc command.
18              
19             perldoc PomBase::Chobo::OntologyConf
20              
21             =over 4
22              
23             =back
24              
25             =head1 COPYRIGHT & LICENSE
26              
27             Copyright 2012 Kim Rutherford, all rights reserved.
28              
29             This program is free software; you can redistribute it and/or modify it
30             under the same terms as Perl itself.
31              
32             =head1 FUNCTIONS
33              
34             =cut
35              
36             our $VERSION = '0.037'; # VERSION
37              
38 5     5   33 use warnings;
  5         8  
  5         136  
39 5     5   31 use Carp;
  5         8  
  5         5978  
40              
41             our %field_conf = (
42             id => {
43             type => 'SINGLE',
44             },
45             name => {
46             type => 'SINGLE',
47             process => sub {
48             my $val = shift;
49             $val =~ s/\\"/"/g;
50             $val;
51             }
52             },
53             def => {
54             type => 'SINGLE_HASH',
55             process => sub {
56             my $val = shift;
57             if ($val =~ /"(.*)"(?:\s+\[(.*)\])?/) {
58             my $definition = $1;
59             my $dbxrefs = $2 // '';
60              
61             my @dbxrefs =
62             map {
63             # remove quoting
64             s|\\(.)|$1|g;
65             $_;
66             }
67             grep {
68             !m|^(?:url:)?https?\\?:| && /^\S+:\S+$/;
69             } split /\s*,\s/, $dbxrefs;
70              
71             return {
72             definition => $definition,
73             dbxrefs => \@dbxrefs,
74             }
75             } else {
76             croak qq(failed to parse "def:" line: $val);
77             }
78             },
79             merge => sub {
80             my $self = shift;
81             my $other = shift;
82              
83             if (!defined $other->def()) {
84             return $self->def();
85             } else {
86             if (!defined $self->def()) {
87             return $other->def();
88             } else {
89             if ($self->def()->{definition} ne $other->def()->{definition}) {
90             warn qq("def:" line differ\n ) . $self->def()->{definition} . "\nversus:\n " .
91             $other->def()->{definition};
92             }
93             return $self->def();
94             }
95             }
96             },
97             to_string => sub {
98             my $val = shift;
99             my $ret_string = $val->{definition};
100             $ret_string .= ' [' . (join ", ", @{$val->{dbxrefs}}) . ']';
101             }
102             },
103             comment => {
104             type => 'SINGLE',
105             },
106             replaced_by => {
107             type => 'SINGLE',
108             },
109             consider => {
110             type => 'SINGLE',
111             },
112             is_obsolete => {
113             type => 'SINGLE',
114             process => sub {
115             my $val = shift;
116             if ($val eq 'true') {
117             return 1;
118             } else {
119             return 0;
120             }
121             },
122             },
123             namespace => {
124             type => 'SINGLE',
125             merge => sub {
126             my $self = shift;
127             my $other = shift;
128              
129             my $self_namespace = $self->{namespace};
130             my $other_namespace = $other->{namespace};
131             if (defined $self_namespace &&
132             defined $other_namespace) {
133             # if the namespace is the same as the db_name, remove it and use the
134             # namespace from the other term to avoid a namespace clash
135             if ($self_namespace eq $self->{db_name}) {
136             $self->{namespace} = undef;
137             } else {
138             if ($other_namespace eq $other->{db_name}) {
139             $other->{namespace} = undef;
140             }
141             }
142             }
143             # do default merging
144             return undef;
145             },
146             },
147             alt_id => {
148             type => 'ARRAY',
149             },
150             is_a => {
151             type => 'ARRAY',
152             },
153             part_of => {
154             type => 'ARRAY',
155             },
156             subset => {
157             type => 'ARRAY',
158             },
159             # xref => {
160             # type => 'ARRAY',
161             # },
162             relationship => {
163             type => 'ARRAY',
164             process => sub {
165             my $val = shift;
166              
167             if ($val =~ /^\s*(\S+)\s+(\S+)\s*(?:\{(.*)\})?$/) {
168             my $relationship_name = $1;
169             my $other_term = $2;
170              
171             if ($relationship_name =~ /^:|:$/) {
172             warn "illegal relationship name: $relationship_name\n";
173             return undef;
174             }
175              
176             return {
177             relationship_name => $relationship_name,
178             other_term => $other_term,
179             };
180             } else {
181             warn "can't parse relationship: $val\n";
182             return undef;
183             }
184             },
185             to_string => sub {
186             my $val = shift;
187              
188             if (ref $val) {
189             return $val->{relationship_name} . ' ' . $val->{other_term};
190             } else {
191             croak "can't output relationship '$val' - expected a reference";
192             }
193             },
194             },
195             synonym => {
196             type => 'ARRAY',
197             process => sub {
198             my $val = shift;
199             if ($val =~ /^"(.*?[^\\])"\s*(.*)/) {
200             my $synonym = $1;
201             my @dbxrefs = ();
202             my $rest = $2;
203              
204             $synonym =~ s/\\(.)/$1/g;
205              
206             my %ret = (
207             synonym => $synonym,
208             );
209              
210             my $scope_and_type;
211              
212             if ($rest =~ /^(?:\s*(\S.*)\s+)?\[([^\]]*)\]/) {
213             if (defined $1) {
214             $scope_and_type = $1;
215             } else {
216             $scope_and_type = 'RELATED';
217             }
218              
219             my $dbxrefs_match = $2;
220              
221             if (defined $dbxrefs_match) {
222             @dbxrefs = split /\s*,\s*/, $dbxrefs_match;
223             }
224             } else {
225             $scope_and_type = $rest;
226             }
227              
228             if (defined $scope_and_type) {
229             if ($scope_and_type =~ /(\S+)\s+(\S+)/) {
230             my ($scope, $type) = ($1, $2, $3);
231              
232             $ret{scope} = $scope;
233             $ret{type} = $type;
234             } else {
235             $ret{scope} = $scope_and_type;
236             }
237             }
238              
239             $ret{dbxrefs} = \@dbxrefs;
240              
241             return \%ret;
242             } else {
243             die "unknown synonym format: $val\n";
244             }
245             },
246             to_string => sub {
247             my $val = shift;
248             my $ret_string = $val->{synonym};
249             if (defined $val->{scope}) {
250             $ret_string .= ' ' . $val->{scope};
251             }
252             if (defined $val->{type}) {
253             $ret_string .= ' ' . $val->{type};
254             }
255             if (defined $val->{dbxrefs}) {
256             $ret_string .= ' [' . (join ", ", @{$val->{dbxrefs}}) . ']';
257             }
258              
259             return $ret_string;
260             },
261             },
262             property_value => {
263             type => 'ARRAY',
264             process => sub {
265             my $raw_value = shift;
266              
267             $raw_value =~ s/\s+xsd:\w+\s*$//;
268              
269             my ($name, $value) = split(/\s+/, $raw_value, 2);
270              
271             return [
272             $name, $value
273             ]
274             },
275             },
276             );
277              
278             1;