line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package RDF::KV; |
2
|
|
|
|
|
|
|
|
3
|
2
|
|
|
2
|
|
121820
|
use 5.010; |
|
2
|
|
|
|
|
9
|
|
4
|
2
|
|
|
2
|
|
11
|
use strict; |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
74
|
|
5
|
2
|
|
|
2
|
|
19
|
use warnings FATAL => 'all'; |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
80
|
|
6
|
|
|
|
|
|
|
|
7
|
|
|
|
|
|
|
# might as well use full-blown moose if URI::NamespaceMap uses it |
8
|
2
|
|
|
2
|
|
3094
|
use Moose; |
|
2
|
|
|
|
|
1054212
|
|
|
2
|
|
|
|
|
11
|
|
9
|
2
|
|
|
2
|
|
14913
|
use Moose::Util::TypeConstraints; |
|
2
|
|
|
|
|
5
|
|
|
2
|
|
|
|
|
25
|
|
10
|
2
|
|
|
2
|
|
6005
|
use namespace::autoclean; |
|
2
|
|
|
|
|
17578
|
|
|
2
|
|
|
|
|
6
|
|
11
|
2
|
|
|
2
|
|
129
|
use Try::Tiny; |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
109
|
|
12
|
|
|
|
|
|
|
|
13
|
2
|
|
|
2
|
|
13
|
use Carp (); |
|
2
|
|
|
|
|
11
|
|
|
2
|
|
|
|
|
28
|
|
14
|
2
|
|
|
2
|
|
13
|
use Scalar::Util (); |
|
2
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
24
|
|
15
|
2
|
|
|
2
|
|
1156
|
use XML::RegExp (); |
|
2
|
|
|
|
|
1305
|
|
|
2
|
|
|
|
|
57
|
|
16
|
2
|
|
|
2
|
|
1008
|
use Data::GUID::Any (); |
|
2
|
|
|
|
|
289556
|
|
|
2
|
|
|
|
|
91
|
|
17
|
2
|
|
|
2
|
|
1958
|
use Data::UUID::NCName (); |
|
2
|
|
|
|
|
537971
|
|
|
2
|
|
|
|
|
82
|
|
18
|
|
|
|
|
|
|
|
19
|
2
|
|
|
2
|
|
1290
|
use URI; |
|
2
|
|
|
|
|
10054
|
|
|
2
|
|
|
|
|
64
|
|
20
|
2
|
|
|
2
|
|
922
|
use URI::BNode; |
|
2
|
|
|
|
|
2851
|
|
|
2
|
|
|
|
|
81
|
|
21
|
2
|
|
|
2
|
|
1025
|
use URI::NamespaceMap; |
|
2
|
|
|
|
|
856135
|
|
|
2
|
|
|
|
|
111
|
|
22
|
|
|
|
|
|
|
# XXX remind me to rewrite this using Moo. |
23
|
|
|
|
|
|
|
|
24
|
2
|
|
|
2
|
|
1042
|
use RDF::KV::Patch; |
|
2
|
|
|
|
|
9
|
|
|
2
|
|
|
|
|
8349
|
|
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
=head1 NAME |
27
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
RDF::KV - Embed RDF linked data in plain old HTML forms |
29
|
|
|
|
|
|
|
|
30
|
|
|
|
|
|
|
=head1 VERSION |
31
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
Version 0.10 |
33
|
|
|
|
|
|
|
|
34
|
|
|
|
|
|
|
=cut |
35
|
|
|
|
|
|
|
|
36
|
|
|
|
|
|
|
our $VERSION = '0.10'; |
37
|
|
|
|
|
|
|
|
38
|
|
|
|
|
|
|
class_type 'URI'; |
39
|
|
|
|
|
|
|
|
40
|
|
|
|
|
|
|
# here's ye olde grammar: |
41
|
|
|
|
|
|
|
|
42
|
|
|
|
|
|
|
# XXX I know I said in the spec that the protocol should be parseable |
43
|
|
|
|
|
|
|
# by a single regex, but regexes make for lame, all-or-nothing |
44
|
|
|
|
|
|
|
# parsers. As such, this should really be rewritten when there's time |
45
|
|
|
|
|
|
|
# to create a more helpful (in the error message sense) parser. |
46
|
|
|
|
|
|
|
|
47
|
|
|
|
|
|
|
# ok you know what? no. This is waaaaaaay simpler. |
48
|
|
|
|
|
|
|
my $MODIFIER = qr/(?:[!=+-]|[+-]!|![+-])/o; |
49
|
|
|
|
|
|
|
my $PREFIX = qr/(?:$XML::RegExp::NCName|[A-Za-z][0-9A-Za-z.+-]*)/o; |
50
|
|
|
|
|
|
|
my $TERM = qr/(?:$PREFIX:\S*)/o; |
51
|
|
|
|
|
|
|
my $RFC5646 = qr/(?:[A-Za-z]+(?:-[0-9A-Za-z]+)*)/o; |
52
|
|
|
|
|
|
|
my $DESIGNATOR = qr/(?:[:_']|\@$RFC5646|\^$TERM)/o; |
53
|
|
|
|
|
|
|
my $DECLARATION = qr/^\s*\$\s+($XML::RegExp::NCName)(?:\s+(\$))?\s*$/mo; |
54
|
|
|
|
|
|
|
my $MACRO = qr/(?:\$\{($XML::RegExp::NCName)\}| |
55
|
|
|
|
|
|
|
\$($XML::RegExp::NCName))/xo; |
56
|
|
|
|
|
|
|
my $NOT_MACRO = qr/(?:(?!\$$XML::RegExp::NCName| |
57
|
|
|
|
|
|
|
\$\{$XML::RegExp::NCName\}).)*/xso; |
58
|
|
|
|
|
|
|
my $MACROS = qr/($NOT_MACRO)(?:$MACRO)?($NOT_MACRO)/smo; |
59
|
|
|
|
|
|
|
my $PARTIAL_STMT = qr/^\s*(?:($MODIFIER)\s+)? |
60
|
|
|
|
|
|
|
(?:($TERM)(?:\s+($TERM))?(?:\s+($DESIGNATOR))?| |
61
|
|
|
|
|
|
|
($TERM)\s+($DESIGNATOR)\s+($TERM)| |
62
|
|
|
|
|
|
|
($TERM)\s+($TERM)(?:\s+($DESIGNATOR))?\s+($TERM)) |
63
|
|
|
|
|
|
|
(?:\s+(\$))?\s*$/xsmo; |
64
|
|
|
|
|
|
|
|
65
|
|
|
|
|
|
|
my @MAP = qw(modifier term1 term2 designator term1 designator graph |
66
|
|
|
|
|
|
|
term1 term2 designator graph deref); |
67
|
|
|
|
|
|
|
|
68
|
|
|
|
|
|
|
=head1 SYNOPSIS |
69
|
|
|
|
|
|
|
|
70
|
|
|
|
|
|
|
my $kv = RDF::KV->new( |
71
|
|
|
|
|
|
|
subject => $uri, # ordinarily the Request-URI |
72
|
|
|
|
|
|
|
graph => $graphuri, # URI for the default graph |
73
|
|
|
|
|
|
|
namespaces => $ns, # default namespace prefix map |
74
|
|
|
|
|
|
|
callback => \&rewrite, # form-results-rewriting callback |
75
|
|
|
|
|
|
|
); |
76
|
|
|
|
|
|
|
|
77
|
|
|
|
|
|
|
# Processes a hashref-of-parameters, like found in Catalyst or |
78
|
|
|
|
|
|
|
# Plack::Request. This call will ignore obviously non-matching |
79
|
|
|
|
|
|
|
# keys, but will croak on botched attempts to use the protocol. |
80
|
|
|
|
|
|
|
|
81
|
|
|
|
|
|
|
my $patch = eval { $kv->process($params) }; |
82
|
|
|
|
|
|
|
if ($@) { |
83
|
|
|
|
|
|
|
# return 409 Conflict ... |
84
|
|
|
|
|
|
|
} |
85
|
|
|
|
|
|
|
|
86
|
|
|
|
|
|
|
# add/remove statements from the graph |
87
|
|
|
|
|
|
|
$patch->apply($model); |
88
|
|
|
|
|
|
|
|
89
|
|
|
|
|
|
|
=head1 DESCRIPTION |
90
|
|
|
|
|
|
|
|
91
|
|
|
|
|
|
|
This module provides a reference implementation for the L<RDF-KV |
92
|
|
|
|
|
|
|
protocol|http://doriantaylor.com/rdf-kv>. The objective of this |
93
|
|
|
|
|
|
|
protocol is to convey RDF linked data from a web browser to a web |
94
|
|
|
|
|
|
|
server using no mechanism beyond conventional |
95
|
|
|
|
|
|
|
C<application/x-www-form-urlencoded> HTML forms. The overarching |
96
|
|
|
|
|
|
|
purpose is to facilitate the development of linked data applications |
97
|
|
|
|
|
|
|
by making the apparatus of JavaScript an I<optional>, rather than a |
98
|
|
|
|
|
|
|
I<mandatory>, consideration. |
99
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
This protocol implementation works by culling key-value pairs denoted |
101
|
|
|
|
|
|
|
in a prescribed syntax from POSTed form input (parsed by something |
102
|
|
|
|
|
|
|
like L<CGI>, L<Plack::Request> or L<Catalyst>), and then stitching |
103
|
|
|
|
|
|
|
them together to create a L<patch object|RDF::KV::Patch> which is then |
104
|
|
|
|
|
|
|
applied to an L<RDF::Trine::Model> graph. |
105
|
|
|
|
|
|
|
|
106
|
|
|
|
|
|
|
=head1 METHODS |
107
|
|
|
|
|
|
|
|
108
|
|
|
|
|
|
|
=head2 new |
109
|
|
|
|
|
|
|
|
110
|
|
|
|
|
|
|
Instantiate the object. The following parameters are also (read-only) |
111
|
|
|
|
|
|
|
accessors. |
112
|
|
|
|
|
|
|
|
113
|
|
|
|
|
|
|
=over 4 |
114
|
|
|
|
|
|
|
|
115
|
|
|
|
|
|
|
=item subject |
116
|
|
|
|
|
|
|
|
117
|
|
|
|
|
|
|
This is the default subject URI (or blank node). |
118
|
|
|
|
|
|
|
|
119
|
|
|
|
|
|
|
=cut |
120
|
|
|
|
|
|
|
|
121
|
|
|
|
|
|
|
has subject => ( |
122
|
|
|
|
|
|
|
is => 'rw', |
123
|
|
|
|
|
|
|
isa => 'Str|URI', |
124
|
|
|
|
|
|
|
required => 1, |
125
|
|
|
|
|
|
|
); |
126
|
|
|
|
|
|
|
|
127
|
|
|
|
|
|
|
=item graph |
128
|
|
|
|
|
|
|
|
129
|
|
|
|
|
|
|
This is the default graph URI. |
130
|
|
|
|
|
|
|
|
131
|
|
|
|
|
|
|
=cut |
132
|
|
|
|
|
|
|
|
133
|
|
|
|
|
|
|
has graph => ( |
134
|
|
|
|
|
|
|
is => 'rw', |
135
|
|
|
|
|
|
|
isa => 'Str|URI', |
136
|
|
|
|
|
|
|
default => '', |
137
|
|
|
|
|
|
|
); |
138
|
|
|
|
|
|
|
|
139
|
|
|
|
|
|
|
=item namespaces |
140
|
|
|
|
|
|
|
|
141
|
|
|
|
|
|
|
This L<URI::NamespaceMap> object will enable URI abbreviation through |
142
|
|
|
|
|
|
|
the use of CURIEs in form input. |
143
|
|
|
|
|
|
|
|
144
|
|
|
|
|
|
|
=cut |
145
|
|
|
|
|
|
|
|
146
|
|
|
|
|
|
|
has namespaces => ( |
147
|
|
|
|
|
|
|
is => 'ro', |
148
|
|
|
|
|
|
|
isa => 'URI::NamespaceMap', |
149
|
|
|
|
|
|
|
default => sub { URI::NamespaceMap->new }, |
150
|
|
|
|
|
|
|
); |
151
|
|
|
|
|
|
|
|
152
|
|
|
|
|
|
|
=item callback |
153
|
|
|
|
|
|
|
|
154
|
|
|
|
|
|
|
Supply a callback function that will be applied to subject and object |
155
|
|
|
|
|
|
|
values, for instance to rewrite a URI. The return value of this |
156
|
|
|
|
|
|
|
function must be understood by L<RDF::KV::Patch/add_this>. |
157
|
|
|
|
|
|
|
|
158
|
|
|
|
|
|
|
=cut |
159
|
|
|
|
|
|
|
|
160
|
|
|
|
|
|
|
has callback => ( |
161
|
|
|
|
|
|
|
is => 'ro', |
162
|
|
|
|
|
|
|
isa => 'CodeRef', |
163
|
|
|
|
|
|
|
default => sub { sub { shift } }, |
164
|
|
|
|
|
|
|
); |
165
|
|
|
|
|
|
|
|
166
|
|
|
|
|
|
|
=back |
167
|
|
|
|
|
|
|
|
168
|
|
|
|
|
|
|
=head2 process \%CONTENT |
169
|
|
|
|
|
|
|
|
170
|
|
|
|
|
|
|
Process form content and return an L<RDF::KV::Patch> object. This is |
171
|
|
|
|
|
|
|
the only significant method. |
172
|
|
|
|
|
|
|
|
173
|
|
|
|
|
|
|
=cut |
174
|
|
|
|
|
|
|
|
175
|
|
|
|
|
|
|
# variants of parameter getters |
176
|
|
|
|
|
|
|
|
177
|
|
|
|
|
|
|
sub _1 { |
178
|
0
|
|
|
0
|
|
|
my ($params, $k) = @_; |
179
|
0
|
|
|
|
|
|
$params->get_all($k); |
180
|
|
|
|
|
|
|
} |
181
|
|
|
|
|
|
|
|
182
|
|
|
|
|
|
|
sub _2 { |
183
|
0
|
|
|
0
|
|
|
my ($params, $k) = @_; |
184
|
0
|
|
|
|
|
|
my $val = $params->{$k}; |
185
|
0
|
0
|
|
|
|
|
ref $val ? @$val : $val; |
186
|
|
|
|
|
|
|
} |
187
|
|
|
|
|
|
|
|
188
|
|
|
|
|
|
|
sub _uuid4 () { |
189
|
0
|
|
|
0
|
|
|
lc Data::GUID::Any::v4_guid_as_string(); |
190
|
|
|
|
|
|
|
} |
191
|
|
|
|
|
|
|
|
192
|
|
|
|
|
|
|
sub _uuid4urn () { |
193
|
0
|
|
|
0
|
|
|
'urn:uuid:' . _uuid4; |
194
|
|
|
|
|
|
|
} |
195
|
|
|
|
|
|
|
|
196
|
|
|
|
|
|
|
sub _uuid4bn () { |
197
|
0
|
|
|
0
|
|
|
URI::BNode->new; |
198
|
|
|
|
|
|
|
} |
199
|
|
|
|
|
|
|
|
200
|
|
|
|
|
|
|
# XXX these should all get syntax checks/CURIE expansion/etc |
201
|
|
|
|
|
|
|
my %SPECIALS = ( |
202
|
|
|
|
|
|
|
SUBJECT => sub { |
203
|
|
|
|
|
|
|
my ($self, $val) = @_; |
204
|
|
|
|
|
|
|
$self->subject($val->[-1]) if @$val; |
205
|
|
|
|
|
|
|
}, |
206
|
|
|
|
|
|
|
GRAPH => sub { |
207
|
|
|
|
|
|
|
my ($self, $val) = @_; |
208
|
|
|
|
|
|
|
$self->graph($val->[-1]) if @$val; |
209
|
|
|
|
|
|
|
}, |
210
|
|
|
|
|
|
|
PREFIX => sub { |
211
|
|
|
|
|
|
|
my ($self, $val) = @_; |
212
|
|
|
|
|
|
|
# XXX CHECK THIS MUTHA |
213
|
|
|
|
|
|
|
for my $v (@$val) { |
214
|
|
|
|
|
|
|
#warn $v; |
215
|
|
|
|
|
|
|
my ($prefix, $uri) = ($v =~ /^\s*(\S+):\s+(.*)$/) |
216
|
|
|
|
|
|
|
or Carp::croak("Invalid prefix mapping $val"); |
217
|
|
|
|
|
|
|
#warn $uri; |
218
|
|
|
|
|
|
|
$self->namespaces->add_mapping($prefix, $uri); |
219
|
|
|
|
|
|
|
} |
220
|
|
|
|
|
|
|
}, |
221
|
|
|
|
|
|
|
); |
222
|
|
|
|
|
|
|
|
223
|
|
|
|
|
|
|
my %GENERATED = ( |
224
|
|
|
|
|
|
|
NEW_UUID => [[\&_uuid4, 0]], |
225
|
|
|
|
|
|
|
NEW_UUID_URN => [[\&_uuid4urn, 0]], |
226
|
|
|
|
|
|
|
NEW_BNODE => [[\&_uuid4bn, 0]], |
227
|
|
|
|
|
|
|
); |
228
|
|
|
|
|
|
|
|
229
|
|
|
|
|
|
|
sub _deref_content { |
230
|
0
|
|
|
0
|
|
|
my ($val, $macros) = @_; |
231
|
0
|
|
|
|
|
|
my @out; |
232
|
|
|
|
|
|
|
|
233
|
|
|
|
|
|
|
# if $val is scalar, this loop will run just once. |
234
|
0
|
0
|
|
|
|
|
for my $v (ref $val ? @$val : ($val)) { |
235
|
|
|
|
|
|
|
# make this versatile |
236
|
0
|
0
|
|
|
|
|
$v = $v->[0] if ref $v; |
237
|
|
|
|
|
|
|
|
238
|
0
|
|
|
|
|
|
my @chunks; |
239
|
0
|
|
|
|
|
|
while ($v =~ /\G$MACROS/gco) { |
240
|
|
|
|
|
|
|
#warn "seen me"; |
241
|
0
|
|
|
|
|
|
my $pre = $1; |
242
|
0
|
|
0
|
|
|
|
my $macro = $2 || $3; |
243
|
0
|
|
|
|
|
|
my $post = $4; |
244
|
|
|
|
|
|
|
|
245
|
0
|
0
|
|
|
|
|
unless (defined $macro) { |
246
|
0
|
0
|
|
|
|
|
if (@chunks) { |
247
|
0
|
|
|
|
|
|
@chunks = map { "$_$pre$post" } @chunks; |
|
0
|
|
|
|
|
|
|
248
|
|
|
|
|
|
|
} |
249
|
|
|
|
|
|
|
else { |
250
|
0
|
|
|
|
|
|
@chunks = ($pre . $post); |
251
|
|
|
|
|
|
|
} |
252
|
0
|
|
|
|
|
|
next; |
253
|
|
|
|
|
|
|
} |
254
|
|
|
|
|
|
|
|
255
|
|
|
|
|
|
|
# do the actual macro dereferencing or noop in |
256
|
|
|
|
|
|
|
# lieu of a bound macro |
257
|
|
|
|
|
|
|
my @x = (defined $macros->{$macro} && @{$macros->{$macro}} ? |
258
|
0
|
0
|
|
|
|
|
(map { sprintf('%s%s%s', |
259
|
|
|
|
|
|
|
$pre, ref $_ ? &$_ : $_, $post) |
260
|
0
|
0
|
0
|
|
|
|
} @{$macros->{$macro}}) : ("$pre\$$macro$post")); |
|
0
|
|
|
|
|
|
|
261
|
|
|
|
|
|
|
# XXX LOLOLOL THIS IS THE MOST ILLEGIBLE PILE OF NONSENSE |
262
|
|
|
|
|
|
|
|
263
|
|
|
|
|
|
|
# it says: if a macro value is present, sub it or no-op, |
264
|
|
|
|
|
|
|
# but if the macro is a code ref, run it. |
265
|
|
|
|
|
|
|
|
266
|
|
|
|
|
|
|
#warn 'wat: ' . Data::Dumper::Dumper(\@x); |
267
|
|
|
|
|
|
|
|
268
|
|
|
|
|
|
|
# initialize chunks |
269
|
0
|
0
|
|
|
|
|
unless (@chunks) { |
270
|
|
|
|
|
|
|
#warn 'correct!'; |
271
|
0
|
|
|
|
|
|
@chunks = @x; |
272
|
0
|
|
|
|
|
|
next; |
273
|
|
|
|
|
|
|
} |
274
|
|
|
|
|
|
|
|
275
|
|
|
|
|
|
|
# replace chunks with product of itself and x |
276
|
0
|
0
|
|
|
|
|
if (@x) { |
277
|
0
|
|
|
|
|
|
my @y; |
278
|
0
|
|
|
|
|
|
for my $c (@chunks) { |
279
|
0
|
|
|
|
|
|
for my $d (@x) { |
280
|
|
|
|
|
|
|
#warn 'halp wtf'; |
281
|
0
|
|
|
|
|
|
push @y, "$c$d"; |
282
|
|
|
|
|
|
|
} |
283
|
|
|
|
|
|
|
} |
284
|
0
|
|
|
|
|
|
@chunks = @y; |
285
|
|
|
|
|
|
|
} |
286
|
|
|
|
|
|
|
} |
287
|
|
|
|
|
|
|
|
288
|
0
|
|
|
|
|
|
push @out, @chunks; |
289
|
|
|
|
|
|
|
} |
290
|
|
|
|
|
|
|
#warn 'hurr: ' . Data::Dumper::Dumper(\@out); |
291
|
|
|
|
|
|
|
|
292
|
|
|
|
|
|
|
|
293
|
0
|
0
|
|
|
|
|
wantarray ? @out : \@out; |
294
|
|
|
|
|
|
|
} |
295
|
|
|
|
|
|
|
|
296
|
|
|
|
|
|
|
sub _massage_macros { |
297
|
0
|
|
|
0
|
|
|
my $macros = shift; |
298
|
|
|
|
|
|
|
# XXX this currently makes destructive changes to $macros insofar |
299
|
|
|
|
|
|
|
# as it rewrites the 'deref' flag with the actual variables to |
300
|
|
|
|
|
|
|
# dereference, or to 0 if there aren't any. If this becomes a |
301
|
|
|
|
|
|
|
# problem, just use Clone. |
302
|
|
|
|
|
|
|
|
303
|
|
|
|
|
|
|
# cycle detect, finished product |
304
|
0
|
|
|
|
|
|
my (%seen, %done); |
305
|
|
|
|
|
|
|
|
306
|
|
|
|
|
|
|
# shallow-copy the hash |
307
|
0
|
|
|
|
|
|
my %pending = %$macros; |
308
|
|
|
|
|
|
|
|
309
|
|
|
|
|
|
|
# get rid of generated |
310
|
0
|
|
|
|
|
|
map { delete $pending{$_} } keys %GENERATED; |
|
0
|
|
|
|
|
|
|
311
|
|
|
|
|
|
|
|
312
|
|
|
|
|
|
|
# Start a queue with a (quasi) random macro. |
313
|
0
|
|
|
|
|
|
my @queue = (keys %pending)[0]; |
314
|
|
|
|
|
|
|
|
315
|
|
|
|
|
|
|
# If none of them contain a (bound) macro references, that macro |
316
|
|
|
|
|
|
|
# is 'done'. |
317
|
|
|
|
|
|
|
|
318
|
|
|
|
|
|
|
# If the values *do* contain bound macro references, check to see |
319
|
|
|
|
|
|
|
# if those are 'done'. If they aren't, *prepend* the keys to the |
320
|
|
|
|
|
|
|
# queue, before the current macro. |
321
|
|
|
|
|
|
|
|
322
|
0
|
|
|
|
|
|
while (@queue) { |
323
|
|
|
|
|
|
|
#warn 'Initial ' . join(';', @queue); |
324
|
0
|
|
|
|
|
|
my $k = shift @queue; |
325
|
|
|
|
|
|
|
#warn "beginning \$$k"; |
326
|
|
|
|
|
|
|
|
327
|
0
|
|
|
|
|
|
$seen{$k}++; |
328
|
|
|
|
|
|
|
|
329
|
0
|
|
|
|
|
|
my @vals = @{$macros->{$k}}; |
|
0
|
|
|
|
|
|
|
330
|
|
|
|
|
|
|
|
331
|
|
|
|
|
|
|
# 'done' and 'pending' macros |
332
|
0
|
|
|
|
|
|
my (%dm, %pm); |
333
|
|
|
|
|
|
|
|
334
|
|
|
|
|
|
|
# Examine each of its values. |
335
|
|
|
|
|
|
|
|
336
|
|
|
|
|
|
|
# Note: this test is equivalent to concatenating the values |
337
|
|
|
|
|
|
|
# together with spaces and performing the regex on that. But |
338
|
|
|
|
|
|
|
# we can't do that because we're storing the macro-matching |
339
|
|
|
|
|
|
|
# state of individual values. |
340
|
0
|
|
|
|
|
|
for my $pair (@vals) { |
341
|
0
|
|
|
|
|
|
my ($val, $deref) = @$pair; |
342
|
|
|
|
|
|
|
|
343
|
|
|
|
|
|
|
# no expando |
344
|
0
|
0
|
|
|
|
|
next unless $deref; |
345
|
|
|
|
|
|
|
|
346
|
0
|
0
|
|
|
|
|
if (ref $deref) { |
347
|
|
|
|
|
|
|
# already been scanned |
348
|
0
|
|
|
|
|
|
for my $m (@$deref) { |
349
|
0
|
0
|
|
|
|
|
defined $done{$m} ? $dm{$m}++ : $pm{$m}++; |
350
|
|
|
|
|
|
|
} |
351
|
|
|
|
|
|
|
} |
352
|
|
|
|
|
|
|
else { |
353
|
0
|
|
|
|
|
|
my %m; |
354
|
0
|
|
|
|
|
|
for my $m (grep { defined $_ } ($val =~ /$MACRO/og)) { |
|
0
|
|
|
|
|
|
|
355
|
|
|
|
|
|
|
|
356
|
|
|
|
|
|
|
# check first to see if it's bound |
357
|
0
|
0
|
|
|
|
|
next unless $macros->{$m}; |
358
|
|
|
|
|
|
|
#warn $m; |
359
|
|
|
|
|
|
|
|
360
|
|
|
|
|
|
|
# if it's yourself, explode |
361
|
0
|
0
|
|
|
|
|
Carp::croak("Self reference found!") if $m eq $k; |
362
|
|
|
|
|
|
|
|
363
|
|
|
|
|
|
|
# get this to replace deref |
364
|
0
|
|
|
|
|
|
$m{$m}++; |
365
|
|
|
|
|
|
|
|
366
|
|
|
|
|
|
|
# and get this to figure out if we can deref |
367
|
0
|
0
|
|
|
|
|
defined $done{$m} ? $dm{$m}++ : $pm{$m}++; |
368
|
|
|
|
|
|
|
} |
369
|
|
|
|
|
|
|
|
370
|
|
|
|
|
|
|
# now replace deref |
371
|
0
|
0
|
|
|
|
|
$pair->[1] = keys %m ? [sort keys %m] : 0; |
372
|
|
|
|
|
|
|
} |
373
|
|
|
|
|
|
|
} |
374
|
|
|
|
|
|
|
|
375
|
|
|
|
|
|
|
# macro values have pending matches |
376
|
0
|
0
|
|
|
|
|
if (keys %pm) { |
|
|
0
|
|
|
|
|
|
377
|
|
|
|
|
|
|
# this is where we would detect a cycle |
378
|
|
|
|
|
|
|
|
379
|
|
|
|
|
|
|
# right HERE |
380
|
|
|
|
|
|
|
|
381
|
0
|
|
|
|
|
|
my @q; |
382
|
0
|
|
|
|
|
|
for my $m (keys %pm) { |
383
|
0
|
0
|
|
|
|
|
Carp::croak("Cycle detected between $k and $m") if $seen{$m}; |
384
|
0
|
|
|
|
|
|
push @q, $m; |
385
|
|
|
|
|
|
|
} |
386
|
|
|
|
|
|
|
#warn join '/', @q; |
387
|
|
|
|
|
|
|
|
388
|
|
|
|
|
|
|
# do it again |
389
|
0
|
|
|
|
|
|
unshift @queue, @q, $k; |
390
|
|
|
|
|
|
|
#warn join ',', @queue; |
391
|
|
|
|
|
|
|
|
392
|
0
|
|
|
|
|
|
next; |
393
|
|
|
|
|
|
|
} |
394
|
|
|
|
|
|
|
elsif (keys %dm) { |
395
|
|
|
|
|
|
|
# macro values have actionable matches |
396
|
|
|
|
|
|
|
|
397
|
|
|
|
|
|
|
#warn "replacing values for \$$k"; |
398
|
|
|
|
|
|
|
|
399
|
|
|
|
|
|
|
# replace contents and mark done |
400
|
0
|
|
|
|
|
|
$done{$k} = _deref_content(\@vals, \%done); |
401
|
|
|
|
|
|
|
} |
402
|
|
|
|
|
|
|
else { |
403
|
|
|
|
|
|
|
#warn Data::Dumper::Dumper(\@vals); |
404
|
|
|
|
|
|
|
# nothing to do, mark done |
405
|
0
|
|
|
|
|
|
$done{$k} = [map { $_->[0] } @vals]; |
|
0
|
|
|
|
|
|
|
406
|
|
|
|
|
|
|
} |
407
|
|
|
|
|
|
|
|
408
|
|
|
|
|
|
|
# remember to remove this guy or we'll loop forever |
409
|
0
|
|
|
|
|
|
delete $pending{$k}; |
410
|
|
|
|
|
|
|
|
411
|
|
|
|
|
|
|
# replenish the queue with another pending object |
412
|
0
|
0
|
0
|
|
|
|
push @queue, (keys %pending)[0] if !@queue and keys %pending; |
413
|
|
|
|
|
|
|
} |
414
|
|
|
|
|
|
|
|
415
|
0
|
|
|
|
|
|
\%done; |
416
|
|
|
|
|
|
|
} |
417
|
|
|
|
|
|
|
|
418
|
|
|
|
|
|
|
|
419
|
|
|
|
|
|
|
sub process { |
420
|
0
|
|
|
0
|
1
|
|
my ($self, $params) = @_; |
421
|
|
|
|
|
|
|
|
422
|
|
|
|
|
|
|
# assume this can also be a Hash::MultiValue |
423
|
0
|
0
|
0
|
|
|
|
my $sub = Scalar::Util::blessed($params) |
424
|
|
|
|
|
|
|
&& $params->can('get_all') ? \&_1 : \&_2; |
425
|
|
|
|
|
|
|
# XXX do we want to do ->isa instead? |
426
|
|
|
|
|
|
|
|
427
|
|
|
|
|
|
|
# begin by seeding macros with generators |
428
|
0
|
|
|
|
|
|
my %macros = %GENERATED; |
429
|
|
|
|
|
|
|
|
430
|
0
|
|
|
|
|
|
my (%maybe, %neither); |
431
|
|
|
|
|
|
|
|
432
|
0
|
|
|
|
|
|
for my $k (keys %$params) { |
433
|
|
|
|
|
|
|
# Step 0: get the values into a homogeneous list |
434
|
0
|
|
|
|
|
|
my @v = $sub->($params, $k); |
435
|
|
|
|
|
|
|
|
436
|
|
|
|
|
|
|
# Step 1: pull out all the macro declarations |
437
|
0
|
0
|
0
|
|
|
|
if (my ($name, $sigil) = ($k =~ $DECLARATION)) { |
|
|
0
|
|
|
|
|
|
438
|
|
|
|
|
|
|
# Step 1.0.1: create [content, deref flag] pairs |
439
|
|
|
|
|
|
|
|
440
|
|
|
|
|
|
|
# skip over generated macros |
441
|
0
|
0
|
|
|
|
|
next if $GENERATED{$name}; |
442
|
|
|
|
|
|
|
|
443
|
|
|
|
|
|
|
# OOH VERY CLEVER |
444
|
0
|
|
0
|
|
|
|
push @{$macros{$name} ||= []}, (map { [$_, int(!!$sigil)] } @v); |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
445
|
|
|
|
|
|
|
} |
446
|
|
|
|
|
|
|
# Step 1.1: set aside candidate statements |
447
|
|
|
|
|
|
|
elsif ($k =~ /^\s*\S+\s+\S+.*?/ or $k =~ /[:\$]/) { |
448
|
|
|
|
|
|
|
# valid partial statements will contain space or : or $ |
449
|
0
|
|
0
|
|
|
|
push @{$maybe{$k} ||= []}, @v; |
|
0
|
|
|
|
|
|
|
450
|
|
|
|
|
|
|
} |
451
|
|
|
|
|
|
|
# Step 1.2: put the rest in a discard pile |
452
|
|
|
|
|
|
|
else { |
453
|
0
|
|
0
|
|
|
|
push @{$neither{$k} ||= []}, @v; |
|
0
|
|
|
|
|
|
|
454
|
|
|
|
|
|
|
} |
455
|
|
|
|
|
|
|
} |
456
|
|
|
|
|
|
|
|
457
|
|
|
|
|
|
|
# cycles should cause a 409 Conflict error, but that isn't our job |
458
|
|
|
|
|
|
|
# here. |
459
|
|
|
|
|
|
|
|
460
|
|
|
|
|
|
|
# XXX although it may be useful to return an object in $@ that was |
461
|
|
|
|
|
|
|
# more informative. |
462
|
|
|
|
|
|
|
|
463
|
|
|
|
|
|
|
# Step 2: dereference all the macros (that asked to be) |
464
|
|
|
|
|
|
|
try { |
465
|
0
|
|
|
0
|
|
|
my $x = _massage_macros(\%macros); |
466
|
0
|
|
|
|
|
|
%macros = %$x; |
467
|
|
|
|
|
|
|
} catch { |
468
|
|
|
|
|
|
|
# move this error up in the stack |
469
|
0
|
|
|
0
|
|
|
Carp::croak($@); |
470
|
0
|
|
|
|
|
|
}; |
471
|
|
|
|
|
|
|
|
472
|
|
|
|
|
|
|
# Step 2.1: overwrite any reserved/magic macros |
473
|
|
|
|
|
|
|
#$macros{NEW_UUID} = [[\&_uuid4, 1]]; |
474
|
|
|
|
|
|
|
#$macros{NEW_UUID_URN} = [[\&_uuid4urn, 1]]; |
475
|
|
|
|
|
|
|
#$macros{NEW_BNODE} = [[\&_uuid4bn, 1]]; |
476
|
|
|
|
|
|
|
# XXX make this extensible? |
477
|
|
|
|
|
|
|
|
478
|
|
|
|
|
|
|
# Step 3: apply special control macros to $self |
479
|
|
|
|
|
|
|
try { |
480
|
0
|
|
|
0
|
|
|
for my $k (keys %SPECIALS) { |
481
|
0
|
0
|
|
|
|
|
next unless $macros{$k}; |
482
|
0
|
|
|
|
|
|
$SPECIALS{$k}->($self, $macros{$k}); |
483
|
|
|
|
|
|
|
} |
484
|
|
|
|
|
|
|
} catch { |
485
|
|
|
|
|
|
|
# cough any errors up the stack |
486
|
0
|
|
|
0
|
|
|
Carp::croak($@); |
487
|
0
|
|
|
|
|
|
}; |
488
|
|
|
|
|
|
|
|
489
|
|
|
|
|
|
|
#require Data::Dumper; |
490
|
|
|
|
|
|
|
#warn Data::Dumper::Dumper(\%macros); |
491
|
|
|
|
|
|
|
|
492
|
|
|
|
|
|
|
|
493
|
|
|
|
|
|
|
# add/remove statements |
494
|
0
|
|
|
|
|
|
my $patch = RDF::KV::Patch->new; |
495
|
0
|
|
|
|
|
|
my (%pos, %neg); |
496
|
0
|
|
|
|
|
|
for my $k (keys %maybe) { |
497
|
|
|
|
|
|
|
# Step 4: dereference macros in statements |
498
|
|
|
|
|
|
|
|
499
|
|
|
|
|
|
|
# Step 4.1 dereference macros in statement *templates* first |
500
|
|
|
|
|
|
|
# so we can figure out which values need to be dereferenced |
501
|
|
|
|
|
|
|
# (since the terminating $ indicator can be substituted in via |
502
|
|
|
|
|
|
|
# macro). |
503
|
0
|
0
|
|
|
|
|
my @k = grep { defined $_ } ($k =~ /$MACRO/og) ? |
|
0
|
|
|
|
|
|
|
504
|
|
|
|
|
|
|
_deref_content($k, \%macros) : ($k); |
505
|
|
|
|
|
|
|
|
506
|
|
|
|
|
|
|
# we want to check the values for empty strings *before* we |
507
|
|
|
|
|
|
|
# dereference them so it's still possible to express the empty |
508
|
|
|
|
|
|
|
# string through the use of a macro |
509
|
0
|
|
|
|
|
|
my @v = grep { $_ ne '' } map { $_ =~ s/^\s*(.*?)\s*$/$1/sm; $_ } |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
510
|
0
|
0
|
|
|
|
|
grep { defined $_ } @{$maybe{$k} || []}; |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
511
|
|
|
|
|
|
|
|
512
|
|
|
|
|
|
|
#require Data::Dumper; |
513
|
|
|
|
|
|
|
#warn Data::Dumper::Dumper($maybe{$k}); |
514
|
|
|
|
|
|
|
|
515
|
|
|
|
|
|
|
# very well could loop just once here |
516
|
0
|
|
|
|
|
|
for my $template (@k) { |
517
|
|
|
|
|
|
|
#warn "lol $template"; |
518
|
|
|
|
|
|
|
|
519
|
|
|
|
|
|
|
# nope actually we're parsing the template now |
520
|
0
|
|
|
|
|
|
my @tokens = ($template =~ $PARTIAL_STMT); |
521
|
|
|
|
|
|
|
|
522
|
|
|
|
|
|
|
#warn scalar @tokens; |
523
|
|
|
|
|
|
|
|
524
|
|
|
|
|
|
|
# ignore if there wasn't a match XXX WARN SOMEHOW? |
525
|
0
|
0
|
|
|
|
|
next unless @tokens; |
526
|
|
|
|
|
|
|
|
527
|
|
|
|
|
|
|
# do not ignore, however, if this screws up |
528
|
0
|
0
|
|
|
|
|
die 'INTERNAL ERROR: regex does not match map' |
529
|
|
|
|
|
|
|
unless @tokens == @MAP; |
530
|
|
|
|
|
|
|
|
531
|
|
|
|
|
|
|
# now make a nice hash of the contents |
532
|
0
|
|
|
|
|
|
my %contents; |
533
|
|
|
|
|
|
|
map { |
534
|
0
|
0
|
|
|
|
|
$contents{$MAP[$_]} = $tokens[$_] if defined $tokens[$_] |
|
0
|
|
|
|
|
|
|
535
|
|
|
|
|
|
|
} (0..$#MAP); |
536
|
|
|
|
|
|
|
|
537
|
|
|
|
|
|
|
# just to recap, %contents can contain, at maximum: |
538
|
|
|
|
|
|
|
# * modifier (reverse statement, negate, etc) |
539
|
|
|
|
|
|
|
# * term1 (either subject or predicate) |
540
|
|
|
|
|
|
|
# * term2 (either predicate or object) |
541
|
|
|
|
|
|
|
# * designator (treat input values as URI/blank/literal[type?]) |
542
|
|
|
|
|
|
|
# * graph URI |
543
|
|
|
|
|
|
|
# * macro-dereference instruction |
544
|
|
|
|
|
|
|
|
545
|
|
|
|
|
|
|
# pull out the statement modifier first |
546
|
|
|
|
|
|
|
$contents{modifier} = { |
547
|
0
|
|
0
|
|
|
|
map { $_ => 1 } (split //, $contents{modifier} || '') }; |
|
0
|
|
|
|
|
|
|
548
|
|
|
|
|
|
|
|
549
|
|
|
|
|
|
|
# now deal with designator |
550
|
0
|
0
|
|
|
|
|
if ($contents{designator}) { |
551
|
0
|
|
|
|
|
|
my ($sigil, $symbol) = ($contents{designator} =~ /^(.)(.*)$/); |
552
|
|
|
|
|
|
|
|
553
|
|
|
|
|
|
|
Carp::croak("Reversed statement templates " . |
554
|
|
|
|
|
|
|
"cannot specify literals ($template)") |
555
|
0
|
0
|
0
|
|
|
|
if ($contents{modifier}{'!'} and $sigil =~ /['@^]/); |
556
|
|
|
|
|
|
|
|
557
|
0
|
0
|
|
|
|
|
if ($sigil eq '^') { |
558
|
|
|
|
|
|
|
# expand datatype URI |
559
|
0
|
|
0
|
|
|
|
$symbol = $self->namespaces->uri($symbol) || $symbol; |
560
|
|
|
|
|
|
|
} |
561
|
|
|
|
|
|
|
|
562
|
|
|
|
|
|
|
$contents{designator} = |
563
|
0
|
0
|
|
|
|
|
$symbol eq '' ? [$sigil] : [$sigil, $symbol]; |
564
|
|
|
|
|
|
|
} |
565
|
|
|
|
|
|
|
else { |
566
|
|
|
|
|
|
|
# single-tick is the default designator for forward |
567
|
|
|
|
|
|
|
# statements, : is for reverse. |
568
|
|
|
|
|
|
|
$contents{designator} = [ |
569
|
0
|
0
|
|
|
|
|
$contents{modifier}{'!'} ? ':' : q/'/ ]; |
570
|
|
|
|
|
|
|
} |
571
|
|
|
|
|
|
|
|
572
|
|
|
|
|
|
|
# now we should expand the rest of the abbreviations |
573
|
0
|
|
|
|
|
|
for my $which (qw(term1 term2 graph)) { |
574
|
0
|
0
|
|
|
|
|
if (defined $contents{$which}) { |
575
|
|
|
|
|
|
|
my $uri = $self->namespaces->uri($contents{$which}) |
576
|
0
|
|
0
|
|
|
|
|| $contents{$which}; |
577
|
|
|
|
|
|
|
# XXX should we do some sort of relative uri |
578
|
|
|
|
|
|
|
# resolution thing? |
579
|
0
|
|
|
|
|
|
$contents{$which} = $uri; |
580
|
|
|
|
|
|
|
} |
581
|
|
|
|
|
|
|
} |
582
|
|
|
|
|
|
|
|
583
|
|
|
|
|
|
|
# I suppose we can do this now |
584
|
0
|
0
|
|
|
|
|
if ($contents{deref}) { |
585
|
|
|
|
|
|
|
# XXX might want to trim bounding whitespace again |
586
|
0
|
|
|
|
|
|
@v = map { _deref_content($_, \%macros) } @v; |
|
0
|
|
|
|
|
|
|
587
|
|
|
|
|
|
|
} |
588
|
|
|
|
|
|
|
|
589
|
|
|
|
|
|
|
#require Data::Dumper; |
590
|
|
|
|
|
|
|
#warn Data::Dumper::Dumper([\%contents, \@v]); |
591
|
|
|
|
|
|
|
|
592
|
|
|
|
|
|
|
# statement reversal behaviour is not entirely symmetric. |
593
|
|
|
|
|
|
|
|
594
|
|
|
|
|
|
|
# + is a noop of the default behaviour: assert S P O or O P S. |
595
|
|
|
|
|
|
|
# = means remove S P * before asserting S P O. (no reversal) |
596
|
|
|
|
|
|
|
# - means either remove S P *, S P O or O P S, but not O P *. |
597
|
|
|
|
|
|
|
|
598
|
|
|
|
|
|
|
# No, you know what? Restricting reverse wildcards is |
599
|
|
|
|
|
|
|
# going to make it a hell of a problem to do things like |
600
|
|
|
|
|
|
|
# completely disconnect one resource from another set of |
601
|
|
|
|
|
|
|
# resources. This protocol has to assume the end user is |
602
|
|
|
|
|
|
|
# allowed to make these kinds of changes. We'll mop up the |
603
|
|
|
|
|
|
|
# permission stuff elsewhere. |
604
|
|
|
|
|
|
|
|
605
|
|
|
|
|
|
|
# thinking this oughta do it: |
606
|
|
|
|
|
|
|
# { g => { s => { p => [{ o => 1 }, { langordt => { o => 1 }}]}}} |
607
|
|
|
|
|
|
|
|
608
|
0
|
|
0
|
|
|
|
my $g = $contents{graph} || $self->graph; |
609
|
|
|
|
|
|
|
|
610
|
0
|
0
|
|
|
|
|
if ($contents{modifier}{'!'}) { |
611
|
|
|
|
|
|
|
# reverse statement (O P S) |
612
|
0
|
|
|
|
|
|
my $p = $contents{term1}; |
613
|
0
|
|
0
|
|
|
|
my $o = URI::BNode->new($contents{term2} || $self->subject); |
614
|
|
|
|
|
|
|
|
615
|
|
|
|
|
|
|
# don't forget to do this |
616
|
0
|
0
|
|
|
|
|
$o = $self->callback->($o) if $self->callback; |
617
|
|
|
|
|
|
|
|
618
|
|
|
|
|
|
|
# you know what, it makes no sense for a reverse |
619
|
|
|
|
|
|
|
# statement to be anything but a URI or a blank node. |
620
|
|
|
|
|
|
|
|
621
|
0
|
0
|
|
|
|
|
next unless $contents{designator}[0] =~ /[_:]/; |
622
|
|
|
|
|
|
|
|
623
|
0
|
0
|
|
|
|
|
if ($contents{modifier}{'-'}) { |
624
|
|
|
|
|
|
|
# remove these triples |
625
|
0
|
|
|
|
|
|
for my $s (@v) { |
626
|
0
|
0
|
|
|
|
|
if ($contents{designator}[0] eq '_') { |
627
|
0
|
0
|
|
|
|
|
$s = '_:' . $s unless $s =~ /^_:/; |
628
|
|
|
|
|
|
|
} |
629
|
|
|
|
|
|
|
else { |
630
|
0
|
|
|
|
|
|
$s = URI->new_abs($s, $o); |
631
|
0
|
0
|
|
|
|
|
$s = $self->callback->($s) if $self->callback; |
632
|
|
|
|
|
|
|
} |
633
|
|
|
|
|
|
|
|
634
|
0
|
|
0
|
|
|
|
$neg{$g} ||= {}; |
635
|
0
|
|
0
|
|
|
|
$neg{$g}{$s} ||= {}; |
636
|
0
|
|
0
|
|
|
|
$neg{$g}{$s}{$p} ||= [{}, {}]; |
637
|
0
|
0
|
|
|
|
|
$neg{$g}{$s}{$p}[0]{$o} = 1 if ref $neg{$g}{$s}{$p}; |
638
|
|
|
|
|
|
|
|
639
|
0
|
|
|
|
|
|
$patch->remove_this($s, $p, $o, $g); |
640
|
|
|
|
|
|
|
} |
641
|
|
|
|
|
|
|
} |
642
|
|
|
|
|
|
|
else { |
643
|
|
|
|
|
|
|
# add these triples |
644
|
0
|
|
|
|
|
|
for my $s (@v) { |
645
|
0
|
0
|
|
|
|
|
next if $s eq ''; |
646
|
0
|
0
|
|
|
|
|
if ($contents{designator}[0] eq '_') { |
647
|
0
|
0
|
|
|
|
|
$s = '_:' . $s unless $s =~ /^_:/; |
648
|
|
|
|
|
|
|
} |
649
|
|
|
|
|
|
|
else { |
650
|
0
|
|
|
|
|
|
$s = URI->new_abs($s, $o); |
651
|
0
|
0
|
|
|
|
|
$s = $self->callback->($s) if $self->callback; |
652
|
|
|
|
|
|
|
} |
653
|
|
|
|
|
|
|
|
654
|
0
|
|
0
|
|
|
|
$pos{$g} ||= {}; |
655
|
0
|
|
0
|
|
|
|
$pos{$g}{$s} ||= {}; |
656
|
0
|
|
0
|
|
|
|
$pos{$g}{$s}{$p} ||= [{}, {}]; |
657
|
0
|
0
|
|
|
|
|
$pos{$g}{$s}{$p}[0]{$o} = 1 if ref $pos{$g}{$s}{$p}; |
658
|
|
|
|
|
|
|
|
659
|
0
|
|
|
|
|
|
$patch->add_this($s, $p, $o, $g); |
660
|
|
|
|
|
|
|
} |
661
|
|
|
|
|
|
|
} |
662
|
|
|
|
|
|
|
} |
663
|
|
|
|
|
|
|
else { |
664
|
|
|
|
|
|
|
# forward statement (S P O) |
665
|
0
|
|
|
|
|
|
my ($s, $p); |
666
|
0
|
0
|
|
|
|
|
if ($contents{term2}) { |
667
|
0
|
|
|
|
|
|
($s, $p) = @contents{qw(term1 term2)}; |
668
|
|
|
|
|
|
|
} |
669
|
|
|
|
|
|
|
else { |
670
|
0
|
|
|
|
|
|
$s = $self->subject; |
671
|
0
|
|
|
|
|
|
$p = $contents{term1}; |
672
|
|
|
|
|
|
|
} |
673
|
|
|
|
|
|
|
|
674
|
|
|
|
|
|
|
# (potentially) rewrite the URI |
675
|
0
|
0
|
|
|
|
|
$s = $self->callback->($s) if $self->callback; |
676
|
|
|
|
|
|
|
|
677
|
0
|
0
|
|
|
|
|
if ($contents{modifier}{'-'}) { |
678
|
|
|
|
|
|
|
# remove these triples |
679
|
0
|
|
0
|
|
|
|
$neg{$g} ||= {}; |
680
|
0
|
|
0
|
|
|
|
$neg{$g}{$s} ||= {}; |
681
|
0
|
|
0
|
|
|
|
$neg{$g}{$s}{$p} ||= [{}, {}]; |
682
|
|
|
|
|
|
|
|
683
|
0
|
0
|
0
|
|
|
|
if (@v and ref $neg{$g}{$s}{$p}) { |
684
|
0
|
|
|
|
|
|
for my $o (@v) { |
685
|
|
|
|
|
|
|
# empty string is a wildcard on negated |
686
|
|
|
|
|
|
|
# templates |
687
|
0
|
0
|
|
|
|
|
if ($o eq '') { |
688
|
0
|
|
|
|
|
|
$neg{$g}{$s}{$p} = 1; |
689
|
0
|
|
|
|
|
|
$patch->remove_this($s, $p, $o, $g); |
690
|
0
|
|
|
|
|
|
last; |
691
|
|
|
|
|
|
|
} |
692
|
|
|
|
|
|
|
|
693
|
|
|
|
|
|
|
# haha holy shit |
694
|
0
|
|
|
|
|
|
my $d = $contents{designator}; |
695
|
0
|
0
|
|
|
|
|
if ($d->[0] =~ /[_:]/) { |
|
|
0
|
|
|
|
|
|
696
|
0
|
0
|
0
|
|
|
|
$o = "_:$o" if $d->[0] eq '_' and $o !~ /^_:/; |
697
|
0
|
|
0
|
|
|
|
my $uri = $self->namespaces->uri($o) || $o; |
698
|
0
|
0
|
|
|
|
|
if ($d->[0] eq ':') { |
699
|
0
|
|
|
|
|
|
$uri = URI->new_abs($uri, $s); |
700
|
0
|
0
|
|
|
|
|
$uri = $self->callback->($uri) |
701
|
|
|
|
|
|
|
if $self->callback; |
702
|
|
|
|
|
|
|
} |
703
|
0
|
|
|
|
|
|
$neg{$g}{$s}{$p}[0]{$uri} = 1; |
704
|
|
|
|
|
|
|
|
705
|
0
|
|
|
|
|
|
$o = $uri; |
706
|
|
|
|
|
|
|
} |
707
|
|
|
|
|
|
|
elsif ($d->[0] =~ /[@^]/) { |
708
|
0
|
|
|
|
|
|
my $x = join '', @$d; |
709
|
0
|
|
0
|
|
|
|
my $y = $neg{$g}{$s}{$p}[1]{$x} ||= {}; |
710
|
0
|
|
|
|
|
|
$y->{$o} = 1; |
711
|
0
|
0
|
|
|
|
|
$o = [$o, $d->[0] eq '@' ? |
712
|
|
|
|
|
|
|
$d->[1] : (undef, $d->[1])]; |
713
|
|
|
|
|
|
|
} |
714
|
|
|
|
|
|
|
else { |
715
|
0
|
|
0
|
|
|
|
my $x = $neg{$g}{$s}{$p}[1]{''} ||= {}; |
716
|
0
|
|
|
|
|
|
$x->{$o} = 1; |
717
|
|
|
|
|
|
|
} |
718
|
|
|
|
|
|
|
|
719
|
0
|
|
|
|
|
|
$patch->remove_this($s, $p, $o, $g); |
720
|
|
|
|
|
|
|
} |
721
|
|
|
|
|
|
|
} |
722
|
|
|
|
|
|
|
} |
723
|
|
|
|
|
|
|
else { |
724
|
0
|
0
|
|
|
|
|
if ($contents{modifier}{'='}) { |
725
|
|
|
|
|
|
|
# remove triple wildcard |
726
|
0
|
|
0
|
|
|
|
$neg{$g} ||= {}; |
727
|
0
|
|
0
|
|
|
|
$neg{$g}{$s} ||= {}; |
728
|
0
|
|
|
|
|
|
$neg{$g}{$s}{$p} = 1; |
729
|
|
|
|
|
|
|
|
730
|
0
|
|
|
|
|
|
$patch->remove_this($s, $p, undef, $g); |
731
|
|
|
|
|
|
|
} |
732
|
|
|
|
|
|
|
|
733
|
|
|
|
|
|
|
# add triples |
734
|
0
|
|
0
|
|
|
|
$pos{$g} ||= {}; |
735
|
0
|
|
0
|
|
|
|
$pos{$g}{$s} ||= {}; |
736
|
0
|
|
0
|
|
|
|
$pos{$g}{$s}{$p} ||= [{}, {}]; |
737
|
|
|
|
|
|
|
|
738
|
0
|
|
|
|
|
|
for my $o (@v) { |
739
|
0
|
|
|
|
|
|
my $d = $contents{designator}; |
740
|
0
|
0
|
|
|
|
|
if ($d->[0] =~ /[_:]/) { |
|
|
0
|
|
|
|
|
|
741
|
0
|
0
|
|
|
|
|
next if $o eq ''; |
742
|
|
|
|
|
|
|
|
743
|
0
|
0
|
0
|
|
|
|
$o = "_:$o" if $d->[0] eq '_' and $o !~ /^_:/; |
744
|
0
|
|
0
|
|
|
|
my $uri = $self->namespaces->uri($o) || $o; |
745
|
0
|
0
|
|
|
|
|
if ($d->[0] eq ':') { |
746
|
0
|
|
|
|
|
|
$uri = URI->new_abs($uri, $s); |
747
|
0
|
0
|
|
|
|
|
$uri = $self->callback->($uri) |
748
|
|
|
|
|
|
|
if $self->callback; |
749
|
|
|
|
|
|
|
} |
750
|
|
|
|
|
|
|
|
751
|
0
|
|
|
|
|
|
$pos{$g}{$s}{$p}[0]{$uri} = 1; |
752
|
|
|
|
|
|
|
|
753
|
0
|
|
|
|
|
|
$o = $uri; |
754
|
|
|
|
|
|
|
} |
755
|
|
|
|
|
|
|
elsif ($d->[0] =~ /[@^]/) { |
756
|
0
|
|
|
|
|
|
my $x = join '', @$d; |
757
|
0
|
|
0
|
|
|
|
my $y = $pos{$g}{$s}{$p}[1]{$x} ||= {}; |
758
|
0
|
|
|
|
|
|
$y->{$o} = 1; |
759
|
|
|
|
|
|
|
|
760
|
0
|
0
|
|
|
|
|
$o = [$o, |
761
|
|
|
|
|
|
|
$d->[0] eq '@' ? $d->[1] : (undef, $d->[1])]; |
762
|
|
|
|
|
|
|
} |
763
|
|
|
|
|
|
|
else { |
764
|
0
|
|
0
|
|
|
|
my $x = $pos{$g}{$s}{$p}[1]{''} ||= {}; |
765
|
0
|
|
|
|
|
|
$x->{$o} = 1; |
766
|
|
|
|
|
|
|
} |
767
|
|
|
|
|
|
|
|
768
|
0
|
|
|
|
|
|
$patch->add_this($s, $p, $o, $g); |
769
|
|
|
|
|
|
|
} |
770
|
|
|
|
|
|
|
} |
771
|
|
|
|
|
|
|
} |
772
|
|
|
|
|
|
|
|
773
|
|
|
|
|
|
|
# you can tell a blank node from a resource if it starts |
774
|
|
|
|
|
|
|
# with _: |
775
|
|
|
|
|
|
|
|
776
|
|
|
|
|
|
|
# for negative wildcards: { g => { s => { p => 1 } } } |
777
|
|
|
|
|
|
|
# since removing S P * overrides any S P O. |
778
|
|
|
|
|
|
|
|
779
|
|
|
|
|
|
|
# an empty @v means there was no value for this key that |
780
|
|
|
|
|
|
|
# was more than whitespace/empty string. |
781
|
|
|
|
|
|
|
|
782
|
|
|
|
|
|
|
|
783
|
|
|
|
|
|
|
# in this case we probably can't be clever and reuse the |
784
|
|
|
|
|
|
|
# values for multiple templates because some may or may |
785
|
|
|
|
|
|
|
# not include the indicator. |
786
|
|
|
|
|
|
|
|
787
|
|
|
|
|
|
|
# actually we can reuse the values, we just can't parse |
788
|
|
|
|
|
|
|
# them until we've parsed the statement templates, because |
789
|
|
|
|
|
|
|
# those tell us what to do with the values. |
790
|
|
|
|
|
|
|
|
791
|
|
|
|
|
|
|
# which also means we have to parse the statement |
792
|
|
|
|
|
|
|
# templates immediately. |
793
|
|
|
|
|
|
|
|
794
|
|
|
|
|
|
|
# there is still the issue of the empty string: what does |
795
|
|
|
|
|
|
|
# it mean, and in what context? |
796
|
|
|
|
|
|
|
|
797
|
|
|
|
|
|
|
# Step 4.2 dereference macros in statement *values* (that |
798
|
|
|
|
|
|
|
# asked to be) |
799
|
|
|
|
|
|
|
|
800
|
|
|
|
|
|
|
|
801
|
|
|
|
|
|
|
# Step 5: parse statement templates |
802
|
|
|
|
|
|
|
|
803
|
|
|
|
|
|
|
# Step 5.1 expand qnames |
804
|
|
|
|
|
|
|
|
805
|
|
|
|
|
|
|
# Step 6: generate complete statements |
806
|
|
|
|
|
|
|
} |
807
|
|
|
|
|
|
|
} |
808
|
|
|
|
|
|
|
|
809
|
|
|
|
|
|
|
#return [\%neg, \%pos]; |
810
|
|
|
|
|
|
|
|
811
|
0
|
|
|
|
|
|
return $patch; |
812
|
|
|
|
|
|
|
} |
813
|
|
|
|
|
|
|
|
814
|
|
|
|
|
|
|
=head1 CAVEATS |
815
|
|
|
|
|
|
|
|
816
|
|
|
|
|
|
|
B<BYOS> == Bring Your Own Security. |
817
|
|
|
|
|
|
|
|
818
|
|
|
|
|
|
|
=head1 AUTHOR |
819
|
|
|
|
|
|
|
|
820
|
|
|
|
|
|
|
Dorian Taylor, C<< <dorian at cpan.org> >> |
821
|
|
|
|
|
|
|
|
822
|
|
|
|
|
|
|
=head1 BUGS |
823
|
|
|
|
|
|
|
|
824
|
|
|
|
|
|
|
Please report any bugs or feature requests to C<bug-rdf-kv at |
825
|
|
|
|
|
|
|
rt.cpan.org>, or through the web interface at |
826
|
|
|
|
|
|
|
L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=RDF-KV>. I will be |
827
|
|
|
|
|
|
|
notified, and then you'll automatically be notified of progress on |
828
|
|
|
|
|
|
|
your bug as I make changes. |
829
|
|
|
|
|
|
|
|
830
|
|
|
|
|
|
|
=head1 SUPPORT |
831
|
|
|
|
|
|
|
|
832
|
|
|
|
|
|
|
You can find documentation for this module with the perldoc command. |
833
|
|
|
|
|
|
|
|
834
|
|
|
|
|
|
|
perldoc RDF::KV |
835
|
|
|
|
|
|
|
|
836
|
|
|
|
|
|
|
You can also look for information at: |
837
|
|
|
|
|
|
|
|
838
|
|
|
|
|
|
|
=over 4 |
839
|
|
|
|
|
|
|
|
840
|
|
|
|
|
|
|
=item * RT: CPAN's request tracker (report bugs here) |
841
|
|
|
|
|
|
|
|
842
|
|
|
|
|
|
|
L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=RDF-KV> |
843
|
|
|
|
|
|
|
|
844
|
|
|
|
|
|
|
=item * AnnoCPAN: Annotated CPAN documentation |
845
|
|
|
|
|
|
|
|
846
|
|
|
|
|
|
|
L<http://annocpan.org/dist/RDF-KV> |
847
|
|
|
|
|
|
|
|
848
|
|
|
|
|
|
|
=item * CPAN Ratings |
849
|
|
|
|
|
|
|
|
850
|
|
|
|
|
|
|
L<http://cpanratings.perl.org/d/RDF-KV> |
851
|
|
|
|
|
|
|
|
852
|
|
|
|
|
|
|
=item * Search CPAN |
853
|
|
|
|
|
|
|
|
854
|
|
|
|
|
|
|
L<http://search.cpan.org/dist/RDF-KV/> |
855
|
|
|
|
|
|
|
|
856
|
|
|
|
|
|
|
=back |
857
|
|
|
|
|
|
|
|
858
|
|
|
|
|
|
|
=head1 SEE ALSO |
859
|
|
|
|
|
|
|
|
860
|
|
|
|
|
|
|
=over 4 |
861
|
|
|
|
|
|
|
|
862
|
|
|
|
|
|
|
=item L<RDF::KV::Patch> |
863
|
|
|
|
|
|
|
|
864
|
|
|
|
|
|
|
=item L<URI::BNode> |
865
|
|
|
|
|
|
|
|
866
|
|
|
|
|
|
|
=item L<RDF::Trine> |
867
|
|
|
|
|
|
|
|
868
|
|
|
|
|
|
|
=back |
869
|
|
|
|
|
|
|
|
870
|
|
|
|
|
|
|
=head1 LICENSE AND COPYRIGHT |
871
|
|
|
|
|
|
|
|
872
|
|
|
|
|
|
|
Copyright 2013 Dorian Taylor. |
873
|
|
|
|
|
|
|
|
874
|
|
|
|
|
|
|
Licensed under the Apache License, Version 2.0 (the "License"); you |
875
|
|
|
|
|
|
|
may not use this file except in compliance with the License. You may |
876
|
|
|
|
|
|
|
obtain a copy of the License at |
877
|
|
|
|
|
|
|
L<http://www.apache.org/licenses/LICENSE-2.0>. |
878
|
|
|
|
|
|
|
|
879
|
|
|
|
|
|
|
Unless required by applicable law or agreed to in writing, software |
880
|
|
|
|
|
|
|
distributed under the License is distributed on an "AS IS" BASIS, |
881
|
|
|
|
|
|
|
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or |
882
|
|
|
|
|
|
|
implied. See the License for the specific language governing |
883
|
|
|
|
|
|
|
permissions and limitations under the License. |
884
|
|
|
|
|
|
|
|
885
|
|
|
|
|
|
|
=cut |
886
|
|
|
|
|
|
|
|
887
|
|
|
|
|
|
|
__PACKAGE__->meta->make_immutable; |
888
|
|
|
|
|
|
|
|
889
|
|
|
|
|
|
|
1; # End of RDF::KV |