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