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