#! /usr/bin/perl -w
# Last edited on 2008-02-04 20:48:12 by stolfi

# CGI-BIN script that colorizes a VMS page.

sub get_params();
sub save_ctable($$);
sub main();
sub print_header($);
sub print_errors();
sub colorize_page($$$$$$);
sub print_colorized_page($);
sub print_tailer();

sub protect_shell($);
sub protect_html($);

sub form_error($);

#---------------------------------------------------------------------
# Set this to obtain a printout of the input data
#
my($debug) = 0;

#---------------------------------------------------------------------
# Hash that contains the form parameters (set by get_params)
#
my(%params);

#---------------------------------------------------------------------
# Work/script directory:
#
my($vmsdir) = "${STOLFIHOME}/voynich/work/Notes/050";

#---------------------------------------------------------------------
# Errors
#
my ($abort) = -1;  # Positive means there were errors.
my (@errors) = (); # Error messages.

#---------------------------------------------------------------------
# The fun starts here...
#
sub main()
{
  if ($debug) 
    { system("iso-to-html"); exit(1); }
    
  my($tempfile) = "/tmp/$$.html";
  get_params();
  my($fnum) = $params{'fnum'};
  my($version) = $params{'version'};
  my($comments) = $params{'comments'};
  my($similar) = $params{'similar'};
  my($colorfile) = "${vmsdir}/color-tables/$$.cdic";
  save_ctable($params{'ctable'},$colorfile);
  # printf STDERR "[%s %s %s %s %s]\n", $fnum,$version,$comments,$similar,$colorfile;
  if (! (-f "${vmsdir}/evt-pages/${fnum}"))
    { form_error("There is no page \"${fnum}\""); }
  print_header($fnum);
  if ($abort >= 0) 
    { print_errors(); }
  else
    { colorize_page($fnum,$version,$comments,$similar,$colorfile,$tempfile);
      print_errors();
      print_colorized_page($tempfile);
    }
  print_tailer();
  unlink($colorfile,$tempfile);
}

#---------------------------------------------------------------------
# Writes errors to the error file for display in the html page
#
sub form_error($)
{
  my($msg) = @_;
  push @errors, sprintf("%s\n", $msg);
  $abort = 1;
}

#---------------------------------------------------------------------
# Obtain the parameters from STDIN, stores them
# in the hash "%params"
#
sub get_params()
{ 
  # Get form info
  my ($info);
  my ($info_size) = $ENV{'CONTENT_LENGTH'};
  if (!defined($info_size)) { $info_size = 1000000; }
  read STDIN, $info, $info_size;
  $info =~ s/%0D%0A/%0A/g;
  
  # Split form info into name=value pairs:
  foreach my $pair (split(/[&\012]/, $info))
    { # printf STDERR "%s\n", $pair;
      
      # Split pair into key and value:
      my ($key,$value) = split(/=/, $pair);

      # Decode % encoding:
      $key =~ s/%([\dA-Fa-f][\dA-Fa-f])/pack("C",hex($1))/eg;
      $value =~ s/[+]/ /g;
      $value =~ s/%([\dA-Fa-f][\dA-Fa-f])/pack("C",hex($1))/eg;

      # Save in %params hash:
      if ($key =~ /^[-.a-zA-Z0-9_]*$/) 
        { $params{$key} = $value; }
      else
        { form_error("invalid key \"${key}\""); }
    }
}

#---------------------------------------------------------------------
# Saves the color table to disk.
#
sub save_ctable($$)
{
  my($ctable,$colorfile) = @_;
  open CTABLE, ">${colorfile}";
  print CTABLE $ctable;
  close CTABLE;
}

#---------------------------------------------------------------------
# Colorizes a page; writes the result to $tempfile.
#
sub colorize_page($$$$$$)
{
  my($fnum,$version,$comments,$similar,$colorfile,$tempfile) = @_;
  $fnum = protect_shell($fnum);
  $version = protect_shell($version);
  $comments = protect_shell($comments);
  $similar = protect_shell($similar);
  $colorfile = protect_shell($colorfile);
  my($errfile) = "/tmp/$$.err";
  system("${vmsdir}/custom-colorize-page-2 $fnum $version $comments $similar $colorfile 1>${tempfile} 2>> ${errfile}");
  if (-f "${errfile}") 
    { push @errors, `cat ${errfile}`;
      $abort = 1;
      unlink($errfile);
    }
}

#---------------------------------------------------------------------
# Generates the HTML preamble, page headers, etc.
#
sub print_header($)
{
  my($fnum) = @_;
  print STDOUT <<EOF;
Content-type: text/html

<!doctype html public "-//W3C//DTD HTML 3.2 Final//EN">
<html>
<head><title>Voynich Manuscript - Page ${fnum}</title></head>
<body bgcolor="#000000" text="#cccccc" link="#00ff99" alink="#eeff99" vlink="#009900">
<tt>

<h1><font color="#ff0000">Page ${fnum}</font></h1>
EOF
}

#---------------------------------------------------------------------
# Format the error messages:
#
sub print_errors()
{ 
  if (scalar(@errors))
    { print STDOUT "<h2><font color=\"#ff0000\">Messages</font></h2>\n\n";
      print STDOUT "<pre><b><font color=\"#ffdd22\">\n";
      print STDOUT protect_html(join("\n", @errors)) . "\n";
      print STDOUT "</font></b></pre>\n\n";
    }
}

#---------------------------------------------------------------------
# Format the output of the log scanning program:
#
sub print_colorized_page($)
{ 
  my($tempfile) = @_;

  print STDOUT "<h2><font color=\"#ff0000\">Colorized text</font></h2>\n\n";
  print STDOUT "<pre><b><font color=\"#cccccc\">\n";
  print STDOUT `cat ${tempfile}`;
  print STDOUT "</font></b></pre>\n";
}

#---------------------------------------------------------------------
# Closes the HTML page
#
sub print_tailer()
{
  my(@t) = localtime(time());
  my($gendate) = sprintf(
    "%04d/%02d/%02d %02d:%02d:%02d (local)",
    1900+$t[5],1+$t[4],$t[3],$t[2],$t[1],$t[0]
  );

  print STDOUT "<small><p>Generated ${gendate}</p></small>\n";
  print STDOUT "</tt>\n";
  print STDOUT "</body>\n";
  print STDOUT "</html>\n";
}

#---------------------------------------------------------------------
# Protect arguments against shell interpretation:
#
sub protect_shell($)
{
  my($val) = @_;
  $val =~ s/[']/'"'"'/g;
  $val =~ s/[\n]//g;
  $val =~ s/[!]/\\!/g;
  return "'" . $val . "'";
}

#---------------------------------------------------------------------
# Protect characters with special meaningin HTML:
#
sub protect_html($)
{
  my($lin) = @_;
  $lin =~ s/%([\dA-Fa-f][\dA-Fa-f])/pack("C",hex($1))/eg;
  $lin =~ s/[&]/\&amp;/g;
  $lin =~ s/[ ]/\&nbsp;/g;
  $lin =~ s/</\&lt;/g;
  $lin =~ s/>/\&gt;/g;
  return $lin;
}

main();