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