Skip to content
Browse files

First source commit from Damian's YAPC::NA tarball (June 2010).

  • Loading branch information...
1 parent a7fdf31 commit b7bd96107b35154facbfe39ac2ed89bcea55a27d @pmichaud pmichaud committed Jul 19, 2010
View
11 demo_IO_Prompter_args.p6
@@ -0,0 +1,11 @@
+#! /Users/damian/bin/rakudo'
+use v6;
+
+use IO::Prompter;
+
+while prompt('Args:', :args) -> $input {
+ say "Got [$input]";
+ say @*ARGS.perl;
+}
+
+
View
38 demo_IO_Prompter_integer_yesno.p6
@@ -0,0 +1,38 @@
+#! /Users/damian/bin/rakudo'
+use v6;
+
+use IO::Prompter;
+
+loop {
+ my $name = prompt("Name:") // last;
+ my $age = prompt("Age:", :integer, :must({'be positive'=>*>0}) )
+ // last;
+ my $married = prompt("Married?", :yesno) // last;
+
+ report($name, $age, $married);
+}
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+sub report ($name, $age, $married) {
+ say " $name (aged $age) is{$married ?? '' !! "n\'t"} married";
+}
+
View
12 demo_IO_Prompter_number.p6
@@ -0,0 +1,12 @@
+#! /Users/damian/bin/rakudo'
+use v6;
+
+use IO::Prompter;
+
+while prompt("Weight:", :number, :default(42),
+ :must({'be greater than 0'=> *>0 })
+) -> $input {
+ say "Got [$input]";
+}
+
+
View
35 demo_IO_Prompter_promptloop.p6
@@ -0,0 +1,35 @@
+#! /Users/damian/bin/rakudo'
+use v6;
+
+use IO::Prompter;
+
+prompt -> $name, Int $age, Bool $married {
+
+ report($name, $age, $married);
+}
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+sub report ($name, $age, $married) {
+ say " $name (aged $age) is{$married ?? '' !! "n\'t"} married";
+}
+
+
View
34 demo_IO_Prompter_promptloop_fancy.p6
@@ -0,0 +1,34 @@
+#! /Users/damian/bin/rakudo'
+use v6;
+
+use IO::Prompter;
+
+prompt -> $what's_your_name, Int $age, Bool :wed($married) {
+
+ report($what's_your_name, $age, $married);
+}
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+sub report ($name, $age, $married) {
+ say " $name (aged $age) is{$married ?? '' !! "n\'t"} married";
+}
+
View
14 demo_IO_Prompter_promptloop_gatherer.p6
@@ -0,0 +1,14 @@
+#! /Users/damian/bin/rakudo'
+use v6;
+
+use IO::Prompter;
+
+my @input = prompt -> $what's_your_name, Int $age, Bool :wed($married) {
+
+ take [$what's_your_name.uc, $age~'ish', $married ?? 'M' !! 'm'];
+}
+
+say "\n----------------";
+.perl.say for @input;
+
+
View
14 demo_IO_Prompter_promptloop_type_constraint.p6
@@ -0,0 +1,14 @@
+#! /Users/damian/bin/rakudo'
+use v6;
+
+use IO::Prompter;
+
+subset Coefficient of Num where 0..1;
+
+prompt -> Num $amount, Coefficient $rate, Int $term, Str $desc where /\S/ {
+
+ say "After $term year(s), $amount will be worth ",
+ $amount * (1+$rate)**$term;
+
+ say $desc;
+}
View
265 lib6/IO/Prompter.pm
@@ -0,0 +1,265 @@
+use v6;
+# [TODO: Currently only runs until Rakudo 2010/01 release]
+
+# prompt() returns objects of this type to separate value, truth, definedness
+# [TODO: Could probably replace this with 'does'ing an anonymous role]...
+class IO::Prompter::Result {
+ has $!input;
+ has $!failed;
+
+ method defined { $!input.defined }
+ method true { ! $!failed }
+ method Str { $!input }
+};
+
+module IO::Prompter;
+
+# Utility regexes...
+regex null { <before .?> } # [TODO: Remove when Rakudo implements this]
+regex sign { <[+\-]> }
+regex digits { \d+: }
+regex number { <sign>? <digits> [\.<digits>?]? [<[eE]><sign>?<digits>]? }
+regex integer { <sign>? <digits> }
+regex yes { :i ^ \h* [ y | yes ] }
+regex Yes { :i <-[y]> }
+regex yesno { :i [ y | yes | n | no ] }
+regex YesNo { [ Y | Yes | N | No ] }
+
+# Table of information for building prompters for various types...
+my %constraint =
+# Prompter Add to What to print on Use this to check that Conversion
+# type prompt invalid input input is valid function
+# ======== ====== ================ ====================== ==========
+ ::Int => [': ', 'a valid integer', /^ \h* <integer> \h* $/, *.Int ],
+ ::Num => [': ', 'a valid number', /^ \h* <number> \h* $/, +* ],
+ ::Bool => ['? ', '"yes" or "no"', /^ \h* <yesno> \h* $/, {?/<yes>/} ],
+ SemiBool => ['? ', '"yes" or "no"', /^ \h* \S+ \h* $/, {?/<yes>/} ],
+ CapSemiBool => ['? ', '"Yes" for yes', /^ \h* <Yes> \h* $/, {?/<yes>/} ],
+ CapFullBool => ['? ', '"Yes" or "No"', /^ \h* <YesNo> \h* $/, {?/<yes>/} ],
+ Any => [': ', 'anything', / <null> /, { $^self } ];
+
+# This sub ensures a value matches the specified set of constraints...
+sub invalid_input ($input, @constraints) {
+ for @constraints -> $constraint {
+ if $input !~~ $constraint.value {
+ return "(must {$constraint.key})";
+ }
+ }
+ return;
+}
+
+constant $NULL_DEFAULT = Mu;
+
+# This sub takes type info and provides a prompter that accepts only that type
+# [TODO: Prompters are stateless, so this sub should be 'is cached'
+# when that's available]...
+sub build_prompter_for (Mu $type, :$in = $*IN, :$out = $*OUT, *%build_opt) {
+
+ # Grab the correct info out of the table...
+ my ($punct, $description, $match, $extractor)
+ = %constraint{$type} // %constraint<Any>;
+
+ # Create single hash of input constraints...
+ my @input_constraints =
+ "be $description" => $match,
+ # [TODO: The next key should be something like:
+ # "be %build_opt<type_constraints>.perl()"
+ # if that ever returns something useful ]
+ "be an acceptable value" => %build_opt<type_constraints>.defined
+ ?? { $extractor($^input) ~~ %build_opt<type_constraints> } !! { 1 },
+ %build_opt<must>.pairs;
+
+ # Check that default supplied (via lower case option) is a valid response...
+ if %build_opt<default> !=:= $NULL_DEFAULT {
+ if invalid_input(%build_opt<default>, @input_constraints) -> $problem {
+ warn "prompt(): Cannot use default value {%build_opt<default>.perl} ",
+ $problem;
+ %build_opt.delete('default');
+ }
+ }
+
+ # Use it to build the requested prompter...
+ return sub ($prompt is copy, *%opt) {
+ # Add trailing punctuation, if requested to:
+ $prompt ~= $punct if %build_opt<autopunctuate>;
+
+ # Print the prompt if I/O is interactive...
+ $out.print($prompt) if ($in & $out).t;
+
+ # Prompt until we get something acceptable (or EOF)...
+ loop {
+ # Get what they typed and give up if it as EOF...
+ my $input = $in.get() // return;
+
+ # Insert the (post-checked) DEFAULT if they just hit <ENTER>...
+ $input = %build_opt<DEFAULT> // $input if $input eq "";
+
+ # Convert the input to the eventual return value...
+ my $retval = $extractor($input);
+
+ # Check if input satisified all constraints; if not, reprompt...
+ if invalid_input($input, @input_constraints) -> $problem {
+ $out.print("$prompt$problem ") if ($in & $out).t;
+ }
+ # Successfully read in an acceptable value, so return it...
+ else {
+ return $retval;
+ }
+ }
+ }
+}
+
+# Given a varname, convert it to a pretty prompt string...
+sub varname_to_prompt ($name) {
+ return $name.subst(/^<-alnum>+/, "").subst(/_/, " ", :g).ucfirst;
+}
+
+# This variant takes a block and loops, prompting for the block's parameters
+# then passing the values to the block until a prompt EOF's...
+multi sub prompt ( &block ) is export {
+ # These will eventually hold the arguments to be passed to the block...
+ my (%named, @positional);
+
+ # Flag to watch for EOF's in the middle of a prompt sequence...
+ my $eof;
+
+ # Build the necessary prompters for the block's parameters...
+ my @param_prompters = gather for &block.signature.params -> $param {
+
+ # Does this parameter have extra 'where'ish constraints?
+ my $type_constraints = $param.constraints;
+
+ # Build the appropriate prompter for this parameter...
+ my $prompter = build_prompter_for(
+ $param.type, :$type_constraints, :autopunctuate,
+ :default($NULL_DEFAULT), :must({})
+ );
+
+ # Build a closure that uses the prompter and saves the resulting value
+ # to the appropriate positional or named argument set...
+ if $param.named {
+ # Convert the named parameter's key to a nice promt string...
+ my $label = $param.named_names;
+ my $name = varname_to_prompt($label);
+
+ # Build the closure that prompts for the arg value and saves it
+ # [TODO: the lexical is only there to stop 2010/01 Rakudo barfing]
+ take my $handler
+ = { %named.push($label => $prompter($name) // $eof++) };
+ }
+ else {
+ # Convert the positional parameter's name to a nice prompt string...
+ my $name = varname_to_prompt($param.name);
+
+ # Build the closure that prompts for the arg value and saves it
+ # [TODO: the lexical is only there to stop 2010/01 Rakudo barfing]
+ take my $handler = { @positional.push($prompter($name) // $eof++) };
+ }
+ }
+
+ # Implement the prompt-and-execute-block loops...
+ gather loop {
+ # Clear your throat...
+ say "";
+
+ # Reset the block's arguments sets...
+ %named = @positional = ();
+
+ # Run the prompters to fill the argument sets...
+ for @param_prompters { $^prompter() unless $eof }
+
+ # Give up if the user EOF'd any of the input requests...
+ last if $eof;
+
+ # Otherwise, execute the block, passing the needed arguments...
+ block(|@positional, |%named);
+ }
+}
+
+constant $DEFAULT_PROMPT = '>';
+constant $ARGS_PROMPT = 'Enter command-line args:';
+constant $ENV_VARS = join "", map {"my \$$^NAME = %*ENV<$^NAME>;"}, %*ENV.keys;
+
+# This variant does the usual "single input" prompt-and-read behaviour
+# [TODO: Should provide short-forms too: :a(:argv) when Rakudo supports that]...
+multi sub prompt (
+ :$args of Bool,
+ :$default of Str = $NULL_DEFAULT,
+ :$DEFAULT of Str = $default,
+ :$fail of Bool = sub{False},
+
+ # [TODO: needs Term::ReadKey]
+ # :$guarantee of Hash = /<null>/,
+
+ :$in of IO = $*IN,
+ :$integer of Bool,
+
+ # [TODO: needs Term::ReadKey ]
+ # :$keyletters of Bool,
+
+ :$must of Hash = hash{},
+ :$number of Bool,
+ :$out of IO = $*OUT,
+ :$prompt of Str is copy,
+ :$wipe of Bool,
+ :$wipefirst of Bool,
+ :$yes of Bool,
+ :$yesno of Bool,
+ :$Yes of Bool,
+ :$YesNo of Bool,
+ *@prompt,
+) is export {
+ # If prompt not explicitly specified, use the strings provided, or else
+ # use a default prompt...
+ $prompt //= @prompt ?? @prompt.join
+ !! $args ?? $ARGS_PROMPT
+ !! $DEFAULT_PROMPT;
+
+ # Clean up the prompt, adding trailing punctuation, as required...
+ $prompt.=subst(/<after \w> $/, ": ");
+ $prompt.=subst(/<after \S> $/, " ");
+ $prompt.=subst(/\n$/,"");
+
+ # Determine the type of prompter to build
+ # [TODO: I really wish there were a cleaner way to do this!]...
+ my $prompter_type = $Yes ?? 'CapSemiBool'
+ !! $YesNo ?? 'CapFullBool'
+ !! $yes ?? 'SemiBool'
+ !! $yesno ?? Bool
+ !! $integer ?? Int
+ !! $number ?? Num
+ !! 'Any';
+
+ # Get the necessary prompter...
+ my $prompter = build_prompter_for($prompter_type, :$in, :$out,
+ :$must, :$default, :$DEFAULT
+ );
+
+ # Wipe first if necessary...
+ state $wiped;
+ print "\n" x 1000 if $wipe || ($wipefirst && !$wiped++);
+
+ # Use the necessary prompter...
+ my $input = $prompter($prompt, :$yes, :$Yes, :$yesno, :$YesNo);
+
+ if $args {
+ # [TODO: Should be: glob eval "$ENV_VARS; << $input >>" ]
+ @*ARGS = eval "$ENV_VARS; << $input >>";
+ return 1;
+ }
+
+ # Determine the success of the request...
+ my $failed = !$input.defined
+ || $yes|$Yes|$yesno|$YesNo && !$input
+ || $input ~~ $fail;
+
+ # Wrap up the result and return it...
+ # [NOTE: conscious decision not to offer :verbatim option
+ # (i.e. string-only return) because strings are objects too
+ return IO::Prompter::Result.new(:$input, :$failed);
+}
+
+# [TODO: Port docs from Perl 5 IO::Prompter module]
+#
+# [TODO: Implement scripted input from =begin PROMPTS/=end PROMPTS block
+# when Term::ReadKey available and $=POD works ]

0 comments on commit b7bd961

Please sign in to comment.
Something went wrong with that request. Please try again.