Parent Directory
| 
Revision Log
Matching full path was not working (the match was being made against only the file name regardless of the match flag).
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.52 2004/09/14 22:10:14 sh002i Exp $ 5 # 6 # This program is free software; you can redistribute it and/or modify it under 7 # the terms of either: (a) the GNU General Public License as published by the 8 # Free Software Foundation; either version 2, or (at your option) any later 9 # version, or (b) the "Artistic License" which comes with this package. 10 # 11 # This program is distributed in the hope that it will be useful, but WITHOUT 12 # ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS 13 # FOR A PARTICULAR PURPOSE. See either the GNU General Public License or the 14 # Artistic License for more details. 15 ################################################################################ 16 17 package WeBWorK::Utils; 18 use base qw(Exporter); 19 20 =head1 NAME 21 22 WeBWorK::Utils - useful utilities used by other WeBWorK modules. 23 24 =cut 25 26 use strict; 27 use warnings; 28 #use Apache::DB; 29 use DateTime; 30 use Date::Parse; 31 use Date::Format; 32 #use Date::Manip; 33 #use DateTime::Format::DateManip; 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 (2 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"; 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 writeLog 65 writeCourseLog 66 writeTimingLogEntry 67 list2hash 68 ref2string 69 decodeAnswers 70 encodeAnswers 71 max 72 pretty_print_rh 73 cryptPassword 74 dequote 75 undefstr 76 sortByName 77 ); 78 79 ################################################################################ 80 # Lowlevel thingies 81 ################################################################################ 82 83 sub runtime_use($) { 84 croak "runtime_use: no module specified" unless $_[0]; 85 eval "package Main; require $_[0]; import $_[0]"; 86 die $@ if $@; 87 } 88 89 #sub backtrace($) { 90 # my ($style) = @_; 91 # $style = "warn" unless $style; 92 # my @bt = DB->backtrace; 93 # shift @bt; # Remove "backtrace" from the backtrace; 94 # if ($style eq "die") { 95 # die join "\n", @bt; 96 # } elsif ($style eq "warn") { 97 # warn join "\n", @bt; 98 # } elsif ($style eq "print") { 99 # print join "\n", @bt; 100 # } elsif ($style eq "return") { 101 # return @bt; 102 # } 103 #} 104 105 ################################################################################ 106 # Filesystem interaction 107 ################################################################################ 108 109 # Convert Windows and Mac (classic) line endings to UNIX line endings in a string. 110 # Windows uses CRLF, Mac uses CR, UNIX uses LF. (CR is ASCII 15, LF if ASCII 12) 111 sub force_eoln($) { 112 my ($string) = @_; 113 $string =~ s/\015\012?/\012/g; 114 return $string; 115 } 116 117 sub readFile($) { 118 my $fileName = shift; 119 local $/ = undef; # slurp the whole thing into one string 120 open my $dh, "<", $fileName 121 or die "failed to read file $fileName: $!"; 122 my $result = <$dh>; 123 close $dh; 124 return force_eoln($result); 125 } 126 127 sub readDirectory($) { 128 my $dirName = shift; 129 opendir my $dh, $dirName 130 or die "Failed to read directory $dirName: $!"; 131 my @result = readdir $dh; 132 close $dh; 133 return @result; 134 } 135 136 =item @matches = listFilesRecusive($dir, $match_qr, $prune_qr, $match_full, $prune_full) 137 138 Traverses the directory tree rooted at $dir, returning a list of files, named 139 pipes, and sockets matching the regular expression $match_qr. Directories 140 matching the regular expression $prune_qr are not visited. 141 142 $match_full and $prune_full are boolean values that indicate whether $match_qr 143 and $prune_qr, respectively, should be applied to the bare directory entry 144 (false) or to the path to the directory entry relative to $dir. 145 146 @matches is a list of paths relative to $dir. 147 148 =cut 149 150 sub listFilesRecursiveHelper($$$$$$); 151 sub listFilesRecursive($;$$$$) { 152 my ($dir, $match_qr, $prune_qr, $match_full, $prune_full) = @_; 153 return listFilesRecursiveHelper($dir, "", $match_qr, $prune_qr, $match_full, $prune_full); 154 } 155 156 sub listFilesRecursiveHelper($$$$$$) { 157 my ($base_dir, $curr_dir, $match_qr, $prune_qr, $match_full, $prune_full) = @_; 158 159 my $full_dir = "$base_dir/$curr_dir"; 160 161 my @dir_contents = readDirectory($full_dir); 162 163 my @matches; 164 165 foreach my $dir_entry (@dir_contents) { 166 my $full_path = "$full_dir/$dir_entry"; 167 if (-d $full_path or -l $full_path) { 168 # standard things to skip 169 next if $dir_entry eq "."; 170 next if $dir_entry eq ".."; 171 172 # skip unreadable directories (and broken symlinks, incidentally) 173 unless (-r $full_path) { 174 warn "Directory/symlink $full_path not readable"; 175 next; 176 } 177 178 # check $prune_qr 179 my $subdir = ($curr_dir eq "") ? $dir_entry : "$curr_dir/$dir_entry"; 180 if (defined $prune_qr) { 181 my $prune_string = $prune_full ? $subdir : $dir_entry; 182 next if $prune_string =~ m/$prune_qr/; 183 } 184 185 # everything looks good, time to recurse! 186 push @matches, listFilesRecursiveHelper($base_dir, $subdir, $match_qr, $prune_qr, $match_full, $prune_full); 187 } elsif (-f $full_path or -p $full_path or -S $full_path) { 188 my $file = ($curr_dir eq "") ? $dir_entry : "$curr_dir/$dir_entry"; 189 my $match_string = $match_full ? $file : $dir_entry; 190 if (not defined $match_string or $match_string =~ m/$match_qr/) { 191 push @matches, $file; 192 } 193 } 194 } 195 196 return @matches; 197 } 198 199 # A very useful macro for making sure that all of the directories to a file have 200 # been constructed. 201 sub surePathToFile($$) { 202 # constructs intermediate 203 # the input path must be the path relative to this starting directory 204 my $start_directory = shift; 205 my $path = shift; 206 my $delim = "/"; #&getDirDelim(); 207 unless ($start_directory and $path ) { 208 warn "missing directory<br> surePathToFile start_directory path "; 209 return ''; 210 } 211 # use the permissions/group on the start directory itself as a template 212 my ($perms, $groupID) = (stat $start_directory)[2,5]; 213 #warn "&urePathToTmpFile: perms=$perms groupID=$groupID\n"; 214 215 # if the path starts with $start_directory (which is permitted but optional) remove this initial segment 216 $path =~ s|^$start_directory|| if $path =~ m|^$start_directory|; 217 #$path = convertPath($path); 218 219 220 # find the nodes on the given path 221 my @nodes = split("$delim",$path); 222 223 # create new path 224 $path = $start_directory; #convertPath("$tmpDirectory"); 225 226 while (@nodes>1) { 227 $path = $path . shift (@nodes) . "/"; #convertPath($path . shift (@nodes) . "/"); 228 #FIXME this make directory command may not be fool proof. 229 unless (-e $path) { 230 mkdir($path, $perms) 231 or warn "Failed to create directory $path"; 232 } 233 234 } 235 236 $path = $path . shift(@nodes); #convertPath($path . shift(@nodes)); 237 return $path; 238 } 239 240 sub makeTempDirectory($$) { 241 my ($parent, $basename) = @_; 242 # Loop until we're able to create a directory, or it fails for some 243 # reason other than there already being something there. 244 my $triesRemaining = MKDIR_ATTEMPTS; 245 my ($fullPath, $success); 246 do { 247 my $suffix = join "", map { ('A'..'Z','a'..'z','0'..'9')[int rand 62] } 1 .. 8; 248 $fullPath = "$parent/$basename.$suffix"; 249 $success = mkdir $fullPath; 250 } until ($success or not $!{EEXIST}); 251 die "Failed to create directory $fullPath: $!" 252 unless $success; 253 return $fullPath; 254 } 255 256 sub removeTempDirectory($) { 257 my ($dir) = @_; 258 rmtree($dir, 0, 0); 259 } 260 261 ################################################################################ 262 # Date/time processing 263 ################################################################################ 264 265 =head2 Date/time processing 266 267 =over 268 269 =item $dateTime = parseDateTime($string, $display_tz) 270 271 Parses $string as a datetime. If $display_tz is given, $string is assumed to be 272 in that timezone. Otherwise, the server's timezone is used. The result, 273 $dateTime, is an integer UNIX datetime (epoch) in the server's timezone. 274 275 =cut 276 277 sub parseDateTime($;$) { 278 my ($string, $display_tz) = @_; 279 $display_tz ||= "local"; 280 #warn "parseDateTime('$string', '$display_tz')\n"; 281 282 # Method #1: using Date::Parse (uncomment "use Date::Parse" above) 283 $string =~ s/\s*\bat\b\s*/ /; # Date::Parse can't handle the "at" in WeBWorK datetimes. 284 my $epoch = str2time($string); 285 #warn "\tMethod #1: str2time($string) = $epoch\n"; 286 my $dt = DateTime->from_epoch(epoch => $epoch, time_zone => "local"); 287 #warn "\tMethod #1: \$dt = ", $dt->strftime(DATE_FORMAT." %Z"), "\n"; 288 289 # Method #2: using Date::Manip (uncomment "use Date::Manip" and "use 290 # DateTime::Format::DateManip" above) 291 #my $dm = ParseDateString($string); 292 #warn "\tMethod #2: ParseDateString($string) = $dm\n"; 293 #my $dt = DateTime::Format::DateManip->parse_datetime($dm); 294 #warn "\tdMethod #2: \$dt = ", $dt->strftime(DATE_FORMAT." %Z"), "\n"; 295 296 my $dt2 = $dt->clone->set_time_zone("floating")->set_time_zone($display_tz); 297 #warn "\t\$dt2 = ", $dt2->strftime(DATE_FORMAT." %Z"), "\n"; 298 my $epoch2 = $dt2->epoch; 299 #warn "\t\$epoch2 (return value) = $epoch2\n"; 300 301 return $epoch2; 302 } 303 304 =item $string = formatDateTime($dateTime, $display_tz) 305 306 Formats the UNIX datetime $dateTime in the standard WeBWorK datetime format. 307 $dateTime is assumed to be in the server's time zone. If $display_tz is given, 308 the datetime is converted from the server's timezone to the timezone specified. 309 310 =cut 311 312 sub formatDateTime($;$) { 313 my ($dateTime, $display_tz) = @_; 314 $display_tz ||= "local"; 315 #warn "formatDateTime('$dateTime', '$display_tz')\n"; 316 317 my $dt = DateTime->from_epoch(epoch => $dateTime, time_zone => $display_tz); 318 #warn "\t\$dt = ", $dt->strftime(DATE_FORMAT." %Z"), "\n"; 319 return $dt->strftime(DATE_FORMAT); 320 } 321 322 =item $string = textDateTime($string_or_dateTime) 323 324 Accepts a UNIX datetime or a formatted string, returns a formatted string. 325 326 =cut 327 328 sub textDateTime($) { 329 return ($_[0] =~ m/^\d*$/) ? formatDateTime($_[0]) : $_[0]; 330 } 331 332 =item $dateTIme = intDateTime($string_or_dateTime) 333 334 Accepts a UNIX datetime or a formatted string, returns a UNIX datetime. 335 336 =cut 337 338 sub intDateTime($) { 339 return ($_[0] =~ m/^\d*$/) ? $_[0] : parseDateTime($_[0]); 340 } 341 342 =back 343 344 =cut 345 346 ################################################################################ 347 # Logging 348 ################################################################################ 349 350 sub writeLog($$@) { 351 my ($ce, $facility, @message) = @_; 352 unless ($ce->{webworkFiles}->{logs}->{$facility}) { 353 warn "There is no log file for the $facility facility defined.\n"; 354 return; 355 } 356 my $logFile = $ce->{webworkFiles}->{logs}->{$facility}; 357 local *LOG; 358 if (open LOG, ">>", $logFile) { 359 print LOG "[", time2str("%a %b %d %H:%M:%S %Y", time), "] @message\n"; 360 close LOG; 361 } else { 362 warn "failed to open $logFile for writing: $!"; 363 } 364 } 365 366 sub writeCourseLog($$@) { 367 my ($ce, $facility, @message) = @_; 368 unless ($ce->{courseFiles}->{logs}->{$facility}) { 369 warn "There is no course log file for the $facility facility defined.\n"; 370 return; 371 } 372 my $logFile = $ce->{courseFiles}->{logs}->{$facility}; 373 local *LOG; 374 if (open LOG, ">>", $logFile) { 375 print LOG "[", time2str("%a %b %d %H:%M:%S %Y", time), "] @message\n"; 376 close LOG; 377 } else { 378 warn "failed to open $logFile for writing: $!"; 379 } 380 } 381 382 # $ce - a WeBWork::CourseEnvironment object 383 # $function - fully qualified function name 384 # $details - any information, do not use the characters '[' or ']' 385 # $beginEnd - the string "begin", "intermediate", or "end" 386 # use the intermediate step begun or completed for INTERMEDIATE 387 # use an empty string for $details when calling for END 388 sub writeTimingLogEntry($$$$) { 389 my ($ce, $function, $details, $beginEnd) = @_; 390 return unless defined $ce->{webworkFiles}->{logs}->{timing}; 391 $beginEnd = ($beginEnd eq "begin") ? ">" : ($beginEnd eq "end") ? "<" : "-"; 392 writeLog($ce, "timing", "$$ ".time." $beginEnd $function [$details]"); 393 } 394 395 ################################################################################ 396 # Data munging 397 ################################################################################ 398 399 sub list2hash(@) { 400 map {$_ => "0"} @_; 401 } 402 403 sub refBaseType($) { 404 my $ref = shift; 405 $ref =~ m/(\w+)\(/; # this might not be robust... 406 return $1; 407 } 408 409 sub ref2string($;$); 410 sub ref2string($;$) { 411 my $ref = shift; 412 my $dontExpand = shift || {}; 413 my $refType = ref $ref; 414 my $result; 415 if ($refType and not $dontExpand->{$refType}) { 416 my $baseType = refBaseType($ref); 417 $result .= '<font size="1" color="grey">' . $refType; 418 $result .= " ($baseType)" if $baseType and $refType ne $baseType; 419 $result .= ":</font><br>"; 420 $result .= '<table border="1" cellpadding="2">'; 421 if ($baseType eq "HASH") { 422 my %hash = %$ref; 423 foreach (sort keys %hash) { 424 $result .= '<tr valign="top">'; 425 $result .= "<td>$_</td>"; 426 $result .= "<td>" . ref2string($hash{$_}, $dontExpand) . "</td>"; 427 $result .= "</tr>"; 428 } 429 } elsif ($baseType eq "ARRAY") { 430 my @array = @$ref; 431 # special case for Problem, Set, and User objects, which are defined 432 # using lists and contain a @FIELDS package variable: 433 no strict 'refs'; 434 my @FIELDS = eval { @{$refType."::FIELDS"} }; 435 use strict 'refs'; 436 undef @FIELDS unless scalar @FIELDS == scalar @array and not $@; 437 foreach (0 .. $#array) { 438 $result .= '<tr valign="top">'; 439 $result .= "<td>$_</td>"; 440 $result .= "<td>".$FIELDS[$_]."</td>" if @FIELDS; 441 $result .= "<td>" . ref2string($array[$_], $dontExpand) . "</td>"; 442 $result .= "</tr>"; 443 } 444 } elsif ($baseType eq "SCALAR") { 445 my $scalar = $$ref; 446 $result .= '<tr valign="top">'; 447 $result .= "<td>$scalar</td>"; 448 $result .= "</tr>"; 449 } else { 450 # perhaps a coderef? in any case, i don't feel like dealing with it! 451 $result .= '<tr valign="top">'; 452 $result .= "<td>$ref</td>"; 453 $result .= "</tr>"; 454 } 455 $result .= "</table>" 456 } else { 457 $result .= defined $ref ? $ref : '<font color="red">undef</font>'; 458 } 459 } 460 461 sub decodeAnswers($) { 462 my $string = shift; 463 return unless defined $string and $string; 464 my @array = split m/##/, $string; 465 $array[$_] =~ s/\\#\\/#/g foreach 0 .. $#array; 466 push @array, "" if @array%2; 467 return @array; # it's actually a hash ;) 468 } 469 470 sub encodeAnswers(\%\@) { 471 my %hash = %{ shift() }; 472 my @order = @{ shift() }; 473 my $string = ""; 474 foreach my $name (@order) { 475 my $value = defined $hash{$name} ? $hash{$name} : ""; 476 $name =~ s/#/\\#\\/g; # this is a WEIRD way to escape things 477 $value =~ s/#/\\#\\/g; # and it's not my fault! 478 if ($value =~ m/\\$/) { 479 # if the value ends with a backslash, string2hash will 480 # interpret that as a normal escape sequence (not part 481 # of the weird pound escape sequence) if the next 482 # character is &. So we have to protect against this. 483 # will adding a spcae at the end of the last answer 484 # hurt anything? i don't think so... 485 $value .= " "; 486 } 487 $string .= "$name##$value##"; # this is also not my fault 488 } 489 $string =~ s/##$//; # remove last pair of hashs 490 return $string; 491 } 492 493 sub max(@) { 494 my $soFar; 495 foreach my $item (@_) { 496 $soFar = $item unless defined $soFar; 497 if ($item > $soFar) { 498 $soFar = $item; 499 } 500 } 501 return defined $soFar ? $soFar : 0; 502 } 503 504 sub pretty_print_rh($) { 505 my $rh = shift; 506 foreach my $key (sort keys %{$rh}) { 507 warn " $key => ",$rh->{$key},"\n"; 508 } 509 } 510 511 sub cryptPassword($) { 512 my ($clearPassword) = @_; 513 my $salt = join("", ('.','/','0'..'9','A'..'Z','a'..'z')[rand 64, rand 64]); 514 my $cryptPassword = crypt($clearPassword, $salt); 515 return $cryptPassword; 516 } 517 518 # from the Perl Cookbook, first edition, page 25: 519 sub dequote($) { 520 local $_ = shift; 521 my ($white, $leader); # common whitespace and common leading string 522 if (/^\s*(?:([^\w\s]+)(\s*).*\n)(?:\s*\1\2?.*\n)+$/) { 523 ($white, $leader) = ($2, quotemeta($1)); 524 } else { 525 ($white, $leader) = (/^(\s+)/, ''); 526 } 527 s/^\s*?$leader(?:$white)?//gm; 528 return $_; 529 } 530 531 sub undefstr($@) { 532 map { defined $_ ? $_ : $_[0] } @_[1..$#_]; 533 } 534 535 ################################################################################ 536 # Sorting 537 ################################################################################ 538 539 # p. 101, Camel, 3rd ed. 540 # The <=> and cmp operators return -1 if the left operand is less than the 541 # right operand, 0 if they are equal, and +1 if the left operand is greater 542 # than the right operand. 543 sub sortByName($@) { 544 my ($field, @items) = @_; 545 return sort { 546 my @aParts = split m/(?<=\D)(?=\d)|(?<=\d)(?=\D)/, defined $field ? $a->$field : $a; 547 my @bParts = split m/(?<=\D)(?=\d)|(?<=\d)(?=\D)/, defined $field ? $b->$field : $b; 548 while (@aParts and @bParts) { 549 my $aPart = shift @aParts; 550 my $bPart = shift @bParts; 551 my $aNumeric = $aPart =~ m/^\d*$/; 552 my $bNumeric = $bPart =~ m/^\d*$/; 553 554 # numbers should come before words 555 return -1 if $aNumeric and not $bNumeric; 556 return +1 if not $aNumeric and $bNumeric; 557 558 # both have the same type 559 if ($aNumeric and $bNumeric) { 560 next if $aPart == $bPart; # check next pair 561 return $aPart <=> $bPart; # compare numerically 562 } else { 563 next if $aPart eq $bPart; # check next pair 564 return $aPart cmp $bPart; # compare lexicographically 565 } 566 } 567 return +1 if @aParts; # a has more sections, should go second 568 return -1 if @bParts; # a had fewer sections, should go first 569 } @items; 570 } 571 572 1;
| aubreyja at gmail dot com | ViewVC Help |
| Powered by ViewVC 1.0.9 |