lib/CXGN/Page/WebForm.pm

   1 package CXGN::Page::WebForm;
   2 use strict;
   3 use Carp;
   4
   5 use Digest::Crc32;
   6 use Tie::Function;
   7 use HTML::Entities;
   8
   9 use CXGN::Tools::List qw/distinct all/;
  10
  11 =head1 NAME
  12
  13 CXGN::Page::WebForm - a persistent HTML form
  14
  15 =head1 SYNOPSIS
  16
  17   package MyWebForm;
  18   use base qw( CXGN::Page::WebForm );
  19   __PACKAGE__->template( <<EOHTML );
  20   Id:<input name="NAME_id"  value="VALUE_id" />
  21   Name:<input name="NAME_name"  value="VALUE_name" />
  22   EOHTML
  23
  24   package main;
  25
  26   my $form = MyWebForm->new;
  27   my $page = CXGN::Page->new('Some page','Rob Buels');
  28   $form->from_request( $page->get_all_encoded_arguments );
  29
  30   print "you submitted the data ",
  31         '('.join(',',$form->data('id','name','something').")\n";
  32   #remember, data() returns a list of (val,val,val,...), not a scalar
  33
  34   #prints whatever the value of w98e_id was in the POST
  35   #we got, where w98e is some arbitrary piece of
  36   #garbage this class uses to keep its parameters
  37   #to itself
  38
  39   $form->set_data( id => 42, name => 'rob' );
  40
  41   print '<form action="" method="post">',"\n",
  42          $form->to_html,
  43          '</form>'; #now print the auto-filled-in form
  44
  45   #will print something like
  46
  47   <form action="" method="post">
  48   Id:<input name="w98e_id" value="42" />
  49   Name:<input name="w98e_name" value="rob" />
  50   </form>
  51
  52   #where w98e is an automatically generated identifier
  53   #that signifies that the values belong to the MyWebForm
  54   #package.
  55
  56 =head1 SUBCLASSES
  57
  58   L<CXGN::Search::WWWQuery>
  59
  60 =head1 DESCRIPTION
  61
  62 This is an object representing a web form, which encodes
  63 and decodes its parameter names such that it always knows
  64 which parameters belong to it.  Use this as a base class
  65 for making HTML forms that fill themselves in based on values
  66 supplied from somewhere else.
  67
  68 =head1 PRIMARY FUNCTIONS
  69
  70 These are the primary functions provided by this class.
  71
  72 =cut
  73
  74 use base qw/ Class::Data::Inheritable /;
  75
  76 use Class::MethodMaker
  77   [ new  => [-init => 'new'],
  78     hash => ['_data'],
  79   ];
  80
  81 =head2 new
  82
  83   Usage: my $form = MyWebForm->new;
  84   Desc : make a new form object
  85   Ret  : a new object
  86   Args : (optional) initial data, same format as set_data() below
  87   Side Effects: calls the init() method in this class to set up
  88                 this object
  89
  90 =cut
  91
  92 sub init { #init() is called by Class::MethodMaker's new() method
  93   my $self = shift;
  94   if(@_) {
  95     $self->set_data(@_);
  96   }
  97 }
  98
  99 =head2 template
 100
 101   Note: this is a CLASS METHOD.
 102
 103   Usage: MyForm->template(<<EOHTML);
 104     ID Number:<input type="text" name="NAME_id" value="VALUE_id" /><br />
 105     Name:<input type="text" name="NAME_name" value="VALUE_name" />
 106   EOHTML
 107   Desc : set the html template to use for this web form
 108   Ret  : the template you set
 109   Args : (optional) new template string to set for this class
 110   Side Effects: sets a piece of class data holding this template
 111
 112 =cut
 113
 114 #make a _template() class method to hold the data
 115 __PACKAGE__->mk_classdata( '_template' );
 116
 117 #wrap the _template classdata in some error checking
 118 sub template {
 119   my $class = shift;
 120
 121   $_[0] && $_[0] =~ /<form\s/
 122     and croak "Do not include <form> elements in your to_html template";
 123
 124   $class->_template(@_);
 125 }
 126
 127 =head2 to_html
 128
 129   Usage: print $myform->to_html
 130   Desc : fills in this class's HTML form template (set with template()
 131          above) with the properly uniqified names, and the values we have
 132          in this object, if any (e.g. from a previous from_request)
 133
 134          If no template is defined, it makes a default one with whatever
 135          parameters and values are set in it, if any.
 136   Ret  : string of html
 137   Args : none
 138   Side Effects: none
 139
 140   Subclass implementors might want to override this to generate
 141   their HTML in a more advanced way.
 142
 143 =cut
 144
 145 sub to_html {
 146   my ($self) = @_;
 147   @_ > 1 and croak "to_html takes no arguments"; #check args
 148
 149   #get our class's template, or make a crappy default one
 150   #if one wasn't given
 151   my $template = (ref $self)->template
 152     || join("<br />\n",
 153             map { my ($val) = $self->_data_index($_);
 154                   qq|<label for="NAME_$_">$_:</label>|
 155                     .qq|<input name="VALUE_$_" value="$val" />|
 156                 } $self->_data_keys
 157            )
 158     || __PACKAGE__.': no template defined, and no data to use for generating default template, so this is an empty template.  Maybe you should provide one.';
 159
 160   #make a tied hash for uniqifying names
 161   tie my %uniq, 'Tie::Function', sub { $self->uniqify_name(@_) };
 162   #make a tied hash for looking up values in this object
 163   tie my %value, 'Tie::Function', sub { my $v = ($self->_data_index(@_))[0];
 164                                          defined($v) ? encode_entities($v) : ''
 165                                        };
 166   #plug the names and values into the template
 167   $template =~ s/(?<=\W)NAME_(\w+)(?=\W)/$uniq{$1}/g;
 168   $template =~ s/(?<=\W)VALUE_(\w+)(?=\W)/$value{$1}/g;
 169
 170   #and return it
 171   return $template;
 172 }
 173
 174 =head2 from_request
 175
 176   Usage: $from->from_request( { bleh => 1, isa_monkey => 'rob'} );
 177   Desc: deserialize this query object from a an Apache request object
 178   Args: ref to a hash of parameters (like that returned from
 179         CXGN::Page->get_arguments() )  you can make your own with
 180         something like:
 181
 182         my $r = Apache2::RequestUtil->request;
 183         $r->content_type("text/html");
 184         my %params=$r->method eq "POST" ? $r->content : $r->args;
 185
 186         $myform->from_request(\%params);
 187
 188   Ret : not specified
 189   Side Effects: none
 190
 191 =cut
 192
 193 sub from_request {
 194   my ($self,$mungedparams) = @_;
 195   my %params = $self->_pick_out_my_params($mungedparams);
 196   $self->_data(%params);
 197 }
 198
 199 =head2 data
 200
 201   Usage: print "got form data (id,name)= ("
 202                 .join(',',$form->data(qw/id name/))
 203                 .")";
 204   Desc : get the values of one or more pieces of form data
 205   Ret  : list of corresponding values for the names you passed in
 206   Args : list of names of the data you want
 207   Side Effects: none
 208
 209   NOTE: both the input and the output of this function are _lists_
 210
 211 =cut
 212
 213 #the secret internal writable accessor is _data, generated
 214 #by Class::MethodMaker above
 215 sub data {
 216   shift->_data_index(@_);
 217 }
 218
 219 =head2 data_multiple
 220
 221  Usage: my @stuff = $form->data_multiple('foolist');
 222  Desc : When a parameter may have multiple values (such as a
 223         multiple-select box) this returns the many values as a
 224         list. Supply only one argument, the name of the parameter.
 225  Ret  : List of values for the named parameter
 226  Args : The name of the parameter
 227  Side Effects: none
 228
 229 =cut
 230
 231 sub data_multiple {
 232
 233   my ($self, $param) = @_;
 234   my ($thingy) = $self->data($param);
 235
 236   return (split /\0/, $thingy);
 237
 238 }
 239
 240 =head2 set_data
 241
 242   Usage: $form->set_data( id => 42, name => 'rob')
 243   Desc : set data in this form
 244   Ret  : nothing meaningful
 245   Args : hash-style list of values to set, like
 246          (id => 42, name => 'rob')
 247   Side Effects: sets object data
 248
 249 =cut
 250
 251 sub set_data {
 252   shift->_data_set(@_);
 253 }
 254
 255 =head2 same_data_as
 256
 257   Usage: print 'yep' if $form_obj_1->same_data_as( $form_obj_2 );
 258   Desc : object method, returns true if the given form object
 259          contains the same data as this one.
 260   Args : a WebForm object
 261   Ret  : true if the objects are the same, false otherwise
 262
 263 =cut
 264
 265 sub same_data_as {
 266   my ($self,$other) = @_;
 267
 268   # true of course if they are the same object
 269   return 1 if $self == $other;
 270
 271   # check if they have the same number of data items set
 272   return unless $self->_data_count == $other->_data_count;
 273
 274   # check if they have the same data item names set
 275   my @keys = distinct $self->_data_keys, $other->_data_keys;
 276
 277   return unless $self->_data_count == scalar @keys;
 278
 279   # now we know they have the same data item names,
 280   # check that they have the same data values
 281   return all map {
 282     $self->_data_index($_) eq $self->_data_index($_)
 283   } @keys;
 284 }
 285
 286
 287 =head1 HELPER FUNCTIONS
 288
 289 These functions may be useful for developers who subclass this.
 290
 291 =head2 _pick_out_my_params
 292
 293   Desc: given a hash of names and values from a GET or POST request, pick
 294         out the variables in the request that belong to us, that is,
 295         that were generated by an object of the same class as this one.
 296   Args: reference to a hash containing name => value pairs
 297   Ret : hash of parameters that, based on the encoding of their names,
 298         belong to this object, as:
 299           ( unmunged name => value,
 300             unmunged name => value,
 301           )
 302   Side Effects: none
 303
 304 =cut
 305
 306 sub _pick_out_my_params {
 307
 308   my ($this,$mungedparams) = @_;
 309
 310   ref $mungedparams eq 'HASH'
 311     or croak 'Argument to from_request must be a hash ref (got a '.(ref $mungedparams).')';
 312
 313   my %unmunged; #params that belong to us, unmunged
 314
 315   #find all the params that belong to us
 316   while(my ($mungedname,$value) = each %$mungedparams) {
 317    if( my $name = $this->de_uniqify_name($mungedname) ) {
 318       $unmunged{$name} = $value;
 319     }
 320   }
 321
 322   return %unmunged;
 323 }
 324
 325 =head2 uniqify_name
 326
 327   Desc: method to munge the name of a form field such that
 328         it will almost certainly not collide with other things in
 329         the same GET or POST request
 330   Args: unmunged name
 331   Ret : munged name
 332
 333 =cut
 334
 335 sub uniqify_name {
 336   shift->_prefix.shift
 337 }
 338
 339 #generate this class's prefix used for uniqifying parameter names
 340 our %_params_prefix_cache;
 341 our $crc = Digest::Crc32->new;
 342 sub _prefix {
 343   my ($this) = @_;
 344   $this = ref $this if ref $this;
 345   $_params_prefix_cache{$this} ||= sprintf('w%x_',$crc->strcrc32($this) & 0xfff);
 346 }
 347
 348 =head2 de_uniqify_name
 349
 350   Desc: method to convert form field names made with uniqify_name above
 351         back into the name you actually want to use
 352   Args: munged name
 353   Ret : unmunged name, or undef if the name passed was not munged in the correct way
 354
 355   Used in _pick_out_my_params().
 356
 357 =cut
 358
 359 sub de_uniqify_name {
 360   my ($this,$html)  = @_;
 361   my $prefix = $this->_prefix();
 362   my ($ret) = $html =~ /^$prefix(.+)/;
 363   $ret;
 364 }
 365
 366 =head2 make_pname
 367
 368   Desc: convenience method, makes a hash in the calling package called
 369         %pname that you can use instead of uniqify_name (see example)
 370   Args: none
 371   Ret : nothing
 372   Example:
 373     __PACKAGE__->make_pname;
 374     our %pname;
 375     sub to_html {
 376       return <<EOH;
 377          <form><input name="$pname{foo}" value="" /></form>
 378       EOH
 379     }
 380
 381 =cut
 382
 383 sub make_pname {
 384   my ($class) = @_;
 385   $class = ref $class if ref $class;
 386   no strict;
 387   tie %{$class.'::pname'}, 'Tie::Function' => sub { $class->uniqify_name(@_) };
 388 }
 389
 390 =head1 AUTHOR(S)
 391
 392     Robert Buels
 393
 394 =cut
 395
 396 ###
 397 1;#do not remove
 398 ###