Annotation of loncom/interface/lonspreadsheet.pm, revision 1.3

1.1       www         1: # The LearningOnline Network with CAPA
                      2: # Spreadsheet/Grades Display Handler
                      3: #
1.3     ! www         4: # 11/11,11/15,11/27,12/04 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;
                     13: use Apache::Constants qw(:common);
1.3     ! www        14: use HTML::TokeParser;
        !            15: 
        !            16: #
        !            17: # f: formulas
        !            18: # t: intermediate format (from f after sett)
        !            19: # v: output values (from t after calcv)
        !            20: #
        !            21: 
        !            22: use vars qw(%v %t %f);
        !            23: 
1.1       www        24: 
                     25: sub deffunc {
                     26:     my $safeeval=shift;
                     27:     my $code=<<'ENDDEFS';
                     28: # ---------------------------------------------------- Inside of the safe space
                     29: 
                     30: sub mask {
                     31:     my ($lower,$upper)=@_;
                     32: 
                     33:     $lower=~/([A-Z]|\*)(\d+|\*)/;
                     34:     my $la=$1;
                     35:     my $ld=$2;
                     36: 
                     37:     $upper=~/([A-Z]|\*)(\d+|\*)/;
                     38:     my $ua=$1;
                     39:     my $ud=$2;
                     40:     my $alpha='';
                     41:     my $num='';
                     42: 
                     43:     if (($la eq '*') || ($ua eq '*')) {
                     44:        $alpha='[A-Z]';
                     45:     } else {
                     46:        $alpha='['.$la.'-'.$ua.']';
                     47:     }   
                     48: 
                     49:     if (($ld eq '*') || ($ud eq '*')) {
                     50: 	$num='\d+';
                     51:     } else {
                     52:         if (length($ld)!=length($ud)) {
                     53:            $num.='(';
                     54: 	   map {
                     55:               $num.='['.$_.'-9]';
                     56:            } ($ld=~m/\d/g);
                     57:            if (length($ud)-length($ld)>1) {
                     58:               $num.='|\d{'.(length($ld)+1).','.(length($ud)-1).'}';
                     59: 	   }
                     60:            $num.='|';
                     61:            map {
                     62:                $num.='[0-'.$_.']';
                     63:            } ($ud=~m/\d/g);
                     64:            $num.=')';
                     65:        } else {
                     66:            my @lda=($ld=~m/\d/g);
                     67:            my @uda=($ud=~m/\d/g);
                     68:            my $i; $j=0;
                     69:            for ($i=0;$i<=$#lda;$i++) {
                     70:                if ($lda[$i]==$uda[$i]) {
                     71: 		   $num.=$lda[$i];
                     72:                    $j=$i;
                     73:                }
                     74:            }
                     75:            if ($j<$#lda-1) {
                     76: 	       $num.='('.$lda[$j+1];
                     77:                for ($i=$j+2;$i<=$#lda;$i++) {
                     78:                    $num.='['.$lda[$i].'-9]';
                     79:                }
                     80:                if ($uda[$j+1]-$lda[$j+1]>1) {
                     81: 		   $num.='|['.($lda[$j+1]+1).'-'.($uda[$j+1]-1).']\d{'.
                     82:                    ($#lda-$j-1).'}';
                     83:                }
                     84: 	       $num.='|'.$uda[$j+1];
                     85:                for ($i=$j+2;$i<=$#uda;$i++) {
                     86:                    $num.='[0-'.$uda[$i].']';
                     87:                }
                     88:                $num.=')';
                     89:            } else {
                     90:                $num.='['.$lda[$#lda].'-'.$uda[$#uda].']';
                     91:            }
                     92:        }
                     93:     }
                     94:     return '^'.$alpha.$num.'$';
                     95: }
                     96: 
                     97: 
                     98: sub NUM {
                     99:     my $mask=mask(@_);
                    100:     my $num=0;
                    101:     map {
                    102:         $num++;
                    103:     } grep /$mask/,keys %v;
                    104:     return $num;   
                    105: }
                    106: 
                    107: sub BIN {
                    108:     my ($low,$high,$lower,$upper)=@_;
                    109:     my $mask=mask($lower,$upper);
                    110:     my $num=0;
                    111:     map {
                    112:         if (($v{$_}>=$low) && ($v{$_}<=$high)) {
                    113:             $num++;
                    114:         }
                    115:     } grep /$mask/,keys %v;
                    116:     return $num;   
                    117: }
                    118: 
                    119: 
                    120: sub SUM {
                    121:     my $mask=mask(@_);
                    122:     my $sum=0;
                    123:     map {
                    124:         $sum+=$v{$_};
                    125:     } grep /$mask/,keys %v;
                    126:     return $sum;   
                    127: }
                    128: 
                    129: sub MEAN {
                    130:     my $mask=mask(@_);
                    131:     my $sum=0; my $num=0;
                    132:     map {
                    133:         $sum+=$v{$_};
                    134:         $num++;
                    135:     } grep /$mask/,keys %v;
                    136:     if ($num) {
                    137:        return $sum/$num;
                    138:     } else {
                    139:        return undef;
                    140:     }   
                    141: }
                    142: 
                    143: sub STDDEV {
                    144:     my $mask=mask(@_);
                    145:     my $sum=0; my $num=0;
                    146:     map {
                    147:         $sum+=$v{$_};
                    148:         $num++;
                    149:     } grep /$mask/,keys %v;
                    150:     unless ($num>1) { return undef; }
                    151:     my $mean=$sum/$num;
                    152:     $sum=0;
                    153:     map {
                    154:         $sum+=($v{$_}-$mean)**2;
                    155:     } grep /$mask/,keys %v;
                    156:     return sqrt($sum/($num-1));    
                    157: }
                    158: 
                    159: sub PROD {
                    160:     my $mask=mask(@_);
                    161:     my $prod=1;
                    162:     map {
                    163:         $prod*=$v{$_};
                    164:     } grep /$mask/,keys %v;
                    165:     return $prod;   
                    166: }
                    167: 
                    168: sub MAX {
                    169:     my $mask=mask(@_);
                    170:     my $max='-';
                    171:     map {
                    172:         unless ($max) { $max=$v{$_}; }
                    173:         if (($v{$_}>$max) || ($max eq '-')) { $max=$v{$_}; }
                    174:     } grep /$mask/,keys %v;
                    175:     return $max;   
                    176: }
                    177: 
                    178: sub MIN {
                    179:     my $mask=mask(@_);
                    180:     my $min='-';
                    181:     map {
                    182:         unless ($max) { $max=$v{$_}; }
                    183:         if (($v{$_}<$min) || ($min eq '-')) { $min=$v{$_}; }
                    184:     } grep /$mask/,keys %v;
                    185:     return $min;   
                    186: }
                    187: 
                    188: sub SUMMAX {
                    189:     my ($num,$lower,$upper)=@_;
                    190:     my $mask=mask($lower,$upper);
                    191:     my @inside=();
                    192:     map {
                    193: 	$inside[$#inside+1]=$v{$_};
                    194:     } grep /$mask/,keys %v;
                    195:     @inside=sort(@inside);
                    196:     my $sum=0; my $i;
                    197:     for ($i=$#inside;(($i>$#inside-$num) && ($i>=0));$i--) { 
                    198:         $sum+=$inside[$i];
                    199:     }
                    200:     return $sum;   
                    201: }
                    202: 
                    203: sub SUMMIN {
                    204:     my ($num,$lower,$upper)=@_;
                    205:     my $mask=mask($lower,$upper);
                    206:     my @inside=();
                    207:     map {
                    208: 	$inside[$#inside+1]=$v{$_};
                    209:     } grep /$mask/,keys %v;
                    210:     @inside=sort(@inside);
                    211:     my $sum=0; my $i;
                    212:     for ($i=0;(($i<$num) && ($i<=$#inside));$i++) { 
                    213:         $sum+=$inside[$i];
                    214:     }
                    215:     return $sum;   
                    216: }
                    217: 
                    218: 
                    219: # ------------------------------------------- End of "Inside of the safe space"
                    220: ENDDEFS
                    221:     $safeeval->reval($code);
                    222: }
                    223: 
1.3     ! www       224: # --------------------------------------------------------- Initialize t from f
        !           225: 
1.1       www       226: sub sett {
                    227:     %t=();
                    228:     map {
                    229: 	if ($f{$_}) {
                    230: 	    $t{$_}=$f{$_};
                    231:             $t{$_}=~s/\.+/\,/g;
                    232:             $t{$_}=~s/(^|[^\"\'])([A-Z]\d+)/$1\$v\{\'$2\'\}/g;
                    233:         }
                    234:     } keys %f;
                    235: }
                    236: 
1.3     ! www       237: # ------------------------------------------------------------ Calculate values
        !           238: 
1.1       www       239: sub calcv {
                    240:     my $safeeval=shift;
                    241:     %v=();
                    242:     my $notfinished=1;
                    243:     my $depth=0;
                    244:     while ($notfinished) {
                    245: 	$notfinished=0;
                    246:         map {
                    247:             my $old=$v{$_};
                    248:             $v{$_}=$safeeval->reval($t{$_});
                    249: 	    if ($@) {
                    250: 		%v=();
                    251:                 return $@;
                    252:             }
                    253: 	    if ($v{$_} ne $old) { $notfinished=1; }
                    254:         } keys %t;
                    255:         $depth++;
                    256:         if ($depth>100) {
                    257: 	    %v=();
                    258:             return 'Maximum calculation depth exceeded';
                    259:         }
                    260:     }
                    261:     return '';
                    262: }
                    263: 
1.3     ! www       264: # ------------------------------------------------------------ Read spreadsheet
        !           265: 
        !           266: sub readf {
        !           267:     my $fn=shift;
        !           268:     %f=();
        !           269:     my $content;
        !           270:     {
        !           271:       my $fh=Apache::File->new($fn);
        !           272:       $content=join('',<$fh>);
        !           273:     }
        !           274:     {
        !           275:       my $parser=HTML::TokeParser->new(\$content);
        !           276:       my $token;
        !           277:       while ($token=$parser->get_token) {
        !           278:          if ($token->[0] eq 'S') {
        !           279: 	     if ($token->[1] eq 'field') {
        !           280: 		 $f{$token->[2]->{'col'}.$token->[2]->{'row'}}=
        !           281: 		     $parser->get_text('/field');
        !           282: 	     }
        !           283:          }
        !           284:       }
        !           285:     }
        !           286: }
        !           287: 
        !           288: # --------------------------------------------------------------- Read metadata
        !           289: 
        !           290: sub readmeta {
        !           291:     my $fn=shift;
        !           292:     unless ($fn=~/\.meta$/) { $fn.='meta'; }
        !           293:     my $content;
        !           294:     my %returnhash=();
        !           295:     {
        !           296:       my $fh=Apache::File->new($fn);
        !           297:       $content=join('',<$fh>);
        !           298:     }
        !           299:    my $parser=HTML::TokeParser->new(\$content);
        !           300:    my $token;
        !           301:    while ($token=$parser->get_token) {
        !           302:       if ($token->[0] eq 'S') {
        !           303:          my $entry=$token->[1];
        !           304:          if (($entry eq 'stores') || ($entry eq 'parameter')) {
        !           305:              my $unikey=$entry;
        !           306:              $unikey.='_'.$token->[2]->{'part'}; 
        !           307:              $unikey.='_'.$token->[2]->{'name'}; 
        !           308:              $returnhash{$unikey}=$token->[2]->{'display'};
        !           309:          }
        !           310:      }
        !           311:   }
        !           312:     return %returnhash;
        !           313: }
        !           314: 
        !           315: 
        !           316: # ------------------------------------------------------------ Returns safeeval
        !           317: 
        !           318: sub init {
        !           319: 
1.1       www       320:     %v=();
                    321:     %t=();
                    322:     %f=();
                    323:     my $safeeval = new Safe;
1.2       www       324:     my $safehole = new Safe::Hole;
1.1       www       325:     $safeeval->permit("entereval");
                    326:     $safeeval->permit(":base_math");
                    327:     $safeeval->permit("sort");
                    328:     $safeeval->deny(":base_io");
1.2       www       329:     $safehole->wrap(\&Apache::lonnet::EXT,$safeeval,'&EXT');
1.1       www       330:     $safeeval->share('%v','%t','%f');
                    331:     &deffunc($safeeval);
1.3     ! www       332: 
        !           333:     return $safeeval;
        !           334: }
        !           335: 
        !           336: # -----------------------------------------------------------------------------
        !           337: 
        !           338: sub handler {
        !           339: 
        !           340:     my $r=shift;
        !           341: 
        !           342:   $r->content_type('text/html');
        !           343:   $r->send_http_header;
        !           344: 
        !           345:   $r->print('<html><head><title>LON-CAPA Spreadsheet</title></head>');
        !           346:   $r->print('<body bgcolor="#FFFFFF">');
        !           347:  
        !           348:     my $safeeval=init();
        !           349: 
1.1       www       350:     $f{'A3'}=5;
                    351:     $f{'A4'}=3;
                    352:     $f{'A5'}=8;
                    353:     $f{'E100'}=5;
                    354:     $f{'C3'}='A3+6';
                    355:     $f{'B4'}='8+int(C3/3)';
                    356:     $f{'C7'}='A3+B4';
                    357:     $f{'G8'}='MEAN("E*")';
                    358:     $f{'G5'}='A3+SUMMIN(2,"A*")';
                    359:     $f{'G6'}='A3+SUM("A*")';
                    360:     $f{'G7'}='STDDEV("A*")';
                    361:     $f{'G9'}='NUM("G*")';
                    362:     $f{'H10'}='MEAN("E*")';
                    363:     $f{'G10'}='BIN(3,5,"A*")';
                    364:     &sett();
1.3     ! www       365:     $r->print(&calcv($safeeval)."\n");
        !           366:     $r->print($v{'C7'}."\n");
        !           367:     $r->print($t{'G5'}.' - '.$v{'G5'}."\n");
        !           368:     $r->print($t{'G6'}.' - '.$v{'G6'}."\n");
        !           369:     $r->print($t{'G7'}.' - '.$v{'G7'}."\n");
        !           370:     $r->print($t{'G8'}.' - '.$v{'G8'}."\n");
        !           371:     $r->print($t{'G9'}.' - '.$v{'G9'}."\n");
        !           372:     $r->print($t{'G10'}.' - '.$v{'G10'}."\n");
        !           373: 
        !           374:     $r->print('</body></html>');
        !           375:     return OK;
1.1       www       376: }
                    377: 
                    378: 1;
                    379: __END__
                    380: 
                    381: 
                    382: 
                    383: 
                    384: 
                    385: 
                    386: 
                    387: 
                    388: 
                    389: 
                    390: 
                    391: 
                    392: 
                    393: 
                    394: 
                    395: 

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>