Merge pull request #13 from cxw42/bang

Added <?!...?> (external cmd) and -k (keep going)

Author: cxw42

README.md

@@ -28,11 +28,12 @@ Usage
 					Perl code of the input files.
 		-E, --debug		Don't evaluate Perl code, just write
 					it to STDERR.
-		-s, --set name=value	As -D, but gneerates into %S and does
+		-k, --keep-going	Don't stop on errors in an external command
+		-s, --set name=value	As -D, but generates into %S and does
 					not substitute in the text body.
 		-h, --help		Usage help.
 
-In a **-D** command, the `value` must be a valid Perl value, e.g., `"foo"`
+In a **-D** option, the `value` must be a valid Perl value, e.g., `"foo"`
 for a string.  This may require you to escape quotes in the **-D** argument,
 depending on your shell.  E.g., if `-D foo="bar"` doesn't work, try
 `-D 'foo="bar"'` (with single quotes around the whole `name=value` part).
@@ -46,9 +47,10 @@ There are several modes, indicated by the character after the `<?`:
 
 	<?	code mode: Perl code is between the tags.
 	<?=	echo mode: prints a Perl expression
-	<?:	command mode: executed by PerlPP itself (see below)
+	<?:	internal-command mode: executed by PerlPP itself (see below)
 	<?/	code mode, beginning with printing a line break.
 	<?#	comment mode: everything in <?# ... ?> is ignored.
+	<?!	external mode: everything in <?! ... ?> is run as an external command
 
 The code mode is started by `<?` followed by any number of whitespaces
 or line breaks.
@@ -72,6 +74,7 @@ The generated script:
 - `use`s `5.010`, `strict`, and `warnings`
 - provides constants `true` (=`!!1`) and `false` (=`!!0`) (with `use constant`)
 - Declares `my %D` and initializes `%D` based on any **-D** options you provide
+- Declares `my %S` and initializes `%S` based on any **-s** options you provide
 
 Other than that, everything in the script comes from your input file(s).
 Use the **-E** option to see the generated script.
@@ -140,8 +143,29 @@ produces the output
 
 So `<?/ ... ?>` is effectively a shorthand for `<? print "\n"; ... ?>`.
 
-Commands
---------
+### External commands using `<?!`
+
+The example
+
+	<?!echo Howdy!?>
+
+produces the output
+
+	Howdy!
+
+If the command returns an error status, perlpp will as well, unless you
+specify **-k**.  That way you can use perlpp and external commands in `make`
+and other programs that check exit codes, and not silently lose error
+information.  For example, running `perlpp` on the input:
+
+	<?! false ?> More stuff
+
+will give you an error message (from the `false`'s error return), and will not
+print `More stuff`.  Running `perlpp -k` on that same input will give the
+error message and will print `More stuff`.
+
+Internal Commands
+-----------------
 
 ### Include
 
@@ -218,7 +242,8 @@ string `'alphabet '`, so the result will be
 	ALPHABET
 		ABCDEFGHIJKLMNOPQRSTUVWXYZ
 
-Capturing works in all modes: code, echo, or command mode.
+Capturing works in all modes: code, echo, internal-command, or
+external-command mode.
 
 C Preprocessor Emulation
 ------------------------

perlpp.pl

@@ -5,7 +5,7 @@
 # http://darkness.codefu.org/wordpress/2003/03/perl-scoping/
 
 package PerlPP;
-our $VERSION = '0.3.0-alpha';
+our $VERSION = '0.3.0-pre.2';
 
 use v5.10;		# provides // - http://perldoc.perl.org/perl5100delta.html
 use strict;
@@ -46,6 +46,7 @@ package PerlPP;
 use constant OBMODE_ECHO	=> 3;
 use constant OBMODE_COMMAND	=> 4;
 use constant OBMODE_COMMENT	=> 5;
+use constant OBMODE_SYSTEM	=> 6;	# an external command being run
 
 # Layout of the output-buffer stack.
 use constant OB_TOP 		=> 0;	# top of the stack is [0]: use [un]shift
@@ -58,6 +59,7 @@ package PerlPP;
 my $Package = '';			# package name for the generated script
 my $RootSTDOUT;
 my $WorkingDir = '.';
+my %Opts;					# Parsed command-line options
 
 # Vars accessible to, or used by or on behalf of, :macro / :immediate code
 my @Preprocessors = ();
@@ -259,6 +261,45 @@ sub ExecuteCommand {
 	}
 } #ExecuteCommand()
 
+sub GetStatusReport {
+	# Get a human-readable result string, given $? and $! from a qx//.
+	# Modified from http://perldoc.perl.org/functions/system.html
+	my $retval;
+	my $status = shift;
+	my $errmsg = shift || '';
+
+	if ($status == -1) {
+		$retval = "failed to execute: $errmsg";
+	} elsif ($status & 127) {
+		$retval = sprintf("process died with signal %d, %s coredump",
+			($status & 127), ($status & 128) ? 'with' : 'without');
+	} elsif($status != 0) {
+		$retval = sprintf("process exited with value %d", $status >> 8);
+	}
+	return $retval;
+} # GetStatusReport()
+
+sub ShellOut {		# Run an external command
+	my $cmd = shift =~ s/^\s+|\s+$//gr;		# trim leading/trailing whitespace
+	die "No command provided to @{[TAG_OPEN]}!...@{[TAG_CLOSE]}" unless $cmd;
+	$cmd = QuoteString $cmd;	# note: cmd is now wrapped in ''
+
+	my $error_response = ($Opts{KEEP_GOING} ? 'warn' : 'die');	# How we will handle errors
+
+	print(
+		qq{do {
+			my \$output = qx${cmd};
+			my \$status = PerlPP::GetStatusReport(\$?, \$!);
+			if(\$status) {
+				$error_response("perlpp: command '" . ${cmd} . "' failed: \${status}; invoked");
+			} else {
+				print \$output;
+			}
+		};
+		} =~ s/^\t{2}//gmr	# de-indent
+	);
+} #ShellOut()
+
 sub OnOpening {
 	# takes the rest of the string, beginning right after the ? of the tag_open
 	# returns (withinTag, string still to be processed)
@@ -286,6 +327,8 @@ sub OnOpening {
 			# OBMODE_CODE
 		} elsif ( $after =~ /^(?:\s|$)/ ) {
 			# OBMODE_CODE
+		} elsif ( $after =~ /^!/ ) {
+			$insetMode = OBMODE_SYSTEM;
 		} elsif ( $after =~ /^"/ ) {
 			die "Unexpected end of capturing";
 		} else {
@@ -328,6 +371,8 @@ sub OnClosing {
 			# Ignore the contents - no operation
 		} elsif ( $insetMode == OBMODE_CODE ) {
 			print "$inside\n";	# \n so you can put comments in your perl code
+		} elsif ( $insetMode == OBMODE_SYSTEM ) {
+			ShellOut( $inside );
 		} else {
 			print $inside;
 		}
@@ -447,19 +492,20 @@ sub OutputResult {
 	close( $f ) or die $!;
 } #OutputResult()
 
-# === Command line ========================================================
+# === Command line parsing ================================================
 
 my %CMDLINE_OPTS = (
-	# hash from internal name to array reference of j
+	# hash from internal name to array reference of
 	# [getopt-name, getopt-options, optional default-value]
 	# They are listed in alphabetical order by option name,
 	# lowercase before upper, although the code does not require that order.
 
-	EVAL => ['e','|eval=s', ""],
+	EVAL => ['e','|eval=s', ''],
 	DEBUG => ['d','|E|debug', false],
 	# -h and --help reserved
 	# --man reserved
-	# INPUT_FILENAME assigned by parse_command_line_into
+	# INPUT_FILENAME assigned by parse_command_line_into()
+	KEEP_GOING => ['k','|keep-going',false],
 	OUTPUT_FILENAME => ['o','|output=s', ""],
 	DEFS => ['D','|define:s%'],		# In %D, and text substitution
 	SETS => ['s','|set:s%'],		# Extra data in %S, without text substitution
@@ -517,17 +563,16 @@ sub parse_command_line_into {
 
 # === Main ================================================================
 sub Main {
-	my %opts;
-	parse_command_line_into \%opts;
+	parse_command_line_into \%Opts;
 
 	# Preamble
 
-	$Package = $opts{INPUT_FILENAME};
+	$Package = $Opts{INPUT_FILENAME};
 	$Package =~ s/^.*?([a-z_][a-z_0-9.]*).pl?$/$1/i;
 	$Package =~ s/[^a-z0-9_]/_/gi;
 		# $Package is not the whole name, so can start with a number.
 
-	StartOB();
+	StartOB();	# Output from here on will be included in the generated script
 	print "package PPP_${Package};\nuse 5.010;\nuse strict;\nuse warnings;\n";
 	print "use constant { true => !!1, false => !!0 };\n";
 
@@ -537,8 +582,8 @@ sub Main {
 	# as textual representations of expressions.
 	# The parameters are in %D at runtime.
 	print "my %D = (\n";
-	for my $defname (keys %{$opts{DEFS}}) {
-		my $val = ${$opts{DEFS}}{$defname} // 'true';
+	for my $defname (keys %{$Opts{DEFS}}) {
+		my $val = ${$Opts{DEFS}}{$defname} // 'true';
 			# just in case it's undef.  "true" is the constant in this context
 		$val = 'true' if $val eq '';
 			# "-D foo" (without a value) sets it to _true_ so
@@ -549,42 +594,42 @@ sub Main {
 	print ");\n";
 
 	# Save a copy for use at generation time
-	%Defs = map {	my $v = eval(${$opts{DEFS}}{$_});
+	%Defs = map {	my $v = eval(${$Opts{DEFS}}{$_});
 					warn "Could not evaluate -D \"$_\": $@" if $@;
 					$_ => ($v // true)
 				}
-			keys %{$opts{DEFS}};
+			keys %{$Opts{DEFS}};
 
 	# Set up regex for text substitution of Defs.
 	# Modified from http://www.perlmonks.org/?node_id=989740 by
 	# AnomalousMonk, http://www.perlmonks.org/?node_id=634253
-	if(%{$opts{DEFS}}) {
+	if(%{$Opts{DEFS}}) {
 		my $rx_search =
-			'\b(' . (join '|', map quotemeta, keys %{$opts{DEFS}}) . ')\b';
+			'\b(' . (join '|', map quotemeta, keys %{$Opts{DEFS}}) . ')\b';
 		$Defs_RE = qr{$rx_search};
 
 		# Save the replacement values.  If a value cannot be evaluated,
 		# use the name so the replacement will not change the text.
 		%Defs_repl_text =
-			map {	my $v = eval(${$opts{DEFS}}{$_});
+			map {	my $v = eval(${$Opts{DEFS}}{$_});
 					($@ || !defined($v)) ? ($_ => $_) : ($_ => ('' . $v))
 				}
-			keys %{$opts{DEFS}};
+			keys %{$Opts{DEFS}};
 	}
 
 	# Now do SETS: -s or --set, into %S by analogy with -D and %D.
 
 	# Save a copy for use at generation time
-	%Sets = map {	my $v = eval(${$opts{SETS}}{$_});
+	%Sets = map {	my $v = eval(${$Opts{SETS}}{$_});
 					warn "Could not evaluate -s \"$_\": $@" if $@;
 					$_ => ($v // true)
 				}
-			keys %{$opts{SETS}};
+			keys %{$Opts{SETS}};
 
 	# Make the copy for runtime
 	print "my %S = (\n";
-	for my $defname (keys %{$opts{SETS}}) {
-		my $val = ${$opts{SETS}}{$defname};
+	for my $defname (keys %{$Opts{SETS}}) {
+		my $val = ${$Opts{SETS}}{$defname};
 		if(!defined($val)) {
 		}
 		$val = 'true' if $val eq '';
@@ -596,20 +641,20 @@ sub Main {
 	print ");\n";
 
 	# Initial code from the command line, if any
-	print $opts{EVAL}, "\n" if $opts{EVAL};
+	print $Opts{EVAL}, "\n" if $Opts{EVAL};
 
 	# The input file
-	ProcessFile( $opts{INPUT_FILENAME} );
+	ProcessFile( $Opts{INPUT_FILENAME} );
 
 	my $script = EndOB();							# The generated Perl script
 
 	# --- Run it ---
-	if ( $opts{DEBUG} ) {
+	if ( $Opts{DEBUG} ) {
 		print $script;
 
 	} else {
-		StartOB();									# output of the Perl script
-		my $result;		# save any errors from the eval
+		StartOB();		# Start collecting the output of the Perl script
+		my $result;		# To save any errors from the eval
 
 		# TODO hide %Defs and others of our variables we don't want
 		# $script to access.
@@ -619,7 +664,7 @@ sub Main {
 			print STDERR $result;
 			exit 1;
 		} else {		# Save successful output
-			OutputResult( \EndOB(), $opts{OUTPUT_FILENAME} );
+			OutputResult( \EndOB(), $Opts{OUTPUT_FILENAME} );
 		}
 	}
 } #Main()
@@ -682,6 +727,12 @@ =head1 OPTIONS
 Don't evaluate Perl code, just write the generated code to STDOUT.
 By analogy with the C<-E> option of gcc.
 
+=item -k, --keep-going
+
+Normally, errors in a C<!command> sequence will terminate further
+processing.  If B<-k> is given, an error message will be printed to stderr,
+but the script will keep running.
+
 =item -s, --set B<name>[=B<value>]
 
 As B<-D>, but:

t/cmdline.t

@@ -2,7 +2,7 @@
 # Tests of perlpp command-line options
 use strict;
 use warnings;
-use Test::More 'no_plan';
+use Test::More;
 use IPC::Run3;
 use constant CMD => 'perl perlpp.pl';
 
@@ -96,9 +96,17 @@ my @testcases=(
 
 ); #@testcases
 
-#plan tests => scalar @testcases;
-# TODO count the out_re and err_re in @testcases, since the number of
+# count the out_re and err_re in @testcases, since the number of
 # tests is the sum of those counts.
+my $testcount = 0;
+
+for my $lrTest (@testcases) {
+	my ($out_re, $err_re) = @$lrTest[2..3];
+	++$testcount if defined $out_re;
+	++$testcount if defined $err_re;
+}
+
+plan tests => $testcount;
 
 for my $lrTest (@testcases) {
 	my ($opts, $testin, $out_re, $err_re) = @$lrTest;