#!/usr/bin/perl
# Make Perl language on server interpret the rest of this file.

# apidemo-2.cgi
# Perform these functions:
#	Acquire the values of the fields from an HTML form.
#	Assemble the values into a request to the PanLex API on the PanLex server.
#	Submit the request.
#	Get the response.
#	Reply with an HTML page.

# Encoding: Perl encodes output data (to the Web server and to database tables) into UTF-8 from
# character values. Thus, UTF-8 in a string, when output, would be incorrect. If UTF-8 data in a
# database table are to be retrieved and then output, they are first converted to character values.

use warnings 'FATAL', 'all';
# Make every warning fatal.

use strict;
# Require strict checking of variable references, symbolic references, and barewords.

use vars ('$i', '%in');
# Declare global variables.

use Encode 'decode_utf8', 'encode_utf8';
# Import:
#	a function to decode from UTF-8 to character values and thereby test form-data UTF-8
# 		validity;
#	a function to encode character values into UTF-8.

use LWP::UserAgent 'new', 'request';
# Import functions to create and operate a user agent.

use HTTP::Request 'new', 'header', 'content';
# Import functions to create and modify an HTTP request.

use utf8;
# Make Perl treat this script as encoded with UTF-8. The pragma “use encoding 'utf8'” conflicts
# with LWP::UserAgent, preventing it from sending requests containing non-ASCII bytes.

use Unicode::Normalize;
# Import functions to normalize Unicode strings.

binmode STDIN, ':utf8';
# Mark the layer of the standard input as UTF-8.

binmode STDOUT, ':utf8';
# Mark the layer of the standard output as UTF-8.

binmode STDERR, ':utf8';
# Mark the layer of the standard error as UTF-8.

&Init;
# Store initial values in %in.

my $headutil = (
	'<script type="text/javascript">' . "\n"
		. "var _gaq = _gaq || [];\n"
		. "_gaq.push(['_setAccount', 'UA-29495207-1']);\n"
		. "_gaq.push(['_trackPageview']);\n"
		. "(function() {\n"
		. "var ga = document.createElement('script'); ga.type = 'text/javascript'; ga.async = true;\n"
		. "ga.src = ('https:' == document.location.protocol ? 'https://ssl' : 'http://www') + '.google-analytics.com/ga.js';\n"
		. "var s = document.getElementsByTagName('script')[0]; s.parentNode.insertBefore(ga, s);\n"
		. "})();\n"
	. "</script>\n"
);
# Identify a script to be included in head elements of xhtml pages.

&In;
# Parse the submitted form data and store the data, normalized and in Unicode character values, in
# %in.

&Sv (&Proc);
# Process the submitted data and serve a response to the user agent.

############################ Subroutine definitions ########################

#### Box
# Return the argument in a box.
# Arguments:
#	0: text.

sub Box {

	return ('<table class="bp"><tr><td><h3>' . (&Hml ($_[0])) . "</h3></td></tr></table>\n\n");

}

#### Hml
# Convert the specified string to a tag-safe string, i.e. a string that may be sent to a browser
# unquoted and surrounded by tags.
# Arguments:
#	0: string.

sub Hml {

	my $ret = $_[0];
	# Identify the string.

	$ret =~ s/&/&amp;/g;
	# Replace any "&" with an "&amp;".

	$ret =~ s/"/&quot;/g;
	# Replace any quotation mark with "&quot;".

	$ret =~ s/</&lt;/g;
	# Replace any "<" with "&lt;".

	$ret =~ s/>/&gt;/g;
	# Replace any ">" with "&gt;".

	return $ret;
	# Return the tag-safe string.

}

#### In
# Read & parse form data.
# Precondition: Data are encoded with the multipart/form-data encoding type.

sub In {

	my ($i, $in, @in, @kv, $reqtype);

	if (exists $ENV{REQUEST_METHOD}) {
	# If there is a request method:

		if ($ENV{REQUEST_METHOD} eq 'POST') {
		# If the request is from a browser form:

			binmode STDIN;
			# Make Perl treat the parameter string as raw bytes instead of UTF-8.

			read STDIN, $in, $ENV{CONTENT_LENGTH};
			# Identify the parameter string.

			my $inu8;

			($in = $inu8) if (defined (eval {$inu8 = (&decode_utf8 ($in, 1))}));
			# If the parameter string is decodable from UTF-8 into Unicode character values, decode it.

			my $dlen = (index $in, "\r");
			# Identify its delimiter length.

			my $sep = ("\r\n" . (quotemeta (substr $in, 0, $dlen)));
			# Identify its expanded delimiter, i.e. its delimeter with any nonalphanumeric
			# characters escaped, prefixed with a return and newline.

			@in = (split /$sep/, (substr $in, $dlen));
			# Identify an array of the substrings.

			pop @in;
			# Delete the final substring ("--\r").

			my $pflen = ((index $in[0], '"') + 1);
			# Identify the length of each substring's constant prefix.

			foreach $i (@in) {
			# For each substring:

				$i = (substr $i, $pflen);
				# Identify its substring that begins with the key (and ends with the value).

				@kv = (split /".*?\r\n\r\n/s, $i, 2);
				# Identify the key and the value.

				($in{$kv[0]} = ((length $kv[1]) ? (&Nml ($kv[1])) : '')) if (length $kv[0]);
				# Store the normalized value of the key if the key is non-blank.

			}

		}

		elsif ($ENV{REQUEST_METHOD} eq 'GET') {
		# Otherwise, if the parameter values are appended to the URL:

			$in = $ENV{'QUERY_STRING'};
			# Identify the parameter string.

			if (length $in) {
			# If the parameter string has any length:

				@in = split(/&/, $in);
				# Identify the array of parameter assignments, '&'-delimited

				foreach $i (0 .. $#in) {
				# For each of them:

					$in[$i] =~ s/\+/ /g;
					# Convert each '+' to ' '

					@kv = split(/=/, $in[$i], 2);
					# Identify the key & value, delimited at the 1st '='

					if (length $kv[0]) {
					# If the key is non-blank:

						$kv[0] =~ s/%(..)/pack("C",hex($1))/ge;
						$kv[1] =~ s/%(..)/pack("C",hex($1))/ge;
						# Convert each %XX in the key or value from hex to alphanumeric.

						$in{$kv[0]} = ((length $kv[1]) ? (&Nml ($kv[1])) : '');
						# Store the key's normalized value, replacing any existing value it has.

					}

				}

			}

		}

		$in{ENV_REMOTE_ADDR} = $ENV{REMOTE_ADDR};
		# Store the remote host's IP address.

		$in{ENV_ACCEPT_LANGUAGE} = $ENV{HTTP_ACCEPT_LANGUAGE};
		# Store the remote host's language-preference message.

	}

}

#### Init
# Initialize the global variables.

sub Init {

	$in{svr} = 'http://if.panlex.org';
	# Store the interface server’s fully qualified host name.

	$in{dir} = '/cgi-bin/plxp-02.cgi';
	# Store the server’s API alias.

	$in{ldir} = '/var/www/demo';
	# Store the local server’s directory of parameter data.
	
	$in{urlroot} = '/demo';
	# Identify the relative URL root of the support files.

	$in{vr} = '02';
	# Store the version of the API to use.

	$in{rbre} = ('<\?xml version="1\.0" encoding="utf-8"\?><data><vr>' . $in{vr} . '</vr>');
	# Store a regular expression that matches the fixed beginning of each PanLex API response.

	$in{fatal} = "<body>\n\n<h1>?</h1>\n\n</body>\n\n";
	# Store a fatal error message that is linguistically quasi-independent.

}

#### LcVc
# Return the specified lc and vc as a variety identifier.
# Arguments:
#   0: ISO code.
#   1: variety code.

sub LcVc {

	return ($_[0] . '-' . (substr (('00' . $_[1]), -3)));
	# Return an identifier of the specified variety in the format "iso-000".

}

#### LvRow
# Return a table row containing a description of the specified language variety and a submission
# button.
# Arguments:
#	0: name of the submission button.
#	1: value provided by the button (e.g., the variety ID).
#	2: ISO code.
#	3: variety code.
#	4: variety label (tag-safe).
# Precondition: Arguments 1-4 are the lv, lc, vc, and tt of a variety.

sub LvRow {

	return (
		'<tr><th><button class="lcvc" type="submit" name="' . $_[0] . '" value="' . $_[1]
		. '">' . (&LcVc (@_[2, 3])) . "</button></th><td>$_[4]</td></tr>"
	);
	# Return a table row containing the specified lc-vc, as a submission button with the specified
	# name and value, and tt.

}

#### NB
# Return whether all the specified keys of %in exist and have defined non-blank values.
# Arguments:
#	0+: keys.

sub NB {

	foreach $i (@_) {
	# For each specified key:

		unless ((exists $in{$i}) && (defined $in{$i}) && (length $in{$i})) {
		# If it doesn’t exist or has an undefined or blank value:

			return '';
			# Return a false result.

		}

	}

	return 1;
	# Return a true value.

}

#### Nml
# Normalize the specified string, i.e. convert it to its normalization form C, then delete any
# characters with Other Unicode General Category properties, then replace any sequences of
# characters with Separator Unicode General Category properties with single spaces, then remove
# any leading and any trailing space, and then return the converted string.
# Arguments:
#	0: a string.

sub Nml {

	my $ret = (&NFC ($_[0]));
	# Identify the normalization form C (decomposition followed by canonical composition) of the
	# specified string.

	$ret =~ s/\p{C}+//g;
	# Delete any sequence of 1 or more characters in it with Other Unicode General Category
	# properties.

	$ret =~ s/\p{Z}+/ /g;
	# Replace any sequence of 1 or more characters in it with the Separator Unicode General
	# Category properties with a single space.

	if ((substr $ret, 0, 1) eq ' ') {
	# If it begins with a space:

		$ret = (substr $ret, 1);
		# Delete its first character.

	}

	if ((substr $ret, -1) eq ' ') {
	# If it ends with a space:

		$ret = (substr $ret, 0, -1);
		# Delete its last character.

	}

	return $ret;
	# Return the normalized string.

}

#### Proc
# Validate the submitted form data, process the required requests, and return the title and body
# of a response page to be sent to the user agent.

sub Proc {

	unless (&NB ('op', 'lg')) {
	# If no operation or no interface and source language variety was specified:

		return ('?[0]', $in{fatal});
		# Return a quasi-language-independent error result.

	}

	if (($in{op} < 0) || ($in{op} > 2)) {
	# If the operation is invalid:

		return ('?[1]', $in{fatal});
		# Return a quasi-language-independent error result.

	}

	my $parf = "$in{ldir}/$in{lg}.txt";
	# Identify the pathname of the file of parameter data for the source and interface language
	# variety.

	unless ((-r $parf)) {
	# If there is no readable file of parameter data for the language variety:

		return ('?[2]', $in{fatal});
		# Return a quasi-language-independent error result.

	}

	open PD, '<:encoding(utf8)', $parf;
	# Open the file of parameter data for reading.

	my @param = <PD>;
	# Identify a list of its parameter values.

	close PD;
	# Close it.

	chomp @param;
	# Delete their trailing newlines.

	$in{tail} = (
		'<p style="text-align: center">' . "\n\n"
		. ' <a href="http://validator.w3.org/check?uri=referer">' . "\n\n"
		. ' <img style="border: 0" src="' . $in{urlroot} . '/valid-xhtml11-blue.png" alt="'
		. $param[13] . '" ' . 'height="31"' . "\n\n" . ' width="88" /></a>' . "\n\n" . "</p>\n\n"
	);
	# Store the validation link for inclusion in pages defined by URLs.

	pop @param;
	# Delete the just-used value from the list.

	if ($in{op} == 0) {
	# If the operation is 0:

		return (&ProcTr0 (@param));
		# Process it.

	}

	elsif ($in{op} == 1) {
	# Otherwise, if the operation is 1:

		return (&ProcTr1 (@param));
		# Process it.

	}

	elsif ($in{op} == 2) {
	# Otherwise, if the operation is 2:

		return (&ProcTr2 (@param));
		# Process it.

	}

}

#### ProcTr0
# Return the title and body of a page containing a form for the submission of an expression in the
# selected language variety.
# Arguments used:
#	1: page title.
#	2: page heading.
#	3: value proposition.
#	4: expression prompt.
#	5: submission button text.

# Precondition: $in{op} and $in{lg} are valid.

sub ProcTr0 {

	my $body = (
		'<body onload="document.forms.fm0.et0.focus()">' . "\n\n<h1>$_[2]</h1>\n\n<h3>"
		. "$_[3]</h3>\n\n"
		. '<form id="fm0" action="/cgi-bin/apidemo-2.cgi" enctype="multipart/form-data" '
		. 'method="post">' . "\n\n"
		. '<p class="c"><input type="hidden" name="op" value="1" /></p>' . "\n\n"
		. '<p class="c"><input type="hidden" name="lg" value="' . $in{lg} . '" /></p>' . "\n\n"
		. '<table class="bp"><tr><td>' . "\n\n" . '<p class="c">' . "$_[4]</p>\n\n"
		. '<p class="c"><input name="et0" type="text" size="50" maxlength="80" ' . "/></p>\n\n"
		. '<p class="c"><input type="submit" value="' . $_[5] . '" /></p>' . "\n\n"
		. "</td></tr></table>\n\n"
		. "</form>\n\n$in{tail}\n\n</body>\n\n"
	);
	# Identify the body.

	return ($_[1], $body);
	# Return the title and body.

}

#### ProcTr1
# Return the title and body of a page responding to the specified source expression.
# Arguments used:
#	0: PanLex variety ID.
#	1: page title.
#	2: page heading.
#	3: value proposition.
#	4: expression-text field caption.
#	5: translation-request submission button text.
#	6: target-variety selection prompt.
#	7: empty-target-variety-set message.
#	8: missing-source-expression message.
#	9: label of link to PanLex indirect translations.

sub ProcTr1 {

	my $body;

	if (&NB ('et0')) {
	# If the expression text has a non-blank value:

		my $et0 = (&encode_utf8 ($in{et0}));
		# Identify the encoding of the expression text into UTF-8.

		my $rsp = (&Req ("<op>ex-0</op><lv>$_[0]</lv><et>$et0</et>"));
		# Submit a request for the ID of the specified expression and identify the PanLex response.

		warn "The response was $rsp\n";

		my @match;

		if (@match = (
			$rsp =~ m#^$in{rbre}<op>ex-0</op><lv>$_[0]</lv><et>$et0</et><ex>(\d+)</ex></data>$#
		)) {
		# If PanLex identified the expression:

			my $ex0 = $match[0];
			# Identify its PanLex ID.

			$rsp = (&Req ("<op>lv-1</op><ex>$ex0</ex>"));
			# Submit a request for a list of the language varieties of attested translations of the
			# expression and identify the PanLex response.

			if (@match = ($rsp =~ m#^$in{rbre}<op>lv-1</op><ex>$ex0</ex><lv>(.+)</lv></data>$#)) {
			# If it contained data on any varieties:

				my @lv = (split /<\/lv><lv>/, (&decode_utf8 ($match[0])));
				# Identify a sorted list of their descriptors, decoded from UTF-8 into Unicode
				# character values.

				my @lvtbl;

				foreach $i (@lv) {
				# For each descriptor, i.e. a pseudo-list of a variety’s lv, lc, vc, and (tag-safe)
				# tt:

					push @lvtbl, (&LvRow ('lv1', $i, (split ':', $i, 4)[1 .. 3]));
					# Append a table row with a submission button for the selection of the variety
					# to a list of table rows.

				}

				$body = (
					"<body>\n\n<h1>$_[2]</h1>\n\n<h3>$_[3]</h3>\n\n<h3>" . (&Box ($in{et0}))
					. "</h3>\n\n<h3>$_[6]</h3>\n\n<form id="
					. '"fm0" action="/cgi-bin/apidemo-2.cgi" enctype="multipart/form-data" '
					. 'method="post">' . "\n\n" . '<input type="hidden" name="op" value="2" />'
					. '<input type="hidden" name="lg" value="' . $in{lg} . '" />' . "\n\n"
					. '<input type="hidden" name="ex0" value="' . $ex0 . '" />' . "\n\n"
					. '<input type="hidden" name="et0" value="' . (&Hml ($in{et0})) . '" />'
					. "\n\n" . '<table class="bp">' . "\n\n" . (join "\n", @lvtbl)
					. "\n\n</table>\n\n"
					. '<p class="c"><a href="http://if.panlex.org/u?sr=exviz5&uslc=' . "'"
					. (substr $in{lg}, 0, 3)
					. "'&uslv=$_[0]&ex=$ex0&exn=100000&exnn=1&lv=$_[0]&sel=lv"
					. "&ser=tot&tt=$et0&ttsel=&trnviz=trtr" . '">' . $_[9]
					. "</a></p>\n\n</body>\n\n"
				);
				# Identify the body of the response page.

			}

			else {
			# Otherwise, i.e. if the PanLex response contains no variety data:

				$body = (
					'<body onload="document.forms.fm0.et0.focus()">'
					. "\n\n<h1>$_[2]</h1>\n\n</h3>\n\n<h3>$_[3]</h3>\n\n<h3>$_[7]</h3>\n\n"
					. '<form id="fm0" action="/cgi-bin/apidemo-2.cgi" enctype="multipart/form-data" '
					. 'method="post">' . "\n\n" . '<input type="hidden" name="op" value="1" />'
					. '<input type="hidden" name="lg" value="' . $in{lg} . '" />' . "\n\n"
					. '<table class="bp"><tr><td>' . "\n\n" . '<p class="c">' . "$_[4]</p>\n\n"
					. '<p class="c"><input name="et0" type="text" size="50" maxlength="80" '
					. "/></p>\n\n"
					. '<p class="c"><input type="submit" value="' . $_[5] . '" /></p>' . "\n\n"
					. "</td></tr></table>\n\n</body>\n\n"
				);
				# Identify the body of a failure response page.

			}

		}

		else {
		# Otherwise, i.e. if PanLex didn’t identify the expression:

			$body = (
				'<body onload="document.forms.fm0.et0.focus()">'
				. "\n\n<h1>$_[2]</h1>\n\n</h3>\n\n<h3>$_[3]</h3>\n\n<h3>$_[8]</h3>\n\n"
				. '<form id="fm0" action="/cgi-bin/apidemo-2.cgi" enctype="multipart/form-data" '
				. 'method="post">' . "\n\n" . '<input type="hidden" name="op" value="1" />'
				. '<input type="hidden" name="lg" value="' . $in{lg} . '" />' . "\n\n"
				. '<table class="bp"><tr><td>' . "\n\n" . '<p class="c">' . "$_[4]</p>\n\n"
				. '<p class="c"><input name="et0" type="text" size="50" maxlength="80" '
				. 'value="' . $in{et0} . '" /></p>' . "\n\n"
				. '<p class="c"><input type="submit" value="' . $_[5] . '" /></p>' . "\n\n"
				. "</td></tr></table>\n\n</body>\n\n"
			);
			# Identify the body of a failure response page.

		}

	}

	else {
	# Otherwise, i.e. if the expression text is blank:

		return (&ProcTr0 (@_));
		# Return the title and body of a page containing a form for the submission of an expression
		# in the selected language variety.

	}

	return ($_[1], $body);
	# Return the title and body of the response page.

}

#### ProcTr2
# Return the title and body of a response page listing the attested translations of the specified
# expression into the selected variety.
# Arguments used:
#	0: PanLex variety ID.
#	1: page title.
#	2: page heading.
#	3: value proposition.
#	10: translation-list heading.
#	11: new-source-expression link label.
#	12: fatal error message.

sub ProcTr2 {

	my $body;

	if (&NB ('et0', 'ex0', 'lv1')) {
	# If the expression ID, expression text, and ID of the target language variety have non-blank
	# values:

		my @lv1 = (split ':', $in{lv1}, 4);
		# Identify the lv, lc, vc, and tt of the target language variety.

		my $rsp = (&Req ("<op>tr-0</op><ex0>$in{ex0}</ex0><lv1>$lv1[0]</lv1>"));
		# Submit a request for the translations of the specified expression into the specified
		# variety.

		my (@match, @lvtbl);

		if (@match = (
			$rsp =~
			m#^$in{rbre}<op>tr-0</op><ex0>$in{ex0}</ex0><lv1>$lv1[0]</lv1><et1>(.+)</et1></data>$#
		)) {
		# If the PanLex response contains any translations:

			my @et1 = (split /<\/et1><et1>/, (&decode_utf8 ($match[0])));
			# Identify a sorted list of their texts, decoded from UTF-8 into Unicode character
			# values.

			foreach $i (@et1) {
			# For each text:

				push @lvtbl, "<tr><td>$i</td></tr>";
				# Append a table row containing it to a list of table rows.

			}

		}

		$body = (
			"<body>\n\n<h1>$_[2]</h1>\n\n<h3>$_[3]</h3>\n\n<h3>\n\n" . (&Box ($in{et0})) . "\n\n"
			. '<table class="bp"><tr><td>' . (&LcVc (@lv1[1, 2])) . '</td><td>' . $lv1[3]
			. '</td></tr></table>' . "\n\n$_[10]</h3>\n\n"
			. '<table class="bp">' . "\n\n" . (join "\n", @lvtbl) . "\n\n</table>\n\n"
			. '<h4><a href="/cgi-bin/apidemo-2.cgi?op=0&lg=' . $in{lg} . '">'
			. $_[11] . "</a></h4>\n\n</body>\n\n"
		);
		# Identify the body of the response page.

	}

	else {
	# Otherwise, i.e. if either required argument is blank:

		$body = ("<body>\n\n<h1>$_[1]</h1>\n\n<h3>$_[12]</h3>\n\n</body>\n\n");
		# Identify the body of a fatal-error response page.

	}

	return ($_[6], $body);
	# Return the title and body of the response page.

}

#### Req
# Create and send a request to the PanLex server and return the response.
# Arguments:
#   0: data after the “vr” element.
# Precondition: The argument is the UTF-8 encoding of normalized text.

sub Req {

	my $rsp = '';
	# Initialize the response as non-existent.

	warn "The request data after vr was $_[0]\n";

	if (length $_[0]) {
	# If there is any content:

		my $ua = (LWP::UserAgent->new);
		# Create and identify a user agent.

		my $rq = (HTTP::Request->new ('POST', "$in{svr}$in{dir}"));
		# Create and identify a generic request to the PanLex API server.

		$rq->header ('Content-Type', 'application/xml; charset=utf-8');
		# Add an XML content-type header to it.

		$rq->content (
			'<?xml version="1.0" encoding="utf-8"?>' . "<data><vr>$in{vr}</vr>$_[0]</data>"
		);
		# Add the content to it.

		$rsp = ($ua->simple_request ($rq));
		# Make the user agent submit the request and identify a text representation of the content
		# of the response from the PanLex server.

		return ($rsp->content);
		# Return the content of the response as UTF-8 bytes.

	}

}

#### Sv
# Send a response page to the client.
# Arguments:
#	0: title.
#	1: body.

sub Sv {

	print "Expires: 0\n";
	# Tell the server to tell the client not to cache the page.

	print "Content-type: text/html; charset=utf-8\n\n";
	# Tell the server to send the following output to the client.

	print
		'<?xml version="1.0" encoding="utf-8"?>', "\n",
		'<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN" ',
		'"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">', "\n\n",
		'<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="tr">', "\n\n",
		"<head>\n\n",
		'<meta http-equiv="content-type" content="text/html; charset=utf-8" />', "\n",
		'<meta http-equiv="cache-control" content="no-cache; no-store" />', "\n",
		'<meta http-equiv="pragma" content="no-cache" />', "\n",
		'<meta http-equiv="content-type" content="text/html; charset=utf-8" />', "\n",
		'<meta name="viewport" content="width=640" />', "\n",
		'<meta name="format-detection" content="telephone=no" />', "\n",
		'<link rel="stylesheet" type="text/css" href="', $in{urlroot},
		'/styles.css" title="styles" />', "\n",
		"<title>$_[0]</title>\n$headutil</head>\n\n$_[1]\n\n</html>\n"
	;
	# Tell the server to serve the page.

}

#### Xml
# Convert the specified string to an XML-tag-safe string, i.e. a string that may be sent to an
# XML file as parsed character data (PCDATA).
# Arguments:
#	0: string.

sub Xml {

	my $ret = $_[0];
	# Identify the string.

	$ret =~ s/&/&amp;/g;
	# Replace any "&" with an "&amp;".

	$ret =~ s/</&lt;/g;
	# Replace any "<" with "&lt;".

	return $ret;
	# Return the PCDATA string.

}
