Parent Directory
| 
Revision Log
Add clarification to error message for surePathToFile
1 ################################################################################ 2 # WeBWorK Online Homework Delivery System 3 # Copyright © 2000-2003 The WeBWorK Project, http://openwebwork.sf.net/ 4 # $CVSHeader: webwork-modperl/lib/WeBWorK/Utils.pm,v 1.69 2005/09/09 20:52:03 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 abou the nature of errors. 326 # 327 sub unformatDateAndTime { 328 my ($string) = @_; 329 my $orgString =$string; 330 $string =~ s|^\s+||; 331 $string =~ s|\s+$||; 332 $string =~ s|at| at |i; ## OK if forget to enter spaces or use wrong case 333 $string =~ s|AM| AM|i; ## OK if forget to enter spaces or use wrong case 334 $string =~ s|PM| PM|i; ## OK if forget to enter spaces or use wrong case 335 $string =~ s|,| at |; ## start translating old form of date/time to new form 336 if ($string =~ m|^\s*[\/\d]+\s+[:\d]+| ) { # case where the at is missing: MM/DD/YYYY at HH:MM AMPM ZONE 337 die "Incorrect date/time format \"$orgString\". The \"at\" appears to be missing. 338 Correct format is MM/DD/YYYY at HH:MM AMPM ZONE (e.g. \"03/29/2004 at 06:00am EST\")"; 339 } 340 341 my($date,$at, $time,$AMPM,$TZ) = split(/\s+/,$string); 342 unless ($time =~ /:/) { 343 { ##bare block for 'case" structure 344 $time =~ /(\d\d)(\d\d)/; 345 my $tmp_hour = $1; 346 my $tmp_min = $2; 347 if ($tmp_hour eq '00') {$time = "12:$tmp_min"; $AMPM = 'AM';last;} 348 if ($tmp_hour eq '12') {$time = "12:$tmp_min"; $AMPM = 'PM';last;} 349 if ($tmp_hour < 12) {$time = "$tmp_hour:$tmp_min"; $AMPM = 'AM';last;} 350 if ($tmp_hour < 24) { 351 $tmp_hour = $tmp_hour - 12; 352 $time = "$tmp_hour:$tmp_min"; 353 $AMPM = 'PM'; 354 } 355 } ##end of bare block for 'case" structure 356 357 } 358 359 my ($mday, $mon, $year, $wday, $yday,$sec, $pm, $min, $hour); 360 $sec=0; 361 $time =~ /^([0-9]+)\s*\:\s*([0-9]*)/; 362 $min=$2; 363 $hour = $1; 364 if ($hour < 1 or $hour > 12) { 365 die "Incorrect date/time format \"$orgString\". Hour must be in the range [1,12]. 366 Correct format is MM/DD/YYYY at HH:MM AMPM ZONE (e.g. \"03/29/2004 at 06:00am EST\") 367 date = $date 368 time = $time 369 ampm = $AMPM 370 zone = $TZ\n"; 371 } 372 if ($min < 0 or $min > 59) { 373 die "Incorrect date/time format \"$orgString\". Minute must be in the range [0-59]. 374 Correct format is MM/DD/YYYY at HH:MM AMPM ZONE 375 date = $date 376 time = $time 377 ampm = $AMPM 378 zone = $TZ\n"; 379 } 380 $pm = 0; 381 $pm = 12 if ($AMPM =~/PM/ and $hour < 12); 382 $hour += $pm; 383 $hour = 0 if ($AMPM =~/AM/ and $hour == 12); 384 $date =~ m!([0-9]+)\s*/\s*([0-9]+)/\s*([0-9]+)! ; 385 $mday =$2; 386 $mon=($1-1); 387 if ($mday < 1 or $mday > 31) { 388 die "Incorrect date/time format \"$orgString\". Day must be in the range [1,31]. 389 Correct format is MM/DD/YY at HH:MM AMPM ZONE 390 date = $date 391 time = $time 392 ampm = $AMPM 393 zone = $TZ\n"; 394 } 395 if ($mon < 0 or $mon > 11) { 396 die "Incorrect date/time format \"$orgString\". Month must be in the range [1,12]. 397 Correct format is MM/DD/YY at HH:MM AMPM ZONE 398 date = $date 399 time = $time 400 ampm = $AMPM 401 zone = $TZ\n"; 402 } 403 $year=$3; 404 $wday=""; 405 $yday=""; 406 return ($sec, $min, $hour, $mday, $mon, $year, $TZ); 407 } 408 409 410 sub parseDateTime($;$) { 411 my ($string, $display_tz) = @_; 412 $display_tz ||= "local"; 413 #warn "parseDateTime('$string', '$display_tz')\n"; 414 415 # use WeBWorK 1 date parsing routine 416 my ($second, $minute, $hour, $day, $month, $year, $zone) = unformatDateAndTime($string); 417 my $zone_str = defined $zone ? $zone : "UNDEF"; 418 #warn "\tunformatDateAndTime: $second $minute $hour $day $month $year $zone_str\n"; 419 420 # DateTime expects month 1-12, not 0-11 421 $month++; 422 423 # Do what Time::Local does to ambiguous years 424 { 425 my $ThisYear = (localtime())[5]; # FIXME: should be relative to $string's timezone 426 my $Breakpoint = ($ThisYear + 50) % 100; 427 my $NextCentury = $ThisYear - $ThisYear % 100; 428 $NextCentury += 100 if $Breakpoint < 50; 429 my $Century = $NextCentury - 100; 430 my $SecOff = 0; 431 432 if ($year >= 1000) { 433 # leave alone 434 } elsif ($year < 100 and $year >= 0) { 435 $year += ($year > $Breakpoint) ? $Century : $NextCentury; 436 $year += 1900; 437 } else { 438 $year += 1900; 439 } 440 } 441 442 my $epoch; 443 444 if (defined $zone and $zone ne "") { 445 if (DateTime::TimeZone->is_valid_name($zone)) { 446 #warn "\t\$zone is valid according to DateTime::TimeZone\n"; 447 448 my $dt = new DateTime( 449 year => $year, 450 month => $month, 451 day => $day, 452 hour => $hour, 453 minute => $minute, 454 second => $second, 455 time_zone => $zone, 456 ); 457 #warn "\t\$dt = ", $dt->strftime(DATE_FORMAT), "\n"; 458 459 $epoch = $dt->epoch; 460 #warn "\t\$dt->epoch = $epoch\n"; 461 } else { 462 #warn "\t\$zone is invalid according to DateTime::TimeZone, so we ask Time::Zone\n"; 463 464 # treat the date/time as UTC 465 my $dt = new DateTime( 466 year => $year, 467 month => $month, 468 day => $day, 469 hour => $hour, 470 minute => $minute, 471 second => $second, 472 time_zone => "UTC", 473 ); 474 #warn "\t\$dt = ", $dt->strftime(DATE_FORMAT), "\n"; 475 476 # convert to an epoch value 477 my $utc_epoch = $dt->epoch 478 or die "Date/time '$string' not representable as an epoch. Get more bits!\n"; 479 #warn "\t\$utc_epoch = $utc_epoch\n"; 480 481 # get offset for supplied timezone and utc_epoch 482 my $offset = tz_offset($zone, $utc_epoch) or die "Time zone '$zone' not recognized.\n"; 483 #warn "\t\$zone is valid according to Time::Zone (\$offset = $offset)\n"; 484 485 #$epoch = $utc_epoch + $offset; 486 ##warn "\t\$epoch = \$utc_epoch + \$offset = $epoch\n"; 487 488 $dt->subtract(seconds => $offset); 489 #warn "\t\$dt - \$offset = ", $dt->strftime(DATE_FORMAT), "\n"; 490 491 $epoch = $dt->epoch; 492 #warn "\t\$epoch = $epoch\n"; 493 } 494 } else { 495 #warn "\t\$zone not supplied, using \$display_tz\n"; 496 497 my $dt = new DateTime( 498 year => $year, 499 month => $month, 500 day => $day, 501 hour => $hour, 502 minute => $minute, 503 second => $second, 504 time_zone => $display_tz, 505 ); 506 #warn "\t\$dt = ", $dt->strftime(DATE_FORMAT), "\n"; 507 508 $epoch = $dt->epoch; 509 #warn "\t\$epoch = $epoch\n"; 510 } 511 512 return $epoch; 513 } 514 515 =item $string = formatDateTime($dateTime, $display_tz) 516 517 Formats the UNIX datetime $dateTime in the standard WeBWorK datetime format. 518 $dateTime is assumed to be in the server's time zone. If $display_tz is given, 519 the datetime is converted from the server's timezone to the timezone specified. 520 521 =cut 522 523 sub formatDateTime($;$) { 524 my ($dateTime, $display_tz) = @_; 525 $display_tz ||= "local"; 526 #warn "formatDateTime('$dateTime', '$display_tz')\n"; 527 528 my $dt = DateTime->from_epoch(epoch => $dateTime, time_zone => $display_tz); 529 #warn "\t\$dt = ", $dt->strftime(DATE_FORMAT), "\n"; 530 return $dt->strftime(DATE_FORMAT); 531 } 532 533 =item $string = textDateTime($string_or_dateTime) 534 535 Accepts a UNIX datetime or a formatted string, returns a formatted string. 536 537 =cut 538 539 sub textDateTime($) { 540 return ($_[0] =~ m/^\d*$/) ? formatDateTime($_[0]) : $_[0]; 541 } 542 543 =item $dateTIme = intDateTime($string_or_dateTime) 544 545 Accepts a UNIX datetime or a formatted string, returns a UNIX datetime. 546 547 =cut 548 549 sub intDateTime($) { 550 return ($_[0] =~ m/^\d*$/) ? $_[0] : parseDateTime($_[0]); 551 } 552 553 =item $timeinsec = timeToSec($time) 554 555 Makes a stab at converting a time (with a possible unit) into a number of 556 seconds. 557 558 =cut 559 560 sub timeToSec($) { 561 my $t = shift(); 562 if ( $t =~ /^(\d+)\s+(\S+)\s*$/ ) { 563 my ( $val, $unit ) = ( $1, $2 ); 564 if ( $unit =~ /month/i || $unit =~ /mon/i ) { 565 $val *= 18144000; # this assumes 30 days/month 566 } elsif ( $unit =~ /week/i || $unit =~ /wk/i ) { 567 $val *= 604800; 568 } elsif ( $unit =~ /day/i || $unit =~ /dy/i ) { 569 $val *= 86400; 570 } elsif ( $unit =~ /hour/i || $unit =~ /hr/i ) { 571 $val *= 3600; 572 } elsif ( $unit =~ /minute/i || $unit =~ /min/i ) { 573 $val *= 60; 574 } elsif ( $unit =~ /second/i || $unit =~ /sec/i || $unit =~ /^s$/i ) { 575 # do nothing 576 } else { 577 warn("Unrecognized time unit $unit.\nAssuming seconds.\n"); 578 } 579 return $val; 580 } elsif ( $t =~ /^(\d+)$/ ) { 581 return $t; 582 } else { 583 warn("Unrecognized time interval: $t\n"); 584 return 0; 585 } 586 } 587 588 =back 589 590 =cut 591 592 ################################################################################ 593 # Logging 594 ################################################################################ 595 596 sub writeLog($$@) { 597 my ($ce, $facility, @message) = @_; 598 unless ($ce->{webworkFiles}->{logs}->{$facility}) { 599 warn "There is no log file for the $facility facility defined.\n"; 600 return; 601 } 602 my $logFile = $ce->{webworkFiles}->{logs}->{$facility}; 603 surePathToFile($ce->{webworkDirs}->{root}, $logFile); 604 local *LOG; 605 if (open LOG, ">>", $logFile) { 606 print LOG "[", time2str("%a %b %d %H:%M:%S %Y", time), "] @message\n"; 607 close LOG; 608 } else { 609 warn "failed to open $logFile for writing: $!"; 610 } 611 } 612 613 sub writeCourseLog($$@) { 614 my ($ce, $facility, @message) = @_; 615 unless ($ce->{courseFiles}->{logs}->{$facility}) { 616 warn "There is no course log file for the $facility facility defined.\n"; 617 return; 618 } 619 my $logFile = $ce->{courseFiles}->{logs}->{$facility}; 620 surePathToFile($ce->{courseDirs}->{root}, $logFile); 621 local *LOG; 622 if (open LOG, ">>", $logFile) { 623 print LOG "[", time2str("%a %b %d %H:%M:%S %Y", time), "] @message\n"; 624 close LOG; 625 } else { 626 warn "failed to open $logFile for writing: $!"; 627 } 628 } 629 630 # $ce - a WeBWork::CourseEnvironment object 631 # $function - fully qualified function name 632 # $details - any information, do not use the characters '[' or ']' 633 # $beginEnd - the string "begin", "intermediate", or "end" 634 # use the intermediate step begun or completed for INTERMEDIATE 635 # use an empty string for $details when calling for END 636 # Information printed in format: 637 # [formatted date & time ] processID unixTime BeginEnd $function $details 638 sub writeTimingLogEntry($$$$) { 639 my ($ce, $function, $details, $beginEnd) = @_; 640 $beginEnd = ($beginEnd eq "begin") ? ">" : ($beginEnd eq "end") ? "<" : "-"; 641 writeLog($ce, "timing", "$$ ".time." $beginEnd $function [$details]"); 642 } 643 644 ################################################################################ 645 # Data munging 646 ################################################################################ 647 648 sub list2hash(@) { 649 map {$_ => "0"} @_; 650 } 651 652 sub refBaseType($) { 653 my $ref = shift; 654 $ref =~ m/(\w+)\(/; # this might not be robust... 655 return $1; 656 } 657 658 sub ref2string($;$); 659 sub ref2string($;$) { 660 my $ref = shift; 661 my $dontExpand = shift || {}; 662 my $refType = ref $ref; 663 my $result; 664 if ($refType and not $dontExpand->{$refType}) { 665 my $baseType = refBaseType($ref); 666 $result .= '<font size="1" color="grey">' . $refType; 667 $result .= " ($baseType)" if $baseType and $refType ne $baseType; 668 $result .= ":</font><br>"; 669 $result .= '<table border="1" cellpadding="2">'; 670 if ($baseType eq "HASH") { 671 my %hash = %$ref; 672 foreach (sort keys %hash) { 673 $result .= '<tr valign="top">'; 674 $result .= "<td>$_</td>"; 675 $result .= "<td>" . ref2string($hash{$_}, $dontExpand) . "</td>"; 676 $result .= "</tr>"; 677 } 678 } elsif ($baseType eq "ARRAY") { 679 my @array = @$ref; 680 # special case for Problem, Set, and User objects, which are defined 681 # using lists and contain a @FIELDS package variable: 682 no strict 'refs'; 683 my @FIELDS = eval { @{$refType."::FIELDS"} }; 684 use strict 'refs'; 685 undef @FIELDS unless scalar @FIELDS == scalar @array and not $@; 686 foreach (0 .. $#array) { 687 $result .= '<tr valign="top">'; 688 $result .= "<td>$_</td>"; 689 $result .= "<td>".$FIELDS[$_]."</td>" if @FIELDS; 690 $result .= "<td>" . ref2string($array[$_], $dontExpand) . "</td>"; 691 $result .= "</tr>"; 692 } 693 } elsif ($baseType eq "SCALAR") { 694 my $scalar = $$ref; 695 $result .= '<tr valign="top">'; 696 $result .= "<td>$scalar</td>"; 697 $result .= "</tr>"; 698 } else { 699 # perhaps a coderef? in any case, i don't feel like dealing with it! 700 $result .= '<tr valign="top">'; 701 $result .= "<td>$ref</td>"; 702 $result .= "</tr>"; 703 } 704 $result .= "</table>" 705 } else { 706 $result .= defined $ref ? $ref : '<font color="red">undef</font>'; 707 } 708 } 709 our $BASE64_ENCODED = 'base64_encoded:'; 710 # use constant BASE64_ENCODED = 'base64_encoded; 711 # was not evaluated in the matching and substitution 712 # statements 713 sub decodeAnswers($) { 714 my $string = shift; 715 return unless defined $string and $string; 716 717 if ($string =~/^$BASE64_ENCODED/o) { 718 $string =~ s/^$BASE64_ENCODED//o; 719 $string = decode_base64($string); 720 } 721 722 my @array = split m/##/, $string; 723 $array[$_] =~ s/\\#\\/#/g foreach 0 .. $#array; 724 push @array, "" if @array%2; 725 return @array; # it's actually a hash ;) 726 } 727 728 sub encodeAnswers(\%\@) { 729 my %hash = %{ shift() }; 730 my @order = @{ shift() }; 731 my $string = ""; 732 foreach my $name (@order) { 733 my $value = defined $hash{$name} ? $hash{$name} : ""; 734 $name =~ s/#/\\#\\/g; # this is a WEIRD way to escape things 735 $value =~ s/#/\\#\\/g; # and it's not my fault! 736 if ($value =~ m/\\$/) { 737 # if the value ends with a backslash, string2hash will 738 # interpret that as a normal escape sequence (not part 739 # of the weird pound escape sequence) if the next 740 # character is &. So we have to protect against this. 741 # will adding a spcae at the end of the last answer 742 # hurt anything? i don't think so... 743 $value .= " "; 744 } 745 $string .= "$name##$value##"; # this is also not my fault 746 } 747 $string =~ s/##$//; # remove last pair of hashs 748 749 $string = $BASE64_ENCODED.encode_base64($string, ""); 750 # Empty string in second argument prevents end-of-line characters from being used. 751 # This is nice for examining database contents manually since it prevents newlines 752 # from being introduced into database records. 753 754 return $string; 755 } 756 757 sub max(@) { 758 my $soFar; 759 foreach my $item (@_) { 760 $soFar = $item unless defined $soFar; 761 if ($item > $soFar) { 762 $soFar = $item; 763 } 764 } 765 return defined $soFar ? $soFar : 0; 766 } 767 768 sub pretty_print_rh($) { 769 my $rh = shift; 770 foreach my $key (sort keys %{$rh}) { 771 warn " $key => ",$rh->{$key},"\n"; 772 } 773 } 774 775 sub cryptPassword($) { 776 my ($clearPassword) = @_; 777 my $salt = join("", ('.','/','0'..'9','A'..'Z','a'..'z')[rand 64, rand 64]); 778 my $cryptPassword = crypt($clearPassword, $salt); 779 return $cryptPassword; 780 } 781 782 # from the Perl Cookbook, first edition, page 25: 783 sub dequote($) { 784 local $_ = shift; 785 my ($white, $leader); # common whitespace and common leading string 786 if (/^\s*(?:([^\w\s]+)(\s*).*\n)(?:\s*\1\2?.*\n)+$/) { 787 ($white, $leader) = ($2, quotemeta($1)); 788 } else { 789 ($white, $leader) = (/^(\s+)/, ''); 790 } 791 s/^\s*?$leader(?:$white)?//gm; 792 return $_; 793 } 794 795 sub undefstr($@) { 796 map { defined $_ ? $_ : $_[0] } @_[1..$#_]; 797 } 798 799 # shuffle an array in place 800 # Perl Cookbook, Recipe 4.17. Randomizing an Array 801 sub fisher_yates_shuffle { 802 my $array = shift; 803 my $i; 804 for ($i = @$array; --$i; ) { 805 my $j = int rand ($i+1); 806 next if $i == $j; 807 @$array[$i,$j] = @$array[$j,$i]; 808 } 809 } 810 811 ################################################################################ 812 # Sorting 813 ################################################################################ 814 815 # p. 101, Camel, 3rd ed. 816 # The <=> and cmp operators return -1 if the left operand is less than the 817 # right operand, 0 if they are equal, and +1 if the left operand is greater 818 # than the right operand. 819 sub sortByName($@) { 820 my ($field, @items) = @_; 821 return sort { 822 my @aParts = split m/(?<=\D)(?=\d)|(?<=\d)(?=\D)/, defined $field ? $a->$field : $a; 823 my @bParts = split m/(?<=\D)(?=\d)|(?<=\d)(?=\D)/, defined $field ? $b->$field : $b; 824 while (@aParts and @bParts) { 825 my $aPart = shift @aParts; 826 my $bPart = shift @bParts; 827 my $aNumeric = $aPart =~ m/^\d*$/; 828 my $bNumeric = $bPart =~ m/^\d*$/; 829 830 # numbers should come before words 831 return -1 if $aNumeric and not $bNumeric; 832 return +1 if not $aNumeric and $bNumeric; 833 834 # both have the same type 835 if ($aNumeric and $bNumeric) { 836 next if $aPart == $bPart; # check next pair 837 return $aPart <=> $bPart; # compare numerically 838 } else { 839 next if $aPart eq $bPart; # check next pair 840 return $aPart cmp $bPart; # compare lexicographically 841 } 842 } 843 return +1 if @aParts; # a has more sections, should go second 844 return -1 if @bParts; # a had fewer sections, should go first 845 } @items; 846 } 847 848 1;
| aubreyja at gmail dot com | ViewVC Help |
| Powered by ViewVC 1.0.9 |