#!/usr/local/bin/perl
#
# Delta Access Perl
# v1.021 beta 
# DA1.3 (_DAT durch _DESCR ersetzt)
#
# This perl script is web interface for Delta Access
# and was written by: Noel Cross noelc@oeb.harvard.edu
#
# Delta Access is written by Gregor Hagedorn 
# and is available from http://www.bgbm.fu-berlin.de/projects/DeltaAccess
#
# This script uses Win32::ODBC
# a Perl 5 extension that provides access to the ODBC API
# It's available at http://www.roth.net/odbc/
# If you don't want to use ODBC it shouldn't be hard to substitute your own
# perl-to-database code, providing your database supports such a thingy.
#
# This script also uses CGI.pm - a Perl5 CGI Library
# available from http://www-genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html
# 
# (standard disclaimers here)

##################################
#
# global variables--you need to customize all of these to fit your purposes.


#Fill in the appropriate ODBC stuff here:
#$odbc_resource_name = "Borneo";
#$odbc_resource_name = "LiasGenera";
#$odbc_resource_name = "deltabeispiel";

#### now dynamic through CGI-environment with default
#### by A. Findling
#### call the script now (example): http://..../cgi-bin/delta_access.pl/Borneo

### new $ENV{'PATH_INFO'}-routines because of different
### CGI-variables of PATH_INFO in IIS3.0 (WINNT4) and personal Webserver 1.0 (WIN95)
### NEW in 1.02 (AF)
#
if (substr($ENV{'PATH_INFO'},length($ENV{'PATH_INFO'})-1,1) eq "/") {
    $ENV{'PATH_INFO'}=substr($ENV{'PATH_INFO'},0,length($ENV{'PATH_INFO'})-1);
}


if ($ENV{'PATH_INFO'} eq $ENV{'SCRIPT_NAME'}) {
    $ENV{'PATH_INFO'}="";
}
else {
    $ENV{'PATH_INFO'}=~s/.*(\/.*?)$/$1/;
}

$odbc_resource_name =substr($ENV{'PATH_INFO'},1,length($ENV{'PATH_INFO'})-1);
if ($odbc_resource_name eq "") {
    $ENV{'PATH_INFO'}="";
    $odbc_resource_name = "LiasGenera";   #### or define other default
}

#
####

$odbc_user = "";
$odbc_passwd = "";


#### variable '$mdb_resource_name' inserted by A. Findling
#### in the source at the SELECT-statements the string 'Borneo' (or 'BORNEO') substituted with '".$mdb_resource_name."' 
#
$mdb_resource_name = $odbc_resource_name;
#
####

#### $title an $authors now defined as hash of $mdb_resource_name to use more than one db in one script
#### look at the other $title an $authors -calls in the script now:  $title{$mdb_resource_name} and $authors{$mdb_resource_name}
#### hash %char_groups [0|1] for [don't exist|exist] added (because we have no grouping of Characters)
#### by A. Findling
#
#### $mainpage-hash for back to the Main Page (Homepage)
### NEW in 1.02 (AF)
#
## Define your Database like following 'ExampleDatabase'
$title{'ExampleDatabase'} = "Example-Database";
$authors{'ExampleDatabase'} = "Authors Names";
$char_groups{'ExampleDatabase'}=0; # or 1 if char_groups defined
$mainpage{'ExampleDatabase'}="/example/";
# Now the URL is: http://...../delta_access.pl/ExampleDatabase

## Original Example-Database of N. Cross:
$title{'Borneo'} = "Tree Genera of Borneo";
$authors{'Borneo'} = "James K. Jarvie and Ermayanti";
$char_groups{'Borneo'}=1;
$mainpage{'Borneo'}="http://www.herbaria.harvard.edu/computerlab/web_keys/borneo.html";
#
####
####


$script_location = "";

$about = "<font size=-1>About</font>";
$character_groups = "<b>Character Groups</b><br>";


#credit
$delta_access_url = "http://www.bgbm.fu-berlin.de/projects/DeltaAccess/";
$huh_url = "http://www.herbaria.harvard.edu";
$noel_email = "noelc\@oeb.harvard.edu";
$gregor_email = "hagedorn\@zedat.fu-berlin.de";

#set up image directory
$image_directory = "http://django.harvard.edu/users/jjarvie/English/Www/";
$heading_color = "\"#99CCFF\"";




# End of custom variables
##################################
# 
use Win32::ODBC;

#
use CGI qw(:standard);
$query = new CGI;

#### Check valid db-definition for security !?!
#### added by A. Findling
#
if ($title{$mdb_resource_name} eq "") {
	print header;
	print "No valid Database";
	exit;
}
#
####

#### $script_name now defined as CGI-environment
#### by A. Findling
#
#$script_name = "delta_access.pl";
$script_name = $ENV{'SCRIPT_NAME'}.$ENV{'PATH_INFO'};
#
####

$path_info = $query->path_info;


if (param()) {
	#open an ODBC connection
	$MyDSN = "DSN=$odbc_resource_name\;UID=$odbc_user\;PWD=$odbc_passwd\;";
	$Data = new Win32::ODBC("$MyDSN");

	if(!$Data) {
		print header;
		print "No connection!<br>\n";
		print "Exiting...<br>\n";
	}


	$call = param('call');

	if($call eq "character_groups") {
		&character_groups;
	}

	elsif($call eq "characters") {

#### following if-statement added by A. Findling
#
	   if ($char_groups{$mdb_resource_name}==1) {
		$character_group_id = param('character_group_id');
		if(!$character_group_id) {
			print header;
			print "<b>Characters</b>";
			exit;
		}
		$character_group_name = param('character_group_name');
		if(!$character_group_name) {
			print "error: missing character_group_name variable\n";
		}
		&characters($character_group_id, $character_group_name);
	   } 
#
#### end of added if-statement

	   &characters($character_group_id, $character_group_name);
	}
	elsif($call eq "states") {
		$character_id = param('character_id');
		if(!$character_id) {
			print header;
			print "<b>Character States</b>\n";
			exit;
		}
		
		$character_name = param('character_name');
		if(!$character_name) {
			print "error: missing character_name variable in states call\n";
		}

		&states($character_id, $character_name);
	}
	elsif($call eq "criteria") {

		$character_id = param('character_id');
		$character_name = param('character_name');
		$state_id = param('state_id');
		$state_name = param('state_name');
		$action = param('action');

		&criteria($character_id, $character_name, $state_id, $state_name, $action);
	}
	elsif($call eq "items") {
		&items;
	}
	elsif($call eq "images") {
		&images;
	}
	elsif($call eq "blank") {
		&blank;
	}

	elsif($call eq "about") {
		&about;
	}
	elsif($call eq "title") {
		&title;
	}
	$Data->Close();
	exit;
}
else {
	&frame;
	exit;
}

sub about {
#### small changes to about by A. Findling
#### adding target="_parent" to the references
#

	print header;


### Automatic back from about to title
### NEW in 1.02 (AF)
### Corrected in 1.021 (AF)
###
#
	print "<HTML>\n";
	print "<HEAD>\n";
	print "<META HTTP-EQUIV=\"Refresh\" CONTENT=\"6; URL=$script_location$script_name?call=title\">\n";
	print "</HEAD>\n";
#
###

### Corrected in 1.021 (AF)
#
	print <<EOF;
	<body bgcolor="#ffffff">
	<font size=-1>
EOF

#### New in 1.021 (A. Findling)
#
	print "Data compiled by $authors{$mdb_resource_name}<br>";
#
####

	print <<EOF;
	<b><a target="_parent" href="http://www.herbaria.harvard.edu/computerlab/web_keys/delta_access_perl.html">Delta Access Perl v1.01</a></b>
	is a web interface to <a  target="_parent" href="http://www.bgbm.fu-berlin.de/projects/DeltaAccess">Delta Access</a>
	and was written by <a href="mailto:$noel_email">Noel Cross</a>
	<br>
EOF
#
####


#### throw the following 'about' away - if you want ;-) (A. Findling)
#
print <<EOF;
	and was a little modified to <a  target="_parent" href="http://www.lrz-muenchen.de/~findling/programs/dap/">'DAP v1.021 beta'</a> 
	for <a target="_parent" href="http://www.botanik.biologie.uni-muenchen.de/botsamml/lias/lias.html">Lias</A> by
	<a  target="_parent" href="http://www.lrz-muenchen.de/~findling/">Axel Findling</a><br>
EOF
#
####
	print <<EOF;
	<a target="_parent" href="http://www.bgbm.fu-berlin.de/projects/DeltaAccess">Delta Access</a> is written by <a href="mailto:$gregor_email">Gregor Hagedorn</a>
	<p>
	(standard disclaimers)
	</font>

	</body>
EOF
### Automatic back from about to title
### NEW in 1.02 (AF)
###
#
	print "</HTML>\n";

#
####

}
sub blank {
	print header;
	print <<EOF;
	<body bgcolor="#ffffff">
	</body>
EOF
	;
}

sub title {
	print header;

### Link to the Main Page (Homepage)
### NEW in 1.02 (AF)
### Corrected in 1.021 (AF)
###
#

	print <<EOF;
	<body bgcolor="#ffffff">
	<center>
	<b>$title{$mdb_resource_name}</b><br>
	[<a href="$script_location$script_name?call=about">$about</a> | <a target="_parent" href="$mainpage{$mdb_resource_name}">Main Page</a>]<br>
	</center>
	</body>
EOF
#
###
	;
}


sub character_groups {
	print header;
	print $character_groups;
	$query = "SELECT character_group.character_group_id, character_group.character_group_name FROM character_group ORDER BY character_group_id";

	$reference_to_table = &get_data($query);

	$count = 0;

	#put the data into an array.
	foreach $reference_to_row (@$reference_to_table) {
		$count++;
		@row = @$reference_to_row;
		$character_group_id = @row[0];
		$character_group_name = @row[1];
		print "<li><a href=\"$script_location$script_name?call=characters&character_group_id=$character_group_id&character_group_name=$character_group_name\" TARGET=Character>$character_group_name</a><br>\n";
	}
}


sub characters {

	print header;
	local($character_group_id, $character_group_name) = @_;

#### following if-statement added by A. Findling
#
	if ($char_groups{$mdb_resource_name}==1) {
	    print "<b>Characters for <i>$character_group_name</i></b><br>"; # is original!
	}
	else {
	    print "<b>Characters</b><br>";
	}
#
#### end of added if-statement

	#$query = "SELECT ".$mdb_resource_name."_CHAR.CID, ".$mdb_resource_name."_CHAR.CharName FROM character_group_character,".$mdb_resource_name."_CHAR WHERE character_group_character.character_id = ".$mdb_resource_name."_CHAR.CID AND character_group_character.character_group_id = $character_group_id AND (".$mdb_resource_name."_CHAR.Type = 'OM' OR ".$mdb_resource_name."_CHAR.Type = 'UM')";

#### following if-statement added by A. Findling
#
      if ($char_groups{$mdb_resource_name}==1) {
	$query = "SELECT ".$mdb_resource_name."_CHAR.CID, ".$mdb_resource_name."_CHAR.CharName FROM character_group_character, ".$mdb_resource_name."_CHAR WHERE character_group_character.character_id = ".$mdb_resource_name."_CHAR.CID AND character_group_character.character_group_id = $character_group_id AND (".$mdb_resource_name."_CHAR.Type  LIKE 'OM' OR ".$mdb_resource_name."_CHAR.Type LIKE 'UM')";
	### is original!
      }
      else {
	$query = "SELECT ".$mdb_resource_name."_CHAR.CID, ".$mdb_resource_name."_CHAR.CharName FROM ".$mdb_resource_name."_CHAR WHERE (".$mdb_resource_name."_CHAR.Type  LIKE 'OM' OR ".$mdb_resource_name."_CHAR.Type LIKE 'UM')";
      }
#
#### end of added if-statement

	$reference_to_table = &get_data($query);

	$count = 0;
	foreach $reference_to_row (@$reference_to_table) {
		$count++;
		@row = @$reference_to_row;
		$character_id = @row[0];
		$character_name = @row[1];
		$character_name_no_spaces = $character_name;
		$character_name_no_spaces =~ s/ /+/g;
		print "<li><a href=\"$script_location$script_name?call=states&character_id=$character_id&character_name=$character_name_no_spaces\" TARGET=State>$character_name</a><br>\n";
	}
}
sub states {
	print header;
	local($character_id, $character_name) = @_;
	print "<b>States for character <i>$character_name</i></b>";
	$query = "SELECT ".$mdb_resource_name."_CS.CID, ".$mdb_resource_name."_CS.CS, ".$mdb_resource_name."_CS.CharStateName FROM ".$mdb_resource_name."_CS WHERE ".$mdb_resource_name."_CS.CID = $character_id AND (".$mdb_resource_name."_CS.CS NOT IN ('V', '-', 'TE', 'U'))";

	$reference_to_table = &get_data($query);

	$count = 0;
	foreach $reference_to_row (@$reference_to_table) {
		$count++;
		@row = @$reference_to_row;
		$character_id = @row[0];
		$state_id = @row[1];
		$state_name = @row[2];

		$character_name_no_spaces = $character_name;
		$character_name_no_spaces =~ s/ /+/g;

		$state_name_no_spaces = $state_name;
		$state_name_no_spaces =~ s/ /+/g;

		print "<li><a href=\"$script_location$script_name?call=criteria&character_name=$character_name_no_spaces&state_id=$state_id&state_name=$state_name_no_spaces&character_id=$character_id&action=normal\" TARGET=Criteria>$state_name</a><br>\n";
	}
}

sub criteria {
	local($character_id, $character_name, $state_id, $state_name, $action) = @_;

	#read the criteria list from the cookie
	%criteria_list = cookie('criteria');
	
	#add a value
	$criteria_list{$character_id} = $state_id;


	#if the reset flag has been passed then clear the cookie
	if($action eq "reset") {
		undef %criteria_list;
	}

	#if the delete flag has been passed then delete this item
	if($action eq "delete") {
		delete $criteria_list{$character_id};
	}

	#write the new cookie
	$the_cookie = cookie(-name=>'criteria',
		     -value=>\%criteria_list,
		     -expires=>'+1h');

	#print the HTML header with the new cookie info
	print header(-cookie=>$the_cookie);

	print "<b>Working Criteria List</b>";

	print " <a href=\"$script_location$script_name?call=items\" TARGET=Items>view list</a>\n";
	print " <a href=\"$script_location$script_name?call=criteria&action=reset\" TARGET=Criteria> reset list</a><br>\n";

	foreach $character_id (sort keys %criteria_list) {
		$state_id = $criteria_list{$character_id};

		$character_name = &get_character_name($character_id);
		$state_name = &get_state_name($character_id, $state_id);

		print "<a href=\"$script_location$script_name?call=criteria&character_name=$character_name_no_spaces&state_id=$state_id&state_name=$state_name_no_spaces&character_id=$character_id&action=delete\">delete</a>";
		print " $character_name : <b><i>$state_name</i></b><br>\n";

	}
}

sub items {
	print header;
#### following 4 lines added (workaround for bug in msie 3.0) by A. Findling
#
	print "<HTML>\n";
	print "<HEAD>\n";
	print "</HEAD>\n";
	print "<BODY>\n";
#
####

	print "<b>Items</b><br>";

	#read the criteria list from the cookie
	%criteria_list = cookie('criteria');
	
	$criteria_count = 0;
	foreach (sort keys %criteria_list) {
		$criteria_count++;
	
		$state_id = $criteria_list{$_};
		$character_id = $_;

		$query = "SELECT ".$mdb_resource_name."_DESCR.IID FROM ".$mdb_resource_name."_DESCR WHERE ".$mdb_resource_name."_DESCR.CS = '$state_id' AND ".$mdb_resource_name."_DESCR.CID = $character_id";

		$error = $Data->Sql($query);
		if($error) {
			print "SQL error $error\n";
			exit(1);
		}

		@criteria_ids = "";

		while($Data->FetchRow()) {
			@ref = $Data->Data;
			push (@criteria_ids, @ref[0]);
		}

		if($criteria_count == 1) {
			@union = @criteria_ids;
		}

		@new_union = "";
		foreach $item1 (@union) {
			foreach $item2 (@criteria_ids) {
				if($item1 == $item2) {
					push(@new_union, $item1);
				}
			} 
		}
		@union = @new_union;

		#print "items matching all criteria: @union<p>";

	}
	if($criteria_count == 0) {
		print "No criteria selected\n";
#### following 2 lines added (workaround for bug in msie 3.0) by A. Findling
#
		print "</BODY>\n";
		print "</HTML>\n";
#
####

		exit;
	}

	$ids = "";
	$ids_count = 0;
	foreach (@union) {

		if(!$_) {
			next;
		}
		elsif($ids_count == 0) {
			$ids = "$_";
		}

		else {
			$ids = "$ids, $_";
		}
		$ids_count++;
	}

	$query = "SELECT ItemName FROM ".$mdb_resource_name."_ITEM WHERE IID IN ($ids)";
	#print $query;

	$error = $Data->Sql($query);
	if($error) {
#### following line and 2 remarks added by A. Findling (
#
		print "No taxa remain\n";
#		print "SQL error $error\n";
#		exit(1);
#
####
	}
	@item_names = "";
	$item_names_count = 0;
	while($Data->FetchRow()) {
		$item_names_count++;
		@ref = $Data->Data;
		push (@item_names, @ref[0]);
	}
	print "($item_names_count matches)<br>";
	foreach $item_name(@item_names) {
		if($item_name) {
			print "$item_name<br>";
		}
	}
#### following 2 lines added (workaround for bug in msie 3.0) by A. Findling
#
	print "</BODY>\n";
	print "</HTML>\n";
#
####
}


sub images {
	print header;
	print "<b>Associated Images</b><br>";
	$image = "Acer.gif";
	print "<img src=\"$image_directory$image\">";

}


sub frame {
	print header;

#### following if-statement added by A. Findling
#
      if ($char_groups{$mdb_resource_name}==1) {
	print <<EOF;
	<html>
	<head>
	<title>$title{$mdb_resource_name}</title>
	</head>

	<frameset rows="10%, 30%, 30%, 30%">
		<frame src="$script_location$script_name?call=title" name="Title">
		<frameset cols="40%, *"> 
			<frame src="$script_location$script_name?call=character_groups" name="Character_groups">
			<frame src="$script_location$script_name?call=characters" name="Character">
		</frameset>
		<frameset cols="40%, *"> 
			<frame src="/cgi-bin/$script_name?call=states" name="State">
			<frame src="/cgi-bin/$script_name?call=blank" name="Criteria">
		</frameset>
		<frameset cols="40%, *"> 
			<frame src="/cgi-bin/$script_name?call=blank" name="Items">
			<frame src="/cgi-bin/$script_name?call=blank" name="Images">
		</frameset>
	</frameset>
	<noframes>

	<body bgcolor="#ffffff">

	to view this page, your browser must support
	frames.  <a 
	href="http://home.netscape.com/comprod/mirror/index.html">download</a> 
	netscape navigator 2.0 or later for frames support. 

	</body>

	</noframes>
EOF
	;
      }
      else {
	print <<EOF;
	<html>
	<head>
	<title>$title{$mdb_resource_name}</title>
	</head>

	<frameset rows="10%, 50%, 40%">
		<frame src="$script_location$script_name?call=title" name="Title">
		<frameset cols="60%, *"> 
			<frame src="$script_location$script_name?call=characters" name="Character">
			<frame src="$script_location$script_name?call=states" name="State">
		</frameset>
		<frameset cols="60%, *"> 
			<frame src="$script_location$script_name?call=blank" name="Criteria">
			<frame src="$script_location$script_name?call=blank" name="Items">
		</frameset>
	</frameset>

	<noframes>

	<body bgcolor="#ffffff">

	to view this page, your browser must support
	frames.  <a 
	href="http://home.netscape.com/comprod/mirror/index.html">download</a> 
	netscape navigator 2.0 or later for frames support. 

	</body>

	</noframes>
EOF
	;
      }
#
#### end of added if-statement

	print $query->end_html;
}

sub get_data {
	local($q) = @_;
	$error = $Data->Sql("$q");
	if($error) {
		print "SQL error $error\n";
		exit(1);
	}
	while($Data->FetchRow()) {
		(@r) = $Data->Data;
		push @t, [@r];
	}
	return t;
}

sub get_character_name {
	local($id) = @_;

	$query = "SELECT ".$mdb_resource_name."_CHAR.CharName FROM ".$mdb_resource_name."_CHAR WHERE ".$mdb_resource_name."_CHAR.CID = $id";

	$error = $Data->Sql("$query");
	if($error) {
		print "SQL error $error\n";
		exit(1);
	}
	$Data->FetchRow();

	local(@row) = $Data->Data;

	local($name) = @row[0];
	return $name;
}

sub get_state_name {
	local($cid, $sid) = @_;

	$query = "SELECT ".$mdb_resource_name."_CS.CharStateName FROM ".$mdb_resource_name."_CS WHERE ".$mdb_resource_name."_CS.CS = '$sid' AND ".$mdb_resource_name."_CS.CID = $cid ";

	$error = $Data->Sql("$query");
	if($error) {
		print "SQL error $error\n";
		exit(1);
	}
	$Data->FetchRow();

	local(@row) = $Data->Data;

	local($name) = @row[0];
	return $name;
}

