Annotation of loncom/interface/lonspreadsheet.pm, revision 1.21
1.1 www 1: # The LearningOnline Network with CAPA
2: # Spreadsheet/Grades Display Handler
3: #
1.15 www 4: # 11/11,11/15,11/27,12/04,12/05,12/06,12/07,
1.20 www 5: # 12/08,12/09,12/11,12/12,12/15,12/16,12/18,12/19,12/30 Gerd Kortemeyer
1.1 www 6:
7: package Apache::lonspreadsheet;
8:
9: use strict;
10: use Safe;
1.3 www 11: use Safe::Hole;
1.1 www 12: use Opcode;
13: use Apache::lonnet;
1.7 www 14: use Apache::Constants qw(:common :http);
1.19 www 15: use GDBM_File;
1.3 www 16: use HTML::TokeParser;
17:
1.11 www 18: #
19: # These cache hashes need to be independent of user, resource and course
20: # (user and course are in the keys)
21: #
22: use vars qw(%spreadsheets %courserdatas %userrdatas);
23: #
24: # These global hashes are dependent on user, course and resource,
25: # and need to be initialized every time when a sheet is calculated
26: #
27: my %courseopt;
28: my %useropt;
29: my %parmhash;
30: my $csec;
31: my $uname;
32: my $udom;
33:
1.5 www 34: # =============================================================================
35: # ===================================== Implements an instance of a spreadsheet
1.4 www 36:
37: sub initsheet {
38: my $safeeval = new Safe;
39: my $safehole = new Safe::Hole;
40: $safeeval->permit("entereval");
41: $safeeval->permit(":base_math");
42: $safeeval->permit("sort");
43: $safeeval->deny(":base_io");
44: $safehole->wrap(\&Apache::lonnet::EXT,$safeeval,'&EXT');
45: my $code=<<'ENDDEFS';
46: # ---------------------------------------------------- Inside of the safe space
47:
1.3 www 48: #
49: # f: formulas
1.4 www 50: # t: intermediate format (variable references expanded)
51: # v: output values
1.6 www 52: # c: preloaded constants (A-column)
53: # rl: row label
1.3 www 54:
1.4 www 55: %v=();
56: %t=();
57: %f=();
1.6 www 58: %c=();
59: %rl=();
60:
61: $maxrow=0;
1.5 www 62: $sheettype='';
63: $filename='';
1.1 www 64:
65: sub mask {
66: my ($lower,$upper)=@_;
67:
1.7 www 68: $lower=~/([A-Za-z]|\*)(\d+|\*)/;
1.1 www 69: my $la=$1;
70: my $ld=$2;
71:
1.7 www 72: $upper=~/([A-Za-z]|\*)(\d+|\*)/;
1.1 www 73: my $ua=$1;
74: my $ud=$2;
75: my $alpha='';
76: my $num='';
77:
78: if (($la eq '*') || ($ua eq '*')) {
1.7 www 79: $alpha='[A-Za-z]';
1.1 www 80: } else {
1.7 www 81: if (($la=~/[A-Z]/) && ($ua=~/[A-Z]/) ||
82: ($la=~/[a-z]/) && ($ua=~/[a-z]/)) {
83: $alpha='['.$la.'-'.$ua.']';
84: } else {
85: $alpha='['.$la.'-Za-'.$ua.']';
86: }
1.1 www 87: }
88:
89: if (($ld eq '*') || ($ud eq '*')) {
90: $num='\d+';
91: } else {
92: if (length($ld)!=length($ud)) {
93: $num.='(';
94: map {
95: $num.='['.$_.'-9]';
96: } ($ld=~m/\d/g);
97: if (length($ud)-length($ld)>1) {
98: $num.='|\d{'.(length($ld)+1).','.(length($ud)-1).'}';
99: }
100: $num.='|';
101: map {
102: $num.='[0-'.$_.']';
103: } ($ud=~m/\d/g);
104: $num.=')';
105: } else {
106: my @lda=($ld=~m/\d/g);
107: my @uda=($ud=~m/\d/g);
1.7 www 108: my $i; $j=0; $notdone=1;
109: for ($i=0;($i<=$#lda)&&($notdone);$i++) {
1.1 www 110: if ($lda[$i]==$uda[$i]) {
111: $num.=$lda[$i];
112: $j=$i;
1.7 www 113: } else {
114: $notdone=0;
1.1 www 115: }
116: }
117: if ($j<$#lda-1) {
118: $num.='('.$lda[$j+1];
119: for ($i=$j+2;$i<=$#lda;$i++) {
120: $num.='['.$lda[$i].'-9]';
121: }
122: if ($uda[$j+1]-$lda[$j+1]>1) {
123: $num.='|['.($lda[$j+1]+1).'-'.($uda[$j+1]-1).']\d{'.
124: ($#lda-$j-1).'}';
125: }
126: $num.='|'.$uda[$j+1];
127: for ($i=$j+2;$i<=$#uda;$i++) {
128: $num.='[0-'.$uda[$i].']';
129: }
130: $num.=')';
131: } else {
1.7 www 132: if ($lda[$#lda]!=$uda[$#uda]) {
133: $num.='['.$lda[$#lda].'-'.$uda[$#uda].']';
134: }
1.1 www 135: }
136: }
137: }
1.4 www 138: return '^'.$alpha.$num."\$";
1.1 www 139: }
140:
141: sub NUM {
142: my $mask=mask(@_);
143: my $num=0;
144: map {
145: $num++;
146: } grep /$mask/,keys %v;
147: return $num;
148: }
149:
150: sub BIN {
151: my ($low,$high,$lower,$upper)=@_;
152: my $mask=mask($lower,$upper);
153: my $num=0;
154: map {
155: if (($v{$_}>=$low) && ($v{$_}<=$high)) {
156: $num++;
157: }
158: } grep /$mask/,keys %v;
159: return $num;
160: }
161:
162:
163: sub SUM {
164: my $mask=mask(@_);
165: my $sum=0;
166: map {
167: $sum+=$v{$_};
168: } grep /$mask/,keys %v;
169: return $sum;
170: }
171:
172: sub MEAN {
173: my $mask=mask(@_);
174: my $sum=0; my $num=0;
175: map {
176: $sum+=$v{$_};
177: $num++;
178: } grep /$mask/,keys %v;
179: if ($num) {
180: return $sum/$num;
181: } else {
182: return undef;
183: }
184: }
185:
186: sub STDDEV {
187: my $mask=mask(@_);
188: my $sum=0; my $num=0;
189: map {
190: $sum+=$v{$_};
191: $num++;
192: } grep /$mask/,keys %v;
193: unless ($num>1) { return undef; }
194: my $mean=$sum/$num;
195: $sum=0;
196: map {
197: $sum+=($v{$_}-$mean)**2;
198: } grep /$mask/,keys %v;
199: return sqrt($sum/($num-1));
200: }
201:
202: sub PROD {
203: my $mask=mask(@_);
204: my $prod=1;
205: map {
206: $prod*=$v{$_};
207: } grep /$mask/,keys %v;
208: return $prod;
209: }
210:
211: sub MAX {
212: my $mask=mask(@_);
213: my $max='-';
214: map {
215: unless ($max) { $max=$v{$_}; }
216: if (($v{$_}>$max) || ($max eq '-')) { $max=$v{$_}; }
217: } grep /$mask/,keys %v;
218: return $max;
219: }
220:
221: sub MIN {
222: my $mask=mask(@_);
223: my $min='-';
224: map {
225: unless ($max) { $max=$v{$_}; }
226: if (($v{$_}<$min) || ($min eq '-')) { $min=$v{$_}; }
227: } grep /$mask/,keys %v;
228: return $min;
229: }
230:
231: sub SUMMAX {
232: my ($num,$lower,$upper)=@_;
233: my $mask=mask($lower,$upper);
234: my @inside=();
235: map {
236: $inside[$#inside+1]=$v{$_};
237: } grep /$mask/,keys %v;
238: @inside=sort(@inside);
239: my $sum=0; my $i;
240: for ($i=$#inside;(($i>$#inside-$num) && ($i>=0));$i--) {
241: $sum+=$inside[$i];
242: }
243: return $sum;
244: }
245:
246: sub SUMMIN {
247: my ($num,$lower,$upper)=@_;
248: my $mask=mask($lower,$upper);
249: my @inside=();
250: map {
251: $inside[$#inside+1]=$v{$_};
252: } grep /$mask/,keys %v;
253: @inside=sort(@inside);
254: my $sum=0; my $i;
255: for ($i=0;(($i<$num) && ($i<=$#inside));$i++) {
256: $sum+=$inside[$i];
257: }
258: return $sum;
259: }
260:
261: sub sett {
262: %t=();
1.16 www 263: my $pattern='';
264: if ($sheettype eq 'assesscalc') {
265: $pattern='A';
266: } else {
267: $pattern='[A-Z]';
268: }
1.1 www 269: map {
1.20 www 270: if ($_=~/template\_(\w)/) {
271: my $col=$1;
272: unless ($col=~/^$pattern/) {
273: map {
274: if ($_=~/A(\d+)/) {
275: my $trow=$1;
276: if ($trow) {
277: my $lb=$col.$trow;
278: $t{$lb}=$f{'template_'.$col};
279: $t{$lb}=~s/\#/$trow/g;
280: $t{$lb}=~s/\.\.+/\,/g;
281: $t{$lb}=~s/(^|[^\"\'])([A-Za-z]\d+)/$1\$v\{\'$2\'\}/g;
282: }
283: }
284: } keys %f;
285: }
286: }
287: } keys %f;
288: map {
289: if (($f{$_}) && ($_!~/template\_/)) {
1.16 www 290: if ($_=~/^$pattern/) {
1.6 www 291: unless ($f{$_}=~/^\!/) {
292: $t{$_}=$c{$_};
293: }
294: } else {
295: $t{$_}=$f{$_};
1.7 www 296: $t{$_}=~s/\.\.+/\,/g;
297: $t{$_}=~s/(^|[^\"\'])([A-Za-z]\d+)/$1\$v\{\'$2\'\}/g;
1.6 www 298: }
1.1 www 299: }
300: } keys %f;
1.17 www 301: $t{'A0'}=$f{'A0'};
302: $t{'A0'}=~s/\.\.+/\,/g;
303: $t{'A0'}=~s/(^|[^\"\'])([A-Za-z]\d+)/$1\$v\{\'$2\'\}/g;
1.1 www 304: }
305:
1.4 www 306: sub calc {
1.1 www 307: %v=();
1.4 www 308: &sett();
1.1 www 309: my $notfinished=1;
310: my $depth=0;
311: while ($notfinished) {
312: $notfinished=0;
313: map {
314: my $old=$v{$_};
1.4 www 315: $v{$_}=eval($t{$_});
1.1 www 316: if ($@) {
317: %v=();
318: return $@;
319: }
320: if ($v{$_} ne $old) { $notfinished=1; }
321: } keys %t;
322: $depth++;
323: if ($depth>100) {
324: %v=();
325: return 'Maximum calculation depth exceeded';
326: }
327: }
328: return '';
329: }
330:
1.21 ! www 331: sub templaterow {
! 332: my @cols=();
! 333: $cols[0]='<b><font size=+1>Template</font></b>';
! 334: map {
! 335: my $fm=$f{'template_'.$_};
! 336: $fm=~s/[\'\"]/\&\#34;/g;
! 337: $cols[$#cols+1]="'template_$_','$fm'".'___eq___'.$fm;
! 338: } ('A','B','C','D','E','F','G','H','I','J','K','L','M',
! 339: 'N','O','P','Q','R','S','T','U','V','W','X','Y','Z',
! 340: 'a','b','c','d','e','f','g','h','i','j','k','l','m',
! 341: 'n','o','p','q','r','s','t','u','v','w','x','y','z');
! 342: return @cols;
! 343: }
! 344:
1.16 www 345: sub outrowassess {
1.6 www 346: my $n=shift;
347: my @cols=();
348: if ($n) {
349: $cols[0]=$rl{$f{'A'.$n}};
350: } else {
351: $cols[0]='<b><font size=+1>Export</font></b>';
352: }
353: map {
354: my $fm=$f{$_.$n};
355: $fm=~s/[\'\"]/\&\#34;/g;
356: $cols[$#cols+1]="'$_$n','$fm'".'___eq___'.$v{$_.$n};
357: } ('A','B','C','D','E','F','G','H','I','J','K','L','M',
1.7 www 358: 'N','O','P','Q','R','S','T','U','V','W','X','Y','Z',
359: 'a','b','c','d','e','f','g','h','i','j','k','l','m',
360: 'n','o','p','q','r','s','t','u','v','w','x','y','z');
1.6 www 361: return @cols;
362: }
363:
1.18 www 364: sub outrow {
365: my $n=shift;
366: my @cols=();
367: if ($n) {
1.21 ! www 368: $cols[0]=$rl{$f{'A'.$n}};
1.18 www 369: } else {
370: $cols[0]='<b><font size=+1>Export</font></b>';
371: }
372: map {
373: my $fm=$f{$_.$n};
374: $fm=~s/[\'\"]/\&\#34;/g;
375: $cols[$#cols+1]="'$_$n','$fm'".'___eq___'.$v{$_.$n};
376: } ('A','B','C','D','E','F','G','H','I','J','K','L','M',
377: 'N','O','P','Q','R','S','T','U','V','W','X','Y','Z',
378: 'a','b','c','d','e','f','g','h','i','j','k','l','m',
379: 'n','o','p','q','r','s','t','u','v','w','x','y','z');
380: return @cols;
381: }
382:
1.14 www 383: sub exportrowa {
384: my $rowa='';
385: map {
1.18 www 386: $rowa.=$v{$_.'0'}."___;___";
1.14 www 387: } ('A','B','C','D','E','F','G','H','I','J','K','L','M',
388: 'N','O','P','Q','R','S','T','U','V','W','X','Y','Z');
1.18 www 389: $rowa=~s/\_\_\_\;\_\_\_$//;
1.14 www 390: return $rowa;
391: }
392:
1.4 www 393: # ------------------------------------------- End of "Inside of the safe space"
394: ENDDEFS
395: $safeeval->reval($code);
396: return $safeeval;
397: }
398:
399: # ------------------------------------------------ Add or change formula values
400:
401: sub setformulas {
402: my ($safeeval,@f)=@_;
1.6 www 403: $safeeval->reval('%f='."('".join("','",@f)."');");
404: }
405:
406: # ------------------------------------------------ Add or change formula values
407:
408: sub setconstants {
409: my ($safeeval,@c)=@_;
410: $safeeval->reval('%c='."('".join("','",@c)."');");
411: }
412:
413: # ------------------------------------------------ Add or change formula values
414:
415: sub setrowlabels {
416: my ($safeeval,@rl)=@_;
417: $safeeval->reval('%rl='."('".join("','",@rl)."');");
1.4 www 418: }
419:
420: # ------------------------------------------------------- Calculate spreadsheet
421:
422: sub calcsheet {
423: my $safeeval=shift;
424: $safeeval->reval('&calc();');
425: }
426:
427: # ------------------------------------------------------------------ Get values
428:
429: sub getvalues {
430: my $safeeval=shift;
431: return $safeeval->reval('%v');
432: }
433:
434: # ---------------------------------------------------------------- Get formulas
435:
436: sub getformulas {
437: my $safeeval=shift;
438: return $safeeval->reval('%f');
439: }
440:
1.5 www 441: # -------------------------------------------------------------------- Set type
442:
443: sub settype {
444: my ($safeeval,$type)=@_;
1.11 www 445: $safeeval->reval('$sheettype="'.$type.'";');
1.5 www 446: }
447:
448: # -------------------------------------------------------------------- Get type
449:
450: sub gettype {
451: my $safeeval=shift;
452: return $safeeval->reval('$sheettype');
453: }
1.6 www 454: # ------------------------------------------------------------------ Set maxrow
455:
456: sub setmaxrow {
457: my ($safeeval,$row)=@_;
458: $safeeval->reval('$maxrow='.$row.';');
459: }
460:
461: # ------------------------------------------------------------------ Get maxrow
462:
463: sub getmaxrow {
464: my $safeeval=shift;
465: return $safeeval->reval('$maxrow');
466: }
1.5 www 467:
1.6 www 468: # ---------------------------------------------------------------- Set filename
1.5 www 469:
470: sub setfilename {
471: my ($safeeval,$fn)=@_;
1.11 www 472: $safeeval->reval('$filename="'.$fn.'";');
1.5 www 473: }
474:
1.6 www 475: # ---------------------------------------------------------------- Get filename
1.5 www 476:
477: sub getfilename {
478: my $safeeval=shift;
479: return $safeeval->reval('$filename');
480: }
1.14 www 481:
482: # ------------------------------------------------------------- Export of A-row
483:
484: sub exportrow {
485: my $safeeval=shift;
486: return $safeeval->reval('&exportrowa()');
487: }
488:
1.5 www 489: # ========================================================== End of Spreadsheet
490: # =============================================================================
491:
492:
1.6 www 493: # --------------------------------------------- Produce output row n from sheet
494:
495: sub rown {
496: my ($safeeval,$n)=@_;
1.21 ! www 497: my $defaultbg;
! 498: unless ($n eq '-') {
! 499: $defaultbg=((($n-1)/5)==int(($n-1)/5))?'#E0E0':'#FFFF';
! 500: } else {
! 501: $defaultbg='#E0FF';
! 502: }
1.6 www 503: my $rowdata="\n<tr><td><b><font size=+1>$n</font></b></td>";
504: my $showf=0;
1.16 www 505: my $proc;
1.18 www 506: my $maxred;
1.16 www 507: if (&gettype($safeeval) eq 'assesscalc') {
508: $proc='&outrowassess';
1.18 www 509: $maxred=1;
1.16 www 510: } else {
511: $proc='&outrow';
1.18 www 512: $maxred=26;
1.16 www 513: }
1.21 ! www 514: if ($n eq '-') { $proc='&templaterow'; $n=-1; }
1.6 www 515: map {
1.9 www 516: my $bgcolor=$defaultbg.((($showf-1)/5==int(($showf-1)/5))?'99':'DD');
1.6 www 517: my ($fm,$vl)=split(/\_\_\_eq\_\_\_/,$_);
518: if ($showf==0) { $vl=$_; }
1.18 www 519: if ($showf<=$maxred) { $bgcolor='#FFDDDD'; }
1.9 www 520: if (($n==0) && ($showf<=26)) { $bgcolor='#CCCCFF'; }
1.18 www 521: if (($showf>$maxred) || ((!$n) && ($showf>0))) {
1.6 www 522: if ($vl eq '') {
1.9 www 523: $vl='<font size=+2 color='.$bgcolor.'>#</font>';
1.6 www 524: }
525: $rowdata.=
1.10 www 526: '<td bgcolor='.$bgcolor.'><a href="javascript:celledit('.$fm.');">'.$vl.
1.6 www 527: '</a></td>';
528: } else {
1.9 www 529: $rowdata.='<td bgcolor='.$bgcolor.'> '.$vl.' </td>';
1.6 www 530: }
531: $showf++;
1.16 www 532: } $safeeval->reval($proc.'('.$n.')');
1.6 www 533: return $rowdata.'</tr>';
534: }
535:
536: # ------------------------------------------------------------- Print out sheet
537:
538: sub outsheet {
539: my $safeeval=shift;
1.18 www 540: my $maxred;
541: my $realm;
542: if (&gettype($safeeval) eq 'assesscalc') {
543: $maxred=1;
544: $realm='Assessment';
545: } elsif (&gettype($safeeval) eq 'studentcalc') {
546: $maxred=26;
547: $realm='User';
548: } else {
549: $maxred=26;
550: $realm='Course';
551: }
552: my $maxyellow=52-$maxred;
553: my $tabledata='<table border=2><tr><th colspan=2 rowspan=2><font size=+2>'.
554: $realm.'</font></th>'.
555: '<td bgcolor=#FFDDDD colspan='.$maxred.
556: '><b><font size=+1>Import</font></b></td>'.
557: '<td colspan='.$maxyellow.
558: '><b><font size=+1>Calculations</font></b></td></tr><tr>';
559: my $showf=0;
1.6 www 560: map {
1.18 www 561: $showf++;
562: if ($showf<=$maxred) {
563: $tabledata.='<td bgcolor="#FFDDDD">';
564: } else {
565: $tabledata.='<td>';
566: }
567: $tabledata.="<b><font size=+1>$_</font></b></td>";
568: } ('A','B','C','D','E','F','G','H','I','J','K','L','M',
1.7 www 569: 'N','O','P','Q','R','S','T','U','V','W','X','Y','Z',
570: 'a','b','c','d','e','f','g','h','i','j','k','l','m',
571: 'n','o','p','q','r','s','t','u','v','w','x','y','z');
1.6 www 572: $tabledata.='</tr>';
573: my $row;
574: my $maxrow=&getmaxrow($safeeval);
1.21 ! www 575: $tabledata.=&rown($safeeval,'-');
1.6 www 576: for ($row=0;$row<=$maxrow;$row++) {
577: $tabledata.=&rown($safeeval,$row);
578: }
579: $tabledata.='</table>';
580: }
581:
582:
1.5 www 583:
1.19 www 584: # ------------------------------------- Read spreadsheet formulas from a course
1.3 www 585:
1.5 www 586: sub readsheet {
1.19 www 587: my ($safeeval,$fn,$r)=@_;
1.4 www 588: my %f=();
1.21 ! www 589: if (($fn eq '') || ($fn=~/^default\_/)) {
1.19 www 590: my $sheetxml='';
1.10 www 591: {
592: my $fh;
1.19 www 593: if ($fh=Apache::File->new($r->dir_config('lonIncludes').
594: '/default.'.&gettype($safeeval))) {
595: $sheetxml=join('',<$fh>);
596: }
597: }
598: my $parser=HTML::TokeParser->new(\$sheetxml);
599: my $token;
600: while ($token=$parser->get_token) {
601: if ($token->[0] eq 'S') {
602: if ($token->[1] eq 'field') {
603: $f{$token->[2]->{'col'}.$token->[2]->{'row'}}=
604: $parser->get_text('/field');
605: }
1.20 www 606: if ($token->[1] eq 'template') {
607: $f{'template_'.$token->[2]->{'col'}}=
608: $parser->get_text('/template');
609: }
1.19 www 610: }
611: }
612: &setfilename($safeeval,'default_'.&gettype($safeeval));
613: } else {
614: &setfilename($safeeval,$fn);
615: unless ($spreadsheets{$fn}) {
616: $spreadsheets{$fn}='';
617: my $reply=&Apache::lonnet::reply('dump:'.
618: $ENV{'course.'.$ENV{'request.course.id'}.'.domain'}.':'.
619: $ENV{'course.'.$ENV{'request.course.id'}.'.num'}.':'.$fn,
620: $ENV{'course.'.$ENV{'request.course.id'}.'.home'});
621: unless ($reply=~/^error\:/) {
622: $spreadsheets{$fn}=$reply;
623: }
1.10 www 624: }
1.19 www 625: map {
626: my ($name,$value)=split(/\=/,$_);
627: $f{&Apache::lonnet::unescape($name)}=
628: &Apache::lonnet::unescape($value);
629: } split(/\&/,$spreadsheets{$fn});
1.3 www 630: }
1.20 www 631:
1.5 www 632: &setformulas($safeeval,%f);
1.3 www 633: }
634:
1.19 www 635: # ------------------------------------------------------------ Save spreadsheet
636:
637: sub writesheet {
638: my $safeeval=shift;
639: if (&Apache::lonnet::allowed('opa',$ENV{'request.course.id'})) {
640: my %f=&getformulas($safeeval);
641: my $sheetdata='';
642: map {
643: $sheetdata.=&Apache::lonnet::escape($_).'='.
644: &Apache::lonnet::escape($f{$_}).'&';
645: } keys %f;
646: $sheetdata=~s/\&$//;
647: my $reply=&Apache::lonnet::reply('put:'.
648: $ENV{'course.'.$ENV{'request.course.id'}.'.domain'}.':'.
649: $ENV{'course.'.$ENV{'request.course.id'}.'.num'}.':'.
650: &getfilename($safeeval).':'.
651: $sheetdata,
652: $ENV{'course.'.$ENV{'request.course.id'}.'.home'});
653: }
654: }
655:
1.10 www 656: # ----------------------------------------------- Make a temp copy of the sheet
657:
658: sub tmpwrite {
1.11 www 659: my ($safeeval,$tmpdir,$symb)=@_;
1.21 ! www 660: my $fn=$uname.'_'.$udom.'_spreadsheet_'.$symb.'_'.&getfilename($safeeval);
1.10 www 661: $fn=~s/\W/\_/g;
662: $fn=$tmpdir.$fn.'.tmp';
663: my $fh;
664: if ($fh=Apache::File->new('>'.$fn)) {
665: print $fh join("\n",&getformulas($safeeval));
666: }
667: }
668:
669: # ---------------------------------------------------------- Read the temp copy
670:
671: sub tmpread {
1.11 www 672: my ($safeeval,$tmpdir,$symb,$nfield,$nform)=@_;
1.21 ! www 673: my $fn=$uname.'_'.$udom.'_spreadsheet_'.$symb.'_'.&getfilename($safeeval);
1.10 www 674: $fn=~s/\W/\_/g;
675: $fn=$tmpdir.$fn.'.tmp';
676: my $fh;
677: my %fo=();
678: if ($fh=Apache::File->new($fn)) {
679: my $name;
680: while ($name=<$fh>) {
681: chomp($name);
682: my $value=<$fh>;
683: chomp($value);
684: $fo{$name}=$value;
685: }
686: }
687: $fo{$nfield}=$nform;
688: &setformulas($safeeval,%fo);
689: }
690:
1.3 www 691: # --------------------------------------------------------------- Read metadata
692:
693: sub readmeta {
694: my $fn=shift;
695: unless ($fn=~/\.meta$/) { $fn.='meta'; }
696: my $content;
697: my %returnhash=();
698: {
699: my $fh=Apache::File->new($fn);
700: $content=join('',<$fh>);
701: }
702: my $parser=HTML::TokeParser->new(\$content);
703: my $token;
704: while ($token=$parser->get_token) {
705: if ($token->[0] eq 'S') {
706: my $entry=$token->[1];
707: if (($entry eq 'stores') || ($entry eq 'parameter')) {
708: my $unikey=$entry;
709: $unikey.='_'.$token->[2]->{'part'};
710: $unikey.='_'.$token->[2]->{'name'};
711: $returnhash{$unikey}=$token->[2]->{'display'};
712: }
713: }
714: }
715: return %returnhash;
716: }
717:
1.11 www 718: # ================================================================== Parameters
719: # -------------------------------------------- Figure out a cascading parameter
720:
721: sub parmval {
722: my ($what,$symb)=@_;
723:
724: unless ($symb) { return ''; }
725: my $result='';
726:
727: my ($mapname,$id,$fn)=split(/\_\_\_/,$symb);
728: # ----------------------------------------------------- Cascading lookup scheme
1.12 www 729: my $rwhat=$what;
730: $what=~s/^parameter\_//;
731: $what=~s/\_/\./;
1.11 www 732:
733: my $symbparm=$symb.'.'.$what;
734: my $mapparm=$mapname.'___(all).'.$what;
735:
736: my $seclevel=
737: $ENV{'request.course.id'}.'.['.
738: $csec.'].'.$what;
739: my $seclevelr=
740: $ENV{'request.course.id'}.'.['.
741: $csec.'].'.$symbparm;
742: my $seclevelm=
743: $ENV{'request.course.id'}.'.['.
744: $csec.'].'.$mapparm;
745:
746: my $courselevel=
747: $ENV{'request.course.id'}.'.'.$what;
748: my $courselevelr=
749: $ENV{'request.course.id'}.'.'.$symbparm;
750: my $courselevelm=
751: $ENV{'request.course.id'}.'.'.$mapparm;
1.12 www 752:
1.11 www 753: # ---------------------------------------------------------- fourth, check user
754:
755: if ($uname) {
756:
757: if ($useropt{$courselevelr}) { return $useropt{$courselevelr}; }
758:
759: if ($useropt{$courselevelm}) { return $useropt{$courselevelm}; }
760:
761: if ($useropt{$courselevel}) { return $useropt{$courselevel}; }
762:
763: }
764:
765: # --------------------------------------------------------- third, check course
766:
767: if ($csec) {
768:
769: if ($courseopt{$seclevelr}) { return $courseopt{$seclevelr}; }
770:
771: if ($courseopt{$seclevelm}) { return $courseopt{$seclevelm}; }
772:
773: if ($courseopt{$seclevel}) { return $courseopt{$seclevel}; }
774:
775: }
776:
777: if ($courseopt{$courselevelr}) { return $courseopt{$courselevelr}; }
778:
779: if ($courseopt{$courselevelm}) { return $courseopt{$courselevelm}; }
780:
781: if ($courseopt{$courselevel}) { return $courseopt{$courselevel}; }
782:
783: # ----------------------------------------------------- second, check map parms
784:
785: my $thisparm=$parmhash{$symbparm};
786: if ($thisparm) { return $thisparm; }
787:
788: # -------------------------------------------------------- first, check default
789:
1.12 www 790: return &Apache::lonnet::metadata($fn,$rwhat.'.default');
1.11 www 791:
792: }
793:
794:
1.5 www 795: # ----------------------------------------------------------------- Update rows
796:
797: sub updaterows {
798: my $safeeval=shift;
799: my %bighash;
800: # -------------------------------------------------------------------- Tie hash
801: if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
802: &GDBM_READER,0640)) {
803: # --------------------------------------------------------- Get all assessments
804:
805: my %allkeys=();
806: my %allassess=();
807:
808: my $stype=&gettype($safeeval);
809:
810: map {
811: if ($_=~/^src\_(\d+)\.(\d+)$/) {
812: my $mapid=$1;
813: my $resid=$2;
814: my $id=$mapid.'.'.$resid;
815: my $srcf=$bighash{$_};
816: if ($srcf=~/\.(problem|exam|quiz|assess|survey|form)$/) {
817: my $symb=
818: &Apache::lonnet::declutter($bighash{'map_id_'.$mapid}).
819: '___'.$resid.'___'.
820: &Apache::lonnet::declutter($srcf);
821: $allassess{$symb}=$bighash{'title_'.$id};
1.8 www 822:
1.6 www 823: if ($stype eq 'assesscalc') {
1.5 www 824: map {
1.11 www 825: if (($_=~/^stores\_(.*)/) || ($_=~/^parameter\_(.*)/)) {
1.5 www 826: my $key=$_;
827: my $display=
828: &Apache::lonnet::metadata($srcf,$key.'.display');
829: unless ($display) {
830: $display=
831: &Apache::lonnet::metadata($srcf,$key.'.name');
832: }
833: $allkeys{$key}=$display;
834: }
835: } split(/\,/,&Apache::lonnet::metadata($srcf,'keys'));
836: }
837: }
838: }
839: } keys %bighash;
840: untie(%bighash);
841:
842: #
1.11 www 843: # %allkeys has a list of storage and parameter displays by unikey
1.5 www 844: # %allassess has a list of all resource displays by symb
845: #
846: # -------------------- Find discrepancies between the course row table and this
847: #
848: my %f=&getformulas($safeeval);
1.6 www 849: my $changed=0;
850:
851: my %current=();
852: if ($stype eq 'assesscalc') {
853: %current=%allkeys;
854: } elsif ($stype eq 'studentcalc') {
855: %current=%allassess;
856: }
857:
858: my $maxrow=0;
859: my %existing=();
860:
861: # ----------------------------------------------------------- Now obsolete rows
1.5 www 862: map {
1.6 www 863: if ($_=~/^A(\d+)/) {
864: $maxrow=($1>$maxrow)?$1:$maxrow;
865: $existing{$f{$_}}=1;
1.17 www 866: unless ((defined($current{$f{$_}})) || (!$1)) {
1.6 www 867: $f{$_}='!!! Obsolete';
868: $changed=1;
1.5 www 869: }
870: }
871: } keys %f;
1.6 www 872:
873: # -------------------------------------------------------- New and unknown keys
874:
875: map {
876: unless ($existing{$_}) {
877: $changed=1;
878: $maxrow++;
879: $f{'A'.$maxrow}=$_;
880: }
881: } keys %current;
882:
883: if ($changed) { &setformulas($safeeval,%f); }
884:
885: &setmaxrow($safeeval,$maxrow);
886: &setrowlabels($safeeval,%current);
1.5 www 887:
888: } else {
889: return 'Could not access course data';
890: }
891: }
1.3 www 892:
1.16 www 893: # --------------------------------------------------- Load data for one student
894:
895: sub rowazstudent {
896: my $safeeval=shift;
897: my %c=();
898: my %f=&getformulas($safeeval);
899: map {
1.17 www 900: if ($_=~/^A(\d+)/) {
901: my $row=$1;
1.16 www 902: unless ($f{$_}=~/^\!/) {
1.18 www 903: my @assessdata=split(/\_\_\_\;\_\_\_/,
1.17 www 904: &Apache::lonnet::ssi(
1.16 www 905: '/res/msu/korte/junk.assesscalc',('utarget' => 'export',
906: 'uname' => $uname,
907: 'udom' => $udom,
1.17 www 908: 'usymb' => $f{$_})));
909: my $index=0;
910: map {
1.18 www 911: if ($assessdata[$index]) {
912: $c{$_.$row}=$assessdata[$index];
913: unless ($_ eq 'A') {
914: $f{$_.$row}='import';
915: }
916: }
1.17 www 917: $index++;
918: } ('A','B','C','D','E','F','G','H','I','J','K','L','M',
919: 'N','O','P','Q','R','S','T','U','V','W','X','Y','Z');
1.16 www 920: }
921: }
922: } keys %f;
1.18 www 923: &setformulas($safeeval,%f);
1.16 www 924: &setconstants($safeeval,%c);
925: }
926:
1.6 www 927: # ------------------------------------------------ Load data for one assessment
928:
929: sub rowaassess {
1.11 www 930: my ($safeeval,$symb)=@_;
1.6 www 931: my $uhome=&Apache::lonnet::homeserver($uname,$udom);
932: my $namespace;
933: unless ($namespace=$ENV{'request.course.id'}) { return ''; }
1.11 www 934:
935: # ----------------------------------------------------------- Get stored values
936: my $answer=&Apache::lonnet::reply(
1.15 www 937: "restore:$udom:$uname:".
938: &Apache::lonnet::escape($namespace).":".
939: &Apache::lonnet::escape($symb),$uhome);
1.6 www 940: my %returnhash=();
941: map {
942: my ($name,$value)=split(/\=/,$_);
1.11 www 943: $returnhash{&Apache::lonnet::unescape($name)}=
944: &Apache::lonnet::unescape($value);
1.6 www 945: } split(/\&/,$answer);
946: my $version;
947: for ($version=1;$version<=$returnhash{'version'};$version++) {
948: map {
949: $returnhash{$_}=$returnhash{$version.':'.$_};
950: } split(/\:/,$returnhash{$version.':keys'});
951: }
1.11 www 952: # ----------------------------- returnhash now has all stores for this resource
953:
954: # ---------------------------- initialize coursedata and userdata for this user
955: %courseopt=();
956: %useropt=();
957: my $uhome=&Apache::lonnet::homeserver($uname,$udom);
958: unless ($uhome eq 'no_host') {
959: # -------------------------------------------------------------- Get coursedata
1.13 www 960: unless
961: ((time-$courserdatas{$ENV{'request.course.id'}.'.last_cache'})<120) {
1.11 www 962: my $reply=&Apache::lonnet::reply('dump:'.
963: $ENV{'course.'.$ENV{'request.course.id'}.'.domain'}.':'.
964: $ENV{'course.'.$ENV{'request.course.id'}.'.num'}.':resourcedata',
965: $ENV{'course.'.$ENV{'request.course.id'}.'.home'});
966: if ($reply!~/^error\:/) {
967: $courserdatas{$ENV{'request.course.id'}}=$reply;
1.13 www 968: $courserdatas{$ENV{'request.course.id'}.'.last_cache'}=time;
1.11 www 969: }
970: }
971: map {
972: my ($name,$value)=split(/\=/,$_);
973: $courseopt{&Apache::lonnet::unescape($name)}=
974: &Apache::lonnet::unescape($value);
975: } split(/\&/,$courserdatas{$ENV{'request.course.id'}});
976: # --------------------------------------------------- Get userdata (if present)
1.13 www 977: unless
978: ((time-$userrdatas{$uname.'___'.$udom.'.last_cache'})<120) {
1.11 www 979: my $reply=
980: &Apache::lonnet::reply('dump:'.$udom.':'.$uname.':resourcedata',$uhome);
981: if ($reply!~/^error\:/) {
982: $userrdatas{$uname.'___'.$udom}=$reply;
1.13 www 983: $userrdatas{$uname.'___'.$udom.'.last_cache'}=time;
1.11 www 984: }
985: }
986: map {
987: my ($name,$value)=split(/\=/,$_);
988: $useropt{&Apache::lonnet::unescape($name)}=
1.15 www 989: &Apache::lonnet::unescape($value);
1.11 www 990: } split(/\&/,$userrdatas{$uname.'___'.$udom});
991: }
992: # -- now courseopt, useropt initialized for this user and course (used parmval)
1.6 www 993:
994: my %c=();
995: my %f=&getformulas($safeeval);
996: map {
997: if ($_=~/^A/) {
998: unless ($f{$_}=~/^\!/) {
1.11 www 999: if ($f{$_}=~/^parameter/) {
1000: $c{$_}=&parmval($f{$_},$symb);
1001: } else {
1.15 www 1002: my $key=$f{$_};
1003: $key=~s/^stores\_/resource\./;
1004: $key=~s/\_/\./;
1005: $c{$_}=$returnhash{$key};
1.11 www 1006: }
1007: }
1.6 www 1008: }
1009: } keys %f;
1.11 www 1010:
1.6 www 1011: &setconstants($safeeval,%c);
1012: }
1013:
1.10 www 1014: # --------------------------------------------------------- Various form fields
1015:
1016: sub textfield {
1017: my ($title,$name,$value)=@_;
1018: return "\n<p><b>$title:</b><br>".
1019: '<input type=text name="'.$name.'" size=80 value="'.$value.'">';
1020: }
1021:
1022: sub hiddenfield {
1023: my ($name,$value)=@_;
1024: return "\n".'<input type=hidden name="'.$name.'" value="'.$value.'">';
1025: }
1026:
1027: sub selectbox {
1028: my ($title,$name,$value,%options)=@_;
1029: my $selout="\n<p><b>$title:</b><br>".'<select name="'.$name.'">';
1030: map {
1031: $selout.='<option value="'.$_.'"';
1032: if ($_ eq $value) { $selout.=' selected'; }
1033: $selout.='>'.$options{$_}.'</option>';
1034: } sort keys %options;
1035: return $selout.'</select>';
1036: }
1037:
1.12 www 1038: # ================================================================ Main handler
1.3 www 1039:
1040: sub handler {
1.7 www 1041: my $r=shift;
1042:
1.11 www 1043: $uname='';
1044: $udom='';
1045: $csec='';
1046:
1.7 www 1047: if ($r->header_only) {
1048: $r->content_type('text/html');
1049: $r->send_http_header;
1050: return OK;
1051: }
1.3 www 1052:
1.7 www 1053: # ----------------------------------------------------- Needs to be in a course
1.3 www 1054:
1.7 www 1055: if (($ENV{'request.course.fn'}) ||
1056: ($ENV{'request.state'} eq 'construct')) {
1.10 www 1057:
1058: # --------------------------- Get query string for limited number of parameters
1.17 www 1059:
1.10 www 1060: map {
1061: my ($name, $value) = split(/=/,$_);
1062: $value =~ tr/+/ /;
1063: $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
1.19 www 1064: if (($name eq 'uname') || ($name eq 'udom') ||
1065: ($name eq 'usymb') || ($name eq 'ufn')) {
1.10 www 1066: unless ($ENV{'form.'.$name}) {
1067: $ENV{'form.'.$name}=$value;
1068: }
1069: }
1070: } (split(/&/,$ENV{'QUERY_STRING'}));
1071:
1072: # ------------------------------------------- Nothing there? Must be login user
1073: unless ($ENV{'form.uname'}) {
1.11 www 1074: $uname=$ENV{'user.name'};
1075: $udom=$ENV{'user.domain'};
1076: } else {
1077: $uname=$ENV{'form.uname'};
1078: $udom=$ENV{'form.udom'};
1.10 www 1079: }
1.14 www 1080: # ----------------------------------------------------------- Change of target?
1081:
1.16 www 1082: my $reroute=($ENV{'form.utarget'} eq 'export');
1.14 www 1083:
1.10 www 1084: # ------------------------------------------------------------------- Open page
1085:
1.7 www 1086: $r->content_type('text/html');
1.11 www 1087: $r->header_out('Cache-control','no-cache');
1088: $r->header_out('Pragma','no-cache');
1.7 www 1089: $r->send_http_header;
1.3 www 1090:
1.14 www 1091: # --------------------------------------------------------------- Screen output
1092:
1093: unless ($reroute) {
1.10 www 1094: $r->print('<html><head><title>LON-CAPA Spreadsheet</title>');
1095: $r->print(<<ENDSCRIPT);
1096: <script language="JavaScript">
1097:
1098: function celledit(cn,cf) {
1099: var cnf=prompt(cn,cf);
1100: if (cnf!=null) {
1101: document.sheet.unewfield.value=cn;
1102: document.sheet.unewformula.value=cnf;
1103: document.sheet.submit();
1104: }
1105: }
1106:
1107: </script>
1108: ENDSCRIPT
1109: $r->print('</head><body bgcolor="#FFFFFF">'.
1.21 ! www 1110: '<img align=right src=/adm/lonIcons/lonlogos.gif>'.
! 1111: '<h1>LON-CAPA Spreadsheet</h1>'.
1.10 www 1112: '<form action="'.$r->uri.'" name=sheet method=post>'.
1113: &hiddenfield('uname',$ENV{'form.uname'}).
1114: &hiddenfield('udom',$ENV{'form.udom'}).
1115: &hiddenfield('usymb',$ENV{'form.usymb'}).
1116: &hiddenfield('unewfield','').
1117: &hiddenfield('unewformula',''));
1.14 www 1118: }
1119:
1120: # ---------------------------------------- Read new sheet or modified worksheet
1121:
1.4 www 1122: my $sheetone=initsheet();
1.19 www 1123: $r->uri=~/\/(\w+)$/;
1124: &settype($sheetone,$1);
1.10 www 1125: if ($ENV{'form.unewfield'}) {
1126: $r->print('<h2>Modified Workcopy</h2>');
1127: $ENV{'form.unewformula'}=~s/\'/\"/g;
1128: $r->print('New formula: '.$ENV{'form.unewfield'}.'='.
1129: $ENV{'form.unewformula'}.'<br>');
1.19 www 1130: &setfilename($sheetone,$ENV{'form.ufn'});
1.10 www 1131: &tmpread($sheetone,$r->dir_config('lonDaemons').'/tmp/',
1.11 www 1132: $ENV{'form.usymb'},
1.10 www 1133: $ENV{'form.unewfield'},$ENV{'form.unewformula'});
1.11 www 1134: } else {
1.19 www 1135: &readsheet($sheetone,$ENV{'form.ufn'},$r);
1.21 ! www 1136: $ENV{'form.ufn'}=&getfilename($sheetone);
1.11 www 1137: }
1.14 www 1138:
1139: # --------------------------------------------- See if all import rows uptodate
1140:
1.11 www 1141: if (tie(%parmhash,'GDBM_File',
1142: $ENV{'request.course.fn'}.'_parms.db',&GDBM_READER,0640)) {
1143: $csec=&Apache::lonnet::usection($udom,$uname,$ENV{'request.course.id'});
1144: if ($csec eq '-1') {
1145: $r->print('<h3><font color=red>'.
1146: "User '$uname' at domain '$udom' not a student in this course</font></h3>");
1147: }
1148: &updaterows($sheetone);
1149: untie(%parmhash);
1.10 www 1150: } else {
1.11 www 1151: $r->print('<h3><font color=red>'.
1152: 'Could not initialize import fields (not in a course)</font></h3>');
1153: }
1.14 www 1154:
1155: # ------------------------------------------------ Write the modified worksheet
1156:
1.11 www 1157: &tmpwrite($sheetone,$r->dir_config('lonDaemons').'/tmp/',
1158: $ENV{'form.usymb'});
1.14 www 1159:
1160: # ----------------------------------------------------- Print user, course, etc
1161: unless ($reroute) {
1.21 ! www 1162: $r->print(&hiddenfield('ufn',$ENV{'form.ufn'}).
! 1163: "<b>User '$uname' at domain '$udom' for '".
1.11 www 1164: $ENV{'course.'.$ENV{'request.course.id'}.'.description'}."'");
1165: if ($csec) {
1166: $r->print(", group/section '$csec'");
1167: }
1168: $r->print("</b>\n");
1.14 www 1169: }
1170: # -------------------------------------------------------- Import and calculate
1171:
1.11 www 1172: if (&gettype($sheetone) eq 'assesscalc') {
1173: &rowaassess($sheetone,$ENV{'form.usymb'});
1.16 www 1174: } elsif (&gettype($sheetone) eq 'studentcalc') {
1175: &rowazstudent($sheetone);
1.10 www 1176: }
1.18 www 1177: my $calcoutput=&calcsheet($sheetone);
1178: unless ($reroute) {
1179: $r->print('<h3><font color=red>'.$calcoutput.'</h3></font>');
1180: }
1.14 www 1181:
1182: # ------------------------------------------------------- Print or export sheet
1183: unless ($reroute) {
1.6 www 1184: $r->print(&outsheet($sheetone));
1.8 www 1185:
1.10 www 1186: $r->print('</form></body></html>');
1.14 www 1187: } else {
1.18 www 1188: $r->print(&exportrow($sheetone));
1.14 www 1189: }
1190: # ------------------------------------------------------------------------ Done
1.7 www 1191: } else {
1192: # ----------------------------- Not in a course, or not allowed to modify parms
1193: $ENV{'user.error.msg'}=
1194: $r->uri.":opa:0:0:Cannot modify spreadsheet";
1195: return HTTP_NOT_ACCEPTABLE;
1196: }
1.3 www 1197: return OK;
1.1 www 1198: }
1199:
1200: 1;
1201: __END__
1202:
1203:
1204:
1205:
1206:
1207:
1208:
1209:
1210:
1211:
1212:
1213:
1214:
1215:
1216:
1217:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/back.gif){kind=icon}
Return to lonspreadsheet.pm CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / loncom / interface