Parent Directory
| 
Revision Log
added REAL logout support. keys now get invalidated at logout. also, fixed a bug in classlist (see the diff). also, added a sub to Utils (see the diff). -sam
1 ################################################################################ 2 # WeBWorK mod_perl (c) 2000-2002 WeBWorK Project 3 # $Id$ 4 ################################################################################ 5 6 package WeBWorK::Utils; 7 8 =head1 NAME 9 10 WeBWorK::Utils - useful utilities used by other WeBWorK modules. 11 12 =cut 13 14 use strict; 15 use warnings; 16 use base qw(Exporter); 17 use Date::Format; 18 use Date::Parse; 19 20 our @EXPORT = (); 21 our @EXPORT_OK = qw( 22 runtime_use 23 readFile 24 formatDateTime 25 parseDateTime 26 writeLog 27 writeTimingLogEntry 28 dbDecode 29 dbEncode 30 decodeAnswers 31 encodeAnswers 32 ref2string 33 dequoteHere 34 ); 35 36 sub runtime_use($) { 37 return unless @_; 38 eval "package Main; require $_[0]; import $_[0]"; 39 die $@ if $@; 40 } 41 42 sub readFile($) { 43 my $fileName = shift; 44 local *INPUTFILE; 45 open INPUTFILE, "<", $fileName 46 or die "Failed to read $fileName: $!"; 47 local $/ = undef; 48 my $result = <INPUTFILE>; 49 close INPUTFILE; 50 return $result; 51 } 52 53 sub formatDateTime($) { 54 my $dateTime = shift; 55 # "standard" WeBWorK date/time format (for set definition files): 56 # %m month number, starting with 01 57 # %d numeric day of the month, with leading zeros (eg 01..31) 58 # %y year (2 digits) 59 # %I hour, 12 hour clock, leading 0's) 60 # %M minute, leading 0's 61 # %P am or pm (Yes %p and %P are backwards :) 62 return time2str("%m/%d/%y %I:%M%P", $dateTime); 63 } 64 65 sub parseDateTime($) { 66 my $string = shift; 67 return str2time $string; 68 } 69 70 sub writeLog($$@) { 71 my ($ce, $facility, @message) = @_; 72 unless ($ce->{webworkFiles}->{logs}->{$facility}) { 73 warn "There is no log file for the $facility facility defined.\n"; 74 return; 75 } 76 my $logFile = $ce->{webworkFiles}->{logs}->{$facility}; 77 local *LOG; 78 if (open LOG, ">>", $logFile) { 79 print LOG "[", time2str("%a %b %d %H:%M:%S %Y", time), "] @message\n"; 80 close LOG; 81 } else { 82 warn "failed to open $logFile for writing: $!"; 83 } 84 } 85 86 # $ce - a WeBWork::CourseEnvironment object 87 # $function - fully qualified function name 88 # $details - any information, do not use the characters '[' or ']' 89 # $beginEnd - the string "begin" or "end" 90 # use an empty string for $details when calling for END 91 sub writeTimingLogEntry($$$$) { 92 my ($ce, $function, $details, $beginEnd) = @_; 93 return unless defined $ce->{webworkFiles}->{logs}->{timing}; 94 $beginEnd = ($beginEnd eq "begin") ? ">" : "<"; 95 writeLog($ce, "timing", "$$ ".time." $beginEnd $function [$details]"); 96 } 97 98 # ----- 99 100 sub dbDecode($) { 101 my $string = shift; 102 return unless defined $string and $string; 103 my %hash = $string =~ /(.*?)(?<!\\)=(.*?)(?:(?<!\\)&|$)/g; 104 $hash{$_} =~ s/\\(&|=)/$1/g foreach keys %hash; # unescape & and = 105 return %hash; 106 } 107 108 sub dbEncode(@) { 109 my %hash = @_; 110 my $string; 111 foreach (keys %hash) { 112 $hash{$_} = "" unless defined $hash{$_}; # promote undef to "" 113 $hash{$_} =~ s/(=|&)/\\$1/g; # escape & and = 114 $string .= "$_=$hash{$_}&"; 115 } 116 chop $string; # remove final '&' from string for old code :p 117 return $string; 118 } 119 120 sub decodeAnswers($) { 121 my $string = shift; 122 return unless defined $string and $string; 123 my @array = split m/##/, $string; 124 $array[$_] =~ s/\\#\\/#/g foreach 0 .. $#array; 125 push @array, "" if @array%2; 126 return @array; # it's actually a hash ;) 127 } 128 129 sub encodeAnswers(\%\@) { 130 my %hash = %{ shift() }; 131 my @order = @{ shift() }; 132 my $string; 133 foreach my $name (@order) { 134 my $value = defined $hash{$name} ? $hash{$name} : ""; 135 $name =~ s/#/\\#\\/g; # this is a WEIRD way to escape things 136 $value =~ s/#/\\#\\/g; # and it's not my fault! 137 $string .= "$name##$value##"; # this is also not my fault 138 } 139 $string =~ s/##$//; # remove last pair of hashs 140 return $string; 141 } 142 143 # ----- 144 145 sub ref2string($;$); 146 sub ref2string($;$) { 147 my $ref = shift; 148 my $dontExpand = shift || {}; 149 my $refType = ref $ref; 150 my $result; 151 if ($refType and not $dontExpand->{$refType}) { 152 my $baseType = refBaseType($ref); 153 $result .= '<font size="1" color="grey">' . $refType; 154 $result .= " ($baseType)" if $baseType and $refType ne $baseType; 155 $result .= ":</font><br>"; 156 $result .= '<table border="1" cellpadding="2">'; 157 if ($baseType eq "HASH") { 158 my %hash = %$ref; 159 foreach (sort keys %hash) { 160 $result .= '<tr valign="top">'; 161 $result .= "<td>$_</td>"; 162 $result .= "<td>" . ref2string($hash{$_}, $dontExpand) . "</td>"; 163 $result .= "</tr>"; 164 } 165 } elsif ($baseType eq "ARRAY") { 166 my @array = @$ref; 167 # special case for Problem, Set, and User objects, which are defined 168 # using lists and contain a @FIELDS package variable: 169 no strict 'refs'; 170 my @FIELDS = eval { @{$refType."::FIELDS"} }; 171 use strict 'refs'; 172 undef @FIELDS unless scalar @FIELDS == scalar @array and not $@; 173 foreach (0 .. $#array) { 174 $result .= '<tr valign="top">'; 175 $result .= "<td>$_</td>"; 176 $result .= "<td>".$FIELDS[$_]."</td>" if @FIELDS; 177 $result .= "<td>" . ref2string($array[$_], $dontExpand) . "</td>"; 178 $result .= "</tr>"; 179 } 180 } elsif ($baseType eq "SCALAR") { 181 my $scalar = $$ref; 182 $result .= '<tr valign="top">'; 183 $result .= "<td>$scalar</td>"; 184 $result .= "</tr>"; 185 } else { 186 # perhaps a coderef? in any case, i don't feel like dealing with it! 187 $result .= '<tr valign="top">'; 188 $result .= "<td>$ref</td>"; 189 $result .= "</tr>"; 190 } 191 $result .= "</table>" 192 } else { 193 $result .= defined $ref ? $ref : '<font color="red">undef</font>'; 194 } 195 } 196 197 sub refBaseType($) { 198 my $ref = shift; 199 local $SIG{__DIE__} = 'IGNORE'; 200 return "HASH" if eval { $_ = %$ref; 1 }; 201 return "ARRAY" if eval { $_ = @$ref; 1 }; 202 return "SCALAR" if eval { $_ = $$ref; 1 }; 203 return 0; 204 } 205 206 sub dequoteHere($) { 207 # from "1.11. Indenting Here Documents" in the Perl Cookbook 208 # by Tom Christiansen & Nathan Torkington 209 local $_ = shift; 210 my ($white, $leader); # common whitespace and common leading string 211 if (/^\s*(?:([^\w\s]+)(\s*).*\n)(?:\s*\1\2?.*\n)+$/) { 212 ($white, $leader) = ($2, quotemeta($1)); 213 } else { 214 ($white, $leader) = (/^(\s+)/, ''); 215 } 216 s/^\s*?$leader(?:$white)?//gm; 217 return $_; 218 } 219 220 1;
| aubreyja at gmail dot com | ViewVC Help |
| Powered by ViewVC 1.0.9 |