Annotation of loncom/interface/lonspreadsheet.pm, revision 1.8
1.1 www 1: # The LearningOnline Network with CAPA
2: # Spreadsheet/Grades Display Handler
3: #
1.8 ! www 4: # 11/11,11/15,11/27,12/04,12/05,12/06,12/07 Gerd Kortemeyer
1.1 www 5:
6: package Apache::lonspreadsheet;
7:
8: use strict;
9: use Safe;
1.3 www 10: use Safe::Hole;
1.1 www 11: use Opcode;
12: use Apache::lonnet;
1.7 www 13: use Apache::Constants qw(:common :http);
1.3 www 14: use HTML::TokeParser;
1.6 www 15: use GDBM_File;
1.3 www 16:
1.5 www 17: # =============================================================================
18: # ===================================== Implements an instance of a spreadsheet
1.4 www 19:
20: sub initsheet {
21: my $safeeval = new Safe;
22: my $safehole = new Safe::Hole;
23: $safeeval->permit("entereval");
24: $safeeval->permit(":base_math");
25: $safeeval->permit("sort");
26: $safeeval->deny(":base_io");
27: $safehole->wrap(\&Apache::lonnet::EXT,$safeeval,'&EXT');
28: my $code=<<'ENDDEFS';
29: # ---------------------------------------------------- Inside of the safe space
30:
1.3 www 31: #
32: # f: formulas
1.4 www 33: # t: intermediate format (variable references expanded)
34: # v: output values
1.6 www 35: # c: preloaded constants (A-column)
36: # rl: row label
1.3 www 37:
1.4 www 38: %v=();
39: %t=();
40: %f=();
1.6 www 41: %c=();
42: %rl=();
43:
44: $maxrow=0;
1.5 www 45: $sheettype='';
46: $filename='';
1.1 www 47:
48: sub mask {
49: my ($lower,$upper)=@_;
50:
1.7 www 51: $lower=~/([A-Za-z]|\*)(\d+|\*)/;
1.1 www 52: my $la=$1;
53: my $ld=$2;
54:
1.7 www 55: $upper=~/([A-Za-z]|\*)(\d+|\*)/;
1.1 www 56: my $ua=$1;
57: my $ud=$2;
58: my $alpha='';
59: my $num='';
60:
61: if (($la eq '*') || ($ua eq '*')) {
1.7 www 62: $alpha='[A-Za-z]';
1.1 www 63: } else {
1.7 www 64: if (($la=~/[A-Z]/) && ($ua=~/[A-Z]/) ||
65: ($la=~/[a-z]/) && ($ua=~/[a-z]/)) {
66: $alpha='['.$la.'-'.$ua.']';
67: } else {
68: $alpha='['.$la.'-Za-'.$ua.']';
69: }
1.1 www 70: }
71:
72: if (($ld eq '*') || ($ud eq '*')) {
73: $num='\d+';
74: } else {
75: if (length($ld)!=length($ud)) {
76: $num.='(';
77: map {
78: $num.='['.$_.'-9]';
79: } ($ld=~m/\d/g);
80: if (length($ud)-length($ld)>1) {
81: $num.='|\d{'.(length($ld)+1).','.(length($ud)-1).'}';
82: }
83: $num.='|';
84: map {
85: $num.='[0-'.$_.']';
86: } ($ud=~m/\d/g);
87: $num.=')';
88: } else {
89: my @lda=($ld=~m/\d/g);
90: my @uda=($ud=~m/\d/g);
1.7 www 91: my $i; $j=0; $notdone=1;
92: for ($i=0;($i<=$#lda)&&($notdone);$i++) {
1.1 www 93: if ($lda[$i]==$uda[$i]) {
94: $num.=$lda[$i];
95: $j=$i;
1.7 www 96: } else {
97: $notdone=0;
1.1 www 98: }
99: }
100: if ($j<$#lda-1) {
101: $num.='('.$lda[$j+1];
102: for ($i=$j+2;$i<=$#lda;$i++) {
103: $num.='['.$lda[$i].'-9]';
104: }
105: if ($uda[$j+1]-$lda[$j+1]>1) {
106: $num.='|['.($lda[$j+1]+1).'-'.($uda[$j+1]-1).']\d{'.
107: ($#lda-$j-1).'}';
108: }
109: $num.='|'.$uda[$j+1];
110: for ($i=$j+2;$i<=$#uda;$i++) {
111: $num.='[0-'.$uda[$i].']';
112: }
113: $num.=')';
114: } else {
1.7 www 115: if ($lda[$#lda]!=$uda[$#uda]) {
116: $num.='['.$lda[$#lda].'-'.$uda[$#uda].']';
117: }
1.1 www 118: }
119: }
120: }
1.4 www 121: return '^'.$alpha.$num."\$";
1.1 www 122: }
123:
124: sub NUM {
125: my $mask=mask(@_);
126: my $num=0;
127: map {
128: $num++;
129: } grep /$mask/,keys %v;
130: return $num;
131: }
132:
133: sub BIN {
134: my ($low,$high,$lower,$upper)=@_;
135: my $mask=mask($lower,$upper);
136: my $num=0;
137: map {
138: if (($v{$_}>=$low) && ($v{$_}<=$high)) {
139: $num++;
140: }
141: } grep /$mask/,keys %v;
142: return $num;
143: }
144:
145:
146: sub SUM {
147: my $mask=mask(@_);
148: my $sum=0;
149: map {
150: $sum+=$v{$_};
151: } grep /$mask/,keys %v;
152: return $sum;
153: }
154:
155: sub MEAN {
156: my $mask=mask(@_);
157: my $sum=0; my $num=0;
158: map {
159: $sum+=$v{$_};
160: $num++;
161: } grep /$mask/,keys %v;
162: if ($num) {
163: return $sum/$num;
164: } else {
165: return undef;
166: }
167: }
168:
169: sub STDDEV {
170: my $mask=mask(@_);
171: my $sum=0; my $num=0;
172: map {
173: $sum+=$v{$_};
174: $num++;
175: } grep /$mask/,keys %v;
176: unless ($num>1) { return undef; }
177: my $mean=$sum/$num;
178: $sum=0;
179: map {
180: $sum+=($v{$_}-$mean)**2;
181: } grep /$mask/,keys %v;
182: return sqrt($sum/($num-1));
183: }
184:
185: sub PROD {
186: my $mask=mask(@_);
187: my $prod=1;
188: map {
189: $prod*=$v{$_};
190: } grep /$mask/,keys %v;
191: return $prod;
192: }
193:
194: sub MAX {
195: my $mask=mask(@_);
196: my $max='-';
197: map {
198: unless ($max) { $max=$v{$_}; }
199: if (($v{$_}>$max) || ($max eq '-')) { $max=$v{$_}; }
200: } grep /$mask/,keys %v;
201: return $max;
202: }
203:
204: sub MIN {
205: my $mask=mask(@_);
206: my $min='-';
207: map {
208: unless ($max) { $max=$v{$_}; }
209: if (($v{$_}<$min) || ($min eq '-')) { $min=$v{$_}; }
210: } grep /$mask/,keys %v;
211: return $min;
212: }
213:
214: sub SUMMAX {
215: my ($num,$lower,$upper)=@_;
216: my $mask=mask($lower,$upper);
217: my @inside=();
218: map {
219: $inside[$#inside+1]=$v{$_};
220: } grep /$mask/,keys %v;
221: @inside=sort(@inside);
222: my $sum=0; my $i;
223: for ($i=$#inside;(($i>$#inside-$num) && ($i>=0));$i--) {
224: $sum+=$inside[$i];
225: }
226: return $sum;
227: }
228:
229: sub SUMMIN {
230: my ($num,$lower,$upper)=@_;
231: my $mask=mask($lower,$upper);
232: my @inside=();
233: map {
234: $inside[$#inside+1]=$v{$_};
235: } grep /$mask/,keys %v;
236: @inside=sort(@inside);
237: my $sum=0; my $i;
238: for ($i=0;(($i<$num) && ($i<=$#inside));$i++) {
239: $sum+=$inside[$i];
240: }
241: return $sum;
242: }
243:
244: sub sett {
245: %t=();
246: map {
247: if ($f{$_}) {
1.6 www 248: if ($_=~/^A/) {
249: unless ($f{$_}=~/^\!/) {
250: $t{$_}=$c{$_};
251: }
252: } else {
253: $t{$_}=$f{$_};
1.7 www 254: $t{$_}=~s/\.\.+/\,/g;
255: $t{$_}=~s/(^|[^\"\'])([A-Za-z]\d+)/$1\$v\{\'$2\'\}/g;
1.6 www 256: }
1.1 www 257: }
258: } keys %f;
259: }
260:
1.4 www 261: sub calc {
1.1 www 262: %v=();
1.4 www 263: &sett();
1.1 www 264: my $notfinished=1;
265: my $depth=0;
266: while ($notfinished) {
267: $notfinished=0;
268: map {
269: my $old=$v{$_};
1.4 www 270: $v{$_}=eval($t{$_});
1.1 www 271: if ($@) {
272: %v=();
273: return $@;
274: }
275: if ($v{$_} ne $old) { $notfinished=1; }
276: } keys %t;
277: $depth++;
278: if ($depth>100) {
279: %v=();
280: return 'Maximum calculation depth exceeded';
281: }
282: }
283: return '';
284: }
285:
1.6 www 286: sub outrow {
287: my $n=shift;
288: my @cols=();
289: if ($n) {
290: $cols[0]=$rl{$f{'A'.$n}};
291: } else {
292: $cols[0]='<b><font size=+1>Export</font></b>';
293: }
294: map {
295: my $fm=$f{$_.$n};
296: $fm=~s/[\'\"]/\&\#34;/g;
297: $cols[$#cols+1]="'$_$n','$fm'".'___eq___'.$v{$_.$n};
298: } ('A','B','C','D','E','F','G','H','I','J','K','L','M',
1.7 www 299: 'N','O','P','Q','R','S','T','U','V','W','X','Y','Z',
300: 'a','b','c','d','e','f','g','h','i','j','k','l','m',
301: 'n','o','p','q','r','s','t','u','v','w','x','y','z');
1.6 www 302: return @cols;
303: }
304:
1.4 www 305: # ------------------------------------------- End of "Inside of the safe space"
306: ENDDEFS
307: $safeeval->reval($code);
308: return $safeeval;
309: }
310:
311: # ------------------------------------------------ Add or change formula values
312:
313: sub setformulas {
314: my ($safeeval,@f)=@_;
1.6 www 315: $safeeval->reval('%f='."('".join("','",@f)."');");
316: }
317:
318: # ------------------------------------------------ Add or change formula values
319:
320: sub setconstants {
321: my ($safeeval,@c)=@_;
322: $safeeval->reval('%c='."('".join("','",@c)."');");
323: }
324:
325: # ------------------------------------------------ Add or change formula values
326:
327: sub setrowlabels {
328: my ($safeeval,@rl)=@_;
329: $safeeval->reval('%rl='."('".join("','",@rl)."');");
1.4 www 330: }
331:
332: # ------------------------------------------------------- Calculate spreadsheet
333:
334: sub calcsheet {
335: my $safeeval=shift;
336: $safeeval->reval('&calc();');
337: }
338:
339: # ------------------------------------------------------------------ Get values
340:
341: sub getvalues {
342: my $safeeval=shift;
343: return $safeeval->reval('%v');
344: }
345:
346: # ---------------------------------------------------------------- Get formulas
347:
348: sub getformulas {
349: my $safeeval=shift;
350: return $safeeval->reval('%f');
351: }
352:
1.5 www 353: # -------------------------------------------------------------------- Set type
354:
355: sub settype {
356: my ($safeeval,$type)=@_;
357: $safeeval->reval('$sheettype='.$type.';');
358: }
359:
360: # -------------------------------------------------------------------- Get type
361:
362: sub gettype {
363: my $safeeval=shift;
364: return $safeeval->reval('$sheettype');
365: }
1.6 www 366: # ------------------------------------------------------------------ Set maxrow
367:
368: sub setmaxrow {
369: my ($safeeval,$row)=@_;
370: $safeeval->reval('$maxrow='.$row.';');
371: }
372:
373: # ------------------------------------------------------------------ Get maxrow
374:
375: sub getmaxrow {
376: my $safeeval=shift;
377: return $safeeval->reval('$maxrow');
378: }
1.5 www 379:
1.6 www 380: # ---------------------------------------------------------------- Set filename
1.5 www 381:
382: sub setfilename {
383: my ($safeeval,$fn)=@_;
384: $safeeval->reval('$filename='.$fn.';');
385: }
386:
1.6 www 387: # ---------------------------------------------------------------- Get filename
1.5 www 388:
389: sub getfilename {
390: my $safeeval=shift;
391: return $safeeval->reval('$filename');
392: }
393:
394: # ========================================================== End of Spreadsheet
395: # =============================================================================
396:
397:
1.6 www 398: # --------------------------------------------- Produce output row n from sheet
399:
400: sub rown {
401: my ($safeeval,$n)=@_;
402: my $rowdata="\n<tr><td><b><font size=+1>$n</font></b></td>";
403: my $showf=0;
404: map {
405: my ($fm,$vl)=split(/\_\_\_eq\_\_\_/,$_);
406: if ($showf==0) { $vl=$_; }
407: if ($showf>1) {
408: if ($vl eq '') {
409: $vl='<font size=+2 color=white>#</font>';
410: }
411: $rowdata.=
412: '<td><a href="javascript:prompt('.$fm.');">'.$vl.
413: '</a></td>';
414: } else {
415: $rowdata.='<td> '.$vl.' </td>';
416: }
417: $showf++;
418: } $safeeval->reval('&outrow('.$n.')');
419: return $rowdata.'</tr>';
420: }
421:
422: # ------------------------------------------------------------- Print out sheet
423:
424: sub outsheet {
425: my $safeeval=shift;
426: my $tabledata='<table border=2><tr><td colspan=2> </td>';
427: map {
428: $tabledata.="<td><b><font size=+1>$_</font></b></td>";
429: } ('A<br>Import','B','C','D','E','F','G','H','I','J','K','L','M',
1.7 www 430: 'N','O','P','Q','R','S','T','U','V','W','X','Y','Z',
431: 'a','b','c','d','e','f','g','h','i','j','k','l','m',
432: 'n','o','p','q','r','s','t','u','v','w','x','y','z');
1.6 www 433: $tabledata.='</tr>';
434: my $row;
435: my $maxrow=&getmaxrow($safeeval);
436: for ($row=0;$row<=$maxrow;$row++) {
437: $tabledata.=&rown($safeeval,$row);
438: }
439: $tabledata.='</table>';
440: }
441:
442:
1.5 www 443:
444: # --------------------------------------- Read spreadsheet formulas from a file
1.3 www 445:
1.5 www 446: sub readsheet {
1.8 ! www 447: my ($safeeval,$fn)=@_;
1.5 www 448: &setfilename($safeeval,$fn);
449: $fn=~/\.(\w+)/;
450: &settype($safeeval,$1);
1.4 www 451: my %f=();
1.8 ! www 452: my $content='';
1.3 www 453: {
1.8 ! www 454: my $fh;
! 455: if ($fh=Apache::File->new($fn)) {
! 456: $content=join('',<$fh>);
! 457: }
1.3 www 458: }
459: {
460: my $parser=HTML::TokeParser->new(\$content);
461: my $token;
462: while ($token=$parser->get_token) {
463: if ($token->[0] eq 'S') {
464: if ($token->[1] eq 'field') {
465: $f{$token->[2]->{'col'}.$token->[2]->{'row'}}=
466: $parser->get_text('/field');
467: }
468: }
469: }
470: }
1.5 www 471: &setformulas($safeeval,%f);
1.3 www 472: }
473:
474: # --------------------------------------------------------------- Read metadata
475:
476: sub readmeta {
477: my $fn=shift;
478: unless ($fn=~/\.meta$/) { $fn.='meta'; }
479: my $content;
480: my %returnhash=();
481: {
482: my $fh=Apache::File->new($fn);
483: $content=join('',<$fh>);
484: }
485: my $parser=HTML::TokeParser->new(\$content);
486: my $token;
487: while ($token=$parser->get_token) {
488: if ($token->[0] eq 'S') {
489: my $entry=$token->[1];
490: if (($entry eq 'stores') || ($entry eq 'parameter')) {
491: my $unikey=$entry;
492: $unikey.='_'.$token->[2]->{'part'};
493: $unikey.='_'.$token->[2]->{'name'};
494: $returnhash{$unikey}=$token->[2]->{'display'};
495: }
496: }
497: }
498: return %returnhash;
499: }
500:
1.5 www 501: # ----------------------------------------------------------------- Update rows
502:
503: sub updaterows {
504: my $safeeval=shift;
505: my %bighash;
506: # -------------------------------------------------------------------- Tie hash
507: if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
508: &GDBM_READER,0640)) {
509: # --------------------------------------------------------- Get all assessments
510:
511: my %allkeys=();
512: my %allassess=();
513:
514: my $stype=&gettype($safeeval);
515:
516: map {
517: if ($_=~/^src\_(\d+)\.(\d+)$/) {
518: my $mapid=$1;
519: my $resid=$2;
520: my $id=$mapid.'.'.$resid;
521: my $srcf=$bighash{$_};
522: if ($srcf=~/\.(problem|exam|quiz|assess|survey|form)$/) {
523: my $symb=
524: &Apache::lonnet::declutter($bighash{'map_id_'.$mapid}).
525: '___'.$resid.'___'.
526: &Apache::lonnet::declutter($srcf);
527: $allassess{$symb}=$bighash{'title_'.$id};
1.8 ! www 528:
1.6 www 529: if ($stype eq 'assesscalc') {
1.5 www 530: map {
531: if ($_=~/^stores\_(.*)/) {
532: my $key=$_;
533: my $display=
534: &Apache::lonnet::metadata($srcf,$key.'.display');
535: unless ($display) {
536: $display=
537: &Apache::lonnet::metadata($srcf,$key.'.name');
538: }
1.8 ! www 539:
! 540:
1.5 www 541: $allkeys{$key}=$display;
542: }
543: } split(/\,/,&Apache::lonnet::metadata($srcf,'keys'));
544: }
545: }
546: }
547: } keys %bighash;
548: untie(%bighash);
549:
550: #
551: # %allkeys has a list of storage displays by unikey
552: # %allassess has a list of all resource displays by symb
553: #
554: # -------------------- Find discrepancies between the course row table and this
555: #
556: my %f=&getformulas($safeeval);
1.6 www 557: my $changed=0;
558:
559: my %current=();
560: if ($stype eq 'assesscalc') {
561: %current=%allkeys;
562: } elsif ($stype eq 'studentcalc') {
563: %current=%allassess;
564: }
565:
566: my $maxrow=0;
567: my %existing=();
568:
569: # ----------------------------------------------------------- Now obsolete rows
1.5 www 570: map {
1.6 www 571: if ($_=~/^A(\d+)/) {
572: $maxrow=($1>$maxrow)?$1:$maxrow;
573: $existing{$f{$_}}=1;
574: unless (defined($current{$f{$_}})) {
575: $f{$_}='!!! Obsolete';
576: $changed=1;
1.5 www 577: }
578: }
579: } keys %f;
1.6 www 580:
581: # -------------------------------------------------------- New and unknown keys
582:
583: map {
584: unless ($existing{$_}) {
585: $changed=1;
586: $maxrow++;
587: $f{'A'.$maxrow}=$_;
588: }
589: } keys %current;
590:
591: if ($changed) { &setformulas($safeeval,%f); }
592:
593: &setmaxrow($safeeval,$maxrow);
594: &setrowlabels($safeeval,%current);
1.5 www 595:
596: } else {
597: return 'Could not access course data';
598: }
599: }
1.3 www 600:
1.6 www 601: # ------------------------------------------------ Load data for one assessment
602:
603: sub rowaassess {
604: my ($safeeval,$uname,$udom,$symb)=@_;
605: my $uhome=&Apache::lonnet::homeserver($uname,$udom);
606: my $namespace;
607: unless ($namespace=$ENV{'request.course.id'}) { return ''; }
608: my $answer=reply("restore:$udom:$uname:$namespace:$symb",$uhome);
609: my %returnhash=();
610: map {
611: my ($name,$value)=split(/\=/,$_);
612: $returnhash{&unescape($name)}=&unescape($value);
613: } split(/\&/,$answer);
614: my $version;
615: for ($version=1;$version<=$returnhash{'version'};$version++) {
616: map {
617: $returnhash{$_}=$returnhash{$version.':'.$_};
618: } split(/\:/,$returnhash{$version.':keys'});
619: }
620:
621: my %c=();
622: my %f=&getformulas($safeeval);
623: map {
624: if ($_=~/^A/) {
625: unless ($f{$_}=~/^\!/) {
626: $c{$_}=$returnhash{$f{$_}};
627: }
628: }
629: } keys %f;
630: &setconstants($safeeval,%c);
631: }
632:
1.3 www 633:
634: sub handler {
1.7 www 635: my $r=shift;
636:
637: if ($r->header_only) {
638: $r->content_type('text/html');
639: $r->send_http_header;
640: return OK;
641: }
1.3 www 642:
1.7 www 643: # ----------------------------------------------------- Needs to be in a course
1.3 www 644:
1.7 www 645: if (($ENV{'request.course.fn'}) ||
646: ($ENV{'request.state'} eq 'construct')) {
647:
648: $r->content_type('text/html');
649: $r->send_http_header;
1.3 www 650:
1.7 www 651: $r->print('<html><head><title>LON-CAPA Spreadsheet</title></head>');
652: $r->print('<body bgcolor="#FFFFFF">');
1.3 www 653:
1.4 www 654: my $sheetone=initsheet();
1.8 ! www 655: &readsheet($sheetone,$r->filename);
! 656: &updaterows($sheetone);
1.6 www 657: &calcsheet($sheetone);
658: $r->print(&outsheet($sheetone));
1.8 ! www 659:
1.3 www 660: $r->print('</body></html>');
1.7 www 661:
662: } else {
663: # ----------------------------- Not in a course, or not allowed to modify parms
664: $ENV{'user.error.msg'}=
665: $r->uri.":opa:0:0:Cannot modify spreadsheet";
666: return HTTP_NOT_ACCEPTABLE;
667: }
1.3 www 668: return OK;
1.1 www 669: }
670:
671: 1;
672: __END__
673:
674:
675:
676:
677:
678:
679:
680:
681:
682:
683:
684:
685:
686:
687:
688:
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