File Coverage

blib/lib/Proc/Construct_output.pm

Criterion	Covered	Total	%
statement	9	34	26.4
branch	0	6	0.0
condition	0	9	0.0
subroutine	3	4	75.0
pod	0	1	0.0
total	12	54	22.2

package Proc::Construct_output;

use 5.008;
use strict;
use warnings;

require Exporter;

our @ISA = qw(Exporter);
our %EXPORT_TAGS = ( 'all' => [ qw() ] );
our @EXPORT_OK = (qw(run));
our @EXPORT = qw();

our $VERSION = '0.01';


sub run{
   my($code,$debug)=@_;
   local $_=$code;

   while(

      #################
      # if, else, elsif

      s/
         (\W)
         (
            if\s*
               \([^)(}{]*?\)\s*
                  \{[^}{]*?\}\s*
            (?:
               (
                  else|
                  elsif\s*\([^)(}{]*?\)
               )\s*
               {[^}{]*?}\s*
            )*
         )
      /
         my $temp=$1."do___SB___$2"."___FB___";
         $temp =~ s#([{])#___SB___#g;
         $temp =~ s#([}])#___FB___#g;
         $temp =~ s#([(])#___SP___#g;
         $temp =~ s#([)])#___FP___#g;
         $temp
      /sgxe

      ||

      ############
      #output_last

      s/
         (\W)
         output_last\s
            (.*?);
      /$1
         push \@temp,$2;
         last;
      /sgx

      ||

      ########
      #output

      s/
         (\W)
         output\s
            (.*?);
      /$1 push \@temp,$2;/sgx

      ||

      #####################
      # foreach, while

      s/
         (\W)
         (
            (?:
               (foreach|while)
            )\s*
               \(
                  [^)(}{]*?
               \)\s*
               \{
                  [^}{]*?
               \}
         )
      /
         my $temp=$1."do___SB___my \@temp=();$2;\@temp"."___FB___";
         $temp =~ s#([{])#___SB___#g;
         $temp =~ s#([}])#___FB___#g;
         $temp =~ s#([(])#___SP___#g;
         $temp =~ s#([)])#___FP___#g;
         $temp;
      /sxeg

   ){
      if($debug){
         print;
      }
   }

   s/___SB___/\{/g;
   s/___FB___/\}/g;
   s/___SP___/\(/g;
   s/___FP___/\)/g;

   if($debug){
      print;
   }
   my(@error)=eval $_;
   print @error if $error[0] != 1;
}

1;
__END__