view release on metacpan or  search on metacpan

Widgets/ListBox.pm  view on Meta::CPAN

use Carp;
use Curses;
use Curses::Widgets;

($VERSION) = (q$Revision: 1.104 $ =~ /(\d+(?:\.(\d+))+)/);
@ISA = qw(Curses::Widgets);

#####################################################################
#
# Module code follows
#
#####################################################################

=head1 METHODS

=head2 new (inherited from Curses::Widgets)

  $tm = Curses::Widgets::ListBox->new({
    CAPTION     => 'List',
    CAPTIONCOL  => 'yellow',
    COLUMNS     => 10,
    LINES       => 3,
    VALUE       => 0,
    INPUTFUNC   => \&scankey,
    FOREGROUND  => 'white',
    BACKGROUND  => 'black',
    SELECTEDCOL => 'green',
    BORDER      => 1,
    BORDERCOL   => 'red',
    FOCUSSWITCH => "\t",
    X           => 1,
    Y           => 1,
    TOPELEMENT  => 0,
    LISTITEMS   => [@list],
    });

The new method instantiates a new ListBox object.  The only mandatory
key/value pairs in the configuration hash are B<X> and B<Y>.  All others
have the following defaults:

  Key           Default   Description
  ============================================================
  CAPTION         undef   Caption superimposed on border
  CAPTIONCOL      undef   Foreground colour for caption text
  COLUMNS            10   Number of columns displayed
  LINES               3   Number of lines in the window
  INPUTFUNC   \&scankey   Function to use to scan for keystrokes
  FOREGROUND      undef   Default foreground colour
  BACKGROUND      undef   Default background colour
  SELECTEDCOL     undef   Default colour of selected items
  BORDER              1   Display a border around the field
  BORDERCOL       undef   Foreground colour for border
  FOCUSSWITCH      "\t"   Characters which signify end of input
  TOPELEMENT          0   Index of element displayed on line 1
  LISTITEMS          []   List of list items
  MULTISEL            0   Whether or not multiple items can be 
                          selected
  TOGGLE         "\n\s"   What input toggles selection of the 
                          current item
  VALUE         0 or []   Index(es) of selected items
  CURSORPOS           0   Index of the item the cursor is 
                          currently on

The B<CAPTION> is only valid when the B<BORDER> is enabled.  If the border
is disabled, the field will be underlined, provided the terminal supports it.

The value of B<VALUE> should be an array reference when in multiple
selection mode.  Otherwise it should either undef or an integer.

=cut

sub _conf {
  # Validates and initialises the new ListBox object.
  #
  # Usage:  $self->_conf(%conf);

  my $self = shift;
  my %conf = ( 
    COLUMNS     => 10,
    LINES       => 3,
    VALUE       => undef,
    INPUTFUNC   => \&scankey,
    BORDER      => 1,
    FOCUSSWITCH => "\t",
    TOPELEMENT  => 0,
    LISTITEMS   => [],
    MULTISEL    => 0,
    VALUE       => undef,
    CURSORPOS   => 0,
    TOGGLE      => "\n ",
    @_ 
    );
  my @required = qw(X Y);
  my $err = 0;

  # Check for required arguments
  foreach (@required) { $err = 1 unless exists $conf{$_} };

  $conf{SELECTEDCOL} = lc($conf{SELECTEDCOL}) if exists $conf{SELECTEDCOL};

  # Make sure no errors are returned by the parent method
  $err = 1 unless $self->SUPER::_conf(%conf);

  # Update VALUE depending on selection mode
  $conf{VALUE} = [] if $conf{MULTISEL} and not exists $conf{VALUE};

  return $err == 0 ? 1 : 0;
}

=head2 draw

  $lb->draw($mwh, 1);

The draw method renders the list box in its current state.  This
requires a valid handle to a curses window in which it will render
itself.  The optional second argument, if true, will cause the field's
text cursor to be rendered as well.

=cut

sub _border {
  my $self = shift;
  my $dwh = shift;
  my $conf = $self->{CONF};
  my ($top, $pos, $lines, $cols, $items) = 
    @$conf{qw(TOPELEMENT CURSORPOS LINES COLUMNS LISTITEMS)};
  my ($y, $x);

  # Render the box
  $self->SUPER::_border($dwh);

  # Adjust the cursor position if it's out of whack
  $pos = $#{$items} if $pos > $#{$items};
  while ($pos - $top > $lines - 1) { $top++ };
  while ($top > $pos) { --$top };

  # Render up/down arrows as needed
  $dwh->getmaxyx($y, $x);
  $dwh->addch(0, $x - 2, ACS_UARROW) if $top > 0;
  $dwh->addch($y - 1, $x - 2, ACS_DARROW) if 
    $top + $lines < @$items ;

  # Restore the default settings
  $self->_restore($dwh);

  # Save any massaged values
  @$conf{qw(TOPELEMENT CURSORPOS)} = ($top, $pos);
}

sub _content {
  my $self = shift;
  my $dwh = shift;
  my $conf = $self->{CONF};
  my ($pos, $top, $border, $cols, $lines, $sel) = 
    @$conf{qw(CURSORPOS TOPELEMENT BORDER COLUMNS LINES VALUE)};
  my @items = @{$$conf{LISTITEMS}};
  my (@colours, $i);

  # Turn on underlining (terminal-dependent) if no border is used
  $dwh->attron(A_UNDERLINE) unless $border;

  # Display the items on the list
  if (scalar @items) {

    # Display the items
    for $i ($top..$#items) {
      @colours = @$conf{qw(FOREGROUND BACKGROUND)};
      if (defined $sel &&
        grep /^$i$/, (ref($sel) eq 'ARRAY' ? @$sel : $sel)) {

        # Set the colour for selected items
        if (exists $$conf{SELECTEDCOL}) {
          $colours[0] = $$conf{SELECTEDCOL};
          $dwh->attrset(COLOR_PAIR(select_colour(
            @$conf{qw(SELECTEDCOL BACKGROUND)})));
          $dwh->attron(A_BOLD) if $$conf{SELECTEDCOL} eq 'yellow';

        # Bold it if no selection colour was defined
        } else {
          $dwh->attron(A_BOLD);
        }
      }

      # Print the item
      $dwh->addstr($i - $top, 0, substr($items[$i], 0, $cols));

      # Underline the line if there's no border
      $dwh->chgat($i - $top, 0, $cols, A_UNDERLINE, select_colour(@colours), 
        0) unless $border;

      # Restore the default settings
      $self->_restore($dwh);
    }
  }
}

sub _cursor {
  my $self = shift;
  my $dwh = shift;
  my $conf = $self->{CONF};
  my ($pos, $top, $cols, $sel) = 
    @$conf{qw(CURSORPOS TOPELEMENT COLUMNS VALUE)};
  my $fg;

  # Determine the foreground colour
  if (defined $sel && exists $$conf{SELECTEDCOL} &&
    grep /^$pos$/, (ref($sel) eq 'ARRAY' ? @$sel : $sel)) {
    $fg = $$conf{SELECTEDCOL};
  } else {
    $fg = $$conf{FOREGROUND};
  }

  # Display the cursor
  $dwh->chgat($pos - $top, 0, $cols, A_STANDOUT, select_colour(
    $fg, $$conf{BACKGROUND}), 0);

  # Restore the default settings
  $self->_restore($dwh);
}

sub input_key {
  # Process input a keystroke at a time.
  #
  # Usage:  $self->input_key($key);

  my $self = shift;
  my $in = shift;
  my $conf = $self->{CONF};
  my $sel = $$conf{VALUE};
  my @items = @{$$conf{LISTITEMS}};
  my $pos = $$conf{CURSORPOS};
  my $re = $$conf{TOGGLE};
  my $np;

  # Process special keys
  if ($in eq KEY_UP) {
    if ($pos > 0) {
      --$pos;
    } else {
      beep;
    }
  } elsif ($in eq KEY_DOWN) {
    if ($pos < $#items) {
      ++$pos;
    } else {
      beep;
    }
  } elsif ($in eq KEY_HOME || $in eq KEY_END || $in eq KEY_PPAGE ||
    $in eq KEY_NPAGE) {

    if (scalar @items) {
      if ($in eq KEY_HOME) {
        beep if $pos == 0;
        $pos = 0;
      } elsif ($in eq KEY_END) {
        beep if $pos == $#items;
        $pos = $#items;
      } elsif ($in eq KEY_PPAGE) {
        beep if $pos == 0;
        $pos -= $$conf{LINES};
        $pos = 0 if $pos < 0;
      } elsif ($in eq KEY_NPAGE) {
        beep if $pos == $#items;
        $pos += $$conf{LINES};
        $pos = $#items if $pos > $#items;
      }
    } else {
      beep;
    }

  # Process normal key strokes
  } else {