add support for commands without module files

mojolicious · Jun 16, 2015 · 9d69906 · 9d69906
1 parent abc0037
commit 9d69906
Show file tree

Hide file tree

Showing 6 changed files with 57 additions and 22 deletions.
diff --git a/Changes b/Changes
@@ -1,7 +1,8 @@
 
-6.12  2015-06-14
+6.12  2015-06-16
   - Welcome to the Mojolicious core team Dan Book.
   - Added TO_JSON method to Mojo::Collection. (wttw)
+  - Added find_packages function to Mojo::Loader.
   - Fixed bug in Mojo::Message where multipart content would get downgraded
     unnecessarily.
 

diff --git a/lib/Mojo/Loader.pm b/lib/Mojo/Loader.pm
@@ -7,7 +7,8 @@ use File::Spec::Functions qw(catdir catfile splitdir);
 use Mojo::Exception;
 use Mojo::Util qw(b64_decode class_to_path);
 
-our @EXPORT_OK = qw(data_section file_is_binary find_modules load_class);
+our @EXPORT_OK
+  = qw(data_section file_is_binary find_modules find_packages load_class);
 
 my (%BIN, %CACHE);
 
@@ -33,6 +34,12 @@ sub find_modules {
   return sort keys %modules;
 }
 
+sub find_packages {
+  my $ns = shift;
+  no strict 'refs';
+  return sort map { $_ =~ /^(.+)::$/ ? ("${ns}::$1") : () } keys %{"${ns}::"};
+}
+
 sub load_class {
   my $class = shift;
 
@@ -148,6 +155,12 @@ cached once they have been accessed for the first time.
 
 Check if embedded file from the C<DATA> section of a class was Base64 encoded.
 
+=head2 find_packages
+
+  my @pkgs = find_packages 'MyApp::Namespace';
+
+Search for packages in a namespace non-recursively.
+
 =head2 find_modules
 
   my @modules = find_modules 'MyApp::Namespace';

diff --git a/lib/Mojolicious/Commands.pm b/lib/Mojolicious/Commands.pm
@@ -2,7 +2,7 @@ package Mojolicious::Commands;
 use Mojo::Base 'Mojolicious::Command';
 
 use Getopt::Long 'GetOptionsFromArray';
-use Mojo::Loader qw(find_modules load_class);
+use Mojo::Loader qw(find_modules find_packages load_class);
 use Mojo::Server;
 use Mojo::Util 'tablify';
 
@@ -62,7 +62,7 @@ sub run {
   my %all;
   for my $ns (@{$self->namespaces}) {
     $all{substr $_, length "${ns}::"} //= $_->new->description
-      for grep { _command($_) } find_modules $ns;
+      for grep { _command($_) } find_modules($ns), find_packages($ns);
   }
 
   my @rows = map { [" $_", $all{$_}] } sort keys %all;

diff --git a/t/mojo/loader.t b/t/mojo/loader.t
@@ -7,7 +7,14 @@ use Test::More;
 use FindBin;
 use lib "$FindBin::Bin/lib";
 
-use Mojo::Loader qw(data_section file_is_binary find_modules load_class);
+use Mojo::Loader
+  qw(data_section file_is_binary find_packages find_modules load_class);
+
+package MyLoaderTest::Foo::Bar;
+
+package MyLoaderTest::Foo::Baz;
+
+package main;
 
 # Single character core module
 ok !load_class('B'), 'loaded';
@@ -49,7 +56,7 @@ is $e->lines_after->[1][0], 6,    'right number';
 is $e->lines_after->[1][1], '1;', 'right line';
 like "$e", qr/Exception/, 'right message';
 
-# Search
+# Search modules
 my @modules = find_modules 'Mojo::LoaderTest';
 is_deeply \@modules,
   [qw(Mojo::LoaderTest::A Mojo::LoaderTest::B Mojo::LoaderTest::C)],
@@ -58,6 +65,11 @@ is_deeply [find_modules "Mojo'LoaderTest"],
   [qw(Mojo'LoaderTest::A Mojo'LoaderTest::B Mojo'LoaderTest::C)],
   'found the right modules';
 
+# Search packages
+my @pkgs = find_packages 'MyLoaderTest::Foo';
+is_deeply \@pkgs, ['MyLoaderTest::Foo::Bar', 'MyLoaderTest::Foo::Baz'],
+  'found the right packages';
+
 # Load
 ok !load_class("Mojo'LoaderTest::A"), 'loaded successfully';
 ok !!Mojo::LoaderTest::A->can('new'), 'loaded successfully';

diff --git a/t/mojo/user_agent_online.t b/t/mojo/user_agent_online.t
@@ -163,23 +163,23 @@ is $tx->req->url,    'http://google.com', 'right url';
 is $tx->res->code,   302,                 'right status';
 
 # Simple keep-alive requests
-$tx = $ua->get('http://www.wikipedia.org');
-is $tx->req->method, 'GET',                      'right method';
-is $tx->req->url,    'http://www.wikipedia.org', 'right url';
-is $tx->req->body,   '',                         'no content';
-is $tx->res->code,   200,                        'right status';
+$tx = $ua->get('https://www.wikipedia.org');
+is $tx->req->method, 'GET',                       'right method';
+is $tx->req->url,    'https://www.wikipedia.org', 'right url';
+is $tx->req->body,   '',                          'no content';
+is $tx->res->code,   200,                         'right status';
 ok $tx->keep_alive, 'connection will be kept alive';
 ok !$tx->kept_alive, 'connection was not kept alive';
-$tx = $ua->get('http://www.wikipedia.org');
-is $tx->req->method, 'GET',                      'right method';
-is $tx->req->url,    'http://www.wikipedia.org', 'right url';
-is $tx->res->code,   200,                        'right status';
+$tx = $ua->get('https://www.wikipedia.org');
+is $tx->req->method, 'GET',                       'right method';
+is $tx->req->url,    'https://www.wikipedia.org', 'right url';
+is $tx->res->code,   200,                         'right status';
 ok $tx->keep_alive, 'connection will be kept alive';
 ok $tx->kept_alive, 'connection was kept alive';
-$tx = $ua->get('http://www.wikipedia.org');
-is $tx->req->method, 'GET',                      'right method';
-is $tx->req->url,    'http://www.wikipedia.org', 'right url';
-is $tx->res->code,   200,                        'right status';
+$tx = $ua->get('https://www.wikipedia.org');
+is $tx->req->method, 'GET',                       'right method';
+is $tx->req->url,    'https://www.wikipedia.org', 'right url';
+is $tx->res->code,   200,                         'right status';
 ok $tx->keep_alive, 'connection will be kept alive';
 ok $tx->kept_alive, 'connection was kept alive';
 
@@ -244,10 +244,10 @@ is $tx->req->method, 'GET',                                'right method';
 is $tx->req->url,    'https://en.wikipedia.org/wiki/Perl', 'right url';
 is $tx->res->code,   200,                                  'right status';
 is $tx->previous->req->method, 'GET', 'right method';
-is $tx->previous->req->url, 'http://en.wikipedia.org/wiki/Perl', 'right url';
+is $tx->previous->req->url, 'https://www.wikipedia.org/wiki/Perl', 'right url';
 is $tx->previous->res->code, 301, 'right status';
 is $tx->redirects->[-1]->req->method, 'GET', 'right method';
-is $tx->redirects->[-1]->req->url, 'http://en.wikipedia.org/wiki/Perl',
+is $tx->redirects->[-1]->req->url, 'https://www.wikipedia.org/wiki/Perl',
   'right url';
 is $tx->redirects->[-1]->res->code, 301, 'right status';
 

diff --git a/t/mojolicious/commands.t b/t/mojolicious/commands.t
@@ -13,6 +13,13 @@ use lib "$FindBin::Bin/lib";
 use Cwd 'cwd';
 use File::Temp 'tempdir';
 
+package Mojolicious::Command::my_fake_test_command;
+
+package Mojolicious::Command::my_test_command;
+use Mojo::Base 'Mojolicious::Command';
+
+package main;
+
 # Make sure @ARGV is not changed
 {
   local $ENV{MOJO_MODE};
@@ -97,8 +104,10 @@ my $buffer = '';
   local $ENV{HARNESS_ACTIVE} = 0;
   $commands->run;
 }
-like $buffer, qr/Usage: APPLICATION COMMAND \[OPTIONS\].*daemon.*version/s,
+like $buffer,
+  qr/Usage: APPLICATION COMMAND \[OPTIONS\].*daemon.*my_test_command.*version/s,
   'right output';
+unlike $buffer, qr/my_fake_test_command/, 'fake command has been ignored';
 
 # help
 $buffer = '';