Permalink
Browse files

Merge in Damian's latest (1/1/2011) version of IO::Prompter.

  • Loading branch information...
colomon committed Jan 2, 2011
1 parent 947091e commit e5ff9131ecc07f0ed17b67b51311f5b814aa629c
Showing with 367 additions and 0 deletions.
  1. +179 −0 lib6/IO/Prompter.pm
  2. 0 {lib → old-lib}/IO/Prompter.pm
  3. +21 −0 t/YES__def.t
  4. +21 −0 t/YN__def.t
  5. +11 −0 t/explicit_prompt.t
  6. +13 −0 t/fail.t
  7. +13 −0 t/integer.t
  8. +24 −0 t/must.t
  9. +13 −0 t/number.t
  10. +13 −0 t/verbatim.t
  11. +17 −0 t/wipe.t
  12. +21 −0 t/yes_def.t
  13. +21 −0 t/yn_def.t
View
@@ -0,0 +1,179 @@
+#! /Users/damian/bin/rakudo*
+use v6;
+
+class IO::Prompter::Result {
+ has $!input;
+ has $!failed;
+
+ method defined { $!input.defined }
+ method Bool { ! $!failed }
+ method Str { ~ $!input }
+ method Stringy { ~ $!input }
+ method Num { + $!input }
+ method Numeric { + $!input }
+ method Int { $!input.Int }
+ method Integral{ $!input.Int }
+};
+
+module IO::Prompter;
+
+my $null = regex { <before .?> }
+my $sign = regex { <[+\-]> }
+my $digits = regex { \d+: }
+my $number = regex { <$sign>? <$digits> [\.<$digits>?]? [<[eE]><$sign>?<$digits>]? }
+my $integer = regex { <$sign>? <$digits> }
+my $yes = regex { :i ^ \h* [ y | yes ] }
+my $Yes = regex { <-[y]> .* }
+my $yesno = regex { :i [ y | yes | n | no ] }
+my $YesNo = regex { [ Y | Yes | N | No ] }
+
+my %constraint =
+ Int => [': ', 'a valid integer', /^ \h* <$integer> \h* $/, *.Int ],
+ Num => [': ', 'a valid number', /^ \h* <$number> \h* $/, +* ],
+ Bool => ['? ', '"yes" or "no"', /^ \h* <$yesno> \h* $/, {?m/<$yes>/} ],
+ SemiBool => ['? ', '"yes" or "no"', /^ \h* \S+ \h* $/, {?m/<$yes>/} ],
+ CapSemiBool => ['? ', '"Yes" for yes', /^ \h* <$Yes> \h* $/, {?m/<$yes>/} ],
+ CapFullBool => ['? ', '"Yes" or "No"', /^ \h* <$YesNo> \h* $/, {?m/<$yes>/} ],
+ Mu => [': ', 'anything', / <$null> /, { $^self } ];
+
+sub build_prompter_for (Mu $type, :$in = $*IN, :$out = $*OUT, *%build_opt) {
+ my ($punct, $description, $match, $extractor)
+ = (%constraint{$type} // %constraint<Mu>)[];
+
+ return sub ($prompt is copy, *%opt) {
+ $prompt ~= $punct if %build_opt<autopunctuate>;
+ $out.print($prompt) if ($in & $out).t;
+ loop {
+ my $input = $in.get() // return;
+ $input = %build_opt<default> // $input if $input eq "";
+ my $retval = $extractor($input);
+ if $input !~~ $match {
+ $out.print("Please enter $description. $prompt")
+ if ($in & $out).t;
+ }
+ elsif $retval !~~ (%build_opt<constraints>//Mu) {
+ $out.print("Please enter a valid {lc $prompt}")
+ if ($in & $out).t;
+ }
+ elsif %build_opt<must> {
+ return $retval
+ unless gather for %build_opt<must>.kv -> $msg, $constraint {
+ next if $input|$retval ~~ $constraint;
+ $out.print( $msg ~~ /^<upper>/ ?? $msg !! $prompt ~ "(must $msg) ")
+ if ($in & $out).t;
+ take 'failed';
+ last;
+ }
+ }
+ else {
+ return $retval;
+ }
+ }
+ }
+}
+
+sub varname_to_prompt ($name) {
+ return $name.subst(/^<-alnum>+/, "").subst(/_/, " ", :g).ucfirst;
+}
+
+multi sub prompt ( &block ) is export {
+ my (%named, @positional, $eof);
+
+ my @param_prompters = gather for &block.signature.params -> $param {
+ my $constraints = $param.constraints;
+ my $prompter = build_prompter_for($param.type.perl, :$constraints, :autopunctuate);
+
+ if $param.named {
+ my $label = $param.named_names;
+ my $name = varname_to_prompt($label);
+ take my $handler = { %named.push($label => $prompter($name) // $eof++) };
+ }
+ else {
+ my $name = varname_to_prompt($param.name);
+ take my $handler = { @positional.push($prompter($name) // $eof++) };
+ }
+ }
+
+ my @gathered; # Workaround for broken optimization behaviour
+ loop {
+ say "";
+ %named = @positional = ();
+ for @param_prompters { $^prompter() unless $eof }
+ last if $eof;
+ push @gathered, gather block(|@positional, |%named);
+ }
+ return @gathered;
+}
+
+
+my $first_wipe = 1;
+
+multi sub prompt (
+ $prompt_str?,
+# :a( :$args ) of Bool,
+# :c( :$complete ) of Array|Hash|Str,
+ :d(:$default) of Str,
+#--> :D(:$DEFAULT) of Str,
+# :e( :$echo ) of Str,
+ :f(:$fail) of Bool = sub{False},
+ :$in of IO = $*IN,
+# :g( :$guarantee ) of Hash = hash{},
+# :h( :$history ) of Str,
+ :i(:$integer) of Bool,
+# :k( :$keyletters ) of Bool,
+# :l( :$line ) of Bool,
+#--> :$menu of Any,
+ :$must of Hash = hash{},
+ :n(:$number) of Bool,
+ :$out of IO = $*OUT,
+ :p(:$prompt) of Str is copy,
+# :r( :$return ) of Str,
+# :$stdio of Bool,
+# :s( :$single ) of Bool,
+# :t( :$timeout ) of Bool,
+ :v(:$verbatim) of Bool,
+ :w(:$wipe) of Bool,
+ :wf(:$wipefirst) of Bool,
+ :y(:$yes) of Bool,
+ :yn(:$yesno) of Bool,
+ :Y(:$Yes) of Bool,
+ :YN(:$YesNo) of Bool,
+ *%unexpected_options,
+ *@prompt,
+) is export {
+ # Die horribly if unknown options are offered...
+ if %unexpected_options {
+ die %unexpected_options.map({"Unknown option in call to prompt(): $_.perl()"}).join("\n");
+ }
+
+ # Sort out the prompt...
+ @prompt.unshift($prompt_str // ());
+ $prompt //= (@prompt ?? @prompt.join !! '>');
+ if $prompt ~~ / (.*\w) $ / { $prompt ~= ": " }
+ if $prompt ~~ / (.*\S) $ / { $prompt ~= " " }
+ $prompt.=subst(/\n$/,"");
+
+ my $constraint = $Yes ?? 'CapSemiBool'
+ !! $YesNo ?? 'CapFullBool'
+ !! $yes ?? 'SemiBool'
+ !! $yesno ?? 'Bool'
+ !! $integer ?? 'Int'
+ !! $number ?? 'Num'
+ !! 'Mu';
+
+ my $prompter = build_prompter_for($constraint, :$in, :$out, :$default, :$must);
+
+ if ($wipe || $wipefirst && $first_wipe) {
+ say "\n" x 60;
+ $first_wipe = 0;
+ }
+
+ my $input = $prompter($prompt, :$default, :$yes, :$Yes, :$yesno, :$YesNo);
+ my $failed = !$input.defined
+ || $yes|$Yes|$yesno|$YesNo && !$input
+ || ?( $input ~~ $fail );
+
+ return $verbatim ?? $input
+ !! IO::Prompter::Result.new(:$input, :$failed);
+}
+
File renamed without changes.
View
@@ -0,0 +1,21 @@
+#! /Users/damian/bin/rakudo*
+use v6;
+
+use Testing;
+use IO::Prompter;
+
+OK have => prompt('Type "Yes":', :Y, :default<n>, in => IN('yes','Yes')),
+ want => 1,
+ desc => ':Y with "yes"';
+
+OK have => prompt('Type "Y":', :Yes, :default<n>, in => IN('Y')),
+ want => 1,
+ desc => ':Yes with "y"';
+
+OK have => prompt('Type anything but "Y":', :Yes, :default<n>, in => IN('huh?')),
+ want => 0,
+ desc => ':Yes with "n"';
+
+OK have => prompt('Just hit return:', :Yes, :default<n>, in => IN('')),
+ want => 0,
+ desc => ':Yes with default';
View
@@ -0,0 +1,21 @@
+#! /Users/damian/bin/rakudo*
+use v6;
+
+use Testing;
+use IO::Prompter;
+
+OK have => prompt('Type "Yes":', :YesNo, :default<n>, in => IN('yes','no','Yes')),
+ want => 1,
+ desc => ':YesNo with "Yes"';
+
+OK have => prompt('Type "Y":', :YN, :default<n>, in => IN('Y')),
+ want => 1,
+ desc => ':YN with "Y"';
+
+OK have => prompt('Type "N":', :YesNo, :default<n>, in => IN('huh?','no','No')),
+ want => 0,
+ desc => ':YesNo with "N"';
+
+OK have => prompt('Just hit return:', :YesNo, :default<N>, in => IN('')),
+ want => 0,
+ desc => ':YesNo with default';
View
@@ -0,0 +1,11 @@
+#! /Users/damian/bin/rakudo*
+use v6;
+
+use Testing;
+use IO::Prompter;
+
+SKIP 'Interactive test only' if $*IN !~~ :t || $*OUT !~~ :t;
+
+OK have => prompt('Press "n"', :prompt<Press 'y'>, :yesno),
+ want => 1,
+ desc => "Override the prompt";
View
@@ -0,0 +1,13 @@
+#! /Users/damian/bin/rakudo*
+use v6;
+
+use Testing;
+use IO::Prompter;
+
+OK have => prompt(fail => /bye/, in => IN('hello')),
+ want => 'hello',
+ desc => "Don't fail";
+
+OK have => prompt(fail => /bye/, in => IN('bye')),
+ want => !*,
+ desc => "Fail";
View
@@ -0,0 +1,13 @@
+#! /Users/damian/bin/rakudo*
+use v6;
+
+use Testing;
+use IO::Prompter;
+
+OK have => prompt(:integer, in => IN('a','1.2','-42a','-12')),
+ want => -12,
+ desc => "Require an integer";
+
+OK have => prompt(:i, in => IN('a','1.2','-42a','-12')),
+ want => -12,
+ desc => "Require an integer (short form)";
View
@@ -0,0 +1,24 @@
+#! /Users/damian/bin/rakudo*
+use v6;
+
+use Testing;
+use IO::Prompter;
+
+my $result;
+
+$result = prompt "Enter line 1",
+ :must{ 'have a 2' => /2/ },
+ in=>IN('Line 1','Line 2');
+OK have => $result,
+ want => 'Line 2',
+ desc => 'First line retrieved';
+
+$result = prompt "Enter line 2",
+ :number,
+ :must{ 'be in [1..10]' => 1..10,
+ 'be even' => { $_ %% 2 }
+ },
+ in=>IN(42,7,6);
+OK have => $result,
+ want => '6',
+ desc => 'Second line retrieved';
View
@@ -0,0 +1,13 @@
+#! /Users/damian/bin/rakudo*
+use v6;
+
+use Testing;
+use IO::Prompter;
+
+OK have => prompt(:number, in => IN('a','4.2a','1.2')),
+ want => 1.2,
+ desc => "Require a number";
+
+OK have => prompt(:n, in => IN('a','4.2a','1.2')),
+ want => 1.2,
+ desc => "Require a number (short form)";
View
@@ -0,0 +1,13 @@
+#! /Users/damian/bin/rakudo*
+use v6;
+
+use Testing;
+use IO::Prompter;
+
+OK have => prompt(in => IN('hello')),
+ want => none(Str),
+ desc => "Non-verbatim doesn't return Str";
+
+OK have => prompt(:verbatim, in => IN('hello')),
+ want => Str & 'hello',
+ desc => "Verbatim returns Str";
View
@@ -0,0 +1,17 @@
+#! /Users/damian/bin/rakudo*
+use v6;
+
+use Testing;
+use IO::Prompter;
+
+SKIP 'Interactive test only' if $*IN !~~ :t || $*OUT !~~ :t;
+
+OK have => prompt(:wf, :yn, 'This should have wiped the screen. Did it?'),
+ desc => "Wipe first";
+
+OK have => prompt(:wf, :yn, 'This should not have wiped the screen. Did it?'),
+ want => 0,
+ desc => "Wipe first";
+
+OK have => prompt(:w, :yn, 'This should have wiped the screen. Did it?'),
+ desc => "Wipe first";
View
@@ -0,0 +1,21 @@
+#! /Users/damian/bin/rakudo*
+use v6;
+
+use Testing;
+use IO::Prompter;
+
+OK have => prompt('Type "yes":', :yes, :default<n>, in => IN('yes')),
+ want => 1,
+ desc => ':yes with "yes"';
+
+OK have => prompt('Type "y":', :yes, :default<n>, in => IN('y')),
+ want => 1,
+ desc => ':yes with "y"';
+
+OK have => prompt('Type anything but "y":', :yes, :default<n>, in => IN('huh?')),
+ want => 0,
+ desc => ':yes with "n"';
+
+OK have => prompt('Just hit return:', :y, :d<n>, in => IN('')),
+ want => 0,
+ desc => ':y with default (short forms)';
View
@@ -0,0 +1,21 @@
+#! /Users/damian/bin/rakudo*
+use v6;
+
+use Testing;
+use IO::Prompter;
+
+OK have => prompt('Type "yes":', :yesno, :default<n>, in => IN('yes')),
+ want => 1,
+ desc => ':yesno with "yes"';
+
+OK have => prompt('Type "y":', :yesno, :default<n>, in => IN('y')),
+ want => 1,
+ desc => ':yesno with "y"';
+
+OK have => prompt('Type "n":', :yn, :default<n>, in => IN('huh?','no')),
+ want => 0,
+ desc => ':yn with "n"';
+
+OK have => prompt('Just hit return:', :yesno, :default<n>, in => IN('')),
+ want => 0,
+ desc => ':yesno with default';

0 comments on commit e5ff913

Please sign in to comment.