File Coverage

blib/lib/HTML/Widget/Plugin/Radio.pm

Criterion	Covered	Total	%
statement	50	51	98.0
branch	23	26	88.4
condition	7	12	58.3
subroutine	9	9	100.0
pod	3	3	100.0
total	92	101	91.0

use strict;
use warnings;
package HTML::Widget::Plugin::Radio;
# ABSTRACT: a widget for sets of radio buttons
$HTML::Widget::Plugin::Radio::VERSION = '0.202';
use parent 'HTML::Widget::Plugin';

#pod =head1 SYNOPSIS
#pod
#pod   $widget_factory->radio({
#pod     name    => 'radio',
#pod     value   => 'value_1',
#pod     options => [
#pod       [ value_1 => "Description 1" ],
#pod       [ value_2 => "Description 2" ],
#pod       [ value_2 => "Description 2", 'optional-elem-id' ],
#pod     ],
#pod   });
#pod
#pod This will emit roughly:
#pod
#pod
#pod   checked='checked'>
#pod   Description 2
#pod
#pod
#pod   Description 2
#pod
#pod
#pod   id='optional-elem-id'>
#pod   Description 2
#pod
#pod =head1 DESCRIPTION
#pod
#pod This plugin provides a radio button-set widget
#pod
#pod =cut

use HTML::Element;

#pod =head1 METHODS
#pod
#pod =head2 C< provided_widgets >
#pod
#pod This plugin provides the following widgets: radio
#pod
#pod =cut

sub provided_widgets { qw(radio) }

#pod =head2 C< radio >
#pod
#pod This method returns a set of radio buttons.
#pod
#pod In addition to the generic L attributes, the following
#pod are valid arguments:
#pod
#pod =over
#pod
#pod =item disabled
#pod
#pod If true, this option indicates that the select widget can't be changed by the
#pod user.
#pod
#pod =item ignore_invalid
#pod
#pod If this is given and true, an invalid value is ignored instead of throwing an
#pod exception.
#pod
#pod =item options
#pod
#pod This option must be a reference to an array of allowed values, each of which
#pod will get its own radio button.
#pod
#pod =item value
#pod
#pod If this argument is given, the option with this value will be pre-selected in
#pod the widget's initial state.
#pod
#pod An exception will be thrown if more or less than one of the provided options
#pod has this value.
#pod
#pod =back
#pod
#pod =cut

sub _attribute_args { qw(disabled) }
sub _boolean_args   { qw(disabled) }

sub radio {
  my ($self, $factory, $arg) = @_;

  my @widgets;

  $self->validate_value($arg->{value}, $arg->{options})
    unless $arg->{ignore_invalid};

  if (my $id_attr = delete $arg->{attr}{id}) {
    Carp::cluck "id may not be used as a widget-level attribute for radio";
    $arg->{attr}{name} = $id_attr if not defined $arg->{attr}{name};
  }

  for my $option (@{ $arg->{options} }) {
    my ($value, $text, $id) = (ref $option) ? (@$option) : (($option) x 2);

    my $widget = HTML::Element->new('input', type => 'radio');
    $widget->attr($_ => $arg->{attr}{$_}) for keys %{ $arg->{attr} };

    $id = "$arg->{attr}{name}-$value"
      if ! defined $id and defined $arg->{attr}{name};

    $widget->attr(id => $id) if defined $id;

    $widget->attr(value => $value);

    $widget->attr(checked => 'checked')
      if defined $arg->{value} and $arg->{value} eq $value;

    push @widgets, $widget;

    my $text_elem = HTML::Element->new('~literal', text => $text);
    if (! $arg->{parts} and defined $id) {
      my $label = HTML::Element->new(label => (for => $id));
      $label->push_content($text_elem);
      push @widgets, $label;
    } else {
      push @widgets, $text_elem;
    }
  }

  # XXX document
  return @widgets if wantarray and $arg->{parts};

  return join q{}, map { $_->as_XML } @widgets;
}

#pod =head2 C< validate_value >
#pod
#pod This method checks whether the given value option is valid.  See C>
#pod for an explanation of its default rules.
#pod
#pod =cut

sub validate_value {
  my ($class, $value, $options) = @_;

  my @options = map { ref $_ ? $_->[0] : $_ } @$options;

  if (defined $value) {
    my $matches = grep { $value eq $_ } @options;

    if (not $matches) {
      Carp::croak "provided value '$value' not in given options: "
                . join(q{ }, map { "'$_'" } @options);
    } elsif ($matches > 1) {
      Carp::croak "provided value '$value' matches more than one option";
    }
  }
}

1;

__END__