#!perl -w

# ttyForm.pl - Will Mengarini <seldon@eskimo.com> - works with Perl 4 or 5

package main;

# This is essentially a line-oriented implementation of filling out a form.
# In addition to prompting for responses to items in sequence, it allows
# special responses like "b" for "go back 1 item".  This is an optimal UI for
# forms that have many numeric items; the special responses are distinguished
# by being non-numeric.  This only works for numeric-only forms.  A form that
# has non-numeric items might better be processed by writing out a temp file
# containing the default responses, then popping the user into an editor.
# But with numeric-only answers this alternative really is more convenient.
# If the users aren't computer-literate enough to be expected to safely
# edit a text file, or if the form is large, this package could be
# extended to handle non-numeric field entries by using control characters
# as the keys for moving around.

# Here's the introduction that the user sees at the start of the form.

sub ttyForm'printLoopIntroduction { local($numItems) = @_;

  local($pluralization) = $numItems . ' item' . ($numItems == 1 ? '' : 's');

  print <<EOT
You are filling out a form containing $pluralization.
You'll be presented with each numbered item in sequence.
For each item, you may accept the current number (displayed in brackets) by
pressing <Enter>, or you may type in a new number followed by <Enter>.
When you've responded to the final item, the loop will wrap around to the
first item for review or update.  This will continue ad infinitum until you
respond to a prompt with \"q\" for quit.  (Don't forget <Enter> after it.)
Other loop-control commands can be displayed by responding to any prompt
with \"?\".  For help on an individual item, respond \"h\".
EOT

}

# Here's the help describing loop-control commands.

$ttyForm'LoopControlKeys = <<'EOT';
    ?   print this help message
    b   go back 1 item
    h   print a help message pertaining to the current question
    q   quit the loop
    r   reset any numbers changed so far to what they were to begin with,
        & return to the first item
    t   return to the first item
Remember that there are 2 different help messages available to you:
'?' prints this help message, but 'h' prints a message explaining
the question for which you are supposed to give a numeric answer.
EOT

sub ttyForm'printLoopControlHelp { local($prompt) = @_;
  print <<EOT;
At this point you have these alternatives:
* You can enter a numeric response to the question you're being asked.
EOT
  print <<EOT if $prompt =~ /\[.+\]/;
* You can just hit <Enter> to accept the default response.
EOT
  print <<EOT;
* You can hit one of the following keys, followed by <Enter>:
$ttyForm'LoopControlKeys
EOT
}

# This is a selftesting package that runs under Perl 4 & 5.
# To selftest it, invoke it as a main program with an arg of '--selftest'.
# (Normal usage is "require 'ttyForm.pl';".)

require 'selftest.pl';
require 'ask.pl';
&maybeSelfTest;

# The user interaction is run by &updateLoop, which displays the current
# value of each parameter to the user & allows it to be updated. This is
# the function you'll invoke from your script to get the values updated.

# &updateLoop takes 3 args.  The first 2 contain, encoded in a string, the
# current values for each parameter. The 2 args together will be passed to
# Perl's split; the first is the "splitter", the second the values.  Since
# the splitter will later be used as a "joiner" with Perl's join operator, it
# must be a literal string, not a regexp.  (Splitters containing
# metacharacters will have them automatically quoted.)  A splitter of ''
# causes each character in the second arg to correspond to an item.

# The third arg describes, for each item, how it is to be presented to the
# user for update.  &updateLoop goes thru the entire list of items,
# presenting each to the user & allowing each to be modified.  Each time a
# prompt is given, special responses are accepted to control the loop,
# as explained above in &ttyForm'printLoopControlHelp.

# The third arg has a conceptual structure that's difficult
# to implement in Perl 4, so here, first of all, is what I *want*:
#   array [ 1 .. # of prompts] of
#     struct {
#       response spec (specifies response encryption & validity)
#       short prompt
#       longer explanation
#     }
# Since Perl 4 only has 1-dimensional arrays, the struct needs to be a
# string; the inefficiency of parsing it won't be a problem since it's part
# of an interactive loop. The third arg is an array of strings, each string
# representing an instance of that struct.

# The response spec is one line with these items separated by semicolons:
#   decryptor: a sub from here that translates an item from the parameter
#     string into cleartext. Although the value returned by the decryptor
#     must represent a number, it may represent it as a Perl string value,
#     so you have control over the format in which defaults are displayed.
#     For example, if you want your defaults displayed with 2 decimal places,
#     you can have your decryptor format them with "sprintf '%.2f'".
#   encryptor: a sub from here that translates the user's response into
#     an item that goes in the parameter string.
#   validators: subs that determine whether the response, assuming it is not
#     one of the special responses listed above ("t", "b", "", etc), is OK,
#     & return 2 values like those of $validator subs in my ask.pl.
#     There can be one or more validators, & they're invoked in sequence.
#     Note that it's because those special responses need to be allowed for
#     that standard ask.pl subs like &askInteger can't be used.  However,
#     standard ask.pl *validators* like &inRange() can be used, & all
#     validators must conform to the validator protocols in ask.pl.
#     Validators that consist just of sub calls will have '&' prepended
#     for Perl 4, & '()' appended if they don't already have args.
# The short prompt is always one line.
# The longer explanation is zero or more lines (the remainder of the string).

# For some apps the second arg can contain the current values in cleartext;
# that is, the {de,en}cryptors are NOPs.  For those apps, use this sub ...

sub same { return $_[0] }

# ... as both the {de & en}cryptor.  I.e., start your response spec
# with "same;same;".

# This is a built-in validator you can use:

sub isInteger {
  if( $value =~ /^-?\d+([Ee]-?\d+)?$/ ){
    (1)
  }else{
    (0, "\"$value\" isn't an integer.\n");
  }
}

# If you roll your own validators, use the same protocol for return values.
# You can also use any validators from ask.pl; &inRange() tends to be useful.
# Validator protocol is documented at length in ask.pl.

# Note that special responses ("t", "b", "", etc) are recognized & acted upon
# before the the response is passed to the validator sub that's part of the
# response spec, so that sub doesn't need to worry about them.  On the other
# hand, it has no way of pre-empting them.  In this version, that's
# not a problem because forms responses are always numeric unless special.

# If your external logic makes it possible for &updateLoop to be called
# with a second arg that doesn't already contain values for all items in
# the prompt (i.e. that doesn't contain defaults), then you're responsible
# for ensuring that the {de,en}cryptors you supply can cope with undef.
# This may not be obvious, since the loop will seem to require answers
# to any form items that don't have defaults; but it'll be possible for the
# user to terminate the loop at any time using "q", so you need to deal with
# the possibility that some items don't get defined.

# Usage examples are in the selftest code; search down for "__TESTCODE__".

# That completes usage documentation; what follows documents implementation.

# The following validator isn't embedded in usage documentation because the
# caller should never need to use it; it's always automatically invoked as
# the first validator on any user response.

sub isNumber {
  if( $value =~ /^-?(\d+(\.\d*)?|\.\d+)([Ee]-?\d+)?$/ ){
    (1)
  }else{
    (0, "\"$value\" isn't a number.\n");
  }
}

# sub updateLoop:
#   split second arg (current values of each item) based on first arg
#   die unless third arg & split have equal positive # of items
#   display message telling user how many items there are, & clarifying that
#     loop only ends when "q" is entered (otherwise wraparound is automatic)
#   calculate # of leading 0s needed when prepending item # to short prompt
#   starting with current item = first item, loop:
#     prepend item # with leading 0s to short prompt
#     if current value of current item is defined:
#       append its decryption in brackets to the short prompt as the default
#     &askValue( short prompt, '.+', 'nonempty, & there's no default', etc )
#       to handle logic for requiring a result if there's no default
#     if result is loop exit:
#   ;   last
#     elf result is loop control:
#       adjust which item is current
#     elf result is reset:
#       split second arg (current values of each item) based on first arg,
#         overwriting any changes previously made in this loop
#       adjust current item to first item
#     else:
#       set current item to result
#       move to next item or wrap around back to first item
# ; return join of items back into format of second arg

sub updateLoop { local( $splitter, $valuesIn, @form ) = @_;

  local( # not my() only because maintaining Perl 4 compatibility
    @values,         # split of $valuesIn by $splitter
    $fieldSize,      # for use in leading-zeroes printf of item #
    $item,           # index of form item being presented to user
    $quotedSplitter, # $splitter with metacharacters quoted
    $responseSpec,   # line 1 of @form item: {de,en}cryptor, validators
    $prompt,         # line 2 of @form item (gets massaged here for display)
    @help,           # lines 3..n of @form item
  );

  # Prepare $quotedSplitter for split(), saving $splitter for join().
  # Do it the hard way since Perl 4 has no quotemeta.
  ($quotedSplitter = $splitter) =~ s#([\@$^&*()+|"'?])#\\$1#g;

  die "\@form (arg to &updateLoop) is empty" unless @form;

  @values = split( $quotedSplitter, $valuesIn );
  @values = (undef) x @form unless( @values );
  unless( @values == @form ){
    die '# values = ',scalar(@values),'; # form items = ',scalar(@form)
  }

  $fieldSize = length( @form ); # i.e. scalar list size => string => log10+1

  &ttyForm'printLoopIntroduction( scalar(@form) );

  # It looks as if it'd be more efficient to put {de,en}cryption in their
  # own separate loops, outside the interactive loop. This has 2 problems:
  # * For a large form, running all those {de,en}cryptors at once could
  #   cause a delay the user would notice.
  # * Each form item has its own {de,en}cryptor so the items may be stored
  #   in varying formats (e.g. mixed integers & reals).  Having separate
  #   {de,en}cryption loops would require doing both splits to extract all
  #   the {de,en}cryptors before entering the interactive loop.  This would
  #   produce another noticeable delay, & would also consume RAM to store the
  #   arrays, which on a tiny Intel machine could cause a failure.
  # So {de,en}cryption is integrated into the interactive loop.

  for( $item = 0;; ){

    ($responseSpec,$prompt,@help) = split( /\n/, $form[$item] );
    defined $responseSpec  || die "Item $item \$responseSpec undefined";
    defined $prompt        || die "Item $item \$prompt undefined";
    defined @help          || die "Item $item \@help undefined";
    ($decryptor,$encryptor,@validators) = split( /;/, $responseSpec );
    defined $decryptor     || die "Item $item \$decryptor undefined";
    defined $encryptor     || die "Item $item \$encryptor undefined";
    defined @validators    || die "Item $item \@validators undefined";

    $prompt = sprintf( "%0${fieldSize}d: %s",$item + 1,$prompt );
    if( defined $values[$item] ){
      local($default) = eval '&' . $decryptor . "('$values[$item]')";
      die $@ if $@;
      $prompt .= sprintf( " [%s]",$default );
    }
    $prompt .= ': ';

    if( ! -t $ask'defaultIN && eof($ask'defaultIN) ){
      # this is a regression test, so prevent an endless loop
      die "EOF on $ask'defaultIN";
    }

    $result = &askValue(
      $prompt, '.+', "nonempty, & there's no default",
      '&ttyForm\'loopValidator("' . join( ';', @validators ) . '")'
    );

    unless( defined $result ){
;     return undef;
      # Only possible when selftesting detects failure, because &askValue
      # will only return undef when $ask'iterationLimit is exceeded.
    }elsif( $result eq '?' ){
      &ttyForm'printLoopControlHelp( $prompt );
    }elsif( $result eq 'b' ){
      $item = $#form if --$item < 0;
    }elsif( $result eq 'h' ){
      print join( $/, @help ),$/;
    }elsif( $result eq 'q' ){
  ;   last
    }elsif( $result eq 'r' ){
      @values = split( $quotedSplitter, $valuesIn );
      @values = (undef) x @form unless( @values );
      $item = 0;
    }elsif( $result eq 't' ){
      $item = 0;
    }else{
      $values[$item] = eval '&' . $encryptor . '(' . $result . ')';
      die $@ if $@;
      $item = 0 if ++$item > $#form;
    }

  }#for( $item = 0;; )

  join( $splitter, @values );

}

# sub ttyForm'loopValidator:
#   if $value matches any loop-control construct:
# ;   return (1)
#   elf $value is a number:
#     for each @validators:
#       run it
#       if it returned (0,whatever):
# ;       return that from &ttyForm'loopValidator
# ;   return (1)
#   else:
#     assume response was intended to be loop control
# ;   return (0,multiline help message on loop control)

sub ttyForm'loopValidator { # @_ processed in elsif
  if( $value =~ /^[?bhqrt]$/ ){
;   (1)
  }elsif( $value =~ /^[-.,eE0-9]+$/ ){
    local(@responseValidators) = split( ';', $_[0] );
    unshift( @responseValidators,'&isNumber()' );
    for( @responseValidators ){
      #adorn sub invocations with '&' & '()' if needed
      if( /^\w(\w|\d)*(\s*\(|$)/ ){ $_ = '&' . $_ }
      if( /^\&\w(\w|\d)*$/       ){ $_ .= '()' }
      #run the validator & return failure if the validator does
      ($valid,$whyNot) = eval;
      $@ && die __FILE__ . ": eval \"$_\" failed:\n$@";
;     $valid || return (0,$whyNot);
    }
    #all @validators returned success so return success
;   (1)
  }else{
;   (0,"These are the loop control keys:\n$ttyForm'LoopControlKeys")
  }
}

&updateLoop, &ttyForm'loopValidator, &same, &isNumber, &isInteger if 0;

1;

__END__

__TESTCODE__

# This is supposed to run in package main, so we'll test it there.

package main;

# To test &updateLoop we simulate keyboard input to it & check whether its
# returned value contains the proper modifications to its second
# arg. Test data following __TESTDATA__ specifies the args, the expected
# return value, & the keyboard input needed to produce it. The headings are
#   ----ValuesIn----    Input value of second arg to &updateLoop
#   ----ValuesOut----   Output value of second arg to &updateLoop
#   ----Form----        Value of third arg to &updateLoop
#   ----Keystrokes----  What the user types to change ValuesIn to ValuesOut
#   ----Interact----    Explained in next paragraph
# The only time the selftest function actually runs a test case is when it
# encounters a ----Keystrokes---- or ----Interact---- block.  Each of the
# other blocks, when encountered, specifies a value that the test function
# remembers across test cases, so if a value remains the same, it needn't be
# respecified. For example, ----ValuesIn---- & ----Form---- can be specified
# once, then multiple sets of ----Keystrokes---- can be paired with the
# ----ValuesOut---- those keystrokes should produce, all using the same
# ----ValuesIn---- & ----Form----.  It didn't seem worth the effort to
# selftest error handling, so any time an error is encountered the message
# goes to the terminal & the testing aborts.

# I can imagine running all the tests, having everything run to completion,
# believing the package is finished, & then discovering that when used
# interactively it Just Doesn't Work.  So interactive testing is probably a
# good idea at least once before publication of each release, & it may be
# wanted intermittently during development & maintenance. This is what
# ----Interact---- is for; it takes the place of ----Keystrokes---- & runs a
# test using the current values of ----ValuesIn---- & ----Form----, but
# instead of simulating input to &updateLoop, it allows &updateLoop to get
# input from the terminal, ignores ----ValuesOut----, & after the form is
# exited, displays to the tester whatever differences between the
# original ----ValuesIn---- & the resulting values out were obtained.  I'm
# too lazy to retype '----Interact----' every time I want to use it again, so
# comments (lines matching /^\s*#/) are allowed & ignored in __TESTDATA__,
# & ----Interact---- lines can just be left anywhere in the test suite,
# commented out, for use when wanted.

# Items in $ValuesIn are separated with "|", so &same is the {de,en}cryptor.

# The main test loop follows the strategy of reading <TESTDATA> line by
# line, recognizing each /^----(.*)----$/ line as starting a new block
# where $1 specifies that new block's type, continuing to read the entirety
# of the block into $blockText until reaching another /^----(.*)----$/ line
# or eof, then passing $blockType & $blockText to a sub for processing.

# Pseudocode for the main test loop without special Keystrokes handling:
#   while read new line:
#     allow for comments & evals
#     if /^----(type of this new block)----$/:
#       if there was a previous block (ie this isn't the first):
#         process previous block
#       remember type of this new block
#       clear text of new block
#     else:
#       append new line to text of new block
#     next
#   if there is an unprocessed block:
#     process previous block
#   else:
#     die

# A problem with that algorithm arises because this code must run under
# DOS, where Unix-style pipes aren't available & open('-|') doesn't work.
# This means that reading Keystrokes into a variable, intending later to
# pipe it back into &updateLoop, just doesn't work. The smoothest way to
# deal with this is to leave TESTDATA pointing at the Keystrokes & let
# &processBlock read them (actually just redirecting &askValue's input
# from TESTDATA). Consequently, the main loop processes Keystrokes blocks
# as soon as it reads the ---Keystrokes---- header, whereas it processes
# all other blocks only after it's read them & the header of the *next*
# block (or eof). This seriously complicates the logic. One way to make
# it less messy is to note that "if there is an unprocessed block" really
# means "if defined $blockType" & let &processBlock check for that, just
# NOPping if not. So whether or not defined $blockType, we can always
# safely call &processBlock. However, it'd be nice to still trap the case
# where an error causes $blockType to be undef when it should have a value;
# we can check for that whenever we're supposed to be appending text to
# $blockText, which should only be happening if we've read a block header &
# it wasn't a Keystrokes header, so we're reading the text.

# This now becomes the pseudocode for the main test loop:
#   while read new line:
#     allow for comments & evals
#     if /^----(type of new block)----$/:
#       process previous block if any
#       clear text of new block
#       if type of this new block is Keystrokes:
#         process this new Keystrokes block
#         remember that we now have no new block type
#           # In other words it's as if we were at the top of the file,
#           # so the next input line, if there is one, must be either
#           # a comment, an EVAL, or a block header.
#       else:
#         remember type of this new block
#     else:
#       die unless we currently have a defined block type
#       append new line to text of new block
#   process previous block if any
# Note how comparatively nonobvious it is that block type & block text are
# properly being kept track of. I hate this structure, particularly the need
# to remember at the end of the while to "process previous block if any"
# yet again (a problem that was present in the previous version as well).
# This is a problem with if/then/else/do/while coding; that abstraction just
# can't neatly denote loops structured like this.

# Here is the implementation of that pseudocode:

$keystrokeBlockCount = 0; #for displays
while( <TESTDATA> ){
; next if /^[ \t]*#/; #comments
  if( /^EVAL: (.*)$/ ){ #modifications of the test environment
    eval $1; die $@ if $@;
;   next;
  }
  if( /^----([a-zA-Z]+)----$/ ){
    &processBlock( $blockType, $blockText );
    $blockText = '';
    if( $1 eq 'Keystrokes' ){ # $[0-9] are always local
      &processBlock( $1 );
      undef $blockType;
    }else{
      $blockType = $1;
    }
  }else{
    defined $blockType || die "No block type defined";
    $blockText .= $_;
  }
}
&processBlock( $blockType, $blockText );

sub processBlock{ local( $blockType, $blockText ) = @_;
  unless( defined $blockType ){
;   return;
  }elsif( $blockType eq 'ValuesIn' ){
    chop( $valuesIn = $blockText );
  }elsif( $blockType eq 'ValuesOut' ){
    chop( $valuesOut = $blockText );
  }elsif( $blockType eq 'Form' ){
    @form = split( '\n\n', $blockText );
  }elsif( $blockType eq 'Keystrokes' ){
    $ask'defaultIN = 'TESTDATA';
    $ask'echoInput = 1;
    $ask'iterationLimit = 3;
    local( $result ) = &updateLoop( '|', $valuesIn, @form );
    $ask'defaultIN = 'STDIN';
    $ask'echoInput = 0;
    $ask'iterationLimit = 0;
    ++$keystrokeBlockCount;
    if( ! defined $result || $result ne $valuesOut ){
      print "---Keystrokes---- block #$keystrokeBlockCount failed:\n";
      if( defined $result ){
        print "Expected: $valuesOut\nObtained: $result\n";
      }else{
        print "&updateLoop returned undef.\n";
      }
      die "\UAbending because of selftest failure\E <====================\n";
    }else{
      print "---Keystrokes---- block #$keystrokeBlockCount succeeded.\n";
    }
  }elsif( $blockType eq 'Interact' ){
    print "\n\nBeginning ---Interact---- block.\n";
    print "Initial values: '$valuesIn'\n\n";
    $valuesOut = &updateLoop( '|', $valuesIn, @form );
    print "Initial values: '$valuesIn'\n";
    print "Final values:   '$valuesOut'\n";
  }else{
    die "Block type '$blockType' unrecognized";
  }
}

__TESTDATA__
#
# This is the structure of a ----Form---- item:
#
# response spec (specifies response encryption & validity)
#   decryptor: a sub from here that translates an item from the parameter
#     string into cleartext (presumably a number).
#   encryptor: a sub from here that translates the user's response into
#     an item that goes in the parameter string.
#   validators: subs that determine whether the response, assuming it is not
#     one of the special responses listed above ("t", "b", "", etc), is OK,
#     & return 2 values like those of $validator subs in my ask.pl.
#     There can be any # of validators, & they're invoked in sequence.
#     RETHIMK THAT: PERMISSIBLE # OF VALIDATORS STILL UNDETERMINED
# short prompt
# longer explanation
#
# The items in a ----Form---- block are separated by exactly one blank line.
# There must be no additional leading or trailing blank lines.  However,
# comment lines beginning with "#" will be stripped by the selftest code
# before they ever get into any block.
#
----Form----
same;same;isInteger;inRange(1,5)
Question A (1..5)
Long explanation for question A.

same;same;isInteger;inRange(3,7)
Question B (3..7)
Long explanation for question B.

same;same
Question C
Long explanation for question C.
----ValuesIn----
2|5|-666.14159
----ValuesOut----
3|7|42.1701
----Keystrokes----
8
2
b
4
5
t
h
3
h
7
?
42,1701
42.1.701
42.1701
q
----ValuesOut----
2|5|0
----Keystrokes----
4.5

0.0

0
q
# Let's try some degenerate inputs.
----ValuesOut----
2|5|-666.14159
----Keystrokes----
q
----Keystrokes----
?
h
q
----Keystrokes----





q
----Keystrokes----
2
5
-666.14159
q
# Let's try some variant & degenerate forms. (An empty @form dies.)
----Form----
same;same;isInteger;inRange(1,5)
Question A (1..5)
Line 1 of long explanation for question A.
Line 2 of long explanation for question A.

same;same
Question B
Line 1 of long explanation for question B.
Line 2 of long explanation for question B.
Line 3 of long explanation for question B.
Line 4 of long explanation for question B.
----ValuesIn----
2|-666.14159
----ValuesOut----
3|42.1701
----Keystrokes----
4
4
h
3
h
42.1701
q
----Form----
same;same
Question
Long explanation for question.
----ValuesIn----
-666.14159
----ValuesOut----
42.1701
----Keystrokes----
42.1701
q
----Form----
same;same;isInteger;inRange(1,5)
Question A (1..5)
Long explanation for question A.
----ValuesIn----
2
----ValuesOut----
3
----Keystrokes----
0
3.3333333333333
3
q
#
# Now let's reestablish an interesting form, so if ----Interact---- is
# wanted there'll be something to play with. It's necessary to actually
# run one ----Keystrokes---- block on this form as well, just to be sure
# that 2-digit item-number formatting works.
#
----Form----
same;same;isInteger
Question 1
Long explanation for question 1.

same;same;isInteger
Question 2
Long explanation for question 2.

same;same;isInteger
Question 3
Long explanation for question 3.

same;same;isInteger
Question 4
Long explanation for question 4.

same;same;isInteger
Question 5
Long explanation for question 5.

same;same;isInteger
Question 6
Long explanation for question 6.

same;same;isInteger
Question 7
Long explanation for question 7.

same;same;isInteger
Question 8
Long explanation for question 8.

same;same;isInteger
Question 9
Long explanation for question 9.

same;same;isInteger
Question A
Long explanation for question A.

same;same;isInteger
Question 0bh
Long explanation for question B.

same;same;isInteger
Question 16rC
Long explanation for question 12.

same;same;isInteger
Question 13
Long explanation for question 13.

same;same;isInteger
Question 016
Long explanation for question 14.

same;same;isInteger
Question 15
Long explanation for question 15.
----ValuesIn----
2|3|5|7|11|13|17|19|23|29|31|41|43|47|53
----ValuesOut----
1|1|2|3|5|8|13|21|23|29|31|41|43|47|53
----Keystrokes----
1
1
2
3
5
8
13
21
q
#----Interact----