File Coverage

blib/lib/RDF/KV.pm
Criterion Covered Total %
statement 47 268 17.5
branch 0 140 0.0
condition 0 89 0.0
subroutine 16 28 57.1
pod 1 1 100.0
total 64 526 12.1


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