view release on metacpan or  search on metacpan

lib/Marpa/R2/MetaAST.pm  view on Meta::CPAN

        1, -1
        )
    {
        local $Marpa::R2::Internal::SUBGRAMMAR = $lexical_grammar;
        my $symbol =
            Marpa::R2::Internal::MetaAST::Symbol_List->char_class_to_symbol(
            $parse, $char_class );
        push @symbols, $symbol;
    } ## end for my $char_class ( map { '[' . ( quotemeta $_ ) . ']'...})
    my $list = Marpa::R2::Internal::MetaAST::Symbol_List->combine(@symbols);
    return $list if $Marpa::R2::Internal::SUBGRAMMAR ne 'G1';
    my $lexical_lhs       = $parse->internal_lexeme($string);
    my $lexical_rhs       = $list->names($parse);
    my %lexical_rule      = (
        lhs  => $lexical_lhs,
        rhs  => $lexical_rhs,
        description => "Internal rule for single-quoted string $string",
        mask => [ map { ; 1 } @{$lexical_rhs} ],
    );
    push @{ $parse->{rules}->{$lexical_grammar} }, \%lexical_rule;
    my $g1_symbol =
        Marpa::R2::Internal::MetaAST::Symbol_List->new($lexical_lhs);
    return $g1_symbol;
} ## end sub Marpa::R2::Internal::MetaAST_Nodes::single_quoted_string::evaluate

package Marpa::R2::Internal::MetaAST::Symbol_List;

use English qw( -no_match_vars );

sub new {
    my ( $class, $name ) = @_;
    return bless { names => [ q{} . $name ], mask => [1] }, $class;
}

sub combine {
    my ( $class, @lists ) = @_;
    my $self = {};
    $self->{names} = [ map { @{ $_->names() } } @lists ];
    $self->{mask}  = [ map { @{ $_->mask() } } @lists ];
    return bless $self, $class;
} ## end sub combine

sub Marpa::R2::Internal::MetaAST::char_class_to_re {
    my ($cc_components) = @_;
    die if ref $cc_components ne 'ARRAY';
    my ( $char_class, $flags ) = @{$cc_components};
    $flags = $flags ? '(' . q{?} . $flags . ')' : q{};
    my $regex;
    my $error;
    if ( not defined eval { $regex = qr/$flags$char_class/xms; 1; } ) {
        $error = qq{Problem in evaluating character class: "$char_class"\n};
        $error .= qq{  Flags were "$flags"\n} if $flags;
        $error .= $EVAL_ERROR;
    }
    return $regex, $error;
}

sub Marpa::R2::Internal::MetaAST::flag_string_to_flags {
    my ($raw_flag_string) = @_;
    return q{} if not $raw_flag_string;
    my @raw_flags = split m/:/xms, $raw_flag_string;
    my %flags = ();
    RAW_FLAG: for my $raw_flag (@raw_flags) {
        next RAW_FLAG if not $raw_flag;
        if ( $raw_flag eq 'i' ) {
            $flags{'i'} = 1;
            next RAW_FLAG;
        }
        if ( $raw_flag eq 'ic' ) {
            $flags{'i'} = 1;
            next RAW_FLAG;
        }
        Carp::croak(
            qq{Bad flag for character class\n},
            qq{  Flag string was $raw_flag_string\n},
            qq{  Bad flag was $raw_flag\n}
        );
    } ## end RAW_FLAG: for my $raw_flag (@raw_flags)
    my $cooked_flags = join q{}, sort keys %flags;
    return $cooked_flags;
} ## end sub flag_string_to_flags

# Return the character class symbol name,
# after ensuring everything is set up properly
sub char_class_to_symbol {
    my ( $class, $parse, $char_class ) = @_;

    my $end_of_char_class = rindex $char_class, q{]};
      my $unmodified_char_class = substr $char_class, 0, $end_of_char_class+1;
      my $raw_flags = substr $char_class, $end_of_char_class+1;
    my $flags = Marpa::R2::Internal::MetaAST::flag_string_to_flags($raw_flags);
    my $subgrammar = $Marpa::R2::Internal::SUBGRAMMAR;

    # character class symbol name always start with TWO left square brackets
    my $symbol_name = '[' . $unmodified_char_class . $flags . ']';
    $parse->{character_classes} //= {};
    my $cc_hash = $parse->{character_classes};
    my ( undef, $symbol ) = $cc_hash->{$symbol_name};
    if ( not defined $symbol ) {

        my $cc_components = [$unmodified_char_class, $flags];

        # Fast fail on badly formed char_class -- we re-evaluate the regex just in time
        # before we register characters.
        my ( $regex, $eval_error ) =
            Marpa::R2::Internal::MetaAST::char_class_to_re($cc_components);
        Carp::croak( 'Bad Character class: ',
            $char_class, "\n", 'Perl said ', $eval_error )
            if not $regex;

        $symbol =
            Marpa::R2::Internal::MetaAST::Symbol_List->new($symbol_name);
        $cc_hash->{$symbol_name} = [ $cc_components, $symbol ];
        $parse->symbol_names_set(
            $symbol_name,
            $subgrammar,
            {   dsl_form     => $char_class,
                display_form => $char_class,
                description  => "Character class: $char_class"
            }
        );