Parent Directory
| 
Revision Log
complete rewrite of parseDateTime to close bug #693. - using modified version of WW1's unformatDateAndTime() function for actual parsing. - intelligent treatment of two, three, and four digit years consistent with Time::Local. - attempt to interpret time zone specification using DateTime::TimeZone and then Time::Zone. if neither succeeds, an expection is thrown. - if timezone is not specified, $display_tz is actually used. It never ceases to amaze me how tricky time zone handling is. It appears that I have it right now, but please test.
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.54 2004/09/24 15:21:50 gage Exp $ 5 # 6 # This program is free software; you can redistribute it and/or modify it under 7 # the terms of either: (a) the GNU General Public License as published by the 8 # Free Software Foundation; either version 2, or (at your option) any later 9 # version, or (b) the "Artistic License" which comes with this package. 10 # 11 # This program is distributed in the hope that it will be useful, but WITHOUT 12 # ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS 13 # FOR A PARTICULAR PURPOSE. See either the GNU General Public License or the 14 # Artistic License for more details. 15 ################################################################################ 16 17 package WeBWorK::Utils; 18 use base qw(Exporter); 19 20 =head1 NAME 21 22 WeBWorK::Utils - useful utilities used by other WeBWorK modules. 23 24 =cut 25 26 use strict; 27 use warnings; 28 #use Apache::DB; 29 use DateTime; 30 use Date::Parse; 31 use Date::Format; 32 use Time::Zone; 33 #use Date::Manip; 34 #use DateTime::Format::DateManip; 35 use Errno; 36 use File::Path qw(rmtree); 37 use Carp; 38 39 use constant MKDIR_ATTEMPTS => 10; 40 41 # "standard" WeBWorK date/time format (for set definition files): 42 # %m/%d/%y at %I:%M%P 43 # where: 44 # %m = month number, starting with 01 45 # %d = numeric day of the month, with leading zeros (eg 01..31) 46 # %Y = year (4 digits) 47 # %I = hour, 12 hour clock, leading 0's) 48 # %M = minute, leading 0's 49 # %P = am or pm (Yes %p and %P are backwards :) 50 use constant DATE_FORMAT => "%m/%d/%Y at %I:%M%P %Z"; 51 52 our @EXPORT = (); 53 our @EXPORT_OK = qw( 54 runtime_use 55 readFile 56 readDirectory 57 listFilesRecursive 58 surePathToFile 59 makeTempDirectory 60 removeTempDirectory 61 formatDateTime 62 parseDateTime 63 textDateTime 64 intDateTime 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 sortByName 78 ); 79 80 ################################################################################ 81 # Lowlevel thingies 82 ################################################################################ 83 84 sub runtime_use($) { 85 croak "runtime_use: no module specified" unless $_[0]; 86 eval "package Main; require $_[0]; import $_[0]"; 87 die $@ if $@; 88 } 89 90 #sub backtrace($) { 91 # my ($style) = @_; 92 # $style = "warn" unless $style; 93 # my @bt = DB->backtrace; 94 # shift @bt; # Remove "backtrace" from the backtrace; 95 # if ($style eq "die") { 96 # die join "\n", @bt; 97 # } elsif ($style eq "warn") { 98 # warn join "\n", @bt; 99 # } elsif ($style eq "print") { 100 # print join "\n", @bt; 101 # } elsif ($style eq "return") { 102 # return @bt; 103 # } 104 #} 105 106 ################################################################################ 107 # Filesystem interaction 108 ################################################################################ 109 110 # Convert Windows and Mac (classic) line endings to UNIX line endings in a string. 111 # Windows uses CRLF, Mac uses CR, UNIX uses LF. (CR is ASCII 15, LF if ASCII 12) 112 sub force_eoln($) { 113 my ($string) = @_; 114 $string =~ s/\015\012?/\012/g; 115 return $string; 116 } 117 118 sub readFile($) { 119 my $fileName = shift; 120 local $/ = undef; # slurp the whole thing into one string 121 open my $dh, "<", $fileName 122 or die "failed to read file $fileName: $!"; 123 my $result = <$dh>; 124 close $dh; 125 return force_eoln($result); 126 } 127 128 sub readDirectory($) { 129 my $dirName = shift; 130 opendir my $dh, $dirName 131 or die "Failed to read directory $dirName: $!"; 132 my @result = readdir $dh; 133 close $dh; 134 return @result; 135 } 136 137 =item @matches = listFilesRecusive($dir, $match_qr, $prune_qr, $match_full, $prune_full) 138 139 Traverses the directory tree rooted at $dir, returning a list of files, named 140 pipes, and sockets matching the regular expression $match_qr. Directories 141 matching the regular expression $prune_qr are not visited. 142 143 $match_full and $prune_full are boolean values that indicate whether $match_qr 144 and $prune_qr, respectively, should be applied to the bare directory entry 145 (false) or to the path to the directory entry relative to $dir. 146 147 @matches is a list of paths relative to $dir. 148 149 =cut 150 151 sub listFilesRecursiveHelper($$$$$$); 152 sub listFilesRecursive($;$$$$) { 153 my ($dir, $match_qr, $prune_qr, $match_full, $prune_full) = @_; 154 return listFilesRecursiveHelper($dir, "", $match_qr, $prune_qr, $match_full, $prune_full); 155 } 156 157 sub listFilesRecursiveHelper($$$$$$) { 158 my ($base_dir, $curr_dir, $match_qr, $prune_qr, $match_full, $prune_full) = @_; 159 160 my $full_dir = "$base_dir/$curr_dir"; 161 162 my @dir_contents = readDirectory($full_dir); 163 164 my @matches; 165 166 foreach my $dir_entry (@dir_contents) { 167 my $full_path = "$full_dir/$dir_entry"; 168 if (-d $full_path or -l $full_path) { 169 # standard things to skip 170 next if $dir_entry eq "."; 171 next if $dir_entry eq ".."; 172 173 # skip unreadable directories (and broken symlinks, incidentally) 174 unless (-r $full_path) { 175 warn "Directory/symlink $full_path not readable"; 176 next; 177 } 178 179 # check $prune_qr 180 my $subdir = ($curr_dir eq "") ? $dir_entry : "$curr_dir/$dir_entry"; 181 if (defined $prune_qr) { 182 my $prune_string = $prune_full ? $subdir : $dir_entry; 183 next if $prune_string =~ m/$prune_qr/; 184 } 185 186 # everything looks good, time to recurse! 187 push @matches, listFilesRecursiveHelper($base_dir, $subdir, $match_qr, $prune_qr, $match_full, $prune_full); 188 } elsif (-f $full_path or -p $full_path or -S $full_path) { 189 my $file = ($curr_dir eq "") ? $dir_entry : "$curr_dir/$dir_entry"; 190 my $match_string = $match_full ? $file : $dir_entry; 191 if (not defined $match_string or $match_string =~ m/$match_qr/) { 192 push @matches, $file; 193 } 194 } 195 } 196 197 return @matches; 198 } 199 200 # A very useful macro for making sure that all of the directories to a file have 201 # been constructed. 202 sub surePathToFile($$) { 203 # constructs intermediate 204 # the input path must be the path relative to this starting directory 205 my $start_directory = shift; 206 my $path = shift; 207 my $delim = "/"; #&getDirDelim(); 208 unless ($start_directory and $path ) { 209 warn "missing directory<br> surePathToFile start_directory path "; 210 return ''; 211 } 212 # use the permissions/group on the start directory itself as a template 213 my ($perms, $groupID) = (stat $start_directory)[2,5]; 214 #warn "&urePathToTmpFile: perms=$perms groupID=$groupID\n"; 215 216 # if the path starts with $start_directory (which is permitted but optional) remove this initial segment 217 $path =~ s|^$start_directory|| if $path =~ m|^$start_directory|; 218 #$path = convertPath($path); 219 220 221 # find the nodes on the given path 222 my @nodes = split("$delim",$path); 223 224 # create new path 225 $path = $start_directory; #convertPath("$tmpDirectory"); 226 227 while (@nodes>1) { 228 $path = $path . shift (@nodes) . "/"; #convertPath($path . shift (@nodes) . "/"); 229 #FIXME this make directory command may not be fool proof. 230 unless (-e $path) { 231 mkdir($path, $perms) 232 or warn "Failed to create directory $path"; 233 } 234 235 } 236 237 $path = $path . shift(@nodes); #convertPath($path . shift(@nodes)); 238 return $path; 239 } 240 241 sub makeTempDirectory($$) { 242 my ($parent, $basename) = @_; 243 # Loop until we're able to create a directory, or it fails for some 244 # reason other than there already being something there. 245 my $triesRemaining = MKDIR_ATTEMPTS; 246 my ($fullPath, $success); 247 do { 248 my $suffix = join "", map { ('A'..'Z','a'..'z','0'..'9')[int rand 62] } 1 .. 8; 249 $fullPath = "$parent/$basename.$suffix"; 250 $success = mkdir $fullPath; 251 } until ($success or not $!{EEXIST}); 252 die "Failed to create directory $fullPath: $!" 253 unless $success; 254 return $fullPath; 255 } 256 257 sub removeTempDirectory($) { 258 my ($dir) = @_; 259 rmtree($dir, 0, 0); 260 } 261 262 ################################################################################ 263 # Date/time processing 264 ################################################################################ 265 266 =head2 Date/time processing 267 268 =over 269 270 =item $dateTime = parseDateTime($string, $display_tz) 271 272 Parses $string as a datetime. If $display_tz is given, $string is assumed to be 273 in that timezone. Otherwise, the server's timezone is used. The result, 274 $dateTime, is an integer UNIX datetime (epoch) in the server's timezone. 275 276 =cut 277 278 # This is a modified version of the subroutine of the same name from WeBWorK 279 # 1.9.05's scripts/FILE.pl (v1.13). It has been modified to understand time 280 # zones. The time zone specification must appear at the end of the string and be 281 # preceded by whitespace. The return value is a list consisting of the following 282 # elements: 283 # 284 # ($second, $minute, $hour, $day, $month, $year, $zone) 285 # 286 # $second, $minute, $hour, $day, and $month are zero-indexed. $year is the 287 # number of years since 1900. $zone is a string (hopefully) representing the 288 # time zone. 289 # 290 # Error handling has also been improved. Exceptions are now thrown for errors, 291 # and more information is given abou the nature of errors. 292 # 293 sub unformatDateAndTime { 294 my ($string) = @_; 295 my $orgString =$string; 296 $string =~ s|^\s+||; 297 $string =~ s|\s+$||; 298 $string =~ s|at| at |i; ## OK if forget to enter spaces or use wrong case 299 $string =~ s|AM| AM|i; ## OK if forget to enter spaces or use wrong case 300 $string =~ s|PM| PM|i; ## OK if forget to enter spaces or use wrong case 301 $string =~ s|,| at |; ## start translating old form of date/time to new form 302 303 my($date,$at,$time,$AMPM,$TZ) = split(/\s+/,$string); 304 unless ($time =~ /:/) { 305 { ##bare block for 'case" structure 306 $time =~ /(\d\d)(\d\d)/; 307 my $tmp_hour = $1; 308 my $tmp_min = $2; 309 if ($tmp_hour eq '00') {$time = "12:$tmp_min"; $AMPM = 'AM';last;} 310 if ($tmp_hour eq '12') {$time = "12:$tmp_min"; $AMPM = 'PM';last;} 311 if ($tmp_hour < 12) {$time = "$tmp_hour:$tmp_min"; $AMPM = 'AM';last;} 312 if ($tmp_hour < 24) { 313 $tmp_hour = $tmp_hour - 12; 314 $time = "$tmp_hour:$tmp_min"; 315 $AMPM = 'PM'; 316 } 317 } ##end of bare block for 'case" structure 318 319 } 320 321 my ($mday, $mon, $year, $wday, $yday,$sec, $pm, $min, $hour); 322 $sec=0; 323 $time =~ /^([0-9]+)\s*\:\s*([0-9]*)/; 324 $min=$2; 325 $hour = $1; 326 if ($hour < 1 or $hour > 12) { 327 die "Incorrect date/time format $orgString. Hour must be in the range [1,12]. Correct format is MM/DD/YYYY at HH:MM AMPM ZONE\n"; 328 } 329 if ($min < 0 or $min > 59) { 330 die "Incorrect date/time format $orgString. Minute must be in the range [0-59]. Correct format is MM/DD/YYYY at HH:MM AMPM ZONE\n"; 331 } 332 $pm = 0; 333 $pm = 12 if ($AMPM =~/PM/ and $hour < 12); 334 $hour += $pm; 335 $hour = 0 if ($AMPM =~/AM/ and $hour == 12); 336 $date =~ m!([0-9]+)\s*/\s*([0-9]+)/\s*([0-9]+)! ; 337 $mday =$2; 338 $mon=($1-1); 339 if ($mday < 1 or $mday > 31) { 340 die "Incorrect date/time format $orgString. Day must be in the range [1,31]. Correct format is MM/DD/YY at HH:MM AMPM ZONE\n"; 341 } 342 if ($mon < 0 or $mon > 11) { 343 die "Incorrect date/time format $orgString. Month must be in the range [1,12]. Correct format is MM/DD/YY at HH:MM AMPM ZONE\n"; 344 } 345 $year=$3; 346 $wday=""; 347 $yday=""; 348 return ($sec, $min, $hour, $mday, $mon, $year, $TZ); 349 } 350 351 352 sub parseDateTime($;$) { 353 my ($string, $display_tz) = @_; 354 $display_tz ||= "local"; 355 #warn "parseDateTime('$string', '$display_tz')\n"; 356 357 # use WeBWorK 1 date parsing routine 358 my ($second, $minute, $hour, $day, $month, $year, $zone) = unformatDateAndTime($string); 359 my $zone_str = defined $zone ? $zone : "UNDEF"; 360 #warn "\tunformatDateAndTime: $second $minute $hour $day $month $year $zone_str\n"; 361 362 # DateTime expects month 1-12, not 0-11 363 $month++; 364 365 # Do what Time::Local does to ambiguous years 366 { 367 my $ThisYear = (localtime())[5]; # FIXME: should be relative to $string's timezone 368 my $Breakpoint = ($ThisYear + 50) % 100; 369 my $NextCentury = $ThisYear - $ThisYear % 100; 370 $NextCentury += 100 if $Breakpoint < 50; 371 my $Century = $NextCentury - 100; 372 my $SecOff = 0; 373 374 if ($year >= 1000) { 375 # leave alone 376 } elsif ($year < 100 and $year >= 0) { 377 $year += ($year > $Breakpoint) ? $Century : $NextCentury; 378 $year += 1900; 379 } else { 380 $year += 1900; 381 } 382 } 383 384 my $epoch; 385 386 if (defined $zone and $zone ne "") { 387 if (DateTime::TimeZone->is_valid_name($zone)) { 388 #warn "\t\$zone is valid according to DateTime::TimeZone\n"; 389 390 my $dt = new DateTime( 391 year => $year, 392 month => $month, 393 day => $day, 394 hour => $hour, 395 minute => $minute, 396 second => $second, 397 time_zone => $zone, 398 ); 399 #warn "\t\$dt = ", $dt->strftime(DATE_FORMAT), "\n"; 400 401 $epoch = $dt->epoch; 402 #warn "\t\$dt->epoch = $epoch\n"; 403 } else { 404 #warn "\t\$zone is invalid according to DateTime::TimeZone, so we ask Time::Zone\n"; 405 406 # treat the date/time as UTC 407 my $dt = new DateTime( 408 year => $year, 409 month => $month, 410 day => $day, 411 hour => $hour, 412 minute => $minute, 413 second => $second, 414 time_zone => "UTC", 415 ); 416 #warn "\t\$dt = ", $dt->strftime(DATE_FORMAT), "\n"; 417 418 # convert to an epoch value 419 my $utc_epoch = $dt->epoch 420 or die "Date/time '$string' not representable as an epoch. Get more bits!\n"; 421 #warn "\t\$utc_epoch = $utc_epoch\n"; 422 423 # get offset for supplied timezone and utc_epoch 424 my $offset = tz_offset($zone, $utc_epoch) or die "Time zone '$zone' not recognized.\n"; 425 #warn "\t\$zone is valid according to Time::Zone (\$offset = $offset)\n"; 426 427 #$epoch = $utc_epoch + $offset; 428 ##warn "\t\$epoch = \$utc_epoch + \$offset = $epoch\n"; 429 430 $dt->subtract(seconds => $offset); 431 #warn "\t\$dt - \$offset = ", $dt->strftime(DATE_FORMAT), "\n"; 432 433 $epoch = $dt->epoch; 434 #warn "\t\$epoch = $epoch\n"; 435 } 436 } else { 437 #warn "\t\$zone not supplied, using \$display_tz\n"; 438 439 my $dt = new DateTime( 440 year => $year, 441 month => $month, 442 day => $day, 443 hour => $hour, 444 minute => $minute, 445 second => $second, 446 time_zone => $display_tz, 447 ); 448 #warn "\t\$dt = ", $dt->strftime(DATE_FORMAT), "\n"; 449 450 $epoch = $dt->epoch; 451 #warn "\t\$epoch = $epoch\n"; 452 } 453 454 return $epoch; 455 } 456 457 =item $string = formatDateTime($dateTime, $display_tz) 458 459 Formats the UNIX datetime $dateTime in the standard WeBWorK datetime format. 460 $dateTime is assumed to be in the server's time zone. If $display_tz is given, 461 the datetime is converted from the server's timezone to the timezone specified. 462 463 =cut 464 465 sub formatDateTime($;$) { 466 my ($dateTime, $display_tz) = @_; 467 $display_tz ||= "local"; 468 #warn "formatDateTime('$dateTime', '$display_tz')\n"; 469 470 my $dt = DateTime->from_epoch(epoch => $dateTime, time_zone => $display_tz); 471 #warn "\t\$dt = ", $dt->strftime(DATE_FORMAT), "\n"; 472 return $dt->strftime(DATE_FORMAT); 473 } 474 475 =item $string = textDateTime($string_or_dateTime) 476 477 Accepts a UNIX datetime or a formatted string, returns a formatted string. 478 479 =cut 480 481 sub textDateTime($) { 482 return ($_[0] =~ m/^\d*$/) ? formatDateTime($_[0]) : $_[0]; 483 } 484 485 =item $dateTIme = intDateTime($string_or_dateTime) 486 487 Accepts a UNIX datetime or a formatted string, returns a UNIX datetime. 488 489 =cut 490 491 sub intDateTime($) { 492 return ($_[0] =~ m/^\d*$/) ? $_[0] : parseDateTime($_[0]); 493 } 494 495 =back 496 497 =cut 498 499 ################################################################################ 500 # Logging 501 ################################################################################ 502 503 sub writeLog($$@) { 504 my ($ce, $facility, @message) = @_; 505 unless ($ce->{webworkFiles}->{logs}->{$facility}) { 506 warn "There is no log file for the $facility facility defined.\n"; 507 return; 508 } 509 my $logFile = $ce->{webworkFiles}->{logs}->{$facility}; 510 local *LOG; 511 if (open LOG, ">>", $logFile) { 512 print LOG "[", time2str("%a %b %d %H:%M:%S %Y", time), "] @message\n"; 513 close LOG; 514 } else { 515 warn "failed to open $logFile for writing: $!"; 516 } 517 } 518 519 sub writeCourseLog($$@) { 520 my ($ce, $facility, @message) = @_; 521 unless ($ce->{courseFiles}->{logs}->{$facility}) { 522 warn "There is no course log file for the $facility facility defined.\n"; 523 return; 524 } 525 my $logFile = $ce->{courseFiles}->{logs}->{$facility}; 526 local *LOG; 527 if (open LOG, ">>", $logFile) { 528 print LOG "[", time2str("%a %b %d %H:%M:%S %Y", time), "] @message\n"; 529 close LOG; 530 } else { 531 warn "failed to open $logFile for writing: $!"; 532 } 533 } 534 535 # $ce - a WeBWork::CourseEnvironment object 536 # $function - fully qualified function name 537 # $details - any information, do not use the characters '[' or ']' 538 # $beginEnd - the string "begin", "intermediate", or "end" 539 # use the intermediate step begun or completed for INTERMEDIATE 540 # use an empty string for $details when calling for END 541 sub writeTimingLogEntry($$$$) { 542 my ($ce, $function, $details, $beginEnd) = @_; 543 return unless defined $ce->{webworkFiles}->{logs}->{timing}; 544 $beginEnd = ($beginEnd eq "begin") ? ">" : ($beginEnd eq "end") ? "<" : "-"; 545 writeLog($ce, "timing", "$$ ".time." $beginEnd $function [$details]"); 546 } 547 548 ################################################################################ 549 # Data munging 550 ################################################################################ 551 552 sub list2hash(@) { 553 map {$_ => "0"} @_; 554 } 555 556 sub refBaseType($) { 557 my $ref = shift; 558 $ref =~ m/(\w+)\(/; # this might not be robust... 559 return $1; 560 } 561 562 sub ref2string($;$); 563 sub ref2string($;$) { 564 my $ref = shift; 565 my $dontExpand = shift || {}; 566 my $refType = ref $ref; 567 my $result; 568 if ($refType and not $dontExpand->{$refType}) { 569 my $baseType = refBaseType($ref); 570 $result .= '<font size="1" color="grey">' . $refType; 571 $result .= " ($baseType)" if $baseType and $refType ne $baseType; 572 $result .= ":</font><br>"; 573 $result .= '<table border="1" cellpadding="2">'; 574 if ($baseType eq "HASH") { 575 my %hash = %$ref; 576 foreach (sort keys %hash) { 577 $result .= '<tr valign="top">'; 578 $result .= "<td>$_</td>"; 579 $result .= "<td>" . ref2string($hash{$_}, $dontExpand) . "</td>"; 580 $result .= "</tr>"; 581 } 582 } elsif ($baseType eq "ARRAY") { 583 my @array = @$ref; 584 # special case for Problem, Set, and User objects, which are defined 585 # using lists and contain a @FIELDS package variable: 586 no strict 'refs'; 587 my @FIELDS = eval { @{$refType."::FIELDS"} }; 588 use strict 'refs'; 589 undef @FIELDS unless scalar @FIELDS == scalar @array and not $@; 590 foreach (0 .. $#array) { 591 $result .= '<tr valign="top">'; 592 $result .= "<td>$_</td>"; 593 $result .= "<td>".$FIELDS[$_]."</td>" if @FIELDS; 594 $result .= "<td>" . ref2string($array[$_], $dontExpand) . "</td>"; 595 $result .= "</tr>"; 596 } 597 } elsif ($baseType eq "SCALAR") { 598 my $scalar = $$ref; 599 $result .= '<tr valign="top">'; 600 $result .= "<td>$scalar</td>"; 601 $result .= "</tr>"; 602 } else { 603 # perhaps a coderef? in any case, i don't feel like dealing with it! 604 $result .= '<tr valign="top">'; 605 $result .= "<td>$ref</td>"; 606 $result .= "</tr>"; 607 } 608 $result .= "</table>" 609 } else { 610 $result .= defined $ref ? $ref : '<font color="red">undef</font>'; 611 } 612 } 613 614 sub decodeAnswers($) { 615 my $string = shift; 616 return unless defined $string and $string; 617 my @array = split m/##/, $string; 618 $array[$_] =~ s/\\#\\/#/g foreach 0 .. $#array; 619 push @array, "" if @array%2; 620 return @array; # it's actually a hash ;) 621 } 622 623 sub encodeAnswers(\%\@) { 624 my %hash = %{ shift() }; 625 my @order = @{ shift() }; 626 my $string = ""; 627 foreach my $name (@order) { 628 my $value = defined $hash{$name} ? $hash{$name} : ""; 629 $name =~ s/#/\\#\\/g; # this is a WEIRD way to escape things 630 $value =~ s/#/\\#\\/g; # and it's not my fault! 631 if ($value =~ m/\\$/) { 632 # if the value ends with a backslash, string2hash will 633 # interpret that as a normal escape sequence (not part 634 # of the weird pound escape sequence) if the next 635 # character is &. So we have to protect against this. 636 # will adding a spcae at the end of the last answer 637 # hurt anything? i don't think so... 638 $value .= " "; 639 } 640 $string .= "$name##$value##"; # this is also not my fault 641 } 642 $string =~ s/##$//; # remove last pair of hashs 643 return $string; 644 } 645 646 sub max(@) { 647 my $soFar; 648 foreach my $item (@_) { 649 $soFar = $item unless defined $soFar; 650 if ($item > $soFar) { 651 $soFar = $item; 652 } 653 } 654 return defined $soFar ? $soFar : 0; 655 } 656 657 sub pretty_print_rh($) { 658 my $rh = shift; 659 foreach my $key (sort keys %{$rh}) { 660 warn " $key => ",$rh->{$key},"\n"; 661 } 662 } 663 664 sub cryptPassword($) { 665 my ($clearPassword) = @_; 666 my $salt = join("", ('.','/','0'..'9','A'..'Z','a'..'z')[rand 64, rand 64]); 667 my $cryptPassword = crypt($clearPassword, $salt); 668 return $cryptPassword; 669 } 670 671 # from the Perl Cookbook, first edition, page 25: 672 sub dequote($) { 673 local $_ = shift; 674 my ($white, $leader); # common whitespace and common leading string 675 if (/^\s*(?:([^\w\s]+)(\s*).*\n)(?:\s*\1\2?.*\n)+$/) { 676 ($white, $leader) = ($2, quotemeta($1)); 677 } else { 678 ($white, $leader) = (/^(\s+)/, ''); 679 } 680 s/^\s*?$leader(?:$white)?//gm; 681 return $_; 682 } 683 684 sub undefstr($@) { 685 map { defined $_ ? $_ : $_[0] } @_[1..$#_]; 686 } 687 688 ################################################################################ 689 # Sorting 690 ################################################################################ 691 692 # p. 101, Camel, 3rd ed. 693 # The <=> and cmp operators return -1 if the left operand is less than the 694 # right operand, 0 if they are equal, and +1 if the left operand is greater 695 # than the right operand. 696 sub sortByName($@) { 697 my ($field, @items) = @_; 698 return sort { 699 my @aParts = split m/(?<=\D)(?=\d)|(?<=\d)(?=\D)/, defined $field ? $a->$field : $a; 700 my @bParts = split m/(?<=\D)(?=\d)|(?<=\d)(?=\D)/, defined $field ? $b->$field : $b; 701 while (@aParts and @bParts) { 702 my $aPart = shift @aParts; 703 my $bPart = shift @bParts; 704 my $aNumeric = $aPart =~ m/^\d*$/; 705 my $bNumeric = $bPart =~ m/^\d*$/; 706 707 # numbers should come before words 708 return -1 if $aNumeric and not $bNumeric; 709 return +1 if not $aNumeric and $bNumeric; 710 711 # both have the same type 712 if ($aNumeric and $bNumeric) { 713 next if $aPart == $bPart; # check next pair 714 return $aPart <=> $bPart; # compare numerically 715 } else { 716 next if $aPart eq $bPart; # check next pair 717 return $aPart cmp $bPart; # compare lexicographically 718 } 719 } 720 return +1 if @aParts; # a has more sections, should go second 721 return -1 if @bParts; # a had fewer sections, should go first 722 } @items; 723 } 724 725 1;
| aubreyja at gmail dot com | ViewVC Help |
| Powered by ViewVC 1.0.9 |