lib/HTML/Form/Simple.pm

   1 package HTML::Form::Simple;
   2
   3 use strict;
   4 use warnings;
   5
   6 use XML::Quote;
   7
   8 our $VERSION = '1.00';
   9
  10
  11 sub new {
  12         my ($class, $default) = @_;
  13         bless {default => $default}, $class;
  14 }
  15
  16 sub _attr {
  17         my $self = shift;
  18         my $expect = shift;
  19         my $attr = ref $_[-1] eq 'HASH' ? pop : {};
  20         push @_, undef for @_+1 .. $expect;
  21         push @_, $attr;
  22         return @_;
  23 }
  24
  25 sub quote {
  26         my $self = shift;
  27         return ${$_[0]} if ref $_[0] eq 'SCALAR';
  28         return XML::Quote::xml_quote_min($_[0]);
  29 }
  30
  31 sub tag {
  32         my ($self, $tag, $attr) = @_;
  33
  34         # strip empty if it shouldn't be
  35         defined $attr->{$_} and $attr->{$_} eq '' and delete $attr->{$_}
  36                 for qw(id for type class style);
  37
  38         my $return = '<' . $tag;
  39
  40         # add boolean attributes
  41         delete $attr->{$_} and $return .= ' '.$_
  42                 for qw(selected checked disabled readonly);
  43
  44         # add attributes with (escaped) string values
  45         $return .= sprintf ' %s="%s"', $_, $self->quote($attr->{$_})
  46                 for sort grep { defined $attr->{$_} } keys %$attr;
  47
  48         return $return . '>';
  49 }
  50
  51
  52 sub start {
  53         my ($self, $attr) = @_;
  54
  55         return $self->tag(form => $attr);
  56 }
  57
  58 sub stop {
  59         return '</form>';
  60 }
  61
  62
  63 sub submit {
  64         my $self = shift;
  65         my ($value, $attr) = $self->_attr(1, @_);
  66
  67         $attr->{value} = $value if defined $value;
  68         $attr->{type} = 'submit' unless defined $attr->{type};
  69
  70         return $self->tag(input => $attr);
  71 }
  72
  73 sub hidden {
  74         my $self = shift;
  75         my ($name, $value, $attr) = $self->_attr(2, @_);
  76
  77         if (ref $name eq 'HASH') {
  78                 my @return = map { $self->hidden($_, $name->{$_}, $attr) } sort keys %$name;
  79                 return wantarray ? @return : join(defined $, ? $, : '', @return);
  80         }
  81
  82         if (ref $value eq 'ARRAY') {
  83                 my @return = map { $self->hidden($name, $_, $attr) } @$value;
  84                 return wantarray ? @return : join(defined $, ? $, : '', @return);
  85         }
  86
  87         $attr->{name } = $name  if defined $name;
  88         $attr->{value} = $value if defined $value;
  89         $attr->{value} = $self->{default}->{$name}
  90                 if not defined $attr->{value} and defined $name and defined $self->{default};
  91         $attr->{type} = 'hidden' unless defined $attr->{type};
  92
  93         return $self->tag(input => $attr);
  94 }
  95
  96 sub text {
  97         my $self = shift;
  98         my ($name, $value, $attr) = $self->_attr(2, @_);
  99
 100         $attr->{name } = $name  if defined $name;
 101         $attr->{value} = $value if defined $value;
 102         $attr->{value} = $self->{default}->{$name}
 103                 if not defined $attr->{value} and defined $name and defined $self->{default};
 104         $attr->{id}   = $attr->{name} unless defined $attr->{id};
 105         $attr->{type} = 'text' unless defined $attr->{type} or defined $attr->{rows};
 106
 107         # textarea does not have value as tag attribute
 108         $value = delete $attr->{value} if defined $attr->{rows};
 109
 110         return defined $attr->{rows} ? sprintf(
 111                 '%s%s</textarea>',
 112                 $self->tag(textarea => $attr),
 113                 $self->quote(defined $value ? $value : '')
 114         ) : $self->tag(input => $attr);
 115 }
 116
 117 sub select {
 118         my $self = shift;
 119         my ($name, $rows, $default, $attr) = $self->_attr(3, @_);
 120
 121         $attr->{name} = $name;
 122         $attr->{id}   = $attr->{name} unless defined $attr->{id};
 123         $attr->{type} = 'select' unless defined $attr->{type};
 124
 125         $default = $attr->{value} unless defined $default;
 126         delete $attr->{value};  # never a parent attribute
 127         $default = $self->{default}->{$name}
 128                 if not defined $default and defined $name and defined $self->{default};
 129
 130         my @options = map { ref $_ ? $_ : {value => $_} } @$rows;
 131
 132         my @return;
 133
 134         if ($attr->{type} eq 'select') {
 135                 delete $attr->{type};
 136
 137                 # select option(s) matching the default value
 138                 if (defined $default) {
 139                         for (@options) {
 140                                 $_->{selected} = 1 if defined $_->{value} and $_->{value} eq $default;
 141                         }
 142                 }
 143
 144                 @return = (
 145                         $self->tag(select => $attr),
 146                         (map { $self->tag(option => $_) } @options),
 147                         '</select>',
 148                 );
 149         }
 150         else {
 151                 # set fallback option id from parent id and value
 152                 if (defined $attr->{id} and $attr->{id} ne '') {
 153                         defined $_->{id}
 154                                 or defined $_->{value} and $_->{id} = $attr->{id}.'_'.$_->{value}
 155                                         for @options;
 156                 }
 157
 158                 # put parent label attribute on options
 159                 if (defined $attr->{label}) {
 160                         defined $_->{value} and not defined $_->{label}
 161                                 and $_->{label} = $attr->{label}->{$_->{value}}
 162                                         for @options;
 163                         delete $attr->{label};
 164                 }
 165
 166                 # check any option matching the default value
 167                 if (defined $default) {
 168                         for (@options) {
 169                                 $_->{checked} = 1 if defined $_->{value} and $_->{value} eq $default;
 170                         }
 171                 }
 172
 173                 $_ = {%$attr, %$_} for @options;
 174                 @return = map {
 175                         my $label = delete $_->{label};
 176                         defined $label && $label ne ''
 177                                 ? '<label>'.$self->tag(input => $_)." $label</label>"
 178                                 :           $self->tag(input => $_)
 179                 } @options;
 180         }
 181
 182         return wantarray ? @return : join(defined $, ? $, : '', @return);
 183 }
 184
 185 sub radio {
 186         my $self = shift;
 187         my ($name, $rows, $label, $default, $attr) = $self->_attr(4, @_);
 188
 189         # normalize rows array
 190         if (not defined $rows) {
 191                 if (defined $label) {
 192                         # fill up values with numbers to match labels
 193                         $rows = ref $label eq 'ARRAY' ? [1 .. $#$label+1] : [1];
 194                 }
 195                 else {
 196                         $rows = [{}];
 197                 }
 198         }
 199         elsif (ref $rows ne 'ARRAY') {
 200                 $rows = [$rows];
 201         }
 202
 203         # add labels
 204         if (defined $label) {
 205                 # convert options to hash refs so we can add label attributes
 206                 $rows = [ map { ref $_ eq 'HASH' ? {%$_} : {value => $_} } @$rows ];
 207
 208                 if (ref $label eq 'ARRAY') {
 209                         $rows->[$_]->{label} = $label->[$_] for 0 .. $#$rows;
 210                 } else {
 211                         $_->{label} = $label for @$rows;
 212                 }
 213         }
 214
 215         $self->select($name, $rows, $default, {%$attr, type => 'radio'});
 216 }
 217
 218 sub check {
 219         my $self = shift;
 220         my ($name, $label, $checked, $attr) = $self->_attr(3, @_);
 221
 222         # create option rows array from label argument
 223         my $rows = defined $label ? ref $label eq 'ARRAY' ? [@$label] : [$label] : [{}];
 224         # convert options to hash refs sooner rather than later
 225         $_ = ref $_ eq 'HASH' ? {%$_} : {label => $_} for @$rows;
 226
 227         # parse checked argument
 228         if (defined $checked) {
 229                 if (ref $checked eq 'ARRAY') {
 230                         # each checked row corresponding to an option
 231                         $rows->[$_]->{checked} = $checked->[$_] for 0 .. $#$rows;
 232                         # add superfluous rows as new options
 233                         push @$rows, map { {checked => $_} } @$checked[@$rows .. $#$checked];
 234                 }
 235                 else {
 236                         # a single value for all options
 237                         $_->{checked} = $checked for @$rows;
 238                 }
 239         }
 240
 241         # set default option value (argument number)
 242         exists $rows->[$_]->{value} or $rows->[$_]->{value} = $_ + 1 for 0 .. $#$rows;
 243
 244         # set option id without added value if rows were not given as array
 245         $rows->[0]->{id} = $attr->{id} || $rows->[0]->{name} || $attr->{name} || $name #XXX: //
 246                 if ref $label ne 'ARRAY' and defined $rows->[0] and not defined $rows->[0]->{id};
 247
 248         $self->select($name, $rows, {%$attr, type => 'checkbox'});
 249 }
 250
 251 sub row {
 252         my $self = shift;
 253         my ($name, $contents, $attr) = $self->_attr(2, @_);
 254
 255         $contents = defined $contents && ref $contents ne 'HASH'
 256                 ? $self->quote($contents) : $self->text($name, $contents);
 257         my $label = defined $attr->{label}
 258                 ? $self->quote(delete $attr->{label})
 259                 : defined $name ? $self->quote($name) : '';
 260
 261         return $self->tag(label => {for => $name, %$attr})
 262                 . $label
 263                 . '</label>'
 264                 . (defined $, ? $, : ' ')
 265                 . $contents
 266                 ;
 267 }
 268
 269 1;
 270
 271 __END__
 272
 273 =head1 NAME
 274
 275 HTML::Form::Simple - Generate HTML form elements
 276
 277 =head1 SYNOPSIS
 278
 279         my $input = HTML::Form::Simple->new;
 280         say $input->start; # <form>
 281         printf "<label>%s: %s</label>\n", @$_ for (
 282                 [ 'Your Name' => $input->text(
 283                         user => 'Mr. Default'
 284                 ) ],
 285                 [ Message => $input->text(
 286                         msg => 'Textarea default', {rows => 4, style => 'background:red'}
 287                 ) ],
 288                 [ Gender => join ' or ', $input->radio(
 289                         sex => [qw(m f)], [qw(Male Female)]
 290                 ) ],
 291                 [ Colour => scalar $input->select(
 292                         favcolour => [qw(Blue Green Red)], 'Green'
 293                 ) ],
 294                 [ Options => $input->check(
 295                         spam => 'Receive weekly newsletter'
 296                 ) ],
 297         );
 298         say $input->stop; # </form>
 299
 300 =head1 DESCRIPTION
 301
 302 Set up a form object with new().  The HTML for the opening and closing
 303 C<< <form> >> tags are returned by the start() and stop() methods.
 304
 305 The L<hidden>, L<text>, L<select>, L<radio>, and L<check> methods all
 306 correspond to various input types.  The first argument is always the mandatory
 307 name, and a hash ref as the last argument can optionally be provided for
 308 additional attributes/options.  Everything is properly escaped.
 309
 310 =over
 311
 312 =item C<hidden>
 313
 314 Returns the HTML for a simple C<< <input type="hidden"> >> with specified name
 315 and value (both are required by HTML specs).
 316
 317         $input->hidden('name', 'value');
 318
 319 As with all methods, a final hash ref can be given to add further attributes.
 320 While rarely needed in this case, it can also be used as an override or
 321 alternative to value and name:
 322
 323         $input->hidden({name => 'name', value => 'value'})
 324
 325 =item C<text>
 326
 327 The common C<< <input type="text"> >>.
 328
 329         $input->text('name', 'default');
 330
 331 If the I<rows> option is set, substitutes a similarly set up C<< <textarea> >>:
 332
 333         $input->text('name', 'default', {rows => 4});
 334
 335 =item C<select>
 336
 337         $input->select('name', ['option'], 'default');
 338
 339 Provides C<< <select><option> >> dropdown by default, but can also output
 340 multiple C<< <input> >> tags if a I<type> is provided:
 341
 342         $input->select('name', ['1'], {type => 'checkbox'});
 343
 344 In scalar context, options are joined together by C<$,> (C<$OUTPUT_FIELD_SEPARATOR>).
 345 Otherwise a list of tags is returned.
 346
 347 Each option can be given as either a simple string containing its I<value>,
 348 or a hash ref with custom attributes.
 349 When there's no parent tag (only C<< <input> >>s), a fourth parameter can
 350 provide common options which will be inherited by each element.  Otherwise,
 351 options will apply to either the C<< <select> >> or an C<< <option> >>.
 352
 353 The default value (either as a third scalar parameter, or with the general
 354 I<value> option) will be matched to the value of each option, and if equal,
 355 its I<selected> or I<checked> attribute will be set as appropriate.
 356
 357 =item C<radio>
 358
 359 In fact just a shorthand to L<select> with a preset type of I<radio>, but takes
 360 an additional third argument to easily set the label for each option:
 361
 362         $input->radio('name', ['option'], ['option label'], 'default');
 363
 364 This would be the same as saying:
 365
 366         $input->radio(
 367                 'name',
 368                 [ {label => 'option label', value => 'option'} ],
 369                 {value => 'default'}
 370         );
 371
 372 =item C<check>
 373
 374 Also a L<select> shorthand, but with a I<checkbox> type.
 375 Instead of values, the second argument specifies option I<label>s.
 376 The values by default are set to an auto-incrementing number starting with 1.
 377
 378 Furthermore, the I<checked> status for each option can be specified by a third
 379 argument.  Either a single boolean value defining all rows, or an array ref
 380 with the value for each row in order.
 381
 382         $input->check('name', ['label', 'second option'], [0, 1]);
 383
 384 Or more descriptive but identical:
 385
 386         $input->check('name', [
 387                 {label => 'label',         value => 1, checked => 0},
 388                 {label => 'second option', value => 2, checked => 1},
 389         ]);
 390
 391 =back
 392
 393 =head1 TODO
 394
 395 =over
 396
 397 =item C<default()> method
 398
 399         $input->hidden(foo => $input->default('foo'));
 400         $hash_ref = $input->default;
 401         $input->default('foo') = 'new value';
 402         undef $input->default;  # clear all
 403                 # XXX: does this equal $input->default=undef;?
 404         $input->default = {amend => 'stuff'};
 405
 406 =item documentation
 407
 408 Actual descriptions instead of just a synopsis.
 409
 410 =item C<quote> override
 411
 412 Allow custom value quotation function.
 413 Makes L<XML::Quote|XML::Quote> dependency optional.
 414
 415 =item single checkbox id
 416
 417 Do not add value to single check() by default.
 418
 419 =back
 420
 421 =head1 AUTHOR
 422
 423 Mischa POSLAWSKY <perl@shiar.org>
 424
 425 =head1 LICENSE
 426
 427 This module is free software; you can redistribute it and/or modify it
 428 under the same L<terms|perlartistic> as Perl itself.
 429