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

    1 package WeBWorK::Form::TiedParam;
    2 use strict;
    3 use warnings;
    4 
    5 sub TIESCALAR ($$$) {
    6   my ($invocant, $f, $param) = @_;
    7   my $class = ref($invocant) || $invocant;
    8   my $self = {
    9     f => $f,
   10     param => $param,
   11   };
   12 
   13   return bless $self, $class;
   14 }
   15 
   16 sub FETCH {
   17   my $self = shift;
   18   my $f = $self->{f};
   19   my $param = $self->{param};
   20   return $f->param($param);
   21 }
   22 
   23 sub STORE {
   24   my $self = shift;
   25   my @values = @_;
   26   my $f = $self->{f};
   27   my $param = $self->{param};
   28   $f->param($param, @values);
   29 }
   30 
   31 ###
   32 
   33 package WeBWorK::Form;
   34 # This package will extract form input from an Apache::Request and provides
   35 # an interface to it.
   36 
   37 sub new {
   38   print "new called with \@_ = ( " . (join ", ", @_)  . " )\n";
   39   my ($invocant, $r) = @_;
   40   my $class = ref($invocant) || $invocant;
   41   my $self = {};
   42 
   43   return bless $self, $class;
   44 }
   45 
   46 sub new_from_paramable ($$) {
   47   my ($invocant, $r) = @_;
   48   my $class = ref($invocant) || $invocant;
   49   my $self = {};
   50 
   51   # list of param names
   52   my @params = $r->param;
   53   foreach my $key (@params) {
   54     $self->{$key} = [ $r->param($key) ];
   55   }
   56 
   57   return bless $self, $class;
   58 }
   59 
   60 sub new_test {
   61   my ($invocant, $r) = @_;
   62   my $class = ref($invocant) || $invocant;
   63   my $self = {
   64     a => [qw(aa ab ac)],
   65     b => [ "bcontents" ],
   66     c => [ "cc", "ccd" ],
   67     d => [ "what d has" ],
   68   };
   69 
   70   return bless $self, $class;
   71 }
   72 
   73 # @keys = $f->param
   74 # $value = $f->param("key")
   75 # @values = $f->param("key")
   76 # $f->param("key", "value")
   77 # $f->param(key => [qw(val1 val2 val3)]
   78 # $f->param(key => "val1", "val2", "val3");
   79 
   80 # Oh, there I go again with multiple returns all over.  To be fair,
   81 # any function that emulates CGI::param has to do a few different things
   82 # in different contexts.
   83 sub param {
   84   my ($self, $param, @values) = @_;
   85 
   86   # Called with one argument.  Return keys.
   87   if (!defined $param) {
   88     return keys %$self;
   89   }
   90 
   91   # called with three arguments.  Set a value, then fall through
   92   if (scalar(@values)) {
   93     if (ref $values[0]) {
   94       $self->{$param} = $values[0];
   95     } else {
   96       $self->{$param} = [ @values ];
   97     }
   98   }
   99 
  100   # Called with 2+ arguments.  Return requested value
  101   if (wantarray) {
  102     return @{$self->{$param}};
  103   } else {
  104     return $self->{$param}[0];
  105   }
  106 }
  107 
  108 # lparam("key") will return the same value as param("key"), but it returns
  109 # it as a scalar lvalue, so that you can assign strings or arrayrefs to the
  110 # function call like this: $form->lparam("foo") = "bar" or
  111 # $form->lparam("foo") = [qw(bar baz blah)].
  112 # This function absolutely requires 5.6, which is where :lvalue comes from.
  113 sub lparam($$) : lvalue {
  114   tie my $lvalue, 'WeBWorK::Form::TiedParam', shift, shift;
  115   $lvalue;
  116 }
  117 
  118 sub delete {
  119   my ($self, $param) = @_;
  120   CORE::delete $self->{$param};
  121 }
  122 
  123 sub Delete {
  124   my $self = shift;
  125   $self->delete(@_);
  126 }
  127 
  128 sub printable {
  129   my $self = shift;
  130   my $printedform = "";
  131   foreach my $key ($self->param) {
  132     $printedform .= "[$key]\n";
  133     foreach my $value ($self->param($key)) {
  134       $printedform .= "$value\n";
  135     }
  136     $printedform .= "\n";
  137   }
  138 
  139   return $printedform;
  140 }
  141 
  142 # This partially supports the :cgi-lib Vars() interface, a-la CGI.pm.  Not
  143 # supported is being called in scalar context, which in CGI.pm returned a
  144 # tied hashref to the original form data.  WeBWorK didn't need that, so I
  145 # didn't add it.  If you're feeling industrious...
  146 sub Vars {
  147   my $self = shift;
  148   my %varsFormat = ();
  149   foreach my $key ($self->param) {
  150     $varsFormat{$key} = join "\0", $self->param($key);
  151   }
  152 
  153   return %varsFormat;
  154 }
  155 
  156 1;