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