#!/usr/bin/env perl

#     Copyright © 2009-2014 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, pdflatex and, well, perl
use strict;
use warnings;
use File::Copy qw(move);
#===============================================================================
# Start of configurable parameters
#===============================================================================
my $TEX = ''; # The default processor for text labels (if empty, it uses mpost's default)
my $CONVERTPDF = 1; # Set to 1 if you want all MetaPost figures to be also converted to PDF (requires mptopdf)
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|png|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.7';
my $RELEASE_DATE = '2014/03/23';
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 MetaPost Engine $VERSION ($RELEASE_DATE) by Nicola Vitacolonna\n";
print 'Filename: ' . $ARGV[0] . "\n" if $VERBOSE;
if ($ARGV[0] =~ /(\\|\%)/) {
  print "Sorry, the file name must not contain the character '$1'.";
  print " Please rename the source file and try again.\n";
  exit(1);
}
my ($suffix) = ($ARGV[0] =~ /((\.mp)|(\.mf)|(\.tex))$/);
unless (defined $suffix) {
  print "Sorry, the only acceptable suffixes are .mp, .mf, and .tex.\n";
  if ($DEBUG) {
    print "The file name I've got is '$ARGV[0]' (without quotes).\n";
    print "Its suffix is " . ((defined $suffix) ? $suffix : 'undefined') . ".\n";
  }
  exit(1);
}
my ($jobname) = ($ARGV[0] =~ /^(.+)$suffix$/);
die "Gosh! Empty file name!." unless (defined $jobname);
if ($jobname =~ /\s/) {
  print "WARNING: '$jobname$suffix' contain spaces, which *may* cause trouble.\n";
  print " If compilation fails, try to rename '$jobname$suffix' without spaces.\n";
}
$extra_options .= " -jobname=\"$jobname\"";
my $mf = '';
if ($suffix eq '.mf') {
  $mf = '-mem=mfplain';
  $FIG = 'Charcode';
}
elsif ($suffix eq '.tex') {
  # Search for corresponding MetaPost file
  unless (-e $jobname . '.mp') {
    print "Sorry, $jobname.mp not found.";
    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+(numbersystem|tex|pdf|preview|backgroundcolor|titles?|bin|texmfcache|mem)\s*=\s*(.*)/);
      unless (defined $directive) {
        print "WARNING: skipping wrong directive: $line";
        next;
      }
      if ($directive eq 'numbersystem') { # Added by F. Pastor for switching between number systems
        # Strip leading and trailing spaces
        $value =~ s/^\s*//;
        $value =~ s/\s*$//;
        if ($value !~ /^(scaled|double|binary|decimal)$/) {
          print "WARNING: illegal value for numbersystem: ";
          print $value . "\n";
        }
        else {
          $extra_options .= ' -numbersystem="' . $value . '"';
        }
      }
      elsif ($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 'pdf') {
        if ($value =~ /^\s*(on|yes|1)\s*$/) {
          $CONVERTPDF = 1;
          print "PDF conversion enabled in the source.\n" if $VERBOSE;
        }
        elsif ($value =~ /^\s*(off|no|0)\s*$/) {
          $CONVERTPDF = 0;
          print "PDF conversion disabled in the source.\n" if $VERBOSE;
        }
        else {
          print "WARNING: skipping wrong directive: $line";
        }
      }
      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, White, Sepia, Melon, 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";
        }
      }
      elsif ($directive eq 'bin') {
        my $slash = ($value =~ /\/$/) ? '' : '/';
        $MPOST = $value . $slash . 'mpost';
        $ENV{'PATH'} = $value . ':' . $ENV{'PATH'};
        print "mpost path changed to $MPOST\n" if $VERBOSE;
      }
      elsif ($directive eq 'texmfcache') {
        $ENV{'TEXMFCACHE'} = $value;
        print "TEXMFCACHE set to $value\n" if $VERBOSE;
      }
      elsif ($directive eq 'mem') {
        $extra_options .= ' -mem=' . $value;
      }
      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;
}

if ($DEBUG) {
  print 'mpost: '           . `which mpost`;
  print 'etex: '            . `which etex`;
  print 'pdftex: '          . `which pdftex`;
  print 'texexec: '         . `which texexec`;
  print 'dviluatex: '       . `which dviluatex`;
  print 'dvilualatex: '     . `which dvilualatex`;
  print 'PATH: ' . $ENV{'PATH'} . "\n";
  if (defined $ENV{'TEXMFCACHE'}) {
    print 'TEXMFCACHE: ' . $ENV{'TEXMFCACHE'}. "\n";
  }
}
my $texproc = ($TEX) ? "-tex=\"" .$TEX ."\"" : "";
my $mpost_cmd = "$MPOST $mf $texproc $extra_options \"$jobname$suffix\"";
print "Going to process $jobname$suffix...\n";
print "Command: $mpost_cmd\n" if $VERBOSE;
system($mpost_cmd); # Have fun!
my $exit_status = verifySystemCall($mpost_cmd);
print "$MPOST has exited with status code: $exit_status.\n" if $VERBOSE;
if ($mf and $exit_status == 1) { # mfplain.mem missing?
  print "\nMmh, probably mfplain.mem is missing.";
  print " To create it, execute 'mpost -ini mfplain dump' in a shell,";
  print " then move the generated mfplain.mem into an appropriate place";
  print " (typically, /usr/local/texlive/<year>/texmf-var/web2c/metapost);";
  print " finally, execute 'sudo mktexlsr'.\n";
  exit($exit_status);
}
# Read output files
my @mpout = (); # Any output file
my @fig = ();   # Figures
my $fn;
unless (open(FLS, $jobname . '.fls')) {
  if ($extra_options =~ /-recorder/) { # This is an error
    print "Gosh! Cannot open $jobname.fls :o";
    exit(1);
  }
  else {
    print "Preview not generated.\n";
    exit($exit_status);
  }
}
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);
}

# Try to recognize the file format
my @mps = ();
my @png = ();
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;
  }
  binmode FIG;
  my $header;
  if (read(FIG, $header, 8)) {
    if ($header =~ /^%!PS/) {
      push(@mps, $fn);
    }
    elsif ($header =~ /^<\?xml/) {
      push(@svg, $fn);
    }
    elsif ($header =~ /^?PNG/) {
      push(@png, $fn);
    }
    else {
      push(@unk, $fn);
    }
  }
  else {
    print "WARNING: cannot read $fn. Skipping this figure.\n";
    push(@unk, $fn);
  }
  close(FIG);
}
my $nummps = @mps;
my $numpng = @png;
my $numsvg = @svg;
my $numunk = @unk;
if ($nummps > 0) {
  print "$nummps EPS figure" . (($nummps > 1) ? 's' : '') . " generated: @mps.\n";
}
else {
  print "No EPS figure generated.\n";
}
if ($numpng > 0) {
  print "$numpng PNG figure" . (($numpng > 1) ? 's' : '') . " generated: @png\n";
}
if ($numsvg > 0) {
  print "$numsvg SVG figure" . (($numsvg > 1) ? 's' : '') . " generated: @svg\n";
}
if ($numunk > 0) {
  print "WARNING: $numunk figure" . (($numunk > 1) ? 's' : '') . " with unknown format: @unk\n";
}
# Make HTML5 preview for SVG or PNG images, if any
if (($numsvg > 0 or $numpng > 0) and $PREVIEW) {
  my $html = "<!DOCTYPE HTML>\n<html>\n<head>\n";
  $html .= "<title>MetaPost Preview</title>\n";
  $html .= "<meta charset=\"UTF-8\">\n";
  $html .= "<meta name=\"generator\" content=\"nv-metapost\">\n";
  $html .= "<style type=\"text/css\">\n";
  if ($BACKGROUNDCOLOR ne 'default') {
    if ($BACKGROUNDCOLORMODEL eq 'named') {
      $html .= 'body {background-color:' .$BACKGROUNDCOLOR. ";}\n";
    }
    else {
      $html .= 'body {background-color:' .$BACKGROUNDCOLORMODEL. '(' .$BACKGROUNDCOLOR. ");}\n";
    }
  }
  $html .= ".title  {text-align:center;padding-bottom:25px;}\n";
  $html .= "figure  {text-align:center;padding-bottom:50px;}\n";
  $html .= "</style>\n</head>\n<body>\n";
  foreach my $f (@png) {
    $html .= "<article>\n";
    if ($TITLES and (not ($numpng == 1 and $ONENOTITLE))) {
      $html .= '<h2 class="title">' .$f. "</h2>\n";
    }
    $html .= "  <figure>\n";
    $html .= "    <img src=\"" . $f ."\" alt=\"" . $f . "\">\n";
    $html .= "  </figure>\n";
    $html .= "</article>\n";
  }
  foreach my $f (@svg) {
    $html .= "<article>\n";
    if ($TITLES and (not ($numsvg == 1 and $ONENOTITLE))) {
      $html .= '<h2 class="title">' .$f. "</h2>\n";
    }
    $html .= "<figure>\n";
    if (open(SVG, '<', $f)) {
      local $/;
      my $image = <SVG>;
      $image =~ s/<\?.*?\?>//; # Remove XML processing instruction
      close(SVG);
      $html .= $image . "\n";
    }
    else {
      $html .= "<p class=\"error\">$f could not be opened.</p>\n";
    }
    $html .= "</figure>\n</article>\n";
  }
  $html .= "</body>\n</html>\n";
  unless (open(HTML, '>', "$jobname.html")) {
    print "ERROR: couldn't create $jobname.html.\n";
    exit(1);
  }
  print "HTML document for the preview:\n$html\n" if $DEBUG;
  print HTML $html;
  close(HTML);
  print "HTML file '$jobname.html' generated for " . ($numsvg + $numpng) ." figure"
    . (($numsvg + $numpng > 1) ? 's' : '') . ": @svg @png.\n";
}
exit($exit_status) if ($nummps == 0);

# mptopdf and pdflatex may overwrite mpost's log file.
# If we are going to use either, we'd better rename the log file.
if ($PREVIEW or $CONVERTPDF) {
  if (-e "$jobname.log") {
    move $jobname . '.log', $jobname . '-mp.log';
    print "Renamed $jobname.log into $jobname-mp.log to avoid name clashes.\n";
  }
}

my @pdf = ();
# The output of mpost is converted to PDF if the user has decided so by setting $CONVERTPDF to 1.
if ($CONVERTPDF) {
  # 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';
      move $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 = ();
my @charname = ();
if (open(LOG, $jobname . '-mp.log')) {
  print "Opened $jobname-mp.log\n" if $VERBOSE;
  my @text = <LOG>;
  close(LOG);
  my $log = join('', @text);
  if ($mf) { # Using mfplain, try to parse character name
    while ($log =~ /(.*) \[(\d+)[^\]]*\]/g) {
      push(@charname, $1);
      push(@fignum, $2);
    }
    if ($nummps != scalar(@fignum)) {
      # Mmh, maybe no char names: revert to 'normal' parsing
      print "It seems that characters have no names. Parsing charcodes.\n" if $VERBOSE;
      @charname = (); @fignum = ();
      while ($log =~ /\[(\d+)[^\]]*\]/g) {
        push(@fignum, $1);
      }   
    }
  }
  else { # Plain MetaPost
    while ($log =~ /\[(\d+)[^\]]*\]/g) {
      push(@fignum, $1);
    }
  }
  print scalar(@fignum) . ' charcode' . (scalar(@fignum) > 1 ? 's' : '')
    . " found: @fignum.\n" if $VERBOSE;
  if ($mf and $VERBOSE) {
    print "Character names found: @charname.\n";
  }
}
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 LaTeX
my $latex = '\documentclass{minimal}';
$latex .= '\usepackage[T1]{fontenc}';
#$latex .= '\usepackage[multidot,extendedchars]{grffile}';
$latex .= '\usepackage[pdftex,hiresbb]{graphicx}' . '\DeclareGraphicsRule{*}{mps}{*}{}';
if ($BACKGROUNDCOLOR ne 'default') {
  $latex .= '\usepackage[dvipsnames,usenames]{color}';
  if ($BACKGROUNDCOLORMODEL eq 'named') {
    $latex .= '\pagecolor{' .$BACKGROUNDCOLOR. '}';
  }
  else {
    $latex .= '\pagecolor[' .$BACKGROUNDCOLORMODEL. ']{' .$BACKGROUNDCOLOR. '}';
  }
}
$latex .= '\pdfpagewidth ' .$hsize;
$latex .= '\pdfpageheight ' .$vsize;
$latex .= '\setlength\oddsidemargin{-1in}\setlength\evensidemargin{-1in}';
$latex .= '\setlength\topmargin{-1in}\setlength\topskip{0in}';
$latex .= '\setlength\headheight{0in}\setlength\headsep{0in}';
$latex .= '\setlength\textwidth{' .$hsize. '}';
$latex .= '\setlength\textheight{' .$vsize. '}';
$latex .= '\setlength\footskip{0in}';
$latex .= '\setlength\parindent{0in}\setlength\parskip{0in}';
$latex .= '\begin{document}';
foreach my $f (@mps) {
  my $title = $f;
  my ($pref,$suff) = ($f =~ /^(.+)(\.[^\.]+)$/);
  $suff = '' unless defined $suff; # No filename extension??
  if ($dotitles) {
    if (@fignum) {
      $title .= ' [' . $FIG . '~' . shift(@fignum);
      if ($mf) {
        my $cn = shift(@charname);
        $title .= ": $cn" if defined $cn;
      }
      $title .= ']';
    }
    $title =~ s/[\$\_\#\&\%]/\\$&/g; # Escape special characters with backslash
    $latex .= '\vspace*{\fill}\centerline{\textbf{' . $title . '}}\bigskip\par' .
    '\centerline{\includegraphics{"' . $pref . '"' . $suff .
    '}}\vspace*{\fill}\newpage';
  }
  else {
    $latex .= '\vspace*{\fill}\centerline{\includegraphics{"' . $pref . '"' . $suff . '}}\vspace*{\fill}\newpage';
  }
}
$latex .= '\end{document}\end' . "\n";
print "LaTeX document for the preview: $latex" if $DEBUG;

open(LATEX, "| pdflatex -no-shell-escape -jobname=\"$jobname\"")
  or die "Cannot execute pdflatex";
local $SIG{PIPE} = sub { die "pdflatex pipe broken" };
print LATEX $latex or die "Cannot write output pdf file";
close(LATEX) or die "Could not close pipe. Probably, pdflatex has (unexpectedly) produced an error.";

print "Generated PDF preview document $jobname.pdf for " . $nummps . ' figure' .
  ($nummps > 1 ? 's' : '' ) . ": @mps.\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;
}
