File Coverage

blib/lib/CPANPLUS/Dist/Debora/Pod.pm

Criterion	Covered	Total	%
statement	126	128	98.4
branch	24	36	66.6
condition			n/a
subroutine	18	18	100.0
pod	8	8	100.0
total	176	190	92.6

package CPANPLUS::Dist::Debora::Pod;

# SPDX-License-Identifier: Artistic-1.0-Perl OR GPL-1.0-or-later

use 5.016;
use warnings;
use utf8;

our $VERSION = '0.009';

use parent qw(Pod::Simple);

use Pod::Simple;
use Pod::Simple::Search;

sub find {
    my ($class, $module_name, @dirs) = @_;

    my $pod;

    my $podfile = Pod::Simple::Search->new->inc(0)->find($module_name, @dirs);
    if ($podfile) {
        $pod = CPANPLUS::Dist::Debora::Pod->new;
        $pod->parse_file($podfile);
    }

    return $pod;
}

sub new {
    my $class = shift;

    my $self = $class->SUPER::new(@_);

    $self->{buf}  = q{};
    $self->{text} = q{};

    return $self;
}

sub text {
    my $self = shift;

    return $self->{text};
}

sub title {
    my $self = shift;

    return $self->section(q{1}, qr{NAME}xmsi);
}

sub summary {
    my $self = shift;

    my $summary = $self->title;
    if ($summary) {
        if ($summary =~ m{\h+ - \h+ (.*)}xms) {
            $summary = $1;
        }
    }

    return $summary;
}

sub description {
    my $self = shift;

    my $length = 500;

    my @headings
        = (qr{DESCRIPTION}xmsi, qr{INTRODUCTION}xmsi, qr{SYNOPSIS}xmsi);

    my $description;
    SECTION:
    for my $heading (@headings) {
        my $section = $self->section(q{1}, $heading);
        next SECTION if !$section;

        $description = q{};

        # Remove subheadings.
        $section =~ s{^ =head\d \h (\V+) \v+}{}xmsg;

        # Add the first paragraphs to the description.
        PARAGRAPH:
        for my $paragraph (split qr{\v\v+}xms, $section) {
            if ($description) {
                $description .= "\n\n";
            }
            $description .= $paragraph;
            last PARAGRAPH if length $description > $length;
        }

        # Remove the last sentence if the sentence ends with ":".
        $description =~ s{[.] [^.]* : \z}{.}xms;

        # Remove the last sentence if the sentence contains the word "below".
        $description =~ s{[.] [^.]+ \b (?:below) \b [^.]* [.] \z}{.}xms;

        last SECTION if $description;
    }

    return $description;
}

sub _copyrights_from_text {
    my ($self, $text) = @_;

    my $COPYRIGHT = qr{Copyright (?:\h+ (?:[(]c[)] | ©))?}xmsi;
    my $YEAR      = qr{\d+ (?: \s* [-,] \s* \d+)*}xms;
    my $HOLDER    = qr{[^\v]+}xms;

    my $COPYRIGHT_NOTICE = qr{
        $COPYRIGHT
        \s+
        ($YEAR) [-,]?
        \s+
        ($HOLDER)
    }xms;

    my $MARKS = qr{[.,;!?:]}xms;

    my $AUTHOR_REFERENCE = qr{
        \b (?:above | aforementioned ) \b
        | "AUTHORS?"
    }xmsi;

    # Put a newline before any copyright notice so that we can find
    # consecutive copyright notices.
    $text =~ s{($COPYRIGHT \s+ $YEAR)}{\n$1}xmsg;

    # Remove some phrases.
    my @phrases = (
        qr{\b by \b}xmsi,        # "by"
        qr{[(] [^)]* [)]}xms,    # text in parens
        qr{(?:All | Some) \h+ rights \h+ reserved \V*}xmsi,
        qr{This [\h\w]* \h+ is \h+ free \h+ software \V*}xmsi,
        qr{This [\h\w]* \h+ is \h+ made \h+ available \V*}xmsi,
        qr{License [\h\w]* \h+ granted \V*}xmsi,
        qr{Licensed \h+ under \V*}xmsi,
        qr{Same \h+ license \V*}xmsi,
        qr{You \h+ (?:may | should) \V*}xmsi,
        qr{[^.,;:]+ \h+ is \h+ (?:distributed | released) \V*}xmsi,
        qr{?}xms,    # email addresses
        qr{https?://[^\h]+}xms,        # URLs
    );

    for my $phrase (@phrases) {
        $text =~ s{$MARKS* \h* $phrase}{}xmsg;
    }

    my %unique_copyrights;
    COPYRIGHT_NOTICE:
    while ($text =~ m{$COPYRIGHT_NOTICE}xmsg) {
        my $year   = $1;
        my $holder = $2;

        $year =~ s{\h* -+ \h*}{-}xmsg;    # Remove spaces from hyphens.
        $year =~ s{,(\S)}{, $1}xmsg;      # Put a space after commas.
        $year =~ s{\s+}{ }xmsg;           # Squeeze spaces.

        $holder =~ s{\s+ \z}{}xms;        # Remove trailing spaces.
        $holder =~ s{\s+}{ }xmsg;         # Squeeze spaces.
        $holder =~ s{$MARKS+ \z}{}xms;    # Remove trailing punctuation marks.

        next COPYRIGHT_NOTICE if $holder =~ $AUTHOR_REFERENCE;

        $unique_copyrights{"$year $holder"}
            = {year => $year, holder => $holder};
    }

    my @copyrights
        = sort { $a->{year} cmp $b->{year} } values %unique_copyrights;

    return \@copyrights;
}

sub copyrights {
    my $self = shift;

    my $COPYRIGHT_HEADINGS = qr{
        (?: LICEN[CS]E | LICENSING | COPYRIGHT | LEGAL ) \b [^\v]*
    }xmsi;

    my @copyrights;

    my $section = $self->section(qr{\d}xms, $COPYRIGHT_HEADINGS);
    if ($section) {
        push @copyrights, @{$self->_copyrights_from_text($section)};
    }

    return \@copyrights;
}

sub section {
    my ($self, $level, $title) = @_;

    my $section;
    if ($self->{text} =~ m{^ =head($level) \h $title \v+ (.*)}xms) {
        my $n = $1;
        $section = $2;
        $section =~ s{\v* ^ =head$n \h .*}{}xms;    # Remove other sections.
        $section =~ s{\v+ \z}{}xms;                 # Remove trailing newlines.
    }

    return $section;
}

## no critic (Subroutines::ProhibitUnusedPrivateSubroutines)

sub _handle_element_start {
    my ($self, $name, $attrs) = @_;

    my %do_clear = map { $_ => 1 } qw(
        head1
        head2
        head3
        head4
        item-text
        Para
        Verbatim
    );

    if ($name eq 'item-bullet') {
        $self->{buf} = q{ * };
    }
    elsif ($name eq 'item-number') {
        $self->{buf} = q{ } . $attrs->{number} . q{. };
    }
    elsif ($do_clear{$name}) {
        $self->{buf} = q{};
    }

    return;
}

sub _handle_element_end {
    my ($self, $name) = @_;

    my %do_output = map { $_ => 1 } qw(
        head1
        head2
        head3
        head4
        item-bullet
        item-number
        item-text
        Para
        Verbatim
    );

    my %do_newline = map { $_ => 1 } qw(
        head1
        head2
        head3
        head4
        Para
        Verbatim
    );

    if ($name =~ m{^ head\d}xms) {
        $self->{text} .= "=$name ";
    }

    if ($do_output{$name}) {
        $self->{text} .= $self->{buf};
        $self->{text} .= "\n";
        if ($do_newline{$name}) {
            $self->{text} .= "\n";
        }
        $self->{buf} = q{};
    }

    return;
}

sub _handle_text {
    my ($self, $text) = @_;

    # Pod::Simple provides nbsp and shy since Perl 5.24.
    ## no critic (Variables::ProhibitPackageVars)
    if (defined $Pod::Simple::nbsp) {
        $text =~ s{$Pod::Simple::nbsp}{ }xmsg;
    }
    if (defined $Pod::Simple::shy) {
        $text =~ s{$Pod::Simple::shy}{}xmsg;
    }
    $self->{buf} .= $text;

    return;
}

1;
__END__