Parent Directory
| 
Revision Log
Abstracted "read directory" functions in SendMail and moved them to Instructor. The instructor calls WeBWorK::Utils::readDirectory and then filters the output according to a pattern match. Sorts as well. Also move read_scoring_file to instructor since it will need to be used in other scripts as well. --Mike
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. Please check that", 85 "webserver has permission to read this directory. $!"; 86 my @result = readdir $dh; 87 close $dh; 88 return @result; 89 } 90 91 sub formatDateTime($) { 92 my $dateTime = shift; 93 # "standard" WeBWorK date/time format (for set definition files): 94 # %m month number, starting with 01 95 # %d numeric day of the month, with leading zeros (eg 01..31) 96 # %y year (2 digits) 97 # %I hour, 12 hour clock, leading 0's) 98 # %M minute, leading 0's 99 # %P am or pm (Yes %p and %P are backwards :) 100 return time2str("%m/%d/%y %I:%M%P", $dateTime); 101 } 102 103 sub parseDateTime($) { 104 my $string = shift; 105 return str2time($string); 106 } 107 108 sub writeLog($$@) { 109 my ($ce, $facility, @message) = @_; 110 unless ($ce->{webworkFiles}->{logs}->{$facility}) { 111 warn "There is no log file for the $facility facility defined.\n"; 112 return; 113 } 114 my $logFile = $ce->{webworkFiles}->{logs}->{$facility}; 115 local *LOG; 116 if (open LOG, ">>", $logFile) { 117 print LOG "[", time2str("%a %b %d %H:%M:%S %Y", time), "] @message\n"; 118 close LOG; 119 } else { 120 warn "failed to open $logFile for writing: $!"; 121 } 122 } 123 124 sub writeCourseLog($$@) { 125 my ($ce, $facility, @message) = @_; 126 unless ($ce->{courseFiles}->{logs}->{$facility}) { 127 warn "There is no course log file for the $facility facility defined.\n"; 128 return; 129 } 130 my $logFile = $ce->{courseFiles}->{logs}->{$facility}; 131 local *LOG; 132 if (open LOG, ">>", $logFile) { 133 print LOG "[", time2str("%a %b %d %H:%M:%S %Y", time), "] @message\n"; 134 close LOG; 135 } else { 136 warn "failed to open $logFile for writing: $!"; 137 } 138 } 139 140 141 # $ce - a WeBWork::CourseEnvironment object 142 # $function - fully qualified function name 143 # $details - any information, do not use the characters '[' or ']' 144 # $beginEnd - the string "begin", "intermediate", or "end" 145 # use the intermediate step begun or completed for INTERMEDIATE 146 # use an empty string for $details when calling for END 147 sub writeTimingLogEntry($$$$) { 148 my ($ce, $function, $details, $beginEnd) = @_; 149 return unless defined $ce->{webworkFiles}->{logs}->{timing}; 150 $beginEnd = ($beginEnd eq "begin") ? ">" : ($beginEnd eq "end") ? "<" : "-"; 151 writeLog($ce, "timing", "$$ ".time." $beginEnd $function [$details]"); 152 } 153 154 sub list2hash { 155 map {$_ => "0"} @_; 156 } 157 158 sub max { 159 my $soFar; 160 foreach my $item (@_) { 161 $soFar = $item unless defined $soFar; 162 if ($item > $soFar) { 163 $soFar = $item; 164 } 165 } 166 return defined $soFar ? $soFar : 0; 167 } 168 169 sub decodeAnswers($) { 170 my $string = shift; 171 return unless defined $string and $string; 172 my @array = split m/##/, $string; 173 $array[$_] =~ s/\\#\\/#/g foreach 0 .. $#array; 174 push @array, "" if @array%2; 175 return @array; # it's actually a hash ;) 176 } 177 178 sub encodeAnswers(\%\@) { 179 my %hash = %{ shift() }; 180 my @order = @{ shift() }; 181 my $string; 182 foreach my $name (@order) { 183 my $value = defined $hash{$name} ? $hash{$name} : ""; 184 $name =~ s/#/\\#\\/g; # this is a WEIRD way to escape things 185 $value =~ s/#/\\#\\/g; # and it's not my fault! 186 if ($value =~ m/\\$/) { 187 # if the value ends with a backslash, string2hash will 188 # interpret that as a normal escape sequence (not part 189 # of the weird pound escape sequence) if the next 190 # character is &. So we have to protect against this. 191 # will adding a spcae at the end of the last answer 192 # hurt anything? i don't think so... 193 $value .= " "; 194 } 195 $string .= "$name##$value##"; # this is also not my fault 196 } 197 $string =~ s/##$//; # remove last pair of hashs 198 return $string; 199 } 200 201 sub ref2string($;$); 202 sub ref2string($;$) { 203 my $ref = shift; 204 my $dontExpand = shift || {}; 205 my $refType = ref $ref; 206 my $result; 207 if ($refType and not $dontExpand->{$refType}) { 208 my $baseType = refBaseType($ref); 209 $result .= '<font size="1" color="grey">' . $refType; 210 $result .= " ($baseType)" if $baseType and $refType ne $baseType; 211 $result .= ":</font><br>"; 212 $result .= '<table border="1" cellpadding="2">'; 213 if ($baseType eq "HASH") { 214 my %hash = %$ref; 215 foreach (sort keys %hash) { 216 $result .= '<tr valign="top">'; 217 $result .= "<td>$_</td>"; 218 $result .= "<td>" . ref2string($hash{$_}, $dontExpand) . "</td>"; 219 $result .= "</tr>"; 220 } 221 } elsif ($baseType eq "ARRAY") { 222 my @array = @$ref; 223 # special case for Problem, Set, and User objects, which are defined 224 # using lists and contain a @FIELDS package variable: 225 no strict 'refs'; 226 my @FIELDS = eval { @{$refType."::FIELDS"} }; 227 use strict 'refs'; 228 undef @FIELDS unless scalar @FIELDS == scalar @array and not $@; 229 foreach (0 .. $#array) { 230 $result .= '<tr valign="top">'; 231 $result .= "<td>$_</td>"; 232 $result .= "<td>".$FIELDS[$_]."</td>" if @FIELDS; 233 $result .= "<td>" . ref2string($array[$_], $dontExpand) . "</td>"; 234 $result .= "</tr>"; 235 } 236 } elsif ($baseType eq "SCALAR") { 237 my $scalar = $$ref; 238 $result .= '<tr valign="top">'; 239 $result .= "<td>$scalar</td>"; 240 $result .= "</tr>"; 241 } else { 242 # perhaps a coderef? in any case, i don't feel like dealing with it! 243 $result .= '<tr valign="top">'; 244 $result .= "<td>$ref</td>"; 245 $result .= "</tr>"; 246 } 247 $result .= "</table>" 248 } else { 249 $result .= defined $ref ? $ref : '<font color="red">undef</font>'; 250 } 251 } 252 253 sub refBaseType($) { 254 my $ref = shift; 255 $ref =~ m/(\w+)\(/; # this might not be robust... 256 return $1; 257 } 258 259 # p. 101, Camel, 3rd ed. 260 # The <=> and cmp operators return -1 if the left operand is less than the 261 # right operand, 0 if they are equal, and +1 if the left operand is greater 262 # than the right operand. 263 264 sub sortByName { 265 my ($field, @items) = @_; 266 return sort { 267 my @aParts = split m/(?<=\D)(?=\d)|(?<=\d)(?=\D)/, $a->$field; 268 my @bParts = split m/(?<=\D)(?=\d)|(?<=\d)(?=\D)/, $b->$field; 269 while (@aParts and @bParts) { 270 my $aPart = shift @aParts; 271 my $bPart = shift @bParts; 272 my $aNumeric = $aPart =~ m/^\d*$/; 273 my $bNumeric = $bPart =~ m/^\d*$/; 274 275 # numbers should come before words 276 return -1 if $aNumeric and not $bNumeric; 277 return +1 if not $aNumeric and $bNumeric; 278 279 # both have the same type 280 if ($aNumeric and $bNumeric) { 281 next if $aPart == $bPart; # check next pair 282 return $aPart <=> $bPart; # compare numerically 283 } else { 284 next if $aPart eq $bPart; # check next pair 285 return $aPart cmp $bPart; # compare lexicographically 286 } 287 } 288 return +1 if @aParts; # a has more sections, should go second 289 return -1 if @bParts; # a had fewer sections, should go first 290 } @items; 291 } 292 293 sub makeTempDirectory($$) { 294 my ($parent, $basename) = @_; 295 # Loop until we're able to create a directory, or it fails for some 296 # reason other than there already being something there. 297 my $triesRemaining = MKDIR_ATTEMPTS; 298 my ($fullPath, $success); 299 do { 300 my $suffix = join "", map { ('A'..'Z','a'..'z','0'..'9')[int rand 62] } 1 .. 8; 301 $fullPath = "$parent/$basename.$suffix"; 302 $success = mkdir $fullPath; 303 } until ($success or not $!{EEXIST}); 304 die "Failed to create directory $fullPath: $!" 305 unless $success; 306 return $fullPath; 307 } 308 309 sub removeTempDirectory($) { 310 my ($dir) = @_; 311 rmtree($dir, 0, 0); 312 } 313 314 sub pretty_print_rh { 315 my $rh = shift; 316 foreach my $key (sort keys %{$rh}) { 317 warn " $key => ",$rh->{$key},"\n"; 318 } 319 } 320 321 sub cryptPassword { 322 my ($clearPassword) = @_; 323 my $salt = join("", ('.','/','0'..'9','A'..'Z','a'..'z')[rand 64, rand 64]); 324 my $cryptPassword = crypt($clearPassword, $salt); 325 return $cryptPassword; 326 } 327 328 1;
| aubreyja at gmail dot com | ViewVC Help |
| Powered by ViewVC 1.0.9 |