File Coverage

blib/lib/Lingua/Sentence.pm

Criterion	Covered	Total	%
statement	77	84	91.6
branch	24	36	66.6
condition	11	24	45.8
subroutine	11	11	100.0
pod	3	3	100.0
total	126	158	79.7

package Lingua::Sentence;

use strict;
use warnings;

use Carp           ();
use File::ShareDir ();
use File::Spec     ();
use Path::Tiny     ();

our $VERSION = '1.100';
$VERSION = eval $VERSION;

sub new {
    my ($class, $lang_id, $prefix_file) = @_;
    Carp::croak("Invalid language id: $lang_id")
        unless ($lang_id && $lang_id =~ /^[a-z][a-z]$/i);

    # Try loading nonbreaking prefix file specified in constructor
    my $dir = File::ShareDir::dist_dir('Lingua-Sentence');
    my $fallback = File::Spec->catfile($dir, 'nonbreaking_prefix.' . $lang_id);
    my $fallback_en = File::Spec->catfile($dir, 'nonbreaking_prefix.en');
    if (defined($prefix_file)) {
        unless (-e $prefix_file) {
            warn
                "WARNING: Specified prefix file '$prefix_file' does not exist, attempting fall-back to $lang_id version...\n";
            $prefix_file = $fallback;
        }
    }
    else {
        $prefix_file = $fallback;
    }

    #default back to English if we don't have a language-specific prefix file
    unless (-e $prefix_file) {
        $prefix_file = $fallback_en;
        warn
            "WARNING: No known abbreviations for language '$lang_id', attempting fall-back to English version...\n";
    }

    # grab all non-breaking prefixes and store them in a hashref
    my $nb_prefix = {};
    my $pt        = Path::Tiny::path($prefix_file);
    if ($pt->is_file) {
        for my $line ($pt->lines_utf8({chomp => 1})) {
            next unless $line;
            next if substr($line, 0, 1) eq '#';
            if ($line =~ /^(.*?)\s+#NUMERIC_ONLY#/) {
                $nb_prefix->{$1} = 2;
            }
            else {
                $nb_prefix->{$line} = 1;
            }
        }
    }
    else {
        die("ERROR: No abbreviations files found in $dir\n");
    }

    return bless {LangID => $lang_id, Nonbreaking => $nb_prefix,}, $class;
}

sub split {
    my $self = shift;
    if (!ref $self) {
        return "Unnamed $self";
    }
    my $text = shift;
    if (!$text) {
        return '';
    }
    return _preprocess($self, $text);
}

sub split_array {
    my $self = shift;
    if (!ref $self) {
        return "Unnamed $self";
    }
    my $text = shift;
    if (!$text) {
        return ();
    }
    my $splittext = _preprocess($self, $text);
    chomp $splittext;
    return split(/\n/, $splittext);
}

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

    #####add sentence breaks as needed#####

    #non-period end of sentence markers (?!) followed by sentence starters.
    $text =~ s/([?!]) +(['"([\x{00bf}\x{00A1}\p{IsPi}]*[\p{IsUpper}])/$1\n$2/g;

    #multi-dots followed by sentence starters
    $text
        =~ s/(\.[\.]+) +(['"([\x{00bf}\x{00A1}\p{IsPi}]*[\p{IsUpper}])/$1\n$2/g;

# add breaks for sentences that end with some sort of punctuation inside a quote or parenthetical and are followed by a possible sentence starter punctuation and upper case
    $text
        =~ s/([?!\.][\ ]*['")\]\p{IsPf}]+) +(['"([\x{00bf}\x{00A1}\p{IsPi}]*[\ ]*[\p{IsUpper}])/$1\n$2/g;

# add breaks for sentences that end with some sort of punctuation are followed by a sentence starter punctuation and upper case
    $text
        =~ s/([?!\.]) +(['"([\x{00bf}\x{00A1}\p{IsPi}]+[\ ]*[\p{IsUpper}])/$1\n$2/g;

    # special punctuation cases are covered. Check all remaining periods.
    my $word;
    my $i;
    my @words = split(/ +/, $text);
    $text = "";
    for ($i = 0; $i < (scalar(@words) - 1); $i++) {
        if ($words[$i] =~ /([\p{IsAlnum}\.\-]*)([\'\"\)\]\%\p{IsPf}]*)(\.+)$/) {

            #check if $1 is a known honorific and $2 is empty, never break
            my $prefix         = $1;
            my $starting_punct = $2;
            if (   $prefix
                && $self->{Nonbreaking}{$prefix}
                && $self->{Nonbreaking}{$prefix} == 1
                && !$starting_punct)
            {
                #not breaking;
            }
            elsif ($words[$i] =~ /(\.)[\p{IsUpper}\-]+(\.+)$/) {

                #not breaking - upper case acronym
            }
            elsif ($words[$i + 1]
                =~ /^([ ]*['"([\x{00bf}\x{00A1}\p{IsPi}]*[ ]*[\p{IsUpper}0-9])/)
            {
#the next word has a bunch of initial quotes, maybe a space, then either upper case or a number
                $words[$i] = $words[$i] . "\n"
                    unless ($prefix
                    && $self->{Nonbreaking}{$prefix}
                    && $self->{Nonbreaking}{$prefix} == 2
                    && !$starting_punct
                    && ($words[$i + 1] =~ /^[0-9]+/));

#we always add a return for these unless we have a numeric non-breaker and a number start
            }

        }
        $text = $text . $words[$i] . " ";
    }

 #we stopped one token from the end to allow for easy look-ahead. Append it now.
    $text = $text . $words[$i];

   # clean up spaces at head and tail of each line as well as any double-spacing
    $text =~ s/ +/ /g;
    $text =~ s/\n /\n/g;
    $text =~ s/ \n/\n/g;
    $text =~ s/^ //g;
    $text =~ s/ $//g;

    #add trailing break
    $text .= "\n" unless $text =~ /\n$/;

    return $text;
}

1;
__END__