view release on metacpan or  search on metacpan

lib/PPIx/Shorthand.pm  view on Meta::CPAN

            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 ><ies>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 {