Merge pull request #365 from Troglodyne-Internet-Widgets/preferred-modules

Use the template's preferred modules, and read passwords with IO::Prompter

.perlcriticrc

@@ -72,7 +72,7 @@ warn_level = 40
 info_level = 30
 [Variables::ProhibitUselessInitialization]
 [PreferredModules]
-#config = .preferred_modules.ini
+config = .preferred_modules.ini
 [logicLAB::RequireSheBang]
 formats = #!/usr/bin/env perl
 # Performance
@@ -197,8 +197,8 @@ allow = re Exporter
 #stop_words_file = .pod_stopwords
 [Documentation::RequirePackageMatchesPodName]
 #[ErrorHandling::RequireCheckingReturnValueOfEval]
-#[InputOutput::ProhibitExplicitStdin]
-#[InputOutput::ProhibitInteractiveTest]
+[InputOutput::ProhibitExplicitStdin]
+[InputOutput::ProhibitInteractiveTest]
 [InputOutput::ProhibitJoinedReadline]
 [InputOutput::ProhibitOneArgSelect]
 [InputOutput::ProhibitReadlineInForLoop]
@@ -269,7 +269,7 @@ terminal_funcs = POSIX::_exit
 allow_unused_subroutine_arguments = 1
 # Anything that returns a guard, which does its work by being held to the end of
 # its scope: a mock, a mocked file, a change of directory, a lock.
-allow_if_computed_by = Test::MockModule->new Test::MockFile->file
+# allow_if_computed_by = Test::MockModule->new Test::MockFile->file
 [Variables::ProtectPrivateVars]
 [Variables::RequireLexicalLoopIterators]
 #[Variables::RequireLocalizedPunctuationVars]

.preferred_modules.ini

@@ -1,8 +1,12 @@
 [JSON]
+[JSON::PP]
+[JSON::XS]
 prefer = Cpanel::JSON::XS
 reason = "Use a correct & fast JSON parser"
 
 [YAML]
+[YAML::PP]
+[YAML::Syck]
 prefer = YAML::XS
 reason = "Use a correct & fast YAML parser"
 
@@ -16,10 +20,37 @@ prefer = File::Slurper::Temp
 for = write_binary write_text
 reason = "Avoid mangling files with concurrent writes"
 
+[constant]
+prefer = Readonly
+reason = "A Readonly variable interpolates, has a sigil to find it by, and refuses an assignment at run time"
+
 [perl/rand]
 prefer = Crypt::PRNG
 reason = builtin rand() insecure
 
+[perl/sleep]
+prefer = Time::HiRes
+reason = "The builtin sleeps whole seconds, so a poll interval cannot be shorter than a second"
+
+; tCMS: no [perl/time].  Its times are stored whole-second timestamps, such as
+; a post's created, and not intervals, and the tests set the clock through
+; CORE::GLOBAL::time, which Time::HiRes::time does not use.
+
+[perl/alarm]
+prefer = Time::HiRes
+reason = "The builtin takes whole seconds, so it cannot time out sooner than a second"
+
+[perl/readdir]
+reason="Use File::Find::find() instead"
+
+[Term::ReadKey]
+[IO::Prompt]
+[IO::Prompt::Tiny]
+[Term::Prompt]
+[Prompt::Timeout]
+prefer = IO::Prompter
+reason = "One way to ask for input; it suppresses echo and copes with not having a terminal"
+
 [MIME::Base32::XS]
 [Encode::Base2N]
 prefer = MIME::Base32

Makefile.PL

@@ -112,6 +112,7 @@ WriteMakefile(
         'HTTP::Body'                          => '0',
         'IO::String'                          => '0',
         'IO::Compress::Gzip'                  => '0',
+        'IO::Prompter'                        => '0',
         'Imager'                              => '0',
         'Imager::File::ICO'                   => '0',
         'Imager::File::PNG'                   => '0',

bin/tcms-useradd

@@ -9,6 +9,7 @@ use warnings FATAL => 'all';
 use FindBin::libs;
 use Getopt::Long;
 use Pod::Usage;
+use IO::Prompter();
 use List::Util qw{first};
 
 use Trog::Auth;
@@ -90,23 +91,11 @@ my sub init_logs {
 
 # Read a password off the terminal without echoing it, so it stays out of the
 # shell history and off the screen.  Falls back to a plain read when we aren't
-# on a TTY, which is what makes `echo hunter2 | tcms-useradd ...` work.
-my sub read_password {
-    my ($prompt) = @_;
-    my $password;
-    if ( -t STDIN ) {
-        print STDERR $prompt;
-        require Term::ReadKey;
-        Term::ReadKey::ReadMode('noecho');
-        $password = <STDIN>;
-        Term::ReadKey::ReadMode('restore');
-        print STDERR "\n";
-    }
-    else {
-        $password = <STDIN>;
-    }
-    chomp $password if defined $password;
-    return $password;
+# on a TTY, which is what makes `echo hunter2 | tcms-useradd ...` work.  Returns
+# undef only at the end of the input, and q{} for an empty line.
+my sub read_password ($prompt) {
+    my $password = IO::Prompter::prompt( $prompt, -echo => q{}, -in => *STDIN, -out => *STDERR );
+    return $password ? "$password" : undef;
 }
 
 # What a brand new user's profile post looks like before we merge anything over
@@ -147,7 +136,6 @@ sub main {
     # --password with no value means "ask me", as opposed to leaving the option
     # out entirely, which means "leave the password alone".
     if ( defined $options{password} && !$options{password} ) {
-        my $interactive = -t STDIN;
         $options{password} = read_password("New password for '$options{user}': ");
 
         unless ( $options{password} ) {
@@ -155,14 +143,13 @@ sub main {
             return 2;
         }
 
-        # Only worth confirming when a human is typing it.  Piped input has no
-        # second line to read, and typos in a script aren't fixed by asking twice.
-        if ($interactive) {
-            my $again = read_password("Confirm: ");
-            unless ( defined $again && $options{password} eq $again ) {
-                print STDERR "Passwords did not match.\n";
-                return 2;
-            }
+        # A person at a terminal always enters a line, even an empty one, so
+        # they always confirm.  Piped input with one line has no second line,
+        # and there is nothing to confirm against.
+        my $again = read_password("Confirm: ");
+        if ( defined $again && $options{password} ne $again ) {
+            print STDERR "Passwords did not match.\n";
+            return 2;
         }
     }
 

bin/tcmslogin

@@ -9,6 +9,7 @@ use warnings FATAL => 'all';
 use FindBin::libs;
 use Getopt::Long;
 use Pod::Usage;
+use IO::Prompter();
 
 use Trog::Auth;
 use Trog::Log;
@@ -77,22 +78,9 @@ my sub init_logs {
     return;
 }
 
-my sub read_password {
-    my ($prompt) = @_;
-    my $password;
-    if ( -t STDIN ) {
-        print STDERR $prompt;
-        require Term::ReadKey;
-        Term::ReadKey::ReadMode('noecho');
-        $password = <STDIN>;
-        Term::ReadKey::ReadMode('restore');
-        print STDERR "\n";
-    }
-    else {
-        $password = <STDIN>;
-    }
-    chomp $password if defined $password;
-    return $password;
+my sub read_password ($prompt) {
+    my $password = IO::Prompter::prompt( $prompt, -echo => q{}, -in => *STDIN, -out => *STDERR );
+    return $password ? "$password" : undef;
 }
 
 sub main {

lib/Trog/Data.pm

@@ -5,6 +5,7 @@ use re '/aasx';
 use warnings FATAL => 'all';
 
 use Module::Runtime();
+use Path::Tiny();
 
 use Trog::Log qw{:all};
 
@@ -60,10 +61,9 @@ sub model ($config) {
     my $sqlite_db = $Trog::Data::SQLite::dbname;
     return $model if -e $sqlite_db;
 
-    opendir( my $dh, $flatfile_store ) or return $model;
-    my $posts = grep { -f "$flatfile_store/$_" } readdir $dh;    ## no critic (ProhibitFiletest_f) -- counting names, nothing is opened
-    closedir $dh;
-    return $model unless $posts;
+    my $posts = eval {
+        scalar grep { -f } Path::Tiny::path($flatfile_store)->children;
+    } or return $model;    ## no critic (ProhibitFiletest_f) -- counting names, nothing is opened
 
     WARN("general.data_model is SQLite, but $sqlite_db does not exist and $flatfile_store holds $posts post(s).  Serving them from FlatFile.  Run bin/migrate.pl to move them across.");
     return 'FlatFile';

lib/Trog/Data/FlatFile.pm

@@ -8,6 +8,7 @@ use Carp           qw{confess};
 use Fcntl          qw{LOCK_EX};
 use File::Basename ();
 use File::Path     ();
+use Path::Tiny     ();
 use JSON::MaybeXS;
 use File::Slurper;
 use File::Slurper::Temp();
@@ -38,9 +39,7 @@ our %posts_by_tag;
 
 my sub _index {
     confess "Can't find datastore in $datastore !" unless -d $datastore;
-    opendir( my $dh, $datastore ) or confess;
-    my @index = grep { -f } map { "$datastore/$_" } readdir $dh;    ## no critic (ProhibitFiletest_f) -- listing names, nothing is opened
-    closedir $dh;
+    my @index  = map  { "$_" } grep { -f } Path::Tiny::path($datastore)->children;    ## no critic (ProhibitFiletest_f) -- listing names, nothing is opened
     my @sorted = sort { $b cmp $a } @index;
     return @sorted;
 }

lib/Trog/DataSource.pm

@@ -27,13 +27,13 @@ than methods, and named by a post type's sidecar in x-tcms-datasource.
 The children of $series, as post hashrefs.  Enough of a post to survive being
 rendered like one -- see Trog::DataSource::Virt::post_for for the shape.
 
-    EDITABLE                              optional constant
+    EDITABLE                              optional method
 
 Whether the wizard should generate an editor for a type drawn from this source.
-A source which builds its posts from somewhere else has nothing to edit, and
-saying nothing means no.
+A source which builds its posts from somewhere else has nothing to edit, so it
+returns false.  Saying nothing means yes.
 
-    CACHEABLE                             optional constant
+    CACHEABLE                             optional method
 
 Whether a page drawn from this source may be saved as a static render.  Saying
 nothing means no -- see cacheable() for why that is the safe way round.
@@ -202,9 +202,9 @@ example) and declare CACHEABLE.  Or it doesn't, in which case its pages must not
 be cached at all, because the cached copy has no way of ever becoming right
 again.
 
-Absent means not cacheable, which is the same way round as EDITABLE: a source
-whose author has not thought about invalidation gets the answer that is merely
-slow rather than the one that is wrong.
+Absent means not cacheable.  A source whose author has not thought about
+invalidation gets the answer that is merely slow rather than the one that is
+wrong.
 
 =cut
 

lib/Trog/DataSource/DirIndex.pm

@@ -6,6 +6,7 @@ use warnings FATAL => 'all';
 
 use Cwd         ();
 use Digest::SHA qw{sha256_hex};
+use Path::Tiny  ();
 use URI::Escape ();
 
 use Trog::DataSource ();
@@ -38,7 +39,7 @@ collide with, the synthesized ones.  Put files in the directory instead.
 
 =cut
 
-use constant EDITABLE => 0;
+sub EDITABLE { return 0 }
 
 =head2 CACHEABLE
 
@@ -52,7 +53,7 @@ way of ever becoming right again.
 
 =cut
 
-use constant CACHEABLE => 1;
+sub CACHEABLE { return 1 }
 
 =head1 WHAT MAY BE INDEXED
 
@@ -272,12 +273,14 @@ sub posts ( $series, $query ) {
 
     watch( $query, $dir->{relative} );
 
-    opendir( my $dh, $dir->{absolute} ) or do {
-        WARN("Could not read $dir->{relative}: $!");
+    my @entries;
+    eval {
+        @entries = map { $_->basename } Path::Tiny::path( $dir->{absolute} )->children(qr/\A[^.]/);
+        1;
+    } or do {
+        WARN("Could not read $dir->{relative}: $@");
         return ();
     };
-    my @entries = grep { $_ ne '.' && $_ ne '..' && index( $_, '.' ) != 0 } readdir($dh);
-    closedir($dh);
 
     my @out;
     foreach my $entry ( sort @entries ) {

lib/Trog/DataSource/Virt.pm

@@ -36,7 +36,7 @@ would then sit alongside, and collide with, the synthesized ones.
 
 =cut
 
-use constant EDITABLE => 0;
+sub EDITABLE { return 0 }
 
 =head2 CACHEABLE
 
@@ -51,7 +51,7 @@ right again.
 
 =cut
 
-use constant CACHEABLE => 0;
+sub CACHEABLE { return 0 }
 
 =head2 A NOTE ON SAFETY
 

lib/Trog/Routes/HTML.pm

@@ -7,7 +7,6 @@ use warnings FATAL => 'all';
 no warnings qw{once};
 
 use POSIX qw{strftime};
-use Errno qw{ENOENT};
 use File::Touch();
 use File::Basename qw{basename};
 use List::Util();
@@ -825,10 +824,8 @@ sub logout ($query) {
 
 my sub get_themes {
     my $dir = 'www/themes';
-    opendir( my $dh, $dir ) || do { die "Can't opendir $dir: $!" unless $!{ENOENT} };
-    my @tdirs = grep { !/^\./ && -d "$dir/$_" } readdir($dh);
-    closedir $dh;
-    return \@tdirs;
+    return [] unless -e $dir;
+    return [ map { $_->basename } grep { $_->is_dir } Path::Tiny::path($dir)->children(qr/\A[^.]/) ];
 }
 
 =head2 config
@@ -868,10 +865,7 @@ my sub get_data_models {
     foreach my $incdir (@INC) {
         my $dir = "$incdir/Trog/Data";
         next unless -d $dir;
-        opendir( my $dh, $dir ) || die "Can't opendir $dir: $!";
-        my @dmods = map { s/\.pm$//r } grep { /\.pm$/ && -f "$dir/$_" } readdir($dh);    ## no critic (ProhibitFiletest_f) -- building a menu of module names
-        closedir $dh;
-        return \@dmods;
+        return [ map { $_->basename('.pm') } grep { -f } Path::Tiny::path($dir)->children(qr/[.]pm\z/) ];    ## no critic (ProhibitFiletest_f) -- building a menu of module names
     }
     die "Could not find tCMS data modules!  Is tCMS in \@INC?";
 }
@@ -1122,9 +1116,10 @@ sub get_datasources {
     foreach my $incdir (@INC) {
         my $dir = "$incdir/Trog/DataSource";
         next unless -d $dir;
-        opendir( my $dh, $dir ) or next;
-        $found{"Trog::DataSource::$_"} = 1 foreach map { s/\.pm$//r } grep { /\.pm$/ && -f "$dir/$_" } readdir($dh);    ## no critic (ProhibitFiletest_f) -- building an allowlist of names
-        closedir $dh;
+        my @modules = eval {
+            grep { -f } Path::Tiny::path($dir)->children(qr/[.]pm\z/);
+        } or next;    ## no critic (ProhibitFiletest_f) -- building an allowlist of names
+        $found{ "Trog::DataSource::" . $_->basename('.pm') } = 1 foreach @modules;
     }
     return [ sort keys(%found) ];
 }
@@ -1133,7 +1128,7 @@ sub get_datasources {
 
 Whether a post type backed by $module should be given an editor.
 
-A datasource says so with an EDITABLE constant.  One that does not say is
+A datasource says so with an EDITABLE method.  One that does not say is
 assumed editable, since that is what a post type is unless it has a reason not
 to be.
 

lib/Trog/Themes.pm

@@ -5,6 +5,7 @@ use re '/aasx';
 use warnings FATAL => 'all';
 
 use FindBin::libs;
+use Path::Tiny();
 
 use Trog::Vars;
 use Trog::Config;
@@ -205,14 +206,11 @@ sub forms_dir {
 }
 
 my sub read_dir ( $dir, $ext ) {
-    my $files = [];
-    return $files unless -d $dir;
-    opendir( my $dh, $dir ) or return $files;
-    while ( my $file = readdir($dh) ) {
-        push( @$files, $file ) if -f "$dir/$file" && $file =~ m/\.\Q$ext\E$/;    ## no critic (ProhibitFiletest_f) -- listing names, nothing is opened
-    }
-    closedir($dh);
-    return $files;
+    return [] unless -d $dir;
+    my @files = eval {
+        grep { -f } Path::Tiny::path($dir)->children(qr/[.]\Q$ext\E\z/);
+    };    ## no critic (ProhibitFiletest_f) -- listing names, nothing is opened
+    return [ map { $_->basename } @files ];
 }
 
 =head2 files_in_dir($path, $content_type, $is_component, $ext)

t/Trog-DataSource.t

@@ -234,8 +234,8 @@ BEGIN {
 
     # One which can say when its posts go stale, and so may be cached.
     package Trog::DataSource::TestCached;
-    use constant CACHEABLE => 1;
-    sub posts { return ( main::guest('cached') ) }
+    sub CACHEABLE { return 1 }
+    sub posts     { return ( main::guest('cached') ) }
 
     # One with opinions, including its own search language.
     package Trog::DataSource::TestPicky;

t/bin-migrate.t

@@ -15,6 +15,7 @@ use FindBin::libs;
 use Test::More;
 use Test::MockModule qw{strict};
 use IPC::Run3();
+use Path::Tiny();
 
 our ( $REPO, $ROOT, $OLDCWD );
 
@@ -193,9 +194,7 @@ subtest 'picking up what was written in between' => sub {
 };
 
 subtest 'the flat files are left alone' => sub {
-    opendir( my $dh, 'data/files' ) or die $!;
-    my @files = grep { !m/^\.\.?$/ } readdir($dh);
-    closedir $dh;
+    my @files = Path::Tiny::path('data/files')->children;
 
     is( scalar(@files), 5, 'every post still has its file' );
     ok( -f 'data/posts.db', "and the flat file model's own index is untouched" );

t/bin-tcms-useradd.t

@@ -0,0 +1,70 @@
+#!/usr/bin/env perl
+
+# bin/tcms-useradd reads a password from its input when --password has no
+# value.  What matters is what it does with that input when it is piped, which
+# is how a script sets a password, so this runs it the way a script would.
+
+use 5.040;
+use re '/aasx';
+use warnings FATAL => 'all';
+
+use FindBin;
+use FindBin::libs;
+
+use Test::More;
+use IPC::Run3();
+
+our ( $REPO, $ROOT, $OLDCWD );
+
+BEGIN {
+    require Cwd;
+    require File::Copy;
+    require File::Path;
+    require File::Temp;
+
+    $REPO   = Cwd::abs_path("$FindBin::Bin/..");
+    $OLDCWD = Cwd::getcwd();
+    $ROOT   = File::Temp::tempdir( 'tcms-useradd-XXXXXX', TMPDIR => 1, CLEANUP => 1 );
+
+    $ENV{HOME} = $ROOT;
+    File::Path::make_path("$ROOT/$_") for qw{config schema data/files logs totp www/themes};
+    File::Copy::copy( "$REPO/schema/$_", "$ROOT/schema/$_" ) or die $! for qw{auth.schema flatfile.schema log.schema sqlite.schema};
+    File::Copy::copy( "$REPO/config/default.cfg", "$ROOT/config/default.cfg" ) or die $!;
+
+    chdir($ROOT) or die "could not chdir to the sandbox: $!";
+}
+
+END {
+    chdir($OLDCWD) if $OLDCWD;
+}
+
+require_ok('Trog::Auth') or BAIL_OUT("Can't find what checks the password");
+
+# The user, with this on its input, and what it printed last.
+sub useradd ( $user, $input ) {
+    my $out = q{};
+    IPC::Run3::run3( [ $^X, "-I$REPO/lib", "$REPO/bin/tcms-useradd", '--user', $user, '--password', '--display_name', "Spec $user", '--contact_email', "$user\@test.test" ], \$input, \$out, \$out );
+    my @lines = split /\n/, $out;
+    return ( $? >> 8, $lines[-1] // q{} );
+}
+
+subtest 'a password piped in' => sub {
+    my ( $code, $said ) = useradd( 'one', "pw-one\n" );
+    is( $code, 0, 'one line is a password' ) or diag($said);
+    ok( Trog::Auth::check_password( 'one', 'pw-one' ), 'and it is the one that was set' );
+
+    ( $code, $said ) = useradd( 'two', "pw-two\npw-two\n" );
+    is( $code, 0, 'a second line that matches confirms it' ) or diag($said);
+    ok( Trog::Auth::check_password( 'two', 'pw-two' ), 'and it is set' );
+
+    ( $code, $said ) = useradd( 'three', "pw-three\npw-other\n" );
+    is( $code, 2,                          'a second line that does not match is refused' );
+    is( $said, 'Passwords did not match.', 'and says so' );
+    ok( !Trog::Auth::check_password( 'three', 'pw-three' ), 'and sets nothing' );
+
+    ( $code, $said ) = useradd( 'four', q{} );
+    is( $code, 2,                       'no input at all is refused' );
+    is( $said, 'No password provided.', 'and says so' );
+};
+
+done_testing();