Parent Directory
| 
Revision Log
Normalized headers. All files now contain the text below as a header. This is important since all files now (a) use the full name of the package, (b) assign copyright to "The WeBWorK Project", (c) give the full path of the file (relative to CVSROOT) instead of simply the file name, and (d) include license and warranty information. Here is the new header: ################################################################################ # WeBWorK Online Homework Delivery System # Copyright © 2000-2003 The WeBWorK Projcct, http://openwebwork.sf.net/ # $CVSHeader$ # # This program is free software; you can redistribute it and/or modify it under # the terms of either: (a) the GNU General Public License as published by the # Free Software Foundation; either version 2, or (at your option) any later # version, or (b) the "Artistic License" which comes with this package. # # This program is distributed in the hope that it will be useful, but WITHOUT # ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS # FOR A PARTICULAR PURPOSE. See either the GNU General Public License or the # Artistic License for more details. ################################################################################
1 ################################################################################ 2 # WeBWorK Online Homework Delivery System 3 # Copyright © 2000-2003 The WeBWorK Project, http://openwebwork.sf.net/ 4 # $CVSHeader$ 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 34 use constant MKDIR_ATTEMPTS => 10; 35 36 our @EXPORT = (); 37 our @EXPORT_OK = qw( 38 runtime_use 39 readFile 40 readDirectory 41 formatDateTime 42 parseDateTime 43 writeLog 44 writeCourseLog 45 writeTimingLogEntry 46 list2hash 47 max 48 dbDecode 49 dbEncode 50 decodeAnswers 51 encodeAnswers 52 ref2string 53 sortByName 54 makeTempDirectory 55 removeTempDirectory 56 pretty_print_rh 57 cryptPassword 58 ); 59 60 sub runtime_use($) { 61 return unless @_; 62 eval "package Main; require $_[0]; import $_[0]"; 63 die $@ if $@; 64 } 65 66 #sub backtrace { 67 # my ($style) = @_; 68 # $style = "warn" unless $style; 69 # my @bt = DB->backtrace; 70 # shift @bt; # Remove "backtrace" from the backtrace; 71 # if ($style eq "die") { 72 # die join "\n", @bt; 73 # } elsif ($style eq "warn") { 74 # warn join "\n", @bt; 75 # } elsif ($style eq "print") { 76 # print join "\n", @bt; 77 # } elsif ($style eq "return") { 78 # return @bt; 79 # } 80 #} 81 82 sub readFile($) { 83 my $fileName = shift; 84 local $/ = undef; # slurp the whole thing into one string 85 open my $dh, "<", $fileName 86 or die "failed to read file $fileName: $!"; 87 my $result = <$dh>; 88 close $dh; 89 return $result; 90 } 91 92 sub readDirectory($) { 93 my $dirName = shift; 94 opendir my $dh, $dirName 95 or die "Failed to read directory $dirName: $!"; 96 my @result = readdir $dh; 97 close $dh; 98 return @result; 99 } 100 101 sub formatDateTime($) { 102 my $dateTime = shift; 103 # "standard" WeBWorK date/time format (for set definition files): 104 # %m month number, starting with 01 105 # %d numeric day of the month, with leading zeros (eg 01..31) 106 # %y year (2 digits) 107 # %I hour, 12 hour clock, leading 0's) 108 # %M minute, leading 0's 109 # %P am or pm (Yes %p and %P are backwards :) 110 #return time2str("%m/%d/%y %I:%M%P", $dateTime); 111 return time2str("%m/%d/%y at %I:%M%P", $dateTime); 112 } 113 114 sub parseDateTime($) { 115 my $string = shift; 116 # need to bring our string from "%m/%d/%y at %I:%M%P" to "%m/%d/%y %I:%M%P" format. 117 $string =~ s/\bat\b/ /; 118 return str2time($string); 119 } 120 121 sub writeLog($$@) { 122 my ($ce, $facility, @message) = @_; 123 unless ($ce->{webworkFiles}->{logs}->{$facility}) { 124 warn "There is no log file for the $facility facility defined.\n"; 125 return; 126 } 127 my $logFile = $ce->{webworkFiles}->{logs}->{$facility}; 128 local *LOG; 129 if (open LOG, ">>", $logFile) { 130 print LOG "[", time2str("%a %b %d %H:%M:%S %Y", time), "] @message\n"; 131 close LOG; 132 } else { 133 warn "failed to open $logFile for writing: $!"; 134 } 135 } 136 137 sub writeCourseLog($$@) { 138 my ($ce, $facility, @message) = @_; 139 unless ($ce->{courseFiles}->{logs}->{$facility}) { 140 warn "There is no course log file for the $facility facility defined.\n"; 141 return; 142 } 143 my $logFile = $ce->{courseFiles}->{logs}->{$facility}; 144 local *LOG; 145 if (open LOG, ">>", $logFile) { 146 print LOG "[", time2str("%a %b %d %H:%M:%S %Y", time), "] @message\n"; 147 close LOG; 148 } else { 149 warn "failed to open $logFile for writing: $!"; 150 } 151 } 152 153 154 # $ce - a WeBWork::CourseEnvironment object 155 # $function - fully qualified function name 156 # $details - any information, do not use the characters '[' or ']' 157 # $beginEnd - the string "begin", "intermediate", or "end" 158 # use the intermediate step begun or completed for INTERMEDIATE 159 # use an empty string for $details when calling for END 160 sub writeTimingLogEntry($$$$) { 161 my ($ce, $function, $details, $beginEnd) = @_; 162 return unless defined $ce->{webworkFiles}->{logs}->{timing}; 163 $beginEnd = ($beginEnd eq "begin") ? ">" : ($beginEnd eq "end") ? "<" : "-"; 164 writeLog($ce, "timing", "$$ ".time." $beginEnd $function [$details]"); 165 } 166 167 sub list2hash { 168 map {$_ => "0"} @_; 169 } 170 171 sub max { 172 my $soFar; 173 foreach my $item (@_) { 174 $soFar = $item unless defined $soFar; 175 if ($item > $soFar) { 176 $soFar = $item; 177 } 178 } 179 return defined $soFar ? $soFar : 0; 180 } 181 182 sub decodeAnswers($) { 183 my $string = shift; 184 return unless defined $string and $string; 185 my @array = split m/##/, $string; 186 $array[$_] =~ s/\\#\\/#/g foreach 0 .. $#array; 187 push @array, "" if @array%2; 188 return @array; # it's actually a hash ;) 189 } 190 191 sub encodeAnswers(\%\@) { 192 my %hash = %{ shift() }; 193 my @order = @{ shift() }; 194 my $string; 195 foreach my $name (@order) { 196 my $value = defined $hash{$name} ? $hash{$name} : ""; 197 $name =~ s/#/\\#\\/g; # this is a WEIRD way to escape things 198 $value =~ s/#/\\#\\/g; # and it's not my fault! 199 if ($value =~ m/\\$/) { 200 # if the value ends with a backslash, string2hash will 201 # interpret that as a normal escape sequence (not part 202 # of the weird pound escape sequence) if the next 203 # character is &. So we have to protect against this. 204 # will adding a spcae at the end of the last answer 205 # hurt anything? i don't think so... 206 $value .= " "; 207 } 208 $string .= "$name##$value##"; # this is also not my fault 209 } 210 $string =~ s/##$//; # remove last pair of hashs 211 return $string; 212 } 213 214 sub ref2string($;$); 215 sub ref2string($;$) { 216 my $ref = shift; 217 my $dontExpand = shift || {}; 218 my $refType = ref $ref; 219 my $result; 220 if ($refType and not $dontExpand->{$refType}) { 221 my $baseType = refBaseType($ref); 222 $result .= '<font size="1" color="grey">' . $refType; 223 $result .= " ($baseType)" if $baseType and $refType ne $baseType; 224 $result .= ":</font><br>"; 225 $result .= '<table border="1" cellpadding="2">'; 226 if ($baseType eq "HASH") { 227 my %hash = %$ref; 228 foreach (sort keys %hash) { 229 $result .= '<tr valign="top">'; 230 $result .= "<td>$_</td>"; 231 $result .= "<td>" . ref2string($hash{$_}, $dontExpand) . "</td>"; 232 $result .= "</tr>"; 233 } 234 } elsif ($baseType eq "ARRAY") { 235 my @array = @$ref; 236 # special case for Problem, Set, and User objects, which are defined 237 # using lists and contain a @FIELDS package variable: 238 no strict 'refs'; 239 my @FIELDS = eval { @{$refType."::FIELDS"} }; 240 use strict 'refs'; 241 undef @FIELDS unless scalar @FIELDS == scalar @array and not $@; 242 foreach (0 .. $#array) { 243 $result .= '<tr valign="top">'; 244 $result .= "<td>$_</td>"; 245 $result .= "<td>".$FIELDS[$_]."</td>" if @FIELDS; 246 $result .= "<td>" . ref2string($array[$_], $dontExpand) . "</td>"; 247 $result .= "</tr>"; 248 } 249 } elsif ($baseType eq "SCALAR") { 250 my $scalar = $$ref; 251 $result .= '<tr valign="top">'; 252 $result .= "<td>$scalar</td>"; 253 $result .= "</tr>"; 254 } else { 255 # perhaps a coderef? in any case, i don't feel like dealing with it! 256 $result .= '<tr valign="top">'; 257 $result .= "<td>$ref</td>"; 258 $result .= "</tr>"; 259 } 260 $result .= "</table>" 261 } else { 262 $result .= defined $ref ? $ref : '<font color="red">undef</font>'; 263 } 264 } 265 266 sub refBaseType($) { 267 my $ref = shift; 268 $ref =~ m/(\w+)\(/; # this might not be robust... 269 return $1; 270 } 271 272 # p. 101, Camel, 3rd ed. 273 # The <=> and cmp operators return -1 if the left operand is less than the 274 # right operand, 0 if they are equal, and +1 if the left operand is greater 275 # than the right operand. 276 277 sub sortByName { 278 my ($field, @items) = @_; 279 return sort { 280 my @aParts = split m/(?<=\D)(?=\d)|(?<=\d)(?=\D)/, $a->$field; 281 my @bParts = split m/(?<=\D)(?=\d)|(?<=\d)(?=\D)/, $b->$field; 282 while (@aParts and @bParts) { 283 my $aPart = shift @aParts; 284 my $bPart = shift @bParts; 285 my $aNumeric = $aPart =~ m/^\d*$/; 286 my $bNumeric = $bPart =~ m/^\d*$/; 287 288 # numbers should come before words 289 return -1 if $aNumeric and not $bNumeric; 290 return +1 if not $aNumeric and $bNumeric; 291 292 # both have the same type 293 if ($aNumeric and $bNumeric) { 294 next if $aPart == $bPart; # check next pair 295 return $aPart <=> $bPart; # compare numerically 296 } else { 297 next if $aPart eq $bPart; # check next pair 298 return $aPart cmp $bPart; # compare lexicographically 299 } 300 } 301 return +1 if @aParts; # a has more sections, should go second 302 return -1 if @bParts; # a had fewer sections, should go first 303 } @items; 304 } 305 306 sub makeTempDirectory($$) { 307 my ($parent, $basename) = @_; 308 # Loop until we're able to create a directory, or it fails for some 309 # reason other than there already being something there. 310 my $triesRemaining = MKDIR_ATTEMPTS; 311 my ($fullPath, $success); 312 do { 313 my $suffix = join "", map { ('A'..'Z','a'..'z','0'..'9')[int rand 62] } 1 .. 8; 314 $fullPath = "$parent/$basename.$suffix"; 315 $success = mkdir $fullPath; 316 } until ($success or not $!{EEXIST}); 317 die "Failed to create directory $fullPath: $!" 318 unless $success; 319 return $fullPath; 320 } 321 322 sub removeTempDirectory($) { 323 my ($dir) = @_; 324 rmtree($dir, 0, 0); 325 } 326 327 sub pretty_print_rh { 328 my $rh = shift; 329 foreach my $key (sort keys %{$rh}) { 330 warn " $key => ",$rh->{$key},"\n"; 331 } 332 } 333 334 sub cryptPassword { 335 my ($clearPassword) = @_; 336 my $salt = join("", ('.','/','0'..'9','A'..'Z','a'..'z')[rand 64, rand 64]); 337 my $cryptPassword = crypt($clearPassword, $salt); 338 return $cryptPassword; 339 } 340 341 1;
| aubreyja at gmail dot com | ViewVC Help |
| Powered by ViewVC 1.0.9 |