aboutsummaryrefslogtreecommitdiffstats
path: root/lib/Fripost/Prompt.pm
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Fripost/Prompt.pm')
-rwxr-xr-xlib/Fripost/Prompt.pm106
1 files changed, 88 insertions, 18 deletions
diff --git a/lib/Fripost/Prompt.pm b/lib/Fripost/Prompt.pm
index 0edc22f..fbd39e6 100755
--- a/lib/Fripost/Prompt.pm
+++ b/lib/Fripost/Prompt.pm
@@ -1,7 +1,9 @@
package Fripost::Prompt;
use 5.010_000;
+use warnings;
use strict;
+use utf8;
=head1 NAME
@@ -17,21 +19,22 @@ use Exporter;
use IO::Prompter;
use Fripost::Password qw/mkpasswd/;
-our @EXPORT = qw(confirm confirm_or_abort fix_username prompt_email prompt_password);
+our @EXPORT = qw(confirm confirm_or_abort fix_username
+ prompt_password prompt_if_undefined);
our @ISA = qw(Exporter);
sub confirm {
my ($msg) = @_;
- $msg //= "Is this OK? [no will abort] ";
- return prompt -in => \*STDIN, -out => \*STDOUT, $msg, -yn;
+ $msg //= "Is this OK? ";
+ return prompt -in => \*STDIN, -out => \*STDOUT, -yn, $msg;
}
sub confirm_or_abort {
my ($msg) = @_;
$msg //= "Is this OK? [no will abort] ";
- my $confirmed = prompt -in => \*STDIN, -out => \*STDOUT, $msg, -yn;
+ my $confirmed = prompt -in => \*STDIN, -out => \*STDOUT, -yn, $msg;
unless ($confirmed) {
- say "User aborted";
+ say "Aborted";
exit 1;
}
}
@@ -45,24 +48,87 @@ sub fix_username {
return $nam;
}
-sub prompt_email {
- my ($msg, $is_username) = @_;
- $msg //= "Enter email: ";
- my $email;
- do {
- $email = prompt -in => \*STDIN, -out => \*STDOUT, $msg;
- if ($is_username) {
- $email = fix_username($email);
+# Prompt (with the given prompt message) only if $value is an undefined
+# scalar, or an empty array reference.
+# Constraints may be added on the value, as a array reference where the
+# even indexes correspond to constraint names, and the odd ones are the
+# code that is to be executed. Constraints are checked in the order they
+# are defined (that is why $must is an array reference, not a hash
+# reference). If the *first* constraint name is 'rewrite', it is used to
+# rewrite each value prior to the constraint check.
+#
+# If 'value' is an empty array reference, the prompted value is
+# interpreted as a comma/space separated list of values.
+#
+sub prompt_if_undefined {
+ my ($msg, $value, $must) = @_;
+ my $many = ref $value eq 'ARRAY';
+
+ my $rewrite;
+ if (defined $must and $#$must >= 1 and $must->[0] eq 'rewrite') {
+ shift $must;
+ $rewrite = shift $must;
+ }
+ else {
+ $rewrite //= sub { $_ };
+ }
+
+ if ((not $many and defined $$value) or ($many and @$value)) {
+ if ($many) {
+ for (my $i = 0; $i <= $#$value; $i++) {
+ $value->[$i] = eval { local $_ = $value->[$i];
+ $rewrite->($value->[$i]) };
+ &check_all ($value->[$i], $must, 1);
+ }
+ }
+ else {
+ $$value = eval { $_ = $$value; $rewrite->($$value) };
+ &check_all ($$value, $must, 1);
}
+ }
+ else {
+ my $v;
+ do {
+ $v = prompt -in => \*STDIN, -out => \*STDOUT, $msg;
+ my $vs = $many ? [ map {&$rewrite} (split / *, *| +/, $v) ]
+ : eval { local $_ = $v; $rewrite->($v) };
+ $v = $vs;
+ foreach ($many ? @$vs : ($vs)) {
+ undef $v unless &check_all ($_, $must);
+ }
+ }
+ until (defined $v);
- unless (Email::Valid->address($email)) {
- undef $email;
- say "Error: This is not a valid e-mail address. Try again."
+ if ($many) {
+ map { push @$value, $_ } @$v;
+ }
+ else {
+ $$value = $v;
}
}
- until (defined $email);
- return $email;
+}
+
+# Check every constraint in $must for the given $value.
+# If a constraint is not verified (returns a null value), die if $croak
+# is true, and return 0 otherwise.
+# Return 1 if all constraints are verified.
+sub check_all {
+ my ($value, $must, $croak) = @_;
+ return 1 unless defined $must;
+
+ my @constraints = @$must;
+ while (@constraints) {
+ my $msg = shift @constraints;
+ my $constraint = shift @constraints;
+ unless (eval { local $_ = $value; $value ~~ $constraint}) {
+ print STDERR "Error: `" . $value . "': " . $msg . ".";
+ die "\n" if $croak;
+ say STDERR ' Try again.';
+ return 0;
+ }
+ }
+ return 1;
}
sub prompt_password {
@@ -100,10 +166,14 @@ sub prompt_password {
Stefan Kangas C<< <skangas at skangas.se> >>
+Guilhem Moulin C<< <guilhem at fripost.org> >>
+
=head1 COPYRIGHT
Copyright 2010,2011 Stefan Kangas.
+Copyright 2012 Guilhem Moulin.
+
=head1 LICENSE
This program is free software; you can redistribute it and/or modify it