PerleeScript

PerleeScript.pm

use 5.008007;

package PerleeScript;
use Object::Simple -base;

has 'source';

sub to_javascript {
  my $self = shift;
  
  my $code = $self->source;
  
  $code = '' unless defined $code;
  my $code_new;
  my $ptokens = [];
  my $string;
  
  my @complex_operation = qw/
    ->
    =>
    ==
    !=
    <=
    >=
    eq
    ne
    gt
    ge
    lt
    le
  /;
  my $complex_operation_re
    = join '|', map { quotemeta $_ } @complex_operation;
  
  my $sefe;
  my $comment;
  while ($code ne '') {
    
    # Comment
    if ($comment) {
      if ($code =~ s/^(.*\n)//) {
        push @$ptokens, {type => 'comment', value => $1};
      }
      $comment = 0;
    }
    # String
    elsif ($string) {
      my $q = $ptokens->[-1]->{value};
      
      my $found_pos;
      my $search_start_pos = 0;
      while (1) {
        $found_pos = index($code, $q, $search_start_pos);
        if ($found_pos == -1) {
          push @$ptokens, {type => 'string', value => $code};
          $code = '';
          last;
        }
        elsif (substr($code, $found_pos - 1, 1) eq '\\') {
          $search_start_pos = $found_pos + 1;
        }
        else {
          push @$ptokens, {type => 'string', value => substr($code, 0, $found_pos, '')};
          substr($code, 0, 1, '');
          push @$ptokens, {type => 'string_finish', value => $q};
          last;
        }
        die "Unexpected" if $sefe++ > 500;
      }
      $string = 0;
    }

    # Not string literal
    else {
      # Space
      if ($code =~ s/^([ \t]+)//) {
        push @$ptokens, {type => 'space',  value => $1};
      }
      elsif ($code =~ s/^(\n)//) {
        push @$ptokens, {type => 'ln', value => $1};
      }
      # Commenct
      elsif ($code =~ s/^(#)//) {
        push @$ptokens, {type => 'comment_start', value => $1};
        $comment = 1;
      }
      # ID
      elsif ($code =~ s/^([\$a-zA-Z_][\$a-zA-Z_0-9]*)//) {
        push @$ptokens, {type => 'id', value => $1};
      }
      # Number
      elsif ($code =~ s/^([0-9][0-9_.]*)//) {
        my $number = $1;
        $number =~ s/_//g;
        push @$ptokens, {type => 'number', value => $number};
      }
      # String
      elsif ($code =~ s/^(")// || $code =~ s/^(')//) {
        push @$ptokens, {type => 'string_start', value => $1};
        $string = 1;
      }
      # Parenthesis, bracket, or brace
      elsif ($code =~ s/^(\(|\)|\{|\}|\[|\])//) {
        my $kakko = $1;
        
        my $type_names = {
          '(' => 'parenthesis_start',
          ')' => 'parenthesis_end',
          '[' => 'bracket_start',
          ']' => 'bracket_end',
          '{' => 'brace_start',
          '}' => 'brace_end'
        };
        push @$ptokens, {type => $type_names->{$kakko}, value => $kakko};
      }
      elsif ($code =~ s/^(;)//) {
        push @$ptokens, {type => 'statement_end', value => $1};
      }
      # Operator
      elsif ($code =~ s/^([^\s'"\$a-zA-Z_0-9]+)//) {
        my $op = $1;
        while (1) {
          if ($op =~ s/^($complex_operation_re)//) {
            push @$ptokens, {type => 'operator', value => $1};
          }
          else {
            push @$ptokens, {type => 'operator', value => substr($op, 0, 1, '')};
          }
          last if $op eq '';
          die "Unexpected" if $sefe++ > 500;
        }
      }
      else { die "Unexpected $code" }
    }
  }
  
  die "Unexpected" if $sefe++ > 500;

  # Create linked list
  for (my $i = 0; $i < @$ptokens; $i++) {
    my $ptoken = $ptokens->[$i];
    $ptoken->{prev} = $i > 0 ? $ptokens->[$i - 1] : undef;
    $ptoken->{next} = $i < @$ptokens - 1 ? $ptokens->[$i + 1] : undef;
  }
  
  # Block type
  {
    my $ptoken = $ptokens->[0];
    while ($ptoken) {
      die "Unexpected" if $sefe++ > 500;
      
      if ($ptoken->{type} eq 'brace_start') {
        my $prev_token = $self->_get_prev_nospace_token($ptoken);
        next unless $prev_token;
        
        my $block;
        if ($prev_token->{type} eq 'parenthesis_end') {
          $block = 'code';
        }
        else { $block = 'hash' }
        $ptoken->{block} = $block;
        
        my $close_token = $self->_find_close_token($ptoken);
        if ($close_token) {
          $close_token->{block} = $block;
        }
      }
      $ptoken = $ptoken->{next};
    }
  }
  
  # Found block
  my $jstokens = [@$ptokens];
  
  # Create linked list
  for (my $i = 0; $i < @$jstokens; $i++) {
    my $jstoken = $jstokens->[$i];
    $jstoken->{prev} = $i > 0 ? $jstokens->[$i - 1] : undef;
    $jstoken->{next} = $i < @$jstokens - 1 ? $jstokens->[$i + 1] : undef;
  }

=pod
  # behind if and unless
  {
    my $jstoken = $jstokens->[0];
    while ($jstoken) {
          
      die "Unexpected" if $sefe++ > 500;

      my $value = $jstoken->{value};
      my $type = $jstoken->{type};
      
      if ($type eq 'id') {
        if ($value eq 'unless' || $value eq 'if' || $value eq 'for') {
          my $current_token = $jstoken;
          my $prev_token = $self->_get_prev_unspace_token($jstoken);
          my $last_token;
          
          unless ($prev_token->{type} eq 'statement_end'
            || ($prev_token->{type} eq 'brace_end' && $prev_token->{block} eq 'code')
          {
            my $next_token = $self->_get_next_nospace_token($jstoken);
            while ($next_token) {
              if ($next_token eq 'statement_end') {
                $last_token = $next_token;
              }
              elsif ($next_token->{type} eq 'brace_end' && $next_token->{block} eq 'code') {
                $last_token = $next_token->{prev};
                last;
              }
              $next_token = $self->_get_next_nespace_token($next_token);
            }
            if ($last_token) {
              my $prev_token = $self->_get_prev_nospace_token($jstoken);
              while ($prev_token) {
                if ($prev_token eq 'statement_end') {
                  $last_token = $prev_token;
                }
                elsif ($prev_token->{type} eq 'brace_end' && $prev_token->{block} eq 'code') {
                  $last_token = $prev_token->{prev};
                  last;
                }
                $prev_token = $self->_get_next_nespace_token($prev_token);
              }
            }
          }
        }
      }
      $jstoken = $jstoken->{next};
    }
  }
=cut
  
  # Convert
  {
    my $jstoken = $jstokens->[0];
    while ($jstoken) {
          
      die "Unexpected" if $sefe++ > 500;

      my $value = $jstoken->{value};
      my $type = $jstoken->{type};
      
      if ($type eq 'id') {
        if ($value eq 'unless') {
          my $open_parenthesis_jstoken;
          my $close_parenthesis_jstoken;
          my $parenthesis_depth = 0;
          my $next;
          my $next_start = 0;
          my $next_jstoken = $self->_get_next_nospace_token($jstoken);
          while (1) {
            $next_jstoken = $self->_get_next_nospace_token($next_jstoken) if $next_start++;
            last unless $next_jstoken;
            
            die "Unexpected" if $sefe++ > 500;
            
            my $next_type = $next_jstoken->{type};
            my $next_value = $next_jstoken->{value};
            
            if ($parenthesis_depth) {
              if ($next_type eq 'parenthesis_end') {
                $parenthesis_depth--;
                if ($parenthesis_depth == 0) {
                 $close_parenthesis_jstoken = $next_jstoken;
                  last;
                }
              }
              elsif ($next_type eq 'parenthesis_start') {
                $parenthesis_depth++;
              }
            }
            else {
              if ($next_type eq 'parenthesis_start') {
                 $open_parenthesis_jstoken ||= $next_jstoken;
                 $parenthesis_depth++;
              }
              else {
                $next = 1;
                last;
              }
            }
          }
          next if $next;
          
          # Convert unless to if
          $jstoken->{value} = 'if';
          
          # Insert "!(" after "
          my $new_negative_jstoken = {
            type => 'operator',
            value => '!',
            prev => $open_parenthesis_jstoken,
          };
          my $new_open_parenthesis_jstoken = {
            type => 'parenthesis_start',
            value => '(',
            prev => $new_negative_jstoken,
            next => $open_parenthesis_jstoken->{next}
          };
          $new_negative_jstoken->{next} = $new_open_parenthesis_jstoken;
          $open_parenthesis_jstoken->{next}{prev} = $new_open_parenthesis_jstoken;
          $open_parenthesis_jstoken->{next} = $new_negative_jstoken;
          
          # Insert ")" prev ") {"
          my $new_close_parenthesis_jstoken = {
            type => 'parenthesis_end',
            value => ')',
            prev => $close_parenthesis_jstoken->{prev},
            next => $close_parenthesis_jstoken
          };
          $close_parenthesis_jstoken->{prev}{next} = $new_close_parenthesis_jstoken;
          $close_parenthesis_jstoken->{prev} = $new_close_parenthesis_jstoken;
        }
      }
      $jstoken = $jstoken->{next};
    }
  }
  
  # Create Java Script code
  {
    my $prev_is_number_operator;
    my $jstoken = $jstokens->[0];
    while ($jstoken) {

      my $prev_jstoken = $jstoken->{prev} || {type => 'space', value => ''};
      my $after_jstoken = $jstoken->{next} || {type => 'space', value => ''};
      
      my $value = $jstoken->{value};
      my $type = $jstoken->{type};
      
      if ($type eq 'comment_start') {
        $code_new .= '//';
      }
      elsif ($type eq 'operator') {
        if ($value eq '->') { $code_new .= '.' }
        elsif ($value eq '.'
          && $self->_is_space_token($prev_jstoken)
          && $self->_is_space_token($after_jstoken))
        {
          $code_new .= "+ '' +";
        }
        elsif ($value eq 'eq'
          || $value eq 'ne'
          || $value eq 'gt'
          || $value eq 'ge'
          || $value eq 'lt'
          || $value eq 'le')
        {
          my $op_map = {
            eq => '===',
            ne => '!==',
            gt => '>',
            ge => '<=',
            lt => '<',
            le => '<='
          };
          
          $code_new .= "+ '' " . $op_map->{$value} . " + ''";
        }
        elsif ($value eq '=='
          || $value eq '!='
          || $value eq '>'
          || $value eq '>='
          || $value eq '<'
          || $value eq '<=')
        {
          my $op_map = {
            '==' => '===',
            '!=' => '!==',
            '>' => '>',
            '>=' => '<',
            '<' => '<',
            '<=' => '=<'
          };
          
          $code_new .= "* 1 " . $op_map->{$value} . " +";
          $prev_is_number_operator = 1;
        }
        elsif ($value eq '+'
          || $value eq '-'
          || $value eq '*'
          || $value eq '/'
          || $value eq '%')
        {
          $prev_is_number_operator = 1;
          $code_new .= "* 1 " . $value . " +";
        }
        else { $code_new .= $value }
      }
      elsif ($type eq 'id') {
        if ($value eq 'sub') { $code_new .= 'function ()' }
        elsif ($value eq 'my') { $code_new .= 'var' }
        elsif ($value eq 'elsif') { $code_new .= 'else if' }
        else { $code_new .= $value }
      }
      elsif ($self->_is_space_token($jstoken) && $prev_is_number_operator) {
        $prev_is_number_operator = 0;
      }
      else { $code_new .= $value }
      
      $jstoken = $jstoken->{next};
    }
  }

  return $code_new;
}

sub _is_kakko {
  my ($self, $token) = @_;
  
  my $type = $token->{type};
  return 1 if $type eq 'parentesis_start';
  return 1 if $type eq 'parentesis_end';
  return 1 if $type eq 'bracket_start';
  return 1 if $type eq 'bracket_end';
  return 1 if $type eq 'brace_start';
  return 1 if $type eq 'brace_end';
  
  return 0;
}

sub _find_close_token {
  my ($self, $token) = @_;
  
  my $open = $token->{value};
  my $close
    = $open eq '{' ? '}'
    : $open eq '(' ? ')'
    : $open eq '[' ? ']'
    : undef;
  
  die "Unknown $open" unless $close;
  
  
  my $depth = 1;
  while (1) {
    $token = $token->{next};
    
    last unless $token;
    next unless $self->_is_kakko($token);
    
    if ($token->{value} eq $open) {
      $depth++;
      next;
    }
    elsif ($token->{value} eq $close) {
      $depth--;
      return $token if $depth == 0 && $token->{value} eq $close;
    }
  }
}

sub _is_space_token {
  my ($self, $token) = @_;
  
  return $token->{type} eq 'space' || $token->{type} eq 'ln' ? 1 : 0;
  
}
sub _get_prev_nospace_token {
  my ($self, $token) = @_;
  
  while (1) {
    $token = $token->{prev};
    
    return unless $token;
    next if $self->_is_space_token($token);
    return $token;
  }
}

sub _get_next_nospace_token {
  my ($self, $token) = @_;
  
  while (1) {
    $token = $token->{next};
    
    return unless $token;
    next if $self->_is_space_token($token);
    return $token;
  }
}

=head1 NAME

PerleeScript - Perlee Script (Coffee Script for Perl programmer)

=head1 VERSION

Version 0.01

=cut

our $VERSION = '0.01';


=head1 SYNOPSIS

    use PerleeScript;

    my $ps = PerleeScript->new;
    $ps->source("my $title = 'Perl'");
    my $javascript = $ps->to_javascript;
      # var $title = 'Perl';

=head1 LICENSE AND COPYRIGHT

Copyright 2012 Yuki Kimoto.

This program is free software; you can redistribute it and/or modify it
under the terms of either: the GNU General Public License as published
by the Free Software Foundation; or the Artistic License.

See http://dev.perl.org/licenses/ for more information.

=cut

1; # End of PerleeScript