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