#!/usr/local/bin/perl
#-------------------------------------------------------#
# Simple query CGI
#           by Morikawa I. (morikawa@med.teikyo-u.ac.jp)
#            http://www.med.teikyo-u.ac.jp/~morikawa/sq/
#-------------------------------------------------------#
$VERSION = 0.131; # 98/09/04

$CONF_FILE = 'config.pl';		# name of configuration file


### DO NOT EDIT below, UNTIL you encounter 'YOU CAN EDIT' !

&cgi_header;
&load_conf;
if ($METHOD =~ /^G$/i  ||  $METHOD =~ /^GET$/i) {
    $METHOD = 'GET';
} else {
    $METHOD = 'POST';
}

$SCRIPT = $ENV{'SCRIPT_NAME'};
$SCRIPT =~ m#(/.*/)(.*)$#;
$SCRIPT_DIR = $1;
$SCRIPT_NAME = $2;

&cgi_receive;
&cgi_decode;
&get_arguments;
&load_raw_data;
&make_index if ($INDEX || $INDEX==0);
&header($TITLE);
&print_form;
if ($FORM{'mo'} eq 'q') {
    &decrease_array;
    &print_result();
}
&footer;

sub decrease_array 
{
    local($i,$a,$x,@lines2,@as,$passed_or,$passed_and);

    # indexed selection
    if ($arg_index && $arg_index ne '') {
	@lines2 = ();
	for ($i=0;$i<@lines;$i++) {
	    if (&read_cell($i,$INDEX) eq $arg_index) {
		push(@lines2,$lines[$i]);
	    }
	}
	@lines = @lines2;
    }

# substring matching
    if (@STRING_MATCH >0) {
	
	foreach $x (@STRING_MATCH) {
	    $a = $arg_match[$x];
	    if ($a && $a ne '') {
		$a =~ s/\s+\+\s+/\+/g; # erase spaces around '+'
		$a =~ s/\s+/ /g; # substitute multi-space to single-space
		@as = split(/ /,$a);
		@lines2 = ();
		for ($i=0;$i<@lines;$i++) {
		    $passed_or = undef;
		    foreach (@as) {
			@ax = split(/\+/,$_);
			$passed_and = 'true';
			foreach (@ax) {
			    if (&read_cell($i,$x) !~ /$_/i) {
				$passed_and = undef;
			    }
			}
			$passed_or = 'true' if ($passed_and);
		    }
		    push(@lines2,$lines[$i]) if ($passed_or);
		}
		@lines = @lines2;
	    }		
	}

    }
}

sub make_index {
	local($line,$i,$found);

	@index = ();
	$indexed = &read_cell_from_line($header_line,$INDEX);
	foreach $line (@lines) {
		$i = &read_cell_from_line($line,$INDEX);
		undef $found;
		foreach (@index) {
			if ($_ eq $i) {
				$found = 1;  last;
			}
		}
		push(@index,$i) unless ($found);
	}
}

sub load_raw_data {

	if ($NKF) {
	    open(FILE, "$NKF < $RAW_FILE|");
	} else {
	    open(FILE, "$RAW_FILE");
	}
	$header_line = <FILE>;
	@lines = <FILE>;
	close(FILE);
}

## 検索結果の TABLE 表示
sub print_array {
    local(@arg) = @_;
    local($x,$line);

    print "<TABLE $TABLE_OPTION>\n";
    
    print "<TR>\n";
    foreach (@arg) {
	$x = &read_cell_from_line($header_line,$_);
	print "<TH>$x";
    }
    
    foreach $line (@lines) {
	print "<TR>\n";
	foreach (@arg) {
	    $x = &read_cell_from_line($line,$_);
	    if ($WRAP>=0 && $WRAP == $_) {
                $pre = $WRAP_PREFIX; $sup = $WRAP_SUFFIX;
		if ($WRAP_ITEM) {
		    $N = &read_cell_from_line($line,$WRAP_ITEM);
		    $pre =~ s/\$N/$N/g;
		    $sup =~ s/\$N/$N/g;
                }
                $x = $pre.$x.$sup;
	    }
	    print "<TD>$x";
	}
    }
    print "</TABLE>\n<HR>\n";
}



sub read_cell {
    local($nline,$n) = @_;

    split(/$SEP/,$lines[$nline]);
    return($_[$n]);
}


sub read_cell_from_line {
    local($line,$n) = @_;
    
    split(/$SEP/,$line);
    return($_[$n]);
}

sub load_conf {
    open(CONF,$CONF_FILE) || error("Can't read config file $CONF_FILE!");
    foreach (<CONF>) {
	eval;
    }
    close(CONF);
}

sub error {
    print @_;
    die @_;
}

sub cgi_header {
    print "Content-type: text/html\n\n";
}

sub cgi_receive {
    if ($ENV{'REQUEST_METHOD'} eq "POST") {
	read(STDIN, $incoming, $ENV{'CONTENT_LENGTH'});
    } else {
	$incoming = $ENV{'QUERY_STRING'};
    }
    $incoming =~ tr/+/ /;
    $incoming =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
}

sub cgi_decode {
    local($name,$value,@pairs,@parts);

    @pairs = split(/&/, $incoming);

    foreach (@pairs) {
	($name, $value) = split(/=/, $_);
	
#	$name  =~ tr/+/ /;
#	$value =~ tr/+/ /;
	
	#### Strip out semicolons unless for special character
	$value =~ s/;/$$/g;
	$value =~ s/&(\S{1,6})$$/&\1;/g;
	$value =~ s/$$/ /g;
	
	$value =~ s/\|/ /g;
	$value =~ s/^!/ /g; ## Allow exclamation points in sentences

	#### Skip generally blank fields
	next if ($value eq "");
	
	#### Allow for multiple values of a single name
	$FORM{$name} .= ", " if ($FORM{$name});

	$FORM{$name} .= $value;
    }
}

sub get_arguments
{
    $arg_index = $FORM{'id'};
    foreach $i (@STRING_MATCH) {
	$arg_match[$i] = $FORM{"m$i"};
    }
}

sub debug {
    foreach (keys %FORM) {
	print "$_ = $FORM{$_}<BR>";
    }
}

### DO NOT EDIT above !


### YOU CAN EDIT below to configure the appearance of the page.

## HTMLヘッダ
sub header {
    local($title) = @_;
    print "<HTML><HEAD><TITLE>$title</TITLE></HEAD>\n<BODY $BODY_OPTION>\n";
    print "<H1>$title</H1>\n";
}

## HTMLフッタ
sub footer {
    print "<ADDRESS>$ADDRESS</ADDRESS>\n";
    print "</BODY></HTML>\n";
}

## 入力フォームの表示
sub print_form {
    local($i,$x);

    print "<P>$PREFIX_PARA</P>" if ($PREFIX_PARA);

    print qq|<FORM METHOD="$METHOD" ACTION="$SCRIPT">\n|;

    if ($INDEX || $INDEX==0) {
	print qq|<P>$HEADER_INDEXMENU<BR>\n|;
	print qq|$indexed <SELECT NAME="id">\n|;
	print qq|<OPTION VALUE=""|;
	print qq| SELECTED| if (!$arg_index || $arg_index eq '');
	print qq|>$INDEX_ALL\n|;
	foreach (@index) {
	    print qq|<OPTION VALUE="$_"|;
	    print qq| SELECTED| if ($arg_index eq $_);
	    print qq|>$_\n|;
	}
	print qq|</SELECT></P>\n|;
    }

    if (@STRING_MATCH>0) {
	print qq|<P>$HEADER_SUBSTRING<BR>\n|;
	foreach $i (@STRING_MATCH) {
	    $x = &read_cell_from_line($header_line,$i);
	    print qq|$x <INPUT TYPE="text" NAME="m$i" VALUE="$arg_match[$i]"><BR>\n|;
	}
	print qq|</P>\n|;
    }

    print qq|<INPUT TYPE="submit" VALUE="$BUTTON_SUBMIT">|;
    print qq|<INPUT TYPE="reset" VALUE="$BUTTON_RESET">|;
    print qq|\n[<A HREF="$SCRIPT">$BUTTON_INIT</A>]\n|;
    print qq|<INPUT TYPE="hidden" NAME="mo" VALUE="q">|;
    
    print qq|</FORM>\n|;

    print "<P>$SUFFIX_PARA</P>" if ($SUFFIX_PARA);

    print qq|<div align=right>\n|;
    print qq|[<a href="$HELP_URL">$HELP_TEXT</a>]\n|;
    print qq|<a href="http://www.med.teikyo-u.ac.jp/~morikawa/sq/">Simple Query CGI</a> V.$VERSION\n|;
    print "</div>\n<hr>\n";
}

## 検索結果の表示
sub print_result {
    local($i,$x,$a);

    print "<H2>$HEADER_RESULT</H2>";
    
    # 検索条件の表示
    print "<P>";
    print "インデックス項目「$indexed」 == 「$arg_index」<BR>" if ($arg_index);
    if (@STRING_MATCH > 0) {
	foreach $i (@STRING_MATCH) {
	    $a = $arg_match[$i];
	    if ($a && $a ne '') {
		$x = &read_cell_from_line($header_line,$i);
		print "項目「$x」が文字列「$a」を含む<BR>";
	    }
	}
    }
    print "</P>";
    
    # 検索結果(TABLE)の表示
    &print_array(@DISPLAY);

    print "<HR>\n";

}

### sq.pl end.