File Coverage

blib/lib/Lingua/EN/Titlecase.pm

Criterion	Covered	Total	%
statement	115	121	95.0
branch	53	62	85.4
condition	7	7	100.0
subroutine	20	21	95.2
pod	9	9	100.0
total	204	220	92.7

package Lingua::EN::Titlecase;
use strict;
use warnings;
no warnings "uninitialized";
require 5.006; # for POSIX classes

use parent "Class::Accessor::Fast";

__PACKAGE__->mk_accessors (qw{
                             uc_threshold
                             mixed_threshold
                             mixed_rx
                             wordish_rx
                             allow_mixed
                             word_punctuation
                             });

use overload '""' => sub { $_[0]->original ? $_[0]->title : ref $_[0] },
    fallback => 1;

# DEVELOPER NOTES
# story card it out including a TT2 plugin
# HOW will entities and utf8 be handled?
# should be raw; OO and functional both?
# lc, default is prepositions, articles, conjunctions, can point to a
# file or to a hash ref (like a tied file, should have recipe)
# canonical /different word/, like OSS or eBay?
# Hyphen-Behavior
# confidence
# titlecase, tc
# rules
# allow user to set order of applying look-up rules, lc > uc, e.g.

# NEED TO ALLOW FOR fixing or leaving things like pH, PERL, tied hash dictionary?

# new with 1 arg uses it as string
# with more than 1 tries constructors

# There are quite a few apostrophe edge cases right now and no
# utf8/entity handling

use List::Util "first";
use Carp;
our $VERSION = "0.15";

our %LC = map { $_ => 1 }
    qw( the a an and or but aboard about above across after against
        along amid among around as at before behind below beneath
        beside besides between beyond but by for from in inside into
        like minus near of off on onto opposite outside over past per
        plus regarding since than through to toward towards under
        underneath unlike until up upon versus via with within without
        v vs
        );

my %Attr = (
            word_punctuation => 1,
            original => 1,
            title => 1,
            uc_threshold => 1,
            mixed_threshold => 1,
            );

sub new : method {
    my $self = +shift->SUPER::new();

    if ( @_ == 1 )
    {
        $self->{_original} = $_[0];
    }
    else
    {
        my %args = @_; # might be empty
        for my $key ( keys %args )
        {
            croak "Construction parameter \"$key\" not allowed"
                unless $Attr{$key};
            $self->$key($args{$key});
        }
    }
    return $self->_init();
}

sub _init : method {
    my $self = shift;
    $self->{_titlecase} = "";
    $self->{_real_length} = 0;
    $self->{_mixedcase} = [];
    $self->{_wc} = [];
    $self->{_token_queue} = [];
    $self->{_uppercase} = [];
    $self->word_punctuation(qr/[[:punct:]]/) unless $self->word_punctuation;
    my $wp = $self->word_punctuation;
    $self->wordish_rx(qr/
                   [[:alpha:]]
                   (?: (?<=[[:alpha:]]) $wp (?=[[:alpha:]]) | [[:alpha:]] )*
                   [[:alpha:]]*
                   /x) unless $self->wordish_rx;
    $self->mixed_rx(
                    qr/(?<=[[:lower:]])[[:upper:]]
                    |
                    (?<=\A)[[:upper:]](?=[[:upper:]]+[[:lower:]])
                    |
                    (?<=\A)[[:upper:]](?=[[:lower:]]+[[:upper:]])
                    |
                    (?<=[[:lower:]]$wp)[[:upper:]]
                    |
                    \G(?
                    /x) unless $self->mixed_rx;

    $self->allow_mixed(undef);
    $self->mixed_threshold(0.25) unless $self->mixed_threshold;
    $self->uc_threshold(0.90) unless $self->uc_threshold;
    return $self;
}

sub mixedcase : method {
    my $self = shift;
    $self->_parse unless $self->{_mixedcase};
    return @{$self->{_mixedcase}};
}

sub uppercase : method {
    my $self = shift;
    $self->_parse unless $self->{_uppercase};
    return @{$self->{_uppercase}};
}

sub whitespace : method {
    my $self = shift;
    $self->_parse unless $self->{_whitespace};
    return @{$self->{_whitespace}};
}

sub wc : method {
    my $self = shift;
    $self->_parse unless $self->{_wc};
    return @{$self->{_wc}};
}

sub title : method {
    my $self = shift;
    $self->original(+shift) if @_;
    $self->_parse();
    return $self->titlecase();
}

sub original : method {
    my $self = shift;
    if ( my $new = shift )
    {
        $self->{_parsed} = 0 if $self->{_original} ne $new;
        $self->{_original} = $new;
    }
    return $self->{_original};
}

sub _parse : method {
    my $self = shift;
    return if $self->{_parsed};
    $self->_init();
    my $string = $self->original();
    $self->{_uppercase} = [ $string =~ /[[:upper:]]/g ];
    # TOKEN ARRAYS
    # 0 - type: word|null
    # 1 - content
    # 2 - mixed array
    # 3 - uc array
    # 4 - first word token in queue -- "boolean" -- set in titlecase()

    my $wp = $self->word_punctuation;
    my $mixed_rx = $self->mixed_rx;

    while ( my $token = $self->lexer->($string) )
    {
        my @mixed = $token->[1] =~ /$mixed_rx/g;
        $token->[2] = @mixed ? \@mixed : undef;
        push @{$self->{_mixedcase}}, @mixed if @mixed;
        push @{$self->{_token_queue}}, $token;
        push @{$self->{_wc}}, $token->[1] if $token->[0];
        $self->{_real_length} += length($token->[1]) if $token->[0];
    }
    my $uc_ratio = eval { $self->uppercase / $self->{_real_length} } || 0;
    my $mixed_ratio = eval { $self->mixedcase / $self->{_real_length} } || 0;
    if ( $uc_ratio > $self->uc_threshold ) # too much uppercase to be real
    {
        $_->[1] = lc($_->[1]) for @{ $self->{_token_queue} };
#        carp "Original exceeds uppercase threshold (" .
#            $self->uc_threshold .
#            ") lower casing for pre-processing";
    }
    elsif ( $mixed_ratio > $self->mixed_threshold ) # too mixed to be real
    {
        $_->[1] = lc($_->[1]) for @{ $self->{_token_queue} };
#        carp "Original exceeds mixedcase threshold, lower casing for pre-processing";
    }
    else
    {
        $self->allow_mixed(1);
    }
    $self->{_parsed} = 1;
}

sub lexer : method {
    my $self = shift;
    $self->{_lexer} = shift if $@;
    return $self->{_lexer} if $self->{_lexer};

    my $wp = $self->word_punctuation;
    my $wordish = $self->wordish_rx;

    $self->{_lexer} = sub {
        $_[0] =~ s/\A($wordish)// and return [ "word", "$1" ];
        $_[0] =~ s/\A(.)//s and return [ undef, "$1" ];
        return ();
    };
}

sub titlecase : method {
    my $self = shift;
    # it's up to _parse to clear it
    return $self->{_titlecase} if $self->{_titlecase};

    # first word token
    my $fwt = first { $_->[0] } @{$self->{_token_queue} };
    $fwt->[4] = 1;

    for my $t ( @{ $self->{_token_queue} } )
    {
        if ( $t->[0] )
        {
            if ( $t->[2] and $self->allow_mixed )
            {
                $self->{_titlecase} .= $t->[1];
            }
            elsif ( $t->[4] ) # the initial word token
            {
                $self->{_titlecase} .= ucfirst $t->[1];
            }
            elsif ( $LC{lc($t->[1])} ) # lc/uc checks here
            {
                $self->{_titlecase} .= lc $t->[1];
            }
            else
            {
                $self->{_titlecase} .= ucfirst $t->[1];
            }
        }
        else # not a word token
        {
            $self->{_titlecase} .= $t->[1];
        }
    }
    return $self->{_titlecase};
}

1;

__END__