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