From 9508574dcb8c37ff1cb8211e2fe845b2703d9141 Mon Sep 17 00:00:00 2001
From: Guilhem Moulin <guilhem.moulin@fripost.org>
Date: Sun, 10 Jun 2012 15:38:56 +0200
Subject: A more modular prompt.

---
 lib/Fripost/Prompt.pm | 106 +++++++++++++++++++++++++++++++++++++++++---------
 1 file changed, 88 insertions(+), 18 deletions(-)

(limited to 'lib/Fripost/Prompt.pm')

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
-- 
cgit v1.2.3