Initial Commit

database/perl/lib/Module/CPANTS/Kwalitee/Pod.pm

@@ -0,0 +1,210 @@
+package Module::CPANTS::Kwalitee::Pod;
+use warnings;
+use strict;
+use File::Spec::Functions qw/catfile/;
+use Encode;
+use Data::Binary qw/is_binary/;
+
+our $VERSION = '1.01';
+$VERSION =~ s/_//; ## no critic
+
+our @ABSTRACT_STUBS = (
+  q{Perl extension for blah blah blah}, # h2xs
+  q{[One line description of module's purpose here]}, # Module::Starter etc
+  q{The great new}, # Module::Starter
+  q{It's new $module}, # Minilla
+);
+
+sub order { 100 }
+
+##################################################################
+# Analyse
+##################################################################
+
+sub analyse {
+    my ($class, $me) = @_;
+    my $distdir = $me->distdir;
+    my %abstract;
+    my @errors;
+    for my $module (@{$me->d->{modules} || []}) {
+        my ($package, $abstract, $error, $has_binary_data) = $class->_parse_abstract(catfile($distdir, $module->{file}));
+        push @errors, "$error ($package)" if $error;
+        $me->d->{abstracts_in_pod}{$package} = $abstract if $package;
+        $me->d->{files_hash}{$module->{file}}{has_binary_data} = 1 if $has_binary_data;
+    }
+
+    # sometimes pod for .pm file is put into .pod
+    for my $file (@{$me->d->{files_array} || []}) {
+        next unless $file =~ /\.pod$/ && ($file =~ m!^lib/! or $file =~ m!^[^/]+$!);
+        local $@;
+        my ($package, $abstract, $error, $has_binary_data) = $class->_parse_abstract(catfile($distdir, $file));
+        push @errors, "$error ($package)" if $error;
+        $me->d->{abstracts_in_pod}{$package} = $abstract if $package;
+        $me->d->{files_hash}{$file}{has_binary_data} = 1 if $has_binary_data;
+    }
+    $me->d->{error}{has_abstract_in_pod} = join ';', @errors if @errors;
+}
+
+# adapted from ExtUtils::MM_Unix and Module::Build::PodParser
+sub _parse_abstract {
+    my ($class, $file) = @_;
+    my ($package, $abstract);
+    my $inpod = 0;
+    open my $fh, '<', $file or return;
+    my $directive;
+    my $encoding;
+    my $package_name_pattern = '(?:[A-Za-z0-9_]+::)*[A-Za-z0-9_]+ | [BCIF] < (?:[A-Za-z0-9_]+::)*[A-Za-z0-9_]+ >';
+    if ( $file !~ /\.p(?:m|od)$/ ) {
+        $package_name_pattern .= ' | [A-Za-z0-9_.-]+ | [BCIF] < [A-Za-z0-9_.-]+ >';
+    }
+    while(<$fh>) {
+        if (/^\s*__DATA__\s*$/) {
+            my $copy = $_ = <$fh>;
+            last unless defined $copy;
+            return (undef, undef, undef, 1) if is_binary($copy);
+        }
+        if (substr($_, 0, 1) eq '=') {
+            if (/^=encoding\s+(.+)/) {
+                $encoding = $1;
+            }
+            if (/^=cut/) {
+                $inpod = 0;
+            } elsif (/^=(?!cut)(.+)/) {
+                $directive = $1;
+                $inpod = 1;
+            }
+        }
+        next if !$inpod;
+        next unless $directive =~ /^head/;
+        if ( /^\s*(${package_name_pattern}) \s+ -+ (?:\s+ (.*)\s*$|$)/x ) {
+            ($package, $abstract) = ($1, $2);
+            $package =~ s![BCIF]<([^>]+)>!$1!;
+            next;
+        }
+        next unless $abstract;
+        last if /^\s*$/ || /^=/;
+        s/\s+$//s;
+        $abstract .= "\n$_";
+    }
+
+    my $error;
+    if ($encoding && $abstract) {
+        my $encoder = find_encoding($encoding);
+        if (!$encoder) {
+            $error = "unknown encoding: $encoding";
+        } else {
+            $abstract = eval { $encoder->decode($abstract) };
+            if ($@) {
+                $error = $@;
+                $error =~ s|\s*at .+ line \d+.+$||s;
+            }
+        }
+    }
+    return ($package, $abstract, $error);
+}
+
+##################################################################
+# Kwalitee Indicators
+##################################################################
+
+sub kwalitee_indicators {
+    return [
+      {
+          name => 'has_abstract_in_pod',
+          error => q{No abstract (short description of a module) is found in pod from this distribution.},
+          remedy => q{Provide a short description in the NAME section of the pod (after the module name followed by a hyphen) at least for the main module of this distribution.},
+          code => sub {
+              my $d = shift;
+              return 0 if $d->{error}{has_abstract_in_pod};
+              my @abstracts = grep {defined $_ && length $_} values %{$d->{abstracts_in_pod} || {}};
+              return @abstracts ? 1 : 0;
+          },
+          details => sub {
+              my $d = shift;
+              return "No abstracts in pod";
+          },
+      },
+      {
+          name => 'no_abstract_stub_in_pod',
+          is_extra => 1,
+          error => q{A well-known abstract stub (typically generated by an authoring tool) is found in this distribution.},
+          remedy => q{Modify the stub. You might need to modify other stubs (for name, synopsis, license, etc) as well.},
+          code => sub {
+              my $d = shift;
+              my %mapping = map {$_ => 1} @ABSTRACT_STUBS;
+              my @errors;
+              for (sort keys %{$d->{abstracts_in_pod} || {}}) {
+                  push @errors, $_ if $mapping{$d->{abstracts_in_pod}{$_} || ''};
+              }
+              if (@errors) {
+                  $d->{error}{no_abstract_stub_in_pod} = join ',', @errors;
+              }
+              return @errors ? 0 : 1;
+          },
+          details => sub {
+              my $d = shift;
+              my %mapping = map {$_ => 1} @ABSTRACT_STUBS;
+              return "Abstracts in the following packages are stubs:". $d->{error}{no_abstract_stub_in_pod};
+          },
+      },
+    ];
+}
+
+
+q{Favourite record of the moment:
+  Fat Freddys Drop: Based on a true story};
+
+__END__
+
+=encoding UTF-8
+
+=head1 NAME
+
+Module::CPANTS::Kwalitee::Pod - Check Pod
+
+=head1 SYNOPSIS
+
+Some of the check in this module has moved to L<Module::CPANTS::SiteKwalitee::Pod|https://github.com/cpants/Module-CPANTS-SiteKwalitee> to double-check the pod correctness on the server side.
+
+If you do care, it is recommended to add a test to test pod (with L<Test::Pod>) in "xt/" directory in your distribution.
+
+=head1 DESCRIPTION
+
+=head2 Methods
+
+=head3 order
+
+Defines the order in which Kwalitee tests should be run.
+
+Returns C<100>.
+
+=head3 analyse
+
+Parses pod to see if it has a proper abstract.
+
+=head3 kwalitee_indicators
+
+Returns the Kwalitee Indicators data structure.
+
+=over 4
+
+=item * has_abstract_in_pod
+
+=item * no_abstract_stub_in_pod
+
+=back
+
+=head1 SEE ALSO
+
+L<Module::CPANTS::Analyse>
+
+=head1 AUTHOR
+
+L<Thomas Klausner|https://metacpan.org/author/domm>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright © 2003–2006, 2009 L<Thomas Klausner|https://metacpan.org/author/domm>
+
+You may use and distribute this module according to the same terms
+that Perl is distributed under.