File Coverage

blib/lib/Preproc/Tiny.pm

Criterion	Covered	Total	%
statement	44	48	91.6
branch	13	18	72.2
condition	2	4	50.0
subroutine	9	9	100.0
pod	1	5	20.0
total	69	84	82.1

#------------------------------------------------------------------------------
# Preproc::Tiny - Minimal stand-alone preprocessor for code generation using perl
# Copyright (C) 2016 by Paulo Custodio
#------------------------------------------------------------------------------

package Preproc::Tiny;

use 5.010;
use strict;
use warnings;
use File::Basename;

require Exporter;

our @ISA = qw( Exporter );
our @EXPORT = qw( pp );
our $VERSION = '0.02';

#------------------------------------------------------------------------------
# Code borrowed from Data::Dump
#------------------------------------------------------------------------------
my %esc = (
    "\a" => "\\a",
    "\b" => "\\b",
    "\t" => "\\t",
    "\n" => "\\n",
    "\f" => "\\f",
    "\r" => "\\r",
    "\e" => "\\e",
);

sub quote {
	local($_) = $_[0];
	# If there are many '"' we might want to use qq() instead
	s/([\\\"\@\$])/\\$1/g;
	return qq("$_") unless /[^\040-\176]/;  # fast exit

	s/([\a\b\t\n\f\r\e])/$esc{$1}/g;

	# no need for 3 digits in escape for these
	s/([\0-\037])(?!\d)/sprintf('\\%o',ord($1))/eg;

	s/([\0-\037\177-\377])/sprintf('\\x%02X',ord($1))/eg;
	s/([^\040-\176])/sprintf('\\x{%X}',ord($1))/eg;

	return qq("$_");
}

#------------------------------------------------------------------------------
# Path::Tiny spew and slurp
#------------------------------------------------------------------------------
sub spew {
	my($file, $text) = @_;
	open(my $fh, '>', $file)
		or die "Cannot write file $file: $!\n";
	print $fh $text;
}

sub slurp {
	my($file) = @_;
	open(my $fh, '<', $file)
		or die "Cannot read file $file: $!\n";
	local $/ = undef;
	my $text = <$fh>;
	close($fh);
	return $text;
}

#------------------------------------------------------------------------------
# pp(), the only export
#------------------------------------------------------------------------------
sub pp {
	for my $infile (@_) {
		(my $outfile = $infile) =~ s/\.pp$//i
			or die "Error: input file needs .pp extension\n";
		my $plfile = "$outfile.pl";

		# build code to pre-process
		my $pl = 'my $OUT = "";'."\n";

		local $_ = slurp($infile);
		while (! at_end($_) ) {
			if (/\G (?| ^ \@\@ (.*) \n?
			          |   \@\@ (.*)
					) /gcxim) {
				$pl .= $1."\n";
			}
			elsif (/\G \[\@> \s* (.*?)  (?: -\@\] \s* | \@\] ) /gcxis) {
				$pl .= '$OUT .= '.$1.";\n";
			}
			elsif (/\G \[\@  \s* (.*?)  (?: -\@\] \s* | \@\] ) /gcxis) {
				$pl .= $1.";\n";
			}
			elsif (/ ( [^\[\@]+ ) /gcxi) {
				$pl .= '$OUT .= '.quote($1).";\n";
			}
			else {
				die "$infile: parse error at ".quote(substr($_, pos($_)||0, 100))."\n";
			}
		}

		# build code to generate output file
		$pl .=  'open(my $fh, ">", '.quote($outfile).') or die $!;'."\n".
				'print $fh $OUT;'."\n".
				"1;\n";

		# run template
		spew($plfile, $pl);
		system($^X, $plfile)==0 or die "$infile: parse error\n";

		# delete temp file
		unlink $plfile;
	}
}

sub at_end {
	return (pos($_[0])||0) >= length($_[0]);
}

#------------------------------------------------------------------------------
# Run if called as a script
#------------------------------------------------------------------------------
unless (caller) {
	@ARGV or die "Usage: ",basename($0)," file.pp...\n";
	pp(@ARGV);
}

1;
__END__