line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package SKOS::Simple; |
2
|
|
|
|
|
|
|
{ |
3
|
|
|
|
|
|
|
$SKOS::Simple::VERSION = '0.09_01'; |
4
|
|
|
|
|
|
|
} |
5
|
|
|
|
|
|
|
#ABSTRACT: Create simple SKOS data with entailment |
6
|
|
|
|
|
|
|
|
7
|
5
|
|
|
5
|
|
65924
|
use strict; |
|
5
|
|
|
|
|
13
|
|
|
5
|
|
|
|
|
212
|
|
8
|
5
|
|
|
5
|
|
28
|
use warnings; |
|
5
|
|
|
|
|
11
|
|
|
5
|
|
|
|
|
171
|
|
9
|
|
|
|
|
|
|
|
10
|
5
|
|
|
5
|
|
31
|
use Scalar::Util qw(blessed reftype); |
|
5
|
|
|
|
|
25
|
|
|
5
|
|
|
|
|
532
|
|
11
|
5
|
|
|
5
|
|
4500
|
use Turtle::Writer; |
|
5
|
|
|
|
|
5067
|
|
|
5
|
|
|
|
|
353
|
|
12
|
5
|
|
|
5
|
|
32
|
use Carp; |
|
5
|
|
|
|
|
13
|
|
|
5
|
|
|
|
|
271
|
|
13
|
|
|
|
|
|
|
|
14
|
|
|
|
|
|
|
=head1 DESCRIPTION |
15
|
|
|
|
|
|
|
|
16
|
|
|
|
|
|
|
This module provides a simple class to create and handle classifications, |
17
|
|
|
|
|
|
|
thesauri and similar systems in Simple Knowledge Organization System (SKOS) |
18
|
|
|
|
|
|
|
data model. Most features of SKOS, as specified at |
19
|
|
|
|
|
|
|
L, are supported. In addition there |
20
|
|
|
|
|
|
|
are some useful constraints, which mostly derive from best-practice. |
21
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
In contrast to other RDF-related modules, SKOS::Simple does not depend on |
23
|
|
|
|
|
|
|
any non-core Perl modules, so you can install it by just copying one file. |
24
|
|
|
|
|
|
|
The module implements basic entailment rules of the SKOS standard without |
25
|
|
|
|
|
|
|
the burden of a full RDF reasoning engine. Actually, you can use this |
26
|
|
|
|
|
|
|
module without having to deal with any details of RDF. |
27
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
The current version of this class is optimized form creating and serializing |
29
|
|
|
|
|
|
|
valid SKOS schemes, but not for reading and modifying them. A common use case |
30
|
|
|
|
|
|
|
of SKOS::Simple is to transform a given terminology from some custom format |
31
|
|
|
|
|
|
|
to SKOS, which is then L in Terse RDF |
32
|
|
|
|
|
|
|
Triple language (Turtle). You can then publish the Turtle data and/or process |
33
|
|
|
|
|
|
|
them with general RDF and SKOS tools. |
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
=head1 SYNOPSIS |
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
my $skos = SKOS::Simple->new( |
38
|
|
|
|
|
|
|
base => 'http://example.com/kos/', |
39
|
|
|
|
|
|
|
title => 'My little Knowledge Organization System', |
40
|
|
|
|
|
|
|
hierarchy => 'tree' # check classification constraints |
41
|
|
|
|
|
|
|
); |
42
|
|
|
|
|
|
|
|
43
|
|
|
|
|
|
|
$skos->addConcept( pref => { en => 'foo', ru => 'baz' } ); |
44
|
|
|
|
|
|
|
$skos->addConcept( notation => '42.X-23' ); |
45
|
|
|
|
|
|
|
|
46
|
|
|
|
|
|
|
print $skos->turtle; |
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
=cut |
49
|
|
|
|
|
|
|
|
50
|
5
|
|
|
5
|
|
26
|
use base 'Exporter'; |
|
5
|
|
|
|
|
9
|
|
|
5
|
|
|
|
|
29191
|
|
51
|
|
|
|
|
|
|
our @EXPORT_OK = qw(skos); |
52
|
|
|
|
|
|
|
|
53
|
|
|
|
|
|
|
our %NAMESPACES = ( |
54
|
|
|
|
|
|
|
rdf => 'http://www.w3.org/1999/02/22-rdf-syntax-ns#', |
55
|
|
|
|
|
|
|
skos => 'http://www.w3.org/2004/02/skos/core#', |
56
|
|
|
|
|
|
|
dc => 'http://purl.org/dc/elements/1.1/', |
57
|
|
|
|
|
|
|
foaf => 'http://xmlns.com/foaf/0.1/', |
58
|
|
|
|
|
|
|
void => 'http://rdfs.org/ns/void#', |
59
|
|
|
|
|
|
|
dct => 'http://purl.org/dc/terms/', |
60
|
|
|
|
|
|
|
xsd => 'http://www.w3.org/2001/XMLSchema#', |
61
|
|
|
|
|
|
|
skosxl => 'http://www.w3.org/2008/05/skos-xl#', |
62
|
|
|
|
|
|
|
owl => 'http://www.w3.org/2002/07/owl#', |
63
|
|
|
|
|
|
|
); |
64
|
|
|
|
|
|
|
|
65
|
|
|
|
|
|
|
=head1 SKOS CONFORMANCE |
66
|
|
|
|
|
|
|
|
67
|
|
|
|
|
|
|
The following classes and properties from the SKOS vocabulary are supported. |
68
|
|
|
|
|
|
|
The numbers in brackets (B<[Sxx]>) refer to integrity conditions from the |
69
|
|
|
|
|
|
|
SKOS specification. Additional constraints are marked by numbers like B<[Cxx]>. |
70
|
|
|
|
|
|
|
|
71
|
|
|
|
|
|
|
=over 4 |
72
|
|
|
|
|
|
|
|
73
|
|
|
|
|
|
|
=item L |
74
|
|
|
|
|
|
|
|
75
|
|
|
|
|
|
|
Instances of C B<[S1]> are not represented as objects but as |
76
|
|
|
|
|
|
|
parts of a SKOS::Simple object, so every Concepts must belong to a Concept |
77
|
|
|
|
|
|
|
Scheme B<[C1]>. You can attach Concepts to a scheme with L. |
78
|
|
|
|
|
|
|
|
79
|
|
|
|
|
|
|
=item L |
80
|
|
|
|
|
|
|
|
81
|
|
|
|
|
|
|
Instances of C are implemented as objects of type |
82
|
|
|
|
|
|
|
SKOS::Simple B<[S2]>. Concepts added to a scheme are automatically connected |
83
|
|
|
|
|
|
|
to the scheme via C B<[S3-S4]> (only serialized if requested). |
84
|
|
|
|
|
|
|
Concepts can be selected as top concepts (C / |
85
|
|
|
|
|
|
|
C B<[S5-S8]>). In contrast to the SKOS specification, |
86
|
|
|
|
|
|
|
(L) the top concepts |
87
|
|
|
|
|
|
|
of a scheme cannot have broader concepts in the same scheme B<[C2]>. |
88
|
|
|
|
|
|
|
|
89
|
|
|
|
|
|
|
Concepts and concept schemes must be disjoint B<[S9]>. This is ensured only |
90
|
|
|
|
|
|
|
if you do not use a C but a C parameter. |
91
|
|
|
|
|
|
|
|
92
|
|
|
|
|
|
|
=item L |
93
|
|
|
|
|
|
|
|
94
|
|
|
|
|
|
|
The label types C, C, and C |
95
|
|
|
|
|
|
|
are supported. In addition this module supports the label properties |
96
|
|
|
|
|
|
|
C and C, which are not explicitly included in the |
97
|
|
|
|
|
|
|
SKOS reference. |
98
|
|
|
|
|
|
|
|
99
|
|
|
|
|
|
|
C as super-property of C, C, |
100
|
|
|
|
|
|
|
and C will be supported in a later version. |
101
|
|
|
|
|
|
|
|
102
|
|
|
|
|
|
|
=item L |
103
|
|
|
|
|
|
|
|
104
|
|
|
|
|
|
|
Notations (C) must be unique per concept and scheme |
105
|
|
|
|
|
|
|
B<[C3]>. |
106
|
|
|
|
|
|
|
|
107
|
|
|
|
|
|
|
=cut |
108
|
|
|
|
|
|
|
|
109
|
|
|
|
|
|
|
our %LABEL_PROPERTIES = map { $_ => 1 } qw(prefLabel altLabel hiddenLabel); |
110
|
|
|
|
|
|
|
|
111
|
|
|
|
|
|
|
our %LABEL_TYPES = ( |
112
|
|
|
|
|
|
|
pref => 'skos:prefLabel', # TODO: sub-property of rdfs:label |
113
|
|
|
|
|
|
|
alt => 'skos:altLabel', # dito |
114
|
|
|
|
|
|
|
hidden => 'skos:hiddenLabel', # dito |
115
|
|
|
|
|
|
|
title => 'dc:title' |
116
|
|
|
|
|
|
|
); |
117
|
|
|
|
|
|
|
|
118
|
|
|
|
|
|
|
=item L |
119
|
|
|
|
|
|
|
|
120
|
|
|
|
|
|
|
So called "semantic" relations (C) include |
121
|
|
|
|
|
|
|
C, C, and C. |
122
|
|
|
|
|
|
|
|
123
|
|
|
|
|
|
|
The C and C are currently |
124
|
|
|
|
|
|
|
not supported. |
125
|
|
|
|
|
|
|
|
126
|
|
|
|
|
|
|
With this module you can only model semantic relations between concepts |
127
|
|
|
|
|
|
|
in the same scheme. |
128
|
|
|
|
|
|
|
|
129
|
|
|
|
|
|
|
=cut |
130
|
|
|
|
|
|
|
|
131
|
|
|
|
|
|
|
our %RELATION_PROPERTIES = map { $_ => 1 } qw(semanticRelation |
132
|
|
|
|
|
|
|
broader narrower related broaderTransitive narrowerTransitive); |
133
|
|
|
|
|
|
|
|
134
|
|
|
|
|
|
|
=item L |
135
|
|
|
|
|
|
|
|
136
|
|
|
|
|
|
|
C, C, C, C, |
137
|
|
|
|
|
|
|
C, C and C can be used to |
138
|
|
|
|
|
|
|
document concepts. In contrast to the SKOS specification their range is |
139
|
|
|
|
|
|
|
limited to literal values B<[C4]>. |
140
|
|
|
|
|
|
|
|
141
|
|
|
|
|
|
|
=cut |
142
|
|
|
|
|
|
|
|
143
|
|
|
|
|
|
|
our %NOTE_PROPERTIES = map { $_ => 1 } qw(note |
144
|
|
|
|
|
|
|
changeNote definition editorialNote example historyNote scopeNote); |
145
|
|
|
|
|
|
|
|
146
|
|
|
|
|
|
|
=back |
147
|
|
|
|
|
|
|
|
148
|
|
|
|
|
|
|
Concept Collections (C, C, |
149
|
|
|
|
|
|
|
C, C) and SKOS extension for labels |
150
|
|
|
|
|
|
|
(C etc.) are not supported. Mapping Properties |
151
|
|
|
|
|
|
|
(C, C, C, |
152
|
|
|
|
|
|
|
C, C, C) will |
153
|
|
|
|
|
|
|
probably be implemented in another module. |
154
|
|
|
|
|
|
|
|
155
|
|
|
|
|
|
|
=cut |
156
|
|
|
|
|
|
|
|
157
|
|
|
|
|
|
|
our %MAPPING_PROPERTIES = map { $_ => 1 } qw(mappingRelation |
158
|
|
|
|
|
|
|
closeMatch exactMatch broadMatch narrowMatch relatedMatch); |
159
|
|
|
|
|
|
|
|
160
|
|
|
|
|
|
|
# dublin core elements |
161
|
|
|
|
|
|
|
our %DC_PROPERTIES = map { $_ => "dc:$_" } |
162
|
|
|
|
|
|
|
qw(contributor coverage creator date description format identifier |
163
|
|
|
|
|
|
|
language publisher relation rights source subject title type); |
164
|
|
|
|
|
|
|
|
165
|
|
|
|
|
|
|
# To add RDF data beyond the SKOS data model, you can use the |
166
|
|
|
|
|
|
|
# L. |
167
|
|
|
|
|
|
|
|
168
|
|
|
|
|
|
|
=head1 ADDITIONAL CONSTRAINTS |
169
|
|
|
|
|
|
|
|
170
|
|
|
|
|
|
|
The current version of this module aims at classifications. |
171
|
|
|
|
|
|
|
Support for thesauri will be implemented later. |
172
|
|
|
|
|
|
|
|
173
|
|
|
|
|
|
|
An instance of SKOS::Simple holds exactely one skos:ConceptScheme with |
174
|
|
|
|
|
|
|
the following properties: |
175
|
|
|
|
|
|
|
|
176
|
|
|
|
|
|
|
=over 4 |
177
|
|
|
|
|
|
|
|
178
|
|
|
|
|
|
|
=item * |
179
|
|
|
|
|
|
|
|
180
|
|
|
|
|
|
|
All concepts share a common URI base. By default this common prefix is |
181
|
|
|
|
|
|
|
also the URI of the concept scheme as whole. |
182
|
|
|
|
|
|
|
|
183
|
|
|
|
|
|
|
=item * |
184
|
|
|
|
|
|
|
|
185
|
|
|
|
|
|
|
All concepts must be identifyable by a unique string, that is refered |
186
|
|
|
|
|
|
|
to as the concept identifier. The URI of a concept is build of the |
187
|
|
|
|
|
|
|
common URI prefix and the concept's identifier. The identifier must |
188
|
|
|
|
|
|
|
either be the skos:notation (so every concept must have one), or the |
189
|
|
|
|
|
|
|
skos:prefLabel in one fixed language for all concepts. The only exception |
190
|
|
|
|
|
|
|
to this rule are filters, for instance to uri-encode the prefLabel/notation. |
191
|
|
|
|
|
|
|
|
192
|
|
|
|
|
|
|
=item * |
193
|
|
|
|
|
|
|
|
194
|
|
|
|
|
|
|
Empty strings as literal values are ignored. In most cases you can use |
195
|
|
|
|
|
|
|
C and C<""> interchangeably. |
196
|
|
|
|
|
|
|
|
197
|
|
|
|
|
|
|
=item * |
198
|
|
|
|
|
|
|
|
199
|
|
|
|
|
|
|
All notations have the same Datatype URI (this may be changed). |
200
|
|
|
|
|
|
|
|
201
|
|
|
|
|
|
|
=item * |
202
|
|
|
|
|
|
|
|
203
|
|
|
|
|
|
|
The range of all documentation properties (C, C, |
204
|
|
|
|
|
|
|
C etc.) is the plain literals instead of any resource. |
205
|
|
|
|
|
|
|
|
206
|
|
|
|
|
|
|
=item * |
207
|
|
|
|
|
|
|
|
208
|
|
|
|
|
|
|
I<...sure there are some more limitations...> |
209
|
|
|
|
|
|
|
|
210
|
|
|
|
|
|
|
=back |
211
|
|
|
|
|
|
|
|
212
|
|
|
|
|
|
|
=head1 METHODS |
213
|
|
|
|
|
|
|
|
214
|
|
|
|
|
|
|
=head2 new( [ %properties ] ) |
215
|
|
|
|
|
|
|
|
216
|
|
|
|
|
|
|
Creates a new concept scheme with the following properties: |
217
|
|
|
|
|
|
|
|
218
|
|
|
|
|
|
|
=over 4 |
219
|
|
|
|
|
|
|
|
220
|
|
|
|
|
|
|
=item base |
221
|
|
|
|
|
|
|
|
222
|
|
|
|
|
|
|
The URI prefix that is used for all concepts (not required but recommended). |
223
|
|
|
|
|
|
|
|
224
|
|
|
|
|
|
|
=item scheme |
225
|
|
|
|
|
|
|
|
226
|
|
|
|
|
|
|
The URI of the whole concept scheme (C). |
227
|
|
|
|
|
|
|
By default the C property is used as concept scheme URI. |
228
|
|
|
|
|
|
|
|
229
|
|
|
|
|
|
|
=item title |
230
|
|
|
|
|
|
|
|
231
|
|
|
|
|
|
|
Title(s) of the concept scheme. Must be either a string or a |
232
|
|
|
|
|
|
|
hash that maps language tags to strings. |
233
|
|
|
|
|
|
|
|
234
|
|
|
|
|
|
|
=item namespaces |
235
|
|
|
|
|
|
|
|
236
|
|
|
|
|
|
|
An optional hash with additional namespaces. You can also override standard |
237
|
|
|
|
|
|
|
namespaces (e.g. C). All namespaces explicitly specified by this |
238
|
|
|
|
|
|
|
parameter are always included as C<< @prefix >> in the Turtle output. |
239
|
|
|
|
|
|
|
|
240
|
|
|
|
|
|
|
=item language |
241
|
|
|
|
|
|
|
|
242
|
|
|
|
|
|
|
Language tag of the default language. By default set to C. |
243
|
|
|
|
|
|
|
|
244
|
|
|
|
|
|
|
=item hierarchy |
245
|
|
|
|
|
|
|
|
246
|
|
|
|
|
|
|
Either C or C or the empty string for no hierarchy check |
247
|
|
|
|
|
|
|
(default). At the moment only C is supported. |
248
|
|
|
|
|
|
|
|
249
|
|
|
|
|
|
|
=item identity |
250
|
|
|
|
|
|
|
|
251
|
|
|
|
|
|
|
Specifies which property is used as concept identifier. Possible |
252
|
|
|
|
|
|
|
values are C |
253
|
|
|
|
|
|
|
and C (C). If no value is given, you must |
254
|
|
|
|
|
|
|
either specify C |
255
|
|
|
|
|
|
|
|
256
|
|
|
|
|
|
|
=item label |
257
|
|
|
|
|
|
|
|
258
|
|
|
|
|
|
|
Specifies how to encode concept labels. Possible values are C |
259
|
|
|
|
|
|
|
(C), which is the default value and implied if |
260
|
|
|
|
|
|
|
C<< identify => 'label' >>, C (C, |
261
|
|
|
|
|
|
|
C (C) and C (C). |
262
|
|
|
|
|
|
|
|
263
|
|
|
|
|
|
|
=item notation |
264
|
|
|
|
|
|
|
|
265
|
|
|
|
|
|
|
Specifies whether to check notations to be unique (C) and/or |
266
|
|
|
|
|
|
|
mandatory (C) per concept. C<< identity => 'notation' >> |
267
|
|
|
|
|
|
|
implies C<< notation => 'unique' >>. |
268
|
|
|
|
|
|
|
|
269
|
|
|
|
|
|
|
=item properties |
270
|
|
|
|
|
|
|
|
271
|
|
|
|
|
|
|
Additional properties as structured Turtle. Triples with predicates |
272
|
|
|
|
|
|
|
C, C, and C are not allowed but removed. |
273
|
|
|
|
|
|
|
|
274
|
|
|
|
|
|
|
=item description |
275
|
|
|
|
|
|
|
|
276
|
|
|
|
|
|
|
not supported yet. |
277
|
|
|
|
|
|
|
|
278
|
|
|
|
|
|
|
=back |
279
|
|
|
|
|
|
|
|
280
|
|
|
|
|
|
|
=cut |
281
|
|
|
|
|
|
|
|
282
|
|
|
|
|
|
|
sub new { |
283
|
15
|
|
|
15
|
1
|
12780
|
my $class = shift; |
284
|
15
|
|
|
|
|
54
|
my (%arg) = @_; |
285
|
|
|
|
|
|
|
|
286
|
|
|
|
|
|
|
my $self = bless( { |
287
|
|
|
|
|
|
|
concepts => { }, |
288
|
|
|
|
|
|
|
|
289
|
|
|
|
|
|
|
prop => { }, |
290
|
|
|
|
|
|
|
related => { }, |
291
|
|
|
|
|
|
|
top => { }, # ids of top concepts |
292
|
|
|
|
|
|
|
|
293
|
|
|
|
|
|
|
u_notation => { }, |
294
|
|
|
|
|
|
|
u_label => { }, |
295
|
|
|
|
|
|
|
|
296
|
|
|
|
|
|
|
hierarchy => ($arg{hierarchy} || ""), # tree|thesaurus| |
297
|
|
|
|
|
|
|
base => ($arg{base} || ""), |
298
|
|
|
|
|
|
|
scheme => ($arg{scheme} || ""), |
299
|
|
|
|
|
|
|
title => ($arg{title} || ""), |
300
|
|
|
|
|
|
|
namespaces => ($arg{namespaces} || { }), # TODO: count usage (?) |
301
|
|
|
|
|
|
|
language => ($arg{language} || "en"), # TODO: check tag |
302
|
|
|
|
|
|
|
description => ($arg{description} || ""), # TODO: add |
303
|
|
|
|
|
|
|
|
304
|
12
|
|
|
12
|
|
33
|
idescape => $arg{idescape} || sub { $_[0]; }, # TODO: uri-escape |
305
|
|
|
|
|
|
|
|
306
|
15
|
|
50
|
|
|
2232
|
identity => ($arg{identity} || ""), |
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
100
|
|
|
|
|
307
|
|
|
|
|
|
|
label => ($arg{label} || ""), # label type |
308
|
|
|
|
|
|
|
notation => ($arg{notation} || ""), |
309
|
|
|
|
|
|
|
|
310
|
|
|
|
|
|
|
}, $class ); |
311
|
|
|
|
|
|
|
|
312
|
|
|
|
|
|
|
# TODO: croak "base of scheme missing" unless $self->{base}; |
313
|
15
|
50
|
|
|
|
73
|
croak "base must be an URI" unless uri_or_empty($self->{base}); |
314
|
15
|
50
|
|
|
|
48
|
croak "scheme must be an URI" unless uri_or_empty($self->{scheme}); |
315
|
15
|
100
|
|
|
|
64
|
$self->{scheme} = "" if $self->{scheme} eq $self->{base}; |
316
|
|
|
|
|
|
|
|
317
|
|
|
|
|
|
|
#### identifier, label, notation |
318
|
|
|
|
|
|
|
|
319
|
15
|
100
|
|
|
|
46
|
if ( !$self->{identity} ) { |
|
3
|
50
|
|
|
|
14
|
|
320
|
14
|
50
|
|
|
|
55
|
if ( $self->{label} eq 'unique' ) { |
|
|
100
|
|
|
|
|
|
321
|
0
|
|
|
|
|
0
|
$self->{identity} = 'label'; |
322
|
|
|
|
|
|
|
} elsif ( $self->{notation} eq 'unique' ) { |
323
|
2
|
|
|
|
|
7
|
$self->{identity} = 'notation'; |
324
|
|
|
|
|
|
|
} else { |
325
|
|
|
|
|
|
|
# TODO: do we want this? |
326
|
12
|
|
|
|
|
28
|
$self->{identity} = 'label'; |
327
|
|
|
|
|
|
|
# croak "concept identification not specified"; |
328
|
|
|
|
|
|
|
} |
329
|
|
|
|
|
|
|
} elsif ( !(grep { $self->{identity} eq $_ } qw(label notation identifier)) ) { |
330
|
0
|
|
|
|
|
0
|
croak "concept identification must be 'label', 'notation', or 'identifier'"; |
331
|
|
|
|
|
|
|
} # NOTE: we may add 'id' (internal id) as another method |
332
|
|
|
|
|
|
|
|
333
|
15
|
50
|
|
|
|
38
|
if ( $self->{label} ) { |
334
|
0
|
|
|
|
|
0
|
croak "label type must be one of " . join(", ", keys %LABEL_TYPES) |
335
|
0
|
0
|
|
|
|
0
|
unless ( grep { $self->{label} eq $_ } keys %LABEL_TYPES ); |
336
|
|
|
|
|
|
|
} else { |
337
|
15
|
|
|
|
|
34
|
$self->{label} = 'pref'; |
338
|
|
|
|
|
|
|
} |
339
|
|
|
|
|
|
|
|
340
|
15
|
100
|
|
|
|
40
|
if ( $self->{notation} ) { |
341
|
4
|
|
|
|
|
16
|
croak "notation type can only be 'unique' or 'mandatory'" |
342
|
2
|
50
|
|
|
|
5
|
unless ( grep { $self->{notation} eq $_ } qw(unique mandatory) ); |
343
|
|
|
|
|
|
|
} |
344
|
|
|
|
|
|
|
|
345
|
|
|
|
|
|
|
# mandatory namespaces |
346
|
|
|
|
|
|
|
|
347
|
15
|
100
|
|
|
|
74
|
$self->{namespaces}->{skos} = $NAMESPACES{skos} |
348
|
|
|
|
|
|
|
unless $self->{namespaces}->{skos}; |
349
|
|
|
|
|
|
|
|
350
|
15
|
50
|
33
|
|
|
54
|
$self->{namespaces}->{void} = $NAMESPACES{void} |
351
|
|
|
|
|
|
|
if ( $arg{void} and not $self->{namespaces}->{void} ); |
352
|
|
|
|
|
|
|
|
353
|
15
|
100
|
66
|
|
|
106
|
$self->{namespaces}->{dc} = $NAMESPACES{dc} |
|
|
|
100
|
|
|
|
|
354
|
|
|
|
|
|
|
if ( ($self->{title} || $self->{description}) && not $self->{namespaces}->{dc}); |
355
|
|
|
|
|
|
|
|
356
|
|
|
|
|
|
|
# Add default language, if title without language given |
357
|
15
|
|
|
|
|
25
|
my $lang = $self->{language}; |
358
|
15
|
100
|
66
|
|
|
63
|
if ($self->{title} && not ref($self->{title}) && $lang) { |
|
|
|
100
|
|
|
|
|
359
|
2
|
|
|
|
|
7
|
$self->{title} = { $lang => $self->{title} }; |
360
|
|
|
|
|
|
|
} |
361
|
|
|
|
|
|
|
|
362
|
15
|
|
|
|
|
41
|
my @types = ('skos:ConceptScheme'); |
363
|
|
|
|
|
|
|
|
364
|
15
|
50
|
|
|
|
48
|
if ( my $pattern = delete $arg{idpattern} ) { |
365
|
0
|
|
|
|
|
0
|
$self->{idregexp} = qr/^$pattern$/; |
366
|
0
|
|
|
|
|
0
|
my $basepattern = $self->{base}; |
367
|
0
|
|
|
|
|
0
|
$basepattern =~ s/[.]/\\./g; |
368
|
0
|
|
|
|
|
0
|
$basepattern =~ s/[?]/\\?/g; # TODO: escape more nasty stuff in base URI |
369
|
0
|
|
|
|
|
0
|
$self->{idpattern} = "^$basepattern$pattern\$"; |
370
|
|
|
|
|
|
|
} |
371
|
|
|
|
|
|
|
|
372
|
|
|
|
|
|
|
# TODO: license (dct:license) |
373
|
|
|
|
|
|
|
|
374
|
15
|
50
|
|
|
|
39
|
if ( $arg{void} ) { |
375
|
0
|
|
|
|
|
0
|
$self->{void} = 1; # TODO: document this |
376
|
0
|
0
|
|
|
|
0
|
push @types, 'void:Dataset' if $arg{void}; |
377
|
0
|
|
|
|
|
0
|
$self->{prop}->{'void:uriSpace'} = turtle_uri($self->{base}); |
378
|
0
|
|
|
|
|
0
|
$self->{prop}->{'void:rootResource'} = turtle_uri($self->{base}); |
379
|
0
|
0
|
|
|
|
0
|
if ( $self->{idpattern} ) { |
380
|
0
|
|
|
|
|
0
|
$self->{prop}->{'void:uriRegexPattern'} = turtle_literal($self->{idpattern}); |
381
|
|
|
|
|
|
|
} |
382
|
|
|
|
|
|
|
} |
383
|
|
|
|
|
|
|
|
384
|
|
|
|
|
|
|
# TODO: allow additional types |
385
|
|
|
|
|
|
|
|
386
|
15
|
|
|
|
|
47
|
$self->{prop}->{a} = \@types; |
387
|
|
|
|
|
|
|
|
388
|
|
|
|
|
|
|
# additional properties |
389
|
15
|
100
|
|
|
|
56
|
if ( $arg{properties} ) { |
390
|
1
|
|
|
|
|
3
|
my $p = $arg{properties}; |
391
|
1
|
|
|
|
|
3
|
my $a = delete $p->{a}; |
392
|
|
|
|
|
|
|
|
393
|
|
|
|
|
|
|
# TODO: also filter other namespaces and full URI forms |
394
|
1
|
|
|
|
|
4
|
my @s = grep { $_ =~ /skos:/ } keys %$p; |
|
2
|
|
|
|
|
9
|
|
395
|
1
|
|
|
|
|
5
|
delete $p->{$_} for @s; |
396
|
|
|
|
|
|
|
|
397
|
1
|
|
|
|
|
7
|
while ( my ($key, $value) = each %$p ) { |
398
|
1
|
|
|
|
|
6
|
$self->{prop}->{$key} = $value; |
399
|
|
|
|
|
|
|
} |
400
|
|
|
|
|
|
|
} |
401
|
|
|
|
|
|
|
|
402
|
15
|
100
|
|
|
|
80
|
$self->{prop}->{'dc:title'} = |
403
|
|
|
|
|
|
|
$self->{title} eq '' ? '' : turtle_literal_list( $self->{title} ); |
404
|
|
|
|
|
|
|
|
405
|
15
|
|
50
|
|
|
205
|
my $page = (delete $arg{page} || ""); |
406
|
|
|
|
|
|
|
|
407
|
15
|
50
|
|
|
|
63
|
$self->{prop}->{'foaf:page'} = |
408
|
|
|
|
|
|
|
$page eq '' ? '' : turtle_uri( $page ); |
409
|
|
|
|
|
|
|
|
410
|
15
|
50
|
33
|
|
|
46
|
$self->{namespaces}->{foaf} = $NAMESPACES{foaf} |
411
|
|
|
|
|
|
|
if ( $page ne "" and not $self->{namespaces}->{foaf} ); |
412
|
|
|
|
|
|
|
|
413
|
15
|
|
|
|
|
86
|
return $self; |
414
|
|
|
|
|
|
|
} |
415
|
|
|
|
|
|
|
|
416
|
|
|
|
|
|
|
sub _values { |
417
|
|
|
|
|
|
|
# TODO: also allow hashref (?) |
418
|
70
|
50
|
33
|
70
|
|
108
|
my @values = map { (reftype($_) && reftype($_) eq 'ARRAY') ? @$_ : $_ } @_; |
|
70
|
|
|
|
|
321
|
|
419
|
70
|
100
|
|
|
|
109
|
@values = grep { $_ and $_ ne '' } @values; |
|
70
|
|
|
|
|
825
|
|
420
|
70
|
|
|
|
|
134
|
return @values; |
421
|
|
|
|
|
|
|
} |
422
|
|
|
|
|
|
|
|
423
|
|
|
|
|
|
|
=head2 addConcept ( %properties ) |
424
|
|
|
|
|
|
|
|
425
|
|
|
|
|
|
|
Adds a concept with given properties. Only the identifying property to be |
426
|
|
|
|
|
|
|
used as concept id (C, C |
427
|
|
|
|
|
|
|
mandatory. If there already is a concept with the same id, both are merged! |
428
|
|
|
|
|
|
|
|
429
|
|
|
|
|
|
|
Returns the id of the added or modfied concept. |
430
|
|
|
|
|
|
|
|
431
|
|
|
|
|
|
|
=cut |
432
|
|
|
|
|
|
|
|
433
|
|
|
|
|
|
|
sub addConcept { |
434
|
7
|
|
|
7
|
1
|
2180
|
my $self = shift; |
435
|
|
|
|
|
|
|
|
436
|
|
|
|
|
|
|
# ensures we have an 'id' and 'label' is a hashref |
437
|
7
|
|
|
|
|
29
|
my $arg = $self->conceptentification( @_ ); |
438
|
7
|
|
|
|
|
15
|
my $id = $arg->{id}; |
439
|
7
|
|
|
|
|
15
|
my $lang = $self->{language}; |
440
|
|
|
|
|
|
|
|
441
|
|
|
|
|
|
|
# TODO: check: Concepts and concept schemes must be disjoint [S9]. |
442
|
|
|
|
|
|
|
|
443
|
|
|
|
|
|
|
# only for internal use |
444
|
7
|
|
|
|
|
14
|
my $nocheck = delete $arg->{_nocheck}; |
445
|
|
|
|
|
|
|
|
446
|
|
|
|
|
|
|
# connections to other concepts |
447
|
7
|
|
|
|
|
26
|
my @related = _values( delete $arg->{related} ); |
448
|
7
|
|
|
|
|
20
|
my @broader = _values( delete $arg->{broader} ); |
449
|
7
|
|
|
|
|
22
|
my @narrower = _values( delete $arg->{narrower} ); |
450
|
|
|
|
|
|
|
|
451
|
7
|
|
|
|
|
19
|
my $concept = $self->{concepts}->{$id}; |
452
|
7
|
100
|
|
|
|
28
|
unless ($self->{concepts}->{$id}) { |
453
|
5
|
|
|
|
|
38
|
$concept = $self->{concepts}->{$id} = { |
454
|
|
|
|
|
|
|
notation => "", |
455
|
|
|
|
|
|
|
broader => { }, |
456
|
|
|
|
|
|
|
narrower => { }, |
457
|
|
|
|
|
|
|
related => { }, |
458
|
|
|
|
|
|
|
}; |
459
|
|
|
|
|
|
|
} |
460
|
|
|
|
|
|
|
|
461
|
7
|
|
|
|
|
19
|
my $notation = delete $arg->{notation}; |
462
|
7
|
100
|
|
|
|
26
|
$notation = "" unless defined $notation; |
463
|
|
|
|
|
|
|
|
464
|
7
|
|
|
|
|
16
|
my $identifier = delete $arg->{identifier}; |
465
|
7
|
50
|
|
|
|
35
|
if ( defined $identifier ) { |
466
|
0
|
|
|
|
|
0
|
$concept->{identifier} = $identifier; |
467
|
0
|
|
|
|
|
0
|
$self->{uses_dc} = 1; |
468
|
|
|
|
|
|
|
} |
469
|
|
|
|
|
|
|
|
470
|
7
|
100
|
|
|
|
22
|
if ( $self->{notation} ) { # 'mandatory' or 'unique' |
471
|
6
|
50
|
33
|
|
|
37
|
$concept->{notation} = $notation |
472
|
|
|
|
|
|
|
if ( defined $notation and $notation ne '' ); |
473
|
6
|
50
|
|
|
|
16
|
croak 'Concepts must have a notation' |
474
|
|
|
|
|
|
|
if $concept->{notation} eq ''; |
475
|
6
|
50
|
|
|
|
21
|
if ( $self->{notation} eq 'unique' ) { |
476
|
|
|
|
|
|
|
# TODO: check uniqueness, if notation is not already the idtype |
477
|
|
|
|
|
|
|
# croak 'Concepts must be unique per notation' |
478
|
|
|
|
|
|
|
# if $self->{u_notation}->{ $notation }; |
479
|
|
|
|
|
|
|
# $self->{u_notation}->{ $notation } = $id; |
480
|
|
|
|
|
|
|
} |
481
|
|
|
|
|
|
|
} |
482
|
7
|
100
|
|
|
|
32
|
$concept->{notation} = $notation unless $notation eq ""; |
483
|
|
|
|
|
|
|
|
484
|
|
|
|
|
|
|
# add label properties |
485
|
7
|
|
|
|
|
26
|
foreach my $type ( keys %LABEL_TYPES ) { |
486
|
28
|
|
|
|
|
45
|
my $label = delete $arg->{$type}; |
487
|
28
|
100
|
|
|
|
139
|
next unless defined $label; |
488
|
|
|
|
|
|
|
# TODO: add to existing labels, check for unqiueness, mandatory etc. |
489
|
1
|
|
|
|
|
4
|
$concept->{$type} = $label; |
490
|
|
|
|
|
|
|
} |
491
|
|
|
|
|
|
|
|
492
|
|
|
|
|
|
|
# add documentation/note properties |
493
|
7
|
|
|
|
|
37
|
foreach my $name ( keys %NOTE_PROPERTIES ) { |
494
|
49
|
|
|
|
|
94
|
my @values = _values( delete $arg->{$name} ); |
495
|
49
|
50
|
|
|
|
154
|
if ( @values ) { |
496
|
0
|
|
|
|
|
0
|
push @{ $concept->{$name} }, @values; |
|
0
|
|
|
|
|
0
|
|
497
|
|
|
|
|
|
|
} |
498
|
|
|
|
|
|
|
# TODO: entail skos:note |
499
|
|
|
|
|
|
|
} |
500
|
|
|
|
|
|
|
|
501
|
|
|
|
|
|
|
# additional constraint of SKOS::Simple |
502
|
7
|
50
|
66
|
|
|
42
|
croak "concept <$id> cannot have broader if it is top concept!" |
503
|
|
|
|
|
|
|
if ( @broader && $self->{top}->{$id} ); |
504
|
|
|
|
|
|
|
|
505
|
|
|
|
|
|
|
# add inverse relations |
506
|
7
|
|
|
|
|
19
|
foreach my $i (@related) { |
507
|
0
|
0
|
|
|
|
0
|
next if $concept->{related}->{$i}; |
508
|
0
|
0
|
|
|
|
0
|
$self->addConcept( related => $id, _nocheck => 1, id => $i ) |
509
|
|
|
|
|
|
|
unless $nocheck; |
510
|
0
|
|
|
|
|
0
|
$concept->{related}->{$i} = 1; |
511
|
|
|
|
|
|
|
} |
512
|
7
|
|
|
|
|
17
|
foreach my $i (@broader) { |
513
|
2
|
50
|
|
|
|
10
|
next if $concept->{broader}->{$i}; |
514
|
2
|
50
|
|
|
|
9
|
if ( $self->{hierarchy} eq 'tree' ) { |
515
|
0
|
|
|
|
|
0
|
croak "tree property violated by <$id> skos:broader <$i>" |
516
|
0
|
0
|
|
|
|
0
|
if %{$concept->{broader}}; |
517
|
|
|
|
|
|
|
} # TODO: if 'multi[tree]': detect loops |
518
|
|
|
|
|
|
|
|
519
|
2
|
50
|
|
|
|
16
|
$self->addConcept( narrower => $id, _nocheck => 1, id => $i ) |
520
|
|
|
|
|
|
|
unless $nocheck; |
521
|
2
|
|
|
|
|
8
|
$concept->{broader}->{$i} = 1; |
522
|
|
|
|
|
|
|
} |
523
|
7
|
|
|
|
|
16
|
foreach my $i (@narrower) { |
524
|
2
|
50
|
|
|
|
10
|
next if $concept->{narrower}->{$i}; |
525
|
2
|
50
|
|
|
|
6
|
$self->addConcept( broader => $id, _nocheck => 1, id => $i ) |
526
|
|
|
|
|
|
|
unless $nocheck; |
527
|
2
|
|
|
|
|
11
|
$concept->{narrower}->{$i} = 1; |
528
|
|
|
|
|
|
|
} |
529
|
|
|
|
|
|
|
|
530
|
7
|
|
|
|
|
37
|
return $id; |
531
|
|
|
|
|
|
|
} |
532
|
|
|
|
|
|
|
|
533
|
|
|
|
|
|
|
=head2 topConcepts ( [ @ids ] ) |
534
|
|
|
|
|
|
|
|
535
|
|
|
|
|
|
|
Marks one or more concepts as top concepts. The given concepts must |
536
|
|
|
|
|
|
|
already exist and must not have any broader concepts. Without parameters, |
537
|
|
|
|
|
|
|
this methods returns a list of all top concept identifiers. Unless you |
538
|
|
|
|
|
|
|
explicitly specify top concepts, a list of I concepts without broader |
539
|
|
|
|
|
|
|
concepts is returned. As soon as you explicitly set some top concepts, |
540
|
|
|
|
|
|
|
they will be the I top concepts. You can reset the top concepts |
541
|
|
|
|
|
|
|
to all concepts without broader concepts, provide C as only argument. |
542
|
|
|
|
|
|
|
|
543
|
|
|
|
|
|
|
=cut |
544
|
|
|
|
|
|
|
|
545
|
|
|
|
|
|
|
sub topConcepts { |
546
|
13
|
|
|
13
|
1
|
18
|
my $self = shift; |
547
|
13
|
50
|
|
|
|
36
|
unless ( @_ ) { |
548
|
13
|
50
|
|
|
|
17
|
return keys %{ $self->{top} } if %{ $self->{top} }; |
|
0
|
|
|
|
|
0
|
|
|
13
|
|
|
|
|
47
|
|
549
|
5
|
|
|
|
|
42
|
return grep { |
550
|
5
|
|
|
|
|
8
|
not %{$self->{concepts}->{$_}->{broader}} |
|
13
|
|
|
|
|
51
|
|
551
|
13
|
|
|
|
|
22
|
} keys %{$self->{concepts}}; |
552
|
|
|
|
|
|
|
} |
553
|
0
|
0
|
0
|
|
|
0
|
if ( @_ == 1 && not defined $_[0] ) { |
554
|
0
|
|
|
|
|
0
|
$self->{top} = { }; |
555
|
0
|
|
|
|
|
0
|
return; |
556
|
|
|
|
|
|
|
} |
557
|
0
|
|
|
|
|
0
|
foreach my $id ( @_ ) { |
558
|
0
|
0
|
|
|
|
0
|
croak "Unknown concept <$id>" unless $self->{concepts}->{$id}; |
559
|
0
|
0
|
|
|
|
0
|
next if $self->{top}->{$id}; |
560
|
0
|
|
|
|
|
0
|
croak "Concept <$id> must not have broader to be top concept" |
561
|
0
|
0
|
|
|
|
0
|
if keys %{ $self->{concepts}->{broader} }; |
562
|
0
|
|
|
|
|
0
|
$self->{top}->{$id} = 1; |
563
|
|
|
|
|
|
|
} |
564
|
|
|
|
|
|
|
} |
565
|
|
|
|
|
|
|
|
566
|
|
|
|
|
|
|
=head2 concept ( %properties ) |
567
|
|
|
|
|
|
|
|
568
|
|
|
|
|
|
|
Returns the identifier of a concept with given notation and/or label. |
569
|
|
|
|
|
|
|
It is not checked whether the given concept exists in this scheme. |
570
|
|
|
|
|
|
|
Returns either a string or an empty string if no identifier is given. |
571
|
|
|
|
|
|
|
|
572
|
|
|
|
|
|
|
=cut |
573
|
|
|
|
|
|
|
|
574
|
|
|
|
|
|
|
sub concept { |
575
|
5
|
|
|
5
|
1
|
28
|
my $id = ""; |
576
|
5
|
|
|
|
|
9
|
eval { |
577
|
5
|
|
|
|
|
15
|
my $arg = shift->conceptentification( @_ ); |
578
|
4
|
|
|
|
|
18
|
$id = $arg->{id}; |
579
|
|
|
|
|
|
|
}; |
580
|
5
|
|
|
|
|
87
|
return $id; |
581
|
|
|
|
|
|
|
} |
582
|
|
|
|
|
|
|
|
583
|
|
|
|
|
|
|
=head2 hasConcept ( $id | %properties ) |
584
|
|
|
|
|
|
|
|
585
|
|
|
|
|
|
|
Returns whether there is a concept of a given id. Instead of providing |
586
|
|
|
|
|
|
|
a specific concept C you can also use unique properties (C, |
587
|
|
|
|
|
|
|
C |
588
|
|
|
|
|
|
|
|
589
|
|
|
|
|
|
|
=cut |
590
|
|
|
|
|
|
|
|
591
|
|
|
|
|
|
|
sub hasConcept { |
592
|
3
|
|
|
3
|
1
|
9
|
my $self = shift; |
593
|
3
|
100
|
|
|
|
14
|
my $id = (@_ == 1) ? $_[0] : $self->concept( @_ ); |
594
|
3
|
50
|
33
|
|
|
44
|
return exists $self->{concepts}->{$id} |
595
|
|
|
|
|
|
|
if defined $id and $id ne ""; |
596
|
|
|
|
|
|
|
|
597
|
0
|
|
|
|
|
0
|
return 0; |
598
|
|
|
|
|
|
|
} |
599
|
|
|
|
|
|
|
|
600
|
|
|
|
|
|
|
=head2 concepts |
601
|
|
|
|
|
|
|
|
602
|
|
|
|
|
|
|
Returns a list of all concept's ids. |
603
|
|
|
|
|
|
|
|
604
|
|
|
|
|
|
|
=cut |
605
|
|
|
|
|
|
|
|
606
|
|
|
|
|
|
|
sub concepts { |
607
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
608
|
0
|
|
|
|
|
0
|
return keys %{ $self->{concepts} }; |
|
0
|
|
|
|
|
0
|
|
609
|
|
|
|
|
|
|
} |
610
|
|
|
|
|
|
|
|
611
|
|
|
|
|
|
|
=head2 size |
612
|
|
|
|
|
|
|
|
613
|
|
|
|
|
|
|
Returns the total number of concepts. |
614
|
|
|
|
|
|
|
|
615
|
|
|
|
|
|
|
=cut |
616
|
|
|
|
|
|
|
|
617
|
|
|
|
|
|
|
sub size { |
618
|
3
|
|
|
3
|
1
|
488
|
my $self = shift; |
619
|
3
|
|
|
|
|
15
|
return scalar keys %{ $self->{concepts} }; |
|
3
|
|
|
|
|
20
|
|
620
|
|
|
|
|
|
|
} |
621
|
|
|
|
|
|
|
|
622
|
|
|
|
|
|
|
=head2 conceptentification ( %properties ) |
623
|
|
|
|
|
|
|
|
624
|
|
|
|
|
|
|
Checks and possibly expands some given concept properties to ensure that |
625
|
|
|
|
|
|
|
there is a valid concept id. Returns a hashref that contains the concept |
626
|
|
|
|
|
|
|
id (field C) or croaks. Depending on the identification settings of |
627
|
|
|
|
|
|
|
this scheme you must pass at least one of C, C |
628
|
|
|
|
|
|
|
C, C. |
629
|
|
|
|
|
|
|
|
630
|
|
|
|
|
|
|
=cut |
631
|
|
|
|
|
|
|
|
632
|
|
|
|
|
|
|
sub conceptentification { |
633
|
12
|
|
|
12
|
1
|
52
|
my ($self, %arg) = @_; |
634
|
|
|
|
|
|
|
|
635
|
12
|
|
|
|
|
29
|
my $idtype = $self->{identity}; |
636
|
12
|
|
|
|
|
25
|
my $labeltype = $self->{label}; |
637
|
12
|
|
|
|
|
24
|
my $lang = $self->{language}; |
638
|
|
|
|
|
|
|
|
639
|
12
|
100
|
|
|
|
49
|
$arg{label} = '' unless defined $arg{label}; |
640
|
|
|
|
|
|
|
|
641
|
|
|
|
|
|
|
# rename 'label' parameter if given |
642
|
12
|
100
|
|
|
|
39
|
if ( $arg{label} ne '' ) { |
643
|
|
|
|
|
|
|
# TODO: what if arg{labeltype} is also given? better croak |
644
|
3
|
|
|
|
|
10
|
$arg{$labeltype} = $arg{label}; |
645
|
|
|
|
|
|
|
} |
646
|
|
|
|
|
|
|
|
647
|
|
|
|
|
|
|
# set a label's default language if only a string was given |
648
|
|
|
|
|
|
|
# expand label property to be a hashref on undef |
649
|
12
|
|
|
|
|
45
|
foreach my $type ( 'label', keys %LABEL_TYPES ) { |
650
|
60
|
100
|
100
|
|
|
1356
|
next unless defined $arg{$type} and $arg{$type} ne ''; |
651
|
6
|
50
|
|
|
|
19
|
unless ( ref($arg{$type}) ) { # HASH |
652
|
6
|
50
|
|
|
|
22
|
if ( $arg{$type} eq "" ) { |
653
|
0
|
|
|
|
|
0
|
delete $arg{$type}; |
654
|
|
|
|
|
|
|
} else { |
655
|
6
|
|
|
|
|
31
|
$arg{$type} = { $lang => $arg{$type} }; |
656
|
|
|
|
|
|
|
} |
657
|
|
|
|
|
|
|
} |
658
|
|
|
|
|
|
|
} |
659
|
|
|
|
|
|
|
|
660
|
12
|
100
|
|
|
|
71
|
$arg{id} = "" unless defined $arg{id}; |
661
|
12
|
100
|
|
|
|
48
|
$arg{$idtype} = "" unless defined $arg{$idtype}; |
662
|
|
|
|
|
|
|
|
663
|
12
|
100
|
|
|
|
40
|
if ( $arg{id} ne "" ) { |
664
|
|
|
|
|
|
|
# derive property from id |
665
|
3
|
50
|
33
|
|
|
15
|
if ( $idtype eq 'notation' or $idtype eq 'identifier' ) { |
666
|
3
|
50
|
33
|
|
|
12
|
if ( $arg{$idtype} ne "" and $arg{$idtype} ne $arg{id} ) { |
667
|
0
|
|
|
|
|
0
|
croak "concept id cannot be both '" . $arg{id} |
668
|
|
|
|
|
|
|
. "' and '" . $arg{$idtype} . "'"; |
669
|
|
|
|
|
|
|
} |
670
|
3
|
|
|
|
|
10
|
$arg{$idtype} = $arg{id}; |
671
|
|
|
|
|
|
|
} else { # $idtype eq 'label' |
672
|
0
|
0
|
|
|
|
0
|
$arg{label} = { } if $arg{label} eq ''; |
673
|
0
|
|
|
|
|
0
|
my $l = $arg{label}->{$lang}; |
674
|
0
|
0
|
0
|
|
|
0
|
croak "concept id cannot be both '" . $arg{id} . "' and label '$l'" |
|
|
|
0
|
|
|
|
|
675
|
|
|
|
|
|
|
if ( defined $l and $l ne "" and $l ne $arg{id} ); |
676
|
|
|
|
|
|
|
|
677
|
0
|
|
|
|
|
0
|
$arg{label}->{$lang} = $arg{id}; |
678
|
|
|
|
|
|
|
} |
679
|
|
|
|
|
|
|
} else { |
680
|
|
|
|
|
|
|
# derive id from property (TODO: url-encode if needed) |
681
|
9
|
100
|
|
|
|
29
|
if ( $idtype eq 'notation' ) { |
|
|
50
|
|
|
|
|
|
682
|
5
|
|
|
|
|
17
|
$arg{id} = $arg{notation}; |
683
|
|
|
|
|
|
|
} elsif ( $idtype eq 'identifier' ) { |
684
|
0
|
|
|
|
|
0
|
$arg{id} = $arg{identifier}; |
685
|
|
|
|
|
|
|
} else { # $idtype eq 'label' |
686
|
4
|
100
|
|
|
|
18
|
$arg{id} = $arg{$labeltype}->{ $lang } if $arg{$labeltype}; |
687
|
|
|
|
|
|
|
} |
688
|
|
|
|
|
|
|
} |
689
|
|
|
|
|
|
|
|
690
|
12
|
|
|
|
|
41
|
$arg{id} = $self->{idescape}->( $arg{id} ); |
691
|
|
|
|
|
|
|
|
692
|
12
|
50
|
|
|
|
39
|
if ( $self->{idregexp} ) { |
693
|
0
|
0
|
|
|
|
0
|
croak "identifier " . $arg{id} . " does not fit to pattern" |
694
|
|
|
|
|
|
|
unless $arg{id} =~ $self->{idregexp}; |
695
|
|
|
|
|
|
|
} |
696
|
|
|
|
|
|
|
|
697
|
12
|
100
|
|
|
|
287
|
croak "Missing $idtype as concept identifier" if $arg{id} eq ""; |
698
|
|
|
|
|
|
|
|
699
|
|
|
|
|
|
|
# TODO: check $arg{id} for well-formedness as URI part |
700
|
|
|
|
|
|
|
|
701
|
11
|
|
|
|
|
39
|
return \%arg; |
702
|
|
|
|
|
|
|
} |
703
|
|
|
|
|
|
|
|
704
|
|
|
|
|
|
|
=head2 addHashref ( $hashref ) |
705
|
|
|
|
|
|
|
|
706
|
|
|
|
|
|
|
experimental. |
707
|
|
|
|
|
|
|
|
708
|
|
|
|
|
|
|
=cut |
709
|
|
|
|
|
|
|
|
710
|
|
|
|
|
|
|
sub addHashref { |
711
|
0
|
|
|
0
|
1
|
0
|
my ($self, $hash) = @_; |
712
|
|
|
|
|
|
|
|
713
|
0
|
|
|
|
|
0
|
my $base = $self->{base}; # may be "" |
714
|
|
|
|
|
|
|
|
715
|
|
|
|
|
|
|
# ignores all but the following predicates |
716
|
0
|
|
|
|
|
0
|
my %predicates = ( |
717
|
|
|
|
|
|
|
$NAMESPACES{rdf}.'type' => 'a', |
718
|
|
|
|
|
|
|
$NAMESPACES{dc}.'identifier' => 'id' |
719
|
|
|
|
|
|
|
); |
720
|
|
|
|
|
|
|
|
721
|
0
|
|
|
|
|
0
|
my @pnames = ( |
722
|
|
|
|
|
|
|
keys %NOTE_PROPERTIES, |
723
|
|
|
|
|
|
|
keys %RELATION_PROPERTIES, |
724
|
|
|
|
|
|
|
keys %LABEL_PROPERTIES, 'notation' ); |
725
|
|
|
|
|
|
|
|
726
|
0
|
|
|
|
|
0
|
foreach my $p (@pnames) { |
727
|
0
|
|
|
|
|
0
|
$predicates{ $NAMESPACES{skos}.$p } = $p; |
728
|
|
|
|
|
|
|
} |
729
|
|
|
|
|
|
|
|
730
|
0
|
|
|
|
|
0
|
foreach my $subject ( keys %$hash ) { |
731
|
0
|
|
|
|
|
0
|
my $subj = $subject; |
732
|
0
|
0
|
|
|
|
0
|
next unless ($subj =~ s/^$base//); |
733
|
|
|
|
|
|
|
|
734
|
|
|
|
|
|
|
# TODO: $self->{scheme} as subject |
735
|
|
|
|
|
|
|
|
736
|
0
|
|
|
|
|
0
|
my %concept = (); # => $subj ); |
737
|
0
|
|
|
|
|
0
|
$concept{notation} = $subj; # TODO: remove |
738
|
0
|
|
|
|
|
0
|
my $is_concept = 0; # TODO: check |
739
|
|
|
|
|
|
|
|
740
|
0
|
|
|
|
|
0
|
foreach my $predicate ( keys %{$hash->{$subject}} ) { |
|
0
|
|
|
|
|
0
|
|
741
|
0
|
|
0
|
|
|
0
|
my $p = $predicates{ $predicate } || next; |
742
|
|
|
|
|
|
|
|
743
|
0
|
|
|
|
|
0
|
foreach my $object ( @{ $hash->{$subject}->{$predicate} } ) { |
|
0
|
|
|
|
|
0
|
|
744
|
0
|
|
|
|
|
0
|
my $obj; |
745
|
|
|
|
|
|
|
|
746
|
0
|
0
|
|
|
|
0
|
if ( $p =~ /^(narrower|broader)$/ ) { |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
747
|
0
|
0
|
|
|
|
0
|
next unless $object->{type} eq 'uri'; |
748
|
0
|
|
|
|
|
0
|
$obj = $object->{value}; |
749
|
|
|
|
|
|
|
#print "$obj\n"; |
750
|
0
|
0
|
|
|
|
0
|
next unless ($obj =~ s/^$base//); |
751
|
0
|
|
|
|
|
0
|
push @{$concept{$p}}, $obj; |
|
0
|
|
|
|
|
0
|
|
752
|
|
|
|
|
|
|
} elsif ( $p =~ /^(prefLabel)/ ) { |
753
|
0
|
|
|
|
|
0
|
$obj = $object->{value}; # TODO: language |
754
|
0
|
|
|
|
|
0
|
$concept{label} = $obj; # TODO: unique |
755
|
|
|
|
|
|
|
} elsif ( $p eq 'definition' ) { |
756
|
|
|
|
|
|
|
} |
757
|
|
|
|
|
|
|
|
758
|
|
|
|
|
|
|
# TODO: map |
759
|
|
|
|
|
|
|
#print "$subj $p\n"; |
760
|
|
|
|
|
|
|
} |
761
|
|
|
|
|
|
|
} |
762
|
0
|
0
|
|
|
|
0
|
if ( %concept ) { |
763
|
0
|
|
|
|
|
0
|
$self->addConcept( %concept ); |
764
|
|
|
|
|
|
|
} |
765
|
|
|
|
|
|
|
} |
766
|
|
|
|
|
|
|
} |
767
|
|
|
|
|
|
|
|
768
|
|
|
|
|
|
|
=head1 SERIALIZATION METHODS |
769
|
|
|
|
|
|
|
|
770
|
|
|
|
|
|
|
The following methods serialize the concept scheme or parts of it in |
771
|
|
|
|
|
|
|
L |
772
|
|
|
|
|
|
|
(RDF/Turtle). A valid serialization must start with some namespace |
773
|
|
|
|
|
|
|
declarations, and a base declaration. Both are only included by the |
774
|
|
|
|
|
|
|
C method, but they can also be requested independently. |
775
|
|
|
|
|
|
|
All return values end with a newline unless it is the empty string. |
776
|
|
|
|
|
|
|
|
777
|
|
|
|
|
|
|
A later version may also support 'hashref' format for serializing. |
778
|
|
|
|
|
|
|
|
779
|
|
|
|
|
|
|
=head2 turtle ( [ %options ] ) |
780
|
|
|
|
|
|
|
|
781
|
|
|
|
|
|
|
Returns a full Turtle serialization of this concept scheme. |
782
|
|
|
|
|
|
|
The return value is equivalent to calling C, |
783
|
|
|
|
|
|
|
C, C, and C. |
784
|
|
|
|
|
|
|
|
785
|
|
|
|
|
|
|
The parameter C<< lean => 1 >> enables a lean serialization, which |
786
|
|
|
|
|
|
|
does not include infereable RDF statements. Other parameters are |
787
|
|
|
|
|
|
|
passed to C and C as well. |
788
|
|
|
|
|
|
|
|
789
|
|
|
|
|
|
|
=cut |
790
|
|
|
|
|
|
|
|
791
|
|
|
|
|
|
|
sub turtle { |
792
|
8
|
|
|
8
|
1
|
1126
|
my ($self,%opt) = @_; |
793
|
|
|
|
|
|
|
|
794
|
8
|
|
|
|
|
23
|
return join( "\n", |
795
|
|
|
|
|
|
|
$self->turtleNamespaces, |
796
|
|
|
|
|
|
|
$self->turtleBase , |
797
|
|
|
|
|
|
|
$self->turtleScheme( %opt ) , |
798
|
|
|
|
|
|
|
$self->turtleConcepts( %opt ) ); |
799
|
|
|
|
|
|
|
} |
800
|
|
|
|
|
|
|
|
801
|
|
|
|
|
|
|
=head2 turtleNamespaces |
802
|
|
|
|
|
|
|
|
803
|
|
|
|
|
|
|
Returns Turtle syntax namespace declarations for this scheme. |
804
|
|
|
|
|
|
|
|
805
|
|
|
|
|
|
|
=cut |
806
|
|
|
|
|
|
|
|
807
|
|
|
|
|
|
|
sub turtleNamespaces { |
808
|
8
|
|
|
8
|
1
|
10
|
my $self = shift; |
809
|
|
|
|
|
|
|
|
810
|
8
|
50
|
33
|
|
|
28
|
if ( $self->{uses_dc} and not $self->{namespaces}->{dc} ) { |
811
|
0
|
|
|
|
|
0
|
$self->{namespaces}->{dc} = $NAMESPACES{dc}; |
812
|
|
|
|
|
|
|
} |
813
|
|
|
|
|
|
|
|
814
|
8
|
|
|
|
|
11
|
my @lines; |
815
|
8
|
|
|
|
|
10
|
foreach my $name (keys %{$self->{namespaces}}) { |
|
8
|
|
|
|
|
31
|
|
816
|
16
|
|
|
|
|
63
|
push @lines, "\@prefix $name: <" . $self->{namespaces}->{$name} . "> ."; |
817
|
|
|
|
|
|
|
} |
818
|
|
|
|
|
|
|
|
819
|
8
|
|
|
|
|
48
|
return join("\n", @lines) . "\n"; |
820
|
|
|
|
|
|
|
} |
821
|
|
|
|
|
|
|
|
822
|
|
|
|
|
|
|
=head2 turtleBase |
823
|
|
|
|
|
|
|
|
824
|
|
|
|
|
|
|
Returns a Turtle URI base declaration for this scheme. |
825
|
|
|
|
|
|
|
An empty string is returned if no URI base is set. |
826
|
|
|
|
|
|
|
|
827
|
|
|
|
|
|
|
=cut |
828
|
|
|
|
|
|
|
|
829
|
|
|
|
|
|
|
sub turtleBase { |
830
|
8
|
|
|
8
|
1
|
14
|
my $self = shift; |
831
|
|
|
|
|
|
|
|
832
|
8
|
50
|
|
|
|
44
|
return "" if $self->{base} eq ""; |
833
|
0
|
|
|
|
|
0
|
return "\@base <" . $self->{base} . "> .\n" |
834
|
|
|
|
|
|
|
} |
835
|
|
|
|
|
|
|
|
836
|
|
|
|
|
|
|
|
837
|
|
|
|
|
|
|
=head2 turtleScheme ( [ top => 0 ] ) |
838
|
|
|
|
|
|
|
|
839
|
|
|
|
|
|
|
Returns RDF statements about the concept scheme in Turtle syntax. |
840
|
|
|
|
|
|
|
Details about concepts or namespace/base declarations are not included. |
841
|
|
|
|
|
|
|
The option C<< top => 0 >> (enabled by default) can be used to supress |
842
|
|
|
|
|
|
|
serializing the C property. |
843
|
|
|
|
|
|
|
|
844
|
|
|
|
|
|
|
=cut |
845
|
|
|
|
|
|
|
|
846
|
|
|
|
|
|
|
sub turtleScheme { |
847
|
14
|
|
|
14
|
1
|
94
|
my ($self,%opt) = @_; |
848
|
14
|
100
|
|
|
|
48
|
$opt{top} = 1 unless exists $opt{top}; |
849
|
|
|
|
|
|
|
|
850
|
|
|
|
|
|
|
# note that lean => 1 does not imply top => 0 ! |
851
|
14
|
100
|
|
|
|
36
|
if ( $opt{top} ) { |
852
|
10
|
|
|
|
|
29
|
my @top = $self->topConcepts(); |
853
|
10
|
|
|
|
|
36
|
$self->{prop}->{'skos:hasTopConcept'} = [ map { "<$_>" } @top ]; |
|
1
|
|
|
|
|
10
|
|
854
|
|
|
|
|
|
|
} else { |
855
|
4
|
|
|
|
|
12
|
delete $self->{prop}->{'skos:hasTopConcept'} |
856
|
|
|
|
|
|
|
} |
857
|
|
|
|
|
|
|
|
858
|
14
|
|
|
|
|
38
|
return turtle_statement( "<" . $self->{scheme} . ">", %{$self->{prop}} ); |
|
14
|
|
|
|
|
82
|
|
859
|
|
|
|
|
|
|
} |
860
|
|
|
|
|
|
|
|
861
|
|
|
|
|
|
|
=head2 turtleConcept ( $id [, %options ] ) |
862
|
|
|
|
|
|
|
|
863
|
|
|
|
|
|
|
Returns a concept in Turtle syntax. With option C<< top => 0 >> you can disable |
864
|
|
|
|
|
|
|
serializing the C property. By default, each concept is |
865
|
|
|
|
|
|
|
connected to its concept scheme with either C, or with |
866
|
|
|
|
|
|
|
C. With option C<< scheme => 0 >> you can disable serializing |
867
|
|
|
|
|
|
|
the latter property. With C<< scheme => 2 >> the property C |
868
|
|
|
|
|
|
|
is also included in the serialization if C is given, |
869
|
|
|
|
|
|
|
although the former can be derived as super-property of the latter. |
870
|
|
|
|
|
|
|
|
871
|
|
|
|
|
|
|
=cut |
872
|
|
|
|
|
|
|
|
873
|
|
|
|
|
|
|
sub turtleConcept { |
874
|
8
|
|
|
8
|
1
|
21
|
my ($self,$id,%opt) = @_; |
875
|
8
|
100
|
|
|
|
32
|
$opt{top} = 1 unless exists $opt{top}; |
876
|
8
|
100
|
|
|
|
25
|
$opt{top} = 0 if $opt{lean}; |
877
|
8
|
100
|
|
|
|
23
|
$opt{scheme} = 1 unless exists $opt{scheme}; |
878
|
|
|
|
|
|
|
|
879
|
8
|
|
|
|
|
20
|
my $c = $self->{concepts}->{$id}; |
880
|
|
|
|
|
|
|
|
881
|
8
|
|
|
|
|
17
|
my %stm = ( 'a' => 'skos:Concept' ); |
882
|
|
|
|
|
|
|
|
883
|
|
|
|
|
|
|
# TODO: Support multiple notations |
884
|
8
|
50
|
|
|
|
33
|
if ( $c->{notation} ne '' ) { |
885
|
8
|
|
|
|
|
29
|
$stm{'skos:notation'} = turtle_literal( $c->{notation} ); |
886
|
|
|
|
|
|
|
} |
887
|
|
|
|
|
|
|
|
888
|
|
|
|
|
|
|
# Concept Labels: pref, alt, hidden, title |
889
|
8
|
|
|
|
|
233
|
while ( my ($type,$property) = each %LABEL_TYPES ) { |
890
|
32
|
50
|
|
|
|
154
|
next unless $c->{$type}; |
891
|
0
|
|
|
|
|
0
|
my $label = turtle_literal_list( $c->{$type} ); |
892
|
0
|
|
|
|
|
0
|
$stm{$property} = $label; |
893
|
|
|
|
|
|
|
# TODO: entail rdfs:label if requested (pref, alt, hidden) |
894
|
|
|
|
|
|
|
} |
895
|
|
|
|
|
|
|
|
896
|
|
|
|
|
|
|
|
897
|
8
|
|
|
|
|
21
|
foreach my $rel (qw(broader narrower related)) { |
898
|
24
|
100
|
|
|
|
27
|
next unless %{$c->{$rel}}; |
|
24
|
|
|
|
|
160
|
|
899
|
2
|
|
|
|
|
3
|
$stm{"skos:$rel"} = [ map { "<$_>" } keys %{$c->{$rel}} ]; |
|
2
|
|
|
|
|
13
|
|
|
2
|
|
|
|
|
8
|
|
900
|
|
|
|
|
|
|
} |
901
|
|
|
|
|
|
|
|
902
|
8
|
|
|
|
|
15
|
my $is_top = 0; |
903
|
8
|
100
|
|
|
|
23
|
if ( $opt{top} ) { |
904
|
4
|
50
|
|
|
|
7
|
if ( (keys %{ $self->{top} }) ? $self->{top}->{$id} : not %{$c->{broader}} ) { |
|
4
|
100
|
|
|
|
17
|
|
|
4
|
|
|
|
|
14
|
|
905
|
3
|
|
|
|
|
13
|
$stm{"skos:topConceptOf"} = "<" . $self->{scheme} . ">"; |
906
|
3
|
|
|
|
|
6
|
$is_top = 1; |
907
|
|
|
|
|
|
|
} |
908
|
|
|
|
|
|
|
} |
909
|
|
|
|
|
|
|
|
910
|
|
|
|
|
|
|
# [S7] skos:topConceptOf is a sub-property of skos:inScheme |
911
|
8
|
100
|
|
|
|
26
|
if ( $opt{scheme} - $is_top > 0 ) { |
912
|
|
|
|
|
|
|
# TODO: with 'lean' => 1 and not top => 0 |
913
|
|
|
|
|
|
|
# this is implied if the concept is topConcept |
914
|
5
|
|
|
|
|
23
|
$stm{'skos:inScheme'} = '<' . $self->{scheme} . '>'; |
915
|
|
|
|
|
|
|
} |
916
|
|
|
|
|
|
|
|
917
|
8
|
50
|
33
|
|
|
29
|
if ( defined $c->{identifier} and $c->{identifier} ne "" ) { |
918
|
0
|
|
|
|
|
0
|
$stm{'dc:identifier'} = turtle_literal( $c->{identifier} ); |
919
|
|
|
|
|
|
|
} |
920
|
|
|
|
|
|
|
|
921
|
|
|
|
|
|
|
# TODO: S17 - infer skos:note only if requested |
922
|
8
|
|
|
|
|
49
|
foreach my $name ( keys %NOTE_PROPERTIES ) { |
923
|
56
|
50
|
|
|
|
162
|
next unless $c->{$name}; |
924
|
0
|
|
|
|
|
0
|
$stm{"skos:$name"} = turtle_literal_list( $c->{$name} ); |
925
|
|
|
|
|
|
|
} |
926
|
|
|
|
|
|
|
|
927
|
8
|
|
|
|
|
48
|
return turtle_statement( "<$id>", %stm ); |
928
|
|
|
|
|
|
|
} |
929
|
|
|
|
|
|
|
|
930
|
|
|
|
|
|
|
=head2 turtleConcepts ( [ %options ] ) |
931
|
|
|
|
|
|
|
|
932
|
|
|
|
|
|
|
Returns all concepts in Turtle syntax. |
933
|
|
|
|
|
|
|
|
934
|
|
|
|
|
|
|
=cut |
935
|
|
|
|
|
|
|
|
936
|
|
|
|
|
|
|
sub turtleConcepts { |
937
|
15
|
|
|
15
|
1
|
6291
|
my ($self,%opt) = @_; |
938
|
15
|
|
|
|
|
23
|
delete $opt{id}; |
939
|
|
|
|
|
|
|
|
940
|
8
|
|
|
|
|
100
|
return join( "\n", |
941
|
15
|
|
|
|
|
108
|
map { $self->turtleConcept( $_, %opt ) } |
942
|
15
|
|
|
|
|
23
|
keys %{ $self->{concepts} } ); |
943
|
|
|
|
|
|
|
} |
944
|
|
|
|
|
|
|
|
945
|
|
|
|
|
|
|
=head1 EXPORTABLE FUNCTIONS |
946
|
|
|
|
|
|
|
|
947
|
|
|
|
|
|
|
=head2 skos |
948
|
|
|
|
|
|
|
|
949
|
|
|
|
|
|
|
This is just a shortcut for C<< SKOS::Simple->new >>. |
950
|
|
|
|
|
|
|
|
951
|
|
|
|
|
|
|
=cut |
952
|
|
|
|
|
|
|
|
953
|
|
|
|
|
|
|
sub skos { |
954
|
1
|
|
|
1
|
1
|
13
|
SKOS::Simple->new(@_) |
955
|
|
|
|
|
|
|
} |
956
|
|
|
|
|
|
|
|
957
|
|
|
|
|
|
|
=head2 is_uri ( $uri ) |
958
|
|
|
|
|
|
|
|
959
|
|
|
|
|
|
|
Copied from L, originally by Richard Sonnen. |
960
|
|
|
|
|
|
|
|
961
|
|
|
|
|
|
|
=cut |
962
|
|
|
|
|
|
|
|
963
|
|
|
|
|
|
|
sub is_uri{ |
964
|
7
|
50
|
|
7
|
1
|
22
|
my $self = shift if ref($_[0]); |
965
|
7
|
|
|
|
|
12
|
my $value = shift; |
966
|
|
|
|
|
|
|
|
967
|
7
|
50
|
|
|
|
16
|
return unless defined($value); |
968
|
|
|
|
|
|
|
|
969
|
|
|
|
|
|
|
# check for illegal characters |
970
|
7
|
50
|
|
|
|
29
|
return if $value =~ /[^a-z0-9\:\/\?\#\[\]\@\!\$\&\'\(\)\*\+\,\;\=\.\-\_\~\%]/i; |
971
|
|
|
|
|
|
|
|
972
|
|
|
|
|
|
|
# check for hex escapes that aren't complete |
973
|
7
|
50
|
|
|
|
22
|
return if $value =~ /%[^0-9a-f]/i; |
974
|
7
|
50
|
|
|
|
19
|
return if $value =~ /%[0-9a-f](:?[^0-9a-f]|$)/i; |
975
|
|
|
|
|
|
|
|
976
|
|
|
|
|
|
|
# from RFC 3986 |
977
|
7
|
|
|
|
|
50
|
my($scheme, $authority, $path, $query, $fragment) = |
978
|
|
|
|
|
|
|
($value =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?|); |
979
|
|
|
|
|
|
|
|
980
|
|
|
|
|
|
|
# scheme and path are required, though the path can be empty |
981
|
7
|
50
|
33
|
|
|
108
|
return unless (defined($scheme) && length($scheme) && defined($path)); |
|
|
|
33
|
|
|
|
|
982
|
|
|
|
|
|
|
|
983
|
|
|
|
|
|
|
# if authority is present, the path must be empty or begin with a / |
984
|
7
|
50
|
33
|
|
|
35
|
if(defined($authority) && length($authority)){ |
985
|
7
|
50
|
66
|
|
|
30
|
return unless(length($path) == 0 || $path =~ m!^/!); |
986
|
|
|
|
|
|
|
|
987
|
|
|
|
|
|
|
} else { |
988
|
|
|
|
|
|
|
# if authority is not present, the path must not start with // |
989
|
0
|
0
|
|
|
|
0
|
return if $path =~ m!^//!; |
990
|
|
|
|
|
|
|
} |
991
|
|
|
|
|
|
|
|
992
|
|
|
|
|
|
|
# scheme must begin with a letter, then consist of letters, digits, +, ., or - |
993
|
7
|
50
|
|
|
|
48
|
return unless lc($scheme) =~ m!^[a-z][a-z0-9\+\-\.]*$!; |
994
|
|
|
|
|
|
|
|
995
|
|
|
|
|
|
|
# re-assemble the URL per section 5.3 in RFC 3986 |
996
|
7
|
|
|
|
|
15
|
my $out = $scheme . ':'; |
997
|
7
|
50
|
33
|
|
|
43
|
if(defined $authority && length($authority)){ |
998
|
7
|
|
|
|
|
15
|
$out .= '//' . $authority; |
999
|
|
|
|
|
|
|
} |
1000
|
7
|
|
|
|
|
11
|
$out .= $path; |
1001
|
7
|
50
|
33
|
|
|
20
|
if(defined $query && length($query)){ |
1002
|
0
|
|
|
|
|
0
|
$out .= '?' . $query; |
1003
|
|
|
|
|
|
|
} |
1004
|
7
|
50
|
33
|
|
|
21
|
if(defined $fragment && length($fragment)){ |
1005
|
0
|
|
|
|
|
0
|
$out .= '#' . $fragment; |
1006
|
|
|
|
|
|
|
} |
1007
|
|
|
|
|
|
|
|
1008
|
7
|
|
|
|
|
35
|
return $out; |
1009
|
|
|
|
|
|
|
} |
1010
|
|
|
|
|
|
|
|
1011
|
|
|
|
|
|
|
=head2 uri_or_empty ( $uri ) |
1012
|
|
|
|
|
|
|
|
1013
|
|
|
|
|
|
|
Checks whether the passed parameter is either an URI or undefined. |
1014
|
|
|
|
|
|
|
|
1015
|
|
|
|
|
|
|
=cut |
1016
|
|
|
|
|
|
|
|
1017
|
|
|
|
|
|
|
sub uri_or_empty { |
1018
|
30
|
|
66
|
30
|
1
|
227
|
return (not defined $_[0] or $_[0] eq '' or is_uri($_[0])); |
1019
|
|
|
|
|
|
|
} |
1020
|
|
|
|
|
|
|
|
1021
|
|
|
|
|
|
|
1; |
1022
|
|
|
|
|
|
|
|
1023
|
|
|
|
|
|
|
=head1 SEE ALSO |
1024
|
|
|
|
|
|
|
|
1025
|
|
|
|
|
|
|
The SKOS ontology and its semantics is defined in |
1026
|
|
|
|
|
|
|
L and |
1027
|
|
|
|
|
|
|
L. Turtle format |
1028
|
|
|
|
|
|
|
is specified at http://www.w3.org/TeamSubmission/turtle/. |
1029
|
|
|
|
|
|
|
|
1030
|
|
|
|
|
|
|
See also L for a similar module. |
1031
|
|
|
|
|
|
|
|
1032
|
|
|
|
|
|
|
=cut |