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