#!/usr/bin/perl -w
#
# $Id: getraw,v 1.16 2003/08/01 02:10:56 jmates Exp $
#
# The author disclaims all copyrights and releases this script into the
# public domain.
#
# Means of prompting where human interaction required.

require 5;
use strict;

use Term::ReadKey;

my $VERSION;
($VERSION = '$Revision: 1.16 $ ') =~ s/[^0-9.]//g;

my $default_spec = 'Yy:+ Nn:-';
my $spec;

# "true" is 0 for shell exits, 1 for "false"
my $status_map = {'+' => 0, '-' => 1};

# by default wait forever
my $timeout = -1;

# return value for timeout
my $timeout_status = 101;

# use unix tty device to avoid polluting regular output
my ($readfrom, $writeto);
open $writeto, ">/dev/tty"
 or remark('error', "could not open tty for writing: $!")
 and exit 100;
open $readfrom, "</dev/tty"
 or remark('error', "could not open tty for reading: $!")
 and exit 100;

# command line option handling
use Getopt::Std;
my %opts;
getopts('h?o:t:', \%opts);
help() if exists $opts{'h'} or exists $opts{'?'};

$spec = parse_spec(exists $opts{o} ? $opts{o} : $default_spec);

if (exists $opts{t}) {
  $timeout = duration2seconds($opts{t});
}

# prompt (may not be formatted properly due to raw modes)
print $writeto "@ARGV" if @ARGV;

eval {
  if ($timeout > 0) {
    local $SIG{ALRM} = sub { die "alarm\n" };
    alarm $timeout;
  }

  while (1) {
    my $key = get_key($readfrom);

    # check for specific key, default action, or default to nothing for
    # the key in question
    if (exists $spec->{keys}->{$key}) {
      print $writeto "\n";
      exit $spec->{keys}->{$key};
    } elsif (exists $spec->{default} and $spec->{default} =~ /^\d+$/) {
      print $writeto "\n";
      exit $spec->{default};
    }
  }

  alarm 0 if $timeout > 0;
};
if ($@) {
  die unless $@ eq "alarm\n";

  # TODO figure out why zsh handles the alarm/sets exit to 142 for me
  exit $timeout_status;
}

######################################################################
#
# SUBROUTINES

sub get_key {
  my $readfrom = shift;
  my $first;

  ReadMode(4, $readfrom);

  do {
    $first = ReadKey(-1, $readfrom);
  } until defined $first;

  ReadMode(0, $readfrom);

  return $first;
}

sub parse_spec {
  my $string = shift;
  my $spec;

  for (reverse split /(?<!\\)[ ,]+/, $string) {
    my ($keys, $status) = /(.+?):(.)?$/;
    $status ||= '';  # "do nothing" status, no return code

    $spec->{human}->{$status} .= $keys;

    if (exists $status_map->{$status}) {
      $status = $status_map->{$status};
    }

    # TODO warn about not getting numeric exit status
    if ($status ne '' and $status !~ /^\d+$/) {
      remark('warning', "non-numeric exit status for $_, defaulting to 0");
      $status = 0;
    }

    # unescaped * means "any key" e.g. the default action
    if ($keys =~ s/(?<!\\)\*//) {
      $spec->{default} = $status;
    }

    # unescape backwhacked things (\r, etc.)
    $keys =~ s/(\\.)/$1/eeg;

    # quick lookup map for key typed
    for (split //, $keys) {
      $spec->{keys}->{$_} = $status;
    }
  }

  # sanity check on specification to prevent key-read stalls
  unless ($spec) {
    remark('error', "unable to parse specification '$string'");
    exit 103;
  } else {
    unless (grep { defined and /^\d$/ } $spec->{default},
      values %{$spec->{keys}}) {
      remark('error', "no valid exit codes in specification '$string'");
      exit 103;
    }
  }

  return $spec;
}

sub duration2seconds {
  my $tmpdur = shift;
  my $timeout;

  # how to convert short human durations into seconds
  my %factor = (
    'w' => 604800,
    'd' => 86400,
    'h' => 3600,
    'm' => 60,
    's' => 1,
  );

  # assume raw seconds for plain number
  if ($tmpdur =~ m/^\d+$/) {
    $timeout = $tmpdur;

  } elsif ($tmpdur =~ m/^[wdhms\d\s]+$/) {

    # match "2m 5s" style input and convert to seconds
    while ($tmpdur =~ m/(\d+)\s*([wdhms])/g) {
      $timeout += $1 * $factor{$2};
    }
  } else {
    remark('error', 'unknown characters in duration');
    exit 102;
  }

  unless (defined $timeout and $timeout =~ m/^\d+$/) {
    remark('error', 'unable to parse duration');
    exit 102;
  }

  return $timeout;
}

# generic log handler
sub remark {
  my ($facility, $priority, $message, $where);
  $facility = 'user';

  if (@_ > 1) {
    $priority = shift;
    $message  = "@_";
  } else {
    $priority = 'info';
    $message  = "@_";
  }

  #  return 1 if exists $opts{'q'} and $priority eq 'info';

  # try to send errors to tty if available, STDERR otherwise
  $where = (defined $writeto and -t $writeto) ? $writeto : *STDERR;

  print $where $priority, ": ", $message, "\n";

  return 1;
}

# a generic help blarb
sub help {
  print <<"HELP";
Usage: $0 [opts] [prompt message]

Means to prompt for human interaction.

Options for version $VERSION:
  -h/-?  Display this message

  -o ss  Key mapping specification

  -r     Require return key (default: on keystroke)
  -t dd  Timeout after dd seconds

Run perldoc(1) on this script for additional documentation.

HELP
  exit;
}

=head1 NAME

getraw - means to prompt for human interaction

=head1 DESCRIPTION

=head2 Overview

This script is intended to provide a means for other scripts to interact
with a human, for example to choose from a list.

=head2 Normal Usage

  $ getraw [options] [prompt message]

See L<"OPTIONS"> for details on the command line switches supported.

=head1 OPTIONS

This script currently supports the following command line switches:

=over 4

=item B<-h>, B<-?>

Prints a brief usage note.

=item B<-o> I<specification>

Custom keystroke option specification.  The format is groups of space or
comma separated keystrokes and the exit status they correspond to.  A
colon separates the keys from the exit status.

  -o 'Yy:+ Nn:- *:'

Maps Y and y to + (translated to a "true" value internally), N and n to
a false value, and everything else to a null value.  Keys tied to a null
exit do nothing.  Order is important; groups earlier in the list take
precedence over later entries.  To specify a literal *, or special keys
such as space, tab, or return, backslash the entry.

  -o '\n:+ \ :-'    # newline yes, space no

Bear in mind the specification will likely have to be enclosed in quotes
to prevent shell interpolation.

The + and - status values are easy, though a numeric code can be
specified if the calling application is configured to support such.

  -o 'asdf:0 zxcv:1 qwer:2 *:3'

Says to exit with 0 for asdf, 1 for zxcv, and 2 for qwer.  Every other
key will result with a 3 exit code.  This allows for complex choices
beyond yes or no.

=item B<-t> I<duration>

Timeout wait-for-keypress after the specified time.  I<duration>
may either be raw seconds, or a short hand human format "1m3s" for
63 seconds.

=back

=head1 DIAGNOSTICS

The exit status will usually depend on the specification used and the
key pressed.  Errors from the script itself will have exit values of 100
or higher; lower numbers are reserved for use in specifications.  Error
messages will be sent to the tty device by default, STDERR if the tty
device is not available.

The following error codes are currently defined.

=over 4

=item B<0>

Default "true" exit value.

=item B<1>

Default "false" exit value.

=item B<100>

Error reading or writing to tty device.

=item B<101>

Timeout exit status (may be 142, see L<"BUGS"> for details).

=item B<102>

Error parsing custom timeout duration.

=tiem B<103>

Error parsing key specification.

=back

=head1 BUGS

=head2 Reporting Bugs

Newer versions of this script may be available from:

http://sial.org/code/perl/

If the bug is in the latest version, send a report to the author.
Patches that fix problems or add new features are welcome.

=head2 Known Issues

The zsh shell is exiting the alarm timeout with an exit status of 142,
not sure why at present.  Have not yet tested other shells.

See also source for TODO notes and similar.

=head1 SEE ALSO

perl(1)

=head1 AUTHOR

Jeremy Mates, http://sial.org/contact/

=head1 COPYRIGHT

The author disclaims all copyrights and releases this script into the
public domain.

=head1 HISTORY

Written based on talk Damian Conway gave about his own ~/bin/getraw
program.  This version likely is substantially different.

=head1 VERSION

  $Id: getraw,v 1.16 2003/08/01 02:10:56 jmates Exp $

=head1 SCRIPT CATEGORIES

Utilities

=cut