File Coverage

blib/lib/Parse/Constructor/Arguments.pm

Criterion	Covered	Total	%
statement	1	3	33.3
branch			n/a
condition			n/a
subroutine	1	1	100.0
pod			n/a
total	2	4	50.0

package Parse::Constructor::Arguments;
our $VERSION = '0.091570';


#ABSTRACT: Parse Moose constructor arguments using PPI
use Moose;
use PPI;
use MooseX::Types::Moose(':all');

BEGIN
{
    *DEBUG = sub () { 0 } unless defined *DEBUG{CODE};
}

has document =>
(
    is          => 'ro',
    isa         => 'PPI::Document',
    lazy_build  => 1,
);

has current =>
(
    is          => 'ro',
    isa         => 'PPI::Element',
    lazy        => 1,
    builder     => '_build_current',
    writer      => '_set_current',
);

has input   =>
(
    is          => 'ro',
    isa         => Str,
    required    => 1,
);

sub _build_current
{
    my $self = shift;
    # our first token should be significant
    my $token = $self->document->first_token;

    if($token->significant)
    {
        return $token;
    }

    while(1)
    {
        $token = $token->next_token;
        die "No more significant tokens in stream: '$token'" if not $token;
        return $token if $token->significant;
    }
}

sub _build_document
{
    my $self = shift;
    my $input = $self->input;
    my $document = PPI::Document->new(\$input);
    return $document;
}


    # states:
    # 0 - Looking for a Word or Literal to use as a key
    # 1 - Looking for a comma operator
    # 2 - Looking for a value
sub parse
{
    my $class = shift;
    my $str = shift;
    my $self = $class->new(input => $str);

    # grab the current token, which should be the first significant token
    my $token = $self->current;

    # what we are building
    my %data;

    # state related parsing variables
    my $key;
    my $state = 0;

    while(1)
    {
        if($state == 0)
        {
            if($token->isa('PPI::Token::Word'))
            {
                DEBUG && warn "Word Key: $token";
                $key = $token->content;
            }
            elsif($token->isa('PPI::Token::Quote::Single') or $token->isa('PPI::Token::Quote::Literal'))
            {
                DEBUG && warn "Quote Key: $token";
                $key = $token->literal;
            }
            else
            {
                die "Invalid state: Expected a Word or Literal but got '$token'";
            }

            $state++;
        }
        elsif($state == 1)
        {
            if($token->isa('PPI::Token::Operator') && $token->content =~ /,|=>/)
            {
                DEBUG && warn "Comma: $token";
            }
            else
            {
                die "Invalid state: Expected a Comma operator, but got '$token'";
            }

            $state++;
        }
        elsif($state == 2)
        {
            if($token->isa('PPI::Token::Quote::Single') or $token->isa('PPI::Token::Quote::Literal'))
            {
                DEBUG && warn "Quote Value: $token";
                $data{$key} = $token->literal;
            }
            elsif($token->isa('PPI::Token::Structure'))
            {
                my $content = $token->content;
                die "Unsupported structure '$content'"
                    if $content ne '[' and $content ne '{';

                DEBUG && warn 'Constructor: ' . $token->parent;
                $data{$key} = $self->process;
            }
            elsif($token->isa('PPI::Token::Number'))
            {
                DEBUG && warn "Number: $token";
                $data{$key} = $token->literal;
            }
            else
            {
                die "Invalid state: Expected Literal, Number or Structure, but got '$token'";
            }

            $state++;
            $key = undef;
        }
        elsif($state == 3)
        {
            if($token->isa('PPI::Token::Operator') && $token->content =~ /,|=>/)
            {
                DEBUG && warn "Comma: $token";
            }
            else
            {
                die "Invalid state: Expected a Comma operator, but got '$token'";
            }

            $state = 0;
        }

        if(my $t = $self->peek_next_token)
        {
            DEBUG && warn "Peeked and took $t";
            $token = $t;
            $self->_set_current($token);
        }
        else
        {
            DEBUG && warn "Peeked and there were no more tokens";
            last;
        }
    }

    return \%data;
}

sub process
{
    my $self = shift;
    my ($data, $applicator, $terminator, $word, $token);

    if($self->current->content eq '[')
    {
        DEBUG && warn "Processing Array...";
        $data = [];
        $terminator = ']';
        $applicator = sub { push(@{$_[0]}, $_[2]) };
    }
    else
    {
        DEBUG && warn "Processing Hash...";
        $data = {};
        $terminator = '}';
        $applicator = sub { $_[0]->{$_[1]} = $_[2] };
    }

    $token = $self->get_next_significant;

    while($token->content ne $terminator)
    {
        # words are stored until we know if they are a key or a value
        if($token->isa('PPI::Token::Word'))
        {
            DEBUG && warn "Process Word: $token";
            $word = $token->content;
            $token = $self->get_next_significant;
        }

        if($token->isa('PPI::Token::Number'))
        {
            DEBUG && warn "Process Number: $token";
            $applicator->($data, $word, $token->content);
            $word = undef;
        }
        elsif($token->isa('PPI::Token::Structure'))
        {
            DEBUG && warn "Process Structure: $token";
            $applicator->($data, $word, $self->process);
            $word = undef;
        }
        elsif($token->isa('PPI::Token::Quote::Single') || $token->isa('PPI::Token::Quote::Literal'))
        {
            DEBUG && warn "Process Quote: $token";
            if(!$word && $terminator eq '}')
            {
                DEBUG && warn "Process Hash Key Quote: $token";
                $word = $token->literal;
                $token = $self->get_next_significant;
                next;
            }

            $applicator->($data, $word, $token->literal);
            $word = undef;
        }
        elsif($token->isa('PPI::Token::QuoteLike::Words') and $terminator ne '}')
        {
            # This seems to be the only way to get the fuckin data from this token
            # which is completely retarded. Need to file a bug with PPI on this
            DEBUG && warn "Process QuoteLike Words: $token";

            my $operator = $token->{operator};
            my $separator = $token->{separator};
            my $content = $token->content;
            $content =~ s/$operator|$separator//g;

            $applicator->($data, undef, $_) for split(' ', $content);
        }
        elsif($token->isa('PPI::Token::Operator'))
        {
            DEBUG && warn "Process Comma: $token";
            if($token->content =~ /,|=>/)
            {
                $token = $self->get_next_significant;
                next;
            }
        }

        # now we process our words if they haven't been consumed
        DEBUG && warn "Process Add Word: $word" if $word;
        $applicator->($data, undef, $word) if $word;
        $word = undef;

        $token = $self->get_next_significant;
    }

    DEBUG && warn "Returning From Processing";
    return $data;
}

sub get_next_significant
{
    my $self = shift;
    my $token = $self->current;

    DEBUG && warn "Current: $token";
    while(1)
    {
        $token = $token->next_token;
        die 'No more significant tokens in stream: '. $self->document if not $token;

        if(!$token->significant)
        {
            next;
        }

        DEBUG && warn "Significant: $token";
        $self->_set_current($token);
        return $token;
    }
}

sub peek_next_token
{
    my $self = shift;
    my $token = $self->current;

    while(1)
    {
        $token = $token->next_token;
        return 0 if not $token;
        return $token if $token->significant;
    }
}

__PACKAGE__->meta->make_immutable;

1;



=pod

=head1 NAME

Parse::Constructor::Arguments - Parse Moose constructor arguments using PPI

=head1 VERSION

version 0.091570

=head1 DESCRIPTION
Parse::Constructor::Arguments parses Moose-style constructor arguments into a
usable data structure using PPI to accomplish the task. It exports nothing
and the only public method is a class method: parse.

=head1 METHODS

=head2 parse(ClassName $class: Str $str)

This is a class method used for parsing constructor arguments. It takes a
string that will be used as the basis of the PPI::Document. Returns a hashref
where the keys are the named arguments and the values are the actual values to
those named arguments. (eg. q|foo => ['bar']| returns { foo => ['bar'] })

=head1 AUTHOR

  Nicholas Perez <[e-mail]>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2009 by Nicholas Perez.

This is free software; you can redistribute it and/or modify it under
the same terms as perl itself.

=cut



__END__