#!/usr/local/bin/perl
# The genanc.cgi script is used to display the ancestor data for an individual
use strict;
use warnings;
#Useful for testing: Perl error messages, plus your die statements, will get
#sent to the browser. Otherwise you will just see "Internal Server Error".
use CGI::Carp qw/fatalsToBrowser/;
use CGI qw(param);
my $old_stdout = select(STDOUT);
$| = 1;
select($old_stdout);
my $old_stderr = select(STDERR);
$| = 1;
select($old_stderr);
my $arg="";
my $key="";
my $iscgi=0;
my $check=0;
my $nogen=0;
my $debug="";
my $modfile="ancmodel.html";
my $htmlfile="genanc.html";
my $debugfile="genanc.debug";
my $htmlhead="<!DOCTYPE html>";
my $cgihead="Content-type: text\/html";
my $line;
my $cntr;
my $numfams;
my $famcin;
my $fnamein;
my $preffamin;
my $scolorin;
my $hkeyin;
my $wkeyin;
my $numchildkey;
my $i;
my $pfamlink="";
my $hindname="";
my $indfile;
my $famfile;
my $namfile;
my @lineargs;
my %rin;
my %famrin;
my %namrin;
my %indfamsnum;
my %indfamc;
my %indfams;
my %sexcolor;
my %fullnameplus;
my %preffamkey;
my %childkeynum;
my %husbkey;
my %wifekey;
my %childkey;
my $anclsave;
my $loopcntr;
my $loopmax;
# The sequence of called subroutines is:
# Getopts
# Getdatafiles
# Checkdata
# Printpage
# Getfamily *
# Printancline
# PrintHTML
# PrintHTML
# * = subroutine called recursively
if (exists($ARGV[0])) {
Getopts();
if ($debug eq "") { $debug=" "; }
if ($debug ne " ") {
open (DOUT,">$debugfile") or die "Can't open $debugfile: $!";
}
} else {
$iscgi=1;
$arg=param("ind");
$arg=~s/[^a-zA-Z0-9@]//g;
}
Getdatafiles();
if ($check == 1) { Checkdata(); }
if (exists($rin{$arg})) {
$pfamlink="href=\"..\/FAM$preffamkey{$arg}.html\"";
$hindname=$fullnameplus{$arg};
} else {
# arg is missing
$arg="@@";
}
Printpage();
exit;
# <key> <numfams> <famcin> <fams> ...
sub Getdatafiles {
$indfile="../indfile";
open (IND,"<$indfile") or die "Can't open $indfile: $!";
Dprint("1","Reading $indfile ...\n");
$cntr=0;
while (<IND>) {
s/\r[\n]*/\n/gm; # get rid of carriage returns, we only want line feeds
chomp;
$line=$_;
$cntr=$cntr+1;
Dprint("1","$cntr: $line\n");
$key="";
$numfams=0;
$famcin="";
@lineargs = split(/\s/,$line);
if (defined $lineargs[0]) { $key=$lineargs[0]; }
if (defined $lineargs[1]) { $numfams=$lineargs[1]; }
if (defined $lineargs[2]) { $famcin=$lineargs[2]; }
Dprint("1","key: $key\n");
Dprint("1","numfams: $numfams\n");
Dprint("1","famcin: $famcin\n");
if ($key ne "") {
$rin{$key}=$key;
$indfamsnum{$key}=$numfams;
$indfamc{$key,1}=$famcin; # Only use first FAMC record
if ($numfams > 0) {
$i=0;
while ($i < $numfams) {
$i=$i+1;
$indfams{$key,$i}="";
if (defined $lineargs[$i+2]) { $indfams{$key,$i}=$lineargs[$i+2]; }
}
}
}
}
close IND;
$loopmax=$cntr * 2;
# <key> <preffamin> <scolorin> <fnamein>
$namfile="../namfile";
open (NAM,"<$namfile") or die "Can't open $namfile: $!";
Dprint("2","Reading $namfile ...\n");
$cntr=0;
while (<NAM>) {
s/\r[\n]*/\n/gm; # get rid of carriage returns, we only want line feeds
chomp;
$line=$_;
$cntr=$cntr+1;
Dprint("2","$cntr: $line\n");
$key="";
$preffamin="";
$scolorin="";
$fnamein="";
@lineargs = split(/\s/,$line,4);
if (defined $lineargs[0]) { $key=$lineargs[0]; }
if (defined $lineargs[1]) { $preffamin=$lineargs[1]; }
if (defined $lineargs[2]) { $scolorin=$lineargs[2]; }
if (defined $lineargs[3]) { $fnamein=$lineargs[3]; }
Dprint("2","key: $key\n");
Dprint("2","fnamein: $fnamein\n");
if ($key ne "") {
$namrin{$key}=$key;
$preffamkey{$key}=$preffamin;
$sexcolor{$key}=$scolorin;
$fullnameplus{$key}=$fnamein;
}
}
close NAM;
# <key> <numchildkey> <hkeyin> <wkeyin> <childkey> ...
$famfile="../famfile";
open (FAM,"<$famfile") or die "Can't open $famfile: $!";
Dprint("3","Reading $famfile ...\n");
$cntr=0;
while (<FAM>) {
s/\r[\n]*/\n/gm; # get rid of carriage returns, we only want line feeds
chomp;
$line=$_;
$cntr=$cntr+1;
Dprint("3","$cntr: $line\n");
$key="";
$numchildkey=0;
$hkeyin="";
$wkeyin="";
@lineargs = split(/\s/,$line);
if (defined $lineargs[0]) { $key=$lineargs[0]; }
if (defined $lineargs[1]) { $numchildkey=$lineargs[1]; }
if (defined $lineargs[2]) { $hkeyin=$lineargs[2]; }
if (defined $lineargs[3]) { $wkeyin=$lineargs[3]; }
Dprint("3","key: $key\n");
Dprint("3","numchildkey: $numchildkey\n");
if ($key ne "") {
$famrin{$key}=$key;
$childkeynum{$key}=$numchildkey;
$husbkey{$key}=$hkeyin;
$wifekey{$key}=$wkeyin;
if ($numchildkey > 0) {
$i=0;
while ($i < $numchildkey) {
$i=$i+1;
$childkey{$key,$i}="";
if (defined $lineargs[$i+3]) { $childkey{$key,$i}=$lineargs[$i+3]; }
}
}
}
}
close FAM;
}
sub Checkdata {
Dprint("C","Checking IND data ...\n");
foreach $key (keys %rin) {
if (exists($famrin{$indfamc{$key,1}})) {
Dprint("K","IND $key: Found FAMC record $indfamc{$key,1}\n");
} else {
if ($indfamc{$key,1} ne "@@") {
Dprint("C","IND $key: Cannot find FAMC record $indfamc{$key,1}\n");
}
}
if ($indfamsnum{$key} > 0) {
$i=0;
while ($i < $indfamsnum{$key}) {
$i=$i+1;
if (exists($famrin{$indfams{$key,$i}})) {
Dprint("K","IND $key: Found FAMS record $indfams{$key,$i}\n");
} else {
Dprint("C","IND $key: Cannot find FAMS record $indfams{$key,$i}\n");
}
}
}
if (exists($fullnameplus{$key})) {
Dprint("K","IND $key: Found fullnameplus: $fullnameplus{$key}\n");
} else {
Dprint("C","IND $key: Cannot find fullnameplus\n");
}
}
Dprint("C","Checking NAM data ...\n");
foreach $key (keys %namrin) {
if (exists($preffamkey{$key})) {
Dprint("K","NAM $key: Found preffamkey: $preffamkey{$key}\n");
} else {
Dprint("C","NAM $key: Cannot find preffamkey\n");
}
if (exists($sexcolor{$key})) {
Dprint("K","NAM $key: Found sexcolor: $sexcolor{$key}\n");
} else {
Dprint("C","NAM $key: Cannot find sexcolor\n");
}
if (exists($fullnameplus{$key})) {
Dprint("K","NAM $key: Found fullnameplus: $fullnameplus{$key}\n");
} else {
Dprint("C","NAM $key: Cannot find fullnameplus\n");
}
}
Dprint("C","Checking FAM data ...\n");
foreach $key (keys %famrin) {
if (exists($rin{$husbkey{$key}})) {
Dprint("K","FAM $key: Found IND record for husband $husbkey{$key}\n");
} else {
if ($husbkey{$key} ne "@@") {
Dprint("C","FAM $key: Cannot find IND record for husband $husbkey{$key}\n");
}
}
if (exists($rin{$wifekey{$key}})) {
Dprint("K","FAM $key: Found IND record for wife $wifekey{$key}\n");
} else {
if ($wifekey{$key} ne "@@") {
Dprint("C","FAM $key: Cannot find IND record for wife $wifekey{$key}\n");
}
}
if ($childkeynum{$key} > 0) {
$i=0;
while ($i < $childkeynum{$key}) {
$i=$i+1;
if (exists($rin{$childkey{$key,$i}})) {
Dprint("K","FAM $key: Found IND record for child $childkey{$key,$i}\n");
} else {
Dprint("C","FAM $key: Cannot find IND record for child $childkey{$key,$i}\n");
}
}
}
}
}
sub Printpage {
if (($nogen == 0) && ($iscgi == 0)) {
open (HTML,">$htmlfile") or die "Can't open $htmlfile: $!";
Dprint("G","Generating $htmlfile ...\n");
} else {
Dprint("G","Generating CGI HTML output ...\n");
}
open(MOD,"<$modfile") or die "Can't open $modfile: $!";
Dprint("G","Reading $modfile ...\n");
$cntr=0;
while (<MOD>) {
s/\r[\n]*/\n/gm; # get rid of carriage returns, we only want line feeds
chomp;
$line=$_;
$cntr=$cntr+1;
Dprint("g","$cntr: $line\n");
if ($line =~ /^<!DOCTYPE html>/) {
if ($iscgi == 1) {
$line=$cgihead;
}
PrintHTML("$line\n\n");
Dprint("G","Print header: $line\n");
} elsif ($line =~ /^.+xXx/) {
Dprint("G","Got xXx at line $cntr: $line\n");
if ($line =~ /^.+xANCLINEx/) {
$line =~ s/<!-- xXxANCLINEx -->//;
$anclsave=$line;
Dprint("G","Ancestor model line: $anclsave\n");
# Print all the lines in the ancestor table
$loopcntr=0;
Getfamily($arg,0,"");
Dprint("L","Getfamily loop count: $loopcntr\n");
} else {
# Modify line and then write it
$line =~ s/xXxRINx/$rin{$key}/;
$line =~ s/xXxFAMLINKx/$pfamlink/;
$line =~ s/xXxINDEXLINKx/href=\"..\/IDXSurname.html\"/;
$line =~ s/xXxFULLNAMEx/$hindname/;
PrintHTML("$line\n");
Dprint("G","Modified model line: $line\n");
}
} else {
# If not inside ancestor table just write line
PrintHTML("$line\n");
Dprint("G","Copy model line: $line\n");
}
}
close MOD;
if (($nogen == 0) && ($iscgi == 0)) {
close HTML;
}
}
sub Getfamily {
my $fikey=$_[0];
my $flev=$_[1];
my $indent=$_[2];
my $fx;
my $fpkey;
my $fscolor;
my $ftext;
$loopcntr=$loopcntr+1;
Dprint("l","loopcntr=$loopcntr, fikey=$fikey\n");
if ($loopcntr > $loopmax) {
PrintHTML("<br>Getfamily loopcntr exceeded $loopmax<br>");
PrintHTML("Inconsistent or invalid GED file, aborting<br>") ;
} else {
$flev=$flev+1;
my $pindent=$indent;
$indent=$indent . "::::::";
# Check to see if we can find this individual
if (exists($rin{$fikey})) {
$fpkey=$preffamkey{$fikey};
$fscolor=$sexcolor{$fikey};
$ftext=$pindent . "$flev-$fullnameplus{$fikey}";
Printancline($fscolor,$fpkey,$ftext);
Dprint("F","$ftext\n");
Dprint("S","$fikey $fullnameplus{$fikey}\n");
my $fi;
my $ffkey;
my $fskey;
my $fcnum;
my $fj;
my $fckey;
$ffkey=$indfamc{$fikey,1};
# Check to see if we can find this family
if (exists($famrin{$ffkey})) {
$fskey=$husbkey{$ffkey};
if ($fskey ne "@@") {
Getfamily($fskey,$flev,$indent);
}
$fskey=$wifekey{$ffkey};
if ($fskey ne "@@") {
Getfamily($fskey,$flev,$indent);
}
} else {
# Cannot find this family
$fx=0;
}
} else {
# Cannot find this individual
$fx=0;
}
}
}
sub Printancline {
my $dscolor=$_[0];
my $dpkey=$_[1];
my $dtext=$_[2];
my $dlink="href=\"..\/FAM$dpkey.html\"";
# Model line has been saved in anclsave
$line=$anclsave;
$line =~ s/xXxCOLORx/$dscolor/;
$line =~ s/xXxANCLINKx/$dlink/;
$line =~ s/xXxANCTEXTx/$dtext/;
$line =~ s/:/ /g;
PrintHTML("$line\n");
Dprint("G","Modified ancestor table line: $line\n");
}
sub PrintHTML {
my $htmldata=$_[0];
if ($nogen == 0) {
if ($iscgi == 0) {
print HTML "$htmldata";
} else {
print "$htmldata";
}
}
}
sub Getopts {
if ($#ARGV >= 0) {
my $i=0;
while ($i <= $#ARGV) {
if ($ARGV[$i] eq "-help") {
Help();
++$i;
} elsif ($ARGV[$i] eq "-nogen") {
$nogen=1;
++$i;
} elsif ($ARGV[$i] eq "-check") {
$check=1;
++$i;
} elsif (($i+1) <= $#ARGV) {
if ($ARGV[$i] eq "-d") {
# enable debug mode
$debug = $ARGV[++$i];
++$i;
} else {
Usage();
}
} else {
if ($arg eq "") {
$arg=$ARGV[$i];
print "Not running CGI, argument is: $arg\n";
++$i;
} else {
Usage();
}
}
}
}
}
# Debug print
sub Dprint {
my $dlev=$_[0];
my $dline=$_[1];
# See if $dlev is any of the characters in $debug
if (($debug eq "all") || ($debug =~ m/$dlev/)) {
print "$dline";
print DOUT "$dline";
}
}
sub Usage {
die "Usage: $0 [-help] [-test] [-nogen] [-d <debuglevel>] <arg>\n";
}
sub Help {
print "Usage: $0 [-help] [-check] [-nogen] [-d <debuglevel>] <arg>\n";
print "-help = Display this help information\n";
print "-check = Check input files for validity\n";
print "-nogen = Suppress creating output HTML data\n";
print "-d <debuglevel> = Enable printout for various debug levels\n";
print "<arg> = input argument\n";
exit;
}