CodeGen-Cpppp
view release on metacpan or search on metacpan
}
# --list-sections suppresses output
if ($opt_list_sections) {
@script= grep $_->[0] ne 'output', @script;
}
elsif (!grep $_->[0] eq 'output') {
# If there was no 'out' specified, add one to STDOUT
push @script, [ 'output', '-' ];
}
sub set_param($var, $value) {
$var =~ /^( [\$\@\%]? ) [\w_]+ $/x
or die "Parameter name '$var' is not valid\n";
if ($1) {
my $expr= $1 eq '$'? '$param{$var}='.$value
: $1 eq '@'? '$param{$var}=['.$value.']'
: '$param{$var}={'.$value.'}';
# Automatically require modules mentioned in the expression
while (/\b([A-Za-z][\w_]+(::[A-Za-z0-9][\w_]+)+)\b/) {
my $fname= $1 . '.pm';
$fname =~ s,::,/,g;
or die "Error evaluating parameter '$var': $@\n";
} else {
$param{'$'.$var} //= $value;
$param{'@'.$var} //= [ split ',', $value ]
if $value =~ /,/;
my ($k, $v);
$param{'%'.$var} //= { map +(($k,$v)=split('=',$_,2)), split ',', $value }
if $value =~ /=/;
}
}
sub set_feature($expr) {
my ($k, $v)= split '=', $expr, 2;
set_param("feature_$k", $v // 1);
}
my $cpppp= CodeGen::Cpppp->new(
convert_linecomment_to_c89 => $convert_linecomment_to_c89,
);
my $tpl;
sub process_tpl(@input_args) {
if ($opt_dump_pl) {
my $parse= $cpppp->parse_cpppp(@input_args);
my $code= $cpppp->_gen_perl_template_package($parse, with_data => 1);
my $sec= $input_args[1] // $input_args[0];
$cpppp->output->declare_sections($sec);
$cpppp->output->append($sec, $code)
} else {
my $tpl_class= $cpppp->compile_cpppp(@input_args);
my $tpl_params= $tpl_class->coerce_parameters(\%param);
$tpl= $cpppp->new_template($tpl_class, $tpl_params);
}
}
sub do_eval($code) {
eval $code or die "Eval '$code' failed: $@\n";
}
sub call_method($code) {
defined $tpl or die "No template is defined, for --call";
do_eval("\$tpl->$code");
}
sub output($spec) {
my ($filespec, $sections)= reverse split /=/, $spec, 2;
if ($filespec eq '-' || !length $filespec) {
print $cpppp->get_filtered_output($sections);
} else {
$cpppp->write_sections_to_file($sections, split('@', $filespec, 2));
}
$cpppp->output->consume(defined $sections? ($sections) : ());
}
# All the global options are taken care of. Now execute the "script options"
if ($opt_list_sections) {
say "name\tline_count";
for my $s ($cpppp->output->section_list) {
my $line_count= ()= $cpppp->output->get($s) =~ /\n/g;
say "$s\t$line_count";
}
exit 0;
}
# Lets a template main::re_exec(@different_args)
sub re_exec(@new_argv) {
exec($^X, "$FindBin::RealBin/$FindBin::RealScript", @new_argv)
or die "exec: $!";
}
__END__
=pod
=encoding UTF-8
lib/CodeGen/Cpppp.pm view on Meta::CPAN
# 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)
lib/CodeGen/Cpppp.pm view on Meta::CPAN
("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): $!";
lib/CodeGen/Cpppp.pm view on Meta::CPAN
# 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"}++;
lib/CodeGen/Cpppp.pm view on Meta::CPAN
}
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'
lib/CodeGen/Cpppp.pm view on Meta::CPAN
}
# 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}}) {
lib/CodeGen/Cpppp.pm view on Meta::CPAN
$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
lib/CodeGen/Cpppp.pm view on Meta::CPAN
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') {
lib/CodeGen/Cpppp.pm view on Meta::CPAN
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__
lib/CodeGen/Cpppp/Enum.pm view on Meta::CPAN
use v5.20;
use warnings;
use Carp;
use experimental 'signatures', 'lexical_subs', 'postderef';
use Scalar::Util 'looks_like_number';
use List::Util 'any', 'min', 'max';
BEGIN { *uniqstr= List::Util->can('uniqstr') // sub { my %seen; grep !$seen{$_}++, @_ } }
use CodeGen::Cpppp::CParser;
sub new($class, %attrs) {
my $self= bless {}, $class;
# apply num_format first because it affects set_values
$self->num_format(delete $attrs{num_format})
if exists $attrs{num_format};
$self->$_($attrs{$_}) for keys %attrs;
return $self;
}
sub prefix($self, @val) {
if (@val) { $self->{prefix}= $val[0]; return $self }
$self->{prefix} // ''
}
sub macro_prefix($self, @val) {
if (@val) { $self->{macro_prefix}= $val[0]; return $self }
$self->{macro_prefix} // uc($self->prefix);
}
sub symbol_prefix($self, @val) {
if (@val) { $self->{symbol_prefix}= $val[0]; return $self }
$self->{symbol_prefix} // lc($self->prefix);
}
sub type($self, @val) {
if (@val) { $self->{type}= $val[0]; return $self; }
$self->{type} // 'int';
}
sub values($self, @val) {
return $self->set_values(@val) if @val;
@{ $self->{values} // [] }
}
sub set_values($self, @spec) {
my @values;
for (@spec == 1 && ref $spec[0]? @{$spec[0]} : @spec) {
if ('ARRAY' eq ref) {
push @values, [ @$_ ];
} elsif (/^\w+$/) {
push @values, [ $_ ];
} else {
defined $values[-1] or croak "Got an enum value '$_' before a name";
defined $values[-1][1] and croak "'$_' is not a valid enum name";
$values[-1][1]= $_;
lib/CodeGen/Cpppp/Enum.pm view on Meta::CPAN
my ($base, $ofs, $fmt)= $self->_parse_value_expr($prev);
$_->[1]= sprintf $fmt, $ofs+1;
}
$prev= $_->[1];
}
$self->{values}= \@values;
$self->{_analysis}= undef;
$self;
}
sub value_table_var($self, @val) {
if (@val) {
$self->{value_table_var}= $val[0];
return $self;
}
$self->{value_table_var} // $self->symbol_prefix . 'value_table';
}
sub indent($self, @val) {
if (@val) {
$self->{indent}= $val[0];
return $self;
}
$self->{indent} // ' ';
}
sub _current_indent {
$CodeGen::Cpppp::INDENT // shift->indent;
}
sub num_format($self, @val) {
if (@val) {
$self->{num_format}= $val[0];
$self->{_analysis}= undef;
return $self;
}
$self->{num_format} // '%d';
}
sub max_waste_factor($self, @val) {
if (@val) {
$self->{max_waste_factor}= $val[0];
$self->{_analysis}= undef;
return $self;
}
$self->{max_waste_factor} // 2;
}
our %_algorithm= map +( $_ => 1 ), qw( bsearch hashtable switch );
sub algorithm($self, @val) {
if (@val) {
!defined $val[0] or $_algorithm{$val[0]}
or croak "Unknown parse_design '$val[0]', expected one of ".join(', ', keys %_algorithm);
$self->{algorithm}= $val[0];
return $self;
}
$self->{algorithm}
}
sub _parse_value_expr($self, $val) {
# Make the common case fast
return '', +$val, '%d'
if $val =~ /^[-+]?(?:0|[1-9][0-9]*)\Z/;
# else need to parse the expression
my @tokens= CodeGen::Cpppp::CParser->tokenize($val);
my $type_pattern= join '', map $_->type, @tokens;
# Recognize patterns where a +N occurs at the end of the expression
# Else, the whole value is the expression and will get '+N' appended.
return $val, 0, "($val+".($self->{num_format}//'%d').")"
unless $type_pattern =~ /(^|[-+])integer\W*$/;
lib/CodeGen/Cpppp/Enum.pm view on Meta::CPAN
substr($fmt_str, $pos, $pos2-$pos, '%'.($pos2-$pos).$notation);
# The "base" is everying to the left of the number minus the number of "("
# to match the number of ")" to the right of the number
my $rparen= grep $_->type eq ')', @tokens[$i..$#tokens];
shift @tokens while $tokens[0]->type eq '(' && $rparen--;
my $base= substr($val, $tokens[0]->src_pos, $pos-$tokens[0]->src_pos);
return ($base, $n, $fmt_str);
}
sub is_symbolic($self) {
$self->_analysis->{base_expr} ne '';
}
sub is_sequential($self) {
$self->_analysis->{is_seq}
}
sub is_nearly_sequential($self) {
$self->_analysis->{is_nearly_seq}
}
sub _analysis($self) {
$self->{_analysis} //= do {
my @vals= map +[ $_->[0], $self->_parse_value_expr($_->[1]) ], $self->values;
my $base_expr= $vals[0][1];
my %seen_ofs= ( $vals[0][2] => 1 );
for (@vals[1..$#vals]) {
# Can't be sequential unless they share a symbolic base expression
$base_expr= undef, last
unless $_->[1] eq $base_expr;
$seen_ofs{$_->[2]}++;
}
lib/CodeGen/Cpppp/Enum.pm view on Meta::CPAN
$info{gap}= $gap;
$info{min}= $min;
$info{max}= $max;
$info{base_expr}= $base_expr;
}
\%info
};
}
sub generate_declaration($self, %options) {
return join "\n", $self->_generate_declaration_macros(\%options);
}
sub _generate_declaration_macros($self, $options) {
my @vals= $self->values;
my $name_width= max map length($_->[0]), @vals;
my $prefix= $self->macro_prefix;
my $fmt= "#define $prefix%-${name_width}s %s";
return map sprintf($fmt, $_->[0], $_->[1]), @vals;
}
sub generate_static_tables($self, %options) {
return join "\n", _generate_enum_table($self, \%options);
}
sub _generate_enum_table($self, $options) {
my $prefix= $self->prefix;
my @names= map $prefix . $_->[0], $self->values;
my $name_width= max map length, @names;
my $indent= $self->_current_indent;
my $fmt= $indent.$indent.'{ "%s",%*s %s },';
my @code= (
"const struct { const char *name; const ".$self->type." value; }",
$indent . $self->value_table_var . "[] = {",
(map sprintf($fmt, $_, $name_width-length, '', $_), @names),
$indent . '};'
);
substr($code[-2], -1, 1, ''); # remove trailing comma
return @code;
}
sub generate_lookup_by_value($self, %options) {
return join "\n", $self->_generate_lookup_by_value_switch(\%options);
}
sub _generate_lookup_by_value_switch($self, $options) {
my @vals= $self->values;
my $name_width= max map length($_->[0]), @vals;
my $info= $self->_analysis;
my $val_variable= 'value';
my $prefix= $self->macro_prefix;
my $enum_table= $self->value_table_var;
# Generate a switch() table to look them up
my @code= "switch ($val_variable) {";
my $fmt= "case $prefix%s:%*s return ${enum_table}[%d].name;";
for (0..$#vals) {
push @code, sprintf($fmt, $vals[$_][0], $name_width - length($vals[$_][0]), '', $_);
}
push @code, 'default: return NULL;', '}';
return @code;
}
sub generate_lookup_by_name($self, %options) {
return join "\n", $self->_generate_lookup_by_name_switch(\%options);
}
sub _generate_lookup_by_name_switch($self, $options) {
my @vals= $self->values;
my $info= $self->_analysis;
my $caseless= $options->{caseless};
my $prefixless= $options->{prefixless};
my $prefixlen= length($self->macro_prefix);
my $indent= $self->_current_indent;
my $len_var= $options->{len_var} // 'len';
my $str_ptr= $options->{str_ptr} // 'str';
my $enum_table= $self->value_table_var;
my $strcmp= $caseless? "strcasecmp" : "strcmp";
lib/CodeGen/Cpppp/Enum.pm view on Meta::CPAN
}
push @code,
"if ($strcmp($str_ptr, ${enum_table}[test_el].name) == 0) {",
"${indent}if (value_out) *value_out= ${enum_table}[test_el].value;",
"${indent}return true;",
"}",
"return false;";
return @code;
}
sub _binary_split($self, $vals, $caseless, $str_var, $pivot_pos) {
# Stop at length 1
return qq{test_el= $vals->[0][1];}
if @$vals == 1;
# Find a character comparison that splits the list roughly in half.
my $goal= .5 * scalar @$vals;
# Test every possible character and keep track of the best.
my ($best_i, $best_ch, $best_less);
for (my $i= 0; $i < length $vals->[0][0]; ++$i) {
if (!$caseless) {
for my $ch (uniqstr map substr($_->[0], $i, 1), @$vals) {
lib/CodeGen/Cpppp/Output.pm view on Meta::CPAN
use Scalar::Util 'looks_like_number';
use List::Util 'max';
use overload '""' => sub { $_[0]->get };
our %standard_sections= (
public => 100,
protected => 200,
private => 10000,
);
sub new($class, @args) {
bless {
section_priority => { %standard_sections },
out => {},
@args == 1 && ref $args[0]? %{$args[0]}
: !(@args & 1)? @args
: croak "Expected hashref or even-length list"
}, $class;
}
sub section_list($self) {
my $pri= $self->section_priority;
sort { $pri->{$a} <=> $pri->{$b} } keys %$pri;
}
sub has_section($self, $name) {
defined $self->section_priority->{$name};
}
sub section_priority($self) {
$self->{section_priority}
}
sub declare_sections($self, @list) {
my $pri= $self->section_priority;
my $max_before_private= max grep $_ < $pri->{private}, values %$pri;
my $next= $max_before_private + 1;
while (@list) {
my $name= shift @list;
looks_like_number($name) and croak "Expected non-numeric name at '$name'";
if (looks_like_number($list[0])) {
$pri->{$name}= shift @list;
} elsif (!defined $pri->{$name}) {
$name =~ /\.\.|,/ and croak "Section names may not contain '..' or ','";
$pri->{$name}= $next++;
}
}
$self;
}
sub append($self, $section, @code) {
defined $self->{section_priority}{$section} or croak "Unknown section $section";
push @{$self->{out}{$section}}, @code;
}
sub prepend($self, $section, @code) {
defined $self->{section_priority}{$section} or croak "Unknown section $section";
unshift @{$self->{out}{$section}}, @code;
}
sub expand_section_selector($self, @list) {
@list= map +(ref $_ eq 'ARRAY'? @$_ : $_), @list;
@list= map split(',', $_), @list;
my $sec_pri= $self->section_priority;
my %seen;
for (@list) {
if (/([^.]+)\.\.([^.]+)/) {
my $low= $sec_pri->{$1} // croak "Unknown section $1";
my $high= $sec_pri->{$2} // croak "Unknown section $2";
for (keys %$sec_pri) {
$seen{$_}++ if $sec_pri->{$_} >= $low && $sec_pri->{$_} <= $high;
}
} else {
$sec_pri->{$_} // croak "Unknown section $_";
$seen{$_}++;
}
}
sort { $sec_pri->{$a} <=> $sec_pri->{$b} } keys %seen;
}
sub get($self, @sections) {
my @sec= @sections? $self->expand_section_selector(@sections) : $self->section_list;
join '', map @{$self->{out}{$_} // []}, @sec;
}
sub consume($self, @sections) {
my @sec= @sections? $self->expand_section_selector(@sections) : $self->section_list;
my $out= join '', map @{delete $self->{out}{$_} // []}, @sec;
@{$self->{out}{$_}}= () for @sec;
$out
}
1;
__END__
lib/CodeGen/Cpppp/Template.pm view on Meta::CPAN
sub format_commandline {
require CodeGen::Cpppp::Platform;
CodeGen::Cpppp::Platform::format_commandline(@_);
}
sub format_timestamp {
my @t= gmtime;
sprintf "%04d-%02d-%02dT%02d:%02d:%02dZ", $t[5]+1900, @t[4,3,2,1,0]
}
}
sub _tag_for_version($ver) {
return ':v0';
}
sub import {
my $class= $_[0];
my $caller= caller;
for (my $i= 1; $i < @_; $i++) {
if ($_[$i] eq '-setup') {
my $ver= version->parse($_[$i+1]);
splice(@_, $i, 2, _tag_for_version($ver));
$class->_setup_derived_package($caller, $ver);
}
}
splice(@_, 0, 1, 'CodeGen::Cpppp::Template::Exports');
goto \&Exporter::import;
}
our $_next_pkg= 1;
sub _create_derived_package($class, $cpppp_ver, $parse_data) {
my $pkg= 'CodeGen::Cpppp::Template::_'.$_next_pkg++;
no strict 'refs';
@{"${pkg}::ISA"}= ( $class );
${"${pkg}::cpppp_version"}= $cpppp_ver;
$pkg->_init_parse_data($parse_data);
}
sub _setup_derived_package($class, $pkg, $cpppp_ver) {
strict->import;
warnings->import;
utf8->import;
experimental->import(qw( lexical_subs signatures postderef ));
no strict 'refs';
@{"${pkg}::ISA"}= ( $class ) unless @{"${pkg}::ISA"};
${"${pkg}::cpppp_version"}= $cpppp_ver;
}
sub _init_parse_data($class, $parse_data) {
no strict 'refs';
${"${class}::_parse_data"}= $parse_data;
# Create accessors for all of the attributes declared in the template.
for (keys $parse_data->{template_parameter}->%*) {
my $name= $_;
*{"${class}::$name"}= sub { $_[0]{$name} };
}
# Expose all of the functions declared in the template
for (keys $parse_data->{template_method}->%*) {
my $name= $_;
*{"${class}::$name"}= sub {
my $m= shift->{template_method}{$name}
or croak "Template execution did not define method '$name'";
goto $m;
};
}
$class;
}
sub cpppp_version($class) {
no strict 'refs';
${"${class}::cpppp_version"} // __PACKAGE__->VERSION
}
sub _gen_perl_scope_functions($class, $cpppp_ver) {
return (
'# line '. (__LINE__+1) . ' "' . __FILE__ . '"',
'my sub param { unshift @_, $self; goto $self->can("_init_param") }',
'my sub define { unshift @_, $self; goto $self->can("define_template_macro") }',
'my sub section { unshift @_, $self; goto $self->can("current_output_section") }',
'my sub template { unshift @_, $self->context; goto $self->context->can("new_template") }',
'my $trim_comma= CodeGen::Cpppp::AntiCharacter->new(qr/,/, qr/\s*/);',
'my $trim_ws= CodeGen::Cpppp::AntiCharacter->new(qr/\s*/);',
);
}
sub _gen_BUILD_method($class, $cpppp_ver, $perl, $src_filename, $src_lineno) {
return
"sub ${class}::BUILD(\$self, \$constructor_parameters=undef) {",
" Scalar::Util::weaken(\$self);",
# Inject all the lexical functions that need to be in scope
$class->_gen_perl_scope_functions($cpppp_ver),
qq{# line $src_lineno "$src_filename"},
$perl,
"}",
}
sub _build_BUILD_method($class, $version, $perl, $src_filename, $src_lineno) {
{
no strict 'refs';
croak "${class}::BUILD is already defined" if defined &{$class.'::BUILD'};
}
croak "Compile failed for ${class}::BUILD() : $@"
unless eval join "\n",
$class->_gen_BUILD_method($version, $perl, $src_lineno, $src_filename),
'1';
}
sub context { $_[0]{context} }
sub output { $_[0]->flush->{output} }
sub current_output_section($self, $new=undef) {
if (defined $new) {
$self->output->has_section($new)
or croak "No defined output section '$new'";
$self->_finish_render;
$self->{current_output_section}= $new;
}
$self->{current_output_section};
}
sub autocolumn { $_[0]{autocolumn} = $_[1]||0 if @_ > 1; $_[0]{autocolumn} }
sub autocomma { $_[0]{autocomma} = $_[1]||0 if @_ > 1; $_[0]{autocomma} }
sub autoindent { $_[0]{autoindent} = $_[1]||0 if @_ > 1; $_[0]{autoindent} }
sub autostatementline { $_[0]{autostatementline}= $_[1]||0 if @_ > 1; $_[0]{autostatementline} }
sub indent { $_[0]{indent} = $_[1] if @_ > 1; $_[0]{indent} }
sub emit_POD { $_[0]{emit_POD} = $_[1]||0 if @_ > 1; $_[0]{emit_POD} }
sub _parse_data($class) {
$class = ref $class if ref $class;
no strict 'refs';
return ${"${class}::_parse_data"};
}
sub new($class, @args) {
no strict 'refs';
my %attrs= @args == 1 && ref $args[0]? $args[0]->%*
: !(@args&1)? @args
: croak "Expected even-length list or hashref";
my $parse= $class->_parse_data;
# Make sure each attr is the correct type of ref, for the params.
for (keys %attrs) {
if (my $p= $parse->{template_parameter}{$_}) {
if ($p eq '@') { ref $attrs{$_} eq 'ARRAY' or croak("Expected ARRAY for parameter $_"); }
elsif ($p eq '%') { ref $attrs{$_} eq 'HASH' or croak("Expected HASH for parameter $_"); }
lib/CodeGen/Cpppp/Template.pm view on Meta::CPAN
current_output_section => 'private',
%attrs,
}, $class;
Scalar::Util::weaken($self->{context})
if $self->{context};
$self->BUILD(\%attrs);
$self->flush;
}
sub coerce_parameters($class, $params) {
my %ret;
my $parse= $class->_parse_data;
for my $k (keys $parse->{template_parameter}->%*) {
my $p= $parse->{template_parameter}{$k};
my $v= $params->{$p.$k} // $params->{$k};
next unless defined $v;
if ($p eq '@') {
$v= ref $v eq 'HASH'? [ keys %$v ] : [ $v ]
unless ref $v eq 'ARRAY';
} elsif ($p eq '%') {
# If it isn't a hash, treat it like a list that needs added to a set
$v= { map +($_ => 1), ref $v eq 'ARRAY'? @$v : ($v) }
unless ref $v eq 'HASH';
}
$ret{$k}= $v;
}
\%ret;
}
sub _init_param($self, $name, $ref, @initial_value) {
if (exists $self->{$name}) {
# Assign the value received from constructor to the variable in the template
ref $ref eq 'SCALAR'? ($$ref= $self->{$name})
: ref $ref eq 'ARRAY' ? (@$ref= @{$self->{$name} || []})
: ref $ref eq 'HASH' ? (%$ref= %{$self->{$name} || {}})
: croak "Unhandled ref type ".ref($ref);
} else {
ref $ref eq 'SCALAR'? ($$ref= $initial_value[0])
: ref $ref eq 'ARRAY' ? (@$ref= @initial_value)
: ref $ref eq 'HASH' ? (%$ref= @initial_value)
: croak "Unhandled ref type ".ref($ref);
}
# Now store the variable of the template directly into this hash
ref $ref eq 'SCALAR'? Hash::Util::hv_store(%$self, $name, $$ref)
: ($self->{$name}= $ref);
$ref;
}
sub flush($self) {
$self->_finish_render;
$self;
}
sub define_template_macro($self, $name, $code) {
$self->{template_macro}{$name}= $code;
}
sub define_template_method($self, $name, $code) {
$self->{template_method}{$name}= $code;
}
sub _render_pod_block($self, $i) {
if ($self->emit_POD) {
$self->_finish_render;
$self->{output}->append($self->{current_output_section} => $self->_parse_data->{pod_blocks}[$i]);
}
}
sub _finish_render($self) {
return unless defined $self->{current_out};
# Second pass, adjust whitespace of all column markers so they line up.
# Iterate from leftmost column rightward.
for my $group_i (sort { $a <=> $b } keys %{$self->{current_out_colgroup_state}}) {
delete $self->{current_out_colgroup_state}{$group_i}
if $self->{current_out_colgroup_state}{$group_i} == 2;
my $token= _colmarker($group_i);
# Find the longest prefix (excluding trailing whitespace)
# Also find the max number of digits following column.
my ($maxcol, $maxdigit)= (0,0);
lib/CodeGen/Cpppp/Template.pm view on Meta::CPAN
}
$self->{current_out} =~ s/[ ]* $token (?= (-? 0x[A-Fa-f0-9]+ | -? \d+)? )/
$linestart= rindex($self->{current_out}, "\n", $-[0])+1;
" "x(1 + $maxcol - ($-[0] - $linestart) + ($1? $maxdigit - length($1) : 0))
/gex;
}
$self->{output}->append($self->{current_output_section} => $self->{current_out});
$self->{current_out}= '';
}
sub _colmarker($colgroup_id) { join '', "\x{200A}", map chr(0x2000+$_), split //, $colgroup_id; }
sub _str_esc { join '', map +(ord($_) > 0x7e || ord($_) < 0x21? sprintf("\\x{%X}",ord) : $_), split //, $_[0] }
sub _render_code_block {
my ($self, $i, @expr_subs)= @_;
my $block= $self->_parse_data->{code_block_templates}[$i];
my $text= $block->{text};
# Continue appending to the same output buffer so that autocolumn can
# inspect the result as a whole.
my $out= \($self->{current_out} //= '');
my $at= 0;
( run in 1.134 second using v1.01-cache-2.11-cpan-65fba6d93b7 )