#!/e/epaperwork/sw/bin/perl ## ## OSSP mct - Multiple Choice Test Engine ## Copyright (c) 2002 Ralf S. Engelschall ## Copyright (c) 2002 The OSSP Project ## Copyright (c) 2002 Cable & Wireless Deutschland ## ## 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 => "\n\n\@HEAD\@\n\n\n\@BODY\@\n" }; # 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|
\n|sg; print STDOUT &http_response( "ePaperwork :: Multiple Choice Test: ERROR", "

ePaperwork :: Multiple Choice Test: ERROR

\n" . "

$err

\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/\|\|(.+?)\|\|/$1<\/tt>/sg; $text =~ s|//(.+?)//|$1|sg; $text =~ s|\*\*(.+?)\*\*|$1|sg; $text =~ s|->(.+?)::(.+?)<-|$1|sg; $text =~ s|->(.+?)<-|$1|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 .= "ePaperwork :: Multiple Choice Test: ". $MCT->{HEADER}->{TITLE}.""; # import CSS sub addcss { my ($file) = @_; $head .= "\n"; } my $css = $name; $css =~ s|\.mct$|.css|s; if (-f "$css") { &addcss("$css"); } if (-f "mct.css") { &addcss("mct.css"); } $body .= ""; $body .= ""; $body .= ""; $body .= ""; $body .= ""; $body .= ""; if ($form ne '') { # display results $body .= ""; $body .= ""; } $body .= ""; $body .= ""; $body .= ""; $body .= ""; # 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 .= ""; $body .= ""; # 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 .= "\n"; $body .= "\n"; $body .= "\n"; $body .= "\n"; $nq++; } $body .= "\n"; $body .= "\n"; $body .= &sug2html($MCT->{HEADER}->{TITLE}); $body .= "\n"; $body .= " " . "".&sug2html($q->{TITLE}).""; my $multichoice = 0; foreach my $c (@{$q->{CHOICES}}) { if ($c->{TYPE} eq '++') { $multichoice++; } } if ($multichoice <= 1) { $multichoice = 0; } if ($multichoice) { $body .= " ($multichoice answers expected)"; } if ($hint) { if ($q->{HINT} ne '') { $body .= " Hint: ".&sug2html($q->{HINT})."\n"; } } if ($note) { $body .= " " . $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 .= " " . "\n"; $body .= "\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 .= ""; } else { $cell .= ""; } $cell .= " ".&sug2html($c->{TEXT})." \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 .= "\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 .= ""; } $body .= "\n"; } $q_score = 0 if ($q_score < 0); my $q_score = sprintf("%d", (($q_score / $q_ok) * 100)); $r_score += $q_score; $body .= ""; $body .= $cell->{HTML}; $body .= "\n"; $body .= "\n"; my $result = sprintf("%d", ($r_score / $r_questions)); $body .= " "; if ($form ne '') { if ($note) { $body .= ""; $body .= $CGI->submit(-name => 'form', -value => "Hide Notes") . "\n"; $body .= ""; $body .= ""; $body .= $CGI->submit(-name => 'form', -value => "Send Notes") . "\n"; $body .= ""; } else { $body .= ""; $body .= $CGI->submit(-name => 'form', -value => "Show Notes") . "\n"; $body .= ""; } if ($hint) { $body .= ""; $body .= $CGI->submit(-name => 'form', -value => "Hide Hints") . "\n"; $body .= ""; } else { $body .= ""; $body .= $CGI->submit(-name => 'form', -value => "Show Hints") . "\n"; $body .= ""; } $body .= ""; $body .= $CGI->submit(-name => 'form', -value => "Bookmark") . "\n"; $body .= ""; $body .= "" . $CGI->submit(-name => 'form', -value => "Mail") . "\n"; } $body .= ' '; $body .= " "; if ($form ne '') { $body .= "" . $CGI->submit(-name => 'form', -value => "Restart") . "\n"; } $body .= "" . $CGI->reset(-value => "Undo") . "\n"; $body .= "" . $CGI->submit(-name => 'form', -value => " Rate! ") . "\n"; #$body .= " "; $body .= $CGI->endform; $body .= " "; $body .= " "; $body .= "You have achieved ${result}% 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 .= " "; $body .= " "; $body .= "{PROG_HOME}."\">".$MY->{PROG_NAME}." ". $MY->{PROG_VERS}." - ".$MY->{PROG_DESC}." \n"; $body .= "\n"; $body .= "\n"; print STDOUT &http_response($head, $body); exit(0);