File Coverage

blib/lib/PPIx/Shorthand.pm

Criterion	Covered	Total	%
statement	66	66	100.0
branch	14	14	100.0
condition			n/a
subroutine	14	14	100.0
pod	5	5	100.0
total	99	99	100.0

package PPIx::Shorthand;

use utf8;
use 5.008001;

use strict;
use warnings;

use Readonly;
use Carp;

use version; our $VERSION = qv('v1.2.0');

use Exporter qw< import >;

our @EXPORT_OK =
    qw<
        get_ppi_class
    >;
our %EXPORT_TAGS    = (
    all => [@EXPORT_OK],
);


Readonly my $EMPTY_STRING => q<>;

Readonly my @PPI_TOKEN_CLASSES => qw<
   PPI::Element
      PPI::Node
         PPI::Document
            PPI::Document::Fragment
         PPI::Statement
            PPI::Statement::Package
            PPI::Statement::Include
            PPI::Statement::Sub
               PPI::Statement::Scheduled
            PPI::Statement::Compound
            PPI::Statement::Break
            PPI::Statement::Given
            PPI::Statement::When
            PPI::Statement::Data
            PPI::Statement::End
            PPI::Statement::Expression
               PPI::Statement::Variable
            PPI::Statement::Null
            PPI::Statement::UnmatchedBrace
            PPI::Statement::Unknown
         PPI::Structure
            PPI::Structure::Block
            PPI::Structure::Subscript
            PPI::Structure::Constructor
            PPI::Structure::Condition
            PPI::Structure::List
            PPI::Structure::For
            PPI::Structure::Given
            PPI::Structure::When
            PPI::Structure::Unknown
      PPI::Token
         PPI::Token::Whitespace
         PPI::Token::Comment
         PPI::Token::Pod
         PPI::Token::Number
            PPI::Token::Number::Binary
            PPI::Token::Number::Octal
            PPI::Token::Number::Hex
            PPI::Token::Number::Float
               PPI::Token::Number::Exp
            PPI::Token::Number::Version
         PPI::Token::Word
         PPI::Token::DashedWord
         PPI::Token::Symbol
            PPI::Token::Magic
         PPI::Token::ArrayIndex
         PPI::Token::Operator
         PPI::Token::Quote
            PPI::Token::Quote::Single
            PPI::Token::Quote::Double
            PPI::Token::Quote::Literal
            PPI::Token::Quote::Interpolate
         PPI::Token::QuoteLike
            PPI::Token::QuoteLike::Backtick
            PPI::Token::QuoteLike::Command
            PPI::Token::QuoteLike::Regexp
            PPI::Token::QuoteLike::Words
            PPI::Token::QuoteLike::Readline
         PPI::Token::Regexp
            PPI::Token::Regexp::Match
            PPI::Token::Regexp::Substitute
            PPI::Token::Regexp::Transliterate
         PPI::Token::HereDoc
         PPI::Token::Cast
         PPI::Token::Structure
         PPI::Token::Label
         PPI::Token::Separator
         PPI::Token::Data
         PPI::Token::End
         PPI::Token::Prototype
         PPI::Token::Attribute
         PPI::Token::Unknown
>;

Readonly my %PPI_TOKEN_CLASSES => map { $_ => 1 } @PPI_TOKEN_CLASSES;

Readonly my $PPI_PREFIX_LENGTH => length 'PPI::';

Readonly my @NON_UNIQUE_BASENAME_CLASSES => qw<
   Data
   End
   Given
   Regexp
   Structure
   Unknown
   When
>;

Readonly my $GLOBAL_INSTANCE => PPIx::Shorthand->new();


sub get_ppi_class {
    my ($name) = @_;

    return $GLOBAL_INSTANCE->get_class($name);
} # end get_ppi_class()


sub new {
    my ($class) = @_;

    my $self = bless {}, $class;

    foreach my $ppi_class (@PPI_TOKEN_CLASSES) {
        $self->{lc $ppi_class} = $ppi_class;
        $self->_add_plural($ppi_class, $ppi_class);

        my $no_prefix = lc substr $ppi_class, $PPI_PREFIX_LENGTH;
        $self->{$no_prefix} = $ppi_class;
        $self->_add_plural($no_prefix, $ppi_class);

        my @components = split m/::/xms, $no_prefix;
        foreach my $separator ( qw< _ - . : >, $EMPTY_STRING ) {
            my $shorthand = join $separator, @components;
            $self->{$shorthand} = $ppi_class;
            $self->_add_plural($shorthand, $ppi_class);
        } # end foreach

        $self->{ $components[-1] } = $ppi_class;
        $self->_add_plural($components[-1], $ppi_class);
    } # end foreach

    foreach my $basename_class (@NON_UNIQUE_BASENAME_CLASSES) {
        my $fullname = "PPI::Token::$basename_class";

        $self->{ lc $basename_class } = $fullname;
        $self->_add_plural($basename_class, $fullname);
    } # end foreach

    return $self;
} # end new()

sub _add_plural {
    my ($self, $basename_class, $ppi_class) = @_;
    my $plural = lc $basename_class;

    return if $plural =~ m/ \b word \z /xms; # What a wonderous exception.

    $plural =~ s< ( [^sy] ) \z ><${1}s>xms;
    $plural =~ s< y \z >xms;

    $self->{$plural} = $ppi_class;

    return;
}


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

    croak 'Must specify name.' if not $name;

    return $self->{ lc $name };
} # end get_class()


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

    croak 'Must specify name.' if not $name;
    croak 'Must specify PPI class.' if not $ppi_class;
    croak qq<"$ppi_class" is not a known subclass of PPI::Element.>
        if not $PPI_TOKEN_CLASSES{$ppi_class};


    $self->{lc $name} = $ppi_class;

    return;
} # end add_class_translation()


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

    croak 'Must specify name.' if not $name;
    croak qq<"$name" is not a known translation.>
        if not delete $self->{lc $name};

    return;
} # end remove_class_translation()


1;

__END__