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