line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Lingua::Thesaurus::Storage; |
2
|
6
|
|
|
6
|
|
5220
|
use Moose::Role; |
|
6
|
|
|
|
|
15168
|
|
|
6
|
|
|
|
|
21
|
|
3
|
6
|
|
|
6
|
|
12442
|
use Moose::Meta::Class; |
|
6
|
|
|
|
|
9
|
|
|
6
|
|
|
|
|
168
|
|
4
|
6
|
|
|
6
|
|
23
|
use namespace::clean -except => 'meta'; |
|
6
|
|
|
|
|
7
|
|
|
6
|
|
|
|
|
39
|
|
5
|
|
|
|
|
|
|
|
6
|
|
|
|
|
|
|
#====================================================================== |
7
|
|
|
|
|
|
|
# ATTRIBUTES |
8
|
|
|
|
|
|
|
#====================================================================== |
9
|
|
|
|
|
|
|
|
10
|
|
|
|
|
|
|
has 'params' => (is => 'ro', isa => 'HashRef', |
11
|
|
|
|
|
|
|
lazy => 1, builder => '_params', |
12
|
|
|
|
|
|
|
predicate => 'has_params', |
13
|
|
|
|
|
|
|
documentation => "params saved in storage"); |
14
|
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
has 'term_class' => (is => 'ro', isa => 'ClassName', |
16
|
|
|
|
|
|
|
lazy => 1, builder => '_build_term_class', |
17
|
|
|
|
|
|
|
init_arg => undef, |
18
|
|
|
|
|
|
|
documentation => "dynamic class for terms"); |
19
|
|
|
|
|
|
|
|
20
|
|
|
|
|
|
|
has 'relType_class' => (is => 'ro', isa => 'ClassName', |
21
|
|
|
|
|
|
|
lazy => 1, builder => '_relType_class', |
22
|
|
|
|
|
|
|
init_arg => undef, |
23
|
|
|
|
|
|
|
documentation => "class for relTypes"); |
24
|
|
|
|
|
|
|
|
25
|
|
|
|
|
|
|
#====================================================================== |
26
|
|
|
|
|
|
|
# REQUIRED METHODS |
27
|
|
|
|
|
|
|
#====================================================================== |
28
|
|
|
|
|
|
|
|
29
|
|
|
|
|
|
|
requires 'search_terms'; |
30
|
|
|
|
|
|
|
requires 'fetch_term'; |
31
|
|
|
|
|
|
|
requires 'related'; |
32
|
|
|
|
|
|
|
requires 'rel_types'; |
33
|
|
|
|
|
|
|
requires 'fetch_rel_type'; |
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
requires 'do_transaction'; |
36
|
|
|
|
|
|
|
requires 'initialize'; |
37
|
|
|
|
|
|
|
requires 'store_rel_type'; |
38
|
|
|
|
|
|
|
requires 'store_relation'; |
39
|
|
|
|
|
|
|
requires 'store_term'; |
40
|
|
|
|
|
|
|
requires 'finalize'; |
41
|
|
|
|
|
|
|
|
42
|
|
|
|
|
|
|
requires '_params'; |
43
|
|
|
|
|
|
|
|
44
|
|
|
|
|
|
|
#====================================================================== |
45
|
|
|
|
|
|
|
# IMPLEMENTED METHODS |
46
|
|
|
|
|
|
|
#====================================================================== |
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
sub _build_term_class { |
49
|
3
|
|
|
3
|
|
6
|
my ($self) = @_; |
50
|
|
|
|
|
|
|
|
51
|
|
|
|
|
|
|
# compute subclass name from the list of possible relations |
52
|
3
|
|
|
|
|
11
|
my @rel_ids = $self->rel_types; |
53
|
3
|
|
|
|
|
25
|
my $subclass_name = join "_", "auto", sort @rel_ids; |
54
|
3
|
|
|
|
|
10
|
my $parent_class = $self->_parent_term_class; |
55
|
3
|
|
|
|
|
8
|
my $pkg_name = "${parent_class}::${subclass_name}"; |
56
|
|
|
|
|
|
|
|
57
|
|
|
|
|
|
|
# build subclass (only if it does not already exist) |
58
|
6
|
|
|
6
|
|
1825
|
no strict 'refs'; |
|
6
|
|
|
|
|
8
|
|
|
6
|
|
|
|
|
1429
|
|
59
|
3
|
100
|
|
|
|
32
|
unless (%{$pkg_name."::"}) { |
|
3
|
|
|
|
|
29
|
|
60
|
|
|
|
|
|
|
# build a closure for each relation type (NT, BT, etc.) |
61
|
2
|
|
|
|
|
2
|
my %methods; |
62
|
2
|
|
|
|
|
7
|
foreach my $rel_id (@rel_ids) { |
63
|
5
|
|
|
5
|
|
797
|
$methods{$rel_id} = sub {my $self = shift; |
|
|
|
|
5
|
|
|
|
|
|
|
|
5
|
|
|
|
|
|
|
|
5
|
|
|
|
|
|
|
|
5
|
|
|
|
|
|
|
|
5
|
|
|
|
|
|
|
|
5
|
|
|
|
|
|
|
|
5
|
|
|
|
|
|
|
|
5
|
|
|
|
|
|
|
|
5
|
|
|
|
|
|
|
|
5
|
|
|
|
64
|
5
|
|
|
|
|
19
|
my @rel = map {$_->[1]} $self->related($rel_id); |
|
14
|
|
|
|
|
23
|
|
65
|
20
|
100
|
|
|
|
47
|
return wantarray ? @rel : $rel[0];}; |
|
5
|
|
|
|
|
17
|
|
66
|
|
|
|
|
|
|
} |
67
|
|
|
|
|
|
|
|
68
|
|
|
|
|
|
|
# dynamically create a new subclass |
69
|
2
|
|
|
|
|
13
|
my $meta_subclass = Moose::Meta::Class->create( |
70
|
|
|
|
|
|
|
$pkg_name, |
71
|
|
|
|
|
|
|
superclasses => [$parent_class], |
72
|
|
|
|
|
|
|
methods => \%methods, |
73
|
|
|
|
|
|
|
); |
74
|
2
|
|
|
|
|
3730
|
$meta_subclass->make_immutable; |
75
|
|
|
|
|
|
|
} |
76
|
|
|
|
|
|
|
|
77
|
3
|
|
|
|
|
666
|
return $pkg_name; |
78
|
|
|
|
|
|
|
} |
79
|
|
|
|
|
|
|
|
80
|
|
|
|
|
|
|
|
81
|
|
|
|
|
|
|
|
82
|
|
|
|
|
|
|
sub _parent_term_class { |
83
|
3
|
|
|
3
|
|
6
|
my $self = shift; |
84
|
|
|
|
|
|
|
my $parent_term_class = $self->params->{term_class} |
85
|
3
|
|
50
|
|
|
161
|
|| 'Lingua::Thesaurus::Term'; |
86
|
3
|
|
|
|
|
22
|
Module::Load::load $parent_term_class; |
87
|
3
|
|
|
|
|
136
|
return $parent_term_class; |
88
|
|
|
|
|
|
|
} |
89
|
|
|
|
|
|
|
|
90
|
|
|
|
|
|
|
|
91
|
|
|
|
|
|
|
sub _relType_class { |
92
|
5
|
|
|
5
|
|
6
|
my $self = shift; |
93
|
|
|
|
|
|
|
my $relType_class = $self->params->{relType_class} |
94
|
5
|
|
50
|
|
|
176
|
|| 'Lingua::Thesaurus::RelType'; |
95
|
5
|
|
|
|
|
16
|
Module::Load::load $relType_class; |
96
|
5
|
|
|
|
|
225
|
return $relType_class; |
97
|
|
|
|
|
|
|
} |
98
|
|
|
|
|
|
|
|
99
|
|
|
|
|
|
|
1; |
100
|
|
|
|
|
|
|
|
101
|
|
|
|
|
|
|
__END__ |
102
|
|
|
|
|
|
|
|
103
|
|
|
|
|
|
|
=head1 NAME |
104
|
|
|
|
|
|
|
|
105
|
|
|
|
|
|
|
Lingua::Thesaurus::Storage - Role for thesaurus storage |
106
|
|
|
|
|
|
|
|
107
|
|
|
|
|
|
|
=head1 DESCRIPTION |
108
|
|
|
|
|
|
|
|
109
|
|
|
|
|
|
|
This role specifies the interface for thesaurus storage classes. |
110
|
|
|
|
|
|
|
|
111
|
|
|
|
|
|
|
|
112
|
|
|
|
|
|
|
=head1 METHODS |
113
|
|
|
|
|
|
|
|
114
|
|
|
|
|
|
|
=head2 Retrieval methods |
115
|
|
|
|
|
|
|
|
116
|
|
|
|
|
|
|
=head3 search_terms |
117
|
|
|
|
|
|
|
|
118
|
|
|
|
|
|
|
Implementation for L<Lingua::Thesaurus/"search_terms">. |
119
|
|
|
|
|
|
|
|
120
|
|
|
|
|
|
|
=head3 fetch_term |
121
|
|
|
|
|
|
|
|
122
|
|
|
|
|
|
|
Implementation for L<Lingua::Thesaurus/"fetch_term">. |
123
|
|
|
|
|
|
|
|
124
|
|
|
|
|
|
|
=head3 related |
125
|
|
|
|
|
|
|
|
126
|
|
|
|
|
|
|
Implementation for L<Lingua::Thesaurus::Term/"related">. |
127
|
|
|
|
|
|
|
|
128
|
|
|
|
|
|
|
=head3 rel_types |
129
|
|
|
|
|
|
|
|
130
|
|
|
|
|
|
|
Implementation for L<Lingua::Thesaurus/"rel_types">. |
131
|
|
|
|
|
|
|
|
132
|
|
|
|
|
|
|
=head3 fetch_rel_type |
133
|
|
|
|
|
|
|
|
134
|
|
|
|
|
|
|
Implementation for L<Lingua::Thesaurus/"fetch_rel_type">. |
135
|
|
|
|
|
|
|
|
136
|
|
|
|
|
|
|
|
137
|
|
|
|
|
|
|
=head2 Populating the database |
138
|
|
|
|
|
|
|
|
139
|
|
|
|
|
|
|
=head3 initialize |
140
|
|
|
|
|
|
|
|
141
|
|
|
|
|
|
|
Called by an IO class to initialize storage before a load operation. |
142
|
|
|
|
|
|
|
|
143
|
|
|
|
|
|
|
=head3 do_transaction |
144
|
|
|
|
|
|
|
|
145
|
|
|
|
|
|
|
$storage->do_transaction($coderef); |
146
|
|
|
|
|
|
|
|
147
|
|
|
|
|
|
|
Will execute C<$coderef> within a transaction. This is used |
148
|
|
|
|
|
|
|
by L<Lingua::Thesaurus::IO/"load"> to store all terms and relations |
149
|
|
|
|
|
|
|
in a single step. |
150
|
|
|
|
|
|
|
|
151
|
|
|
|
|
|
|
=head3 store_term |
152
|
|
|
|
|
|
|
|
153
|
|
|
|
|
|
|
my $term_id = $storage->store_term($term_string); |
154
|
|
|
|
|
|
|
|
155
|
|
|
|
|
|
|
Stores a new term, and returns the unique storage id for this |
156
|
|
|
|
|
|
|
term. Depending on the implementation, an exception could be raised if |
157
|
|
|
|
|
|
|
several attempts are made to store the same C<$term_string>. |
158
|
|
|
|
|
|
|
|
159
|
|
|
|
|
|
|
|
160
|
|
|
|
|
|
|
=head3 store_rel_type |
161
|
|
|
|
|
|
|
|
162
|
|
|
|
|
|
|
$storage->store_rel_type($rel_id, $description, $is_external); |
163
|
|
|
|
|
|
|
|
164
|
|
|
|
|
|
|
Stores a new relation type. |
165
|
|
|
|
|
|
|
|
166
|
|
|
|
|
|
|
=over |
167
|
|
|
|
|
|
|
|
168
|
|
|
|
|
|
|
=item * |
169
|
|
|
|
|
|
|
|
170
|
|
|
|
|
|
|
C<$rel_id> is a unique identifier string for this relation type |
171
|
|
|
|
|
|
|
(such as C<'NT'> or C<'UF'>). |
172
|
|
|
|
|
|
|
|
173
|
|
|
|
|
|
|
=item * |
174
|
|
|
|
|
|
|
|
175
|
|
|
|
|
|
|
C<$description> is an optional free text description |
176
|
|
|
|
|
|
|
|
177
|
|
|
|
|
|
|
=item * |
178
|
|
|
|
|
|
|
|
179
|
|
|
|
|
|
|
C<$is_external> is a boolean which tells whether related items |
180
|
|
|
|
|
|
|
will be other terms or external data. |
181
|
|
|
|
|
|
|
|
182
|
|
|
|
|
|
|
=back |
183
|
|
|
|
|
|
|
|
184
|
|
|
|
|
|
|
|
185
|
|
|
|
|
|
|
|
186
|
|
|
|
|
|
|
=head3 store_relation |
187
|
|
|
|
|
|
|
|
188
|
|
|
|
|
|
|
$storage->store_relation($term_id, $rel_id, $related, |
189
|
|
|
|
|
|
|
$is_external, $inverse_id); |
190
|
|
|
|
|
|
|
|
191
|
|
|
|
|
|
|
Stores a relation, where |
192
|
|
|
|
|
|
|
|
193
|
|
|
|
|
|
|
=over |
194
|
|
|
|
|
|
|
|
195
|
|
|
|
|
|
|
=item * |
196
|
|
|
|
|
|
|
|
197
|
|
|
|
|
|
|
C<$term_id> is the unique identifier for the first term in the relation |
198
|
|
|
|
|
|
|
|
199
|
|
|
|
|
|
|
=item * |
200
|
|
|
|
|
|
|
|
201
|
|
|
|
|
|
|
C<$rel_id> is the unique identifier for relation type |
202
|
|
|
|
|
|
|
|
203
|
|
|
|
|
|
|
=item * |
204
|
|
|
|
|
|
|
|
205
|
|
|
|
|
|
|
C<$related> is an arrayref of items to relate to the term; |
206
|
|
|
|
|
|
|
if C<$is_external> is true, these items can be any scalar; |
207
|
|
|
|
|
|
|
if C<$is_external> is false, items should be identifiers of other terms. |
208
|
|
|
|
|
|
|
|
209
|
|
|
|
|
|
|
The storage should preserve the order of items in C<$related>, i.e. |
210
|
|
|
|
|
|
|
the L</"related"> method should return items in the same order. |
211
|
|
|
|
|
|
|
|
212
|
|
|
|
|
|
|
=item * |
213
|
|
|
|
|
|
|
|
214
|
|
|
|
|
|
|
C<$is_external> is a boolean which tells what kind of items |
215
|
|
|
|
|
|
|
are related, as explained above |
216
|
|
|
|
|
|
|
|
217
|
|
|
|
|
|
|
=item * |
218
|
|
|
|
|
|
|
|
219
|
|
|
|
|
|
|
C<$inverse_id> is the optional identifier of the inverse |
220
|
|
|
|
|
|
|
relation type; if non-null, relations will be stored in both |
221
|
|
|
|
|
|
|
directions. |
222
|
|
|
|
|
|
|
|
223
|
|
|
|
|
|
|
=back |
224
|
|
|
|
|
|
|
|
225
|
|
|
|
|
|
|
|
226
|
|
|
|
|
|
|
=head3 finalize |
227
|
|
|
|
|
|
|
|
228
|
|
|
|
|
|
|
Will be called by IO classes after loading files. |
229
|
|
|
|
|
|
|
Storage implementations may use this to perform cleanup operations if needed. |