#!/usr/bin/perl -w
{
#   timesplit.pl Oct 08

$version = "timesplit.pl version 1.0  24 Oct 2008";

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

#   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;
                            
#   Define form action routine as this file.  Undefined SCRIPT_NAME code
#   to allow possibility that this program is not being run in web environment
($form_action_routine = $ENV{"SCRIPT_NAME"}) || 
			($form_action_routine = &get_this_file_as_url($0));

#   Check that build-opt-env set up things as expected
$topdir = &check_build_opt_env_var('OPTHOME',$build_opt_env);
$tempdir = &check_build_opt_env_var('USETEMPDIR',$build_opt_env); 
$tempdir = &abs_filespec($tempdir,"Env var USETEMPDIR");
$rundir = &check_build_opt_env_var('OPTRUNDIR',$build_opt_env);
$rundir = &rel_filespec($rundir,"Env var OPTRUNDIR");
$rundir = "$topdir/$rundir";
$bindir = &abs_filespec($topdir,"Env var OPTHOME") . "/bin";

$serv = "$rundir/serv";

$listvar = "$bindir/listvar";
$listvar_command = "$listvar -a";

#   Guesses for varname which user might want to split.  A string
#   below is a valid guess if a varname in the object begins with
#   the string (case insensitive).  The best guess is the match nearest
#   the beginning of the array below
@JGOFS_varname_guess = ("date","event","yrmoda","hhmm","time");

$task_form_var_name = "Task_to_be_performed";
$action_form_value = "Split_time";
$refresh_cache_form_value = "Refresh_varlist_cache";

$object_form_var_name = "object_defn";
$job_id_form_var_name = "unique"; 
$varname_form_var_name = "var_to_split";
$format_form_var_name = "format";

&ReadParse(*form_info);

$task = &get_form_var($task_form_var_name,"OPT");
if (($task eq "") || ($task eq $refresh_cache_form_value)) {
   &print_form;
}elsif ($task eq $action_form_value) {
   &process_form;
} else {
   &quit ("Bad value for form var $task_form_var_name; namely,",$task);
}

# Avoid "used one time" diagnostic
undef %form_info;
exit;
}

sub print_form
{
  &printheader();

  print "<html>\n";

  $title = 'Time split page';
  print "<head><title>$title</title></head>\n";
  print "<h1>$title</h1>\n";

  print <<EOT;
Sample use: takes object with date variable encoded as yyyymmdd and
	puts out object with additional year, month, and day variables
EOT
  $h = qq|input type="hidden"|;

#     First time through, get values from environment.  Otherwise, 
#   get values from form.  As of now, the only way there can be a
#   2nd time through is if we are doing a cache refresh
#     Wherever they come from, put values on the next form
  $refresh_cache = ($task eq $refresh_cache_form_value);
  if ($refresh_cache) {
#     Should really check object somehow after getting it - await
#     improvement to parse_object_spec stuff
    $object = &get_form_var($object_form_var_name,"REQ","NOCHECK");
#     See process_form for why job_id is OPT.  Reason less likely here
#     than there, but possible
    $unique = &get_form_var($job_id_form_var_name,"OPT");
  } else {
    $object = &check_build_opt_env_var('OBJECT',$build_opt_env); 
    $ENV{'SUBSELS'} && (  $object .=  "(" . $ENV{'SUBSELS'} . ")"  );
  }
  $unique || ($unique = $$);
  print qq|<form method="POST" action="$form_action_routine">\n|;
  print qq|<$h name="$job_id_form_var_name" value="$unique">\n|;
  print qq|<$h name="$object_form_var_name" value="$object">\n|;

  ($used_cached_file,@def_varlist) = 
	&get_cached_varlist($listvar_command,$tempdir,$object,$refresh_cache);


#   Extract best guess from varlist.  A valid guess is a varname
#   that begins w/ any string in the guess list.  If > 1, choose the
#   one nearest the beginning of the guess list.
#   While at it, put varlist into a simple array
  $guess = "";
  $rank = 99999;
  foreach (@def_varlist) {
    foreach $var (split (' ',$_)) {
      ($var eq '>') and next;
      ($var) = split /\[/,$var;
      $i = 0;
      foreach (@JGOFS_varname_guess) {
	$i++;
	($i >= $rank) && last;
	($var =~ /^$_/i) || next;
	$rank = $i;
	$guess = $var;
	last;
      }
    push @varlist,$var;
    }
  }

  print "<p><br>Variable to be split  \n";
  print qq|<select name="$varname_form_var_name">\n|;
  foreach (@varlist) {
    print "<option";
    ($_ eq $guess) && (print " selected");
    print ">$_\n";
  }
  ($guess eq "") && print "<option selected>SELECTION_NEEDED\n";
  print "</select>";


  print "<p><br>Format for variable selected above \n";
  print qq|<br><input type="text" name=$format_form_var_name size=20>\n|;
  print "<br>Example: format yyyymmdd_HHMM will decode datum 20081024:0026\n";


  print qq|<p><br><br><input type="submit"| .
	" name=$task_form_var_name value=$action_form_value >\n";

  if ($used_cached_file) {
    print << "XXstuffXX-040";
    </b>
    <hr noshade><p>
    <font size=2>
    <b>
    <input type="submit" 
	   name="$task_form_var_name" 
	   value="$refresh_cache_form_value">
	if the variable lists above (which are cached) look incorrect
    </b>
    </font>
XXstuffXX-040
  }

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

sub process_form
{
  $date = localtime();

  $official_year_var = "year";
  $official_month_var = "month";
  $official_day_var = "day";
  $official_time_var = "time";
  $official_yrday_var = "yrday";
  $official_yrday0_var = "yrday0";
  &printheader();

  print "<html>\n";

#     If we are here because of a web page, get unique from that page
#     If we were called directly (eg, args in QUERY_STRING), generate our
#       own unique stamp
  $unique = &get_form_var($job_id_form_var_name,"OPT");
  $unique || ($unique = $$);

  $object = &get_form_var($object_form_var_name,'REQ','NOCHECK');

  $input_timedate_var = &get_form_var($varname_form_var_name,'REQ');
#     Don't be deceived into thinking that the varlist we end up with after
#     the next statement has anything to do w/the varlist in the print_form
#     section.  We COULD check that the next line used the cache, but that
#     would disable stand-alone use of process_form
  (undef,@def_varlist) = 
		&get_cached_varlist($listvar_command,$tempdir,$object,0);
  $level = 0;
  foreach (@def_varlist) {
    foreach (split (' ',$_)) {
      ($_ eq '>') && next;
      ($var) = split /\[/;
      $varlist{$var} = $level;
    }
    $level++;
  }
  (defined $varlist{$input_timedate_var}) || 
	&quit ("Input variable $input_timedate_var not found in input object");

  $new_format = $format = &get_form_var($format_form_var_name,'REQ');
  $legal_format_chars = "JjymdHM_";
  ($format =~ /[$legal_format_chars]+/) || 
    &quit ("Format must consist only of characters from set " .
	  $legal_format_chars .
	 "\nFormat (between vertical bars): |$format|");
  foreach (split //,$format) {
    $format_chars{$_} = 1;
  }

  $julian_in = ($format_chars{'J'} || $format_chars{'j'});
  ($julian_in && ($format_chars{'m'} || $format_chars{'d'})) && 
		&quit ("Cannot specify Julian input with month or day input" .
				 "\nFormat (between vertical bars): |$format|");

#     Change things to  defgb's timedateparams format (see param1.doc in
#     defgb release directory).
#       MOST ERRORS (eg multiple field specs) WILL GO ALL THE WAY TO DEFGB

#   defgb's "skip" character is asterisk
  $format_chars{'_'} && ($new_format =~ tr/_/\*/);

#   Year
  if ($format_chars{'y'}) {
    $n = ($format =~ tr/y//);
    $ok = (($n == 2) && ($format =~ /yy/)) ||
  	(($n == 4) && ($format =~ /yyyy/));
    $ok || &quit ("Year format must be yyyy or yy\n" .
				 "\nFormat (between vertical bars): |$format|");
    ($n == 4) && ($new_format =~ tr/y/Y/);
    push @outvars,$official_year_var;
    push @tdparams_outvar_defns,"outyearname = $official_year_var";
  }

#   Month
  if ($format_chars{'m'}) {
    $n = ($format =~ tr/m//);
    $ok = (($n == 2) && ($format =~ /mm/)) ||
	(($n == 3) && ($format =~ /mmm/));
    $ok || &quit ("Month format must be mmm or mm\n" .
				 "\nFormat (between vertical bars): |$format|");
    ($n == 3) && ($new_format =~ tr/m/b/);	# Alpha month abbr; eg Jan
    push @outvars,$official_month_var;			
    push @tdparams_outvar_defns,"outmonthname = $official_month_var";
  }

#   Day
  if ($format_chars{'d'}) {
    $n = ($format =~ tr/d//);
    $ok = (($n == 2) && ($format =~ /dd/));
    $ok || &quit ("Day format must be dd\n" .
				 "\nFormat (between vertical bars): |$format|");
    push @outvars,$official_day_var;			
    push @tdparams_outvar_defns,"outdayname = $official_day_var";
  }

#   Julians
  if ($julian_in) { 
    $n = ($format =~ tr/Jj//);
    $ok = (($n == 3) 
		&& ($format =~ /jjj/i)
		&& ! ($format_chars{'J'} && $format_chars{'j'})
	  );
    $ok || &quit ("Julian day format must be jjj or JJJ\n" .
				 "\nFormat (between vertical bars): |$format|");
    $julian_format_line = "outjulianformat = ";
    $format_chars{'j'} && 
		&do_julian("j",$official_yrday_var,$format_chars{'y'});
    $format_chars{'J'} && 
		&do_julian("v",$official_yrday0_var,$format_chars{'y'});
  }

#   Hours & minutes
  if ($format_chars{'H'} || $format_chars{'M'}) { 
    push @outvars,$official_time_var;			
    push @tdparams_outvar_defns,"outtimename = $official_time_var";
    $n = ($format =~ tr/H//);
    $ok = (($n == 2) && ($format =~ /HH/)) ||
	  ($n == 0);
    $ok || &quit ("Hour format may only appear once and must be HH\n" .
				 "\nFormat (between vertical bars): |$format|");
    $n = ($format =~ tr/M//);
    $ok = (($n == 2) && ($format =~ /MM/)) ||
	  ($n == 0);
    $ok || &quit ("Minute format may only appear once and must be MM\n" .
				 "\nFormat (between vertical bars): |$format|");
    $new_format =~ s/HHMM/NNNN/;# Avoid problems w/blank hours in common HHMM
  }

#   Figure out names of variables we are going to add.  Format will
#   be $official_name . $suffix, where $suffix will be the same for
#   all added vars, and will be either empty or _N.  Criterion is that
#   name we want to add cannot already be in object.
  $ok = 1;
  foreach (@outvars) {
    defined($varlist{$_}) || next;
    $ok = 0;
    last;
  }
  if ($ok) {
    $suffix = "";
  } else {
    $sanity_count = 1000;
    $suffix = 0;
    while ($suffix < $sanity_count) {
      $ok = 1;
      foreach (@outvars) {
        $varlist{$_ . "_$suffix"} || next;
        $ok = 0;
        last;
      }
      $ok && last;
      $sanity_count++;
    }
    $ok || &quit ("Internal error.  " .
		"Could not find unique varname in $sanity_count tries");
    $suffix = "_$suffix";
  }  
#     Add inserted variables on level of input variable (adding suffixes
#       "on the fly")
#     Use \t since that's the variable separator in def_varlist
  $input_timedate_level = $varlist{$input_timedate_var};
  $def_varlist[$input_timedate_level] = 
		join "$suffix\t",@outvars,$def_varlist[$input_timedate_level];

###			Stuff from here out pretty much a copy of timecnv

#   Put defgb indirect & optional files in persistent object subdir
#   in case user decides to save object.
  $persistent_object_dir = "$tempdir/persistent_objects";
  if (-e $persistent_object_dir) {
     (-d $persistent_object_dir) ||
			&quit ("$persistent_object_dir is not a directory");
     (-w $persistent_object_dir) ||
	&quit ("Cannot create files in directory $persistent_object_dir");
  } else {
     mkdir ($persistent_object_dir,0775) ||
		&quit("Cannot create directory $persistent_object_dir : $!");
  }

  $timesplit_obj_name = "timesplit_$unique";
  $relative_varlist_file = "$timesplit_obj_name.varlist";
  $relative_tdparams_file = "$timesplit_obj_name.tdparams";

  $file_root = "$persistent_object_dir/$timesplit_obj_name";
  $ind_file = "$file_root.ind";
  $varlist_file = "$persistent_object_dir/$relative_varlist_file";
  $tdparams_file = "$persistent_object_dir/$relative_tdparams_file";
################################################

#  Build object for serv to run
#  Object name (PATH_INFO for serv) = defgb_1_arg, which requires a defgb
#  indirect file (pointing to our input object) and defgb varlist
#  and timedateparams optional files (to add the output time vars to
#  the object and to describe the input time format, respectively)
#  The indirect file is serv's QUERY_STRING

  ($id = $ENV{"REMOTE_HOST"}) || ($id = "eff. UID $>");
#    In next line, # is defgb comment indicator
  $defgb_comment = "#  Written for $id $date  ";

###
#    Indirect file
  (open (IND_FILE,">$ind_file")) || &quit ("Bad open/write $ind_file: $!");
#    In next line {}s are defgb "where did this comment come from" delims
  print IND_FILE $defgb_comment,"{$version}\n";
#   In next line, {}s are defgb delims indicating object input
  print IND_FILE "datafile = {$object}\n";
  print IND_FILE "timedateparams = $tdparams_file\n";
  print IND_FILE "varlist = $varlist_file\n";
  (close IND_FILE) || &quit ("Problem closing $ind_file: $!");
  
###
#    Timedateparams file
  (open (TDPARAMS_FILE,">$tdparams_file")) ||
				&quit ("Bad open/write $tdparams_file: $!");
  print TDPARAMS_FILE "$defgb_comment\n";
  print TDPARAMS_FILE 
	"invar1name=$input_timedate_var; invar1template=$new_format\n";
  foreach (@tdparams_outvar_defns) {
    print TDPARAMS_FILE "$_$suffix\n",
  }
  $julian_in && print TDPARAMS_FILE "$julian_format_line\n";
  (close TDPARAMS_FILE) || &quit ("Problem closing $tdparams_file: $!");

###
#    Varlist file
  (open (VARLIST_FILE,">$varlist_file")) ||
				&quit ("Bad open/write $varlist_file: $!");
  print VARLIST_FILE "$defgb_comment\n";
  foreach (@def_varlist) {
    print VARLIST_FILE "$_\n";
  }
  (close VARLIST_FILE) || &quit ("Problem closing $varlist_file: $!");


  ($serv_status,$sys_status,$child_status,$command) =
		&let_serv_do_it($serv,"/defgb_1_arg.html0","\@$ind_file");
  ($serv_status eq "OK") || 
			&quit ("Bad serv attempt\n" .
				"\tCommand:\n $command\n" .
				"\t\$! = $sys_status;  \$? = $child_status");

  undef $version;		# Global variable used in quit
  return;
}

sub do_julian
{
  my ($format,$outvarname,$have_year_info) = @_;

  $have_year_info || ($format = uc($format));	# See defgb doc
  $julian_format_line .= $format;
  push @outvars,$outvarname;
  push @tdparams_outvar_defns,"outjulianname = $outvarname";
  return;
}
