File Coverage

blib/lib/String/CaseProfile.pm

Criterion	Covered	Total	%
statement	159	169	94.0
branch	77	86	89.5
condition	21	33	63.6
subroutine	15	15	100.0
pod	3	3	100.0
total	275	306	89.8

package String::CaseProfile;

use 5.008;
use strict;
use warnings;
use Carp qw(carp);

use Exporter;
use base 'Exporter';
our @EXPORT_OK = qw(
                    get_profile
                    set_profile
                    copy_profile
                   );

our %EXPORT_TAGS = ( 'all' => [ @EXPORT_OK ] );

our $VERSION = '0.18';


my $word_re =  qr{
                    \b(?:\p{Lu}{1,2}\.)+(?:\P{L}|$)
                    |
                    \b\p{Lu}{1,2}\/\p{Lu}{1,2}\b
                    |
                    (?:
                        \p{L}
                        |
                        (?<=\p{L})[-'\x92_&](?=\p{L})
                        |
                        (?<=[lL])\xB7(?=[lL])
                        |
                        \d
                    )+
                 }x;


my %types = (
                '1st_uc' => 'f',
                'all_uc' => 'u',
                'all_lc' => 'l',
                'other'  => 'o',
             );


sub get_profile {
    my $string = shift;

    my (@excluded, $strict);

    if (ref $_[0] eq 'HASH') {

        if ($_[0]->{exclude}) {
            @excluded = @{$_[0]->{exclude}};
        }

        $strict   = $_[0]->{strict};

    } else {

        if ( defined $_[0] ) {
            @excluded = @{ $_[0]} ;
        }

    }

    # read excluded words, if any
    my %excluded;
    if ( @excluded > 0 ) {
        $excluded{$_}++ foreach ( @excluded );
    }

    my @words = $string =~ /($word_re)/g;

    my @word_types;
    if ( @words == 1 && length $words[0] == 1 ) {

        if ($words[0] =~ /^\p{Lu}$/) {

            push @word_types, 'all_uc';

        } elsif ($words[0] =~ /^\p{Ll}$/) {

            push @word_types, 'all_lc';

        } else {

            push @word_types, 'other';
        }

    } else {

        @word_types = map {

                            _exclude($_, \%excluded)
                            ?
                            'excluded'
                            :
                            _word_type($_)

                          } @words;

    }

    my %profile;
    ( $profile{fold}, $profile{string_type} ) = _string_type($strict, @word_types);

    for (my $i = 0; $i <= $#words; $i++) {
        push @{$profile{words}}, {
                                    word => $words[$i],
                                    type => $word_types[$i],
                                 }
    }

    $profile{report} = _create_report($string, \%profile);

    return %profile;
}


sub _exclude {
    my ($word, $excluded_href) = @_;

    return 1 if $excluded_href->{$word};

    if ($word =~ /[-']/) {
        my @pieces = split /[-']/, $word;
        my @excluded = grep { $excluded_href->{$_} } @pieces;
        if (@excluded) { return 1 } else { return 0 };
    } else {
        return 0;
    }
}

sub _create_report {
    my ($string, $prof_href) = @_;

    my %prof = %{$prof_href};

    my $report;
    $report .= "String:  $string\n";
    $report .= "Type:    $prof{string_type}\n";
    $report .= "Pattern: $prof{fold}\n\n";
    $report .= "Word                Type\n--------------------------\n";
    for ( my $i = 0; $i < scalar(@{$prof{words}}); $i++ ) {
        $report .= sprintf "%-20s%-20s\n", $prof{words}[$i]->{word},
                                           $prof{words}[$i]->{type};
    }

    return $report;
}


sub set_profile {
    my ($string, %ref_profile) = @_;

    my %string_profile = get_profile($string, $ref_profile{exclude});

    my @words = map { $_->{word} } @{$string_profile{words}};
    my @word_types = map { $_->{type} } @{$string_profile{words}};

    my $force = $ref_profile{'force_change'};

    # validate string_type
    my ($legal, $ref_string_type);
    if ($ref_profile{string_type}) {
        $ref_string_type = $ref_profile{string_type};
        if ($types{$ref_string_type} && $ref_string_type ne 'other') {
            $legal = 1;
        } elsif ($ref_string_type eq 'other') {
            return $string;
        } else {
            carp "Illegal value of string_type";
        }
    }

    my @transformed;

    if ($legal) {
        if ($ref_string_type eq '1st_uc') {
            if ($word_types[0] eq 'excluded') {
                $transformed[0] = $words[0];
            } else {
                $transformed[0] = _transform(
                                              '1st_uc',
                                              $words[0],
                                              $word_types[0],
                                              $force
                                            );
            }
            for (my $i = 1; $i <= $#words; $i++) {
                if ($word_types[$i] eq 'excluded') {
                    push @transformed, $words[$i];
                } else {
                    push @transformed, _transform(
                                                  'all_lc',
                                                  $words[$i],
                                                  $word_types[$i],
                                                  $force
                                                 );
                }
            }
        } else {
            for (my $i = 0; $i <= $#words; $i++) {
                if (
                    $word_types[$i] eq 'excluded'
                    && $ref_string_type ne 'all_uc'
                   ) {
                        push @transformed, $words[$i];
                } else {
                    push @transformed, _transform(
                                                  $ref_string_type,
                                                  $words[$i],
                                                  $word_types[$i],
                                                  $force
                                                 );
                }
            }
        }

    # custom profile
    } elsif ($ref_profile{custom}) {

        # validate default type
        my ($type, $default_type);
        if ($ref_profile{custom}->{default}) {
            $type = $ref_profile{custom}->{default};
            if ($types{$type} && $types{$type} ne 'other') {
                $default_type = $type;
            } else {
                carp "Illegal default value in custom profile";
            }
        }

        for (my $i = 0; $i <= $#word_types; $i++) {

            my $in_index = $ref_profile{custom}->{index}->{$i};
            my $trigger_type = $ref_profile{custom}->{$word_types[$i]};

            if ($in_index) {
                if (
                    $word_types[$i] eq 'excluded'
                    && $in_index ne 'all_uc'
                   ) {
                        push @transformed, $words[$i];
                } elsif ($in_index ne $word_types[$i]) {
                    push @transformed, _transform(
                                                  $in_index,
                                                  $words[$i],
                                                  $word_types[$i],
                                                  $force
                                                 );
                } else {
                    push @transformed, $words[$i];
                }
            } elsif ($trigger_type) {
                if (
                    $word_types[$i] eq 'excluded'
                    && $ref_string_type ne 'all_uc'
                   ) {
                        push @transformed, $words[$i];
                } else {
                    push @transformed, _transform(
                                                  $trigger_type,
                                                  $words[$i],
                                                  $word_types[$i],
                                                  $force
                                                 );
                }

            } elsif ($default_type) { # use default type
                if (
                    $word_types[$i] eq 'excluded'
                    && $ref_string_type ne 'all_uc'
                   ) {
                        push @transformed, $words[$i];
                } else {
                    push @transformed, _transform(
                                                  $default_type,
                                                  $words[$i],
                                                  $word_types[$i],
                                                  $force
                                                 );
                }
            } else {
                push @transformed, $words[$i];
            }
        }
    }

    # transform string
    if (@transformed) {
        for (my $i = 0; $i <= $#words; $i++) {
            $string =~ s/\b$words[$i]\b/$transformed[$i]/;
        }
    }

    return $string;
}


sub copy_profile {
    my %options = @_;

    my $from    = $options{from};
    my $to      = $options{to};
    my $strict  = $options{strict};
    my $exclude = $options{exclude};

    if ( $from && $to ) {

        if ( $exclude || $strict ) {

            my %ref_profile = get_profile( $from, {
                                                   exclude => $exclude,
                                                   strict => $strict
                                                  }
                                         );

            $ref_profile{exclude} = $exclude;

            return set_profile( $to, %ref_profile );

        } else {

            return set_profile($options{to}, get_profile($options{from}));

        }

    } elsif ( !$from && !$to ) {

        carp "Missing parameters\n";
        return '';

    } elsif ( !$from ) {

        carp "Missing reference string\n";
        return $to;

    } else {

        carp "Missing target string\n";
        return '';

    }
}


sub _word_type {
    my ($word) = @_;

    if ($word =~ /^[bcdfghjklmnpqrstvwxyz]$/i) {
        return 'other';
    } elsif ($word =~ /^\p{Lu}(?:\p{Ll}|[-'\x92\xB7])*$/) {
        return '1st_uc';
    } elsif ($word =~ /^(?:\p{Ll}|[-'\x92\xB7])+$/) {
        return 'all_lc';
    } elsif ($word =~ /^(?:\p{Lu}|[-'\x92\xB7])+$/) {
        return 'all_uc';
    } else {
        return 'other';
    }

}


sub _string_type {

    my $strict = shift;
    my @types = @_;

    my $types_str = join "", map { $types{$_} } grep { $_ ne 'excluded' } @types;

    # remove 'other' word types
    my $clean_str = $types_str;
    $clean_str =~ s/o//g unless $strict;

    my $string_type;

    if ($clean_str =~ /^fl*$/) {
        $string_type = '1st_uc';
    } elsif ($clean_str =~ /^u+$/) {
        $string_type = 'all_uc';
    } elsif ($clean_str =~ /^l+$/) {
        $string_type = 'all_lc';
    } else {
        $string_type = 'other';
    }

    return ($types_str, $string_type);
}


sub _transform {
    my ($type, $word, $word_type, $force) = @_;

    return $word if ($word_type eq 'other' && !$force);

    my %dispatch = (
                    '1st_uc' => ucfirst(lc($word)),
                    'all_uc' => uc($word),
                    'all_lc' => lc($word),
                    'other'  => $word,
                   );

    $dispatch{$type};
}


1;
__END__