File Coverage

blib/lib/SQL/Statement/Operation.pm
Criterion Covered Total %
statement 150 177 84.7
branch 14 22 63.6
condition 22 47 46.8
subroutine 45 62 72.5
pod 6 6 100.0
total 237 314 75.4


line stmt bran cond sub pod time code
1             package SQL::Statement::Operation;
2              
3             ######################################################################
4             #
5             # This module is copyright (c), 2009-2020 by Jens Rehsack.
6             # All rights reserved.
7             #
8             # It may be freely distributed under the same terms as Perl itself.
9             # See below for help and copyright information (search for SYNOPSIS).
10             #
11             ######################################################################
12              
13 16     16   116 use strict;
  16         33  
  16         542  
14 16     16   89 use warnings FATAL => "all";
  16         32  
  16         550  
15              
16 16     16   92 use vars qw(@ISA);
  16         29  
  16         608  
17 16     16   87 use Carp ();
  16         32  
  16         259  
18              
19 16     16   80 use SQL::Statement::Term ();
  16         44  
  16         5384  
20              
21             our $VERSION = '1.413_001';
22              
23             @ISA = qw(SQL::Statement::Term);
24              
25             =pod
26              
27             =head1 NAME
28              
29             SQL::Statement::Operation - base class for all operation terms
30              
31             =head1 SYNOPSIS
32              
33             # create an operation with an SQL::Statement object as owner, specifying
34             # the operation name (for error purposes), the left and the right
35             # operand
36             my $term = SQL::Statement::Operation->new( $owner, $op, $left, $right );
37             # access the result of that operation
38             $term->value( $eval );
39              
40             =head1 DESCRIPTION
41              
42             SQL::Statement::Operation is an abstract base class providing the interface
43             for all operation terms.
44              
45             =head1 INHERITANCE
46              
47             SQL::Statement::Operation
48             ISA SQL::Statement::Term
49              
50             =head1 METHODS
51              
52             =head2 new
53              
54             Instantiates new operation term.
55              
56             =head2 value
57              
58             Return the result of the operation of the term by calling L
59              
60             =head2 operate
61              
62             I method which will do the operation of the term. Must be
63             overridden by derived classes.
64              
65             =head2 op
66              
67             Returns the name of the executed operation.
68              
69             =head2 left
70              
71             Returns the left operand (if any).
72              
73             =head2 right
74              
75             Returns the right operand (if any).
76              
77             =head2 DESTROY
78              
79             Destroys the term and undefines the weak reference to the owner as well
80             as the stored operation, the left and the right operand.
81              
82             =cut
83              
84             sub new
85             {
86 297     297 1 776 my ( $class, $owner, $operation, $leftTerm, $rightTerm ) = @_;
87              
88 297         824 my $self = $class->SUPER::new($owner);
89 297         649 $self->{OP} = $operation;
90 297         522 $self->{LEFT} = $leftTerm;
91 297         504 $self->{RIGHT} = $rightTerm;
92              
93 297         690 return $self;
94             }
95              
96 1     1 1 10 sub op { return $_[0]->{OP}; }
97 0     0 1 0 sub left { return $_[0]->{LEFT}; }
98 0     0 1 0 sub right { return $_[0]->{RIGHT}; }
99              
100             sub operate($)
101             {
102 0   0 0 1 0 Carp::confess( sprintf( q{pure virtual function 'operate' called on %s for %s}, ref( $_[0] ) || __PACKAGE__, $_[0]->{OP} ) );
103             }
104              
105             sub DESTROY
106             {
107 297     297   527 my $self = $_[0];
108              
109 297         527 undef $self->{OP};
110 297         959 undef $self->{LEFT};
111 297         750 undef $self->{RIGHT};
112              
113 297         743 $self->SUPER::DESTROY();
114             }
115              
116 1204     1204 1 2421 sub value($) { return $_[0]->operate( $_[1] ); }
117              
118             package SQL::Statement::Operation::Neg;
119              
120 16     16   411 use vars qw(@ISA);
  16         47  
  16         1615  
121             @ISA = qw(SQL::Statement::Operation);
122              
123             =pod
124              
125             =head1 NAME
126              
127             SQL::Statement::Operation::Neg - negate operation
128              
129             =head1 SYNOPSIS
130              
131             # create an operation with an SQL::Statement object as owner,
132             # specifying the operation name, the left and B right operand
133             my $term = SQL::Statement::Neg->new( $owner, $op, $left, undef );
134             # access the result of that operation
135             $term->value( $eval );
136              
137             =head1 DESCRIPTION
138              
139             SQL::Statement::Operation::Neg
140              
141             =head1 INHERITANCE
142              
143             SQL::Statement::Operation::Neg
144             ISA SQL::Statement::Operation
145             ISA SQL::Statement::Term
146              
147             =head1 METHODS
148              
149             =head2 operate
150              
151             Return the logical negated value of the left operand.
152              
153             =cut
154              
155             sub operate($)
156             {
157 72     72   152 return !$_[0]->{LEFT}->value( $_[1] );
158             }
159              
160             package SQL::Statement::Operation::And;
161              
162 16     16   114 use vars qw(@ISA);
  16         31  
  16         2140  
163             @ISA = qw(SQL::Statement::Operation);
164              
165             =pod
166              
167             =head1 NAME
168              
169             SQL::Statement::Operation::And - and operation
170              
171             =head1 SYNOPSIS
172              
173             # create an C operation with an SQL::Statement object as owner,
174             # specifying the operation name, the left and the right operand
175             my $term = SQL::Statement::And->new( $owner, $op, $left, $right );
176             # access the result of that operation
177             $term->value( $eval );
178              
179             =head1 DESCRIPTION
180              
181             SQL::Statement::Operation::And implements the logical C operation
182             between two terms.
183              
184             =head1 INHERITANCE
185              
186             SQL::Statement::Operation::And
187             ISA SQL::Statement::Operation
188             ISA SQL::Statement::Term
189              
190             =head1 METHODS
191              
192             =head2 operate
193              
194             Return the result of the logical C operation for the Ls of the
195             left and right operand.
196              
197             =cut
198              
199             sub operate($)
200             {
201 326     326   696 my $left = $_[0]->{LEFT}->value( $_[1] );
202 326         787 my $right = $_[0]->{RIGHT}->value( $_[1] );
203              
204 326   100     1143 return $left && $right;
205             }
206              
207             package SQL::Statement::Operation::Or;
208              
209 16     16   117 use vars qw(@ISA);
  16         32  
  16         2249  
210             @ISA = qw(SQL::Statement::Operation);
211              
212             =pod
213              
214             =head1 NAME
215              
216             SQL::Statement::Operation::Or - or operation
217              
218             =head1 SYNOPSIS
219              
220             # create an C operation with an SQL::Statement object as owner,
221             # specifying the operation name, the left and the right operand
222             my $term = SQL::Statement::Or->new( $owner, $op, $left, $right );
223             # access the result of that operation
224             $term->value( $eval );
225              
226             =head1 DESCRIPTION
227              
228             SQL::Statement::Operation::Or implements the logical C operation
229             between two terms.
230              
231             =head1 INHERITANCE
232              
233             SQL::Statement::Operation::Or
234             ISA SQL::Statement::Operation
235             ISA SQL::Statement::Term
236              
237             =head1 METHODS
238              
239             =head2 operate
240              
241             Return the result of the logical C operation for the Ls of the
242             left and right operand.
243              
244             =cut
245              
246             sub operate($)
247             {
248 11     11   48 my $left = $_[0]->{LEFT}->value( $_[1] );
249 11         34 my $right = $_[0]->{RIGHT}->value( $_[1] );
250              
251 11   100     50 return $left || $right;
252             }
253              
254             package SQL::Statement::Operation::Is;
255              
256 16     16   166 use vars qw(@ISA);
  16         39  
  16         2764  
257             @ISA = qw(SQL::Statement::Operation);
258              
259             =pod
260              
261             =head1 NAME
262              
263             SQL::Statement::Operation::Is - is operation
264              
265             =head1 SYNOPSIS
266              
267             # create an C operation with an SQL::Statement object as owner,
268             # specifying the operation name, the left and the right operand
269             my $term = SQL::Statement::Is->new( $owner, $op, $left, $right );
270             # access the result of that operation
271             $term->value( $eval );
272              
273             =head1 DESCRIPTION
274              
275             SQL::Statement::Operation::Is supports: C, C and C.
276             The right operand is always evaluated in boolean context in case of C
277             and C. C returns I even if the left term is an empty
278             string (C<''>).
279              
280             =head1 INHERITANCE
281              
282             SQL::Statement::Operation::Is
283             ISA SQL::Statement::Operation
284             ISA SQL::Statement::Term
285              
286             =head1 METHODS
287              
288             =head2 operate
289              
290             Returns true when the left term is null, true or false - based on the
291             requested right value.
292              
293             =cut
294              
295             sub operate($)
296             {
297 0     0   0 my $self = $_[0];
298 0         0 my $left = $self->{LEFT}->value( $_[1] );
299 0         0 my $right = $self->{RIGHT}->value( $_[1] );
300 0         0 my $expr;
301              
302 0 0       0 if ( defined($right) )
303             {
304 0 0 0     0 $expr = defined($left) ? $left && $right : 0; # is true / is false
305             }
306             else
307             {
308 0   0     0 $expr = !defined($left) || ( $left eq '' ); # FIXME I don't like that '' IS NULL
309             }
310              
311 0         0 return $expr;
312             }
313              
314             package SQL::Statement::Operation::ANSI::Is;
315              
316 16     16   123 use vars qw(@ISA);
  16         41  
  16         2760  
317             @ISA = qw(SQL::Statement::Operation);
318              
319             =pod
320              
321             =head1 NAME
322              
323             SQL::Statement::Operation::ANSI::Is - is operation
324              
325             =head1 SYNOPSIS
326              
327             # create an C operation with an SQL::Statement object as owner,
328             # specifying the operation name, the left and the right operand
329             my $term = SQL::Statement::Is->new( $owner, $op, $left, $right );
330             # access the result of that operation
331             $term->value( $eval );
332              
333             =head1 DESCRIPTION
334              
335             SQL::Statement::Operation::ANSI::Is supports: C, C and C.
336             The right operand is always evaluated in boolean context in case of C
337             and C. C returns I if the right term is not defined,
338             I otherwise.
339              
340             =head1 INHERITANCE
341              
342             SQL::Statement::Operation::Is
343             ISA SQL::Statement::Operation
344             ISA SQL::Statement::Term
345              
346             =head1 METHODS
347              
348             =head2 operate
349              
350             Returns true when the left term is null, true or false - based on the
351             requested right value.
352              
353             =cut
354              
355             sub operate($)
356             {
357 3     3   5 my $self = $_[0];
358 3         10 my $left = $self->{LEFT}->value( $_[1] );
359 3         9 my $right = $self->{RIGHT}->value( $_[1] );
360 3         5 my $expr;
361              
362 3 50       9 if ( defined($right) )
363             {
364 0 0 0     0 $expr = defined($left) ? $left && $right : 0; # is true / is false
365             }
366             else
367             {
368 3         8 $expr = !defined($left);
369             }
370              
371 3         12 return $expr;
372             }
373              
374             package SQL::Statement::Operation::Contains;
375              
376 16     16   130 use vars qw(@ISA);
  16         30  
  16         806  
377             @ISA = qw(SQL::Statement::Operation);
378 16     16   98 use Scalar::Util qw(looks_like_number);
  16         30  
  16         3716  
379              
380             =pod
381              
382             =head1 NAME
383              
384             SQL::Statement::Operation::Contains - in operation
385              
386             =head1 SYNOPSIS
387              
388             # create an C operation with an SQL::Statement object as owner,
389             # specifying the operation name, the left and the right operand
390             my $term = SQL::Statement::Contains->new( $owner, $op, $left, $right );
391             # access the result of that operation
392             $term->value( $eval );
393              
394             =head1 DESCRIPTION
395              
396             SQL::Statement::Operation::Contains expects the right operand is an array
397             of L instances. It checks whether the left operand
398             is in the list of the right operands or not like:
399              
400             $left->value($eval) ~~ map { $_->value($eval) } @{$right}
401              
402             =head1 INHERITANCE
403              
404             SQL::Statement::Operation::Contains
405             ISA SQL::Statement::Operation
406             ISA SQL::Statement::Term
407              
408             =head1 METHODS
409              
410             =head2 operate
411              
412             Returns true when the left term is equal to any of the right terms
413              
414             =cut
415              
416             sub operate($)
417             {
418 71     71   116 my ( $self, $eval ) = @_;
419 71         170 my $left = $self->{LEFT}->value($eval);
420 71         119 my @right = map { $_->value($eval); } @{ $self->{RIGHT} };
  277         578  
  71         136  
421 71         139 my $expr = 0;
422              
423 71         124 foreach my $r (@right)
424             {
425             last
426 228 100 66     947 if $expr |= ( looks_like_number($left) && looks_like_number($r) ) ? $left == $r : $left eq $r;
    100          
427             }
428              
429 71         325 return $expr;
430             }
431              
432             package SQL::Statement::Operation::Between;
433              
434 16     16   133 use vars qw(@ISA);
  16         31  
  16         850  
435             @ISA = qw(SQL::Statement::Operation);
436 16     16   115 use Scalar::Util qw(looks_like_number);
  16         31  
  16         3759  
437              
438             =pod
439              
440             =head1 NAME
441              
442             SQL::Statement::Operation::Between - between operation
443              
444             =head1 SYNOPSIS
445              
446             # create an C operation with an SQL::Statement object as owner,
447             # specifying the operation name, the left and the right operand
448             my $term = SQL::Statement::Between->new( $owner, $op, $left, $right );
449             # access the result of that operation
450             $term->value( $eval );
451              
452             =head1 DESCRIPTION
453              
454             SQL::Statement::Operation::Between expects the right operand is an array
455             of 2 L instances. It checks whether the left operand
456             is between the right operands like:
457              
458             ( $left->value($eval) >= $right[0]->value($eval) )
459             && ( $left->value($eval) <= $right[1]->value($eval) )
460              
461             =head1 INHERITANCE
462              
463             SQL::Statement::Operation::Between
464             ISA SQL::Statement::Operation
465             ISA SQL::Statement::Term
466              
467             =head1 METHODS
468              
469             =head2 operate
470              
471             Returns true when the left term is between both right terms
472              
473             =cut
474              
475             sub operate($)
476             {
477 71     71   127 my ( $self, $eval ) = @_;
478 71         165 my $left = $self->{LEFT}->value($eval);
479 71         129 my @right = map { $_->value($eval); } @{ $self->{RIGHT} };
  142         321  
  71         134  
480 71         132 my $expr = 0;
481              
482 71 100 66     367 if ( looks_like_number($left)
      66        
483             && looks_like_number( $right[0] )
484             && looks_like_number( $right[1] ) )
485             {
486 44   100     147 $expr = ( $left >= $right[0] ) && ( $left <= $right[1] );
487             }
488             else
489             {
490 27   66     124 $expr = ( $left ge $right[0] ) && ( $left le $right[1] );
491             }
492              
493 71         312 return $expr;
494             }
495              
496             package SQL::Statement::Operation::Equality;
497              
498 16     16   123 use vars qw(@ISA);
  16         282  
  16         845  
499             @ISA = qw(SQL::Statement::Operation);
500              
501 16     16   106 use Carp ();
  16         30  
  16         421  
502 16     16   93 use Scalar::Util qw(looks_like_number);
  16         40  
  16         4438  
503              
504             =pod
505              
506             =head1 NAME
507              
508             SQL::Statement::Operation::Equality - abstract base class for comparisons
509              
510             =head1 SYNOPSIS
511              
512             # create an C operation with an SQL::Statement object as owner,
513             # specifying the operation name, the left and the right operand
514             my $term = SQL::Statement::Equality->new( $owner, $op, $left, $right );
515             # access the result of that operation
516             $term->value( $eval );
517              
518             =head1 DESCRIPTION
519              
520             SQL::Statement::Operation::Equality implements compare operations between
521             two terms - choosing either numerical comparison or string comparison,
522             depending whether both operands are numeric or not.
523              
524             =head1 INHERITANCE
525              
526             SQL::Statement::Operation::Equality
527             ISA SQL::Statement::Operation
528             ISA SQL::Statement::Term
529              
530             =head1 METHODS
531              
532             =head2 operate
533              
534             Return the result of the comparison.
535              
536             =head2 numcmp
537              
538             I method which will do the numeric comparison of both terms. Must be
539             overridden by derived classes.
540              
541             =head2 strcmp
542              
543             I method which will do the string comparison of both terms. Must be
544             overridden by derived classes.
545              
546             =cut
547              
548             sub operate($)
549             {
550 569     569   808 my $self = $_[0];
551 569         1325 my $left = $self->{LEFT}->value( $_[1] );
552 569         1535 my $right = $self->{RIGHT}->value( $_[1] );
553 569 100 66     1933 return 0 unless ( defined($left) && defined($right) );
554 567 100 66     2621 return ( looks_like_number($left) && looks_like_number($right) )
555             ? $self->numcmp( $left, $right )
556             : $self->strcmp( $left, $right );
557             }
558              
559             sub numcmp($)
560             {
561 0   0 0   0 Carp::confess( sprintf( q{pure virtual function 'numcmp' called on %s for %s}, ref( $_[0] ) || __PACKAGE__, $_[0]->{OP} ) );
562             }
563              
564             sub strcmp($)
565             {
566 0   0 0   0 Carp::confess( sprintf( q{pure virtual function 'strcmp' called on %s for %s}, ref( $_[0] ) || __PACKAGE__, $_[0]->{OP} ) );
567             }
568              
569             package SQL::Statement::Operation::Equal;
570              
571 16     16   138 use vars qw(@ISA);
  16         37  
  16         2230  
572             @ISA = qw(SQL::Statement::Operation::Equality);
573              
574             =pod
575              
576             =head1 NAME
577              
578             SQL::Statement::Operation::Equal - implements equal operation
579              
580             =head1 SYNOPSIS
581              
582             # create an C operation with an SQL::Statement object as owner,
583             # specifying the operation name, the left and the right operand
584             my $term = SQL::Statement::Equal->new( $owner, $op, $left, $right );
585             # access the result of that operation
586             $term->value( $eval );
587              
588             =head1 DESCRIPTION
589              
590             SQL::Statement::Operation::Equal implements compare operations between
591             two numbers and two strings.
592              
593             =head1 INHERITANCE
594              
595             SQL::Statement::Operation::Equal
596             ISA SQL::Statement::Operation::Equality
597             ISA SQL::Statement::Operation
598             ISA SQL::Statement::Term
599              
600             =head1 METHODS
601              
602             =head2 numcmp
603              
604             Return true when C<$left == $right>
605              
606             =head2 strcmp
607              
608             Return true when C<$left eq $right>
609              
610             =cut
611              
612 444     444   1321 sub numcmp($$) { return $_[1] == $_[2]; }
613 62     62   216 sub strcmp($$) { return $_[1] eq $_[2]; }
614              
615             package SQL::Statement::Operation::NotEqual;
616              
617 16     16   126 use vars qw(@ISA);
  16         39  
  16         1987  
618             @ISA = qw(SQL::Statement::Operation::Equality);
619              
620             =pod
621              
622             =head1 NAME
623              
624             SQL::Statement::Operation::NotEqual - implements not equal operation
625              
626             =head1 SYNOPSIS
627              
628             # create an C operation with an SQL::Statement object as owner,
629             # specifying the operation name, the left and the right operand
630             my $term = SQL::Statement::NotEqual->new( $owner, $op, $left, $right );
631             # access the result of that operation
632             $term->value( $eval );
633              
634             =head1 DESCRIPTION
635              
636             SQL::Statement::Operation::NotEqual implements negated compare operations
637             between two numbers and two strings.
638              
639             =head1 INHERITANCE
640              
641             SQL::Statement::Operation::NotEqual
642             ISA SQL::Statement::Operation::Equality
643             ISA SQL::Statement::Operation
644             ISA SQL::Statement::Term
645              
646             =head1 METHODS
647              
648             =head2 numcmp
649              
650             Return true when C<$left != $right>
651              
652             =head2 strcmp
653              
654             Return true when C<$left ne $right>
655              
656             =cut
657              
658 0     0   0 sub numcmp($$) { return $_[1] != $_[2]; }
659 0     0   0 sub strcmp($$) { return $_[1] ne $_[2]; }
660              
661             package SQL::Statement::Operation::Lower;
662              
663 16     16   122 use vars qw(@ISA);
  16         30  
  16         1926  
664             @ISA = qw(SQL::Statement::Operation::Equality);
665              
666             =pod
667              
668             =head1 NAME
669              
670             SQL::Statement::Operation::Lower - implements lower than operation
671              
672             =head1 SYNOPSIS
673              
674             # create an C operation with an SQL::Statement object as owner,
675             # specifying the operation name, the left and the right operand
676             my $term = SQL::Statement::Lower->new( $owner, $op, $left, $right );
677             # access the result of that operation
678             $term->value( $eval );
679              
680             =head1 DESCRIPTION
681              
682             SQL::Statement::Operation::Lower implements lower than compare operations
683             between two numbers and two strings.
684              
685             =head1 INHERITANCE
686              
687             SQL::Statement::Operation::Lower
688             ISA SQL::Statement::Operation::Equality
689             ISA SQL::Statement::Operation
690             ISA SQL::Statement::Term
691              
692             =head1 METHODS
693              
694             =head2 numcmp
695              
696             Return true when C<$left < $right>
697              
698             =head2 strcmp
699              
700             Return true when C<$left lt $right>
701              
702             =cut
703              
704 39     39   175 sub numcmp($$) { return $_[1] < $_[2]; }
705 0     0   0 sub strcmp($$) { return $_[1] lt $_[2]; }
706              
707             package SQL::Statement::Operation::Greater;
708              
709 16     16   128 use vars qw(@ISA);
  16         49  
  16         2227  
710             @ISA = qw(SQL::Statement::Operation::Equality);
711              
712             =pod
713              
714             =head1 NAME
715              
716             SQL::Statement::Operation::Greater - implements greater than operation
717              
718             =head1 SYNOPSIS
719              
720             # create an C operation with an SQL::Statement object as owner,
721             # specifying the operation name, the left and the right operand
722             my $term = SQL::Statement::Greater->new( $owner, $op, $left, $right );
723             # access the result of that operation
724             $term->value( $eval );
725              
726             =head1 DESCRIPTION
727              
728             SQL::Statement::Operation::Greater implements greater than compare operations
729             between two numbers and two strings.
730              
731             =head1 INHERITANCE
732              
733             SQL::Statement::Operation::Greater
734             ISA SQL::Statement::Operation::Equality
735             ISA SQL::Statement::Operation
736             ISA SQL::Statement::Term
737              
738             =head1 METHODS
739              
740             =head2 numcmp
741              
742             Return true when C<$left > $right>
743              
744             =head2 strcmp
745              
746             Return true when C<$left gt $right>
747              
748             =cut
749              
750 22     22   84 sub numcmp($$) { return $_[1] > $_[2]; }
751 0     0   0 sub strcmp($$) { return $_[1] gt $_[2]; }
752              
753             package SQL::Statement::Operation::LowerEqual;
754              
755 16     16   123 use vars qw(@ISA);
  16         30  
  16         2017  
756             @ISA = qw(SQL::Statement::Operation::Equality);
757              
758             =pod
759              
760             =head1 NAME
761              
762             SQL::Statement::Operation::LowerEqual - implements lower equal operation
763              
764             =head1 SYNOPSIS
765              
766             # create an C operation with an SQL::Statement object as owner,
767             # specifying the operation name, the left and the right operand
768             my $term = SQL::Statement::LowerEqual->new( $owner, $op, $left, $right );
769             # access the result of that operation
770             $term->value( $eval );
771              
772             =head1 DESCRIPTION
773              
774             SQL::Statement::Operation::LowerEqual implements lower equal compare operations
775             between two numbers and two strings.
776              
777             =head1 INHERITANCE
778              
779             SQL::Statement::Operation::LowerEqual
780             ISA SQL::Statement::Operation::Equality
781             ISA SQL::Statement::Operation
782             ISA SQL::Statement::Term
783              
784             =head1 METHODS
785              
786             =head2 numcmp
787              
788             Return true when C<$left <= $right>
789              
790             =head2 strcmp
791              
792             Return true when C<$left le $right>
793              
794             =cut
795              
796 0     0   0 sub numcmp($$) { return $_[1] <= $_[2]; }
797 0     0   0 sub strcmp($$) { return $_[1] le $_[2]; }
798              
799             package SQL::Statement::Operation::GreaterEqual;
800              
801 16     16   134 use vars qw(@ISA);
  16         38  
  16         1885  
802             @ISA = qw(SQL::Statement::Operation::Equality);
803              
804             =pod
805              
806             =head1 NAME
807              
808             SQL::Statement::Operation::GreaterEqual - implements greater equal operation
809              
810             =head1 SYNOPSIS
811              
812             # create an C operation with an SQL::Statement object as owner,
813             # specifying the operation name, the left and the right operand
814             my $term = SQL::Statement::GreaterEqual->new( $owner, $op, $left, $right );
815             # access the result of that operation
816             $term->value( $eval );
817              
818             =head1 DESCRIPTION
819              
820             SQL::Statement::Operation::GreaterEqual implements greater equal compare operations
821             between two numbers and two strings.
822              
823             =head1 INHERITANCE
824              
825             SQL::Statement::Operation::GreaterEqual
826             ISA SQL::Statement::Operation::Equality
827             ISA SQL::Statement::Operation
828             ISA SQL::Statement::Term
829              
830             =head1 METHODS
831              
832             =head2 numcmp
833              
834             Return true when C<$left >= $right>
835              
836             =head2 strcmp
837              
838             Return true when C<$left ge $right>
839              
840             =cut
841              
842 0     0   0 sub numcmp($$) { return $_[1] >= $_[2]; }
843 0     0   0 sub strcmp($$) { return $_[1] ge $_[2]; }
844              
845             package SQL::Statement::Operation::Regexp;
846              
847 16     16   111 use vars qw(@ISA);
  16         34  
  16         5417  
848             @ISA = qw(SQL::Statement::Operation);
849              
850             =pod
851              
852             =head1 NAME
853              
854             SQL::Statement::Operation::Regexp - abstract base class for comparisons based on regular expressions
855              
856             =head1 SYNOPSIS
857              
858             # create an C operation with an SQL::Statement object as owner,
859             # specifying the operation name, the left and the right operand
860             my $term = SQL::Statement::Regexp->new( $owner, $op, $left, $right );
861             # access the result of that operation
862             $term->value( $eval );
863              
864             =head1 DESCRIPTION
865              
866             SQL::Statement::Operation::Regexp implements the comparisons for the C
867             operation family.
868              
869             =head1 INHERITANCE
870              
871             SQL::Statement::Operation::Regexp
872             ISA SQL::Statement::Operation
873             ISA SQL::Statement::Term
874              
875             =head1 METHODS
876              
877             =head2 operate
878              
879             Return the result of the comparison.
880              
881             =head2 right
882              
883             Returns the regular expression based on the right term. The right term
884             is expected to be constant - so C in not supported.
885              
886             =head2 regexp
887              
888             I method which must return a regular expression (C) from
889             the given string. Must be overridden by derived classes.
890              
891             =cut
892              
893             sub right($)
894             {
895 81     81   114 my $self = $_[0];
896 81         194 my $right = $self->{RIGHT}->value( $_[1] );
897              
898 81 100       191 unless ( defined( $self->{PATTERNS}->{$right} ) )
899             {
900 5         19 $self->{PATTERNS}->{$right} = $right;
901 5         27 $self->{PATTERNS}->{$right} =~ s/%/.*/g;
902 5         24 $self->{PATTERNS}->{$right} = $self->regexp( $self->{PATTERNS}->{$right} );
903             }
904              
905 81         154 return $self->{PATTERNS}->{$right};
906             }
907              
908             sub regexp($)
909             {
910 0   0 0   0 Carp::confess( sprintf( q{pure virtual function 'regexp' called on %s for %s}, ref( $_[0] ) || __PACKAGE__, $_[0]->{OP} ) );
911             }
912              
913             sub operate($)
914             {
915 81     81   132 my $self = $_[0];
916 81         188 my $left = $self->{LEFT}->value( $_[1] );
917 81         193 my $right = $self->right( $_[1] );
918              
919 81 50 33     291 return 0 unless ( defined($left) && defined($right) );
920 81         466 return $left =~ m/^$right$/s;
921             }
922              
923             package SQL::Statement::Operation::Like;
924              
925 16     16   121 use vars qw(@ISA);
  16         40  
  16         1680  
926             @ISA = qw(SQL::Statement::Operation::Regexp);
927              
928             =pod
929              
930             =head1 NAME
931              
932             SQL::Statement::Operation::Like - implements the like operation
933              
934             =head1 SYNOPSIS
935              
936             # create an C operation with an SQL::Statement object as owner,
937             # specifying the operation name, the left and the right operand
938             my $term = SQL::Statement::Like->new( $owner, $op, $left, $right );
939             # access the result of that operation
940             $term->value( $eval );
941              
942             =head1 DESCRIPTION
943              
944             SQL::Statement::Operation::Like is used to the comparisons for the C
945             operation.
946              
947             =head1 INHERITANCE
948              
949             SQL::Statement::Operation::Like
950             ISA SQL::Statement::Operation::Regexp
951             ISA SQL::Statement::Operation
952             ISA SQL::Statement::Term
953              
954             =head1 METHODS
955              
956             =head2 regexp
957              
958             Returns C
959              
960             =cut
961              
962             sub regexp($)
963             {
964 5     5   12 my $right = $_[1];
965 5         69 return qr/^$right$/s;
966             }
967              
968             package SQL::Statement::Operation::Clike;
969              
970 16     16   124 use vars qw(@ISA);
  16         39  
  16         1636  
971             @ISA = qw(SQL::Statement::Operation::Regexp);
972              
973             =pod
974              
975             =head1 NAME
976              
977             SQL::Statement::Operation::Clike - implements the clike operation
978              
979             =head1 SYNOPSIS
980              
981             # create an C operation with an SQL::Statement object as owner,
982             # specifying the operation name, the left and the right operand
983             my $term = SQL::Statement::Clike->new( $owner, $op, $left, $right );
984             # access the result of that operation
985             $term->value( $eval );
986              
987             =head1 DESCRIPTION
988              
989             SQL::Statement::Operation::Clike is used to the comparisons for the C
990             operation.
991              
992             =head1 INHERITANCE
993              
994             SQL::Statement::Operation::Clike
995             ISA SQL::Statement::Operation::Regexp
996             ISA SQL::Statement::Operation
997             ISA SQL::Statement::Term
998              
999             =head1 METHODS
1000              
1001             =head2 regexp
1002              
1003             Returns C
1004              
1005             =cut
1006              
1007             sub regexp($)
1008             {
1009 0     0     my $right = $_[1];
1010 0           return qr/^$right$/si;
1011             }
1012              
1013             package SQL::Statement::Operation::Rlike;
1014              
1015 16     16   116 use vars qw(@ISA);
  16         35  
  16         1759  
1016             @ISA = qw(SQL::Statement::Operation::Regexp);
1017              
1018             =pod
1019              
1020             =head1 NAME
1021              
1022             SQL::Statement::Operation::RLike - implements the rlike operation
1023              
1024             =head1 SYNOPSIS
1025              
1026             # create an C operation with an SQL::Statement object as owner,
1027             # specifying the operation name, the left and the right operand
1028             my $term = SQL::Statement::RLike->new( $owner, $op, $left, $right );
1029             # access the result of that operation
1030             $term->value( $eval );
1031              
1032             =head1 DESCRIPTION
1033              
1034             SQL::Statement::Operation::RLike is used to the comparisons for the C
1035             operation.
1036              
1037             =head1 INHERITANCE
1038              
1039             SQL::Statement::Operation::RLike
1040             ISA SQL::Statement::Operation::Regexp
1041             ISA SQL::Statement::Operation
1042             ISA SQL::Statement::Term
1043              
1044             =head1 METHODS
1045              
1046             =head2 regexp
1047              
1048             Returns C
1049              
1050             =cut
1051              
1052             sub regexp($)
1053             {
1054 0     0     my $right = $_[1];
1055 0           return qr/$right$/;
1056             }
1057              
1058             =head1 AUTHOR AND COPYRIGHT
1059              
1060             Copyright (c) 2009-2020 by Jens Rehsack: rehsackATcpan.org
1061              
1062             All rights reserved.
1063              
1064             You may distribute this module under the terms of either the GNU
1065             General Public License or the Artistic License, as specified in
1066             the Perl README file.
1067              
1068             =cut
1069              
1070             1;