Parent Directory
| 
Revision Log
Revision 2 - (view) (download) (as text)
| 1 : | sam | 2 | #!/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 |