File Coverage

blib/lib/Term/Query.pm

Criterion	Covered	Total	%
statement	7	9	77.7
branch			n/a
condition			n/a
subroutine	3	3	100.0
pod			n/a
total	10	12	83.3

# Term::Query.pm				-*- perl -*-
#
#    Copyright (C) 1995  Alan K. Stebbens
#
#    This program is free software; you can redistribute it and/or modify
#    it under the terms of the GNU General Public License as published by
#    the Free Software Foundation; either version 2 of the License, or
#    (at your option) any later version.
#
#    This program is distributed in the hope that it will be useful,
#    but WITHOUT ANY WARRANTY; without even the implied warranty of
#    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#    GNU General Public License for more details.
#
#    You should have received a copy of the GNU General Public License
#    along with this program; if not, write to the Free Software
#    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
# $Id: Query.pm,v 1.1.1.1 1996/08/09 21:39:25 stebbens Exp $
# Author: Alan K. Stebbens
#
#
# query 	-- generalized query routine
#
# query_table 	-- perform multiple queries (given an array of info)
#
# query_table_set_defaults
#		-- set all named variable's to their default values.
#
# query_table_process
#		-- process a table of queries
#
# Note: This module uses the Array::PrintCols module (by the same author).

package Term::Query;

require 5.001;

use Exporter;

@ISA = (Exporter);
@EXPORT_OK = qw( query
		 query_table
		 query_table_set_defaults
		 query_table_process
	       );

use Carp;
use Array::PrintCols;

###############
#
# $result = query($prompt, $flags, [optional fields])
#
# Ask a question, prompting with $prompt (unless STDIN is not tty).
# Validate the answer based on $flags below.
#
#
# The following flags indicate the type or attribute of the value
#  r   - an answer is required
#  Y   - the question requires a "yes" or "no", defaulting to "yes"
#  N   - the question requires a "yes" or "no", defaulting to "no"
#  i   - the input is an integer
#  n   - the input is a number (possibly a real number)
#  H   - do *not* treat '?' as a request for help (note, this disables
#        any help, unless implemented in the "after" subroutine).
#
# The following flags indicate that the next argument is:
#  a   - a subroutine which is invoked *After* the input is read, but
#	 prior to doing any other checks; if it returns false, the input
#        is rejected.
#  b   - a subroutine which is invoked *Before* the input is read, which
#        generally prepares for the input; if it returns false, then no
#        input is accepted; if it returns undef, an EOF is assumed.
#  d   - the next argument is a Default input, used if the actual input
#  	 is the empty string.
#  h   - the next argument is a Help string to print in response to "?"
#  I   - the next argument is the input "method" ref: if it is a scalar
#	 value, then no read is performed and this value is used as if
#	 it has been entered by the user; if it is a CODE ref, then the
#	 sub is invoked to obtain its return value as the input.
#  J   - same as I, except that if the initial value returned by the
#        next argument reference is unacceptable for any reason,
#	 solicit a new, proper value from STDIN.  (Mnemonic: "jump" into
#	 query with an initial value).
#  k   - the next argument is a table reference of allowable keywords
#	 (mnemonic: check a Keywword list).
#  K   - the next argument is a table reference of disallowed keywords
#	 (mnemonic: check against a Keyword list).
#  m   - the next argument is a Match pattern (regexp)
#  l   - the next argument is a maximum Length value
#  V   - the next argument is a variable name or *reference* to receive
#        the value; if it is a name (a string) and unqualified, it is
#	 qualified at the package level outside of Query.pm.
#
# The ordering of the arguments must match the ordering of their
# corresponding flags.
#
# The ordering of the flags is also important -- it determines the order in
# which the various checks are made.  For example, if the flags are
# given in this order: 'alm', then the $after sub is invoked first, then the
# length check is made, then the $match test is made.
#
# Of course, the 'b' flag (and the corresponding $before sub) is always
# invoked before doing any input.
#
# Returns undef on EOF.
# Otherwise, the result is the input.

%query_flags = (
	'a', sub { $after = shift(@_);
		   &add_check("after"); },

	'b', sub { $before = shift(@_); },

	'd', sub { $default = shift(@_);
		   &add_check(qw(default	null)); },

	'h', sub { $help = shift(@_);
		   &add_check(qw(help		null)); },

	'H', sub { $nohelp++;
		  $check_done{"help"}++;},	# don't do any help

	'i', sub { $integer++;
		   &add_check(qw(int		null strip default help)); },

	'I', sub { $inref = shift(@_);
		   $inref_flag++; },

	'J', sub { $inref = shift(@_);
		   $inref_flag++;
		   $inref_once++; },

	'k', sub { $keys = shift(@_);
		   ref($keys) eq 'ARRAY' or
		       (croak "query: The k flag needs an array reference argument.\n");
		   &add_check(qw(key		null strip default help)); },

	'K', sub { $notkeys = shift(@_);
		   ref($notkeys) eq 'ARRAY' or
		       (croak "query: The K flag needs an array reference argument.\n");
		   &add_check(qw(nonkey		null strip default help)); },

	'l', sub { $maxlen = shift(@_);
		   &add_check(qw(maxlen		null default help)); },

	'm', sub { $match = shift(@_);
		   &add_check(qw(match		null default help)); },

	'n', sub { $number++;
		   &add_check(qw(num		null strip default help)); },

	'N', sub { $no++;
		   &add_check(qw(yesno		null strip default help)); },

	'r', sub { $required++;
		   &add_check(qw(req		null default help)); },

	's', sub { $strip++;
		   &add_check(qw(strip		null default help)); },

	'V', sub { $variable = shift(@_);
		   ref($variable) eq 'SCALAR' or
		   (ref($variable) eq '' &&
		    $variable =~ /^((\w+)?(::|'))?\w+$/) or
		       (croak "query: The V flag needs a variable name or reference.\n"); },

	'Y', sub { $yes++;
		   &add_check(qw(yesno		null strip default help)); },

	);

$need_arg_codes = 'abdhIkKlmV';		# list of codes which need an argument

# This is an array of check "codes", and corresponding anonymous subs
# which, when invoked, should return one of the values (undef, '', 1)
# indicating how to proceed with the input.
#
# The sub "add_check", when invoked as part of the flag parsing (see
# above), causes the codes below to be inserted into the @checks array,
# which is then processed for each input.

%check_code = (
	'after',	\&check_after,
	'default',	\&check_default,
	'help',		\&check_help,
	'int',		\&check_integer,
	'key',		\&check_keys,
	'maxlen',	\&check_length,
	'match',	\&check_match,
	'nonkey',	\&check_nonkeys,
	'num',		\&check_number,
	'req',		\&check_required,
	'strip',	\&strip_input,
	'yesno',	\&check_yesorno,
	'null',		\&check_null,
       );

# This variable controls how the keyword matching is done.

$Case_sensitive = '';

$Force_Interactive = '';		# set to force interactive behaviour

##################################################################################
#
# 	&query($prompt, $flags, @optional_args)
#
# Returns
#
#   undef	EOF on input
#
#

sub query {
  local( $prompt ) = shift;
  local( $flags ) = shift;		# there may be other arguments
  local( $help, $required, $default, $match, $maxlen, $keys, $notkeys );
  local( $yes, $no, $integer, $number, $strip, $after, $before, $inref );
  local( $inref_once, $inref_flag, $variable );
  local( $c, $ev, $input );
  local( @flags ) = split(//,$flags);
  local( @checks, $check, $result );
  local( %check_done );		# make sure this gets reset

  foreach $c ( @flags ) {
    $ev = $query_flags{$c} or
    	(croak "query: Unknown query flag '$c'\n");
    &$ev;			# set a flag, or get the next argument
  }

  &add_check(qw( help null default ));	# these checks are done
					# by default (unless disabled)

  # setup a default, depending on type
  $default = $yes ? 'yes' : 'no' if $yes or $no;

  $help .= "\n" if $help && substr($help,-1) ne "\n";

  Query:while (1) {
    if (length($before)) {
	&$before or last;	# check $before sub first
    }
    if ($inref_flag) {		# do we have a reference?
	$input = &deref($inref);
	$inref_flag = '' if $inref_once;	# kill flag if "once"
    } else {
	if (-t STDIN or $Force_Interactive) {	# interactive?
	    print $prompt;
	    print " " unless substr($prompt, -1) eq ' ';
	    if ($default ne '') {
		my($def) = &deref($default);
		print "[$def] ";
	    }
	}
	$input = ;
	print "\n" if !-t STDIN and $Force_Interactive;
    }

    # Now process all the check expressions.  If any return undef, then
    # return from this routine with undef.  If a null or zero return is
    # made, then reject the input.  Otherwise, it passes.

    foreach $check ( @checks ) {
      $result = &$check;		# process the check
      return undef unless defined($result);	# was the result undef?

      # Perform the next test if this one was okay
      next if $result;

      # If $inref_flag is set (I flag), don't loop
      return undef 	if $inref_flag;

      # don't try looping on non-interactive input
      return undef unless -t STDIN or $Force_Interactive;

      print "Please try again, or enter \"?\" for help.\n";
      next Query;		# do another query
    }
    last Query;			# all tests passed
  }
  &define_var($variable, $input); # assign a variable (maybe)
  return $input;		# return with input
}

#############################
#
#	&deref ($possible_ref)
#
# If the $possible_ref is a reference, dereference it
# correctly.

sub deref {
    my($ref) = shift;
    my($type) = ref($ref);
    return $ref 	if $type eq '';		# not a reference
    return $$ref 	if $type eq 'SCALAR';	# a scalar
    return &$ref 	if $type eq 'CODE';	# a subroutine
    return @$ref	if $type eq 'ARRAY';	# an array
    return %$ref	if $type eq 'HASH';	# a hashed array
    return &deref($$ref) if $type eq 'REF';	# recursive reference
    $ref;					# whatever..
}


#############################
#
#	&add_check($code, @precedes)
#
# Add the check code for $code, after ensuring that all codes
# in @precedes have already been done.
#
# In other words, if a particular check should be done *after*
# some other test, place the other check code(s) as one of the
# elements in the @precedes array.
#
# Add_check ensures that no check is scheduled twice.

sub add_check {
  local($code,@precedes) = @_;
  return if $check_done{$code};	# don't make the same check twice
  local($c);			# ensure predecessors are done first
  foreach $c (@precedes) {	# see if others are done
    &add_check($c) unless $check_done{$c};
  }
  push(@checks,$check_code{$code});
  $check_done{$code}++;
}

#################################
#
# These are the "check" routines.
#
# They are all called without arguments, and have full access to the
# variables of the &query routine.

# They all should check $input and return either:
#
#  undef	-return from query with undef
#  ''		-fail the input, and force another query
#  1		-input is okay, do the next check


#	&check_after
#
#	If $after is a CODE ref, invoke it to
#	allow the sub to validate the input.

sub check_after {
  return 1 unless length($after);	# default is okay
  &$after(\$input);			# invoke the sub
}

#	&check_default
#
#	If $default is a CODE ref, invoke it to
#	get the default value, otherwise just use
#	the value as is.

sub check_default {
    $input = &deref($default) if !length($input);
    1;
}

#
#	&check_keys
#

sub check_keys {
  local( @exact );
  if ($Case_sensitive) {
    @exact = grep($input eq $_, @$keys);
  } else {
    @exact = grep(/^\Q$input\E$/i, @$keys);
  }
  if ($#exact == 0) {
    $input = $exact[0];	# it matches -- return the keyword
    return 1;		# yea!
  }
  local( @matches );
  if ($Case_sensitive) {
    @matches = grep(/^\Q$input\E/, @$keys);
  } else {
    @matches = grep(/^\Q$input\E/i, @$keys);
  }
  if ($#matches == 0) {	# exactly one match?
    $input = $matches[0];
    return 1;		# return success
  }
  if ($#matches > 0) {	# ambiguous?
    print "The input \"$input\" is ambiguous; it matches the following:\n";
    print_cols \@matches;
  } else {
    print "The input \"$input\" fails to match any of the allowed keywords:\n";
    print_cols $keys;
  }
  '';			# fail the input
}

#
#	&check_nonkeys
#

sub check_nonkeys {
  local( @matches );
  if ($Case_sensitive) {
    @matches = grep($_ eq $input, @$notkeys);
  } else {
    @matches  = grep(/^\Q$input\E$/i, @$notkeys);
  }
  @matches || return 1;		# no matches -- it's okay
  printf("The input \"%s\" matches a disallowed keyword \"%s\".\n",
	 $input, $matches[0]);
  return '';
}

#
#	&check_number
#

sub check_number {
  if ($input !~ /^(\d+(\.\d*)?|\.\d+)(e\d+)?$/i) {
    print "Please enter a number, real or integer.\n";
    return '';
  }
  $input = 0.0 + $input;	# convert to numeric
  1;				# and it's okay
}

#
#	&check_integer
#

sub check_integer {
  if ($input !~ /^(\d+|0x[0-9a-f]+)$/i) {
    print "Please enter an integer number.\n";
    return '';
  }
  $input = 0 + $input;	# conver to integer
  1;
}

#
#	&check_yesorno
#

sub check_yesorno {
  if ($input !~ /^(y(es?)?|no?)$/i) {
    print "Please answer with \"yes\" or \"no\".\n";
    return '';
  }
  # Coerce input to 'yes' or 'no'
  # Fixed by [e-mail] (Mark Wright)
  $input = $input =~ /^y(es?)?$/i ? 'yes' : 'no';
}

#
#	&check_match
#

sub check_match {
  return 1 if $match eq '' or $input =~ m/$match/;
  printf "\"%s\" fails to match \"%s\"\n", $input, $match;
  '';			# fail the input
}

#
#	&check_length
#

sub check_length {
  return 1 if $maxlen <= 0 or length($input) <= $maxlen;
  printf "Input is %d characters too long; cannot exceed %d characters.\n",
	 (length($input) - $maxlen), $maxlen;
  '';			# fail the input
}

#
#	&check_required
#
sub check_required {
  return 1 if length($input);
  print "Input is required.\n";
  '';			# fail the input
}

#
#	&check_null
#

sub check_null {
  return undef unless length($input);	# a null input is an EOF
  chomp($input);			# trim trailing newline
  1;					# always succeed
}

#
#	&strip_input

sub strip_input {
  $input =~ s/^\s+//;
  $input =~ s/\s+$//;
  $input =~ s/\s+/ /g;		# squeeze blanks
  1;				# always ok
}

#
#	&check_help
#
# Check for help trigger '?'

sub check_help {
  $input =~ /^\s*\?\s*$/ || return 1;	# if not '?', its okay
  print ($help || "You are being asked \"$prompt\"\n");
  print "Input is required.\n" if $required;
  printf "The input should be %s.\n",($integer ? 'an integer' : 'a number')
    if $integer || $number;
  print "The input should be either \"yes\" or \"no\".\n" if $yes || $no;
  if ($default) {
    my($def) = &deref($default);
    print "If you enter nothing, the default answer will be \"$def\".\n";
  } else {
    print "There is no default input.\n";
  }
  printf "The input cannot exceed %d characters in length.\n", $maxlen
    if $maxlen;
  printf "The input must match the pattern \"%s\".\n",$match if $match;
  if (@$keys) {
    print "The input must match one of the following keywords:\n";
    print_cols $keys, 0, 0, 1;
    print "The keyword matching is case-sensitive.\n" if $Case_sensitive;
  }
  if (@$notkeys) {
    print "The input cannot match one of the following keywords:\n";
    print_cols $notkeys, 0, 0, 1;
    print "The keyword matching is case-sensitive.\n" if $Case_sensitive;
  }
  print "\n";
  '';				# cause another query
}


###############
#
# query_table_process \@array, \&flagsub, \&querysub.
#
# Given an array suitable for query_table, run through the table and
# perform &querysub on each query definition, invoking &flagsub on each
# flag character.
#
# The local variables available to the subs are:
#   $table	- the array reference
#   $flags	- all the flags
#   $flag	- the current flag being processed (&flagsub only)
#   $arg	- the argument for the current flag, if appropriate.
#   $prompt	- the prompt for the current query
#
# When the &querysub is invoked, if it returns UNDEF, then the query
# table processing stops immediately, with an UNDEF return.

sub query_table_process {
  local( $table ) = shift;		# the query table
  local( $flagsub ) = shift;		# sub to perform on each flag
  local( $querysub ) = shift;		# sub to perform for each query
  local( $x, $prompt, $flags, $query_args, $argx, $flag, $_, $arg);

  ref($table) eq 'ARRAY' or
    (croak "query_table_process: Need an array reference argument.\n");
  (ref($flagsub) eq 'CODE' or $flagsub eq '') and
  (ref($querysub) eq 'CODE' or $querysub eq '') or
    (croak "query_table_process: Need a code reference argument.\n");

  for ($x = 0; $x <= $#$table; $x += 3) {
    $prompt     = $table->[$x];		# get the prompt
    $flags      = $table->[$x+1];	# get the flags
    $query_args = $table->[$x+2];	# get the arguments (if any)
    $argx	= 0;			# initialize arg index
    foreach $flag ( split(//, $flags) ) {
      $query_flags{$flag} or
	(croak "query_table_set_defaults: Unknown query flag: '$flag'\n");
      $arg = '';			# set arg to null by default
      if (index($need_arg_codes, $flag) >= 0) {
	$arg = $query_args->[$argx++];	# get the next arg
      }
      &$flagsub if $flagsub ne '';	# run the flag sub
    }
    if ($querysub ne '') {		# is there a querysub?
      &$querysub or return undef;	# run the query
    }
  }
  1;
}

###############
#
# $ok = query_table \@array;
#
# $ok == undef if EOF returned
#     == 1 if all queries completed ok
#     == 0 if not.
#
# Run multiple queries given "query" entries in the @array.
#
# The array is organized like this:
#
#  @array = ( prompt1, flags1, [ arglist1, ... ],
#	      prompt2, flags2, [ arglist2, ... ],
#		...
#	      promptN, flagsN, [ arglistN, ...] )
#
# Note: the query table is a N x 3 array, with the 3rd column being
# itself arrays of varying lengths, depending upon the corresponding
# flags.
#
# Of course, this routine is more useful if the flags contain the 'V'
# flag, and the arglist has a correspoinding variable name.
#

sub query_table {
  local( $table ) = shift;
  local( @args );

  query_table_process $table, 	# process the query table
    sub {			# flagsub
      push(@args, $arg) if index($need_arg_codes, $flag) >= 0;
    },
    sub {			# querysub
      defined(query $prompt, $flags, @args) or return undef;
      @args = ();		# reset the args array
      1;
    };
  1;
}

###############
#
# query_table_set_defaults \@array;
#
# Given an array suitable for query_table, run through the table and
# initialize any variables mentioned with the provided defaults, if any.
#
# This routine is suitable for preinitializing variables using the
# same query table as would be used to query for their values.
#

sub query_table_set_defaults {
  local( $table ) = shift;		# the query table
  local( $var, $def );

  query_table_process $table,
    sub {				# flag sub
      $var = $arg if $flag eq 'V';	# look for the variable arg
      $def = $arg if $flag eq 'd';	# look for the default arg
    },
    sub { &define_var($var, $def); };	# define a variable (maybe)
  1;
}

#######################
#
# define_var $var, $ref
#
# Define $var outside of this package.
#
# $var can be a reference to a variable, or it can be a string name.
# If it is the latter and not already qualified, it will be
# qualified at the package level outside of the Query.pm module.
#

sub define_var {
  my( $var ) = shift;			# the variable name
  my( $ref ) = shift;			# the value to define
  return 1 unless length($var);		# don't work with nulls
  if (!(ref($var) or $var =~ /::/)) { 	# variable already qualified?
    my( $pkg, $file ) = (caller)[0,1];	# get caller info
    my( $i );
    # Walk the stack until we get the first level outside of Query.pm
    for ($i = 1; $file =~ /Query\.pm/; $i++) {
      ($pkg, $file) = (caller $i)[0,1];
    }
    $pkg = 'main' unless $pkg ne '';	# default package
    $var = "${pkg}::${var}";		# qualify the variable's scope
  }
  $$var = &deref($ref);			# assign a deref'ed value
  1;					# always return good stuff
}

1;

__END__