[Module-build-checkins] [svn:Module-Build] r5931 - in Module-Build/trunk: . lib/Module/Build t
Status: Beta
Brought to you by:
kwilliams
|
From: <ra...@cv...> - 2006-04-19 08:43:21
|
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;
|