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