#!/usr/bin/perl ## $Id$ #################################################################### # Copyright @ 1995-1998 University of Rochester # All Rights Reserved #################################################################### # ############################################################# # ############################################################# # File: FILE.pl # This contains the subroutines for creating problem files, # recording scores, printing delimited files, etc. # ############################################################# # ############################################################# use strict; # Variables global to this file my $scoringDirectory = getCourseScoringDirectory(); my $templateDirectory = getCourseTemplateDirectory(); my $scriptDirectory = getWebworkScriptDirectory(); my $databaseDirectory = getCourseDatabaseDirectory(); my $DELIM = $Global::delim; my $scoreFilePrefix = $Global::scoreFilePrefix; my $scoring_log = $Global::scoring_log; my $dash = $Global::dash; my $DAT = $Global::dat; my @STATUS_DROP = @Global::statusDrop; my $dd = getDirDelim(); # Subroutines: #sub createProblem { # my($mode,$probNum,$psvn,$courseName,$sourceref,$refSubmittedAnswers)=@_; # my @out; # #&attachProbSetRecord($psvn); # my $fileName = &getProblemFileName($probNum,$psvn); # #print "content-type: text/plain\n\ngetProblemFileName gives $fileName\n probNum =$probNum and psvn =$psvn\n"; # $fileName = $main::in{'probFileName'} if defined($main::in{'probFileName'}); # #print "now fileName gives $fileName\n probNum =$probNum and psvn =$psvn\n"; # ####Define global variables for the interpreter and seed random function # #srand(&getProblemSeed($probNum,$psvn)); ## print "\n\nContent-type: text/html\n\nERROR: createProblem: Submitted Answers list |$refSubmittedAnswers| not passed\n\n" ## unless defined($refSubmittedAnswers); # defineProblemVars($mode,$probNum, $psvn,$courseName,$refSubmittedAnswers); # @out = &createLines($mode,$fileName,$sourceref); #} # #sub createProblem2 { # my ($mode,$probNum,$psvn,$courseName,$sourceref,$refSubmittedAnswers)=@_; # my %envir=defineProblemEnvir($mode,$probNum,$psvn,$courseName,$refSubmittedAnswers); # #print %envir; # createPGtext($sourceref,\%envir); #} # ######## ## Where is createNumberedInsert used??? ######## # sub createNumberedInsert { # my($mode,$probNum,$psvn)=@_; # my @out; # # &attachProbSetRecord($psvn); # my $fileName = &getInsertFileName($num,$psvn); # # ###Define global variables for the interpreter # defineProblemVars($mode,$probNum, $psvn,$refSubmittedAnswers); # @out = &createLines($mode, $fileName); # } #This subroutine has been substituted by createProblem, because it is # virtually identical to it #sub createInsert { # my($mode,$fileName,$psvn,$courseName,$sourceref)=@_; # my @out; # # &attachProbSetRecord($psvn); # # # ###Define global variables for the interpreter # # This is for the probSet.pl page so $probNum is not well defined # my $probNum = 0; # defineProblemVars($mode,$probNum, $psvn,$courseName); # @out = &createLines($mode,$fileName,$sourceref); #} #sub defineProblemVars { # my ($mode,$probNum,$psvn,$courseName,$refSubmittedAnswers) = @_; # @main::submittedAnswers = @$refSubmittedAnswers if defined($refSubmittedAnswers); # $main::psvnNumber = $psvn; # $main::psvn = $psvn; # $main::studentName = &getStudentName($psvn); # $main::studentLogin = &getStudentLogin($psvn); # $main::sectionName = &getClassSection($psvn); # $main::sectionNumber = &getClassSection($psvn); # $main::setNumber = &getSetNumber($psvn); # $main::questionNumber = $probNum; # $main::probNum = $probNum; # $main::openDate = &getOpenDate($psvn); # $main::formatedOpenDate = &formatDateAndTime(&getOpenDate($psvn)); # $main::dueDate = &getDueDate($psvn); # $main::formatedDueDate = &formatDateAndTime(&getDueDate($psvn)); # $main::answerDate = &getAnswerDate($psvn); # $main::formatedAnswerDate = &formatDateAndTime(&getAnswerDate($psvn)); # $main::problemValue = &getProblemValue($probNum,$psvn); # $main::fileName = &getProblemFileName($probNum,$psvn); # $main::probFileName = &getProblemFileName($probNum,$psvn); # $main::templateDirectory = &getCourseTemplateDirectory(); # $main::languageMode = $mode; # $main::outputMode = $mode; # $main::courseName = $courseName; # $main::sessionKey = ( defined($main::in{'key'}) ) ?$main::in{'key'} : " "; # #my $seed ; # #if ( defined( $inputs{'seed'}) && $permissions == $Global::instructor_permissions ) { # # $seed = $inputs{'seed'}; # #} else { # # $seed = &getProblemSeed($probNum, $psvn); # #} # #$main::problemSeed = $seed; # ##Move srand to PGeval, after unpacking it # #srand($main::problemSeed); # #} ###no longer use this subroutine ###createPGtext calls PGeval directly ###the language is figured out in the processProblem.pl #sub createLines { # # my ($mode,$fileName,$sourceref) = @_; # my @out; # # ### Set current directory ## my $pathName = $fileName; ## $pathName =~ s|[^/]*$||; ## my $currentDirectory = ${templateDirectory} . ${pathName}; ## chdir "$currentDirectory"; ## ## if (! open(INPUT, "${templateDirectory}$fileName") ) { ### If the file can not be found and opened output an error message ## push(@out, "createLines: ERROR: Can't open filename ${templateDirectory}$fileName\n"); # } # else { # # ### Determine language # # print "content-type: text/plain\n\n fileName = $fileName\n"; # $fileName =~ /\.([^\.]*)$/; # my $languageType = $1; # #print "languageType=$languageType
\n"; ### Call interpreter # if ($languageType eq 'qz') { # ##Assign INPUT to problem file # require "${scriptDirectory}qz2sub.pl";; # @out = &qz2($mode); # # @out = post_process_qz($mode, \@out); # } elsif ($languageType eq 'pg') { # #$languageMode = $mode; #Define global variables for the interpreter and seed random function # @out =&PGeval($sourceref); # } else { # $out[0] = "ERROR: createLines: Don't understand languages with extension $languageType.
\n"; # } ## } # @out; #} # #sub post_process_qz { # my ($mode,$refInput_lines) = @_; # my $col = 70; # my $len = 0.07*$col; # my @output_lines = (); # my $ansName = ""; # my $answerValue = ""; # my $ansCount = 0; # my $line; # foreach $line (@$refInput_lines) { # # if ($line =~ /^\[ans/i) { # # $ansCount++; # $ansName = "answer" . "$ansCount"; # $answerValue = param("$ansName") if defined param("$ansName"); # #print "
$ansName
"; # if ($mode eq 'HTML') { # push(@output_lines, qq(\n\n
) ); # } elsif ($mode eq 'Latex2HTML') { # push(@output_lines, qq!\\begin{rawhtml}\n\n\\end{rawhtml}\n! ); # # } elsif ($mode eq 'TeX') { # push(@output_lines, "\rule{${len}in}{.01in}" ); # } else { # push(@output_lines, "ERROR: post_process_qz: mode=$mode is not recognized"); # } # push(@main::PG_ANSWERS, create_qz_ans_function($line)); # } else { # push(@output_lines, $line); # } # } # # @output_lines; #} #sub create_qz_ans_function{ # my $line = shift @_; # my $answer_evaluator = 0; # my ($format, $correctAnswer) = split("=",$line); # # if ($format =~ /^\[ans:([0-9]*),?([0-9\.\-\+eE]*)%?/ ) { #numeric compare--the guts of std_num_cmp # my $accuracy = $2; # my $precision=$1; # my $relpercentTol = $2; # $relpercentTol = .01 unless($relpercentTol); # my $tol = .01*$relpercentTol; # my $formattedCorrectAnswer = sprintf("%10.${precision}g",$correctAnswer ); # $answer_evaluator = sub { # my $in = shift @_; # my $formattedSubmittedAnswer = ""; # my $PGanswerMessage = ""; # my ($inVal,$correctVal); # $correctVal = eval($correctAnswer); # $@=''; # $inVal = eval($in); # if ($@) { ##error message from eval # $formattedSubmittedAnswer = $@; # $formattedSubmittedAnswer =~ s/at.*line [\d]*//g; # $formattedSubmittedAnswer =~ s/called//g; # $formattedSubmittedAnswer =~ s/&main:://g; # $formattedSubmittedAnswer =~ s/chunk [\d]*//g; # } else { # $formattedSubmittedAnswer = sprintf($format,$inVal); # } # # if ($correctVal == 0) { # $tol = 1E-12; ## want $tol to be non zero # } else { # $tol = abs($tol*$correctVal); # } # my $correctQ =0; # $correctQ = 1 if ((not $@) and # (abs( $inVal - $correctVal ) <= $tol)); # if ($@) { # $PGanswerMessage = "There is a syntax error in your answer"; # } # ($correctQ,$formattedCorrectAnswer,$formattedSubmittedAnswer,$PGanswerMessage); # }; # # } else { #string compare use the guts of str_cmp to accomplish this # # my $normalizedCorrectAnswer = $correctAnswer; # # normalize the correct answer: # $normalizedCorrectAnswer=~ s/s*$//; # remove trailing whitespace # $normalizedCorrectAnswer=~ s/s+/ /g; # replace double spaces by single space # $normalizedCorrectAnswer=~ tr/a-z/A-Z/; # Make letters uppercase # $normalizedCorrectAnswer=~ s/^s*//; # remove initial spaces # my $PGanswerMessage = ""; # $answer_evaluator = sub { # my $in = shift @_; # my $originalAnswer = $in; # $in =~ s/s*$//; # remove trailing whitespace # $in =~ s/s+/ /g; # replace double spaces by single space # $in =~ tr/a-z/A-Z/; # Make letters uppercase # # why is there no removing of the initial spaces here? # my $correctQ =0; # $correctQ = 1 if $in eq $normalizedCorrectAnswer; # ($correctQ,$correctAnswer,$originalAnswer,$PGanswerMessage); # }; # # # } # $answer_evaluator; #} ############################## SCORING FILES ROUTINES ############################ #sub recordProblemAnswer { # my ($in, $num,$user, $psvn)=@_; # # &attachProbSetRecord($psvn); # my($setNumber)=&getSetNumber($psvn); # my ($scoreFileName)="${databaseDirectory}$scoreFilePrefix$setNumber$dash${psvn}.sco"; # unless (-e $scoreFileName) # {&createFile($scoreFileName, $Global::sco_files_permission, $Global::numericalGroupID);} # open(TEMP_FILE,">>$scoreFileName") || # print "Couldn't record answer in $scoreFileName"; # # my $time = time; # add time stamp -- should we make this human readable? # my $time = &formatDateAndTime(time); # add time stamp # # print TEMP_FILE "$num $DELIM $in $DELIM $user $DELIM $time\n"; # close(TEMP_FILE); # if ($in eq 'Y') {&putProblemNumOfCorrectAns(&getProblemNumOfCorrectAns($num,$psvn)+1,$num,$psvn);} # if ($in eq 'N') {&putProblemNumOfIncorrectAns(&getProblemNumOfIncorrectAns($num,$psvn)+1,$num,$psvn);} # unless (defined(&getProblemStatus($num)) and (&getProblemStatus($num) eq 'Y')) { # &putProblemStatus($in,$num,$psvn); # } # &detachProbSetRecord($psvn); # }; #sub getRecordedScores { # # my ($Yarrayref,$Narrayref,$psvn) = @_; # &attachProbSetRecord($psvn); # my $setNumber = &getSetNumber($psvn); # &detachProbSetRecord($psvn); # my ($scoreFileName)="${databaseDirectory}$scoreFilePrefix$setNumber$dash${psvn}.sco"; # #print "Reading from file $scoreFileName\n" if $debugON; # if ( open(SCORE_FILE,"<$scoreFileName") ) { # while () { # my @temp=split(/$DELIM/,$_); # if ($temp[1]=~/Y/) {$$Yarrayref[$temp[0]]++;} # elsif ($temp[1]=~/N/) {$$Narrayref[$temp[0]]++;} # else {wwerror("$0", "corrupted $scoreFileName");} # }; # close(SCORE_FILE); # } else { # warn "Warning: Couldn't open $scoreFileName. Will continue.\n"; # } # # OPERATES ON THE ARRAYS Yarray and Narray. #} sub round_score { my $num = shift; my $rounding_dem = 10**$Global::score_decimal_digits; int($num*$rounding_dem + .5)/$rounding_dem; } ######################## END SCORING FILES ROUTINES ########################### ############ ### SMD - subroutine to get the number of answers from a specific file ### - this handles questions which have more than one answer field. ### - called with a problem number ($probNum) ### - returns number of answers #sub getNumberofAns # { # local($problemnumber)=@_; # $numberofAnswers=0; # local($filename)= &getProblemFileName($problemnumber); # open(FILE, "${templateDirectory}$filename"); # while() # { # if ($_ =~ /^\s*\[ans/) # { # $numberofAnswers++; # } # } # close FILE; # $numberofAnswers; # } ### GAGE 8/23/96 #sub getNumberofSubmittedAns { # my $i = 1; # while (defined($inputs{"answer$i"}) ) #inputs can't be sytactically local (using my) # {$i++}; # $i--; # the off-by-one problem # $i; ########### sub readSetDef { my ($fileName) = @_; my $setNumber = ''; my $shortFileName = fileFromPath($fileName); if ($shortFileName =~ m|^set(\w+)\.def$|) {$setNumber = $1;} else { wwerror("$0", "The setDefinition file name must begin with set and must end with .def . Every thing in between becomes the name of the set. For example set1.def, setExam.def, and setsample7.def define sets named 1, Exam, and sample7 respectively. The filename, $shortFileName, you entered is not legal\n"); } my ($line,$name,$value,$attemptLimit); open (SETFILENAME, "$fileName") or wwerror("$0", "Can't open file $fileName\n"); my $setHeaderFileName = ''; my $probHeaderFileName = ''; my @problemList=(); my @problemValueList=(); my @problemAttemptLimitList=(); my ($dueDate,$openDate,$answerDate); my ($problemListref,$problemValueListref,$problemAttemptLimitListref); while () { chomp($line = $_); $line =~ s|(#.*)||; ## don't read past comments unless ($line =~ /\S/) {next;} ## skip blank lines $line =~ s|\s*$||; ## trim trailing spaces $line =~ m|^\s*(\w+)\s*=\s*(.*)|; if ($1 eq 'setNumber') {next;} elsif ($1 eq 'paperHeaderFile') {$setHeaderFileName = $2;} elsif ($1 eq 'screenHeaderFile') {$probHeaderFileName = $2;} elsif ($1 eq 'dueDate') {$dueDate = $2;} elsif ($1 eq 'openDate') {$openDate = $2;} elsif ($1 eq 'answerDate') {$answerDate = $2;} elsif ($1 eq 'problemList') {last;} else {wwerror("$0", "readSetDef error, can't read the line: $line");} } my $time1 = &unformatDateAndTime($openDate); my $time2 = &unformatDateAndTime($dueDate); my $time3 = &unformatDateAndTime($answerDate); if ($time2 < $time1 or $time3 < $time2) { &Global::error('File.pl: readSetDef error', "The open date: $openDate, due date: $dueDate, and answer date: $answerDate must be in chronologicasl order."); } $setHeaderFileName =~ s/(.*?)\s*$/$1/; #remove trailing white space $probHeaderFileName =~ s/(.*?)\s*$/$1/; #remove trailing white space # print "setNumber: $setNumber\ndueDate: $dueDate\nopenDate: $openDate\nanswerDate: $answerDate\n"; while() { chomp($line=$_); $line =~ s/(#.*)//; ## don't read past comments unless ($line =~ /\S/) {next;} ## skip blank lines ($name, $value, $attemptLimit) = split (/\s*,\s*/,$line); $name =~ s/\s*//g; push(@problemList, $name); $value = "" unless defined($value); $value =~ s/[^\d]*//g; unless ($value =~ /\d+/) {$value = 1;} push(@problemValueList, $value); $attemptLimit = "" unless defined($attemptLimit); $attemptLimit =~ s/[^\d-]*//g; unless ($attemptLimit =~ /\d+/) {$attemptLimit = -1;} push(@problemAttemptLimitList, $attemptLimit); } close(SETFILENAME); #print "problemList: @problemList\n"; #print "problemValueList: @problemValueList\n"; #print "problemAttemptLimitList: @problemAttemptLimitList\n"; $problemListref = \@problemList; $problemValueListref = \@problemValueList; $problemAttemptLimitListref = \@problemAttemptLimitList; ($setNumber,$setHeaderFileName,$probHeaderFileName,$dueDate,$openDate,$answerDate,$problemListref,$problemValueListref,$problemAttemptLimitListref); } sub max { ## find the max element of array my $out = $_[0]; my $num; foreach $num (@_) { if ((defined $num) and ($num > $out)) {$out = $num;} } $out; } sub min { ## find the max element of array my $out = $_[0]; my $num; foreach $num (@_) { if ((defined $num) and ($num < $out)) {$out = $num;} } $out; } sub getFieldLengths { ## takes as a parameter the reference to a delimited array ## (such as you would get by reading in a delimited file) ## where each element is a line from a delimited file. ## returns an array which holds ## the maximum field lengths in the file. my ($datFileArray_ref)=@_; my($i); my(@datArray,@fieldLength,@datFileArray, $line); @fieldLength=(); @datFileArray=@$datFileArray_ref; foreach $line (@datFileArray) { ## read through file and get field lengths unless ($line =~ /\S/) {next;} ## skip blank lines chomp $line; @datArray=&getRecord($line); for ($i=0; $i <=$#datArray; $i++) { $fieldLength[$i] = 0 unless defined $fieldLength[$i]; $fieldLength[$i]=&max(length("$datArray[$i]"),$fieldLength[$i]); } } return (@fieldLength); } sub columnArrayArrange { ## takes as a parameter a delimited array ## (such as you would get by reading in a delimited file) ## where each element is a line from a delimited file. # Outputs an array which adds # extra space if necessary to the fields so that all columns line up. # The widest field in any column will contain exactly 1 spaces at the # end of the (non space characters of the) field. For example # ",a very long field entry ," at one extreme and ", ," at the other my @inFile=@_; my($i,$tempFileName,$datString,$line); my @outFile =(); my(@fieldLength,@datArray); $i=1; @fieldLength=&getFieldLengths(\@inFile); foreach $line (@inFile) { ## read through file array and get field lengths unless ($line =~ /\S/) {next;} ## skip blank lines chomp $line; @datArray=&getRecord($line); for ($i=0; $i <=$#datArray; $i++) { $datArray[$i].=(" " x ($fieldLength[$i]+1-length("$datArray[$i]"))); } $datString=join("${DELIM}",@datArray); push @outFile , "$datString\n"; } @outFile; } sub columnPrint { # Takes two parameters. The first is the filename of the # delimited input file. The second is the name of the # output file (these names may be the same). The permissions # and group of the output file will be the same as the # input file # Takes any delimited (with \$DELIM delimiters) file and adds # extra space if necessary to the fields so that all columns line up. # The widest field in any column will contain exactly 2 spaces at the # end of the (non space characters 0f the) field. For example # ",a very long field entry ," at one extreme and ", ," at the other # my($inFileName,$outFileName)=@_; my($line); my ($permission, $gid) = (stat($inFileName))[2,5]; $permission = ($permission & 0777); ##get rid of file type stuff open(INFILE,"$inFileName") or wwerror("$0","can't open $inFileName for reading"); my @inFile=; close(INFILE); &createFile($outFileName, $permission, $gid); my @outFile = &columnArrayArrange(@inFile); open(OUTFILE,">$outFileName") or wwerror("$0","can't open $outFileName for writing"); foreach $line (@outFile) {print OUTFILE $line;} close(OUTFILE); } sub getRecord # Takes a delimited line as a parameter and returns an # array. Note that all white space is removed. If the # last field is empty, the last element of the returned # array is also empty (unlike what the perl split command # would return). E.G. @lineArray=&getRecord(\$delimitedLine). { my $DELIM = $Global::delim; my($line) = $_[0]; my(@lineArray); $line.='A'; # add 'A' to end of line so that # last field is never empty @lineArray = split(/\s*${DELIM}\s*/,$line); $lineArray[$#lineArray] =~s/\s*A$//; # remove spaces and the 'A' from last element $lineArray[0] =~s/^\s*//; # remove white space from first element @lineArray; } sub delim2aa { # Takes a delimited file as a parameter and returns an # associative array with the first field as the key. # Blank lines are skipped. White space is removed my $fileName =$_[0]; my(@dbArray,$key,%assocArray,$dbString); open(FILE, "$fileName") or wwerror("$0","can't open $fileName"); while () { unless ($_ =~ /\S/) {next;} ## skip blank lines chomp; @dbArray=&getRecord($_); $key=shift(@dbArray); $dbString=join("${DELIM}",@dbArray); $assocArray{$key}=$dbString; } close(FILE); %assocArray; } sub dropStatus # Takes one parameter \$status and returns 1 if \$status matches a word in the # \@STATUS_DROP global array, 0 otherwise. E.G. if ($dropStatus(\$status) {...} # where \$status is the entry in the status field of the class list. \@STATUS_DROP # is a global array defined in webwork.ph { my($tag) = 0; my($status) = $_[0]; my($statusItem); foreach $statusItem (@STATUS_DROP) { if ($status =~ /^\s*$statusItem\s*$/i) {$tag = 1;} } $tag; } ##########################Basem's additions#################### ##Gives a nice list of ALL problem sets using radio buttons as default. ##So to make a form with radio buttoned sets, simply start the form on the ##line before calling printProbSets and a line after for the submit. The ##default CGI value that is passed is the probSetKey. To make it the setNo, ##call this subroutine: &printProbSets("setNo") ############################################################### #sub printProbSets { # my ($passFlag,$pHash)=@_; # my %setNumberHash = %$pHash; # my @sortedSetNumberKeys=&sortSetNamesByDueDate($pHash); # my @problemDates = (); # my $problemDateLine; # my ( $probSetKey, $odts,$ddts,$adts,$timeNow,$DueDate,$AnswerDate,$OpenDate); # my $sortedSetNumber; # # foreach $sortedSetNumber(@sortedSetNumberKeys) { # $probSetKey=$setNumberHash{$sortedSetNumber}; # &attachProbSetRecord($probSetKey); # $odts=&getOpenDate($probSetKey); # $ddts=&getDueDate($probSetKey); # $adts=&getAnswerDate($probSetKey); # $timeNow = time; # # $DueDate=&formatDateAndTime($ddts); # $AnswerDate = &formatDateAndTime($adts); # $OpenDate = &formatDateAndTime($odts); # # # prepare message based on current time relative to the Open, Due and Answer dates. # $problemDateLine = ""; # # if ($passFlag eq "setNo") { # $problemDateLine = "\n "; # } # else { # $problemDateLine = "\n "; # } # # $problemDateLine .= "Problem Set Number $sortedSetNumber"; # ($timeNow < $odts ) && do {$problemDateLine .= &beforeOpenDateMsg($OpenDate) . # &problemDates($OpenDate,$DueDate,$AnswerDate);}; # ( $odts <= $timeNow ) && ($timeNow < $ddts) && # do {$problemDateLine .= &afterOpenDateMsg($DueDate) . # &problemDates($OpenDate,$DueDate,$AnswerDate);}; # ( $ddts <= $timeNow ) && ($timeNow < $adts) && # do {$problemDateLine .= # &afterDueDateMsg($AnswerDate) . &problemDates($OpenDate,$DueDate,$AnswerDate);}; # ( $adts <= $timeNow ) && # do {$problemDateLine .= # &afterAnswerDateMsg .&problemDates($OpenDate,$DueDate,$AnswerDate);}; # push (@problemDates, $problemDateLine); # } # # print join("\n\n", @problemDates),"\n"; # include open/due/answer dates # # prepared above #} # ##########################Basem's additions#################### ##Does the same thing as printProbSets but in the abbreviated style used in ##welcome.pl ############################################################### #sub printProbSetsJR { # my ($passFlag,$pHash)=@_; # my %setNumberHash = %$pHash; # my @sortedSetNumberKeys=sort keys(%setNumberHash); # my @problemDates = (); # my $problemDateLine; # my ( $probSetKey, $odts,$ddts,$adts,$timeNow,$DueDate,$AnswerDate,$OpenDate); # my $sortedSetNumber; # # foreach $sortedSetNumber(@sortedSetNumberKeys) { # $probSetKey=$setNumberHash{$sortedSetNumber}; # &attachProbSetRecord($probSetKey); # $odts=&getOpenDate($probSetKey); # $ddts=&getDueDate($probSetKey); # $adts=&getAnswerDate($probSetKey); # $timeNow = time; # # $DueDate=&formatDateAndTime($ddts); # $AnswerDate = &formatDateAndTime($adts); # $OpenDate = &formatDateAndTime($odts); # # # prepare message based on current time relative to the Open, Due and Answer dates. # $problemDateLine = ""; # # if ($passFlag eq "setNo") { # $problemDateLine = "\n "; # } # else { # $problemDateLine = "\n "; # } # # $problemDateLine .= "Problem Set Number $sortedSetNumber"; # # ($timeNow < $odts ) && do {$problemDateLine .= &beforeOpenDateMsg($OpenDate);}; # ( $odts <= $timeNow ) && ($timeNow < $ddts) && # do {$problemDateLine .= &afterOpenDateMsg($DueDate);}; # ( $ddts <= $timeNow ) && ($timeNow < $adts) && # do {$problemDateLine .= &afterDueDateMsg($AnswerDate);}; # ( $adts <= $timeNow ) && # do {$problemDateLine .= &afterAnswerDateMsg;}; # # # push (@problemDates, $problemDateLine); # } #print join("\n\n", @problemDates),"\n"; # include open/due/answer dates # # prepared above #} sub beforeOpenDateMsg { my ($OpenDate) = @_; my $out = " --- Before open date -- "; $out .= "Open date is: $OpenDate
"; $out; }; sub afterOpenDateMsg { #and before Due Date my ($DueDate) = @_; my $out = " --- OPEN"; $out .= " -- Due date is: $DueDate
"; $out; }; sub afterDueDateMsg { #and before AnswerDate my ($AnswerDate) = @_; my $out = " --- CLOSED --"; $out .= " Answers available on: $AnswerDate
"; $out; }; sub afterAnswerDateMsg { my $out = " --- CLOSED -- "; $out .= " answers available.
"; $out; }; sub problemDates { my ($OpenDate,$DueDate,$AnswerDate) = @_; my $out = < Open: $OpenDate Due: $DueDate Answer: $AnswerDate ENDproblemDatesHTML $out; } sub formatDateAndTime { my ($timeStamp)=@_; my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($timeStamp); my $twelveHour; if($min<10){$min= "0" . $min;} if($hour==0){$twelveHour = 12 . ":" . $min . " AM";} elsif($hour<12){$twelveHour= $hour . ":" . $min . " AM";} elsif($hour==12){$twelveHour = $hour . ":" . $min . " PM";} else {$twelveHour = ($hour-12) . ":" . $min . " PM";} if($year>99){$year = $year -100;} if($year<10){$year= "0" . $year;} my $returnTimeString = ($mon+1) . "/" . $mday . "/" . $year . " at " . $twelveHour; $returnTimeString; } sub unformatDateAndTime { my ($string) = @_; my $orgString =$string; $string =~ s|^\s+||; $string =~ s|\s+$||; $string =~ s|at| at |i; ## OK if forget to enter spaces or use wrong case $string =~ s|AM| AM|i; ## OK if forget to enter spaces or use wrong case $string =~ s|PM| PM|i; ## OK if forget to enter spaces or use wrong case $string =~ s|,| at |; ## start translating old form of date/time to new form my($date,$at,$time,$AMPM) = split(/\s+/,$string); unless ($time =~ /:/) { { ##bare block for 'case" structure $time =~ /(\d\d)(\d\d)/; my $tmp_hour = $1; my $tmp_min = $2; if ($tmp_hour eq '00') {$time = "12:$tmp_min"; $AMPM = 'AM';last;} if ($tmp_hour eq '12') {$time = "12:$tmp_min"; $AMPM = 'PM';last;} if ($tmp_hour < 12) {$time = "$tmp_hour:$tmp_min"; $AMPM = 'AM';last;} if ($tmp_hour < 24) { $tmp_hour = $tmp_hour - 12; $time = "$tmp_hour:$tmp_min"; $AMPM = 'PM'; } } ##end of bare block for 'case" structure } my ($mday, $mon, $year, $wday, $yday,$sec, $pm, $min, $hour); $sec=0; $time =~ /^([0-9]+)\s*\:\s*([0-9]*)/; $min=$2; $hour = $1; if ( $hour < 1 or $hour > 12 or $min < 0 or $min > 59) { &Global::error('File.pl: unformatDateAndTime error', "Incorrect date/time format $orgString. Correct format is 9/13/02 at 12:15 PM"); } $pm = 0; $pm = 12 if ($AMPM =~/PM/ and $hour < 12); $hour += $pm; $hour = 0 if ($AMPM =~/AM/ and $hour == 12); $date =~ m!([0-9]+)\s*/\s*([0-9]+)/\s*([0-9]+)! ; $mday =$2; $mon=($1-1); if ( $mday < 1 or $mday > 31 or $mon < 0 or $mon > 11) { &Global::error('File.pl: unformatDateAndTime error', "Incorrect date/time format $orgString. Correct format is 9/13/02 at 12:15 PM"); } $year=$3; $wday=""; $yday=""; timelocal ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday); } sub texInput ## Similar to the TeX input command. Takes a filename (with or without extension) ## which is assumed to be in the \$templateDirectory. ## E.G. print OUTFILE &texInput("file.tex"); ## or print OUTFILE &texInput("file"); { my $texInFile = $_[0]; my $texString; if ($texInFile eq "") { $texString = ''; } else { unless ($texInFile =~ m#\.#) {$texInFile .= '.tex';} open(TEX_IN_FILE,"${templateDirectory}$texInFile") || &Global::error("File.pl: textInput error", " Can't open ${templateDirectory}$texInFile"); my @texInputArray = ; close(TEX_IN_FILE); $texString = join('',@texInputArray); unless ($texString =~ /\n$/s) {$texString .= "\n";} } ## print "$texString"; $texString; } # A very useful macro for making sure that all of the directories to a file have been constructed. sub surePathToTmpFile { # constructs intermediate directories if needed beginning at ${Global::htmlDirectory}tmp/ # the input path must be either the full path, or the path relative to this tmp sub directory my $path = shift; my $delim = &getDirDelim(); my $tmpDirectory = getCourseTempDirectory(); # if the path starts with $tmpDirectory (which is permitted but optional) remove this initial segment $path =~ s|^$tmpDirectory|| if $path =~ m|^$tmpDirectory|; $path = convertPath($path); # find the nodes on the given path my @nodes = split("$delim",$path); # create new path $path = convertPath("$tmpDirectory"); while (@nodes>1 ) { $path = convertPath($path . shift (@nodes) ."/"); unless (-e $path) { # system("mkdir $path"); createDirectory($path,$Global::tmp_directory_permission, $Global::numericalGroupID) || wwerror($0, "Failed to create directory $path","","",""); } } $path = convertPath($path . shift(@nodes)); # system(qq!echo "" > $path! ); $path; } sub fileFromPath { my $path = shift; my $delim =&getDirDelim(); $path = convertPath($path); $path =~ m|([^$delim]+)$|; $1; } sub directoryFromPath { my $path = shift; my $delim =&getDirDelim(); $path = convertPath($path); $path =~ s|[^$delim]*$||; $path; } sub createDirectory { my ($dirName, $permission, $numgid) = @_; mkdir($dirName, $permission) or wwerror("$0: createDirectory error", " Can't do mkdir($dirName, $permission)"); chmod($permission, $dirName) or wwerror("$0: createDirectory error", " Can't do chmod($permission, $dirName)"); unless ($numgid == -1) {chown(-1,$numgid,$dirName) or wwerror("$0: createDirectory error", " Can't do chown(-1,$numgid,$dirName)");} } use Cwd; sub createFile { my ($fileName, $permission, $numgid) = @_; # my $decimal_per = sprintf "%lo", $permission; # print "\n IN createFile: file is $fileName, permission is $decimal_per, gid is $numgid\n"; open(TEMPCREATEFILE, ">$fileName") || wwerror("File.pl: createFile error", " Can't open $fileName"); my @stat = stat TEMPCREATEFILE; close(TEMPCREATEFILE); ## if the owner of the file is running this script (e.g. when the file is first created) ## set the permissions and group correctly if ($< == $stat[4]) { # my $oldDirectory = cwd(); # warn " old directory is $oldDirectory
\n"; # my $newDirectory = $fileName; # $newDirectory =~ s|/[^/]+$||; # warn " new directory is $newDirectory
\n"; # $fileName =~ m|([^/]+$)|; # my $newFileName = $1; # warn "new File name = $newFileName
\n"; # chdir $newDirectory; # warn "changing to directory =" .cwd() ."
\n"; # #chmod(0777,$fileName); my $tmp = chmod($permission,$fileName) or warn("File.pl: createFile error", " Can't do chmod($permission, $fileName)"); chown(-1,$numgid,$fileName) or warn("File.pl: createFile error", " Can't do chown($numgid, $fileName)"); # #warn "foo is readable
\n" if -w 'foo.gif'; # #warn "chmod =" . chmod($permission,$newFileName) || # # warn("File.pl: createFile error", " Can't do chmod($permission, $newFileName)"); # #chdir $oldDirectory; # #warn "changed back to directory =" .cwd() ."
\n"; } } sub rmDirectoryAndFiles { my ($PROBDIR) =@_; my @allfiles = (); opendir( DIRHANDLE, "$PROBDIR") || warn qq/Can't read directory $PROBDIR $!/; @allfiles = map "$PROBDIR$_", grep( !/^\.\.?$/, readdir DIRHANDLE); closedir(DIRHANDLE); # print "unlinking
",join("
", @allfiles),"

"; unlink(@allfiles); # print "removing directory $PROBDIR

"; rmdir("$PROBDIR"); } # this returns an array of set names sorted by due date (with all open sets first). # It is called by a reference to a hash with keys the Set Names and values psvn's # such as returned by &getAllProbSetNumbersHash or &getAllSetNumbersForStudentLoginHash sub sortSetNamesByDueDate { my ($setNameHashref) = @_; my %setNameHash = %$setNameHashref; my ($setName,$psvn,$ddts,$timeNow); my %dueTimes =(); foreach $setName (keys %setNameHash) { $psvn=$setNameHash{$setName}; &attachProbSetRecord($psvn); $ddts=&getDueDate($psvn); $dueTimes{$setName} = $ddts; } my @sortedSetNames = sort ## Sort setnumbers by due date. Using an anonymous block so that ## dueTimes gets passes without making it global to FILE.pl or ## passing it to a sorting subroutine (can we pass this?) { $timeNow = time; if ( ($dueTimes{$a} <= $timeNow) and ($dueTimes{$b} <= $timeNow) ) { $dueTimes{$a} <=> $dueTimes{$b} or $a cmp $b } elsif ( ($dueTimes{$a} > $timeNow) and ($dueTimes{$b} > $timeNow) ) { $dueTimes{$a} <=> $dueTimes{$b} or $a cmp $b } else { $dueTimes{$b} <=> $dueTimes{$a} } } keys %setNameHash ; @sortedSetNames; } sub checkClasslistFile { ## takes as parameters the number of fields and the full path name of ## the classlist file. Checks that the file iv valid, i.e. (1) all records ## have the same number of fields, (2) the first fields (studentID's, usually SS#'s) are ## all distinct and (3) the last fields (the loginID's) are all distinct, ## and (4) that studentID's and loginID's comtain only valid characters my($noOfFields,$fileName)=@_; my $msg = htmlCheckClasslistFile($noOfFields,$fileName); unless ($msg eq 'OK') { &wwerror("$0","$msg"); } } sub htmlCheckClasslistFile { ## takes as parameters the number of fields and the full path name of ## the classlist file. Checks that the file iv valid, i.e. (1) all records ## have the same number of fields, (2) the first fields (studentID's, usually SS#'s) are ## all distinct and (3) the last fields (the loginID's) are all distinct, ## and (4) that studentID's and loginID's comtain only valid characters and ## (5) that other fields do not contain bas chacters my($noOfFields,$fileName)=@_; open (FILE, "$fileName") or &wwerror("$0","can't open $fileName"); my @classList = ; close(FILE); my $msg = checkClasslistArray($noOfFields, \@classList,$fileName); return $msg; } sub checkClasslistArray { ## takes as parameters the number of fields and a ref to ## the classlist array. Checks that the file iv valid, i.e. (1) all records ## have the same number of fields, (2) the first fields (studentID's, usually SS#'s) are ## all distinct and (3) the last fields (the loginID's) are all distinct, ## and (4) that studentID's and loginID's comtain only valid characters and ## (5) that other fields do not contain bas chacters my($noOfFields,$classListref,$fileName)=@_; my($noOfDelim,$dbString,$num,$i,@classList); my(@keyList); my $msg =''; $noOfDelim = $noOfFields -1; @classList = @$classListref; foreach $dbString (@classList) { unless ($dbString =~ /\S/) {next;} chomp $dbString; $num=($dbString =~s/$DELIM/$DELIM/g); if ($num != $noOfDelim) { $num =$num+1; $msg = "\n\n The classlist file\n $fileName \n is corrupted. The record\n $dbString \n contains $num fields instead of $noOfFields fields. \nYou must correct this and then run this script again. \n\n"; return $msg; } } my (@SSList, @loginList); @SSList=(); @loginList=(); foreach $dbString (@classList) { unless ($dbString =~ /\S/) {next;} chomp $dbString; my @classListRecord=&getRecord($dbString); my ($studentID, $lastName, $firstName, $status, $comment, $section,$recitation, $email_address, $login_name) = @classListRecord; # next if &dropStatus($status); ## ignore students who have dropped unless ($studentID =~ /^[\w\-\.]+$/) { $msg = "\n\n The classlist file\n$fileName\n\n is corrupted. The record \n$dbString \n contains the invalid studentID: $studentID \n studentID's can contain only upper and lower case letters, digits, -, dot('.'), and _ \n You must correct this and then run this script again.\n\n"; return $msg; } unless ($login_name =~ /^[\w\-\.]+$/) { $msg = "\n\n The classlist file\n$fileName\n\n is corrupted. The record \n$dbString \n contains the invalid loginName: $login_name \n loginName's can contain only upper and lower case letters, digits, -, dot('.'), and _ \n You must correct this and then run this script again.\n\n"; return $msg; } ## test entries for bad characters. my @entries = ($lastName, $firstName, $status, $comment, $section,$recitation, $email_address); my $item =''; foreach $item (@entries) { my $msg = test_entry($item); unless ($msg eq 'OK') {return $msg;} } push(@SSList,$studentID); push(@loginList,$login_name); } @SSList = sort(@SSList); for ($i=0; $i < @SSList-1; $i++) { if ($SSList[$i] eq $SSList[$i+1]) { $msg = "\n\n The classlist file\n$fileName\n\n is corrupted. Duplicate studentID's equal to $SSList[$i] in\n $fileName\nYou must correct this and then run this script again.\n\n"; return $msg; } } @loginList = sort(@loginList); for ($i=0; $i < @loginList-1; $i++) { if ($loginList[$i] eq $loginList[$i+1]) { $msg ="\n\n The classlist file\n$fileName\n\n is corrupted. Duplicate loginNames equal to $loginList[$i] in\n $fileName\nYou must correct this and then run this script again.\n\n"; return $msg; } } $msg ='OK'; return $msg; } ### macros for writing and reading html tables sub array2htmlRow { ## The parameter is an array whose entries will beccome elements of a row ## in an html table. The output is a string formated the same way Excel ## formats html tables: numbers aligned right, other things left. my @inArray = @_; my ($item,$align); my $outString =''; $outString = join '','',"\n"; foreach $item (@inArray) { unless ($item =~ /\S/) {$item = ' ';} if ($item =~/^[\d\.]+$/){$align ='RIGHT'} else {$align ='LEFT'} $outString .= join '','',"\n"; $outString .= join '',$item,'',"\n"; } $outString .= join '','',"\n"; } sub array2htmlRowForm { ## The parameter is an array whose first entry is the row number (1, 2, etc) ## and remaining entries will become elements of a row ## in an html table. my ($row,@inArray) = @_; my ($item,$size); my $outString =''; my $col =1; $outString = join '','',"\n"; foreach $item (@inArray) { unless ($item =~ /\S/) {$item = ' ';} $size = length($item); $outString .= join '','',"\n"; $outString .= join '',' ',"\n"; $col++; } $outString .= join '','',"\n"; } sub delimitedArray2htmlTable { # Takes a ref to an array whose elements are rows of a delimited file # and outputs a string containing # an html table version of the array suitable for viewing and editing # in Excel or a browser such as Netscape/Communicator. If the second # optional parameter is 'htmlform', the output is an html form. Otherwise # the output is a plain html document. # Blank lines are skipped. White space is removed. my ($inArrayref, $type) = @_; ## setup html header and initial table stuff my $rowString; my $outString = "\n"; ## translate data from delimited format to html format my $row =1; foreach (@$inArrayref) { unless ($_ =~ /\S/) {next;} ## skip blank lines chomp; if ( (defined $type) and ($type eq 'htmlform')) {$rowString = &array2htmlRowForm($row, &getRecord($_));} else {$rowString = &array2htmlRow(&getRecord($_));} $outString .= $rowString; $row++; } ## setup html end table $outString .= join '','
',"\n" ; } sub delimitedArray2html { # Takes a ref to an array whose elements are rows of a delimited file # and outputs a string containing # an html version of the array suitable for viewing and editing # in Excel or a browser such as Netscape/Communicator. The $label is the name # appearing at the top of the form or page. If the third # optional parameter is 'htmlform', the output is an html form. Otherwise # the output is a plain html document. # Blank lines are skipped. White space is removed. my ($inArrayref, $label, $type) = @_; ## setup html header and initial table stuff my $rowString; my $outString = join '','',"\n" ,'',"\n", ''; $outString .= join '',$label,'',"\n",'',"\n",'',"\n"; $outString .= join '','

',$label,'

',"\n"; $outString .= &delimitedArray2htmlTable($inArrayref, $type); ## setup html footer stuff $outString .= join '','',"\n", ''; } sub delim2html { # Takes a delimited file name as input and outputs a string containing # an html version of the input file suitable for viewing and editing # in Excel or a browser such as Netscape/Communicator. If the second # optional parameter is 'htmlform', the output is an html form. Otherwise # the output is a plain html document. # Blank lines are skipped. White space is removed. my ($inFileName,$type) = @_; my $shortFileName = $inFileName; unless (defined($type) and $type eq 'htmlform') {$type = 'html';} if ($shortFileName =~ m|$dd|) { $shortFileName =~ m|$dd([^$dd]*)$|; ## extract filename from full path name $shortFileName = $1; } $shortFileName =~ s|\..*||; ## remove extension open(INFILE, $inFileName) || wwerror("$0", "can't open $inFileName"); my @outArray = ; close(INFILE); my $outString = delimitedArray2html(\@outArray,$shortFileName,$type); $outString; } sub htmlPage2htmlTable { ## Takes a string which contains a full html page ## containing a single table and removes all the ## header and footer material leaving only the row ## entries between and
. Also removes all the ## and stuff from within the table. ## The cleaned up string is returned. my ($inString) = @_; $inString =~ s|^.*<\s*table.*?>||is; ## remove and stuff before $inString =~ s|<\s*/table\s*>.*?$||is; ## remove
and stuff after $inString =~ s|<\s*/*font.*?>||gis; ## remove font stuff $inString =~ s|>[^>]*$|>|s; ## remove any stuff after last > $inString; } sub htmlTable2delim { ## Takes a string (e.g. output from htmlPage2htmlTable) which ## contains the rows from an html table and returns a string ## containing the table data in delimited format. my ($inString) = @_; my ($outString, $item, $rowString); $outString =''; while ($inString){ $inString =~ s|^(.*?<\s*/tr\s*>)||is; # get next row $item = $1; $rowString = join("${DELIM}",&htmlRow2array($item)); $outString .= join '', $rowString, " \n"; } $outString; } sub htmlForm2delim { ## Takes a reference to the associtive array of inputs from ## a form. The $inputs{row5col8} is the element for the 5th row ## and 8 column. It is assumed the input is a rectangular array ##Returns a string containing the table data in delimited format. my ($inputsref) = @_; my %inputs = %$inputsref; my ($item, $index,$row,$col); my $maxCol = 1; my $maxRow = 1; my @rowColIndex = grep /^row\d+col\d+$/, keys %inputs; foreach $index (@rowColIndex) { $index =~ /^row(\d+)col(\d+)$/; if ($1 > $maxRow) {$maxRow = $1}; if ($2 > $maxCol) {$maxCol = $2}; } my @outArray =(); my $rowString =''; my @rowArray= (); for $row (1..$maxRow) { @rowArray= (); for $col (1..$maxCol) {push @rowArray, $inputs{"row${row}col${col}"};} $rowString = join("${DELIM}",@rowArray); push (@outArray,$rowString); } @outArray = &columnArrayArrange(@outArray); ## line up columns my $outString = join('',@outArray); $outString; } sub htmlRow2array { ## The parameter is a string "" containing one row ## in an html table. The output is an array containing the entries ## contained in that row. my ($inString) = @_; $inString =~ s|^.*<\s*tr.*?>||is; ## remove and stuff before $inString =~ s|<\s*/tr\s*>.*$||is; ## remove and stuff after $inString =~ s|>[^>]*$|>|s; ## remove any stuff after last > my @outArray =(); my $item; while ($inString){ $inString =~ s%^(.*?<)\s*/t[d|h]\s*>%%is; # get next entry $item = $1; $item =~ m|>\s*(.*?)<|is; # get entry $item =$1; $item =~ s|\s*$||; # remove trailing spaces if (($item eq ' ') or ($item eq '')) {$item =' '} push @outArray, $item; } @outArray; } ## this subroutine prints all environment variables. ## adapted from http://www.cgi-resources.com/Documentation/Environment_Variables/ ## takes parameters html_top, html_bot which print html top and bottom matter if set sub printEnvVars { my ($top, $bot) = @_; my ($bigcontent, @content, $content,$name,$value,%input,$tvar,$key); # First, if METHOD=GET we grab the environment variable # containing the Query_String - otherwise we grab the # environment variable Content_Length. if ($ENV{'REQUEST_METHOD'} eq "GET") { $bigcontent = $ENV{'QUERY_STRING'}; } # Close if bracket else { read(STDIN, $bigcontent, $ENV{'CONTENT_LENGTH'}); } # Close else bracket # bigcontent now contains a long string which is broken by # ampersands between the various form elements. So let's split # it and load it into an array @content = split(/&/, $bigcontent); # But we aren't done yet. All of the spaces in the form data # were replaced by pluses. Other non-alpha characters except # equal signs were replaced by their hex values. So now we # need to step through the array and translate them back into # their "sent" form. foreach $content (@content) { # Split HTML form's "NAME" and "VALUE" at equal signs ($name, $value) = split(/=/, $content); # Replace the pluses with spaces $value =~ tr/+/ /; # Translate the hex (now preceded by percent sign) into ASCII $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg; # And finish by loading input variables for use in program. # You call it by $input{'formvarname'} to get the literal # that the user typed into that field on the Form. $input{$name} = $value; } # Close bracket for foreach loop # Tell the server that we are going to send it to user's browser if ($top eq 'html_top') {print "Content-type: text/html\n\n"; # So we don't have to type backslashes everywhere before reserved # characters in the HTML, we use this so the PERL compiler will # know that what follows is literal (except for variable names) # But be careful - still need backslash in front of literal at # signs, dollar signs, etc., since PERL assumes a variable name # follows these characters. print <Environment Variable Test ENDOFTEXT } # Now, simply sort and print the names and values of each of the # environment variables from the keyed array to browser window foreach $key (sort keys(%ENV)) {print "$key:<\/B>$ENV{$key}
";} if ($bot eq 'html_bot') { print < ENDOFTEXT } } sub backupFile { ## takes as a parameter the full filename ## makes upto three backups of file with x, y, or z appended to filename where x ## the most recent backup my $fileName =$_[0]; my $orgFileName = "$fileName"; my ($ext, $fnMinusExt,$noPeriod); if (! ($orgFileName =~ m|\.|)) { $noPeriod =1; $fnMinusExt = $orgFileName; $ext =''; } else { $noPeriod =0; $orgFileName =~ m|^(.*)\.([^\.]*)$|; $fnMinusExt = $1; $ext = $2; } my $period = '.'; $period = '' if $noPeriod; if (-e "${fnMinusExt}y${period}${ext}") { rename("${fnMinusExt}y${period}$ext","${fnMinusExt}z${period}$ext") or &wwerror("$0","can't rename ${fnMinusExt}y${period}$ext"); } if (-e "${fnMinusExt}x${period}$ext") { rename("${fnMinusExt}x${period}$ext","${fnMinusExt}y${period}$ext") or &wwerror("$0","can't rename ${fnMinusExt}x${period}$ext"); } if (-e "${fnMinusExt}${period}$ext") { rename("${fnMinusExt}${period}$ext","${fnMinusExt}x${period}$ext") or &wwerror("$0","can't rename ${fnMinusExt}${period}$ext"); } } sub stripWhiteSpace { ## strip initial and trailing whitespace my $string = $_[0]; $string =~ s/\s*$//; # remove trailing whitespace $string =~ s/^\s*//; # remove initial spaces $string; } sub test_entry{ ## check for bad characters. & and = are used as delimiters ## in databases. DELIM (usually a coma) is used in csv files my $entry = shift; my $msg = 'OK'; if ($entry =~ /[=&$DELIM]/) { $msg = " The entry: $entry is invalid. An entry can not contain any of the following characters: $DELIM & = You must go back and correct this.\n"; } $msg; } sub testNewStudentLogin { my $login_name = shift; my $newStudentID = shift; my $msg = 'OK'; unless ($login_name =~ /^[\w\-\.]+$/) { $msg = " The login name: $login_name is invalid. Login name's can contain only upper and lower case letters, digits, -, dot('.'), and _ you must go back and correct this.\n"; return $msg; } my %currentLogins = %{getLoginName_StudentID_Hash()}; if (defined $currentLogins{$login_name}){ attachCLRecord($login_name); my $studentLastName = CL_getStudentLastName($login_name); my $studentFirstName = CL_getStudentFirstName($login_name); my $studentID = CL_getStudentID($login_name); $msg = " The login name: $login_name is already in use. It is assigned to $studentFirstName $studentLastName ($studentID). You must go back and choose a login name which is not yet being used.\n"; return $msg; } ## check that if student login exists in webwork database, the studentID's match if ( -e "${databaseDirectory}$Global::database" ){ my %loginName_StudentID_Hash_from_WW_DB =%{getLoginName_StudentID_Hash_from_WW_DB()}; if (defined $loginName_StudentID_Hash_from_WW_DB{$login_name}) { my $oldStudentID = $loginName_StudentID_Hash_from_WW_DB{$login_name}; unless ($newStudentID eq $oldStudentID) { my %setNumberHash = &getAllSetNumbersForStudentLoginHash($login_name); my @SetNumberKeys = keys(%setNumberHash); $msg = " The login name: $login_name is already in use in the webwork problem database. However, the new student ID ($newStudentID) does not match the old student ID ($oldStudentID). The following problem sets exist for $login_name $oldStudentID: Sets: @SetNumberKeys You have three choices. (1) Go back and use $oldStudentID for the student ID in which case the above sets will again be assigned to $login_name $oldStudentID. (2) Go back and choose a login name which is not yet being used. (3) Delete the problem sets listed above for $login_name $oldStudentID and then try again adding the student $login_name $newStudentID."; return $msg; } } } $msg; } sub testNewStudentID { my $studentID = shift; my $newLogin_name = shift; my $msg ='OK'; unless ($studentID =~ /^[\w\-\.]+$/) { $msg = " The student ID: $studentID is invalid. student ID's can contain only upper and lower case letters, digits, -, dot('.'), and _ you must go back and correct this.\n"; return ($msg); } my %currentIDs = %{getStudentID_LoginName_Hash()}; if (defined $currentIDs{$studentID}) { my $oldLogin = $currentIDs{$studentID}; attachCLRecord($oldLogin); my $studentLastName = CL_getStudentLastName($oldLogin); my $studentFirstName = CL_getStudentFirstName($oldLogin); $msg = " The student ID: $studentID is already in use. It is assigned to $studentFirstName $studentLastName ($oldLogin). you must go back and choose a student ID which is not yet being used.\n"; return $msg; } ## check that if student ID exists in webwork database, the student login's match if ( -e "${databaseDirectory}$Global::database" ){ my %loginName_StudentID_Hash_from_WW_DB =%{getLoginName_StudentID_Hash_from_WW_DB()}; my %studentID_LoginName_Hash_from_WW_DB = reverse %loginName_StudentID_Hash_from_WW_DB; if (defined $studentID_LoginName_Hash_from_WW_DB{$studentID}) { my $oldLogin_name = $studentID_LoginName_Hash_from_WW_DB{$studentID}; unless ($newLogin_name eq $oldLogin_name) { my %setNumberHash = &getAllSetNumbersForStudentLoginHash($oldLogin_name); my @SetNumberKeys = keys(%setNumberHash); $msg = " The student ID: $studentID is already in use in the webwork problem database. However, the new student Login name ($newLogin_name) does not match the old student Login name ($oldLogin_name). The following problem sets exist for $oldLogin_name $studentID: Sets: @SetNumberKeys You have three choices. (1) Go back and use $oldLogin_name for the student login name in which case the above sets will again be assigned to $oldLogin_name $studentID. (2) Go back and choose a student ID which is not yet being used. (3) Delete the problem sets listed above for $oldLogin_name $studentID and then try again adding the student $newLogin_name $studentID."; return $msg; } } } $msg; } sub getClasslistFilesAndLabels { ## returns a two element array ## the 0th element is a ref to an array of files ## the 1st element is a ref to a hash of labels my $Course = shift; my $defaultClasslistFile = getCourseClasslistFile($Course); ## find the available files opendir CLASSLISTDIR, $templateDirectory or wweror($0,"Can't open directory $templateDirectory"); my @allFiles = grep !/^\./, readdir CLASSLISTDIR; closedir CLASSLISTDIR; ## sort the files my @classlistFiles = grep /\.lst$/,@allFiles; my @sortedNames = sort @classlistFiles; ## put the default classlist file first if it exists my $shortFileName = $defaultClasslistFile; if ($shortFileName =~ m|$dd|) { $shortFileName =~ m|$dd([^$dd]*)$|; ## extract filename from full path name $shortFileName = $1; } my @newSortedNames = grep !/^$shortFileName$/, @sortedNames; if ($#newSortedNames != $#sortedNames) { unshift @newSortedNames,$shortFileName; @sortedNames = @newSortedNames; } ## generate labels my %label_hash = (); my ($ind,$date,$fileName,@stat); for $ind (@sortedNames) { $fileName = "${templateDirectory}$ind"; if (-e $fileName) { @stat = stat($fileName); $date = $stat[9]; $date = formatDateAndTime($date); $date =~ s|\s*at.*||; $label_hash{$ind} = "$ind --- Last Changed $date"; } } (\@sortedNames,\%label_hash); } 1;