File Coverage

blib/lib/Text/Naming/Convention.pm

Criterion	Covered	Total	%
statement	87	92	94.5
branch	41	48	85.4
condition	26	27	96.3
subroutine	9	9	100.0
pod	4	4	100.0
total	167	180	92.7

package Text::Naming::Convention;

use warnings;
use strict;
use Carp;

use base qw/Exporter/;
our @EXPORT_OK = qw/naming renaming default_convention default_keep_uppers/;

our $VERSION = '0.06';

my @_valid_conventions = ( '_', '-', 'UpperCamelCase', 'lowerCamelCase' );
my $_default_convention = '_';

# keep the upper case for word like 'RFC', but not 'bAr', that only take
# effect for CamelCase conventions, and not the first word if it's
# lowerCamelCase.
my $_default_keep_uppers = 1;

=head2 default_convention

get or set default convention, default is '_'.
valid values are ( '_', '-', 'UpperCamelCase', 'lowerCamelCase' ).
return the default convention.

=cut

sub default_convention {
    my $convention = shift;
    return $_default_convention unless $convention;

    if ( grep { $_ eq $convention } @_valid_conventions ) {
        $_default_convention = $convention;
    }
    else {
        carp "invalid convention: $convention";
    }
    return $_default_convention;
}

=head2 default_keep_uppers

keep words of uppers or not, here uppers means all uppers like 'BAR', not 'bAr'.
default value is true

=cut

sub default_keep_uppers {
    if (@_) {
        $_default_keep_uppers = shift;
    }
    return $_default_keep_uppers;

}

=head2 naming

given a list of words, return the named string
the last arg can be hashref that supplies option like:
{ convention => 'UpperCamelCase' }

=cut

sub naming {
    my @words       = @_;
    my $convention  = $_default_convention;
    my $keep_uppers = $_default_keep_uppers;

    if ( ref $words[-1] eq 'HASH' ) {
        my $option = pop @words;

        # the last element is option
        if ( _is_valid_convention( $option->{convention} ) ) {
            $convention = $option->{convention};
        }
        else {
            carp "invlid convention: $option->{convention}";
        }

        if ( exists $option->{keep_uppers} ) {
            $keep_uppers = $option->{keep_uppers};
        }
    }

    for my $word (@words) {
        next if $keep_uppers && $word =~ /^[A-Z]+$/ && $convention =~ /Camel/;
        $word = lc $word;
    }

    if ( $convention eq '_' ) {
        return join '_', @words;
    }
    elsif ( $convention eq '-' ) {
        return join '-', @words;
    }
    elsif ( $convention eq 'UpperCamelCase' ) {
        return join '', map { ucfirst } @words;
    }
    elsif ( $convention eq 'lowerCamelCase' ) {
        my $first = shift @words;
        $first = lc $first;
        return $first . join '', map { ucfirst } @words;
    }
    else {
        carp "invalid $convention: $convention";
    }
}

sub _is_valid_convention {
    my $convention = shift;
    return unless $convention;
    return grep { $_ eq $convention } @_valid_conventions;
}

=head2 renaming

given a name, renaming it with another convention.
the last arg can be hashref that supplies option like:
{ convention => 'UpperCamelCase' }

return the renamed one.

if the convention is the same as the name, just return the name.

if without arguments and $_ is defined and it's not a reference, renaming $_


=cut

sub renaming {

    my ($name, $option);
    if ( scalar @_ ) {
        $name        = shift;
        $option      = shift;
    }
    elsif ( defined $_ && ! ref $_ ) {
        $name = $_;
    }
    else {
        return
    }

    my $convention  = $_default_convention;

    if ( $option && ref $option eq 'HASH' ) {

        # the last element is option
        if ( _is_valid_convention( $option->{convention} ) ) {
            $convention = $option->{convention};
        }
        else {
            carp "invlid convention: $option->{convention}";
        }

    }

    if ( $name =~ /(_)/ || $name =~ /(-)/ ) {
        my $from = $1;
        return $name if $convention eq $from;

        if ( ( $convention eq '_' || $convention eq '-' ) )
        {
            $name =~ s/$from/$convention/g;
            return $name;
        }
        else {
            $name =~ s/$from(.)/uc $1/ge;
            return ucfirst $name if $convention eq 'UpperCamelCase';
            return $name;
        }
    }
    else {
        if ( $convention eq '_' || $convention eq '-' ) {
            # massage the first word, FOOBar => fooBar
            $name =~ s/^([A-Z])([^A-Z])/lc( $1 ) . $2/e;
            $name =~ s/^([A-Z]+)(?![a-z])/lc $1/e;

            # massage the last word, FooBAR => FooBar
            $name =~ s/(?<=[A-Z])([A-Z]+(\d+)?)$/lc( $1 )/e;

            # e.g. fooBARBaz => foo_bar_baz
            # first step: fooBARBaz => fooBarBaz
            # second step: fooBarBaz => foo_bar_baz
            $name =~ s/([A-Z]+)([A-Z])/(ucfirst lc $1 ) . $2/ge;
            $name =~ s/([^A-Z])([A-Z])/$1 . $convention . lc $2/ge;
            # tr all the weirdly left [A-Z]
            $name =~ tr/A-Z/a-z/;
        }
        else {
            my $from = 'UpperCamelCase';
            $from = 'lowerCamelCase' if $name =~ /^[^A-Z]/;
            if ( $convention eq 'UpperCamelCase' && $convention ne $from ) {
                return ucfirst $name;
            }
            elsif ( $convention eq 'lowerCamelCase' && $convention ne $from ) {
                $name =~ s/^([A-Z])([^A-Z])/lc( $1 ) . $2/e;
                $name =~ s/^([A-Z]+)(?![a-z])/lc $1/e;
                return $name;
            }
        }
    }
    return $name;
}

1;

__END__