package Devel::Declare::Lexer::Factory; use Devel::Declare::Lexer::Stream; use Devel::Declare::Lexer::Tokens; use v5; our (@ISA, @EXPORT_OK, %EXPORT_TAGS); BEGIN { use Exporter; @ISA = qw(Exporter); @EXPORT_OK = qw( _stream _statement _reference _variable _string _var_assign _list _keypair _if _return _bareword _block _sub _whitespace _operator ); %EXPORT_TAGS = ( 'all' => \@EXPORT_OK ); } sub _stream { my ($old_stream, $new_stream) = @_; my @stream = (); tie @stream, 'Devel::Declare::Lexer::Stream'; if($old_stream) { push @stream, shift @$old_stream; # declarator push @stream, shift @$old_stream; # whitespace } if($new_stream) { push @stream, @$new_stream; } return @stream; } sub _statement { my ($tokens) = @_; my @t = (); push @t, @$tokens; push @t, new Devel::Declare::Lexer::Token::EndOfStatement; return @t; } sub _reference { my ($refto) = @_; my @tokens = (); push @tokens, new Devel::Declare::Lexer::Token::Operator( value => '\\' ); push @tokens, @$refto; return @tokens; } sub _operator { my ($operator) = @_; return ( new Devel::Declare::Lexer::Token::Operator( value => $operator ) ); } sub _variable { my ($sigil, $name) = @_; my @tokens = (); while($sigil) { push @tokens, new Devel::Declare::Lexer::Token::Variable( value => substr($sigil, 0, 1) ); $sigil = substr($sigil, 1); } push @tokens, new Devel::Declare::Lexer::Token::Bareword( value => $name ); return @tokens; } sub _bareword { my ($word) = @_; return ( new Devel::Declare::Lexer::Token::Bareword( value => $word ) ); } sub _string { my ($type, $value) = @_; return ( new Devel::Declare::Lexer::Token::String( start => $type, end => $type, value => $value ) ); } sub _var_assign { my ($var, $value) = @_; my @tokens = (); push @tokens, @$var; push @tokens, new Devel::Declare::Lexer::Token::Whitespace( value => ' ' ); push @tokens, new Devel::Declare::Lexer::Token::Operator( value => '=' ); push @tokens, new Devel::Declare::Lexer::Token::Whitespace( value => ' ' ); if(ref($value) =~ /ARRAY/) { push @tokens, @$value; } else { push @tokens, $value; } return @tokens; } sub _list { my @items = @_; my @tokens = (); for my $item (@items) { if(ref($item) =~ /ARRAY/) { push @tokens, @$item; } else { push @tokens, $item; } push @tokens, new Devel::Declare::Lexer::Token::Operator( value => ',' ); push @tokens, new Devel::Declare::Lexer::Token::Whitespace( value => ' ' ); } # Remove additional ,\s pop @tokens; pop @tokens; return @tokens; } sub _keypair { my ($var1, $var2) = @_; my @tokens = (); push @tokens, @$var1; push @tokens, @$var2; return @tokens; } sub _return { my ($value) = @_; my @tokens = (); push @tokens, new Devel::Declare::Lexer::Token::Bareword( value => 'return' ); push @tokens, new Devel::Declare::Lexer::Token::Whitespace( value => ' ' ); push @tokens, @$value; return @tokens; } sub _block { my ($inner, $type, $args) = @_; $type = $type || '{'; my $etype = $type; $etype =~ tr/{([/})]/; my @tokens = (); push @tokens, new Devel::Declare::Lexer::Token::LeftBracket( value => $type ); push @tokens, @$inner; if(!$args->{no_close}) { push @tokens, new Devel::Declare::Lexer::Token::RightBracket( value => $etype ); } return @tokens; } sub _whitespace { my ($ws) = @_; return ( new Devel::Declare::Lexer::Token::Whitespace( value => $ws ) ); } sub _sub { my ($name, $block) = @_; my @tokens = (); push @tokens, new Devel::Declare::Lexer::Token::Bareword( value => 'sub' ); push @tokens, new Devel::Declare::Lexer::Token::Whitespace( value => ' ' ); push @tokens, new Devel::Declare::Lexer::Token::Bareword( value => $name ); push @tokens, new Devel::Declare::Lexer::Token::Whitespace( value => ' ' ); push @tokens, @$block; return @tokens; } sub _if { my ($condition, $then, $elsifs, $else) = @_; my @tokens = (); push @tokens, new Devel::Declare::Lexer::Token::Bareword( value => 'if' ); push @tokens, new Devel::Declare::Lexer::Token::LeftBracket( value => '(' ); push @tokens, @$condition; push @tokens, new Devel::Declare::Lexer::Token::RightBracket( value => ')' ); push @tokens, new Devel::Declare::Lexer::Token::LeftBracket( value => '{' ); push @tokens, @$then; push @tokens, new Devel::Declare::Lexer::Token::RightBracket( value => '}' ); if($elsifs) { my @elsif = @$elsifs; if(scalar @elsif > 0) { for my $eif (@elsif) { push @tokens, new Devel::Declare::Lexer::Token::Bareword( value => 'elsif' ); push @tokens, new Devel::Declare::Lexer::Token::LeftBracket( value => '(' ); push @tokens, @{$eif->{condition}}; push @tokens, new Devel::Declare::Lexer::Token::RightBracket( value => ')' ); push @tokens, new Devel::Declare::Lexer::Token::LeftBracket( value => '{' ); push @tokens, @{$eif->{then}}; push @tokens, new Devel::Declare::Lexer::Token::RightBracket( value => '}' ); } } } if($else) { push @tokens, new Devel::Declare::Lexer::Token::Bareword( value => 'else' ); push @tokens, new Devel::Declare::Lexer::Token::LeftBracket( value => '{' ); push @tokens, @$else; push @tokens, new Devel::Declare::Lexer::Token::RightBracket( value => '}' ); } return @tokens; } 1;