Parent Directory
| 
Revision Log
another setup script test (changed #! lines)
1 #!/usr/local/bin/webwork-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 39 sub round_score { 40 my $num = shift; 41 my $rounding_dem = 10**$Global::score_decimal_digits; 42 int($num*$rounding_dem + .5)/$rounding_dem; 43 } 44 45 46 sub readSetDef { 47 my ($fileName) = @_; 48 my $setNumber = ''; 49 my $shortFileName = fileFromPath($fileName); 50 if ($shortFileName =~ m|^set(\w+)\.def$|) {$setNumber = $1;} 51 else { 52 wwerror("$0", "The setDefinition file name must begin with <CODE>set</CODE> 53 and must end with <CODE>.def</CODE> . Every thing in between becomes the name of the set. 54 For example <CODE>set1.def</CODE>, <CODE>setExam.def</CODE>, and <CODE>setsample7.def</CODE> 55 define sets named <CODE>1</CODE>, <CODE>Exam</CODE>, and <CODE>sample7</CODE> respectively. The 56 filename, $shortFileName, you entered is not legal\n"); 57 } 58 59 my ($line,$name,$value,$attemptLimit); 60 open (SETFILENAME, "$fileName") or wwerror("$0", "Can't open file $fileName\n"); 61 my $setHeaderFileName = ''; 62 my $probHeaderFileName = ''; 63 my @problemList=(); 64 my @problemValueList=(); 65 my @problemAttemptLimitList=(); 66 my ($dueDate,$openDate,$answerDate); 67 my ($problemListref,$problemValueListref,$problemAttemptLimitListref); 68 while (<SETFILENAME>) { 69 chomp($line = $_); 70 $line =~ s|(#.*)||; ## don't read past comments 71 unless ($line =~ /\S/) {next;} ## skip blank lines 72 $line =~ s|\s*$||; ## trim trailing spaces 73 $line =~ m|^\s*(\w+)\s*=\s*(.*)|; 74 if ($1 eq 'setNumber') {next;} 75 elsif ($1 eq 'paperHeaderFile') {$setHeaderFileName = $2;} 76 elsif ($1 eq 'screenHeaderFile') {$probHeaderFileName = $2;} 77 elsif ($1 eq 'dueDate') {$dueDate = $2;} 78 elsif ($1 eq 'openDate') {$openDate = $2;} 79 elsif ($1 eq 'answerDate') {$answerDate = $2;} 80 elsif ($1 eq 'problemList') {last;} 81 else {wwerror("$0", "readSetDef error, can't read the line: $line");} 82 } 83 84 my $time1 = &unformatDateAndTime($openDate); 85 my $time2 = &unformatDateAndTime($dueDate); 86 my $time3 = &unformatDateAndTime($answerDate); 87 if ($time2 < $time1 or $time3 < $time2) { 88 &Global::error('File.pl: readSetDef error', "The open date: $openDate, due date: $dueDate, and answer date: $answerDate 89 must be in chronologicasl order."); 90 } 91 92 $setHeaderFileName =~ s/(.*?)\s*$/$1/; #remove trailing white space 93 $probHeaderFileName =~ s/(.*?)\s*$/$1/; #remove trailing white space 94 95 # print "setNumber: $setNumber\ndueDate: $dueDate\nopenDate: $openDate\nanswerDate: $answerDate\n"; 96 while(<SETFILENAME>) { 97 chomp($line=$_); 98 $line =~ s/(#.*)//; ## don't read past comments 99 unless ($line =~ /\S/) {next;} ## skip blank lines 100 101 ($name, $value, $attemptLimit) = split (/\s*,\s*/,$line); 102 $name =~ s/\s*//g; 103 push(@problemList, $name); 104 $value = "" unless defined($value); 105 $value =~ s/[^\d]*//g; 106 unless ($value =~ /\d+/) {$value = 1;} 107 push(@problemValueList, $value); 108 $attemptLimit = "" unless defined($attemptLimit); 109 $attemptLimit =~ s/[^\d-]*//g; 110 unless ($attemptLimit =~ /\d+/) {$attemptLimit = -1;} 111 112 push(@problemAttemptLimitList, $attemptLimit); 113 } 114 close(SETFILENAME); 115 #print "problemList: @problemList\n"; 116 #print "problemValueList: @problemValueList\n"; 117 #print "problemAttemptLimitList: @problemAttemptLimitList\n"; 118 $problemListref = \@problemList; 119 $problemValueListref = \@problemValueList; 120 $problemAttemptLimitListref = \@problemAttemptLimitList; 121 ($setNumber,$setHeaderFileName,$probHeaderFileName,$dueDate,$openDate,$answerDate,$problemListref,$problemValueListref,$problemAttemptLimitListref); 122 } 123 124 sub max { ## find the max element of array 125 my $out = $_[0]; 126 my $num; 127 foreach $num (@_) { 128 if ((defined $num) and ($num > $out)) {$out = $num;} 129 } 130 $out; 131 } 132 133 sub min { ## find the max element of array 134 my $out = $_[0]; 135 my $num; 136 foreach $num (@_) { 137 if ((defined $num) and ($num < $out)) {$out = $num;} 138 } 139 $out; 140 } 141 142 sub getFieldLengths { 143 144 ## takes as a parameter the reference to a delimited array 145 ## (such as you would get by reading in a delimited file) 146 ## where each element is a line from a delimited file. 147 ## returns an array which holds 148 ## the maximum field lengths in the file. 149 150 my ($datFileArray_ref)=@_; 151 my($i); 152 my(@datArray,@fieldLength,@datFileArray, $line); 153 @fieldLength=(); 154 @datFileArray=@$datFileArray_ref; 155 156 foreach $line (@datFileArray) { ## read through file and get field lengths 157 unless ($line =~ /\S/) {next;} ## skip blank lines 158 chomp $line; 159 @datArray=&getRecord($line); 160 for ($i=0; $i <=$#datArray; $i++) { 161 $fieldLength[$i] = 0 unless defined $fieldLength[$i]; 162 $fieldLength[$i]=&max(length("$datArray[$i]"),$fieldLength[$i]); 163 } 164 } 165 return (@fieldLength); 166 } 167 168 169 sub columnArrayArrange { 170 171 ## takes as a parameter a delimited array 172 ## (such as you would get by reading in a delimited file) 173 ## where each element is a line from a delimited file. 174 175 # Outputs an array which adds 176 # extra space if necessary to the fields so that all columns line up. 177 # The widest field in any column will contain exactly 1 spaces at the 178 # end of the (non space characters of the) field. For example 179 # ",a very long field entry ," at one extreme and ", ," at the other 180 181 my @inFile=@_; 182 my($i,$tempFileName,$datString,$line); 183 my @outFile =(); 184 my(@fieldLength,@datArray); 185 $i=1; 186 187 @fieldLength=&getFieldLengths(\@inFile); 188 foreach $line (@inFile) { ## read through file array and get field lengths 189 unless ($line =~ /\S/) {next;} ## skip blank lines 190 chomp $line; 191 @datArray=&getRecord($line); 192 for ($i=0; $i <=$#datArray; $i++) { 193 $datArray[$i].=(" " x ($fieldLength[$i]+1-length("$datArray[$i]"))); 194 } 195 $datString=join("${DELIM}",@datArray); 196 push @outFile , "$datString\n"; 197 } 198 @outFile; 199 } 200 201 202 sub columnPrint { 203 204 # Takes two parameters. The first is the filename of the 205 # delimited input file. The second is the name of the 206 # output file (these names may be the same). The permissions 207 # and group of the output file will be the same as the 208 # input file 209 210 # Takes any delimited (with \$DELIM delimiters) file and adds 211 # extra space if necessary to the fields so that all columns line up. 212 # The widest field in any column will contain exactly 2 spaces at the 213 # end of the (non space characters 0f the) field. For example 214 # ",a very long field entry ," at one extreme and ", ," at the other 215 # 216 my($inFileName,$outFileName)=@_; 217 my($line); 218 219 my ($permission, $gid) = (stat($inFileName))[2,5]; 220 $permission = ($permission & 0777); ##get rid of file type stuff 221 222 open(INFILE,"$inFileName") or wwerror("$0","can't open $inFileName for reading"); 223 my @inFile=<INFILE>; 224 close(INFILE); 225 226 &createFile($outFileName, $permission, $gid); 227 228 my @outFile = &columnArrayArrange(@inFile); 229 230 open(OUTFILE,">$outFileName") or wwerror("$0","can't open $outFileName for writing"); 231 foreach $line (@outFile) {print OUTFILE $line;} 232 close(OUTFILE); 233 } 234 235 sub getRecord 236 237 # Takes a delimited line as a parameter and returns an 238 # array. Note that all white space is removed. If the 239 # last field is empty, the last element of the returned 240 # array is also empty (unlike what the perl split command 241 # would return). E.G. @lineArray=&getRecord(\$delimitedLine). 242 { 243 my $DELIM = $Global::delim; 244 my($line) = $_[0]; 245 my(@lineArray); 246 $line.='A'; # add 'A' to end of line so that 247 # last field is never empty 248 @lineArray = split(/\s*${DELIM}\s*/,$line); 249 $lineArray[$#lineArray] =~s/\s*A$//; # remove spaces and the 'A' from last element 250 $lineArray[0] =~s/^\s*//; # remove white space from first element 251 @lineArray; 252 } 253 254 255 256 257 sub delim2aa { 258 259 # Takes a delimited file as a parameter and returns an 260 # associative array with the first field as the key. 261 # Blank lines are skipped. White space is removed 262 263 my $fileName =$_[0]; 264 my(@dbArray,$key,%assocArray,$dbString); 265 open(FILE, "$fileName") or wwerror("$0","can't open $fileName"); 266 while (<FILE>) 267 { 268 unless ($_ =~ /\S/) {next;} ## skip blank lines 269 chomp; 270 @dbArray=&getRecord($_); 271 $key=shift(@dbArray); 272 $dbString=join("${DELIM}",@dbArray); 273 $assocArray{$key}=$dbString; 274 } 275 close(FILE); 276 %assocArray; 277 } 278 sub dropStatus 279 280 # Takes one parameter \$status and returns 1 if \$status matches a word in the 281 # \@STATUS_DROP global array, 0 otherwise. E.G. if ($dropStatus(\$status) {...} 282 # where \$status is the entry in the status field of the class list. \@STATUS_DROP 283 # is a global array defined in webwork.ph 284 { 285 my($tag) = 0; 286 my($status) = $_[0]; 287 my($statusItem); 288 foreach $statusItem (@STATUS_DROP) 289 { 290 if ($status =~ /^\s*$statusItem\s*$/i) {$tag = 1;} 291 292 } 293 $tag; 294 } 295 296 297 sub beforeOpenDateMsg { 298 my ($OpenDate) = @_; 299 my $out = " --- <em>Before open date</em> -- "; 300 $out .= "Open date is: $OpenDate <BR>"; 301 $out; 302 }; 303 sub afterOpenDateMsg { #and before Due Date 304 my ($DueDate) = @_; 305 my $out = " --- <em><B>OPEN</B></em>"; 306 $out .= " -- Due date is: $DueDate <BR>"; 307 $out; 308 }; 309 sub afterDueDateMsg { #and before AnswerDate 310 my ($AnswerDate) = @_; 311 my $out = " --- <em><B>CLOSED</B></em> --"; 312 $out .= " Answers available on: $AnswerDate <BR>"; 313 $out; 314 }; 315 sub afterAnswerDateMsg { 316 my $out = " --- <em><B>CLOSED</B></em> -- "; 317 $out .= " answers available.<BR>"; 318 $out; 319 }; 320 321 322 sub problemDates { 323 my ($OpenDate,$DueDate,$AnswerDate) = @_; 324 my $out = <<ENDproblemDatesHTML; 325 <PRE> 326 Open: $OpenDate 327 <B>Due: $DueDate</B> 328 Answer: $AnswerDate 329 </PRE> 330 ENDproblemDatesHTML 331 332 $out; 333 } 334 335 sub formatDateAndTime { 336 my ($timeStamp)=@_; 337 my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = 338 localtime($timeStamp); 339 my $twelveHour; 340 if($min<10){$min= "0" . $min;} 341 342 if($hour==0){$twelveHour = 12 . ":" . $min . " AM";} 343 elsif($hour<12){$twelveHour= $hour . ":" . $min . " AM";} 344 elsif($hour==12){$twelveHour = $hour . ":" . $min . " PM";} 345 else {$twelveHour = ($hour-12) . ":" . $min . " PM";} 346 347 if($year>99){$year = $year -100;} 348 if($year<10){$year= "0" . $year;} 349 350 my $returnTimeString = ($mon+1) . "/" . $mday . "/" . $year . " at " . $twelveHour; 351 $returnTimeString; 352 } 353 354 355 sub unformatDateAndTime { 356 my ($string) = @_; 357 my $orgString =$string; 358 $string =~ s|^\s+||; 359 $string =~ s|\s+$||; 360 $string =~ s|at| at |i; ## OK if forget to enter spaces or use wrong case 361 $string =~ s|AM| AM|i; ## OK if forget to enter spaces or use wrong case 362 $string =~ s|PM| PM|i; ## OK if forget to enter spaces or use wrong case 363 $string =~ s|,| at |; ## start translating old form of date/time to new form 364 365 my($date,$at,$time,$AMPM) = split(/\s+/,$string); 366 unless ($time =~ /:/) { 367 { ##bare block for 'case" structure 368 $time =~ /(\d\d)(\d\d)/; 369 my $tmp_hour = $1; 370 my $tmp_min = $2; 371 if ($tmp_hour eq '00') {$time = "12:$tmp_min"; $AMPM = 'AM';last;} 372 if ($tmp_hour eq '12') {$time = "12:$tmp_min"; $AMPM = 'PM';last;} 373 if ($tmp_hour < 12) {$time = "$tmp_hour:$tmp_min"; $AMPM = 'AM';last;} 374 if ($tmp_hour < 24) { 375 $tmp_hour = $tmp_hour - 12; 376 $time = "$tmp_hour:$tmp_min"; 377 $AMPM = 'PM'; 378 } 379 } ##end of bare block for 'case" structure 380 381 } 382 383 my ($mday, $mon, $year, $wday, $yday,$sec, $pm, $min, $hour); 384 $sec=0; 385 $time =~ /^([0-9]+)\s*\:\s*([0-9]*)/; 386 $min=$2; 387 $hour = $1; 388 if ( $hour < 1 or $hour > 12 or $min < 0 or $min > 59) { 389 &Global::error('File.pl: unformatDateAndTime error', "Incorrect date/time format $orgString. Correct format is 9/13/02 at 12:15 PM"); 390 } 391 $pm = 0; 392 $pm = 12 if ($AMPM =~/PM/ and $hour < 12); 393 $hour += $pm; 394 $hour = 0 if ($AMPM =~/AM/ and $hour == 12); 395 $date =~ m!([0-9]+)\s*/\s*([0-9]+)/\s*([0-9]+)! ; 396 $mday =$2; 397 $mon=($1-1); 398 if ( $mday < 1 or $mday > 31 or $mon < 0 or $mon > 11) { 399 &Global::error('File.pl: unformatDateAndTime error', "Incorrect date/time format $orgString. Correct format is 9/13/02 at 12:15 PM"); 400 } 401 $year=$3; 402 $wday=""; 403 $yday=""; 404 timelocal ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday); 405 } 406 407 sub texInput 408 409 ## Similar to the TeX input command. Takes a filename (with or without extension) 410 ## which is assumed to be in the \$templateDirectory. 411 ## E.G. print OUTFILE &texInput("file.tex"); 412 ## or print OUTFILE &texInput("file"); 413 414 { 415 my $texInFile = $_[0]; 416 my $texString; 417 if ($texInFile eq "") { 418 $texString = ''; 419 } else { 420 unless ($texInFile =~ m#\.#) {$texInFile .= '.tex';} 421 open(TEX_IN_FILE,"${templateDirectory}$texInFile") || 422 &Global::error("File.pl: textInput error", " Can't open ${templateDirectory}$texInFile"); 423 my @texInputArray = <TEX_IN_FILE>; 424 close(TEX_IN_FILE); 425 $texString = join('',@texInputArray); 426 unless ($texString =~ /\n$/s) {$texString .= "\n";} 427 } 428 ## print "$texString"; 429 $texString; 430 } 431 432 433 434 435 436 # A very useful macro for making sure that all of the directories to a file have been constructed. 437 438 sub surePathToTmpFile { # constructs intermediate directories if needed beginning at ${Global::htmlDirectory}tmp/ 439 # the input path must be either the full path, or the path relative to this tmp sub directory 440 my $path = shift; 441 my $delim = &getDirDelim(); 442 my $tmpDirectory = getCourseTempDirectory(); 443 # if the path starts with $tmpDirectory (which is permitted but optional) remove this initial segment 444 $path =~ s|^$tmpDirectory|| if $path =~ m|^$tmpDirectory|; 445 $path = convertPath($path); 446 # find the nodes on the given path 447 my @nodes = split("$delim",$path); 448 # create new path 449 $path = convertPath("$tmpDirectory"); 450 451 while (@nodes>1 ) { 452 $path = convertPath($path . shift (@nodes) ."/"); 453 unless (-e $path) { 454 # system("mkdir $path"); 455 createDirectory($path,$Global::tmp_directory_permission, $Global::numericalGroupID) || 456 wwerror($0, "Failed to create directory $path","","",""); 457 458 } 459 460 } 461 $path = convertPath($path . shift(@nodes)); 462 463 # system(qq!echo "" > $path! ); 464 465 $path; 466 467 } 468 469 470 471 472 sub fileFromPath { 473 my $path = shift; 474 my $delim =&getDirDelim(); 475 $path = convertPath($path); 476 $path =~ m|([^$delim]+)$|; 477 $1; 478 479 } 480 481 sub directoryFromPath { 482 my $path = shift; 483 my $delim =&getDirDelim(); 484 $path = convertPath($path); 485 $path =~ s|[^$delim]*$||; 486 $path; 487 } 488 489 sub createDirectory 490 { 491 my ($dirName, $permission, $numgid) = @_; 492 mkdir($dirName, $permission) or 493 wwerror("$0: createDirectory error", " Can't do mkdir($dirName, $permission)"); 494 chmod($permission, $dirName) or 495 wwerror("$0: createDirectory error", " Can't do chmod($permission, $dirName)"); 496 unless ($numgid == -1) {chown(-1,$numgid,$dirName) or 497 wwerror("$0: createDirectory error", " Can't do chown(-1,$numgid,$dirName)");} 498 } 499 use Cwd; 500 sub createFile { 501 my ($fileName, $permission, $numgid) = @_; 502 # my $decimal_per = sprintf "%lo", $permission; 503 # print "\n IN createFile: file is $fileName, permission is $decimal_per, gid is $numgid\n"; 504 505 open(TEMPCREATEFILE, ">$fileName") || 506 wwerror("File.pl: createFile error", " Can't open $fileName"); 507 my @stat = stat TEMPCREATEFILE; 508 close(TEMPCREATEFILE); 509 510 ## if the owner of the file is running this script (e.g. when the file is first created) 511 ## set the permissions and group correctly 512 if ($< == $stat[4]) { 513 # my $oldDirectory = cwd(); 514 # warn " old directory is $oldDirectory<BR>\n"; 515 # my $newDirectory = $fileName; 516 # $newDirectory =~ s|/[^/]+$||; 517 # warn " new directory is $newDirectory<BR>\n"; 518 # $fileName =~ m|([^/]+$)|; 519 # my $newFileName = $1; 520 # warn "new File name = $newFileName<BR>\n"; 521 # chdir $newDirectory; 522 # warn "changing to directory =" .cwd() ."<BR>\n"; 523 # 524 #chmod(0777,$fileName); 525 my $tmp = chmod($permission,$fileName) or 526 warn("File.pl: createFile error", " Can't do chmod($permission, $fileName)"); 527 chown(-1,$numgid,$fileName) or 528 warn("File.pl: createFile error", " Can't do chown($numgid, $fileName)"); 529 # #warn "foo is readable<BR>\n" if -w 'foo.gif'; 530 # #warn "chmod =" . chmod($permission,$newFileName) || 531 # # warn("File.pl: createFile error", " Can't do chmod($permission, $newFileName)"); 532 # #chdir $oldDirectory; 533 # #warn "changed back to directory =" .cwd() ."<BR>\n"; 534 } 535 } 536 537 sub rmDirectoryAndFiles 538 { 539 my ($PROBDIR) =@_; 540 my @allfiles = (); 541 opendir( DIRHANDLE, "$PROBDIR") || warn qq/Can't read directory $PROBDIR $!/; 542 @allfiles = map "$PROBDIR$_", grep( !/^\.\.?$/, readdir DIRHANDLE); 543 closedir(DIRHANDLE); 544 # print "unlinking<BR>",join("<BR>", @allfiles),"<P>"; 545 unlink(@allfiles); 546 # print "removing directory $PROBDIR <P>"; 547 rmdir("$PROBDIR"); 548 } 549 550 551 552 # this returns an array of set names sorted by due date (with all open sets first). 553 # It is called by a reference to a hash with keys the Set Names and values psvn's 554 # such as returned by &getAllProbSetNumbersHash or &getAllSetNumbersForStudentLoginHash 555 556 sub sortSetNamesByDueDate { 557 my ($setNameHashref) = @_; 558 my %setNameHash = %$setNameHashref; 559 my ($setName,$psvn,$ddts,$timeNow); 560 my %dueTimes =(); 561 562 foreach $setName (keys %setNameHash) { 563 $psvn=$setNameHash{$setName}; 564 &attachProbSetRecord($psvn); 565 $ddts=&getDueDate($psvn); 566 $dueTimes{$setName} = $ddts; 567 } 568 569 my @sortedSetNames = sort 570 571 ## Sort setnumbers by due date. Using an anonymous block so that 572 ## dueTimes gets passes without making it global to FILE.pl or 573 ## passing it to a sorting subroutine (can we pass this?) 574 575 { 576 $timeNow = time; 577 if ( ($dueTimes{$a} <= $timeNow) and ($dueTimes{$b} <= $timeNow) ) 578 { 579 $dueTimes{$a} <=> $dueTimes{$b} 580 or 581 $a cmp $b 582 } 583 elsif ( ($dueTimes{$a} > $timeNow) and ($dueTimes{$b} > $timeNow) ) 584 { 585 $dueTimes{$a} <=> $dueTimes{$b} 586 or 587 $a cmp $b 588 } 589 else 590 { 591 $dueTimes{$b} <=> $dueTimes{$a} 592 } 593 } 594 595 keys %setNameHash ; 596 @sortedSetNames; 597 } 598 599 sub checkClasslistFile { 600 ## takes as parameters the number of fields and the full path name of 601 ## the classlist file. Checks that the file iv valid, i.e. (1) all records 602 ## have the same number of fields, (2) the first fields (studentID's, usually SS#'s) are 603 ## all distinct and (3) the last fields (the loginID's) are all distinct, 604 ## and (4) that studentID's and loginID's comtain only valid characters 605 606 my($noOfFields,$fileName)=@_; 607 my $msg = htmlCheckClasslistFile($noOfFields,$fileName); 608 unless ($msg eq 'OK') { 609 &wwerror("$0","$msg"); 610 } 611 } 612 613 sub htmlCheckClasslistFile { 614 ## takes as parameters the number of fields and the full path name of 615 ## the classlist file. Checks that the file iv valid, i.e. (1) all records 616 ## have the same number of fields, (2) the first fields (studentID's, usually SS#'s) are 617 ## all distinct and (3) the last fields (the loginID's) are all distinct, 618 ## and (4) that studentID's and loginID's comtain only valid characters and 619 ## (5) that other fields do not contain bas chacters 620 621 my($noOfFields,$fileName)=@_; 622 623 open (FILE, "$fileName") or 624 &wwerror("$0","can't open $fileName"); 625 my @classList = <FILE>; 626 close(FILE); 627 628 my $msg = checkClasslistArray($noOfFields, \@classList,$fileName); 629 return $msg; 630 } 631 632 sub checkClasslistArray { 633 ## takes as parameters the number of fields and a ref to 634 ## the classlist array. Checks that the file iv valid, i.e. (1) all records 635 ## have the same number of fields, (2) the first fields (studentID's, usually SS#'s) are 636 ## all distinct and (3) the last fields (the loginID's) are all distinct, 637 ## and (4) that studentID's and loginID's comtain only valid characters and 638 ## (5) that other fields do not contain bas chacters 639 640 my($noOfFields,$classListref,$fileName)=@_; 641 my($noOfDelim,$dbString,$num,$i,@classList); 642 my(@keyList); 643 my $msg =''; 644 $noOfDelim = $noOfFields -1; 645 646 @classList = @$classListref; 647 648 foreach $dbString (@classList) { 649 unless ($dbString =~ /\S/) {next;} 650 chomp $dbString; 651 $num=($dbString =~s/$DELIM/$DELIM/g); 652 if ($num != $noOfDelim) { 653 $num =$num+1; 654 $msg = "\n\n The classlist file\n $fileName \n is corrupted. The record\n 655 $dbString \n contains $num fields instead of $noOfFields fields. \nYou 656 must correct this and then run this script again. 657 \n\n"; 658 return $msg; 659 } 660 } 661 my (@SSList, @loginList); 662 @SSList=(); @loginList=(); 663 foreach $dbString (@classList) { 664 unless ($dbString =~ /\S/) {next;} 665 chomp $dbString; 666 my @classListRecord=&getRecord($dbString); 667 my ($studentID, $lastName, $firstName, $status, $comment, $section,$recitation, $email_address, $login_name) 668 = @classListRecord; 669 # next if &dropStatus($status); ## ignore students who have dropped 670 unless ($studentID =~ /^[\w\-\.]+$/) { 671 $msg = "\n\n The classlist file\n$fileName\n\n is corrupted. The record 672 \n$dbString \n contains the invalid studentID: $studentID 673 \n studentID's can contain only upper and lower case letters, digits, -, dot('.'), and _ 674 \n You must correct this and then run this script again.\n\n"; 675 return $msg; 676 } 677 unless ($login_name =~ /^[\w\-\.]+$/) { 678 $msg = "\n\n The classlist file\n$fileName\n\n is corrupted. The record 679 \n$dbString \n contains the invalid loginName: $login_name 680 \n loginName's can contain only upper and lower case letters, digits, -, dot('.'), and _ 681 \n You must correct this and then run this script again.\n\n"; 682 return $msg; 683 } 684 685 ## test entries for bad characters. 686 my @entries = ($lastName, $firstName, $status, $comment, $section,$recitation, $email_address); 687 my $item =''; 688 foreach $item (@entries) { 689 my $msg = test_entry($item); 690 unless ($msg eq 'OK') {return $msg;} 691 } 692 693 push(@SSList,$studentID); 694 push(@loginList,$login_name); 695 } 696 @SSList = sort(@SSList); 697 for ($i=0; $i < @SSList-1; $i++) { 698 if ($SSList[$i] eq $SSList[$i+1]) { 699 $msg = "\n\n The classlist file\n$fileName\n\n is corrupted. Duplicate studentID's equal 700 to $SSList[$i] in\n $fileName\nYou must correct this and then run this script again.\n\n"; 701 return $msg; 702 } 703 } 704 @loginList = sort(@loginList); 705 for ($i=0; $i < @loginList-1; $i++) { 706 if ($loginList[$i] eq $loginList[$i+1]) { 707 $msg ="\n\n The classlist file\n$fileName\n\n is corrupted. Duplicate loginNames equal 708 to $loginList[$i] in\n 709 $fileName\nYou must correct this and then run this script again.\n\n"; 710 return $msg; 711 } 712 } 713 $msg ='OK'; 714 return $msg; 715 } 716 717 ### macros for writing and reading html tables 718 719 sub array2htmlRow { 720 ## The parameter is an array whose entries will beccome elements of a row 721 ## in an html table. The output is a string formated the same way Excel 722 ## formats html tables: numbers aligned right, other things left. 723 724 my @inArray = @_; 725 my ($item,$align); 726 my $outString =''; 727 $outString = join '','<TR ALIGN="left" VALIGN="bottom">',"\n"; 728 foreach $item (@inArray) { 729 unless ($item =~ /\S/) {$item = ' ';} 730 if ($item =~/^[\d\.]+$/){$align ='RIGHT'} else {$align ='LEFT'} 731 $outString .= join '','<TD ALIGN=',$align,'>',"\n"; 732 $outString .= join '',$item,'</TD>',"\n"; 733 } 734 $outString .= join '','</TR>',"\n"; 735 } 736 737 sub array2htmlRowForm { 738 ## The parameter is an array whose first entry is the row number (1, 2, etc) 739 ## and remaining entries will become elements of a row 740 ## in an html table. 741 742 my ($row,@inArray) = @_; 743 my ($item,$size); 744 my $outString =''; 745 my $col =1; 746 $outString = join '','<TR ALIGN=LEFT VALIGN=BOTTOM>',"\n"; 747 foreach $item (@inArray) { 748 unless ($item =~ /\S/) {$item = ' ';} 749 $size = length($item); 750 $outString .= join '','<TD>',"\n"; 751 $outString .= join '','<INPUT TYPE="TEXT" SIZE = ', $size, ' NAME="',"row${row}col$col",'" VALUE="',"$item",'"> </TD>',"\n"; 752 753 $col++; 754 } 755 $outString .= join '','</TR>',"\n"; 756 } 757 758 sub delimitedArray2htmlTable { 759 760 # Takes a ref to an array whose elements are rows of a delimited file 761 # and outputs a string containing 762 # an html table version of the array suitable for viewing and editing 763 # in Excel or a browser such as Netscape/Communicator. If the second 764 # optional parameter is 'htmlform', the output is an html form. Otherwise 765 # the output is a plain html document. 766 # Blank lines are skipped. White space is removed. 767 768 my ($inArrayref, $type) = @_; 769 770 ## setup html header and initial table stuff 771 my $rowString; 772 my $outString = "<Table border>\n"; 773 774 ## translate data from delimited format to html format 775 my $row =1; 776 foreach (@$inArrayref) 777 { 778 unless ($_ =~ /\S/) {next;} ## skip blank lines 779 chomp; 780 if ( (defined $type) and ($type eq 'htmlform')) {$rowString = &array2htmlRowForm($row, &getRecord($_));} 781 else {$rowString = &array2htmlRow(&getRecord($_));} 782 $outString .= $rowString; 783 $row++; 784 } 785 786 ## setup html end table 787 $outString .= join '','</Table>',"\n" ; 788 } 789 790 sub delimitedArray2html { 791 792 # Takes a ref to an array whose elements are rows of a delimited file 793 # and outputs a string containing 794 # an html version of the array suitable for viewing and editing 795 # in Excel or a browser such as Netscape/Communicator. The $label is the name 796 # appearing at the top of the form or page. If the third 797 # optional parameter is 'htmlform', the output is an html form. Otherwise 798 # the output is a plain html document. 799 # Blank lines are skipped. White space is removed. 800 801 my ($inArrayref, $label, $type) = @_; 802 803 ## setup html header and initial table stuff 804 my $rowString; 805 my $outString = join '','<HTML>',"\n" ,'<HEAD>',"\n", '<TITLE>'; 806 $outString .= join '',$label,'</TITLE>',"\n",'</HEAD>',"\n",'<BODY>',"\n"; 807 $outString .= join '','<H1><CENTER>',$label,'</CENTER></H1>',"\n"; 808 $outString .= &delimitedArray2htmlTable($inArrayref, $type); 809 810 ## setup html footer stuff 811 $outString .= join '','</BODY>',"\n", '</HTML>'; 812 } 813 814 815 sub delim2html { 816 817 # Takes a delimited file name as input and outputs a string containing 818 # an html version of the input file suitable for viewing and editing 819 # in Excel or a browser such as Netscape/Communicator. If the second 820 # optional parameter is 'htmlform', the output is an html form. Otherwise 821 # the output is a plain html document. 822 # Blank lines are skipped. White space is removed. 823 824 my ($inFileName,$type) = @_; 825 826 my $shortFileName = $inFileName; 827 unless (defined($type) and $type eq 'htmlform') {$type = 'html';} 828 if ($shortFileName =~ m|$dd|) { 829 $shortFileName =~ m|$dd([^$dd]*)$|; ## extract filename from full path name 830 $shortFileName = $1; 831 } 832 $shortFileName =~ s|\..*||; ## remove extension 833 open(INFILE, $inFileName) || wwerror("$0", "can't open $inFileName"); 834 my @outArray = <INFILE>; 835 close(INFILE); 836 my $outString = delimitedArray2html(\@outArray,$shortFileName,$type); 837 $outString; 838 } 839 840 841 842 843 sub htmlPage2htmlTable { ## Takes a string which contains a full html page 844 ## containing a single table and removes all the 845 ## header and footer material leaving only the row 846 ## entries between <table> and </table>. Also removes all the 847 ## <font ...> and </font> stuff from within the table. 848 ## The cleaned up string is returned. 849 850 my ($inString) = @_; 851 $inString =~ s|^.*<\s*table.*?>||is; ## remove <table> and stuff before 852 $inString =~ s|<\s*/table\s*>.*?$||is; ## remove </table> and stuff after 853 $inString =~ s|<\s*/*font.*?>||gis; ## remove font stuff 854 $inString =~ s|>[^>]*$|>|s; ## remove any stuff after last > 855 $inString; 856 } 857 858 sub htmlTable2delim { ## Takes a string (e.g. output from htmlPage2htmlTable) which 859 ## contains the rows from an html table and returns a string 860 ## containing the table data in delimited format. 861 862 my ($inString) = @_; 863 my ($outString, $item, $rowString); 864 $outString =''; 865 while ($inString){ 866 $inString =~ s|^(.*?<\s*/tr\s*>)||is; # get next row 867 $item = $1; 868 $rowString = join("${DELIM}",&htmlRow2array($item)); 869 $outString .= join '', $rowString, " \n"; 870 } 871 $outString; 872 } 873 874 sub htmlForm2delim { ## Takes a reference to the associtive array of inputs from 875 ## a form. The $inputs{row5col8} is the element for the 5th row 876 ## and 8 column. It is assumed the input is a rectangular array 877 ##Returns a string containing the table data in delimited format. 878 879 my ($inputsref) = @_; 880 my %inputs = %$inputsref; 881 my ($item, $index,$row,$col); 882 my $maxCol = 1; 883 my $maxRow = 1; 884 my @rowColIndex = grep /^row\d+col\d+$/, keys %inputs; 885 foreach $index (@rowColIndex) { 886 $index =~ /^row(\d+)col(\d+)$/; 887 if ($1 > $maxRow) {$maxRow = $1}; 888 if ($2 > $maxCol) {$maxCol = $2}; 889 } 890 891 my @outArray =(); 892 my $rowString =''; 893 my @rowArray= (); 894 895 for $row (1..$maxRow) { 896 @rowArray= (); 897 for $col (1..$maxCol) {push @rowArray, $inputs{"row${row}col${col}"};} 898 $rowString = join("${DELIM}",@rowArray); 899 push (@outArray,$rowString); 900 } 901 @outArray = &columnArrayArrange(@outArray); ## line up columns 902 my $outString = join('',@outArray); 903 $outString; 904 } 905 906 907 908 sub htmlRow2array { 909 ## The parameter is a string "<TR ... /TR>" containing one row 910 ## in an html table. The output is an array containing the entries 911 ## contained in that row. 912 913 my ($inString) = @_; 914 $inString =~ s|^.*<\s*tr.*?>||is; ## remove <tr> and stuff before 915 $inString =~ s|<\s*/tr\s*>.*$||is; ## remove </tr> and stuff after 916 $inString =~ s|>[^>]*$|>|s; ## remove any stuff after last > 917 918 my @outArray =(); 919 my $item; 920 while ($inString){ 921 $inString =~ s%^(.*?<)\s*/t[d|h]\s*>%%is; # get next entry 922 $item = $1; 923 $item =~ m|>\s*(.*?)<|is; # get entry 924 $item =$1; 925 $item =~ s|\s*$||; # remove trailing spaces 926 if (($item eq ' ') or ($item eq '')) {$item =' '} 927 push @outArray, $item; 928 } 929 @outArray; 930 } 931 932 933 ## this subroutine prints all environment variables. 934 ## adapted from http://www.cgi-resources.com/Documentation/Environment_Variables/ 935 ## takes parameters html_top, html_bot which print html top and bottom matter if set 936 sub printEnvVars { 937 938 my ($top, $bot) = @_; 939 my ($bigcontent, @content, $content,$name,$value,%input,$tvar,$key); 940 # First, if METHOD=GET we grab the environment variable 941 # containing the Query_String - otherwise we grab the 942 # environment variable Content_Length. 943 if ($ENV{'REQUEST_METHOD'} eq "GET") { 944 $bigcontent = $ENV{'QUERY_STRING'}; 945 } # Close if bracket 946 else { 947 read(STDIN, $bigcontent, $ENV{'CONTENT_LENGTH'}); 948 } # Close else bracket 949 # bigcontent now contains a long string which is broken by 950 # ampersands between the various form elements. So let's split 951 # it and load it into an array 952 @content = split(/&/, $bigcontent); 953 # But we aren't done yet. All of the spaces in the form data 954 # were replaced by pluses. Other non-alpha characters except 955 # equal signs were replaced by their hex values. So now we 956 # need to step through the array and translate them back into 957 # their "sent" form. 958 foreach $content (@content) { 959 # Split HTML form's "NAME" and "VALUE" at equal signs 960 ($name, $value) = split(/=/, $content); 961 # Replace the pluses with spaces 962 $value =~ tr/+/ /; 963 # Translate the hex (now preceded by percent sign) into ASCII 964 $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg; 965 # And finish by loading input variables for use in program. 966 # You call it by $input{'formvarname'} to get the literal 967 # that the user typed into that field on the Form. 968 $input{$name} = $value; 969 } # Close bracket for foreach loop 970 971 # Tell the server that we are going to send it to user's browser 972 if ($top eq 'html_top') {print "Content-type: text/html\n\n"; 973 # So we don't have to type backslashes everywhere before reserved 974 # characters in the HTML, we use this so the PERL compiler will 975 # know that what follows is literal (except for variable names) 976 # But be careful - still need backslash in front of literal at 977 # signs, dollar signs, etc., since PERL assumes a variable name 978 # follows these characters. 979 print <<ENDOFTEXT; 980 <HTML><HEAD><TITLE>Environment Variable 981 Test</TITLE></HEAD> 982 <BODY BGCOLOR="#FFFFFF"> 983 984 ENDOFTEXT 985 } 986 # Now, simply sort and print the names and values of each of the 987 # environment variables from the keyed array to browser window 988 foreach $key (sort keys(%ENV)) {print 989 "<B>$key:<\/B>$ENV{$key}<BR>";} 990 991 if ($bot eq 'html_bot') { 992 print <<ENDOFTEXT; 993 994 <P> 995 </BODY> 996 </HTML> 997 ENDOFTEXT 998 999 } 1000 } 1001 1002 sub backupFile { 1003 ## takes as a parameter the full filename 1004 ## makes upto three backups of file with x, y, or z appended to filename where x 1005 ## the most recent backup 1006 1007 my $fileName =$_[0]; 1008 my $orgFileName = "$fileName"; 1009 my ($ext, $fnMinusExt,$noPeriod); 1010 if (! ($orgFileName =~ m|\.|)) { 1011 $noPeriod =1; 1012 $fnMinusExt = $orgFileName; 1013 $ext =''; 1014 } 1015 else { 1016 $noPeriod =0; 1017 $orgFileName =~ m|^(.*)\.([^\.]*)$|; 1018 $fnMinusExt = $1; 1019 $ext = $2; 1020 } 1021 my $period = '.'; 1022 $period = '' if $noPeriod; 1023 if (-e "${fnMinusExt}y${period}${ext}") { 1024 rename("${fnMinusExt}y${period}$ext","${fnMinusExt}z${period}$ext") or 1025 &wwerror("$0","can't rename ${fnMinusExt}y${period}$ext"); 1026 } 1027 1028 if (-e "${fnMinusExt}x${period}$ext") { 1029 rename("${fnMinusExt}x${period}$ext","${fnMinusExt}y${period}$ext") or 1030 &wwerror("$0","can't rename ${fnMinusExt}x${period}$ext"); 1031 } 1032 1033 if (-e "${fnMinusExt}${period}$ext") { 1034 rename("${fnMinusExt}${period}$ext","${fnMinusExt}x${period}$ext") or 1035 &wwerror("$0","can't rename ${fnMinusExt}${period}$ext"); 1036 } 1037 } 1038 1039 sub stripWhiteSpace { ## strip initial and trailing whitespace 1040 my $string = $_[0]; 1041 $string =~ s/\s*$//; # remove trailing whitespace 1042 $string =~ s/^\s*//; # remove initial spaces 1043 $string; 1044 } 1045 1046 sub test_entry{ ## check for bad characters. & and = are used as delimiters 1047 ## in databases. DELIM (usually a coma) is used in csv files 1048 my $entry = shift; 1049 my $msg = 'OK'; 1050 if ($entry =~ /[=&$DELIM]/) { 1051 $msg = " The entry: $entry is invalid. 1052 An entry can not contain any of the following characters: $DELIM & = 1053 You must go back and correct this.\n"; 1054 } 1055 $msg; 1056 } 1057 1058 sub testNewStudentLogin { 1059 my $login_name = shift; 1060 my $newStudentID = shift; 1061 my $msg = 'OK'; 1062 unless ($login_name =~ /^[\w\-\.]+$/) { 1063 $msg = " The login name: $login_name is invalid. 1064 Login name's can contain only upper and lower case letters, digits, -, dot('.'), and _ 1065 you must go back and correct this.\n"; 1066 return $msg; 1067 } 1068 my %currentLogins = %{getLoginName_StudentID_Hash()}; 1069 if (defined $currentLogins{$login_name}){ 1070 attachCLRecord($login_name); 1071 1072 my $studentLastName = CL_getStudentLastName($login_name); 1073 my $studentFirstName = CL_getStudentFirstName($login_name); 1074 my $studentID = CL_getStudentID($login_name); 1075 1076 $msg = " The login name: $login_name is already in use. 1077 It is assigned to $studentFirstName $studentLastName ($studentID). 1078 You must go back and choose a login name which is not yet being used.\n"; 1079 return $msg; 1080 } 1081 $msg; 1082 } 1083 1084 1085 sub testNewStudentID { 1086 my $studentID = shift; 1087 my $newLogin_name = shift; 1088 my $msg ='OK'; 1089 unless ($studentID =~ /^[\w\-\.]+$/) { 1090 $msg = " The student ID: $studentID is invalid. 1091 student ID's can contain only upper and lower case letters, digits, -, dot('.'), and _ 1092 you must go back and correct this.\n"; 1093 return ($msg); 1094 } 1095 my %currentIDs = %{getStudentID_LoginName_Hash()}; 1096 1097 if (defined $currentIDs{$studentID}) { 1098 my $oldLogin = $currentIDs{$studentID}; 1099 attachCLRecord($oldLogin); 1100 1101 my $studentLastName = CL_getStudentLastName($oldLogin); 1102 my $studentFirstName = CL_getStudentFirstName($oldLogin); 1103 1104 1105 $msg = " The student ID: $studentID is already in use. 1106 It is assigned to $studentFirstName $studentLastName ($oldLogin). 1107 you must go back and choose a student ID which is not yet being used.\n"; 1108 return $msg; 1109 } 1110 $msg; 1111 } 1112 1113 sub getClasslistFilesAndLabels { ## returns a two element array 1114 ## the 0th element is a ref to an array of files 1115 ## the 1st element is a ref to a hash of labels 1116 my $Course = shift; 1117 my $defaultClasslistFile = getCourseClasslistFile($Course); 1118 1119 ## find the available files 1120 1121 opendir CLASSLISTDIR, $templateDirectory or wweror($0,"Can't open directory $templateDirectory"); 1122 my @allFiles = grep !/^\./, readdir CLASSLISTDIR; 1123 closedir CLASSLISTDIR; 1124 1125 ## sort the files 1126 1127 my @classlistFiles = grep /\.lst$/,@allFiles; 1128 my @sortedNames = sort @classlistFiles; 1129 1130 ## put the default classlist file first if it exists 1131 my $shortFileName = $defaultClasslistFile; 1132 if ($shortFileName =~ m|$dd|) { 1133 $shortFileName =~ m|$dd([^$dd]*)$|; ## extract filename from full path name 1134 $shortFileName = $1; 1135 } 1136 my @newSortedNames = grep !/^$shortFileName$/, @sortedNames; 1137 if ($#newSortedNames != $#sortedNames) { 1138 unshift @newSortedNames,$shortFileName; 1139 @sortedNames = @newSortedNames; 1140 } 1141 1142 ## generate labels 1143 my %label_hash = (); 1144 1145 my ($ind,$date,$fileName,@stat); 1146 for $ind (@sortedNames) { 1147 $fileName = "${templateDirectory}$ind"; 1148 if (-e $fileName) { 1149 @stat = stat($fileName); 1150 $date = $stat[9]; 1151 $date = formatDateAndTime($date); 1152 $date =~ s|\s*at.*||; 1153 $label_hash{$ind} = "$ind --- Last Changed $date"; 1154 } 1155 } 1156 (\@sortedNames,\%label_hash); 1157 } 1158 1159 1160 1161 1162 1;
| aubreyja at gmail dot com | ViewVC Help |
| Powered by ViewVC 1.0.9 |