#!/usr/bin/env perl

#     Copyright © 2009-2010 by Nicola Vitacolonna. All rights reserved.
#
#     This program is free software: you can redistribute it and/or modify
#     it under the terms of the GNU General Public License as published by
#     the Free Software Foundation, either version 3 of the License, or
#     (at your option) any later version.
# 
#     This program is distributed in the hope that it will be useful,
#     but WITHOUT ANY WARRANTY; without even the implied warranty of
#     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#     GNU General Public License for more details.
# 
#     You should have received a copy of the GNU General Public License
#     along with this program.  If not, see <http://www.gnu.org/licenses/>.

# Requires: mpost, ConTeXt and, well, Perl!
use strict;
use warnings;
#===============================================================================
# Start of configurable parameters
#===============================================================================
my $TEX = 'texexec --dvi'; # The default processor for text labels (if empty, uses mpost's default)
my $TITLES = 1; # Set to 0 to suppress titles and margins in the preview
my $ONENOTITLE = 1; # Set to 1 to suppress the title and margins when there is only one figure
my $PREVIEW = 1; # Set to 0 if you don't want the preview to be created
my $BACKGROUNDCOLOR = 'default'; # The default background color of the preview
my $BACKGROUNDCOLORMODEL = ''; # This may be empty 'rgb', 'cmyk', 'gray' or 'named'
my $HMARGIN = 100; # Left and right margin in the preview (in pt)
my $VMARGIN = 100; # Top and bottom margin in the preview (in pt)
my $VERBOSE = 0; # Set to 1 for added verbosity
my $DEBUG = 0; # Set to 1 for debugging purposes
my $FIG = 'Fig.'; # Change or translate if you want
my $FIGEXT = '(\d+|mps|eps|ps|epsf|epsi|svg)';  # Recognized filename extensions for figures
my $EXCL = '^(.+\.log|.+\.mpo|.+\.mpx|mptextmp\.mp)$'; # Output files to ignore
#===============================================================================
# End of configurable parameters
#===============================================================================

my $VERSION = '1.4.0';
my $RELEASE_DATE = '2010/1/29';
my $MPOST = 'mpost'; # MetaPost executable (specify full path if needed)
my $extra_options = '-recorder'; # Additional mpost options
$extra_options .= ' -debug' if ($DEBUG);
print "This is MetaFun Engine $VERSION ($RELEASE_DATE) by Nicola Vitacolonna\n";
print 'Filename: ' . $ARGV[0] . "\n" if $VERBOSE;
if ($ARGV[0] =~ /(\\|\%)/) {
	print "Sorry, your filename must not contain the character '$1'.";
	print " Please rename your file.\n";
	exit(1);
}
my ($suffix) = ($ARGV[0] =~ /((\.mp)|(\.tex))$/);
unless (defined $suffix) {
	print "Sorry, your source file must have a .mp or .tex suffix\n";
	exit(1);
}
my ($jobname) = ($ARGV[0] =~ /^(.+)$suffix$/);
die "Please give a non-empty name to you file." unless (defined $jobname);
if ($jobname =~ /\s/) {
	print "WARNING: '$jobname$suffix' contain spaces,";
	print "	which *may* cause trouble.";
	print "	If compilation fails, try to rename '$jobname$suffix'";
	print "	without using spaces.\n";
}
$extra_options .= " -jobname=\"$jobname\"";
if ($suffix eq '.tex') {
	# Search for corresponding MetaPost file
	unless (-e $jobname . '.mp') {
		print "Sorry, I cannot find $jobname.mp.";
		exit(1);
	}
	$suffix = '.mp';
	$PREVIEW = 0; # Generating the preview may conflict with .tex file compilation
}

# Search for %!MPOST directives in the source file (which may be .mp, .mf or .tex)
if (open(SOURCE, '<', $ARGV[0])) {
	my $line;
	while ($line = <SOURCE>) {
		next if ($line =~ /^\s*$/);
		last if ($line !~ /^\s*%/); # Read until the first non-comment line is found
		if ($line =~ /^\s*%\s?!MPOST/) { # Parse %!MPOST directives
			my ($directive, $value) = ($line =~ /^\s*%\s?!MPOST\s+(tex|preview|backgroundcolor|titles?)\s*=\s*(.*)/);
			unless (defined $directive) {
				print "WARNING: skipping wrong directive: $line";
				next;
			}
			if ($directive eq 'tex') {
				$TEX = $value;
				# Filter potentially dangerous characters
				$TEX =~ s/[\;"'~&]//g;
				if ($TEX ne $value) {
					print "WARNING: stripped forbidden characters in ";
					print $line;
					print "The following characters are not allowed: \ ; \" ' ~ &\n";
				}
				# Strip leading and trailing spaces
				$TEX =~ s/^\s*//;
				$TEX =~ s/\s*$//;
				$TEX .= ' --dvi' if ($TEX =~ /texexec/);
				$extra_options .= ' -troff' if ($TEX =~ /troff/); # Untested
				print "Set TeX processor to '$TEX'.\n" if $VERBOSE;
			}
			elsif ($directive eq 'preview') {
				if ($value =~ /^\s*(on|yes|1)\s*$/) {
					$PREVIEW = 1;
					print "Preview generation enabled in the source.\n" if $VERBOSE;
				}
				elsif ($value =~ /^\s*(off|no|0)\s*$/) {
					$PREVIEW = 0;
					print "Preview generation disabled in the source.\n" if $VERBOSE;
				}
				else {
					print "WARNING: skipping wrong directive: $line";
				}
			}
			elsif ($directive eq 'backgroundcolor') {
				my ($model, $spec) = ($value =~ /^\s*([A-z]+)\s*\(?([\d,.\s]+)?\)?\s*$/);
				if (defined $model) {
					if (defined $spec) { # Assume color model rgb, cmyk or gray
						$BACKGROUNDCOLORMODEL = $model;
						$spec =~ s/\s//g; # Strip spaces
						$BACKGROUNDCOLOR = $spec;
						print "Set preview background color to $BACKGROUNDCOLORMODEL($BACKGROUNDCOLOR).\n" if $VERBOSE;
					}
					else { # Assume named color (e.g., red, cyan, etc...)
						$BACKGROUNDCOLORMODEL = 'named';
						$BACKGROUNDCOLOR = $model;
						print "Set preview background color to $BACKGROUNDCOLOR.\n" if $VERBOSE;
					}
				}
				else {
					print "WARNING: skipping wrong directive: $line";
				}
			}
			elsif ($directive =~ /titles?/) {
				if ($value =~ /^\s*(on|yes|1)\s*$/) {
					$TITLES = 1;
					$ONENOTITLE = 0;
					print "Preview titles enabled in the source.\n" if $VERBOSE;
				}
				elsif ($value =~ /^\s*(off|no|0)\s*$/) {
					$TITLES = 0;
					$ONENOTITLE = 1;
					print "Preview titles disabled in the source.\n" if $VERBOSE;
				}
				else {
					print "WARNING: skipping wrong directive: $line";
				}
			}
			else {
				print "WARNING: skipping wrong directive: $line";
			}
		} # end parsing %!MPOST
	}
	close(SOURCE);
}
else {
	print "WARNING: parsing $ARGV[0] for % !MPOST directives has failed." if $VERBOSE;
}

my $texproc = ($TEX) ? "-tex=\"" .$TEX ."\"" : "";
my $mpost_cmd = "$MPOST -mem=metafun $texproc $extra_options \"$jobname$suffix\"";
print "Going to process $jobname$suffix...\n";
print "Command: $mpost_cmd\n" if $VERBOSE;
# We do not use mptopdf here, because it does not work
# with 'filenametemplate'/'outputtemplate'
system($mpost_cmd); # Have fun
my $exit_status = verifySystemCall($mpost_cmd);
print "$MPOST has exited with status code: $exit_status.\n" if $VERBOSE;
# Read output files
my @mpout = (); # Any output file
my @fig = ();   # Figures
my $fn;
open(FLS, $jobname . '.fls') or die "Gosh! Cannot open $jobname.fls :o";
while (my $l = <FLS>) {
	if ( ($fn) = ($l =~ /^\s*OUTPUT\s*(.+)$/) ) {
		chomp($fn);
		unless ($fn =~ /$EXCL/) {
			push(@mpout, $fn);
			push(@fig, $fn) if ($fn =~ /\.$FIGEXT$/);
		}
	}
}
close(FLS);

unless (@mpout) {
	print "No output file generated.";
	print " Is your source really supposed to output any file?" if $VERBOSE;
	print "\n";
	exit($exit_status);
}
my $nn = @mpout;
my $s = ($nn > 1) ? 's' :  '';
my $a = ($nn > 1) ? ''  : ' a';
print "$jobname$suffix has generated the following" .
	(($nn > 1) ? " $nn"  : '') . " output file$s: @mpout.\n" if $VERBOSE;
unless (@fig) {
	print "$nn output file$s generated (not$a figure$s).";
	print " Is your source really supposed to generate any figure?" if $VERBOSE;
	print "\n";
	exit($exit_status);
}

# Filter files in SVG format
my @mps = ();
my @svg = ();
my @unk = (); # File with unknown format or unreadable
foreach $fn (@fig) {
	unless (open(FIG, '<', $fn)) {
		print "WARNING: cannot open $fn. Skipping this figure.\n";
		push(@unk, $fn);
		next;
	}
	my $header = <FIG>; # Read the first line
	close(FIG);
	if (defined $header) {
		if ($header =~ /^%!PS/) {
			push(@mps, $fn);
		}
		elsif ($header =~ /^<\?xml/) {
			push(@svg, $fn);
		}
		else {
			push(@unk, $fn);
		}
	}
	else {
		push(@unk, $fn);
	}
}
my $nummps = @mps;
my $numsvg = @svg;
my $numunk = @unk;
if ($VERBOSE) {
	if ($nummps > 0) {
		print "$nummps EPS figure" . (($nummps > 1) ? 's' : '') . " generated: @mps.\n";
	}
	else {
		print "No EPS figure generated.\n";
	}
}
if ($numsvg > 0) {
	print "$numsvg SVG figure" . (($numsvg > 1) ? 's' : '') . " generated: @svg\n";
	print "NOTE: SVG does not support MetaFun special features.";
	print " You may get unwanted results if your figures use transparency, shadows, and so on.\n";
}
if ($numunk > 0) {
	print "WARNING: $numunk figure" . (($numunk > 1) ? 's' : '') . " with unknown format: @unk\n";
}
# Make XHTML preview for SVG images, if any
if ($numsvg > 0 and $PREVIEW) {
	my $xhtml = '<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">';
	$xhtml .= '<html xmlns="http://www.w3.org/1999/xhtml">';
	$xhtml .= '<head>';
	$xhtml .= '<meta http-equiv="Content-Type" content="text/html;charset=utf-8"/>';
	$xhtml .= '<title>Preview generated by nv-metafun.engine ' .$VERSION. ' (' .$RELEASE_DATE. ')</title>';
	$xhtml .= '<style type="text/css">';
	if ($BACKGROUNDCOLOR ne 'default') {
		if ($BACKGROUNDCOLORMODEL eq 'named') {
			$xhtml .= 'body {background-color:' .$BACKGROUNDCOLOR. ';}';
		}
		else {
			$xhtml .= 'body {background-color:' .$BACKGROUNDCOLORMODEL. '(' .$BACKGROUNDCOLOR. ');}';	
		}
	}
	$xhtml .= 'div.title  {text-align:center;padding-bottom:25px;}';
	$xhtml .= 'div.figure {text-align:center;padding-bottom:50px;}';
	$xhtml .= '</style>';
	$xhtml .= '</head>';
	$xhtml .= '<body>';
	foreach my $f (@svg) {
		if ($TITLES and (not ($numsvg == 1 and $ONENOTITLE))) {
			$xhtml .= '<div class="title">' .$f. '</div>';
		}
		$xhtml .= '<div class="figure"><object type="image/svg+xml" data="';
		$xhtml .= $f. '" width="700" height="400"></object></div>';
	}
	$xhtml .= '</body></html>';
	unless (open(XHTML, '>', "$jobname.xhtml")) {
		print "ERROR: couldn't create $jobname.xhtml.\n";
		exit(1);
	}
	print "XHTML document for the preview: $xhtml\n" if $DEBUG;
	print XHTML $xhtml;
	close(XHTML);
	print "XHTML file '$jobname.xhtml' generated for $numsvg SVG figure"
		. (($numsvg > 1) ? 's' : '') . ": @svg.\n";
}
exit($exit_status) if ($nummps == 0);

if (-e "$jobname.log") {
	system("mv -f \"$jobname.log\" \"$jobname-mp.log\"");
	print "Renamed $jobname.log into $jobname-mp.log to avoid name clashes.\n";
}

my @pdf = ();
# Convert figure(s) to pdf using mptopdf
foreach my $f (@mps) {
	# Integrity check on suffix (mptopdf only recognizes .mps and .'number')
	my ($pref,$suff) = ($f =~ /^(.+)(\.[^\.]+)$/);
	unless (defined $suff and $suff =~ /^(\.mps)|(\.\d+)$/) {
		print "WARNING: mptopdf only accepts .mps and .<num> suffixes. ";
		print "Appended .mps suffix to $f.\n";
		# Append .mps suffix to filename
		my $newname = $f . '.mps';
		system("mv -f $f $newname");
		$f = $newname;
	}
	my $mptopdf_output = `mptopdf $f`;
	my ($pdfname) = ($mptopdf_output =~ /converted to (.+\.pdf)/);
	unless (defined $pdfname) {
		print "WARNING: cannot get pdf name for $f from mptopdf. ";
		print "Skipping this file.\n";
		next;
	}
	push(@pdf,$pdfname);
	print "Generated PDF figure $pdfname\n";
}

unless ($PREVIEW) {
	print "Preview not generated.\n";
	exit(0);
}

# If we get here, $PREVIEW is on

# Get charcodes from log file.
# This works reliably as long as the log file does not contain other [<number>]
# expressions, e.g., printed by 'show' or 'message' commands, or unless
# the source file outputs both SVG and EPS figures (in which case, there will
# be a mismatch between the numbe of charcodes in the log file and the number of
# figures, since we do not use SVG figures for the preview).
my @fignum = ();
if (open(LOG, $jobname . '-mp.log')) {
	print "Opened $jobname-mp.log\n" if $VERBOSE;
	my @text = <LOG>;
	close(LOG);
	my $log = join('', @text);
	while ($log =~ /\[(\d+)[^\]]*\]/g) {
		push(@fignum, $1);
	}
	print scalar(@fignum) . ' charcode' . (scalar(@fignum) > 1 ? 's' : '')
		. " found: @fignum.\n" if $VERBOSE;
}
else {
	print "Mmh, cannot open $jobname-mp.log... Maybe something went wrong?\n";
}
if ($nummps != scalar(@fignum)) {
	print "Uff, cannot reliably determine the figures' charcodes.";
	print " They will be ignored.\n";
	@fignum = ();
}

my $hsize = 0;
my $vsize = 0;
# Determine the largest horizontal/vertical size of a bounding box
foreach my $f (@mps) {
	# Open the file and determine its bounding box
	unless (open(EPS, $f)) {
		print "Oh oh, cannot open $f. Skipping this file.\n";
		next;
	}
	my $line;
	while ($line = <EPS>) {
		# break the loop when the bounding box is found
		last if ($line =~ /HiResBoundingBox/);
	}
	close(EPS);
	if (defined $line) {
		my ($llx, $lly, $urx, $ury) =
			($line =~ /BoundingBox:\s+(.+)\s+(.+)\s+(.+)\s+(.+)/);
		if ($hsize < $urx - $llx + 1) { $hsize = $urx - $llx + 1; }
		if ($vsize < $ury - $lly + 1) { $vsize = $ury - $lly + 1; }
		print "Bounding box of $f: $llx $lly $urx $ury\n" if $VERBOSE;
	}
	else {
		print "WARNING: it seems that $f does not have a bounding box.\n";
		print "Is $f really a Postscript file?\n" if $VERBOSE;
	}
}

# Set size to approximately A4 paper if no bounding box has been found
$hsize = 495 if ($hsize == 0);
$vsize = 742 if ($vsize == 0);
my $dotitles = ($TITLES and (not ($nummps == 1 and $ONENOTITLE)));
if ($dotitles) {
	# Add some margins
	$hsize += $HMARGIN;
	$vsize += $VMARGIN;
	# Enlarge if it's still too small
	$hsize = 200 if ($hsize < 200);
	$vsize = 200 if ($vsize < 200);
}
$hsize = $hsize . 'pt';
$vsize = $vsize . 'pt';
# Make pdf output using ConTeXt
my $context = '\setupoutput[pdftex]';
$context .= '\definepapersize[MetaFun!][width=' . $hsize . ',height=' . $vsize . ']';
$context .= '\setuppapersize[MetaFun!][MetaFun!]';
 $context .= '\setuplayout[top=0mm,topdistance=0mm,header=0mm,headerdistance=0mm,'
 	. 'footerdistance=0mm,footer=0mm,bottomdistance=0mm,bottom=0mm,height=fit,'
 	. 'leftedge=0mm,leftedgedistance=0mm,leftmargin=0mm,leftmargindistance=0mm,'
 	. 'rightmargindistance=0mm,rightmargin=0mm,rightedgedistance=0mm,rightedge=0mm,'
 	. 'topspace=0mm,backspace=0mm,width=fit]';
$context .= '\setupframed[align=middle,top=\vfill,bottom=\vfill,'
	. 'height=\textheight,width=\textwidth';
$context .= ($DEBUG) ? ']' : ',frame=off]';
$context .= '\setupcolors[state=start]';
if ($BACKGROUNDCOLOR ne 'default') {
	if ($BACKGROUNDCOLORMODEL eq 'named') {
		$context .= '\setupbackgrounds[page][background=color,backgroundcolor='
			. $BACKGROUNDCOLOR . ']';
	}
	elsif ($BACKGROUNDCOLORMODEL =~ /rgb/) {
		my ($r, $g, $b) = ($BACKGROUNDCOLOR =~ /(.+),(.+),(.+)/);
		unless (defined $r and defined $g and defined $b) {
			print "WARNING: couldn't parse background color specification. Using white.\n";
			$context .= '\definecolor[mybgcolor][s=1]';
		}
		else {
			$context .= '\definecolor[mybgcolor][r=' .$r. ',g=' .$g. ',b=' .$b. ']';
		}
	}
	elsif ($BACKGROUNDCOLORMODEL =~ /cmyk/) {
		my ($c, $m, $y, $k) = ($BACKGROUNDCOLOR =~ /(.+),(.+),(.+),(.+)/);
		unless (defined $c and defined $m and defined $y and defined $k) {
			print "WARNING: couldn't parse background color specification. Using white.\n";
			$context .= '\definecolor[mybgcolor][s=1]';
		}
		else {
			$context .= '\definecolor[mybgcolor][c=' .$c. ',m=' .$m. ',y=' .$y. ',k=' .$k. ']';
		}
	}
	elsif ($BACKGROUNDCOLORMODEL =~ /gr[ae]y/) {
		my ($s) = ($BACKGROUNDCOLOR =~ /(.+)/);
		unless (defined $s) {
			print "WARNING: couldn't parse background color specification. Using white.\n";
			$context .= '\definecolor[mybgcolor][s=1]';			
		}
		else {
			$context .= '\definecolor[mybgcolor][s=' .$s. ']';
		}
	}
	else {
		print "WARNING: couldn't parse background color specification. Using white.\n";
		$context .= '\definecolor[mybgcolor][s=1]';					
	}
	$context .= '\setupbackgrounds[paper][background=color,backgroundcolor=mybgcolor]';
}
$context .= '\setuppagenumbering[state=stop]';
if ($DEBUG) {
	$context .= '\showframe\showlayout\showgrid';
	$context .= '\showcolor[rgb]';
}
$context .= '\starttext';
foreach my $f (@pdf) {
	my $title = $f;
	if ($dotitles) {
		if (@fignum) {
			$title .= ' [' . $FIG . '~' . shift(@fignum) . ']';
		}
		$title =~ s/[\$\_\#\&\%]/\\$&/g; # Escape special characters with backslash
		$context .= '\framed{{\bf ' . $title . '}\blank[2*medium]';
		$context .= '\midaligned{\externalfigure[' . $f . ']}}\page';
	}
	else {
		$context .= '\startpagefigure[' . $f . ']\stoppagefigure';
	}
}
$context .= '\stoptext\end' . "\n";
print "ConTeXt document for the preview: $context" if $DEBUG;
# I do not call texexec here, because I have found no way to pipe code into it
open(TEXEXEC, "| pdftex -progname=texexec -fmt=cont-en -translate-file=natural.tcx --8bit -jobname=\"$jobname\" -no-shell-escape")
  or die "Cannot execute pdftex";
local $SIG{PIPE} = sub { die "pdftex pipe broken" };
print TEXEXEC $context or die "Cannot write output pdf file";
close(TEXEXEC) or die "Could not close pipe. Probably, pdftex has (unexpectedly) produced an error.";

print "Generated PDF preview document $jobname.pdf for " . scalar(@pdf) . ' figure' .
	(scalar(@pdf) > 1 ? 's' : '' ) . ": @pdf\n";
if ($numsvg > 0) {
	print "(SVG output is not in the PDF preview).\n";
}
exit($exit_status);

# verifySystemCall()
#
#  Usage    : my $exit_status = verifySystemCall($program_name);
#  Returns  : -1 if the program couldn't be run;
#             -2 if the program died (a msg is printed to stdout);
#             the exit code of the program, otherwise.
sub verifySystemCall {
	my $prog = shift;
	return -1 if ($? == -1);
    if ($? & 127) {
	    my $sig = ($? & 127);
	    my $core = ($? & 128) ? 'with' : 'without';
		print "$prog died with signal $sig, $core coredump.\n";
		return -2;
	}
	elsif (($? >> 8) != 0) {
		my $x = $? >> 8;
		return $x;
	}
	return 0;
}
