module-build-checkins

[<ra...@cv...>]

Author: randys
Date: Wed Apr 19 01:42:17 2006
New Revision: 5931

Modified:
   Module-Build/trunk/Build.PL
   Module-Build/trunk/Changes
   Module-Build/trunk/lib/Module/Build/API.pod
   Module-Build/trunk/lib/Module/Build/Base.pm
   Module-Build/trunk/t/extend.t

Log:
Initial implementation of the ask() method.

Modified: Module-Build/trunk/Build.PL
==============================================================================
--- Module-Build/trunk/Build.PL	(original)
+++ Module-Build/trunk/Build.PL	Wed Apr 19 01:42:17 2006
@@ -33,6 +33,7 @@
 		'ExtUtils::Mkbootstrap' => 0,
 		'IO::File'       => 0,
 		'Cwd'            => 0,
+		'Text::Abbrev'   => 0,
 		'Text::ParseWords' => 0,
 		'Getopt::Long'   => 0,
 		'Test::Harness'  => 0,

Modified: Module-Build/trunk/Changes
==============================================================================
--- Module-Build/trunk/Changes	(original)
+++ Module-Build/trunk/Changes	Wed Apr 19 01:42:17 2006
@@ -2,6 +2,12 @@
 
 0.27_11
 
+ - Add new method ask(), that's intended to provide a better tool for
+   authors to query users when performing a build. It provides better
+   support for unattended builds as well as providing better
+   validation of input. This new method is preferred over prompt() and
+   y_n().
+
  - When searching for '.modulebuildrc', return the first HOME-like
    directory that actually contains the file instead of the first
    existing directory. Document the search locations and the order

Modified: Module-Build/trunk/lib/Module/Build/API.pod
==============================================================================
--- Module-Build/trunk/lib/Module/Build/API.pod	(original)
+++ Module-Build/trunk/lib/Module/Build/API.pod	Wed Apr 19 01:42:17 2006
@@ -819,6 +819,115 @@
 the second argument is assigned to the args hash under the key passed as the
 first argument.
 
+=item ask()
+
+[version 0.28]
+
+Asks the user a question and returns the answer as a string.
+
+The following is a list of arguments.  Only C<prompt> and C<default>
+are required.
+
+=over
+
+=item allow_nonoption_default
+
+Normally, if an C<options> array is present, then the value of the
+C<default> argument must exist in C<options>.  Setting
+C<allow_nonoption_default> to true allows the C<default> argument to
+be set to an arbitrary value.
+
+Default is false.
+
+=item default   [required]
+
+This is the default value that will be used if the user presses
+E<lt>enterE<gt> or if running an unattended build.
+
+The value assigned to C<default> may be different from the options
+listed in the C<options> argument.
+
+=item getopts_name
+
+The name of a command line option.  If an option with this name is
+given on the command line, the value of the option will be used as the
+answer to the prompt.
+
+=item on_validate
+
+This is a code reference that can be used to validate or modify the
+answer entered by the user.  The value the user enters will be passed
+in as the first argument, and it will also be stored in C<$_>
+variable.  Any modification to the variable C<$_> will be retained as
+the new answer.
+
+The subroutine passed to C<on_validate> must return a value to
+indicate how to proceed.
+
+If the return value is true, then the answer will be accepted as is,
+without further testing.  In particular, there will be no test to
+ensure that the answer is in the C<options> array if any where given.
+
+If the return value is false, then the answer will be rejected and a
+new answer will be requested, regardless of whether the answer exists
+in the C<options> array.
+
+If the return value is C<undef>, then the answer will be subject to
+the normal checks: if there is an C<options> array and the answer is
+one of the options, it will be accepted; if it is an open-ended query
+without an C<options> array, it will be accepted; otherwise it will be
+rejected.
+
+=item options
+
+A reference to an array containing a list of valid options.  If options
+are provided, C<ask()> will not return until a valid option is
+entered, or the C<default> is selected by pressing E<lt>enterE<gt>
+without entering a value.  Option names are case-insensitive, but the
+option returned will be normalized to the form used in the argument to
+C<options>.  It is not necessary for the user to enter the entire
+option name; C<ask()> will accept any unambiguous sequence of
+characters that will match only one option.  Eg. If the options are
+C<qw(yes no)> it will accept any of 'y', 'ye', or 'yes' to mean
+yes.  The complete option name will be returned.
+
+If no options are provided, C<ask()> will accept any response from the
+user.
+
+=item prompt   [required]
+
+This string will be displayed to the user to indicate that input is
+needed.  It should indicate the type of input required.
+
+=item show_default
+
+A boolean value that indicates whether the default value should be
+displayed as part of the prompt.  If true and if the default is a
+non-empty string, the default will be displayed at the end of the
+prompt, after the list of options if present.  It will be enclosed in
+square brackets.
+
+Default is true.
+
+=item show_options
+
+A boolean value that indicates whether the list of options should be
+displayed as part of the prompt.  If true and if C<options> contains a
+non-empty array, the list of options will be displayed at the end of
+the prompt, and before the C<default> value if it is shown.  The
+options will be separated by slashes and enclosed in parenthesis.
+
+Default is true.
+
+=back
+
+If C<ask()> detects that it is not running interactively and there
+is nothing on STDIN or if the PERL_MM_USE_DEFAULT environment variable
+is set to true, the C<default> will be used without prompting.  This
+prevents automated processes from blocking on user input.
+
+This method may be called as a class or object method.
+
 =item autosplit_file($from, $to)
 
 [version 0.28]

Modified: Module-Build/trunk/lib/Module/Build/Base.pm
==============================================================================
--- Module-Build/trunk/lib/Module/Build/Base.pm	(original)
+++ Module-Build/trunk/lib/Module/Build/Base.pm	Wed Apr 19 01:42:17 2006
@@ -473,13 +473,13 @@
 sub _readline {
   my $self = shift;
 
-  my $ans;
+  my $answer;
   if ( !$self->_is_unattended ) {
-    $ans = <STDIN>;
-    chomp $ans if defined $ans;
+    $answer = <STDIN>;
+    chomp $answer if defined $answer;
   }
 
-  return $ans;
+  return $answer;
 }
 
 sub prompt {
@@ -530,6 +530,144 @@
   }
 }
 
+sub ask {
+  my $self = shift;
+  my %args = @_;
+
+  # Check argument requirements
+  croak("ask() called without a prompt message") unless $args{prompt};
+  croak("ask() called without a default value") unless exists($args{default});
+
+  # Set defaults
+  my $show_options = exists($args{show_options}) ? $args{show_options} : 1;
+  my $show_default = exists($args{show_default}) ? $args{show_default} : 1;
+
+  my $getopts_name = exists($args{getopts_name}) ? $args{getopts_name} : undef;
+
+  my $allow_nonoption_default = exists($args{allow_nonoption_default})
+      ? $args{allow_nonoption_default} : 0;
+
+  my $on_validate = ref( $args{on_validate} ) eq 'CODE'
+    ? sub {
+        my $ans_ref = shift;
+        local $_ = $$ans_ref;
+        my $ret = $args{on_validate}->($_);
+        $$ans_ref = $_;
+        return $ret;
+      }
+    : sub { return undef };
+
+
+  # Setup options & abbrevs
+  my @options = ();
+  my $disp_options = '';
+  my %abbrev_of = ();
+  my %proper_case_of = ();
+
+  if ( $args{options} && ref($args{options}) eq 'ARRAY' ) {
+    @options = @{$args{options}};
+    if ( @options ) {
+      require Text::Abbrev;
+      %abbrev_of = Text::Abbrev::abbrev(map lc, @options);
+      %proper_case_of = map { lc $_, $_ } @options;
+      $disp_options = '(' . join('/', @options) . ')';
+    }
+  }
+
+  # Validate the default
+  my $default;
+  if ( $allow_nonoption_default ||
+       !$args{options}          ||
+       grep( {$_ eq $args{default}} @options ) )
+  {
+    $default = $args{default};
+  } else {
+    croak("The 'default' argument must exist in 'options' array.");
+  }
+
+  my $disp_default = '[' . $proper_case_of{$abbrev_of{lc $default}} . ']'
+    if $default && exists($abbrev_of{lc $default});
+
+  # Format prompt
+  my $prompt = $args{prompt};
+
+  # if $prompt ends in new-line, don't insert inital space
+  my $space = sub { (substr($_[0], -1) eq "\n") ? '' : ' ' };
+
+  $prompt .= $space->($prompt) . $disp_options
+      if $disp_options && $show_options;
+
+  $prompt .= $space->($prompt) . $disp_default
+      if $disp_default && $show_default;
+
+  $prompt .= $space->($prompt);
+
+
+  local $|=1;
+
+  # Guess
+  if ( $getopts_name && ref($self) ) {
+
+    my %cmdline_args = $self->args;
+    if ( exists( $cmdline_args{$getopts_name} ) ) {
+
+      my $answer = $cmdline_args{$getopts_name} || '';
+      print $args{prompt} . $space->($args{prompt}) . "$answer\n";
+
+      $answer = $proper_case_of{$abbrev_of{lc $answer}}
+          if exists($abbrev_of{lc $answer});
+
+      my $is_valid = $on_validate->(\$answer);
+      if ( $is_valid ) {
+        return $answer;
+      } elsif ( defined( $is_valid ) ) {
+        # defined, but false return: do not continue other checks
+      } elsif ( @options ) {
+        if ( exists($abbrev_of{lc $answer}) || $answer eq $default ) {
+          return $answer;
+        } else {
+          warn "Invalid option '$getopts_name=$answer'\n\n";
+        }
+      } else {
+        return $answer;
+      }
+    }
+  }
+
+  # Get answer
+  my $answer;
+  my $needs_answer = 1;
+  while ( $needs_answer ) {
+    print $prompt;
+    $answer = $self->_readline();
+
+    if ( !defined($answer) || !length($answer) ) { # Ctrl-D || Default
+      print "$default\n";
+      $answer = $default;
+      $needs_answer = 0;
+
+    } else {
+      $answer = $proper_case_of{$abbrev_of{lc $answer}}
+          if exists($abbrev_of{lc $answer});
+
+      my $is_valid = $on_validate->(\$answer);
+      if ( $is_valid ) {
+        $needs_answer = 0;
+      } elsif ( defined( $is_valid ) ) {
+        # defined, but false return: do not continue other checks
+      } elsif ( @options ) {
+        if ( exists($abbrev_of{lc $answer}) || $answer eq $default ) {
+          $needs_answer = 0;
+        }
+      } else {
+        $needs_answer = 0;
+      }
+    }
+  }
+
+  return $answer;
+}
+
 sub current_action { shift->{action} }
 sub invoked_action { shift->{invoked_action} }
 

Modified: Module-Build/trunk/t/extend.t
==============================================================================
--- Module-Build/trunk/t/extend.t	(original)
+++ Module-Build/trunk/t/extend.t	Wed Apr 19 01:42:17 2006
@@ -2,7 +2,7 @@
 
 use strict;
 use lib $ENV{PERL_CORE} ? '../lib/Module/Build/t/lib' : 't/lib';
-use MBTest tests => 64;
+use MBTest tests => 82;
 
 use Cwd ();
 my $cwd = Cwd::cwd;
@@ -211,7 +211,7 @@
   local $ENV{PERL_MM_USE_DEFAULT};
 
   local $^W = 0;
-  *{Module::Build::_readline} = sub { 'y' };
+  local *{Module::Build::_readline} = sub { 'y' };
 
   ok my $mb = Module::Build->new(
 				  module_name => $dist->name,
@@ -262,6 +262,104 @@
   ok $ans, "  y_n() with a default";
 }
 
+{
+  # Test interactive prompting
+
+  my $ans;
+  local $ENV{PERL_MM_USE_DEFAULT};
+
+  local $^W = 0;
+  local *{Module::Build::_readline} = sub { 'y' };
+
+  ok my $mb = Module::Build->new(
+				  module_name => $dist->name,
+				  license => 'perl',
+                                  args => {login => 'randys',
+                                           boolean => 'yes'},
+			        );
+
+  eval{ $mb->ask() };
+  like $@, qr/called without a prompt/, 'ask() requires a prompt';
+
+  eval{ $mb->ask(prompt => 'prompt?') };
+  like $@, qr/called without a default/, 'ask() requires a default';
+
+  eval{ $mb->ask(prompt => 'prompt?', default => 'y') };
+  print "\n";
+  is $@, '', 'default not required in options when options is undefined';
+
+  eval{ $mb->ask(prompt => 'prompt?', default => 'y',
+                 options => [qw(a b c)]) };
+  like $@, qr/'default' argument must exist in 'options' array/,
+      'default must exist in options when options is non-empty';
+
+  eval{ $mb->ask(prompt  => 'prompt?',
+                 default => 'y',
+                 allow_nonoption_default => 1) };
+  print "\n";
+  is $@, '', 'open ended query';
+
+  eval{ $mb->ask(prompt  => 'prompt?',
+                 default => 'y',
+                 options => [qw(a b c)],
+                 allow_nonoption_default => 1) };
+  print "\n";
+  is $@, '', 'multi-choice with nonoption default';
+
+  eval{ $mb->ask(prompt  => 'prompt?',
+                 default => 'y',
+                 options => [qw(a b c y)] ) };
+  print "\n";
+  is $@, '', 'multi-choice with option default';
+
+  undef( $ans );
+  eval{ $ans = $mb->ask(prompt  => 'login?',
+                        default => 'guest',
+                        getopts_name => 'login',
+                        allow_nonoption_default => 1) };
+  print "\n";
+  is $@, '';
+  is $ans, 'randys', 'get answer from command line option';
+
+  undef( $ans );
+  eval{ $ans = $mb->ask(prompt  => 'prompt?',
+                        default => 'yes',
+                        options => [qw(yes no)],
+                        getopts_name => 'boolean' ) };
+  print "\n";
+  is $@, '';
+  is $ans, 'yes', 'get answer from command line option';
+
+  undef( $ans );
+  eval{ $ans = $mb->ask(prompt  => 'prompt?',
+                        default => 'yes',
+                        options => [qw(yes no)],
+                        on_validate => sub { s/yes/true/; 1 } ) };
+  print "\n";
+  is $@, '';
+  is $ans, 'true', 'change/validate answer';
+
+
+
+  *{Module::Build::_readline} = sub { undef };
+  undef( $ans );
+  eval{ $ans = $mb->ask(prompt  => 'prompt?',
+                        default => 'y',
+                        options => [qw(y n)] ) };
+  print "\n";
+  is $@, '';
+  is $ans, 'y', '<ctrl-d> - default answer';
+
+  *{Module::Build::_readline} = sub { '' };
+  undef( $ans );
+  eval{ $ans = $mb->ask(prompt  => 'prompt?',
+                        default => 'y',
+                        options => [qw(y n)] ) };
+  print "\n";
+  is $@, '';
+  is $ans, 'y', '<enter> - default answer';
+}
+
 # cleanup
 chdir( $cwd ) or die "Can''t chdir to '$cwd': $!";
 $dist->remove;