Parent Directory
| 
Revision Log
added listFilesRecursive() subroutine, some housekeeping.
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.47 2004/09/08 01:42:05 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 Date::Format; 30 use Date::Parse; 31 use Errno; 32 use File::Path qw(rmtree); 33 use Carp; 34 35 use constant MKDIR_ATTEMPTS => 10; 36 37 our @EXPORT = (); 38 our @EXPORT_OK = qw( 39 runtime_use 40 readFile 41 readDirectory 42 listFilesRecursive 43 formatDateTime 44 parseDateTime 45 textDateTime 46 intDateTime 47 writeLog 48 writeCourseLog 49 writeTimingLogEntry 50 list2hash 51 max 52 dbDecode 53 dbEncode 54 decodeAnswers 55 encodeAnswers 56 ref2string 57 sortByName 58 makeTempDirectory 59 removeTempDirectory 60 pretty_print_rh 61 surePathToFile 62 cryptPassword 63 dequote 64 undefstr 65 ); 66 67 sub runtime_use { 68 croak "runtime_use: no module specified" unless $_[0]; 69 eval "package Main; require $_[0]; import $_[0]"; 70 die $@ if $@; 71 } 72 73 #sub backtrace { 74 # my ($style) = @_; 75 # $style = "warn" unless $style; 76 # my @bt = DB->backtrace; 77 # shift @bt; # Remove "backtrace" from the backtrace; 78 # if ($style eq "die") { 79 # die join "\n", @bt; 80 # } elsif ($style eq "warn") { 81 # warn join "\n", @bt; 82 # } elsif ($style eq "print") { 83 # print join "\n", @bt; 84 # } elsif ($style eq "return") { 85 # return @bt; 86 # } 87 #} 88 89 # Convert Windows and Mac (classic) line endings to UNIX line endings in a string. 90 # Windows uses CRLF, Mac uses CR, UNIX uses LF. (CR is ASCII 15, LF if ASCII 12) 91 sub force_eoln($) { 92 my ($string) = @_; 93 $string =~ s/\015\012?/\012/g; 94 return $string; 95 } 96 97 sub readFile($) { 98 my $fileName = shift; 99 local $/ = undef; # slurp the whole thing into one string 100 open my $dh, "<", $fileName 101 or die "failed to read file $fileName: $!"; 102 my $result = <$dh>; 103 close $dh; 104 return force_eoln($result); 105 } 106 107 sub readDirectory($) { 108 my $dirName = shift; 109 opendir my $dh, $dirName 110 or die "Failed to read directory $dirName: $!"; 111 my @result = readdir $dh; 112 close $dh; 113 return @result; 114 } 115 116 =item @matches = listFilesRecusive($dir, $match_qr, $prune_qr, $match_full, $prune_full) 117 118 Traverses the directory tree rooted at $dir, returning a list of files, named 119 pipes, and sockets matching the regular expression $match_qr. Directories 120 matching the regular expression $prune_qr are not visited. 121 122 $match_full and $prune_full are boolean values that indicate whether $match_qr 123 and $prune_qr, respectively, should be applied to the bare directory entry 124 (false) or to the path to the directory entry relative to $dir. 125 126 @matches is a list of paths relative to $dir. 127 128 =cut 129 130 sub listFilesRecursiveHelper($$$$$$); 131 sub listFilesRecursive($;$$$$) { 132 my ($dir, $match_qr, $prune_qr, $match_full, $prune_full) = @_; 133 return listFilesRecursiveHelper($dir, "", $match_qr, $prune_qr, $match_full, $prune_full); 134 } 135 136 sub listFilesRecursiveHelper($$$$$$) { 137 my ($base_dir, $curr_dir, $match_qr, $prune_qr, $match_full, $prune_full) = @_; 138 139 my $full_dir = "$base_dir/$curr_dir"; 140 141 my @dir_contents = readDirectory($full_dir); 142 143 my @matches; 144 145 foreach my $dir_entry (@dir_contents) { 146 my $full_path = "$full_dir/$dir_entry"; 147 if (-d $full_path or -l $full_path) { 148 # standard things to skip 149 next if $dir_entry eq "."; 150 next if $dir_entry eq ".."; 151 152 # skip unreadable directories (and broken symlinks, incidentally) 153 unless (-r $full_path) { 154 warn "Directory/symlink $full_path not readable"; 155 next; 156 } 157 158 # check $prune_qr 159 my $subdir = ($curr_dir eq "") ? $dir_entry : "$curr_dir/$dir_entry"; 160 if (defined $prune_qr) { 161 my $prune_string = $prune_full ? $subdir : $dir_entry; 162 next if $prune_string =~ m/$prune_qr/; 163 } 164 165 # everything looks good, time to recurse! 166 push @matches, listFilesRecursiveHelper($base_dir, $subdir, $match_qr, $prune_qr, $match_full, $prune_full); 167 } elsif (-f $full_path or -p $full_path or -S $full_path) { 168 my $file = ($curr_dir eq "") ? $dir_entry : "$curr_dir/$dir_entry"; 169 my $match_string = $match_full ? $file : $dir_entry; 170 if (not defined $match_string or $dir_entry =~ m/$match_qr/) { 171 push @matches, $file; 172 } 173 } 174 } 175 176 return @matches; 177 } 178 179 sub formatDateTime($) { 180 my $dateTime = shift; 181 # "standard" WeBWorK date/time format (for set definition files): 182 # %m month number, starting with 01 183 # %d numeric day of the month, with leading zeros (eg 01..31) 184 # %y year (2 digits) 185 # %I hour, 12 hour clock, leading 0's) 186 # %M minute, leading 0's 187 # %P am or pm (Yes %p and %P are backwards :) 188 #return time2str("%m/%d/%y %I:%M%P", $dateTime); 189 return time2str("%m/%d/%y at %I:%M%P", $dateTime); 190 } 191 192 sub parseDateTime($) { 193 my $string = shift; 194 # need to bring our string from "%m/%d/%y at %I:%M%P" to "%m/%d/%y %I:%M%P" format. 195 $string =~ s/\bat\b/ /; 196 return str2time($string); 197 } 198 199 sub textDateTime($) { 200 return ($_[0] =~ m/^\d*$/) ? formatDateTime($_[0]) : $_[0]; 201 } 202 203 sub intDateTime($) { 204 return ($_[0] =~ m/^\d*$/) ? $_[0] : parseDateTime($_[0]); 205 } 206 207 sub writeLog($$@) { 208 my ($ce, $facility, @message) = @_; 209 unless ($ce->{webworkFiles}->{logs}->{$facility}) { 210 warn "There is no log file for the $facility facility defined.\n"; 211 return; 212 } 213 my $logFile = $ce->{webworkFiles}->{logs}->{$facility}; 214 local *LOG; 215 if (open LOG, ">>", $logFile) { 216 print LOG "[", time2str("%a %b %d %H:%M:%S %Y", time), "] @message\n"; 217 close LOG; 218 } else { 219 warn "failed to open $logFile for writing: $!"; 220 } 221 } 222 223 sub writeCourseLog($$@) { 224 my ($ce, $facility, @message) = @_; 225 unless ($ce->{courseFiles}->{logs}->{$facility}) { 226 warn "There is no course log file for the $facility facility defined.\n"; 227 return; 228 } 229 my $logFile = $ce->{courseFiles}->{logs}->{$facility}; 230 local *LOG; 231 if (open LOG, ">>", $logFile) { 232 print LOG "[", time2str("%a %b %d %H:%M:%S %Y", time), "] @message\n"; 233 close LOG; 234 } else { 235 warn "failed to open $logFile for writing: $!"; 236 } 237 } 238 239 # A very useful macro for making sure that all of the directories to a file have been constructed. 240 241 sub surePathToFile { 242 # constructs intermediate 243 # the input path must be the path relative to this starting directory 244 my $start_directory = shift; 245 my $path = shift; 246 my $delim = "/"; #&getDirDelim(); 247 unless ($start_directory and $path ) { 248 warn "missing directory<br> surePathToFile start_directory path "; 249 return ''; 250 } 251 # use the permissions/group on the start directory itself as a template 252 my ($perms, $groupID) = (stat $start_directory)[2,5]; 253 #warn "&urePathToTmpFile: perms=$perms groupID=$groupID\n"; 254 255 # if the path starts with $start_directory (which is permitted but optional) remove this initial segment 256 $path =~ s|^$start_directory|| if $path =~ m|^$start_directory|; 257 #$path = convertPath($path); 258 259 260 # find the nodes on the given path 261 my @nodes = split("$delim",$path); 262 263 # create new path 264 $path = $start_directory; #convertPath("$tmpDirectory"); 265 266 while (@nodes>1) { 267 $path = $path . shift (@nodes) . "/"; #convertPath($path . shift (@nodes) . "/"); 268 #FIXME this make directory command may not be fool proof. 269 unless (-e $path) { 270 mkdir($path, $perms) 271 or warn "Failed to create directory $path"; 272 } 273 274 } 275 276 $path = $path . shift(@nodes); #convertPath($path . shift(@nodes)); 277 return $path; 278 } 279 280 # $ce - a WeBWork::CourseEnvironment object 281 # $function - fully qualified function name 282 # $details - any information, do not use the characters '[' or ']' 283 # $beginEnd - the string "begin", "intermediate", or "end" 284 # use the intermediate step begun or completed for INTERMEDIATE 285 # use an empty string for $details when calling for END 286 sub writeTimingLogEntry($$$$) { 287 my ($ce, $function, $details, $beginEnd) = @_; 288 return unless defined $ce->{webworkFiles}->{logs}->{timing}; 289 $beginEnd = ($beginEnd eq "begin") ? ">" : ($beginEnd eq "end") ? "<" : "-"; 290 writeLog($ce, "timing", "$$ ".time." $beginEnd $function [$details]"); 291 } 292 293 sub list2hash { 294 map {$_ => "0"} @_; 295 } 296 297 sub max { 298 my $soFar; 299 foreach my $item (@_) { 300 $soFar = $item unless defined $soFar; 301 if ($item > $soFar) { 302 $soFar = $item; 303 } 304 } 305 return defined $soFar ? $soFar : 0; 306 } 307 308 sub decodeAnswers($) { 309 my $string = shift; 310 return unless defined $string and $string; 311 my @array = split m/##/, $string; 312 $array[$_] =~ s/\\#\\/#/g foreach 0 .. $#array; 313 push @array, "" if @array%2; 314 return @array; # it's actually a hash ;) 315 } 316 317 sub encodeAnswers(\%\@) { 318 my %hash = %{ shift() }; 319 my @order = @{ shift() }; 320 my $string = ""; 321 foreach my $name (@order) { 322 my $value = defined $hash{$name} ? $hash{$name} : ""; 323 $name =~ s/#/\\#\\/g; # this is a WEIRD way to escape things 324 $value =~ s/#/\\#\\/g; # and it's not my fault! 325 if ($value =~ m/\\$/) { 326 # if the value ends with a backslash, string2hash will 327 # interpret that as a normal escape sequence (not part 328 # of the weird pound escape sequence) if the next 329 # character is &. So we have to protect against this. 330 # will adding a spcae at the end of the last answer 331 # hurt anything? i don't think so... 332 $value .= " "; 333 } 334 $string .= "$name##$value##"; # this is also not my fault 335 } 336 $string =~ s/##$//; # remove last pair of hashs 337 return $string; 338 } 339 340 sub ref2string($;$); 341 sub ref2string($;$) { 342 my $ref = shift; 343 my $dontExpand = shift || {}; 344 my $refType = ref $ref; 345 my $result; 346 if ($refType and not $dontExpand->{$refType}) { 347 my $baseType = refBaseType($ref); 348 $result .= '<font size="1" color="grey">' . $refType; 349 $result .= " ($baseType)" if $baseType and $refType ne $baseType; 350 $result .= ":</font><br>"; 351 $result .= '<table border="1" cellpadding="2">'; 352 if ($baseType eq "HASH") { 353 my %hash = %$ref; 354 foreach (sort keys %hash) { 355 $result .= '<tr valign="top">'; 356 $result .= "<td>$_</td>"; 357 $result .= "<td>" . ref2string($hash{$_}, $dontExpand) . "</td>"; 358 $result .= "</tr>"; 359 } 360 } elsif ($baseType eq "ARRAY") { 361 my @array = @$ref; 362 # special case for Problem, Set, and User objects, which are defined 363 # using lists and contain a @FIELDS package variable: 364 no strict 'refs'; 365 my @FIELDS = eval { @{$refType."::FIELDS"} }; 366 use strict 'refs'; 367 undef @FIELDS unless scalar @FIELDS == scalar @array and not $@; 368 foreach (0 .. $#array) { 369 $result .= '<tr valign="top">'; 370 $result .= "<td>$_</td>"; 371 $result .= "<td>".$FIELDS[$_]."</td>" if @FIELDS; 372 $result .= "<td>" . ref2string($array[$_], $dontExpand) . "</td>"; 373 $result .= "</tr>"; 374 } 375 } elsif ($baseType eq "SCALAR") { 376 my $scalar = $$ref; 377 $result .= '<tr valign="top">'; 378 $result .= "<td>$scalar</td>"; 379 $result .= "</tr>"; 380 } else { 381 # perhaps a coderef? in any case, i don't feel like dealing with it! 382 $result .= '<tr valign="top">'; 383 $result .= "<td>$ref</td>"; 384 $result .= "</tr>"; 385 } 386 $result .= "</table>" 387 } else { 388 $result .= defined $ref ? $ref : '<font color="red">undef</font>'; 389 } 390 } 391 392 sub refBaseType($) { 393 my $ref = shift; 394 $ref =~ m/(\w+)\(/; # this might not be robust... 395 return $1; 396 } 397 398 # p. 101, Camel, 3rd ed. 399 # The <=> and cmp operators return -1 if the left operand is less than the 400 # right operand, 0 if they are equal, and +1 if the left operand is greater 401 # than the right operand. 402 403 sub sortByName { 404 my ($field, @items) = @_; 405 return sort { 406 my @aParts = split m/(?<=\D)(?=\d)|(?<=\d)(?=\D)/, defined $field ? $a->$field : $a; 407 my @bParts = split m/(?<=\D)(?=\d)|(?<=\d)(?=\D)/, defined $field ? $b->$field : $b; 408 while (@aParts and @bParts) { 409 my $aPart = shift @aParts; 410 my $bPart = shift @bParts; 411 my $aNumeric = $aPart =~ m/^\d*$/; 412 my $bNumeric = $bPart =~ m/^\d*$/; 413 414 # numbers should come before words 415 return -1 if $aNumeric and not $bNumeric; 416 return +1 if not $aNumeric and $bNumeric; 417 418 # both have the same type 419 if ($aNumeric and $bNumeric) { 420 next if $aPart == $bPart; # check next pair 421 return $aPart <=> $bPart; # compare numerically 422 } else { 423 next if $aPart eq $bPart; # check next pair 424 return $aPart cmp $bPart; # compare lexicographically 425 } 426 } 427 return +1 if @aParts; # a has more sections, should go second 428 return -1 if @bParts; # a had fewer sections, should go first 429 } @items; 430 } 431 432 sub makeTempDirectory($$) { 433 my ($parent, $basename) = @_; 434 # Loop until we're able to create a directory, or it fails for some 435 # reason other than there already being something there. 436 my $triesRemaining = MKDIR_ATTEMPTS; 437 my ($fullPath, $success); 438 do { 439 my $suffix = join "", map { ('A'..'Z','a'..'z','0'..'9')[int rand 62] } 1 .. 8; 440 $fullPath = "$parent/$basename.$suffix"; 441 $success = mkdir $fullPath; 442 } until ($success or not $!{EEXIST}); 443 die "Failed to create directory $fullPath: $!" 444 unless $success; 445 return $fullPath; 446 } 447 448 sub removeTempDirectory($) { 449 my ($dir) = @_; 450 rmtree($dir, 0, 0); 451 } 452 453 sub pretty_print_rh { 454 my $rh = shift; 455 foreach my $key (sort keys %{$rh}) { 456 warn " $key => ",$rh->{$key},"\n"; 457 } 458 } 459 460 sub cryptPassword { 461 my ($clearPassword) = @_; 462 my $salt = join("", ('.','/','0'..'9','A'..'Z','a'..'z')[rand 64, rand 64]); 463 my $cryptPassword = crypt($clearPassword, $salt); 464 return $cryptPassword; 465 } 466 467 # from the Perl Cookbook, first edition, page 25: 468 sub dequote($) { 469 local $_ = shift; 470 my ($white, $leader); # common whitespace and common leading string 471 if (/^\s*(?:([^\w\s]+)(\s*).*\n)(?:\s*\1\2?.*\n)+$/) { 472 ($white, $leader) = ($2, quotemeta($1)); 473 } else { 474 ($white, $leader) = (/^(\s+)/, ''); 475 } 476 s/^\s*?$leader(?:$white)?//gm; 477 return $_; 478 } 479 480 sub undefstr($@) { 481 map { defined $_ ? $_ : $_[0] } @_[1..$#_]; 482 } 483 484 1;
| aubreyja at gmail dot com | ViewVC Help |
| Powered by ViewVC 1.0.9 |