<html><head><meta name="color-scheme" content="light dark"></head><body><pre style="word-wrap: break-word; white-space: pre-wrap;">package HTML::Form::ListInput;

use strict;
use parent 'HTML::Form::Input';

use Carp 'croak';

our $VERSION = '6.11';

# ABSTRACT: An HTML form list input element for use with HTML::Form

#select/option   (val1, val2, ....)
#input/radio     (undef, val1, val2,...)
#input/checkbox  (undef, value)
#select-multiple/option (undef, value)

sub new {
    my $class = shift;
    my $self  = $class-&gt;SUPER::new(@_);

    my $value      = delete $self-&gt;{value};
    my $value_name = delete $self-&gt;{value_name};
    my $type       = $self-&gt;{type};

    if ( $type eq "checkbox" ) {
        $value = "on" unless defined $value;
        $self-&gt;{menu} = [
            { value =&gt; undef,  name =&gt; "off", },
            { value =&gt; $value, name =&gt; $value_name, },
        ];
        $self-&gt;{current} = ( delete $self-&gt;{checked} ) ? 1 : 0;

    }
    else {
        $self-&gt;{option_disabled}++
            if $type eq "radio" &amp;&amp; delete $self-&gt;{disabled};
        $self-&gt;{menu} = [
            { value =&gt; $value, name =&gt; $value_name },
        ];
        my $checked = $self-&gt;{checked} || $self-&gt;{option_selected};
        delete $self-&gt;{checked};
        delete $self-&gt;{option_selected};
        if ( exists $self-&gt;{multiple} ) {
            unshift( @{ $self-&gt;{menu} }, { value =&gt; undef, name =&gt; "off" } );
            $self-&gt;{current} = $checked ? 1 : 0;
        }
        else {
            $self-&gt;{current} = 0 if $checked;
        }
    }
    $self;
}

sub add_to_form {
    my ( $self, $form ) = @_;
    my $type = $self-&gt;type;

    return $self-&gt;SUPER::add_to_form($form)
        if $type eq "checkbox";

    if ( $type eq "option" &amp;&amp; exists $self-&gt;{multiple} ) {
        $self-&gt;{disabled} ||= delete $self-&gt;{option_disabled};
        return $self-&gt;SUPER::add_to_form($form);
    }

    Carp::croak "Assert" if @{ $self-&gt;{menu} } != 1;
    my $m = $self-&gt;{menu}[0];
    $m-&gt;{disabled}++ if delete $self-&gt;{option_disabled};

    # if there was no name we have to search for an input that explicitly has
    # no name either, because otherwise the name attribute would be ignored
    my $prev = $form-&gt;find_input(
        $self-&gt;{name} || \undef, $self-&gt;{type},
        $self-&gt;{idx}
    );
    return $self-&gt;SUPER::add_to_form($form) unless $prev;

    # merge menus
    $prev-&gt;{current} = @{ $prev-&gt;{menu} } if exists $self-&gt;{current};
    push( @{ $prev-&gt;{menu} }, $m );
}

sub fixup {
    my $self = shift;
    if ( $self-&gt;{type} eq "option" &amp;&amp; !( exists $self-&gt;{current} ) ) {
        $self-&gt;{current} = 0;
    }
    $self-&gt;{menu}[ $self-&gt;{current} ]{seen}++ if exists $self-&gt;{current};
}

sub disabled {
    my $self = shift;
    my $type = $self-&gt;type;

    my $old = $self-&gt;{disabled} || _menu_all_disabled( @{ $self-&gt;{menu} } );
    if (@_) {
        my $v = shift;
        $self-&gt;{disabled} = $v;
        for ( @{ $self-&gt;{menu} } ) {
            $_-&gt;{disabled} = $v;
        }
    }
    return $old;
}

sub _menu_all_disabled {
    for (@_) {
        return 0 unless $_-&gt;{disabled};
    }
    return 1;
}

sub value {
    my $self = shift;
    my $old;
    $old = $self-&gt;{menu}[ $self-&gt;{current} ]{value}
        if exists $self-&gt;{current};
    $old = $self-&gt;{value} if exists $self-&gt;{value};
    if (@_) {
        my $i   = 0;
        my $val = shift;
        my $cur;
        my $disabled;
        for ( @{ $self-&gt;{menu} } ) {
            if (
                (
                       defined($val)
                    &amp;&amp; defined( $_-&gt;{value} )
                    &amp;&amp; $val eq $_-&gt;{value}
                )
                || ( !defined($val) &amp;&amp; !defined( $_-&gt;{value} ) )
            ) {
                $cur      = $i;
                $disabled = $_-&gt;{disabled};
                last unless $disabled;
            }
            $i++;
        }
        if ( !( defined $cur ) || $disabled ) {
            if ( defined $val ) {

                # try to search among the alternative names as well
                my $i = 0;
                my $cur_ignorecase;
                my $lc_val = lc($val);
                for ( @{ $self-&gt;{menu} } ) {
                    if ( defined $_-&gt;{name} ) {
                        if ( $val eq $_-&gt;{name} ) {
                            $disabled = $_-&gt;{disabled};
                            $cur      = $i;
                            last unless $disabled;
                        }
                        if ( !defined($cur_ignorecase)
                            &amp;&amp; $lc_val eq lc( $_-&gt;{name} ) ) {
                            $cur_ignorecase = $i;
                        }
                    }
                    $i++;
                }
                unless ( defined $cur ) {
                    $cur = $cur_ignorecase;
                    if ( defined $cur ) {
                        $disabled = $self-&gt;{menu}[$cur]{disabled};
                    }
                    elsif ( $self-&gt;{strict} ) {
                        my $n = $self-&gt;name;
                        Carp::croak("Illegal value '$val' for field '$n'");
                    }
                }
            }
            elsif ( $self-&gt;{strict} ) {
                my $n = $self-&gt;name;
                Carp::croak("The '$n' field can't be unchecked");
            }
        }
        if ( $self-&gt;{strict} &amp;&amp; $disabled ) {
            my $n = $self-&gt;name;
            Carp::croak("The value '$val' has been disabled for field '$n'");
        }
        if ( defined $cur ) {
            $self-&gt;{current} = $cur;
            $self-&gt;{menu}[$cur]{seen}++;
            delete $self-&gt;{value};
        }
        else {
            $self-&gt;{value} = $val;
            delete $self-&gt;{current};
        }
    }
    $old;
}

sub check {
    my $self = shift;
    $self-&gt;{current} = 1;
    $self-&gt;{menu}[1]{seen}++;
}

sub possible_values {
    my $self = shift;
    map $_-&gt;{value}, grep !$_-&gt;{disabled}, @{ $self-&gt;{menu} };
}

sub other_possible_values {
    my $self = shift;
    map $_-&gt;{value}, grep !$_-&gt;{seen} &amp;&amp; !$_-&gt;{disabled}, @{ $self-&gt;{menu} };
}

sub value_names {
    my $self = shift;
    my @names;
    for ( @{ $self-&gt;{menu} } ) {
        my $n = $_-&gt;{name};
        $n = $_-&gt;{value} unless defined $n;
        push( @names, $n );
    }
    @names;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

HTML::Form::ListInput - An HTML form list input element for use with HTML::Form

=head1 VERSION

version 6.11

=head1 AUTHOR

Gisle Aas &lt;gisle@activestate.com&gt;

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 1998 by Gisle Aas.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut
</pre></body></html>