File Coverage

blib/lib/XAO/testcases/FS/search.pm
Criterion Covered Total %
statement 15 472 3.1
branch 0 56 0.0
condition 0 45 0.0
subroutine 5 25 20.0
pod 0 11 0.0
total 20 609 3.2


line stmt bran cond sub pod time code
1             package XAO::testcases::FS::search;
2 1     1   824 use strict;
  1         2  
  1         29  
3 1     1   514 use XAO::Utils;
  1         18391  
  1         72  
4 1     1   503 use XAO::Objects;
  1         5316  
  1         35  
5 1     1   7 use Error qw(:try);
  1         3  
  1         6  
6              
7 1     1   146 use base qw(XAO::testcases::FS::base);
  1         2  
  1         482  
8              
9             ###############################################################################
10              
11             ### This bug is known, there is no easy fix for it. And I am not sure it should be fixed at all.
12              
13             ### sub test_mixed_levels {
14             ### my $self=shift;
15             ### my $odb=$self->get_odb();
16             ###
17             ### $odb->fetch('/')->build_structure(
18             ### Level0 => {
19             ### type => 'list',
20             ### class => 'Data::Level0',
21             ### key => 'l0_id',
22             ### structure => {
23             ### Level1 => {
24             ### type => 'list',
25             ### class => 'Data::Level1',
26             ### key => 'l1_id',
27             ### structure => {
28             ### text => {
29             ### type => 'text',
30             ### maxlength => 50,
31             ### },
32             ### },
33             ### },
34             ### text => {
35             ### type => 'text',
36             ### maxlength => 50,
37             ### },
38             ### },
39             ### },
40             ### );
41             ###
42             ### my ($l0_obj,$l1_obj);
43             ### my ($l0_list,$l1_list);
44             ### my $obj_id;
45             ###
46             ### #1st elt has no 1st level list
47             ### $l0_list=$odb->fetch('/Level0');
48             ### $l0_obj=$l0_list->get_new();
49             ### $l0_obj->put(text=>'foobar');
50             ### $obj_id=$l0_list->put($l0_obj);
51             ### # If you uncomment this lines, search will be ok
52             ### # but with empty 1-st level list, search unable to find first record with text='foobar'
53             ### # $l0_obj=$l0_list->get($obj_id);
54             ### # my $l1_list=$l0_obj->get('Level1');
55             ### # $l1_obj=$l1_list->get_new();
56             ### # $l1_obj->put(text=>'zzz');
57             ### # $l1_list->put($l1_obj);
58             ###
59             ### #2nd elt has 1st level branch with 2 records ('foo','bar');
60             ### $l0_obj=$l0_list->get_new();
61             ### $l0_obj->put(text=>'something different');
62             ### $obj_id=$l0_list->put($l0_obj);
63             ### $l0_obj=$l0_list->get($obj_id);
64             ### $l1_list=$l0_obj->get('Level1');
65             ### $l1_obj=$l1_list->get_new();
66             ### $l1_obj->put(text=>'foo');
67             ### $l1_list->put($l1_obj);
68             ### $l1_obj=$l1_list->get_new();
69             ### $l1_obj->put(text=>'bar');
70             ### $l1_list->put($l1_obj);
71             ###
72             ### my $sr=$l0_list->search(
73             ### [
74             ### ['text','cs','bar'],
75             ### 'or',
76             ### ['Level1/text','cs','bar'],
77             ### ],
78             ### );
79             ###
80             ### my $nrows=scalar(@$sr);
81             ### $self->assert($nrows==2,
82             ### "Wrong search results in test_mixed_levels ($nrows instead of 2)");
83             ### }
84              
85             ###############################################################################
86              
87             sub test_scan {
88 0     0 0   my $self=shift;
89              
90 0           my $odb=$self->get_odb();
91              
92 0           my $cust_list=$odb->fetch('/Customers');
93 0           my $cust_obj=$cust_list->get_new();
94              
95 0           for(my $i=0; $i<100; ++$i) {
96 0           $cust_obj->put(name => sprintf('scancust%04u',$i));
97 0           $cust_list->put(sprintf('id%04u',$i) => $cust_obj);
98             }
99              
100 0           $self->assert(scalar($cust_list->keys)==102,
101             "Expected to have 102 customers in the list, got ".scalar($cust_list->keys));
102              
103              
104 0           my %tests=(
105             t01 => {
106             params => {
107             block_size => 20,
108             search_query => [
109             'name','sw','scancust',
110             ],
111             search_options => {
112             result => [ 'customer_id','name' ],
113             orderby => [ descend => 'customer_id' ],
114             limit => 90, # overall limit
115             offset => 5, # overall offset
116             },
117             },
118             expect => {
119             rows => 90,
120             blocks => 5,
121             first5 => 'id0094,id0093,id0092,id0091,id0090',
122             },
123             },
124             t02 => {
125             params => {
126             block_size => 1,
127             search_query => [
128             'name','sw','scancust',
129             ],
130             search_options => {
131             orderby => 'name',
132             },
133             },
134             expect => {
135             rows => 100,
136             blocks => 100,
137             first5 => 'id0000,id0001,id0002,id0003,id0004',
138             },
139             },
140             t03 => {
141             params => {
142             block_size => 11,
143             search_options => {
144             orderby => 'customer_id',
145             offset => 5, # overall offset
146             },
147             },
148             expect => {
149             rows => 97,
150             blocks => 9,
151             first5 => 'id0003,id0004,id0005,id0006,id0007',
152             },
153             },
154             t04 => {
155             params => {
156             block_size => 40,
157             limit => 35, # overall offset
158             search_options => {
159             orderby => 'customer_id',
160             limit => 50, # low priority
161             },
162             },
163             expect => {
164             rows => 35,
165             blocks => 1,
166             first5 => 'c1,c2,id0000,id0001,id0002',
167             },
168             },
169             );
170              
171             # Testing both collection and list scanning on the same set of tests.
172             #
173 0           my $cust_coll=$odb->collection(class => 'Data::Customer');
174              
175 0           foreach my $cust_lc ($cust_list,$cust_coll) {
176 0           foreach my $testname (keys %tests) {
177 0           my $tdata=$tests{$testname};
178              
179 0           my $called_before=0;
180 0           my $called_block=0;
181 0           my $called_row=0;
182 0           my $called_after=0;
183 0           my @srb;
184             my @srr;
185             $cust_lc->scan($tdata->{'params'},{
186             call_before => sub {
187 0     0     my ($list,$args)=@_;
188 0           ++$called_before;
189 0   0       $self->assert(ref($args) && $args->{'block_size'},
190             "Expected to get back arguments in 'call_before'");
191 0           $self->assert(ref($list),
192             "Expected to get back list in 'call_before'");
193             },
194             call_block => sub {
195 0     0     my ($list,$args,$block)=@_;
196 0           ++$called_block;
197             ### dprint "call_block($called_block): ".Dumper($block);
198 0           push(@srb,@$block);
199 0 0 0       $self->assert((ref($args) && ref($args->{'call_block'})) ? 1 : 0,
200             "$testname: Expected to get back arguments in 'call_block'");
201 0 0         $self->assert((ref($list)) ? 1 : 0,
202             "$testname: Expected to get back list in 'call_block'");
203 0           $self->assert(ref($block) eq 'ARRAY',
204             "$testname: Expected to get results block in 'call_block'");
205             },
206             call_row => sub {
207 0     0     my ($list,$args,$row)=@_;
208 0           ++$called_row;
209 0           push(@srr,$row);
210 0 0 0       $self->assert((ref($args) && $args->{'search_options'}) ? 1 : 0,
211             "$testname: Expected to get back arguments in 'call_row'");
212 0           $self->assert(ref($list),
213             "$testname: Expected to get back list in 'call_row'");
214 0           $self->assert(defined($row),
215             "$testname: Expected to get a result row in 'call_row'");
216             },
217             call_after => sub {
218 0     0     my ($list,$args)=@_;
219 0           ++$called_after;
220 0   0       $self->assert(ref($args) && $args->{'block_size'},
221             "$testname: Expected to get back arguments in 'call_after'");
222 0           $self->assert(ref($list),
223             "$testname: Expected to get back list in 'call_after'");
224             },
225 0           });
226              
227 0           my $expect=$tdata->{'expect'};
228              
229 0           $self->assert($called_before==1,
230             "$testname: Expected to have called_before==1, got $called_before");
231 0           $self->assert($called_block==$expect->{'blocks'},
232             "$testname: Expected to have called_block==$expect->{'blocks'}, got $called_block");
233 0           $self->assert($called_row==$expect->{'rows'},
234             "$testname: Expected to have called_row==$expect->{'rows'}, got $called_row");
235 0           $self->assert($called_after==1,
236             "$testname: Expected to have called_after==1, got $called_after");
237              
238 0           $self->assert(scalar(@srb)==scalar(@srr),
239             "$testname: Expected to have the same data from call_block and call_row");
240 0           for(my $i=0; $i<@srr; ++$i) {
241 0           $self->assert($srb[$i] eq $srr[$i],
242             "$testname: Expected to have the same data from call_block and call_row, got $srb[$i] and $srr[$i] at position $i");
243             }
244              
245             # In the collection we're going to get collection IDs, not list
246             # IDs. Translating them to make the same tests work in both
247             # cases.
248             #
249 0 0         @srr=(map { ref($_) ? $_ : $cust_lc->get($_)->container_key } @srr);
  0            
250              
251 0 0         my $first5=join(',',map { ref($_) ? $_->[0] : $_ } @srr[0..4] );
  0            
252              
253 0           $self->assert($first5 eq $expect->{'first5'},
254             "$testname: Expected first 5 elements to be $expect->{'first5'}, got $first5");
255             }
256             }
257             }
258              
259             ###############################################################################
260              
261             sub test_mixed_case {
262 0     0 0   my $self=shift;
263              
264 0           my $odb=$self->get_odb();
265              
266 0           my $custlist=$odb->fetch('/Customers');
267              
268 0           my $customer=$custlist->get_new();
269              
270 0           $self->assert(ref($customer),
271             "Can't create Customer");
272              
273 0           $customer->add_placeholder(
274             name => 'MixedCase',
275             type => 'text',
276             charset => 'utf8', # required for case-ign. collation
277             maxlength => 100,
278             index => 1,
279             );
280              
281 0           $customer->add_placeholder(
282             name => 'lowFirst',
283             type => 'text',
284             charset => 'latin1',
285             maxlength => 1000,
286             );
287              
288 0           $customer->put(
289             MixedCase => 'mixed1',
290             lowFirst => 'lc1',
291             );
292 0           $custlist->put(mct1 => $customer);
293 0           $customer->put(
294             MixedCase => 'mixed2 with more',
295             lowFirst => 'lc2',
296             );
297 0           $custlist->put(mct2 => $customer);
298              
299 0           my $sr=$custlist->search('MixedCase','eq','mixed1');
300 0           $self->assert(@$sr==1,
301             "Expected 1 result for mixed1");
302 0           $self->assert($sr->[0] eq 'mct1',
303             "Expected to find 'mct1' for 'mixed1'");
304              
305 0           $sr=$custlist->search('MixedCase','sw','mixed');
306 0           $self->assert(@$sr==2,
307             "Expected 2 results for mixed1");
308              
309 0           $sr=$custlist->search('lowFirst','eq','lc2');
310 0           $self->assert(@$sr==1,
311             "Expected 1 result for lowFirst=lc2");
312 0           $self->assert($sr->[0] eq 'mct2',
313             "Expected to find 'mct2' for 'lc2'");
314              
315 0           $sr=$custlist->search(['lowFirst','eq','lc2'],'and',['MixedCase','eq','mixed1']);
316 0           $self->assert(@$sr==0,
317             "Expected NO result for [lowFirst=lc2] and [MixedCase=mixed1]");
318             }
319              
320             ###############################################################################
321              
322             # Testing how returning multiple fields works -- 'result' option in search
323              
324             sub test_result_option {
325 0     0 0   my $self=shift;
326 0           my $odb=$self->get_odb();
327              
328 0           my $cust_list=$odb->fetch('/Customers');
329              
330 0           $cust_list->get_new->add_placeholder(
331             name => 'desc',
332             type => 'text',
333             maxlength => 50,
334             charset => 'utf8',
335             );
336 0           $cust_list->get_new->add_placeholder(
337             name => 'common',
338             type => 'text',
339             maxlength => 50,
340             charset => 'utf8',
341             );
342 0           $cust_list->get('c1')->put(name => 'name1', desc => 'aaaaa', common => 'common');
343 0           $cust_list->get('c2')->put(name => 'name2', desc => 'ddddd', common => 'common');
344              
345 0           $cust_list->get_new->add_placeholder(
346             name => 'Orders',
347             type => 'list',
348             class => 'Data::Order',
349             key => 'order_id',
350             );
351 0           my $order_list=$cust_list->get('c1')->get('Orders');
352 0           my $order_obj=$order_list->get_new;
353 0           $order_obj->add_placeholder(
354             name => 'total',
355             type => 'real',
356             );
357 0           $order_obj->add_placeholder(
358             name => 'text',
359             type => 'text',
360             maxlength => 100,
361             );
362 0           $order_obj->put(
363             total => 123.45,
364             text => 'c1o1',
365             );
366 0           $order_list->put('o1' => $order_obj);
367 0           $order_obj->put(
368             total => 234.56,
369             text => 'c1o2',
370             );
371 0           $order_list->put('o2' => $order_obj);
372 0           $order_obj->put(
373             total => 345.67,
374             text => 'c1o3',
375             );
376 0           $order_list->put('o3' => $order_obj);
377 0           $order_list=$cust_list->get('c2')->get('Orders');
378 0           $order_obj->put(
379             total => 456.78,
380             text => 'c2o1',
381             );
382 0           $order_list->put('o1' => $order_obj);
383 0           $order_obj->put(
384             total => 567.89,
385             text => 'c2o2',
386             );
387 0           $order_list->put('o2' => $order_obj);
388              
389 0           my $order_coll=$odb->collection(class => 'Data::Order');
390              
391             my %matrix=(
392             t01 => {
393             list => $cust_list,
394             args => [ 'desc','cs','d' ],
395             options => { result => [ qw(name desc) ], orderby => '-name', distinct => 'customer_id' },
396             result => 'name2|ddddd',
397             rcount => 2,
398             },
399             t02 => {
400             list => $cust_list,
401             options => { result => [ qw(desc) ], orderby => 'name' },
402             result => 'aaaaa;ddddd',
403             rcount => 1,
404             },
405             t03 => {
406             list => $cust_list,
407             args => [ 'desc','cs','a' ],
408             options => { result => [ '#container_key','customer_id','name','desc' ], orderby => '-name' },
409             result => 'c1|c1|name1|aaaaa',
410             rcount => 4,
411             },
412             t04 => {
413             list => $cust_list,
414             options => { result => [ '#collection_key' ], orderby => 'desc' },
415             result => '1;2', # this may break in other databases
416             rcount => 1,
417             },
418             t05 => {
419             list => $order_coll,
420             options => { result => [ '#id' ], orderby => 'text' },
421             result => '1;2;3;4;5', # this may break in other databases
422             },
423             t06 => {
424             list => $cust_list,
425             options => { result => [ qw(common common) ], distinct => 'common' },
426             result => 'common|common',
427             },
428             t07 => {
429             list => $order_coll,
430             options => { result => [ '#connector', 'parent_unique_id' ] },
431             result => sub {
432 0     0     my $row=shift;
433 0           $self->assert($row->[0] eq $row->[1],
434             "Expected #connector value '$row->[0]' to equal parent_unique_id value '$row->[1]'");
435             },
436             },
437 0           t10 => {
438             list => $cust_list,
439             args => [ 'Orders/total','gt',300 ],
440             options => { result => [ qw(name common) ], orderby => 'customer_id' },
441             result => 'name1|common;name2|common',
442             rcount => 2,
443             },
444             t11 => {
445             list => $cust_list,
446             args => [ 'Orders/total','gt',300 ],
447             options => { result => [ qw(Orders/total Orders/text) ],
448             orderby => [ ascend => 'customer_id', descend => 'Orders/total' ] },
449             result => '345.67|c1o3;456.78|c2o1',
450             rcount => 2,
451             },
452             t12 => {
453             list => $cust_list,
454             options => { result => [ qw(Orders/total desc Orders/text) ],
455             orderby => '-Orders/total' },
456             result => '456.78|ddddd|c2o1;123.45|aaaaa|c1o1',
457             rcount => 3,
458             },
459             t13 => {
460             list => $cust_list,
461             options => { result => [ qw(Orders/total customer_id Orders/text) ],
462             orderby => '-Orders/total' },
463             result => '456.78|c2|c2o1;123.45|c1|c1o1',
464             rcount => 3,
465             },
466             t14 => {
467             list => $cust_list,
468             options => { result => [ qw(Orders/total customer_id Orders/text) ],
469             orderby => '-Orders/total',
470             distinct => 'Orders/text' },
471             result => '567.89|c2|c2o2;456.78|c2|c2o1;345.67|c1|c1o3;234.56|c1|c1o2;123.45|c1|c1o1',
472             rcount => 3,
473             },
474             t15 => {
475             list => $cust_list,
476             options => { result => [ qw(Orders/total customer_id) ],
477             orderby => 'Orders/total',
478             distinct => 'Orders/text' },
479             result => '123.45|c1;234.56|c1;345.67|c1;456.78|c2;567.89|c2',
480             rcount => 2,
481             },
482             t20 => {
483             list => $order_coll,
484             options => { result => [ 'text','../name','#container_key' ],
485             orderby => '-total' },
486             result => 'c2o2|name2|o2;c2o1|name2|o1;c1o3|name1|o3;c1o2|name1|o2;c1o1|name1|o1',
487             rcount => 3,
488             },
489             t21 => {
490             list => $cust_list,
491             options => { result => [ 'common' ] },
492             result => 'common;common',
493             rcount => 1,
494             },
495             t22 => {
496             list => $cust_list,
497             args => [ 'Orders/total', 'gt', 0 ],
498             options => { result => [ 'common' ] },
499             result => 'common;common',
500             rcount => 1,
501             },
502             t30 => {
503             list => $order_list,
504             args => [ [ 'total','gt',0 ], 'and', [ 'total','lt',1000 ] ],
505             options => { result => [ qw(order_id text total) ],
506             orderby => 'text' },
507             result => 'o1|c2o1|456.78;o2|c2o2|567.89',
508             rcount => 3,
509             }
510             );
511              
512 0           foreach my $t (sort keys %matrix) {
513 0           my $test=$matrix{$t};
514 0           my $list=$test->{'list'};
515              
516             my $sr=$test->{'args'} ? $list->search($test->{'args'},$test->{'options'})
517 0 0         : $list->search($test->{'options'});
518              
519             ### dprint Dumper($sr);
520 0           $self->assert(ref($sr) eq 'ARRAY',
521             "Test '$t', expected to get a list reference, got '".ref($sr)."'");
522              
523 0           $self->assert(ref($sr->[0]) eq 'ARRAY',
524             "Test '$t', expected to get a list of arrays, got '".ref($sr->[0])."'");
525              
526 0           my $expect=$test->{'result'};
527              
528 0 0         if(ref $expect eq 'CODE') {
529 0           foreach my $row (@$sr) {
530 0           $expect->($row);
531             }
532             }
533             else {
534             my $got=join(';',map {
535 0 0         join('|',$test->{'rcount'} ? @$_[0..($test->{'rcount'}-1)] : @$_);
  0            
536             } @$sr);
537              
538 0           $self->assert($got eq $expect,
539             "Test '$t', expected '$expect', got '$got'");
540             }
541             }
542             }
543              
544             ###############################################################################
545              
546             # reported by enn@, 2006/05/03
547              
548             sub test_empty_array_ref {
549 0     0 0   my $self=shift;
550 0           my $odb=$self->get_odb();
551 0           my $customers=$odb->fetch('/Customers');
552              
553 0           my $got;
554             try {
555 0     0     my $sr=$customers->search([ 'name','sw', [ ] ]);
556 0           my $got=join(',',sort @$sr);
557             }
558             otherwise {
559 0     0     my $e=shift;
560 0           dprint "Expected error: $e";
561 0           };
562              
563 0           $self->assert(!defined $got,
564             "Bug in empty array reference treatment");
565             }
566              
567             ##################################################################################
568              
569             # Test for a bug in MySQL_DBI driver in handling on multi-value returns
570             # in search.
571              
572             sub test_bug_20030505 {
573 0     0 0   my $self=shift;
574 0           my $odb=$self->get_odb();
575 0           my $customers=$odb->fetch('/Customers');
576 0           my $sr=$customers->search({distinct => 'name'});
577 0           my $got=join(',',sort @$sr);
578 0           my $expect='c1,c2';
579 0           $self->assert($got eq $expect,
580             "Bug in multi-value handling - expected $expect, got $got");
581             }
582              
583             ##
584             # Really deep searches that are very unlikely to ever be requested in
585             # real life.
586             #
587             sub test_real_deep {
588 0     0 0   my $self=shift;
589              
590 0           my $odb=$self->get_odb();
591              
592 0           @XAO::DO::Data::A::ISA='XAO::DO::FS::Hash';
593 0           $INC{'XAO/DO/Data/A.pm'}='XAO/DO/FS/Hash.pm';
594 0           @XAO::DO::Data::B::ISA='XAO::DO::FS::Hash';
595 0           $INC{'XAO/DO/Data/B.pm'}='XAO/DO/FS/Hash.pm';
596 0           @XAO::DO::Data::C::ISA='XAO::DO::FS::Hash';
597 0           $INC{'XAO/DO/Data/C.pm'}='XAO/DO/FS/Hash.pm';
598 0           @XAO::DO::Data::D::ISA='XAO::DO::FS::Hash';
599 0           $INC{'XAO/DO/Data/D.pm'}='XAO/DO/FS/Hash.pm';
600 0           @XAO::DO::Data::E::ISA='XAO::DO::FS::Hash';
601 0           $INC{'XAO/DO/Data/E.pm'}='XAO/DO/FS/Hash.pm';
602 0           @XAO::DO::Data::F::ISA='XAO::DO::FS::Hash';
603 0           $INC{'XAO/DO/Data/F.pm'}='XAO/DO/FS/Hash.pm';
604 0           @XAO::DO::Data::G::ISA='XAO::DO::FS::Hash';
605 0           $INC{'XAO/DO/Data/G.pm'}='XAO/DO/FS/Hash.pm';
606 0           @XAO::DO::Data::X::ISA='XAO::DO::FS::Hash';
607 0           $INC{'XAO/DO/Data/X.pm'}='XAO/DO/FS/Hash.pm';
608              
609 0           dprint "Building structure";
610              
611 0           $odb->fetch('/')->build_structure(
612             X => {
613             type => 'list',
614             class => 'Data::X',
615             key => 'x_id',
616             structure => {
617             A => {
618             type => 'list',
619             class => 'Data::A',
620             key => 'a_id',
621             structure => {
622             B => {
623             type => 'list',
624             class => 'Data::B',
625             key => 'b_id',
626             structure => {
627             C => {
628             type => 'list',
629             class => 'Data::C',
630             key => 'c_id',
631             structure => {
632             name => {
633             type => 'text',
634             maxlength => 50,
635             },
636             desc => {
637             type => 'text',
638             maxlength => 300,
639             },
640             },
641             },
642             name => {
643             type => 'text',
644             maxlength => 50,
645             },
646             desc => {
647             type => 'text',
648             maxlength => 300,
649             },
650             },
651             },
652             name => {
653             type => 'text',
654             maxlength => 50,
655             index => 1,
656             },
657             desc => {
658             type => 'text',
659             maxlength => 300,
660             },
661             },
662             },
663             D => {
664             type => 'list',
665             class => 'Data::D',
666             key => 'd_id',
667             structure => {
668             E => {
669             type => 'list',
670             class => 'Data::E',
671             key => 'e_id',
672             structure => {
673             name => {
674             type => 'text',
675             maxlength => 50,
676             charset => 'latin1',
677             },
678             desc => {
679             type => 'text',
680             maxlength => 300,
681             charset => 'utf8',
682             },
683             },
684             },
685             name => {
686             type => 'text',
687             maxlength => 50,
688             index => 1,
689             unique => 1,
690             },
691             desc => {
692             type => 'text',
693             maxlength => 300,
694             },
695             },
696             },
697             F => {
698             type => 'list',
699             class => 'Data::F',
700             key => 'f_id',
701             structure => {
702             G => {
703             type => 'list',
704             class => 'Data::G',
705             key => 'g_id',
706             structure => {
707             name => {
708             type => 'text',
709             maxlength => 50,
710             },
711             desc => {
712             type => 'text',
713             maxlength => 300,
714             },
715             },
716             },
717             name => {
718             type => 'text',
719             maxlength => 50,
720             },
721             desc => {
722             type => 'text',
723             maxlength => 300,
724             },
725             },
726             },
727             name => {
728             type => 'text',
729             maxlength => 50,
730             },
731             desc => {
732             type => 'text',
733             maxlength => 300,
734             },
735             },
736             },
737             );
738              
739 0           srand(876543);
740 0 0         if(int(rand(1000))!=838) {
741 0           print STDERR "Got incompatible random sequence, skipping the test\n";
742 0           return;
743             }
744 0           srand(876543);
745              
746 0           dprint "Structure done, filling up..";
747 0           my @wordlist=qw(qwe wer ert rty tyu yui uio iop op[ p[] []\
748             asdf sdfg dfgh fghj ghjk hjkl jkl; kl;'
749             zxcvb xcvbn cvbnm vbnm bnm. nm./
750             qwerty wertyu ertui adsfa awerq adf qtwt ljl
751             qwer qw);
752             my $rname=sub {
753 0     0     my $name='';
754 0           for(1..5) {
755 0 0         $name.=' ' if $name;
756 0           $name.=$wordlist[rand(@wordlist)];
757             }
758 0           return substr($name,0,50);
759 0           };
760             my $rdesc=sub {
761 0     0     my $name='';
762 0           for(1..20) {
763 0 0         $name.=' ' if $name;
764 0           $name.=$wordlist[rand(@wordlist)];
765             }
766 0           return substr($name,0,300);
767 0           };
768              
769 0           my $xlist=$odb->fetch('/X');
770 0           my $xnew=$xlist->get_new;
771 0           my $on='a001';
772 0           for(1..5) {
773 0           $xnew->put(
774             name => &$rname,
775             desc => &$rdesc,
776             );
777 0           my $xid=$on++;
778 0           $xlist->put($xid => $xnew);
779             ## dprint ".xid=$xid";
780 0           my $xobj=$xlist->get($xid);
781 0           my $alist=$xobj->get('A');
782 0           my $anew=$alist->get_new;
783 0           for(1..5) {
784 0           $anew->put(
785             name => &$rname,
786             desc => &$rdesc,
787             );
788 0           my $aid=$on++;
789 0           $alist->put($aid => $anew);
790             ## dprint "..aid=$aid";
791 0           my $aobj=$alist->get($aid);
792 0           my $blist=$aobj->get('B');
793 0           my $bnew=$blist->get_new;
794 0           for(1..5) {
795 0           $bnew->put(
796             name => &$rname,
797             desc => &$rdesc,
798             );
799 0           my $bid=$on++;
800 0           $blist->put($bid => $bnew);
801             ## dprint "...bid=$bid";
802 0           my $bobj=$blist->get($bid);
803 0           my $clist=$bobj->get('C');
804 0           my $cnew=$clist->get_new;
805 0           for(1..5) {
806 0           $cnew->put(
807             name => &$rname,
808             desc => &$rdesc,
809             );
810 0           my $cid=$on++;
811 0           $clist->put($cid => $cnew);
812             ## dprint "....cid=$cid";
813 0           my $cobj=$clist->get($cid);
814             }
815             }
816             }
817 0           my $dlist=$xobj->get('D');
818 0           my $dnew=$dlist->get_new;
819 0           for(1..5) {
820 0           $dnew->put(
821             name => &$rname,
822             desc => &$rdesc,
823             );
824 0           my $did=$on++;
825 0           $dlist->put($did => $dnew);
826             ## dprint "..did=$did";
827 0           my $dobj=$dlist->get($did);
828 0           my $elist=$dobj->get('E');
829 0           my $enew=$elist->get_new;
830 0           for(1..5) {
831 0           $enew->put(
832             name => &$rname,
833             desc => &$rdesc,
834             );
835 0           my $eid=$on++;
836 0           $elist->put($eid => $enew);
837             ## dprint "...eid=$eid";
838             }
839             }
840 0           my $flist=$xobj->get('F');
841 0           my $fnew=$flist->get_new;
842 0           for(1..5) {
843 0           $fnew->put(
844             name => &$rname,
845             desc => &$rdesc,
846             );
847 0           my $fid=$on++;
848 0           $flist->put($fid => $fnew);
849             ## dprint "..fid=$fid";
850 0           my $fobj=$flist->get($fid);
851 0           my $glist=$fobj->get('G');
852 0           my $gnew=$glist->get_new;
853 0           for(1..5) {
854 0           $gnew->put(
855             name => &$rname,
856             desc => &$rdesc,
857             );
858 0           my $gid=$on++;
859 0           $glist->put($gid => $gnew);
860             ## dprint "...gid=$gid";
861             }
862             }
863             }
864 0           dprint "Done building test data set, starting tests..";
865              
866 0           my %matrix=(
867             t1 => {
868             args => [
869             [ 'name', 'wq', 'qwerty' ],
870             'and',
871             [ 'desc', 'wq', 'qwerty' ],
872             ],
873             class => 'Data::B',
874             result => '105,13,21,27,3,41,43,75,9',
875             sort => 1,
876             },
877             t2 => {
878             args => [
879             [ 'name', 'wq', 'qwerty' ],
880             'and',
881             [ 'desc', 'wq', 'qwerty' ],
882             { orderby => 'C/name' },
883             ],
884             class => 'Data::B',
885             result => '9,13,21,41,43,3,27,75,105',
886             },
887             t3 => {
888             args => [
889             [ 'C/name', 'sw', 'q' ],
890             'and',
891             [ '../desc', 'sw', 'w' ],
892             { orderby => '/X/A/B/name' },
893             ],
894             class => 'Data::B',
895             result => '108,33,106,109',
896             },
897             t3_1 => {
898             args => [
899             [ 'C/name', 'sw', 'q' ],
900             'and',
901             [ '../desc', 'sw', 'w' ],
902             { orderby => '/X/A/B/name',
903             index => '../../A/name',
904             },
905             ],
906             class => 'Data::B',
907             result => '108,33,106,109',
908             },
909             t3_2 => {
910             args => [
911             [ 'C/name', 'sw', 'q' ],
912             'and',
913             [ '../desc', 'sw', 'w' ],
914             { orderby => 'C/../name',
915             index => '../B/C/name',
916             },
917             ],
918             class => 'Data::B',
919             result => '108,33,106,109',
920             },
921             t4 => {
922             args => [
923             [ [ '/X/F/G/name','sw','a' ],
924             'or',
925             [ '../../D/E/name','sw','b' ],
926             ],
927             'and',
928             [ 'C/desc', 'sw', 'qwerty' ],
929             ],
930             class => 'Data::B',
931             result => '100,109,2,27,30,71,80,84,90,91',
932             sort => 1,
933             },
934             t4_1 => {
935             args => [
936             [ [ '/X/F/G/name','sw','a' ],
937             'or',
938             [ '../../D/E/name','sw','b' ],
939             ],
940             'and',
941             [ 'C/desc', 'sw', 'qwerty' ],
942             ],
943             uri => '/X/a001/A/a002/B',
944             result => 'a009',
945             sort => 1,
946             },
947             t4_2 => {
948             args => [
949             [ [ '/X/F/G/name','sw','a' ],
950             'or',
951             [ '../../D/E/name','sw','b' ],
952             ],
953             'and',
954             [ 'C/desc', 'sw', 'qwerty' ],
955             { index => '/X/name',
956             orderby => '-/X/A/B/name',
957             }
958             ],
959             uri => '/X/a217/A/a218/B',
960             result => 'a243,a225',
961             },
962             t5 => {
963             args => [
964             [ '/project','cs','new' ],
965             ],
966             uri => '/X/a217/A/a218/B',
967             result => 'a219,a225,a231,a237,a243',
968             sort => 1,
969             },
970             t5_1 => {
971             args => [
972             [ '/project','eq','new' ],
973             ],
974             uri => '/X/a217/A/a218/B',
975             result => '',
976             sort => 1,
977             },
978             t6 => {
979             args => [
980             [ '/project','cs','new' ],
981             { orderby => 'name',
982             limit => 10,
983             },
984             ],
985             class => 'Data::E',
986             result => '14,57,23,90,103,33,105,22,80,27',
987             },
988             t6_1 => {
989             args => [
990             [ '/project','cs','new' ],
991             { orderby => 'name',
992             limit => 10,
993             index => '/X/D/name',
994             },
995             ],
996             class => 'Data::E',
997             result => '14,57,23,90,103,33,105,22,80,27',
998             },
999             t6_2 => {
1000             args => [
1001             [ '/project','cs','new' ],
1002             { orderby => 'name',
1003             limit => 10,
1004             offset => 0,
1005             },
1006             ],
1007             class => 'Data::E',
1008             result => '14,57,23,90,103,33,105,22,80,27',
1009             },
1010             t6_3 => {
1011             args => [
1012             [ '/project','cs','new' ],
1013             { orderby => 'name',
1014             limit => 10,
1015             offset => 1,
1016             },
1017             ],
1018             class => 'Data::E',
1019             result => '57,23,90,103,33,105,22,80,27,74',
1020             },
1021             t6_4 => {
1022             args => [
1023             [ '/project','cs','new' ],
1024             { orderby => 'name',
1025             offset => 120,
1026             },
1027             ],
1028             class => 'Data::E',
1029             result => '30,19,73,65,92',
1030             },
1031             t7 => {
1032             args => [
1033             [ 'B/*/C/*/name', 'sw', 'e' ],
1034             'and',
1035             [ 'B/*/C/*/name', 'sw', 'r' ],
1036             ],
1037             class => 'Data::A',
1038             result => '1,10,11,13,15,16,17,23,5,6,9',
1039             sort => 1,
1040             },
1041             t7_1 => {
1042             args => [
1043             [ 'B/*/C/1/name', 'sw', 'e' ],
1044             'and',
1045             [ 'B/*/C/1/name', 'sw', 'r' ],
1046             ],
1047             class => 'Data::A',
1048             result => '',
1049             sort => 1,
1050             },
1051             t7_2 => {
1052             args => [
1053             [ 'B/1/C/*/name', 'sw', 'er' ],
1054             'and',
1055             [ 'B/1/C/*/name', 'sw', 'rt' ],
1056             ],
1057             class => 'Data::A',
1058             result => '11,15,23',
1059             sort => 1,
1060             },
1061             t7_3 => {
1062             args => [
1063             [ 'B/C/*/name', 'sw', 'er' ],
1064             'and',
1065             [ 'B/C/*/name', 'sw', 'rt' ],
1066             ],
1067             class => 'Data::A',
1068             result => '11,15,23',
1069             sort => 1,
1070             },
1071             t7_4 => {
1072             args => [
1073             [ 'B/C/1/name', 'sw', 'er' ],
1074             'and',
1075             [ 'B/C/2/name', 'sw', 'rt' ],
1076             ],
1077             class => 'Data::A',
1078             result => '11,15,23',
1079             sort => 1,
1080             },
1081             t7_5 => {
1082             args => [
1083             [ 'B/3/C/1/name', 'sw', 'er' ],
1084             'and',
1085             [ 'B/3/C/1/name', 'sw', 'rt' ],
1086             ],
1087             class => 'Data::A',
1088             result => '',
1089             sort => 1,
1090             },
1091             );
1092              
1093 0           foreach my $test_id (sort keys %matrix) {
1094 0           my $test_data=$matrix{$test_id};
1095 0           my $list;
1096 0 0         if($test_data->{class}) {
1097 0           $list=$odb->collection(class => $test_data->{class});
1098             }
1099             else {
1100 0           $list=$odb->fetch($test_data->{uri});
1101             }
1102 0           my $sr=$list->search(@{$test_data->{args}});
  0            
1103 0 0         my $got=join(",",$test_data->{sort} ? (sort @$sr) : @$sr);
1104 0           my $expect=$test_data->{result};
1105 0           $self->assert($got eq $expect,
1106             "Test '$test_id' is wrong: got='$got', expect='$expect'");
1107             }
1108             }
1109              
1110             ###############################################################################
1111              
1112             sub test_search {
1113 0     0 0   my $self=shift;
1114              
1115 0           my $odb=$self->get_odb();
1116              
1117 0           my $custlist=$odb->fetch('/Customers');
1118              
1119 0           my $customer=$custlist->get_new();
1120              
1121 0           $self->assert(ref($customer),
1122             "Can't create Customer");
1123              
1124 0           $customer->add_placeholder(
1125             name => 'short',
1126             type => 'text',
1127             charset => 'utf8', # required for case-ign. collation
1128             maxlength => 100,
1129             index => 1,
1130             );
1131              
1132 0           $customer->add_placeholder(
1133             name => 'long',
1134             type => 'text',
1135             charset => 'utf8',
1136             maxlength => 1000,
1137             );
1138              
1139             ##
1140             # For deeper search
1141             #
1142 0           $customer->add_placeholder(name => 'Products',
1143             type => 'list',
1144             class => 'Data::Product',
1145             key => 'product_id');
1146 0           my $product=XAO::Objects->new(objname => 'Data::Product',
1147             glue => $odb);
1148 0           $product->add_placeholder(name => 'price',
1149             type => 'real',
1150             maxvalue => 1000,
1151             minvalue => 0);
1152              
1153             ##
1154             # Words to fill descriptions. Tests depend on exact sequence and
1155             # number and content of them. Do not alter!
1156             #
1157 0           my @words=split(/\s+/,<<'EOT');
1158             Just some stuff from 'fortune'.
1159              
1160             live lively liver
1161              
1162             I am not a politician and my other habits are also good.
1163             Almost everything in life is easier to get into than out of.
1164             The reward of a thing well done is to have done it.
1165             earth is 98% full ... please delete anyone you can.
1166             Hoping to goodness is not theologically sound. - Peanuts
1167             There is a Massachusetts law requiring all dogs to have
1168             their hind legs tied during the month of April.
1169             The man scarce lives who is not more credulous than he ought to be.... The
1170             natural disposition is always to believe. It is acquired wisdom and experience
1171             only that teach incredulity and they very seldom teach it enough.
1172             - Adam Smith
1173             Kansas state law requires pedestrians crossing the highways at night to
1174             wear tail lights.
1175             Very few things actually get manufactured these days because in an
1176             infinitely large Universe such as the one in which we live most things one
1177             could possibly imagine and a lot of things one would rather not grow
1178             somewhere. A forest was discovered recently in which most of the trees grew
1179             ratchet screwdrivers as fruit. The life cycle of the ratchet screwdriver is
1180             quite interesting. Once picked it needs a dark dusty drawer in which it can
1181             lie undisturbed for years. Then one night it suddenly hatches discards its
1182             outer skin that crumbles into dust and emerges as a totally unidentifiable
1183             little metal object with flanges at both ends and a sort of ridge and a hole
1184             for a screw. This when found will get thrown away. No one knows what the
1185             screwdriver is supposed to gain from this. Nature in her infinite wisdom
1186             is presumably working on it.
1187             EOT
1188              
1189             ##
1190             # The algorithm below gives us 201 distinct shorts, 287 distinct
1191             # longs and 300 distinct pairs
1192             #
1193 0           my $n=1;
1194 0           my $ns=2;
1195 0           my $nl=3;
1196 0           my $pp=12;
1197 0           $customer->put(name => 'Search Test Customer');
1198 0           $odb->transact_begin;
1199 0           for(1..300) {
1200 0           my $str='';
1201 0           for(my $i=0; $i!=10; $i++) {
1202 0 0         $str.=' ' if $str;
1203 0           $str.=$words[$ns];
1204 0           $ns+=7+$n;
1205 0           $ns-=200 while $ns>=200;
1206             }
1207 0           $customer->put(short => $str);
1208 0           $str='';
1209 0           for(my $i=0; $i!=50; $i++) {
1210 0 0         $str.=' ' if $str;
1211 0           $str.=$words[$nl];
1212 0           $nl+=11+$n;
1213 0           $nl-=@words while $nl>=@words;
1214             }
1215 0           $customer->put(long => $str);
1216 0           my $id=$custlist->put($customer);
1217 0           $n++;
1218              
1219 0           my $plist=$custlist->get($id)->get('Products');
1220 0           $product->put(price => $pp);
1221 0           $pp+=17.21;
1222 0 0         $pp-=1000 if $pp>=1000;
1223 0           $plist->put($product);
1224             }
1225 0           $odb->transact_commit;
1226              
1227             ##
1228             # Checking normal search
1229             #
1230 0           my $list=$custlist->search('short', 'ws', 'live');
1231 0           $self->assert(@$list == 43,
1232             "Wrong search results, test 1 (".scalar(@$list).")");
1233 0           $list=$custlist->search([ 'short', 'wq', 'have' ],
1234             'and',
1235             [ 'long', 'ws', 'thing' ]);
1236 0           $self->assert(@$list == 19,
1237             "Wrong search results, test 2 (".scalar(@$list).")");
1238 0           $list=$custlist->search([ 'short', 'wq', 'in' ],
1239             'or',
1240             [ 'long', 'wq', 'the' ]);
1241 0           $self->assert(@$list == 233,
1242             "Wrong search results, test 3 (".scalar(@$list).")");
1243 0           $list=$custlist->search([ 'short', 'wq', 'is|not' ],
1244             'or',
1245             [ 'long', 'wq', '[aA]' ]);
1246 0           $self->assert(@$list == 0,
1247             "Wrong search results, test 16 (".scalar(@$list).")");
1248              
1249             ##
1250             # Checking multiple keyword search
1251             #
1252 0           $list=$custlist->search('short', 'wq', [qw(in the forest)] );
1253 0           $self->assert(@$list == 192,
1254             "Wrong search results, test 4 (".scalar(@$list).")");
1255 0           $list=$custlist->search([ 'short', 'wq', 'in' ],
1256             'OR',
1257             [ [ 'short', 'wq', 'the' ],
1258             'OR',
1259             [ 'short', 'wq', 'forest' ]
1260             ]);
1261 0           $self->assert(@$list == 192,
1262             "Wrong search results, test 5 (".scalar(@$list).")");
1263              
1264             ##
1265             # Check sorting
1266             #
1267 0           $list=$custlist->search([ 'short', 'wq', 'in' ],
1268             'and',
1269             [ 'long', 'wq', 'the' ],
1270             { orderby => [ ascend => 'short',
1271             ascend => 'long' ]
1272             });
1273 0           $self->assert(@$list == 61,
1274             "Wrong search results, test 6 (".scalar(@$list).")");
1275 0           my $short;
1276             my $long;
1277 0           foreach my $id (@$list) {
1278 0           my $obj=$custlist->get($id);
1279 0           my $s=$obj->get('short');
1280 0           my $l=$obj->get('long');
1281 0 0 0       next unless $s =~ /^[a-z]/ && $l =~ /^[a-z]/;
1282 0 0 0       if($short && $long) {
1283 0           $self->assert(ord($s) >= ord($short),
1284             "Wrong sorting order ('$s' < '$short')");
1285 0 0         if($s eq $short) {
1286 0           $self->assert(ord($l) >= ord($long),
1287             "Wrong sorting order ('$l' < '$long')");
1288             }
1289             }
1290             else {
1291 0           $short=$s;
1292 0           $long=$l;
1293             }
1294             }
1295              
1296             ##
1297             # Check reverse sorting and passing array reference at the same
1298             # time.
1299             #
1300 0           $list=$custlist->search([ [ 'short', 'wq', 'in' ],
1301             'and',
1302             [ 'long', 'wq', 'the' ],
1303             ],
1304             { orderby => [ descend => 'long',
1305             descend => 'short' ]
1306             });
1307 0           $self->assert(@$list == 61,
1308             "Wrong search results, test 15 (".scalar(@$list).")");
1309 0           $short=undef;
1310 0           $long=undef;
1311 0           foreach my $id (@$list) {
1312 0           my $obj=$custlist->get($id);
1313 0           my $s=$obj->get('short');
1314 0           my $l=$obj->get('long');
1315 0 0 0       next unless $s =~ /^[a-z]/ && $l =~ /^[a-z]/;
1316 0 0 0       if($short && $long) {
1317 0           $self->assert(ord($l) <= ord($long),
1318             "Wrong sorting order ('$l' > '$long')");
1319 0 0         if($l eq $long) {
1320 0           $self->assert(ord($s) <= ord($short),
1321             "Wrong sorting order ('$s' > '$short')");
1322             }
1323             }
1324             else {
1325 0           $short=$s;
1326 0           $long=$l;
1327             }
1328             }
1329              
1330             ##
1331             # Check how distinct works
1332             #
1333 0           $list=$custlist->search('short', 'wq', 'you', { distinct => 'short' });
1334 0           $self->assert(@$list == 18,
1335             "Wrong search results, test 7 (".scalar(@$list).")");
1336 0           $list=$custlist->search('short', 'wq', [qw(seldom dogs)],
1337             { distinct => 'long' });
1338 0           $self->assert(@$list == 29,
1339             "Wrong search results, test 8 (".scalar(@$list).")");
1340 0           $list=$custlist->search('short', 'wq', [qw(you the in at to)],
1341             { distinct => [qw(short long)] });
1342 0           $self->assert(@$list == 235,
1343             "Wrong search results, test 9 (".scalar(@$list).")");
1344              
1345             ##
1346             # Finally, checking how empty condition works
1347             #
1348 0           $list=$custlist->search();
1349 0           $self->assert(@$list == 302,
1350             "Wrong search results, test 10 (".scalar(@$list).")");
1351              
1352             ##
1353             # Check ordering works on empty conditions.
1354             #
1355 0           $list=$custlist->search({ orderby => [ ascend => 'short',
1356             descend => 'long' ]
1357             });
1358 0           $self->assert(@$list == 302,
1359             "Wrong search results, test 11 (".scalar(@$list).")");
1360 0           $short=undef;
1361 0           $long=undef;
1362 0           foreach my $id (@$list) {
1363 0           my $obj=$custlist->get($id);
1364 0           my $s=$obj->get('short');
1365 0           my $l=$obj->get('long');
1366 0 0 0       next unless $s && $s =~ /^[a-z]/ && $l =~ /^[a-z]/;
      0        
1367 0 0 0       if($short && $long) {
1368 0           $self->assert(ord($s) >= ord($short),
1369             "Wrong sorting order ('$s' < '$short')");
1370 0 0         if($s eq $short) {
1371 0           $self->assert(ord($l) <= ord($long),
1372             "Wrong sorting order ('$l' > '$long')");
1373             }
1374             }
1375             else {
1376 0           $short=$s;
1377 0           $long=$l;
1378             }
1379             }
1380              
1381             ##
1382             # Now checking how ordering on inner property works
1383             #
1384 0           $list=$custlist->search({ orderby => [ ascend => 'Products/price',
1385             descend => 'short' ]
1386             });
1387 0           $self->assert(@$list == 300,
1388             "Wrong search results, test 12 (".scalar(@$list).")");
1389 0           $short=undef;
1390 0           my $price=undef;
1391 0           foreach my $id (@$list) {
1392 0           my $obj=$custlist->get($id);
1393 0           my $s=$obj->get('short');
1394 0 0 0       next unless $s && $s =~ /^[a-z]/;
1395 0           my $pl=$obj->get('Products');
1396 0           my $p=$pl->get(($pl->keys)[0])->get('price');
1397 0 0 0       if($short && defined($price)) {
1398 0           $self->assert($p >= $price,
1399             "Wrong sorting order ($p < $price)");
1400 0 0         if($p == $price) {
1401 0           dprint "That happened ($p)";
1402 0           $self->assert(ord($s) <= ord($short),
1403             "Wrong sorting order ('$s' > '$short')");
1404             }
1405             }
1406             else {
1407 0           $short=$s;
1408 0           $price=$p;
1409             }
1410             }
1411              
1412             ##
1413             # Searching by price and checking that IDs in this simple case are
1414             # distinct.
1415             #
1416 0           $list=$custlist->search([ 'Products/price', 'gt', 100 ],
1417             'and',
1418             [ 'Products/price', 'lt', 600 ]);
1419 0           $self->assert(@$list == 149,
1420             "Wrong search results, test 13 (".scalar(@$list).")");
1421 0           my %a;
1422 0           @a{@$list}=@$list;
1423 0           $self->assert(scalar(keys %a) == 149,
1424             "Non-unique ID in search results, test 14");
1425              
1426             ##
1427             # Cleaning up
1428             #
1429 0           $customer->drop_placeholder('long');
1430 0           $customer->drop_placeholder('short');
1431             }
1432              
1433             sub test_collection_search {
1434 0     0 0   my $self=shift;
1435 0           my $odb=$self->get_odb();
1436              
1437 0           my $cc=$odb->collection(class => 'Data::Customer');
1438              
1439 0           my $list=$cc->search('name', 'wq', 'Test');
1440              
1441 0           $self->assert(@$list == 2,
1442             "Search results are wrong on collection");
1443             }
1444              
1445             ##
1446             # See note in CHANGES for 1.03 for the bug we're testing here against.
1447             # First thing to do if that test ever fails again is to uncomment
1448             # printing final SQL statement in Glue.pm and check if table joins are
1449             # correct.
1450             # am@xao.com, Jan/18, 2002
1451             #
1452             sub test_multiple_branches {
1453 0     0 0   my $self=shift;
1454 0           my $odb=$self->get_odb();
1455              
1456 0           my $customers=$odb->fetch('/Customers');
1457              
1458 0           my $c=$customers->get_new;
1459 0           $c->build_structure(
1460             Orders => {
1461             type => 'list',
1462             class => 'Data::Order',
1463             key => 'order_id',
1464             structure => {
1465             name => {
1466             type => 'text',
1467             maxlength => 100,
1468             },
1469             },
1470             },
1471             Products => {
1472             type => 'list',
1473             class => 'Data::Product',
1474             key => 'product_id',
1475             structure => {
1476             name => {
1477             type => 'text',
1478             maxlength => 100,
1479             },
1480             },
1481             },
1482             );
1483              
1484 0           $customers->put('screw' => $c);
1485 0           $c=$customers->get('screw');
1486 0           $c->get('Orders')->put(aaa => $c->get('Orders')->get_new);
1487 0           $c->get('Orders')->get('aaa')->put(name => 'foo');
1488 0           $c->get('Products')->put(bbb => $c->get('Products')->get_new);
1489 0           $c->get('Products')->get('bbb')->put(name => 'bar');
1490              
1491 0           $c=$customers->get('c1');
1492 0           $c->get('Orders')->put(ooo => $c->get('Orders')->get_new);
1493 0           $c->get('Orders')->get('ooo')->put(name => 'foo');
1494 0           $c->get('Products')->put(ppp => $c->get('Products')->get_new);
1495 0           $c->get('Products')->get('ppp')->put(name => 'bar');
1496              
1497 0           $c=$customers->get('c2');
1498 0           $c->get('Orders')->put(ooo => $c->get('Orders')->get_new);
1499 0           $c->get('Orders')->get('ooo')->put(name => 'ku');
1500 0           $c->get('Products')->put(ppp => $c->get('Products')->get_new);
1501 0           $c->get('Products')->get('ppp')->put(name => 'ru');
1502              
1503 0           $customers->put(c3 => $customers->get_new);
1504 0           $c=$customers->get('c3');
1505 0           $c->get('Orders')->put(ooo => $c->get('Orders')->get_new);
1506 0           $c->get('Orders')->get('ooo')->put(name => 'boom');
1507 0           $c->get('Products')->put(ppp => $c->get('Products')->get_new);
1508 0           $c->get('Products')->get('ppp')->put(name => 'ru');
1509              
1510 0           $customers->put(c4 => $customers->get_new);
1511 0           $c=$customers->get('c4');
1512 0           $c->get('Orders')->put(ooo => $c->get('Orders')->get_new);
1513 0           $c->get('Orders')->get('ooo')->put(name => 'ku');
1514 0           $c->get('Products')->put(ppp => $c->get('Products')->get_new);
1515 0           $c->get('Products')->get('ppp')->put(name => 'duh!');
1516              
1517 0           my $ids=$customers->search([ 'Products/name', 'eq', 'ku' ],
1518             'or',
1519             [ 'Orders/name', 'eq', 'ru' ],
1520             { orderby => 'customer_id' });
1521              
1522 0           my $t_ids=join(",",@$ids);
1523 0           $self->assert($t_ids eq '',
1524             "Wrong search results for multi-branch search (got '$t_ids', expect '')");
1525              
1526 0           $ids=$customers->search([ 'Orders/name', 'eq', 'ku' ],
1527             'or',
1528             [ 'Products/name', 'eq', 'ru' ],
1529             { orderby => 'customer_id' });
1530              
1531 0           $t_ids=join(",",@$ids);
1532 0           $self->assert($t_ids eq 'c2,c3,c4',
1533             "Wrong search results for multi-branch search (got '$t_ids', expect 'c2,c3,c4')");
1534              
1535 0           $ids=$customers->search([ 'Orders/name', 'eq', 'kaaau' ],
1536             'or',
1537             [ 'Products/name', 'eq', 'ru' ],
1538             { orderby => '-customer_id' });
1539              
1540 0           $t_ids=join(",",@$ids);
1541 0           $self->assert($t_ids eq 'c3,c2',
1542             "Wrong search results for multi-branch search (got '$t_ids', expect 'c3,c2')");
1543              
1544 0           $ids=$customers->search([ 'Orders/name', 'eq', 'foo' ],
1545             'and',
1546             [ 'Products/name', 'eq', 'bar' ],
1547             { orderby => 'customer_id' });
1548              
1549 0           $t_ids=join(",",@$ids);
1550 0           $self->assert($t_ids eq 'c1,screw',
1551             "Wrong search results for multi-branch search (got '$t_ids', expect 'c1,screw')");
1552             }
1553              
1554             ##
1555             # Imagine a structure like this:
1556             # /Orders
1557             # |-o1
1558             # | |-Products
1559             # | | |-p1
1560             # | | | |-min => 100
1561             # | | | \-max => 200
1562             # | | |-p2
1563             # | | | |-min => 150
1564             # | | | \-max => 250
1565             #
1566             # What should be returned by:
1567             # $orders->search([ 'Products/min','eq',100 ], 'and',
1568             # [ 'Products/max','eq',250 ]);
1569             # Should the 'o1' match? Now there is a way to resolve it (as of 1.04).
1570             #
1571             # $orders->search([ 'Products/*/min','eq',100 ], 'and',
1572             # [ 'Products/*/max','eq',250 ]);
1573             # Will match, while:
1574             # $orders->search([ 'Products/1/min','eq',100 ], 'and',
1575             # [ 'Products/1/max','eq',250 ]);
1576             # Will not as it will try both on the same product. Default should be to
1577             # treat as if /1/ was everywhere.
1578             #
1579             # am@xao.com, Sep/10, 2002
1580             #
1581             sub test_deep_variants {
1582 0     0 0   my $self=shift;
1583 0           my $odb=$self->get_odb();
1584              
1585 0           my %struct=(
1586             Orders => {
1587             type => 'list',
1588             class => 'Data::Order',
1589             key => 'order_id',
1590             structure => {
1591             Products => {
1592             type => 'list',
1593             class => 'Data::Product',
1594             key => 'order_id',
1595             structure => {
1596             min => {
1597             type => 'integer',
1598             minvalue => 0,
1599             },
1600             max => {
1601             type => 'integer',
1602             minvalue => 0,
1603             },
1604             },
1605             },
1606             name => {
1607             type => 'text',
1608             maxlength => 200,
1609             },
1610             },
1611             },
1612             );
1613              
1614 0           $odb->fetch('/')->build_structure(\%struct);
1615 0           my $orders=$odb->fetch('/Orders');
1616 0           $self->deep_variants($orders);
1617              
1618 0           $odb->fetch('/')->drop_placeholder('Orders');
1619 0           my $c1=$odb->fetch('/Customers/c1');
1620 0           $c1->build_structure(\%struct);
1621 0           $self->deep_variants($c1->get('Orders'));
1622 0           my $c2=$odb->fetch('/Customers/c2');
1623 0           $self->deep_variants($c2->get('Orders'));
1624             }
1625              
1626             sub deep_variants {
1627 0     0 0   my $self=shift;
1628 0           my $orders=shift;
1629              
1630 0           my $on=$orders->get_new();
1631 0           $on->put(name => 'qwerty');
1632 0           $orders->put(o1 => $on);
1633 0           my $products=$orders->get('o1')->get('Products');
1634 0           my $pn=$products->get_new;
1635 0           $pn->put(min => 100);
1636 0           $pn->put(max => 200);
1637 0           $products->put(p1 => $pn);
1638 0           $pn->put(min => 150);
1639 0           $pn->put(max => 250);
1640 0           $products->put(p2 => $pn);
1641 0           $pn->put(min => 250);
1642 0           $pn->put(max => 350);
1643 0           $products->put(p3 => $pn);
1644 0           $pn->put(min => 350);
1645 0           $pn->put(max => 450);
1646 0           $products->put(p4 => $pn);
1647 0           $pn->put(min => 450);
1648 0           $pn->put(max => 550);
1649 0           $products->put(p5 => $pn);
1650              
1651 0           my $sr=$orders->search([ 'Products/*/min','eq',100 ], 'and',
1652             [ 'Products/*/max','eq',250 ]);
1653 0   0       $self->assert(scalar(@$sr)==1 && $sr->[0] eq 'o1',
1654             "Wrong /*/ deep search in test_deep_variants");
1655              
1656 0           $sr=$orders->search([ 'Products/1/min','eq',100 ], 'and',
1657             [ 'Products/1/max','eq',250 ]);
1658 0           $self->assert(scalar(@$sr)==0,
1659             "Wrong /1/ deep search in test_deep_variants");
1660              
1661 0           $sr=$orders->search([ 'Products/min','eq',100 ], 'and',
1662             [ 'Products/max','eq',250 ]);
1663 0           $self->assert(scalar(@$sr)==0,
1664             "Wrong default deep search in test_deep_variants");
1665              
1666 0           $sr=$orders->search([ 'Products/*/min','eq',100 ],
1667             'and',
1668             [ [ 'Products/*/max','gt',200 ],
1669             'and',
1670             [ [ 'Products/*/min','lt',300 ],
1671             'and',
1672             [ 'Products/*/max','eq',200 ],
1673             ],
1674             ]);
1675 0   0       $self->assert(scalar(@$sr)==1 && $sr->[0] eq 'o1',
1676             "Wrong complex deep search in test_deep_variants");
1677             }
1678              
1679             ###############################################################################
1680             1;