File Coverage

blib/lib/CodeGen/Cpppp.pm

Criterion	Covered	Total	%
statement	316	347	91.0
branch	89	138	64.4
condition	48	78	61.5
subroutine	36	37	97.3
pod	14	14	100.0
total	503	614	81.9

package CodeGen::Cpppp;
use v5.20;
use warnings;
use Carp;
use experimental 'signatures', 'lexical_subs', 'postderef';
use version;
use Cwd 'abs_path';
use Scalar::Util 'blessed', 'looks_like_number';
use CodeGen::Cpppp::Template;
use CodeGen::Cpppp::Output;

our $VERSION= '0.005'; # VERSION
# ABSTRACT: The C Perl-Powered Pre-Processor

# These can be inspected by code generators to find out the current
# context the code is being inserted into.  They are localized by
# the template engine.
our $CURRENT_INDENT_PREFIX= '';
our $CURRENT_IS_INLINE= 0;
our $INDENT= '   ';


sub autoindent($self, $newval=undef) {
   $self->{autoindent}= $newval if defined $newval;
   $self->{autoindent} // 1;
}
sub autocolumn($self, $newval=undef) {
   $self->{autocolumn}= $newval if defined $newval;
   $self->{autocolumn} // 1;
}

sub convert_linecomment_to_c89($self, $newval=undef) {
   $self->{convert_linecomment_to_c89}= $newval if defined $newval;
   $self->{convert_linecomment_to_c89} // 0;
}


sub include_path { $_[0]{include_path} //= [] }
sub output { $_[0]{output} //= CodeGen::Cpppp::Output->new }


sub new($class, @attrs) {
   my $self= bless {
      @attrs == 1 && ref $attrs[0]? %{$attrs[0]}
      : !(@attrs&1)? @attrs
      : croak "Expected even-length list or hashref"
   }, $class;
   $self->{include_path}= [ $self->{include_path} ]
      if defined $self->{include_path} && ref $self->{include_path} ne 'ARRAY';
   $self;
}


sub require_template($self, $filename) {
   $self->{templates}{$filename} ||= do {
      my $path= $self->find_template($filename)
         or croak("No template '$filename' found");
      $self->{templates}{$path} ||= $self->compile_cpppp($path);
   }
}


sub find_template($self, $filename) {
   return abs_path($filename) if $filename =~ m,/, and -e $filename;
   # /foo ./foo and ../foo do not trigger a path search
   return undef if $filename =~ m,^\.?\.?/,;
   for ($self->include_path->@*) {
      my $p= "$_/$filename";
      $p =~ s,//,/,g; # in case include-path ends with '/'
      return abs_path($p) if -e $p;
   }
   return undef;
}


sub new_template($self, $class_or_filename, @params) {
   my $class= $class_or_filename =~ /^CodeGen::Cpppp::/ && $class_or_filename->can('new')
      ? $class_or_filename
      : $self->require_template($class_or_filename);
   my %params= (
      context => $self,
      output => $self->output,
      !(@params&1)? @params
      : 1 == @params && ref $params[0] eq 'HASH'? %{$params[0]}
      : croak("Expected even-length key/val list, or hashref"),
   );
   $class->new(\%params);
}


our $next_pkg= 1;
sub compile_cpppp($self, @input_args) {
   my $parse= $self->parse_cpppp(@input_args);
   my $perl= $self->_gen_perl_template_package($parse);
   unless (eval $perl) {
      die "$perl\n\nException: $@\n";
   }
   return $parse->{package};
}

sub _gen_perl_template_package($self, $parse, %opts) {
   my $perl= $parse->{code} // '';
   my ($src_lineno, $src_filename, @global, $perl_ver, $cpppp_ver, $tpl_use_line)= (1);
   # Extract all initial 'use' and 'no' statements from the script.
   # If they refer to perl or CodeGen:::Cpppp, make a note of it.
   while ($perl =~ s/^ ( [ \t]+ | [#] .* | use [^;]+ ; | no [^;]+ ; \s* ) \n//gx) {
      my $line= $1;
      push @global, $line;
      $perl_ver= version->parse($1)
         if $line =~ /use \s+ ( v.* | ["']? [0-9.]+ ["']? ) \s* ; /x;
      $cpppp_ver= version->parse($1)
         if $line =~ /use \s+ CodeGen::Cpppp \s* ( v.* | ["']? [0-9.]+ ["']? ) \s* ; /x;
      $tpl_use_line= 1
         if $line =~ /use \s+ CodeGen::Cpppp::Template \s+/;
      if ($line =~ /^# line (\d+) "([^"]+)"/) {
         $src_lineno= $1;
         $src_filename= $2;
      } else {
         $src_lineno+= 1 + (()= $line =~ /\n/g);
      }
   }
   if ($opts{with_data}) {
      require Data::Dumper;
      my $dumper= Data::Dumper->new([ { %$parse, code => '...' } ], [ '$_parse_data' ])
         ->Indent(1)->Sortkeys(1);
      push @global,
         'our $_parse_data; '.$dumper->Dump;
   }

   # Build the boilerplate for the template eval
   my $pkg= CodeGen::Cpppp::Template->_create_derived_package($cpppp_ver, $parse);
   $parse->{package}= $pkg;
   $cpppp_ver //= $VERSION;
   $src_filename //= $parse->{filename};
   join '', map "$_\n",
      "package $pkg;",
      # Inject a minimum perl version unless user-provided
      ("use v5.20;")x!(defined $perl_ver),
      # Inject a Template -setup unless user-provided
      ("use CodeGen::Cpppp::Template -setup => $cpppp_ver;")x!($tpl_use_line),
      # All the rest of the user's use/no statements
      @global,
      # Everything after that goes into a BUILD method
      $pkg->_gen_BUILD_method($cpppp_ver, $perl, $src_filename, $src_lineno),
      "1";
}

sub parse_cpppp($self, $in, $filename=undef, $line=undef) {
   my @lines;
   if (ref $in eq 'SCALAR') {
      @lines= split /^/m, $$in;
   }
   else {
      my $fh;
      if (ref $in eq 'GLOB' || (blessed($in) && $in->can('getline'))) {
         $fh= $in;
      } else {
         open($fh, '<', $in) or croak "open($in): $!";
      }
      local $/= undef;
      my $text= <$fh>;
      $filename //= "$in";
      utf8::decode($text) or warn "$filename is not encoded as utf-8\n";
      @lines= split /^/m, $text;
   }
   $line //= 1;
   $self->{cpppp_parse}= {
      autoindent        => $self->autoindent,
      autocolumn        => $self->autocolumn,
      filename          => $filename,
      colmarker         => {},
      coltrack          => { },
   };
   my ($perl, $perl_line, $block_group, $tpl_start_line, $cur_tpl, $pod_start, @pod)
      = ('', 0, 1);
   my sub end_tpl {
      if (defined $cur_tpl && $cur_tpl =~ /\S/) {
         my $parsed= $self->_parse_code_block($cur_tpl, $filename, $tpl_start_line);
         my $current_indent= $perl =~ /\n([ \t]*).*\n\Z/? $1 : '';
         $current_indent .= '  ' if $perl =~ /\{ *\n\Z/;
         $perl .= $self->_gen_perl_call_code_block($parsed, $current_indent);
      }
      $cur_tpl= undef;
   };
   for (@lines) {
      if (/^=(\w+)/) {
         if (!defined $pod_start) {
            $pod_start= $line;
            if (defined $cur_tpl) {
               # trim off any blank line that occurs right before the pod.
               chomp $cur_tpl;
               end_tpl();
            }
         }
         push @pod, $_;
         if (@pod > 1 && $1 eq 'cut') {
            my $current_indent= $perl =~ /\n([ \t]*).*\n\Z/? $1 : '';
            $current_indent .= '  ' if $perl =~ /\{ *\n\Z/;
            $perl .= $self->_gen_perl_emit_pod_block(join('', @pod), $filename, $pod_start, $current_indent);
            @pod= ();
            $pod_start= undef;
         }
      }
      elsif (defined $pod_start) {
         push @pod, $_;
      }
      elsif (/^#!/) { # ignore #!
      }
      elsif (/^##/) { # full-line of perl code
         end_tpl() if defined $cur_tpl;
         $perl .= qq{# line $line "$filename"\n} unless $perl_line == $line;
         (my $pl= $_) =~ s/^##\s?//;
         $perl .= $self->_transform_template_perl($pl, $line);
         $perl_line= $line+1;
      }
      elsif (/^(.*?) ## ?((?:if|unless|for|while|unless) .*)/) { # perl conditional suffix, half tpl/half perl
         my ($tpl, $pl)= ($1, $2);
         end_tpl() if defined $cur_tpl;
         $tpl_start_line= $line;
         $cur_tpl= $tpl;
         end_tpl();
         $perl =~ s/;\s*$//; # remove semicolon
         $pl .= ';' unless $pl =~ /;\s*$/; # re-add it if user didn't
         $perl .= qq{\n# line $line "$filename"\n    $pl\n};
         $perl_line= $line + 1;
      }
      else { # default is to assume a line of template
         if (!defined $cur_tpl) {
            $tpl_start_line= $line;
            $cur_tpl= '';
         }
         $cur_tpl .= $_;
      }
   } continue { ++$line }
   end_tpl() if defined $cur_tpl;

   # Resolve final bits of column tracking
   my $ct= delete $self->{cpppp_parse}{coltrack};
   _finish_coltrack($ct, $_) for grep looks_like_number($_), keys %$ct;

   # Finish detecting indent, if not specified
   if (!defined $self->{cpppp_parse}{indent}) {
      $self->{cpppp_parse}{indent}
         = $self->_guess_indent(delete $self->{cpppp_parse}{indent_seen} || []);
   }

   $self->{cpppp_parse}{code}= $perl;
   delete $self->{cpppp_parse};
}

sub _guess_indent($self, $indent_seen) {
   my %evidence;
   my $prev;
   for (@$indent_seen) {
      if (!defined $prev || length($_) <= length($prev)) {
         $evidence{/^\t+$/? "\t" : /\t/? 'mixed_tabs' : $_}++;
      }
      elsif (length($prev) < length($_)) {
         if ($prev =~ /\t/ || $_ =~ /\t/) {
            if ($prev =~ /^\t+$/ && $_ =~ /^\t+$/) {
               $evidence{"\t"}++;
            } else {
               $evidence{mixed_tabs}++;
            }
         } else {
            my $step= length($_) - length($prev);
            if (0 == length($prev) % $step) {
               $evidence{' 'x$step}++;
            }
         }
      }
      $prev= $_;
   }
   my $guess;
   for (keys %evidence) {
      $guess= $_ if !defined $guess
         || $evidence{$_} > $evidence{$guess}
         || ($evidence{$_} == $evidence{$guess} && $_ lt $guess);
   }
   return defined $guess && $guess eq 'mixed_tabs'? undef : $guess;
}

sub _transform_template_perl($self, $pl, $line) {
   # If user declares "sub NAME(", convert that to "my sub NAME" so that it can
   # capture refs to the variables of new template instances.
   if ($pl =~ /^ \s* (my \s+)? sub \s* ([\w_]+) \b \s* /x) {
      my $name= $2;
      $self->{cpppp_parse}{template_method}{$name}= { line => $line };
      my $ofs= $-[0];
      my $ofs2= defined $1? $+[1] : $ofs;
      substr($pl, $ofs, $ofs2-$ofs, "my sub $name; \$self->define_template_method($name => \\&$name);");
   }
   # If user declares 'param $foo = $x' adjust that to 'param my $foo = $x'
   if ($pl =~ /^ \s* (param) \b /xgc) {
      my $ofs= $-[1];
      # It's an error if the thing following isn't a variable name
      $pl =~ /\G \s* ( [\$\@\%] [\w_]+ ) /xgc
         or croak("Expected variable name (including sigil) after 'param'");
      my $var_name= $1;
      $pl =~ /\G \s* ([;=]) /xgc
         or croak("Parameter declaration $var_name must be followed by '=' or ';'");
      my $term= $1;
      my $name= substr($var_name, 1);
      substr($pl, $ofs, $+[0]-$ofs, qq{param '$name', \\my $var_name }.($term eq ';'? ';' : ','));
      $self->{cpppp_parse}{template_parameter}{$name}= substr($var_name,0,1);
   }
   # If user declares "define name(", convert that to both a method and a define
   elsif ($pl =~ /^ \s* (define) \s+ ([\w_]+) (\s*) \(/x) {
      my $name= $2;
      $self->{cpppp_parse}{template_macro}{$name}= 'CODE';
      substr($pl, $-[1], $-[2]-$-[1], qq{my sub $name; \$self->define_template_macro($name => \\&$name); sub });
   }
   $pl;
}

sub _gen_perl_call_code_block($self, $parsed, $indent='') {
   my $codeblocks= $self->{cpppp_parse}{code_block_templates} ||= [];
   push @$codeblocks, $parsed;
   my $code= $indent.'$self->_render_code_block('.$#$codeblocks;
   my %cache;
   my $i= 0;
   my $cur_line= 0;
   for my $s (@{$parsed->{subst}}) {
      if (defined $s->{eval}) {
         # No need to create more than one anonsub for the same expression
         if (defined $cache{$s->{eval}}) {
            $s->{eval_idx}= $cache{$s->{eval}};
            next;
         }
         $cache{$s->{eval}}= $s->{eval_idx}= $i++;
         my $sig= $s->{eval} =~ /self|output/? '($self, $output)' : '';
         if ($s->{line} == $cur_line) {
            $code .= qq{, sub${sig}{ $s->{eval} }};
         } elsif ($s->{line} == $cur_line+1) {
            $cur_line++;
            $code .= qq{,\n$indent  sub${sig}{ $s->{eval} }};
         } else {
            $code .= qq{,\n# line $s->{line} "$parsed->{file}"\n$indent  sub${sig}{ $s->{eval} }};
            $cur_line= $s->{line};
            $cur_line++ for $s->{eval} =~ /\n/g;
         }
      }
   }
   $code .= "\n$indent" if index($code, "\n") >= 0;
   $code . ");\n";
}

sub _gen_perl_emit_pod_block($self, $pod, $file, $line, $indent='') {
   my $pod_blocks= $self->{cpppp_parse}{pod_blocks} ||= [];
   push @$pod_blocks, { pod => $pod, file => $file, line => $line };
   return $indent.'$self->_render_pod_block('.$#$pod_blocks.");\n";
}

sub _finish_coltrack($coltrack, $col) {
   # did it eventually have an eval to the left?
   if (grep $_->{follows_eval}, $coltrack->{$col}{members}->@*) {
      $coltrack->{$col}{members}[-1]{last}= 1;
   } else {
      # invalidate them all, they won't become unaligned anyway.
      $_->{colgroup}= undef for $coltrack->{$col}{members}->@*;
   }
   delete $coltrack->{$col};
}

sub _parse_code_block($self, $text, $file=undef, $orig_line=undef) {
   $text .= "\n" unless substr($text,-1) eq "\n";
   if ($text =~ /^# line (\d+) "([^"]+)"/) {
      $orig_line= $1-1;
      $file= $2;
   }
   local our $line= $orig_line || 1;
   local our $parse= $self->{cpppp_parse} //= {};
   local our $start;
   local our @subst;
   # Check if we can auto-detect the indent
   unless (defined $parse->{indent}) {
      # Find all total indents used in this code, but only count lines that
      # were preceeded by ';' or '{' or ')' followed by lines starting with a
      # word or variable substitution.
      push @{$parse->{indent_seen}}, $1 while $text =~ /[;{)]\s*\n([ \t]+)[\w\$\@]/g;
   }
   # Everything in coltrack that survived the last _parse_code_block call
   # ended on the final line of the template.  Set the line numbers to
   # continue into this template.
   for my $c (grep looks_like_number($_), keys $parse->{coltrack}->%*) {
      $parse->{coltrack}{$c}{line}= $line;
   }
   local $_= $text;
   # Parse and record the locations of the embedded perl statements
   ()= m{
      # Rough approximation of continuation of perl expressions in quoted strings
      (?(DEFINE)
         (? (?>
              \{ (?&BALANCED_EXPR) \}
            | \[ (?&BALANCED_EXPR) \]
            | \( (?&BALANCED_EXPR) \)
            | [^[\](){}\n]+
            | \n (?{ $line++ })
         )* )
      )

      # Start of a perl expression in a quoted string
      [\$\@] (?{ $start= -1+pos })
         (?:
           \{ (?&BALANCED_EXPR) \}           #
           | [\w_]+                          # plain variable
            (?:                              # maybe followed by ->[] or similar
               (?: -> )?
               (?: \{ (?&BALANCED_EXPR) \} | \[ (?&BALANCED_EXPR) \] )
            ) *
         ) (?{ push @subst, { pos => $start, len => -$start+pos, line => $line }; })

      # Track what line we're on
      | \n     (?{ $line++ })

      # Column alignment detection for the autocolumn feature
      | (?{ $start= pos; }) [ \t]{2,}+ (?{
            push @subst, { pos => pos, len => 0, line => $line, colgroup => undef };
        })
   }xg;

   my $prev_eval;
   for my $s (@subst) {
      if (exists $s->{colgroup}) {
         my $linestart= (rindex($text, "\n", $s->{pos})+1);
         my $col= $s->{pos} - $linestart;
         $s->{follows_eval}= $prev_eval && $prev_eval->{line} == $s->{line};
         # If same column as previous line, continue the coltracking.
         if ($parse->{coltrack}{$col}) {
            if ($parse->{coltrack}{$col}{members}[-1]{line} == $s->{line} - 1) {
               push @{ $parse->{coltrack}{$col}{members} }, $s;
               $s->{colgroup}= $parse->{coltrack}{$col}{id};
               $parse->{coltrack}{$col}{line}= $s->{line};
               next;
            }
            # column ended prior to this
            _finish_coltrack($parse->{coltrack}, $col);
         }
         # There's no need to create a column unless nonspace to the left
         # Otherwise it would just be normal indent.
         if (substr($text, $linestart, $s->{pos} - $linestart) =~ /\S/) {
            # new column begins
            $s->{colgroup}= $col*10000 + ++$parse->{coltrack}{next_id}{$col};
            $s->{first}= 1;
            $parse->{coltrack}{$col}= {
               id => $s->{colgroup},
               line => $s->{line},
               members => [ $s ],
            };
         }
      }
      else { # Perl expression
         my $expr= substr($text, $s->{pos}, $s->{len});
         # Special case: ${{  }} notation is a shortcut for @{[do{ ... }]}
         $expr =~ s/^ \$\{\{ (.*) \}\} $/$1/x;
         # When not inside a string, ${foo} becomes ambiguous with ${foo()}
         $expr =~ s/^ ([\$\@]) \{ ([\w_]+) \} /$1$2/x;
         $s->{eval}= $expr;
         $prev_eval= $s;
      }
   }
   # Clean up any tracked column that ended before the final line of the template
   for my $c (grep looks_like_number($_), keys $parse->{coltrack}->%*) {
      _finish_coltrack($parse->{coltrack}, $c)
         if $parse->{coltrack}{$c}{line} < $line-1;
   }
   @subst= grep defined $_->{eval} || defined $_->{colgroup}, @subst;

   { text => $text, subst => \@subst, file => $file }
}


sub patch_file($self, $fname, $patch_markers, $new_content) {
   $new_content .= "\n" unless $new_content =~ /\n\Z/ or !length $new_content;
   utf8::encode($new_content);
   open my $fh, '+<', $fname or die "open($fname): $!";
   my $content= do { local $/= undef; <$fh> };
   $content =~ s{(BEGIN \Q$patch_markers\E[^\n]*\n).*?(^[^\n]+?END \Q$patch_markers\E)}
      {$1$new_content$2}sm
      or croak "Can't find $patch_markers in $fname";
   $fh->seek(0,0) or die "seek: $!";
   $fh->print($content) or die "write: $!";
   $fh->truncate($fh->tell) or die "truncate: $!";
   $fh->close or die "close: $!";
   $self;
}


sub backup_and_overwrite_file($self, $fname, $new_content) {
   $new_content .= "\n" unless $new_content =~ /\n\Z/;
   utf8::encode($new_content);
   if (-e $fname) {
      my $n= 0;
      ++$n while -e "$fname.$n";
      require File::Copy;
      File::Copy::copy($fname, "$fname.$n") or die "copy($fname, $fname.$n): $!";
   }
   open my $fh, '>', $fname or die "open($fname): $!";
   $fh->print($new_content) or die "write: $!";
   $fh->close or die "close: $!";
   $self;
}


sub get_filtered_output($self, @sections) {
   @sections= grep defined, @sections; # allow a single undef to mean 'all'
   my $content= $self->output->get(@sections);
   if ($self->convert_linecomment_to_c89) {
      # rewrite '//' comments as '/*' comments
      require CodeGen::Cpppp::CParser;
      my @tokens= CodeGen::Cpppp::CParser->tokenize($content);
      my $ofs= 0;
      for (@tokens) {
         $_->[2] += $ofs;
         if ($_->type eq 'comment') {
            if (substr($content, $_->src_pos, 2) eq '//') {
               substr($content, $_->src_pos, $_->src_len, '/*'.$_->value.' */');
               $ofs += 3;
            }
         }
      }
   }
   $content;
}


sub write_sections_to_file($self, $sections, $fname, $patch_markers=undef) {
   my $content= $self->get_filtered_output($sections);
   if (defined $patch_markers) {
      $self->patch_file($fname, $patch_markers, $content);
   } else {
      $self->backup_and_overwrite_file($fname, $content);
   }
   $self
}

sub _slurp_file($self, $fname) {
   open my $fh, '<', $fname or die "open($fname): $!";
   my $content= do { local $/= undef; <$fh> };
   $fh->close or die "close: $!";
   $content;
}

1;

__END__