ossp-pkg/mct/mct.cgi
1.1
#!/e/epaperwork/sw/bin/perl
##
## OSSP mct - Multiple Choice Test Engine
## Copyright (c) 2002 Ralf S. Engelschall <rse@engelschall.com>
## Copyright (c) 2002 The OSSP Project <http://www.ossp.org/>
## Copyright (c) 2002 Cable & Wireless Deutschland <http://www.cw.com/de/>
##
## This file is part of OSSP mct, a multiple choice test engine
## which can be found at http://www.ossp.org/pkg/tool/mct/.
##
## Permission to use, copy, modify, and distribute this software for
## any purpose with or without fee is hereby granted, provided that
## the above copyright notice and this permission notice appear in all
## copies.
##
## THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESSED OR IMPLIED
## WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
## MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
## IN NO EVENT SHALL THE AUTHORS AND COPYRIGHT HOLDERS AND THEIR
## CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
## SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
## LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
## USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
## ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
## OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT
## OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
## SUCH DAMAGE.
##
## mct.cgi: multiple choice test CGI engine (language: Perl)
##
# requirements
require 5.006;
use IO; # standard in Perl 5.6
use POSIX; # standard in Perl 5.6
use CGI; # standard in Perl 5.6
#use Mail::Sendmail; # standard in OpenPKG's Perl, else: CPAN!
# program configuration
my $MY = {
PROG_NAME => 'OSSP mct',
PROG_VERS => '1.0.0',
PROG_DESC => 'Multiple Choice Test Engine',
PROG_HOME => 'http://www.ossp.org/pkg/tool/mct/',
MAIL_FROM => 'mct@epaperwork.org',
MAIL_HOST => 'mail.epaperwork.org',
TEMPLATE => "<html>\n<head>\n\@HEAD\@\n</head>\n<body>\n\@BODY\@\n</body></html>"
};
# switch to unbuffered output
$|++;
# establish CGI object
my $CGI = new CGI;
# generate an HTTP response
sub http_response {
my ($head, $body) = @_;
# fill in template page
my $response = $MY->{TEMPLATE};
$response =~ s|\@HEAD\@|$head|sg;
$response =~ s|\@BODY\@|$body|sg;
# prepend with HTTP header
$response = $CGI->header(
-type => 'text/html',
-expires => 'now',
'-Content-length' => length($response)
) . $response;
return $response;
}
# activate a general error handler
$SIG{__DIE__} = sub {
my ($err) = @_;
$err =~ s|at\s+\S+\s+line\s+(\d+)|(line $1)|s;
$err =~ s|\n|<br>\n|sg;
print STDOUT &http_response(
"<title>ePaperwork :: Multiple Choice Test: ERROR</title>",
"<h1>ePaperwork :: Multiple Choice Test: ERROR</h1>\n" .
"<pre>$err</pre>\n"
);
exit(0);
};
# convert Sugar-style markup text to HTML text
sub sug2html {
my ($text) = @_;
# escape HTML special characters
$text =~ s|&|&|sg;
$text =~ s|<|<|sg;
$text =~ s|>|>|sg;
# expand Sugar markup
$text =~ s/\|\|(.+?)\|\|/<tt>$1<\/tt>/sg;
$text =~ s|//(.+?)//|<i>$1</i>|sg;
$text =~ s|\*\*(.+?)\*\*|<b>$1</b>|sg;
$text =~ s|->(.+?)::(.+?)<-|<a href="$2" target="mct-extern">$1</a>|sg;
$text =~ s|->(.+?)<-|<a href="$1" target="mct-extern">$1</a>|sg;
return $text;
}
# read and parse MCT specification
sub readmct {
my ($name) = @_;
# read MCT specification
my $fh = new IO::File "<$name"
|| die "unable to open MCT specification \"$name\"";
my $mct = '';
$mct .= $_ while (defined($_ = $fh->getline()));
$fh->close();
# provide line continuation feature
$mct =~ s|\s*\\\s*\n\s*| |sg;
# parse MCT specification
my $MCT = {
'HEADER' => {},
'RESULT' => [],
'QUESTION' => []
};
$mct =~ s|^(.+?\n)\n(.+)$|&parse_header($1), &parse_body($2), ''|sge;
# parse header lines
sub parse_header {
my ($mct) = @_;
while ($mct =~ s|^([A-Za-z][A-Za-z0-9-]*):\s*(.*?)\n||s) {
if (not defined($MCT->{HEADER}->{uc($1)})) {
$MCT->{HEADER}->{uc($1)} = $2;
}
else {
$MCT->{HEADER}->{uc($1)} .= $2;
}
}
}
# parse body blocks
sub parse_body {
my ($mct) = @_;
$mct = "\n" . $mct . "\n";
$mct =~ s|\n\?\?\s+(.+?)\n(.+?\n)(?=\n)|&parse_question($1, $2), ''|sge;
$mct =~ s|\n==\s+(.+?)\n(.+?\n)(?=\n)|&parse_result($1, $2), ''|sge;
}
# parse a single question block
sub parse_question {
my ($title, $mct) = @_;
my $e = {
'TITLE' => $title,
'HINT' => '',
'CHOICES' => []
};
foreach my $line (split(/\n/, $mct)) {
if ($line =~ m/^((?:!!))\s+(.+)$/s) {
$e->{HINT} = $2;
}
elsif ($line =~ m/^((?:--|\+\+))\s+(.+)$/s) {
my $c = { 'TYPE' => $1, 'TEXT' => $2 };
push(@{$e->{CHOICES}}, $c);
}
}
push(@{$MCT->{QUESTION}}, $e);
}
# parse a single result block
sub parse_result {
my ($title, $mct) = @_;
my $e = {
'TITLE' => $title,
'CHOICES' => []
};
foreach my $line (split(/\n/, $mct)) {
if ($line =~ m/^((?:--))\s+(\d+)-(\d+)\s+(.+)$/s) {
my $c = {
'TYPE' => $1,
'RANGE' => [$2, $3],
'TEXT' => $4 };
push(@{$e->{CHOICES}}, $c);
}
}
push(@{$MCT->{RESULT}}, $e);
}
return $MCT;
}
# deterministically permutate an array
sub permute {
my ($k, @a) = @_;
my @b = ();
$k = ($k * ($#a+1)) / 9;
$k = 1 if ($k < 1);
$k = ($k % ($#a+1));
$k = 1 if ($k < 1);
my $i = $k/2;
while ($#a > -1) {
for (my $j = 0; $j < ($#a+1); $j++) {
my $x = shift(@a);
if (($i % $k) == 0) {
push(@b, $x);
}
else {
push(@a, $x);
}
$i++;
}
$k-- if ($k > 1);
}
return @b;
}
# adjust CGI environment to make sure that self-referencing
# URLs go again through the direct URL of the MCT file!!
$ENV{SCRIPT_NAME} = $ENV{PATH_INFO};
delete $ENV{REQUEST_URI};
# fetch CGI parameters
my $name = $CGI->path_translated();
my $form = $CGI->param('form') || '';
my $perm = $CGI->param('perm') || '';
my $hint = $CGI->param('hint') || '';
my $note = $CGI->param('note') || '';
my $serial = $CGI->param('serial') || '';
# sanity checks on CGI parameters
if ($name !~ m|\.mct$|) {
die "MCT specification \"$name\": invalid path name";
}
if (not -f $name) {
die "MCT specification \"$name\": file not found";
}
if ($perm ne '' and $perm !~ m/^[1-9]$/) {
die "Invalid \"perm\" parameter value \"$perm\"";
}
if ($hint ne '' and $hint !~ m/^[01]$/) {
die "Invalid \"hint\" parameter value \"$hint\"";
}
if ($note ne '' and $note !~ m/^[01]$/) {
die "Invalid \"note\" parameter value \"$note\"";
}
if ($serial ne '' and $serial !~ m/^\d+$/) {
die "Invalid \"serial\" parameter value \"$serial\"";
}
# read MCT specification
my $MCT = &readmct($name);
# XXX
# optionally read HTML page template
my $template = $name;
$template =~ s|\.mct$|.html|s;
my $fh = new IO::File "<$template" || die;
$MY->{TEMPLATE} = '';
$MY->{TEMPLATE} .= $_ while (<$fh>);
$fh->close();
# make sure the serial numbers match
if ($serial ne '') {
if ($serial ne $MCT->{HEADER}->{SERIAL}) {
die "Sorry, serial in request (#$serial) does not match current MCT serial (#".$MCT->{HEADER}->{SERIAL}.")";
}
}
$serial = $MCT->{HEADER}->{SERIAL};
# calculate query summary
my $summary = '';
sub summarynum {
my ($num) = @_;
return $num if ($num < 10);
return "{$num}";
}
my $nq = 0;
foreach my $q (@{$MCT->{QUESTION}}) {
$summary .= "," if ($summary ne '');
$summary .= &summarynum($nq);
$question = $CGI->param("q$nq");
my $nc = 0;
foreach my $c (@{$q->{CHOICES}}) {
my $choice = ($CGI->param("q$nq.c$nc") || ($question eq "c$nc"));
if ($choice) {
$summary .= &summarynum($nc);
}
$nc++;
}
$nq++;
}
# support Submit button
if ($form eq 'Send Notes') {
my $body = '';
$body .= "Dear author of the Multiple Choice Test \"".$MCT->{HEADER}->{NAME}."\",\n" .
"my current choice (".$CGI->url(-full => 1)."?choice=$summary)\n" .
"resulted in the following annotation notes for you.\n" .
"\n";
$nq = 0;
foreach my $q (@{$MCT->{QUESTION}}) {
my $an = ($CGI->param("q${nq}.an") || "");
if ($an ne '') {
$body .= "Question:\n" .
"| ".$q->{TITLE}."\n";
$an =~ s/^/| /mg;
$body .= "Note:\n".$an;
$body .= "\n\n";
}
$CGI->param("q${nq}.an", "");
$nq++;
}
my %mailcfg = (
'To' => $MCT->{HEADER}->{"REPLY-TO"},
'From' => $MY->{MAIL_FROM},
'Subject' => "Notes on MCT \"".$MCT->{HEADER}->{NAME}."\"",
'Message' => $body,
'smtp' => $MY->{MAIL_HOST}
);
sendmail(%mailcfg) or die $Mail::Sendmail::error;
$CGI->param('note', 0);
$note = 0;
$form = " Rate! ";
}
# support Mail button
if ($form eq 'Mail') {
sub urlescape {
my ($text) = @_;
$text =~ s|([ \t&+?:/=\n\r])|sprintf("%%%02x", ord($1))|sge;
return $text;
}
my $subject = &urlescape("Result in MCT \"".$MCT->{HEADER}->{NAME}."\"");
my $body = &urlescape("Result: ".$CGI->url(-full => 1)."?choice=$summary");
print STDOUT $CGI->redirect(-uri => "mailto:".$MCT->{HEADER}->{"REPLY-TO"}."?subject=$subject&body=$body", -type => "text/plain");
exit(0);
}
# support Restart button by redirecting via GET
if ($form eq 'Restart') {
print STDOUT $CGI->redirect(-uri => $CGI->url(-full => 1), -type => "text/html");
exit(0);
}
# support Note button
if ($form eq 'Show Notes') {
$CGI->param('note', 1);
$note = 1;
}
elsif ($form eq 'Hide Notes') {
$CGI->param('note', 0);
$note = 0;
}
# support Hint button
if ($form eq 'Show Hints') {
$CGI->param('hint', 1);
$hint = 1;
}
elsif ($form eq 'Hide Hints') {
$CGI->param('hint', 0);
$hint = 0;
}
# calculate new permution index
if ($perm eq '') {
$perm = int((rand 8) + 1);;
$CGI->param('perm', $perm);
}
# support Bookmark button
if ($form eq 'Bookmark') {
# redirect to bookmark URL
# XXX print STDOUT $CGI->redirect($CGI->url(-full => 1)."?name=$name&perm=$perm&choice=$summary");
print STDOUT $CGI->redirect(-uri => $CGI->url(-full => 1)."?serial=$serial&perm=$perm&choice=$summary", -type => "text/plain");
exit(0);
}
if ($CGI->param('choice') ne '') {
# import choice from bookmark URL
my $choice = $CGI->param('choice');
sub nextnum {
my ($str) = @_;
my $num = '';
if ($str =~ m|^\{(\d+)\}(.*)$|s) {
($num, $str) = ($1, $2);
}
elsif ($str =~ m|^(\d)(.*)$|s) {
($num, $str) = ($1, $2);
}
elsif ($str =~ m|^.(.*)$|s) {
$str = $1;
}
return ($num, $str);
}
foreach $str (split(/,/, $choice)) {
my ($nq, $str) = &nextnum($str);
if ($nq ne '') {
if (defined($MCT->{QUESTION}->[$nq])) {
$q = $MCT->{QUESTION}->[$nq];
my $multichoice = 0;
foreach my $c (@{$q->{CHOICES}}) {
if ($c->{TYPE} eq '++') {
$multichoice++;
}
}
$multichoice = 0 if ($multichoice <= 1);
if ($multichoice) {
my $nc;
while ($str ne '') {
($nc, $str) = &nextnum($str);
$CGI->param("q$nq.c$nc", "1");
}
}
else {
my ($nc, $str) = &nextnum($str);
$CGI->param("q$nq", "c$nc");
}
}
}
}
$form = " Rate! ";
}
# start generating the web page
my $head = '';
my $body = '';
$head .= "<title>ePaperwork :: Multiple Choice Test: ".
$MCT->{HEADER}->{TITLE}."</title>";
# import CSS
sub addcss {
my ($file) = @_;
$head .= "<style type=\"text/css\"><!--\n";
my $fh = new IO::File "<$file" || die;
$head .= $_ while (<$fh>);
$fh->close();
$head .= "--></style>\n";
}
my $css = $name;
$css =~ s|\.mct$|.css|s;
if (-f "$css") {
&addcss("$css");
}
if (-f "mct.css") {
&addcss("mct.css");
}
$body .= "<table width=100% cellspacing=0 cellpadding=1 border=0>";
$body .= "<tr><td colspan=2 class=mct-border>";
# XXX $body .= $CGI->startform(-method => "POST", -action => $CGI->url(-full => 1)."?name=$name");
$body .= $CGI->startform(-method => "POST", -action => $CGI->url(-full => 1));
#$body .= $CGI->hidden(-name => 'name', -default => [$name]);
$body .= $CGI->hidden(-name => 'perm', -default => [$perm]);
$body .= $CGI->hidden(-name => 'hint', -default => [$hint]);
$body .= $CGI->hidden(-name => 'note', -default => [$note]);
$body .= $CGI->hidden(-name => 'serial', -default => [$serial]);
$body .= "<table width=100% cellspacing=0 cellpadding=4 border=0>";
$body .= "<tr><td colspan=2 class=\"mct-header\">\n";
$body .= "<blockquote>\n";
$body .= &sug2html($MCT->{HEADER}->{TITLE});
$body .= "</blockquote>\n";
$body .= "</td></tr>";
# determine whether to enable cheat mode
my $cheat = 0;
if ($MCT->{HEADER}->{PASSWORD} ne '') {
$nq = 0;
foreach my $q (@{$MCT->{QUESTION}}) {
my $an = ($CGI->param("q${nq}.an") || "");
if (index($an, $MCT->{HEADER}->{PASSWORD}) > -1) {
$cheat = 1;
last;
}
$nq++;
}
}
my $r_questions = 0;
my $r_score = 0;
$nq = 0;
foreach my $q (@{$MCT->{QUESTION}}) {
$r_questions++;
my $col0 = ($nq % 2);
$body .= "<tr>\n";
$body .= "<td width=40% valign=top class=mct-qt$col0>" .
"<span class=\"mct-qt\">".&sug2html($q->{TITLE})."</span>";
my $multichoice = 0;
foreach my $c (@{$q->{CHOICES}}) {
if ($c->{TYPE} eq '++') {
$multichoice++;
}
}
if ($multichoice <= 1) {
$multichoice = 0;
}
if ($multichoice) {
$body .= "<br>($multichoice answers expected)";
}
if ($hint) {
if ($q->{HINT} ne '') {
$body .= "<br><span class=\"mct-hint\">Hint: ".&sug2html($q->{HINT})."</span>\n";
}
}
if ($note) {
$body .= "<br>" .
$CGI->textarea(-name => "q${nq}.an",
-default => ($CGI->param("q${nq}.an") || ""),
-rows => 3, -columns => "30%");
}
else {
$body .= $CGI->hidden(-name => "q${nq}.an", -default => [($CGI->param("q${nq}.an") || "")]);
}
$body .= "<p></td>\n";
$body .= "<td width=60% valign=top class=mct-qt$col0>" .
"<span class=\"mct-qc\">\n";
$body .= "<table width=100% cellspacing=0 cellpadding=0 border=0>\n";
my $nc = 0;
my $q_choices = 0;
my $q_score = 0;
my $q_ok = 0;
my @cells = ();
foreach my $c (@{$q->{CHOICES}}) {
$q_choices++;
my $choice = $CGI->param("q$nq.c$nc");
if (not $multichoice) {
$choice = $CGI->param("q$nq");
if ($choice eq "c$nc") {
$choice = 1;
}
else {
$choice = 0;
}
}
my $class = '';
if ($choice) {
if ($c->{TYPE} eq '++') {
$class = "OK";
$q_score++;
}
else {
$class = "BAD";
$q_score--;
}
}
else {
if ($c->{TYPE} eq '++') {
$class = "CHEAT" if ($form ne '' && $cheat);
}
}
if ($c->{TYPE} eq '++') {
$q_ok++;
}
my $cell = '';
if ($multichoice) {
$cell .= "<input ".($choice ? "checked " : "").
"type=\"checkbox\" name=\"q$nq.c$nc\" value=\"1\">";
}
else {
$cell .= "<input ".($choice ? "checked " : "").
"type=\"radio\" name=\"q$nq\" value=\"c$nc\">";
}
$cell .= " ".&sug2html($c->{TEXT})."<br>\n";
my $c = {
'CLASS' => $class,
'HTML' => $cell,
'LENGTH' => length($c->{TEXT})
};
push(@cells, $c);
$nc++;
}
@cells = &permute($perm, @cells);
my $maxlen = 0;
foreach my $cell (@cells) {
if ($maxlen < $cell->{LENGTH}) {
$maxlen = $cell->{LENGTH};
}
}
my $cols = 1;
$cols = 2 if ($maxlen < 30);
$cols = 3 if ($maxlen < 10);
$cols = 4 if ($maxlen < 5);
my $rows = sprintf("%d", (($#cells+1) + ($cols - 1)) / $cols);
for (my $i = 0; $i < $rows; $i++) {
$body .= "<tr>\n";
for (my $j = 0; $j < $cols; $j++) {
my $cell = ($cells[$i+($j*$rows)] || { 'CLASS' => '', 'HTML' => ' '});
my $class = $cell->{CLASS};
if ($class eq '' or $class eq 'OK') {
my $col1 = ($i % 2);
$class = "$col0$col1";
}
$body .= "<td class=mct-qc$class>";
$body .= $cell->{HTML};
$body .= "</td>";
}
$body .= "</tr>\n";
}
$q_score = 0 if ($q_score < 0);
my $q_score = sprintf("%d", (($q_score / $q_ok) * 100));
$r_score += $q_score;
$body .= "</table>\n";
$body .= "</span><p></td>\n";
$body .= "</tr>\n";
$nq++;
}
$body .= "</table>\n";
my $result = sprintf("%d", ($r_score / $r_questions));
$body .= "</td></tr>";
$body .= "<tr>";
$body .= "<td align=left class=\"mct-button\">";
if ($form ne '') {
if ($note) {
$body .= "<span class=\"mct-button-switchnotes\">";
$body .= $CGI->submit(-name => 'form', -value => "Hide Notes") . "\n";
$body .= "</span>";
$body .= "<span class=\"mct-button-sendnotes\">";
$body .= $CGI->submit(-name => 'form', -value => "Send Notes") . "\n";
$body .= "</span>";
}
else {
$body .= "<span class=\"mct-button-switchnotes\">";
$body .= $CGI->submit(-name => 'form', -value => "Show Notes") . "\n";
$body .= "</span>";
}
if ($hint) {
$body .= "<span class=\"mct-button-hints\">";
$body .= $CGI->submit(-name => 'form', -value => "Hide Hints") . "\n";
$body .= "</span>";
}
else {
$body .= "<span class=\"mct-button-hints\">";
$body .= $CGI->submit(-name => 'form', -value => "Show Hints") . "\n";
$body .= "</span>";
}
$body .= "<span class=\"mct-button-bookmark\">";
$body .= $CGI->submit(-name => 'form', -value => "Bookmark") . "\n";
$body .= "</span>";
$body .= "<span class=\"mct-button-mail\">" .
$CGI->submit(-name => 'form', -value => "Mail") .
"</span>\n";
}
$body .= ' ';
$body .= "</td>";
$body .= "<td align=right class=\"mct-button\">";
if ($form ne '') {
$body .= "<span class=\"mct-button-restart\">" .
$CGI->submit(-name => 'form', -value => "Restart") .
"</span>\n";
}
$body .= "<span class=\"mct-button-undo\">" .
$CGI->reset(-value => "Undo") .
"</span>\n";
$body .= "<b><span class=\"mct-button-rate\">" . $CGI->submit(-name => 'form', -value => " Rate! ") . "</span></b>\n";
#$body .= " ";
$body .= $CGI->endform;
$body .= "</td>";
$body .= "</tr>";
if ($form ne '') {
# display results
$body .= "<tr>";
$body .= "<td colspan=2 align=left class=\"mct-result\">";
$body .= "<p><blockquote>";
$body .= "You have achieved <span class=\"mct-result-percent\">${result}%</span> success in this multiple choice test.\n";
foreach my $r (@{$MCT->{RESULT}}) {
$body .= $r->{TITLE} . " ";
foreach my $c (@{$r->{CHOICES}}) {
if ($c->{RANGE}->[0] <= $result and $result <= $c->{RANGE}->[1]) {
$body .= &sug2html($c->{TEXT});
last;
}
}
$body .= "\n";
}
$body .= "<br><br></blockquote>";
$body .= "</td></tr>";
}
$body .= "<tr>";
$body .= "<td colspan=2 align=center class=\"mct-footer\">";
$body .= "<a href=\"".$MY->{PROG_HOME}."\">".$MY->{PROG_NAME}."</a> ".
$MY->{PROG_VERS}." - ".$MY->{PROG_DESC}."<br>\n";
$body .= "</td>";
$body .= "</tr>";
$body .= "</table>\n";
$body .= "\n";
print STDOUT &http_response($head, $body);
exit(0);
