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

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