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

    1 ################################################################################
    2 # WeBWorK Online Homework Delivery System
    3 # Copyright © 2000-2007 The WeBWorK Project, http://openwebwork.sf.net/
    4 # $CVSHeader: webwork2/lib/WeBWorK/Utils.pm,v 1.83 2009/07/12 23:48:00 gage 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 DateTime;
   30 use Date::Parse;
   31 use Date::Format;
   32 use File::Copy;
   33 use File::Spec;
   34 use Time::Zone;
   35 use MIME::Base64;
   36 use Errno;
   37 use File::Path qw(rmtree);
   38 use Storable;
   39 use Carp;
   40 
   41 use constant MKDIR_ATTEMPTS => 10;
   42 
   43 # "standard" WeBWorK date/time format (for set definition files):
   44 #     %m/%d/%y at %I:%M%P
   45 # where:
   46 #     %m = month number, starting with 01
   47 #     %d = numeric day of the month, with leading zeros (eg 01..31)
   48 #     %Y = year (4 digits)
   49 #     %I = hour, 12 hour clock, leading 0's)
   50 #     %M = minute, leading 0's
   51 #     %P = am or pm (Yes %p and %P are backwards :)
   52 use constant DATE_FORMAT => "%m/%d/%Y at %I:%M%P %Z";
   53 
   54 our @EXPORT    = ();
   55 our @EXPORT_OK = qw(
   56   after
   57   before
   58   between
   59   constituency_hash
   60   cryptPassword
   61   decodeAnswers
   62   dequote
   63   encodeAnswers
   64   fisher_yates_shuffle
   65   formatDateTime
   66   has_aux_files
   67   intDateTime
   68   list2hash
   69   listFilesRecursive
   70   makeTempDirectory
   71   max
   72   not_blank
   73   parseDateTime
   74   path_is_subdir
   75   pretty_print_rh
   76   readDirectory
   77   readFile
   78   ref2string
   79   removeTempDirectory
   80   runtime_use
   81   sortByName
   82   surePathToFile
   83   textDateTime
   84   timeToSec
   85   trim_spaces
   86   undefstr
   87   writeCourseLog
   88   writeLog
   89   writeTimingLogEntry
   90 );
   91 
   92 =head1 FUNCTIONS
   93 
   94 =cut
   95 
   96 ################################################################################
   97 # Lowlevel thingies
   98 ################################################################################
   99 
  100 # This is like use, except it happens at runtime. You have to quote the module name and put a
  101 # comma after it if you're specifying an import list. Also, to specify an empty import list (as
  102 # opposed to no import list) use an empty arrayref instead of an empty array.
  103 #
  104 #   use Xyzzy;               =>    runtime_use "Xyzzy";
  105 #   use Foo qw/pine elm/;    =>    runtime_use "Foo", qw/pine elm/;
  106 #   use Foo::Bar ();         =>    runtime_use "Foo::Bar", [];
  107 
  108 sub runtime_use($;@) {
  109   my ($module, @import_list) = @_;
  110   my $package = (caller)[0]; # import into caller's namespace
  111 
  112   my $import_string;
  113   if (@import_list == 1 and ref $import_list[0] eq "ARRAY" and @{$import_list[0]} == 0) {
  114     $import_string = "";
  115   } else {
  116     # \Q = quote metachars \E = end quoting
  117     $import_string = "import $module " . join(",", map { qq|"\Q$_\E"| } @import_list);
  118   }
  119   eval "package $package; require $module; $import_string";
  120   die $@ if $@;
  121 }
  122 
  123 #sub backtrace($) {
  124 # my ($style) = @_;
  125 # $style = "warn" unless $style;
  126 # my @bt = DB->backtrace;
  127 # shift @bt; # Remove "backtrace" from the backtrace;
  128 # if ($style eq "die") {
  129 #   die join "\n", @bt;
  130 # } elsif ($style eq "warn") {
  131 #   warn join "\n", @bt;
  132 # } elsif ($style eq "print") {
  133 #   print join "\n", @bt;
  134 # } elsif ($style eq "return") {
  135 #   return @bt;
  136 # }
  137 #}
  138 
  139 ################################################################################
  140 # Filesystem interaction
  141 ################################################################################
  142 
  143 =head2 Filesystem interaction
  144 
  145 =over
  146 
  147 =cut
  148 
  149 # Convert Windows and Mac (classic) line endings to UNIX line endings in a string.
  150 # Windows uses CRLF, Mac uses CR, UNIX uses LF. (CR is ASCII 15, LF if ASCII 12)
  151 sub force_eoln($) {
  152   my ($string) = @_;
  153   $string =~ s/\015\012?/\012/g;
  154   return $string;
  155 }
  156 
  157 sub readFile($) {
  158   my $fileName = shift;
  159   local $/ = undef; # slurp the whole thing into one string
  160   open my $dh, "<", $fileName
  161     or die "failed to read file $fileName: $!";
  162   my $result = <$dh>;
  163   close $dh;
  164   return force_eoln($result);
  165 }
  166 
  167 sub readDirectory($) {
  168   my $dirName = shift;
  169   opendir my $dh, $dirName
  170     or die "Failed to read directory $dirName: $!";
  171   my @result = readdir $dh;
  172   close $dh;
  173   return @result;
  174 }
  175 
  176 =item @matches = listFilesRecusive($dir, $match_qr, $prune_qr, $match_full, $prune_full)
  177 
  178 Traverses the directory tree rooted at $dir, returning a list of files, named
  179 pipes, and sockets matching the regular expression $match_qr. Directories
  180 matching the regular expression $prune_qr are not visited.
  181 
  182 $match_full and $prune_full are boolean values that indicate whether $match_qr
  183 and $prune_qr, respectively, should be applied to the bare directory entry
  184 (false) or to the path to the directory entry relative to $dir.
  185 
  186 @matches is a list of paths relative to $dir.
  187 
  188 =cut
  189 
  190 sub listFilesRecursiveHelper($$$$$$);
  191 sub listFilesRecursive($;$$$$) {
  192   my ($dir, $match_qr, $prune_qr, $match_full, $prune_full) = @_;
  193   return listFilesRecursiveHelper($dir, "", $match_qr, $prune_qr, $match_full, $prune_full);
  194 }
  195 
  196 sub listFilesRecursiveHelper($$$$$$) {
  197   my ($base_dir, $curr_dir, $match_qr, $prune_qr, $match_full, $prune_full) = @_;
  198 
  199   my $full_dir = "$base_dir/$curr_dir";
  200 
  201   my @dir_contents = readDirectory($full_dir);
  202 
  203   my @matches;
  204 
  205   foreach my $dir_entry (@dir_contents) {
  206     my $full_path = "$full_dir/$dir_entry";
  207 
  208     # determine whether the entry is a directory or a file, taking into account the
  209     my $is_dir;
  210     my $is_file;
  211     if (-l $full_path) {
  212       my $link_target = "$full_dir/" . readlink $full_path;
  213       if ($link_target) {
  214         $is_dir = -d $link_target;
  215         $is_file = !$is_dir && -f $link_target || -p $link_target || -S $link_target;
  216       } else {
  217         warn "Couldn't resolve symlink $full_path: $!";
  218       }
  219     } else {
  220       $is_dir = -d $full_path;
  221       $is_file = !$is_dir && -f $full_path || -p $full_path || -S $full_path;
  222     }
  223 
  224     if ($is_dir) {
  225       # standard things to skip
  226       next if $dir_entry eq ".";
  227       next if $dir_entry eq "..";
  228 
  229       # skip unreadable directories (and broken symlinks, incidentally)
  230       unless (-r $full_path) {
  231         warn "Directory/symlink $full_path not readable";
  232         next;
  233       }
  234 
  235       # check $prune_qr
  236       my $subdir = ($curr_dir eq "") ? $dir_entry : "$curr_dir/$dir_entry";
  237       if (defined $prune_qr) {
  238         my $prune_string = $prune_full ? $subdir : $dir_entry;
  239         next if $prune_string =~ m/$prune_qr/;
  240       }
  241 
  242       # everything looks good, time to recurse!
  243       push @matches, listFilesRecursiveHelper($base_dir, $subdir, $match_qr, $prune_qr, $match_full, $prune_full);
  244     } elsif ($is_file) {
  245       my $file = ($curr_dir eq "") ? $dir_entry : "$curr_dir/$dir_entry";
  246       my $match_string = $match_full ? $file : $dir_entry;
  247       if (not defined $match_string or $match_string =~ m/$match_qr/) {
  248         push @matches, $file;
  249       }
  250     } else {
  251       # otherwise, it's a character device or a block device, and i don't
  252       # suppose we want anything to do with those ;-)
  253     }
  254   }
  255 
  256   return @matches;
  257 }
  258 
  259 # A very useful macro for making sure that all of the directories to a file have
  260 # been constructed.
  261 sub surePathToFile($$) {
  262   # constructs intermediate directories enroute to the file
  263   # the input path must be the path relative to this starting directory
  264   my $start_directory = shift;
  265   my $path = shift;
  266   my $delim = "/";
  267   unless ($start_directory and $path ) {
  268     warn "missing directory<br> surePathToFile  start_directory   path ";
  269     return '';
  270   }
  271   # use the permissions/group on the start directory itself as a template
  272   my ($perms, $groupID) = (stat $start_directory)[2,5];
  273   #warn "&urePathToTmpFile: perms=$perms groupID=$groupID\n";
  274 
  275   # if the path starts with $start_directory (which is permitted but optional) remove this initial segment
  276   $path =~ s|^$start_directory|| if $path =~ m|^$start_directory|;
  277 
  278 
  279   # find the nodes on the given path
  280         my @nodes = split("$delim",$path);
  281 
  282   # create new path
  283   $path = $start_directory; #convertPath("$tmpDirectory");
  284 
  285   while (@nodes>1) {  # the last node is the file name
  286     $path = $path . shift (@nodes) . "/"; #convertPath($path . shift (@nodes) . "/");
  287     #FIXME  this make directory command may not be fool proof.
  288     unless (-e $path) {
  289       mkdir($path, $perms)
  290         or warn "Failed to create directory $path with start directory $start_directory ";
  291     }
  292 
  293   }
  294 
  295   $path = $path . shift(@nodes); #convertPath($path . shift(@nodes));
  296   return $path;
  297 }
  298 
  299 sub makeTempDirectory($$) {
  300   my ($parent, $basename) = @_;
  301   # Loop until we're able to create a directory, or it fails for some
  302   # reason other than there already being something there.
  303   my $triesRemaining = MKDIR_ATTEMPTS;
  304   my ($fullPath, $success);
  305   do {
  306     my $suffix = join "", map { ('A'..'Z','a'..'z','0'..'9')[int rand 62] } 1 .. 8;
  307     $fullPath = "$parent/$basename.$suffix";
  308     $success = mkdir $fullPath;
  309   } until ($success or not $!{EEXIST});
  310   die "Failed to create directory $fullPath: $!"
  311     unless $success;
  312   return $fullPath;
  313 }
  314 
  315 sub removeTempDirectory($) {
  316   my ($dir) = @_;
  317   rmtree($dir, 0, 0);
  318 }
  319 
  320 =item path_is_subdir($path, $dir, $allow_relative)
  321 
  322 Ensures that $path refers to a location "inside" $dir. If $allow_relative is
  323 true and $path is not absoulte, it is assumed to be relative to $dir.
  324 
  325 The method of checking is rather rudimentary at the moment. First, upreferences
  326 ("..") are disallowed, in $path, then it is checked to make sure that some
  327 prefix of it matches $dir.
  328 
  329 If either of these checks fails, a false value is returned. Otherwise, a true
  330 value is returned.
  331 
  332 =cut
  333 
  334 sub path_is_subdir($$;$) {
  335   my ($path, $dir, $allow_relative) = @_;
  336 
  337   unless ($path =~ /^\//) {
  338     if ($allow_relative) {
  339       $path = "$dir/$path";
  340     } else {
  341       return 0;
  342     }
  343   }
  344 
  345   $path = File::Spec->canonpath($path);
  346   $path .= "/" unless $path =~ m|/$|;
  347   return 0 if $path =~ m#(^\.\.$|^\.\./|/\.\./|/\.\.$)#;
  348 
  349   $dir = File::Spec->canonpath($dir);
  350   $dir .= "/" unless $dir =~ m|/$|;
  351   return 0 unless $path =~ m|^$dir|;
  352 
  353   return 1;
  354 }
  355 
  356 =back
  357 
  358 =cut
  359 
  360 ################################################################################
  361 # Date/time processing
  362 ################################################################################
  363 
  364 =head2 Date/time processing
  365 
  366 =over
  367 
  368 =item $dateTime = parseDateTime($string, $display_tz)
  369 
  370 Parses $string as a datetime. If $display_tz is given, $string is assumed to be
  371 in that timezone. Otherwise, the server's timezone is used. The result,
  372 $dateTime, is an integer UNIX datetime (epoch) in the server's timezone.
  373 
  374 =cut
  375 
  376 # This is a modified version of the subroutine of the same name from WeBWorK
  377 # 1.9.05's scripts/FILE.pl (v1.13). It has been modified to understand time
  378 # zones. The time zone specification must appear at the end of the string and be
  379 # preceded by whitespace. The return value is a list consisting of the following
  380 # elements:
  381 #
  382 #     ($second, $minute, $hour, $day, $month, $year, $zone)
  383 #
  384 # $second, $minute, $hour, $day, and $month are zero-indexed. $year is the
  385 # number of years since 1900. $zone is a string (hopefully) representing the
  386 # time zone.
  387 #
  388 # Error handling has also been improved. Exceptions are now thrown for errors,
  389 # and more information is given about the nature of errors.
  390 #
  391 sub unformatDateAndTime {
  392   my ($string) = @_;
  393   my $orgString = $string;
  394 
  395   $string =~ s|^\s+||;
  396   $string =~ s|\s+$||;
  397   $string =~ s|at| at |i; ## OK if forget to enter spaces or use wrong case
  398   $string =~ s|AM| AM|i;  ## OK if forget to enter spaces or use wrong case
  399   $string =~ s|PM| PM|i;  ## OK if forget to enter spaces or use wrong case
  400   $string =~ s|,| at |; ## start translating old form of date/time to new form
  401 
  402   # case where the at is missing: MM/DD/YYYY at HH:MM AMPM ZONE
  403   unformatDateAndTime_error($orgString, "The 'at' appears to be missing.")
  404     if $string =~ m|^\s*[\/\d]+\s+[:\d]+|;
  405 
  406   my ($date, $at, $time, $AMPM, $TZ) = split /\s+/, $string;
  407 
  408   unformatDateAndTime_error($orgString, "The date and/or time appear to be missing.", $date, $time, $AMPM, $TZ)
  409     unless defined $date and defined $at and defined $time;
  410 
  411   # deal with military time
  412   unless ($time =~ /:/) {
  413     {  ##bare block for 'case" structure
  414       $time =~ /(\d\d)(\d\d)/;
  415       my $tmp_hour = $1;
  416       my $tmp_min = $2;
  417       if ($tmp_hour eq '00') {$time = "12:$tmp_min"; $AMPM = 'AM';last;}
  418       if ($tmp_hour eq '12') {$time = "12:$tmp_min"; $AMPM = 'PM';last;}
  419       if ($tmp_hour < 12) {$time = "$tmp_hour:$tmp_min"; $AMPM = 'AM';last;}
  420       if ($tmp_hour < 24) {
  421         $tmp_hour = $tmp_hour - 12;
  422         $time = "$tmp_hour:$tmp_min";
  423         $AMPM = 'PM';
  424       }
  425     }  ##end of bare block for 'case" structure
  426 
  427   }
  428 
  429   # default value for $AMPM
  430   $AMPM = "AM" unless defined $AMPM;
  431 
  432   my ($mday, $mon, $year, $wday, $yday, $sec, $pm, $min, $hour);
  433   $sec=0;
  434   $time =~ /^([0-9]+)\s*\:\s*([0-9]*)/;
  435   $min=$2;
  436   $hour = $1;
  437   unformatDateAndTime_error($orgString, "Hour must be in the range [1,12].", $date, $time, $AMPM, $TZ)
  438     if $hour < 1 or $hour > 12;
  439   unformatDateAndTime_error($orgString, "Minute must be in the range [0-59].", $date, $time, $AMPM, $TZ)
  440     if $min < 0 or $min > 59;
  441   $pm = 0;
  442   $pm = 12 if ($AMPM =~/PM/ and $hour < 12);
  443   $hour += $pm;
  444   $hour = 0 if ($AMPM =~/AM/ and $hour == 12);
  445   $date =~  m|([0-9]+)\s*/\s*([0-9]+)/\s*([0-9]+)|;
  446   $mday =$2;
  447   $mon=($1-1);
  448   unformatDateAndTime_error($orgString, "Day must be in the range [1,31].", $date, $time, $AMPM, $TZ)
  449     if $mday < 1 or $mday > 31;
  450   unformatDateAndTime_error($orgString, "Month must be in the range [1,12].", $date, $time, $AMPM, $TZ)
  451     if $mon < 0 or $mon > 11;
  452   $year=$3;
  453   $wday="";
  454   $yday="";
  455   return ($sec, $min, $hour, $mday, $mon, $year, $TZ);
  456 }
  457 
  458 sub unformatDateAndTime_error {
  459 
  460   if (@_ > 2) {
  461     my ($orgString, $error, $date, $time, $AMPM, $TZ) = @_;
  462     $date = "(undefined)" unless defined $date;
  463     $time = "(undefined)" unless defined $time;
  464     $AMPM = "(undefined)" unless defined $AMPM;
  465     $TZ   = "(undefined)" unless defined $TZ;
  466     die "Incorrect date/time format \"$orgString\": $error\n",
  467       "Correct format is MM/DD/YY at HH:MM AMPM ZONE\n",
  468       "\tdate = $date\n",
  469       "\ttime = $time\n",
  470       "\tampm = $AMPM\n",
  471       "\tzone = $TZ\n";
  472   } else {
  473     my ($orgString, $error) = @_;
  474     die "Incorrect date/time format \"$orgString\": $error\n",
  475       "Correct format is MM/DD/YY at HH:MM AMPM ZONE\n";
  476   }
  477 }
  478 
  479 sub parseDateTime($;$) {
  480   my ($string, $display_tz) = @_;
  481   warn "time zone not defined".caller() unless defined($display_tz);
  482   $display_tz ||= "local";
  483   #warn "parseDateTime('$string', '$display_tz')\n";
  484 
  485   # use WeBWorK 1 date parsing routine
  486   my ($second, $minute, $hour, $day, $month, $year, $zone) = unformatDateAndTime($string);
  487   my $zone_str = defined $zone ? $zone : "UNDEF";
  488   #warn "\tunformatDateAndTime: $second $minute $hour $day $month $year $zone_str\n";
  489 
  490   # DateTime expects month 1-12, not 0-11
  491   $month++;
  492 
  493   # Do what Time::Local does to ambiguous years
  494   {
  495     my $ThisYear     = (localtime())[5]; # FIXME: should be relative to $string's timezone
  496     my $Breakpoint   = ($ThisYear + 50) % 100;
  497     my $NextCentury  = $ThisYear - $ThisYear % 100;
  498        $NextCentury += 100 if $Breakpoint < 50;
  499     my $Century      = $NextCentury - 100;
  500     my $SecOff       = 0;
  501 
  502     if ($year >= 1000) {
  503       # leave alone
  504     } elsif ($year < 100 and $year >= 0) {
  505       $year += ($year > $Breakpoint) ? $Century : $NextCentury;
  506       $year += 1900;
  507     } else {
  508       $year += 1900;
  509     }
  510   }
  511 
  512   my $epoch;
  513 
  514   if (defined $zone and $zone ne "") {
  515     if (DateTime::TimeZone->is_valid_name($zone)) {
  516       #warn "\t\$zone is valid according to DateTime::TimeZone\n";
  517 
  518       my $dt = new DateTime(
  519         year      => $year,
  520         month     => $month,
  521         day       => $day,
  522         hour      => $hour,
  523         minute    => $minute,
  524         second    => $second,
  525         time_zone => $zone,
  526       );
  527       #warn "\t\$dt = ", $dt->strftime(DATE_FORMAT), "\n";
  528 
  529       $epoch = $dt->epoch;
  530       #warn "\t\$dt->epoch = $epoch\n";
  531     } else {
  532       #warn "\t\$zone is invalid according to DateTime::TimeZone, so we ask Time::Zone\n";
  533 
  534       # treat the date/time as UTC
  535       my $dt = new DateTime(
  536         year      => $year,
  537         month     => $month,
  538         day       => $day,
  539         hour      => $hour,
  540         minute    => $minute,
  541         second    => $second,
  542         time_zone => "UTC",
  543       );
  544       #warn "\t\$dt = ", $dt->strftime(DATE_FORMAT), "\n";
  545 
  546       # convert to an epoch value
  547       my $utc_epoch = $dt->epoch
  548         or die "Date/time '$string' not representable as an epoch. Get more bits!\n";
  549       #warn "\t\$utc_epoch = $utc_epoch\n";
  550 
  551       # get offset for supplied timezone and utc_epoch
  552       my $offset = tz_offset($zone, $utc_epoch) or die "Time zone '$zone' not recognized.\n";
  553       #warn "\t\$zone is valid according to Time::Zone (\$offset = $offset)\n";
  554 
  555       #$epoch = $utc_epoch + $offset;
  556       ##warn "\t\$epoch = \$utc_epoch + \$offset = $epoch\n";
  557 
  558       $dt->subtract(seconds => $offset);
  559       #warn "\t\$dt - \$offset = ", $dt->strftime(DATE_FORMAT), "\n";
  560 
  561       $epoch = $dt->epoch;
  562       #warn "\t\$epoch = $epoch\n";
  563     }
  564   } else {
  565     #warn "\t\$zone not supplied, using \$display_tz\n";
  566 
  567     my $dt = new DateTime(
  568       year      => $year,
  569       month     => $month,
  570       day       => $day,
  571       hour      => $hour,
  572       minute    => $minute,
  573       second    => $second,
  574       time_zone => $display_tz,
  575     );
  576     #warn "\t\$dt = ", $dt->strftime(DATE_FORMAT), "\n";
  577 
  578     $epoch = $dt->epoch;
  579     #warn "\t\$epoch = $epoch\n";
  580   }
  581 
  582   return $epoch;
  583 }
  584 
  585 =item $string = formatDateTime($dateTime, $display_tz)
  586 
  587 Formats the UNIX datetime $dateTime in the standard WeBWorK datetime format.
  588 $dateTime is assumed to be in the server's time zone. If $display_tz is given,
  589 the datetime is converted from the server's timezone to the timezone specified.
  590 
  591 =cut
  592 
  593 sub formatDateTime($;$) {
  594   my ($dateTime, $display_tz) = @_;
  595   warn "not defined formatDateTime('$dateTime', '$display_tz') ",join(" ",caller(2)) unless  $display_tz and  $dateTime;
  596   $display_tz ||= "local";
  597 
  598   my $dt = DateTime->from_epoch(epoch => $dateTime, time_zone => $display_tz);
  599   #warn "\t\$dt = ", $dt->strftime(DATE_FORMAT), "\n";
  600   return $dt->strftime(DATE_FORMAT);
  601 }
  602 
  603 =item $string = textDateTime($string_or_dateTime)
  604 
  605 Accepts a UNIX datetime or a formatted string, returns a formatted string.
  606 
  607 =cut
  608 
  609 sub textDateTime($) {
  610   return ($_[0] =~ m/^\d*$/) ? formatDateTime($_[0]) : $_[0];
  611 }
  612 
  613 =item $dateTIme = intDateTime($string_or_dateTime)
  614 
  615 Accepts a UNIX datetime or a formatted string, returns a UNIX datetime.
  616 
  617 =cut
  618 
  619 sub intDateTime($) {
  620   return ($_[0] =~ m/^\d*$/) ?  $_[0] : parseDateTime($_[0]);
  621 }
  622 
  623 =item $timeinsec = timeToSec($time)
  624 
  625 Makes a stab at converting a time (with a possible unit) into a number of
  626 seconds.
  627 
  628 =cut
  629 
  630 sub timeToSec($) {
  631     my $t = shift();
  632     if ( $t =~ /^(\d+)\s+(\S+)\s*$/ ) {
  633   my ( $val, $unit ) = ( $1, $2 );
  634   if ( $unit =~ /month/i || $unit =~ /mon/i ) {
  635       $val *= 18144000;  # this assumes 30 days/month
  636   } elsif ( $unit =~ /week/i || $unit =~ /wk/i ) {
  637       $val *= 604800;
  638   } elsif ( $unit =~ /day/i || $unit =~ /dy/i ) {
  639       $val *= 86400;
  640   } elsif ( $unit =~ /hour/i || $unit =~ /hr/i ) {
  641       $val *= 3600;
  642   } elsif ( $unit =~ /minute/i || $unit =~ /min/i ) {
  643       $val *= 60;
  644   } elsif ( $unit =~ /second/i || $unit =~ /sec/i || $unit =~ /^s$/i ) {
  645       # do nothing
  646   } else {
  647       warn("Unrecognized time unit $unit.\nAssuming seconds.\n");
  648   }
  649   return $val;
  650     } elsif ( $t =~ /^(\d+)$/ ) {
  651   return $t;
  652     } else {
  653   warn("Unrecognized time interval: $t\n");
  654   return 0;
  655     }
  656 }
  657 
  658 =item before($time, $now)
  659 
  660 True if $now is less than $time. If $now is not specified, the value of time()
  661 is used.
  662 
  663 =cut
  664 
  665 sub before  { return (@_==2) ? $_[1] < $_[0] : time < $_[0] }
  666 
  667 =item after($time, $now)
  668 
  669 True if $now is greater than $time. If $now is not specified, the value of time()
  670 is used.
  671 
  672 =cut
  673 
  674 sub after   { return (@_==2) ? $_[1] > $_[0] : time > $_[0] }
  675 
  676 =item between($start, $end, $now)
  677 
  678 True if $now is greater than or equal to $start and less than or equal to $end.
  679 If $now is not specified, the value of time() is used.
  680 
  681 =cut
  682 
  683 sub between { my $t = (@_==3) ? $_[2] : time; return $t >= $_[0] && $t <= $_[1] }
  684 
  685 =back
  686 
  687 =cut
  688 
  689 ################################################################################
  690 # Logging
  691 ################################################################################
  692 
  693 sub writeLog($$@) {
  694   my ($ce, $facility, @message) = @_;
  695   unless ($ce->{webworkFiles}->{logs}->{$facility}) {
  696     warn "There is no log file for the $facility facility defined.\n";
  697     return;
  698   }
  699   my $logFile = $ce->{webworkFiles}->{logs}->{$facility};
  700   surePathToFile($ce->{webworkDirs}->{root}, $logFile);
  701   local *LOG;
  702   if (open LOG, ">>", $logFile) {
  703     print LOG "[", time2str("%a %b %d %H:%M:%S %Y", time), "] @message\n";
  704     close LOG;
  705   } else {
  706     warn "failed to open $logFile for writing: $!";
  707   }
  708 }
  709 
  710 sub writeCourseLog($$@) {
  711   my ($ce, $facility, @message) = @_;
  712   unless ($ce->{courseFiles}->{logs}->{$facility}) {
  713     warn "There is no course log file for the $facility facility defined.\n";
  714     return;
  715   }
  716   my $logFile = $ce->{courseFiles}->{logs}->{$facility};
  717   surePathToFile($ce->{courseDirs}->{root}, $logFile);
  718   local *LOG;
  719   if (open LOG, ">>", $logFile) {
  720     print LOG "[", time2str("%a %b %d %H:%M:%S %Y", time), "] @message\n";
  721     close LOG;
  722   } else {
  723     warn "failed to open $logFile for writing: $!";
  724   }
  725 }
  726 
  727 # $ce - a WeBWork::CourseEnvironment object
  728 # $function - fully qualified function name
  729 # $details - any information, do not use the characters '[' or ']'
  730 # $beginEnd - the string "begin", "intermediate", or "end"
  731 # use the intermediate step begun or completed for INTERMEDIATE
  732 # use an empty string for $details when calling for END
  733 # Information printed in format:
  734 # [formatted date & time ] processID unixTime BeginEnd $function  $details
  735 sub writeTimingLogEntry($$$$) {
  736   my ($ce, $function, $details, $beginEnd) = @_;
  737   $beginEnd = ($beginEnd eq "begin") ? ">" : ($beginEnd eq "end") ? "<" : "-";
  738   writeLog($ce, "timing", "$$ ".time." $beginEnd $function [$details]");
  739 }
  740 
  741 ################################################################################
  742 # Data munging
  743 ################################################################################
  744 ## Utility function to trim whitespace off the start and end of its input
  745 sub trim_spaces {
  746   my $in = shift;
  747   return '' unless $in;  # skip blank spaces
  748   $in =~ s/^\s*(.*?)\s*$/$1/;
  749   return($in);
  750 }
  751 sub list2hash(@) {
  752   map {$_ => "0"} @_;
  753 }
  754 
  755 sub refBaseType($) {
  756   my $ref = shift;
  757   $ref =~ m/(\w+)\(/; # this might not be robust...
  758   return $1;
  759 }
  760 
  761 sub ref2string($;$);
  762 sub ref2string($;$) {
  763   my $ref = shift;
  764   my $dontExpand = shift || {};
  765   my $refType = ref $ref;
  766   my $result;
  767   if ($refType and not $dontExpand->{$refType}) {
  768     my $baseType = refBaseType($ref);
  769     $result .= '<font size="1" color="grey">' . $refType;
  770     $result .= " ($baseType)" if $baseType and $refType ne $baseType;
  771     $result .= ":</font><br>";
  772     $result .= '<table border="1" cellpadding="2">';
  773     if ($baseType eq "HASH") {
  774       my %hash = %$ref;
  775       foreach (sort keys %hash) {
  776         $result .= '<tr valign="top">';
  777         $result .= "<td>$_</td>";
  778         $result .= "<td>" . ref2string($hash{$_}, $dontExpand) . "</td>";
  779         $result .= "</tr>";
  780       }
  781     } elsif ($baseType eq "ARRAY") {
  782       my @array = @$ref;
  783       # special case for Problem, Set, and User objects, which are defined
  784       # using lists and contain a @FIELDS package variable:
  785       no strict 'refs';
  786       my @FIELDS = eval { @{$refType."::FIELDS"} };
  787       use strict 'refs';
  788       undef @FIELDS unless scalar @FIELDS == scalar @array and not $@;
  789       foreach (0 .. $#array) {
  790         $result .= '<tr valign="top">';
  791         $result .= "<td>$_</td>";
  792         $result .= "<td>".$FIELDS[$_]."</td>" if @FIELDS;
  793         $result .= "<td>" . ref2string($array[$_], $dontExpand) . "</td>";
  794         $result .= "</tr>";
  795       }
  796     } elsif ($baseType eq "SCALAR") {
  797       my $scalar = $$ref;
  798       $result .= '<tr valign="top">';
  799       $result .= "<td>$scalar</td>";
  800       $result .= "</tr>";
  801     } else {
  802       # perhaps a coderef? in any case, i don't feel like dealing with it!
  803       $result .= '<tr valign="top">';
  804       $result .= "<td>$ref</td>";
  805       $result .= "</tr>";
  806     }
  807     $result .= "</table>"
  808   } else {
  809     $result .= defined $ref ? $ref : '<font color="red">undef</font>';
  810   }
  811 }
  812 our $BASE64_ENCODED = 'base64_encoded:';
  813 #  use constant BASE64_ENCODED = 'base64_encoded;
  814 #  was not evaluated in the matching and substitution
  815 #  statements
  816 
  817 # sub decodeAnswers($) {
  818 #   my $string = shift;
  819 #   return unless defined $string and $string;
  820 #
  821 #   if ($string =~/^$BASE64_ENCODED/o) {
  822 #     $string =~ s/^$BASE64_ENCODED//o;
  823 #     $string = decode_base64($string);
  824 #   }
  825 #
  826 #   my @array = split m/##/, $string;
  827 #   $array[$_] =~ s/\\#\\/#/g foreach 0 .. $#array;
  828 #   push @array, "" if @array%2;
  829 #   return @array; # it's actually a hash ;)
  830 # }
  831 
  832 sub decodeAnswers($) {
  833   my $serialized = shift;
  834   return unless defined $serialized and $serialized;
  835   my $array_ref = eval{ Storable::thaw($serialized) };
  836   if ($@) {
  837     warn "problem fetching answers -- possibly left over from base64 days.  $@";
  838     return ();
  839   } else {
  840     return @{$array_ref};
  841   }
  842 }
  843 
  844 sub encodeAnswers(\%\@) {
  845   my %hash = %{shift()};
  846   my @order = @{shift()};
  847   my @ordered_hash = ();
  848   foreach my $key (@order) {
  849     push @ordered_hash, $key, $hash{$key};
  850   }
  851   return Storable::freeze( \@ordered_hash);
  852 
  853 }
  854 
  855 # sub encodeAnswers(\%\@) {
  856 #   my %hash = %{ shift() };
  857 #   my @order = @{ shift() };
  858 #   my $string = "";
  859 #   foreach my $name (@order) {
  860 #     my $value = defined $hash{$name} ? $hash{$name} : "";
  861 #     $name  =~ s/#/\\#\\/g; # this is a WEIRD way to escape things
  862 #     $value =~ s/#/\\#\\/g; # and it's not my fault!
  863 #     if ($value =~ m/\\$/) {
  864 #       # if the value ends with a backslash, string2hash will
  865 #       # interpret that as a normal escape sequence (not part
  866 #       # of the weird pound escape sequence) if the next
  867 #       # character is &. So we have to protect against this.
  868 #       # will adding a spcae at the end of the last answer
  869 #       # hurt anything? i don't think so...
  870 #       $value .= " ";
  871 #     }
  872 #     $string .= "$name##$value##"; # this is also not my fault
  873 #   }
  874 #   $string =~ s/##$//; # remove last pair of hashs
  875 #
  876 #   $string = $BASE64_ENCODED.encode_base64($string, "");
  877 #   # Empty string in second argument prevents end-of-line characters from being used.
  878 #   # This is nice for examining database contents manually since it prevents newlines
  879 #   # from being introduced into database records.
  880 #
  881 #   return $string;
  882 # }
  883 
  884 sub max(@) {
  885   my $soFar;
  886   foreach my $item (@_) {
  887     $soFar = $item unless defined $soFar;
  888     if ($item > $soFar) {
  889       $soFar = $item;
  890     }
  891   }
  892   return defined $soFar ? $soFar : 0;
  893 }
  894 
  895 sub pretty_print_rh($) {
  896   my $rh = shift;
  897   foreach my $key (sort keys %{$rh})  {
  898     warn "  $key => ",$rh->{$key},"\n";
  899   }
  900 }
  901 
  902 sub cryptPassword($) {
  903   my ($clearPassword) = @_;
  904   my $salt = join("", ('.','/','0'..'9','A'..'Z','a'..'z')[rand 64, rand 64]);
  905   my $cryptPassword = crypt($clearPassword, $salt);
  906   return $cryptPassword;
  907 }
  908 
  909 # from the Perl Cookbook, first edition, page 25:
  910 sub dequote($) {
  911   local $_ = shift;
  912   my ($white, $leader); # common whitespace and common leading string
  913   if (/^\s*(?:([^\w\s]+)(\s*).*\n)(?:\s*\1\2?.*\n)+$/) {
  914     ($white, $leader) = ($2, quotemeta($1));
  915   } else {
  916     ($white, $leader) = (/^(\s+)/, '');
  917   }
  918   s/^\s*?$leader(?:$white)?//gm;
  919   return $_;
  920 }
  921 
  922 sub undefstr($@) {
  923   map { defined $_ ? $_ : $_[0] } @_[1..$#_];
  924 }
  925 
  926 
  927 # shuffle an array in place
  928 # Perl Cookbook, Recipe 4.17. Randomizing an Array
  929 sub fisher_yates_shuffle {
  930   my $array = shift;
  931   my $i;
  932   for ($i = @$array; --$i; ) {
  933     my $j = int rand ($i+1);
  934     next if $i == $j;
  935     @$array[$i,$j] = @$array[$j,$i];
  936   }
  937 }
  938 
  939 sub constituency_hash {
  940   my $hash = {};
  941   @$hash{@_} = ();
  942   return $hash;
  943 }
  944 
  945 ################################################################################
  946 # Sorting
  947 ################################################################################
  948 
  949 # p. 101, Camel, 3rd ed.
  950 # The <=> and cmp operators return -1 if the left operand is less than the
  951 # right operand, 0 if they are equal, and +1 if the left operand is greater
  952 # than the right operand.
  953 #
  954 # FIXME: I've added the ability to do multiple field sorts, below; I'm
  955 #    leaving this code, commented out, in case there's a good reason to
  956 #    revert to this and do multiple field sorts differently.  -glr 2007/03/05
  957 # sub sortByName($@) {
  958 #   my ($field, @items) = @_;
  959 #   return sort {
  960 #     my @aParts = split m/(?<=\D)(?=\d)|(?<=\d)(?=\D)/, defined $field ? $a->$field : $a;
  961 #     my @bParts = split m/(?<=\D)(?=\d)|(?<=\d)(?=\D)/, defined $field ? $b->$field : $b;
  962 #     while (@aParts and @bParts) {
  963 #       my $aPart = shift @aParts;
  964 #       my $bPart = shift @bParts;
  965 #       my $aNumeric = $aPart =~ m/^\d*$/;
  966 #       my $bNumeric = $bPart =~ m/^\d*$/;
  967 
  968 #       # numbers should come before words
  969 #       return -1 if     $aNumeric and not $bNumeric;
  970 #       return +1 if not $aNumeric and     $bNumeric;
  971 
  972 #       # both have the same type
  973 #       if ($aNumeric and $bNumeric) {
  974 #         next if $aPart == $bPart; # check next pair
  975 #         return $aPart <=> $bPart; # compare numerically
  976 #       } else {
  977 #         next if $aPart eq $bPart; # check next pair
  978 #         return $aPart cmp $bPart; # compare lexicographically
  979 #       }
  980 #     }
  981 #     return +1 if @aParts; # a has more sections, should go second
  982 #     return -1 if @bParts; # a had fewer sections, should go first
  983 #   } @items;
  984 # }
  985 
  986 sub sortByName($@) {
  987   my ($field, @items) = @_;
  988 
  989   my %itemsByIndex = ();
  990   if ( ref( $field ) eq 'ARRAY' ) {
  991     foreach my $item ( @items ) {
  992       my $key = '';
  993       foreach ( @$field ) {
  994             $key .= $item->$_;  # in this case we assume
  995       }                           #    all entries in @$field
  996       $itemsByIndex{$key} = $item;  #  are defined.
  997         }
  998   } else {
  999       %itemsByIndex = map {(defined $field)?$_->$field:$_ => $_} @items;
 1000   }
 1001 
 1002   my @sKeys = sort {
 1003     my @aParts = split m/(?<=\D)(?=\d)|(?<=\d)(?=\D)/, $a;
 1004     my @bParts = split m/(?<=\D)(?=\d)|(?<=\d)(?=\D)/, $b;
 1005 
 1006     while (@aParts and @bParts) {
 1007       my $aPart = shift @aParts;
 1008       my $bPart = shift @bParts;
 1009       my $aNumeric = $aPart =~ m/^\d*$/;
 1010       my $bNumeric = $bPart =~ m/^\d*$/;
 1011 
 1012       # numbers should come before words
 1013       return -1 if     $aNumeric and not $bNumeric;
 1014       return +1 if not $aNumeric and     $bNumeric;
 1015 
 1016       # both have the same type
 1017       if ($aNumeric and $bNumeric) {
 1018         next if $aPart == $bPart; # check next pair
 1019         return $aPart <=> $bPart; # compare numerically
 1020       } else {
 1021         next if $aPart eq $bPart; # check next pair
 1022         return $aPart cmp $bPart; # compare lexicographically
 1023       }
 1024     }
 1025     return +1 if @aParts; # a has more sections, should go second
 1026     return -1 if @bParts; # a had fewer sections, should go first
 1027   } (keys %itemsByIndex);
 1028 
 1029   return map{$itemsByIndex{$_}} @sKeys;
 1030 }
 1031 
 1032 ################################################################################
 1033 # Validate strings and labels
 1034 ################################################################################
 1035 
 1036 sub not_blank ($) {     # check that a string exists and is not blank
 1037   my $str = shift;
 1038   return( defined($str) and $str =~/\S/ );
 1039 }
 1040 
 1041 ###########################################################
 1042     # If things have worked so far determine if the file might be accompanied by auxiliary files
 1043 
 1044     #
 1045 sub has_aux_files ($) { #  determine whether a question has auxiliary files
 1046                         # a path ending in    foo/foo.pg  is assumed to contain auxilliary files
 1047     my $path = shift;
 1048     if ( not_blank($path) ) {
 1049           my ($dir, $prob) = $path =~ m|([^/]+)/([^/]+)\.pg$|;  # must be a problem file ending in .pg
 1050       return 1 if (defined($dir) and defined ($prob) and $dir eq $prob);
 1051     } else {
 1052       warn "This subroutine cannot handle empty paths: |$path|",caller();
 1053     }
 1054     return 0;    # no aux files with this .pg file
 1055 
 1056 }
 1057 
 1058 1;