| 1 | package Vee::Form; |
|---|
| 2 | use strict; |
|---|
| 3 | use base 'Class::Accessor::Fast'; |
|---|
| 4 | |
|---|
| 5 | __PACKAGE__->mk_accessors(qw/controls name submitted/); |
|---|
| 6 | |
|---|
| 7 | =head1 NAME |
|---|
| 8 | |
|---|
| 9 | Vee::Form - Form processing, handling, and printing |
|---|
| 10 | |
|---|
| 11 | =head1 SYNOPSIS |
|---|
| 12 | |
|---|
| 13 | Coming soon |
|---|
| 14 | |
|---|
| 15 | =head1 DESCRIPTION |
|---|
| 16 | |
|---|
| 17 | Coming soon |
|---|
| 18 | |
|---|
| 19 | =head1 METHODS |
|---|
| 20 | |
|---|
| 21 | Coming soon |
|---|
| 22 | |
|---|
| 23 | =cut |
|---|
| 24 | |
|---|
| 25 | ################################################################################ |
|---|
| 26 | # constructor |
|---|
| 27 | |
|---|
| 28 | sub new { |
|---|
| 29 | my $proto = shift; |
|---|
| 30 | my $class = ref($proto) || $proto; |
|---|
| 31 | my $self = {}; |
|---|
| 32 | |
|---|
| 33 | my %opts = @_; |
|---|
| 34 | |
|---|
| 35 | bless ($self, $class); |
|---|
| 36 | $self->name($opts{id} || 'form'); |
|---|
| 37 | $self->controls({}); # expected potential controls |
|---|
| 38 | $self->submitted(undef); |
|---|
| 39 | $self->add_fields( %{ $opts{fields} } ) if $opts{fields}; |
|---|
| 40 | if ($opts{copy_params}) { |
|---|
| 41 | $self->params( {%{ $opts{params} }} ); |
|---|
| 42 | } else { |
|---|
| 43 | $self->params($opts{params}); |
|---|
| 44 | } |
|---|
| 45 | |
|---|
| 46 | return $self; |
|---|
| 47 | } |
|---|
| 48 | |
|---|
| 49 | ################################################################################ |
|---|
| 50 | # data access |
|---|
| 51 | |
|---|
| 52 | # returns whether this was passed in the query string |
|---|
| 53 | sub exists { |
|---|
| 54 | my ($self, $name) = @_; |
|---|
| 55 | return exists $self->params->{$name}; |
|---|
| 56 | } |
|---|
| 57 | |
|---|
| 58 | # returns parameter hashref |
|---|
| 59 | sub params { |
|---|
| 60 | my ($self, $params) = @_; |
|---|
| 61 | if (defined $params) { |
|---|
| 62 | $self->{params} = $params; |
|---|
| 63 | $self->submitted(1) if %$params; |
|---|
| 64 | $self->validate_params; |
|---|
| 65 | } |
|---|
| 66 | return $self->{params}; |
|---|
| 67 | } |
|---|
| 68 | |
|---|
| 69 | # returns list of all values in array context, or just the first in scalar context |
|---|
| 70 | sub get { |
|---|
| 71 | my $self = shift; |
|---|
| 72 | unless (@_) { return undef; } |
|---|
| 73 | my $name = shift; |
|---|
| 74 | if (ref $self->params->{$name}) { |
|---|
| 75 | return wantarray ? @{ $self->params->{$name} } : $self->params->{$name}->[0]; |
|---|
| 76 | } else { |
|---|
| 77 | return exists $self->params->{$name} ? $self->params->{$name} : |
|---|
| 78 | (exists $self->controls->{$name} ? $self->controls->{$name}->{value} : undef); |
|---|
| 79 | } |
|---|
| 80 | } |
|---|
| 81 | |
|---|
| 82 | # forcibly changes a value passed through the query string. |
|---|
| 83 | # useful for testing or for ignoring passed data. |
|---|
| 84 | # if the value is omitted, the value will be deleted. |
|---|
| 85 | sub force { |
|---|
| 86 | my ($self, $name, $newvalue) = @_; |
|---|
| 87 | if (@_ == 2) { |
|---|
| 88 | delete $self->params->{$name} |
|---|
| 89 | } else { |
|---|
| 90 | $self->params->{$name} = $newvalue |
|---|
| 91 | } |
|---|
| 92 | } |
|---|
| 93 | |
|---|
| 94 | ################################################################################ |
|---|
| 95 | # form creation and defaulting and stuff. if there are any query parameters |
|---|
| 96 | # with the correct names, the passed parameters will replace the 'value' etc |
|---|
| 97 | # parameters passed. unless otherwise stated, everything is used as an html |
|---|
| 98 | # attribute. |
|---|
| 99 | |
|---|
| 100 | # for dropdowns, radio sets, and groups of checkboxes, pass all possible |
|---|
| 101 | # values and labels for them through the 'options' param. a hashref will |
|---|
| 102 | # be sorted with keys as the actual form data and values as labels; an |
|---|
| 103 | # arrayref will have each element used as both data and label. |
|---|
| 104 | # if you want them sorted, pass an arrayref as 'options_sorted'. its values |
|---|
| 105 | # will be used to create a hash, so pretend it's a hashref with braces. |
|---|
| 106 | |
|---|
| 107 | # adds many at once |
|---|
| 108 | sub add_fields { |
|---|
| 109 | my ($self, %fields) = @_; |
|---|
| 110 | for my $key (keys %fields) { |
|---|
| 111 | $self->add_field($key, $fields{$key}) |
|---|
| 112 | } |
|---|
| 113 | } |
|---|
| 114 | |
|---|
| 115 | # just one! |
|---|
| 116 | sub add_field { |
|---|
| 117 | my $self = shift; |
|---|
| 118 | my ($name, $attr); |
|---|
| 119 | if (@_ == 1 and ref $_[0] eq 'HASH') { |
|---|
| 120 | $attr = $_[0]; |
|---|
| 121 | $name = delete $attr->{name}; |
|---|
| 122 | } elsif (@_ == 2 and ref $_[0] eq '' and ref $_[1] eq 'HASH') { |
|---|
| 123 | ($name, $attr) = @_; |
|---|
| 124 | } elsif (@_ % 2 == 0) { |
|---|
| 125 | $attr = { @_ }; |
|---|
| 126 | $name = delete $attr->{name}; |
|---|
| 127 | } else { |
|---|
| 128 | die "Couldn't understand parameters to add_field"; |
|---|
| 129 | } |
|---|
| 130 | |
|---|
| 131 | if (!$name) { die "Name required" } |
|---|
| 132 | |
|---|
| 133 | # put options in the correct format |
|---|
| 134 | if (exists $attr->{options}) { |
|---|
| 135 | if (ref $attr->{options} eq 'HASH') { |
|---|
| 136 | $attr->{options} = [ |
|---|
| 137 | map { |
|---|
| 138 | [ $_ => $attr->{options}{$_} ] |
|---|
| 139 | } sort keys %{$attr->{options}} |
|---|
| 140 | ]; |
|---|
| 141 | } |
|---|
| 142 | |
|---|
| 143 | if (ref $attr->{options} ne 'ARRAY') { |
|---|
| 144 | die "'options' parameter must be an arrayref for now"; |
|---|
| 145 | } |
|---|
| 146 | |
|---|
| 147 | if (!ref $attr->{options}[0]) { |
|---|
| 148 | $attr->{options} = [ |
|---|
| 149 | map {[ $_ => $_ ]} @{ $attr->{options} } |
|---|
| 150 | ]; |
|---|
| 151 | } |
|---|
| 152 | } |
|---|
| 153 | |
|---|
| 154 | if (!exists $attr->{default}) { |
|---|
| 155 | if (exists $attr->{options}) { |
|---|
| 156 | if ($attr->{type} ne 'checkbox') { |
|---|
| 157 | $attr->{default} = $attr->{options}[0][0]; |
|---|
| 158 | } |
|---|
| 159 | } else { |
|---|
| 160 | $attr->{default} = '' |
|---|
| 161 | } |
|---|
| 162 | } |
|---|
| 163 | |
|---|
| 164 | if (!ref $attr->{default} and $attr->{count} and $attr->{count} > 1) { |
|---|
| 165 | $attr->{default} = [ ( $attr->{default} ) x $attr->{count} ]; |
|---|
| 166 | } |
|---|
| 167 | |
|---|
| 168 | $self->controls->{$name} = $attr; |
|---|
| 169 | return $name; |
|---|
| 170 | } |
|---|
| 171 | |
|---|
| 172 | # return a hash of just parameters that aren't defaults |
|---|
| 173 | sub simplified_params { |
|---|
| 174 | my $self = shift; |
|---|
| 175 | my $res = { %{ $self->params } }; |
|---|
| 176 | for my $field (keys %{$self->controls}) { |
|---|
| 177 | next unless exists $res->{$field}; |
|---|
| 178 | # TODO: fix for arrays |
|---|
| 179 | my $delete = 1; |
|---|
| 180 | my $default = $self->controls->{$field}->{default}; |
|---|
| 181 | if (defined $res->{$field} xor defined $default or |
|---|
| 182 | ref $res->{$field} ne ref $default) { |
|---|
| 183 | $delete = 0 |
|---|
| 184 | } elsif (ref $res->{$field} eq 'ARRAY') { |
|---|
| 185 | my %defaults; |
|---|
| 186 | $defaults{$_}++ for @$default; |
|---|
| 187 | my @values; |
|---|
| 188 | for my $val (@{ $res->{$field} }) { |
|---|
| 189 | if ($defaults{$val}) { |
|---|
| 190 | $defaults{$val}--; |
|---|
| 191 | } else { |
|---|
| 192 | push @values, $val; |
|---|
| 193 | } |
|---|
| 194 | } |
|---|
| 195 | $res->{$field} = \@values; |
|---|
| 196 | $delete = 0 if @values; |
|---|
| 197 | } elsif (ref $res->{$field} eq '') { |
|---|
| 198 | $delete = 0 if defined $res->{$field} and $res->{$field} ne $default; |
|---|
| 199 | } |
|---|
| 200 | delete $res->{$field} if $delete; |
|---|
| 201 | } |
|---|
| 202 | return $res; |
|---|
| 203 | } |
|---|
| 204 | |
|---|
| 205 | # ensures that the passed parameters fit |
|---|
| 206 | # in general this shouldn't be called by anyone on the outside |
|---|
| 207 | # of course, right now this module is designed to just use new() and nothing else... |
|---|
| 208 | sub validate_params { |
|---|
| 209 | my $self = shift; |
|---|
| 210 | |
|---|
| 211 | my $p = $self->params; |
|---|
| 212 | my $c = $self->controls; |
|---|
| 213 | |
|---|
| 214 | # only cycle through control list |
|---|
| 215 | # (i.e., if a parameter got here without a matching control, leave it be) |
|---|
| 216 | for my $field (keys %$c) { |
|---|
| 217 | # if there is no fixed list to choose from, just use default |
|---|
| 218 | if (not $c->{$field}{options} or not defined $p->{$field}) { |
|---|
| 219 | $p->{$field} = $c->{$field}{default} unless defined $p->{$field}; |
|---|
| 220 | if (not ref $p->{$field} and $c->{$field}{count}) { |
|---|
| 221 | $p->{$field} = [ $p->{$field} ]; |
|---|
| 222 | } |
|---|
| 223 | next; |
|---|
| 224 | } |
|---|
| 225 | |
|---|
| 226 | # delete anything not in the fixed list |
|---|
| 227 | my @ok_params; |
|---|
| 228 | for my $param (Vee::Utils::array( $p->{$field} )) { |
|---|
| 229 | next unless scalar grep { $_->[0] eq $param } @{ $c->{$field}{options} }; |
|---|
| 230 | push @ok_params, $param; |
|---|
| 231 | } |
|---|
| 232 | |
|---|
| 233 | if (!@ok_params) { |
|---|
| 234 | if (exists $c->{$field}{default}) { |
|---|
| 235 | $p->{$field} = $c->{$field}{default} |
|---|
| 236 | } else { |
|---|
| 237 | delete $p->{$field} |
|---|
| 238 | } |
|---|
| 239 | } else { |
|---|
| 240 | $p->{$field} = scalar @ok_params == 1 ? $ok_params[0] : [ @ok_params ] |
|---|
| 241 | } |
|---|
| 242 | } |
|---|
| 243 | } |
|---|
| 244 | |
|---|
| 245 | # returns the <input> tag(s) for a given name. |
|---|
| 246 | # if the tag is a set, this will return "tag label <br/> tag label..." |
|---|
| 247 | # if the tag is a set AND you specify a value for the second param, this will return "tag label" |
|---|
| 248 | sub get_tag { |
|---|
| 249 | my ($self, $name, $req_value) = @_; |
|---|
| 250 | if (!$name or !exists $self->controls->{$name}) { return '[Nonexistant control]' } |
|---|
| 251 | my %attr = %{ $self->controls->{$name} }; |
|---|
| 252 | delete $attr{default}; |
|---|
| 253 | delete $attr{checked}; |
|---|
| 254 | |
|---|
| 255 | my $is_checked; |
|---|
| 256 | if (exists $attr{options} and defined $req_value and defined $self->params->{$name}) { |
|---|
| 257 | $is_checked = 1 if Vee::Utils::in($req_value, Vee::Utils::array($self->params->{$name})); |
|---|
| 258 | } |
|---|
| 259 | |
|---|
| 260 | $attr{name} = $name; |
|---|
| 261 | $attr{value} = $self->params->{$name}; |
|---|
| 262 | delete $attr{value} unless defined $attr{value}; |
|---|
| 263 | $attr{id} ||= $self->name . '_' . $name; |
|---|
| 264 | |
|---|
| 265 | my @options = Vee::Utils::array(delete $attr{options}) if exists $attr{options}; |
|---|
| 266 | |
|---|
| 267 | my $count = delete $attr{count}; |
|---|
| 268 | # count may be 1 or not |
|---|
| 269 | # req_value may be given or not |
|---|
| 270 | if ($count) { |
|---|
| 271 | if (defined $req_value) { |
|---|
| 272 | $attr{value} = $attr{value}->[$req_value] if ref $attr{value} eq 'ARRAY'; |
|---|
| 273 | } else { |
|---|
| 274 | return join '<br/>', map { $self->get_tag($name, $_) } 0 .. $count - 1; |
|---|
| 275 | } |
|---|
| 276 | } |
|---|
| 277 | |
|---|
| 278 | # boring old textbox or passwordbox; nothing special |
|---|
| 279 | if ($attr{type} eq 'text' or $attr{type} eq 'hidden') { |
|---|
| 280 | return sprintf '<input %s/>', join ' ', map { qq'$_="$attr{$_}"' } keys %attr |
|---|
| 281 | |
|---|
| 282 | # password/file requires.. nothing |
|---|
| 283 | } elsif ($attr{type} eq 'file' or $attr{type} eq 'password') { |
|---|
| 284 | delete $attr{value}; |
|---|
| 285 | return sprintf '<input %s/>', join ' ', map { qq'$_="$attr{$_}"' } keys %attr; |
|---|
| 286 | |
|---|
| 287 | # checkboxen |
|---|
| 288 | } elsif ($attr{type} eq 'checkbox') { |
|---|
| 289 | if (!@options) { |
|---|
| 290 | # just one checkbox |
|---|
| 291 | if (!defined $attr{id}) { $attr{id} = $self->id . '_' . $name; } |
|---|
| 292 | delete $attr{checked}; |
|---|
| 293 | if ($attr{value}) { |
|---|
| 294 | $attr{checked} = 'checked'; |
|---|
| 295 | } else { |
|---|
| 296 | delete $attr{value} |
|---|
| 297 | } |
|---|
| 298 | return sprintf '<input %s/>', join ' ', map { qq'$_="$attr{$_}"' } keys %attr; |
|---|
| 299 | } elsif (defined $req_value) { |
|---|
| 300 | # multiple checkboxes, one selected |
|---|
| 301 | if (defined $req_value and not scalar grep { $_->[0] eq $req_value } @options) { return '' } |
|---|
| 302 | $attr{value} = $req_value; |
|---|
| 303 | $attr{checked} = 'checked' if $is_checked; |
|---|
| 304 | if (defined $attr{id}) { $attr{id} = $attr{id} . '_' . $req_value } else { $attr{id} = qq'qry_${name}_$req_value'; } |
|---|
| 305 | return sprintf '<input %s/>', join ' ', map { qq'$_="$attr{$_}"' } keys %attr; |
|---|
| 306 | } else { |
|---|
| 307 | # multiple checkboxes, return them all |
|---|
| 308 | my $cur_value = $attr{value}; |
|---|
| 309 | delete $attr{value}; |
|---|
| 310 | my @res; |
|---|
| 311 | my $id = $attr{id}; |
|---|
| 312 | for my $pair (@options) { |
|---|
| 313 | if ($cur_value and Vee::Utils::in($pair->[0], Vee::Utils::array($cur_value))) { $attr{checked} = 'checked' } else { delete $attr{checked} } |
|---|
| 314 | $attr{value} = $pair->[0]; |
|---|
| 315 | if (defined $id) { $attr{id} = $id . '_' . $pair->[0] } else { $attr{id} = qq'qry_${name}_$pair->[0]'; } |
|---|
| 316 | push @res, sprintf '<label> <input %s/> %s </label>', join(' ', map { qq'$_="$attr{$_}"' } keys %attr), $pair->[1]; |
|---|
| 317 | } |
|---|
| 318 | return join '<br/>', @res; |
|---|
| 319 | } |
|---|
| 320 | |
|---|
| 321 | } elsif ($attr{type} eq 'radio') { |
|---|
| 322 | # set of radio buttons |
|---|
| 323 | if (defined $req_value) { |
|---|
| 324 | # multiple radio buttons, one selected |
|---|
| 325 | if ($req_value and not scalar grep { $_->[0] eq $req_value } @options) { return '' } |
|---|
| 326 | $attr{checked} = 'checked' if $is_checked; |
|---|
| 327 | $attr{value} = $req_value; |
|---|
| 328 | if (defined $attr{id}) { $attr{id} = $attr{id} . '_' . $req_value } else { $attr{id} = qq'qry_${name}_$req_value'; } |
|---|
| 329 | return sprintf '<input %s/>', join ' ', map { qq'$_="$attr{$_}"' } keys %attr; |
|---|
| 330 | } else { |
|---|
| 331 | # multiple radio buttons, return them all |
|---|
| 332 | my $cur_value = $attr{value}; |
|---|
| 333 | delete $attr{value}; |
|---|
| 334 | my @res; |
|---|
| 335 | my $id = $attr{id}; |
|---|
| 336 | for my $pair (@options) { |
|---|
| 337 | if ($pair->[0] eq $cur_value) { $attr{checked} = 'checked' } else { delete $attr{checked} } |
|---|
| 338 | $attr{value} = $pair->[0]; |
|---|
| 339 | if (defined $id) { $attr{id} = $id . '_' . $pair->[0] } else { $attr{id} = qq'qry_${name}_$pair->[0]'; } |
|---|
| 340 | push @res, sprintf '<label> <input %s/> %s </label>', join(' ', map { qq'$_="$attr{$_}"' } keys %attr), $pair->[1]; |
|---|
| 341 | } |
|---|
| 342 | return join '<br/>', @res; |
|---|
| 343 | } |
|---|
| 344 | |
|---|
| 345 | # dropdown box |
|---|
| 346 | # TODO: rest of attributes |
|---|
| 347 | } elsif ($attr{type} eq 'select') { |
|---|
| 348 | my $res = qq'<select name="$attr{name}" id="$attr{id}"> '; |
|---|
| 349 | for my $pair (@options) { |
|---|
| 350 | $res .= qq'<option value="$pair->[0]"'; |
|---|
| 351 | if ($attr{value} eq $pair->[0]) { $res .= ' selected="selected"' } |
|---|
| 352 | $res .= "> $pair->[1] </option> "; |
|---|
| 353 | } |
|---|
| 354 | $res .= '</select>'; |
|---|
| 355 | return $res; |
|---|
| 356 | |
|---|
| 357 | # textarea, mostly like text but.. completely different |
|---|
| 358 | } elsif ($attr{type} eq 'textarea') { |
|---|
| 359 | my $value = delete $attr{value}; |
|---|
| 360 | delete $attr{type}; |
|---|
| 361 | return sprintf qq'<textarea %s>%s</textarea>', |
|---|
| 362 | join(' ', map { qq'$_="$attr{$_}"' } keys %attr), |
|---|
| 363 | $value; |
|---|
| 364 | |
|---|
| 365 | } else { |
|---|
| 366 | return qq'[Unknown control $attr{type}]'; |
|---|
| 367 | } |
|---|
| 368 | } |
|---|
| 369 | |
|---|
| 370 | # returns a hash of all passed query parameters that also have a corresponding |
|---|
| 371 | # control but are set to something other than the default |
|---|
| 372 | # TODO: make this do a deep compare! |
|---|
| 373 | sub get_changes { |
|---|
| 374 | my $self = shift; |
|---|
| 375 | my %res = (); |
|---|
| 376 | for my $k (keys %{ $self->params }) { |
|---|
| 377 | next unless exists $self->controls->{$k}; |
|---|
| 378 | if ($self->params->{$k} ne $self->controls->{$k}->{value}) { |
|---|
| 379 | $res{$k} = $self->params->{$k}; |
|---|
| 380 | } |
|---|
| 381 | } |
|---|
| 382 | return %res; |
|---|
| 383 | } |
|---|
| 384 | |
|---|
| 385 | # like getchanges above, but just returns a query string for linking |
|---|
| 386 | sub get_query { |
|---|
| 387 | my $self = shift; |
|---|
| 388 | my @res = (); |
|---|
| 389 | for my $k (keys %{ $self->params }) { |
|---|
| 390 | next unless exists $self->controls->{$k}; |
|---|
| 391 | if ($self->params->{$k} ne $self->controls->{$k}->{value}) { |
|---|
| 392 | if (ref $self->params->{$k} eq 'ARRAY') { |
|---|
| 393 | # this mess checks to see if the default LIST is identical to the provided list |
|---|
| 394 | if (ref $self->controls->{$k} eq 'ARRAY' && |
|---|
| 395 | join("\0", sort @{ $self->params->{$k} }) eq join("\0", sort @{ $self->controls->{$k} })) |
|---|
| 396 | { next } |
|---|
| 397 | |
|---|
| 398 | # push each one, one at a time |
|---|
| 399 | push @res, map { "$k=$_" } @{ $self->params->{$k} }; |
|---|
| 400 | } else { |
|---|
| 401 | push @res, $k . '=' . $self->params->{$k}; |
|---|
| 402 | } |
|---|
| 403 | } |
|---|
| 404 | } |
|---|
| 405 | return join ';', @res; |
|---|
| 406 | } |
|---|
| 407 | |
|---|
| 408 | =head1 AUTHOR |
|---|
| 409 | |
|---|
| 410 | Maintainer: Alex "Eevee" Munroe (C<veekun@veekun.com>) |
|---|
| 411 | |
|---|
| 412 | See the included F<AUTHORS> file for a full list of contributers. |
|---|
| 413 | |
|---|
| 414 | =head1 LICENSE |
|---|
| 415 | |
|---|
| 416 | See the included F<LICENSE> file. |
|---|
| 417 | |
|---|
| 418 | =cut |
|---|
| 419 | |
|---|
| 420 | 1; |
|---|
