File Coverage

blib/lib/RPSL/Parser.pm

Criterion	Covered	Total	%
statement	78	81	96.3
branch	16	22	72.7
condition	1	3	33.3
subroutine	14	14	100.0
pod	4	4	100.0
total	113	124	91.1

package RPSL::Parser;
require 5.006_001;
use strict;
use warnings;
use base qw( Class::Accessor );
__PACKAGE__->mk_accessors(
    qw( text type tokens key comment
      object omit_key order )
);

our $VERSION = "0.039_001";

# Public Interface Methods

# Constructor
sub new {
    my $class = shift;
    my $self  = bless {
        __META => {
            comment => {},
            object  => {},
        }
    }, $class;
    return $self;
}

# service method
sub parse {
    my $self = shift;
    unless ( UNIVERSAL::isa( $self, q{RPSL::Parser} ) ) {
        $self = RPSL::Parser->new;
    }
    return $self->_read_text(@_)->_tokenize->_build_parse_tree->_parse_tree;
}

# Private Interface Methods

# Overriding Class::Accessor::get
sub get {
    my ( $self, @keys ) = @_;
    return wantarray
      ? @{ $self->{__META} }{@keys}
      : ${ $self->{__META} }{ $keys[0] };
}

# Overriding Class::Accessor::set
sub set {
    my ( $self, $key, $value ) = @_;
    return $self->{__META}{$key} = $value;
}

# Other private methods
sub _read_text {
    my ( $self, @input ) = @_;
    my $data;
    if (   UNIVERSAL::isa( $input[0], 'GLOB' )
        or UNIVERSAL::isa( $input[0], 'IO::Handle' ) )
    {
        local $/;
        $data = <$input[0]>;
    }
    else {
        $data = join '', @input;
    }
    $self->text($data);
    return $self;
}

sub _cleanup_attribute {
    my ( $self, $value ) = @_;
    return unless $value;
    $value =~ s/\n\s+/\n/gosm;
    $value =~ s/^\s+|\s+$//go;
    return $value;
}

sub _tokenize {
    my $self = shift;
    my $text = $self->text;
    study $text;
    my @tokens = $text =~ m{
        ^(?:
            # Look for an attribute name ...
            ( [a-z0-9][a-z0-9_-]+[a-z0-9] ):
            # ... followed by zero or more horizontal spaces ...
            [\t ]*
            # ... followed by a value ...
            ( .*?
                # ... and all valid continuation lines.
                (?: \n [\s+] .* ? )*
            )
        )$
    }mixg;
    $self->tokens( \@tokens );
    return $self;
}

sub _store_attribute {
    my ( $self, $key, $value ) = @_;
    $value = $self->_cleanup_attribute($value);

    # Store the value
    if ( exists $self->object->{$key} ) {
        if ( !UNIVERSAL::isa( $self->object->{$key}, 'ARRAY' ) ) {
            $self->object->{$key} = [ $self->object->{$key} ];
        }
        push @{ $self->object->{$key} }, $value;
    }
    else {
        $self->object->{$key} = $value;
    }
    return $self;
}

sub _store_comment {
    my ( $self, $order, $value ) = @_;
    return unless defined $value;
    if ( $value =~ s{#(.*)}{} ) {
        $self->comment->{$order} = $self->_cleanup_attribute($1);
    }
    return $value;
}

sub _build_parse_tree {
    my $self   = shift;
    my @tokens = @{ $self->tokens };
    my ( @order, @omit_key );
    while ( my ( $key, $value ) = splice @tokens, 0, 2 ) {

        # Save the order
        push @order, $key;

        # Handle multi-line comments
        if ( defined $value ) {
            my @parts = split qr{\n\+?\s*}, $value;
            if ( @parts > 1 ) {    # too much, put it back.
                unshift @tokens, $key, $_ for reverse @parts[ 1 .. $#parts ];
                $value = $parts[0];
                my $count = $#order;
                map { push @omit_key, $count + $_ } 1 .. $#parts;
            }
        }

        $value = $self->_store_comment( $#order, $value );
        $self->_store_attribute( $key, $value );
    }    # end while

    # Fill in the object's meta-attributes
    $self->order( \@order );
    $self->omit_key( \@omit_key );
    $self->type( $order[0] );

    # Stores the object primary key value
    my $primary_key = $self->object->{ $order[0] };
    $primary_key = $primary_key->[0]
      if UNIVERSAL::isa( $primary_key, 'ARRAY' );
    $primary_key =~ s{\s*\#.*$}{};
    $self->key($primary_key);

    # Done!
    return $self;
}

sub _parse_tree {
    my $self = shift;
    return {
        data => $self->object,
        type => $self->type,
        key  => $self->key,
        meta => {
            order    => $self->order,
            comment  => $self->comment,
            omit_key => $self->omit_key,
        },
    };
}

1;
__END__