Parent Directory
| 
Revision Log
Took out the redundant "confirm email address" from user options. Also, added a Util function "backtrace", which can be passed one of "die", "warn", "print", or "return". I'm just showing off, but it might prove useful in debugging. -Dennis
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 Date::Format; 18 use Date::Parse; 19 use DB; # DeBug, not DataBase 20 21 our @EXPORT = (); 22 our @EXPORT_OK = qw( 23 runtime_use 24 backtrace 25 readFile 26 formatDateTime 27 parseDateTime 28 writeLog 29 writeTimingLogEntry 30 list2hash 31 max 32 readDirectory 33 dbDecode 34 dbEncode 35 decodeAnswers 36 encodeAnswers 37 ref2string 38 dequoteHere 39 wrapText 40 ); 41 42 sub runtime_use($) { 43 return unless @_; 44 eval "package Main; require $_[0]; import $_[0]"; 45 die $@ if $@; 46 } 47 48 sub backtrace { 49 my ($style) = @_; 50 $style = "warn" unless $style; 51 my @bt = DB->backtrace; 52 shift @bt; # Remove "backtrace" from the backtrace; 53 if ($style eq "die") { 54 die join "\n", @bt; 55 } elsif ($style eq "warn") { 56 warn join "\n", @bt; 57 } elsif ($style eq "print") { 58 print join "\n", @bt; 59 } elsif ($style eq "return") { 60 return @bt; 61 } 62 } 63 64 sub readFile($) { 65 my $fileName = shift; 66 local *INPUTFILE; 67 open INPUTFILE, "<", $fileName 68 or die "Failed to read $fileName: $!"; 69 local $/ = undef; 70 my $result = <INPUTFILE>; 71 close INPUTFILE; 72 return $result; 73 } 74 75 sub readDirectory($) { 76 my ($dirname) = @_; 77 78 opendir my $dirhandle, $dirname or die "couldn't open directory $dirname: $!"; 79 my @contents = readdir $dirhandle; 80 closedir $dirhandle; 81 return @contents; 82 } 83 84 sub formatDateTime($) { 85 my $dateTime = shift; 86 # "standard" WeBWorK date/time format (for set definition files): 87 # %m month number, starting with 01 88 # %d numeric day of the month, with leading zeros (eg 01..31) 89 # %y year (2 digits) 90 # %I hour, 12 hour clock, leading 0's) 91 # %M minute, leading 0's 92 # %P am or pm (Yes %p and %P are backwards :) 93 return time2str("%m/%d/%y %I:%M%P", $dateTime); 94 } 95 96 sub parseDateTime($) { 97 my $string = shift; 98 return str2time($string); 99 } 100 101 sub writeLog($$@) { 102 my ($ce, $facility, @message) = @_; 103 unless ($ce->{webworkFiles}->{logs}->{$facility}) { 104 warn "There is no log file for the $facility facility defined.\n"; 105 return; 106 } 107 my $logFile = $ce->{webworkFiles}->{logs}->{$facility}; 108 local *LOG; 109 if (open LOG, ">>", $logFile) { 110 print LOG "[", time2str("%a %b %d %H:%M:%S %Y", time), "] @message\n"; 111 close LOG; 112 } else { 113 warn "failed to open $logFile for writing: $!"; 114 } 115 } 116 117 # $ce - a WeBWork::CourseEnvironment object 118 # $function - fully qualified function name 119 # $details - any information, do not use the characters '[' or ']' 120 # $beginEnd - the string "begin", "intermediate", or "end" 121 # use the intermediate step begun or completed for INTERMEDIATE 122 # use an empty string for $details when calling for END 123 sub writeTimingLogEntry($$$$) { 124 my ($ce, $function, $details, $beginEnd) = @_; 125 return unless defined $ce->{webworkFiles}->{logs}->{timing}; 126 $beginEnd = ($beginEnd eq "begin") ? ">" : ($beginEnd eq "end") ? "<" : "-"; 127 writeLog($ce, "timing", "$$ ".time." $beginEnd $function [$details]"); 128 } 129 130 sub list2hash { 131 map {$_ => "0"} @_; 132 } 133 134 sub max { 135 my $soFar; 136 foreach my $item (@_) { 137 $soFar = $item unless defined $soFar; 138 if ($item > $soFar) { 139 $soFar = $item; 140 } 141 } 142 return defined $soFar ? $soFar : 0; 143 } 144 145 # ----- 146 147 sub dbDecode($) { 148 my $string = shift; 149 return unless defined $string and $string; 150 my %hash = $string =~ /(.*?)(?<!\\)=(.*?)(?:(?<!\\)&|$)/g; 151 $hash{$_} =~ s/\\(&|=)/$1/g foreach keys %hash; # unescape & and = 152 return %hash; 153 } 154 155 sub dbEncode(@) { 156 my %hash = @_; 157 my $string; 158 foreach (keys %hash) { 159 $hash{$_} = "" unless defined $hash{$_}; # promote undef to "" 160 $hash{$_} =~ s/(=|&)/\\$1/g; # escape & and = 161 $string .= "$_=$hash{$_}&"; 162 } 163 chop $string; # remove final '&' from string for old code :p 164 return $string; 165 } 166 167 sub decodeAnswers($) { 168 my $string = shift; 169 return unless defined $string and $string; 170 my @array = split m/##/, $string; 171 $array[$_] =~ s/\\#\\/#/g foreach 0 .. $#array; 172 push @array, "" if @array%2; 173 return @array; # it's actually a hash ;) 174 } 175 176 sub encodeAnswers(\%\@) { 177 my %hash = %{ shift() }; 178 my @order = @{ shift() }; 179 my $string; 180 foreach my $name (@order) { 181 my $value = defined $hash{$name} ? $hash{$name} : ""; 182 $name =~ s/#/\\#\\/g; # this is a WEIRD way to escape things 183 $value =~ s/#/\\#\\/g; # and it's not my fault! 184 $string .= "$name##$value##"; # this is also not my fault 185 } 186 $string =~ s/##$//; # remove last pair of hashs 187 return $string; 188 } 189 190 # ----- 191 192 sub ref2string($;$); 193 sub ref2string($;$) { 194 my $ref = shift; 195 my $dontExpand = shift || {}; 196 my $refType = ref $ref; 197 my $result; 198 if ($refType and not $dontExpand->{$refType}) { 199 my $baseType = refBaseType($ref); 200 $result .= '<font size="1" color="grey">' . $refType; 201 $result .= " ($baseType)" if $baseType and $refType ne $baseType; 202 $result .= ":</font><br>"; 203 $result .= '<table border="1" cellpadding="2">'; 204 if ($baseType eq "HASH") { 205 my %hash = %$ref; 206 foreach (sort keys %hash) { 207 $result .= '<tr valign="top">'; 208 $result .= "<td>$_</td>"; 209 $result .= "<td>" . ref2string($hash{$_}, $dontExpand) . "</td>"; 210 $result .= "</tr>"; 211 } 212 } elsif ($baseType eq "ARRAY") { 213 my @array = @$ref; 214 # special case for Problem, Set, and User objects, which are defined 215 # using lists and contain a @FIELDS package variable: 216 no strict 'refs'; 217 my @FIELDS = eval { @{$refType."::FIELDS"} }; 218 use strict 'refs'; 219 undef @FIELDS unless scalar @FIELDS == scalar @array and not $@; 220 foreach (0 .. $#array) { 221 $result .= '<tr valign="top">'; 222 $result .= "<td>$_</td>"; 223 $result .= "<td>".$FIELDS[$_]."</td>" if @FIELDS; 224 $result .= "<td>" . ref2string($array[$_], $dontExpand) . "</td>"; 225 $result .= "</tr>"; 226 } 227 } elsif ($baseType eq "SCALAR") { 228 my $scalar = $$ref; 229 $result .= '<tr valign="top">'; 230 $result .= "<td>$scalar</td>"; 231 $result .= "</tr>"; 232 } else { 233 # perhaps a coderef? in any case, i don't feel like dealing with it! 234 $result .= '<tr valign="top">'; 235 $result .= "<td>$ref</td>"; 236 $result .= "</tr>"; 237 } 238 $result .= "</table>" 239 } else { 240 $result .= defined $ref ? $ref : '<font color="red">undef</font>'; 241 } 242 } 243 244 sub refBaseType($) { 245 my $ref = shift; 246 $ref =~ m/(\w+)\(/; # this might not be robust... 247 return $1; 248 } 249 250 1;
| aubreyja at gmail dot com | ViewVC Help |
| Powered by ViewVC 1.0.9 |