File Coverage

blib/lib/Venus/Role/Comparable.pm
Criterion Covered Total %
statement 73 85 85.8
branch 56 74 75.6
condition 15 21 71.4
subroutine 16 16 100.0
pod 11 12 91.6
total 171 208 82.2


line stmt bran cond sub pod time code
1             package Venus::Role::Comparable;
2              
3 87     87   1634 use 5.018;
  87         311  
4              
5 87     87   484 use strict;
  87         177  
  87         1785  
6 87     87   398 use warnings;
  87         158  
  87         2242  
7              
8 87     87   433 use Venus::Role 'with';
  87         171  
  87         568  
9              
10             require Scalar::Util;
11             require Venus::Type;
12              
13             # METHODS
14              
15             sub eq {
16 440     440 1 1461 my ($self, $data) = @_;
17              
18 440         2250 $data = Venus::Type->new(value => $data)->deduce;
19              
20 440 100       1661 if (Scalar::Util::refaddr($self) eq Scalar::Util::refaddr($data)) {
21 2         9 return true;
22             }
23 438 50 33     3457 if (Scalar::Util::blessed($data) && !$data->isa('Venus::Kind')) {
24 0         0 return false;
25             }
26 438 100       1780 if ($self->comparer('eq') eq 'numified') {
    100          
    50          
27 186 100       566 return $self->numified == $data->numified ? true : false;
28             }
29             elsif ($self->comparer('eq') eq 'stringified') {
30 80 100       324 return $self->stringified eq $data->stringified ? true : false;
31             }
32             elsif (my $method = $self->comparer('eq')) {
33 172 100       670 return $self->$method eq $data->$method ? true : false;
34             }
35             else {
36 0         0 return false;
37             }
38             }
39              
40             sub ge {
41 187     187 1 441 my ($self, $data) = @_;
42              
43 187 100 100     611 if ($self->gt($data) || $self->eq($data)) {
44 102         284 return true;
45             }
46             else {
47 85         259 return false;
48             }
49             }
50              
51             sub gele {
52 94     94 1 272 my ($self, $ge, $le) = @_;
53              
54 94 100 100     280 if ($self->ge($ge) && $self->le($le)) {
55 21         66 return true;
56             }
57             else {
58 73         207 return false;
59             }
60             }
61              
62             sub gt {
63 388     388 1 862 my ($self, $data) = @_;
64              
65 388         2068 $data = Venus::Type->new(value => $data)->deduce;
66              
67 388 100       1388 if (Scalar::Util::refaddr($self) eq Scalar::Util::refaddr($data)) {
68 1         5 return false;
69             }
70 387 50 33     3170 if (Scalar::Util::blessed($data) && !$data->isa('Venus::Kind')) {
71 0         0 return false;
72             }
73 387 100       1627 if ($self->comparer('gt') eq 'numified') {
    50          
    0          
74 315 100       1261 return $self->numified > $data->numified ? true : false;
75             }
76             elsif ($self->comparer('gt') eq 'stringified') {
77 72 100       264 return $self->stringified gt $data->stringified ? true : false;
78             }
79             elsif (my $method = $self->comparer('gt')) {
80 0 0       0 return $self->$method gt $data->$method ? true : false;
81             }
82             else {
83 0         0 return false;
84             }
85             }
86              
87             sub gtlt {
88 94     94 1 269 my ($self, $gt, $lt) = @_;
89              
90 94 100 100     294 if ($self->gt($gt) && $self->lt($lt)) {
91 2         7 return true;
92             }
93             else {
94 92         269 return false;
95             }
96             }
97              
98             sub is {
99 3     3 1 8 my ($self, $data) = @_;
100              
101 3 50       12 if (!ref $data) {
102 0         0 return false;
103             }
104 3 100       19 if (Scalar::Util::refaddr($self) eq Scalar::Util::refaddr($data)) {
105 1         4 return true;
106             }
107             else {
108 2         9 return false;
109             }
110             }
111              
112             sub lt {
113 268     268 1 709 my ($self, $data) = @_;
114              
115 268         1414 $data = Venus::Type->new(value => $data)->deduce;
116              
117 268 50       1008 if (Scalar::Util::refaddr($self) eq Scalar::Util::refaddr($data)) {
118 0         0 return false;
119             }
120 268 50 33     2316 if (Scalar::Util::blessed($data) && !$data->isa('Venus::Kind')) {
121 0         0 return false;
122             }
123 268 100       1300 if ($self->comparer('lt') eq 'numified') {
    50          
    0          
124 217 100       912 return $self->numified < $data->numified ? true : false;
125             }
126             elsif ($self->comparer('lt') eq 'stringified') {
127 51 100       196 return $self->stringified lt $data->stringified ? true : false;
128             }
129             elsif (my $method = $self->comparer('lt')) {
130 0 0       0 return $self->$method lt $data->$method ? true : false;
131             }
132             else {
133 0         0 return false;
134             }
135             }
136              
137             sub le {
138 146     146 1 457 my ($self, $data) = @_;
139              
140 146 100 100     538 if ($self->lt($data) || $self->eq($data)) {
141 82         261 return true;
142             }
143             else {
144 64         215 return false;
145             }
146             }
147              
148             sub ne {
149 94     94 1 274 my ($self, $data) = @_;
150              
151 94 100       351 return $self->eq($data) ? false : true;
152             }
153              
154             sub st {
155 4     4 1 11 my ($self, $data) = @_;
156              
157 4 50       16 if (!Scalar::Util::blessed($data)) {
158 0         0 return false;
159             }
160 4 100       21 if (Scalar::Util::refaddr($self) eq Scalar::Util::refaddr($data)) {
161 1         3 return true;
162             }
163 3 100       18 if ($data->isa($self->class)) {
164 1         5 return true;
165             }
166             else {
167 2         7 return false;
168             }
169             }
170              
171             sub tv {
172 95     95 1 253 my ($self, $data) = @_;
173              
174 95 50       576 if (!Scalar::Util::blessed($data)) {
175 0         0 return false;
176             }
177 95 100       512 if (Scalar::Util::refaddr($self) eq Scalar::Util::refaddr($data)) {
178 1         3 return true;
179             }
180 94 100       426 if ($data->isa($self->class)) {
181 12         72 return $self->eq($data);
182             }
183             else {
184 82         350 return false;
185             }
186             }
187              
188             # EXPORTS
189              
190             sub EXPORT {
191 88     88 0 397 ['eq', 'ge', 'gele', 'gt', 'gtlt', 'is', 'lt', 'le', 'ne', 'st', 'tv']
192             }
193              
194             1;
195              
196              
197              
198             =head1 NAME
199              
200             Venus::Role::Comparable - Comparable Role
201              
202             =cut
203              
204             =head1 ABSTRACT
205              
206             Comparable Role for Perl 5
207              
208             =cut
209              
210             =head1 SYNOPSIS
211              
212             package Example;
213              
214             use Venus::Class;
215              
216             base 'Venus::Kind';
217              
218             with 'Venus::Role::Comparable';
219              
220             sub numified {
221             return 2;
222             }
223              
224             package main;
225              
226             my $example = Example->new;
227              
228             # my $result = $example->eq(2);
229              
230             =cut
231              
232             =head1 DESCRIPTION
233              
234             This package modifies the consuming package and provides methods for performing
235             numerical and stringwise comparision operations or any object or raw data type.
236              
237             =cut
238              
239             =head1 METHODS
240              
241             This package provides the following methods:
242              
243             =cut
244              
245             =head2 eq
246              
247             eq(Any $arg) (Bool)
248              
249             The eq method performs an I<"equals"> operation using the invocant and the
250             argument provided. The operation will be performed as either a numerical or
251             stringwise operation based upon the preference (i.e. the return value of the
252             L method) of the invocant.
253              
254             I>
255              
256             =over 4
257              
258             =item eq example 1
259              
260             package main;
261              
262             my $example = Example->new;
263              
264             my $result = $example->eq($example);
265              
266             # 1
267              
268             =back
269              
270             =over 4
271              
272             =item eq example 2
273              
274             package main;
275              
276             my $example = Example->new;
277              
278             my $result = $example->eq([1,2]);
279              
280             # 0
281              
282             =back
283              
284             =over 4
285              
286             =item eq example 3
287              
288             package main;
289              
290             my $example = Example->new;
291              
292             my $result = $example->eq({1..4});
293              
294             # 0
295              
296             =back
297              
298             =cut
299              
300             =head2 ge
301              
302             ge(Any $arg) (Bool)
303              
304             The ge method performs a I<"greater-than-or-equal-to"> operation using the
305             invocant and argument provided. The operation will be performed as either a
306             numerical or stringwise operation based upon the preference (i.e. the return
307             value of the L method) of the invocant.
308              
309             I>
310              
311             =over 4
312              
313             =item ge example 1
314              
315             package main;
316              
317             my $example = Example->new;
318              
319             my $result = $example->ge(3);
320              
321             # 0
322              
323             =back
324              
325             =over 4
326              
327             =item ge example 2
328              
329             package main;
330              
331             my $example = Example->new;
332              
333             my $result = $example->ge($example);
334              
335             # 1
336              
337             =back
338              
339             =over 4
340              
341             =item ge example 3
342              
343             package main;
344              
345             my $example = Example->new;
346              
347             my $result = $example->ge([1,2,3]);
348              
349             # 0
350              
351             =back
352              
353             =cut
354              
355             =head2 gele
356              
357             gele(Any $arg1, Any $arg2) (Bool)
358              
359             The gele method performs a I<"greater-than-or-equal-to"> operation on the 1st
360             argument, and I<"lesser-than-or-equal-to"> operation on the 2nd argument. The
361             operation will be performed as either a numerical or stringwise operation based
362             upon the preference (i.e. the return value of the L method) of the
363             invocant.
364              
365             I>
366              
367             =over 4
368              
369             =item gele example 1
370              
371             package main;
372              
373             my $example = Example->new;
374              
375             my $result = $example->gele(1, 3);
376              
377             # 1
378              
379             =back
380              
381             =over 4
382              
383             =item gele example 2
384              
385             package main;
386              
387             my $example = Example->new;
388              
389             my $result = $example->gele(2, []);
390              
391             # 0
392              
393             =back
394              
395             =over 4
396              
397             =item gele example 3
398              
399             package main;
400              
401             my $example = Example->new;
402              
403             my $result = $example->gele(0, '3');
404              
405             # 1
406              
407             =back
408              
409             =cut
410              
411             =head2 gt
412              
413             gt(Any $arg) (Bool)
414              
415             The gt method performs a I<"greater-than"> operation using the invocant and
416             argument provided. The operation will be performed as either a numerical or
417             stringwise operation based upon the preference (i.e. the return value of the
418             L method) of the invocant.
419              
420             I>
421              
422             =over 4
423              
424             =item gt example 1
425              
426             package main;
427              
428             my $example = Example->new;
429              
430             my $result = $example->gt({1..2});
431              
432             # 0
433              
434             =back
435              
436             =over 4
437              
438             =item gt example 2
439              
440             package main;
441              
442             my $example = Example->new;
443              
444             my $result = $example->gt(1.9998);
445              
446             # 1
447              
448             =back
449              
450             =over 4
451              
452             =item gt example 3
453              
454             package main;
455              
456             my $example = Example->new;
457              
458             my $result = $example->gt(\1_000_000);
459              
460             # 0
461              
462             =back
463              
464             =cut
465              
466             =head2 gtlt
467              
468             gtlt(Any $arg1, Any $arg2) (Bool)
469              
470             The gtlt method performs a I<"greater-than"> operation on the 1st argument, and
471             I<"lesser-than"> operation on the 2nd argument. The operation will be performed
472             as either a numerical or stringwise operation based upon the preference (i.e.
473             the return value of the L method) of the invocant.
474              
475             I>
476              
477             =over 4
478              
479             =item gtlt example 1
480              
481             package main;
482              
483             my $example = Example->new;
484              
485             my $result = $example->gtlt('1', 3);
486              
487             # 1
488              
489             =back
490              
491             =over 4
492              
493             =item gtlt example 2
494              
495             package main;
496              
497             my $example = Example->new;
498              
499             my $result = $example->gtlt({1..2}, {1..4});
500              
501             # 0
502              
503             =back
504              
505             =over 4
506              
507             =item gtlt example 3
508              
509             package main;
510              
511             my $example = Example->new;
512              
513             my $result = $example->gtlt('.', ['.']);
514              
515             # 1
516              
517             =back
518              
519             =cut
520              
521             =head2 is
522              
523             is(Any $arg) (Bool)
524              
525             The is method performs an I<"is-exactly"> operation using the invocant and the
526             argument provided. If the argument provided is blessed and exactly the same as
527             the invocant (i.e. shares the same address space) the operation will return
528             truthy.
529              
530             I>
531              
532             =over 4
533              
534             =item is example 1
535              
536             package main;
537              
538             my $example = Example->new;
539              
540             my $result = $example->is($example);
541              
542             # 1
543              
544             =back
545              
546             =over 4
547              
548             =item is example 2
549              
550             package main;
551              
552             my $example = Example->new;
553              
554             my $result = $example->is([1,2]);
555              
556             # 0
557              
558             =back
559              
560             =over 4
561              
562             =item is example 3
563              
564             package main;
565              
566             my $example = Example->new;
567              
568             my $result = $example->is(Example->new);
569              
570             # 0
571              
572             =back
573              
574             =cut
575              
576             =head2 le
577              
578             le(Any $arg) (Bool)
579              
580             The le method performs a I<"lesser-than-or-equal-to"> operation using the
581             invocant and argument provided. The operation will be performed as either a
582             numerical or stringwise operation based upon the preference (i.e. the return
583             value of the L method) of the invocant.
584              
585             I>
586              
587             =over 4
588              
589             =item le example 1
590              
591             package main;
592              
593             my $example = Example->new;
594              
595             my $result = $example->le('9');
596              
597             # 1
598              
599             =back
600              
601             =over 4
602              
603             =item le example 2
604              
605             package main;
606              
607             my $example = Example->new;
608              
609             my $result = $example->le([1..2]);
610              
611             # 1
612              
613             =back
614              
615             =over 4
616              
617             =item le example 3
618              
619             package main;
620              
621             my $example = Example->new;
622              
623             my $result = $example->le(\1);
624              
625             # 0
626              
627             =back
628              
629             =cut
630              
631             =head2 lt
632              
633             lt(Any $arg) (Bool)
634              
635             The lt method performs a I<"lesser-than"> operation using the invocant and
636             argument provided. The operation will be performed as either a numerical or
637             stringwise operation based upon the preference (i.e. the return value of the
638             L method) of the invocant.
639              
640             I>
641              
642             =over 4
643              
644             =item lt example 1
645              
646             package main;
647              
648             my $example = Example->new;
649              
650             my $result = $example->lt(qr/.*/);
651              
652             # 1
653              
654             =back
655              
656             =over 4
657              
658             =item lt example 2
659              
660             package main;
661              
662             my $example = Example->new;
663              
664             my $result = $example->lt('.*');
665              
666             # 0
667              
668             =back
669              
670             =over 4
671              
672             =item lt example 3
673              
674             package main;
675              
676             my $example = Example->new;
677              
678             my $result = $example->lt('5');
679              
680             # 1
681              
682             =back
683              
684             =cut
685              
686             =head2 ne
687              
688             ne(Any $arg) (Bool)
689              
690             The ne method performs a I<"not-equal-to"> operation using the invocant and
691             argument provided. The operation will be performed as either a numerical or
692             stringwise operation based upon the preference (i.e. the return value of the
693             L method) of the invocant.
694              
695             I>
696              
697             =over 4
698              
699             =item ne example 1
700              
701             package main;
702              
703             my $example = Example->new;
704              
705             my $result = $example->ne([1,2]);
706              
707             # 1
708              
709             =back
710              
711             =over 4
712              
713             =item ne example 2
714              
715             package main;
716              
717             my $example = Example->new;
718              
719             my $result = $example->ne([2]);
720              
721             # 1
722              
723             =back
724              
725             =over 4
726              
727             =item ne example 3
728              
729             package main;
730              
731             my $example = Example->new;
732              
733             my $result = $example->ne(qr/2/);
734              
735             # 1
736              
737             =back
738              
739             =cut
740              
741             =head2 st
742              
743             st(Object $arg) (Bool)
744              
745             The st method performs a I<"same-type"> operation using the invocant and
746             argument provided. If the argument provided is an instance of the invocant, or
747             a subclass, the operation will return truthy.
748              
749             I>
750              
751             =over 4
752              
753             =item st example 1
754              
755             package main;
756              
757             my $example = Example->new;
758              
759             my $result = $example->st($example);
760              
761             # 1
762              
763             =back
764              
765             =over 4
766              
767             =item st example 2
768              
769             package main;
770              
771             use Venus::Number;
772              
773             my $example = Example->new;
774              
775             my $result = $example->st(Venus::Number->new(2));
776              
777             # 0
778              
779             =back
780              
781             =over 4
782              
783             =item st example 3
784              
785             package main;
786              
787             use Venus::String;
788              
789             my $example = Example->new;
790              
791             my $result = $example->st(Venus::String->new('2'));
792              
793             # 0
794              
795             =back
796              
797             =over 4
798              
799             =item st example 4
800              
801             package Example2;
802              
803             use base 'Example';
804              
805             package main;
806              
807             use Venus::String;
808              
809             my $example = Example2->new;
810              
811             my $result = $example->st(Example2->new);
812              
813             # 1
814              
815             =back
816              
817             =cut
818              
819             =head2 tv
820              
821             tv(Any $arg) (Bool)
822              
823             The tv method performs a I<"type-and-value-equal-to"> operation using the
824             invocant and argument provided. The operation will be performed as either a
825             numerical or stringwise operation based upon the preference (i.e. the return
826             value of the L method) of the invocant.
827              
828             I>
829              
830             =over 4
831              
832             =item tv example 1
833              
834             package main;
835              
836             my $example = Example->new;
837              
838             my $result = $example->tv($example);
839              
840             # 1
841              
842             =back
843              
844             =over 4
845              
846             =item tv example 2
847              
848             package main;
849              
850             use Venus::Number;
851              
852             my $example = Example->new;
853              
854             my $result = $example->tv(Venus::Number->new(2));
855              
856             # 0
857              
858             =back
859              
860             =over 4
861              
862             =item tv example 3
863              
864             package main;
865              
866             use Venus::String;
867              
868             my $example = Example->new;
869              
870             my $result = $example->tv(Venus::String->new('2'));
871              
872             # 0
873              
874             =back
875              
876             =over 4
877              
878             =item tv example 4
879              
880             package main;
881              
882             use Venus::String;
883              
884             my $example = Example->new;
885              
886             my $result = $example->tv(Example->new);
887              
888             # 1
889              
890             =back
891              
892             =cut
893              
894             =head1 AUTHORS
895              
896             Awncorp, C
897              
898             =cut
899              
900             =head1 LICENSE
901              
902             Copyright (C) 2000, Al Newkirk.
903              
904             This program is free software, you can redistribute it and/or modify it under
905             the terms of the Apache license version 2.0.
906              
907             =cut