File Coverage

blib/lib/Devel/Declare/Parser.pm

Criterion	Covered	Total	%
statement	273	298	91.6
branch	90	122	73.7
condition	18	20	90.0
subroutine	67	74	90.5
pod	47	48	97.9
total	495	562	88.0

package Devel::Declare::Parser;
use strict;
use warnings;

require Devel::Declare::Interface;
use Devel::Declare;
use B::Compiling;
use B::Hooks::EndOfScope;
use Scalar::Util qw/blessed/;
use Carp;

our $VERSION = '0.018';

sub new {
    my $class = shift;
    my ( $name, $dec, $offset ) = @_;
    return bless( [ $name, $dec, $offset, $offset ], $class );
}

sub process {
    my $self = shift;
    return unless $self->pre_parse();
    return unless $self->parse();
    return unless $self->post_parse();
    return unless $self->rewrite();
    return unless $self->write_line();
    return unless $self->edit_line();
    return 1;
}

###############
# Abstractable
#

sub quote_chars {( qw/ [ ( ' " / )};
sub end_chars {( qw/ { ; / )};

sub inject {()}

sub pre_parse {
    my $self = shift;
    $self->skip_declarator;
    $self->skipspace;

    return if $self->is_defenition;
    return if $self->is_contained;
    return if $self->is_arrow_contained;
    return 1;
}

sub parse {
    my $self = shift;
    $self->parts( $self->strip_remaining_items );
    $self->end_char( $self->peek_num_chars(1));
    $self->strip_length(1) if $self->end_char eq '{';
    return 1;
}

sub post_parse { 1 }

sub rewrite {
    my $self = shift;
    $self->new_parts( $self->parts );
    1;
}

sub write_line {
    my $self = shift;
    my $newline = $self->open_line();

    $newline .= join( ', ',
        map { $self->format_part($_) }
            @{ $self->new_parts || [] }
    );

    $newline .= $self->close_line();

    my $line = $self->line;
    substr( $line, $self->offset, 0 ) = $newline;
    $self->line( $line );
    $self->diag( "New Line: " . $line . "\n" )
        if $self->DEBUG;

    1;
}

sub edit_line { 1 }

sub open_line { "(" }

sub close_line {
    my $self = shift;
    my $end = $self->end_char();
    return ")" if $end ne '{';
    return ( @{$self->new_parts || []} ? ', ' : '' )
         . 'sub'
         . ( $self->prototype ? $self->prototype : '' )
         .' { '
         . join( '; ',
            $self->inject,
            $self->_block_end_injection,
         )
         . '; ';
}

##############
# Stash
#

our %STASH;

sub _stash {
    my ( $item ) = @_;
    my $id = "$item";
    $STASH{$id} = $item;
    return $id;
}

sub _unstash {
    my ( $id ) = @_;
    return delete $STASH{$id};
}

##############
# Accessors
#

my @ACCESSORS = qw/parts new_parts end_char prototype contained/;

{
    my $count = 0;
    for my $accessor ( qw/name declarator original_offset offset/, @ACCESSORS ) {
        my $idx = $count++;
        no strict 'refs';
        *$accessor = sub {
            my $self = shift;
            ( $self->[$idx] ) = @_ if @_;
            return $self->[$idx];
        };
    }
    no strict 'refs';
    *{ __PACKAGE__ . '::_last_index' } = sub { $count };
}

sub add_accessor {
    my $class = shift;
    my ( $accessor ) = @_;
    no strict 'refs';
    my $idx = $class->_last_index + ${ $class . '::_LAST_INDEX' }++;
    *{ $class . '::' . $accessor } = sub {
        my $self = shift;
        ( $self->[$idx] ) = @_ if @_;
        return $self->[$idx];
    };
}

###############
# Informational
#

our %QUOTEMAP = (
    '(' => ')',
    '{' => '}',
    '[' => ']',
    '<' => '>',
);

sub end_quote {
    my $self = shift;
    my ( $start ) = @_;
    return $QUOTEMAP{ $start } || $start;
}

sub linenum  { PL_compiling->line }
sub filename { PL_compiling->file }

sub has_comma {
    my $self = shift;
    grep { $_ eq ',' } $self->has_non_string_or_quote_parts;
}

sub has_fat_comma {
    my $self = shift;
    grep { $_ eq '=>' } $self->has_non_string_or_quote_parts;
}

sub has_non_string_or_quote_parts {
    my $self = shift;
    grep { !ref($_) } @{ $self->parts };
}

sub has_string_or_quote_parts {
    my $self = shift;
    grep { ref($_) } @{ $self->parts };
}

sub has_keyword {
    my $self = shift;
    my ( $word ) = @_;
    return unless $word;
    grep {
        ref( $_ ) ? ($_->[1] eq $word) : ($_ eq $word)
    } @{ $self->parts };
}

################
# Debug
#

our $DEBUG = 0;
sub DEBUG {shift; ( $DEBUG ) = @_ if @_; $DEBUG }

sub diag { warn( _debug(@_)) }
sub bail { die( _debug(@_))  }

sub _debug {
    shift if blessed( $_[0] );

    my @caller = caller(1);
    my @msgs = (
        @_,
        DEBUG() ? (
            "\nCaller:      " . $caller[0] . "\n",
            "Caller file: " . $caller[1] . "\n",
            "Caller Line: " . $caller[2] . "\n",
        ) : (),
    );
    return ( @msgs, " at " . filename() . " line " . linenum() . "\n" );
}

################
# Line manipulation and advancement
#

sub line {
    my $self = shift;
    Devel::Declare::set_linestr($_[0]) if @_;
    return Devel::Declare::get_linestr();
}

sub advance {
    my $self = shift;
    my ( $len ) = @_;
    return unless $len;
    $self->offset( $self->offset + $len );
}

sub strip_length {
    my $self = shift;
    my ($len) = @_;
    return unless $len;

    my $linestr = $self->line();
    substr($linestr, $self->offset, $len) = '';
    $self->line($linestr);
}

sub skip_declarator {
    my $self = shift;
    my $item = $self->peek_is_other;
    my $name = $self->name;
    if ( $item =~ m/^(.*)$name/ ) {
        $self->original_offset(
            $self->original_offset + length($1)
        );
    }
    $self->advance( length($item) );
}

sub skipspace {
    my $self = shift;
    $self->advance(
        Devel::Declare::toke_skipspace( $self->offset )
    );
}

################
# Public parsing interface
#

sub is_defenition {
    my $self = shift;
    my $name = $self->declarator;
    return 1 if $self->line =~ m/sub[\s\n]+$name/sm;
    return 0;
}

sub is_contained {
    my $self = shift;
    return 0 unless $self->peek_num_chars(1);
    return 0 if $self->peek_num_chars(1) ne '(';
    $self->contained(1);
    return 1;
}

sub is_arrow_contained {
    my $self = shift;
    $self->skipspace;

    #Strip first item
    my $first = $self->strip_item;
    my $offset = $self->offset;

    # look at whats next
    $self->skipspace;
    my $stuff = $self->peek_remaining();

    # Put first back.
    my $line = $self->line;
    substr( $line, $offset, 0 ) = $self->format_part( $first, 1 ) || "";
    $self->offset( $offset );
    $self->line( $line );

    return 1 if $stuff =~ m/^=>[\s\n]*\(/sm;
}

sub peek_item_type {
    my $self = shift;
    $self->skipspace;
    return 'quote' if $self->peek_is_quote;
    return 'word'  if $self->peek_is_word;
    return 'block' if $self->peek_is_block;
    return 'end'   if $self->peek_is_end;
    return 'other' if $self->peek_is_other;
    return undef;
}

sub peek_item {
    my $self = shift;
    $self->skipspace;

    my $type = $self->peek_item_type;
    return unless $type;

    my $method = "peek_$type";
    return unless $self->can( $method );

    my $item = $self->$method();
    return unless $item;

    return $item unless wantarray;
    return ( $item, $type );
}

sub peek_quote {
    my $self = shift;
    $self->skipspace;

    my $start = substr($self->line, $self->offset, 3);
    my $charstart = substr($start, 0, 1);
    return unless $self->peek_is_quote( $start, $charstart );

    my ( $length, $quoted ) = $self->_quoted_from_dd();

    return [ $quoted, $charstart ];
}

sub peek_word {
    my $self = shift;
    $self->skipspace;
    my $len = $self->peek_is_word;
    return unless $len;

    my $linestr = $self->line();
    my $name = substr($linestr, $self->offset, $len);
    return [ $name, undef ];
}

sub peek_other {
    my $self = shift;
    $self->skipspace;
    return if $self->peek_is_word;
    return if $self->peek_is_quote;
    return if $self->peek_is_end;
    return if $self->peek_is_block;
    return $self->peek_is_other;
}

sub peek_is_quote {
    my $self = shift;
    my ( $start ) = $self->peek_num_chars(1);
    return (grep { $_ eq $start } $self->quote_chars )
        || undef;
}

sub peek_is_word {
    my $self = shift;
    return $self->_peek_is_package
        || $self->_peek_is_word;
}

sub peek_is_block {
    my $self = shift;
    my ( $start ) = $self->peek_num_chars(1);
    return ($start eq '{')
        || undef;
}

sub peek_is_end {
    my $self = shift;
    my ( $start ) = $self->peek_num_chars(1);
    my ($end) = grep { $start eq $_ } $self->end_chars;
    return $end
        || $self->peek_is_block;
}

sub peek_is_other {
    my $self = shift;
    my $linestr = $self->line;
    substr( $linestr, 0, $self->offset ) = '';
    my $quote = join( '', $self->quote_chars );
    return unless $linestr =~ m/^([^\s;{$quote]+)/;
    return $1;
}

sub peek_num_chars {
    my $self = shift;
    my @out = map { substr($self->line, $self->offset, $_) } @_;
    return @out if wantarray;
    return $out[0];
}

sub strip_item {
    my $self = shift;
    return $self->_item_via_( 'strip_length' );
}

sub strip_remaining_items {
    my $self = shift;
    my @parts;
    while ( my $part = $self->strip_item ) {
        push @parts => $part;
    }
    return \@parts;
}

sub peek_remaining {
    my $self = shift;
    return substr( $self->line, $self->offset );
}

###############
# Private parser interface
#

sub _peek_is_word {
    my $self = shift;
    return Devel::Declare::toke_scan_word($self->offset, 1)
        || undef;
}

sub _peek_is_package {
    my $self = shift;
    my $start = $self->peek_num_chars(1);
    return unless $start =~ m/^[A-Za-z_]$/;
    return unless $self->peek_remaining =~ m/^(\w+::[\w:]+)/;
    return length($1);
}

sub _linestr_offset_from_dd {
    my $self = shift;
    return Devel::Declare::get_linestr_offset()
}

sub _quoted_from_dd {
    my $self = shift;
    my $length = Devel::Declare::toke_scan_str($self->offset);
    my $quoted = Devel::Declare::get_lex_stuff();
    Devel::Declare::clear_lex_stuff();

    return ( $length, $quoted );
}

sub _item_via_ {
    my $self = shift;
    my ( $move_method ) = @_;

    my ( $item, $type ) = $self->peek_item;
    return unless $item;

    $self->_move_via_( $move_method, $type, $item );
    return $item;
}

sub _move_via_ {
    my $self = shift;
    my ( $method, $type, $item ) = @_;

    croak( "$method is not a valid move method" )
        unless $self->can( $method );

    if ( $type eq 'word' ) {
        $self->$method( $self->peek_is_word );
    }
    elsif ( $type eq 'quote' ) {
        my ( $len ) = $self->_quoted_from_dd();
        $self->$method( $len );
    }
    elsif ( $type eq 'other' ) {
        $self->$method( length( $item ));
    }
}

#############
# Rewriting interface
#

sub format_part {
    my $self = shift;
    my ( $part, $no_added_quotes ) = @_;
    return unless $part;
    return $part unless ref($part);
    return $part->[0] if $no_added_quotes && !$part->[1];
    return "'" . $part->[0] . "'"
        unless $part->[1];
    return $part->[1] . $part->[0] . $self->end_quote( $part->[1] );
}

#############
# Codeblock munging
#

sub _block_end_injection {
    my $self = shift;
    my $class = blessed( $self );

    my $id = _stash( $self );

    return "BEGIN { $class\->_edit_block_end('$id') }";
}

sub _edit_block_end {
    my $class = shift;
    my ( $id ) = @_;

    on_scope_end {
        $class->_scope_end($id);
    };
}

sub _scope_end {
    my $class = shift;
    my ( $id ) = @_;
    my $self = _unstash( $id );

    my $oldlinestr = $self->line;
    my $linestr = $oldlinestr;
    $self->offset( $self->_linestr_offset_from_dd() );
    if ( $linestr =~ m/}\s*$/ ) {
        substr($linestr, $self->offset, 0) = ' );';
    }
    else {
        substr($linestr, $self->offset, 0) = ' ) ';
    }
    $self->line($linestr);
    $self->diag(
        "Old Line: " . $oldlinestr . "\n",
        "New Line: " . $linestr . "\n",
    ) if $self->DEBUG;

}

1;

__END__