Parent Directory
| 
Revision Log
initial import
1 #!/usr/bin/perl 2 3 ## $Id$ 4 5 #################################################################### 6 # Copyright @ 1995-1998 University of Rochester 7 # All Rights Reserved 8 #################################################################### 9 10 # ############################################################# 11 # ############################################################# 12 # File: FILE.pl 13 # This contains the subroutines for creating problem files, 14 # recording scores, printing delimited files, etc. 15 # ############################################################# 16 # ############################################################# 17 use strict; 18 19 20 # Variables global to this file 21 22 my $scoringDirectory = getCourseScoringDirectory(); 23 my $templateDirectory = getCourseTemplateDirectory(); 24 my $scriptDirectory = getWebworkScriptDirectory(); 25 my $databaseDirectory = getCourseDatabaseDirectory(); 26 27 my $DELIM = $Global::delim; 28 my $scoreFilePrefix = $Global::scoreFilePrefix; 29 my $scoring_log = $Global::scoring_log; 30 my $dash = $Global::dash; 31 my $DAT = $Global::dat; 32 my @STATUS_DROP = @Global::statusDrop; 33 34 my $dd = getDirDelim(); 35 36 37 38 # Subroutines: 39 40 41 #sub createProblem { 42 # my($mode,$probNum,$psvn,$courseName,$sourceref,$refSubmittedAnswers)=@_; 43 # my @out; 44 # #&attachProbSetRecord($psvn); 45 # my $fileName = &getProblemFileName($probNum,$psvn); 46 # #print "content-type: text/plain\n\ngetProblemFileName gives $fileName\n probNum =$probNum and psvn =$psvn\n"; 47 # $fileName = $main::in{'probFileName'} if defined($main::in{'probFileName'}); 48 # #print "now fileName gives $fileName\n probNum =$probNum and psvn =$psvn\n"; 49 # 50 ####Define global variables for the interpreter and seed random function 51 # #srand(&getProblemSeed($probNum,$psvn)); 52 ## print "\n\nContent-type: text/html\n\nERROR: createProblem: Submitted Answers list |$refSubmittedAnswers| not passed\n\n" 53 ## unless defined($refSubmittedAnswers); 54 # defineProblemVars($mode,$probNum, $psvn,$courseName,$refSubmittedAnswers); 55 # @out = &createLines($mode,$fileName,$sourceref); 56 #} 57 # 58 #sub createProblem2 { 59 # my ($mode,$probNum,$psvn,$courseName,$sourceref,$refSubmittedAnswers)=@_; 60 # my %envir=defineProblemEnvir($mode,$probNum,$psvn,$courseName,$refSubmittedAnswers); 61 # #print %envir; 62 # createPGtext($sourceref,\%envir); 63 #} 64 # 65 66 ######## 67 ## Where is createNumberedInsert used??? 68 ######## 69 # sub createNumberedInsert { 70 # my($mode,$probNum,$psvn)=@_; 71 # my @out; 72 # # &attachProbSetRecord($psvn); 73 # my $fileName = &getInsertFileName($num,$psvn); 74 # 75 # ###Define global variables for the interpreter 76 # defineProblemVars($mode,$probNum, $psvn,$refSubmittedAnswers); 77 # @out = &createLines($mode, $fileName); 78 # } 79 80 #This subroutine has been substituted by createProblem, because it is 81 # virtually identical to it 82 #sub createInsert { 83 # my($mode,$fileName,$psvn,$courseName,$sourceref)=@_; 84 # my @out; 85 # # &attachProbSetRecord($psvn); 86 # 87 # 88 # ###Define global variables for the interpreter 89 # # This is for the probSet.pl page so $probNum is not well defined 90 # my $probNum = 0; 91 # defineProblemVars($mode,$probNum, $psvn,$courseName); 92 # @out = &createLines($mode,$fileName,$sourceref); 93 #} 94 95 #sub defineProblemVars { 96 # my ($mode,$probNum,$psvn,$courseName,$refSubmittedAnswers) = @_; 97 # @main::submittedAnswers = @$refSubmittedAnswers if defined($refSubmittedAnswers); 98 # $main::psvnNumber = $psvn; 99 # $main::psvn = $psvn; 100 # $main::studentName = &getStudentName($psvn); 101 # $main::studentLogin = &getStudentLogin($psvn); 102 # $main::sectionName = &getClassSection($psvn); 103 # $main::sectionNumber = &getClassSection($psvn); 104 # $main::setNumber = &getSetNumber($psvn); 105 # $main::questionNumber = $probNum; 106 # $main::probNum = $probNum; 107 # $main::openDate = &getOpenDate($psvn); 108 # $main::formatedOpenDate = &formatDateAndTime(&getOpenDate($psvn)); 109 # $main::dueDate = &getDueDate($psvn); 110 # $main::formatedDueDate = &formatDateAndTime(&getDueDate($psvn)); 111 # $main::answerDate = &getAnswerDate($psvn); 112 # $main::formatedAnswerDate = &formatDateAndTime(&getAnswerDate($psvn)); 113 # $main::problemValue = &getProblemValue($probNum,$psvn); 114 # $main::fileName = &getProblemFileName($probNum,$psvn); 115 # $main::probFileName = &getProblemFileName($probNum,$psvn); 116 # $main::templateDirectory = &getCourseTemplateDirectory(); 117 # $main::languageMode = $mode; 118 # $main::outputMode = $mode; 119 # $main::courseName = $courseName; 120 # $main::sessionKey = ( defined($main::in{'key'}) ) ?$main::in{'key'} : " "; 121 # #my $seed ; 122 # #if ( defined( $inputs{'seed'}) && $permissions == $Global::instructor_permissions ) { 123 # # $seed = $inputs{'seed'}; 124 # #} else { 125 # # $seed = &getProblemSeed($probNum, $psvn); 126 # #} 127 # #$main::problemSeed = $seed; 128 # ##Move srand to PGeval, after unpacking it 129 # #srand($main::problemSeed); 130 # 131 #} 132 133 134 ###no longer use this subroutine 135 ###createPGtext calls PGeval directly 136 ###the language is figured out in the processProblem.pl 137 #sub createLines { 138 # 139 # my ($mode,$fileName,$sourceref) = @_; 140 # my @out; 141 # 142 # 143 ### Set current directory 144 ## my $pathName = $fileName; 145 ## $pathName =~ s|[^/]*$||; 146 ## my $currentDirectory = ${templateDirectory} . ${pathName}; 147 ## chdir "$currentDirectory"; 148 ## 149 ## if (! open(INPUT, "${templateDirectory}$fileName") ) { 150 ### If the file can not be found and opened output an error message 151 ## push(@out, "createLines: ERROR: Can't open filename ${templateDirectory}$fileName\n"); 152 # } 153 # else { 154 # 155 # 156 ### Determine language 157 # # print "content-type: text/plain\n\n fileName = $fileName\n"; 158 # $fileName =~ /\.([^\.]*)$/; 159 # my $languageType = $1; 160 # #print "languageType=$languageType<BR>\n"; 161 ### Call interpreter 162 # if ($languageType eq 'qz') { 163 # ##Assign INPUT to problem file 164 # require "${scriptDirectory}qz2sub.pl";; 165 # @out = &qz2($mode); 166 # 167 # @out = post_process_qz($mode, \@out); 168 # } elsif ($languageType eq 'pg') { 169 # #$languageMode = $mode; #Define global variables for the interpreter and seed random function 170 # @out =&PGeval($sourceref); 171 # } else { 172 # $out[0] = "ERROR: createLines: Don't understand languages with extension $languageType.<BR>\n"; 173 # } 174 ## } 175 # @out; 176 #} 177 # 178 179 180 #sub post_process_qz { 181 # my ($mode,$refInput_lines) = @_; 182 # my $col = 70; 183 # my $len = 0.07*$col; 184 # my @output_lines = (); 185 # my $ansName = ""; 186 # my $answerValue = ""; 187 # my $ansCount = 0; 188 # my $line; 189 # foreach $line (@$refInput_lines) { 190 # 191 # if ($line =~ /^\[ans/i) { 192 # 193 # $ansCount++; 194 # $ansName = "answer" . "$ansCount"; 195 # $answerValue = param("$ansName") if defined param("$ansName"); 196 # #print "<BR>$ansName<BR>"; 197 # if ($mode eq 'HTML') { 198 # push(@output_lines, qq(<INPUT TYPE="TEXT" NAME=$ansName VALUE="$answerValue" SIZE="$col" MAXLENGTH="800">\n\n<HR>) ); 199 # } elsif ($mode eq 'Latex2HTML') { 200 # push(@output_lines, qq!\\begin{rawhtml}\n<INPUT TYPE=TEXT SIZE=$col NAME=\"answer$ansCount\" VALUE = \"$main::submittedAnswers[$ansCount]\">\n\\end{rawhtml}\n! ); 201 # 202 # } elsif ($mode eq 'TeX') { 203 # push(@output_lines, "\rule{${len}in}{.01in}" ); 204 # } else { 205 # push(@output_lines, "ERROR: post_process_qz: mode=$mode is not recognized"); 206 # } 207 # push(@main::PG_ANSWERS, create_qz_ans_function($line)); 208 # } else { 209 # push(@output_lines, $line); 210 # } 211 # } 212 # 213 # @output_lines; 214 #} 215 #sub create_qz_ans_function{ 216 # my $line = shift @_; 217 # my $answer_evaluator = 0; 218 # my ($format, $correctAnswer) = split("=",$line); 219 # 220 # if ($format =~ /^\[ans:([0-9]*),?([0-9\.\-\+eE]*)%?/ ) { #numeric compare--the guts of std_num_cmp 221 # my $accuracy = $2; 222 # my $precision=$1; 223 # my $relpercentTol = $2; 224 # $relpercentTol = .01 unless($relpercentTol); 225 # my $tol = .01*$relpercentTol; 226 # my $formattedCorrectAnswer = sprintf("%10.${precision}g",$correctAnswer ); 227 # $answer_evaluator = sub { 228 # my $in = shift @_; 229 # my $formattedSubmittedAnswer = ""; 230 # my $PGanswerMessage = ""; 231 # my ($inVal,$correctVal); 232 # $correctVal = eval($correctAnswer); 233 # $@=''; 234 # $inVal = eval($in); 235 # if ($@) { ##error message from eval 236 # $formattedSubmittedAnswer = $@; 237 # $formattedSubmittedAnswer =~ s/at.*line [\d]*//g; 238 # $formattedSubmittedAnswer =~ s/called//g; 239 # $formattedSubmittedAnswer =~ s/&main:://g; 240 # $formattedSubmittedAnswer =~ s/chunk [\d]*//g; 241 # } else { 242 # $formattedSubmittedAnswer = sprintf($format,$inVal); 243 # } 244 # 245 # if ($correctVal == 0) { 246 # $tol = 1E-12; ## want $tol to be non zero 247 # } else { 248 # $tol = abs($tol*$correctVal); 249 # } 250 # my $correctQ =0; 251 # $correctQ = 1 if ((not $@) and 252 # (abs( $inVal - $correctVal ) <= $tol)); 253 # if ($@) { 254 # $PGanswerMessage = "There is a syntax error in your answer"; 255 # } 256 # ($correctQ,$formattedCorrectAnswer,$formattedSubmittedAnswer,$PGanswerMessage); 257 # }; 258 # 259 # } else { #string compare use the guts of str_cmp to accomplish this 260 # 261 # my $normalizedCorrectAnswer = $correctAnswer; 262 # # normalize the correct answer: 263 # $normalizedCorrectAnswer=~ s/s*$//; # remove trailing whitespace 264 # $normalizedCorrectAnswer=~ s/s+/ /g; # replace double spaces by single space 265 # $normalizedCorrectAnswer=~ tr/a-z/A-Z/; # Make letters uppercase 266 # $normalizedCorrectAnswer=~ s/^s*//; # remove initial spaces 267 # my $PGanswerMessage = ""; 268 # $answer_evaluator = sub { 269 # my $in = shift @_; 270 # my $originalAnswer = $in; 271 # $in =~ s/s*$//; # remove trailing whitespace 272 # $in =~ s/s+/ /g; # replace double spaces by single space 273 # $in =~ tr/a-z/A-Z/; # Make letters uppercase 274 # # why is there no removing of the initial spaces here? 275 # my $correctQ =0; 276 # $correctQ = 1 if $in eq $normalizedCorrectAnswer; 277 # ($correctQ,$correctAnswer,$originalAnswer,$PGanswerMessage); 278 # }; 279 # 280 # 281 # } 282 # $answer_evaluator; 283 #} 284 ############################## SCORING FILES ROUTINES ############################ 285 #sub recordProblemAnswer { 286 # my ($in, $num,$user, $psvn)=@_; 287 # # &attachProbSetRecord($psvn); 288 # my($setNumber)=&getSetNumber($psvn); 289 # my ($scoreFileName)="${databaseDirectory}$scoreFilePrefix$setNumber$dash${psvn}.sco"; 290 # unless (-e $scoreFileName) 291 # {&createFile($scoreFileName, $Global::sco_files_permission, $Global::numericalGroupID);} 292 # open(TEMP_FILE,">>$scoreFileName") || 293 # print "Couldn't record answer in $scoreFileName"; 294 # # my $time = time; # add time stamp -- should we make this human readable? 295 # my $time = &formatDateAndTime(time); # add time stamp 296 # 297 # print TEMP_FILE "$num $DELIM $in $DELIM $user $DELIM $time\n"; 298 # close(TEMP_FILE); 299 # if ($in eq 'Y') {&putProblemNumOfCorrectAns(&getProblemNumOfCorrectAns($num,$psvn)+1,$num,$psvn);} 300 # if ($in eq 'N') {&putProblemNumOfIncorrectAns(&getProblemNumOfIncorrectAns($num,$psvn)+1,$num,$psvn);} 301 # unless (defined(&getProblemStatus($num)) and (&getProblemStatus($num) eq 'Y')) { 302 # &putProblemStatus($in,$num,$psvn); 303 # } 304 # &detachProbSetRecord($psvn); 305 # }; 306 307 #sub getRecordedScores { 308 # 309 # my ($Yarrayref,$Narrayref,$psvn) = @_; 310 # &attachProbSetRecord($psvn); 311 # my $setNumber = &getSetNumber($psvn); 312 # &detachProbSetRecord($psvn); 313 # my ($scoreFileName)="${databaseDirectory}$scoreFilePrefix$setNumber$dash${psvn}.sco"; 314 # #print "Reading from file $scoreFileName\n" if $debugON; 315 # if ( open(SCORE_FILE,"<$scoreFileName") ) { 316 # while (<SCORE_FILE>) { 317 # my @temp=split(/$DELIM/,$_); 318 # if ($temp[1]=~/Y/) {$$Yarrayref[$temp[0]]++;} 319 # elsif ($temp[1]=~/N/) {$$Narrayref[$temp[0]]++;} 320 # else {wwerror("$0", "corrupted $scoreFileName");} 321 # }; 322 # close(SCORE_FILE); 323 # } else { 324 # warn "Warning: Couldn't open $scoreFileName. Will continue.\n"; 325 # } 326 # # OPERATES ON THE ARRAYS Yarray and Narray. 327 #} 328 329 sub round_score { 330 my $num = shift; 331 my $rounding_dem = 10**$Global::score_decimal_digits; 332 int($num*$rounding_dem + .5)/$rounding_dem; 333 } 334 335 ######################## END SCORING FILES ROUTINES ########################### 336 ############ 337 ### SMD - subroutine to get the number of answers from a specific file 338 ### - this handles questions which have more than one answer field. 339 ### - called with a problem number ($probNum) 340 ### - returns number of answers 341 #sub getNumberofAns 342 # { 343 # local($problemnumber)=@_; 344 # $numberofAnswers=0; 345 # local($filename)= &getProblemFileName($problemnumber); 346 # open(FILE, "${templateDirectory}$filename"); 347 # while(<FILE>) 348 # { 349 # if ($_ =~ /^\s*\[ans/) 350 # { 351 # $numberofAnswers++; 352 # } 353 # } 354 # close FILE; 355 # $numberofAnswers; 356 # } 357 ### GAGE 8/23/96 358 #sub getNumberofSubmittedAns { 359 # my $i = 1; 360 # while (defined($inputs{"answer$i"}) ) #inputs can't be sytactically local (using my) 361 # {$i++}; 362 # $i--; # the off-by-one problem 363 # $i; 364 365 ########### 366 367 sub readSetDef { 368 my ($fileName) = @_; 369 my $setNumber = ''; 370 my $shortFileName = fileFromPath($fileName); 371 if ($shortFileName =~ m|^set(\w+)\.def$|) {$setNumber = $1;} 372 else { 373 wwerror("$0", "The setDefinition file name must begin with <CODE>set</CODE> 374 and must end with <CODE>.def</CODE> . Every thing in between becomes the name of the set. 375 For example <CODE>set1.def</CODE>, <CODE>setExam.def</CODE>, and <CODE>setsample7.def</CODE> 376 define sets named <CODE>1</CODE>, <CODE>Exam</CODE>, and <CODE>sample7</CODE> respectively. The 377 filename, $shortFileName, you entered is not legal\n"); 378 } 379 380 my ($line,$name,$value,$attemptLimit); 381 open (SETFILENAME, "$fileName") or wwerror("$0", "Can't open file $fileName\n"); 382 my $setHeaderFileName = ''; 383 my $probHeaderFileName = ''; 384 my @problemList=(); 385 my @problemValueList=(); 386 my @problemAttemptLimitList=(); 387 my ($dueDate,$openDate,$answerDate); 388 my ($problemListref,$problemValueListref,$problemAttemptLimitListref); 389 while (<SETFILENAME>) { 390 chomp($line = $_); 391 $line =~ s|(#.*)||; ## don't read past comments 392 unless ($line =~ /\S/) {next;} ## skip blank lines 393 $line =~ s|\s*$||; ## trim trailing spaces 394 $line =~ m|^\s*(\w+)\s*=\s*(.*)|; 395 if ($1 eq 'setNumber') {next;} 396 elsif ($1 eq 'paperHeaderFile') {$setHeaderFileName = $2;} 397 elsif ($1 eq 'screenHeaderFile') {$probHeaderFileName = $2;} 398 elsif ($1 eq 'dueDate') {$dueDate = $2;} 399 elsif ($1 eq 'openDate') {$openDate = $2;} 400 elsif ($1 eq 'answerDate') {$answerDate = $2;} 401 elsif ($1 eq 'problemList') {last;} 402 else {wwerror("$0", "readSetDef error, can't read the line: $line");} 403 } 404 405 my $time1 = &unformatDateAndTime($openDate); 406 my $time2 = &unformatDateAndTime($dueDate); 407 my $time3 = &unformatDateAndTime($answerDate); 408 if ($time2 < $time1 or $time3 < $time2) { 409 &Global::error('File.pl: readSetDef error', "The open date: $openDate, due date: $dueDate, and answer date: $answerDate 410 must be in chronologicasl order."); 411 } 412 413 $setHeaderFileName =~ s/(.*?)\s*$/$1/; #remove trailing white space 414 $probHeaderFileName =~ s/(.*?)\s*$/$1/; #remove trailing white space 415 416 # print "setNumber: $setNumber\ndueDate: $dueDate\nopenDate: $openDate\nanswerDate: $answerDate\n"; 417 while(<SETFILENAME>) { 418 chomp($line=$_); 419 $line =~ s/(#.*)//; ## don't read past comments 420 unless ($line =~ /\S/) {next;} ## skip blank lines 421 422 ($name, $value, $attemptLimit) = split (/\s*,\s*/,$line); 423 $name =~ s/\s*//g; 424 push(@problemList, $name); 425 $value = "" unless defined($value); 426 $value =~ s/[^\d]*//g; 427 unless ($value =~ /\d+/) {$value = 1;} 428 push(@problemValueList, $value); 429 $attemptLimit = "" unless defined($attemptLimit); 430 $attemptLimit =~ s/[^\d-]*//g; 431 unless ($attemptLimit =~ /\d+/) {$attemptLimit = -1;} 432 433 push(@problemAttemptLimitList, $attemptLimit); 434 } 435 close(SETFILENAME); 436 #print "problemList: @problemList\n"; 437 #print "problemValueList: @problemValueList\n"; 438 #print "problemAttemptLimitList: @problemAttemptLimitList\n"; 439 $problemListref = \@problemList; 440 $problemValueListref = \@problemValueList; 441 $problemAttemptLimitListref = \@problemAttemptLimitList; 442 ($setNumber,$setHeaderFileName,$probHeaderFileName,$dueDate,$openDate,$answerDate,$problemListref,$problemValueListref,$problemAttemptLimitListref); 443 } 444 445 sub max { ## find the max element of array 446 my $out = $_[0]; 447 my $num; 448 foreach $num (@_) { 449 if ((defined $num) and ($num > $out)) {$out = $num;} 450 } 451 $out; 452 } 453 454 sub min { ## find the max element of array 455 my $out = $_[0]; 456 my $num; 457 foreach $num (@_) { 458 if ((defined $num) and ($num < $out)) {$out = $num;} 459 } 460 $out; 461 } 462 463 sub getFieldLengths { 464 465 ## takes as a parameter the reference to a delimited array 466 ## (such as you would get by reading in a delimited file) 467 ## where each element is a line from a delimited file. 468 ## returns an array which holds 469 ## the maximum field lengths in the file. 470 471 my ($datFileArray_ref)=@_; 472 my($i); 473 my(@datArray,@fieldLength,@datFileArray, $line); 474 @fieldLength=(); 475 @datFileArray=@$datFileArray_ref; 476 477 foreach $line (@datFileArray) { ## read through file and get field lengths 478 unless ($line =~ /\S/) {next;} ## skip blank lines 479 chomp $line; 480 @datArray=&getRecord($line); 481 for ($i=0; $i <=$#datArray; $i++) { 482 $fieldLength[$i] = 0 unless defined $fieldLength[$i]; 483 $fieldLength[$i]=&max(length("$datArray[$i]"),$fieldLength[$i]); 484 } 485 } 486 return (@fieldLength); 487 } 488 489 490 sub columnArrayArrange { 491 492 ## takes as a parameter a delimited array 493 ## (such as you would get by reading in a delimited file) 494 ## where each element is a line from a delimited file. 495 496 # Outputs an array which adds 497 # extra space if necessary to the fields so that all columns line up. 498 # The widest field in any column will contain exactly 1 spaces at the 499 # end of the (non space characters of the) field. For example 500 # ",a very long field entry ," at one extreme and ", ," at the other 501 502 my @inFile=@_; 503 my($i,$tempFileName,$datString,$line); 504 my @outFile =(); 505 my(@fieldLength,@datArray); 506 $i=1; 507 508 @fieldLength=&getFieldLengths(\@inFile); 509 foreach $line (@inFile) { ## read through file array and get field lengths 510 unless ($line =~ /\S/) {next;} ## skip blank lines 511 chomp $line; 512 @datArray=&getRecord($line); 513 for ($i=0; $i <=$#datArray; $i++) { 514 $datArray[$i].=(" " x ($fieldLength[$i]+1-length("$datArray[$i]"))); 515 } 516 $datString=join("${DELIM}",@datArray); 517 push @outFile , "$datString\n"; 518 } 519 @outFile; 520 } 521 522 523 sub columnPrint { 524 525 # Takes two parameters. The first is the filename of the 526 # delimited input file. The second is the name of the 527 # output file (these names may be the same). The permissions 528 # and group of the output file will be the same as the 529 # input file 530 531 # Takes any delimited (with \$DELIM delimiters) file and adds 532 # extra space if necessary to the fields so that all columns line up. 533 # The widest field in any column will contain exactly 2 spaces at the 534 # end of the (non space characters 0f the) field. For example 535 # ",a very long field entry ," at one extreme and ", ," at the other 536 # 537 my($inFileName,$outFileName)=@_; 538 my($line); 539 540 my ($permission, $gid) = (stat($inFileName))[2,5]; 541 $permission = ($permission & 0777); ##get rid of file type stuff 542 543 open(INFILE,"$inFileName") or wwerror("$0","can't open $inFileName for reading"); 544 my @inFile=<INFILE>; 545 close(INFILE); 546 547 &createFile($outFileName, $permission, $gid); 548 549 my @outFile = &columnArrayArrange(@inFile); 550 551 open(OUTFILE,">$outFileName") or wwerror("$0","can't open $outFileName for writing"); 552 foreach $line (@outFile) {print OUTFILE $line;} 553 close(OUTFILE); 554 } 555 556 sub getRecord 557 558 # Takes a delimited line as a parameter and returns an 559 # array. Note that all white space is removed. If the 560 # last field is empty, the last element of the returned 561 # array is also empty (unlike what the perl split command 562 # would return). E.G. @lineArray=&getRecord(\$delimitedLine). 563 { 564 my $DELIM = $Global::delim; 565 my($line) = $_[0]; 566 my(@lineArray); 567 $line.='A'; # add 'A' to end of line so that 568 # last field is never empty 569 @lineArray = split(/\s*${DELIM}\s*/,$line); 570 $lineArray[$#lineArray] =~s/\s*A$//; # remove spaces and the 'A' from last element 571 $lineArray[0] =~s/^\s*//; # remove white space from first element 572 @lineArray; 573 } 574 575 576 577 578 sub delim2aa { 579 580 # Takes a delimited file as a parameter and returns an 581 # associative array with the first field as the key. 582 # Blank lines are skipped. White space is removed 583 584 my $fileName =$_[0]; 585 my(@dbArray,$key,%assocArray,$dbString); 586 open(FILE, "$fileName") or wwerror("$0","can't open $fileName"); 587 while (<FILE>) 588 { 589 unless ($_ =~ /\S/) {next;} ## skip blank lines 590 chomp; 591 @dbArray=&getRecord($_); 592 $key=shift(@dbArray); 593 $dbString=join("${DELIM}",@dbArray); 594 $assocArray{$key}=$dbString; 595 } 596 close(FILE); 597 %assocArray; 598 } 599 sub dropStatus 600 601 # Takes one parameter \$status and returns 1 if \$status matches a word in the 602 # \@STATUS_DROP global array, 0 otherwise. E.G. if ($dropStatus(\$status) {...} 603 # where \$status is the entry in the status field of the class list. \@STATUS_DROP 604 # is a global array defined in webwork.ph 605 { 606 my($tag) = 0; 607 my($status) = $_[0]; 608 my($statusItem); 609 foreach $statusItem (@STATUS_DROP) 610 { 611 if ($status =~ /^\s*$statusItem\s*$/i) {$tag = 1;} 612 613 } 614 $tag; 615 } 616 ##########################Basem's additions#################### 617 ##Gives a nice list of ALL problem sets using radio buttons as default. 618 ##So to make a form with radio buttoned sets, simply start the form on the 619 ##line before calling printProbSets and a line after for the submit. The 620 ##default CGI value that is passed is the probSetKey. To make it the setNo, 621 ##call this subroutine: &printProbSets("setNo") 622 ############################################################### 623 #sub printProbSets { 624 # my ($passFlag,$pHash)=@_; 625 # my %setNumberHash = %$pHash; 626 # my @sortedSetNumberKeys=&sortSetNamesByDueDate($pHash); 627 # my @problemDates = (); 628 # my $problemDateLine; 629 # my ( $probSetKey, $odts,$ddts,$adts,$timeNow,$DueDate,$AnswerDate,$OpenDate); 630 # my $sortedSetNumber; 631 # 632 # foreach $sortedSetNumber(@sortedSetNumberKeys) { 633 # $probSetKey=$setNumberHash{$sortedSetNumber}; 634 # &attachProbSetRecord($probSetKey); 635 # $odts=&getOpenDate($probSetKey); 636 # $ddts=&getDueDate($probSetKey); 637 # $adts=&getAnswerDate($probSetKey); 638 # $timeNow = time; 639 # 640 # $DueDate=&formatDateAndTime($ddts); 641 # $AnswerDate = &formatDateAndTime($adts); 642 # $OpenDate = &formatDateAndTime($odts); 643 # 644 # # prepare message based on current time relative to the Open, Due and Answer dates. 645 # $problemDateLine = ""; 646 # 647 # if ($passFlag eq "setNo") { 648 # $problemDateLine = "\n <INPUT NAME=\"setNo\" 649 # TYPE=\"radio\" VALUE=\"$sortedSetNumber\"> "; 650 # } 651 # else { 652 # $problemDateLine = "\n <INPUT NAME=\"probSetKey\" 653 # TYPE=\"radio\" VALUE=\"$setNumberHash{$sortedSetNumber}\"> "; 654 # } 655 # 656 # $problemDateLine .= "Problem Set Number $sortedSetNumber"; 657 # ($timeNow < $odts ) && do {$problemDateLine .= &beforeOpenDateMsg($OpenDate) . 658 # &problemDates($OpenDate,$DueDate,$AnswerDate);}; 659 # ( $odts <= $timeNow ) && ($timeNow < $ddts) && 660 # do {$problemDateLine .= &afterOpenDateMsg($DueDate) . 661 # &problemDates($OpenDate,$DueDate,$AnswerDate);}; 662 # ( $ddts <= $timeNow ) && ($timeNow < $adts) && 663 # do {$problemDateLine .= 664 # &afterDueDateMsg($AnswerDate) . &problemDates($OpenDate,$DueDate,$AnswerDate);}; 665 # ( $adts <= $timeNow ) && 666 # do {$problemDateLine .= 667 # &afterAnswerDateMsg .&problemDates($OpenDate,$DueDate,$AnswerDate);}; 668 # push (@problemDates, $problemDateLine); 669 # } 670 # 671 # print join("\n\n", @problemDates),"\n"; # include open/due/answer dates 672 # # prepared above 673 #} 674 # 675 ##########################Basem's additions#################### 676 ##Does the same thing as printProbSets but in the abbreviated style used in 677 ##welcome.pl 678 ############################################################### 679 #sub printProbSetsJR { 680 # my ($passFlag,$pHash)=@_; 681 # my %setNumberHash = %$pHash; 682 # my @sortedSetNumberKeys=sort keys(%setNumberHash); 683 # my @problemDates = (); 684 # my $problemDateLine; 685 # my ( $probSetKey, $odts,$ddts,$adts,$timeNow,$DueDate,$AnswerDate,$OpenDate); 686 # my $sortedSetNumber; 687 # 688 # foreach $sortedSetNumber(@sortedSetNumberKeys) { 689 # $probSetKey=$setNumberHash{$sortedSetNumber}; 690 # &attachProbSetRecord($probSetKey); 691 # $odts=&getOpenDate($probSetKey); 692 # $ddts=&getDueDate($probSetKey); 693 # $adts=&getAnswerDate($probSetKey); 694 # $timeNow = time; 695 # 696 # $DueDate=&formatDateAndTime($ddts); 697 # $AnswerDate = &formatDateAndTime($adts); 698 # $OpenDate = &formatDateAndTime($odts); 699 # 700 # # prepare message based on current time relative to the Open, Due and Answer dates. 701 # $problemDateLine = ""; 702 # 703 # if ($passFlag eq "setNo") { 704 # $problemDateLine = "\n <INPUT NAME=\"setNo\" 705 # TYPE=\"radio\" VALUE=\"$sortedSetNumber\"> "; 706 # } 707 # else { 708 # $problemDateLine = "\n <INPUT NAME=\"probSetKey\" 709 # TYPE=\"radio\" VALUE=\"$setNumberHash{$sortedSetNumber}\"> "; 710 # } 711 # 712 # $problemDateLine .= "Problem Set Number $sortedSetNumber"; 713 # 714 # ($timeNow < $odts ) && do {$problemDateLine .= &beforeOpenDateMsg($OpenDate);}; 715 # ( $odts <= $timeNow ) && ($timeNow < $ddts) && 716 # do {$problemDateLine .= &afterOpenDateMsg($DueDate);}; 717 # ( $ddts <= $timeNow ) && ($timeNow < $adts) && 718 # do {$problemDateLine .= &afterDueDateMsg($AnswerDate);}; 719 # ( $adts <= $timeNow ) && 720 # do {$problemDateLine .= &afterAnswerDateMsg;}; 721 # 722 # 723 # push (@problemDates, $problemDateLine); 724 # } 725 #print join("\n\n", @problemDates),"\n"; # include open/due/answer dates 726 # # prepared above 727 #} 728 729 730 sub beforeOpenDateMsg { 731 my ($OpenDate) = @_; 732 my $out = " --- <em>Before open date</em> -- "; 733 $out .= "Open date is: $OpenDate <BR>"; 734 $out; 735 }; 736 sub afterOpenDateMsg { #and before Due Date 737 my ($DueDate) = @_; 738 my $out = " --- <em><B>OPEN</B></em>"; 739 $out .= " -- Due date is: $DueDate <BR>"; 740 $out; 741 }; 742 sub afterDueDateMsg { #and before AnswerDate 743 my ($AnswerDate) = @_; 744 my $out = " --- <em><B>CLOSED</B></em> --"; 745 $out .= " Answers available on: $AnswerDate <BR>"; 746 $out; 747 }; 748 sub afterAnswerDateMsg { 749 my $out = " --- <em><B>CLOSED</B></em> -- "; 750 $out .= " answers available.<BR>"; 751 $out; 752 }; 753 754 755 sub problemDates { 756 my ($OpenDate,$DueDate,$AnswerDate) = @_; 757 my $out = <<ENDproblemDatesHTML; 758 <PRE> 759 Open: $OpenDate 760 <B>Due: $DueDate</B> 761 Answer: $AnswerDate 762 </PRE> 763 ENDproblemDatesHTML 764 765 $out; 766 } 767 768 sub formatDateAndTime { 769 my ($timeStamp)=@_; 770 my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = 771 localtime($timeStamp); 772 my $twelveHour; 773 if($min<10){$min= "0" . $min;} 774 775 if($hour==0){$twelveHour = 12 . ":" . $min . " AM";} 776 elsif($hour<12){$twelveHour= $hour . ":" . $min . " AM";} 777 elsif($hour==12){$twelveHour = $hour . ":" . $min . " PM";} 778 else {$twelveHour = ($hour-12) . ":" . $min . " PM";} 779 780 if($year>99){$year = $year -100;} 781 if($year<10){$year= "0" . $year;} 782 783 my $returnTimeString = ($mon+1) . "/" . $mday . "/" . $year . " at " . $twelveHour; 784 $returnTimeString; 785 } 786 787 788 sub unformatDateAndTime { 789 my ($string) = @_; 790 my $orgString =$string; 791 $string =~ s|^\s+||; 792 $string =~ s|\s+$||; 793 $string =~ s|at| at |i; ## OK if forget to enter spaces or use wrong case 794 $string =~ s|AM| AM|i; ## OK if forget to enter spaces or use wrong case 795 $string =~ s|PM| PM|i; ## OK if forget to enter spaces or use wrong case 796 $string =~ s|,| at |; ## start translating old form of date/time to new form 797 798 my($date,$at,$time,$AMPM) = split(/\s+/,$string); 799 unless ($time =~ /:/) { 800 { ##bare block for 'case" structure 801 $time =~ /(\d\d)(\d\d)/; 802 my $tmp_hour = $1; 803 my $tmp_min = $2; 804 if ($tmp_hour eq '00') {$time = "12:$tmp_min"; $AMPM = 'AM';last;} 805 if ($tmp_hour eq '12') {$time = "12:$tmp_min"; $AMPM = 'PM';last;} 806 if ($tmp_hour < 12) {$time = "$tmp_hour:$tmp_min"; $AMPM = 'AM';last;} 807 if ($tmp_hour < 24) { 808 $tmp_hour = $tmp_hour - 12; 809 $time = "$tmp_hour:$tmp_min"; 810 $AMPM = 'PM'; 811 } 812 } ##end of bare block for 'case" structure 813 814 } 815 816 my ($mday, $mon, $year, $wday, $yday,$sec, $pm, $min, $hour); 817 $sec=0; 818 $time =~ /^([0-9]+)\s*\:\s*([0-9]*)/; 819 $min=$2; 820 $hour = $1; 821 if ( $hour < 1 or $hour > 12 or $min < 0 or $min > 59) { 822 &Global::error('File.pl: unformatDateAndTime error', "Incorrect date/time format $orgString. Correct format is 9/13/02 at 12:15 PM"); 823 } 824 $pm = 0; 825 $pm = 12 if ($AMPM =~/PM/ and $hour < 12); 826 $hour += $pm; 827 $hour = 0 if ($AMPM =~/AM/ and $hour == 12); 828 $date =~ m!([0-9]+)\s*/\s*([0-9]+)/\s*([0-9]+)! ; 829 $mday =$2; 830 $mon=($1-1); 831 if ( $mday < 1 or $mday > 31 or $mon < 0 or $mon > 11) { 832 &Global::error('File.pl: unformatDateAndTime error', "Incorrect date/time format $orgString. Correct format is 9/13/02 at 12:15 PM"); 833 } 834 $year=$3; 835 $wday=""; 836 $yday=""; 837 timelocal ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday); 838 } 839 840 sub texInput 841 842 ## Similar to the TeX input command. Takes a filename (with or without extension) 843 ## which is assumed to be in the \$templateDirectory. 844 ## E.G. print OUTFILE &texInput("file.tex"); 845 ## or print OUTFILE &texInput("file"); 846 847 { 848 my $texInFile = $_[0]; 849 my $texString; 850 if ($texInFile eq "") { 851 $texString = ''; 852 } else { 853 unless ($texInFile =~ m#\.#) {$texInFile .= '.tex';} 854 open(TEX_IN_FILE,"${templateDirectory}$texInFile") || 855 &Global::error("File.pl: textInput error", " Can't open ${templateDirectory}$texInFile"); 856 my @texInputArray = <TEX_IN_FILE>; 857 close(TEX_IN_FILE); 858 $texString = join('',@texInputArray); 859 unless ($texString =~ /\n$/s) {$texString .= "\n";} 860 } 861 ## print "$texString"; 862 $texString; 863 } 864 865 866 867 868 869 # A very useful macro for making sure that all of the directories to a file have been constructed. 870 871 sub surePathToTmpFile { # constructs intermediate directories if needed beginning at ${Global::htmlDirectory}tmp/ 872 # the input path must be either the full path, or the path relative to this tmp sub directory 873 my $path = shift; 874 my $delim = &getDirDelim(); 875 my $tmpDirectory = getCourseTempDirectory(); 876 # if the path starts with $tmpDirectory (which is permitted but optional) remove this initial segment 877 $path =~ s|^$tmpDirectory|| if $path =~ m|^$tmpDirectory|; 878 $path = convertPath($path); 879 # find the nodes on the given path 880 my @nodes = split("$delim",$path); 881 # create new path 882 $path = convertPath("$tmpDirectory"); 883 884 while (@nodes>1 ) { 885 $path = convertPath($path . shift (@nodes) ."/"); 886 unless (-e $path) { 887 # system("mkdir $path"); 888 createDirectory($path,$Global::tmp_directory_permission, $Global::numericalGroupID) || 889 wwerror($0, "Failed to create directory $path","","",""); 890 891 } 892 893 } 894 $path = convertPath($path . shift(@nodes)); 895 896 # system(qq!echo "" > $path! ); 897 898 $path; 899 900 } 901 902 903 904 905 sub fileFromPath { 906 my $path = shift; 907 my $delim =&getDirDelim(); 908 $path = convertPath($path); 909 $path =~ m|([^$delim]+)$|; 910 $1; 911 912 } 913 914 sub directoryFromPath { 915 my $path = shift; 916 my $delim =&getDirDelim(); 917 $path = convertPath($path); 918 $path =~ s|[^$delim]*$||; 919 $path; 920 } 921 922 sub createDirectory 923 { 924 my ($dirName, $permission, $numgid) = @_; 925 mkdir($dirName, $permission) or 926 wwerror("$0: createDirectory error", " Can't do mkdir($dirName, $permission)"); 927 chmod($permission, $dirName) or 928 wwerror("$0: createDirectory error", " Can't do chmod($permission, $dirName)"); 929 unless ($numgid == -1) {chown(-1,$numgid,$dirName) or 930 wwerror("$0: createDirectory error", " Can't do chown(-1,$numgid,$dirName)");} 931 } 932 use Cwd; 933 sub createFile { 934 my ($fileName, $permission, $numgid) = @_; 935 # my $decimal_per = sprintf "%lo", $permission; 936 # print "\n IN createFile: file is $fileName, permission is $decimal_per, gid is $numgid\n"; 937 938 open(TEMPCREATEFILE, ">$fileName") || 939 wwerror("File.pl: createFile error", " Can't open $fileName"); 940 my @stat = stat TEMPCREATEFILE; 941 close(TEMPCREATEFILE); 942 943 ## if the owner of the file is running this script (e.g. when the file is first created) 944 ## set the permissions and group correctly 945 if ($< == $stat[4]) { 946 # my $oldDirectory = cwd(); 947 # warn " old directory is $oldDirectory<BR>\n"; 948 # my $newDirectory = $fileName; 949 # $newDirectory =~ s|/[^/]+$||; 950 # warn " new directory is $newDirectory<BR>\n"; 951 # $fileName =~ m|([^/]+$)|; 952 # my $newFileName = $1; 953 # warn "new File name = $newFileName<BR>\n"; 954 # chdir $newDirectory; 955 # warn "changing to directory =" .cwd() ."<BR>\n"; 956 # 957 #chmod(0777,$fileName); 958 my $tmp = chmod($permission,$fileName) or 959 warn("File.pl: createFile error", " Can't do chmod($permission, $fileName)"); 960 chown(-1,$numgid,$fileName) or 961 warn("File.pl: createFile error", " Can't do chown($numgid, $fileName)"); 962 # #warn "foo is readable<BR>\n" if -w 'foo.gif'; 963 # #warn "chmod =" . chmod($permission,$newFileName) || 964 # # warn("File.pl: createFile error", " Can't do chmod($permission, $newFileName)"); 965 # #chdir $oldDirectory; 966 # #warn "changed back to directory =" .cwd() ."<BR>\n"; 967 } 968 } 969 970 sub rmDirectoryAndFiles 971 { 972 my ($PROBDIR) =@_; 973 my @allfiles = (); 974 opendir( DIRHANDLE, "$PROBDIR") || warn qq/Can't read directory $PROBDIR $!/; 975 @allfiles = map "$PROBDIR$_", grep( !/^\.\.?$/, readdir DIRHANDLE); 976 closedir(DIRHANDLE); 977 # print "unlinking<BR>",join("<BR>", @allfiles),"<P>"; 978 unlink(@allfiles); 979 # print "removing directory $PROBDIR <P>"; 980 rmdir("$PROBDIR"); 981 } 982 983 984 985 # this returns an array of set names sorted by due date (with all open sets first). 986 # It is called by a reference to a hash with keys the Set Names and values psvn's 987 # such as returned by &getAllProbSetNumbersHash or &getAllSetNumbersForStudentLoginHash 988 989 sub sortSetNamesByDueDate { 990 my ($setNameHashref) = @_; 991 my %setNameHash = %$setNameHashref; 992 my ($setName,$psvn,$ddts,$timeNow); 993 my %dueTimes =(); 994 995 foreach $setName (keys %setNameHash) { 996 $psvn=$setNameHash{$setName}; 997 &attachProbSetRecord($psvn); 998 $ddts=&getDueDate($psvn); 999 $dueTimes{$setName} = $ddts; 1000 } 1001 1002 my @sortedSetNames = sort 1003 1004 ## Sort setnumbers by due date. Using an anonymous block so that 1005 ## dueTimes gets passes without making it global to FILE.pl or 1006 ## passing it to a sorting subroutine (can we pass this?) 1007 1008 { 1009 $timeNow = time; 1010 if ( ($dueTimes{$a} <= $timeNow) and ($dueTimes{$b} <= $timeNow) ) 1011 { 1012 $dueTimes{$a} <=> $dueTimes{$b} 1013 or 1014 $a cmp $b 1015 } 1016 elsif ( ($dueTimes{$a} > $timeNow) and ($dueTimes{$b} > $timeNow) ) 1017 { 1018 $dueTimes{$a} <=> $dueTimes{$b} 1019 or 1020 $a cmp $b 1021 } 1022 else 1023 { 1024 $dueTimes{$b} <=> $dueTimes{$a} 1025 } 1026 } 1027 1028 keys %setNameHash ; 1029 @sortedSetNames; 1030 } 1031 1032 sub checkClasslistFile { 1033 ## takes as parameters the number of fields and the full path name of 1034 ## the classlist file. Checks that the file iv valid, i.e. (1) all records 1035 ## have the same number of fields, (2) the first fields (studentID's, usually SS#'s) are 1036 ## all distinct and (3) the last fields (the loginID's) are all distinct, 1037 ## and (4) that studentID's and loginID's comtain only valid characters 1038 1039 my($noOfFields,$fileName)=@_; 1040 my $msg = htmlCheckClasslistFile($noOfFields,$fileName); 1041 unless ($msg eq 'OK') { 1042 &wwerror("$0","$msg"); 1043 } 1044 } 1045 1046 sub htmlCheckClasslistFile { 1047 ## takes as parameters the number of fields and the full path name of 1048 ## the classlist file. Checks that the file iv valid, i.e. (1) all records 1049 ## have the same number of fields, (2) the first fields (studentID's, usually SS#'s) are 1050 ## all distinct and (3) the last fields (the loginID's) are all distinct, 1051 ## and (4) that studentID's and loginID's comtain only valid characters and 1052 ## (5) that other fields do not contain bas chacters 1053 1054 my($noOfFields,$fileName)=@_; 1055 1056 open (FILE, "$fileName") or 1057 &wwerror("$0","can't open $fileName"); 1058 my @classList = <FILE>; 1059 close(FILE); 1060 1061 my $msg = checkClasslistArray($noOfFields, \@classList,$fileName); 1062 return $msg; 1063 } 1064 1065 sub checkClasslistArray { 1066 ## takes as parameters the number of fields and a ref to 1067 ## the classlist array. Checks that the file iv valid, i.e. (1) all records 1068 ## have the same number of fields, (2) the first fields (studentID's, usually SS#'s) are 1069 ## all distinct and (3) the last fields (the loginID's) are all distinct, 1070 ## and (4) that studentID's and loginID's comtain only valid characters and 1071 ## (5) that other fields do not contain bas chacters 1072 1073 my($noOfFields,$classListref,$fileName)=@_; 1074 my($noOfDelim,$dbString,$num,$i,@classList); 1075 my(@keyList); 1076 my $msg =''; 1077 $noOfDelim = $noOfFields -1; 1078 1079 @classList = @$classListref; 1080 1081 foreach $dbString (@classList) { 1082 unless ($dbString =~ /\S/) {next;} 1083 chomp $dbString; 1084 $num=($dbString =~s/$DELIM/$DELIM/g); 1085 if ($num != $noOfDelim) { 1086 $num =$num+1; 1087 $msg = "\n\n The classlist file\n $fileName \n is corrupted. The record\n 1088 $dbString \n contains $num fields instead of $noOfFields fields. \nYou 1089 must correct this and then run this script again. 1090 \n\n"; 1091 return $msg; 1092 } 1093 } 1094 my (@SSList, @loginList); 1095 @SSList=(); @loginList=(); 1096 foreach $dbString (@classList) { 1097 unless ($dbString =~ /\S/) {next;} 1098 chomp $dbString; 1099 my @classListRecord=&getRecord($dbString); 1100 my ($studentID, $lastName, $firstName, $status, $comment, $section,$recitation, $email_address, $login_name) 1101 = @classListRecord; 1102 # next if &dropStatus($status); ## ignore students who have dropped 1103 unless ($studentID =~ /^[\w\-\.]+$/) { 1104 $msg = "\n\n The classlist file\n$fileName\n\n is corrupted. The record 1105 \n$dbString \n contains the invalid studentID: $studentID 1106 \n studentID's can contain only upper and lower case letters, digits, -, dot('.'), and _ 1107 \n You must correct this and then run this script again.\n\n"; 1108 return $msg; 1109 } 1110 unless ($login_name =~ /^[\w\-\.]+$/) { 1111 $msg = "\n\n The classlist file\n$fileName\n\n is corrupted. The record 1112 \n$dbString \n contains the invalid loginName: $login_name 1113 \n loginName's can contain only upper and lower case letters, digits, -, dot('.'), and _ 1114 \n You must correct this and then run this script again.\n\n"; 1115 return $msg; 1116 } 1117 1118 ## test entries for bad characters. 1119 my @entries = ($lastName, $firstName, $status, $comment, $section,$recitation, $email_address); 1120 my $item =''; 1121 foreach $item (@entries) { 1122 my $msg = test_entry($item); 1123 unless ($msg eq 'OK') {return $msg;} 1124 } 1125 1126 push(@SSList,$studentID); 1127 push(@loginList,$login_name); 1128 } 1129 @SSList = sort(@SSList); 1130 for ($i=0; $i < @SSList-1; $i++) { 1131 if ($SSList[$i] eq $SSList[$i+1]) { 1132 $msg = "\n\n The classlist file\n$fileName\n\n is corrupted. Duplicate studentID's equal 1133 to $SSList[$i] in\n $fileName\nYou must correct this and then run this script again.\n\n"; 1134 return $msg; 1135 } 1136 } 1137 @loginList = sort(@loginList); 1138 for ($i=0; $i < @loginList-1; $i++) { 1139 if ($loginList[$i] eq $loginList[$i+1]) { 1140 $msg ="\n\n The classlist file\n$fileName\n\n is corrupted. Duplicate loginNames equal 1141 to $loginList[$i] in\n 1142 $fileName\nYou must correct this and then run this script again.\n\n"; 1143 return $msg; 1144 } 1145 } 1146 $msg ='OK'; 1147 return $msg; 1148 } 1149 1150 ### macros for writing and reading html tables 1151 1152 sub array2htmlRow { 1153 ## The parameter is an array whose entries will beccome elements of a row 1154 ## in an html table. The output is a string formated the same way Excel 1155 ## formats html tables: numbers aligned right, other things left. 1156 1157 my @inArray = @_; 1158 my ($item,$align); 1159 my $outString =''; 1160 $outString = join '','<TR ALIGN="left" VALIGN="bottom">',"\n"; 1161 foreach $item (@inArray) { 1162 unless ($item =~ /\S/) {$item = ' ';} 1163 if ($item =~/^[\d\.]+$/){$align ='RIGHT'} else {$align ='LEFT'} 1164 $outString .= join '','<TD ALIGN=',$align,'>',"\n"; 1165 $outString .= join '',$item,'</TD>',"\n"; 1166 } 1167 $outString .= join '','</TR>',"\n"; 1168 } 1169 1170 sub array2htmlRowForm { 1171 ## The parameter is an array whose first entry is the row number (1, 2, etc) 1172 ## and remaining entries will become elements of a row 1173 ## in an html table. 1174 1175 my ($row,@inArray) = @_; 1176 my ($item,$size); 1177 my $outString =''; 1178 my $col =1; 1179 $outString = join '','<TR ALIGN=LEFT VALIGN=BOTTOM>',"\n"; 1180 foreach $item (@inArray) { 1181 unless ($item =~ /\S/) {$item = ' ';} 1182 $size = length($item); 1183 $outString .= join '','<TD>',"\n"; 1184 $outString .= join '','<INPUT TYPE="TEXT" SIZE = ', $size, ' NAME="',"row${row}col$col",'" VALUE="',"$item",'"> </TD>',"\n"; 1185 1186 $col++; 1187 } 1188 $outString .= join '','</TR>',"\n"; 1189 } 1190 1191 sub delimitedArray2htmlTable { 1192 1193 # Takes a ref to an array whose elements are rows of a delimited file 1194 # and outputs a string containing 1195 # an html table version of the array suitable for viewing and editing 1196 # in Excel or a browser such as Netscape/Communicator. If the second 1197 # optional parameter is 'htmlform', the output is an html form. Otherwise 1198 # the output is a plain html document. 1199 # Blank lines are skipped. White space is removed. 1200 1201 my ($inArrayref, $type) = @_; 1202 1203 ## setup html header and initial table stuff 1204 my $rowString; 1205 my $outString = "<Table border>\n"; 1206 1207 ## translate data from delimited format to html format 1208 my $row =1; 1209 foreach (@$inArrayref) 1210 { 1211 unless ($_ =~ /\S/) {next;} ## skip blank lines 1212 chomp; 1213 if ( (defined $type) and ($type eq 'htmlform')) {$rowString = &array2htmlRowForm($row, &getRecord($_));} 1214 else {$rowString = &array2htmlRow(&getRecord($_));} 1215 $outString .= $rowString; 1216 $row++; 1217 } 1218 1219 ## setup html end table 1220 $outString .= join '','</Table>',"\n" ; 1221 } 1222 1223 sub delimitedArray2html { 1224 1225 # Takes a ref to an array whose elements are rows of a delimited file 1226 # and outputs a string containing 1227 # an html version of the array suitable for viewing and editing 1228 # in Excel or a browser such as Netscape/Communicator. The $label is the name 1229 # appearing at the top of the form or page. If the third 1230 # optional parameter is 'htmlform', the output is an html form. Otherwise 1231 # the output is a plain html document. 1232 # Blank lines are skipped. White space is removed. 1233 1234 my ($inArrayref, $label, $type) = @_; 1235 1236 ## setup html header and initial table stuff 1237 my $rowString; 1238 my $outString = join '','<HTML>',"\n" ,'<HEAD>',"\n", '<TITLE>'; 1239 $outString .= join '',$label,'</TITLE>',"\n",'</HEAD>',"\n",'<BODY>',"\n"; 1240 $outString .= join '','<H1><CENTER>',$label,'</CENTER></H1>',"\n"; 1241 $outString .= &delimitedArray2htmlTable($inArrayref, $type); 1242 1243 ## setup html footer stuff 1244 $outString .= join '','</BODY>',"\n", '</HTML>'; 1245 } 1246 1247 1248 sub delim2html { 1249 1250 # Takes a delimited file name as input and outputs a string containing 1251 # an html version of the input file suitable for viewing and editing 1252 # in Excel or a browser such as Netscape/Communicator. If the second 1253 # optional parameter is 'htmlform', the output is an html form. Otherwise 1254 # the output is a plain html document. 1255 # Blank lines are skipped. White space is removed. 1256 1257 my ($inFileName,$type) = @_; 1258 1259 my $shortFileName = $inFileName; 1260 unless (defined($type) and $type eq 'htmlform') {$type = 'html';} 1261 if ($shortFileName =~ m|$dd|) { 1262 $shortFileName =~ m|$dd([^$dd]*)$|; ## extract filename from full path name 1263 $shortFileName = $1; 1264 } 1265 $shortFileName =~ s|\..*||; ## remove extension 1266 open(INFILE, $inFileName) || wwerror("$0", "can't open $inFileName"); 1267 my @outArray = <INFILE>; 1268 close(INFILE); 1269 my $outString = delimitedArray2html(\@outArray,$shortFileName,$type); 1270 $outString; 1271 } 1272 1273 1274 1275 1276 sub htmlPage2htmlTable { ## Takes a string which contains a full html page 1277 ## containing a single table and removes all the 1278 ## header and footer material leaving only the row 1279 ## entries between <table> and </table>. Also removes all the 1280 ## <font ...> and </font> stuff from within the table. 1281 ## The cleaned up string is returned. 1282 1283 my ($inString) = @_; 1284 $inString =~ s|^.*<\s*table.*?>||is; ## remove <table> and stuff before 1285 $inString =~ s|<\s*/table\s*>.*?$||is; ## remove </table> and stuff after 1286 $inString =~ s|<\s*/*font.*?>||gis; ## remove font stuff 1287 $inString =~ s|>[^>]*$|>|s; ## remove any stuff after last > 1288 $inString; 1289 } 1290 1291 sub htmlTable2delim { ## Takes a string (e.g. output from htmlPage2htmlTable) which 1292 ## contains the rows from an html table and returns a string 1293 ## containing the table data in delimited format. 1294 1295 my ($inString) = @_; 1296 my ($outString, $item, $rowString); 1297 $outString =''; 1298 while ($inString){ 1299 $inString =~ s|^(.*?<\s*/tr\s*>)||is; # get next row 1300 $item = $1; 1301 $rowString = join("${DELIM}",&htmlRow2array($item)); 1302 $outString .= join '', $rowString, " \n"; 1303 } 1304 $outString; 1305 } 1306 1307 sub htmlForm2delim { ## Takes a reference to the associtive array of inputs from 1308 ## a form. The $inputs{row5col8} is the element for the 5th row 1309 ## and 8 column. It is assumed the input is a rectangular array 1310 ##Returns a string containing the table data in delimited format. 1311 1312 my ($inputsref) = @_; 1313 my %inputs = %$inputsref; 1314 my ($item, $index,$row,$col); 1315 my $maxCol = 1; 1316 my $maxRow = 1; 1317 my @rowColIndex = grep /^row\d+col\d+$/, keys %inputs; 1318 foreach $index (@rowColIndex) { 1319 $index =~ /^row(\d+)col(\d+)$/; 1320 if ($1 > $maxRow) {$maxRow = $1}; 1321 if ($2 > $maxCol) {$maxCol = $2}; 1322 } 1323 1324 my @outArray =(); 1325 my $rowString =''; 1326 my @rowArray= (); 1327 1328 for $row (1..$maxRow) { 1329 @rowArray= (); 1330 for $col (1..$maxCol) {push @rowArray, $inputs{"row${row}col${col}"};} 1331 $rowString = join("${DELIM}",@rowArray); 1332 push (@outArray,$rowString); 1333 } 1334 @outArray = &columnArrayArrange(@outArray); ## line up columns 1335 my $outString = join('',@outArray); 1336 $outString; 1337 } 1338 1339 1340 1341 sub htmlRow2array { 1342 ## The parameter is a string "<TR ... /TR>" containing one row 1343 ## in an html table. The output is an array containing the entries 1344 ## contained in that row. 1345 1346 my ($inString) = @_; 1347 $inString =~ s|^.*<\s*tr.*?>||is; ## remove <tr> and stuff before 1348 $inString =~ s|<\s*/tr\s*>.*$||is; ## remove </tr> and stuff after 1349 $inString =~ s|>[^>]*$|>|s; ## remove any stuff after last > 1350 1351 my @outArray =(); 1352 my $item; 1353 while ($inString){ 1354 $inString =~ s%^(.*?<)\s*/t[d|h]\s*>%%is; # get next entry 1355 $item = $1; 1356 $item =~ m|>\s*(.*?)<|is; # get entry 1357 $item =$1; 1358 $item =~ s|\s*$||; # remove trailing spaces 1359 if (($item eq ' ') or ($item eq '')) {$item =' '} 1360 push @outArray, $item; 1361 } 1362 @outArray; 1363 } 1364 1365 1366 ## this subroutine prints all environment variables. 1367 ## adapted from http://www.cgi-resources.com/Documentation/Environment_Variables/ 1368 ## takes parameters html_top, html_bot which print html top and bottom matter if set 1369 sub printEnvVars { 1370 1371 my ($top, $bot) = @_; 1372 my ($bigcontent, @content, $content,$name,$value,%input,$tvar,$key); 1373 # First, if METHOD=GET we grab the environment variable 1374 # containing the Query_String - otherwise we grab the 1375 # environment variable Content_Length. 1376 if ($ENV{'REQUEST_METHOD'} eq "GET") { 1377 $bigcontent = $ENV{'QUERY_STRING'}; 1378 } # Close if bracket 1379 else { 1380 read(STDIN, $bigcontent, $ENV{'CONTENT_LENGTH'}); 1381 } # Close else bracket 1382 # bigcontent now contains a long string which is broken by 1383 # ampersands between the various form elements. So let's split 1384 # it and load it into an array 1385 @content = split(/&/, $bigcontent); 1386 # But we aren't done yet. All of the spaces in the form data 1387 # were replaced by pluses. Other non-alpha characters except 1388 # equal signs were replaced by their hex values. So now we 1389 # need to step through the array and translate them back into 1390 # their "sent" form. 1391 foreach $content (@content) { 1392 # Split HTML form's "NAME" and "VALUE" at equal signs 1393 ($name, $value) = split(/=/, $content); 1394 # Replace the pluses with spaces 1395 $value =~ tr/+/ /; 1396 # Translate the hex (now preceded by percent sign) into ASCII 1397 $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg; 1398 # And finish by loading input variables for use in program. 1399 # You call it by $input{'formvarname'} to get the literal 1400 # that the user typed into that field on the Form. 1401 $input{$name} = $value; 1402 } # Close bracket for foreach loop 1403 1404 # Tell the server that we are going to send it to user's browser 1405 if ($top eq 'html_top') {print "Content-type: text/html\n\n"; 1406 # So we don't have to type backslashes everywhere before reserved 1407 # characters in the HTML, we use this so the PERL compiler will 1408 # know that what follows is literal (except for variable names) 1409 # But be careful - still need backslash in front of literal at 1410 # signs, dollar signs, etc., since PERL assumes a variable name 1411 # follows these characters. 1412 print <<ENDOFTEXT; 1413 <HTML><HEAD><TITLE>Environment Variable 1414 Test</TITLE></HEAD> 1415 <BODY BGCOLOR="#FFFFFF"> 1416 1417 ENDOFTEXT 1418 } 1419 # Now, simply sort and print the names and values of each of the 1420 # environment variables from the keyed array to browser window 1421 foreach $key (sort keys(%ENV)) {print 1422 "<B>$key:<\/B>$ENV{$key}<BR>";} 1423 1424 if ($bot eq 'html_bot') { 1425 print <<ENDOFTEXT; 1426 1427 <P> 1428 </BODY> 1429 </HTML> 1430 ENDOFTEXT 1431 1432 } 1433 } 1434 1435 sub backupFile { 1436 ## takes as a parameter the full filename 1437 ## makes upto three backups of file with x, y, or z appended to filename where x 1438 ## the most recent backup 1439 1440 my $fileName =$_[0]; 1441 my $orgFileName = "$fileName"; 1442 my ($ext, $fnMinusExt,$noPeriod); 1443 if (! ($orgFileName =~ m|\.|)) { 1444 $noPeriod =1; 1445 $fnMinusExt = $orgFileName; 1446 $ext =''; 1447 } 1448 else { 1449 $noPeriod =0; 1450 $orgFileName =~ m|^(.*)\.([^\.]*)$|; 1451 $fnMinusExt = $1; 1452 $ext = $2; 1453 } 1454 my $period = '.'; 1455 $period = '' if $noPeriod; 1456 if (-e "${fnMinusExt}y${period}${ext}") { 1457 rename("${fnMinusExt}y${period}$ext","${fnMinusExt}z${period}$ext") or 1458 &wwerror("$0","can't rename ${fnMinusExt}y${period}$ext"); 1459 } 1460 1461 if (-e "${fnMinusExt}x${period}$ext") { 1462 rename("${fnMinusExt}x${period}$ext","${fnMinusExt}y${period}$ext") or 1463 &wwerror("$0","can't rename ${fnMinusExt}x${period}$ext"); 1464 } 1465 1466 if (-e "${fnMinusExt}${period}$ext") { 1467 rename("${fnMinusExt}${period}$ext","${fnMinusExt}x${period}$ext") or 1468 &wwerror("$0","can't rename ${fnMinusExt}${period}$ext"); 1469 } 1470 } 1471 1472 sub stripWhiteSpace { ## strip initial and trailing whitespace 1473 my $string = $_[0]; 1474 $string =~ s/\s*$//; # remove trailing whitespace 1475 $string =~ s/^\s*//; # remove initial spaces 1476 $string; 1477 } 1478 1479 sub test_entry{ ## check for bad characters. & and = are used as delimiters 1480 ## in databases. DELIM (usually a coma) is used in csv files 1481 my $entry = shift; 1482 my $msg = 'OK'; 1483 if ($entry =~ /[=&$DELIM]/) { 1484 $msg = " The entry: $entry is invalid. 1485 An entry can not contain any of the following characters: $DELIM & = 1486 You must go back and correct this.\n"; 1487 } 1488 $msg; 1489 } 1490 1491 sub testNewStudentLogin { 1492 my $login_name = shift; 1493 my $newStudentID = shift; 1494 my $msg = 'OK'; 1495 unless ($login_name =~ /^[\w\-\.]+$/) { 1496 $msg = " The login name: $login_name is invalid. 1497 Login name's can contain only upper and lower case letters, digits, -, dot('.'), and _ 1498 you must go back and correct this.\n"; 1499 return $msg; 1500 } 1501 my %currentLogins = %{getLoginName_StudentID_Hash()}; 1502 if (defined $currentLogins{$login_name}){ 1503 attachCLRecord($login_name); 1504 1505 my $studentLastName = CL_getStudentLastName($login_name); 1506 my $studentFirstName = CL_getStudentFirstName($login_name); 1507 my $studentID = CL_getStudentID($login_name); 1508 1509 $msg = " The login name: $login_name is already in use. 1510 It is assigned to $studentFirstName $studentLastName ($studentID). 1511 You must go back and choose a login name which is not yet being used.\n"; 1512 return $msg; 1513 } 1514 1515 ## check that if student login exists in webwork database, the studentID's match 1516 1517 if ( -e "${databaseDirectory}$Global::database" ){ 1518 my %loginName_StudentID_Hash_from_WW_DB =%{getLoginName_StudentID_Hash_from_WW_DB()}; 1519 if (defined $loginName_StudentID_Hash_from_WW_DB{$login_name}) { 1520 my $oldStudentID = $loginName_StudentID_Hash_from_WW_DB{$login_name}; 1521 unless ($newStudentID eq $oldStudentID) { 1522 my %setNumberHash = &getAllSetNumbersForStudentLoginHash($login_name); 1523 my @SetNumberKeys = keys(%setNumberHash); 1524 $msg = " The login name: $login_name is already in use in the webwork problem database. 1525 However, the new student ID ($newStudentID) does not match the old student ID ($oldStudentID). 1526 The following problem sets exist for $login_name $oldStudentID: 1527 Sets: @SetNumberKeys 1528 You have three choices. 1529 (1) Go back and use $oldStudentID for the student ID in which case the above sets will again be 1530 assigned to $login_name $oldStudentID. 1531 (2) Go back and choose a login name which is not yet being used. 1532 (3) Delete the problem sets listed above for $login_name $oldStudentID and then try again adding the student 1533 $login_name $newStudentID."; 1534 1535 return $msg; 1536 } 1537 } 1538 } 1539 $msg; 1540 } 1541 1542 1543 sub testNewStudentID { 1544 my $studentID = shift; 1545 my $newLogin_name = shift; 1546 my $msg ='OK'; 1547 unless ($studentID =~ /^[\w\-\.]+$/) { 1548 $msg = " The student ID: $studentID is invalid. 1549 student ID's can contain only upper and lower case letters, digits, -, dot('.'), and _ 1550 you must go back and correct this.\n"; 1551 return ($msg); 1552 } 1553 my %currentIDs = %{getStudentID_LoginName_Hash()}; 1554 1555 if (defined $currentIDs{$studentID}) { 1556 my $oldLogin = $currentIDs{$studentID}; 1557 attachCLRecord($oldLogin); 1558 1559 my $studentLastName = CL_getStudentLastName($oldLogin); 1560 my $studentFirstName = CL_getStudentFirstName($oldLogin); 1561 1562 1563 $msg = " The student ID: $studentID is already in use. 1564 It is assigned to $studentFirstName $studentLastName ($oldLogin). 1565 you must go back and choose a student ID which is not yet being used.\n"; 1566 return $msg; 1567 } 1568 1569 ## check that if student ID exists in webwork database, the student login's match 1570 1571 if ( -e "${databaseDirectory}$Global::database" ){ 1572 my %loginName_StudentID_Hash_from_WW_DB =%{getLoginName_StudentID_Hash_from_WW_DB()}; 1573 my %studentID_LoginName_Hash_from_WW_DB = reverse %loginName_StudentID_Hash_from_WW_DB; 1574 if (defined $studentID_LoginName_Hash_from_WW_DB{$studentID}) { 1575 my $oldLogin_name = $studentID_LoginName_Hash_from_WW_DB{$studentID}; 1576 unless ($newLogin_name eq $oldLogin_name) { 1577 my %setNumberHash = &getAllSetNumbersForStudentLoginHash($oldLogin_name); 1578 my @SetNumberKeys = keys(%setNumberHash); 1579 $msg = " The student ID: $studentID is already in use in the webwork problem database. 1580 However, the new student Login name ($newLogin_name) does not match the old student Login name ($oldLogin_name). 1581 The following problem sets exist for $oldLogin_name $studentID: 1582 Sets: @SetNumberKeys 1583 You have three choices. 1584 (1) Go back and use $oldLogin_name for the student login name in which case the above sets will again be 1585 assigned to $oldLogin_name $studentID. 1586 (2) Go back and choose a student ID which is not yet being used. 1587 (3) Delete the problem sets listed above for $oldLogin_name $studentID and then try again adding the student 1588 $newLogin_name $studentID."; 1589 1590 return $msg; 1591 } 1592 } 1593 } 1594 1595 1596 $msg; 1597 } 1598 1599 sub getClasslistFilesAndLabels { ## returns a two element array 1600 ## the 0th element is a ref to an array of files 1601 ## the 1st element is a ref to a hash of labels 1602 my $Course = shift; 1603 my $defaultClasslistFile = getCourseClasslistFile($Course); 1604 1605 ## find the available files 1606 1607 opendir CLASSLISTDIR, $templateDirectory or wweror($0,"Can't open directory $templateDirectory"); 1608 my @allFiles = grep !/^\./, readdir CLASSLISTDIR; 1609 closedir CLASSLISTDIR; 1610 1611 ## sort the files 1612 1613 my @classlistFiles = grep /\.lst$/,@allFiles; 1614 my @sortedNames = sort @classlistFiles; 1615 1616 ## put the default classlist file first if it exists 1617 my $shortFileName = $defaultClasslistFile; 1618 if ($shortFileName =~ m|$dd|) { 1619 $shortFileName =~ m|$dd([^$dd]*)$|; ## extract filename from full path name 1620 $shortFileName = $1; 1621 } 1622 my @newSortedNames = grep !/^$shortFileName$/, @sortedNames; 1623 if ($#newSortedNames != $#sortedNames) { 1624 unshift @newSortedNames,$shortFileName; 1625 @sortedNames = @newSortedNames; 1626 } 1627 1628 ## generate labels 1629 my %label_hash = (); 1630 1631 my ($ind,$date,$fileName,@stat); 1632 for $ind (@sortedNames) { 1633 $fileName = "${templateDirectory}$ind"; 1634 if (-e $fileName) { 1635 @stat = stat($fileName); 1636 $date = $stat[9]; 1637 $date = formatDateAndTime($date); 1638 $date =~ s|\s*at.*||; 1639 $label_hash{$ind} = "$ind --- Last Changed $date"; 1640 } 1641 } 1642 (\@sortedNames,\%label_hash); 1643 } 1644 1645 1646 1647 1648 1;
| aubreyja at gmail dot com | ViewVC Help |
| Powered by ViewVC 1.0.9 |