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

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