#!/usr/bin/perl -w
{
#  statisticker_web_interface.pl			WJS  Jul 03
#
$version = "statisticker_web_interface.pl  version 1.3c 10 Jun 2012";

#  10 Jun 12.  v 1.3c  WJS
#     Bug fix: cannot depend on $! to tell if  open  succeeded.  No
#	getting around explicitly processing the return from  open.
#       [Begin 1.3c]
#   4 Aug 08.  v 1.3b  WJS
#     Reformat some error messages.
#       [Begin 1.3b]
#  25 Oct 07.  v 1.3a  WJS
#     Use check_build_opt_env_var from wjs_web*.pl
#       [Begin 1.3a]
#  23 Aug 05.  v 1.3  WJS
#     Recode to pass object spec as hidden form var.  Makes things
#	more consistent w/matlab & netcdf stuff.  Also, avoids the
#	PATH_INFO/QUERY_STRING issues that led to matlab & netcdf
#	using hidden variable
#  19 Aug 05.  v 1.3  WJS
#     Recode to use "alpha variable display" menu as subroutine
#   6 Aug 05.  v 1.3  WJS
#     Test for some "nothingness" a bit sooner than previously
#     Recode to use get_JGOFS_record, etc
#       [Begin 1.3]

#  10 Dec 04.  v 1.2e  WJS
#     Change perl location
#  18 Jun 04.  v 1.2e  WJS
#     Didn't like the 1.2d code.  Changed it, but don't intend to
#	release this until more needs to be done
#       [Begin 1.2e]
#  18 Jun 04.  v 1.2d  WJS
#     Bug fix: 1.2c fix done poorly.  Try to do better
#       [Begin 1.2d]
#  28 May 04.  v 1.2c  WJS
#     Bug fix: using build-opt-env.pl's DISPSS instead of SUBSELS.  This
#	is a regression error of some kind - code was correct in 1.2
#       [Begin 1.2c]
#   6 Mar 04.  v 1.2b  WJS
#     New version mostly for housekeeping purposes
#     "use Errno" to define EPIPE and ESPIPE
#       [Begin 1.2b]
#
#  28 Feb 04.  v 1.2a  WJS
#     New list requires test for EPIPE
#     To get new list to log problems to web server log, need
#	-error switch (plus -nopipeerr switch to NOT log those errors)
#     Simplify a few "if defined x then if x" tests to "if x" - perl
#	can sometimes actually be helpful!
#     Bug fix: syntax error in forming read error message
#     Bug fix: build-opt-env does not always define all of its env vars
#	Check for the ones we need.
#     Bug fix: empty varname fix of 26 Feb uncovered a problem where
#	we assumed a hash existed (even if empty)
#  27 Feb 04.  v 1.2a  WJS
#     build-opt-env.pl on synthesis:1988 (my test) defines env var OBJ.
#	On globec:80 (real OOserver) env var is OBJECT.  Change to
#	latter, (& add OBJECT defn to :1988 build-opt-env.pl)
#  26 Feb 04.  v 1.2a  WJS
#     Now it seems that close is returning 29.  Assume that's normal...
#     Bug fix: get rid of "extra", empty varname (due to failure to chomp)
#	Not sure how long that's been an issue...
#  25 Feb 04.  v 1.2a  WJS
#     Replace backtick operator w/ explicit open/read/close to pipe
#	It seems that using backtick sets $! to 29 on Solaris (2 versions)
#	and linux using Solaris perls 5.004 & 5.8, whereas Irix perl 5.6 OK
#     Now it seems that close is returning 29.  Assume that's normal...
#       [Begin 1.2a-test release only.  Every variant had something wrong...]

#   8 Oct 03.  v 1.2  WJS
#     Bug fix: split /[\t]+/ was not working as I thought it would.
#	Didn't figure out why, of course - just added -z to list (which
#	produces the string being split).  Is this a butt-biter? Stay tuned...
#  25 Sep 03.  v 1.2  WJS
#     By default, select all stats except distinct
#  24 Sep 03.  v 1.2  WJS
#     Typo fix in comment
#  11 Sep 03.  v 1.2  WJS
#     Allow user to select alpha comparisons.  Default offering to our
#     "usual" (try to numerically decode 1st val of each var)
#       [Begin 1.2]

#   4 Sep 03.  v 1.1a  WJS
#     Using @ to set off stats-specific parameters seems to work better than #
#       [Begin 1.1a]
#  29 Aug 03.  v 1.1  WJS
#     Recode for statisticker v 3.1.
#     Put web interface version info onto web page as comment.
#       [Begin 1.1]

#  25 Jul 03.  v 1.0  WJS
#       [Needs build-opt-env.pl]
#       [Needs ctime.pl]
#       [Needs cgi-lib.pl]
#       [Begin 1.0]
###

  require ("cgi-lib.pl");
  require ("ctime.pl");
  require ("wjs_web_perl_utilities.pl");

#   List separator character.  Pick something that doesn't mean anything
#   to perl pattern matcher (as well as a char unlikely to appear in
#   our valid strings, too!)
  $sep = ",";
#   statisticker uses subset of characters illegal to outer to distinguish
#   its portion of QUERY_STRING from outers.  See statisticker doc.  
#   Code here should be able to use any one of these - select for minimal
#   interference w/other programs' special chars.  Similar argument applies
#   to character used to separate list of vars that need to be compared 
#   alphabetically
  $illegal_outer_char = "@";
  $stat_DISTINCT_key = $illegal_outer_char . "DISTINCT" . $illegal_outer_char;
  $stat_ROWS_ARE_STATS_key = $illegal_outer_char . "ROWS_ARE_STATS" . 
							$illegal_outer_char;
  $stat_alpha_comp_key = $illegal_outer_char . "alpha" . $illegal_outer_char;
  $alpha_comp_list_sep = "+";

#   Variables we are going to get from form defined as their form variable
#   names (including hidden variables)
  $object_form_var_name = "object_spec";
  $irreg = "irregular_data_treatment";
  $orientation = "orientation";
  $selected_statistics = "stats";
  $form_action = "form_action";
  $alpha_comp_list = "alpha_vars";
#   Define values for how to treat irregular data. 
  $skip_irregular = "skip_irregular";
  $skip_missing = "skip_missing";
  $include_all = "include_all";
#   Define values for orientation
  $stats_are_rows = "stats_are_rows";
  $stats_are_columns = "stats_are_columns";

#   Define form action routine.
  $form_action_routine = $ENV{"SCRIPT_NAME"} ?
			$ENV{"SCRIPT_NAME"} : "/jg/stat_web_interface.pl";

#   Associate variables w/values, along w/descriptive strings for form user
#     As coded, order does NOT determine order on form (no way to do so w/o
#     coding change). Permissible values for $selected_statistics come from 
#     $get_statisticker_info 
  $values{$irreg} = join $sep,
		    (
		     "$skip_irregular,Skip all irregular data," .
		     "$skip_missing,Skip missing but count other irregular data," .
		     "$include_all,Include all data"
		    );
  $values{$orientation} = join $sep,
			  (
			   "$stats_are_rows,Rows," .
			   "$stats_are_columns,Columns"
			  );
#   List defaults.  Default for $selected_statistics is each one.  I
#   Suppose for completeness I should "do" that, but I didn't.
  $defaults{$irreg} = $skip_irregular;
  $defaults{$orientation} = $stats_are_columns;

#   Set up environment.  Assume .pl routine is in our directory
  $build_opt_env = "./build-opt-env.pl";
  &check_r_access($build_opt_env);
  require $build_opt_env;

#   Check that build-opt-env set up things as expected
  $topdir = &check_build_opt_env_var("OPTHOME",$build_opt_env);
  $bindir = "$topdir/bin";

  ($stat_obj,$special_stat_name_list,$addend_list,$stat_name_list) = 
					&get_statisticker_info ($sep);
  @statisticker_var_roots = split ($sep,$stat_name_list);
  ($stat_name_for_distinct_count,
	$stat_name_for_stat_column,
	$stat_name_for_variables_column)
		=
     split ($sep,$special_stat_name_list);

  &ReadParse(*form_info);


#   Main purpose of putting form action routine on form as a hidden
#   variable is to distinguish between use of this program in the
#   "put the form up" and "process the form results" modes.  The
#   consistency check is just on general principles - anyone who de-
#   liberately mis-routes things here can change the hidden value as well.
  if (  $after_submit = (defined $form_info{$form_action})  ) {
      ($form_info{$form_action} eq $form_action_routine) ||
	&quit ("Submit action routine should be same as form value"   ,
		  "Action = $form_action_routine; " .
				"Form value = $form_info{$form_action}"     );
  }

if ($after_submit) {
   &process_form;
} else {
   &print_form;
}
  exit;
}

sub print_form
{
  &printheader();

  print "<html>\n";

#   <title>...</title> names the "frame" of the web page but doesn't put
#   anything on the page, hence the "doing it twice"
  print "<head><title>Statistics selection page</title></head>\n";
  print "<h1>Statistics selection page</h1>\n";

#   Check that build-opt-env set up things as expected
  $object = &check_build_opt_env_var("OBJECT",$build_opt_env);
  defined ($ENV{'SUBSELS'}) ||
	&quit ("Internal problem.  ",
    		"Did not get defined env var SUBSELS from $build_opt_env");

  print "<form method=\"POST\"" .
			" action=\"$form_action_routine" .
			"\">\n";

#   Put object spec into form as hidden variable
  $ENV{'SUBSELS'} && (  $object .=  "(" . $ENV{'SUBSELS'} . ")"  );
  $h = "input type=\"hidden\"";
  print "<$h name=\"$object_form_var_name\" value=\"$object\">\n";

#   Put name of form action routine on form
  print "<$h name=\"$form_action\" value=\"$form_action_routine\">\n";

  print "<br><br><h2>Select desired statistics</h2>\n";
  print "Multiple selections allowed\n";
  print "<select multiple name=\"$selected_statistics\">\n";
  foreach (@statisticker_var_roots) {
    print "<option";
    ($_ eq $stat_name_for_distinct_count) || (print " selected");
    print ">$_\n";
  }
  print "</select>";
  print << "EndOfHereis01";
<pre>
	If you would like to compute more statistics than are listed above,
you may be able to use the "Math" function.  To try this, complete this form.
When the above statistics are displayed, choose the "Plotting and Other
Operations" button on that page, and then choose "Math".  Be sure to
display the statistics as columns (the default; selectable on this form; below)
</pre>
EndOfHereis01

  print "<br><br><h2>Select desired treatment of irregular data</h2>\n";
  &print_as_radio_buttons ($irreg);

  print "<br><br><h2>Select whether statistics are displayed as rows or columns</h2>\n";
  &print_as_radio_buttons ($orientation);

  $list_program = "$bindir/list";
  &print_select_alpha_variables 
		($list_program,$object,$alpha_comp_list,"FALSE");

  print "<br><br><input type=\"SUBMIT\" value=\"Display statistics\">\n";

  print "</form></body></html>\n";
  exit;

}


sub process_form
{
#### &dump_input_info ($sep,%form_info);

#   Must run statisticker as an object in order to allow user to, say,
#   math it or further subselect it, etc.  This defn is file spec of serv image
  $serv = "./serv";
  &check_x_access($serv);

  $stat_list = &get_form_var($selected_statistics,"REQ","STRING_LIST");

#   Using "query_string" as name since string being created here will
#   be used as QUERY_STRING for serv to run statisticker.  query_string
#   is, accordingly, the list of args the statisticker wants
  $query_string = &get_form_var($object_form_var_name,'REQ','NOCHECK');
  ($status,$errmsg,undef,undef) = &parse_object_spec($query_string);
  ($status eq "OK") || 
	&quit ("Parsing problem: $errmsg","with object spec",$query_string);

#   Handle lists that have "hardcoded" values.  keys of %values are
#   form variable names; values of $values are (choice, choice_description) 
#   pairs for that form variable
  while (($key,$value) = each %values) {
    %values_hash = split ($sep,$value);
    (defined $values_hash{$form_info{$key}}) ||
      &quit("Illegal value for form variable $key",
		"List of valid values follows:",
		keys(%values_hash)			);
  }
    
  (  $addend{$skip_irregular}, $addend{$skip_missing}, $addend{$include_all}  )
		=
     split ($sep,$addend_list);
  $addend = $addend{&get_form_var($irreg,'REQ','STRING')};

#   If user is displaying stats as columns, we want to make an "and"ed" 
#   projection list of the chosen stats.  Must also include the column 
#   that lists the variables for which the stats are computed!
#   If user is displaying stats as rows, we want to make an "or"ed selection
#   list of the chosen stats, for which we need the name of the column 
#   in which the statistics are listed
  $query_string .= ",$stat_ROWS_ARE_STATS_key=";
  if (&get_form_var($orientation,'REQ','STRING') eq $stats_are_rows) {
#     $list is selections
    $prefix = "$stat_name_for_stat_column=";
    $logic_operator = "|";
    $query_string .= "TRUE,";
  } else {
#     $list is projections
    $prefix = "";
    $logic_operator = ",";
    $query_string .= "FALSE," . 
			$stat_name_for_variables_column . $logic_operator;
  }

  foreach (@statisticker_var_roots) {
    $defined_stat{$_} = 1;
  }
 
  foreach (split ("\0",$stat_list)) {
    (defined $defined_stat{$_})
		||
	&quit("Selected statistic $_ not available",
		 "List of available statistics follows:",
		 @statisticker_var_roots);
    $query_string .= $prefix . $_ . $addend . $logic_operator;
    ($_ eq $stat_name_for_distinct_count) && ($want_distinct = 1);
  }
  chop $query_string;
  $query_string .= ",$stat_DISTINCT_key=" . 
		   (  (defined $want_distinct) ? "TRUE" : "FALSE"  );

#   Should be able to join/split with tr/// or s///, but I can't...
  $alpha_list = &get_form_var($alpha_comp_list,'OPT','STRING_LIST');
  if ($alpha_list && ($alpha_list ne '#NONE#')) {
    ($alpha_list =~ /#NONE#/) && 
	   &quit ("Cannot select an alpha " .
		"variable along with the 'no alpha variables' choice");
    ( $query_string .= ",$stat_alpha_comp_key=" . 
			join ($alpha_comp_list_sep, split("\0",$alpha_list)) );
  }

#   Can use make_path_info instead of next line...
  $ENV{"PATH_INFO"} = $stat_obj . ".html0";
  $ENV{"QUERY_STRING"} = $query_string;
#### print "<pre>PATH_INFO = " . $ENV{"PATH_INFO"} . "\nQUERY_STRING = " .
#### $ENV{"QUERY_STRING"} . "\n</pre>";

  undef $version; # Avoid "1-time use" diagnostic.  Variable is used in quit
#   perl complains that a statement after exec is "unreachable"
#   Apparently all perl exec system service calls succeed.
  exec ($serv);
}

sub print_as_radio_buttons
{
  my($var) = @_;
  my (%values_hash,@default,$val,$text);

  %values_hash = split $sep,$values{$var};
  @default = split $sep,$defaults{$var};
  (@default == 1) ||
    &quit ("Internal coding error",
	      "Radio button variable \"$var\" given > 1 default value");
  while (($val,$text) = each %values_hash) {  
    print "<input type=\"radio\" name=\"$var\" value=\"$val\"";
    ($val eq $default[0]) && print " CHECKED";
    print ">$text\n<br>\n";
  }

  return;
}

sub get_statisticker_info
#   This function written to match statisticker version 3.1
#   Returns filespec of statisticker image & several arrays.  Arrays
#	are joined into lists
#   Argument is the join character for the lists
#   Returned lists are:
#	1) The name of the statisticker object (including its offset from
#	   its object root)
#	2) List of the certain "special" varnames in the statisticker object
#	   a) Varname for "distinct count" statistic
#	   b) Varname for statistics column in "by rows" display
#	   c) Varname for variables in "by columns" display
#	3) List of addends to statistic names, which define how irreg data
#	   has been treated in forming that statistic
#	   a) Addend which indicates all irreg data have been excluded
#	   b) Addend which indicates missing data have been excluded
#	   c) Addend which indicates no irreg data have been excluded
#	4) List of statistics we can offer user
#   There is no logical reason why these responses can't be hardcoded and
#   returned.  Existing code continues the mad attempt to check configuration
#   of other pieces of system and try to deal w/errors therein
{
  my ($sep) = @_;

  my ($listvar,$methods_root,$stat_method,$stat_image);
  my ($test_obj,$stat_obj);
  my ($skip_irregular_addend,$skip_missing_addend,$include_all_addend);
  my (@addends,%defined_addends);
  my (@stat_var_list);
  my ($stat_name_for_stat_column,
      $stat_name_for_distinct_count,
      $stat_name_for_variables_column);
  my ($command,$msg,$addend);
  my ($save_bang,$save_ques,$save_PATH_INFO);
  my ($ordered_stat_list,$stat_name,%stat_names);

#   / in next set represents directory offset from object root with
#  which listvar and the statisticker were compiled; ie, we expect to find 
#  "statisticker=" & "test=" in serverroot/objects/.objects, we expect listvar 
#  to look for statisticker there, and we expect statisticker to look for
#  test there (OK, OK - that's not the only way this syntax would work, but
#  it sure is the simplest!)
#    Alter to taste...
  $test_obj = "/test";
  $stat_obj = "/statisticker";

#     Define values for how to treat irregular data. 
  $skip_irregular_addend = 2;
  $skip_missing_addend = 1;
  $include_all_addend = 0;
#     Return @addends.  Order is significant
  @addends = ($skip_irregular_addend,$skip_missing_addend,$include_all_addend);
#   See loop that parses statisticker varnames for potential stats to see
#   the problem w/ > 10 addends (namely, we assume 1 trailing digit)
  (@addends <= 10) || 
			&quit("Internal problem.  ",
	 "statisticker presumably has 10 or fewer ways to treat irreg data",
	 "but perl routine defines > 10");
  foreach (@addends) {
    $defined_addends{$_} = 1;
  }

#     Which is the statistic name that indicates that it is possible to
#     get the count of distinct values
  $stat_name_for_distinct_count = "distinct";  

######

  defined ($topdir = $ENV{"OPTHOME"}) || &quit ("OPTHOME env var not defined");
  $listvar = "$topdir/bin/listvar";
  &check_x_access($listvar);

#   Set up for listvar of the stat object to get the statistic names
#   as the variable names.  To do this, stats have to be the column headers.
#     Clean out PATH_INFO because not only could it affect statisticker 
#   method (don't think it does, though), it could also (fatally) affect 
#   method used by test object.  By default, test uses def, which is so 
#   fatally affected...
  $command = $listvar  . ' "' . 
	"$stat_obj($test_obj,$stat_ROWS_ARE_STATS_key=FALSE)" 
			. '"';
  (defined $ENV{"PATH_INFO"}) && 
			($save_PATH_INFO = $ENV{"PATH_INFO"});
  $ENV{"PATH_INFO"} = "";

#   Do the command and save the statuses
  $! = $? = 0;
  $open_status = open (INLISTVAR, "$command |");
  $save_bang = $!;
  $save_ques = $?;

#   Restore env var we fiddled with.  Do this "perfectly" (before we
#   might exit this routine, etc) even though presumably the setting dies
#   with us.  Easier for me to do the "perfect" thing than try to know all
#   the reasons I could do it w/less verbiage
  if (defined ($save_PATH_INFO)) {
    $ENV{"PATH_INFO"} = $save_PATH_INFO;
    undef $save_PATH_INFO;
  } else {
    delete $ENV{"PATH_INFO"};
  }

  $open_status || &quit("Problem with piping to following command",$command, 
			      "\$! = $save_bang; \$? = $save_ques");

  ($status,$rec,@err_msg) = &get_JGOFS_record (INLISTVAR);
  while ($status eq "OK") {
    push @stat_var_list,$rec;
    ($status,$rec,@err_msg) = &get_JGOFS_record (INLISTVAR);
  }
  ($status eq "EOF") || 
		&quit("Problem getting statisticker info",$command,@err_msg);
  close INLISTVAR;	# Not needed - avoids "1-time use" diagnostic

  if ( ! defined $stat_var_list[1]) {
    $msg = (defined $stat_var_list[0]) ? 
	 "only 1 variable name returned.  Variable = $stat_var_list[0]" :
	 "no variable names returned. ??";
    &quit("Suspicious return from following command", $command,
				       "\$! & \$? indicators OK, but $msg");
  }

#   Assume order of variables as presented to user by statisticker is
#   more pleasing than a random order.
  $ordered_stat_list = "";
  foreach (@stat_var_list) {
    chomp;
#     Of the infinite number of regular expressions that match the
#     present set of statisticker varnames, we decided that a variable
#     name that is represents a statistic is a string followed by a
#     digit reflecting the treatment of bad data in that statistic
#     There is at least 1 non-statistic-name variable in the statisticker
#     (namely "variable" to head the column of varnames from the object
#     for which stats are being computed).  Not clear what another one
#     would be, but we don't consider such a variable an error...
#	Presumably we should also check that each $stat_name occurs w/
#     each addend as well, but we don't.  Sigh.
    ($stat_name,$addend) = /\s*(.+)(\d)\s*$/;
#     If no digit at the end, a "null list" is returned.  Presumably
#     that means $stat_name (and $addend) are defined but empty.  Some
#     day I may learn perl...
    if ($addend) {
      (defined $defined_addends{$addend}) || &quit
         ("Looks like statisticker changed but perl interface didn't",
	  "perl interface handles " . @addend . " ways of dealing w/irreg data",
	  "varname $_ from statisticker seems to define another");
      if ( ! (defined $stat_names{$stat_name})  ) {
	$stat_names{$stat_name} = 1;
	$ordered_stat_list .= $stat_name . $sep;
      }
    } else {
#	Assume first non-statistics name found is the name for the column in
#	which the variables in the statistick'ed object are listed.  Decide for
#	yourself if this is better or worse than just hardcoding it.
#	Compare w/$stat_name_for_stat_column
      (defined $stat_name_for_variables_column) ||
				($stat_name_for_variables_column = $_);
    }
  }
  (defined $stat_name_for_variables_column) ||
       &quit("Could not find name for column where variables are listed",
	     "List of all column names follows:",
	     @stat_var_list);
#   To get next val, we COULD listvar the statisticker w/ROWS_ARE_STATS=
#   TRUE, and pick the first column name (under assump that's the one)
#   Decided that's not worth another trip through listvar.  (Interesting
#   that both this name and $stat_name_for_variables_column are constants
#   in the statisticker.  Presumably we could put them in a .h file, use
#   perl's "read a c .h file" feature, and build both this and the statisticker
#   at the same time)
  $stat_name_for_stat_column = "stat_name";

  chop $ordered_stat_list;
  return ($stat_obj,
	  join($sep,($stat_name_for_distinct_count,
		     $stat_name_for_stat_column,
	  	     $stat_name_for_variables_column)),
	  join ($sep,@addends),
	  $ordered_stat_list);
}