File Coverage

blib/lib/Venus/Search.pm
Criterion Covered Total %
statement 101 101 100.0
branch 6 10 60.0
condition 23 48 47.9
subroutine 24 24 100.0
pod 14 15 93.3
total 168 198 84.8


line stmt bran cond sub pod time code
1             package Venus::Search;
2              
3 3     3   74 use 5.018;
  3         12  
4              
5 3     3   16 use strict;
  3         6  
  3         67  
6 3     3   15 use warnings;
  3         10  
  3         101  
7              
8 3     3   15 use Venus::Class 'attr', 'base', 'with';
  3         8  
  3         23  
9              
10             base 'Venus::Kind::Utility';
11              
12             with 'Venus::Role::Explainable';
13             with 'Venus::Role::Stashable';
14              
15             use overload (
16             '""' => 'explain',
17 1     1   4 'eq' => sub{"$_[0]" eq "$_[1]"},
18 1     1   4 'ne' => sub{"$_[0]" ne "$_[1]"},
19 1     1   2 'qr' => sub{qr{@{[quotemeta("$_[0]")]}}},
  1         4  
20 3         41 '~~' => 'explain',
21             fallback => 1,
22 3     3   21 );
  3         8  
23              
24             # ATTRIBUTES
25              
26             attr 'flags';
27             attr 'regexp';
28             attr 'string';
29              
30             # BUILDERS
31              
32             sub build_self {
33 25     25 0 54 my ($self, $data) = @_;
34              
35 25 50       80 $self->flags('') if !$self->flags;
36 25 50       85 $self->regexp(qr//) if !$self->regexp;
37 25 50       86 $self->string('') if !$self->string;
38              
39 25         54 return $self;
40             }
41              
42             # METHODS
43              
44             sub captures {
45 1     1 1 4 my ($self) = @_;
46              
47 1   33     5 my $evaluation = $self->stash('evaluation') || $self->evaluate;
48              
49 1         5 my $string = $self->initial;
50 1         5 my $last_match_start = $self->last_match_start;
51 1         4 my $last_match_end = $self->last_match_end;
52              
53 1         3 my $captures = [];
54              
55 1         6 for (my $i = 1; $i < @$last_match_end; $i++) {
56 1   50     7 my $start = $last_match_start->[$i] || 0;
57 1   50     6 my $end = $last_match_end->[$i] || 0;
58              
59 1         5 push @$captures, substr $string, $start, $end - $start;
60             }
61              
62 1 50       8 return wantarray ? (@$captures) : $captures;
63             }
64              
65             sub evaluate {
66 24     24 1 61 my ($self) = @_;
67              
68 24         53 my $captures = 0;
69 24         63 my $flags = $self->flags;
70 24         51 my @matches = ();
71 24         69 my $regexp = $self->regexp;
72 24         63 my $string = $self->string;
73 24         56 my $initial = "$string";
74              
75 24         46 local $@;
76 24   50 2   2099 eval join ';', (
  2         1011  
  2         1012  
  2         45  
77             '$captures = (' . '$string =~ m/$regexp/' . ($flags // '') . ')',
78             '@matches = ([@-], [@+], {%-})',
79             );
80              
81 24         110 my $error = $@;
82              
83 24 100       75 if ($error) {
84 1         22 $self->error({throw => 'error_on_evaluate', error => $error});
85             }
86              
87 23         109 return $self->stash(evaluation => [
88             $regexp,
89             $string,
90             $captures,
91             @matches,
92             $initial,
93             ]);
94             }
95              
96             sub explain {
97 14     14 1 431 my ($self) = @_;
98              
99 14         36 return $self->get;
100             }
101              
102             sub get {
103 15     15 1 32 my ($self) = @_;
104              
105 15   66     99 my $evaluation = $self->stash('evaluation') || $self->evaluate;
106              
107 15         96 return $evaluation->[1];
108             }
109              
110             sub count {
111 1     1 1 4 my ($self) = @_;
112              
113 1   33     5 my $evaluation = $self->stash('evaluation') || $self->evaluate;
114              
115 1         6 return $evaluation->[2];
116             }
117              
118             sub initial {
119 5     5 1 17 my ($self) = @_;
120              
121 5   66     15 my $evaluation = $self->stash('evaluation') || $self->evaluate;
122              
123 5         20 return $evaluation->[6];
124             }
125              
126             sub last_match_end {
127 5     5 1 13 my ($self) = @_;
128              
129 5   66     15 my $evaluation = $self->stash('evaluation') || $self->evaluate;
130              
131 5         15 return $evaluation->[4];
132             }
133              
134             sub last_match_start {
135 5     5 1 13 my ($self) = @_;
136              
137 5   66     16 my $evaluation = $self->stash('evaluation') || $self->evaluate;
138              
139 5         17 return $evaluation->[3];
140             }
141              
142             sub matched {
143 1     1 1 4 my ($self) = @_;
144              
145 1   33     4 my $evaluation = $self->stash('evaluation') || $self->evaluate;
146              
147 1         5 my $string = $self->initial;
148 1         3 my $last_match_start = $self->last_match_start;
149 1         5 my $last_match_end = $self->last_match_end;
150              
151 1   50     6 my $start = $last_match_start->[0] || 0;
152 1   50     5 my $end = $last_match_end->[0] || 0;
153              
154 1         7 return substr $string, $start, $end - $start;
155             }
156              
157             sub named_captures {
158 2     2 1 5 my ($self) = @_;
159              
160 2   33     7 my $evaluation = $self->stash('evaluation') || $self->evaluate;
161              
162 2         9 return $evaluation->[5];
163             }
164              
165             sub prematched {
166 1     1 1 4 my ($self) = @_;
167              
168 1   33     5 my $evaluation = $self->stash('evaluation') || $self->evaluate;
169              
170 1         4 my $string = $self->initial;
171 1         5 my $last_match_start = $self->last_match_start;
172 1         5 my $last_match_end = $self->last_match_end;
173              
174 1   50     6 my $start = $last_match_start->[0] || 0;
175 1   50     5 my $end = $last_match_end->[0] || 0;
176              
177 1         6 return substr $string, 0, $start;
178             }
179              
180             sub postmatched {
181 1     1 1 5 my ($self) = @_;
182              
183 1   33     4 my $evaluation = $self->stash('evaluation') || $self->evaluate;
184              
185 1         4 my $string = $self->initial;
186 1         4 my $last_match_start = $self->last_match_start;
187 1         4 my $last_match_end = $self->last_match_end;
188              
189 1   50     6 my $start = $last_match_start->[0] || 0;
190 1   50     5 my $end = $last_match_end->[0] || 0;
191              
192 1         7 return substr $string, $end;
193             }
194              
195             sub set {
196 1     1 1 4 my ($self, $string) = @_;
197              
198 1         4 $self->string($string);
199              
200 1         3 my $evaluation = $self->evaluate;
201              
202 1         6 return $evaluation->[1];
203             }
204              
205             # ERRORS
206              
207             sub error_on_evaluate {
208 2     2 1 9 my ($self, $data) = @_;
209              
210             my $result = {
211             name => 'on.evaluate',
212             raise => true,
213             message => $data->{error},
214 2         11 };
215              
216 2         6 return $result;
217             }
218              
219             1;
220              
221              
222              
223             =head1 NAME
224              
225             Venus::Search - Search Class
226              
227             =cut
228              
229             =head1 ABSTRACT
230              
231             Search Class for Perl 5
232              
233             =cut
234              
235             =head1 SYNOPSIS
236              
237             package main;
238              
239             use Venus::Search;
240              
241             my $search = Venus::Search->new(
242             string => 'hello world',
243             regexp => '(hello)',
244             );
245              
246             # $search->captures;
247              
248             =cut
249              
250             =head1 DESCRIPTION
251              
252             This package provides methods for manipulating regexp search data.
253              
254             =cut
255              
256             =head1 ATTRIBUTES
257              
258             This package has the following attributes:
259              
260             =cut
261              
262             =head2 flags
263              
264             flags(Str)
265              
266             This attribute is read-write, accepts C<(Str)> values, is optional, and defaults to C<''>.
267              
268             =cut
269              
270             =head2 regexp
271              
272             regexp(Regexp)
273              
274             This attribute is read-write, accepts C<(Regexp)> values, is optional, and defaults to C.
275              
276             =cut
277              
278             =head2 string
279              
280             string(Str)
281              
282             This attribute is read-write, accepts C<(Str)> values, is optional, and defaults to C<''>.
283              
284             =cut
285              
286             =head1 INHERITS
287              
288             This package inherits behaviors from:
289              
290             L
291              
292             =cut
293              
294             =head1 INTEGRATES
295              
296             This package integrates behaviors from:
297              
298             L
299              
300             L
301              
302             =cut
303              
304             =head1 METHODS
305              
306             This package provides the following methods:
307              
308             =cut
309              
310             =head2 captures
311              
312             captures() (ArrayRef)
313              
314             The captures method returns the capture groups from the result object which
315             contains information about the results of the regular expression operation.
316             This method can return a list of values in list-context.
317              
318             I>
319              
320             =over 4
321              
322             =item captures example 1
323              
324             # given: synopsis;
325              
326             my $captures = $search->captures;
327              
328             # ["hello"]
329              
330             =back
331              
332             =cut
333              
334             =head2 count
335              
336             count() (Num)
337              
338             The count method returns the number of matches found in the result object which
339             contains information about the results of the regular expression operation.
340              
341             I>
342              
343             =over 4
344              
345             =item count example 1
346              
347             # given: synopsis;
348              
349             my $count = $search->count;
350              
351             # 1
352              
353             =back
354              
355             =cut
356              
357             =head2 evaluate
358              
359             evaluate() (ArrayRef)
360              
361             The evaluate method performs the regular expression operation and returns an
362             arrayref representation of the results.
363              
364             I>
365              
366             =over 4
367              
368             =item evaluate example 1
369              
370             # given: synopsis;
371              
372             my $evaluate = $search->evaluate;
373              
374             # ["(hello)", "hello world", 1, [0, 0], [5, 5], {}, "hello world"]
375              
376             =back
377              
378             =over 4
379              
380             =item evaluate example 2
381              
382             package main;
383              
384             use Venus::Search;
385              
386             my $search = Venus::Search->new(
387             string => 'hello world',
388             regexp => 'hello:)',
389             );
390              
391             my $evaluate = $search->evaluate;
392              
393             # Exception! (isa Venus::Search::Error) (see error_on_evaluate)
394              
395             =back
396              
397             =cut
398              
399             =head2 explain
400              
401             explain() (Str)
402              
403             The explain method returns the subject of the regular expression operation and
404             is used in stringification operations.
405              
406             I>
407              
408             =over 4
409              
410             =item explain example 1
411              
412             # given: synopsis;
413              
414             my $explain = $search->explain;
415              
416             # "hello world"
417              
418             =back
419              
420             =cut
421              
422             =head2 get
423              
424             get() (Str)
425              
426             The get method returns the subject of the regular expression operation.
427              
428             I>
429              
430             =over 4
431              
432             =item get example 1
433              
434             # given: synopsis;
435              
436             my $get = $search->get;
437              
438             # "hello world"
439              
440             =back
441              
442             =cut
443              
444             =head2 initial
445              
446             initial() (Str)
447              
448             The initial method returns the unaltered string from the result object which
449             contains information about the results of the regular expression operation.
450              
451             I>
452              
453             =over 4
454              
455             =item initial example 1
456              
457             # given: synopsis;
458              
459             my $initial = $search->initial;
460              
461             # "hello world"
462              
463             =back
464              
465             =cut
466              
467             =head2 last_match_end
468              
469             last_match_end() (Maybe[ArrayRef[Int]])
470              
471             The last_match_end method returns an array of offset positions into the string
472             where the capture(s) stopped matching from the result object which contains
473             information about the results of the regular expression operation.
474              
475             I>
476              
477             =over 4
478              
479             =item last_match_end example 1
480              
481             # given: synopsis;
482              
483             my $last_match_end = $search->last_match_end;
484              
485             # [5, 5]
486              
487             =back
488              
489             =cut
490              
491             =head2 last_match_start
492              
493             last_match_start() (Maybe[ArrayRef[Int]])
494              
495             The last_match_start method returns an array of offset positions into the
496             string where the capture(s) matched from the result object which contains
497             information about the results of the regular expression operation.
498              
499             I>
500              
501             =over 4
502              
503             =item last_match_start example 1
504              
505             # given: synopsis;
506              
507             my $last_match_start = $search->last_match_start;
508              
509             # [0, 0]
510              
511             =back
512              
513             =cut
514              
515             =head2 matched
516              
517             matched() (Maybe[Str])
518              
519             The matched method returns the portion of the string that matched from the
520             result object which contains information about the results of the regular
521             expression operation.
522              
523             I>
524              
525             =over 4
526              
527             =item matched example 1
528              
529             # given: synopsis;
530              
531             my $matched = $search->matched;
532              
533             # "hello"
534              
535             =back
536              
537             =cut
538              
539             =head2 named_captures
540              
541             named_captures() (HashRef)
542              
543             The named_captures method returns a hash containing the requested named regular
544             expressions and captured string pairs from the result object which contains
545             information about the results of the regular expression operation.
546              
547             I>
548              
549             =over 4
550              
551             =item named_captures example 1
552              
553             # given: synopsis;
554              
555             my $named_captures = $search->named_captures;
556              
557             # {}
558              
559             =back
560              
561             =over 4
562              
563             =item named_captures example 2
564              
565             package main;
566              
567             use Venus::Search;
568              
569             my $search = Venus::Search->new(
570             string => 'hello world',
571             regexp => '(?world)',
572             );
573              
574             my $named_captures = $search->named_captures;
575              
576             # { locale => ["world"] }
577              
578             =back
579              
580             =cut
581              
582             =head2 postmatched
583              
584             postmatched() (Maybe[Str])
585              
586             The postmatched method returns the portion of the string after the regular
587             expression matched from the result object which contains information about the
588             results of the regular expression operation.
589              
590             I>
591              
592             =over 4
593              
594             =item postmatched example 1
595              
596             # given: synopsis;
597              
598             my $postmatched = $search->postmatched;
599              
600             # " world"
601              
602             =back
603              
604             =cut
605              
606             =head2 prematched
607              
608             prematched() (Maybe[Str])
609              
610             The prematched method returns the portion of the string before the regular
611             expression matched from the result object which contains information about the
612             results of the regular expression operation.
613              
614             I>
615              
616             =over 4
617              
618             =item prematched example 1
619              
620             # given: synopsis;
621              
622             my $prematched = $search->prematched;
623              
624             # ""
625              
626             =back
627              
628             =cut
629              
630             =head2 set
631              
632             set(Str $string) (Str)
633              
634             The set method sets the subject of the regular expression operation.
635              
636             I>
637              
638             =over 4
639              
640             =item set example 1
641              
642             # given: synopsis;
643              
644             my $set = $search->set('hello universe');
645              
646             # "hello universe"
647              
648             =back
649              
650             =cut
651              
652             =head1 ERRORS
653              
654             This package may raise the following errors:
655              
656             =cut
657              
658             =over 4
659              
660             =item error: C
661              
662             This package may raise an error_on_evaluate exception.
663              
664             B
665              
666             # given: synopsis;
667              
668             my $input = {
669             throw => 'error_on_evaluate',
670             error => 'Exception!',
671             };
672              
673             my $error = $search->catch('error', $input);
674              
675             # my $name = $error->name;
676              
677             # "on_evaluate"
678              
679             # my $message = $error->message;
680              
681             # "Exception!"
682              
683             =back
684              
685             =head1 OPERATORS
686              
687             This package overloads the following operators:
688              
689             =cut
690              
691             =over 4
692              
693             =item operation: C<(.)>
694              
695             This package overloads the C<.> operator.
696              
697             B
698              
699             # given: synopsis;
700              
701             my $result = $search . ', welcome';
702              
703             # "hello world, welcome"
704              
705             =back
706              
707             =over 4
708              
709             =item operation: C<(eq)>
710              
711             This package overloads the C operator.
712              
713             B
714              
715             # given: synopsis;
716              
717             my $result = $search eq 'hello world';
718              
719             # 1
720              
721             =back
722              
723             =over 4
724              
725             =item operation: C<(ne)>
726              
727             This package overloads the C operator.
728              
729             B
730              
731             # given: synopsis;
732              
733             my $result = $search ne 'Hello world';
734              
735             # 1
736              
737             =back
738              
739             =over 4
740              
741             =item operation: C<(qr)>
742              
743             This package overloads the C operator.
744              
745             B
746              
747             # given: synopsis;
748              
749             my $result = 'hello world, welcome' =~ qr/$search/;
750              
751             # 1
752              
753             =back
754              
755             =over 4
756              
757             =item operation: C<("")>
758              
759             This package overloads the C<""> operator.
760              
761             B
762              
763             # given: synopsis;
764              
765             my $result = "$search";
766              
767             # "hello world"
768              
769             B
770              
771             # given: synopsis;
772              
773             my $result = "$search, $search";
774              
775             # "hello world, hello world"
776              
777             =back
778              
779             =over 4
780              
781             =item operation: C<(~~)>
782              
783             This package overloads the C<~~> operator.
784              
785             B
786              
787             # given: synopsis;
788              
789             my $result = $search ~~ 'hello world';
790              
791             # 1
792              
793             =back
794              
795             =head1 AUTHORS
796              
797             Awncorp, C
798              
799             =cut
800              
801             =head1 LICENSE
802              
803             Copyright (C) 2000, Al Newkirk.
804              
805             This program is free software, you can redistribute it and/or modify it under
806             the terms of the Apache license version 2.0.
807              
808             =cut