Parent Directory
| 
Revision Log
Added surePathToFile utility called as surePathToFile start_directory path (the path can be the full path including the start_directory segment) If the start_directory is the tmp directory then one has the effect of surePathToTmpFile defined in IO.pl
1 ################################################################################ 2 # WeBWorK Online Homework Delivery System 3 # Copyright © 2000-2003 The WeBWorK Project, http://openwebwork.sf.net/ 4 # $CVSHeader: webwork-modperl/lib/WeBWorK/Utils.pm,v 1.41 2004/05/05 22:01:48 sh002i Exp $ 5 # 6 # This program is free software; you can redistribute it and/or modify it under 7 # the terms of either: (a) the GNU General Public License as published by the 8 # Free Software Foundation; either version 2, or (at your option) any later 9 # version, or (b) the "Artistic License" which comes with this package. 10 # 11 # This program is distributed in the hope that it will be useful, but WITHOUT 12 # ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS 13 # FOR A PARTICULAR PURPOSE. See either the GNU General Public License or the 14 # Artistic License for more details. 15 ################################################################################ 16 17 package WeBWorK::Utils; 18 use base qw(Exporter); 19 20 =head1 NAME 21 22 WeBWorK::Utils - useful utilities used by other WeBWorK modules. 23 24 =cut 25 26 use strict; 27 use warnings; 28 #use Apache::DB; 29 use Date::Format; 30 use Date::Parse; 31 use Errno; 32 use File::Path qw(rmtree); 33 use Carp; 34 35 use constant MKDIR_ATTEMPTS => 10; 36 37 our @EXPORT = (); 38 our @EXPORT_OK = qw( 39 runtime_use 40 readFile 41 readDirectory 42 formatDateTime 43 parseDateTime 44 writeLog 45 writeCourseLog 46 writeTimingLogEntry 47 list2hash 48 max 49 dbDecode 50 dbEncode 51 decodeAnswers 52 encodeAnswers 53 ref2string 54 sortByName 55 makeTempDirectory 56 removeTempDirectory 57 pretty_print_rh 58 surePathToFile 59 cryptPassword 60 dequote 61 undefstr 62 ); 63 64 sub runtime_use { 65 croak "runtime_use: no module specified" unless $_[0]; 66 eval "package Main; require $_[0]; import $_[0]"; 67 die $@ if $@; 68 } 69 70 #sub backtrace { 71 # my ($style) = @_; 72 # $style = "warn" unless $style; 73 # my @bt = DB->backtrace; 74 # shift @bt; # Remove "backtrace" from the backtrace; 75 # if ($style eq "die") { 76 # die join "\n", @bt; 77 # } elsif ($style eq "warn") { 78 # warn join "\n", @bt; 79 # } elsif ($style eq "print") { 80 # print join "\n", @bt; 81 # } elsif ($style eq "return") { 82 # return @bt; 83 # } 84 #} 85 86 sub readFile($) { 87 my $fileName = shift; 88 local $/ = undef; # slurp the whole thing into one string 89 open my $dh, "<", $fileName 90 or die "failed to read file $fileName: $!"; 91 my $result = <$dh>; 92 close $dh; 93 return $result; 94 } 95 96 sub readDirectory($) { 97 my $dirName = shift; 98 opendir my $dh, $dirName 99 or die "Failed to read directory $dirName: $!"; 100 my @result = readdir $dh; 101 close $dh; 102 return @result; 103 } 104 105 sub formatDateTime($) { 106 my $dateTime = shift; 107 # "standard" WeBWorK date/time format (for set definition files): 108 # %m month number, starting with 01 109 # %d numeric day of the month, with leading zeros (eg 01..31) 110 # %y year (2 digits) 111 # %I hour, 12 hour clock, leading 0's) 112 # %M minute, leading 0's 113 # %P am or pm (Yes %p and %P are backwards :) 114 #return time2str("%m/%d/%y %I:%M%P", $dateTime); 115 return time2str("%m/%d/%y at %I:%M%P", $dateTime); 116 } 117 118 sub parseDateTime($) { 119 my $string = shift; 120 # need to bring our string from "%m/%d/%y at %I:%M%P" to "%m/%d/%y %I:%M%P" format. 121 $string =~ s/\bat\b/ /; 122 return str2time($string); 123 } 124 125 sub writeLog($$@) { 126 my ($ce, $facility, @message) = @_; 127 unless ($ce->{webworkFiles}->{logs}->{$facility}) { 128 warn "There is no log file for the $facility facility defined.\n"; 129 return; 130 } 131 my $logFile = $ce->{webworkFiles}->{logs}->{$facility}; 132 local *LOG; 133 if (open LOG, ">>", $logFile) { 134 print LOG "[", time2str("%a %b %d %H:%M:%S %Y", time), "] @message\n"; 135 close LOG; 136 } else { 137 warn "failed to open $logFile for writing: $!"; 138 } 139 } 140 141 sub writeCourseLog($$@) { 142 my ($ce, $facility, @message) = @_; 143 unless ($ce->{courseFiles}->{logs}->{$facility}) { 144 warn "There is no course log file for the $facility facility defined.\n"; 145 return; 146 } 147 my $logFile = $ce->{courseFiles}->{logs}->{$facility}; 148 local *LOG; 149 if (open LOG, ">>", $logFile) { 150 print LOG "[", time2str("%a %b %d %H:%M:%S %Y", time), "] @message\n"; 151 close LOG; 152 } else { 153 warn "failed to open $logFile for writing: $!"; 154 } 155 } 156 157 # A very useful macro for making sure that all of the directories to a file have been constructed. 158 159 sub surePathToFile { 160 # constructs intermediate 161 # the input path must be the path relative to this starting directory 162 my $start_directory = shift; 163 my $path = shift; 164 my $delim = "/"; #&getDirDelim(); 165 unless ($start_directory and $path ) { 166 warn "missing directory<br> surePathToFile start_directory path "; 167 return ''; 168 } 169 # use the permissions/group on the start directory itself as a template 170 my ($perms, $groupID) = (stat $start_directory)[2,5]; 171 #warn "&urePathToTmpFile: perms=$perms groupID=$groupID\n"; 172 173 # if the path starts with $start_directory (which is permitted but optional) remove this initial segment 174 $path =~ s|^$start_directory|| if $path =~ m|^$start_directory|; 175 #$path = convertPath($path); 176 177 178 # find the nodes on the given path 179 my @nodes = split("$delim",$path); 180 181 # create new path 182 $path = $start_directory; #convertPath("$tmpDirectory"); 183 184 while (@nodes>1) { 185 $path = $path . shift (@nodes) . "/"; #convertPath($path . shift (@nodes) . "/"); 186 #FIXME this make directory command may not be fool proof. 187 unless (-e $path) { 188 mkdir($path, $perms) 189 or warn "Failed to create directory $path"; 190 } 191 192 } 193 194 $path = $path . shift(@nodes); #convertPath($path . shift(@nodes)); 195 return $path; 196 } 197 198 # $ce - a WeBWork::CourseEnvironment object 199 # $function - fully qualified function name 200 # $details - any information, do not use the characters '[' or ']' 201 # $beginEnd - the string "begin", "intermediate", or "end" 202 # use the intermediate step begun or completed for INTERMEDIATE 203 # use an empty string for $details when calling for END 204 sub writeTimingLogEntry($$$$) { 205 my ($ce, $function, $details, $beginEnd) = @_; 206 return unless defined $ce->{webworkFiles}->{logs}->{timing}; 207 $beginEnd = ($beginEnd eq "begin") ? ">" : ($beginEnd eq "end") ? "<" : "-"; 208 writeLog($ce, "timing", "$$ ".time." $beginEnd $function [$details]"); 209 } 210 211 sub list2hash { 212 map {$_ => "0"} @_; 213 } 214 215 sub max { 216 my $soFar; 217 foreach my $item (@_) { 218 $soFar = $item unless defined $soFar; 219 if ($item > $soFar) { 220 $soFar = $item; 221 } 222 } 223 return defined $soFar ? $soFar : 0; 224 } 225 226 sub decodeAnswers($) { 227 my $string = shift; 228 return unless defined $string and $string; 229 my @array = split m/##/, $string; 230 $array[$_] =~ s/\\#\\/#/g foreach 0 .. $#array; 231 push @array, "" if @array%2; 232 return @array; # it's actually a hash ;) 233 } 234 235 sub encodeAnswers(\%\@) { 236 my %hash = %{ shift() }; 237 my @order = @{ shift() }; 238 my $string; 239 foreach my $name (@order) { 240 my $value = defined $hash{$name} ? $hash{$name} : ""; 241 $name =~ s/#/\\#\\/g; # this is a WEIRD way to escape things 242 $value =~ s/#/\\#\\/g; # and it's not my fault! 243 if ($value =~ m/\\$/) { 244 # if the value ends with a backslash, string2hash will 245 # interpret that as a normal escape sequence (not part 246 # of the weird pound escape sequence) if the next 247 # character is &. So we have to protect against this. 248 # will adding a spcae at the end of the last answer 249 # hurt anything? i don't think so... 250 $value .= " "; 251 } 252 $string .= "$name##$value##"; # this is also not my fault 253 } 254 $string =~ s/##$//; # remove last pair of hashs 255 return $string; 256 } 257 258 sub ref2string($;$); 259 sub ref2string($;$) { 260 my $ref = shift; 261 my $dontExpand = shift || {}; 262 my $refType = ref $ref; 263 my $result; 264 if ($refType and not $dontExpand->{$refType}) { 265 my $baseType = refBaseType($ref); 266 $result .= '<font size="1" color="grey">' . $refType; 267 $result .= " ($baseType)" if $baseType and $refType ne $baseType; 268 $result .= ":</font><br>"; 269 $result .= '<table border="1" cellpadding="2">'; 270 if ($baseType eq "HASH") { 271 my %hash = %$ref; 272 foreach (sort keys %hash) { 273 $result .= '<tr valign="top">'; 274 $result .= "<td>$_</td>"; 275 $result .= "<td>" . ref2string($hash{$_}, $dontExpand) . "</td>"; 276 $result .= "</tr>"; 277 } 278 } elsif ($baseType eq "ARRAY") { 279 my @array = @$ref; 280 # special case for Problem, Set, and User objects, which are defined 281 # using lists and contain a @FIELDS package variable: 282 no strict 'refs'; 283 my @FIELDS = eval { @{$refType."::FIELDS"} }; 284 use strict 'refs'; 285 undef @FIELDS unless scalar @FIELDS == scalar @array and not $@; 286 foreach (0 .. $#array) { 287 $result .= '<tr valign="top">'; 288 $result .= "<td>$_</td>"; 289 $result .= "<td>".$FIELDS[$_]."</td>" if @FIELDS; 290 $result .= "<td>" . ref2string($array[$_], $dontExpand) . "</td>"; 291 $result .= "</tr>"; 292 } 293 } elsif ($baseType eq "SCALAR") { 294 my $scalar = $$ref; 295 $result .= '<tr valign="top">'; 296 $result .= "<td>$scalar</td>"; 297 $result .= "</tr>"; 298 } else { 299 # perhaps a coderef? in any case, i don't feel like dealing with it! 300 $result .= '<tr valign="top">'; 301 $result .= "<td>$ref</td>"; 302 $result .= "</tr>"; 303 } 304 $result .= "</table>" 305 } else { 306 $result .= defined $ref ? $ref : '<font color="red">undef</font>'; 307 } 308 } 309 310 sub refBaseType($) { 311 my $ref = shift; 312 $ref =~ m/(\w+)\(/; # this might not be robust... 313 return $1; 314 } 315 316 # p. 101, Camel, 3rd ed. 317 # The <=> and cmp operators return -1 if the left operand is less than the 318 # right operand, 0 if they are equal, and +1 if the left operand is greater 319 # than the right operand. 320 321 sub sortByName { 322 my ($field, @items) = @_; 323 return sort { 324 my @aParts = split m/(?<=\D)(?=\d)|(?<=\d)(?=\D)/, defined $field ? $a->$field : $a; 325 my @bParts = split m/(?<=\D)(?=\d)|(?<=\d)(?=\D)/, defined $field ? $b->$field : $b; 326 while (@aParts and @bParts) { 327 my $aPart = shift @aParts; 328 my $bPart = shift @bParts; 329 my $aNumeric = $aPart =~ m/^\d*$/; 330 my $bNumeric = $bPart =~ m/^\d*$/; 331 332 # numbers should come before words 333 return -1 if $aNumeric and not $bNumeric; 334 return +1 if not $aNumeric and $bNumeric; 335 336 # both have the same type 337 if ($aNumeric and $bNumeric) { 338 next if $aPart == $bPart; # check next pair 339 return $aPart <=> $bPart; # compare numerically 340 } else { 341 next if $aPart eq $bPart; # check next pair 342 return $aPart cmp $bPart; # compare lexicographically 343 } 344 } 345 return +1 if @aParts; # a has more sections, should go second 346 return -1 if @bParts; # a had fewer sections, should go first 347 } @items; 348 } 349 350 sub makeTempDirectory($$) { 351 my ($parent, $basename) = @_; 352 # Loop until we're able to create a directory, or it fails for some 353 # reason other than there already being something there. 354 my $triesRemaining = MKDIR_ATTEMPTS; 355 my ($fullPath, $success); 356 do { 357 my $suffix = join "", map { ('A'..'Z','a'..'z','0'..'9')[int rand 62] } 1 .. 8; 358 $fullPath = "$parent/$basename.$suffix"; 359 $success = mkdir $fullPath; 360 } until ($success or not $!{EEXIST}); 361 die "Failed to create directory $fullPath: $!" 362 unless $success; 363 return $fullPath; 364 } 365 366 sub removeTempDirectory($) { 367 my ($dir) = @_; 368 rmtree($dir, 0, 0); 369 } 370 371 sub pretty_print_rh { 372 my $rh = shift; 373 foreach my $key (sort keys %{$rh}) { 374 warn " $key => ",$rh->{$key},"\n"; 375 } 376 } 377 378 sub cryptPassword { 379 my ($clearPassword) = @_; 380 my $salt = join("", ('.','/','0'..'9','A'..'Z','a'..'z')[rand 64, rand 64]); 381 my $cryptPassword = crypt($clearPassword, $salt); 382 return $cryptPassword; 383 } 384 385 # from the Perl Cookbook, first edition, page 25: 386 sub dequote($) { 387 local $_ = shift; 388 my ($white, $leader); # common whitespace and common leading string 389 if (/^\s*(?:([^\w\s]+)(\s*).*\n)(?:\s*\1\2?.*\n)+$/) { 390 ($white, $leader) = ($2, quotemeta($1)); 391 } else { 392 ($white, $leader) = (/^(\s+)/, ''); 393 } 394 s/^\s*?$leader(?:$white)?//gm; 395 return $_; 396 } 397 398 sub undefstr($@) { 399 map { defined $_ ? $_ : $_[0] } @_[1..$#_]; 400 } 401 402 1;
| aubreyja at gmail dot com | ViewVC Help |
| Powered by ViewVC 1.0.9 |