File Coverage

blib/lib/DDC/PP/CQuery.pm
Criterion Covered Total %
statement 183 305 60.0
branch 13 52 25.0
condition 15 73 20.5
subroutine 71 145 48.9
pod 0 13 0.0
total 282 588 47.9


line stmt bran cond sub pod time code
1             ##-*- Mode: CPerl -*-
2              
3             ##======================================================================
4             ## top-level
5             package DDC::PP::CQuery;
6 20     20   146 use DDC::PP::Object;
  20         46  
  20         613  
7 20     20   112 use DDC::Utils qw();
  20         40  
  20         355  
8 20     20   95 use Carp qw(carp confess);
  20         37  
  20         1012  
9 20     20   129 use strict;
  20         43  
  20         547  
10              
11              
12             ##======================================================================
13             ## CQuery
14             package DDC::PP::CQuery;
15 20     20   131 use strict;
  20         52  
  20         9294  
16             our @ISA = qw(DDC::PP::Object);
17              
18             __PACKAGE__->defprop('Label');
19             __PACKAGE__->defprop('Options');
20             sub new {
21 98     98 0 387 my ($that,$label,%opts) = @_;
22 98         380 return $that->SUPER::new(Label=>$label,%opts);
23             }
24              
25             ##-- options only
26             sub _new {
27 329     329   595 my $that = shift;
28 329         1139 return $that->SUPER::new(@_);
29             }
30              
31 0     0 0 0 sub Negated { return 0; }
32 0   0 0 0 0 sub Negate { confess((ref($_[0])||$_[0])."::Negate(): attempt to negate non-negatable query"); }
33              
34 0     0 0 0 sub GetMatchId { return 0; }
35 0   0 0 0 0 sub SetMatchId { confess((ref($_[0])||$_[0])."::SetMatchId(): attempt to set match-ID for non-token query"); }
36 2     2 0 12 sub HasMatchId { $_[0]->GetMatchId != 0; }
37              
38 0     0 0 0 sub RootOk { return !$_[0]->Negated; }
39 0     0 0 0 sub ClearOptions { delete $_[0]{Options}; }
40       0 0   sub Clear { ; }
41              
42             sub toString {
43 0     0 0 0 return $_[0]{Label};
44             }
45             sub optionsToString {
46 2 50   2 0 9 return '' if (!$_[0]{Options});
47 2         14 return $_[0]{Options}->toString;
48             }
49             sub toStringFull {
50 2     2 0 14 return $_[0]->toString . $_[0]->optionsToString;
51             }
52              
53             ##-- stringification utility
54             sub sqString {
55 30 50   30 0 138 return DDC::Utils::escapeq(defined($_[1]) ? $_[1] : '');
56             }
57              
58              
59             ##======================================================================
60             ## CQNegatable
61             package DDC::PP::CQNegatable;
62 20     20   199 use strict;
  20         44  
  20         4397  
63             our @ISA = qw(DDC::PP::CQuery);
64              
65             __PACKAGE__->defprop('Negated');
66             sub new {
67 2     2   13 my ($that,$label,$negated,%opts) = @_;
68 2         14 return $that->_new(Label=>$label,Negated=>$negated,%opts);
69             }
70              
71 32 50   32   130 sub Negated { return $_[0]->getNegated ? 1 : 0; }
72 0 0   0   0 sub Negate { return $_[0]->setNegated($_[0]->getNegated ? 0 : 1); }
73              
74             sub NegString {
75 32     32   87 my ($obj,$s) = @_;
76 32 50       119 return $_[0]->Negated ? "!$s" : $s;
77             }
78              
79             ##======================================================================
80             ## CQAtomic
81             package DDC::PP::CQAtomic;
82 20     20   153 use strict;
  20         48  
  20         1314  
83             our @ISA = qw(DDC::PP::CQNegatable);
84              
85              
86             ##======================================================================
87             ## CQBinOp
88             package DDC::PP::CQBinOp;
89 20     20   139 use strict;
  20         42  
  20         7174  
90             our @ISA = qw(DDC::PP::CQNegatable);
91              
92             __PACKAGE__->defprop('Dtr1');
93             __PACKAGE__->defprop('Dtr2');
94             __PACKAGE__->defprop('OpName');
95             sub new {
96 47     47   133 my ($that,$dtr1,$dtr2,$opName,$negated,%opts) = @_;
97 47         232 return $that->_new(Label=>$opName,OpName=>$opName,Dtr1=>$dtr1,Dtr2=>$dtr2,Negated=>$negated,%opts);
98             }
99              
100 6     6   10 sub Children { [grep {defined($_)} @{$_[0]}{qw(Dtr1 Dtr2)}]; }
  12         42  
  6         18  
101              
102             sub GetMatchId {
103 0     0   0 my $obj = shift;
104             return (($obj->{Dtr2} && $obj->{Dtr2}->GetMatchId)
105             || ($obj->{Dtr1} && $obj->{Dtr1}->GetMatchId)
106 0   0     0 || 0);
107             }
108             sub SetMatchId {
109 0     0   0 my ($obj,$id) = @_;
110 0 0       0 $obj->{Dtr1}->SetMatchId($id) if ($obj->{Dtr1});
111 0 0       0 $obj->{Dtr2}->SetMatchId($id) if ($obj->{Dtr2});
112 0         0 return $id;
113             }
114              
115             sub Clear {
116 0     0   0 delete @{$_[0]}{qw(Dtr1 Dtr2)};
  0         0  
117             }
118             sub toString {
119 5     5   1774 my $obj = shift;
120 5         26 return $obj->NegString("(".$obj->{Dtr1}->toString." ".$obj->{OpName}." ".$obj->{Dtr2}->toString.")");
121             }
122              
123             ##======================================================================
124             ## CQAnd
125             package DDC::PP::CQAnd;
126 20     20   164 use strict;
  20         59  
  20         2022  
127             our @ISA = qw(DDC::PP::CQBinOp);
128              
129             sub new {
130 33     33   93 my ($that,$dtr1,$dtr2) = @_;
131 33         137 return $that->SUPER::new($dtr1,$dtr2,"&&");
132             }
133              
134             ##======================================================================
135             ## CQAndImplicit
136             package DDC::PP::CQAndImplicit;
137 20     20   142 use strict;
  20         53  
  20         1007  
138             our @ISA = qw(DDC::PP::CQAnd);
139              
140             ##======================================================================
141             ## CQOr
142             package DDC::PP::CQOr;
143 20     20   125 use strict;
  20         39  
  20         2151  
144             our @ISA = qw(DDC::PP::CQBinOp);
145              
146             sub new {
147 2     2   8 my ($that,$dtr1,$dtr2) = @_;
148 2         14 return $that->SUPER::new($dtr1,$dtr2,"||");
149             }
150              
151             ##======================================================================
152             ## CQWith
153             package DDC::PP::CQWith;
154 20     20   156 use strict;
  20         38  
  20         4493  
155             our @ISA = qw(DDC::PP::CQBinOp);
156              
157             __PACKAGE__->defprop('MatchId');
158             sub new {
159 12     12   38 my ($that,$dtr1,$dtr2,$matchid,%opts) = @_;
160 12   50     87 return $that->SUPER::new($dtr1,$dtr2,"WITH",0,MatchId=>($matchid||0),%opts);
161             }
162              
163             sub GetMatchId {
164 0     0   0 my $obj = shift;
165 0   0     0 return $obj->{MatchId} || $obj->SUPER::GetMatchId();
166             }
167             sub SetMatchId {
168 0     0   0 $_[0]{MatchId} = $_[1];
169             }
170              
171             sub toString {
172 0 0   0   0 return $_[0]->SUPER::toString().($_[0]{MatchId} ? " =$_[0]{MatchId}" : '');
173             }
174              
175             ##======================================================================
176             ## CQWithout
177             package DDC::PP::CQWithout;
178 20     20   154 use strict;
  20         41  
  20         2070  
179             our @ISA = qw(DDC::PP::CQWith);
180              
181             sub new {
182 2     2   9 my ($that,$dtr1,$dtr2,$matchid,%opts) = @_;
183 2         17 return $that->SUPER::new($dtr1,$dtr2,$matchid,OpName=>"WITHOUT",%opts);
184             }
185              
186             ##======================================================================
187             ## CQWithor
188             package DDC::PP::CQWithor;
189 20     20   132 use strict;
  20         47  
  20         1854  
190             our @ISA = qw(DDC::PP::CQWith);
191              
192             sub new {
193 2     2   10 my ($that,$dtr1,$dtr2,$matchid,%opts) = @_;
194 2         17 return $that->SUPER::new($dtr1,$dtr2,$matchid,OpName=>"WITHOR",%opts);
195             }
196              
197             ##======================================================================
198             ## CQToken
199             package DDC::PP::CQToken;
200 20     20   131 use strict;
  20         46  
  20         7252  
201             our @ISA = qw(DDC::PP::CQAtomic);
202              
203             __PACKAGE__->defprop('IndexName');
204             __PACKAGE__->defprop('Value');
205             __PACKAGE__->defprop('MatchId');
206             sub new {
207 280     280   1631 my ($that,$index,$value,$matchid,%opts) = @_;
208 280   100     2164 return $that->_new(Label=>$value,Negated=>0,IndexName=>($index||''),Value=>$value,MatchId=>($matchid||0),%opts);
      50        
209             }
210              
211             *GetMatchId = *getMatchId;
212             *SetMatchId = *setMatchId;
213              
214 0     0   0 sub OperatorKey { return '_'; }
215 27   50 27   230 sub IndexName { return $_[0]{IndexName} || '' }
216 0   0 0   0 sub BreakName { return $_[0]{BreakName} || '' }
217              
218 27 50   27   93 sub IndexString { return $_[0]->IndexName eq '' ? '' : ('$'.$_[0]->IndexName.'='); }
219 12     12   72 sub ValueString { return $_[0]->sqString($_[0]->{Value}); }
220 27 50   27   147 sub MatchIdString { return $_[0]{MatchId} ? " =$_[0]{MatchId}" : ''; }
221              
222             sub toString {
223 27     27   221 my $obj = shift;
224 27         124 return $obj->NegString($obj->IndexString . $obj->ValueString . $obj->MatchIdString);
225             }
226              
227             ##======================================================================
228             ## CQTokExact
229             package DDC::PP::CQTokExact;
230 20     20   152 use strict;
  20         40  
  20         2035  
231             our @ISA = qw(DDC::PP::CQToken);
232              
233 0     0   0 sub OperatorKey { return '@'; }
234 10     10   47 sub ValueString { return '@'.$_[0]->sqString($_[0]->{Value}); }
235              
236             ##======================================================================
237             ## CQTokAny
238             package DDC::PP::CQTokAny;
239 20     20   152 use strict;
  20         42  
  20         1584  
240             our @ISA = qw(DDC::PP::CQToken);
241              
242 0     0   0 sub OperatorKey { return '*'; }
243 0     0   0 sub ValueString { return '*'; }
244              
245             ##======================================================================
246             ## CQTokAnchor
247             package DDC::PP::CQTokAnchor;
248 20     20   136 use strict;
  20         78  
  20         3815  
249             our @ISA = qw(DDC::PP::CQToken);
250              
251             __PACKAGE__->defprop('ValueInt');
252             sub new {
253 0     0   0 my ($that,$index,$value,%opts) = @_;
254 0         0 return $that->SUPER::new($index,$value,0,ValueInt=>$value,%opts);
255             }
256              
257 0     0   0 sub OperatorKey { return '.'; }
258 0     0   0 sub IndexString { return '$.'.$_[0]->IndexName.'='; }
259 0   0 0   0 sub ValueString { return $_[0]{ValueInt} || 0; }
260              
261             ##======================================================================
262             ## CQTokRegex
263             package DDC::PP::CQTokRegex;
264 20     20   163 use strict;
  20         45  
  20         3736  
265             our @ISA = qw(DDC::PP::CQToken);
266              
267             __PACKAGE__->defprop('RegexNegated');
268             sub new {
269 11     11   33 my ($that,$index,$regex,$negated,%opts) = @_;
270 11         53 return $that->SUPER::new($index,$regex,0,%opts);
271             }
272              
273 0     0   0 sub OperatorKey { return '/_/'; }
274             sub ValueString {
275 1 50   1   5 my $re = defined($_[0]{Value}) ? $_[0]{Value} : '';
276             #$re =~ s{/}{\\/}g; ##-- no; see mantis #47973
277 1 50       12 return ($_[0]{RegexNegated} ? '!' : '')."/$re/";
278             }
279              
280             ##======================================================================
281             ## CQTokSet
282             package DDC::PP::CQTokSet;
283 20     20   155 use strict;
  20         50  
  20         4665  
284             our @ISA = qw(DDC::PP::CQToken);
285              
286             __PACKAGE__->defprop('Values');
287             sub new {
288 245     245   973 my ($that,$index,$rawValue,$values,%opts) = @_;
289 245   50     1137 return $that->SUPER::new($index,$rawValue,0,Values=>($values||[]),%opts);
290             }
291              
292 0     0   0 sub OperatorKey { return '@_' };
293             sub SetValueString {
294 4     4   10 my ($obj,$values) = @_;
295 4   33     13 $values ||= $obj->{Values};
296 4         13 return join(',', map {$obj->sqString($_)} @$values);
  8         21  
297             }
298             sub ValueString {
299 0     0   0 return '@{' . $_[0]->SetValueString . '}';
300             }
301              
302             ##======================================================================
303             ## CQTokInfl
304             package DDC::PP::CQTokInfl;
305 20     20   145 use strict;
  20         64  
  20         6582  
306             our @ISA = qw(DDC::PP::CQTokSet);
307              
308             __PACKAGE__->defprop('Expanders');
309             sub new {
310 241     241   811 my ($that,$index,$value,$expanders,%opts) = @_;
311 241   100     1281 return $that->SUPER::new($index,$value,[$value],Expanders=>($expanders||[]),Value=>$value,%opts);
312             }
313             sub newSet {
314 0     0   0 my ($that,$index,$values,$expanders,%opts) = @_;
315 0   0     0 return $that->SUPER::new($index,"$values",$values,Expanders=>($expanders||[]),Value=>"$values",%opts);
316             }
317              
318 0     0   0 sub OperatorKey { return '_'; }
319             sub ExpanderString {
320 16     16   40 my $obj = shift;
321 16 50       24 return '' if (!@{$obj->{Expanders}||[]});
  16 100       116  
322 8 50 33     16 return join('|', '', map {!defined($_) || $_ eq '' ? '-' : $_} @{$obj->{Expanders}});
  8         90  
  8         19  
323             }
324             sub ValueString {
325 12     12   36 my $obj = shift;
326 12         96 return $obj->DDC::PP::CQToken::ValueString . $obj->ExpanderString;
327             }
328              
329             ##======================================================================
330             ## CQTokSetInfl
331             package DDC::PP::CQTokSetInfl;
332 20     20   167 use strict;
  20         48  
  20         3161  
333             our @ISA = qw(DDC::PP::CQTokInfl);
334              
335             __PACKAGE__->defprop('RawValues');
336             sub new {
337 4     4   15 my ($that,$index,$values,$expanders,%opts) = @_;
338 4         26 return $that->SUPER::new($index,$values,$expanders,RawValues=>$values,%opts);
339             }
340              
341             sub ValueString {
342 4     4   10 my $obj = shift;
343 4         24 return '{' . $obj->SetValueString($obj->{RawValues}) . '}' . $obj->ExpanderString;
344             }
345              
346             ##======================================================================
347             ## CQTokPrefix
348             package DDC::PP::CQTokPrefix;
349 20     20   138 use strict;
  20         47  
  20         2882  
350             our @ISA = qw(DDC::PP::CQToken);
351              
352             sub new {
353 4     4   14 my ($that,$index,$prefix,%opts) = @_;
354 4         25 return $that->SUPER::new($index,$prefix,0,%opts);
355             }
356 0     0   0 sub OperatorKey { return '/_/'; }
357 0     0   0 sub ValueString { return $_[0]->sqString($_[0]{Value}).'*'; }
358              
359             ##======================================================================
360             ## CQTokSuffix
361             package DDC::PP::CQTokSuffix;
362 20     20   147 use strict;
  20         48  
  20         2973  
363             our @ISA = qw(DDC::PP::CQToken);
364              
365             sub new {
366 0     0   0 my ($that,$index,$suffix,%opts) = @_;
367 0         0 return $that->SUPER::new($index,$suffix,0,%opts);
368             }
369 0     0   0 sub OperatorKey { return '/_/'; }
370 0     0   0 sub ValueString { return '*'.$_[0]->sqString($_[0]{Value}); }
371              
372             ##======================================================================
373             ## CQTokInfix
374             package DDC::PP::CQTokInfix;
375 20     20   133 use strict;
  20         46  
  20         2919  
376             our @ISA = qw(DDC::PP::CQToken);
377              
378             sub new {
379 0     0   0 my ($that,$index,$infix,%opts) = @_;
380 0         0 return $that->SUPER::new($index,$infix,0,%opts);
381             }
382 0     0   0 sub OperatorKey { return '/_/'; }
383 0     0   0 sub ValueString { return '*'.$_[0]->sqString($_[0]{Value}).'*'; }
384              
385             ##======================================================================
386             ## CQTokPrefixSet
387             package DDC::PP::CQTokPrefixSet;
388 20     20   158 use strict;
  20         37  
  20         2878  
389             our @ISA = qw(DDC::PP::CQTokSet);
390              
391             sub new {
392 0     0   0 my ($that,$index,$prefixes,%opts) = @_;
393 0   0     0 return $that->SUPER::new($index,"$prefixes",($prefixes||[]),%opts);
394             }
395              
396 0     0   0 sub OperatorKey { return '/_/'; }
397 0     0   0 sub ValueString { return '{' . $_[0]->SetValueString . '}*'; }
398              
399             ##======================================================================
400             ## CQTokSuffixSet
401             package DDC::PP::CQTokSuffixSet;
402 20     20   153 use strict;
  20         49  
  20         3018  
403             our @ISA = qw(DDC::PP::CQTokSet);
404              
405             sub new {
406 0     0   0 my ($that,$index,$suffixes,%opts) = @_;
407 0   0     0 return $that->SUPER::new($index,"$suffixes",($suffixes||[]),%opts);
408             }
409              
410 0     0   0 sub OperatorKey { return '/_/'; }
411 0     0   0 sub ValueString { return '*{' . $_[0]->SetValueString . '}'; }
412              
413             ##======================================================================
414             ## CQTokInfixSet
415             package DDC::PP::CQTokInfixSet;
416 20     20   140 use strict;
  20         36  
  20         3138  
417             our @ISA = qw(DDC::PP::CQTokSet);
418              
419             sub new {
420 0     0   0 my ($that,$index,$infixes,%opts) = @_;
421 0   0     0 return $that->SUPER::new($index,"$infixes",($infixes||[]),%opts);
422             }
423              
424 0     0   0 sub OperatorKey { return '/_/'; }
425 0     0   0 sub ValueString { return '*{' . $_[0]->SetValueString . '}*'; }
426              
427             ##======================================================================
428             ## CQTokMorph
429             package DDC::PP::CQTokMorph;
430 20     20   150 use strict;
  20         53  
  20         4689  
431             our @ISA = qw(DDC::PP::CQToken);
432              
433             __PACKAGE__->defprop('Items');
434             sub new {
435 0     0   0 my ($that,$index,$items,%opts) = @_;
436 0   0     0 return $that->SUPER::new(($index||'MorphPattern'),"$items",0, Items=>($items||[]), %opts);
      0        
437             }
438              
439             sub Append {
440 0     0   0 my ($obj,$item) = @_;
441 0         0 push(@{$obj->{Items}},$item);
  0         0  
442             }
443              
444 0     0   0 sub OperatorKey { return '[_]'; }
445 0 0   0   0 sub ValueString { return '[' . join(',', map {$_[0]->sqString($_)} @{$_[0]{Items}||[]}). ']'; }
  0         0  
  0         0  
446              
447             ##======================================================================
448             ## CQTokLemma
449             package DDC::PP::CQTokLemma;
450 20     20   163 use strict;
  20         58  
  20         3049  
451             our @ISA = qw(DDC::PP::CQTokMorph);
452              
453             sub new {
454 0     0   0 my ($that,$index,$value,%opts) = @_;
455 0   0     0 return $that->DDC::PP::CQToken::new(($index||'Lemma'),$value,0,%opts);
456             }
457              
458 0     0   0 sub OperatorKey { return '%_'; }
459 0     0   0 sub ValueString { return '%' . $_[0]->sqString($_[0]{Value}); }
460              
461             ##======================================================================
462             ## CQTokThes
463             package DDC::PP::CQTokThes;
464 20     20   156 use strict;
  20         41  
  20         3027  
465             our @ISA = qw(DDC::PP::CQToken);
466              
467             sub new {
468 0     0   0 my ($that,$index,$value,%opts) = @_;
469 0   0     0 return $that->SUPER::new(($index||'Thes'),$value,0,%opts);
470             }
471              
472 0     0   0 sub OperatorKey { return ':{_}'; }
473 0     0   0 sub ValueString { return ':{' . $_[0]->sqString($_[0]{Value}) . '}'; };
474              
475             ##======================================================================
476             ## CQTokChunk
477             package DDC::PP::CQTokChunk;
478 20     20   150 use strict;
  20         53  
  20         3031  
479             our @ISA = qw(DDC::PP::CQToken);
480              
481             sub new {
482 0     0   0 my ($that,$index,$value,%opts) = @_;
483 0   0     0 return $that->SUPER::new(($index||''),$value,0,%opts);
484             }
485              
486 0     0   0 sub OperatorKey { return '^_'; }
487 0     0   0 sub ValueString { return '^' . $_[0]->sqString($_[0]{Value}); }
488              
489             ##======================================================================
490             ## CQTokFile
491             package DDC::PP::CQTokFile;
492 20     20   155 use strict;
  20         69  
  20         3155  
493             our @ISA = qw(DDC::PP::CQToken);
494              
495             sub new {
496 0     0   0 my ($that,$index,$filename,%opts) = @_;
497 0         0 return $that->SUPER::new($index,$filename,0,%opts);
498             }
499              
500 0     0   0 sub OperatorKey { return '<_'; }
501 0     0   0 sub ValueString { return '<' . $_[0]->sqString($_[0]{Value}); }
502              
503             ##======================================================================
504             ## CQNear
505             package DDC::PP::CQNear;
506 20     20   137 use strict;
  20         44  
  20         9138  
507             our @ISA = qw(DDC::PP::CQNegatable);
508              
509             __PACKAGE__->defprop('Dtr1');
510             __PACKAGE__->defprop('Dtr2');
511             __PACKAGE__->defprop('Dtr3');
512             __PACKAGE__->defprop('Dist');
513             sub new {
514 0     0   0 my ($that,$dist,$dtr1,$dtr2,$dtr3,%opts) = @_;
515 0 0       0 return $that->SUPER::new("NEAR",0,Dist=>(defined($dist) ? $dist : 1), Dtr1=>$dtr1, Dtr2=>$dtr2, Dtr3=>$dtr3, %opts);
516             }
517              
518 0     0   0 sub Children { [grep {defined($_)} @{$_[0]}{qw(Dtr1 Dtr2 Dtr3)}]; }
  0         0  
  0         0  
519              
520 0     0   0 sub Clear { delete @{$_[0]}{qw(Dtr1 Dtr2 Dtr3)}; }
  0         0  
521              
522             sub GetMatchId {
523 0     0   0 my $obj = shift;
524             return (($obj->{Dtr3} && $obj->{Dtr3}->GetMatchId)
525             || ($obj->{Dtr2} && $obj->{Dtr2}->GetMatchId)
526             || ($obj->{Dtr1} && $obj->{Dtr2}->GetMatchId)
527 0   0     0 || 0
528             );
529             }
530             sub SetMatchId {
531 0     0   0 my ($obj,$id) = @_;
532 0 0       0 $obj->{Dtr1}->SetMatchId($id) if ($obj->{Dtr1});
533 0 0       0 $obj->{Dtr2}->SetMatchId($id) if ($obj->{Dtr2});
534 0 0       0 $obj->{Dtr3}->SetMatchId($id) if ($obj->{Dtr3});
535 0         0 return $id;
536             }
537              
538             sub toString {
539 0     0   0 return $_[0]->NegString("NEAR(".join(',', (map {$_->toString} grep {defined $_} @{$_[0]}{qw(Dtr1 Dtr2 Dtr3)}), $_[0]{Dist}).")");
  0         0  
  0         0  
  0         0  
540             }
541              
542             ##======================================================================
543             ## CQSeq
544             package DDC::PP::CQSeq;
545 20     20   159 use strict;
  20         45  
  20         15054  
546             our @ISA = qw(DDC::PP::CQAtomic);
547              
548             __PACKAGE__->defprop('Items');
549             __PACKAGE__->defprop('Dists');
550             __PACKAGE__->defprop('DistOps');
551             sub new {
552 2     2   7 my ($that,$items,$dists,$distops,%opts) = @_;
553 2   50     40 return $that->SUPER::new('""',0, Items=>($items||[]), Dists=>($dists||[]), DistOps=>($distops||[]), %opts);
      50        
      50        
554             }
555             sub new1 {
556 0     0   0 my ($that,$item,%opts) = @_;
557 0         0 return $that->new([$item],[],[],%opts);
558             }
559              
560             sub Append {
561 4     4   13 my ($obj,$nextItem,$nextDist,$nextDistOp) = @_;
562 4   100     23 $nextDistOp ||= '<';
563 4 50       7 if (@{$obj->{Items}}) {
  4         29  
564 4         7 push(@{$obj->{Dists}}, $nextDist);
  4         11  
565 4         7 push(@{$obj->{DistOps}}, $nextDistOp);
  4         9  
566             }
567 4         9 push(@{$obj->{Items}}, $nextItem);
  4         12  
568             }
569              
570 0     0     sub Clear { @{$_[0]{Items}} = @{$_[0]{Dists}} = @{$_[0]{DistOps}} = qw(); }
  0            
  0            
  0            
571              
572 0   0 0     sub Children { return $_[0]{Items}||[]; }
573             sub GetMatchId {
574 0     0     my ($id);
575 0 0         foreach (@{$_[0]{Items}||[]}) {
  0            
576 0 0 0       return $id if ($_ && ($id=$_->GetMatchId));
577             }
578 0           return 0;
579             }
580             sub SetMatchId {
581 0     0     my ($obj,$id) = @_;
582 0 0         foreach (@{$_[0]{Items}||[]}) {
  0            
583 0 0         $_->SetMatchId($id) if (UNIVERSAL::can($_,'SetMatchId'));
584             }
585 0           return $id;
586             }
587              
588             sub toString {
589 0     0     my $obj = shift;
590             return $obj->NegString('"'
591             .join(' ',
592             map {
593             ($obj->{Items}[$_]->toString,
594             ($_ < $#{$obj->{Items}} && ($obj->{Dists}[$_] || ($obj->{DistOps}[$_]||'<') ne '<')
595 0 0 0       ? ("#".($obj->{DistOps}[$_]||'<').($obj->{Dists}[$_]||'0'))
      0        
      0        
596             : qw()))
597 0           } (0..$#{$obj->{Items}}))
  0            
598             .'"');
599             }
600              
601              
602              
603             1; ##-- be happy
604              
605             =pod
606              
607             =head1 NAME
608              
609             DDC::PP::CQuery - pure-perl implementation of DDC::XS::CQuery
610              
611             =head1 SYNOPSIS
612              
613             use DDC::PP::CQuery;
614             #... stuff happens ...
615              
616              
617             =head1 DESCRIPTION
618              
619             The DDC::PP::CQuery class is a pure-perl fork of the L class,
620             which see for details.
621              
622             =head1 SEE ALSO
623              
624             perl(1),
625             DDC::PP(3perl),
626             DDC::XS(3perl).
627              
628             =head1 AUTHOR
629              
630             Bryan Jurish Emoocow@cpan.orgE
631              
632             =head1 COPYRIGHT AND LICENSE
633              
634             Copyright (C) 2016 by Bryan Jurish
635              
636             This library is free software; you can redistribute it and/or modify
637             it under the same terms as Perl itself, either Perl version 5.14.2 or,
638             at your option, any later version of Perl 5 you may have available.
639              
640             =cut
641