view release on metacpan or  search on metacpan

lib/CodeGen/Cpppp.pm  view on Meta::CPAN

         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__

=pod

=encoding UTF-8

=head1 NAME

CodeGen::Cpppp - The C Perl-Powered Pre-Processor

=head1 RATIONALE

I<It's very special, because, if you can see, the preprocessor, goes up, to
C<perl>.  Look, right across the directory, C<perl>, C<perl>, C<perl>.>

=over

I<And most distributions go up to C<m4> >

=back

I<Exactly>

=over

I<Does that mean it's more powerful?  ...Is it more powerful?>

=back

I<Well, it's one layer of abstraction higher, isn't it?  It's not C<m4>.
You see, most blokes gonna be templating with C<cpp> or C<m4>, you're on C<m4>
here all the way up, all the way up, aaaall the way up, you're at C<m4> for your
pre-processing, Where can you go from there? Where?  Nowhere!  Exactly.>

I<What we do is if we need that extra, push over the cliff, you know what we do?>

=over

I<put it up to C<perl> >

=back

I< C<perl>, exactly. One higher. >

=over

I<Why don't you just download the C<cpp> source, and enhance it with the

lib/CodeGen/Cpppp.pm  view on Meta::CPAN

=head1 CONSTRUCTOR

=head2 new

Bare-bones for now, it accepts whatever hash values you hand to it.

=head1 METHODS

=head2 require_template

  $tpl_class= $cpppp->require_template($filename);

Load a template from a file, and die if not found or if it fails to compile.
Subsequent loads of the same file return the same class.

=head2 find_template

  $abs_path= $cpppp->find_template($filename);

Check the filename itself, and relative to all paths in L</include_path>,
and return the absolute path to the first match.

=head2 new_template

  $tpl_instance= $cpppp->new_template($class_or_filename, %params);

Load a template by filename (or use an already-loaded class) and construct a
new instance using C<%params> but also with the context and output defaulting
to this C<$cpppp> instance, and return the template object.

=head2 compile_cpppp

  $cpppp->compile_cpppp($filename);
  $cpppp->compile_cpppp($input_fh, $filename);
  $cpppp->compile_cpppp(\$scalar_tpl, $filename, $line_offset);

This reads the input file handle (or scalar-ref) and builds a new perl template
class out of it (and dies if there are syntax errors in the template).

Yes, this 'eval's the input, and no, there are not any guards against
malicious templates.  But you run the same risk any time you run someone's
'./configure' script.

=head2 patch_file

  $cpppp->patch_file($filename, $marker, $new_content);

Reads C<$filename>, looking for lines containing C<"BEGIN $marker"> and
C<"END $marker">.  If not found, it dies.  It then replaces all the lines
between those two lines with C<$new_content>, and writes it back to the same
file handle.

Example:

  my $tpl= $cpppp->require_template("example.cp");
  my $out= $tpl->new->output;
  $cpppp->patch_file("project.h", "example.cp", $out->get('public'));
  $cpppp->patch_file("internal.h", "example.cp", $out->get('protected'));

=head2 backup_and_overwrite_file

  $cpppp->backup_and_overwrite_file($filename, $new_content);

Create a backup of $filename if it already exists, and then write a new file
containing C<$new_content>.  The backup is created by appending a ".N" to the
filename, choosing the first available "N" counting upward from 0.

=head2 get_filtered_output

  my $text= $cpppp->get_filtered_output(@sections);

Like C<< $cpppp->output->get >>, but also apply filters to the output, like
L</convert_linecomment_to_c89>.

=head2 write_sections_to_file

  $cpppp->write_sections_to_file($section_spec, $filename);
  $cpppp->write_sections_to_file($section_spec, $filename, $patch_markers);

This is a simple wrapper around L<CodeGen::Cpppp::Output/get> and either
L</backup_and_overwrite_file> or L</patch_file>, depending on whether you
supply C<$patch_markers>.

=head1 AUTHOR

Michael Conrad <mike@nrdvana.net>

=head1 VERSION

version 0.005

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2024 by Michael Conrad.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut