Annotation of loncom/interface/lonspreadsheet.pm, revision 1.20
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.16 www 331: sub outrowassess {
1.6 www 332: my $n=shift;
333: my @cols=();
334: if ($n) {
335: $cols[0]=$rl{$f{'A'.$n}};
336: } else {
337: $cols[0]='<b><font size=+1>Export</font></b>';
338: }
339: map {
340: my $fm=$f{$_.$n};
341: $fm=~s/[\'\"]/\&\#34;/g;
342: $cols[$#cols+1]="'$_$n','$fm'".'___eq___'.$v{$_.$n};
343: } ('A','B','C','D','E','F','G','H','I','J','K','L','M',
1.7 www 344: 'N','O','P','Q','R','S','T','U','V','W','X','Y','Z',
345: 'a','b','c','d','e','f','g','h','i','j','k','l','m',
346: 'n','o','p','q','r','s','t','u','v','w','x','y','z');
1.6 www 347: return @cols;
348: }
349:
1.18 www 350: sub outrow {
351: my $n=shift;
352: my @cols=();
353: if ($n) {
354: $cols[0]=$rl{$f{'A'.$n}}.' stuff';
355: } else {
356: $cols[0]='<b><font size=+1>Export</font></b>';
357: }
358: map {
359: my $fm=$f{$_.$n};
360: $fm=~s/[\'\"]/\&\#34;/g;
361: $cols[$#cols+1]="'$_$n','$fm'".'___eq___'.$v{$_.$n};
362: } ('A','B','C','D','E','F','G','H','I','J','K','L','M',
363: 'N','O','P','Q','R','S','T','U','V','W','X','Y','Z',
364: 'a','b','c','d','e','f','g','h','i','j','k','l','m',
365: 'n','o','p','q','r','s','t','u','v','w','x','y','z');
366: return @cols;
367: }
368:
1.14 www 369: sub exportrowa {
370: my $rowa='';
371: map {
1.18 www 372: $rowa.=$v{$_.'0'}."___;___";
1.14 www 373: } ('A','B','C','D','E','F','G','H','I','J','K','L','M',
374: 'N','O','P','Q','R','S','T','U','V','W','X','Y','Z');
1.18 www 375: $rowa=~s/\_\_\_\;\_\_\_$//;
1.14 www 376: return $rowa;
377: }
378:
1.4 www 379: # ------------------------------------------- End of "Inside of the safe space"
380: ENDDEFS
381: $safeeval->reval($code);
382: return $safeeval;
383: }
384:
385: # ------------------------------------------------ Add or change formula values
386:
387: sub setformulas {
388: my ($safeeval,@f)=@_;
1.6 www 389: $safeeval->reval('%f='."('".join("','",@f)."');");
390: }
391:
392: # ------------------------------------------------ Add or change formula values
393:
394: sub setconstants {
395: my ($safeeval,@c)=@_;
396: $safeeval->reval('%c='."('".join("','",@c)."');");
397: }
398:
399: # ------------------------------------------------ Add or change formula values
400:
401: sub setrowlabels {
402: my ($safeeval,@rl)=@_;
403: $safeeval->reval('%rl='."('".join("','",@rl)."');");
1.4 www 404: }
405:
406: # ------------------------------------------------------- Calculate spreadsheet
407:
408: sub calcsheet {
409: my $safeeval=shift;
410: $safeeval->reval('&calc();');
411: }
412:
413: # ------------------------------------------------------------------ Get values
414:
415: sub getvalues {
416: my $safeeval=shift;
417: return $safeeval->reval('%v');
418: }
419:
420: # ---------------------------------------------------------------- Get formulas
421:
422: sub getformulas {
423: my $safeeval=shift;
424: return $safeeval->reval('%f');
425: }
426:
1.5 www 427: # -------------------------------------------------------------------- Set type
428:
429: sub settype {
430: my ($safeeval,$type)=@_;
1.11 www 431: $safeeval->reval('$sheettype="'.$type.'";');
1.5 www 432: }
433:
434: # -------------------------------------------------------------------- Get type
435:
436: sub gettype {
437: my $safeeval=shift;
438: return $safeeval->reval('$sheettype');
439: }
1.6 www 440: # ------------------------------------------------------------------ Set maxrow
441:
442: sub setmaxrow {
443: my ($safeeval,$row)=@_;
444: $safeeval->reval('$maxrow='.$row.';');
445: }
446:
447: # ------------------------------------------------------------------ Get maxrow
448:
449: sub getmaxrow {
450: my $safeeval=shift;
451: return $safeeval->reval('$maxrow');
452: }
1.5 www 453:
1.6 www 454: # ---------------------------------------------------------------- Set filename
1.5 www 455:
456: sub setfilename {
457: my ($safeeval,$fn)=@_;
1.11 www 458: $safeeval->reval('$filename="'.$fn.'";');
1.5 www 459: }
460:
1.6 www 461: # ---------------------------------------------------------------- Get filename
1.5 www 462:
463: sub getfilename {
464: my $safeeval=shift;
465: return $safeeval->reval('$filename');
466: }
1.14 www 467:
468: # ------------------------------------------------------------- Export of A-row
469:
470: sub exportrow {
471: my $safeeval=shift;
472: return $safeeval->reval('&exportrowa()');
473: }
474:
1.5 www 475: # ========================================================== End of Spreadsheet
476: # =============================================================================
477:
478:
1.6 www 479: # --------------------------------------------- Produce output row n from sheet
480:
481: sub rown {
482: my ($safeeval,$n)=@_;
1.9 www 483: my $defaultbg=((($n-1)/5)==int(($n-1)/5))?'#E0E0':'#FFFF';
1.6 www 484: my $rowdata="\n<tr><td><b><font size=+1>$n</font></b></td>";
485: my $showf=0;
1.16 www 486: my $proc;
1.18 www 487: my $maxred;
1.16 www 488: if (&gettype($safeeval) eq 'assesscalc') {
489: $proc='&outrowassess';
1.18 www 490: $maxred=1;
1.16 www 491: } else {
492: $proc='&outrow';
1.18 www 493: $maxred=26;
1.16 www 494: }
1.6 www 495: map {
1.9 www 496: my $bgcolor=$defaultbg.((($showf-1)/5==int(($showf-1)/5))?'99':'DD');
1.6 www 497: my ($fm,$vl)=split(/\_\_\_eq\_\_\_/,$_);
498: if ($showf==0) { $vl=$_; }
1.18 www 499: if ($showf<=$maxred) { $bgcolor='#FFDDDD'; }
1.9 www 500: if (($n==0) && ($showf<=26)) { $bgcolor='#CCCCFF'; }
1.18 www 501: if (($showf>$maxred) || ((!$n) && ($showf>0))) {
1.6 www 502: if ($vl eq '') {
1.9 www 503: $vl='<font size=+2 color='.$bgcolor.'>#</font>';
1.6 www 504: }
505: $rowdata.=
1.10 www 506: '<td bgcolor='.$bgcolor.'><a href="javascript:celledit('.$fm.');">'.$vl.
1.6 www 507: '</a></td>';
508: } else {
1.9 www 509: $rowdata.='<td bgcolor='.$bgcolor.'> '.$vl.' </td>';
1.6 www 510: }
511: $showf++;
1.16 www 512: } $safeeval->reval($proc.'('.$n.')');
1.6 www 513: return $rowdata.'</tr>';
514: }
515:
516: # ------------------------------------------------------------- Print out sheet
517:
518: sub outsheet {
519: my $safeeval=shift;
1.18 www 520: my $maxred;
521: my $realm;
522: if (&gettype($safeeval) eq 'assesscalc') {
523: $maxred=1;
524: $realm='Assessment';
525: } elsif (&gettype($safeeval) eq 'studentcalc') {
526: $maxred=26;
527: $realm='User';
528: } else {
529: $maxred=26;
530: $realm='Course';
531: }
532: my $maxyellow=52-$maxred;
533: my $tabledata='<table border=2><tr><th colspan=2 rowspan=2><font size=+2>'.
534: $realm.'</font></th>'.
535: '<td bgcolor=#FFDDDD colspan='.$maxred.
536: '><b><font size=+1>Import</font></b></td>'.
537: '<td colspan='.$maxyellow.
538: '><b><font size=+1>Calculations</font></b></td></tr><tr>';
539: my $showf=0;
1.6 www 540: map {
1.18 www 541: $showf++;
542: if ($showf<=$maxred) {
543: $tabledata.='<td bgcolor="#FFDDDD">';
544: } else {
545: $tabledata.='<td>';
546: }
547: $tabledata.="<b><font size=+1>$_</font></b></td>";
548: } ('A','B','C','D','E','F','G','H','I','J','K','L','M',
1.7 www 549: 'N','O','P','Q','R','S','T','U','V','W','X','Y','Z',
550: 'a','b','c','d','e','f','g','h','i','j','k','l','m',
551: 'n','o','p','q','r','s','t','u','v','w','x','y','z');
1.6 www 552: $tabledata.='</tr>';
553: my $row;
554: my $maxrow=&getmaxrow($safeeval);
555: for ($row=0;$row<=$maxrow;$row++) {
556: $tabledata.=&rown($safeeval,$row);
557: }
558: $tabledata.='</table>';
559: }
560:
561:
1.5 www 562:
1.19 www 563: # ------------------------------------- Read spreadsheet formulas from a course
1.3 www 564:
1.5 www 565: sub readsheet {
1.19 www 566: my ($safeeval,$fn,$r)=@_;
1.4 www 567: my %f=();
1.19 www 568: unless ($fn) {
569: my $sheetxml='';
1.10 www 570: {
571: my $fh;
1.19 www 572: if ($fh=Apache::File->new($r->dir_config('lonIncludes').
573: '/default.'.&gettype($safeeval))) {
574: $sheetxml=join('',<$fh>);
575: }
576: }
577: my $parser=HTML::TokeParser->new(\$sheetxml);
578: my $token;
579: while ($token=$parser->get_token) {
580: if ($token->[0] eq 'S') {
581: if ($token->[1] eq 'field') {
582: $f{$token->[2]->{'col'}.$token->[2]->{'row'}}=
583: $parser->get_text('/field');
584: }
1.20 ! www 585: if ($token->[1] eq 'template') {
! 586: $f{'template_'.$token->[2]->{'col'}}=
! 587: $parser->get_text('/template');
! 588: }
1.19 www 589: }
590: }
591: &setfilename($safeeval,'default_'.&gettype($safeeval));
592: } else {
593: &setfilename($safeeval,$fn);
594: unless ($spreadsheets{$fn}) {
595: $spreadsheets{$fn}='';
596: my $reply=&Apache::lonnet::reply('dump:'.
597: $ENV{'course.'.$ENV{'request.course.id'}.'.domain'}.':'.
598: $ENV{'course.'.$ENV{'request.course.id'}.'.num'}.':'.$fn,
599: $ENV{'course.'.$ENV{'request.course.id'}.'.home'});
600: unless ($reply=~/^error\:/) {
601: $spreadsheets{$fn}=$reply;
602: }
1.10 www 603: }
1.19 www 604: map {
605: my ($name,$value)=split(/\=/,$_);
606: $f{&Apache::lonnet::unescape($name)}=
607: &Apache::lonnet::unescape($value);
608: } split(/\&/,$spreadsheets{$fn});
1.3 www 609: }
1.20 ! www 610:
1.5 www 611: &setformulas($safeeval,%f);
1.3 www 612: }
613:
1.19 www 614: # ------------------------------------------------------------ Save spreadsheet
615:
616: sub writesheet {
617: my $safeeval=shift;
618: if (&Apache::lonnet::allowed('opa',$ENV{'request.course.id'})) {
619: my %f=&getformulas($safeeval);
620: my $sheetdata='';
621: map {
622: $sheetdata.=&Apache::lonnet::escape($_).'='.
623: &Apache::lonnet::escape($f{$_}).'&';
624: } keys %f;
625: $sheetdata=~s/\&$//;
626: my $reply=&Apache::lonnet::reply('put:'.
627: $ENV{'course.'.$ENV{'request.course.id'}.'.domain'}.':'.
628: $ENV{'course.'.$ENV{'request.course.id'}.'.num'}.':'.
629: &getfilename($safeeval).':'.
630: $sheetdata,
631: $ENV{'course.'.$ENV{'request.course.id'}.'.home'});
632: }
633: }
634:
1.10 www 635: # ----------------------------------------------- Make a temp copy of the sheet
636:
637: sub tmpwrite {
1.11 www 638: my ($safeeval,$tmpdir,$symb)=@_;
1.10 www 639: my $fn=$uname.'_'.$udom.'_spreadsheet_'.&getfilename($safeeval);
640: $fn=~s/\W/\_/g;
641: $fn=$tmpdir.$fn.'.tmp';
642: my $fh;
643: if ($fh=Apache::File->new('>'.$fn)) {
644: print $fh join("\n",&getformulas($safeeval));
645: }
646: }
647:
648: # ---------------------------------------------------------- Read the temp copy
649:
650: sub tmpread {
1.11 www 651: my ($safeeval,$tmpdir,$symb,$nfield,$nform)=@_;
1.10 www 652: my $fn=$uname.'_'.$udom.'_spreadsheet_'.&getfilename($safeeval);
653: $fn=~s/\W/\_/g;
654: $fn=$tmpdir.$fn.'.tmp';
655: my $fh;
656: my %fo=();
657: if ($fh=Apache::File->new($fn)) {
658: my $name;
659: while ($name=<$fh>) {
660: chomp($name);
661: my $value=<$fh>;
662: chomp($value);
663: $fo{$name}=$value;
664: }
665: }
666: $fo{$nfield}=$nform;
667: &setformulas($safeeval,%fo);
668: }
669:
1.3 www 670: # --------------------------------------------------------------- Read metadata
671:
672: sub readmeta {
673: my $fn=shift;
674: unless ($fn=~/\.meta$/) { $fn.='meta'; }
675: my $content;
676: my %returnhash=();
677: {
678: my $fh=Apache::File->new($fn);
679: $content=join('',<$fh>);
680: }
681: my $parser=HTML::TokeParser->new(\$content);
682: my $token;
683: while ($token=$parser->get_token) {
684: if ($token->[0] eq 'S') {
685: my $entry=$token->[1];
686: if (($entry eq 'stores') || ($entry eq 'parameter')) {
687: my $unikey=$entry;
688: $unikey.='_'.$token->[2]->{'part'};
689: $unikey.='_'.$token->[2]->{'name'};
690: $returnhash{$unikey}=$token->[2]->{'display'};
691: }
692: }
693: }
694: return %returnhash;
695: }
696:
1.11 www 697: # ================================================================== Parameters
698: # -------------------------------------------- Figure out a cascading parameter
699:
700: sub parmval {
701: my ($what,$symb)=@_;
702:
703: unless ($symb) { return ''; }
704: my $result='';
705:
706: my ($mapname,$id,$fn)=split(/\_\_\_/,$symb);
707: # ----------------------------------------------------- Cascading lookup scheme
1.12 www 708: my $rwhat=$what;
709: $what=~s/^parameter\_//;
710: $what=~s/\_/\./;
1.11 www 711:
712: my $symbparm=$symb.'.'.$what;
713: my $mapparm=$mapname.'___(all).'.$what;
714:
715: my $seclevel=
716: $ENV{'request.course.id'}.'.['.
717: $csec.'].'.$what;
718: my $seclevelr=
719: $ENV{'request.course.id'}.'.['.
720: $csec.'].'.$symbparm;
721: my $seclevelm=
722: $ENV{'request.course.id'}.'.['.
723: $csec.'].'.$mapparm;
724:
725: my $courselevel=
726: $ENV{'request.course.id'}.'.'.$what;
727: my $courselevelr=
728: $ENV{'request.course.id'}.'.'.$symbparm;
729: my $courselevelm=
730: $ENV{'request.course.id'}.'.'.$mapparm;
1.12 www 731:
1.11 www 732: # ---------------------------------------------------------- fourth, check user
733:
734: if ($uname) {
735:
736: if ($useropt{$courselevelr}) { return $useropt{$courselevelr}; }
737:
738: if ($useropt{$courselevelm}) { return $useropt{$courselevelm}; }
739:
740: if ($useropt{$courselevel}) { return $useropt{$courselevel}; }
741:
742: }
743:
744: # --------------------------------------------------------- third, check course
745:
746: if ($csec) {
747:
748: if ($courseopt{$seclevelr}) { return $courseopt{$seclevelr}; }
749:
750: if ($courseopt{$seclevelm}) { return $courseopt{$seclevelm}; }
751:
752: if ($courseopt{$seclevel}) { return $courseopt{$seclevel}; }
753:
754: }
755:
756: if ($courseopt{$courselevelr}) { return $courseopt{$courselevelr}; }
757:
758: if ($courseopt{$courselevelm}) { return $courseopt{$courselevelm}; }
759:
760: if ($courseopt{$courselevel}) { return $courseopt{$courselevel}; }
761:
762: # ----------------------------------------------------- second, check map parms
763:
764: my $thisparm=$parmhash{$symbparm};
765: if ($thisparm) { return $thisparm; }
766:
767: # -------------------------------------------------------- first, check default
768:
1.12 www 769: return &Apache::lonnet::metadata($fn,$rwhat.'.default');
1.11 www 770:
771: }
772:
773:
1.5 www 774: # ----------------------------------------------------------------- Update rows
775:
776: sub updaterows {
777: my $safeeval=shift;
778: my %bighash;
779: # -------------------------------------------------------------------- Tie hash
780: if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
781: &GDBM_READER,0640)) {
782: # --------------------------------------------------------- Get all assessments
783:
784: my %allkeys=();
785: my %allassess=();
786:
787: my $stype=&gettype($safeeval);
788:
789: map {
790: if ($_=~/^src\_(\d+)\.(\d+)$/) {
791: my $mapid=$1;
792: my $resid=$2;
793: my $id=$mapid.'.'.$resid;
794: my $srcf=$bighash{$_};
795: if ($srcf=~/\.(problem|exam|quiz|assess|survey|form)$/) {
796: my $symb=
797: &Apache::lonnet::declutter($bighash{'map_id_'.$mapid}).
798: '___'.$resid.'___'.
799: &Apache::lonnet::declutter($srcf);
800: $allassess{$symb}=$bighash{'title_'.$id};
1.8 www 801:
1.6 www 802: if ($stype eq 'assesscalc') {
1.5 www 803: map {
1.11 www 804: if (($_=~/^stores\_(.*)/) || ($_=~/^parameter\_(.*)/)) {
1.5 www 805: my $key=$_;
806: my $display=
807: &Apache::lonnet::metadata($srcf,$key.'.display');
808: unless ($display) {
809: $display=
810: &Apache::lonnet::metadata($srcf,$key.'.name');
811: }
812: $allkeys{$key}=$display;
813: }
814: } split(/\,/,&Apache::lonnet::metadata($srcf,'keys'));
815: }
816: }
817: }
818: } keys %bighash;
819: untie(%bighash);
820:
821: #
1.11 www 822: # %allkeys has a list of storage and parameter displays by unikey
1.5 www 823: # %allassess has a list of all resource displays by symb
824: #
825: # -------------------- Find discrepancies between the course row table and this
826: #
827: my %f=&getformulas($safeeval);
1.6 www 828: my $changed=0;
829:
830: my %current=();
831: if ($stype eq 'assesscalc') {
832: %current=%allkeys;
833: } elsif ($stype eq 'studentcalc') {
834: %current=%allassess;
835: }
836:
837: my $maxrow=0;
838: my %existing=();
839:
840: # ----------------------------------------------------------- Now obsolete rows
1.5 www 841: map {
1.6 www 842: if ($_=~/^A(\d+)/) {
843: $maxrow=($1>$maxrow)?$1:$maxrow;
844: $existing{$f{$_}}=1;
1.17 www 845: unless ((defined($current{$f{$_}})) || (!$1)) {
1.6 www 846: $f{$_}='!!! Obsolete';
847: $changed=1;
1.5 www 848: }
849: }
850: } keys %f;
1.6 www 851:
852: # -------------------------------------------------------- New and unknown keys
853:
854: map {
855: unless ($existing{$_}) {
856: $changed=1;
857: $maxrow++;
858: $f{'A'.$maxrow}=$_;
859: }
860: } keys %current;
861:
862: if ($changed) { &setformulas($safeeval,%f); }
863:
864: &setmaxrow($safeeval,$maxrow);
865: &setrowlabels($safeeval,%current);
1.5 www 866:
867: } else {
868: return 'Could not access course data';
869: }
870: }
1.3 www 871:
1.16 www 872: # --------------------------------------------------- Load data for one student
873:
874: sub rowazstudent {
875: my $safeeval=shift;
876: my %c=();
877: my %f=&getformulas($safeeval);
878: map {
1.17 www 879: if ($_=~/^A(\d+)/) {
880: my $row=$1;
1.16 www 881: unless ($f{$_}=~/^\!/) {
1.18 www 882: my @assessdata=split(/\_\_\_\;\_\_\_/,
1.17 www 883: &Apache::lonnet::ssi(
1.16 www 884: '/res/msu/korte/junk.assesscalc',('utarget' => 'export',
885: 'uname' => $uname,
886: 'udom' => $udom,
1.17 www 887: 'usymb' => $f{$_})));
888: my $index=0;
889: map {
1.18 www 890: if ($assessdata[$index]) {
891: $c{$_.$row}=$assessdata[$index];
892: unless ($_ eq 'A') {
893: $f{$_.$row}='import';
894: }
895: }
1.17 www 896: $index++;
897: } ('A','B','C','D','E','F','G','H','I','J','K','L','M',
898: 'N','O','P','Q','R','S','T','U','V','W','X','Y','Z');
1.16 www 899: }
900: }
901: } keys %f;
1.18 www 902: &setformulas($safeeval,%f);
1.16 www 903: &setconstants($safeeval,%c);
904: }
905:
1.6 www 906: # ------------------------------------------------ Load data for one assessment
907:
908: sub rowaassess {
1.11 www 909: my ($safeeval,$symb)=@_;
1.6 www 910: my $uhome=&Apache::lonnet::homeserver($uname,$udom);
911: my $namespace;
912: unless ($namespace=$ENV{'request.course.id'}) { return ''; }
1.11 www 913:
914: # ----------------------------------------------------------- Get stored values
915: my $answer=&Apache::lonnet::reply(
1.15 www 916: "restore:$udom:$uname:".
917: &Apache::lonnet::escape($namespace).":".
918: &Apache::lonnet::escape($symb),$uhome);
1.6 www 919: my %returnhash=();
920: map {
921: my ($name,$value)=split(/\=/,$_);
1.11 www 922: $returnhash{&Apache::lonnet::unescape($name)}=
923: &Apache::lonnet::unescape($value);
1.6 www 924: } split(/\&/,$answer);
925: my $version;
926: for ($version=1;$version<=$returnhash{'version'};$version++) {
927: map {
928: $returnhash{$_}=$returnhash{$version.':'.$_};
929: } split(/\:/,$returnhash{$version.':keys'});
930: }
1.11 www 931: # ----------------------------- returnhash now has all stores for this resource
932:
933: # ---------------------------- initialize coursedata and userdata for this user
934: %courseopt=();
935: %useropt=();
936: my $uhome=&Apache::lonnet::homeserver($uname,$udom);
937: unless ($uhome eq 'no_host') {
938: # -------------------------------------------------------------- Get coursedata
1.13 www 939: unless
940: ((time-$courserdatas{$ENV{'request.course.id'}.'.last_cache'})<120) {
1.11 www 941: my $reply=&Apache::lonnet::reply('dump:'.
942: $ENV{'course.'.$ENV{'request.course.id'}.'.domain'}.':'.
943: $ENV{'course.'.$ENV{'request.course.id'}.'.num'}.':resourcedata',
944: $ENV{'course.'.$ENV{'request.course.id'}.'.home'});
945: if ($reply!~/^error\:/) {
946: $courserdatas{$ENV{'request.course.id'}}=$reply;
1.13 www 947: $courserdatas{$ENV{'request.course.id'}.'.last_cache'}=time;
1.11 www 948: }
949: }
950: map {
951: my ($name,$value)=split(/\=/,$_);
952: $courseopt{&Apache::lonnet::unescape($name)}=
953: &Apache::lonnet::unescape($value);
954: } split(/\&/,$courserdatas{$ENV{'request.course.id'}});
955: # --------------------------------------------------- Get userdata (if present)
1.13 www 956: unless
957: ((time-$userrdatas{$uname.'___'.$udom.'.last_cache'})<120) {
1.11 www 958: my $reply=
959: &Apache::lonnet::reply('dump:'.$udom.':'.$uname.':resourcedata',$uhome);
960: if ($reply!~/^error\:/) {
961: $userrdatas{$uname.'___'.$udom}=$reply;
1.13 www 962: $userrdatas{$uname.'___'.$udom.'.last_cache'}=time;
1.11 www 963: }
964: }
965: map {
966: my ($name,$value)=split(/\=/,$_);
967: $useropt{&Apache::lonnet::unescape($name)}=
1.15 www 968: &Apache::lonnet::unescape($value);
1.11 www 969: } split(/\&/,$userrdatas{$uname.'___'.$udom});
970: }
971: # -- now courseopt, useropt initialized for this user and course (used parmval)
1.6 www 972:
973: my %c=();
974: my %f=&getformulas($safeeval);
975: map {
976: if ($_=~/^A/) {
977: unless ($f{$_}=~/^\!/) {
1.11 www 978: if ($f{$_}=~/^parameter/) {
979: $c{$_}=&parmval($f{$_},$symb);
980: } else {
1.15 www 981: my $key=$f{$_};
982: $key=~s/^stores\_/resource\./;
983: $key=~s/\_/\./;
984: $c{$_}=$returnhash{$key};
1.11 www 985: }
986: }
1.6 www 987: }
988: } keys %f;
1.11 www 989:
1.6 www 990: &setconstants($safeeval,%c);
991: }
992:
1.10 www 993: # --------------------------------------------------------- Various form fields
994:
995: sub textfield {
996: my ($title,$name,$value)=@_;
997: return "\n<p><b>$title:</b><br>".
998: '<input type=text name="'.$name.'" size=80 value="'.$value.'">';
999: }
1000:
1001: sub hiddenfield {
1002: my ($name,$value)=@_;
1003: return "\n".'<input type=hidden name="'.$name.'" value="'.$value.'">';
1004: }
1005:
1006: sub selectbox {
1007: my ($title,$name,$value,%options)=@_;
1008: my $selout="\n<p><b>$title:</b><br>".'<select name="'.$name.'">';
1009: map {
1010: $selout.='<option value="'.$_.'"';
1011: if ($_ eq $value) { $selout.=' selected'; }
1012: $selout.='>'.$options{$_}.'</option>';
1013: } sort keys %options;
1014: return $selout.'</select>';
1015: }
1016:
1.12 www 1017: # ================================================================ Main handler
1.3 www 1018:
1019: sub handler {
1.7 www 1020: my $r=shift;
1021:
1.11 www 1022: $uname='';
1023: $udom='';
1024: $csec='';
1025:
1.7 www 1026: if ($r->header_only) {
1027: $r->content_type('text/html');
1028: $r->send_http_header;
1029: return OK;
1030: }
1.3 www 1031:
1.7 www 1032: # ----------------------------------------------------- Needs to be in a course
1.3 www 1033:
1.7 www 1034: if (($ENV{'request.course.fn'}) ||
1035: ($ENV{'request.state'} eq 'construct')) {
1.10 www 1036:
1037: # --------------------------- Get query string for limited number of parameters
1.17 www 1038:
1.10 www 1039: map {
1040: my ($name, $value) = split(/=/,$_);
1041: $value =~ tr/+/ /;
1042: $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
1.19 www 1043: if (($name eq 'uname') || ($name eq 'udom') ||
1044: ($name eq 'usymb') || ($name eq 'ufn')) {
1.10 www 1045: unless ($ENV{'form.'.$name}) {
1046: $ENV{'form.'.$name}=$value;
1047: }
1048: }
1049: } (split(/&/,$ENV{'QUERY_STRING'}));
1050:
1051: # ------------------------------------------- Nothing there? Must be login user
1052: unless ($ENV{'form.uname'}) {
1.11 www 1053: $uname=$ENV{'user.name'};
1054: $udom=$ENV{'user.domain'};
1055: } else {
1056: $uname=$ENV{'form.uname'};
1057: $udom=$ENV{'form.udom'};
1.10 www 1058: }
1.14 www 1059: # ----------------------------------------------------------- Change of target?
1060:
1.16 www 1061: my $reroute=($ENV{'form.utarget'} eq 'export');
1.14 www 1062:
1.10 www 1063: # ------------------------------------------------------------------- Open page
1064:
1.7 www 1065: $r->content_type('text/html');
1.11 www 1066: $r->header_out('Cache-control','no-cache');
1067: $r->header_out('Pragma','no-cache');
1.7 www 1068: $r->send_http_header;
1.3 www 1069:
1.14 www 1070: # --------------------------------------------------------------- Screen output
1071:
1072: unless ($reroute) {
1.10 www 1073: $r->print('<html><head><title>LON-CAPA Spreadsheet</title>');
1074: $r->print(<<ENDSCRIPT);
1075: <script language="JavaScript">
1076:
1077: function celledit(cn,cf) {
1078: var cnf=prompt(cn,cf);
1079: if (cnf!=null) {
1080: document.sheet.unewfield.value=cn;
1081: document.sheet.unewformula.value=cnf;
1082: document.sheet.submit();
1083: }
1084: }
1085:
1086: </script>
1087: ENDSCRIPT
1088: $r->print('</head><body bgcolor="#FFFFFF">'.
1089: '<form action="'.$r->uri.'" name=sheet method=post>'.
1090: &hiddenfield('uname',$ENV{'form.uname'}).
1091: &hiddenfield('udom',$ENV{'form.udom'}).
1092: &hiddenfield('usymb',$ENV{'form.usymb'}).
1.19 www 1093: &hiddenfield('ufn',$ENV{'form.ufn'}).
1.10 www 1094: &hiddenfield('unewfield','').
1095: &hiddenfield('unewformula',''));
1.14 www 1096: }
1097:
1098: # ---------------------------------------- Read new sheet or modified worksheet
1099:
1.4 www 1100: my $sheetone=initsheet();
1.19 www 1101: $r->uri=~/\/(\w+)$/;
1102: &settype($sheetone,$1);
1.10 www 1103: if ($ENV{'form.unewfield'}) {
1104: $r->print('<h2>Modified Workcopy</h2>');
1105: $ENV{'form.unewformula'}=~s/\'/\"/g;
1106: $r->print('New formula: '.$ENV{'form.unewfield'}.'='.
1107: $ENV{'form.unewformula'}.'<br>');
1.19 www 1108: &setfilename($sheetone,$ENV{'form.ufn'});
1.10 www 1109: &tmpread($sheetone,$r->dir_config('lonDaemons').'/tmp/',
1.11 www 1110: $ENV{'form.usymb'},
1.10 www 1111: $ENV{'form.unewfield'},$ENV{'form.unewformula'});
1.11 www 1112: } else {
1.19 www 1113: &readsheet($sheetone,$ENV{'form.ufn'},$r);
1.11 www 1114: }
1.14 www 1115:
1116: # --------------------------------------------- See if all import rows uptodate
1117:
1.11 www 1118: if (tie(%parmhash,'GDBM_File',
1119: $ENV{'request.course.fn'}.'_parms.db',&GDBM_READER,0640)) {
1120: $csec=&Apache::lonnet::usection($udom,$uname,$ENV{'request.course.id'});
1121: if ($csec eq '-1') {
1122: $r->print('<h3><font color=red>'.
1123: "User '$uname' at domain '$udom' not a student in this course</font></h3>");
1124: }
1125: &updaterows($sheetone);
1126: untie(%parmhash);
1.10 www 1127: } else {
1.11 www 1128: $r->print('<h3><font color=red>'.
1129: 'Could not initialize import fields (not in a course)</font></h3>');
1130: }
1.14 www 1131:
1132: # ------------------------------------------------ Write the modified worksheet
1133:
1.11 www 1134: &tmpwrite($sheetone,$r->dir_config('lonDaemons').'/tmp/',
1135: $ENV{'form.usymb'});
1.14 www 1136:
1137: # ----------------------------------------------------- Print user, course, etc
1138: unless ($reroute) {
1.11 www 1139: $r->print("<b>User '$uname' at domain '$udom' for '".
1140: $ENV{'course.'.$ENV{'request.course.id'}.'.description'}."'");
1141: if ($csec) {
1142: $r->print(", group/section '$csec'");
1143: }
1144: $r->print("</b>\n");
1.14 www 1145: }
1146: # -------------------------------------------------------- Import and calculate
1147:
1.11 www 1148: if (&gettype($sheetone) eq 'assesscalc') {
1149: &rowaassess($sheetone,$ENV{'form.usymb'});
1.16 www 1150: } elsif (&gettype($sheetone) eq 'studentcalc') {
1151: &rowazstudent($sheetone);
1.10 www 1152: }
1.18 www 1153: my $calcoutput=&calcsheet($sheetone);
1154: unless ($reroute) {
1155: $r->print('<h3><font color=red>'.$calcoutput.'</h3></font>');
1156: }
1.14 www 1157:
1158: # ------------------------------------------------------- Print or export sheet
1159: unless ($reroute) {
1.6 www 1160: $r->print(&outsheet($sheetone));
1.8 www 1161:
1.10 www 1162: $r->print('</form></body></html>');
1.14 www 1163: } else {
1.18 www 1164: $r->print(&exportrow($sheetone));
1.14 www 1165: }
1166: # ------------------------------------------------------------------------ Done
1.7 www 1167: } else {
1168: # ----------------------------- Not in a course, or not allowed to modify parms
1169: $ENV{'user.error.msg'}=
1170: $r->uri.":opa:0:0:Cannot modify spreadsheet";
1171: return HTTP_NOT_ACCEPTABLE;
1172: }
1.3 www 1173: return OK;
1.1 www 1174: }
1175:
1176: 1;
1177: __END__
1178:
1179:
1180:
1181:
1182:
1183:
1184:
1185:
1186:
1187:
1188:
1189:
1190:
1191:
1192:
1193:
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