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 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 1;
 252
 253 __END__
 254
 255 =head1 NAME
 256
 257 HTML::Form::Simple - Generate HTML form elements
 258
 259 =head1 SYNOPSIS
 260
 261         my $input = HTML::Form::Simple->new;
 262         say $input->start; # <form>
 263         printf "<label>%s: %s</label>\n", @$_ for (
 264                 [ 'Your Name' => $input->text(
 265                         user => 'Mr. Default'
 266                 ) ],
 267                 [ Message => $input->text(
 268                         msg => 'Textarea default', {rows => 4, style => 'background:red'}
 269                 ) ],
 270                 [ Gender => join ' or ', $input->radio(
 271                         sex => [qw(m f)], [qw(Male Female)]
 272                 ) ],
 273                 [ Colour => scalar $input->select(
 274                         favcolour => [qw(Blue Green Red)], 'Green'
 275                 ) ],
 276                 [ Options => $input->check(
 277                         spam => 'Receive weekly newsletter'
 278                 ) ],
 279         );
 280         say $input->stop; # </form>
 281
 282 =head1 DESCRIPTION
 283
 284 Set up a form object with new().  The HTML for the opening and closing
 285 C<< <form> >> tags are returned by the start() and stop() methods.
 286
 287 The L<hidden>, L<text>, L<select>, L<radio>, and L<check> methods all
 288 correspond to various input types.  The first argument is always the mandatory
 289 name, and a hash ref as the last argument can optionally be provided for
 290 additional attributes/options.  Everything is properly escaped.
 291
 292 =over
 293
 294 =item C<hidden>
 295
 296 Returns the HTML for a simple C<< <input type="hidden"> >> with specified name
 297 and value (both are required by HTML specs).
 298
 299         $input->hidden('name', 'value');
 300
 301 As with all methods, a final hash ref can be given to add further attributes.
 302 While rarely needed in this case, it can also be used as an override or
 303 alternative to value and name:
 304
 305         $input->hidden({name => 'name', value => 'value'})
 306
 307 =item C<text>
 308
 309 The common C<< <input type="text"> >>.
 310
 311         $input->text('name', 'default');
 312
 313 If the I<rows> option is set, substitutes a similarly set up C<< <textarea> >>:
 314
 315         $input->text('name', 'default', {rows => 4});
 316
 317 =item C<select>
 318
 319         $input->select('name', ['option'], 'default');
 320
 321 Provides C<< <select><option> >> dropdown by default, but can also output
 322 multiple C<< <input> >> tags if a I<type> is provided:
 323
 324         $input->select('name', ['1'], {type => 'checkbox'});
 325
 326 In scalar context, options are joined together by C<$,> (C<$OUTPUT_FIELD_SEPARATOR>).
 327 Otherwise a list of tags is returned.
 328
 329 Each option can be given as either a simple string containing its I<value>,
 330 or a hash ref with custom attributes.
 331 When there's no parent tag (only C<< <input> >>s), a fourth parameter can
 332 provide common options which will be inherited by each element.  Otherwise,
 333 options will apply to either the C<< <select> >> or an C<< <option> >>.
 334
 335 The default value (either as a third scalar parameter, or with the general
 336 I<value> option) will be matched to the value of each option, and if equal,
 337 its I<selected> or I<checked> attribute will be set as appropriate.
 338
 339 =item C<radio>
 340
 341 In fact just a shorthand to L<select> with a preset type of I<radio>, but takes
 342 an additional third argument to easily set the label for each option:
 343
 344         $input->radio('name', ['option'], ['option label'], 'default');
 345
 346 This would be the same as saying:
 347
 348         $input->radio(
 349                 'name',
 350                 [ {label => 'option label', value => 'option'} ],
 351                 {value => 'default'}
 352         );
 353
 354 =item C<check>
 355
 356 Also a L<select> shorthand, but with a I<checkbox> type.
 357 Instead of values, the second argument specifies option I<label>s.
 358 The values by default are set to an auto-incrementing number starting with 1.
 359
 360 Furthermore, the I<checked> status for each option can be specified by a third
 361 argument.  Either a single boolean value defining all rows, or an array ref
 362 with the value for each row in order.
 363
 364         $input->check('name', ['label', 'second option'], [0, 1]);
 365
 366 Or more descriptive but identical:
 367
 368         $input->check('name', [
 369                 {label => 'label',         value => 1, checked => 0},
 370                 {label => 'second option', value => 2, checked => 1},
 371         ]);
 372
 373 =back
 374
 375 =head1 TODO
 376
 377 =over
 378
 379 =item C<default()> method
 380
 381         $input->hidden(foo => $input->default('foo'));
 382         $hash_ref = $input->default;
 383         $input->default('foo') = 'new value';
 384         undef $input->default;  # clear all
 385                 # XXX: does this equal $input->default=undef;?
 386         $input->default = {amend => 'stuff'};
 387
 388 =item documentation
 389
 390 Actual descriptions instead of just a synopsis.
 391
 392 =item C<quote> override
 393
 394 Allow custom value quotation function.
 395 Makes L<XML::Quote|XML::Quote> dependency optional.
 396
 397 =item single checkbox id
 398
 399 Do not add value to single check() by default.
 400
 401 =back
 402
 403 =head1 AUTHOR
 404
 405 Mischa POSLAWSKY <perl@shiar.org>
 406
 407 =head1 LICENSE
 408
 409 This module is free software; you can redistribute it and/or modify it
 410 under the same L<terms|perlartistic> as Perl itself.
 411