File Coverage

blib/lib/perltugues.pm

Criterion	Covered	Total	%
statement	62	88	70.4
branch	4	10	40.0
condition			n/a
subroutine	5	5	100.0
pod	0	1	0.0
total	71	104	68.2

package perltugues;

require 5.005_62;
use strict;
use warnings;
use utf8;

our $VERSION = '0.19';

use Filter::Simple;

FILTER_ONLY
  all => sub {
  my $package = shift;
  my %par = @_;
  my $DEBUG = $par{DEBUG} if $par{DEBUG};
  return unless $DEBUG;
  my $i = 0;
  my @qq = /"(.*?)"/g;
  push @qq, /'(.*?)'/g;
  s/"(.*?)"/'"$' . ($i++) . '$"'/ge;
  s/'(.*?)'/"'\$" . ($i++) . "\$'"/ge;
  filter($_);
  s/"\$(\d+)\$"/'"' . (shift @qq) . '"'/ge;
  s/'\$(\d+)\$'/"'" . (shift @qq) . "'"/ge;
  Perl::Tidy::perltidy(source => \$_, destination => \$_)
   if eval "require Perl::Tidy";
  print if $DEBUG;
  exit;
},
  code_no_comments  => \&filter;
my $tipo = "inteiro|texto|real|caracter";
#my $tipo = '\w+';

sub filter {
   my @var;
   my @varArray;
   $_ = "use strict;$/" . $_;

   s/#.*$//g;

   s# \bse\b \s* \(? (.*?) \)? \s* \{
    #if ($1)\{$/
    #gmx;

   s# \bse \s* n[ãa]o
    #else
    #gmx;

   s# \ba \s+ n[aã]o \s+ ser (?:\s+ q(?:ue)? )?\b \s* (.*?) \s* \{
    #unless ($1)\{$/
    #gmx;

   s# \bpara\b \s+ (\w+) \s* \( (.*?) \) \s* \{
    #for ($2){\$$1->vale(\$_);$/
    #gmx;

   s# \bpara\b \s+ (\w+) \s* <- \s* \(? (.*?) \)? \s* \{
    #for ($2){\$$1->vale(\$_);$/
    #gmx;

   s# \bpara\b \s* \(? (.*?)\) \)? \s* \{
    #for ($1){
    #gmx;

   s/ (\(?) \bde \s+ (\w+) \s+ a \s+ (\w+) (?:\s+ (?:a|para) \s+ cada \s+ (.+?) ) (\)?)
    /$1map({(\$_ * $4) + $2} 0 .. (int($3\/$4) - ($2?1:0)))$5
    /gmx;

   s/ (\(?) \bde \s+ (\w+) \s+ a \s+ (\w+) (\)?)
    /$1$2 .. $3$4
    /gmx;

   s# \benquanto\b \s* \(? (.*?) \)? \s*\{
    #while ($1)\{$/
    #gmx;

   s# \bat(?:eh?|é) (?:\s+q(?:ue)?)?\b \s* (\()? (.*?) \)? \{
    #until($2)\{$/
    #gmx;

   s/ \bescrev[ae]\b \s* \(? (.*?) \)? (;)
    /print($1)$2
    /gmx;

   s/\bleia\b(?:\s*\(?(.*?)\)?)?\s*;/chomp(my \$_tmp_=<>);\$$1->vale(\$_tmp_);/g;
   s/\bsaia do (?:loop|la[cç]o)\b/last/g;
   s/\bpr[óo]ximo\b/next/g;
   s/\bde novo\b/redo/g;
   s/\brefa[çc]a\b/redo/g;
   s/\bv[aá] para\b/goto/g;
   s/\(([^()]*?)\)\s*separado\s+por\s*((["']?).*?\3)(\s*[,;])/join($2, $1)$4/g;
   s#quebra\s+de\s+linha#\$/#g;
   s#fim de texto#"\\0"#g;
   s/\bin[íi]cio:?\b/{/g;
   s/\bfim\b/}/g;
   s/\bfun[cç][aã]o\b/sub/g;

### ___   Tipos Array  ___ ###

   {
      my @varB = grep {!/^\s*$/} m#\barray\s+(?:$tipo)\s*:\s*([]\w, []+)\s*;#gsm;
      @varB = map {/^(\w+)/; $1} @varB;
      push(@varArray, split /\s*,\s*/, join ",", @varB);

      my $redef = (grep{my $v=$_; 1 < grep {$v eq $_} @varArray} @varArray)[0];
      die qq#Variavel "$redef" redefinida!$/# if defined $redef;

      my $err_var = (grep{!/^[a-z,A-Z]/} @varArray)[0];
      die qq#Nome invalido da variavel "$err_var".$/# if defined $err_var;

      my($t, $v);
      my %tipo = m#\barray\s+($tipo)\s*:\s*([]\w, []+)\s*;#gxsm;
      for my $t(keys %tipo){
         $_ = "use perltugues::$t;$/" . $_;
      }
      s#\barray\s+($tipo)\s*:\s*([]\w, []+)\s*;
       #my $_tipo = $1;
        my $_var  = $2;
        join$/,map{
                     "my \@$1 = (" . (join",", ("perltugues::$_tipo->new") x $2) . ");"
                        if /^(\w+)\[(\d+)\]$/
                  }split/\s*,\s*/, $_var
       #gexsm;
      for my $var(@varArray){
         s/\btamanho\s*\($var\)/scalar \@$var/g;
         s/([^\$])\b$var\[(.+?)\]\s*=\s*((['"])?.*?\3?)\s*;/$1($2 <= \$#$var?\${$var}[$2]->vale($3):die qq#O array "\\$var" esta sendo acessado numa posicao inexistente\$\/#);/g;
         s/([^\$])\b$var\[(.+?)\]/$1($2 <= \$#$var?\$$var\[$2]:die qq#O array "$var" esta sendo acessado numa posicao inexistente\$\/#)/g;
         s/([^@#])\b$var\b(?!\[.*?\])/$1\@$var/g;
      }
   }
### ___   Tipos Escalares  ___ ###

   my @varB = grep {!/^\s*$/} m#\s*\b(?:$tipo)\s*:\s*([\w, ]+)\s*;#gsm;
   #my @varB = grep {!/^\s*$/} m#(?:^|;)\s*\b(?:$tipo)\s*:\s*([\w, ]+)\s*;#gsm;
   push(@var, split /\s*,\s*/, join ",", @varB);

   my $redef = (grep{my $v=$_; 1 < grep {$v eq $_} @var} @var)[0];
   die qq#Variavel "$redef" redefinida!$/# if defined $redef;

   my $err_var = (grep{!/^[a-z,A-Z]/} @var)[0];
   die qq#Nome invalido da variavel "$err_var".$/# if defined $err_var;

   my($t, $v);
   my %tipo = m#\s*\b($tipo)\s*:\s*([\w, ]+)\s*;#gsmx;
   #my %tipo = m#(?:^|;)\s*\b($tipo)\s*:\s*([\w, ]+)\s*;#gsmx;
   for my $t(keys %tipo){
      $_ = "use perltugues::$t;$/" . $_;
   }
   #s#((?:^|;)\s*)\b($tipo)\s*:\s*([\w, ]+)\s*;
   s#(\s*)\b($tipo)\s*:\s*([\w, ]+)\s*;
    #$1 . join$/,map{"my \$$_ = perltugues::$2->new;"}split/\s*,\s*/, $3
    #gesmx;
   for my $var(@var){
      s/([^\$])\b$var\s*=\s*((['"])?.*?\3?)\s*;/$1\$$var->vale($2);/g;
      s/([^\$])\b$var\b/$1\$$var/g;
   }

};

42;
__END__