File Coverage

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

Criterion	Covered	Total	%
statement	59	59	100.0
branch	26	26	100.0
condition	6	6	100.0
subroutine	12	12	100.0
pod	6	6	100.0
total	109	109	100.0

use strict;
use warnings;
package HTML::Widget::Plugin::Select;
# ABSTRACT: a widget for selection from a list
$HTML::Widget::Plugin::Select::VERSION = '0.202';
use parent 'HTML::Widget::Plugin';

#pod =head1 SYNOPSIS
#pod
#pod   $widget_factory->select({
#pod     id      => 'the-selector', # if no name attr given, defaults to id value
#pod     value   => 10,
#pod     options => [
#pod       [  0 => "Zero" ],
#pod       [  5 => "Five" ],
#pod       [ 10 => "Ten"  ],
#pod     ],
#pod   });
#pod
#pod =head1 DESCRIPTION
#pod
#pod This plugin provides a select-from-list widget.
#pod
#pod The C attribute may be used to add a default class to every
#pod produced input.  This class cannot be overridden.
#pod
#pod   my $plugin = HTML::Widget::Factory::Input->new({
#pod     default_classes => [ qw(foo bar) ],
#pod   });
#pod
#pod =head1 METHODS
#pod
#pod =head2 C< provided_widgets >
#pod
#pod This plugin provides the following widgets: select
#pod
#pod =cut

sub provided_widgets { qw(select) }

#pod =head2 C< select >
#pod
#pod This method returns a select-from-list widget.
#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 may be an arrayref of arrayrefs, each containing a value/name pair, or it
#pod may be a hashref of values and names.
#pod
#pod Use the array form if you need multiple entries for a single value or if order
#pod is important.
#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

use HTML::Element;

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

sub select { ## no critic Builtin
  my ($self, $factory, $arg) = @_;

  $self->build($factory, $arg);
}

#pod =head2 C< build >
#pod
#pod  my $widget = $class->build($factory, \%arg)
#pod
#pod This method does the actual construction of the widget based on the args set up
#pod in the exported widget-constructing call.  It's here for subclasses to exploit.
#pod
#pod =cut

sub build {
  my ($self, $factory, $arg) = @_;
  $arg->{attr}{name} = $arg->{attr}{id} unless $arg->{attr}{name};

  my $widget = HTML::Element->new('select');

  my @options;
  if (ref $arg->{options} eq 'HASH') {
    @options = map { [ $_, $arg->{options}{$_} ] } keys %{ $arg->{options} };
  } else {
    @options = @{ $arg->{options} };
    Carp::croak "undefined value passed to select widget"
      if grep { not(defined $_) or ref $_ and not defined $_->[0] } @options;
  }

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

  for my $entry (@options) {
    my ($value, $name) = (ref $entry) ? @$entry : ($entry) x 2;
    my $option = $self->make_option($factory, $value, $name, $arg);
    $widget->push_content($option);
  }

  $widget->attr($_ => $arg->{attr}{$_}) for keys %{ $arg->{attr} };
  return $widget->as_XML;
}

#pod =head2 C< make_option >
#pod
#pod   my $option = $class->make_option($factory, $value, $name, $arg);
#pod
#pod This method constructs the HTML::Element option element that will represent one
#pod of the options that may be put into the select box.  This is here for
#pod subclasses to exploit.
#pod
#pod =cut

sub make_option {
  my ($self, $factory, $value, $name, $arg) = @_;

  my $option = HTML::Element->new('option', value => $value);
     $option->push_content($name);
     $option->attr(selected => 'selected')
       if defined $arg->{value} and $arg->{value} eq $value;

  return $option;
}

#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;
  # maybe this should be configurable?
  if ($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 '$matches' matches more than one option";
    }
  }
}

sub rewrite_arg {
  my ($self, $arg, @rest) = @_;

  $arg = $self->SUPER::rewrite_arg($arg, @rest);

  if ($self->{default_classes}) {
    my $class = join q{ }, @{ $self->{default_classes} };
    $arg->{attr}{class} = defined $arg->{attr}{class}
      ? "$class $arg->{attr}{class}"
      : $class;
  }

  return $arg;
}


1;

__END__