View of /trunk/webwork2/lib/WeBWorK/Utils.pm

    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   dbDecode
   27   dbEncode
   28   decodeAnswers
   29   encodeAnswers
   30   ref2string
   31 );
   32 
   33 sub runtime_use($) {
   34   return unless @_;
   35   eval "package Main; require $_[0]; import $_[0]";
   36   die $@ if $@;
   37 }
   38 
   39 sub readFile($) {
   40   my $fileName = shift;
   41   local *INPUTFILE;
   42   open INPUTFILE, "<", $fileName
   43     or die "Failed to read $fileName: $!";
   44   local $/ = undef;
   45   my $result = <INPUTFILE>;
   46   close INPUTFILE;
   47   return $result;
   48 }
   49 
   50 sub formatDateTime($) {
   51   my $dateTime = shift;
   52   # "standard" WeBWorK date/time format (for set definition files):
   53   # %m  month number, starting with 01
   54   # %d  numeric day of the month, with leading zeros (eg 01..31)
   55   # %y  year (2 digits)
   56   # %I  hour, 12 hour clock, leading 0's)
   57   # %M  minute, leading 0's
   58   # %P  am or pm (Yes %p and %P are backwards :)
   59   return time2str "%m/%d/%y %I:%M%P", $dateTime;
   60 }
   61 
   62 sub parseDateTime($) {
   63   my $string = shift;
   64   return str2time $string;
   65 }
   66 
   67 #sub writeLog($$$) {
   68 # my ($ce, $facility, $message) = @_;
   69 # die "There is no log file for $facility defined."
   70 #   unless $ce->{webworkFiles}->{logs}->{$facility};
   71 # my $logFile = $ce->{webworkFiles}->{logs}->{$facility};
   72 # local *LOG;
   73 # open LOG, "<<", $logFile
   74 #   of die "failed to open $logFile for writing: $!";
   75 # print LOG $message;
   76 # close LOG;
   77 #}
   78 
   79 # -----
   80 
   81 sub dbDecode($) {
   82   my $string = shift;
   83   return unless defined $string and $string;
   84   my %hash = $string =~ /(.*?)(?<!\\)=(.*?)(?:(?<!\\)&|$)/g;
   85   $hash{$_} =~ s/\\(&|=)/$1/g foreach keys %hash; # unescape & and =
   86   return %hash;
   87 }
   88 
   89 sub dbEncode(@) {
   90   my %hash = @_;
   91   my $string;
   92   foreach (keys %hash) {
   93     $hash{$_} = "" unless defined $hash{$_}; # promote undef to ""
   94     $hash{$_} =~ s/(=|&)/\\$1/g; # escape & and =
   95     $string .= "$_=$hash{$_}&";
   96   }
   97   chop $string; # remove final '&' from string for old code :p
   98   return $string;
   99 }
  100 
  101 sub decodeAnswers($) {
  102   my $string = shift;
  103   return unless defined $string and $string;
  104   my @array = split m/##/, $string;
  105   $array[$_] =~ s/\\#\\/#/g foreach 0 .. $#array;
  106   push @array, "" if @array%2;
  107   return @array; # it's actually a hash ;)
  108 }
  109 
  110 sub encodeAnswers(\%\@) {
  111   my %hash = %{ shift() };
  112   my @order = @{ shift() };
  113   my $string;
  114   foreach my $name (@order) {
  115     my $value = defined $hash{$name} ? $hash{$name} : "";
  116     $name  =~ s/#/\\#\\/g; # this is a WEIRD way to escape things
  117     $value =~ s/#/\\#\\/g; # and it's not my fault!
  118     $string .= "$name##$value##"; # this is also not my fault
  119   }
  120   $string =~ s/##$//; # remove last pair of hashs
  121   return $string;
  122 }
  123 
  124 # -----
  125 
  126 sub ref2string($;$);
  127 sub ref2string($;$) {
  128   my $ref = shift;
  129   my $dontExpand = shift || {};
  130   my $refType = ref $ref;
  131   my $result;
  132   if ($refType and not $dontExpand->{$refType}) {
  133     my $baseType = refBaseType($ref);
  134     $result .= '<font size="1" color="grey">' . $refType;
  135     $result .= " ($baseType)" if $baseType and $refType ne $baseType;
  136     $result .= ":</font><br>";
  137     $result .= '<table border="1" cellpadding="2">';
  138     if ($baseType eq "HASH") {
  139       my %hash = %$ref;
  140       foreach (sort keys %hash) {
  141         $result .= '<tr valign="top">';
  142         $result .= "<td>$_</td>";
  143         $result .= "<td>" . ref2string($hash{$_}, $dontExpand) . "</td>";
  144         $result .= "</tr>";
  145       }
  146     } elsif ($baseType eq "ARRAY") {
  147       my @array = @$ref;
  148       # special case for Problem, Set, and User objects, which are defined
  149       # using lists and contain a @FIELDS package variable:
  150       no strict 'refs';
  151       my @FIELDS = eval { @{$refType."::FIELDS"} };
  152       use strict 'refs';
  153       undef @FIELDS unless scalar @FIELDS == scalar @array and not $@;
  154       foreach (0 .. $#array) {
  155         $result .= '<tr valign="top">';
  156         $result .= "<td>$_</td>";
  157         $result .= "<td>".$FIELDS[$_]."</td>" if @FIELDS;
  158         $result .= "<td>" . ref2string($array[$_], $dontExpand) . "</td>";
  159         $result .= "</tr>";
  160       }
  161     } elsif ($baseType eq "SCALAR") {
  162       my $scalar = $$ref;
  163       $result .= '<tr valign="top">';
  164       $result .= "<td>$scalar</td>";
  165       $result .= "</tr>";
  166     } else {
  167       # perhaps a coderef? in any case, i don't feel like dealing with it!
  168       $result .= '<tr valign="top">';
  169       $result .= "<td>$ref</td>";
  170       $result .= "</tr>";
  171     }
  172     $result .= "</table>"
  173   } else {
  174     $result .= defined $ref ? $ref : '<font color="red">undef</font>';
  175   }
  176 }
  177 
  178 sub refBaseType($) {
  179   my $ref = shift;
  180   local $SIG{__DIE__} = 'IGNORE';
  181   return "HASH"   if eval { $_ = %$ref; 1 };
  182   return "ARRAY"  if eval { $_ = @$ref; 1 };
  183   return "SCALAR" if eval { $_ = $$ref; 1 };
  184   return 0;
  185 }
  186 
  187 1;