File Coverage

blib/lib/Term/Completion.pm

Criterion	Covered	Total	%
statement	32	309	10.3
branch	9	160	5.6
condition	1	44	2.2
subroutine	7	18	38.8
pod	8	9	88.8
total	57	540	10.5

package Term::Completion;

use strict;
use warnings;
use Carp qw(croak);
use IO::Handle;

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

our $VERSION = '1.00';

our %DEFAULTS = (
    # input/output channels
    in       => \*STDIN,
    out      => \*STDOUT,
    # key definitions
    tab      => qr/\t/,
    list     => qr/\cd/,
    'kill'   => qr/\cu/,
    erase    => qr/[\177\010]/, # BS and DEL
    wipe     => qr/\cw/,
    enter    => qr/[\r\n]/,
    up       => qr/\cp|\x1b\[[AD]/, # CTRL-p, up arrow, left arrow
    down     => qr/\cn|\x1b\[[BC]/, # CTRL-n, down arrow, right arrow
    # key definitions for paging
    quit     => qr/[\ccq]/, # CTRL-C or q
    # output parameters
    prompt   => '',
    columns  => 80, # default, if no Term::Size available
    rows     => 24,
    bell     => "\a",
    page_str => '--more--',
    eol      => "\r\n",
    del_one  => "\b \b",
    # help
    help     => undef,
    helptext => undef,
    # default: empty list of choices
    choices  => [],
    default  => ''
);

# selection which TTY handler to use
sub import
{
  my $class = shift;
  my @syms;
  # TODO Win32?
  my $termhandler = ($^O !~ /interix/i ? 'Term::Completion::_readkey' :
    'Term::Completion::_POSIX');
  foreach(@_) {
    if(/^:posix$/) {
      $termhandler = 'Term::Completion::_POSIX';
    }
    elsif(/^:stty$/) {
      $termhandler = 'Term::Completion::_stty';
    }
    elsif(/^:readkey$/) {
      $termhandler = 'Term::Completion::_readkey';
    }
    elsif(/^:DEFAULT$/ || !/^:/) {
      push(@syms, $_);
    }
    else {
      croak __PACKAGE__ . " does not export '$_'";
    }
  }
  eval "require $termhandler;";
  if($@) {
    croak "Cannot initialize ".__PACKAGE__.", error occurred while loading auxiliary class $termhandler:\n$@";
  }
  push(@ISA, $termhandler);
  $class->export_to_level(1, $class, @syms);
}

sub _get_defaults
{
  my %def = %DEFAULTS;
  delete @def{qw(columns rows)};
  return %def;
}

sub new
{
  my __PACKAGE__ $class = shift;

  if(ref $class) {
    $class = ref $class;
  }
  my %args = @_;
  my $this = bless({$class->_get_defaults, %args}, $class);
  return $this;
}

#sub DESTROY
#{
#  my __PACKAGE__ $this = shift;
#  1;
#}

# old style interface
sub Complete
{
  my $prompt = shift;
  $prompt = '' unless defined $prompt;

  my @choices;
  if (ref $_[0] || $_[0] =~ /^\*/) {
    @choices = sort @{$_[0]};
  } else {
    @choices = sort(@_);
  }

  __PACKAGE__->new(
    prompt => $prompt,
    choices => \@choices
  )->complete;
}

# sub get_key
# virtual - defined in tty driver classes

sub show_help
{
  my __PACKAGE__ $this = shift;
  my $text = $this->{helptext} || '';
  $text =~ s/\r?\n|\n?\r/$this->{eol}/g;
  $this->{out}->print($text);
}

sub complete
{
  my __PACKAGE__ $this = shift;

  my $return = $this->{default};
  my $r = length($return);

  if(defined $this->{helptext} && !defined $this->{help}) {
    $this->show_help();
  }

  # we grab full control of the terminal, switch off echo
  $this->set_raw_tty();

  my $tab_pressed = 0; # repeated tab counter
  my $choice_num; # selector
  my @choice_cycle;
  my $eof = 0;

  # handle terminal size changes
  # save any existing signal handler
  if(exists $SIG{'WINCH'}) {
    $this->{_sig_winch} = $SIG{WINCH};
    # set new signal handler
    local $SIG{'WINCH'} = sub {
      if($this->{_sig_winch}) {
        &{$this->{_sig_winch}};
      }
      # write new prompt and completion line
      $this->{out}->print($this->{eol}, $this->{prompt}, $return);
    };
  }

  # main loop for completion
  LOOP: {
    local $_ = '';
    $this->{out}->print($this->{prompt}, $return);
    my $key;
    GETC: while (defined($key = $this->get_key) && ($_ .= $key, $_ !~ $this->{enter})) {
      CASE: {
        # deal with arrow key escape sequences
        if(/^\x1b([^\[])/ || /^\x1b\[(?:[A-Z]|\d+~)(.)/) {
          # unknown ESC sequence: just keep the last key typed
          $_ = $1;
          redo CASE;
        }

        # (TAB) attempt completion
        $_ =~ $this->{tab} && do {
          if($tab_pressed++) {
            $this->show_choices($return);
            redo LOOP;
          }
          my @match = $this->get_choices($return);
          if (@match == 0) {
            # sound bell if there is no match
            $this->bell();
          } else {
            my $l = length(my $test = shift(@match));
            if(@match) {
              # sound bell if multiple choices
              $this->bell();
            }
            elsif($this->{delim}) {
              $test .= $this->{delim};
              $l++;
            }
            foreach my $cmp (@match) {
              until (substr($cmp, 0, $l) eq substr($test, 0, $l)) {
                $l--;
              }
            }
            my $add = $l - $r;
            if($add) {
              $this->{out}->print($test = substr($test, $r, $add));
              # reset counter if something was added
              $tab_pressed = 0;
              $choice_num = undef;
              $return .= $test;
              $r += $add;
            }
          }
          last CASE;
        };

        $tab_pressed = 0; # reset repeated tab counter

        # (^D) completion list
        $_ =~ $this->{list} && do {
          $this->show_choices($return);
          redo LOOP;
        };

        # on-demand help
        if(defined $this->{help}) {
          $_ =~ $this->{help} && do {
            if(defined $this->{helptext}) {
              $this->{out}->print($this->{eol});
              $this->show_help();
            }
            redo LOOP;
          };
        }

        # (^U) kill
        $_ =~ $this->{'kill'} && do {
          if ($r) {
            # start over on a new line
            $r = 0;
            $return = "";
            $this->{out}->print($this->{eol});
            $choice_num = undef;
            redo LOOP;
          }
          last CASE;
        };

        # (DEL) || (BS) erase
        $_ =~ $this->{erase} && do {
          if($r) {
            $this->{out}->print($this->{del_one});
            chop($return);
            $r--;
            $choice_num = undef;
          }
          last CASE;
        };

        # ^W wipe until separator
        $_ =~ $this->{wipe} && do {
          if($r) {
            my $sep = '';
            $sep = $this->{sep} if defined $this->{sep};
            $sep .= $this->{delim} if defined $this->{delim};
            if(length($sep) && $return =~ s/((?:^|[$sep$sep]+)[^$sep$sep]*[$sep$sep]*)$//s) {
              my $cut = $1;
              $this->{out}->print($this->{del_one} x length($cut));
              $r = length($return);
              $choice_num = undef;
            }
          }
          last CASE;
        };

        # up (CTRL-P)
        $_ =~ $this->{up} && do {
          unless(defined $choice_num) {
            @choice_cycle = $this->get_choices($return);
            if(defined $choice_cycle[$#choice_cycle]) {
              $choice_num = $#choice_cycle;
            }
          } else {
            if($choice_num <= 0) {
              $choice_num = @choice_cycle; # TODO get_choices returns number in scalar context?
            }
            $choice_num--;
          }
          #TODO only delete/print differences, not full string
          unless(defined $choice_num) {
            $this->bell();
          } else {
            $this->{out}->print($this->{del_one} x length($return));
            $return = $choice_cycle[$choice_num];
            $this->{out}->print($return);
            $r = length($return);
          }
          last CASE;
        };

        # down (CTRL-N)
        $_ =~ $this->{down} && do {
          unless(defined $choice_num) {
            @choice_cycle = $this->get_choices($return);
            if(defined $choice_cycle[0]) {
              $choice_num = 0;
            }
          } else {
            if(++$choice_num >= @choice_cycle) {
              $choice_num = 0;
            }
          }
          #TODO only delete/print differences, not full string
          unless(defined $choice_num) {
            $this->bell();
          } else {
            $this->{out}->print($this->{del_one} x length($return));
            $return = $choice_cycle[$choice_num];
            $this->{out}->print($return);
            $r = length($return);
          }
          last CASE;
        };

        # printable char
        ord >= 32 && do {
          $return .= $_;
          $r++;
          $this->{out}->print($_);
          $choice_num = undef;
          last CASE;
        };

        $_ !~ /^\x1b/ && do {
          # sound bell and reset any unknown key
          $this->bell();
          $_ = '';
        };
        next GETC; # nothing matched - get new character
      } # :ESAC
      $_ = '';
    } # while getc != enter
    $this->{out}->print($this->{eol});
    $return = $this->post_process($return);
    # only validate if we had input
    my $match = defined($key) ? $this->validate($return) : $return;
    unless(defined $match) {
      redo LOOP;
    }
    $return = $match;
  } # end LOOP

  $this->reset_tty;
  delete $this->{_sig_winch};

  return $return;
}

sub validate
{
  my __PACKAGE__ $this = shift;
  my $return = shift;
  unless($this->{validate}) {
    return $return;
  }
  elsif(ref $this->{validate}) {
    # arrayref with message to print and code ref
    my ($msg, $cb) = @{$this->{validate}};
    my $match = &$cb($return);
    unless(defined $match) {
      $this->{out}->print($msg,$this->{eol});
      return;
    }
    return $match;
  }

  # we may have several validation options
  my @vals = split(/[\s,]+/, $this->{validate});

  VALIDATE_OPTIONS: foreach my $val (@vals) {

    if($val eq 'lowercase') {
      $return = lc($return);
    }

    if($val eq 'uppercase') {
      $return = uc($return);
    }

    if($val eq 'match_one') {
      my @choices = $this->get_choices('');
      my @matches = grep(/^\Q$return\E/, @choices);
      MATCH: {
        if(@matches == 1) {
          # unique match at beginning
          $return = $matches[0];
          last MATCH;
        }
        elsif(@matches == 0) {
          @matches = grep(/\Q$return\E/, @choices);
          if(@matches == 1) {
            # unique match anywhere
            $return = $matches[0];
            last MATCH;
          }
        }
        $this->{out}->print("ERROR: Answer '$return' does not match a unique item!",$this->{eol});
        $return = undef;
        last VALIDATE_OPTIONS;
      } # MATCH
    }

    if($val eq 'nonempty') {
      unless(length $return) {
        $this->{out}->print("ERROR: Empty input not allowed!",$this->{eol});
        $return = undef;
        last VALIDATE_OPTIONS;
      }
    }

    if($val eq 'nonblank') {
      unless(length $return && $return =~ /\S/) {
        $this->{out}->print("ERROR: Blank input not allowed!",$this->{eol});
        $return = undef;
        last VALIDATE_OPTIONS;
      }
    }

    if($val eq 'fromchoices') {
      if(length($return) && !grep($return eq $_, $this->get_choices(''))) {
        $this->{out}->print("ERROR: You must choose one item from the list!",$this->{eol});
        $return = undef;
        last VALIDATE_OPTIONS;
      }
    }

    if($val eq 'numeric') {
      unless($return =~ /^-?(?:\.\d+|\d+\.?\d*)$/) {
        $this->{out}->print("ERROR: Value must be numeric!",$this->{eol});
        $return = undef;
        last VALIDATE_OPTIONS;
      }
    }

    if($val eq 'integer') {
      unless($return =~ /^-?\d+$/) {
        $this->{out}->print("ERROR: Value must be an integer number!",$this->{eol});
        $return = undef;
        last VALIDATE_OPTIONS;
      }
    }

    if($val eq 'nonzero') {
      if($return == 0) {
        $this->{out}->print("ERROR: Value must be a non-zero value!",$this->{eol});
        $return = undef;
        last VALIDATE_OPTIONS;
      }
    }

    if($val eq 'positive') {
      unless($return > 0.0) {
        $this->{out}->print("ERROR: Value must be a positive value!",$this->{eol});
        $return = undef;
        last VALIDATE_OPTIONS;
      }
    }

  } # end validation options

  # TODO die on unknown validate option?
  return $return;
}

sub bell
{
  my __PACKAGE__ $this = shift;
  my $bell = $this->{bell};
  $this->{out}->print($bell) if $bell;
}

sub get_choices
{
  my __PACKAGE__ $this = shift;
  grep(defined && /^\Q$_[0]/,@{$this->{choices}});
}

sub show_choices
{
  my __PACKAGE__ $this = shift;
  my $return = shift;
  # start new line - cursor was on input line
  $this->{out}->print($this->{eol});
  $this->_show_choices($this->get_choices($return));
}

sub _show_choices {
  my __PACKAGE__ $this = shift;
  my @choices = @_;

  my $eol = $this->{eol};
  unless(@choices) {
    return 1;
  }
  if(defined $this->{columns} && $this->{columns} == 0) {
    # poor man's solution:
    $this->{out}->print(join($eol, @choices), $eol);
    return 1;
  }

  # find width of widest entry
  my $MAXWIDTH = 0;
  grep(length > $MAXWIDTH && ($MAXWIDTH = length), @choices);
  $MAXWIDTH++; # add one for a blank between the columns

  if(exists $SIG{'WINCH'}) {
    $this->{_winch} = 0;
    local $SIG{'WINCH'} = sub {
      $this->{_winch}++;
      if($this->{_sig_winch}) {
        return &{$this->{_sig_winch}};
      }
    };
  }

  my ($COLUMNS,$ROWS) = ($this->{columns}, $this->{rows});
  START_PAGING: {
    ($COLUMNS,$ROWS) = $this->get_term_size()
      unless $COLUMNS && $ROWS;
    my $maxwidth = $MAXWIDTH;
    my $columns = $maxwidth >= $COLUMNS ? 1 : int($COLUMNS / $maxwidth);

    ## if there's enough margin to intersperse among the columns, do so.
    $maxwidth += int(($COLUMNS % $maxwidth) / $columns);
    my $lines = int((@choices + $columns - 1) / $columns);
    $columns-- while ((($lines * $columns) - @choices + 1) > $lines);

    my $i = 0;
    my $page_lines = 0;
    for (my $l = 0; $l < $lines; $l++) {
      my @line;
      for(my $c = 0; $c < $columns && $i<@choices; $c++) {
        push(@line, sprintf("%-${maxwidth}s", $_[$i++]));
      }
      # no paging if ROWS were set to 0
      if($ROWS && ++$page_lines == $ROWS) {
        $this->{out}->print($this->{page_str});
        my $c = $this->get_key;
        # delete pager line
        $this->{out}->print($this->{del_one} x length($this->{page_str}));
        if($c =~ $this->{quit}) {
          return 1;
        }
        elsif($this->{_winch}) {
          # winch signaled, restart paging
          $this->{_winch} = 0;
          $this->bell();
          $this->{out}->print($this->{eol});
	  $COLUMNS = $ROWS = undef;
          redo START_PAGING;
        }
        elsif($c =~ $this->{enter}) {
          $page_lines--;
        }
        else {
          $page_lines = 0;
        }
      }
      $this->{out}->print(@line, $eol);
    } # end loop over lines
  } # end START_PAGING
  1;
}

sub post_process
{
  my __PACKAGE__ $this = shift;
  my $return = shift;
  $return =~ s/^\s+|\s+$//sg;
  $return;
}

1;
__END__