[system] / branches / gage_dev / webwork2 / lib / WeBWorK / Utils.pm Repository:
ViewVC logotype

Diff of /branches/gage_dev/webwork2/lib/WeBWorK/Utils.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

Revision 410 Revision 3610
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.68 2005/09/07 18:02:06 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
1package WeBWorK::Utils; 17package WeBWorK::Utils;
2
3use base qw(Exporter); 18use base qw(Exporter);
4 19
20=head1 NAME
21
22WeBWorK::Utils - useful utilities used by other WeBWorK modules.
23
24=cut
25
26use strict;
27use warnings;
28#use Apache::DB;
29use DateTime;
30use Date::Parse;
31use Date::Format;
32use Time::Zone;
33use MIME::Base64;
34use Errno;
35use File::Path qw(rmtree);
36use Carp;
37
38use constant MKDIR_ATTEMPTS => 10;
39
40# "standard" WeBWorK date/time format (for set definition files):
41# %m/%d/%y at %I:%M%P
42# where:
43# %m = month number, starting with 01
44# %d = numeric day of the month, with leading zeros (eg 01..31)
45# %Y = year (4 digits)
46# %I = hour, 12 hour clock, leading 0's)
47# %M = minute, leading 0's
48# %P = am or pm (Yes %p and %P are backwards :)
49use constant DATE_FORMAT => "%m/%d/%Y at %I:%M%P %Z";
50
5our @EXPORT = (); 51our @EXPORT = ();
6our @EXPORT_OK = qw(runtime_use readFile); 52our @EXPORT_OK = qw(
53 runtime_use
54 readFile
55 readDirectory
56 listFilesRecursive
57 surePathToFile
58 makeTempDirectory
59 removeTempDirectory
60 formatDateTime
61 parseDateTime
62 textDateTime
63 intDateTime
64 timeToSec
65 writeLog
66 writeCourseLog
67 writeTimingLogEntry
68 list2hash
69 ref2string
70 decodeAnswers
71 encodeAnswers
72 max
73 pretty_print_rh
74 cryptPassword
75 dequote
76 undefstr
77 fisher_yates_shuffle
78 sortByName
79);
80
81=head1 FUNCTIONS
82
83=cut
84
85################################################################################
86# Lowlevel thingies
87################################################################################
7 88
8sub runtime_use($) { 89sub runtime_use($) {
9 return unless @_; 90 croak "runtime_use: no module specified" unless $_[0];
10 eval "require $_[0]; import $_[0]"; 91 eval "package Main; require $_[0]; import $_[0]";
11 die $@ if $@; 92 die $@ if $@;
93}
94
95#sub backtrace($) {
96# my ($style) = @_;
97# $style = "warn" unless $style;
98# my @bt = DB->backtrace;
99# shift @bt; # Remove "backtrace" from the backtrace;
100# if ($style eq "die") {
101# die join "\n", @bt;
102# } elsif ($style eq "warn") {
103# warn join "\n", @bt;
104# } elsif ($style eq "print") {
105# print join "\n", @bt;
106# } elsif ($style eq "return") {
107# return @bt;
108# }
109#}
110
111################################################################################
112# Filesystem interaction
113################################################################################
114
115=head2 Filesystem interaction
116
117=over
118
119=cut
120
121# Convert Windows and Mac (classic) line endings to UNIX line endings in a string.
122# Windows uses CRLF, Mac uses CR, UNIX uses LF. (CR is ASCII 15, LF if ASCII 12)
123sub force_eoln($) {
124 my ($string) = @_;
125 $string =~ s/\015\012?/\012/g;
126 return $string;
12} 127}
13 128
14sub readFile($) { 129sub readFile($) {
15 my $fileName = shift; 130 my $fileName = shift;
16 open INPUTFILE, "<", $fileName 131 local $/ = undef; # slurp the whole thing into one string
132 open my $dh, "<", $fileName
17 or die "Failed to read $fileName: $!"; 133 or die "failed to read file $fileName: $!";
18 local $/ = undef; 134 my $result = <$dh>;
19 my $result = <INPUTFILE>; 135 close $dh;
20 close INPUTFILE; 136 return force_eoln($result);
137}
138
139sub readDirectory($) {
140 my $dirName = shift;
141 opendir my $dh, $dirName
142 or die "Failed to read directory $dirName: $!";
143 my @result = readdir $dh;
144 close $dh;
21 return $result; 145 return @result;
22} 146}
147
148=item @matches = listFilesRecusive($dir, $match_qr, $prune_qr, $match_full, $prune_full)
149
150Traverses the directory tree rooted at $dir, returning a list of files, named
151pipes, and sockets matching the regular expression $match_qr. Directories
152matching the regular expression $prune_qr are not visited.
153
154$match_full and $prune_full are boolean values that indicate whether $match_qr
155and $prune_qr, respectively, should be applied to the bare directory entry
156(false) or to the path to the directory entry relative to $dir.
157
158@matches is a list of paths relative to $dir.
159
160=cut
161
162sub listFilesRecursiveHelper($$$$$$);
163sub listFilesRecursive($;$$$$) {
164 my ($dir, $match_qr, $prune_qr, $match_full, $prune_full) = @_;
165 return listFilesRecursiveHelper($dir, "", $match_qr, $prune_qr, $match_full, $prune_full);
166}
167
168sub listFilesRecursiveHelper($$$$$$) {
169 my ($base_dir, $curr_dir, $match_qr, $prune_qr, $match_full, $prune_full) = @_;
170
171 my $full_dir = "$base_dir/$curr_dir";
172
173 my @dir_contents = readDirectory($full_dir);
174
175 my @matches;
176
177 foreach my $dir_entry (@dir_contents) {
178 my $full_path = "$full_dir/$dir_entry";
179
180 # determine whether the entry is a directory or a file, taking into account the
181 my $is_dir;
182 my $is_file;
183 if (-l $full_path) {
184 my $link_target = "$full_dir/" . readlink $full_path;
185 if ($link_target) {
186 $is_dir = -d $link_target;
187 $is_file = !$is_dir && -f $link_target || -p $link_target || -S $link_target;
188 } else {
189 warn "Couldn't resolve symlink $full_path: $!";
190 }
191 } else {
192 $is_dir = -d $full_path;
193 $is_file = !$is_dir && -f $full_path || -p $full_path || -S $full_path;
194 }
195
196 if ($is_dir) {
197 # standard things to skip
198 next if $dir_entry eq ".";
199 next if $dir_entry eq "..";
200
201 # skip unreadable directories (and broken symlinks, incidentally)
202 unless (-r $full_path) {
203 warn "Directory/symlink $full_path not readable";
204 next;
205 }
206
207 # check $prune_qr
208 my $subdir = ($curr_dir eq "") ? $dir_entry : "$curr_dir/$dir_entry";
209 if (defined $prune_qr) {
210 my $prune_string = $prune_full ? $subdir : $dir_entry;
211 next if $prune_string =~ m/$prune_qr/;
212 }
213
214 # everything looks good, time to recurse!
215 push @matches, listFilesRecursiveHelper($base_dir, $subdir, $match_qr, $prune_qr, $match_full, $prune_full);
216 } elsif ($is_file) {
217 my $file = ($curr_dir eq "") ? $dir_entry : "$curr_dir/$dir_entry";
218 my $match_string = $match_full ? $file : $dir_entry;
219 if (not defined $match_string or $match_string =~ m/$match_qr/) {
220 push @matches, $file;
221 }
222 } else {
223 # otherwise, it's a character device or a block device, and i don't
224 # suppose we want anything to do with those ;-)
225 }
226 }
227
228 return @matches;
229}
230
231# A very useful macro for making sure that all of the directories to a file have
232# been constructed.
233sub surePathToFile($$) {
234 # constructs intermediate directories enroute to the file
235 # the input path must be the path relative to this starting directory
236 my $start_directory = shift;
237 my $path = shift;
238 my $delim = "/";
239 unless ($start_directory and $path ) {
240 warn "missing directory<br> surePathToFile start_directory path ";
241 return '';
242 }
243 # use the permissions/group on the start directory itself as a template
244 my ($perms, $groupID) = (stat $start_directory)[2,5];
245 #warn "&urePathToTmpFile: perms=$perms groupID=$groupID\n";
246
247 # if the path starts with $start_directory (which is permitted but optional) remove this initial segment
248 $path =~ s|^$start_directory|| if $path =~ m|^$start_directory|;
249
250
251 # find the nodes on the given path
252 my @nodes = split("$delim",$path);
253
254 # create new path
255 $path = $start_directory; #convertPath("$tmpDirectory");
256
257 while (@nodes>1) { # the last node is the file name
258 $path = $path . shift (@nodes) . "/"; #convertPath($path . shift (@nodes) . "/");
259 #FIXME this make directory command may not be fool proof.
260 unless (-e $path) {
261 mkdir($path, $perms)
262 or warn "Failed to create directory $path";
263 }
264
265 }
266
267 $path = $path . shift(@nodes); #convertPath($path . shift(@nodes));
268 return $path;
269}
270
271sub makeTempDirectory($$) {
272 my ($parent, $basename) = @_;
273 # Loop until we're able to create a directory, or it fails for some
274 # reason other than there already being something there.
275 my $triesRemaining = MKDIR_ATTEMPTS;
276 my ($fullPath, $success);
277 do {
278 my $suffix = join "", map { ('A'..'Z','a'..'z','0'..'9')[int rand 62] } 1 .. 8;
279 $fullPath = "$parent/$basename.$suffix";
280 $success = mkdir $fullPath;
281 } until ($success or not $!{EEXIST});
282 die "Failed to create directory $fullPath: $!"
283 unless $success;
284 return $fullPath;
285}
286
287sub removeTempDirectory($) {
288 my ($dir) = @_;
289 rmtree($dir, 0, 0);
290}
291
292=back
293
294=cut
295
296################################################################################
297# Date/time processing
298################################################################################
299
300=head2 Date/time processing
301
302=over
303
304=item $dateTime = parseDateTime($string, $display_tz)
305
306Parses $string as a datetime. If $display_tz is given, $string is assumed to be
307in that timezone. Otherwise, the server's timezone is used. The result,
308$dateTime, is an integer UNIX datetime (epoch) in the server's timezone.
309
310=cut
311
312# This is a modified version of the subroutine of the same name from WeBWorK
313# 1.9.05's scripts/FILE.pl (v1.13). It has been modified to understand time
314# zones. The time zone specification must appear at the end of the string and be
315# preceded by whitespace. The return value is a list consisting of the following
316# elements:
317#
318# ($second, $minute, $hour, $day, $month, $year, $zone)
319#
320# $second, $minute, $hour, $day, and $month are zero-indexed. $year is the
321# number of years since 1900. $zone is a string (hopefully) representing the
322# time zone.
323#
324# Error handling has also been improved. Exceptions are now thrown for errors,
325# and more information is given abou the nature of errors.
326#
327sub unformatDateAndTime {
328 my ($string) = @_;
329 my $orgString =$string;
330 $string =~ s|^\s+||;
331 $string =~ s|\s+$||;
332 $string =~ s|at| at |i; ## OK if forget to enter spaces or use wrong case
333 $string =~ s|AM| AM|i; ## OK if forget to enter spaces or use wrong case
334 $string =~ s|PM| PM|i; ## OK if forget to enter spaces or use wrong case
335 $string =~ s|,| at |; ## start translating old form of date/time to new form
336 if ($string =~ m|^\s*[\/\d]+\s+[:\d]+| ) { # case where the at is missing: MM/DD/YYYY at HH:MM AMPM ZONE
337 die "Incorrect date/time format \"$orgString\". The \"at\" appears to be missing.
338 Correct format is MM/DD/YYYY at HH:MM AMPM ZONE (e.g. \"03/29/2004 at 06:00am EST\")";
339 }
340
341 my($date,$at, $time,$AMPM,$TZ) = split(/\s+/,$string);
342 unless ($time =~ /:/) {
343 { ##bare block for 'case" structure
344 $time =~ /(\d\d)(\d\d)/;
345 my $tmp_hour = $1;
346 my $tmp_min = $2;
347 if ($tmp_hour eq '00') {$time = "12:$tmp_min"; $AMPM = 'AM';last;}
348 if ($tmp_hour eq '12') {$time = "12:$tmp_min"; $AMPM = 'PM';last;}
349 if ($tmp_hour < 12) {$time = "$tmp_hour:$tmp_min"; $AMPM = 'AM';last;}
350 if ($tmp_hour < 24) {
351 $tmp_hour = $tmp_hour - 12;
352 $time = "$tmp_hour:$tmp_min";
353 $AMPM = 'PM';
354 }
355 } ##end of bare block for 'case" structure
356
357 }
358
359 my ($mday, $mon, $year, $wday, $yday,$sec, $pm, $min, $hour);
360 $sec=0;
361 $time =~ /^([0-9]+)\s*\:\s*([0-9]*)/;
362 $min=$2;
363 $hour = $1;
364 if ($hour < 1 or $hour > 12) {
365 die "Incorrect date/time format \"$orgString\". Hour must be in the range [1,12].
366 Correct format is MM/DD/YYYY at HH:MM AMPM ZONE (e.g. \"03/29/2004 at 06:00am EST\")
367 date = $date
368 time = $time
369 ampm = $AMPM
370 zone = $TZ\n";
371 }
372 if ($min < 0 or $min > 59) {
373 die "Incorrect date/time format \"$orgString\". Minute must be in the range [0-59].
374 Correct format is MM/DD/YYYY at HH:MM AMPM ZONE
375 date = $date
376 time = $time
377 ampm = $AMPM
378 zone = $TZ\n";
379 }
380 $pm = 0;
381 $pm = 12 if ($AMPM =~/PM/ and $hour < 12);
382 $hour += $pm;
383 $hour = 0 if ($AMPM =~/AM/ and $hour == 12);
384 $date =~ m!([0-9]+)\s*/\s*([0-9]+)/\s*([0-9]+)! ;
385 $mday =$2;
386 $mon=($1-1);
387 if ($mday < 1 or $mday > 31) {
388 die "Incorrect date/time format \"$orgString\". Day must be in the range [1,31].
389 Correct format is MM/DD/YY at HH:MM AMPM ZONE
390 date = $date
391 time = $time
392 ampm = $AMPM
393 zone = $TZ\n";
394 }
395 if ($mon < 0 or $mon > 11) {
396 die "Incorrect date/time format \"$orgString\". Month must be in the range [1,12].
397 Correct format is MM/DD/YY at HH:MM AMPM ZONE
398 date = $date
399 time = $time
400 ampm = $AMPM
401 zone = $TZ\n";
402 }
403 $year=$3;
404 $wday="";
405 $yday="";
406 return ($sec, $min, $hour, $mday, $mon, $year, $TZ);
407}
408
409
410sub parseDateTime($;$) {
411 my ($string, $display_tz) = @_;
412 $display_tz ||= "local";
413 #warn "parseDateTime('$string', '$display_tz')\n";
414
415 # use WeBWorK 1 date parsing routine
416 my ($second, $minute, $hour, $day, $month, $year, $zone) = unformatDateAndTime($string);
417 my $zone_str = defined $zone ? $zone : "UNDEF";
418 #warn "\tunformatDateAndTime: $second $minute $hour $day $month $year $zone_str\n";
419
420 # DateTime expects month 1-12, not 0-11
421 $month++;
422
423 # Do what Time::Local does to ambiguous years
424 {
425 my $ThisYear = (localtime())[5]; # FIXME: should be relative to $string's timezone
426 my $Breakpoint = ($ThisYear + 50) % 100;
427 my $NextCentury = $ThisYear - $ThisYear % 100;
428 $NextCentury += 100 if $Breakpoint < 50;
429 my $Century = $NextCentury - 100;
430 my $SecOff = 0;
431
432 if ($year >= 1000) {
433 # leave alone
434 } elsif ($year < 100 and $year >= 0) {
435 $year += ($year > $Breakpoint) ? $Century : $NextCentury;
436 $year += 1900;
437 } else {
438 $year += 1900;
439 }
440 }
441
442 my $epoch;
443
444 if (defined $zone and $zone ne "") {
445 if (DateTime::TimeZone->is_valid_name($zone)) {
446 #warn "\t\$zone is valid according to DateTime::TimeZone\n";
447
448 my $dt = new DateTime(
449 year => $year,
450 month => $month,
451 day => $day,
452 hour => $hour,
453 minute => $minute,
454 second => $second,
455 time_zone => $zone,
456 );
457 #warn "\t\$dt = ", $dt->strftime(DATE_FORMAT), "\n";
458
459 $epoch = $dt->epoch;
460 #warn "\t\$dt->epoch = $epoch\n";
461 } else {
462 #warn "\t\$zone is invalid according to DateTime::TimeZone, so we ask Time::Zone\n";
463
464 # treat the date/time as UTC
465 my $dt = new DateTime(
466 year => $year,
467 month => $month,
468 day => $day,
469 hour => $hour,
470 minute => $minute,
471 second => $second,
472 time_zone => "UTC",
473 );
474 #warn "\t\$dt = ", $dt->strftime(DATE_FORMAT), "\n";
475
476 # convert to an epoch value
477 my $utc_epoch = $dt->epoch
478 or die "Date/time '$string' not representable as an epoch. Get more bits!\n";
479 #warn "\t\$utc_epoch = $utc_epoch\n";
480
481 # get offset for supplied timezone and utc_epoch
482 my $offset = tz_offset($zone, $utc_epoch) or die "Time zone '$zone' not recognized.\n";
483 #warn "\t\$zone is valid according to Time::Zone (\$offset = $offset)\n";
484
485 #$epoch = $utc_epoch + $offset;
486 ##warn "\t\$epoch = \$utc_epoch + \$offset = $epoch\n";
487
488 $dt->subtract(seconds => $offset);
489 #warn "\t\$dt - \$offset = ", $dt->strftime(DATE_FORMAT), "\n";
490
491 $epoch = $dt->epoch;
492 #warn "\t\$epoch = $epoch\n";
493 }
494 } else {
495 #warn "\t\$zone not supplied, using \$display_tz\n";
496
497 my $dt = new DateTime(
498 year => $year,
499 month => $month,
500 day => $day,
501 hour => $hour,
502 minute => $minute,
503 second => $second,
504 time_zone => $display_tz,
505 );
506 #warn "\t\$dt = ", $dt->strftime(DATE_FORMAT), "\n";
507
508 $epoch = $dt->epoch;
509 #warn "\t\$epoch = $epoch\n";
510 }
511
512 return $epoch;
513}
514
515=item $string = formatDateTime($dateTime, $display_tz)
516
517Formats the UNIX datetime $dateTime in the standard WeBWorK datetime format.
518$dateTime is assumed to be in the server's time zone. If $display_tz is given,
519the datetime is converted from the server's timezone to the timezone specified.
520
521=cut
522
523sub formatDateTime($;$) {
524 my ($dateTime, $display_tz) = @_;
525 $display_tz ||= "local";
526 #warn "formatDateTime('$dateTime', '$display_tz')\n";
527
528 my $dt = DateTime->from_epoch(epoch => $dateTime, time_zone => $display_tz);
529 #warn "\t\$dt = ", $dt->strftime(DATE_FORMAT), "\n";
530 return $dt->strftime(DATE_FORMAT);
531}
532
533=item $string = textDateTime($string_or_dateTime)
534
535Accepts a UNIX datetime or a formatted string, returns a formatted string.
536
537=cut
538
539sub textDateTime($) {
540 return ($_[0] =~ m/^\d*$/) ? formatDateTime($_[0]) : $_[0];
541}
542
543=item $dateTIme = intDateTime($string_or_dateTime)
544
545Accepts a UNIX datetime or a formatted string, returns a UNIX datetime.
546
547=cut
548
549sub intDateTime($) {
550 return ($_[0] =~ m/^\d*$/) ? $_[0] : parseDateTime($_[0]);
551}
552
553=item $timeinsec = timeToSec($time)
554
555Makes a stab at converting a time (with a possible unit) into a number of
556seconds.
557
558=cut
559
560sub timeToSec($) {
561 my $t = shift();
562 if ( $t =~ /^(\d+)\s+(\S+)\s*$/ ) {
563 my ( $val, $unit ) = ( $1, $2 );
564 if ( $unit =~ /month/i || $unit =~ /mon/i ) {
565 $val *= 18144000; # this assumes 30 days/month
566 } elsif ( $unit =~ /week/i || $unit =~ /wk/i ) {
567 $val *= 604800;
568 } elsif ( $unit =~ /day/i || $unit =~ /dy/i ) {
569 $val *= 86400;
570 } elsif ( $unit =~ /hour/i || $unit =~ /hr/i ) {
571 $val *= 3600;
572 } elsif ( $unit =~ /minute/i || $unit =~ /min/i ) {
573 $val *= 60;
574 } elsif ( $unit =~ /second/i || $unit =~ /sec/i || $unit =~ /^s$/i ) {
575 # do nothing
576 } else {
577 warn("Unrecognized time unit $unit.\nAssuming seconds.\n");
578 }
579 return $val;
580 } elsif ( $t =~ /^(\d+)$/ ) {
581 return $t;
582 } else {
583 warn("Unrecognized time interval: $t\n");
584 return 0;
585 }
586}
587
588=back
589
590=cut
591
592################################################################################
593# Logging
594################################################################################
595
596sub writeLog($$@) {
597 my ($ce, $facility, @message) = @_;
598 unless ($ce->{webworkFiles}->{logs}->{$facility}) {
599 warn "There is no log file for the $facility facility defined.\n";
600 return;
601 }
602 my $logFile = $ce->{webworkFiles}->{logs}->{$facility};
603 surePathToFile($ce->{webworkDirs}->{root}, $logFile);
604 local *LOG;
605 if (open LOG, ">>", $logFile) {
606 print LOG "[", time2str("%a %b %d %H:%M:%S %Y", time), "] @message\n";
607 close LOG;
608 } else {
609 warn "failed to open $logFile for writing: $!";
610 }
611}
612
613sub writeCourseLog($$@) {
614 my ($ce, $facility, @message) = @_;
615 unless ($ce->{courseFiles}->{logs}->{$facility}) {
616 warn "There is no course log file for the $facility facility defined.\n";
617 return;
618 }
619 my $logFile = $ce->{courseFiles}->{logs}->{$facility};
620 surePathToFile($ce->{courseDirs}->{root}, $logFile);
621 local *LOG;
622 if (open LOG, ">>", $logFile) {
623 print LOG "[", time2str("%a %b %d %H:%M:%S %Y", time), "] @message\n";
624 close LOG;
625 } else {
626 warn "failed to open $logFile for writing: $!";
627 }
628}
629
630# $ce - a WeBWork::CourseEnvironment object
631# $function - fully qualified function name
632# $details - any information, do not use the characters '[' or ']'
633# $beginEnd - the string "begin", "intermediate", or "end"
634# use the intermediate step begun or completed for INTERMEDIATE
635# use an empty string for $details when calling for END
636# Information printed in format:
637# [formatted date & time ] processID unixTime BeginEnd $function $details
638sub writeTimingLogEntry($$$$) {
639 my ($ce, $function, $details, $beginEnd) = @_;
640 $beginEnd = ($beginEnd eq "begin") ? ">" : ($beginEnd eq "end") ? "<" : "-";
641 writeLog($ce, "timing", "$$ ".time." $beginEnd $function [$details]");
642}
643
644################################################################################
645# Data munging
646################################################################################
647
648sub list2hash(@) {
649 map {$_ => "0"} @_;
650}
651
652sub refBaseType($) {
653 my $ref = shift;
654 $ref =~ m/(\w+)\(/; # this might not be robust...
655 return $1;
656}
657
658sub ref2string($;$);
659sub ref2string($;$) {
660 my $ref = shift;
661 my $dontExpand = shift || {};
662 my $refType = ref $ref;
663 my $result;
664 if ($refType and not $dontExpand->{$refType}) {
665 my $baseType = refBaseType($ref);
666 $result .= '<font size="1" color="grey">' . $refType;
667 $result .= " ($baseType)" if $baseType and $refType ne $baseType;
668 $result .= ":</font><br>";
669 $result .= '<table border="1" cellpadding="2">';
670 if ($baseType eq "HASH") {
671 my %hash = %$ref;
672 foreach (sort keys %hash) {
673 $result .= '<tr valign="top">';
674 $result .= "<td>$_</td>";
675 $result .= "<td>" . ref2string($hash{$_}, $dontExpand) . "</td>";
676 $result .= "</tr>";
677 }
678 } elsif ($baseType eq "ARRAY") {
679 my @array = @$ref;
680 # special case for Problem, Set, and User objects, which are defined
681 # using lists and contain a @FIELDS package variable:
682 no strict 'refs';
683 my @FIELDS = eval { @{$refType."::FIELDS"} };
684 use strict 'refs';
685 undef @FIELDS unless scalar @FIELDS == scalar @array and not $@;
686 foreach (0 .. $#array) {
687 $result .= '<tr valign="top">';
688 $result .= "<td>$_</td>";
689 $result .= "<td>".$FIELDS[$_]."</td>" if @FIELDS;
690 $result .= "<td>" . ref2string($array[$_], $dontExpand) . "</td>";
691 $result .= "</tr>";
692 }
693 } elsif ($baseType eq "SCALAR") {
694 my $scalar = $$ref;
695 $result .= '<tr valign="top">';
696 $result .= "<td>$scalar</td>";
697 $result .= "</tr>";
698 } else {
699 # perhaps a coderef? in any case, i don't feel like dealing with it!
700 $result .= '<tr valign="top">';
701 $result .= "<td>$ref</td>";
702 $result .= "</tr>";
703 }
704 $result .= "</table>"
705 } else {
706 $result .= defined $ref ? $ref : '<font color="red">undef</font>';
707 }
708}
709our $BASE64_ENCODED = 'base64_encoded:';
710# use constant BASE64_ENCODED = 'base64_encoded;
711# was not evaluated in the matching and substitution
712# statements
713sub decodeAnswers($) {
714 my $string = shift;
715 return unless defined $string and $string;
716
717 if ($string =~/^$BASE64_ENCODED/o) {
718 $string =~ s/^$BASE64_ENCODED//o;
719 $string = decode_base64($string);
720 }
721
722 my @array = split m/##/, $string;
723 $array[$_] =~ s/\\#\\/#/g foreach 0 .. $#array;
724 push @array, "" if @array%2;
725 return @array; # it's actually a hash ;)
726}
727
728sub encodeAnswers(\%\@) {
729 my %hash = %{ shift() };
730 my @order = @{ shift() };
731 my $string = "";
732 foreach my $name (@order) {
733 my $value = defined $hash{$name} ? $hash{$name} : "";
734 $name =~ s/#/\\#\\/g; # this is a WEIRD way to escape things
735 $value =~ s/#/\\#\\/g; # and it's not my fault!
736 if ($value =~ m/\\$/) {
737 # if the value ends with a backslash, string2hash will
738 # interpret that as a normal escape sequence (not part
739 # of the weird pound escape sequence) if the next
740 # character is &. So we have to protect against this.
741 # will adding a spcae at the end of the last answer
742 # hurt anything? i don't think so...
743 $value .= " ";
744 }
745 $string .= "$name##$value##"; # this is also not my fault
746 }
747 $string =~ s/##$//; # remove last pair of hashs
748
749 $string = $BASE64_ENCODED.encode_base64($string, "");
750 # Empty string in second argument prevents end-of-line characters from being used.
751 # This is nice for examining database contents manually since it prevents newlines
752 # from being introduced into database records.
753
754 return $string;
755}
756
757sub max(@) {
758 my $soFar;
759 foreach my $item (@_) {
760 $soFar = $item unless defined $soFar;
761 if ($item > $soFar) {
762 $soFar = $item;
763 }
764 }
765 return defined $soFar ? $soFar : 0;
766}
767
768sub pretty_print_rh($) {
769 my $rh = shift;
770 foreach my $key (sort keys %{$rh}) {
771 warn " $key => ",$rh->{$key},"\n";
772 }
773}
774
775sub cryptPassword($) {
776 my ($clearPassword) = @_;
777 my $salt = join("", ('.','/','0'..'9','A'..'Z','a'..'z')[rand 64, rand 64]);
778 my $cryptPassword = crypt($clearPassword, $salt);
779 return $cryptPassword;
780}
781
782# from the Perl Cookbook, first edition, page 25:
783sub dequote($) {
784 local $_ = shift;
785 my ($white, $leader); # common whitespace and common leading string
786 if (/^\s*(?:([^\w\s]+)(\s*).*\n)(?:\s*\1\2?.*\n)+$/) {
787 ($white, $leader) = ($2, quotemeta($1));
788 } else {
789 ($white, $leader) = (/^(\s+)/, '');
790 }
791 s/^\s*?$leader(?:$white)?//gm;
792 return $_;
793}
794
795sub undefstr($@) {
796 map { defined $_ ? $_ : $_[0] } @_[1..$#_];
797}
798
799# shuffle an array in place
800# Perl Cookbook, Recipe 4.17. Randomizing an Array
801sub fisher_yates_shuffle {
802 my $array = shift;
803 my $i;
804 for ($i = @$array; --$i; ) {
805 my $j = int rand ($i+1);
806 next if $i == $j;
807 @$array[$i,$j] = @$array[$j,$i];
808 }
809}
810
811################################################################################
812# Sorting
813################################################################################
814
815# p. 101, Camel, 3rd ed.
816# The <=> and cmp operators return -1 if the left operand is less than the
817# right operand, 0 if they are equal, and +1 if the left operand is greater
818# than the right operand.
819sub sortByName($@) {
820 my ($field, @items) = @_;
821 return sort {
822 my @aParts = split m/(?<=\D)(?=\d)|(?<=\d)(?=\D)/, defined $field ? $a->$field : $a;
823 my @bParts = split m/(?<=\D)(?=\d)|(?<=\d)(?=\D)/, defined $field ? $b->$field : $b;
824 while (@aParts and @bParts) {
825 my $aPart = shift @aParts;
826 my $bPart = shift @bParts;
827 my $aNumeric = $aPart =~ m/^\d*$/;
828 my $bNumeric = $bPart =~ m/^\d*$/;
829
830 # numbers should come before words
831 return -1 if $aNumeric and not $bNumeric;
832 return +1 if not $aNumeric and $bNumeric;
833
834 # both have the same type
835 if ($aNumeric and $bNumeric) {
836 next if $aPart == $bPart; # check next pair
837 return $aPart <=> $bPart; # compare numerically
838 } else {
839 next if $aPart eq $bPart; # check next pair
840 return $aPart cmp $bPart; # compare lexicographically
841 }
842 }
843 return +1 if @aParts; # a has more sections, should go second
844 return -1 if @bParts; # a had fewer sections, should go first
845 } @items;
846}
847
8481;
Legend:
Removed from v.410  
changed lines
  Added in v.3610
aubreyja at gmail dot com
 ViewVC Help
Powered by ViewVC 1.0.9