Annotation of loncom/homework/lonproblem.pm, revision 1.3
1.1 albertel 1: # The LearningOnline Network with CAPA
2: # Problem Handler
3: #
1.2 harris41 4: # 12/15-01/21,01/24 Gerd Kortemeyer
1.1 albertel 5:
6: package Apache::lonproblem;
7:
8: use strict;
9: use HTML::TokeParser;
10: use Safe;
11: use Apache::File;
12:
13: # ================================================================ Main Handler
14:
15: sub handler {
1.3 ! albertel 16: my $r=shift;
! 17: my @parsecontents;
! 18: my $parsestring;
! 19: my $outstring;
! 20:
! 21: {
! 22: my $fh=Apache::File->new($r->filename);
! 23: @parsecontents=<$fh>;
! 24: }
! 25:
! 26: $parsestring=join('',@parsecontents);
! 27:
! 28: print "<form>";
! 29:
! 30: &xmlparse($r,$parsestring,'web');
! 31:
! 32: print "\n---------------\n";
! 33: print "<form>";
! 34: &xmlparse($r,$parsestring,'edit');
! 35: $outstring=xmlparse($parsestring,'modified');
! 36: print "\n---------------\n$outstring\n";
! 37: return 1; #change to ok
1.1 albertel 38: }
39:
1.2 harris41 40: # =============================================================================
1.1 albertel 41: # ============================================================= Parsing Routine
42: # Takes $parsestring and $target
1.2 harris41 43: # =============================================================================
1.1 albertel 44:
45: sub xmlparse {
1.3 ! albertel 46:
! 47: my ($r,$parsestring,$target) = @_;
! 48:
! 49: my $safeeval = new Safe 'Script';
! 50:
! 51: my $parsereval = new Safe 'Parser';
! 52:
! 53: my $parser=HTML::TokeParser->new(\$parsestring);
! 54:
! 55: my $outtext='';
! 56:
1.1 albertel 57: # ---------------------------------------------------------------- Handled tags
58:
1.3 ! albertel 59: my %toptoplevel = ( 'problem' => 'Problem',
! 60: 'entryform' => 'Entry Form',
! 61: 'survey' => 'Survey',
! 62: 'graded' => 'Manually Graded' );
! 63:
! 64:
1.2 harris41 65: # --------------------------------------------------------------- Toplevel Tags
1.1 albertel 66:
1.3 ! albertel 67: my %topleveltags = ( 'block' => 'Condition Block',
! 68: 'part' => 'Problem Part',
! 69: 'include' => 'Include Section',
! 70: 'answer' => 'Answerfield',
! 71: 'script' => 'Script',
! 72: 'outtext' => 'Text Block' );
1.2 harris41 73:
74: # ---------------------------------------------------------- Preregistered Tags
1.1 albertel 75:
1.3 ! albertel 76: my %includetags = ( 'scriptlib' => 'Script Library',
! 77: 'parserlib' => 'Parser Library' );
! 78: # -------------------------------------------------------------Answer type Tags
! 79:
! 80: my %answertags = ( 'capaanswer' => 'CAPA Standard Answers');
1.2 harris41 81:
82: # -------------------------------------------------------------------- All Tags
83:
1.1 albertel 84:
1.3 ! albertel 85: my %xmltags = ( %includetags, %topleveltags, %toptoplevel, %answertags );
! 86:
! 87: my $toplevel = '';
! 88: my $above = '';
! 89:
1.1 albertel 90: # --------------------------------------------------- Depth counter for editing
91:
1.3 ! albertel 92: my @depthcounter=();
! 93: my $depth=-1;
! 94: my $olddepth=-1;
1.1 albertel 95:
96: # ----------------------------------------------------------------------- Stack
97:
1.3 ! albertel 98: my @stack=('');
1.1 albertel 99:
100: # -------------------------------------------------------------- Init $saveeval
101:
1.3 ! albertel 102: &init_safeeval($safeeval);
1.1 albertel 103:
104: # ---------------------------------------------------------- Parse $parsestring
105:
1.3 ! albertel 106: my $token;
1.1 albertel 107:
1.3 ! albertel 108: while ($token=$parser->get_token) {n
1.2 harris41 109: # =============================================================================
1.3 ! albertel 110: if ($token->[0] eq 'S') {
1.2 harris41 111: # =================================================================== Start Tag
112: # --------------------------------------------------------------- Depth Counter
1.1 albertel 113: if (defined($xmltags{$token->[1]})) {
1.3 ! albertel 114: if ($depth<$olddepth-1) {
! 115: $#depthcounter--;
! 116: $olddepth=$depth;
! 117: }
! 118: $depth++;
! 119: $depthcounter[$depth]++;
! 120: if ($depthcounter[$depth]==1) {
! 121: $olddepth=$depth;
! 122: }
1.1 albertel 123: }
1.2 harris41 124: # -----------------------------------------------------------------------------
125:
126:
1.1 albertel 127: if ($target eq 'web') {
1.3 ! albertel 128: my $sub="start_$token->[1]";
! 129: {
! 130: no strict 'refs';
! 131: if (defined (&$sub)) {
! 132: &$sub($r,$token,$parser,$safeeval,\@stack);
! 133: } else {
! 134: $stack[$#stack].=$token->[4];
! 135: }
! 136: }
1.1 albertel 137: }
1.3 ! albertel 138:
1.1 albertel 139: if ($target eq 'edit') {
1.3 ! albertel 140: my $depthlabel=join('_',@depthcounter);
! 141: if (defined($xmltags{$token->[1]})) {
! 142: if (defined($topleveltags{$token->[1]})) {
! 143: &insertmenu($r,$xmltags{$token->[1]},
! 144: $depthlabel,\%topleveltags);
! 145: $toplevel=$token->[1];
! 146: } else {
! 147: if ($toplevel eq 'answer') {
! 148: &insertmenu($r,$xmltags{$token->[1]},
! 149: $depthlabel,\%answertags);
! 150: }
! 151: }
! 152: my $sub="start_edit_$token->[1]";
! 153: {
! 154: no strict 'refs';
! 155: if (defined (&$sub)) {
! 156: &$sub($r,$token,$parser,$xmltags{$token->[1]},
! 157: $depthlabel,$above,\%answertypes,\@stack);
! 158: }
! 159: }
! 160: } else {
! 161: $stack[$#stack].=$token->[4];
! 162: }
1.1 albertel 163: }
1.3 ! albertel 164:
1.1 albertel 165: if ($target eq 'modified') {
166: }
1.2 harris41 167:
168: # =============================================================================
1.3 ! albertel 169: } elsif ($token->[0] eq 'E') {
1.2 harris41 170: # ===================================================================== End Tag
171:
1.1 albertel 172: if ($target eq 'web') {
1.3 ! albertel 173: my $sub="end_$token->[1]";
! 174: {
! 175: no strict 'refs';
! 176: if (defined (&$sub)) {
! 177: &$sub($r,$token,$parser,$safeeval,\@stack);
! 178: } else {
! 179: $stack[$#stack].=$token->[2];
! 180: }
! 181: }
1.1 albertel 182: }
1.3 ! albertel 183:
1.1 albertel 184: if ($target eq 'edit') {
1.3 ! albertel 185: if (defined($xmltags{$token->[1]})) {
! 186: my $sub="end_edit_$token->[1]";
! 187: {
! 188: no strict 'refs';
! 189: if (defined (&$sub)) {
! 190: &$sub($r,$token,$above,\@stack);
! 191: }
! 192: }
! 193: }
1.1 albertel 194: }
1.3 ! albertel 195:
1.1 albertel 196: if ($target eq 'modified') {
197: }
1.2 harris41 198: # --------------------------------------------------------------- Depth Counter
1.1 albertel 199: if (defined($xmltags{$token->[1]})) { $depth--; }
1.2 harris41 200: # -----------------------------------------------------------------------------
201: # =============================================================================
1.3 ! albertel 202: } elsif ($token->[0] eq 'T') {
1.2 harris41 203: # ================================================================= Parsed Text
1.1 albertel 204: $stack[$#stack].=$token->[1];
1.3 ! albertel 205: }
! 206: }
1.1 albertel 207:
1.3 ! albertel 208: return $outtext;
1.1 albertel 209: }
210: # =============================================================================
211:
1.2 harris41 212: # --------------------------------------------------------------- Execute Token
1.1 albertel 213:
214:
215:
216: # ------------------------------------------------- Helper Routines for Editing
217:
218: sub rawprint {
1.3 ! albertel 219: my ($r,$data)=@_;
! 220: $r->print($data);
1.1 albertel 221: }
222:
223: sub insertmenu {
1.3 ! albertel 224: my ($r,$description,$depthlabel,$xmltagsref)=@_;
! 225: &rawprint($r,'<br><table bgcolor="#DDDD33" width="100%"><tr><td>');
! 226: &rawprint($r,"\n".'<select name="mod_menu_'.$depthlabel.'">'."\n");
! 227: &rawprint($r,'<option value="no_changes" selected>(no changes)</option>');
! 228: &rawprint($r,"\n".
! 229: '<option value="delete">Delete '.$description.
! 230: ' Below</option>');
! 231: my $key;
! 232: foreach $key (keys %$xmltagsref) {
! 233: &rawprint($r,"\n".
! 234: '<option value="insert_'.$key.'">Insert '.
! 235: $$xmltagsref{$key}.'</option>');
! 236: }
! 237: &rawprint($r,"\n".'</select></td></tr></table><br>'."\n");
1.1 albertel 238: }
1.2 harris41 239:
240: # =============================================================================
241: # ================================================ Routines for Safe Evaluation
242: # =============================================================================
243:
244: # -------------------------------------------- Initialize routines in $safeeval
245:
246: sub init_safeeval {
1.3 ! albertel 247: my $safeeval=shift;
! 248: my $initprg=<<'ENDINIT';
1.2 harris41 249:
250: # -------------------------------------------- Initializations inside $safeeval
251:
1.3 ! albertel 252: $e=25;
! 253: $c=20;
1.2 harris41 254:
1.3 ! albertel 255: ENDINIT
1.2 harris41 256: # ---------------------------------------------------------------- Execute that
1.3 ! albertel 257: $safeeval->reval($initprg);
1.2 harris41 258: }
259:
260: # ----------------------------------------------- Routines that use Safe Spaces
1.1 albertel 261:
262: sub printout {
1.3 ! albertel 263: my ($r,$data,$safespace)=@_;
! 264: $r->print($safespace->reval('return qq('.$data.');'));
1.1 albertel 265: }
266:
267: sub runfile {
1.3 ! albertel 268: my ($r,$filename,$safespace)=@_;
! 269: my $includefile;
! 270: if ($filename=~/^\//) {
! 271: $includefile=$filename;
! 272: } else {
! 273: $includefile=$r->dir_config('lonIncludes');
! 274: $includefile.='/'.$filename;
! 275: }
! 276: if (-e $includefile) {
! 277: $safespace->rdo($includefile);
! 278: }
1.1 albertel 279: }
280:
281: sub run {
1.3 ! albertel 282: my ($expression,$safespace)=@_;
! 283: $safespace->reval($expression);
1.1 albertel 284: }
285:
286: sub booleanexpr {
1.3 ! albertel 287: my ($expression,$safespace)=@_;
! 288: return $safespace->reval('return '.$expression.';');
1.1 albertel 289: }
290:
1.2 harris41 291:
292: # =============================================================================
293: # ================================================== Tag Handlers for Rendering
294: # =============================================================================
1.1 albertel 295:
296: sub start_block {
1.3 ! albertel 297: my ($r,$token,$parser,$safeeval,$stackref)=@_;
! 298: if (!booleanexpr($token->[2]{'condition'},$safeeval)) {
! 299: my $blockdepth=0;
! 300: my $nexttoken;
! 301: while ($nexttoken=$parser->get_tag()) {
! 302: if ($nexttoken->[0] eq 'block') { $blockdepth++ };
! 303: if ($nexttoken->[0] eq '/block') {
! 304: if ($blockdepth==0) {
! 305: return;
! 306: } else {
! 307: $blockdepth--;
! 308: }
1.1 albertel 309: }
1.3 ! albertel 310: }
! 311: }
! 312: return;
1.1 albertel 313: }
314:
315: sub start_script {
1.3 ! albertel 316: my ($r,$token,$parser,$safeeval,$stackref)=@_;
! 317: $stackref->[$#$stackref+1]='';
1.1 albertel 318: }
319:
320: sub end_script {
1.3 ! albertel 321: my ($r,$token,$parser,$safeeval,$stackref)=@_;
! 322: &run($stackref->[$#$stackref],$safeeval);
! 323: $#$stackref--;
1.1 albertel 324: }
325:
326: sub start_outtext {
1.3 ! albertel 327: my ($r,$token,$parser,$safeeval,$stackref)=@_;
! 328: $stackref->[$#$stackref+1]='';
1.1 albertel 329: }
330:
331: sub end_outtext {
1.3 ! albertel 332: my ($r,$token,$parser,$safeeval,$stackref)=@_;
! 333: &printout($r,$stackref->[$#$stackref],$safeeval);
! 334: $#$stackref--;
1.1 albertel 335: }
336:
337: sub start_inlinetext {
1.3 ! albertel 338: &start_outtext(@_);
1.1 albertel 339: }
340:
341: sub end_inlinetext {
1.3 ! albertel 342: &end_outtext(@_);
1.1 albertel 343: }
344:
1.2 harris41 345: sub start_scriptlib {
1.3 ! albertel 346: my ($r,$token,$parser,$safeeval,$stackref)=@_;
! 347: &runfile($r,$parser->get_text('/scriptlib'),$safeeval);
1.2 harris41 348: }
349:
350: sub start_parserlib {
1.3 ! albertel 351: my ($r,$token,$parser,$safeeval,$stackref)=@_;
! 352: &runfile($r,$parser->get_text('/parserlib'),$parsereval);
1.1 albertel 353: }
354:
1.2 harris41 355:
1.1 albertel 356: sub start_answer {
1.3 ! albertel 357: my ($r,$token,$parser,$safeeval,$stackref)=@_;
! 358: $stackref->[$#$stackref+1]='<answer>::'.
! 359: join(':',map{$_.':'.$token->[2]->{$_}} @{$token->[3]});
! 360: $stackref->[$#$stackref+1]='';
1.1 albertel 361: }
362:
363: sub end_answer {
1.3 ! albertel 364: my ($r,$token,$parser,$safeeval,$stackref)=@_;
! 365: my @itemtexts;
! 366: my @itemargs;
! 367: my $stackpointer=$#$stackref;
! 368: while (($stackref->[$stackpointer]!~'<answer>::') && ($stackpointer>0)) {
! 369: $stackpointer--;
! 370: }
! 371: my %answerargs=split(/:/,$stackref->[$stackpointer]);
1.1 albertel 372: }
373:
374: sub start_item {
1.3 ! albertel 375: my ($r,$token,$parser,$safeeval,$stackref)=@_;
! 376: $stackref->[$#$stackref+1]='<item>::'.
! 377: join(':',map{$_.':'.$token->[2]->{$_}} @{$token->[3]});
! 378: $stackref->[$#$stackref+1]='';
1.1 albertel 379: }
380:
381: sub end_item {}
382:
1.2 harris41 383: # =============================================================================
384: # ==================================================== Tag Handlers for Editing
385: # =============================================================================
1.1 albertel 386:
387: sub start_edit_outtext {
1.3 ! albertel 388: my ($r,$token,$parser,$description,$depthlabel,$above,$answertyperef,
! 389: $stackref)=@_;
! 390: &rawprint($r,"\n<h3>$description</h3>".
! 391: '<textarea rows="10" cols="80" name="data_'.$depthlabel.'">');
! 392: $stackref->[$#$stackref+1]='';
1.1 albertel 393: }
394:
395: sub end_edit_outtext {
1.3 ! albertel 396: my ($r,$token,$above,$stackref)=@_;
! 397: &rawprint($r,$stackref->[$#$stackref]."</textarea>\n");
! 398: $#$stackref--;
1.1 albertel 399: }
400:
401: sub start_edit_script {
1.3 ! albertel 402: &start_edit_outtext(@_);
1.1 albertel 403: }
404:
405: sub end_edit_script {
1.3 ! albertel 406: &end_edit_outtext(@_);
1.1 albertel 407: }
408:
409: sub start_edit_inlinetext {
1.3 ! albertel 410: &start_edit_outtext(@_);
1.1 albertel 411: }
412:
413: sub end_edit_inlinetext {
1.3 ! albertel 414: &end_edit_inlinetext(@_);
1.1 albertel 415: }
416:
417: sub start_edit_block {
1.3 ! albertel 418: my ($r,$token,$parser,$description,$depthlabel,$above,$answertyperef,
! 419: $stackref)=@_;
! 420: my $bgcolor=$depthlabel;
! 421: $bgcolor=~s/\_//g;
! 422: $bgcolor=substr(length($bgcolor),-1,1);
! 423: $bgcolor=~tr/1-5/A-E/;
! 424: $bgcolor=$bgcolor.'FFF'.$bgcolor.'A';
! 425: &rawprint($r,"\n".'<br><table border="2" cellpadding="10" bgcolor="#'.
! 426: $bgcolor.
! 427: '" width="100%"><tr><td><h3>'.$description.'</h3>');
1.1 albertel 428: }
429:
430: sub end_edit_block {
1.3 ! albertel 431: my ($r,$token,$above,$stackref)=@_;
! 432: &rawprint($r,"\n".'</td></tr></table><br>');
1.1 albertel 433: }
434:
435: sub start_edit_answer {
1.3 ! albertel 436: my ($r,$token,$parser,$description,$depthlabel,$above,$answertyperef,
! 437: $stackref)=@_;
! 438: start_edit_block(@_);
! 439: $above=$token->[2]{'type'};
! 440: &rawprint($r,"\n".'<select name="mod_type_'.$depthlabel.'">');
! 441: my $key;
! 442: foreach $key (keys %$answertyperef) {
! 443: &rawprint($r,"\n".'<option value="'.$key.'"');
! 444: if ($above eq $key) { &rawprint($r,' selected'); }
! 445: &rawprint($r,'>'.$$answertyperef{$key}.'</option>');
! 446: }
! 447: &rawprint($r,"\n".'</select>'."\n");
1.1 albertel 448: }
449:
450: sub end_edit_answer {
1.3 ! albertel 451: my ($r,$token,$above,$stackref)=@_;
! 452: end_edit_block(@_);
1.1 albertel 453: }
454:
455: sub start_edit_include {
1.3 ! albertel 456: start_edit_block(@_);
1.1 albertel 457: }
458:
459: sub end_edit_include {
1.3 ! albertel 460: end_edit_block(@_);
1.1 albertel 461: }
462:
463: sub start_edit_problem {
1.3 ! albertel 464: start_edit_block(@_);
1.1 albertel 465: }
466:
467: sub end_edit_problem {
1.3 ! albertel 468: end_edit_block(@_);
1.1 albertel 469: }
470:
471: 1;
472: __END__
1.3 ! albertel 473:
1.1 albertel 474:
475:
476:
477:
478:
479:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/back.gif){kind=icon}
Return to lonproblem.pm CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / loncom / homework