package Fripost::Prompt; use 5.010_000; use warnings; use strict; use utf8; =head1 NAME Prompt.pm - Lots of prompt helper functions =cut our $VERSION = '0.01'; use Data::Dumper; use Email::Valid; use Exporter; use IO::Prompter; use Fripost::Password qw/mkpasswd/; 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? "; 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, -yn, $msg; unless ($confirmed) { say "Aborted"; exit 1; } } sub fix_username { my ($nam) = @_; if (defined $nam && $nam !~ /\@/) { $nam .= '@fripost.org'; say "Using $nam"; } return $nam; } # 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); if ($many) { map { push @$value, $_ } @$v; } else { $$value = $v; } } } # 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 { my ($msg, $msg2) = @_; $msg //= "Enter new password (blank for random): "; $msg2 //= "Enter new password again (blank for random): "; my $password; do { $password = prompt -in => \*STDIN, -out => \*STDOUT, $msg, -echo => '*'; if ($password ne '' and length $password < 12) { undef $password; say STDERR "Error: Passwords have to be at least 12 characters long."; } else { my $confirm = prompt -in => \*STDIN, -out => \*STDOUT, $msg2, -echo => '*'; unless ($password eq $confirm) { undef $password; say STDERR "Error: Passwords do not match"; } } } until (defined $password); if ($password eq '') { $password = mkpasswd(); say "Using password: $password"; } return $password; } =head1 AUTHOR Stefan Kangas C<< >> Guilhem Moulin C<< >> =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 under the same terms as perl itself. =cut 1; # End of Prompt.pm