File Coverage

lib/Pod/Definitions/Heuristic.pm
Criterion Covered Total %
statement 59 70 84.2
branch 13 20 65.0
condition 1 2 50.0
subroutine 8 9 88.8
pod 3 3 100.0
total 84 104 80.7


line stmt bran cond sub pod time code
1             package Pod::Definitions::Heuristic;
2              
3 2     2   1141 use Pod::Headings;
  2         5  
  2         77  
4             our $VERSION = '0.03';
5              
6 2     2   21 use v5.20;
  2         5  
7              
8 2     2   7 use strict;
  2         4  
  2         34  
9 2     2   7 use warnings;
  2         3  
  2         54  
10 2     2   8 use feature 'signatures';
  2         3  
  2         152  
11 2     2   11 no warnings 'experimental::signatures';
  2         24  
  2         2276  
12              
13             #
14             # Instantiation
15             #
16              
17 14     14 1 3687 sub new ($class, @args) {
  14         21  
  14         23  
  14         15  
18 14         33 my $self = {@args};
19 14         18 bless $self, $class;
20              
21 14         28 return $self;
22             }
23              
24             #
25             # Accessors
26             #
27              
28 0     0 1 0 sub text ($self, $new = undef) {
  0         0  
  0         0  
  0         0  
29 0 0       0 $self->{text} = $new if defined $new;
30 0         0 return $self->{text};
31             }
32              
33 14     14 1 30 sub clean ($self) {
  14         18  
  14         14  
34             # Clean headings for index display
35              
36             #
37             # TODO:
38             #
39             # Rewrite this as a series of filters, in the style of
40             # Mail::Filter, or iptables, where each filter's output is passed
41             # to the next in the chain, with the possibility of:
42             #
43             # - skipping the remainder of the chain with a final result (PASS)
44             # - skipping the remainder of the chain without saving (FAIL)
45             # - modifying the text (as iptables lets you modify a packet)
46             #
47             # TODO:
48             #
49             # - Perhaps an alternate heuristic for 'item' entries?
50             #
51              
52 14         22 my $original = $self->{text};
53 14         38 $original =~ s/^\s+//;
54 14         33 $original =~ s/\s(?:mean|go)\?$//;
55 14         31 $original =~ s/\?$//;
56             # Which versions are supported -> Versions supported
57             # How much does... How well is... How many...
58 14         56 $original =~ s/^(?:(what|which|how|many|much|well|is|are|do)\s+)+(\S.*?)?\s+(?:is|are|do)\s+(.+)\z/\u$2, $3/i;
59 14         25 $original =~ s/\s{2,}/ /g;
60              
61             # What does the error "Oops" mean? -> Oops, error
62 14 100       52 if ($original =~ m/^(?:(?:what|do|does|a|an|the)\s+)+((?:error|message)\s+)"?(.*)\z/i) {
63 1         5 my ($prefix, $main) = ($1, ucfirst($2));
64 1         5 $main =~ s/[?"]//g;
65 1         3 $main =~ s/^\s+//;
66 1         2 $prefix =~ s/[?"]//g;
67 1         3 $prefix =~ s/\s+\z//;
68 1         5 return "$main, $prefix";
69             }
70              
71             # How can I blip the blop? -> Blip the blop, How can I
72             # Why doesn't my socket have a packet? -> Socket have a packet, Why doesn't my
73             # Where are the pockets on the port? -> Pockets on the port, Where are the
74 13 100       51 if ($original =~ m/^((?:(?:who|what|when|where|which|why|how|is|are|did|a|an|the|do|does|don't|doesn't|can|not|I|my|need|to|about|there|much|many)\s+|go\s+for|error\s+"\.*|message\s+"\.*)+)(.*)$/i) {
75 4         18 my ($prefix, $main) = ($1, ucfirst($2));
76 4         8 $main =~ s/[?"]//g;
77 4         7 $main =~ s/^\s+//;
78 4         7 $prefix =~ s/[?"]//g;
79 4         11 $prefix =~ s/\s+\z//;
80 4         19 return "$main, $prefix";
81             }
82             # Nibbling the carrot -> Carrot, nibbling the
83 9 100       27 if ($original =~ m/^(\w+ing(?:\s+and\s+\w+ing)?)\s+(a|an|the|some|any|all|to|from|your)?\b\s*(.*)$/) {
84 1         6 my ($verb, $qualifier, $remainder) = ($1, $2, $3);
85 1   50     3 $qualifier ||= '';
86             # print ucfirst("$remainder, $verb $qualifier\n");
87 1         9 return ucfirst("$remainder, $verb $qualifier");
88             }
89             # $variable=function_name(...) -> function_name
90 8 50       23 if ($original =~ m/^[\$@]\w+\s*=\s*(?:\$\w+\s*->\s*)?(\w+)/) {
91 0         0 return $1;
92             }
93             # $variable->function_name(...) -> function_name
94 8 50       16 if ($original =~ m/^\$?\w+\s*->\s*(\w+)/) {
95 0         0 return $1;
96             }
97             # Module::Module->function_name(...) -> function_name
98 8 50       16 if ($original =~ m/^\w+(?:::\w+)+\s*->\s*(\w+)/) {
99 0         0 return $1;
100             }
101             # function_name($args,...) -> function_name
102 8 100       18 if ($original =~ m/^(\w+)\s*\(\s*[\$@%]\w+/) {
103 1         5 return $1;
104             }
105             # ($var, $var) = function_name(...) -> function_name
106 7 50       13 if ($original =~ m/^\([\$@%][^)]+\)\s*=\s*(?:\$\w+\s*->\s*)?(\w+)/) {
107 0         0 return $1;
108             }
109             # function_name BLOCK LIST [EXPR] -> function_name
110 7 50       25 if ($original =~ m/^((?:\w|_)+)\s+(?:(?:BLOCK|EXPR|LIST|COUNT|ARRAY\d*|VALUE|STRING|ITEM|\.+)\s*)+/) {
111 0         0 return $1;
112             }
113 7         23 return $original;
114             }
115              
116             1;
117              
118             __END__