File Coverage

blib/lib/HTML/Menu/Select.pm

Criterion	Covered	Total	%
statement	59	63	93.6
branch	25	30	83.3
condition	6	6	100.0
subroutine	7	7	100.0
pod	3	3	100.0
total	100	109	91.7

package HTML::Menu::Select;
use 5.004;
use strict;
use Carp 'carp';

our $VERSION = '1.01';

require Exporter;
our @ISA = qw( Exporter );

our @EXPORT_OK = qw(
 options menu popup_menu
 );

our %EXPORT_TAGS = ( all => \@EXPORT_OK );

our @KNOWN_KEYS = qw(
  name value values default defaults labels attributes size multiple override );


sub popup_menu { &menu };

sub menu {
  my %arg  = (ref $_[0]) ? %{$_[0]} : @_;
  my $html = '';

  $arg{name} = '' if not exists $arg{name};

  $html = sprintf '

  for my $key (keys %arg) {
    if (! grep {$key eq $_} @KNOWN_KEYS) {
      $html .= sprintf ' %s="%s"', $key, _escapeHTML( $arg{$key} );
    }
  }

  $html .= ">\n";
  $html .= options(%arg);
  $html .= "\n";

  return $html;
}


sub options {
  my %arg  = (ref $_[0]) ? %{$_[0]} : @_;
  my $html  = '';

  # aliases
  for (qw/ value default /) {
    $arg{$_} = $arg{"${_}s"}
      if exists $arg{"${_}s"};

    $arg{$_} = [$arg{$_}]
      if exists $arg{$_} && ! ref $arg{$_};
  }

  # don't support CGI.pm's 'override' argument
  if (exists $arg{override}) {
    carp "CGI.pm's 'override' argument is not supported by HTML::Menu::Select";
  }

  for my $option (@{ $arg{value} }) {
    $html .= '

    for my $default (@{ $arg{default} }) {
      if ($option eq $default) {
        $html .= 'selected="selected" ';
      }
    }

    for my $att (keys %{ $arg{attributes} }) {
      if ($att eq $option) {
        for (keys %{ $arg{attributes}{$att} }) {
          $html .= sprintf '%s="%s" ',
                           $_,
                           _escapeHTML( $arg{attributes}{$att}{$_} );
        }
      }
    }

    $html .= sprintf 'value="%s">', _escapeHTML( $option );

    if (exists $arg{labels} && exists $arg{labels}{$option}) {
      $html .= _escapeHTML( $arg{labels}{$option} );
    }
    else {
      $html .= _escapeHTML( $option );
    }

    $html .= '';
    $html .= "\n";
  }

  return $html;
}


sub _escapeHTML {
  my ($escape) = (@_);

  return unless defined $escape;

  if (exists $::INC{'CGI.pm'}) {
    return CGI::escapeHTML( $escape );
  }
  elsif (exists $::INC{'CGI/Simple/Util.pm'}) {
    return CGI::Simple::Util::escapeHTML( $escape );
  }
  elsif (exists $::INC{'HTML/Entities.pm'}) {
    return HTML::Entities::encode_entities( $escape );
  }
  elsif (exists $::INC{'Apache/Util.pm'}) {
    return Apache::Util::escape_html( $escape );
  }

  # looks like nothing's already loaded to do it for us
  $escape =~ s/&/&/gs;
  $escape =~ s/
  $escape =~ s/>/>/gs;
  $escape =~ s/"/"/gs;

  return $escape;
}

1;

__END__