#!/usr/bin/perl -w
#  version 18 Jul 2008
#
# get2andjoin
#  purpose: to receive the second join object from getobj2
#  after user has determined which params will be included
#  with object2, then issue a form permitting user to cancel 
#  or to Submit the join for action
#
#  added 10-22-1999, clh:  checking for common parameters before
#    join is allowed to proceed, attempt to help user determine
#    how to proceed.
#
#  joinumethod expects selections/projections to be listed
#      with appropriate object in comma separated list.  Ex:
#   joinumethod.html0,object1(obj1sel,obj1proj),object2(obj2proj,obj2sel)
#
# NB: this file belongs in the directory configured as ScriptAlias /jg/
#     on this HTTPD server.  (typically htmlbin or optbin)
#     Generated from a template by a makefile in the source tree
#
#   1 Nov 08.  WJS
#	Switch from obj name joinumethod to join_2_args to see if we can 
#     download, etc directly.  Same method at the other end of the object name
#  18 Jul 08.  WJS
#	Got diagnostic from error log but couldn't coordinate w/instance.
#     Found and addressed what seems to be a logic problem in that area.
#  22 Aug 07.  WJS
#	Bug of some kind in "objects share variable?" code.  In particular,
#     earlier code reported that cmarz.whoi.edu/CMarZ objects iioe_zoo
#     and iioe_other had no vars in common when they do.
#	Earlier code more complicated for the primary task than it needed
#     to be.  However, it does some nice analysis when problems occur.
#     Added a block to do the primary task.  If it fails, execute old code
#     to get error analysis.
#	NOTE: design flaw in this whole package in that object spec parsing
#     is done here when it should be done in a common place.  Situation is
#     analogous to parse_path_info situation (and, in fact, this code
#     (other join-related html stuff if not this file) does some path_info
#     parsing when it shouldn't.  Presumably a parse_object_spec program
#     (or perhaps a what_kind_of_param_is_this) program should be written,
#     implementing what's documented in method_args.doc.  Note in particular
#     that this code assumes all args are sels & projs, besides assuming
#     it can tell sels from projs (OK, since this code gets all vars for
#     an object, it CAN tell sels from projs - if an arg is a varname,
#     then it is a proj, and this can be safely done w/recourse to a
#     common parsing routine)
#   3 Jun 05.  WJS
#       In an error situation, the return location after the error
#     display used undefined variable $fullobject1.  Took a guess
#     and made it $object1 (look for $cancel_string)
#	Postfix empty strings for $mainlocation, defined elsewhere and used
#     once here, generating diagnostic.  Ditto for $dispss.  Don't do
#     usual undef trick, since these might be the "defined elsewhere and
#     used once here" variables in another program!
#  16 Mar 05.  WJS
#	Hardcode perl location - obviates need for template file
#  

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);
do $build_opt_env;

$mainlocation = "$realtempdir"."/";
$listvar = $LISTVAR = "$topdir/bin/listvar";
$parse_path_info = "$topdir/bin/parse_path_info";


MAIN:
{
  &printtop;

#   Parse the PATH_INFO from our call.  We get here from getobj2, where great
#   pains were taken to put only the object name in the call to us.  However,
#   the object name can include the dreaded //, so the main purpose of 
#   parse_path_info here is to put the "extra" / back.  I suppose that because
#   of the pains taken to remove everything, we should treat the reoccurrence of
#   any field as an error.  However, too lazy to do that (to be complete, for example,
#   we'd have to check for extended URL info, something we DIDN'T do in getobj2)
  &check_x_access($parse_path_info);
  $command = "$parse_path_info -nonewline";
  ($results,$exit_status,@status_info) = &backtick($command);
  ($exit_status == 0) ||
	&quit (&format_backtick_return_status
				($command,@status_info,"return from command = $results"));
  %path_info_fields = split(/[,=]/,$results,-1);
  $object2 = $path_info_fields{'object'};
  (  ($status = &bad_path_info_piece($object2)) eq "OK") || 
		&quit ("$status object name returned from parse_path_info of $ENV{'PATH_INFO'}");

  &ReadParse(*input);

#   In the "great pains in getobj2" department, we did NOT write a null string
#   for form var  ext  , so if it's null here, it's really an error ... 
 (($EXT=$input{'ext'}) eq "") && ($EXT = "html0");

#########################################################
# depending on whether the user clicked 'Keep all' button
#
#   if user selected 'all' then
#	check for any original subsels - usually from .remoteobjects
#	if any, then use them as the definitive obj2 subselections
#   else
#	resolve the original subselections and
#	the newly selected ones and use total as the obj2 subselections
#   endif
#########################################################
 
    if ($input{'quant'} eq "all") {
      if ($input{'obj2origsels'} ne "none") {
         $param2=$input{'obj2origsels'};
      } else {
         $param2="";
      }
#
# else they want no subselections and none were defined originally
#
    } else {
#
# user defined new projections for object 2
#
	$newparam2=$input{'obj2newsels'};
	if ($input{'obj2origsels'} ne "none") {
	  foreach (split("\0", $input{'obj2origsels'})) {
	    $proj2{$_}=$_;
	  }
        }
	foreach (split("\0", $newparam2)) {
	    $proj2{$_}="$_";
	}
	$param2="";
        foreach $value (keys(%proj2)) {
	    $param2.="$value".",";
	}
	chop($param2);
      }

if ($param2 eq "") {
    $totalsecond="$object2";
} else {
    $totalsecond="$object2"."\("."$param2"."\)";
}
# See if there is a variable in common between the objects as projected
# by the user both in the original object specs and on the join page
#    Start by making hash of vars in 2nd object as projected
  &check_x_access($listvar);
  $command = qq|$listvar -1 "$totalsecond"|; 
  ($results,$exit_status,@status_info) = &backtick($command);
  ($exit_status == 0) ||
	&quit (&format_backtick_return_status
				($command,@status_info,"return from command = $results"));
  foreach (split ' ',$results) {
    $vars_in_obj2{$_} = 1;
  }
#
#   get information for object 1 from files in USETEMPDIR
#   Sets vars $object1, $param1, $dispobj, $subsels, $dispss & $refloc
#  
  do 'getfile1vars.pl';

  $command = qq|$listvar -1 "$object1|; 
  $subsels && ($command .= "($subsels)");
  $command .= '"';
  ($results,$exit_status,@status_info) = &backtick($command);
  ($exit_status == 0) ||
	&quit (&format_backtick_return_status
				($command,@status_info,"return from command = $results"));
#   Compare variables from object 1, as projected, w/variables from
#   object 2
  $match = "NO";
  foreach (split ' ',$results) {
    (defined $vars_in_obj2{$_}) && ($match = "YES") && last;
  }

  if ($match eq "YES") {
    &print_and_doit;
    exit(0);
  }

# Below is original code for both determining a match and offering the
# user diagnostic info if no match.  Go through it if code above says
# no match for diagnostic purposes.  Be interesting if code below
# decides there IS a match!  (As of Apr 2013, in the throes of an
# // -> / "Apache incident", code above said "No match" and code
# below DID say "match", triggering the "this is a bug" message below ...
# and indeed it is ...  I was tempted not to repeat the LISTVARs
# below, but since the idea is to "leave it alone", I'm going to leave
# it alone)

# get all parameters for objects
#
@object2vars = `$LISTVAR \"$object2"`;
@object1vars = `$LISTVAR \"$object1"`;
#
# User must select:
#       a) 2 objects with at least one common parameter
#  and  b) if user projects parameters, must choose at least 1 of common ones
#
#  Therefore, 4 possible cases exist
#  case 1 and 4: object1 is not projected - use all of its parameters
#        
# but, first need to remove selections - only want projections
#  
 $obj1justparams = &remove_selections($subsels);
 $obj2justparams = &remove_selections($param2);

 if ($obj1justparams eq 'none' or $obj1justparams eq "") {
#          
#   case 1: obj2 is not projected either - compare all vars
#          
     if ($obj2justparams eq "") {
        $case = 1;
        $status = &check_common(\@object1vars, \@object2vars);
     } else {
#          
#   case 4: obj2 has projections - check only these
#          
         $case = 4;
         @varsfor2 = split ',',$obj2justparams;
         $status = &check_common(\@object1vars, \@varsfor2);
     }
#
#  case 2 and 3: obj1 has projections - use only its projected parameters
#
  } else {
      if ($obj2justparams ne "") {
#          
#  case 3: obj2 also has projections 
#      
        $case = 3;
        @varsfor1 = split ',',$obj1justparams;
        @varsfor2 = split ',',$obj2justparams;
        $status = &check_common(\@varsfor1, \@varsfor2);
      } else {
#          
#  case 2: obj2 has no projections, use all of its parameters
# 
        $case = 2;
        @varsfor1 = split ',',$obj1justparams;
        $status = &check_common(\@object2vars, \@varsfor1);
      }
  }
  if ($status eq "good") {
#		     &print_and_doit;
    $msg = "old and new code in get2andjoin disagree about whether " .
	   "2 objects have a variable in common.  This is a bug - " .
	   "sorry about that";
    print "<p> *** $msg";
    die $msg;
  } else {
     &no_common_param;
  }
}
# avoid "1-time use" diagnostics
undef $realtempdir;
$mainlocation .= "";
$dispss .= "";


sub bad_path_info_piece {
  my ($input,$dummy) = @_;
  (defined $dummy) && &quit("bad_path_info_piece called w/too many args");
  (defined $input) || return "UNDEFINED";
  ($input eq "") && return "EMPTY";
  ($input eq "***ERROR***") && return "ERROR";
  return "OK";
}

################### printtop
sub printtop{
 print "Content-type: text/html\n\n";
 print "<HTML><HEAD><TITLE>Join 2 Data Objects</TITLE></HEAD>\n";
 print "<BODY BGCOLOR=\"ffffff\">\n";
}
################### remove-selections
sub remove_selections{
#
#  remove terms of the list sent to this subroutine which contain
#     the operators signalling selections
#
   my $arglist = pop @_;
   my $opset = "=><% ";
   my $newlist = "";

   @terms = split('[,|]',$arglist);
   foreach $term (@terms) {
      if ($term !~ /[$opset]/) {
        $newlist .= "$term".",";
      }
   }
   chop($newlist);
   return $newlist;
}
################### check_common
sub check_common{
  local (*check1, *check2) = @_;
  chomp @check1;
  chomp @check2;
  $status = "nogood";
 
  foreach $var1 (@check1) {
    foreach $var2 (@check2) {
       if ($var2 eq $var1) {
         $status = "good";
         last;
       }
    }
   }
  return $status;
}

################### print_and_doit
sub print_and_doit{
#
# one thing to add is htmlesc'ing - necessary?
#
#

  $cancel_string="http://"."$refloc"."$dispobj"."?"."$subsels";
  $doitprog="http://$ENV{'MYADDR'}/jg/serv/join_2_args.$EXT";
  $actualurl1=$dispobj;
  if ($subsels ne "") {
    $tmpobj=$dispobj;
    $actualurl1="$tmpobj"."\("."$subsels"."\)";
    $dispobj .= "("."$dispss".")";
  }            

  print <<ENDTEXT;

<H1>Ready to Join 2 Data Objects</H1>
<B>Object 1: $dispobj<BR>
Object 2:  $totalsecond</B><BR>
<HR NOSHADE>
<P>

<FORM METHOD="POST" 
          ACTION="$doitprog?$actualurl1,$totalsecond">

Press <FONT SIZE="4" COLOR="0000ff">
               <INPUT ALIGN=left TYPE="submit" NAME="choice"
                VALUE="Join"></FONT> to do it.
ENDTEXT
  print "<INPUT TYPE=\"hidden\"
          NAME=\"secondobj\" VALUE=\"$totalsecond\">\n";
  print "</FORM>\n";

  print "<FORM METHOD=\"POST\" ACTION=\"$cancel_string\">\n";

  print <<ENDofSUB;
Or <FONT SIZE="4"  COLOR="0000ff">
            <INPUT TYPE="submit" ALIGN=right
             VALUE="Cancel"></FONT>
</FORM>
</BODY>
</HTML>
ENDofSUB

}
################### no_common_param
#
# routine to inform user that no common parameters were chosen from
#   the 2 objects in use
#
# there are 4 cases that exist to account for the error
#   case 1:  object 1 has no projections,   object 2 has no projections
#                no common parameters exist full variable list
#   case 2:  object 1 has no projections,   object 2 has projections
#                possibly object 2 contains a variable in common with object 1
#   case 3:  object 1 has projections,      object 2 has projections
#                expand projections on either / both objects
#   case 4:  object 1 has projections,      object 2 has no projections
#                possibly object 1 contains a variable in common with object 1
#
sub no_common_param{

$cancel_string="http://"."$refloc"."$object1";
  print <<ENDOFMSG;

<p>
<font size=6>
Oops! You haven't chosen any parameters in common...
</font>
<p>
<table width=90% border=2>
ENDOFMSG

SWITCH: {
  if ($case eq 1) {
      print "<tr><th><font color=0000ff>Object 1: ",$dispobj,"</font>
             </th><th>
             <font color=0000ff>Object 2: ",$totalsecond,"</font></th></tr>";
      print "<tr><th>ALL available parameters</th>";
      print "<th>ALL available parameters</th></tr>";
    if ($#object1vars >= $#object2vars) {
      $max = $#object1vars;
      $min = $#object2vars;
    } else {
      $max = $#object2vars;
      $min = $#object1vars;
    }
    for ($i = 0; $i <= $min; $i++) {
       print "<tr><td>",$object1vars[$i],"</td><td>",$object2vars[$i],"</td></tr>";
    }
    until ($i > $max) { 
       $remaining_var = ($max == $#object1vars) ? 
				$object1vars[$i++] : $object2vars[$i++];
       print "<tr><td>",$remaining_var,"</td><td>"," ","</td></tr>";
    }
    print "</table>";
    print "<p><hr noshade>";
    print "<center><b><font color=0000ff size=5>Important information</font></b></center><p>";
    print "These 2 objects have NO parameters in common.";
    print "They are not candidates for a Join, which REQUIRES at least one parameter in common.";
#    print "To combine the data in these 2 objects, assuming that you have decided that this is
#           logically appropriate, use the menu item labelled: Merge 2 objects<p>\n";

    last SWITCH; 
  }

  if ($case eq 2) {
      print "<caption><font color=0000ff>Object 1: ",$dispobj,"</font></caption>";
      print "<tr><th>ALL available parameters</th>"; 
      print "<th>Projected parameters (only these are used for the Join)</th></tr>";
    for ($i=0; $i <= $#varsfor1; $i++) {
       print "<tr><td>",$object1vars[$i],"</td><td>",$varsfor1[$i],"</td></tr>";
    }
    until ($i > $#object1vars) { 
       print "<tr><td>",$object1vars[$i++],"</td><td>"," ","</td></tr>";
    }
    print "</table>";

    print "<p>";
    print "<table width=90% border=2>";
    print "<caption><font color=0000ff>Object 2: ",$totalsecond,"</font></caption>";
    print "<tr><th>ALL available parameters</th></tr>";
    $i=0;
    until ($i > $#object2vars) { 
       print "<tr><td>",$object2vars[$i++],"</td></tr>";
    }
    print "</table>";

    print "<p><hr noshade>";
    print "<center><b><font color=0000ff size=5>A Suggestion</font></b></center><p>";    
    print "Since object 1 has <a href=\"/sel-proj-defn.html\#proj\">projections</a>,
           it is the likely place to look for the common parameter.";
    print "Examine the lists above and decide which parameter should be included in the
           <b>list of projected parameters for object 1</b>.";
    print "Return to the Menu item labeled 'Sub-selections of data',
           add the common parameter to the list of projections and then, 
           return here to join these 2 objects.<p>\n";

    last SWITCH;
  }

  if ($case eq 3) {
      print "<caption><font color=0000ff>Object 1: ",$dispobj,"</font></caption>";
      print "<tr><th>ALL available parameters</th>"; 
      print "<th>Using only these parameters for the Join ('projected parameters')</th></tr>";
    for ($i=0; $i <= $#varsfor1; $i++) {
       print "<tr><td>",$object1vars[$i],"</td><td>",$varsfor1[$i],"</td></tr>";
    }
    until ($i > $#object1vars) { 
       print "<tr><td>",$object1vars[$i++],"</td><td>"," ","</td></tr>";
    }
    print "</table>";
    print "<p>";

    print "<table width=90% border=2>";
    print "<caption><font color=0000ff>Object 2: ",$totalsecond,"</font></caption>";
      print "<tr><th>ALL available parameters</th>"; 
      print "<th>Using only these parameters for the Join ('projected parameters')</th></tr>";
    for ($i=0; $i <= $#varsfor2; $i++) {
       print "<tr><td>",$object2vars[$i],"</td><td>",$varsfor2[$i],"</td></tr>";
    }
    until ($i > $#object2vars) { 
       print "<tr><td>",$object2vars[$i++],"</td><td>"," ","</td></tr>";
    }
    print "</table>";

    print "<p><hr noshade>";
    print "<center><b><font color=0000ff size=5>A suggestion</font></b></center><p>";        
    print "There do exist common parameters in these 2 objects.";
    print "However, each of the objects has 
           <a href=\"/sel-proj-defn.html\#proj\">projections</a> and so,
           either is a candidate for the omitted common parameter(s).";
    print "<ul>Examine the lists above and decide which parameter from which object
           should be included in the list of projected parameters.";
    print "<li>If the parameter needs to be added to object 1, return to the Menu item
            labeled 'Sub-selections of data', add the common parameter to the list of
            projections and then, return here to join these 2 objects.";
    print "<li>If the parameter needs to be added to object 2, use the 'Back' button
           of your browser to return to the previous screen where you selected only
           some of object 2's parameters to use in the Join.";
    print "Add the common parameter and Continue.</ul><p>\n";

    last SWITCH;
  }

  if ($case eq 4) {
      print "<caption><font color=0000ff>Object 1: ",$dispobj,"</font></caption>";
      print "<tr><th>Using all available parameters</th><th>","  ","</th></tr>";
    $i=0;
    until ($i > $#object1vars) { 
       print "<tr><td>",$object1vars[$i++],"</td><td>"," ","</td></tr>";
    }
    print "</table>";
    print "<p>";

      print "<table width=90% border=2>";
      print "<caption><font color=0000ff>Object 2: ",$totalsecond,"</font></caption>";
      print "<tr><th>ALL parameters available</th>";
      print "<th>Using only these parameters for the Join ('projected parameters')</th></tr>";
    for ($i=0; $i <= $#varsfor2; $i++) {
       print "<tr><td>",$object2vars[$i],"</td><td>",$varsfor2[$i],"</td></tr>";
    }
    until ($i > $#object2vars) { 
       print "<tr><td>",$object2vars[$i++],"</td><td>"," ","</td></tr>";
    }
    print "</table>";

    print "<p><hr noshade>";
    print "<center><b><font color=0000ff size=5>A suggestion</font></b></center><p>";
    print "Since object 2 has <a href=\"/sel-proj-defn.html\#proj\">projections</a>, 
           it is the likely place to look
           for the omitted parameter which is in common with object 1.<br> ";
    print "Examine the lists above and decide which parameter should be included in the
           <b>list of projected parameters for object 2</b>.";
    print "Then, Click on the 'Back' button of your browser to return to the previous screen
           where you selected only some of object 2's parameters to use in the Join.";
    print " Add the common parameter and Continue.<p>\n";

    last SWITCH;
  }
 }

  print "<FORM METHOD=\"POST\" ACTION=\"$cancel_string\">\n";

  print <<ENDofthisSUB;
   <FONT SIZE="4"  COLOR="0000ff">
            <INPUT TYPE="submit" ALIGN=right
             VALUE="Return to Menu"></FONT>
</FORM>
</BODY>
</HTML>
ENDofthisSUB
}