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