loncom/interface/spreadsheet/Spreadsheet.pm - view

File: [LON-CAPA] / loncom / interface / spreadsheet / Spreadsheet.pm
Revision 1.26: download - view: text, annotated - select for diffs
Mon Sep 15 20:31:01 2003 UTC (20 years, 9 months ago) by matthew
Branches: MAIN
CVS tags: HEAD

Complete rewrite of &mask to return more correct regular expressions.
This is to fix a bug where &mask("X15","X24") would return ^[X-X][5-4]$.
Now it returns ^[X-X](\d+)(?(?{$1>= 15 && $1<=24})|donotmatch)$, which is
actually clearer although it does not appear so at first glance.  A comment
was added to &mask to explain the regular expression.
POD documented &mask, added a debugging helper, and modified all of the
calls to &mask to wrap its result in an eval as such complexities require
using an eval.  I would reference a bug here but bugzilla is down.

1: # 2: # $Id: Spreadsheet.pm,v 1.26 2003/09/15 20:31:01 matthew Exp $ 3: # 4: # Copyright Michigan State University Board of Trustees 5: # 6: # This file is part of the LearningOnline Network with CAPA (LON-CAPA). 7: # 8: # LON-CAPA is free software; you can redistribute it and/or modify 9: # it under the terms of the GNU General Public License as published by 10: # the Free Software Foundation; either version 2 of the License, or 11: # (at your option) any later version. 12: # 13: # LON-CAPA is distributed in the hope that it will be useful, 14: # but WITHOUT ANY WARRANTY; without even the implied warranty of 15: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 16: # GNU General Public License for more details. 17: # 18: # You should have received a copy of the GNU General Public License 19: # along with LON-CAPA; if not, write to the Free Software 20: # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 21: # 22: # /home/httpd/html/adm/gpl.txt 23: # 24: # http://www.lon-capa.org/ 25: # 26: # The LearningOnline Network with CAPA 27: # Spreadsheet/Grades Display Handler 28: # 29: # POD required stuff: 30: 31: =head1 NAME 32: 33: Spreadsheet 34: 35: =head1 SYNOPSIS 36: 37: =head1 DESCRIPTION 38: 39: =over 4 40: 41: =cut 42: 43: ################################################### 44: ################################################### 45: ### Spreadsheet ### 46: ################################################### 47: ################################################### 48: package Apache::Spreadsheet; 49: 50: use strict; 51: #use warnings FATAL=>'all'; 52: #no warnings 'uninitialized'; 53: use Apache::Constants qw(:common :http); 54: use Apache::lonnet; 55: use Safe; 56: use Safe::Hole; 57: use Opcode; 58: use HTML::Entities(); 59: use HTML::TokeParser; 60: use Spreadsheet::WriteExcel; 61: use Time::HiRes; 62: 63: ## 64: ## Package Variables 65: ## 66: my %expiredates; 67: 68: my @UC_Columns = split(//,'ABCDEFGHIJKLMNOPQRSTUVWXYZ'); 69: my @LC_Columns = split(//,'abcdefghijklmnopqrstuvwxyz'); 70: 71: ###################################################### 72: 73: =pod 74: 75: =item &new 76: 77: Returns a new spreadsheet object. 78: 79: =cut 80: 81: ###################################################### 82: sub new { 83: my $this = shift; 84: my $class = ref($this) || $this; 85: my ($stype) = ($class =~ /Apache::(.*)$/); 86: # 87: my ($name,$domain,$filename,$usymb)=@_; 88: # 89: my $self = { 90: name => $name, 91: domain => $domain, 92: type => $stype, 93: symb => $usymb, 94: errorlog => '', 95: maxrow => 0, 96: cid => $ENV{'request.course.id'}, 97: cnum => $ENV{'course.'.$ENV{'request.course.id'}.'.num'}, 98: cdom => $ENV{'course.'.$ENV{'request.course.id'}.'.domain'}, 99: chome => $ENV{'course.'.$ENV{'request.course.id'}.'.home'}, 100: coursedesc => $ENV{'course.'.$ENV{'request.course.id'}.'.description'}, 101: coursefilename => $ENV{'request.course.fn'}, 102: # 103: # Flags 104: temporary => 0, # true if this sheet has been modified but not saved 105: new_rows => 0, # true if this sheet has new rows 106: # 107: # blackout is used to determine if any data needs to be hidden from the 108: # student. 109: blackout => 0, 110: # 111: # Data storage 112: formulas => {}, 113: constants => {}, 114: rows => [], 115: row_source => {}, 116: othersheets => [], 117: }; 118: # 119: $self->{'uhome'} = &Apache::lonnet::homeserver($name,$domain); 120: # 121: bless($self,$class); 122: # 123: # Load in the spreadsheet definition 124: $self->filename($filename); 125: if (exists($ENV{'form.workcopy'}) && 126: $self->{'type'} eq $ENV{'form.workcopy'}) { 127: $self->load_tmp(); 128: } else { 129: $self->load(); 130: } 131: return $self; 132: } 133: 134: ###################################################### 135: 136: =pod 137: 138: =item &filename 139: 140: get or set the filename for a spreadsheet. 141: 142: =cut 143: 144: ###################################################### 145: sub filename { 146: my $self = shift(); 147: if (@_) { 148: my ($newfilename) = @_; 149: if (! defined($newfilename) || $newfilename eq 'Default' || 150: $newfilename !~ /\w/ || $newfilename eq '') { 151: my $key = 'course.'.$self->{'cid'}.'.spreadsheet_default_'. 152: $self->{'type'}; 153: if (exists($ENV{$key}) && $ENV{$key} ne '') { 154: $newfilename = $ENV{$key}; 155: } else { 156: $newfilename = 'default_'.$self->{'type'}; 157: } 158: } 159: if ($newfilename !~ /\w/ || $newfilename =~ /^\W*$/) { 160: $newfilename = 'default_'.$self->{'type'}; 161: } 162: if ($newfilename !~ /^default\.$self->{'type'}$/ ) { 163: if ($newfilename !~ /_$self->{'type'}$/) { 164: $newfilename =~ s/[\s_]*$//; 165: $newfilename .= '_'.$self->{'type'}; 166: } 167: } 168: $self->{'filename'} = $newfilename; 169: return; 170: } 171: return $self->{'filename'}; 172: } 173: 174: ###################################################### 175: 176: =pod 177: 178: =item &make_default() 179: 180: Make the current spreadsheet file the default for the course. Expires all the 181: default spreadsheets.......! 182: 183: =cut 184: 185: ###################################################### 186: sub make_default { 187: my $self = shift(); 188: my $result = &Apache::lonnet::put('environment', 189: {'spreadsheet_default_'.$self->{'type'} => $self->filename()}, 190: $self->{'cdom'},$self->{'cnum'}); 191: return $result if ($result ne 'ok'); 192: my $symb = $self->{'symb'}; 193: $symb = '' if (! defined($symb)); 194: &Apache::lonnet::expirespread('','',$self->{'type'},$symb); 195: } 196: 197: ###################################################### 198: 199: =pod 200: 201: =item &is_default() 202: 203: Returns 1 if the current spreadsheet is the default as specified in the 204: course environment. Returns 0 otherwise. 205: 206: =cut 207: 208: ###################################################### 209: sub is_default { 210: my $self = shift; 211: # Check to find out if we are the default spreadsheet (filenames match) 212: my $default_filename = ''; 213: my %tmphash = &Apache::lonnet::get('environment', 214: ['spreadsheet_default_'. 215: $self->{'type'}], 216: $self->{'cdom'}, 217: $self->{'cnum'}); 218: my ($tmp) = keys(%tmphash); 219: if ($tmp !~ /^(con_lost|error|no_such_host)/i) { 220: $default_filename = $tmphash{'spreadsheet_default_'.$self->{'type'}}; 221: } 222: if ($default_filename =~ /^\s*$/) { 223: $default_filename = 'default_'.$self->{'type'}; 224: } 225: return 1 if ($self->filename() eq $default_filename); 226: return 0; 227: } 228: 229: sub initialize { 230: # This method is here to remind you that it will be overridden by 231: # the descendents of the spreadsheet class. 232: } 233: 234: sub clear_package { 235: # This method is here to remind you that it will be overridden by 236: # the descendents of the spreadsheet class. 237: } 238: 239: sub cleanup { 240: my $self = shift(); 241: $self->clear_package(); 242: } 243: 244: sub initialize_spreadsheet_package { 245: &load_spreadsheet_expirationdates(); 246: &clear_spreadsheet_definition_cache(); 247: } 248: 249: sub load_spreadsheet_expirationdates { 250: undef %expiredates; 251: my $cid=$ENV{'request.course.id'}; 252: my @tmp = &Apache::lonnet::dump('nohist_expirationdates', 253: $ENV{'course.'.$cid.'.domain'}, 254: $ENV{'course.'.$cid.'.num'}); 255: if (lc($tmp[0]) !~ /^error/){ 256: %expiredates = @tmp; 257: } 258: } 259: 260: sub check_expiration_time { 261: my $self = shift; 262: my ($time)=@_; 263: return 0 if (! defined($time)); 264: my ($key1,$key2,$key3,$key4,$key5); 265: # Description of keys 266: # 267: # key1: all sheets of this type have expired 268: # key2: all sheets of this type for this student 269: # key3: all sheets of this type in this map for this student 270: # key4: this assessment sheet for this student 271: # key5: this assessment sheet for all students 272: $key1 = '::'.$self->{'type'}.':'; 273: $key2 = $self->{'name'}.':'.$self->{'domain'}.':'.$self->{'type'}.':'; 274: $key3 = $key2.$self->{'container'} if (defined($self->{'container'})); 275: $key4 = $key2.$self->{'symb'} if (defined($self->{'symb'})); 276: $key5 = $key1.$self->{'symb'} if (defined($self->{'symb'})); 277: my $returnvalue = 1; # default to okay 278: foreach my $key ($key1,$key2,$key3,$key4,$key5) { 279: next if (! defined($key)); 280: if (exists($expiredates{$key}) && $expiredates{$key} > $time) { 281: $returnvalue = 0; # need to recompute 282: } 283: } 284: return $returnvalue; 285: } 286: 287: ###################################################### 288: 289: =pod 290: 291: =item &initialize_safe_space 292: 293: Returns the safe space required by a Spreadsheet object. 294: 295: =head 2 Safe Space Functions 296: 297: =over 4 298: 299: =cut 300: 301: ###################################################### 302: { 303: 304: my $safeeval; 305: 306: sub initialize_safe_space { 307: my $self = shift; 308: if (! defined($safeeval)) { 309: $safeeval = new Safe(shift); 310: my $safehole = new Safe::Hole; 311: $safeeval->permit("entereval"); 312: $safeeval->permit(":base_math"); 313: $safeeval->permit("sort"); 314: $safeeval->deny(":base_io"); 315: $safehole->wrap(\&Apache::lonnet::EXT,$safeeval,'&EXT'); 316: $safehole->wrap(\&mask,$safeeval,'&mask'); 317: $safeeval->share('$@'); 318: my $code=<<'ENDDEFS'; 319: # ---------------------------------------------------- Inside of the safe space 320: # 321: # f: formulas 322: # t: intermediate format (variable references expanded) 323: # v: output values 324: # c: preloaded constants (A-column) 325: # rl: row label 326: # os: other spreadsheets (for student spreadsheet only) 327: undef %sheet_values; # Holds the (computed, final) values for the sheet 328: # This is only written to by &calc, the spreadsheet computation routine. 329: # It is read by many functions 330: undef %t; # Holds the values of the spreadsheet temporarily. Set in &sett, 331: # which does the translation of strings like C5 into the value in C5. 332: # Used in &calc - %t holds the values that are actually eval'd. 333: undef %f; # Holds the formulas for each cell. This is the users 334: # (spreadsheet authors) data for each cell. 335: undef %c; # Holds the constants for a sheet. In the assessment 336: # sheets, this is the A column. Used in &MINPARM, &MAXPARM, &expandnamed, 337: # &sett, and &constants. There is no &getconstants. 338: # &constants is called by &loadstudent, &loadcourse, &load assessment, 339: undef @os; # Holds the names of other spreadsheets - this is used to specify 340: # the spreadsheets that are available for the assessment sheet. 341: # Set by &setothersheets. &setothersheets is called by &handler. A 342: # related subroutine is &othersheets. 343: $errorlog = ''; 344: # 345: $maxrow = 0; 346: $type = ''; 347: # 348: # filename/reference of the sheet 349: $filename = ''; 350: # 351: # user data 352: $name = ''; 353: $uhome = ''; 354: $domain = ''; 355: # 356: # course data 357: $csec = ''; 358: $chome= ''; 359: $cnum = ''; 360: $cdom = ''; 361: $cid = ''; 362: $coursefilename = ''; 363: # 364: # symb 365: $usymb = ''; 366: # 367: # error messages 368: $errormsg = ''; 369: # 370: #------------------------------------------------------- 371: 372: =pod 373: 374: =item NUM(range) 375: 376: returns the number of items in the range. 377: 378: =cut 379: 380: #------------------------------------------------------- 381: sub NUM { 382: my $mask=&mask(@_); 383: my $num= $#{@{grep(eval("/$mask/"),keys(%sheet_values))}}+1; 384: return $num; 385: } 386: 387: #------------------------------------------------------- 388: 389: =pod 390: 391: =item BIN(low,high,lower,upper) 392: 393: =cut 394: 395: #------------------------------------------------------- 396: sub BIN { 397: my ($low,$high,$lower,$upper)=@_; 398: my $mask=&mask($lower,$upper); 399: my $num=0; 400: foreach (grep eval("/$mask/"),keys(%sheet_values)) { 401: if (($sheet_values{$_}>=$low) && ($sheet_values{$_}<=$high)) { 402: $num++; 403: } 404: } 405: return $num; 406: } 407: 408: #------------------------------------------------------- 409: 410: =pod 411: 412: =item SUM(range) 413: 414: returns the sum of items in the range. 415: 416: =cut 417: 418: #------------------------------------------------------- 419: sub SUM { 420: my $mask=&mask(@_); 421: my $sum=0; 422: foreach (grep eval("/$mask/"),keys(%sheet_values)) { 423: $sum+=$sheet_values{$_}; 424: } 425: return $sum; 426: } 427: 428: #------------------------------------------------------- 429: 430: =pod 431: 432: =item MEAN(range) 433: 434: compute the average of the items in the range. 435: 436: =cut 437: 438: #------------------------------------------------------- 439: sub MEAN { 440: my $mask=&mask(@_); 441: my $sum=0; 442: my $num=0; 443: foreach (grep eval("/$mask/"),keys(%sheet_values)) { 444: $sum+=$sheet_values{$_}; 445: $num++; 446: } 447: if ($num) { 448: return $sum/$num; 449: } else { 450: return undef; 451: } 452: } 453: 454: #------------------------------------------------------- 455: 456: =pod 457: 458: =item STDDEV(range) 459: 460: compute the standard deviation of the items in the range. 461: 462: =cut 463: 464: #------------------------------------------------------- 465: sub STDDEV { 466: my $mask=&mask(@_); 467: my $sum=0; my $num=0; 468: foreach (grep eval("/$mask/"),keys(%sheet_values)) { 469: $sum+=$sheet_values{$_}; 470: $num++; 471: } 472: unless ($num>1) { return undef; } 473: my $mean=$sum/$num; 474: $sum=0; 475: foreach (grep eval("/$mask/"),keys(%sheet_values)) { 476: $sum+=($sheet_values{$_}-$mean)**2; 477: } 478: return sqrt($sum/($num-1)); 479: } 480: 481: #------------------------------------------------------- 482: 483: =pod 484: 485: =item PROD(range) 486: 487: compute the product of the items in the range. 488: 489: =cut 490: 491: #------------------------------------------------------- 492: sub PROD { 493: my $mask=&mask(@_); 494: my $prod=1; 495: foreach (grep eval("/$mask/"),keys(%sheet_values)) { 496: $prod*=$sheet_values{$_}; 497: } 498: return $prod; 499: } 500: 501: #------------------------------------------------------- 502: 503: =pod 504: 505: =item MAX(range) 506: 507: compute the maximum of the items in the range. 508: 509: =cut 510: 511: #------------------------------------------------------- 512: sub MAX { 513: my $mask=&mask(@_); 514: my $max='-'; 515: foreach (grep eval("/$mask/"),keys(%sheet_values)) { 516: unless ($max) { $max=$sheet_values{$_}; } 517: if (($sheet_values{$_}>$max) || ($max eq '-')) { 518: $max=$sheet_values{$_}; 519: } 520: } 521: return $max; 522: } 523: 524: #------------------------------------------------------- 525: 526: =pod 527: 528: =item MIN(range) 529: 530: compute the minimum of the items in the range. 531: 532: =cut 533: 534: #------------------------------------------------------- 535: sub MIN { 536: my $mask=&mask(@_); 537: my $min='-'; 538: foreach (grep eval("/$mask/"),keys(%sheet_values)) { 539: unless ($max) { $max=$sheet_values{$_}; } 540: if (($sheet_values{$_}<$min) || ($min eq '-')) { 541: $min=$sheet_values{$_}; 542: } 543: } 544: return $min; 545: } 546: 547: #------------------------------------------------------- 548: 549: =pod 550: 551: =item SUMMAX(num,lower,upper) 552: 553: compute the sum of the largest 'num' items in the range from 554: 'lower' to 'upper' 555: 556: =cut 557: 558: #------------------------------------------------------- 559: sub SUMMAX { 560: my ($num,$lower,$upper)=@_; 561: my $mask=&mask($lower,$upper); 562: my @inside=(); 563: foreach (grep eval("/$mask/"),keys(%sheet_values)) { 564: push (@inside,$sheet_values{$_}); 565: } 566: @inside=sort(@inside); 567: my $sum=0; my $i; 568: for ($i=$#inside;(($i>$#inside-$num) && ($i>=0));$i--) { 569: $sum+=$inside[$i]; 570: } 571: return $sum; 572: } 573: 574: #------------------------------------------------------- 575: 576: =pod 577: 578: =item SUMMIN(num,lower,upper) 579: 580: compute the sum of the smallest 'num' items in the range from 581: 'lower' to 'upper' 582: 583: =cut 584: 585: #------------------------------------------------------- 586: sub SUMMIN { 587: my ($num,$lower,$upper)=@_; 588: my $mask=&mask($lower,$upper); 589: my @inside=(); 590: foreach (grep eval("/$mask/"),keys(%sheet_values)) { 591: $inside[$#inside+1]=$sheet_values{$_}; 592: } 593: @inside=sort(@inside); 594: my $sum=0; my $i; 595: for ($i=0;(($i<$num) && ($i<=$#inside));$i++) { 596: $sum+=$inside[$i]; 597: } 598: return $sum; 599: } 600: 601: #------------------------------------------------------- 602: 603: =pod 604: 605: =item MINPARM(parametername) 606: 607: Returns the minimum value of the parameters matching the parametername. 608: parametername should be a string such as 'duedate'. 609: 610: =cut 611: 612: #------------------------------------------------------- 613: sub MINPARM { 614: my ($expression) = @_; 615: my $min = undef; 616: study($expression); 617: foreach $parameter (keys(%c)) { 618: next if ($parameter !~ /$expression/); 619: if ((! defined($min)) || ($min > $c{$parameter})) { 620: $min = $c{$parameter} 621: } 622: } 623: return $min; 624: } 625: 626: #------------------------------------------------------- 627: 628: =pod 629: 630: =item MAXPARM(parametername) 631: 632: Returns the maximum value of the parameters matching the input parameter name. 633: parametername should be a string such as 'duedate'. 634: 635: =cut 636: 637: #------------------------------------------------------- 638: sub MAXPARM { 639: my ($expression) = @_; 640: my $max = undef; 641: study($expression); 642: foreach $parameter (keys(%c)) { 643: next if ($parameter !~ /$expression/); 644: if ((! defined($min)) || ($max < $c{$parameter})) { 645: $max = $c{$parameter} 646: } 647: } 648: return $max; 649: } 650: 651: 652: sub calc { 653: %sheet_values = %t; 654: my $notfinished = 1; 655: my $lastcalc = ''; 656: my $depth = 0; 657: while ($notfinished) { 658: $notfinished=0; 659: while (my ($cell,$value) = each(%t)) { 660: my $old=$sheet_values{$cell}; 661: $sheet_values{$cell}=eval $value; 662: # $errorlog .= $cell.' = '.$old.'->'.$sheet_values{$cell}."\n"; 663: if ($@) { 664: undef %sheet_values; 665: return $cell.': '.$@; 666: } 667: if ($sheet_values{$cell} ne $old) { 668: $notfinished=1; 669: $lastcalc=$cell; 670: } 671: } 672: # $errorlog.="------------------------------------------------"; 673: 674: $depth++; 675: if ($depth>100) { 676: undef %sheet_values; 677: return $lastcalc.': Maximum calculation depth exceeded'; 678: } 679: } 680: return ''; 681: } 682: 683: # ------------------------------------------- End of "Inside of the safe space" 684: ENDDEFS 685: $safeeval->reval($code); 686: } 687: $self->{'safe'} = $safeeval; 688: $self->{'root'} = $self->{'safe'}->root(); 689: # 690: # Place some of the %$self items into the safe space except the safe space 691: # itself 692: my $initstring = ''; 693: foreach (qw/name domain type usymb cid csec coursefilename 694: cnum cdom chome uhome/) { 695: $initstring.= qq{\$$_="$self->{$_}";}; 696: } 697: $self->{'safe'}->reval($initstring); 698: return $self; 699: } 700: 701: } 702: 703: ###################################################### 704: 705: =pod 706: 707: =back 708: 709: =cut 710: 711: ###################################################### 712: 713: 714: ###################################################### 715: 716: =pod 717: 718: =item &mask($lower,$upper) 719: 720: Inputs: $lower and $upper, cell names ("X12" or "a150") or globs ("X*"). 721: 722: Returns: Regular expression matching spreadsheet cells that are within 723: the rectangle defined by $lower and $upper. Due to the nature of the 724: regular expression this result must be used inside an eval(). 725: 726: =cut 727: 728: ###################################################### 729: { 730: 731: my %memoizer; 732: 733: sub mask { 734: my ($lower,$upper)=@_; 735: my $key = $lower.'_'.$upper; 736: if (exists($memoizer{$key})) { 737: return $memoizer{$key}; 738: } 739: $upper = $lower if (! defined($upper)); 740: # 741: my ($la,$ld) = ($lower=~/([A-z]|\*)(\d+|\*)/); 742: my ($ua,$ud) = ($upper=~/([A-z]|\*)(\d+|\*)/); 743: # 744: my $alpha=''; 745: my $num=''; 746: # 747: # Do not put parenthases around $alpha. 748: # $num depends on the value in $1. 749: if (($la eq '*') || ($ua eq '*')) { 750: $alpha='[A-z]'; 751: } else { 752: $alpha=qq/[$la-$ua]/; 753: } 754: if ($ld ne '*' && $ud ne '*') { 755: # Make sure $ld <= $ud 756: if ($ld > $ud) { 757: my $tmp = $ud; 758: $ud = $ld; 759: $ld = $tmp; 760: } 761: # Here we make a regular expression using some advanced regexp 762: # abilities. 763: # (\d+) will match the digits of the cell name and dump them in 764: # to $1 765: # (?(?{ ... code ...} pattern_if_true | pattern_if_false)) will 766: # choose pattern_if_true if { ... code ... } is true and 767: # pattern_if_false if { ... code ... } is false. 768: # In this case, pattern_if_true is empty. pattern_if_false is 769: # 'donotmatch' and will not match our cells because none of 770: # them end with donotmatch. 771: # Unfortunately, the use of this type of regular expression 772: # requires that each match be wrapped in an eval(). Search for 773: # $mask in this module for examples 774: $num = '(\d+)(?(?{$1>= '.$ld.' && $1<='.$ud.'})|donotmatch)'; 775: } else { 776: $num = '(\d+)'; 777: } 778: my $expression = '^'.$alpha.$num.'$'; 779: $memoizer{$key} = $expression; 780: return $expression; 781: } 782: 783: # 784: # Debugging routine 785: sub dump_memoized_values { 786: while (my ($key,$value) = each(%memoizer)) { 787: &Apache::lonnet::logthis('memoizer: '.$key.' = '.$value); 788: } 789: return; 790: } 791: 792: } 793: 794: ## 795: ## sub add_hash_to_safe {} # spreadsheet, would like to destroy 796: ## 797: 798: # 799: # expandnamed used to reside in the safe space 800: # 801: sub expandnamed { 802: my $self = shift; 803: my $expression=shift; 804: if ($expression=~/^\&/) { 805: my ($func,$var,$formula)=($expression=~/^\&(\w+)$([^\;]+)\;(.*)$/); 806: my @vars=split(/\W+/,$formula); 807: my %values=(); 808: foreach my $varname ( @vars ) { 809: if ($varname=~/^(parameter|stores|timestamp)/) { 810: $formula=~s/$varname/'$c{\''.$varname.'\'}'/ge; 811: $varname=~s/$var/$[\\w:\\- ]\+$/g; 812: foreach (keys(%{$self->{'constants'}})) { 813: if ($_=~/$varname/) { 814: $values{$1}=1; 815: } 816: } 817: } 818: } 819: if ($func eq 'EXPANDSUM') { 820: my $result=''; 821: foreach (keys(%values)) { 822: my $thissum=$formula; 823: $thissum=~s/$var/$_/g; 824: $result.=$thissum.'+'; 825: } 826: $result=~s/\+$//; 827: return $result; 828: } else { 829: return 0; 830: } 831: } else { 832: # it is not a function, so it is a parameter name 833: # We should do the following: 834: # 1. Take the list of parameter names 835: # 2. look through the list for ones that match the parameter we want 836: # 3. If there are no collisions, return the one that matches 837: # 4. If there is a collision, return 'bad parameter name error' 838: my $returnvalue = ''; 839: my @matches = (); 840: my @values = (); 841: $#matches = -1; 842: study $expression; 843: while (my($parameter,$value) = each(%{$self->{'constants'}})) { 844: next if ($parameter !~ /$expression/); 845: push(@matches,$parameter); 846: push(@values,$value); 847: } 848: if (scalar(@matches) == 0) { 849: $returnvalue = '""';#'"unmatched parameter: '.$parameter.'"'; 850: } elsif (scalar(@matches) == 1) { 851: # why do we not do this lookup here, instead of delaying it? 852: $returnvalue = $values[0]; 853: } elsif (scalar(@matches) > 0) { 854: # more than one match. Look for a concise one 855: $returnvalue = "'non-unique parameter name : $expression'"; 856: for (my $i=0; $i<=$#matches;$i++) { 857: if ($matches[$i] =~ /^$expression$/) { 858: # why do we not do this lookup here? 859: $returnvalue = $values[$i]; 860: } 861: } 862: } else { 863: # There was a negative number of matches, which indicates 864: # something is wrong with reality. Better warn the user. 865: $returnvalue = '"bizzare parameter: '.$expression.'"'; 866: } 867: return $returnvalue; 868: } 869: } 870: 871: sub sett { 872: my $self = shift; 873: my %t=(); 874: # 875: # Deal with the template row 876: foreach my $col ($self->template_cells()) { 877: next if ($col=~/^[A-Z]/); 878: foreach my $row ($self->rows()) { 879: # Get the name of this cell 880: my $cell=$col.$row; 881: # Grab the template declaration 882: $t{$cell}=$self->formula('template_'.$col); 883: # Replace '#' with the row number 884: $t{$cell}=~s/\#/$row/g; 885: # Replace '....' with ',' 886: $t{$cell}=~s/\.\.+/\,/g; 887: # Replace 'A0' with the value from 'A0' 888: $t{$cell}=~s/(^|[^\"\'])([A-Za-z]\d+)/$1\$sheet_values\{\'$2\'\}/g; 889: # Replace parameters 890: $t{$cell}=~s/(^|[^\"\'])\[([^\]]+)\]/$1.$self->expandnamed($2)/ge; 891: } 892: } 893: # 894: # Deal with the normal cells 895: while (my($cell,$formula) = each(%{$self->{'formulas'}})) { 896: next if ($_=~/^template\_/); 897: my ($col,$row) = ($cell =~ /^([A-z])(\d+)$/); 898: if ($row eq '0') { 899: $t{$cell}=$formula; 900: $t{$cell}=~s/\.\.+/\,/g; 901: $t{$cell}=~s/(^|[^\"\'])([A-Za-z]\d+)/$1\$sheet_values\{\'$2\'\}/g; 902: $t{$cell}=~s/(^|[^\"\'])\[([^\]]+)\]/$1.$self->expandnamed($2)/ge; 903: } elsif ( $col =~ /^[A-Z]$/ ) { 904: if ($formula !~ /^\!/ && exists($self->{'constants'}->{$cell})) { 905: my $data = $self->{'constants'}->{$cell}; 906: $t{$cell} = $data; 907: } 908: } else { # $row > 1 and $col =~ /[a-z] 909: $t{$cell}=$formula; 910: $t{$cell}=~s/\.\.+/\,/g; 911: $t{$cell}=~s/(^|[^\"\'])([A-Za-z]\d+)/$1\$sheet_values\{\'$2\'\}/g; 912: $t{$cell}=~s/(^|[^\"\'])\[([^\]]+)\]/$1.$self->expandnamed($2)/ge; 913: } 914: } 915: %{$self->{'safe'}->varglob('t')}=%t; 916: } 917: 918: ## 919: ## sync_safe_space: Called by calcsheet to make sure all the data we 920: # need to calculate is placed into the safe space 921: ## 922: sub sync_safe_space { 923: my $self = shift; 924: # Inside the safe space 'formulas' has a diabolical alter-ego named 'f'. 925: %{$self->{'safe'}->varglob('f')}=%{$self->{'formulas'}}; 926: # 'constants' leads a peaceful hidden life of 'c'. 927: %{$self->{'safe'}->varglob('c')}=%{$self->{'constants'}}; 928: # 'othersheets' hides as 'os', a disguise few can penetrate. 929: @{$self->{'safe'}->varglob('os')}=@{$self->{'othersheets'}}; 930: } 931: 932: ## 933: ## Retrieve the error log from the safe space (used for debugging) 934: ## 935: sub get_errorlog { 936: my $self = shift; 937: $self->{'errorlog'} = $ { $self->{'safe'}->varglob('errorlog') }; 938: return $self->{'errorlog'}; 939: } 940: 941: ## 942: ## Clear the error log inside the safe space 943: ## 944: sub clear_errorlog { 945: my $self = shift; 946: $ {$self->{'safe'}->varglob('errorlog')} = ''; 947: $self->{'errorlog'} = ''; 948: } 949: 950: ## 951: ## constants: either set or get the constants 952: ## 953: sub constants { 954: my $self=shift; 955: my ($constants) = @_; 956: if (defined($constants)) { 957: if (! ref($constants)) { 958: my %tmp = @_; 959: $constants = \%tmp; 960: } 961: $self->{'constants'} = $constants; 962: return; 963: } else { 964: return %{$self->{'constants'}}; 965: } 966: } 967: 968: ## 969: ## formulas: either set or get the formulas 970: ## 971: sub formulas { 972: my $self=shift; 973: my ($formulas) = @_; 974: if (defined($formulas)) { 975: if (! ref($formulas)) { 976: my %tmp = @_; 977: $formulas = \%tmp; 978: } 979: $self->{'formulas'} = $formulas; 980: $self->{'rows'} = []; 981: $self->{'template_cells'} = []; 982: return; 983: } else { 984: return %{$self->{'formulas'}}; 985: } 986: } 987: 988: sub set_formula { 989: my $self = shift; 990: my ($cell,$formula) = @_; 991: $self->{'formulas'}->{$cell}=$formula; 992: return; 993: } 994: 995: ## 996: ## formulas_keys: Return the keys to the formulas hash. 997: ## 998: sub formulas_keys { 999: my $self = shift; 1000: my @keys = keys(%{$self->{'formulas'}}); 1001: return keys(%{$self->{'formulas'}}); 1002: } 1003: 1004: ## 1005: ## formula: Return the formula for a given cell in the spreadsheet 1006: ## returns '' if the cell does not have a formula or does not exist 1007: ## 1008: sub formula { 1009: my $self = shift; 1010: my $cell = shift; 1011: if (defined($cell) && exists($self->{'formulas'}->{$cell})) { 1012: return $self->{'formulas'}->{$cell}; 1013: } 1014: return ''; 1015: } 1016: 1017: ## 1018: ## logthis: write the input to lonnet.log 1019: ## 1020: sub logthis { 1021: my $self = shift; 1022: my $message = shift; 1023: &Apache::lonnet::logthis($self->{'type'}.':'. 1024: $self->{'name'}.':'.$self->{'domain'}.':'. 1025: $message); 1026: return; 1027: } 1028: 1029: ## 1030: ## dump_formulas_to_log: makes lonnet.log huge... 1031: ## 1032: sub dump_formulas_to_log { 1033: my $self =shift; 1034: $self->logthis("Spreadsheet formulas"); 1035: $self->logthis("--------------------------------------------------------"); 1036: while (my ($cell, $formula) = each(%{$self->{'formulas'}})) { 1037: $self->logthis(' '.$cell.' = '.$formula); 1038: } 1039: $self->logthis("--------------------------------------------------------");} 1040: 1041: ## 1042: ## value: returns the computed value of a particular cell 1043: ## 1044: sub value { 1045: my $self = shift; 1046: my $cell = shift; 1047: if (defined($cell) && exists($self->{'values'}->{$cell})) { 1048: return $self->{'values'}->{$cell}; 1049: } 1050: return ''; 1051: } 1052: 1053: ## 1054: ## dump_values_to_log: makes lonnet.log huge... 1055: ## 1056: sub dump_values_to_log { 1057: my $self =shift; 1058: $self->logthis("Spreadsheet Values"); 1059: $self->logthis("------------------------------------------------------"); 1060: while (my ($cell, $value) = each(%{$self->{'values'}})) { 1061: $self->logthis(' '.$cell.' = '.$value); 1062: } 1063: $self->logthis("------------------------------------------------------"); 1064: } 1065: 1066: ## 1067: ## Yet another debugging function 1068: ## 1069: sub dump_hash_to_log { 1070: my $self= shift(); 1071: my %tmp = @_; 1072: if (@_<2) { 1073: %tmp = %{$_[0]}; 1074: } 1075: $self->logthis('---------------------------- (begin hash dump)'); 1076: while (my ($key,$val) = each (%tmp)) { 1077: $self->logthis(' '.$key.' = '.$val.':'); 1078: } 1079: $self->logthis('---------------------------- (finished hash dump)'); 1080: } 1081: 1082: ## 1083: ## rebuild_stats: rebuilds the rows and template_cells arrays 1084: ## 1085: sub rebuild_stats { 1086: my $self = shift; 1087: $self->{'rows'}=[]; 1088: $self->{'template_cells'}=[]; 1089: while (my ($cell,$formula) = each(%{$self->{'formulas'}})) { 1090: push(@{$self->{'rows'}},$1) if ($cell =~ /^A(\d+)/ && $1 != 0); 1091: push(@{$self->{'template_cells'}},$1) if ($cell =~ /^template_(\w+)/); 1092: } 1093: return; 1094: } 1095: 1096: ## 1097: ## template_cells returns a list of the cells defined in the template row 1098: ## 1099: sub template_cells { 1100: my $self = shift; 1101: $self->rebuild_stats() if (! defined($self->{'template_cells'}) || 1102: ! @{$self->{'template_cells'}}); 1103: return @{$self->{'template_cells'}}; 1104: } 1105: 1106: ## 1107: ## Sigh.... 1108: ## 1109: sub setothersheets { 1110: my $self = shift; 1111: my @othersheets = @_; 1112: $self->{'othersheets'} = \@othersheets; 1113: } 1114: 1115: ## 1116: ## rows returns a list of the names of cells defined in the A column 1117: ## 1118: sub rows { 1119: my $self = shift; 1120: $self->rebuild_stats() if (!@{$self->{'rows'}}); 1121: return @{$self->{'rows'}}; 1122: } 1123: 1124: # 1125: # calcsheet: makes all the calls to compute the spreadsheet. 1126: # 1127: sub calcsheet { 1128: my $self = shift; 1129: $self->sync_safe_space(); 1130: $self->clear_errorlog(); 1131: $self->sett(); 1132: my $result = $self->{'safe'}->reval('&calc();'); 1133: # $self->logthis($self->get_errorlog()); 1134: %{$self->{'values'}} = %{$self->{'safe'}->varglob('sheet_values')}; 1135: # $self->logthis($self->get_errorlog()); 1136: return $result; 1137: } 1138: 1139: ########################################################### 1140: ## 1141: ## Output Helpers 1142: ## 1143: ########################################################### 1144: sub display { 1145: my $self = shift; 1146: my ($r) = @_; 1147: $self->compute($r); 1148: my $outputmode = 'html'; 1149: if ($ENV{'form.output_format'} =~ /^(html|excel|csv)$/) { 1150: $outputmode = $ENV{'form.output_format'}; 1151: } 1152: if ($outputmode eq 'html') { 1153: $self->outsheet_html($r); 1154: } elsif ($outputmode eq 'excel') { 1155: $self->outsheet_excel($r); 1156: } elsif ($outputmode eq 'csv') { 1157: $self->outsheet_csv($r); 1158: } 1159: $self->cleanup(); 1160: return; 1161: } 1162: 1163: ############################################ 1164: ## HTML output routines ## 1165: ############################################ 1166: sub html_export_row { 1167: my $self = shift(); 1168: my ($color) = @_; 1169: $color = '#CCCCFF' if (! defined($color)); 1170: my $allowed = &Apache::lonnet::allowed('mgr',$ENV{'request.course.id'}); 1171: my $row_html; 1172: my @rowdata = $self->get_row(0); 1173: foreach my $cell (@rowdata) { 1174: if ($cell->{'name'} =~ /^[A-Z]/) { 1175: $row_html .= '<td bgcolor="'.$color.'">'. 1176: &html_editable_cell($cell,$color,$allowed).'</td>'; 1177: } else { 1178: $row_html .= '<td bgcolor="#DDCCFF">'. 1179: &html_editable_cell($cell,'#DDCCFF',$allowed).'</td>'; 1180: } 1181: } 1182: return $row_html; 1183: } 1184: 1185: sub html_template_row { 1186: my $self = shift(); 1187: my $allowed = &Apache::lonnet::allowed('mgr',$ENV{'request.course.id'}); 1188: my ($num_uneditable,$importcolor) = @_; 1189: my $row_html; 1190: my @rowdata = $self->get_template_row(); 1191: my $count = 0; 1192: for (my $i = 0; $i<=$#rowdata; $i++) { 1193: my $cell = $rowdata[$i]; 1194: if ($i < $num_uneditable) { 1195: $row_html .= '<td bgcolor="'.$importcolor.'">'. 1196: &html_uneditable_cell($cell,'#FFDDDD',$allowed).'</td>'; 1197: } else { 1198: $row_html .= '<td bgcolor="#EOFFDD">'. 1199: &html_editable_cell($cell,'#EOFFDD',$allowed).'</td>'; 1200: } 1201: } 1202: return $row_html; 1203: } 1204: 1205: sub html_editable_cell { 1206: my ($cell,$bgcolor,$allowed) = @_; 1207: my $result; 1208: my ($name,$formula,$value); 1209: if (defined($cell)) { 1210: $name = $cell->{'name'}; 1211: $formula = $cell->{'formula'}; 1212: $value = $cell->{'value'}; 1213: } 1214: $name = '' if (! defined($name)); 1215: $formula = '' if (! defined($formula)); 1216: if (! defined($value)) { 1217: $value = '<font color="'.$bgcolor.'">#</font>'; 1218: if ($formula ne '') { 1219: $value = '<i>undefined value</i>'; 1220: } 1221: } elsif ($value =~ /^\s*$/ ) { 1222: $value = '<font color="'.$bgcolor.'">#</font>'; 1223: } else { 1224: $value = &HTML::Entities::encode($value) if ($value !~/ /); 1225: } 1226: return $value if (! $allowed); 1227: # 1228: # The formula will be parsed by the browser twice before being 1229: # displayed to the user for editing. 1230: # 1231: # The encoding string "^A-blah" is placed in []'s inside a regexp, so 1232: # we specify the characters we want left alone by putting a '^' in front. 1233: $formula = &HTML::Entities::encode($formula,'^A-z0-9 !#$%-;=?~'); 1234: # HTML::Entities::encode does not catch everything - we need '\' encoded 1235: $formula =~ s/\\/&\#092/g; 1236: # Escape it again - this time the only encodable character is '&' 1237: $formula =~ s/\&/\&/g; 1238: # Glue everything together 1239: $result .= "<a href=\"javascript:celledit(\'". 1240: $name."','".$formula."');\">".$value."</a>"; 1241: return $result; 1242: } 1243: 1244: sub html_uneditable_cell { 1245: my ($cell,$bgcolor) = @_; 1246: my $value = (defined($cell) ? $cell->{'value'} : ''); 1247: $value = &HTML::Entities::encode($value) if ($value !~/ /); 1248: return ' '.$value.' '; 1249: } 1250: 1251: sub html_row { 1252: my $self = shift(); 1253: my ($num_uneditable,$row,$exportcolor,$importcolor) = @_; 1254: my $allowed = &Apache::lonnet::allowed('mgr',$ENV{'request.course.id'}); 1255: my @rowdata = $self->get_row($row); 1256: my $num_cols_output = 0; 1257: my $row_html; 1258: my $color = $importcolor; 1259: if ($row == 0) { 1260: $color = $exportcolor; 1261: } 1262: $color = '#FFDDDD' if (! defined($color)); 1263: foreach my $cell (@rowdata) { 1264: if ($num_cols_output++ < $num_uneditable) { 1265: $row_html .= '<td bgcolor="'.$color.'">'; 1266: $row_html .= &html_uneditable_cell($cell,'#FFDDDD'); 1267: } else { 1268: $row_html .= '<td bgcolor="#EOFFDD">'; 1269: $row_html .= &html_editable_cell($cell,'#E0FFDD',$allowed); 1270: } 1271: $row_html .= '</td>'; 1272: } 1273: return $row_html; 1274: } 1275: 1276: sub html_header { 1277: my $self = shift; 1278: return '' if (! $ENV{'request.role.adv'}); 1279: return "<table>\n". 1280: '<tr><th align="center">Output Format</th><tr>'."\n". 1281: '<tr><td>'.&output_selector()."</td></tr>\n". 1282: "</table>\n"; 1283: } 1284: 1285: sub output_selector { 1286: my $output_selector = '<select name="output_format" size="3">'."\n"; 1287: my $default = 'html'; 1288: if (exists($ENV{'form.output_format'})) { 1289: $default = $ENV{'form.output_format'} 1290: } else { 1291: $ENV{'form.output_format'} = $default; 1292: } 1293: foreach (['html','HTML'], 1294: ['excel','Excel'], 1295: ['csv','Comma Seperated Values']) { 1296: my ($name,$description) = @{$_}; 1297: $output_selector.=qq{<option value="$name"}; 1298: if ($name eq $default) { 1299: $output_selector .= ' selected'; 1300: } 1301: $output_selector .= ">$description</option>\n"; 1302: } 1303: $output_selector .= "</select>\n"; 1304: return $output_selector; 1305: } 1306: 1307: ################################################ 1308: ## Excel output routines ## 1309: ################################################ 1310: sub excel_output_row { 1311: my $self = shift; 1312: my ($worksheet,$rownum,$rows_output,@prepend) = @_; 1313: my $cols_output = 0; 1314: # 1315: my @rowdata = $self->get_row($rownum); 1316: foreach my $cell (@prepend,@rowdata) { 1317: my $value = $cell; 1318: $value = $cell->{'value'} if (ref($value)); 1319: $value =~ s/\ / /gi; 1320: $worksheet->write($rows_output,$cols_output++,$value); 1321: } 1322: return; 1323: } 1324: 1325: sub create_excel_spreadsheet { 1326: my $self = shift; 1327: my ($r) = @_; 1328: my $filename = '/prtspool/'. 1329: $ENV{'user.name'}.'_'.$ENV{'user.domain'}.'_'. 1330: time.'_'.rand(1000000000).'.xls'; 1331: my $workbook = Spreadsheet::WriteExcel->new('/home/httpd'.$filename); 1332: if (! defined($workbook)) { 1333: $r->log_error("Error creating excel spreadsheet $filename: $!"); 1334: $r->print("Problems creating new Excel file. ". 1335: "This error has been logged. ". 1336: "Please alert your LON-CAPA administrator"); 1337: return undef; 1338: } 1339: # 1340: # The excel spreadsheet stores temporary data in files, then put them 1341: # together. If needed we should be able to disable this (memory only). 1342: # The temporary directory must be specified before calling 'addworksheet'. 1343: # File::Temp is used to determine the temporary directory. 1344: $workbook->set_tempdir('/home/httpd/perl/tmp'); 1345: # 1346: # Determine the name to give the worksheet 1347: return ($workbook,$filename); 1348: } 1349: 1350: sub outsheet_excel { 1351: my $self = shift; 1352: my ($r) = @_; 1353: my $connection = $r->connection(); 1354: $r->print("<h2>Preparing Excel Spreadsheet</h2>"); 1355: # 1356: # Create excel worksheet 1357: my ($workbook,$filename) = $self->create_excel_spreadsheet($r); 1358: return if (! defined($workbook)); 1359: # 1360: # Create main worksheet 1361: my $worksheet = $workbook->addworksheet('main'); 1362: my $rows_output = 0; 1363: my $cols_output = 0; 1364: # 1365: # Write excel header 1366: foreach my $value ($self->get_title()) { 1367: $cols_output = 0; 1368: $worksheet->write($rows_output++,$cols_output,$value); 1369: } 1370: $rows_output++; # skip a line 1371: # 1372: # Write summary/export row 1373: $cols_output = 0; 1374: $self->excel_output_row($worksheet,0,$rows_output++,'Summary'); 1375: $rows_output++; # skip a line 1376: # 1377: $self->excel_rows($connection,$worksheet,$cols_output,$rows_output); 1378: # 1379: # 1380: # Close the excel file 1381: $workbook->close(); 1382: # 1383: # Write a link to allow them to download it 1384: $r->print('<br />'. 1385: '<a href="'.$filename.'">Your Excel spreadsheet.</a>'."\n"); 1386: return; 1387: } 1388: 1389: ################################# 1390: ## CSV output routines ## 1391: ################################# 1392: sub outsheet_csv { 1393: my $self = shift; 1394: my ($r) = @_; 1395: my $connection = $r->connection(); 1396: my $csvdata = ''; 1397: my @Values; 1398: # 1399: # Open the csv file 1400: my $filename = '/prtspool/'. 1401: $ENV{'user.name'}.'_'.$ENV{'user.domain'}.'_'. 1402: time.'_'.rand(1000000000).'.csv'; 1403: my $file; 1404: unless ($file = Apache::File->new('>'.'/home/httpd'.$filename)) { 1405: $r->log_error("Couldn't open $filename for output $!"); 1406: $r->print("Problems occured in writing the csv file. ". 1407: "This error has been logged. ". 1408: "Please alert your LON-CAPA administrator."); 1409: $r->print("<pre>\n".$csvdata."</pre>\n"); 1410: return 0; 1411: } 1412: # 1413: # Output the title information 1414: foreach my $value ($self->get_title()) { 1415: print $file "'".&Apache::loncommon::csv_translate($value)."'\n"; 1416: } 1417: # 1418: # Output the body of the spreadsheet 1419: $self->csv_rows($connection,$file); 1420: # 1421: # Close the csv file 1422: close($file); 1423: $r->print('<br /><br />'. 1424: '<a href="'.$filename.'">Your CSV spreadsheet.</a>'."\n"); 1425: # 1426: return 1; 1427: } 1428: 1429: sub csv_output_row { 1430: my $self = shift; 1431: my ($filehandle,$rownum,@prepend) = @_; 1432: # 1433: my @rowdata = (); 1434: if (defined($rownum)) { 1435: @rowdata = $self->get_row($rownum); 1436: } 1437: my @output = (); 1438: foreach my $cell (@prepend,@rowdata) { 1439: my $value = $cell; 1440: $value = $cell->{'value'} if (ref($value)); 1441: $value =~ s/\ / /gi; 1442: $value = "'".$value."'"; 1443: push (@output,$value); 1444: } 1445: print $filehandle join(',',@output )."\n"; 1446: return; 1447: } 1448: 1449: ############################################ 1450: ## XML output routines ## 1451: ############################################ 1452: sub outsheet_xml { 1453: my $self = shift; 1454: my ($r) = @_; 1455: ## Someday XML 1456: ## Will be rendered for the user 1457: ## But not on this day 1458: my $Str = '<spreadsheet type="'.$self->{'type'}.'">'."\n"; 1459: while (my ($cell,$formula) = each(%{$self->{'formulas'}})) { 1460: if ($cell =~ /^template_(\d+)/) { 1461: my $col = $1; 1462: $Str .= '<template col="'.$col.'">'.$formula.'</template>'."\n"; 1463: } else { 1464: my ($row,$col) = ($cell =~ /^([A-z])(\d+)/); 1465: next if (! defined($row) || ! defined($col)); 1466: $Str .= '<field row="'.$row.'" col="'.$col.'" >'.$formula.'</cell>' 1467: ."\n"; 1468: } 1469: } 1470: $Str.="</spreadsheet>"; 1471: return $Str; 1472: } 1473: 1474: ############################################ 1475: ### Filesystem routines ### 1476: ############################################ 1477: sub parse_sheet { 1478: # $sheetxml is a scalar reference or a scalar 1479: my ($sheetxml) = @_; 1480: if (! ref($sheetxml)) { 1481: my $tmp = $sheetxml; 1482: $sheetxml = \$tmp; 1483: } 1484: my %formulas; 1485: my %sources; 1486: my $parser=HTML::TokeParser->new($sheetxml); 1487: my $token; 1488: while ($token=$parser->get_token) { 1489: if ($token->[0] eq 'S') { 1490: if ($token->[1] eq 'field') { 1491: my $cell = $token->[2]->{'col'}.$token->[2]->{'row'}; 1492: my $source = $token->[2]->{'source'}; 1493: my $formula = $parser->get_text('/field'); 1494: $formulas{$cell} = $formula; 1495: $sources{$cell} = $source if (defined($source)); 1496: $parser->get_text('/field'); 1497: } 1498: if ($token->[1] eq 'template') { 1499: $formulas{'template_'.$token->[2]->{'col'}}= 1500: $parser->get_text('/template'); 1501: } 1502: } 1503: } 1504: return (\%formulas,\%sources); 1505: } 1506: 1507: { 1508: 1509: my %spreadsheets; 1510: 1511: sub clear_spreadsheet_definition_cache { 1512: undef(%spreadsheets); 1513: } 1514: 1515: sub load_system_default_sheet { 1516: my $self = shift; 1517: my $includedir = $Apache::lonnet::perlvar{'lonIncludes'}; 1518: # load in the default defined spreadsheet 1519: my $sheetxml=''; 1520: my $fh; 1521: if ($fh=Apache::File->new($includedir.'/default_'.$self->{'type'})) { 1522: $sheetxml=join('',<$fh>); 1523: $fh->close(); 1524: } else { 1525: # $sheetxml='<field row="0" col="A">"Error"</field>'; 1526: $sheetxml='<field row="0" col="A"></field>'; 1527: } 1528: $self->filename('default_'); 1529: my ($formulas,undef) = &parse_sheet(\$sheetxml); 1530: return $formulas; 1531: } 1532: 1533: sub load { 1534: my $self = shift; 1535: # 1536: my $stype = $self->{'type'}; 1537: my $cnum = $self->{'cnum'}; 1538: my $cdom = $self->{'cdom'}; 1539: my $chome = $self->{'chome'}; 1540: # 1541: my $filename = $self->filename(); 1542: my $cachekey = join('_',($cnum,$cdom,$stype,$filename)); 1543: # 1544: # see if sheet is cached 1545: my ($formulas); 1546: if (exists($spreadsheets{$cachekey})) { 1547: $formulas = $spreadsheets{$cachekey}->{'formulas'}; 1548: } else { 1549: # Not cached, need to read 1550: if (! defined($filename)) { 1551: $formulas = $self->load_system_default_sheet(); 1552: } elsif($self->filename() =~ /^\/res\/.*\.spreadsheet$/) { 1553: # Load a spreadsheet definition file 1554: my $sheetxml=&Apache::lonnet::getfile 1555: (&Apache::lonnet::filelocation('',$filename)); 1556: if ($sheetxml == -1) { 1557: $sheetxml='<field row="0" col="A">"Error loading spreadsheet ' 1558: .$self->filename().'"</field>'; 1559: } 1560: ($formulas,undef) = &parse_sheet(\$sheetxml); 1561: # Get just the filename and set the sheets filename 1562: my ($newfilename) = ($filename =~ /\/([^\/]*)\.spreadsheet$/); 1563: if ($self->is_default()) { 1564: $self->filename($newfilename); 1565: $self->make_default(); 1566: } else { 1567: $self->filename($newfilename); 1568: } 1569: } else { 1570: # Load the spreadsheet definition file from the save file 1571: my %tmphash = &Apache::lonnet::dump($filename,$cdom,$cnum); 1572: my ($tmp) = keys(%tmphash); 1573: if ($tmp !~ /^(con_lost|error|no_such_host)/i) { 1574: while (my ($cell,$formula) = each(%tmphash)) { 1575: $formulas->{$cell}=$formula; 1576: } 1577: } else { 1578: $formulas = $self->load_system_default_sheet(); 1579: } 1580: } 1581: $filename=$self->filename(); # filename may have changed 1582: $cachekey = join('_',($cnum,$cdom,$stype,$filename)); 1583: %{$spreadsheets{$cachekey}->{'formulas'}} = %{$formulas}; 1584: } 1585: $self->formulas($formulas); 1586: $self->set_row_sources(); 1587: $self->set_row_numbers(); 1588: } 1589: 1590: sub set_row_sources { 1591: my $self = shift; 1592: while (my ($cell,$value) = each(%{$self->{'formulas'}})) { 1593: next if ($cell !~ /^A(\d+)/ || $1 < 1); 1594: my $row = $1; 1595: $self->{'row_source'}->{$row} = $value; 1596: } 1597: return; 1598: } 1599: 1600: sub set_row_numbers { 1601: my $self = shift; 1602: while (my ($cell,$value) = each(%{$self->{'formulas'}})) { 1603: next if ($cell !~ /^A(\d+)$/); 1604: next if (! defined($value)); 1605: $self->{'row_numbers'}->{$value} = $1; 1606: $self->{'maxrow'} = $1 if ($1 > $self->{'maxrow'}); 1607: } 1608: } 1609: 1610: ## 1611: ## exportrow is *not* used to get the export row from a computed sub-sheet. 1612: ## 1613: sub exportrow { 1614: my $self = shift; 1615: my @exportarray; 1616: foreach my $column (@UC_Columns) { 1617: push(@exportarray,$self->value($column.'0')); 1618: } 1619: return @exportarray; 1620: } 1621: 1622: sub save { 1623: my $self = shift; 1624: my ($makedef)=@_; 1625: my $cid=$self->{'cid'}; 1626: # If we are saving it, it must not be temporary 1627: $self->temporary(0); 1628: if (&Apache::lonnet::allowed('opa',$cid)) { 1629: my %f=$self->formulas(); 1630: my $stype = $self->{'type'}; 1631: my $cnum = $self->{'cnum'}; 1632: my $cdom = $self->{'cdom'}; 1633: my $chome = $self->{'chome'}; 1634: my $filename = $self->{'filename'}; 1635: my $cachekey = join('_',($cnum,$cdom,$stype,$filename)); 1636: # Cache new sheet 1637: %{$spreadsheets{$cachekey}->{'formulas'}}=%f; 1638: # Write sheet 1639: foreach (keys(%f)) { 1640: delete($f{$_}) if ($f{$_} eq 'import'); 1641: } 1642: my $reply = &Apache::lonnet::put($filename,\%f,$cdom,$cnum); 1643: return $reply if ($reply ne 'ok'); 1644: $reply = &Apache::lonnet::put($stype.'_spreadsheets', 1645: {$filename => $ENV{'user.name'}.'@'.$ENV{'user.domain'}}, 1646: $cdom,$cnum); 1647: return $reply if ($reply ne 'ok'); 1648: if ($makedef) { 1649: $reply = &Apache::lonnet::put('environment', 1650: {'spreadsheet_default_'.$stype => $filename }, 1651: $cdom,$cnum); 1652: return $reply if ($reply ne 'ok'); 1653: } 1654: if ($self->is_default()) { 1655: if ($self->{'type'} eq 'studentcalc') { 1656: &Apache::lonnet::expirespread('','','studentcalc',''); 1657: } elsif ($self->{'type'} eq 'assesscalc') { 1658: &Apache::lonnet::expirespread('','','assesscalc',''); 1659: &Apache::lonnet::expirespread('','','studentcalc',''); 1660: } 1661: } 1662: return $reply; 1663: } 1664: return 'unauthorized'; 1665: } 1666: 1667: } # end of scope for %spreadsheets 1668: 1669: sub save_tmp { 1670: my $self = shift; 1671: my $filename=$ENV{'user.name'}.'_'. 1672: $ENV{'user.domain'}.'_spreadsheet_'.$self->{'symb'}.'_'. 1673: $self->{'filename'}; 1674: $filename=~s/\W/\_/g; 1675: $filename=$Apache::lonnet::tmpdir.$filename.'.tmp'; 1676: $self->temporary(1); 1677: my $fh; 1678: if ($fh=Apache::File->new('>'.$filename)) { 1679: my %f = $self->formulas(); 1680: while( my ($cell,$formula) = each(%f)) { 1681: next if ($formula eq 'import'); 1682: print $fh &Apache::lonnet::escape($cell)."=". 1683: &Apache::lonnet::escape($formula)."\n"; 1684: } 1685: $fh->close(); 1686: } 1687: } 1688: 1689: sub load_tmp { 1690: my $self = shift; 1691: my $filename=$ENV{'user.name'}.'_'. 1692: $ENV{'user.domain'}.'_spreadsheet_'.$self->{'symb'}.'_'. 1693: $self->{'filename'}; 1694: $filename=~s/\W/\_/g; 1695: $filename=$Apache::lonnet::tmpdir.$filename.'.tmp'; 1696: my %formulas = (); 1697: if (my $spreadsheet_file = Apache::File->new($filename)) { 1698: while (<$spreadsheet_file>) { 1699: chomp; 1700: my ($cell,$formula) = split(/=/); 1701: $cell = &Apache::lonnet::unescape($cell); 1702: $formula = &Apache::lonnet::unescape($formula); 1703: $formulas{$cell} = $formula; 1704: } 1705: $spreadsheet_file->close(); 1706: } 1707: # flag the sheet as temporary 1708: $self->temporary(1); 1709: $self->formulas(\%formulas); 1710: $self->set_row_sources(); 1711: $self->set_row_numbers(); 1712: return; 1713: } 1714: 1715: sub temporary { 1716: my $self=shift; 1717: if (@_) { 1718: ($self->{'temporary'})= @_; 1719: } 1720: return $self->{'temporary'}; 1721: } 1722: 1723: sub modify_cell { 1724: # studentcalc overrides this 1725: my $self = shift; 1726: my ($cell,$formula) = @_; 1727: if ($cell =~ /([A-z])\-/) { 1728: $cell = 'template_'.$1; 1729: } elsif ($cell !~ /^([A-z](\d+)|template_[A-z])$/) { 1730: return; 1731: } 1732: $self->set_formula($cell,$formula); 1733: $self->rebuild_stats(); 1734: return; 1735: } 1736: 1737: ########################################### 1738: # othersheets: Returns the list of other spreadsheets available 1739: ########################################### 1740: sub othersheets { 1741: my $self = shift(); 1742: my ($stype) = @_; 1743: $stype = $self->{'type'} if (! defined($stype) || $stype !~ /calc$/); 1744: # 1745: my @alternatives=(); 1746: my %results=&Apache::lonnet::dump($stype.'_spreadsheets', 1747: $self->{'cdom'}, $self->{'cnum'}); 1748: my ($tmp) = keys(%results); 1749: if ($tmp =~ /^(con_lost|error|no_such_host)/i ) { 1750: @alternatives = ('Default'); 1751: } else { 1752: @alternatives = ('Default', sort (keys(%results))); 1753: } 1754: return @alternatives; 1755: } 1756: 1757: sub blackout { 1758: my $self = shift; 1759: $self->{'blackout'} = $_[0] if (@_); 1760: return $self->{'blackout'}; 1761: } 1762: 1763: sub get_row { 1764: my $self = shift; 1765: my ($n)=@_; 1766: my @cols=(); 1767: foreach my $col (@UC_Columns,@LC_Columns) { 1768: my $cell = $col.$n; 1769: push(@cols,{ name => $cell, 1770: formula => $self->formula($cell), 1771: value => $self->value($cell)}); 1772: } 1773: return @cols; 1774: } 1775: 1776: sub get_template_row { 1777: my $self = shift; 1778: my @cols=(); 1779: foreach my $col (@UC_Columns,@LC_Columns) { 1780: my $cell = 'template_'.$col; 1781: push(@cols,{ name => $cell, 1782: formula => $self->formula($cell), 1783: value => $self->formula($cell) }); 1784: } 1785: return @cols; 1786: } 1787: 1788: sub need_to_save { 1789: my $self = shift; 1790: if ($self->{'new_rows'} && ! $self->temporary()) { 1791: return 1; 1792: } 1793: return 0; 1794: } 1795: 1796: sub get_row_number_from_key { 1797: my $self = shift; 1798: my ($key) = @_; 1799: if (! exists($self->{'row_numbers'}->{$key}) || 1800: ! defined($self->{'row_numbers'}->{$key})) { 1801: # I used to set $f here to the new value, but the key passed for lookup 1802: # may not be the key we need to save 1803: $self->{'maxrow'}++; 1804: $self->{'row_numbers'}->{$key} = $self->{'maxrow'}; 1805: # $self->logthis('added row '.$self->{'row_numbers'}->{$key}. 1806: # ' for '.$key); 1807: $self->{'new_rows'} = 1; 1808: } 1809: return $self->{'row_numbers'}->{$key}; 1810: } 1811: 1812: 1; 1813: 1814: __END__