File Coverage

blib/lib/Neo4j/Cypher/Pattern.pm
Criterion Covered Total %
statement 117 126 92.8
branch 41 44 93.1
condition 8 11 72.7
subroutine 21 25 84.0
pod 13 18 72.2
total 200 224 89.2


line stmt bran cond sub pod time code
1             package Neo4j::Cypher::Pattern;
2 3     3   542 use base Exporter;
  3         26  
  3         251  
3 3     3   22 use Carp;
  3         6  
  3         167  
4 3     3   18 use strict;
  3         6  
  3         80  
5 3     3   17 use warnings;
  3         7  
  3         107  
6 3     3   2287 use overload '""' => 'as_string';
  3         2047  
  3         20  
7              
8             our $VERSION = '0.1001';
9             our $VERSION = '0.1001';
10             our @EXPORT_OK = qw/pattern ptn/;
11              
12             sub puke(@);
13             sub belch(@);
14              
15             sub new {
16 50     50 1 554 my $class = shift;
17 50         102 my $self = {};
18 50         120 $self->{stmt}=[];
19 50 100       138 if (@_) {
20 2         7 my $nq = join('|',@_);
21 2         19 $self->{no_quote} = qr/$nq/;
22             }
23 50         265 bless $self, $class;
24             }
25              
26             sub pattern {
27 0     0 1 0 Neo4j::Cypher::Pattern->new(@_);
28             }
29              
30 49     49 1 162 sub ptn { Neo4j::Cypher::Pattern->new(@_); }
31              
32             sub path {
33 2     2 1 6 my $self = shift;
34 2 50 33     18 puke("Need arg1 => identifier") if (!defined $_[0] || ref($_[0]));
35 2         12 return "$_[0] = $self";
36             }
37              
38             # alias for path
39 2     2 1 12 sub as { shift->path(@_) }
40              
41             sub node {
42             # args:
43             # scalar string = varname
44             # array ref - array of labels
45             # hash ref - hash of props/values
46 93     93 1 210 my $self = shift;
47 93 100       232 unless (@_) {
48 6         10 push @{$self->{stmt}}, '()';
  6         25  
49 6         37 return $self;
50             }
51 87         173 my ($varname) = grep { !ref } @_;
  118         330  
52 87         164 my ($lbls) = grep { ref eq 'ARRAY' } @_;
  118         256  
53 87         152 my ($props) = grep { ref eq 'HASH' } @_;
  118         234  
54             # look for labels
55 87         144 my @l;
56 87         254 ($varname, @l) = split /:/, $varname;
57 87 100       223 if (@l) {
58 19   50     105 $lbls //= [];
59 19         41 push @$lbls, @l;
60             }
61 87 100       225 my $str = $lbls ? join(':',$varname, @$lbls) : $varname;
62 87 100       208 if ($props) {
63 27         43 my $p;
64 27         123 while (my($k,$v) = each %$props) {
65 31         245 push @$p, "$k:".$self->_quote($v);
66             }
67 27         96 $p = join(',',@$p);
68 27         73 $str .= " {$p}";
69             }
70 87         131 push @{$self->{stmt}}, "($str)";
  87         305  
71 87         388 return $self;
72             }
73              
74 85     85 1 217 sub N {shift->node(@_);}
75              
76             sub related_to {
77 32     32 1 52 my $self = shift;
78 32 100       96 unless (@_) {
79 3         6 push @{$self->{stmt}}, '--';
  3         7  
80 3         11 return $self;
81             }
82 29         62 my ($hops) = grep { ref eq 'ARRAY' } @_;
  44         137  
83 29         60 my ($props) = grep { ref eq 'HASH' } @_;
  44         99  
84 29         58 my ($varname,$type) = grep { !ref } @_;
  44         107  
85 29 100       70 if ($type) {
86 3         9 ($varname) = split /:/,$varname;
87             } else {
88 26         149 ($varname, $type) = $varname =~ /^([^:]*):?(.*)/;
89             }
90 29         61 my $dir;
91 29 100       75 if ($varname) {
92 27         89 $varname =~ s/^(<|>)//;
93 27         69 $dir = $1;
94 27         73 $varname =~ s/(<|>)$//;
95 27         61 $dir = $1;
96             }
97 29 100       69 unless ($dir) {
98 15 100       37 if ($type) {
99 11         31 $type =~ s/^(<|>)//;
100 11         19 $dir = $1;
101 11         44 $type =~ s/(<|>)$//;
102 11         26 $dir = $1;
103             }
104             }
105 29 100       88 my $str = $varname.($type ? ":$type" : "");
106              
107 29 100       74 if ($hops) {
108 9 100       31 if (@$hops == 0) {
    50          
109 2         5 $str.="*";
110             }
111             elsif (@$hops==1) {
112 0         0 $str .= "*$$hops[0]";
113             }
114             else {
115 7         20 $str .= "*$$hops[0]..$$hops[1]"
116             }
117             }
118 29 100       74 if ($props) {
119 3         5 my $p;
120 3         16 while (my($k,$v) = each %$props) {
121 3         11 push @$p, "$k:".$self->_quote($v);
122             }
123 3         8 $p = join(',',@$p);
124 3         9 $str .= " {$p}";
125             }
126 29 100       81 $str = ($str ? "-[$str]-" : '--');
127 29         67 $str =~ s/\[ \{/[{/;
128 29 100       72 if ($dir) {
129 22 100       80 if ($dir eq "<") {
    50          
130 7         17 $str = "<$str";
131             }
132             elsif ($dir eq ">") {
133 15         32 $str = "$str>";
134             }
135             else {
136 0         0 1; # huh?
137             }
138             }
139 29         49 push @{$self->{stmt}}, $str;
  29         76  
140 29         128 return $self;
141             }
142              
143 29     29 1 99 sub R {shift->related_to(@_)}
144              
145             # N('a')->toN('b') -> (a)-->(b)
146             # N('a')->fromN('b') -> (a)<--(b)
147 1     1   4 sub _N {shift->related_to->node(@_)}
148 1     1 1 5 sub to_N {shift->related_to('>')->node(@_)}
149 1     1 1 5 sub from_N {shift->related_to('<')->node(@_)}
150              
151             # 'class' method
152             # do pattern->C($pat1, $pat2)
153             sub compound {
154 5     5 1 10 my $self = shift;
155 5         17 return join(',',@_);
156             }
157              
158 5     5 1 20 sub C {shift->compound(@_)}
159              
160 17     17 0 51 sub clear { shift->{stmt}=[],1; }
161              
162             sub as_string {
163 160     160 0 760 my $self = shift;
164 160         243 return join('',@{$self->{stmt}});
  160         842  
165             }
166              
167             sub _quote {
168             return $_[1] if (
169 34 100 100 34   281 ($_[0]->{no_quote} and $_[1] =~ $_[0]->{no_quote}) or
      100        
170             $_[1] =~ /(?:^|\s)\$/ # no quote parameters
171             );
172 30 100       90 return ${$_[1]} if (ref $_[1] eq 'SCALAR');
  1         6  
173             # escape single quotes
174 29         59 my $v = $_[1];
175 29         59 $v =~ s/'/\\'/g;
176 29         142 return "'$v'";
177             }
178 0     0 0   sub pop { pop @{shift->{stmt}}; }
  0            
179              
180             sub belch (@) {
181 0     0 0   my($func) = (caller(1))[3];
182 0           Carp::carp "[$func] Warning: ", @_;
183             }
184              
185             sub puke (@) {
186 0     0 0   my($func) = (caller(1))[3];
187 0           Carp::croak "[$func] Fatal: ", @_;
188             }
189              
190             =head1 NAME
191              
192             Neo4j::Cypher::Pattern - Generate Cypher pattern strings
193              
194             =head1 SYNOPSIS
195              
196             # express a cypher pattern
197             use Neo4j::Cypher::Pattern qw/ptn/;
198              
199             ptn->node();
200             ptn->N(); #alias
201             ptn->N("varname");
202             ptn->N("varname",["label"],{prop => "value"});
203             ptn->N("varname:label");
204             ptn->N(["label"],{prop => "value"});
205              
206             ptn->node('a')->related_to()->node('b'); # (a)--(b)
207             ptn->N('a')->R()->N('b'); # alias
208             # additional forms
209             ptn->N('a')->R("varname","typename",[$minhops,$maxhops],{prop => "value"})
210             ->N('b'); # (a)-[varname:typename*minhops..maxhops { prop:"value }]-(b)
211             ptn->N('a')->R("varname:typename")->N('b'); # (a)-[varname:typename]-(b)
212             ptn->N('a')->R(":typename")->N('b'); # (a)-[:typename]-(b)
213             ptn->N('a')->R("", "typename")->N('b'); # (a)-[:typename]-(b)
214             # directed relns
215             ptn->N('a')->R("<:typename")->N('b'); # (a)<-[:typename]-(b)
216             ptn->N('a')->R("varname:typename>")->N('b'); # (a)-[varname:typename]->(b)
217              
218             # these return strings
219             $pattern->path('varname'); # path variable assigned to a pattern
220             $pattern->as('varname'); # alias
221             ptn->compound($pattern1, $pattern2); # comma separated patterns
222             ptn->C($pattern1, $pattern2); # alias
223              
224             =head1 DESCRIPTION
225              
226             The L
227             query language of the graph database L uses
228             L
229             to represent graph nodes and their relationships, for selecting and
230             matching in queries. C can be used to create
231             Cypher pattern productions in Perl in an intuitive way. It is part of
232             the L distribution.
233              
234             =head2 Basic idea : produce patterns by chaining method calls
235              
236             C objects possess methods to represent nodes
237             and relationships. Each method adds its portion of the pattern, with
238             arguments, to the object's internal queue. Every method returns the
239             object itself. When an object is rendered as a string, it concatenates
240             nodes and relationship productions to yield the entire query statement
241             as a string.
242              
243             These features add up to the following idiom. Suppose we want to
244             render the Cypher pattern
245              
246             (b {name:"Slate"})<-[:WORKS_FOR]-(a {name:"Fred"})-[:KNOWS]->(c {name:"Barney"})
247              
248             In C, we do
249              
250             $p = Neo4j::Cypher::Pattern->new()->N('b',{name=>'Slate')
251             ->R('<:WORKS_FOR')->N('a',{name => 'Fred'})
252             ->R(':KNOWS>')->N('c',{name=>'Barney'});
253             print "$p\n"; # "" is overloaded by $p->as_string()
254              
255             Because you may create many patterns in a program, a short
256             alias for the constructor can be imported, and extra variable
257             assignments can be avoided.
258              
259             print ptn->N('b',{name=>'Slate'})
260             ->R('<:WORKS_FOR')->N('a',{name => 'Fred'})
261             ->R(':KNOWS>')->N('c',{name=>'Barney'}), "\n";
262              
263             =head2 Quoting
264              
265             In pattern productions, values for properties will be quoted by
266             default with single quotes (single quotes that are present will be
267             escaped) unless the values are numeric.
268              
269             To prevent quoting Cypher statement list variable names (for example), make the name an argument to the pattern I:
270              
271             ptn('event')->N('y')->R("<:IN")->N('e:Event'=> { id => 'event.id' });
272              
273             # renders (y)<-[:IN]-(e:Event {id:event.id})
274             # rather than (y)<-[:IN]-(e:Event {id:"event.id"})
275              
276             =head1 METHODS
277              
278             =over
279              
280             =item Constructor new()
281              
282             =item pattern(), ptn()
283              
284             Exportable aliases for the constructor. Arguments are variable names
285             that should not be quoted in rendering values of properties.
286              
287             =item node(), N()
288              
289             Render a node. Arguments in any order:
290              
291             scalar string: variable name or variable:label
292             array ref: array of node labels
293             hash ref: hash of property => value
294              
295             =item related_to(), R()
296              
297             Render a relationship. Arguments in any order:
298              
299             scalar string: variable name or variable:type
300             array ref: variable-length pattern:
301             [$minhops, $maxhops]
302             [] (empty array)- any number of hops
303             [$hops] - exactly $hops
304             hash ref : hash of property => value
305              
306             =item path(), as()
307              
308             Render the pattern set equal to a path variable:
309              
310             $p = ptn->N('a')->_N('b');
311             print $p->as('pth'); # gives 'pth = (a)--(b)'
312              
313             =item compound(), C()
314              
315             Render multiple patterns separated by commas
316              
317             ptn->compound( ptn->N('a')->to_N('b'), ptn->N('a')->from_N('c'));
318             # (a)-->(b), (a)<--(c)
319              
320             =item Shortcuts _N, to_N, from_N
321              
322             ptn->N('a')->_N('b'); # (a)--(b)
323             ptn->N('a')->to_N('b'); # (a)-->(b)
324             pth->N('a')->from_N('b'); # (a)<--(b)
325              
326             =back
327              
328             =head1 SEE ALSO
329              
330             L
331              
332             =head1 AUTHOR
333              
334             Mark A. Jensen
335             CPAN: MAJENSEN
336             majensen -at- cpan -dot- org
337              
338             =head1 COPYRIGHT
339              
340             (c) 2017 Mark A. Jensen
341              
342             =cut
343             1;