Parent Directory
| 
Revision Log
Resolve bug #994 ("Try it" yields: sourceFilePath is unsafe!)
SetMaker uses a relative path for sourceFilePath, which is nice, but
which path_is_subdir didn't account for. Added thrid argument,
$allow_relative, to that utility which causes $dir to be prepended to
$path. Modified Problem.pm to trigger this behavior.
1 ################################################################################ 2 # WeBWorK Online Homework Delivery System 3 # Copyright © 2000-2006 The WeBWorK Project, http://openwebwork.sf.net/ 4 # $CVSHeader: webwork2/lib/WeBWorK/Utils.pm,v 1.73 2006/02/07 21:03:21 sh002i Exp $ 5 # 6 # This program is free software; you can redistribute it and/or modify it under 7 # the terms of either: (a) the GNU General Public License as published by the 8 # Free Software Foundation; either version 2, or (at your option) any later 9 # version, or (b) the "Artistic License" which comes with this package. 10 # 11 # This program is distributed in the hope that it will be useful, but WITHOUT 12 # ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS 13 # FOR A PARTICULAR PURPOSE. See either the GNU General Public License or the 14 # Artistic License for more details. 15 ################################################################################ 16 17 package WeBWorK::Utils; 18 use base qw(Exporter); 19 20 =head1 NAME 21 22 WeBWorK::Utils - useful utilities used by other WeBWorK modules. 23 24 =cut 25 26 use strict; 27 use warnings; 28 #use Apache::DB; 29 use DateTime; 30 use Date::Parse; 31 use Date::Format; 32 use File::Spec; 33 use Time::Zone; 34 use MIME::Base64; 35 use Errno; 36 use File::Path qw(rmtree); 37 use Carp; 38 39 use constant MKDIR_ATTEMPTS => 10; 40 41 # "standard" WeBWorK date/time format (for set definition files): 42 # %m/%d/%y at %I:%M%P 43 # where: 44 # %m = month number, starting with 01 45 # %d = numeric day of the month, with leading zeros (eg 01..31) 46 # %Y = year (4 digits) 47 # %I = hour, 12 hour clock, leading 0's) 48 # %M = minute, leading 0's 49 # %P = am or pm (Yes %p and %P are backwards :) 50 use constant DATE_FORMAT => "%m/%d/%Y at %I:%M%P %Z"; 51 52 our @EXPORT = (); 53 our @EXPORT_OK = qw( 54 runtime_use 55 readFile 56 readDirectory 57 listFilesRecursive 58 surePathToFile 59 makeTempDirectory 60 removeTempDirectory 61 path_is_subdir 62 formatDateTime 63 parseDateTime 64 textDateTime 65 intDateTime 66 timeToSec 67 writeLog 68 writeCourseLog 69 writeTimingLogEntry 70 list2hash 71 ref2string 72 decodeAnswers 73 encodeAnswers 74 max 75 pretty_print_rh 76 cryptPassword 77 dequote 78 undefstr 79 fisher_yates_shuffle 80 sortByName 81 ); 82 83 =head1 FUNCTIONS 84 85 =cut 86 87 ################################################################################ 88 # Lowlevel thingies 89 ################################################################################ 90 91 sub runtime_use($) { 92 croak "runtime_use: no module specified" unless $_[0]; 93 eval "package Main; require $_[0]; import $_[0]"; 94 die $@ if $@; 95 } 96 97 #sub backtrace($) { 98 # my ($style) = @_; 99 # $style = "warn" unless $style; 100 # my @bt = DB->backtrace; 101 # shift @bt; # Remove "backtrace" from the backtrace; 102 # if ($style eq "die") { 103 # die join "\n", @bt; 104 # } elsif ($style eq "warn") { 105 # warn join "\n", @bt; 106 # } elsif ($style eq "print") { 107 # print join "\n", @bt; 108 # } elsif ($style eq "return") { 109 # return @bt; 110 # } 111 #} 112 113 ################################################################################ 114 # Filesystem interaction 115 ################################################################################ 116 117 =head2 Filesystem interaction 118 119 =over 120 121 =cut 122 123 # Convert Windows and Mac (classic) line endings to UNIX line endings in a string. 124 # Windows uses CRLF, Mac uses CR, UNIX uses LF. (CR is ASCII 15, LF if ASCII 12) 125 sub force_eoln($) { 126 my ($string) = @_; 127 $string =~ s/\015\012?/\012/g; 128 return $string; 129 } 130 131 sub readFile($) { 132 my $fileName = shift; 133 local $/ = undef; # slurp the whole thing into one string 134 open my $dh, "<", $fileName 135 or die "failed to read file $fileName: $!"; 136 my $result = <$dh>; 137 close $dh; 138 return force_eoln($result); 139 } 140 141 sub readDirectory($) { 142 my $dirName = shift; 143 opendir my $dh, $dirName 144 or die "Failed to read directory $dirName: $!"; 145 my @result = readdir $dh; 146 close $dh; 147 return @result; 148 } 149 150 =item @matches = listFilesRecusive($dir, $match_qr, $prune_qr, $match_full, $prune_full) 151 152 Traverses the directory tree rooted at $dir, returning a list of files, named 153 pipes, and sockets matching the regular expression $match_qr. Directories 154 matching the regular expression $prune_qr are not visited. 155 156 $match_full and $prune_full are boolean values that indicate whether $match_qr 157 and $prune_qr, respectively, should be applied to the bare directory entry 158 (false) or to the path to the directory entry relative to $dir. 159 160 @matches is a list of paths relative to $dir. 161 162 =cut 163 164 sub listFilesRecursiveHelper($$$$$$); 165 sub listFilesRecursive($;$$$$) { 166 my ($dir, $match_qr, $prune_qr, $match_full, $prune_full) = @_; 167 return listFilesRecursiveHelper($dir, "", $match_qr, $prune_qr, $match_full, $prune_full); 168 } 169 170 sub listFilesRecursiveHelper($$$$$$) { 171 my ($base_dir, $curr_dir, $match_qr, $prune_qr, $match_full, $prune_full) = @_; 172 173 my $full_dir = "$base_dir/$curr_dir"; 174 175 my @dir_contents = readDirectory($full_dir); 176 177 my @matches; 178 179 foreach my $dir_entry (@dir_contents) { 180 my $full_path = "$full_dir/$dir_entry"; 181 182 # determine whether the entry is a directory or a file, taking into account the 183 my $is_dir; 184 my $is_file; 185 if (-l $full_path) { 186 my $link_target = "$full_dir/" . readlink $full_path; 187 if ($link_target) { 188 $is_dir = -d $link_target; 189 $is_file = !$is_dir && -f $link_target || -p $link_target || -S $link_target; 190 } else { 191 warn "Couldn't resolve symlink $full_path: $!"; 192 } 193 } else { 194 $is_dir = -d $full_path; 195 $is_file = !$is_dir && -f $full_path || -p $full_path || -S $full_path; 196 } 197 198 if ($is_dir) { 199 # standard things to skip 200 next if $dir_entry eq "."; 201 next if $dir_entry eq ".."; 202 203 # skip unreadable directories (and broken symlinks, incidentally) 204 unless (-r $full_path) { 205 warn "Directory/symlink $full_path not readable"; 206 next; 207 } 208 209 # check $prune_qr 210 my $subdir = ($curr_dir eq "") ? $dir_entry : "$curr_dir/$dir_entry"; 211 if (defined $prune_qr) { 212 my $prune_string = $prune_full ? $subdir : $dir_entry; 213 next if $prune_string =~ m/$prune_qr/; 214 } 215 216 # everything looks good, time to recurse! 217 push @matches, listFilesRecursiveHelper($base_dir, $subdir, $match_qr, $prune_qr, $match_full, $prune_full); 218 } elsif ($is_file) { 219 my $file = ($curr_dir eq "") ? $dir_entry : "$curr_dir/$dir_entry"; 220 my $match_string = $match_full ? $file : $dir_entry; 221 if (not defined $match_string or $match_string =~ m/$match_qr/) { 222 push @matches, $file; 223 } 224 } else { 225 # otherwise, it's a character device or a block device, and i don't 226 # suppose we want anything to do with those ;-) 227 } 228 } 229 230 return @matches; 231 } 232 233 # A very useful macro for making sure that all of the directories to a file have 234 # been constructed. 235 sub surePathToFile($$) { 236 # constructs intermediate directories enroute to the file 237 # the input path must be the path relative to this starting directory 238 my $start_directory = shift; 239 my $path = shift; 240 my $delim = "/"; 241 unless ($start_directory and $path ) { 242 warn "missing directory<br> surePathToFile start_directory path "; 243 return ''; 244 } 245 # use the permissions/group on the start directory itself as a template 246 my ($perms, $groupID) = (stat $start_directory)[2,5]; 247 #warn "&urePathToTmpFile: perms=$perms groupID=$groupID\n"; 248 249 # if the path starts with $start_directory (which is permitted but optional) remove this initial segment 250 $path =~ s|^$start_directory|| if $path =~ m|^$start_directory|; 251 252 253 # find the nodes on the given path 254 my @nodes = split("$delim",$path); 255 256 # create new path 257 $path = $start_directory; #convertPath("$tmpDirectory"); 258 259 while (@nodes>1) { # the last node is the file name 260 $path = $path . shift (@nodes) . "/"; #convertPath($path . shift (@nodes) . "/"); 261 #FIXME this make directory command may not be fool proof. 262 unless (-e $path) { 263 mkdir($path, $perms) 264 or warn "Failed to create directory $path with start directory $start_directory "; 265 } 266 267 } 268 269 $path = $path . shift(@nodes); #convertPath($path . shift(@nodes)); 270 return $path; 271 } 272 273 sub makeTempDirectory($$) { 274 my ($parent, $basename) = @_; 275 # Loop until we're able to create a directory, or it fails for some 276 # reason other than there already being something there. 277 my $triesRemaining = MKDIR_ATTEMPTS; 278 my ($fullPath, $success); 279 do { 280 my $suffix = join "", map { ('A'..'Z','a'..'z','0'..'9')[int rand 62] } 1 .. 8; 281 $fullPath = "$parent/$basename.$suffix"; 282 $success = mkdir $fullPath; 283 } until ($success or not $!{EEXIST}); 284 die "Failed to create directory $fullPath: $!" 285 unless $success; 286 return $fullPath; 287 } 288 289 sub removeTempDirectory($) { 290 my ($dir) = @_; 291 rmtree($dir, 0, 0); 292 } 293 294 =item path_is_subdir($path, $dir, $allow_relative) 295 296 Ensures that $path refers to a location "inside" $dir. If $allow_relative is 297 true and $path is not absoulte, it is assumed to be relative to $dir. 298 299 The method of checking is rather rudimentary at the moment. First, upreferences 300 ("..") are disallowed, in $path, then it is checked to make sure that some 301 prefix of it matches $dir. 302 303 If either of these checks fails, a false value is returned. Otherwise, a true 304 value is returned. 305 306 =cut 307 308 sub path_is_subdir($$;$) { 309 my ($path, $dir, $allow_relative) = @_; 310 311 unless ($path =~ /^\//) { 312 if ($allow_relative) { 313 $path = "$dir/$path"; 314 } else { 315 return 0; 316 } 317 } 318 319 $path = File::Spec->canonpath($path); 320 $path .= "/" unless $path =~ m|/$|; 321 return 0 if $path =~ m#(^\.\.$|^\.\./|/\.\./|/\.\.$)#; 322 323 $dir = File::Spec->canonpath($dir); 324 $dir .= "/" unless $dir =~ m|/$|; 325 return 0 unless $path =~ m|^$dir|; 326 327 return 1; 328 } 329 330 =back 331 332 =cut 333 334 ################################################################################ 335 # Date/time processing 336 ################################################################################ 337 338 =head2 Date/time processing 339 340 =over 341 342 =item $dateTime = parseDateTime($string, $display_tz) 343 344 Parses $string as a datetime. If $display_tz is given, $string is assumed to be 345 in that timezone. Otherwise, the server's timezone is used. The result, 346 $dateTime, is an integer UNIX datetime (epoch) in the server's timezone. 347 348 =cut 349 350 # This is a modified version of the subroutine of the same name from WeBWorK 351 # 1.9.05's scripts/FILE.pl (v1.13). It has been modified to understand time 352 # zones. The time zone specification must appear at the end of the string and be 353 # preceded by whitespace. The return value is a list consisting of the following 354 # elements: 355 # 356 # ($second, $minute, $hour, $day, $month, $year, $zone) 357 # 358 # $second, $minute, $hour, $day, and $month are zero-indexed. $year is the 359 # number of years since 1900. $zone is a string (hopefully) representing the 360 # time zone. 361 # 362 # Error handling has also been improved. Exceptions are now thrown for errors, 363 # and more information is given about the nature of errors. 364 # 365 sub unformatDateAndTime { 366 my ($string) = @_; 367 my $orgString = $string; 368 369 $string =~ s|^\s+||; 370 $string =~ s|\s+$||; 371 $string =~ s|at| at |i; ## OK if forget to enter spaces or use wrong case 372 $string =~ s|AM| AM|i; ## OK if forget to enter spaces or use wrong case 373 $string =~ s|PM| PM|i; ## OK if forget to enter spaces or use wrong case 374 $string =~ s|,| at |; ## start translating old form of date/time to new form 375 376 # case where the at is missing: MM/DD/YYYY at HH:MM AMPM ZONE 377 unformatDateAndTime_error($orgString, "The 'at' appears to be missing.") 378 if $string =~ m|^\s*[\/\d]+\s+[:\d]+|; 379 380 my ($date, $at, $time, $AMPM, $TZ) = split /\s+/, $string; 381 382 unformatDateAndTime_error($orgString, "The date and/or time appear to be missing.", $date, $time, $AMPM, $TZ) 383 unless defined $date and defined $at and defined $time; 384 385 # deal with military time 386 unless ($time =~ /:/) { 387 { ##bare block for 'case" structure 388 $time =~ /(\d\d)(\d\d)/; 389 my $tmp_hour = $1; 390 my $tmp_min = $2; 391 if ($tmp_hour eq '00') {$time = "12:$tmp_min"; $AMPM = 'AM';last;} 392 if ($tmp_hour eq '12') {$time = "12:$tmp_min"; $AMPM = 'PM';last;} 393 if ($tmp_hour < 12) {$time = "$tmp_hour:$tmp_min"; $AMPM = 'AM';last;} 394 if ($tmp_hour < 24) { 395 $tmp_hour = $tmp_hour - 12; 396 $time = "$tmp_hour:$tmp_min"; 397 $AMPM = 'PM'; 398 } 399 } ##end of bare block for 'case" structure 400 401 } 402 403 # default value for $AMPM 404 $AMPM = "AM" unless defined $AMPM; 405 406 my ($mday, $mon, $year, $wday, $yday, $sec, $pm, $min, $hour); 407 $sec=0; 408 $time =~ /^([0-9]+)\s*\:\s*([0-9]*)/; 409 $min=$2; 410 $hour = $1; 411 unformatDateAndTime_error($orgString, "Hour must be in the range [1,12].", $date, $time, $AMPM, $TZ) 412 if $hour < 1 or $hour > 12; 413 unformatDateAndTime_error($orgString, "Minute must be in the range [0-59].", $date, $time, $AMPM, $TZ) 414 if $min < 0 or $min > 59; 415 $pm = 0; 416 $pm = 12 if ($AMPM =~/PM/ and $hour < 12); 417 $hour += $pm; 418 $hour = 0 if ($AMPM =~/AM/ and $hour == 12); 419 $date =~ m|([0-9]+)\s*/\s*([0-9]+)/\s*([0-9]+)|; 420 $mday =$2; 421 $mon=($1-1); 422 unformatDateAndTime_error($orgString, "Day must be in the range [1,31].", $date, $time, $AMPM, $TZ) 423 if $mday < 1 or $mday > 31; 424 unformatDateAndTime_error($orgString, "Month must be in the range [1,12].", $date, $time, $AMPM, $TZ) 425 if $mon < 0 or $mon > 11; 426 $year=$3; 427 $wday=""; 428 $yday=""; 429 return ($sec, $min, $hour, $mday, $mon, $year, $TZ); 430 } 431 432 sub unformatDateAndTime_error { 433 434 if (@_ > 2) { 435 my ($orgString, $error, $date, $time, $AMPM, $TZ) = @_; 436 $date = "(undefined)" unless defined $date; 437 $time = "(undefined)" unless defined $time; 438 $AMPM = "(undefined)" unless defined $AMPM; 439 $TZ = "(undefined)" unless defined $TZ; 440 die "Incorrect date/time format \"$orgString\": $error\n", 441 "Correct format is MM/DD/YY at HH:MM AMPM ZONE\n", 442 "\tdate = $date\n", 443 "\ttime = $time\n", 444 "\tampm = $AMPM\n", 445 "\tzone = $TZ\n"; 446 } else { 447 my ($orgString, $error) = @_; 448 die "Incorrect date/time format \"$orgString\": $error\n", 449 "Correct format is MM/DD/YY at HH:MM AMPM ZONE\n"; 450 } 451 } 452 453 sub parseDateTime($;$) { 454 my ($string, $display_tz) = @_; 455 $display_tz ||= "local"; 456 #warn "parseDateTime('$string', '$display_tz')\n"; 457 458 # use WeBWorK 1 date parsing routine 459 my ($second, $minute, $hour, $day, $month, $year, $zone) = unformatDateAndTime($string); 460 my $zone_str = defined $zone ? $zone : "UNDEF"; 461 #warn "\tunformatDateAndTime: $second $minute $hour $day $month $year $zone_str\n"; 462 463 # DateTime expects month 1-12, not 0-11 464 $month++; 465 466 # Do what Time::Local does to ambiguous years 467 { 468 my $ThisYear = (localtime())[5]; # FIXME: should be relative to $string's timezone 469 my $Breakpoint = ($ThisYear + 50) % 100; 470 my $NextCentury = $ThisYear - $ThisYear % 100; 471 $NextCentury += 100 if $Breakpoint < 50; 472 my $Century = $NextCentury - 100; 473 my $SecOff = 0; 474 475 if ($year >= 1000) { 476 # leave alone 477 } elsif ($year < 100 and $year >= 0) { 478 $year += ($year > $Breakpoint) ? $Century : $NextCentury; 479 $year += 1900; 480 } else { 481 $year += 1900; 482 } 483 } 484 485 my $epoch; 486 487 if (defined $zone and $zone ne "") { 488 if (DateTime::TimeZone->is_valid_name($zone)) { 489 #warn "\t\$zone is valid according to DateTime::TimeZone\n"; 490 491 my $dt = new DateTime( 492 year => $year, 493 month => $month, 494 day => $day, 495 hour => $hour, 496 minute => $minute, 497 second => $second, 498 time_zone => $zone, 499 ); 500 #warn "\t\$dt = ", $dt->strftime(DATE_FORMAT), "\n"; 501 502 $epoch = $dt->epoch; 503 #warn "\t\$dt->epoch = $epoch\n"; 504 } else { 505 #warn "\t\$zone is invalid according to DateTime::TimeZone, so we ask Time::Zone\n"; 506 507 # treat the date/time as UTC 508 my $dt = new DateTime( 509 year => $year, 510 month => $month, 511 day => $day, 512 hour => $hour, 513 minute => $minute, 514 second => $second, 515 time_zone => "UTC", 516 ); 517 #warn "\t\$dt = ", $dt->strftime(DATE_FORMAT), "\n"; 518 519 # convert to an epoch value 520 my $utc_epoch = $dt->epoch 521 or die "Date/time '$string' not representable as an epoch. Get more bits!\n"; 522 #warn "\t\$utc_epoch = $utc_epoch\n"; 523 524 # get offset for supplied timezone and utc_epoch 525 my $offset = tz_offset($zone, $utc_epoch) or die "Time zone '$zone' not recognized.\n"; 526 #warn "\t\$zone is valid according to Time::Zone (\$offset = $offset)\n"; 527 528 #$epoch = $utc_epoch + $offset; 529 ##warn "\t\$epoch = \$utc_epoch + \$offset = $epoch\n"; 530 531 $dt->subtract(seconds => $offset); 532 #warn "\t\$dt - \$offset = ", $dt->strftime(DATE_FORMAT), "\n"; 533 534 $epoch = $dt->epoch; 535 #warn "\t\$epoch = $epoch\n"; 536 } 537 } else { 538 #warn "\t\$zone not supplied, using \$display_tz\n"; 539 540 my $dt = new DateTime( 541 year => $year, 542 month => $month, 543 day => $day, 544 hour => $hour, 545 minute => $minute, 546 second => $second, 547 time_zone => $display_tz, 548 ); 549 #warn "\t\$dt = ", $dt->strftime(DATE_FORMAT), "\n"; 550 551 $epoch = $dt->epoch; 552 #warn "\t\$epoch = $epoch\n"; 553 } 554 555 return $epoch; 556 } 557 558 =item $string = formatDateTime($dateTime, $display_tz) 559 560 Formats the UNIX datetime $dateTime in the standard WeBWorK datetime format. 561 $dateTime is assumed to be in the server's time zone. If $display_tz is given, 562 the datetime is converted from the server's timezone to the timezone specified. 563 564 =cut 565 566 sub formatDateTime($;$) { 567 my ($dateTime, $display_tz) = @_; 568 $display_tz ||= "local"; 569 #warn "formatDateTime('$dateTime', '$display_tz')\n"; 570 571 my $dt = DateTime->from_epoch(epoch => $dateTime, time_zone => $display_tz); 572 #warn "\t\$dt = ", $dt->strftime(DATE_FORMAT), "\n"; 573 return $dt->strftime(DATE_FORMAT); 574 } 575 576 =item $string = textDateTime($string_or_dateTime) 577 578 Accepts a UNIX datetime or a formatted string, returns a formatted string. 579 580 =cut 581 582 sub textDateTime($) { 583 return ($_[0] =~ m/^\d*$/) ? formatDateTime($_[0]) : $_[0]; 584 } 585 586 =item $dateTIme = intDateTime($string_or_dateTime) 587 588 Accepts a UNIX datetime or a formatted string, returns a UNIX datetime. 589 590 =cut 591 592 sub intDateTime($) { 593 return ($_[0] =~ m/^\d*$/) ? $_[0] : parseDateTime($_[0]); 594 } 595 596 =item $timeinsec = timeToSec($time) 597 598 Makes a stab at converting a time (with a possible unit) into a number of 599 seconds. 600 601 =cut 602 603 sub timeToSec($) { 604 my $t = shift(); 605 if ( $t =~ /^(\d+)\s+(\S+)\s*$/ ) { 606 my ( $val, $unit ) = ( $1, $2 ); 607 if ( $unit =~ /month/i || $unit =~ /mon/i ) { 608 $val *= 18144000; # this assumes 30 days/month 609 } elsif ( $unit =~ /week/i || $unit =~ /wk/i ) { 610 $val *= 604800; 611 } elsif ( $unit =~ /day/i || $unit =~ /dy/i ) { 612 $val *= 86400; 613 } elsif ( $unit =~ /hour/i || $unit =~ /hr/i ) { 614 $val *= 3600; 615 } elsif ( $unit =~ /minute/i || $unit =~ /min/i ) { 616 $val *= 60; 617 } elsif ( $unit =~ /second/i || $unit =~ /sec/i || $unit =~ /^s$/i ) { 618 # do nothing 619 } else { 620 warn("Unrecognized time unit $unit.\nAssuming seconds.\n"); 621 } 622 return $val; 623 } elsif ( $t =~ /^(\d+)$/ ) { 624 return $t; 625 } else { 626 warn("Unrecognized time interval: $t\n"); 627 return 0; 628 } 629 } 630 631 =back 632 633 =cut 634 635 ################################################################################ 636 # Logging 637 ################################################################################ 638 639 sub writeLog($$@) { 640 my ($ce, $facility, @message) = @_; 641 unless ($ce->{webworkFiles}->{logs}->{$facility}) { 642 warn "There is no log file for the $facility facility defined.\n"; 643 return; 644 } 645 my $logFile = $ce->{webworkFiles}->{logs}->{$facility}; 646 surePathToFile($ce->{webworkDirs}->{root}, $logFile); 647 local *LOG; 648 if (open LOG, ">>", $logFile) { 649 print LOG "[", time2str("%a %b %d %H:%M:%S %Y", time), "] @message\n"; 650 close LOG; 651 } else { 652 warn "failed to open $logFile for writing: $!"; 653 } 654 } 655 656 sub writeCourseLog($$@) { 657 my ($ce, $facility, @message) = @_; 658 unless ($ce->{courseFiles}->{logs}->{$facility}) { 659 warn "There is no course log file for the $facility facility defined.\n"; 660 return; 661 } 662 my $logFile = $ce->{courseFiles}->{logs}->{$facility}; 663 surePathToFile($ce->{courseDirs}->{root}, $logFile); 664 local *LOG; 665 if (open LOG, ">>", $logFile) { 666 print LOG "[", time2str("%a %b %d %H:%M:%S %Y", time), "] @message\n"; 667 close LOG; 668 } else { 669 warn "failed to open $logFile for writing: $!"; 670 } 671 } 672 673 # $ce - a WeBWork::CourseEnvironment object 674 # $function - fully qualified function name 675 # $details - any information, do not use the characters '[' or ']' 676 # $beginEnd - the string "begin", "intermediate", or "end" 677 # use the intermediate step begun or completed for INTERMEDIATE 678 # use an empty string for $details when calling for END 679 # Information printed in format: 680 # [formatted date & time ] processID unixTime BeginEnd $function $details 681 sub writeTimingLogEntry($$$$) { 682 my ($ce, $function, $details, $beginEnd) = @_; 683 $beginEnd = ($beginEnd eq "begin") ? ">" : ($beginEnd eq "end") ? "<" : "-"; 684 writeLog($ce, "timing", "$$ ".time." $beginEnd $function [$details]"); 685 } 686 687 ################################################################################ 688 # Data munging 689 ################################################################################ 690 691 sub list2hash(@) { 692 map {$_ => "0"} @_; 693 } 694 695 sub refBaseType($) { 696 my $ref = shift; 697 $ref =~ m/(\w+)\(/; # this might not be robust... 698 return $1; 699 } 700 701 sub ref2string($;$); 702 sub ref2string($;$) { 703 my $ref = shift; 704 my $dontExpand = shift || {}; 705 my $refType = ref $ref; 706 my $result; 707 if ($refType and not $dontExpand->{$refType}) { 708 my $baseType = refBaseType($ref); 709 $result .= '<font size="1" color="grey">' . $refType; 710 $result .= " ($baseType)" if $baseType and $refType ne $baseType; 711 $result .= ":</font><br>"; 712 $result .= '<table border="1" cellpadding="2">'; 713 if ($baseType eq "HASH") { 714 my %hash = %$ref; 715 foreach (sort keys %hash) { 716 $result .= '<tr valign="top">'; 717 $result .= "<td>$_</td>"; 718 $result .= "<td>" . ref2string($hash{$_}, $dontExpand) . "</td>"; 719 $result .= "</tr>"; 720 } 721 } elsif ($baseType eq "ARRAY") { 722 my @array = @$ref; 723 # special case for Problem, Set, and User objects, which are defined 724 # using lists and contain a @FIELDS package variable: 725 no strict 'refs'; 726 my @FIELDS = eval { @{$refType."::FIELDS"} }; 727 use strict 'refs'; 728 undef @FIELDS unless scalar @FIELDS == scalar @array and not $@; 729 foreach (0 .. $#array) { 730 $result .= '<tr valign="top">'; 731 $result .= "<td>$_</td>"; 732 $result .= "<td>".$FIELDS[$_]."</td>" if @FIELDS; 733 $result .= "<td>" . ref2string($array[$_], $dontExpand) . "</td>"; 734 $result .= "</tr>"; 735 } 736 } elsif ($baseType eq "SCALAR") { 737 my $scalar = $$ref; 738 $result .= '<tr valign="top">'; 739 $result .= "<td>$scalar</td>"; 740 $result .= "</tr>"; 741 } else { 742 # perhaps a coderef? in any case, i don't feel like dealing with it! 743 $result .= '<tr valign="top">'; 744 $result .= "<td>$ref</td>"; 745 $result .= "</tr>"; 746 } 747 $result .= "</table>" 748 } else { 749 $result .= defined $ref ? $ref : '<font color="red">undef</font>'; 750 } 751 } 752 our $BASE64_ENCODED = 'base64_encoded:'; 753 # use constant BASE64_ENCODED = 'base64_encoded; 754 # was not evaluated in the matching and substitution 755 # statements 756 sub decodeAnswers($) { 757 my $string = shift; 758 return unless defined $string and $string; 759 760 if ($string =~/^$BASE64_ENCODED/o) { 761 $string =~ s/^$BASE64_ENCODED//o; 762 $string = decode_base64($string); 763 } 764 765 my @array = split m/##/, $string; 766 $array[$_] =~ s/\\#\\/#/g foreach 0 .. $#array; 767 push @array, "" if @array%2; 768 return @array; # it's actually a hash ;) 769 } 770 771 sub encodeAnswers(\%\@) { 772 my %hash = %{ shift() }; 773 my @order = @{ shift() }; 774 my $string = ""; 775 foreach my $name (@order) { 776 my $value = defined $hash{$name} ? $hash{$name} : ""; 777 $name =~ s/#/\\#\\/g; # this is a WEIRD way to escape things 778 $value =~ s/#/\\#\\/g; # and it's not my fault! 779 if ($value =~ m/\\$/) { 780 # if the value ends with a backslash, string2hash will 781 # interpret that as a normal escape sequence (not part 782 # of the weird pound escape sequence) if the next 783 # character is &. So we have to protect against this. 784 # will adding a spcae at the end of the last answer 785 # hurt anything? i don't think so... 786 $value .= " "; 787 } 788 $string .= "$name##$value##"; # this is also not my fault 789 } 790 $string =~ s/##$//; # remove last pair of hashs 791 792 $string = $BASE64_ENCODED.encode_base64($string, ""); 793 # Empty string in second argument prevents end-of-line characters from being used. 794 # This is nice for examining database contents manually since it prevents newlines 795 # from being introduced into database records. 796 797 return $string; 798 } 799 800 sub max(@) { 801 my $soFar; 802 foreach my $item (@_) { 803 $soFar = $item unless defined $soFar; 804 if ($item > $soFar) { 805 $soFar = $item; 806 } 807 } 808 return defined $soFar ? $soFar : 0; 809 } 810 811 sub pretty_print_rh($) { 812 my $rh = shift; 813 foreach my $key (sort keys %{$rh}) { 814 warn " $key => ",$rh->{$key},"\n"; 815 } 816 } 817 818 sub cryptPassword($) { 819 my ($clearPassword) = @_; 820 my $salt = join("", ('.','/','0'..'9','A'..'Z','a'..'z')[rand 64, rand 64]); 821 my $cryptPassword = crypt($clearPassword, $salt); 822 return $cryptPassword; 823 } 824 825 # from the Perl Cookbook, first edition, page 25: 826 sub dequote($) { 827 local $_ = shift; 828 my ($white, $leader); # common whitespace and common leading string 829 if (/^\s*(?:([^\w\s]+)(\s*).*\n)(?:\s*\1\2?.*\n)+$/) { 830 ($white, $leader) = ($2, quotemeta($1)); 831 } else { 832 ($white, $leader) = (/^(\s+)/, ''); 833 } 834 s/^\s*?$leader(?:$white)?//gm; 835 return $_; 836 } 837 838 sub undefstr($@) { 839 map { defined $_ ? $_ : $_[0] } @_[1..$#_]; 840 } 841 842 # shuffle an array in place 843 # Perl Cookbook, Recipe 4.17. Randomizing an Array 844 sub fisher_yates_shuffle { 845 my $array = shift; 846 my $i; 847 for ($i = @$array; --$i; ) { 848 my $j = int rand ($i+1); 849 next if $i == $j; 850 @$array[$i,$j] = @$array[$j,$i]; 851 } 852 } 853 854 ################################################################################ 855 # Sorting 856 ################################################################################ 857 858 # p. 101, Camel, 3rd ed. 859 # The <=> and cmp operators return -1 if the left operand is less than the 860 # right operand, 0 if they are equal, and +1 if the left operand is greater 861 # than the right operand. 862 sub sortByName($@) { 863 my ($field, @items) = @_; 864 return sort { 865 my @aParts = split m/(?<=\D)(?=\d)|(?<=\d)(?=\D)/, defined $field ? $a->$field : $a; 866 my @bParts = split m/(?<=\D)(?=\d)|(?<=\d)(?=\D)/, defined $field ? $b->$field : $b; 867 while (@aParts and @bParts) { 868 my $aPart = shift @aParts; 869 my $bPart = shift @bParts; 870 my $aNumeric = $aPart =~ m/^\d*$/; 871 my $bNumeric = $bPart =~ m/^\d*$/; 872 873 # numbers should come before words 874 return -1 if $aNumeric and not $bNumeric; 875 return +1 if not $aNumeric and $bNumeric; 876 877 # both have the same type 878 if ($aNumeric and $bNumeric) { 879 next if $aPart == $bPart; # check next pair 880 return $aPart <=> $bPart; # compare numerically 881 } else { 882 next if $aPart eq $bPart; # check next pair 883 return $aPart cmp $bPart; # compare lexicographically 884 } 885 } 886 return +1 if @aParts; # a has more sections, should go second 887 return -1 if @bParts; # a had fewer sections, should go first 888 } @items; 889 } 890 891 1;
| aubreyja at gmail dot com | ViewVC Help |
| Powered by ViewVC 1.0.9 |