Annotation of loncom/interface/lonspreadsheet.pm, revision 1.22
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'});
1.22 ! www 653: if ($reply eq 'ok') {
! 654: return &Apache::lonnet::reply('put:'.
! 655: $ENV{'course.'.$ENV{'request.course.id'}.'.domain'}.':'.
! 656: $ENV{'course.'.$ENV{'request.course.id'}.'.num'}.':'.
! 657: &gettype($safeeval).'_spreadsheets:'.
! 658: &Apache::lonnet::escape(&getfilename($safeeval)).'='.
! 659: $ENV{'user.name'},
! 660: $ENV{'course.'.$ENV{'request.course.id'}.'.home'});
! 661: } else {
! 662: return $reply;
! 663: }
! 664: }
! 665: return 'unauthorized';
1.19 www 666: }
667:
1.10 www 668: # ----------------------------------------------- Make a temp copy of the sheet
669:
670: sub tmpwrite {
1.11 www 671: my ($safeeval,$tmpdir,$symb)=@_;
1.21 www 672: my $fn=$uname.'_'.$udom.'_spreadsheet_'.$symb.'_'.&getfilename($safeeval);
1.10 www 673: $fn=~s/\W/\_/g;
674: $fn=$tmpdir.$fn.'.tmp';
675: my $fh;
676: if ($fh=Apache::File->new('>'.$fn)) {
677: print $fh join("\n",&getformulas($safeeval));
678: }
679: }
680:
681: # ---------------------------------------------------------- Read the temp copy
682:
683: sub tmpread {
1.11 www 684: my ($safeeval,$tmpdir,$symb,$nfield,$nform)=@_;
1.21 www 685: my $fn=$uname.'_'.$udom.'_spreadsheet_'.$symb.'_'.&getfilename($safeeval);
1.10 www 686: $fn=~s/\W/\_/g;
687: $fn=$tmpdir.$fn.'.tmp';
688: my $fh;
689: my %fo=();
690: if ($fh=Apache::File->new($fn)) {
691: my $name;
692: while ($name=<$fh>) {
693: chomp($name);
694: my $value=<$fh>;
695: chomp($value);
696: $fo{$name}=$value;
697: }
698: }
1.22 ! www 699: if ($nfield) { $fo{$nfield}=$nform; }
1.10 www 700: &setformulas($safeeval,%fo);
701: }
702:
1.3 www 703: # --------------------------------------------------------------- Read metadata
704:
705: sub readmeta {
706: my $fn=shift;
707: unless ($fn=~/\.meta$/) { $fn.='meta'; }
708: my $content;
709: my %returnhash=();
710: {
711: my $fh=Apache::File->new($fn);
712: $content=join('',<$fh>);
713: }
714: my $parser=HTML::TokeParser->new(\$content);
715: my $token;
716: while ($token=$parser->get_token) {
717: if ($token->[0] eq 'S') {
718: my $entry=$token->[1];
719: if (($entry eq 'stores') || ($entry eq 'parameter')) {
720: my $unikey=$entry;
721: $unikey.='_'.$token->[2]->{'part'};
722: $unikey.='_'.$token->[2]->{'name'};
723: $returnhash{$unikey}=$token->[2]->{'display'};
724: }
725: }
726: }
727: return %returnhash;
728: }
729:
1.11 www 730: # ================================================================== Parameters
731: # -------------------------------------------- Figure out a cascading parameter
732:
733: sub parmval {
734: my ($what,$symb)=@_;
735:
736: unless ($symb) { return ''; }
737: my $result='';
738:
739: my ($mapname,$id,$fn)=split(/\_\_\_/,$symb);
740: # ----------------------------------------------------- Cascading lookup scheme
1.12 www 741: my $rwhat=$what;
742: $what=~s/^parameter\_//;
743: $what=~s/\_/\./;
1.11 www 744:
745: my $symbparm=$symb.'.'.$what;
746: my $mapparm=$mapname.'___(all).'.$what;
747:
748: my $seclevel=
749: $ENV{'request.course.id'}.'.['.
750: $csec.'].'.$what;
751: my $seclevelr=
752: $ENV{'request.course.id'}.'.['.
753: $csec.'].'.$symbparm;
754: my $seclevelm=
755: $ENV{'request.course.id'}.'.['.
756: $csec.'].'.$mapparm;
757:
758: my $courselevel=
759: $ENV{'request.course.id'}.'.'.$what;
760: my $courselevelr=
761: $ENV{'request.course.id'}.'.'.$symbparm;
762: my $courselevelm=
763: $ENV{'request.course.id'}.'.'.$mapparm;
1.12 www 764:
1.11 www 765: # ---------------------------------------------------------- fourth, check user
766:
767: if ($uname) {
768:
769: if ($useropt{$courselevelr}) { return $useropt{$courselevelr}; }
770:
771: if ($useropt{$courselevelm}) { return $useropt{$courselevelm}; }
772:
773: if ($useropt{$courselevel}) { return $useropt{$courselevel}; }
774:
775: }
776:
777: # --------------------------------------------------------- third, check course
778:
779: if ($csec) {
780:
781: if ($courseopt{$seclevelr}) { return $courseopt{$seclevelr}; }
782:
783: if ($courseopt{$seclevelm}) { return $courseopt{$seclevelm}; }
784:
785: if ($courseopt{$seclevel}) { return $courseopt{$seclevel}; }
786:
787: }
788:
789: if ($courseopt{$courselevelr}) { return $courseopt{$courselevelr}; }
790:
791: if ($courseopt{$courselevelm}) { return $courseopt{$courselevelm}; }
792:
793: if ($courseopt{$courselevel}) { return $courseopt{$courselevel}; }
794:
795: # ----------------------------------------------------- second, check map parms
796:
797: my $thisparm=$parmhash{$symbparm};
798: if ($thisparm) { return $thisparm; }
799:
800: # -------------------------------------------------------- first, check default
801:
1.12 www 802: return &Apache::lonnet::metadata($fn,$rwhat.'.default');
1.11 www 803:
804: }
805:
806:
1.5 www 807: # ----------------------------------------------------------------- Update rows
808:
809: sub updaterows {
810: my $safeeval=shift;
811: my %bighash;
812: # -------------------------------------------------------------------- Tie hash
813: if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
814: &GDBM_READER,0640)) {
815: # --------------------------------------------------------- Get all assessments
816:
817: my %allkeys=();
818: my %allassess=();
819:
820: my $stype=&gettype($safeeval);
821:
822: map {
823: if ($_=~/^src\_(\d+)\.(\d+)$/) {
824: my $mapid=$1;
825: my $resid=$2;
826: my $id=$mapid.'.'.$resid;
827: my $srcf=$bighash{$_};
828: if ($srcf=~/\.(problem|exam|quiz|assess|survey|form)$/) {
829: my $symb=
830: &Apache::lonnet::declutter($bighash{'map_id_'.$mapid}).
831: '___'.$resid.'___'.
832: &Apache::lonnet::declutter($srcf);
833: $allassess{$symb}=$bighash{'title_'.$id};
1.8 www 834:
1.6 www 835: if ($stype eq 'assesscalc') {
1.5 www 836: map {
1.11 www 837: if (($_=~/^stores\_(.*)/) || ($_=~/^parameter\_(.*)/)) {
1.5 www 838: my $key=$_;
839: my $display=
840: &Apache::lonnet::metadata($srcf,$key.'.display');
841: unless ($display) {
842: $display=
843: &Apache::lonnet::metadata($srcf,$key.'.name');
844: }
845: $allkeys{$key}=$display;
846: }
847: } split(/\,/,&Apache::lonnet::metadata($srcf,'keys'));
848: }
849: }
850: }
851: } keys %bighash;
852: untie(%bighash);
853:
854: #
1.11 www 855: # %allkeys has a list of storage and parameter displays by unikey
1.5 www 856: # %allassess has a list of all resource displays by symb
857: #
858: # -------------------- Find discrepancies between the course row table and this
859: #
860: my %f=&getformulas($safeeval);
1.6 www 861: my $changed=0;
862:
863: my %current=();
864: if ($stype eq 'assesscalc') {
865: %current=%allkeys;
866: } elsif ($stype eq 'studentcalc') {
867: %current=%allassess;
868: }
869:
870: my $maxrow=0;
871: my %existing=();
872:
873: # ----------------------------------------------------------- Now obsolete rows
1.5 www 874: map {
1.6 www 875: if ($_=~/^A(\d+)/) {
876: $maxrow=($1>$maxrow)?$1:$maxrow;
877: $existing{$f{$_}}=1;
1.17 www 878: unless ((defined($current{$f{$_}})) || (!$1)) {
1.6 www 879: $f{$_}='!!! Obsolete';
880: $changed=1;
1.5 www 881: }
882: }
883: } keys %f;
1.6 www 884:
885: # -------------------------------------------------------- New and unknown keys
886:
887: map {
888: unless ($existing{$_}) {
889: $changed=1;
890: $maxrow++;
891: $f{'A'.$maxrow}=$_;
892: }
893: } keys %current;
894:
895: if ($changed) { &setformulas($safeeval,%f); }
896:
897: &setmaxrow($safeeval,$maxrow);
898: &setrowlabels($safeeval,%current);
1.5 www 899:
900: } else {
901: return 'Could not access course data';
902: }
903: }
1.3 www 904:
1.16 www 905: # --------------------------------------------------- Load data for one student
906:
907: sub rowazstudent {
908: my $safeeval=shift;
909: my %c=();
910: my %f=&getformulas($safeeval);
911: map {
1.17 www 912: if ($_=~/^A(\d+)/) {
913: my $row=$1;
1.16 www 914: unless ($f{$_}=~/^\!/) {
1.18 www 915: my @assessdata=split(/\_\_\_\;\_\_\_/,
1.17 www 916: &Apache::lonnet::ssi(
1.16 www 917: '/res/msu/korte/junk.assesscalc',('utarget' => 'export',
918: 'uname' => $uname,
919: 'udom' => $udom,
1.17 www 920: 'usymb' => $f{$_})));
921: my $index=0;
922: map {
1.18 www 923: if ($assessdata[$index]) {
924: $c{$_.$row}=$assessdata[$index];
925: unless ($_ eq 'A') {
926: $f{$_.$row}='import';
927: }
928: }
1.17 www 929: $index++;
930: } ('A','B','C','D','E','F','G','H','I','J','K','L','M',
931: 'N','O','P','Q','R','S','T','U','V','W','X','Y','Z');
1.16 www 932: }
933: }
934: } keys %f;
1.18 www 935: &setformulas($safeeval,%f);
1.16 www 936: &setconstants($safeeval,%c);
937: }
938:
1.6 www 939: # ------------------------------------------------ Load data for one assessment
940:
941: sub rowaassess {
1.11 www 942: my ($safeeval,$symb)=@_;
1.6 www 943: my $uhome=&Apache::lonnet::homeserver($uname,$udom);
944: my $namespace;
945: unless ($namespace=$ENV{'request.course.id'}) { return ''; }
1.11 www 946:
947: # ----------------------------------------------------------- Get stored values
948: my $answer=&Apache::lonnet::reply(
1.15 www 949: "restore:$udom:$uname:".
950: &Apache::lonnet::escape($namespace).":".
951: &Apache::lonnet::escape($symb),$uhome);
1.6 www 952: my %returnhash=();
953: map {
954: my ($name,$value)=split(/\=/,$_);
1.11 www 955: $returnhash{&Apache::lonnet::unescape($name)}=
956: &Apache::lonnet::unescape($value);
1.6 www 957: } split(/\&/,$answer);
958: my $version;
959: for ($version=1;$version<=$returnhash{'version'};$version++) {
960: map {
961: $returnhash{$_}=$returnhash{$version.':'.$_};
962: } split(/\:/,$returnhash{$version.':keys'});
963: }
1.11 www 964: # ----------------------------- returnhash now has all stores for this resource
965:
966: # ---------------------------- initialize coursedata and userdata for this user
967: %courseopt=();
968: %useropt=();
969: my $uhome=&Apache::lonnet::homeserver($uname,$udom);
970: unless ($uhome eq 'no_host') {
971: # -------------------------------------------------------------- Get coursedata
1.13 www 972: unless
973: ((time-$courserdatas{$ENV{'request.course.id'}.'.last_cache'})<120) {
1.11 www 974: my $reply=&Apache::lonnet::reply('dump:'.
975: $ENV{'course.'.$ENV{'request.course.id'}.'.domain'}.':'.
976: $ENV{'course.'.$ENV{'request.course.id'}.'.num'}.':resourcedata',
977: $ENV{'course.'.$ENV{'request.course.id'}.'.home'});
978: if ($reply!~/^error\:/) {
979: $courserdatas{$ENV{'request.course.id'}}=$reply;
1.13 www 980: $courserdatas{$ENV{'request.course.id'}.'.last_cache'}=time;
1.11 www 981: }
982: }
983: map {
984: my ($name,$value)=split(/\=/,$_);
985: $courseopt{&Apache::lonnet::unescape($name)}=
986: &Apache::lonnet::unescape($value);
987: } split(/\&/,$courserdatas{$ENV{'request.course.id'}});
988: # --------------------------------------------------- Get userdata (if present)
1.13 www 989: unless
990: ((time-$userrdatas{$uname.'___'.$udom.'.last_cache'})<120) {
1.11 www 991: my $reply=
992: &Apache::lonnet::reply('dump:'.$udom.':'.$uname.':resourcedata',$uhome);
993: if ($reply!~/^error\:/) {
994: $userrdatas{$uname.'___'.$udom}=$reply;
1.13 www 995: $userrdatas{$uname.'___'.$udom.'.last_cache'}=time;
1.11 www 996: }
997: }
998: map {
999: my ($name,$value)=split(/\=/,$_);
1000: $useropt{&Apache::lonnet::unescape($name)}=
1.15 www 1001: &Apache::lonnet::unescape($value);
1.11 www 1002: } split(/\&/,$userrdatas{$uname.'___'.$udom});
1003: }
1004: # -- now courseopt, useropt initialized for this user and course (used parmval)
1.6 www 1005:
1006: my %c=();
1007: my %f=&getformulas($safeeval);
1008: map {
1009: if ($_=~/^A/) {
1010: unless ($f{$_}=~/^\!/) {
1.11 www 1011: if ($f{$_}=~/^parameter/) {
1012: $c{$_}=&parmval($f{$_},$symb);
1013: } else {
1.15 www 1014: my $key=$f{$_};
1015: $key=~s/^stores\_/resource\./;
1016: $key=~s/\_/\./;
1017: $c{$_}=$returnhash{$key};
1.11 www 1018: }
1019: }
1.6 www 1020: }
1021: } keys %f;
1.11 www 1022:
1.6 www 1023: &setconstants($safeeval,%c);
1024: }
1025:
1.10 www 1026: # --------------------------------------------------------- Various form fields
1027:
1028: sub textfield {
1029: my ($title,$name,$value)=@_;
1030: return "\n<p><b>$title:</b><br>".
1031: '<input type=text name="'.$name.'" size=80 value="'.$value.'">';
1032: }
1033:
1034: sub hiddenfield {
1035: my ($name,$value)=@_;
1036: return "\n".'<input type=hidden name="'.$name.'" value="'.$value.'">';
1037: }
1038:
1039: sub selectbox {
1040: my ($title,$name,$value,%options)=@_;
1041: my $selout="\n<p><b>$title:</b><br>".'<select name="'.$name.'">';
1042: map {
1043: $selout.='<option value="'.$_.'"';
1044: if ($_ eq $value) { $selout.=' selected'; }
1045: $selout.='>'.$options{$_}.'</option>';
1046: } sort keys %options;
1047: return $selout.'</select>';
1048: }
1049:
1.12 www 1050: # ================================================================ Main handler
1.3 www 1051:
1052: sub handler {
1.7 www 1053: my $r=shift;
1054:
1.11 www 1055: $uname='';
1056: $udom='';
1057: $csec='';
1058:
1.7 www 1059: if ($r->header_only) {
1060: $r->content_type('text/html');
1061: $r->send_http_header;
1062: return OK;
1063: }
1.3 www 1064:
1.7 www 1065: # ----------------------------------------------------- Needs to be in a course
1.3 www 1066:
1.7 www 1067: if (($ENV{'request.course.fn'}) ||
1068: ($ENV{'request.state'} eq 'construct')) {
1.10 www 1069:
1070: # --------------------------- Get query string for limited number of parameters
1.17 www 1071:
1.10 www 1072: map {
1073: my ($name, $value) = split(/=/,$_);
1074: $value =~ tr/+/ /;
1075: $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
1.19 www 1076: if (($name eq 'uname') || ($name eq 'udom') ||
1077: ($name eq 'usymb') || ($name eq 'ufn')) {
1.10 www 1078: unless ($ENV{'form.'.$name}) {
1079: $ENV{'form.'.$name}=$value;
1080: }
1081: }
1082: } (split(/&/,$ENV{'QUERY_STRING'}));
1083:
1084: # ------------------------------------------- Nothing there? Must be login user
1085: unless ($ENV{'form.uname'}) {
1.11 www 1086: $uname=$ENV{'user.name'};
1087: $udom=$ENV{'user.domain'};
1088: } else {
1089: $uname=$ENV{'form.uname'};
1090: $udom=$ENV{'form.udom'};
1.10 www 1091: }
1.14 www 1092: # ----------------------------------------------------------- Change of target?
1093:
1.16 www 1094: my $reroute=($ENV{'form.utarget'} eq 'export');
1.14 www 1095:
1.10 www 1096: # ------------------------------------------------------------------- Open page
1097:
1.7 www 1098: $r->content_type('text/html');
1.11 www 1099: $r->header_out('Cache-control','no-cache');
1100: $r->header_out('Pragma','no-cache');
1.7 www 1101: $r->send_http_header;
1.3 www 1102:
1.14 www 1103: # --------------------------------------------------------------- Screen output
1104:
1105: unless ($reroute) {
1.10 www 1106: $r->print('<html><head><title>LON-CAPA Spreadsheet</title>');
1107: $r->print(<<ENDSCRIPT);
1108: <script language="JavaScript">
1109:
1110: function celledit(cn,cf) {
1111: var cnf=prompt(cn,cf);
1112: if (cnf!=null) {
1113: document.sheet.unewfield.value=cn;
1114: document.sheet.unewformula.value=cnf;
1115: document.sheet.submit();
1116: }
1117: }
1118:
1119: </script>
1120: ENDSCRIPT
1121: $r->print('</head><body bgcolor="#FFFFFF">'.
1.21 www 1122: '<img align=right src=/adm/lonIcons/lonlogos.gif>'.
1123: '<h1>LON-CAPA Spreadsheet</h1>'.
1.10 www 1124: '<form action="'.$r->uri.'" name=sheet method=post>'.
1125: &hiddenfield('uname',$ENV{'form.uname'}).
1126: &hiddenfield('udom',$ENV{'form.udom'}).
1127: &hiddenfield('usymb',$ENV{'form.usymb'}).
1128: &hiddenfield('unewfield','').
1129: &hiddenfield('unewformula',''));
1.14 www 1130: }
1131:
1132: # ---------------------------------------- Read new sheet or modified worksheet
1133:
1.4 www 1134: my $sheetone=initsheet();
1.19 www 1135: $r->uri=~/\/(\w+)$/;
1136: &settype($sheetone,$1);
1.10 www 1137: if ($ENV{'form.unewfield'}) {
1138: $r->print('<h2>Modified Workcopy</h2>');
1139: $ENV{'form.unewformula'}=~s/\'/\"/g;
1.22 ! www 1140: $r->print('<p>New formula: '.$ENV{'form.unewfield'}.'='.
! 1141: $ENV{'form.unewformula'}.'<p>');
1.19 www 1142: &setfilename($sheetone,$ENV{'form.ufn'});
1.10 www 1143: &tmpread($sheetone,$r->dir_config('lonDaemons').'/tmp/',
1.11 www 1144: $ENV{'form.usymb'},
1.10 www 1145: $ENV{'form.unewfield'},$ENV{'form.unewformula'});
1.22 ! www 1146: } elsif ($ENV{'form.saveas'}) {
! 1147: &setfilename($sheetone,$ENV{'form.ufn'});
! 1148: &tmpread($sheetone,$r->dir_config('lonDaemons').'/tmp/',
! 1149: $ENV{'form.usymb'});
1.11 www 1150: } else {
1.19 www 1151: &readsheet($sheetone,$ENV{'form.ufn'},$r);
1.21 www 1152: $ENV{'form.ufn'}=&getfilename($sheetone);
1.11 www 1153: }
1.14 www 1154:
1155: # --------------------------------------------- See if all import rows uptodate
1156:
1.11 www 1157: if (tie(%parmhash,'GDBM_File',
1158: $ENV{'request.course.fn'}.'_parms.db',&GDBM_READER,0640)) {
1159: $csec=&Apache::lonnet::usection($udom,$uname,$ENV{'request.course.id'});
1160: if ($csec eq '-1') {
1161: $r->print('<h3><font color=red>'.
1162: "User '$uname' at domain '$udom' not a student in this course</font></h3>");
1163: }
1164: &updaterows($sheetone);
1165: untie(%parmhash);
1.10 www 1166: } else {
1.11 www 1167: $r->print('<h3><font color=red>'.
1168: 'Could not initialize import fields (not in a course)</font></h3>');
1169: }
1.22 ! www 1170: # ---------------------------------------------------- See if something to save
! 1171: if (&Apache::lonnet::allowed('opa',$ENV{'request.course.id'})) {
! 1172: my $fname='';
! 1173: if ($ENV{'form.saveas'} && ($fname=$ENV{'form.newfn'})) {
! 1174: $fname=~s/\W/\_/g;
! 1175: if ($fname eq 'default') { $fname='course_default'; }
! 1176: $fname.='_'.&gettype($sheetone);
! 1177: &setfilename($sheetone,$fname);
! 1178: $ENV{'form.ufn'}=$fname;
! 1179: my $reply=&writesheet($sheetone);
! 1180: unless ($reroute) {
! 1181: $r->print('<p>Saving spreadsheet: '.$reply.'<p>');
! 1182: }
! 1183: }
! 1184: }
1.14 www 1185: # ------------------------------------------------ Write the modified worksheet
1186:
1.11 www 1187: &tmpwrite($sheetone,$r->dir_config('lonDaemons').'/tmp/',
1188: $ENV{'form.usymb'});
1.14 www 1189:
1190: # ----------------------------------------------------- Print user, course, etc
1191: unless ($reroute) {
1.22 ! www 1192: if (&Apache::lonnet::allowed('opa',$ENV{'request.course.id'})) {
! 1193: my $fname=$ENV{'form.ufn'};
! 1194: $fname=~s/\_[^\_]+$//;
! 1195: if ($fname eq 'default') { $fname='course_default'; }
! 1196: $r->print('<input type=submit name=saveas value="Save as ...">'.
! 1197: '<input type=text size=20 name=newfn value="'.$fname.'"><p>');
! 1198: }
1.21 www 1199: $r->print(&hiddenfield('ufn',$ENV{'form.ufn'}).
1200: "<b>User '$uname' at domain '$udom' for '".
1.11 www 1201: $ENV{'course.'.$ENV{'request.course.id'}.'.description'}."'");
1202: if ($csec) {
1203: $r->print(", group/section '$csec'");
1204: }
1205: $r->print("</b>\n");
1.14 www 1206: }
1207: # -------------------------------------------------------- Import and calculate
1208:
1.11 www 1209: if (&gettype($sheetone) eq 'assesscalc') {
1210: &rowaassess($sheetone,$ENV{'form.usymb'});
1.16 www 1211: } elsif (&gettype($sheetone) eq 'studentcalc') {
1212: &rowazstudent($sheetone);
1.10 www 1213: }
1.18 www 1214: my $calcoutput=&calcsheet($sheetone);
1215: unless ($reroute) {
1216: $r->print('<h3><font color=red>'.$calcoutput.'</h3></font>');
1217: }
1.14 www 1218:
1219: # ------------------------------------------------------- Print or export sheet
1220: unless ($reroute) {
1.6 www 1221: $r->print(&outsheet($sheetone));
1.8 www 1222:
1.10 www 1223: $r->print('</form></body></html>');
1.14 www 1224: } else {
1.18 www 1225: $r->print(&exportrow($sheetone));
1.14 www 1226: }
1227: # ------------------------------------------------------------------------ Done
1.7 www 1228: } else {
1229: # ----------------------------- Not in a course, or not allowed to modify parms
1230: $ENV{'user.error.msg'}=
1231: $r->uri.":opa:0:0:Cannot modify spreadsheet";
1232: return HTTP_NOT_ACCEPTABLE;
1233: }
1.3 www 1234: return OK;
1.1 www 1235: }
1236:
1237: 1;
1238: __END__
1239:
1240:
1241:
1242:
1243:
1244:
1245:
1246:
1247:
1248:
1249:
1250:
1251:
1252:
1253:
1254:
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