File Coverage

blib/lib/CPAN/Critic/Module/Abstract.pm
Criterion Covered Total %
statement 41 143 28.6
branch 6 56 10.7
condition 2 20 10.0
subroutine 10 22 45.4
pod 1 2 50.0
total 60 243 24.6


line stmt bran cond sub pod time code
1             package CPAN::Critic::Module::Abstract;
2              
3             our $DATE = '2019-01-06'; # DATE
4             our $VERSION = '0.090'; # VERSION
5              
6 1     1   93724 use 5.010;
  1         13  
7 1     1   7 use strict;
  1         2  
  1         32  
8 1     1   6 use warnings;
  1         2  
  1         26  
9 1     1   2080 use Log::ger;
  1         51  
  1         5  
10              
11 1     1   674 use Package::Stash;
  1         7817  
  1         38  
12 1     1   1036 use Perinci::Sub::DepChecker qw(check_deps);
  1         5529  
  1         77  
13              
14 1     1   9 use Exporter;
  1         2  
  1         188  
15             our @ISA = qw(Exporter);
16             our @EXPORT_OK = qw(
17             critique_cpan_module_abstract
18             declare_policy
19             );
20              
21             our %PROFILES;
22             our %SPEC;
23              
24             sub declare_policy {
25 11     11 0 42 my %args = @_;
26 11 50       29 my $name = $args{name} or die "Please specify name";
27 11 50       32 $SPEC{"policy_$name"} and die "Policy $name already declared";
28             #$args{summary} or die "Please specify summary";
29              
30             my $meta = {
31             v => 1.1,
32             summary => $args{summary},
33 11         30 };
34 11 100       25 $meta->{deps} = $args{deps} if $args{deps};
35             $meta->{args} = {
36 11         38 abstract => {req=>1, schema=>'str*'},
37             stash => {schema=>'hash*'},
38             };
39 11 100       25 if ($args{args}) {
40 10         15 for (keys %{ $args{args} }) {
  10         25  
41 2         7 $meta->{args}{$_} = $args{args}{$_};
42             }
43             }
44 11   50     28 $meta->{"_cpancritic.severity"} = $args{severity} // 3;
45 11   50     36 $meta->{"_cpancritic.themes"} = $args{themes} // [];
46              
47 1     1   7 no strict 'refs';
  1         2  
  1         1728  
48 11         16 *{__PACKAGE__."::policy_$name"} = $args{code};
  11         60  
49 11         33 $SPEC{"policy_$name"} = $meta;
50             }
51              
52             declare_policy
53             name => 'prohibit_empty',
54             severity => 5,
55             code => sub {
56 0     0     my %args = @_;
57 0           my $ab = $args{abstract};
58 0 0         if ($ab =~ /\S/) {
59 0           [200];
60             } else {
61 0           [409];
62             }
63             };
64              
65             declare_policy
66             name => 'prohibit_too_short',
67             severity => 4,
68             args => {
69             min_len => {schema=>['int*', default=>3]},
70             },
71             code => sub {
72 0     0     my %args = @_;
73 0           my $ab = $args{abstract};
74 0   0       my $l = $args{min_len} // 3;
75 0 0         if (!length($ab)) {
    0          
76 0           [412];
77             } elsif (length($ab) >= $l) {
78 0           [200];
79             } else {
80 0           [409];
81             }
82             };
83              
84             declare_policy
85             name => 'prohibit_too_long',
86             severity => 3,
87             args => {
88             max_len => {schema=>['int*', default=>72]},
89             },
90             code => sub {
91 0     0     my %args = @_;
92 0           my $ab = $args{abstract};
93 0   0       my $l = $args{max_len} // 72;
94 0 0         if (length($ab) <= $l) {
95 0           [200];
96             } else {
97 0           [409];
98             }
99             };
100              
101             declare_policy
102             name => 'prohibit_multiline',
103             severity => 3,
104             args => {},
105             code => sub {
106 0     0     my %args = @_;
107 0           my $ab = $args{abstract};
108 0 0         if ($ab !~ /\n/) {
109 0           [200];
110             } else {
111 0           [409];
112             }
113             };
114              
115             declare_policy
116             name => 'prohibit_template',
117             severity => 5,
118             args => {},
119             code => sub {
120 0     0     my %args = @_;
121 0           my $ab = $args{abstract};
122 0 0         if ($ab =~ /^(Perl extension for blah blah blah)/i) {
    0          
    0          
123 0           [409, "Template from h2xs '$1'"];
124             } elsif ($ab =~ /^(The great new )\w+(::\w+)*/i) {
125 0           [409, "Template from module-starter '$1'"];
126             } elsif ($ab =~ /^\b(blah blah)\b/i) {
127 0           [409, "Looks like a template"];
128             } else {
129 0           [200];
130             }
131             };
132              
133             declare_policy
134             name => 'prohibit_starts_with_lowercase_letter',
135             severity => 2,
136             args => {},
137             code => sub {
138 0     0     my %args = @_;
139 0           my $ab = $args{abstract};
140 0 0         if (!length($ab)) {
    0          
141 0           [412];
142             } elsif ($ab =~ /^[[:lower:]]/) {
143 0           [409];
144             } else {
145 0           [200];
146             }
147             };
148              
149             declare_policy
150             name => 'prohibit_ends_with_full_stop',
151             severity => 2,
152             args => {},
153             code => sub {
154 0     0     my %args = @_;
155 0           my $ab = $args{abstract};
156 0 0         if ($ab =~ /\.\z/) {
157 0           [409];
158             } else {
159 0           [200];
160             }
161             };
162              
163             declare_policy
164             name => 'prohibit_redundancy',
165             severity => 3,
166             args => {},
167             code => sub {
168 0     0     my %args = @_;
169 0           my $ab = $args{abstract};
170 0 0         if ($ab =~ /^( (?: (?:a|the) \s+)?
171             (?: perl\s?[56]? \s+)?
172             (?:extension|module|library|interface|xs \s binding)
173             (?: \s+ (?:to|for))?
174             )/xi) {
175 0           [409, "Saying '$1' is redundant, omit it"];
176             } else {
177 0           [200];
178             }
179             };
180              
181             declare_policy
182             name => 'require_english',
183             severity => 2,
184             args => {},
185             deps => {pm=>'Lingua::Identify'},
186             code => sub {
187 0     0     my %args = @_;
188 0           my $ab = $args{abstract};
189 0           my %langs = Lingua::Identify::langof($ab);
190 0 0         return [412, "Empty result from langof"] unless keys(%langs);
191 0           my @langs = sort { $langs{$b}<=>$langs{$a} } keys %langs;
  0            
192 0           my $confidence = Lingua::Identify::confidence(%langs);
193 0           log_trace(
194             "Lingua::Identify result: langof=%s, langs=%s, confidence=%s",
195             \%langs, \@langs, $confidence);
196 0 0         if ($langs[0] ne 'en') {
197             [409, "Language not detected as English, ".
198             sprintf("%d%% %s (confidence %.2f)",
199 0           $langs{$langs[0]}*100, $langs[0], $confidence)];
200             } else {
201 0           [200];
202             }
203             };
204              
205             declare_policy
206             name => 'prohibit_shouting',
207             severity => 2,
208             args => {},
209             code => sub {
210 0     0     my %args = @_;
211 0           my $ab = $args{abstract};
212 0 0         if ($ab =~ /!{3,}/) {
213 0           [409, "Too many exclamation points"];
214             } else {
215 0           my $spaces = 0; $spaces++ while $ab =~ s/\s+//;
  0            
216 0           $ab =~ s/\W+//g;
217 0           $ab =~ s/\d+//g;
218 0 0 0       if ($ab =~ /^[[:upper:]]+$/ && $spaces >= 2) {
219 0           return [409, "All-caps"];
220             } else {
221 0           return [200];
222             }
223             }
224             };
225              
226             declare_policy
227             name => 'prohibit_just_module_name',
228             severity => 2,
229             args => {},
230             code => sub {
231 0     0     my %args = @_;
232 0           my $ab = $args{abstract};
233 0 0         if ($ab =~ /^\w+(::\w+)+$/) {
234 0           [409, "Should not just be a module name"];
235             } else {
236 0           [200];
237             }
238             };
239              
240             # policy: don't repeat module name
241             # policy: should be verb + ...
242              
243             $PROFILES{all} = {
244             policies => [],
245             };
246             for (Package::Stash->new(__PACKAGE__)->list_all_symbols("CODE")) {
247             next unless /^policy_(.+)/;
248             push @{$PROFILES{all}{policies}}, $1;
249             }
250             $PROFILES{default} = $PROFILES{all};
251             # XXX default: 4/5 if length > 100?
252              
253             $SPEC{critique_cpan_module_abstract} = {
254             v => 1.1,
255             summary => 'Critic CPAN module abstract',
256             args => {
257             abstract => {
258             schema => 'str*',
259             req => 1,
260             pos => 0,
261             },
262             profile => {
263             schema => ['str*' => {default=>'default'}],
264             },
265             },
266             };
267             sub critique_cpan_module_abstract {
268 0     0 1   my %args = @_;
269 0   0       my $abstract = $args{abstract} // "";
270 0   0       my $profile = $args{profile} // "default";
271              
272             # some cleanup for abstract
273 0           for ($abstract) {
274 0           s/\A\s+//; s/\s+\z//;
  0            
275             }
276              
277 0 0         my $pr = $PROFILES{$profile} or return [400, "No such profile '$profile'"];
278              
279 0           my @res;
280 0           log_trace("Running critic profile %s on abstract %s ...",
281             $profile, $abstract);
282 0           my $pass;
283 0           my $stash = {};
284 0           for my $pol0 (@{ $pr->{policies} }) {
  0            
285 0           log_trace("Running policy %s ...", $pol0);
286 0 0         my $pol = ref($pol0) eq 'HASH' ? %$pol0 : {name=>$pol0};
287 0 0         my $spec = $SPEC{"policy_$pol->{name}"} or
288             return [400, "No such policy $pol->{name}"];
289 0 0         if ($spec->{deps}) {
290 0           my $err = check_deps($spec->{deps});
291 0 0         return [500, "Can't run policy $pol->{name}: ".
292             "dependency failed: $err"] if $err;
293             }
294 1     1   8 no strict 'refs';
  1         2  
  1         222  
295 0           my $code = \&{__PACKAGE__ . "::policy_$pol->{name}"};
  0            
296 0           my $res = $code->(abstract=>$abstract, stash=>$stash); # XXX args
297 0           log_trace("Result from policy %s: %s", $pol->{name}, $res);
298 0 0         if ($res->[0] == 409) {
299 0           my $severity = $spec->{"_cpancritic.severity"};
300 0 0         $pass = 0 if $severity >= 5;
301 0   0       push @res, {
302             severity=>$severity,
303             message=>$res->[1] // "Violates $pol->{name}",
304             };
305             }
306             }
307 0   0       $pass //= 1;
308              
309             #[200, "OK", {pass=>$pass, detail=>\@res}];
310 0           [200, "OK", \@res];
311             }
312              
313             1;
314             # ABSTRACT: Critic CPAN module abstract
315              
316             __END__
317              
318             =pod
319              
320             =encoding UTF-8
321              
322             =head1 NAME
323              
324             CPAN::Critic::Module::Abstract - Critic CPAN module abstract
325              
326             =head1 VERSION
327              
328             This document describes version 0.090 of CPAN::Critic::Module::Abstract (from Perl distribution CPAN-Critic-Module-Abstract), released on 2019-01-06.
329              
330             =head1 SYNOPSIS
331              
332             % critic-cpan-module-abstract 'Perl extension for blah blah blah'
333              
334             # customize profile (add/remove policies, modify severities, ...)
335             # TODO
336              
337             =head1 DESCRIPTION
338              
339             This is a proof-of-concept module to critic CPAN module abstract.
340              
341             Dist::Zilla plugin coming shortly.
342              
343             =head1 FUNCTIONS
344              
345              
346             =head2 critique_cpan_module_abstract
347              
348             Usage:
349              
350             critique_cpan_module_abstract(%args) -> [status, msg, payload, meta]
351              
352             Critic CPAN module abstract.
353              
354             This function is not exported by default, but exportable.
355              
356             Arguments ('*' denotes required arguments):
357              
358             =over 4
359              
360             =item * B<abstract>* => I<str>
361              
362             =item * B<profile> => I<str> (default: "default")
363              
364             =back
365              
366             Returns an enveloped result (an array).
367              
368             First element (status) is an integer containing HTTP status code
369             (200 means OK, 4xx caller error, 5xx function error). Second element
370             (msg) is a string containing error message, or 'OK' if status is
371             200. Third element (payload) is optional, the actual result. Fourth
372             element (meta) is called result metadata and is optional, a hash
373             that contains extra information.
374              
375             Return value: (any)
376              
377              
378             =head2 policy_prohibit_empty
379              
380             Usage:
381              
382             policy_prohibit_empty(%args) -> [status, msg, payload, meta]
383              
384             This function is not exported.
385              
386             Arguments ('*' denotes required arguments):
387              
388             =over 4
389              
390             =item * B<abstract>* => I<str>
391              
392             =item * B<stash> => I<hash>
393              
394             =back
395              
396             Returns an enveloped result (an array).
397              
398             First element (status) is an integer containing HTTP status code
399             (200 means OK, 4xx caller error, 5xx function error). Second element
400             (msg) is a string containing error message, or 'OK' if status is
401             200. Third element (payload) is optional, the actual result. Fourth
402             element (meta) is called result metadata and is optional, a hash
403             that contains extra information.
404              
405             Return value: (any)
406              
407              
408             =head2 policy_prohibit_ends_with_full_stop
409              
410             Usage:
411              
412             policy_prohibit_ends_with_full_stop(%args) -> [status, msg, payload, meta]
413              
414             This function is not exported.
415              
416             Arguments ('*' denotes required arguments):
417              
418             =over 4
419              
420             =item * B<abstract>* => I<str>
421              
422             =item * B<stash> => I<hash>
423              
424             =back
425              
426             Returns an enveloped result (an array).
427              
428             First element (status) is an integer containing HTTP status code
429             (200 means OK, 4xx caller error, 5xx function error). Second element
430             (msg) is a string containing error message, or 'OK' if status is
431             200. Third element (payload) is optional, the actual result. Fourth
432             element (meta) is called result metadata and is optional, a hash
433             that contains extra information.
434              
435             Return value: (any)
436              
437              
438             =head2 policy_prohibit_just_module_name
439              
440             Usage:
441              
442             policy_prohibit_just_module_name(%args) -> [status, msg, payload, meta]
443              
444             This function is not exported.
445              
446             Arguments ('*' denotes required arguments):
447              
448             =over 4
449              
450             =item * B<abstract>* => I<str>
451              
452             =item * B<stash> => I<hash>
453              
454             =back
455              
456             Returns an enveloped result (an array).
457              
458             First element (status) is an integer containing HTTP status code
459             (200 means OK, 4xx caller error, 5xx function error). Second element
460             (msg) is a string containing error message, or 'OK' if status is
461             200. Third element (payload) is optional, the actual result. Fourth
462             element (meta) is called result metadata and is optional, a hash
463             that contains extra information.
464              
465             Return value: (any)
466              
467              
468             =head2 policy_prohibit_multiline
469              
470             Usage:
471              
472             policy_prohibit_multiline(%args) -> [status, msg, payload, meta]
473              
474             This function is not exported.
475              
476             Arguments ('*' denotes required arguments):
477              
478             =over 4
479              
480             =item * B<abstract>* => I<str>
481              
482             =item * B<stash> => I<hash>
483              
484             =back
485              
486             Returns an enveloped result (an array).
487              
488             First element (status) is an integer containing HTTP status code
489             (200 means OK, 4xx caller error, 5xx function error). Second element
490             (msg) is a string containing error message, or 'OK' if status is
491             200. Third element (payload) is optional, the actual result. Fourth
492             element (meta) is called result metadata and is optional, a hash
493             that contains extra information.
494              
495             Return value: (any)
496              
497              
498             =head2 policy_prohibit_redundancy
499              
500             Usage:
501              
502             policy_prohibit_redundancy(%args) -> [status, msg, payload, meta]
503              
504             This function is not exported.
505              
506             Arguments ('*' denotes required arguments):
507              
508             =over 4
509              
510             =item * B<abstract>* => I<str>
511              
512             =item * B<stash> => I<hash>
513              
514             =back
515              
516             Returns an enveloped result (an array).
517              
518             First element (status) is an integer containing HTTP status code
519             (200 means OK, 4xx caller error, 5xx function error). Second element
520             (msg) is a string containing error message, or 'OK' if status is
521             200. Third element (payload) is optional, the actual result. Fourth
522             element (meta) is called result metadata and is optional, a hash
523             that contains extra information.
524              
525             Return value: (any)
526              
527              
528             =head2 policy_prohibit_shouting
529              
530             Usage:
531              
532             policy_prohibit_shouting(%args) -> [status, msg, payload, meta]
533              
534             This function is not exported.
535              
536             Arguments ('*' denotes required arguments):
537              
538             =over 4
539              
540             =item * B<abstract>* => I<str>
541              
542             =item * B<stash> => I<hash>
543              
544             =back
545              
546             Returns an enveloped result (an array).
547              
548             First element (status) is an integer containing HTTP status code
549             (200 means OK, 4xx caller error, 5xx function error). Second element
550             (msg) is a string containing error message, or 'OK' if status is
551             200. Third element (payload) is optional, the actual result. Fourth
552             element (meta) is called result metadata and is optional, a hash
553             that contains extra information.
554              
555             Return value: (any)
556              
557              
558             =head2 policy_prohibit_starts_with_lowercase_letter
559              
560             Usage:
561              
562             policy_prohibit_starts_with_lowercase_letter(%args) -> [status, msg, payload, meta]
563              
564             This function is not exported.
565              
566             Arguments ('*' denotes required arguments):
567              
568             =over 4
569              
570             =item * B<abstract>* => I<str>
571              
572             =item * B<stash> => I<hash>
573              
574             =back
575              
576             Returns an enveloped result (an array).
577              
578             First element (status) is an integer containing HTTP status code
579             (200 means OK, 4xx caller error, 5xx function error). Second element
580             (msg) is a string containing error message, or 'OK' if status is
581             200. Third element (payload) is optional, the actual result. Fourth
582             element (meta) is called result metadata and is optional, a hash
583             that contains extra information.
584              
585             Return value: (any)
586              
587              
588             =head2 policy_prohibit_template
589              
590             Usage:
591              
592             policy_prohibit_template(%args) -> [status, msg, payload, meta]
593              
594             This function is not exported.
595              
596             Arguments ('*' denotes required arguments):
597              
598             =over 4
599              
600             =item * B<abstract>* => I<str>
601              
602             =item * B<stash> => I<hash>
603              
604             =back
605              
606             Returns an enveloped result (an array).
607              
608             First element (status) is an integer containing HTTP status code
609             (200 means OK, 4xx caller error, 5xx function error). Second element
610             (msg) is a string containing error message, or 'OK' if status is
611             200. Third element (payload) is optional, the actual result. Fourth
612             element (meta) is called result metadata and is optional, a hash
613             that contains extra information.
614              
615             Return value: (any)
616              
617              
618             =head2 policy_prohibit_too_long
619              
620             Usage:
621              
622             policy_prohibit_too_long(%args) -> [status, msg, payload, meta]
623              
624             This function is not exported.
625              
626             Arguments ('*' denotes required arguments):
627              
628             =over 4
629              
630             =item * B<abstract>* => I<str>
631              
632             =item * B<max_len> => I<int> (default: 72)
633              
634             =item * B<stash> => I<hash>
635              
636             =back
637              
638             Returns an enveloped result (an array).
639              
640             First element (status) is an integer containing HTTP status code
641             (200 means OK, 4xx caller error, 5xx function error). Second element
642             (msg) is a string containing error message, or 'OK' if status is
643             200. Third element (payload) is optional, the actual result. Fourth
644             element (meta) is called result metadata and is optional, a hash
645             that contains extra information.
646              
647             Return value: (any)
648              
649              
650             =head2 policy_prohibit_too_short
651              
652             Usage:
653              
654             policy_prohibit_too_short(%args) -> [status, msg, payload, meta]
655              
656             This function is not exported.
657              
658             Arguments ('*' denotes required arguments):
659              
660             =over 4
661              
662             =item * B<abstract>* => I<str>
663              
664             =item * B<min_len> => I<int> (default: 3)
665              
666             =item * B<stash> => I<hash>
667              
668             =back
669              
670             Returns an enveloped result (an array).
671              
672             First element (status) is an integer containing HTTP status code
673             (200 means OK, 4xx caller error, 5xx function error). Second element
674             (msg) is a string containing error message, or 'OK' if status is
675             200. Third element (payload) is optional, the actual result. Fourth
676             element (meta) is called result metadata and is optional, a hash
677             that contains extra information.
678              
679             Return value: (any)
680              
681              
682             =head2 policy_require_english
683              
684             Usage:
685              
686             policy_require_english(%args) -> [status, msg, payload, meta]
687              
688             This function is not exported.
689              
690             Arguments ('*' denotes required arguments):
691              
692             =over 4
693              
694             =item * B<abstract>* => I<str>
695              
696             =item * B<stash> => I<hash>
697              
698             =back
699              
700             Returns an enveloped result (an array).
701              
702             First element (status) is an integer containing HTTP status code
703             (200 means OK, 4xx caller error, 5xx function error). Second element
704             (msg) is a string containing error message, or 'OK' if status is
705             200. Third element (payload) is optional, the actual result. Fourth
706             element (meta) is called result metadata and is optional, a hash
707             that contains extra information.
708              
709             Return value: (any)
710              
711             =for Pod::Coverage ^(.*)$
712              
713             =head1 HOMEPAGE
714              
715             Please visit the project's homepage at L<https://metacpan.org/release/CPAN-Critic-Module-Abstract>.
716              
717             =head1 SOURCE
718              
719             Source repository is at L<https://github.com/perlancar/perl-CPAN-Critic-Module-Abstract>.
720              
721             =head1 BUGS
722              
723             Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=CPAN-Critic-Module-Abstract>
724              
725             When submitting a bug or request, please include a test-file or a
726             patch to an existing test-file that illustrates the bug or desired
727             feature.
728              
729             =head1 AUTHOR
730              
731             perlancar <perlancar@cpan.org>
732              
733             =head1 COPYRIGHT AND LICENSE
734              
735             This software is copyright (c) 2019, 2017, 2015, 2014, 2012 by perlancar@cpan.org.
736              
737             This is free software; you can redistribute it and/or modify it under
738             the same terms as the Perl 5 programming language system itself.
739              
740             =cut