├── log └── .gitkeep ├── t ├── log │ └── keep ├── conf │ ├── disable │ │ ├── test2.pl │ │ └── config.pl │ ├── b │ │ ├── test.pl │ │ └── config.pl │ ├── c │ │ └── test.pl │ ├── process_mode │ │ ├── b.pl │ │ └── a.pl │ ├── g │ │ └── config.pl │ ├── a │ │ └── config.pl │ ├── null │ │ └── config.pl │ ├── e │ │ └── config.pl │ ├── f │ │ └── config.pl │ ├── error │ │ └── test.pl │ ├── deployment_no_templates │ │ └── config.pl │ ├── encoders │ │ └── test.pl │ └── stack_trace_enabled │ │ └── test.pl ├── views │ ├── 0.tt │ ├── home.tt │ └── error │ │ ├── 404.tt │ │ ├── 500.tt │ │ └── 700.tt ├── test.psgi ├── lib │ ├── MyApp │ │ ├── Request.pm │ │ ├── Routes.pm │ │ ├── Routes2.pm │ │ ├── Response.pm │ │ └── Module │ │ │ └── Null.pm │ ├── UtilPackage.pm │ ├── Kelp │ │ └── Module │ │ │ ├── Config │ │ │ └── Injected.pm │ │ │ ├── Plus.pm │ │ │ └── Template │ │ │ └── Ducks.pm │ ├── StringifyingException.pm │ ├── CustomContext │ │ ├── Context.pm │ │ ├── Controller │ │ │ └── Foo.pm │ │ └── Controller.pm │ ├── MyApp2 │ │ ├── Controller.pm │ │ └── Controller │ │ │ └── Bar.pm │ ├── MyApp2.pm │ ├── JsonError.pm │ ├── MyApp3.pm │ └── MyApp.pm ├── test_psgi.t ├── loaded_modules.t ├── base_attr.t ├── custom_req_resp.t ├── redefine_attrs.t ├── response_finalize.t ├── module_json.t ├── module_config_process_mode.t ├── module_template_null.t ├── subclassed.t ├── module_template.t ├── module_config_null.t ├── safe_param.t ├── routes_url.t ├── routes_custom_controller.t ├── encoders.t ├── template.t ├── bin_tests.t ├── module_load.t ├── response_redirect.t ├── module_config_get.t ├── json-encode-error.t ├── routes_controller.t ├── module_config.t ├── test_request.t ├── module_logger.t ├── persistent_controllers.t ├── request_session.t ├── module.t ├── params.t ├── routes_invalid.t ├── new_anonymous.t ├── pattern_cache.t ├── run_bridge.t ├── base.t ├── middleware.t ├── less.t ├── cookbook_yaml.t ├── charset.t ├── exceptions.t ├── response.t ├── util.t ├── pattern_build.t ├── request.t ├── module_config_merge.t ├── psgi.t ├── run.t ├── unicode.t ├── routes_match.t ├── response_error.t └── routes_add.t ├── .proverc ├── lib └── Kelp │ ├── templates │ ├── kelp │ │ ├── log-.gitkeep.gen │ │ ├── DOTgitignore.gen │ │ ├── app.psgi.gen │ │ ├── conf-test.pl.gen │ │ ├── template │ │ ├── conf-deployment.pl.gen │ │ ├── t-main.t.gen │ │ ├── conf-config.pl.gen │ │ ├── conf-development.pl.gen │ │ ├── lib-PATH-FILE.pm.gen │ │ └── views-welcome.tt │ └── less │ │ ├── template │ │ └── NAME.psgi.gen │ ├── Module │ ├── Null.pm │ ├── Template │ │ └── Null.pm │ ├── Config │ │ ├── Null.pm │ │ └── Less.pm │ ├── Logger │ │ └── Simple.pm │ ├── JSON.pm │ ├── Encoder.pm │ ├── Routes.pm │ ├── Logger.pm │ └── Template.pm │ ├── Routes │ ├── Location.pm │ └── Controller.pm │ ├── Test │ └── CookieJar.pm │ ├── Middleware.pm │ ├── Exception.pm │ ├── Template.pm │ ├── Base.pm │ ├── Context.pm │ ├── Module.pm │ ├── Generator.pm │ └── Manual │ └── Controllers.pod ├── conf └── test.pl ├── .tidyallrc ├── .editorconfig ├── .gitignore ├── cpanfile ├── dist.ini ├── .perltidyrc ├── ex └── perldoc.psgi ├── tools └── router_bench.pl ├── README.md ├── .mailmap ├── .github └── workflows │ └── ci.yml └── bin └── kelp-generator /log/.gitkeep: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /t/log/keep: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /.proverc: -------------------------------------------------------------------------------- 1 | -l 2 | 3 | -------------------------------------------------------------------------------- /t/conf/disable/test2.pl: -------------------------------------------------------------------------------- 1 | { }; 2 | -------------------------------------------------------------------------------- /lib/Kelp/templates/kelp/log-.gitkeep.gen: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /t/conf/b/test.pl: -------------------------------------------------------------------------------- 1 | { 2 | B => 'new' 3 | } 4 | -------------------------------------------------------------------------------- /t/conf/c/test.pl: -------------------------------------------------------------------------------- 1 | { 2 | B => 'new' 3 | } 4 | -------------------------------------------------------------------------------- /lib/Kelp/templates/less/template: -------------------------------------------------------------------------------- 1 | NAME.psgi.gen 2 | -------------------------------------------------------------------------------- /t/conf/process_mode/b.pl: -------------------------------------------------------------------------------- 1 | { 2 | baz => 1 3 | } 4 | -------------------------------------------------------------------------------- /t/views/0.tt: -------------------------------------------------------------------------------- 1 | confession: [% app.naughty_secret %] 2 | -------------------------------------------------------------------------------- /t/views/home.tt: -------------------------------------------------------------------------------- 1 | Hello, world! ☃ 2 | Line Two 3 | 4 | -------------------------------------------------------------------------------- /t/conf/g/config.pl: -------------------------------------------------------------------------------- 1 | { 2 | mode => app->mode 3 | }; 4 | -------------------------------------------------------------------------------- /t/conf/process_mode/a.pl: -------------------------------------------------------------------------------- 1 | { 2 | bar => 1 3 | }; 4 | -------------------------------------------------------------------------------- /t/views/error/404.tt: -------------------------------------------------------------------------------- 1 | Four Oh Four: [% error %] 2 | 3 | -------------------------------------------------------------------------------- /t/views/error/500.tt: -------------------------------------------------------------------------------- 1 | Five Hundred: [% error %] 2 | 3 | -------------------------------------------------------------------------------- /t/views/error/700.tt: -------------------------------------------------------------------------------- 1 | Seven Hundred: [% error %] 2 | 3 | -------------------------------------------------------------------------------- /lib/Kelp/templates/kelp/DOTgitignore.gen: -------------------------------------------------------------------------------- 1 | log/* 2 | !log/.gitkeep 3 | 4 | -------------------------------------------------------------------------------- /t/conf/a/config.pl: -------------------------------------------------------------------------------- 1 | { 2 | A => 'bar', 3 | B => 'foo' 4 | }; 5 | -------------------------------------------------------------------------------- /t/conf/b/config.pl: -------------------------------------------------------------------------------- 1 | { 2 | A => 'bar', 3 | B => 'foo' 4 | }; 5 | -------------------------------------------------------------------------------- /t/conf/disable/config.pl: -------------------------------------------------------------------------------- 1 | { 2 | modules => [qw/Template JSON/] 3 | }; 4 | -------------------------------------------------------------------------------- /t/conf/null/config.pl: -------------------------------------------------------------------------------- 1 | { 2 | shoulda => "This will not go in" 3 | } 4 | 5 | -------------------------------------------------------------------------------- /conf/test.pl: -------------------------------------------------------------------------------- 1 | { 2 | # No Logger while testing 3 | "-modules" => ['Logger'] 4 | }; 5 | -------------------------------------------------------------------------------- /t/conf/e/config.pl: -------------------------------------------------------------------------------- 1 | # This one will die for syntax error 2 | { 3 | one => missing, 4 | }; 5 | -------------------------------------------------------------------------------- /t/test.psgi: -------------------------------------------------------------------------------- 1 | use Kelp::Less; 2 | 3 | get '/say' => sub { 4 | "OK"; 5 | }; 6 | 7 | run; 8 | -------------------------------------------------------------------------------- /t/conf/f/config.pl: -------------------------------------------------------------------------------- 1 | # This one will die because it does not return a HASH 2 | [1,2,3] 3 | 4 | # vim:syntax=perl 5 | -------------------------------------------------------------------------------- /lib/Kelp/templates/kelp/app.psgi.gen: -------------------------------------------------------------------------------- 1 | use lib 'lib'; 2 | use [% name %]; 3 | 4 | my $app = [% name %]->new(); 5 | $app->run; 6 | -------------------------------------------------------------------------------- /t/lib/MyApp/Request.pm: -------------------------------------------------------------------------------- 1 | package MyApp::Request; 2 | use parent 'Kelp::Request'; 3 | 4 | # here just for testing 5 | 6 | 1; 7 | -------------------------------------------------------------------------------- /t/lib/UtilPackage.pm: -------------------------------------------------------------------------------- 1 | package UtilPackage; 2 | use Exporter qw( import ); 3 | 4 | our @EXPORT = qw( path ); 5 | 6 | sub path { "OK" } 7 | 8 | 1; 9 | -------------------------------------------------------------------------------- /t/conf/error/test.pl: -------------------------------------------------------------------------------- 1 | { 2 | modules_init => { 3 | Template => { 4 | paths => [] # No error templates 5 | } 6 | } 7 | } 8 | -------------------------------------------------------------------------------- /t/lib/MyApp/Routes.pm: -------------------------------------------------------------------------------- 1 | package MyApp::Routes; 2 | 3 | sub greet 4 | { 5 | my ($self, $name) = @_; 6 | return "OK $name"; 7 | } 8 | 9 | 1; 10 | -------------------------------------------------------------------------------- /t/lib/MyApp/Routes2.pm: -------------------------------------------------------------------------------- 1 | package MyApp::Routes2; 2 | 3 | sub goodbye 4 | { 5 | my ($self, $name) = @_; 6 | return "BYE $name"; 7 | } 8 | 9 | 1; 10 | -------------------------------------------------------------------------------- /lib/Kelp/templates/less/NAME.psgi.gen: -------------------------------------------------------------------------------- 1 | use Kelp::Less; 2 | 3 | module 'Logger::Simple'; 4 | 5 | get '/' => sub { 6 | "Hello, world!"; 7 | }; 8 | 9 | run; 10 | -------------------------------------------------------------------------------- /t/conf/deployment_no_templates/config.pl: -------------------------------------------------------------------------------- 1 | { 2 | modules_init => { 3 | Template => { 4 | paths => [] # No error templates 5 | } 6 | } 7 | } 8 | -------------------------------------------------------------------------------- /.tidyallrc: -------------------------------------------------------------------------------- 1 | [PerlTidy] 2 | select = **/*.{pl,pm,t} 3 | ignore = Kelp*/**/*.{pl,pm,t} 4 | ignore = .build/**/* 5 | ignore = conf/**/* 6 | ignore = t/conf/**/* 7 | argv = -pro=./.perltidyrc --character-encoding=none 8 | 9 | -------------------------------------------------------------------------------- /t/lib/MyApp/Response.pm: -------------------------------------------------------------------------------- 1 | package MyApp::Response; 2 | use Kelp::Base 'Kelp::Response'; 3 | 4 | sub render_404 5 | { 6 | my $self = shift; 7 | $self->set_code(404)->text->render("NO"); 8 | } 9 | 10 | 1; 11 | -------------------------------------------------------------------------------- /t/lib/Kelp/Module/Config/Injected.pm: -------------------------------------------------------------------------------- 1 | package Kelp::Module::Config::Injected; 2 | use Kelp::Base 'Kelp::Module::Config'; 3 | 4 | sub load 5 | { 6 | return { 7 | injected => 1 8 | }; 9 | } 10 | 11 | 1; 12 | 13 | -------------------------------------------------------------------------------- /t/test_psgi.t: -------------------------------------------------------------------------------- 1 | use Kelp::Test; 2 | use HTTP::Request::Common qw/GET PUT POST DELETE/; 3 | use Test::More; 4 | 5 | my $t = Kelp::Test->new(psgi => 't/test.psgi'); 6 | $t->request(GET '/say')->content_is("OK"); 7 | 8 | done_testing; 9 | -------------------------------------------------------------------------------- /t/lib/Kelp/Module/Plus.pm: -------------------------------------------------------------------------------- 1 | package Kelp::Module::Plus; 2 | use Kelp::Base 'Kelp::Module'; 3 | 4 | sub build 5 | { 6 | my ($self, %args) = @_; 7 | $self->register(plus => sub { $_[1] + $args{number} }); 8 | } 9 | 10 | 1; 11 | 12 | -------------------------------------------------------------------------------- /t/lib/MyApp/Module/Null.pm: -------------------------------------------------------------------------------- 1 | package MyApp::Module::Null; 2 | use Kelp::Base 'Kelp::Module'; 3 | 4 | sub build 5 | { 6 | my ($self, %args) = @_; 7 | $self->register(plus => sub { $_[1] + $args{number} }); 8 | } 9 | 10 | 1; 11 | -------------------------------------------------------------------------------- /lib/Kelp/templates/kelp/conf-test.pl.gen: -------------------------------------------------------------------------------- 1 | # Options specific to testing only 2 | { 3 | # No Logger output when testing 4 | modules_init => { 5 | Logger => { 6 | outputs => [], 7 | }, 8 | }, 9 | } 10 | 11 | -------------------------------------------------------------------------------- /lib/Kelp/Module/Null.pm: -------------------------------------------------------------------------------- 1 | package Kelp::Module::Null; 2 | use Kelp::Base 'Kelp::Module'; 3 | 4 | sub build 5 | { 6 | my ($self, %args) = @_; 7 | } 8 | 9 | 1; 10 | 11 | # This is a stub module which may be used as a placeholder for a future module. 12 | 13 | -------------------------------------------------------------------------------- /lib/Kelp/templates/kelp/template: -------------------------------------------------------------------------------- 1 | app.psgi.gen 2 | conf-config.pl.gen 3 | conf-deployment.pl.gen 4 | conf-development.pl.gen 5 | conf-test.pl.gen 6 | lib-PATH-FILE.pm.gen 7 | log-.gitkeep.gen 8 | DOTgitignore.gen 9 | t-main.t.gen 10 | views-welcome.tt 11 | 12 | -------------------------------------------------------------------------------- /t/loaded_modules.t: -------------------------------------------------------------------------------- 1 | use Kelp::Base -strict; 2 | use Test::More; 3 | use Kelp; 4 | 5 | my $app = Kelp->new; 6 | ok($app->loaded_modules->{$_}) for (qw/Template JSON/); 7 | isa_ok $app->loaded_modules->{Template}, 'Kelp::Module::Template'; 8 | 9 | done_testing; 10 | 11 | -------------------------------------------------------------------------------- /.editorconfig: -------------------------------------------------------------------------------- 1 | # http://editorconfig.org/ 2 | 3 | [*.{pl,pm,t,pod}] 4 | end_of_line = lf 5 | indent_style = space 6 | indent_size = 4 7 | insert_final_newline = true 8 | 9 | [Changes] 10 | end_of_line = lf 11 | indent_style = space 12 | indent_size = 4 13 | insert_final_newline = true 14 | 15 | -------------------------------------------------------------------------------- /t/base_attr.t: -------------------------------------------------------------------------------- 1 | use Kelp::Base -strict; 2 | use Test::More; 3 | 4 | { 5 | 6 | package WithAttrs; 7 | 8 | use Kelp::Base -attr; 9 | 10 | attr a1 => 55; 11 | } 12 | 13 | ok !WithAttrs->can('new'), 'new ok'; 14 | ok !WithAttrs->isa('Kelp::Base'), 'base ok'; 15 | can_ok 'WithAttrs', 'a1'; 16 | 17 | done_testing; 18 | 19 | -------------------------------------------------------------------------------- /t/lib/StringifyingException.pm: -------------------------------------------------------------------------------- 1 | package StringifyingException; 2 | use Kelp::Base; 3 | 4 | attr data => undef; 5 | 6 | use overload 7 | q{""} => 'stringify', 8 | fallback => 1, 9 | ; 10 | 11 | sub stringify 12 | { 13 | return 'Exception with data: [' . (join ',', @{$_[0]->data}) . ']'; 14 | } 15 | 16 | 1; 17 | 18 | -------------------------------------------------------------------------------- /t/conf/encoders/test.pl: -------------------------------------------------------------------------------- 1 | { 2 | encoders => { 3 | json => { 4 | indented => { 5 | indent => 1, 6 | }, 7 | }, 8 | }, 9 | 10 | modules_init => { 11 | JSON => { 12 | indent => 0, 13 | space_before => 0, 14 | }, 15 | }, 16 | } 17 | 18 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | blib/ 2 | .build/ 3 | _build/ 4 | cover_db/ 5 | inc/ 6 | Build 7 | !Build/ 8 | tmp/ 9 | Build.bat 10 | .last_cover_stats 11 | Makefile 12 | Makefile.old 13 | MANIFEST.bak 14 | META.yml 15 | MYMETA.yml 16 | nytprof.out 17 | pm_to_blib 18 | *.tmp 19 | *.log 20 | allprove 21 | log 22 | !log/.gitkeep 23 | .tidyall.d 24 | /Kelp* 25 | *.tar.gz 26 | 27 | -------------------------------------------------------------------------------- /t/lib/CustomContext/Context.pm: -------------------------------------------------------------------------------- 1 | package CustomContext::Context; 2 | 3 | use Kelp::Base 'Kelp::Context'; 4 | use Kelp::Util; 5 | 6 | attr persistent_controllers => !!1; 7 | 8 | sub build_controller 9 | { 10 | my ($self, $controller_class) = @_; 11 | 12 | $controller_class->new( 13 | context => $self, 14 | ); 15 | } 16 | 17 | 1; 18 | 19 | -------------------------------------------------------------------------------- /t/conf/stack_trace_enabled/test.pl: -------------------------------------------------------------------------------- 1 | { 2 | modules_init => { 3 | Template => { 4 | paths => [] # No error templates 5 | } 6 | }, 7 | middleware => ['StackTrace'], 8 | middleware_init => { 9 | StackTrace => { 10 | force => 1, 11 | no_print_errors => 1, 12 | } 13 | } 14 | }; 15 | 16 | -------------------------------------------------------------------------------- /lib/Kelp/Module/Template/Null.pm: -------------------------------------------------------------------------------- 1 | package Kelp::Module::Template::Null; 2 | use Kelp::Base 'Kelp::Module::Template'; 3 | 4 | attr ext => undef; 5 | 6 | sub build_engine 7 | { 8 | return undef; 9 | } 10 | 11 | sub render 12 | { 13 | return ''; 14 | } 15 | 16 | 1; 17 | 18 | # This is a stub template module which may be used as a placeholder for a 19 | # future template module. 20 | 21 | -------------------------------------------------------------------------------- /lib/Kelp/templates/kelp/conf-deployment.pl.gen: -------------------------------------------------------------------------------- 1 | # Options specific to deployment only 2 | { 3 | modules_init => { 4 | 5 | # Don't let the application build if routes have errors 6 | Routes => { 7 | fatal => 1, 8 | }, 9 | 10 | # Compress JSON output in deployment 11 | JSON => { 12 | pretty => 0, 13 | }, 14 | }, 15 | }; 16 | 17 | -------------------------------------------------------------------------------- /t/lib/MyApp2/Controller.pm: -------------------------------------------------------------------------------- 1 | package MyApp2::Controller; 2 | use Kelp::Base 'MyApp2'; 3 | 4 | sub blessed { ref shift } 5 | 6 | # Access to modules 7 | sub test_module { shift->config('charset') } 8 | 9 | sub build 10 | { 11 | my $self = shift; 12 | my $r = $self->routes; 13 | 14 | $r->add("/blessed", "blessed"); 15 | $r->add("/persistence", "bar#test_persistence"); 16 | } 17 | 18 | 1; 19 | 20 | -------------------------------------------------------------------------------- /t/custom_req_resp.t: -------------------------------------------------------------------------------- 1 | use lib 't/lib'; 2 | use MyApp; 3 | use Test::More; 4 | 5 | ok my $app = MyApp->new( 6 | request_obj => 'MyApp::Request', 7 | response_obj => 'MyApp::Response', 8 | ), 9 | q{can build object}; 10 | 11 | isa_ok $app->build_request({}), 'MyApp::Request', q{custom request object}; 12 | isa_ok $app->build_response, 'MyApp::Response', q{custom response object}; 13 | 14 | done_testing; 15 | -------------------------------------------------------------------------------- /t/redefine_attrs.t: -------------------------------------------------------------------------------- 1 | use lib 't/lib'; 2 | use utf8; 3 | use MyApp; 4 | use Test::More; 5 | use Kelp::Test; 6 | use HTTP::Request::Common qw( GET ); 7 | 8 | my $app = MyApp->new; 9 | my $t = Kelp::Test->new(app => $app); 10 | 11 | is $t->request(GET '/blessed')->res->code, 200, 12 | '"path" attr not redefined by import.'; 13 | is $app->check_util_fun, "OK", 14 | '"path" util function still work inside package.'; 15 | 16 | done_testing; 17 | -------------------------------------------------------------------------------- /t/lib/Kelp/Module/Template/Ducks.pm: -------------------------------------------------------------------------------- 1 | package Kelp::Module::Template::Ducks; 2 | use Kelp::Base 'Kelp::Module::Template'; 3 | use Plack::Util; 4 | 5 | attr ext => 'null'; 6 | 7 | sub build_engine 8 | { 9 | my ($self, %args) = @_; 10 | Plack::Util::inline_object(render => sub { "All the ducks" }); 11 | } 12 | 13 | sub render 14 | { 15 | my ($self, $template, $vars, @rest) = @_; 16 | $self->engine->render(); 17 | } 18 | 19 | 1; 20 | 21 | -------------------------------------------------------------------------------- /t/response_finalize.t: -------------------------------------------------------------------------------- 1 | use Kelp::Base -strict; 2 | 3 | use Kelp; 4 | use Kelp::Response; 5 | use Test::More; 6 | 7 | my $app = Kelp->new(mode => 'test'); 8 | my $r = Kelp::Response->new(app => $app); 9 | 10 | $r->text; 11 | $r->set_code(200); 12 | my $A = $r->finalize; 13 | 14 | $r->partial(1); 15 | my $B = $r->finalize; 16 | 17 | is scalar(@$A), 3; 18 | is scalar(@$B), 2; 19 | is $A->[0], $B->[0]; 20 | is_deeply $A->[1], $B->[1]; 21 | 22 | done_testing; 23 | -------------------------------------------------------------------------------- /t/lib/MyApp2.pm: -------------------------------------------------------------------------------- 1 | package MyApp2; 2 | use Kelp::Base 'Kelp'; 3 | 4 | sub build 5 | { 6 | my $self = shift; 7 | my $r = $self->routes; 8 | $r->add("/test_inherit", "bar#test_inherit"); 9 | $r->add("/test_module", "bar#test_module"); 10 | $r->add("/test_template", "bar#test_template"); 11 | $r->add("/test_res_template", "bar#test_res_template"); 12 | 13 | $self->context->controller->build; 14 | $self->context->controller('Bar')->build; 15 | } 16 | 17 | 1; 18 | 19 | -------------------------------------------------------------------------------- /t/module_json.t: -------------------------------------------------------------------------------- 1 | 2 | use Kelp::Base -strict; 3 | use Kelp; 4 | use Test::More; 5 | 6 | # Basic 7 | { 8 | my $app = Kelp->new(__config => {modules => []}); 9 | my $m = $app->load_module('JSON'); 10 | isa_ok $m, "Kelp::Module::JSON"; 11 | can_ok $app, $_ for qw/json/; 12 | ok 13 | $app->json->isa('Cpanel::JSON::XS') 14 | || $app->json->isa('JSON::XS') 15 | || $app->json->isa('JSON::PP'), 16 | 'JSON method ok'; 17 | } 18 | 19 | done_testing; 20 | -------------------------------------------------------------------------------- /cpanfile: -------------------------------------------------------------------------------- 1 | requires 'Plack' => '1.0041'; 2 | requires 'Log::Dispatch' => '0'; 3 | requires 'JSON::MaybeXS' => '0'; 4 | requires 'Path::Tiny' => '0'; 5 | requires 'Template::Tiny' => 0; 6 | requires 'Try::Tiny' => 0; 7 | requires 'Class::Inspector' => '0'; 8 | requires 'namespace::autoclean' => '0'; 9 | requires 'URI' => '0'; 10 | requires 'Hash::MultiValue' => '0'; 11 | requires 'HTTP::Message' => '0'; 12 | requires 'Test::Deep' => '1.129'; 13 | 14 | on 'test' => sub { 15 | requires 'Test::Exception' => '0'; 16 | }; 17 | 18 | -------------------------------------------------------------------------------- /dist.ini: -------------------------------------------------------------------------------- 1 | name = Kelp 2 | abstract = A web framework light, yet rich in nutrients. 3 | license = Perl_5 4 | copyright_holder = Stefan Geneshky 5 | 6 | [@Basic] 7 | [MetaJSON] 8 | 9 | [PruneFiles] 10 | filename=tools 11 | 12 | [VersionFromModule] 13 | [PodSyntaxTests] 14 | [GitHub::Meta] 15 | [Git::Contributors] 16 | order_by=commits 17 | 18 | [NextRelease] 19 | time_zone=UTC 20 | format=%v - %{yyyy-MM-dd}d 21 | 22 | [Git::Commit] 23 | commit_msg=Release %V 24 | 25 | [Prereqs::FromCPANfile] 26 | [Prereqs] 27 | perl = 5.014 28 | 29 | -------------------------------------------------------------------------------- /lib/Kelp/Module/Config/Null.pm: -------------------------------------------------------------------------------- 1 | package Kelp::Module::Config::Null; 2 | use Kelp::Base 'Kelp::Module::Config'; 3 | 4 | attr 'data' => sub { {} }; 5 | 6 | sub load { {} } 7 | 8 | 1; 9 | 10 | # This config module has no defaults and won't load your configuration files. 11 | # The configuration will be completely empty and can be only set by hand in 12 | # code. It's very likely going to make some parts of the system not function as 13 | # they should unless you provide the same set of defaults as 14 | # Kelp::Module::Config::Less (and keep it updated) 15 | 16 | -------------------------------------------------------------------------------- /lib/Kelp/templates/kelp/t-main.t.gen: -------------------------------------------------------------------------------- 1 | use Kelp::Base -strict; 2 | use Kelp::Test; 3 | use Test::More; 4 | use HTTP::Request::Common; 5 | use [% name %]; 6 | 7 | # Create an application object 8 | my $app = [% name %]->new( mode => 'test' ); 9 | 10 | # Feed it into a test object 11 | my $t = Kelp::Test->new( app => $app ); 12 | 13 | # Send a GET request to /home and test the response 14 | $t->request( GET '/' ) 15 | ->code_is(200) 16 | ->content_type_is('text/html') 17 | ->content_like(qr/Welcome to the Kelp web framework!/); 18 | 19 | done_testing; 20 | -------------------------------------------------------------------------------- /.perltidyrc: -------------------------------------------------------------------------------- 1 | ### GENERAL 2 | --maximum-line-length=120 3 | --converge 4 | 5 | ### WHITESPACE 6 | --continuation-indentation=4 7 | --extended-continuation-indentation 8 | --no-delete-old-newlines 9 | 10 | ### ALIGNMENT 11 | --no-outdent-long-lines 12 | --no-outdent-labels 13 | --no-logical-padding 14 | --novalign 15 | 16 | ### TIGHTNESS 17 | --opening-sub-brace-on-new-line 18 | --square-bracket-tightness=2 19 | --paren-tightness=2 20 | --brace-tightness=2 21 | --opening-token-right 22 | 23 | -gal='first any sum sum0 reduce dies_ok lives_ok throws_ok lives_and' 24 | 25 | -------------------------------------------------------------------------------- /t/lib/JsonError.pm: -------------------------------------------------------------------------------- 1 | package JsonError; 2 | use Kelp::Base 'Kelp'; 3 | 4 | sub build 5 | { 6 | my $self = shift; 7 | my $r = $self->routes; 8 | 9 | $r->add( 10 | "/json", 11 | sub { 12 | return { 13 | key => sub { } 14 | }; 15 | } 16 | ); 17 | 18 | $r->add( 19 | "/forced-json", 20 | sub { 21 | my $self = shift; 22 | 23 | $self->res->json; 24 | return { 25 | key => sub { } 26 | }; 27 | } 28 | ); 29 | } 30 | 31 | 1; 32 | -------------------------------------------------------------------------------- /t/lib/CustomContext/Controller/Foo.pm: -------------------------------------------------------------------------------- 1 | package CustomContext::Controller::Foo; 2 | 3 | use Kelp::Base 'CustomContext::Controller'; 4 | 5 | sub test 6 | { 7 | my ($self) = @_; 8 | 9 | $self->res->text; 10 | return ref $self; 11 | } 12 | 13 | sub test_template 14 | { 15 | my ($self) = @_; 16 | 17 | $self->res->template('home'); 18 | } 19 | 20 | sub nested_psgi 21 | { 22 | my ($self) = @_; 23 | 24 | return [ 25 | 200, 26 | ['Content-Type' => 'text/plain'], 27 | [ 28 | 'PSGI OK' 29 | ], 30 | ]; 31 | } 32 | 33 | 1; 34 | 35 | -------------------------------------------------------------------------------- /t/module_config_process_mode.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Test::More; 4 | use Kelp::Module::Config; 5 | use Kelp; 6 | 7 | BEGIN { 8 | use FindBin '$Bin'; 9 | $ENV{KELP_CONFIG_DIR} = "$Bin/conf/process_mode"; 10 | } 11 | 12 | my $app = Kelp->new; 13 | my $c = Kelp::Module::Config->new(app => $app, data => {foo => 1}); 14 | 15 | $c->process_mode('missing'); 16 | is_deeply $c->data, {foo => 1}; 17 | 18 | $c->process_mode('a'); 19 | is_deeply $c->data, {foo => 1, bar => 1}; 20 | 21 | $c->process_mode('b'); 22 | is_deeply $c->data, {foo => 1, bar => 1, baz => 1}; 23 | 24 | done_testing; 25 | -------------------------------------------------------------------------------- /t/module_template_null.t: -------------------------------------------------------------------------------- 1 | $ENV{KELP_REDEFINE} = 1; 2 | 3 | use lib 't/lib'; 4 | use Kelp; 5 | use Kelp::Base -strict; 6 | use Test::More; 7 | 8 | subtest 'testing Template::Null' => sub { 9 | my $app = Kelp->new(__config => {modules => ['Template::Null']}); 10 | is $app->template(), ''; 11 | is $app->template("something", {bar => 'foo'}), ''; 12 | }; 13 | 14 | subtest 'testing Template::Ducks' => sub { 15 | my $app = Kelp->new(__config => {modules => ['Template::Ducks']}); 16 | is $app->template(), "All the ducks"; 17 | is $app->template("something", {bar => 'foo'}), "All the ducks"; 18 | }; 19 | 20 | done_testing; 21 | 22 | -------------------------------------------------------------------------------- /lib/Kelp/templates/kelp/conf-config.pl.gen: -------------------------------------------------------------------------------- 1 | # Common settings 2 | { 3 | modules => [qw/Template JSON Logger/], 4 | modules_init => { 5 | 6 | # One log for errors and one for debug 7 | Logger => { 8 | outputs => [ 9 | [ 10 | 'File', 11 | name => 'error', 12 | filename => 'log/error.log', 13 | min_level => 'warn', 14 | mode => '>>', 15 | newline => 1, 16 | binmode => ':encoding(UTF-8)', 17 | ], 18 | ], 19 | }, 20 | 21 | JSON => { 22 | pretty => 1, 23 | utf8 => 0, # will not encode wide characters 24 | }, 25 | }, 26 | }; 27 | 28 | -------------------------------------------------------------------------------- /lib/Kelp/templates/kelp/conf-development.pl.gen: -------------------------------------------------------------------------------- 1 | # Options specific to development only 2 | { 3 | # Add StackTrace in development 4 | '+middleware' => ['StackTrace'], 5 | middleware_init => { 6 | StackTrace => { 7 | force => 1, 8 | }, 9 | }, 10 | 11 | modules_init => { 12 | # One log for errors and one for debug 13 | Logger => { 14 | '+outputs' => [ 15 | [ 16 | 'Screen', 17 | name => 'debug', 18 | min_level => 'debug', 19 | max_level => 'notice', 20 | stderr => 0, 21 | newline => 1, 22 | utf8 => 1, 23 | ], 24 | ], 25 | }, 26 | }, 27 | }; 28 | 29 | -------------------------------------------------------------------------------- /lib/Kelp/Module/Config/Less.pm: -------------------------------------------------------------------------------- 1 | package Kelp::Module::Config::Less; 2 | use Kelp::Base 'Kelp::Module::Config'; 3 | 4 | # Kelp::Less applications start with no modules or middleware, but it surely 5 | # can be used for normal applications as well. 6 | attr data => sub { 7 | my $self = shift; 8 | my $hash = $self->SUPER::data(); 9 | 10 | $hash->{modules} = []; 11 | $hash->{middleware} = []; 12 | 13 | return $hash; 14 | }; 15 | 16 | 1; 17 | 18 | __END__ 19 | 20 | =pod 21 | 22 | =head1 NAME 23 | 24 | Kelp::Module::Config::Less - Configuration with less defaults 25 | 26 | =head1 DESCRIPTION 27 | 28 | Light config with no modules or middleware by default. Good if you want less 29 | defaults and used by L. 30 | 31 | =head1 SEE ALSO 32 | 33 | L 34 | 35 | =cut 36 | 37 | -------------------------------------------------------------------------------- /t/subclassed.t: -------------------------------------------------------------------------------- 1 | use lib 't/lib'; 2 | use Kelp::Base -strict; 3 | use MyApp; 4 | use Kelp::Test; 5 | use HTTP::Request::Common; 6 | use Test::More; 7 | use Test::Exception; 8 | 9 | my $app = MyApp->new(mode => 'test'); 10 | my $t = Kelp::Test->new(app => $app); 11 | 12 | $t->request(GET '/test') 13 | ->code_isnt(500) 14 | ->content_is("OK") 15 | ->content_isnt("FAIL") 16 | ->header_is("X-Before-Dispatch", "MyApp") 17 | ->header_is("X-Test", "MyApp") 18 | ->header_isnt("X-Framework", "Perl Kelp"); 19 | 20 | $t->request(GET '/missing') 21 | ->code_is(404) 22 | ->content_is("NO"); 23 | 24 | $t->request(GET '/greet/jack') 25 | ->code_is(200) 26 | ->content_is("OK jack"); 27 | 28 | $t->request(GET '/bye/jack') 29 | ->code_is(200) 30 | ->content_is("BYE jack"); 31 | 32 | done_testing; 33 | 34 | -------------------------------------------------------------------------------- /t/module_template.t: -------------------------------------------------------------------------------- 1 | 2 | use Kelp::Base -strict; 3 | use Kelp; 4 | use Test::More; 5 | use utf8; 6 | 7 | # Basic 8 | my $app = Kelp->new(__config => {modules => []}); 9 | my $m = $app->load_module('Template'); 10 | isa_ok $m, 'Kelp::Module::Template'; 11 | can_ok $app, $_ for qw/template/; 12 | is $app->template(\"[% a %] ☃", {a => 4}), '4 ☃', "Process"; 13 | 14 | # Test automatic appending of default extension to template names 15 | my $ext = 'foo'; 16 | is $m->ext($ext), $ext, 'set default template ext'; 17 | is $m->ext, $ext, 'get default template ext'; 18 | is $m->_rename('home'), "home.$ext", 'if no extension, default appended'; 19 | is $m->_rename('home.tt'), 'home.tt', 'if extension, default not appended'; 20 | $m->ext(''); 21 | is $m->_rename('home'), 'home', 'if no default defined, no change'; 22 | $m->ext('tt'); 23 | 24 | done_testing; 25 | 26 | -------------------------------------------------------------------------------- /t/lib/MyApp3.pm: -------------------------------------------------------------------------------- 1 | package MyApp3; 2 | use Kelp::Base 'Kelp'; 3 | 4 | attr context_obj => 'CustomContext::Context'; 5 | 6 | sub build 7 | { 8 | my $self = shift; 9 | 10 | $self->routes->base('CustomContext::Controller'); 11 | $self->routes->rebless(1); 12 | 13 | $self->add_route( 14 | '/a/b' => { 15 | to => sub { 16 | return ref shift() eq __PACKAGE__; 17 | }, 18 | bridge => 1, 19 | } 20 | ); 21 | $self->add_route( 22 | '/a/b/d' => { 23 | to => sub { 24 | $self->res->text; 25 | return ref $self; 26 | }, 27 | } 28 | ); 29 | $self->context->controller()->build; 30 | } 31 | 32 | sub before_finalize 33 | { 34 | my $self = shift; 35 | $self->res->header('X-Final' => __PACKAGE__); 36 | } 37 | 38 | 1; 39 | 40 | -------------------------------------------------------------------------------- /ex/perldoc.psgi: -------------------------------------------------------------------------------- 1 | use Kelp::Less; 2 | use IPC::Open3; 3 | use Symbol 'gensym'; 4 | 5 | module 'Logger::Simple'; 6 | 7 | get '/:perldoc_page' => sub { 8 | my ($self, $name) = @_; 9 | 10 | # safely call perldoc to render page in html 11 | my $pid = open3(undef, my $output, my $error = gensym, 'perldoc', '-T', '-o', 'html', $name); 12 | 13 | # read the output, then reap the process 14 | my $contents = do { 15 | local $/; 16 | readline $output; 17 | }; 18 | my $errors = do { 19 | local $/; 20 | readline $error; 21 | }; 22 | waitpid $pid, 0; 23 | 24 | # if we did not succeed, assume there's no such docs page 25 | my $status = $? >> 8; 26 | $self->res->render_error(404, $errors) 27 | if $status != 0; 28 | 29 | # return the contents - if the response was not rendered, it will be 30 | # used as page content (html) 31 | return $contents; 32 | }; 33 | 34 | run; 35 | 36 | -------------------------------------------------------------------------------- /t/module_config_null.t: -------------------------------------------------------------------------------- 1 | $ENV{KELP_REDEFINE} = 1; 2 | 3 | # Allow the redefining of globs at Kelp::Module 4 | BEGIN { 5 | use FindBin '$Bin'; 6 | $ENV{KELP_CONFIG_DIR} = "$Bin/conf/null"; 7 | } 8 | 9 | use lib 't/lib'; 10 | use Kelp; 11 | use Kelp::Base -strict; 12 | use Test::More; 13 | use Test::Deep; 14 | 15 | subtest 'testing null config' => sub { 16 | my $app = Kelp->new(config_module => 'Config::Null'); 17 | is_deeply $app->config_hash, {}, 'null module ok'; 18 | }; 19 | 20 | subtest 'default on config should work' => sub { 21 | my $app = Kelp->new(config_module => 'Config::Null'); 22 | is $app->config('nothing', 'def'), 'def'; 23 | }; 24 | 25 | subtest 'testing injected config' => sub { 26 | my $app = Kelp->new(config_module => 'Config::Injected'); 27 | is $app->config("injected"), 1; 28 | is $app->config("shoulda"), undef; 29 | }; 30 | 31 | done_testing; 32 | 33 | -------------------------------------------------------------------------------- /t/safe_param.t: -------------------------------------------------------------------------------- 1 | use Kelp::Base -strict; 2 | 3 | use Kelp; 4 | use Kelp::Test; 5 | use HTTP::Request::Common; 6 | use Test::More; 7 | 8 | my $app = Kelp->new_anon(mode => 'test'); 9 | $app->routes->base('main'); 10 | my $t = Kelp::Test->new(app => $app); 11 | 12 | $app->add_route( 13 | "/safe/:val" => { 14 | method => 'GET', 15 | to => "check_safe", 16 | } 17 | ); 18 | 19 | $t->request(GET '/safe/tval?test=sth') 20 | ->content_is('tval 1 sth'); 21 | $t->request(GET '/safe/tval?test=sth&test=sth_else') 22 | ->content_is('tval 1 sth_else'); 23 | 24 | done_testing; 25 | 26 | sub check_safe 27 | { 28 | my ($kelp, $val) = @_; 29 | 30 | # list context + parameter to param used to return all parameters with that 31 | # name (can be multiple) 32 | my @params = $kelp->param('test'); 33 | my $params = $kelp->param; 34 | return join ' ', $val, $params, @params; 35 | } 36 | 37 | -------------------------------------------------------------------------------- /t/lib/MyApp.pm: -------------------------------------------------------------------------------- 1 | package MyApp; 2 | use Kelp::Base 'Kelp'; 3 | use MyApp::Response; 4 | use UtilPackage; 5 | 6 | sub before_dispatch 7 | { 8 | my $self = shift; 9 | $self->res->header('X-Before-Dispatch', 'MyApp'); 10 | } 11 | 12 | sub before_finalize 13 | { 14 | my $self = shift; 15 | $self->res->header('X-Test', 'MyApp'); 16 | } 17 | 18 | sub build_response 19 | { 20 | my $self = shift; 21 | MyApp::Response->new(app => $self); 22 | } 23 | 24 | sub build 25 | { 26 | my $self = shift; 27 | my $r = $self->routes; 28 | $r->add("/test", sub { "OK" }); 29 | $r->add("/greet/:name", "routes#greet"); 30 | $r->add("/bye/:name", "Routes2::goodbye"); 31 | 32 | # Controller routes 33 | $r->add("/blessed", "blessed"); 34 | } 35 | 36 | sub blessed 37 | { 38 | my ($self) = @_; 39 | 40 | $self->template('home'); 41 | } 42 | 43 | sub check_util_fun { path; } 44 | 45 | 1; 46 | 47 | -------------------------------------------------------------------------------- /t/routes_url.t: -------------------------------------------------------------------------------- 1 | package A; 2 | sub b { } 3 | 1; 4 | 5 | package Ab; 6 | sub c { } 7 | 1; 8 | 9 | package main; 10 | use strict; 11 | use warnings; 12 | 13 | use Test::More; 14 | use Kelp::Routes; 15 | 16 | my $r = Kelp::Routes->new; 17 | 18 | $r->add('/a' => {to => 'a#b', name => 'a'}); 19 | $r->add('/b' => {to => 'ab#c', name => 'b'}); 20 | $r->add('/a/b' => {to => 'a#b', name => 'ab'}); 21 | $r->add('/a/b/c' => 'ab#c'); 22 | 23 | is $r->url('noname'), 'noname'; 24 | is $r->url('a'), '/a'; 25 | is $r->url('b'), '/b'; 26 | is $r->url('ab'), '/a/b'; 27 | 28 | $r->clear; 29 | $r->add('/:a/:b', {to => 'a#b', name => 'a'}); 30 | $r->add('/:a/?b', {to => 'ab#c', name => 'b', defaults => {b => 'foo'}}); 31 | 32 | is $r->url(qw/a a bar b foo/), '/bar/foo'; 33 | is $r->url(qw/b a bar b moo/), '/bar/moo'; 34 | is $r->url(qw/b a bar/), '/bar/foo'; 35 | 36 | is $r->url('a', a => '0', b => '0'), '/0/0'; 37 | 38 | done_testing; 39 | 40 | -------------------------------------------------------------------------------- /t/routes_custom_controller.t: -------------------------------------------------------------------------------- 1 | use lib 't/lib'; 2 | use Kelp::Base -strict; 3 | use MyApp3; 4 | use Kelp::Test; 5 | use HTTP::Request::Common; 6 | use Test::More; 7 | 8 | # Get the app 9 | my $app = MyApp3->new(); 10 | 11 | # Test object 12 | my $t = Kelp::Test->new(app => $app); 13 | 14 | $t->request_ok(GET '/a/b/c') 15 | ->content_type_is('text/plain') 16 | ->header_is('X-Final', 'CustomContext::Controller') 17 | ->content_is('CustomContext::Controller::Foo'); 18 | 19 | $t->request_ok(GET '/a/b/d') 20 | ->content_type_is('text/plain') 21 | ->header_is('X-Final', 'MyApp3') 22 | ->content_is('MyApp3'); 23 | 24 | $t->request_ok(GET '/a/b/e') 25 | ->content_type_is('text/plain') 26 | ->header_is('X-Final', 'CustomContext::Controller') 27 | ->content_is('PSGI OK'); 28 | 29 | # test template generated from response 30 | $t->request_ok(GET '/b') 31 | ->content_like(qr{Hello, world!}); 32 | 33 | done_testing; 34 | 35 | -------------------------------------------------------------------------------- /lib/Kelp/Module/Logger/Simple.pm: -------------------------------------------------------------------------------- 1 | package Kelp::Module::Logger::Simple; 2 | use Kelp::Base 'Kelp::Module::Logger'; 3 | use Plack::Util; 4 | 5 | sub _logger 6 | { 7 | my ($self, %args) = @_; 8 | return $self->SUPER::_logger( 9 | outputs => [ 10 | [ 11 | 'Screen', 12 | min_level => $args{min_level} // 'debug', 13 | newline => 1, 14 | stderr => !$args{stdout}, 15 | ] 16 | ] 17 | ); 18 | } 19 | 20 | 1; 21 | 22 | __END__ 23 | 24 | =pod 25 | 26 | =head1 NAME 27 | 28 | Kelp::Module::Logger::Simple - Simple log to standard output 29 | 30 | =head1 SYNOPSIS 31 | 32 | use Kelp::Less; 33 | 34 | module 'Logger::Simple', min_level => 'error', stdout => 1; 35 | 36 | ... 37 | 38 | =head1 DESCRIPTION 39 | 40 | A very simple logger that dumps everything to C or C if C<< 41 | stdout => 1 >> was configured. 42 | 43 | =cut 44 | 45 | -------------------------------------------------------------------------------- /t/encoders.t: -------------------------------------------------------------------------------- 1 | use Kelp::Base -strict; 2 | 3 | use Kelp; 4 | use Test::More; 5 | use FindBin '$Bin'; 6 | 7 | $ENV{KELP_CONFIG_DIR} = "$Bin/conf/encoders"; 8 | my $app = Kelp->new(mode => 'test'); 9 | 10 | subtest 'testing default encoder' => sub { 11 | my $default_encoder = $app->get_encoder('json'); 12 | my $encoder = $app->get_encoder(json => 'default'); 13 | 14 | ok !$encoder->get_indent, 'encoder no indent ok'; 15 | is $default_encoder, $encoder, 'encoder default key is default ok'; 16 | 17 | ok !$encoder->get_space_before, 'space_before after modification ok'; 18 | $encoder->space_before; 19 | ok $app->get_encoder('json')->get_space_before, 'space_before after modification ok'; 20 | }; 21 | 22 | subtest 'testing default encoder' => sub { 23 | my $encoder = $app->get_encoder(json => 'indented'); 24 | ok $encoder->get_indent, 'encoder extra config ok'; 25 | ok !$encoder->get_space_before, 'encoder no default config ok'; 26 | }; 27 | 28 | done_testing; 29 | 30 | -------------------------------------------------------------------------------- /t/template.t: -------------------------------------------------------------------------------- 1 | use Kelp::Base -strict; 2 | use Kelp::Template; 3 | use Test::More; 4 | use Test::Exception; 5 | use IO::File; 6 | use utf8; 7 | 8 | my $text = "Hello, world! ☃\nLine Two\n\n"; 9 | 10 | my $t = Kelp::Template->new(paths => ['views', 't/views']); 11 | is $t->process(\$text), $text, "Render SCALAR"; 12 | is $t->process(\$text), $text, "Render SCALAR again"; 13 | is $t->process('home.tt'), $text, "Render file"; 14 | is $t->process('home.tt'), $text, "Render file again"; 15 | is $t->process(\*DATA), $text, "Render GLOB"; 16 | is $t->process(\*DATA), $text, "Render GLOB again"; 17 | is $t->process(\*DATA), $text, "Render GLOB third time (DATA is tricky)"; 18 | my $f = IO::File->new("t/views/home.tt", "<:encoding(utf8)") or die $!; 19 | is $t->process($f), $text, "Render IO object"; 20 | is $t->process($f), $text, "Render IO object again"; 21 | 22 | dies_ok { $t->process("missing.tt") } "Dies if template is missing"; 23 | 24 | done_testing; 25 | 26 | __DATA__ 27 | Hello, world! ☃ 28 | Line Two 29 | 30 | -------------------------------------------------------------------------------- /lib/Kelp/Routes/Location.pm: -------------------------------------------------------------------------------- 1 | package Kelp::Routes::Location; 2 | 3 | use Kelp::Base; 4 | use Carp; 5 | 6 | attr 'router' => sub { croak 'router is required' }; 7 | attr 'parent' => sub { croak 'parent is required' }; 8 | 9 | sub add 10 | { 11 | my ($self, $pattern, $descr, $parent_data) = @_; 12 | my $parent = $self->parent; 13 | 14 | croak "Cannot chain 'add' calls because the parent route was not parsed correctly" 15 | unless $parent; 16 | 17 | # discard $parent_data from args 18 | $parent_data = { 19 | ($parent->has_name ? (name => $parent->name) : ()), 20 | pattern => $parent->pattern, 21 | }; 22 | 23 | # parent is a bridge now (even if the add call fails) 24 | $parent->bridge(1); 25 | return $self->router->add($pattern, $descr, $parent_data); 26 | } 27 | 28 | 1; 29 | 30 | # internal only 31 | # It's not a router reimplementation! It's just a facade for the add method of 32 | # the router. Developers will interact with it without even knowing. 33 | 34 | -------------------------------------------------------------------------------- /t/bin_tests.t: -------------------------------------------------------------------------------- 1 | use Kelp::Base -strict; 2 | use Test::More; 3 | use Test::Harness 'execute_tests'; 4 | use File::Temp 'tempdir'; 5 | use Config; 6 | use FindBin '$Bin'; 7 | 8 | test_app("Foo"); 9 | 10 | sub test_app 11 | { 12 | my $params = shift; 13 | my $kelp_dir = tempdir(CLEANUP => 1); 14 | push @INC, "$kelp_dir/lib"; 15 | system("$Config{perlpath} $Bin/../bin/kelp-generator --path=$kelp_dir --noverbose $params"); 16 | 17 | my ($total, $failed) = execute_tests(tests => ["$kelp_dir/t/main.t"]); 18 | ok($total->{bad} == 0 && $total->{max} > 0, "Generated app tests OK") 19 | or diag explain $failed; 20 | } 21 | 22 | my $help = `$Config{perlpath} $Bin/../bin/kelp-generator --help`; 23 | like $help, qr/\Qkelp-generator [options] \E/, 'help head ok'; 24 | like $help, qr/\QAvailable application types:\E/, 'help templates ok'; 25 | 26 | my $bad_call = `$Config{perlpath} $Bin/../bin/kelp-generator application-name 2>&1`; 27 | like $bad_call, qr/\Qnot a Perl package name\E/, 'bad call ok'; 28 | 29 | done_testing; 30 | 31 | -------------------------------------------------------------------------------- /t/lib/MyApp2/Controller/Bar.pm: -------------------------------------------------------------------------------- 1 | package MyApp2::Controller::Bar; 2 | use Kelp::Base 'MyApp2::Controller'; 3 | 4 | attr last_value => 1; 5 | 6 | sub empty { } 7 | 8 | sub naughty_secret { "I control the Bar" } 9 | 10 | sub test_inherit { "OK" } 11 | 12 | sub test_template 13 | { 14 | return $_[0]->template('0'); 15 | } 16 | 17 | sub test_res_template 18 | { 19 | $_[0]->res->template('0'); 20 | } 21 | 22 | sub before_finalize 23 | { 24 | my $self = shift; 25 | $self->res->header('X-Controller' => 'Bar'); 26 | } 27 | 28 | sub test_persistence 29 | { 30 | my $self = shift; 31 | my $last = $self->last_value; 32 | $self->last_value($last + 1); 33 | 34 | return $last; 35 | } 36 | 37 | sub after_unrendered 38 | { 39 | my ($self, $match) = @_; 40 | 41 | $self->res->render('whoops'); 42 | } 43 | 44 | sub build 45 | { 46 | my $self = shift; 47 | my $r = $self->routes; 48 | 49 | $r->add("/empty", "Bar::empty"); 50 | $r->add("/blessed_bar", "Bar::blessed"); 51 | $r->add("/blessed_bar2", "bar#blessed"); 52 | } 53 | 54 | 1; 55 | 56 | -------------------------------------------------------------------------------- /t/module_load.t: -------------------------------------------------------------------------------- 1 | BEGIN { 2 | $ENV{KELP_REDEFINE} = 1; 3 | } 4 | 5 | use lib 't/lib'; 6 | use Kelp::Base -strict; 7 | use Kelp; 8 | use Test::More; 9 | use Test::Exception; 10 | 11 | my $app = Kelp->new; 12 | dies_ok { 13 | $app->load_module('Shibboleet'); 14 | }; 15 | 16 | # Check if Null module loads 17 | $app->load_module('Null', name => 'value'); 18 | pass 'Null module loaded'; 19 | 20 | # Direct 21 | $app->load_module('Plus', number => 2); 22 | is $app->plus(5), 7; 23 | 24 | # Via config 25 | my $bpp = Kelp->new; 26 | $bpp->config_hash->{modules_init}->{Plus} = { 27 | number => 3 28 | }; 29 | $bpp->load_module('Plus'); 30 | is $bpp->plus(5), 8; 31 | 32 | # Direct overrides 33 | my $cpp = Kelp->new; 34 | $cpp->config_hash->{modules_init}->{Plus} = { 35 | number => 3 36 | }; 37 | $cpp->load_module('Plus', number => 5); 38 | is $cpp->plus(5), 10; 39 | 40 | # Fully qualified module name 41 | my $dpp = Kelp->new; 42 | $dpp->config_hash->{modules_init}->{'MyApp::Module::Null'} = { 43 | number => 4 44 | }; 45 | $dpp->load_module('+MyApp::Module::Null'); 46 | is $dpp->plus(5), 9; 47 | 48 | done_testing; 49 | 50 | -------------------------------------------------------------------------------- /t/lib/CustomContext/Controller.pm: -------------------------------------------------------------------------------- 1 | package CustomContext::Controller; 2 | 3 | use Kelp::Base; 4 | use Carp; 5 | 6 | attr -context => sub { croak 'context is required' }; 7 | 8 | sub app 9 | { 10 | return $_[0]->context->app; 11 | } 12 | 13 | sub req 14 | { 15 | return $_[0]->context->req; 16 | } 17 | 18 | sub res 19 | { 20 | return $_[0]->context->res; 21 | } 22 | 23 | sub before_finalize 24 | { 25 | my $self = shift; 26 | $self->res->header('X-Final' => __PACKAGE__); 27 | } 28 | 29 | sub build 30 | { 31 | my $self = shift; 32 | return unless ref $self eq __PACKAGE__; 33 | 34 | my $app = $self->app; 35 | 36 | $app->add_route( 37 | '/a' => { 38 | to => 'bridge', 39 | bridge => 1, 40 | } 41 | ); 42 | $app->add_route('/a/b/c' => 'foo#test'); 43 | $app->add_route( 44 | '/a/b/e' => { 45 | to => 'foo#nested_psgi', 46 | psgi => 1, 47 | } 48 | ); 49 | $app->add_route('/b' => 'foo#test_template'); 50 | } 51 | 52 | sub bridge 53 | { 54 | return ref shift() eq __PACKAGE__; 55 | } 56 | 57 | 1; 58 | 59 | -------------------------------------------------------------------------------- /t/response_redirect.t: -------------------------------------------------------------------------------- 1 | use Kelp::Base -strict; 2 | 3 | use Kelp; 4 | use Kelp::Test; 5 | use HTTP::Request::Common; 6 | use Test::More tests => 8; 7 | 8 | my $app = Kelp->new(mode => 'test'); 9 | my $t = Kelp::Test->new(app => $app); 10 | 11 | $app->add_route('/test' => sub { shift->res->redirect_to('/example') }); 12 | $t->request(GET '/test') 13 | ->header_is('Location', '/example') 14 | ->code_is(302); 15 | 16 | $app->add_route('/catalogue/:id' => {to => sub { '?' }, name => 'catalogue', defaults => {id => 'all'}}); 17 | $app->add_route('/test2' => sub { shift->res->redirect_to('catalogue') }); 18 | $t->request(GET '/test2') 19 | ->header_is('Location', '/catalogue/all') 20 | ->code_is(302); 21 | 22 | $app->add_route('/test3' => sub { shift->res->redirect_to('catalogue', {id => 243}) }); 23 | $t->request(GET '/test3') 24 | ->header_is('Location', '/catalogue/243') 25 | ->code_is(302); 26 | 27 | $app->add_route('/test4' => sub { shift->res->redirect_to('catalogue', {}, 403) }); 28 | $t->request(GET '/test4') 29 | ->header_is('Location', '/catalogue/all') 30 | ->code_is(403); 31 | 32 | done_testing; 33 | 34 | -------------------------------------------------------------------------------- /t/module_config_get.t: -------------------------------------------------------------------------------- 1 | BEGIN { 2 | use FindBin '$Bin'; 3 | $ENV{KELP_CONFIG_DIR} = "$Bin/../conf"; 4 | } 5 | 6 | use Plack::Util; 7 | use Kelp::Base -strict; 8 | use Kelp::Module::Config; 9 | use Test::More; 10 | use Test::Exception; 11 | 12 | my $app = Plack::Util::inline_object( 13 | mode => sub { "test" }, 14 | path => sub { $ENV{KELP_CONFIG_DIR} } 15 | ); 16 | my $c = Kelp::Module::Config->new(app => $app); 17 | 18 | # Inject some test data into the config so we can test 19 | $c->data->{test} = { 20 | a => 1, 21 | b => 2, 22 | c => 'bin', 23 | d => {e => 3}, 24 | f => {g => {h => {i => 4}}} 25 | }; 26 | 27 | is $c->get('charset'), 'UTF-8'; 28 | is $c->get('modules_init.JSON.utf8'), 1; 29 | is $c->get('test.a'), 1; 30 | is $c->get('test.d.e'), 3; 31 | is $c->get('test.f.g.h.i'), 4; 32 | is_deeply $c->get('test.f.g.h'), {i => 4}; 33 | is $c->get(''), undef; 34 | is $c->get(), undef; 35 | 36 | is $c->get('test.d.f.g'), undef, 'path doesnt break when key does not exist'; 37 | is $c->get('test.d.f.g', 'woohoo'), 'woohoo', 'default is returned'; 38 | 39 | dies_ok { $c->get('test.b.c') } "Path breaks on invalid type"; 40 | 41 | done_testing; 42 | 43 | -------------------------------------------------------------------------------- /t/json-encode-error.t: -------------------------------------------------------------------------------- 1 | use Kelp::Base -strict; 2 | use Test::More; 3 | use Kelp::Test; 4 | use HTTP::Request::Common; 5 | use lib 't/lib'; 6 | use JsonError; 7 | 8 | my $app = JsonError->new; 9 | my $t = Kelp::Test->new(app => $app); 10 | 11 | # Check if json encoding does not cause json response enconding error (json 12 | # content type + non-reference body). This happened in the past because json 13 | # content type was set before encoding and not cleared when an error occured. 14 | 15 | subtest 'testing mode development' => sub { 16 | $app->mode('development'); 17 | 18 | $t->request(GET '/json') 19 | ->code_is(500) 20 | ->content_unlike(qr{Don't know how to handle non-json reference}); 21 | 22 | $t->request(GET '/forced-json') 23 | ->code_is(500) 24 | ->content_unlike(qr{Don't know how to handle non-json reference}); 25 | }; 26 | 27 | subtest 'testing mode deployment' => sub { 28 | $app->mode('deployment'); 29 | 30 | $t->request(GET '/json') 31 | ->code_is(500) 32 | ->content_like(qr{Five Hundred}); 33 | 34 | $t->request(GET '/forced-json') 35 | ->code_is(500) 36 | ->content_like(qr{Five Hundred}); 37 | }; 38 | 39 | done_testing; 40 | 41 | -------------------------------------------------------------------------------- /t/routes_controller.t: -------------------------------------------------------------------------------- 1 | use lib 't/lib'; 2 | use Kelp::Base -strict; 3 | use MyApp2; 4 | use Kelp::Test; 5 | use HTTP::Request::Common; 6 | use Test::More; 7 | 8 | # Get the app 9 | my $app = MyApp2->new( 10 | __config => { 11 | modules_init => { 12 | Routes => { 13 | rebless => 1, 14 | base => 'MyApp2::Controller', 15 | } 16 | } 17 | } 18 | ); 19 | 20 | $app->routes->add('/inline', sub { "OK" }); 21 | 22 | # Test object 23 | my $t = Kelp::Test->new(app => $app); 24 | 25 | $t->request_ok(GET '/inline') 26 | ->content_is("OK"); 27 | 28 | $t->request_ok(GET '/blessed') 29 | ->content_is('MyApp2::Controller'); 30 | 31 | $t->request_ok(GET '/blessed_bar') 32 | ->content_is('MyApp2::Controller::Bar'); 33 | 34 | $t->request_ok(GET '/blessed_bar2') 35 | ->content_is('MyApp2::Controller::Bar'); 36 | 37 | $t->request_ok(GET '/test_inherit') 38 | ->content_is('OK'); 39 | 40 | $t->request_ok(GET '/test_module') 41 | ->content_is('UTF-8'); 42 | 43 | $t->request_ok(GET '/test_template') 44 | ->header_is('X-Controller' => 'Bar') 45 | ->content_like(qr/confession: I control the Bar/); 46 | 47 | $t->request_ok(GET '/test_res_template') 48 | ->header_is('X-Controller' => 'Bar') 49 | ->content_like(qr/confession: I control the Bar/); 50 | 51 | $t->request_ok(GET '/empty') 52 | ->content_is('whoops'); 53 | 54 | done_testing; 55 | 56 | -------------------------------------------------------------------------------- /t/module_config.t: -------------------------------------------------------------------------------- 1 | 2 | # Allow the redefining of globs at Kelp::Module 3 | BEGIN { 4 | $ENV{KELP_REDEFINE} = 1; 5 | } 6 | 7 | use Kelp::Base -strict; 8 | use Kelp::Module::Config; 9 | use Plack::Util; 10 | use FindBin '$Bin'; 11 | use Test::More; 12 | use Test::Exception; 13 | 14 | # Basic 15 | my $app = Plack::Util::inline_object( 16 | mode => sub { "test" } 17 | ); 18 | my $c = Kelp::Module::Config->new(app => $app); 19 | isa_ok $c, 'Kelp::Module::Config'; 20 | 21 | # No file 22 | $c->data({C => 'baz'}); 23 | $c->path("$Bin/conf/missing"); 24 | $c->build(); 25 | is_deeply($c->data, {C => 'baz'}); 26 | 27 | # Single file 28 | $c->data({C => 'baz'}); 29 | $c->path("$Bin/conf/a"); 30 | $c->build(); 31 | is_deeply($c->data, {A => 'bar', B => 'foo', C => 'baz'}); 32 | 33 | # Main + Mode file 34 | $c->data({C => 'baz'}); 35 | $c->path("$Bin/conf/b"); 36 | $c->build(); 37 | is_deeply($c->data, {A => 'bar', B => 'new', C => 'baz'}); 38 | 39 | # Mode file only 40 | $c->data({C => 'baz'}); 41 | $c->path("$Bin/conf/c"); 42 | $c->build(); 43 | is_deeply($c->data, {B => 'new', C => 'baz'}); 44 | 45 | # Syntax error 46 | $c->data({C => 'baz'}); 47 | $c->path("$Bin/conf/e"); 48 | dies_ok { $c->build() }; 49 | 50 | # Does not return a hash 51 | $c->data({C => 'baz'}); 52 | $c->path("$Bin/conf/f"); 53 | dies_ok { $c->build() }; 54 | 55 | # Access to the app 56 | $c->data({}); 57 | $c->path("$Bin/conf/g"); 58 | $c->build(); 59 | is_deeply($c->data, {mode => 'test'}); 60 | 61 | done_testing; 62 | -------------------------------------------------------------------------------- /t/test_request.t: -------------------------------------------------------------------------------- 1 | use Kelp::Base -strict; 2 | 3 | use Kelp; 4 | use Kelp::Test; 5 | use Test::More; 6 | use Test::Deep; 7 | use HTTP::Request::Common; 8 | use URI::Escape; 9 | 10 | my $app = Kelp->new(mode => 'test'); 11 | my $t = Kelp::Test->new(app => $app); 12 | 13 | # Request 14 | { 15 | $app->add_route('/a' => sub { 1 }); 16 | $t->request_ok(GET '/a'); 17 | $t->request(GET '//a')->code_isnt(200); 18 | } 19 | 20 | # Cookies 21 | { 22 | my $cookie_val = 'kelper'; 23 | my $user_cookie_name = '???='; 24 | my $user_cookie_val = 'what?;value&'; 25 | 26 | # A route to set a cookie 27 | $app->add_route( 28 | '/auth', 29 | sub { 30 | $_[0]->res->cookies->{foo} = $cookie_val; 31 | 'OK'; 32 | } 33 | ); 34 | 35 | # A route to expect a cookie 36 | $app->add_route( 37 | '/user/:name', 38 | sub { 39 | $_[0]->req->cookies->{$_[1]}; 40 | } 41 | ); 42 | 43 | $t->cookies->set_cookie(undef, $user_cookie_name, $user_cookie_val); 44 | $t->request_ok(GET '/auth'); 45 | $t->request_ok(GET '/user/foo')->content_is($cookie_val); 46 | $t->request_ok(GET '/user/' . uri_escape($user_cookie_name))->content_is($user_cookie_val); 47 | 48 | # check if tester itself handles cookies 49 | is_deeply 50 | [$t->cookies->get_cookies(undef, 'foo', $user_cookie_name)], 51 | [$cookie_val, $user_cookie_val], 52 | 'user cookies ok' 53 | ; 54 | } 55 | 56 | done_testing; 57 | 58 | -------------------------------------------------------------------------------- /lib/Kelp/templates/kelp/lib-PATH-FILE.pm.gen: -------------------------------------------------------------------------------- 1 | package [% name %]; 2 | use Kelp::Base 'Kelp'; 3 | 4 | # you probably want the strings in this file to be automatically utf8-decoded. 5 | # Kelp will handle request and response encoding for you, so you should use 6 | # wide characters unless you configure its charset to undefined 7 | use utf8; 8 | 9 | sub before_dispatch { 10 | # overriding this method disables access logs 11 | } 12 | 13 | sub build { 14 | my $self = shift; 15 | my $r = $self->routes; 16 | 17 | $r->add('/', 'welcome'); 18 | 19 | $r->add('/routes', { 20 | method => 'GET', 21 | to => 'list_routes', 22 | }); 23 | 24 | $r->add('/hello', sub { 'Hello World!' }); 25 | } 26 | 27 | sub list_routes { 28 | my $self = shift; 29 | 30 | my @routes = map { 31 | { 32 | method => $_->method // '*', 33 | route => $_->pattern, 34 | handler => ref($_->to) eq 'CODE' ? '(anonymous)' : $_->to, 35 | } 36 | } grep { 37 | not $_->bridge 38 | } @{$self->routes->routes}; 39 | 40 | return \@routes; 41 | } 42 | 43 | sub welcome { 44 | my $self = shift; 45 | 46 | use Data::Dumper; 47 | my $config = Data::Dumper->new([$self->config_hash], ['config']); 48 | $config->Indent(1); 49 | $config->Sortkeys(1); 50 | 51 | $self->template('welcome', { 52 | name => __PACKAGE__, 53 | routes => $self->list_routes, 54 | config => $config->Dump, 55 | }); 56 | } 57 | 58 | 1; 59 | 60 | -------------------------------------------------------------------------------- /t/module_logger.t: -------------------------------------------------------------------------------- 1 | 2 | # Allow the redefining of globs at Kelp::Module 3 | BEGIN { 4 | $ENV{KELP_REDEFINE} = 1; 5 | } 6 | 7 | use Kelp::Base -strict; 8 | use Kelp; 9 | use Kelp::Test; 10 | use Test::More; 11 | use HTTP::Request::Common; 12 | use Path::Tiny qw(tempfile); 13 | 14 | subtest 'testing log levels' => sub { 15 | my $app = Kelp->new(mode => 'nomod'); 16 | my $m = $app->load_module('Logger'); 17 | 18 | isa_ok $m, "Kelp::Module::Logger"; 19 | can_ok $app, $_ for qw/error debug info logger/; 20 | 21 | my $t = Kelp::Test->new(app => $app); 22 | $app->add_route( 23 | '/log', 24 | sub { 25 | my $self = shift; 26 | $self->debug("Debug message"); 27 | $self->error("Error message"); 28 | $self->info("Info message"); 29 | $self->logger('critical', "Critical message"); 30 | "ok"; 31 | } 32 | ); 33 | $t->request(GET '/log')->code_is(200); 34 | }; 35 | 36 | subtest 'testing log output' => sub { 37 | my $app = Kelp->new(mode => 'nomod'); 38 | my $file = tempfile; 39 | my $m = $app->load_module( 40 | 'Logger', 41 | outputs => [ 42 | [ 43 | 'File', 44 | min_level => 'debug', 45 | filename => "$file", 46 | ], 47 | ] 48 | ); 49 | 50 | $app->logger(info => 'test logging output'); 51 | my $contents = $file->slurp; 52 | like $contents, qr/test logging output/, 'log message ok'; 53 | note $contents; 54 | }; 55 | 56 | done_testing; 57 | 58 | -------------------------------------------------------------------------------- /t/persistent_controllers.t: -------------------------------------------------------------------------------- 1 | $ENV{KELP_REDEFINE} = 1; 2 | use lib 't/lib'; 3 | use Kelp::Base -strict; 4 | use MyApp2; 5 | use Kelp::Test; 6 | use HTTP::Request::Common; 7 | use Test::More; 8 | 9 | subtest 'testing without persistence' => sub { 10 | 11 | # Get the app 12 | my $app = MyApp2->new( 13 | __config => { 14 | modules_init => { 15 | Routes => { 16 | rebless => 1, 17 | base => 'MyApp2::Controller', 18 | } 19 | } 20 | } 21 | ); 22 | 23 | my $t = Kelp::Test->new(app => $app); 24 | 25 | $t->request_ok(GET '/persistence') 26 | ->content_is(1); 27 | 28 | $t->request_ok(GET '/persistence') 29 | ->content_is(1); 30 | 31 | $t->request_ok(GET '/persistence') 32 | ->content_is(1); 33 | }; 34 | 35 | subtest 'testing with persistence' => sub { 36 | 37 | # Get the app 38 | my $app = MyApp2->new( 39 | __config => { 40 | persistent_controllers => 1, 41 | modules_init => { 42 | Routes => { 43 | rebless => 1, 44 | base => 'MyApp2::Controller', 45 | } 46 | } 47 | } 48 | ); 49 | 50 | my $t = Kelp::Test->new(app => $app); 51 | 52 | $t->request_ok(GET '/persistence') 53 | ->content_is(1); 54 | 55 | $t->request_ok(GET '/persistence') 56 | ->content_is(2); 57 | 58 | $t->request_ok(GET '/persistence') 59 | ->content_is(3); 60 | }; 61 | 62 | done_testing; 63 | 64 | -------------------------------------------------------------------------------- /t/request_session.t: -------------------------------------------------------------------------------- 1 | use Kelp::Base -strict; 2 | use Kelp::Test; 3 | use Kelp; 4 | use Test::More; 5 | use HTTP::Request::Common; 6 | 7 | my $has_session = eval { 8 | require Plack::Middleware::Session; 9 | 1; 10 | }; 11 | 12 | plan skip_all => 'These tests require Plack::Middleware::Session' 13 | unless $has_session; 14 | 15 | my $app = Kelp->new( 16 | mode => 'test', 17 | __config => {middleware => ['Session']} 18 | ); 19 | my $t = Kelp::Test->new(app => $app); 20 | 21 | #ok $app->can('session'); 22 | 23 | $app->add_route( 24 | '/session', 25 | sub { 26 | my $r = $_[0]->req; 27 | my $s = $r->env->{'psgix.session'}; 28 | is_deeply $r->session(bar => 'foo'), {bar => 'foo'}; 29 | is $r->session('bar'), 'foo'; 30 | is $s->{'bar'}, 'foo'; 31 | 32 | delete $r->session->{bar}; 33 | is $r->session('bar'), undef; 34 | 35 | $r->session(bar => 'foo', baz => 'goo'); 36 | is $r->session('bar'), 'foo'; 37 | is $r->session('baz'), 'goo'; 38 | 39 | is $s->{'bar'}, 'foo'; 40 | is $s->{'baz'}, 'goo'; 41 | 42 | $r->session(faa => 'taa'); 43 | is_deeply $s, { 44 | bar => 'foo', 45 | baz => 'goo', 46 | faa => 'taa' 47 | }; 48 | 49 | $r->session({}); 50 | is_deeply $r->session, {}; 51 | is_deeply $r->env->{'psgix.session'}, {}; 52 | 53 | return 'All OK'; 54 | } 55 | ); 56 | 57 | $t->request(GET '/session') 58 | ->code_is(200) 59 | ->content_is('All OK'); 60 | 61 | done_testing; 62 | 63 | -------------------------------------------------------------------------------- /t/module.t: -------------------------------------------------------------------------------- 1 | 2 | use Kelp::Base -strict; 3 | 4 | use Kelp; 5 | use Kelp::Module; 6 | use Test::More; 7 | use Test::Exception; 8 | use Plack::Util; 9 | 10 | dies_ok { Kelp::Module->new() } "Dies when no app"; 11 | 12 | my %types = ( 13 | hash => {bar => 'foo'}, 14 | array => [9, 8, 7], 15 | object => Plack::Util::inline_object(something => sub { 1 }), 16 | code => sub { "Moo!" } 17 | ); 18 | 19 | my $app = Kelp->new(mode => 'test'); 20 | my $m = Kelp::Module->new(app => $app); 21 | isa_ok $m, 'Kelp::Module'; 22 | 23 | # Register 24 | for my $name (keys %types) { 25 | my $type = $types{$name}; 26 | $m->register($name => $type); 27 | can_ok $app, $name; 28 | 29 | if (ref $type eq 'CODE') { 30 | is $app->$name, $type->(), "CODE checks out"; 31 | } 32 | else { 33 | is_deeply $app->$name, $type, ref($type) . " checks out"; 34 | } 35 | } 36 | 37 | # Redefine 38 | for my $name (keys %types) { 39 | my $type = $types{$name}; 40 | 41 | # Redefine 'em all one by one. 42 | for my $t (values %types) { 43 | dies_ok { $m->register($name => $t) } 44 | "Dies when redefining " . ref $t; 45 | } 46 | 47 | # Now allow redefining and do it again 48 | $ENV{KELP_REDEFINE} = 1; 49 | for my $t (values %types) { 50 | $m->register($name => $t); 51 | if (ref $t eq 'CODE') { 52 | is $app->$name, $t->(), "Redefines CODE"; 53 | } 54 | else { 55 | is ref $app->$name, ref $t, "Redefines " . ref $t; 56 | } 57 | } 58 | $ENV{KELP_REDEFINE} = 0; 59 | } 60 | 61 | done_testing; 62 | -------------------------------------------------------------------------------- /t/params.t: -------------------------------------------------------------------------------- 1 | use Kelp::Base -strict; 2 | 3 | use Kelp; 4 | use Kelp::Test -utf8; 5 | use Test::More; 6 | use HTTP::Request::Common; 7 | use Encode; 8 | use URI::Escape; 9 | use utf8; 10 | 11 | my $app = Kelp->new(mode => 'test'); 12 | my $t = Kelp::Test->new(app => $app); 13 | 14 | $app->add_route( 15 | [POST => '/dump_params/:field'] => sub { 16 | my ($self, $field) = @_; 17 | my $req = $self->req; 18 | 19 | return { 20 | param => $req->param($field), 21 | query_param => $req->query_param($field), 22 | body_param => $req->body_param($field), 23 | json_param => $req->json_param($field), 24 | }; 25 | } 26 | ); 27 | 28 | my $target = '/dump_params/fld?fld=query'; 29 | 30 | subtest 'testing normal request' => sub { 31 | $t->request( 32 | POST $target, 33 | 'Content-Type' => 'application/x-www-form-urlencoded', 34 | 'Content' => 'fld=body', 35 | )->code_is(200); 36 | 37 | $t->json_cmp( 38 | { 39 | param => 'body', 40 | query_param => 'query', 41 | body_param => 'body', 42 | json_param => undef, 43 | } 44 | ); 45 | }; 46 | 47 | subtest 'testing json request' => sub { 48 | $t->request( 49 | POST $target, 50 | 'Content-Type' => 'application/json', 51 | 'Content' => '{"fld": "json"}', 52 | )->code_is(200); 53 | 54 | $t->json_cmp( 55 | { 56 | param => 'json', 57 | query_param => 'query', 58 | body_param => undef, 59 | json_param => 'json', 60 | } 61 | ); 62 | }; 63 | 64 | done_testing; 65 | 66 | -------------------------------------------------------------------------------- /t/routes_invalid.t: -------------------------------------------------------------------------------- 1 | package Test; 2 | 1; 3 | 4 | use strict; 5 | use warnings; 6 | 7 | BEGIN { 8 | my $DOWARN = 0; 9 | $SIG{'__WARN__'} = sub { warn $_[0] if $DOWARN } 10 | } 11 | 12 | use Test::More; 13 | use Test::Exception; 14 | use Kelp::Routes; 15 | use Data::Dumper; 16 | 17 | my @cases = ( 18 | [qr/neither a string nor a coderef/, '/wrong_to1', {to => []}], 19 | [qr/neither a string nor a coderef/, '/wrong_to2', {to => {}}], 20 | [qr/missing/, '/wrong_to3', {to => undef}], 21 | [qr/function 'missing' does not exist/, '/wrong_to4', 'missing'], 22 | [qr/function 'missing' does not exist/, '/wrong_to5', {to => 'missing'}], 23 | [qr/function '1' does not exist/, '/wrong_to6', {to => 1}], 24 | [qr/Can't locate Bar\/_Foo.pm /, '/wrong_to6', {to => 'Bar::_Foo::x'}], 25 | [qr/method 'x' does not exist in class 'Test'/, '/wrong_to7', {to => 'Test::x'}], 26 | ); 27 | 28 | subtest 'testing with default fatal' => sub { 29 | my $r = Kelp::Routes->new; 30 | 31 | for my $case (@cases) { 32 | $r->add(@{$case}[1 .. $#$case]); 33 | } 34 | 35 | my $routes_count = @{$r->routes}; 36 | is $routes_count, 0, 'routes were not added ok'; 37 | 38 | if ($routes_count) { 39 | diag('existing routes: ' . Dumper($r->routes)); 40 | } 41 | }; 42 | 43 | subtest 'testing with fatal=1' => sub { 44 | my $r = Kelp::Routes->new(fatal => 1); 45 | 46 | for my $case (@cases) { 47 | throws_ok { $r->add(@{$case}[1 .. $#$case]) } $case->[0]; 48 | } 49 | 50 | my $routes_count = @{$r->routes}; 51 | is $routes_count, 0, 'routes were not added ok'; 52 | 53 | if ($routes_count) { 54 | diag('existing routes: ' . Dumper($r->routes)); 55 | } 56 | }; 57 | 58 | done_testing; 59 | 60 | -------------------------------------------------------------------------------- /lib/Kelp/Test/CookieJar.pm: -------------------------------------------------------------------------------- 1 | package Kelp::Test::CookieJar; 2 | 3 | use Kelp::Base; 4 | use URI::Escape; 5 | 6 | # Stripped-down HTTP::Cookies interface for testing purposes and proper url escaping 7 | 8 | attr cookies => sub { {} }; 9 | 10 | sub set_cookie 11 | { 12 | my ($self, undef, $name, $value) = @_; 13 | 14 | $self->cookies->{$name} = $value; 15 | return 1; 16 | } 17 | 18 | sub get_cookies 19 | { 20 | my ($self, undef, @names) = @_; 21 | 22 | my %ret; 23 | 24 | if (@names) { 25 | return $self->cookies->{$names[0]} 26 | unless wantarray; 27 | 28 | return map { $self->cookies->{$_} } @names; 29 | } 30 | else { 31 | return $self->cookies; 32 | } 33 | } 34 | 35 | sub clear 36 | { 37 | my ($self, undef, undef, $name) = @_; 38 | 39 | if ($name) { 40 | delete $self->cookies->{$name}; 41 | } 42 | else { 43 | %{$self->cookies} = (); 44 | } 45 | 46 | return $self; 47 | } 48 | 49 | sub add_cookie_header 50 | { 51 | my ($self, $request) = @_; 52 | 53 | my %c = %{$self->cookies}; 54 | my @vals = map { uri_escape($_) . '=' . uri_escape($c{$_}) } keys %c; 55 | $request->header(Cookie => join '; ', @vals); 56 | 57 | return $request; 58 | } 59 | 60 | sub extract_cookies 61 | { 62 | my ($self, $response) = @_; 63 | 64 | my @headers = split ', ', $response->header('Set-Cookie') // ''; 65 | foreach my $header (@headers) { 66 | my $cookie = (split /; /, $header)[0]; 67 | my ($name, $value) = split '=', $cookie; 68 | 69 | next unless defined $name && defined $value; 70 | $self->set_cookie(undef, uri_unescape($name), uri_unescape($value)); 71 | } 72 | 73 | return $response; 74 | } 75 | 76 | 1; 77 | 78 | -------------------------------------------------------------------------------- /tools/router_bench.pl: -------------------------------------------------------------------------------- 1 | use Kelp::Base -strict; 2 | use Kelp::Util; 3 | use Benchmark qw(cmpthese); 4 | 5 | # the depth of the path, but the number of bridges will be +1 6 | my $depth = @ARGV && $ARGV[0] =~ /^\d+$/ ? shift @ARGV : 0; 7 | my $path = join '', map { "/$_" } 1 .. $depth, 'handler'; 8 | 9 | { 10 | 11 | package TestApp; 12 | 13 | use Kelp::Base 'Kelp'; 14 | 15 | sub hello { 'hello' } 16 | sub hi { 'hi' } 17 | } 18 | 19 | my $app = TestApp->new; 20 | 21 | sub prepare_match 22 | { 23 | my $r = shift; 24 | return sub { $r->match($path) }; 25 | } 26 | 27 | sub prepare_dispatch 28 | { 29 | my $r = shift; 30 | my @routes = @{$r->match($path)}; 31 | 32 | return sub { $r->dispatch($app, $_) for @routes }; 33 | } 34 | 35 | my @classes = @ARGV; 36 | @classes = 'Kelp::Routes' if !@classes; 37 | 38 | my %cases; 39 | foreach my $class (@classes) { 40 | my $r = Kelp::Util::load_package($class)->new(base => 'TestApp'); 41 | 42 | my $tree_base = my $tree = []; 43 | 44 | for (1 .. $depth) { 45 | my $new_tree = []; 46 | push @{$tree}, "/$_" => { 47 | to => sub { 1 }, 48 | tree => $new_tree, 49 | }; 50 | 51 | $tree = $new_tree; 52 | } 53 | 54 | @{$tree} = ( 55 | '/handler' => 'hello', 56 | ); 57 | 58 | $r->add( 59 | '' => { 60 | to => sub { 1 }, 61 | tree => $tree_base, 62 | } 63 | ); 64 | 65 | say "$class matches: " . join ', ', map { '"' . $_->name . '"' } @{$r->match($path)}; 66 | $cases{"$class->match"} = prepare_match($r); 67 | $cases{"$class->dispatch"} = prepare_dispatch($r); 68 | } 69 | 70 | cmpthese - 2, \%cases; 71 | 72 | # benchmarks different implementations of Kelp::Routes 73 | # usage: ex/router_bench.pl [ ...] 74 | 75 | -------------------------------------------------------------------------------- /lib/Kelp/Module/JSON.pm: -------------------------------------------------------------------------------- 1 | package Kelp::Module::JSON; 2 | 3 | use Kelp::Base 'Kelp::Module::Encoder'; 4 | 5 | use JSON::MaybeXS; 6 | 7 | sub encoder_name { 'json' } 8 | 9 | sub build_encoder 10 | { 11 | my ($self, $args) = @_; 12 | return JSON::MaybeXS->new(%$args); 13 | } 14 | 15 | sub build 16 | { 17 | my ($self, %args) = @_; 18 | $self->SUPER::build(%args); 19 | 20 | $self->register(json => $self->get_encoder); 21 | } 22 | 23 | 1; 24 | 25 | __END__ 26 | 27 | =head1 NAME 28 | 29 | Kelp::Module::JSON - Simple JSON module for a Kelp application 30 | 31 | =head1 SYNOPSIS 32 | 33 | package MyApp; 34 | use Kelp::Base 'Kelp'; 35 | 36 | sub some_route { 37 | my $self = shift; 38 | 39 | # manually render a json configured to UTF-8 40 | $self->res->set_charset('UTF-8'); 41 | $self->res->render_binary( 42 | $self->json->encode({ yes => 1 }) 43 | ); 44 | } 45 | 46 | =head1 DESCRIPTION 47 | 48 | Standard JSON encoder/decoder. Chooses the best backend through L. 49 | 50 | =head1 REGISTERED METHODS 51 | 52 | This module registers only one method into the application: C. It also 53 | registers itself for later use by L under the name C. 54 | 55 | The module will try to use backends in this order: I. 56 | 57 | =head1 CAVEATS 58 | 59 | You should probably not use C, and just encode the value into a proper 60 | charset by hand. You may not always want to have encoded strings anyway, for 61 | example some interfaces may encode the values themselves. 62 | 63 | Kelp will use an internal copy of JSON encoder / decoder with all the same options 64 | but without C, reserved for internal use. Modifying C options at 65 | runtime will not cause the request / response encoding to change. 66 | 67 | =cut 68 | 69 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 |
2 |

logo

3 |

A web framework light, yet rich in nutrients

4 |
5 | 6 | Kelp is a Perl web framework focused on Plack application toolkit. It's lean, 7 | fast and extensible. [See our website](https://kelp-framework.github.io) for details. 8 | 9 | ## Installation 10 | Kelp is [distributed through CPAN](https://metacpan.org/release/Kelp). It can 11 | be installed through a local CPAN client, for example: 12 | 13 | ```sh 14 | cpanm Kelp 15 | ``` 16 | 17 | ## Documentation 18 | The Kelp manual can be viewed either online on 19 | [metacpan](https://metacpan.org/pod/Kelp::Manual) or offline by 20 | running a `perldoc Kelp::Manual` command. For detailed information, consult 21 | documentation pages for specific parts of Kelp. 22 | 23 | ## Bugs and feature requests 24 | Please use the Github's issue tracker to file both bugs and feature requests. 25 | 26 | ## Contributions 27 | Contributions to the project in form of Github's pull requests are welcome. 28 | Please make sure your code is in line with the general coding style of the 29 | module. Let us know via a github issue if you plan something bigger so we can 30 | talk it through. 31 | 32 | ### Author 33 | Stefan Geneshky 34 | 35 | ### Contributors 36 | In no particular order: 37 | 38 | Julio Fraire 39 | 40 | Maurice Aubrey 41 | 42 | David Steinbrunner 43 | 44 | Gurunandan Bhat 45 | 46 | Perlover 47 | 48 | Ruslan Zakirov 49 | 50 | Christian Froemmel (senfomat) 51 | 52 | Ivan Baidakou (basiliscos) 53 | 54 | roy-tate 55 | 56 | Konstantin Yakunin (@yakunink) 57 | 58 | Benjamin Hengst (notbenh) 59 | 60 | Nikolay Mishin (@mishin) 61 | 62 | Bartosz Jarzyna (bbrtj) 63 | 64 | ## License 65 | 66 | This framework is governed by the same license as Perl itself. 67 | 68 | -------------------------------------------------------------------------------- /t/new_anonymous.t: -------------------------------------------------------------------------------- 1 | package TestApp; 2 | 3 | use Kelp::Base 'Kelp'; 4 | 5 | sub hello { } 6 | 7 | 1; 8 | 9 | use Kelp::Base -strict; 10 | 11 | use Kelp; 12 | use Kelp::Test; 13 | use HTTP::Request::Common; 14 | use Test::More; 15 | use Test::Exception; 16 | use Scalar::Util qw(blessed refaddr); 17 | 18 | my ($app1, $app2); 19 | 20 | lives_ok sub { 21 | $app1 = TestApp->new_anon(mode => 'test'); 22 | $app2 = TestApp->new_anon(mode => 'test'); 23 | }, 24 | 'construction ok'; 25 | 26 | ok $app1, 'first anonymous app ok'; 27 | ok $app2, 'second anonymous app ok'; 28 | 29 | like blessed $app1, qr/^Kelp::Anonymous::/, 'first app class ok'; 30 | like blessed $app2, qr/^Kelp::Anonymous::/, 'second app class ok'; 31 | 32 | isa_ok $app1, 'TestApp'; 33 | isa_ok $app2, 'TestApp'; 34 | 35 | isnt refaddr $app1->routes, refaddr $app2->routes, 'not the same app routes ok'; 36 | unlike $app1->routes->base, qr/^Kelp::Anonymous::/, 'base ok'; 37 | 38 | $app1->routes->add('/', 'hello'); 39 | 40 | isnt 41 | scalar @{$app1->routes->routes}, 42 | scalar @{$app2->routes->routes}, 43 | 'routes storage ok'; 44 | 45 | is $app1->routes->routes->[0]->to, 'TestApp::hello', 'route destination ok'; 46 | 47 | # Check for possible string eval problems 48 | throws_ok sub { 49 | Kelp::new_anon(qq[';#\ndie 'not what was expected']); # <- try hack the class name 50 | }, 51 | qr/invalid class for new_anon/i, 52 | 'eval checks ok'; 53 | 54 | throws_ok sub { 55 | Kelp::new_anon(undef); # <- silly but possible usage 56 | }, 57 | qr/invalid class for new_anon/i, 58 | 'eval checks ok'; 59 | 60 | # The limitation is that we can't mix ->new and ->new_anon 61 | throws_ok sub { 62 | $app1 = Kelp->new(mode => 'test'); 63 | $app2 = Kelp->new_anon(mode => 'test'); 64 | }, 65 | qr/redefining of .+ not allowed/i, 66 | 'limitations ok'; 67 | 68 | done_testing; 69 | 70 | -------------------------------------------------------------------------------- /lib/Kelp/Routes/Controller.pm: -------------------------------------------------------------------------------- 1 | package Kelp::Routes::Controller; 2 | 3 | use Kelp::Base 'Kelp::Routes'; 4 | 5 | # the new Kelp::Routes does the Controller logic by itself, we just need to configure it correctly 6 | attr rebless => 1; 7 | 8 | 1; 9 | 10 | __END__ 11 | 12 | =pod 13 | 14 | =head1 NAME 15 | 16 | Kelp::Routes::Controller - Legacy routes and controller for Kelp 17 | 18 | =head1 SYNOPSIS 19 | 20 | # config.pl 21 | # --------- 22 | { 23 | modules_init => { 24 | Routes => { 25 | router => 'Controller', 26 | base => 'MyApp::Controller', 27 | } 28 | } 29 | } 30 | 31 | # MyApp/Controller.pm 32 | # ------------------- 33 | package MyApp::Controller; 34 | use Kelp::Base 'MyApp'; 35 | 36 | sub shared_method { 37 | my $self = shift; # $self is an instance of 'MyApp::Controller' 38 | ... 39 | } 40 | 41 | 42 | # MyApp/Controller/Users.pm 43 | # ------------------------- 44 | package MyApp::Controller::Users; 45 | use Kelp::Base 'MyApp::Controller'; 46 | 47 | sub read { 48 | my $self = shift; # $self is an instance of 'MyApp::Controller::Users' 49 | ... 50 | } 51 | 52 | 53 | =head1 DESCRIPTION 54 | 55 | B<< This module is no longer needed, since L handles reblessing 56 | by itself when configured with C. It's only here for backward 57 | compatibility and documentation purposes. >> 58 | 59 | This router module reblesses a Kelp application into its own controller class. 60 | This allows you to structure your web application in a classic object oriented 61 | fashion, having C<$self> an instance to the current class rather than the main 62 | web application. 63 | 64 | You must create a main I class which inherits from Kelp. Each 65 | subsequent class can inherit from this class, taking advantage of any common 66 | functionality. 67 | 68 | 69 | =cut 70 | 71 | -------------------------------------------------------------------------------- /.mailmap: -------------------------------------------------------------------------------- 1 | # Mailmap for git contributors dzil plugin (shown on CPAN) 2 | # Emails from CPAN if possible, to have links to profiles on metacpan 3 | 4 | Stefan Geneshky Stefan Geneshky 5 | Stefan Geneshky Stefan G. 6 | Stefan Geneshky Stefan G 7 | Stefan Geneshky Stefan G 8 | Stefan Geneshky Stefan G 9 | Stefan Geneshky Stefan G6Y 10 | Stefan Geneshky Stefan Geneshky 11 | Stefan Geneshky Stefan Geneshky 12 | Stefan Geneshky Sefan G 13 | Stefan Geneshky minimalist 14 | 15 | Bartosz Jarzyna bbrtj 16 | Bartosz Jarzyna brtastic 17 | Bartosz Jarzyna Bartosz Jarzyna <44323413+bbrtj@users.noreply.github.com> 18 | Bartosz Jarzyna brtastic <44323413+brtastic@users.noreply.github.com> 19 | 20 | Konstantin Yakunin Konstantin Yakunin 21 | Konstantin Yakunin Konstantin Yakunin 22 | Konstantin Yakunin Konstantin Yakunin 23 | 24 | Ivan Baidakou Ivan Baidakou 25 | 26 | Maurice Aubrey Maurice Aubrey 27 | 28 | Николай Мишин Nikolay Mishin 29 | 30 | Sergiy Borodych Sergiy Borodych 31 | 32 | Gurunandan Bhat Gurunandan R. Bhat 33 | 34 | Julio Fraire Domínguez Julio Fraire 35 | 36 | -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: Perl 2 | 3 | on: 4 | push: 5 | pull_request: 6 | 7 | jobs: 8 | test: 9 | strategy: 10 | fail-fast: false 11 | matrix: 12 | runner: [ubuntu-latest, macos-latest, windows-latest] 13 | perl: [ '5.14', '5.30', '5.40' ] 14 | exclude: 15 | - runner: windows-latest 16 | perl: '5.14' 17 | - runner: windows-latest 18 | perl: '5.40' 19 | 20 | runs-on: ${{matrix.runner}} 21 | name: OS ${{matrix.runner}} Perl ${{matrix.perl}} 22 | 23 | steps: 24 | - uses: actions/checkout@v3 25 | 26 | - name: Set up perl 27 | uses: shogo82148/actions-setup-perl@v1 28 | with: 29 | perl-version: ${{ matrix.perl }} 30 | distribution: ${{ ( startsWith( matrix.runner, 'windows-' ) && 'strawberry' ) || 'default' }} 31 | 32 | - name: Show Perl Version 33 | run: | 34 | perl -v 35 | cpanm -v 36 | 37 | - name: Check if the code is tidy 38 | if: ${{ startsWith(matrix.runner, 'ubuntu-') && startsWith(matrix.perl, '5.40') }} 39 | run: | 40 | cpanm --notest Perl::Tidy Code::TidyAll 41 | tidyall -a --check-only 42 | - name: Install dependencies 43 | run: | 44 | cpanm --installdeps --notest . 45 | - name: Show Errors on Windows 46 | if: ${{ failure() && startsWith(matrix.runner, 'windows-') }} 47 | run: | 48 | ls -l C:/Users/ 49 | ls -l C:/Users/RUNNER~1/ 50 | cat C:/Users/runneradmin/.cpanm/work/*/build.log 51 | - name: Show Errors on Ubuntu 52 | if: ${{ failure() && startsWith(matrix.runner, 'ubuntu-') }} 53 | run: | 54 | cat /home/runner/.cpanm/work/*/build.log 55 | - name: Show Errors on OSX 56 | if: ${{ failure() && startsWith(matrix.runner, 'macos-') }} 57 | run: | 58 | cat /Users/runner/.cpanm/work/*/build.log 59 | - name: Run tests 60 | env: 61 | AUTHOR_TESTING: 1 62 | RELEASE_TESTING: 1 63 | run: | 64 | prove -l -r t/ 65 | 66 | -------------------------------------------------------------------------------- /lib/Kelp/Middleware.pm: -------------------------------------------------------------------------------- 1 | package Kelp::Middleware; 2 | 3 | use Kelp::Base; 4 | use Plack::Util; 5 | use Kelp::Util; 6 | use Carp; 7 | 8 | attr -app => sub { croak 'app is required' }; 9 | 10 | sub wrap 11 | { 12 | my ($self, $psgi) = @_; 13 | 14 | if (defined(my $middleware = $self->app->config('middleware'))) { 15 | for my $class (@$middleware) { 16 | 17 | # Make sure the middleware was not already loaded 18 | # This does not apply for testing, in which case we want 19 | # the middleware to wrap every single time 20 | next if $self->{_loaded_middleware}->{$class}++ && !$ENV{KELP_TESTING}; 21 | 22 | my $mw = Plack::Util::load_class($class, 'Plack::Middleware'); 23 | my $args = $self->app->config("middleware_init.$class") // {}; 24 | 25 | Kelp::Util::_DEBUG(modules => "Wrapping app in $mw middleware with args: ", $args); 26 | 27 | $psgi = $mw->wrap($psgi, %$args); 28 | } 29 | } 30 | 31 | return $psgi; 32 | } 33 | 34 | 1; 35 | 36 | __END__ 37 | 38 | =pod 39 | 40 | =head1 NAME 41 | 42 | Kelp::Middleware - Kelp app wrapper (PSGI middleware) 43 | 44 | =head1 SYNOPSIS 45 | 46 | middleware => [qw(TrailingSlashKiller Static)], 47 | middleware_init => { 48 | TrailingSlashKiller => { 49 | redirect => 1, 50 | }, 51 | Static => { 52 | path => qr{^/static}, 53 | root => '.', 54 | }, 55 | } 56 | 57 | =head1 DESCRIPTION 58 | 59 | This is a small helper class which wraps Kelp in PSGI middleware. It is loaded 60 | and constructed by Kelp based on the value of L (class 61 | name). 62 | 63 | This class only handles global middleware declared in configuration. Middleware 64 | localized to routes cannot be adjusted by customizing this class. 65 | 66 | =head1 ATTRIBUTES 67 | 68 | =head2 app 69 | 70 | Main application object. Required. 71 | 72 | =head1 METHODS 73 | 74 | =head2 wrap 75 | 76 | $wrapped_psgi = $object->wrap($psgi) 77 | 78 | Wraps the object in all middlewares according to L configuration. 79 | 80 | -------------------------------------------------------------------------------- /t/pattern_cache.t: -------------------------------------------------------------------------------- 1 | 2 | use strict; 3 | use warnings; 4 | use v5.10; 5 | 6 | use Test::More; 7 | use Kelp; 8 | use Kelp::Routes::Pattern; 9 | use Kelp::Test; 10 | use HTTP::Request::Common; 11 | 12 | my $app = Kelp->new(mode => 'test', modules => ['JSON']); 13 | my $t = Kelp::Test->new(app => $app); 14 | 15 | # param 16 | $app->add_route( 17 | '/test/:a/:b', 18 | sub { 19 | my ($self, $a, $b) = @_; 20 | sprintf('%s-%s-%s-%s', $a, $b, $self->named('a'), $self->named('b')); 21 | } 22 | ); 23 | 24 | srand; 25 | for (1 .. 10) { 26 | my $a = int(rand(500)); 27 | my $b = int(rand(500)); 28 | $t->request(POST "/test/$a/$b")->content_is("$a-$b-$a-$b"); 29 | } 30 | 31 | $app->add_route( 32 | '/test2/:i', 33 | sub { 34 | $_[0]->param('b') . $_[1]; 35 | } 36 | ); 37 | 38 | for (1 .. 10) { 39 | my $b = int(rand(500)); 40 | $t->request( 41 | POST "/test2/1", 42 | 'Content-Type' => 'application/json', 43 | 'Content' => sprintf('{"b":%i}', $b) 44 | )->content_is("${b}1"); 45 | $t->request(POST "/test2/1", [b => $b])->content_is("${b}1"); 46 | } 47 | 48 | # param 49 | $app->add_route( 50 | '/test3/:n', 51 | sub { 52 | my ($self, $n) = @_; 53 | if ($n == 1) { 54 | [sort($self->param)]; 55 | } 56 | elsif ($n == 2) { 57 | my %h = map { $_ => $self->param($_) } $self->param; 58 | return \%h; 59 | } 60 | } 61 | ); 62 | $t->request( 63 | POST '/test3/1', 64 | 'Content-Type' => 'application/json', 65 | 'Content' => '{"a":"bar","b":"foo"}' 66 | ) 67 | ->code_is(200) 68 | ->json_cmp(['a', 'b'], "Get JSON list of params"); 69 | 70 | $t->request( 71 | POST '/test3/2', 72 | 'Content-Type' => 'application/json', 73 | 'Content' => '{"a":"bar","b":"foo"}' 74 | ) 75 | ->code_is(200) 76 | ->json_cmp({a => "bar", b => "foo"}, "Get JSON struct of params"); 77 | 78 | $t->request(POST '/test3/1', [a => "bar", b => "foo"]) 79 | ->code_is(200) 80 | ->json_cmp(['a', 'b'], "Get POST list of params"); 81 | 82 | $t->request(POST '/test3/2', [a => "bar", b => "foo"]) 83 | ->code_is(200) 84 | ->json_cmp({a => "bar", b => "foo"}, "Get POST struct of params"); 85 | 86 | done_testing; 87 | -------------------------------------------------------------------------------- /t/run_bridge.t: -------------------------------------------------------------------------------- 1 | use Kelp::Base -strict; 2 | 3 | use Kelp; 4 | use Kelp::Test; 5 | use HTTP::Request::Common; 6 | use Test::More; 7 | 8 | my $app = Kelp->new(mode => 'test'); 9 | $app->routes->base("main"); 10 | my $t = Kelp::Test->new(app => $app); 11 | 12 | # Bridge 13 | $app->add_route( 14 | "/bridge" => { 15 | to => "bridge", 16 | tree => [ 17 | "/route" => "bridge_route", 18 | "/render_route" => "bridge_route_render", 19 | ] 20 | } 21 | ); 22 | $t->request(GET '/bridge')->code_is(403); 23 | $t->request(GET '/bridge/route')->code_is(403); 24 | $t->request(GET '/bridge/route?code=404')->code_is(404); 25 | $t->request(GET '/bridge/not_existing_route?ok=1')->code_is(404); 26 | 27 | $t->request(GET '/bridge/route?ok=1') 28 | ->code_is(200) 29 | ->content_is("We like milk."); 30 | 31 | # if a bridge renders a response, no other handlers should be executed even 32 | # if the return value is true 33 | $t->request(GET '/bridge/render_route?code=403&ok=1') 34 | ->code_is(403) 35 | ->content_is("ok"); 36 | 37 | # render inside bridge 38 | $app->add_route( 39 | "/render" => { 40 | to => sub { 41 | $_[0]->res->set_code(700)->render('auth'); 42 | }, 43 | bridge => 1 44 | } 45 | ); 46 | 47 | $t->request(GET '/render') 48 | ->code_is(700) 49 | ->content_is('auth'); 50 | 51 | # Redirect inside bridge 52 | $app->add_route('/auth' => sub { 'auth' }); 53 | $app->add_route( 54 | '/redirect' => { 55 | to => sub { $_[0]->res->redirect_to('/auth'); 0 }, 56 | tree => [ 57 | '/dead' => sub { 'you should not see this' } 58 | ] 59 | } 60 | ); 61 | 62 | $t->request(GET '/redirect/dead') 63 | ->code_is(302) 64 | ->header_like(location => qr{/auth$}); 65 | 66 | done_testing; 67 | 68 | sub bridge 69 | { 70 | my $self = shift; 71 | $self->req->stash->{info} = "We like milk."; 72 | if (my $code = $self->param('code')) { 73 | $self->res->set_code($code)->render("ok"); 74 | } 75 | return $self->param('ok'); 76 | } 77 | 78 | sub bridge_route 79 | { 80 | my $self = shift; 81 | return $self->req->stash->{info}; 82 | } 83 | 84 | sub bridge_route_render 85 | { 86 | my $self = shift; 87 | $self->res->render($self->req->stash->{info}); 88 | } 89 | 90 | -------------------------------------------------------------------------------- /t/base.t: -------------------------------------------------------------------------------- 1 | 2 | package B1; 3 | use Kelp::Base; 4 | 5 | attr bar => 1; 6 | attr foo => sub { {a => 1} }; 7 | attr baz => sub { [1, 2, 3, 4] }; 8 | attr bat => sub { 9 | $_[0]->bar($_[0]->bar + 1); 10 | $_[0]->bar; 11 | }; 12 | attr color => sub { $_[0]->_build_color }; 13 | attr -ro => 9; 14 | attr un => sub { undef }; 15 | 16 | sub _build_color { "red" } 17 | 18 | package B2; 19 | use Kelp::Base 'B1'; 20 | 21 | attr bar => 10; 22 | sub _build_color { "green" } 23 | 24 | package B3; 25 | use Kelp::Base 'B2'; 26 | 27 | attr bar => 100; 28 | sub _build_color { "blue" } 29 | 30 | package C1; 31 | use Kelp::Base -strict; 32 | sub new { bless {}, $_[0] } 33 | 34 | package main; 35 | use Test::More; 36 | 37 | my $o = B1->new; 38 | 39 | isa_ok $o, 'B1'; 40 | can_ok $o, qw/bar foo baz bat ro un/; 41 | is $o->bar, 1; 42 | is_deeply $o->foo, {a => 1}; 43 | is_deeply $o->baz, [1, 2, 3, 4]; 44 | is $o->bat, 2; 45 | is $o->bat, 2; 46 | 47 | # undef 48 | is $o->un, undef; 49 | $o->un(1); 50 | is $o->un, 1; 51 | $o->un(undef); 52 | is $o->un, undef; 53 | 54 | $o->bar(3); 55 | is $o->bar, 3; 56 | 57 | $o->foo({a => 2}); 58 | is_deeply $o->foo, {a => 2}; 59 | 60 | $o->baz({b => 2}); 61 | is_deeply $o->baz, {b => 2}; 62 | 63 | is $o->color, "red"; 64 | 65 | # Readonly 66 | is $o->ro, 9; 67 | $o->ro(10); 68 | is $o->ro, 9; 69 | 70 | my $oo = B1->new(ro => 6); 71 | is $oo->ro, 6; 72 | $oo->ro(7); 73 | is $oo->ro, 6; 74 | 75 | my $p = B2->new; 76 | isa_ok $p, 'B2'; 77 | ok $p->can($_) for qw/bar foo baz bat/; 78 | 79 | is $p->bar, 10; 80 | is_deeply $p->foo, {a => 1}; 81 | is_deeply $p->baz, [1, 2, 3, 4]; 82 | is $p->bat, 11; 83 | is $p->bat, 11; 84 | 85 | is $p->color, "green"; 86 | 87 | my $q = B2->new(bar => 20, baz => {a => 6}); 88 | is $q->bar, 20; 89 | is_deeply $q->baz, {a => 6}; 90 | is $q->bat, 21; 91 | is $q->bat, 21; 92 | 93 | my $r = B3->new; 94 | isa_ok $r, 'B3'; 95 | ok $r->can($_) for qw/bar foo baz bat/; 96 | 97 | is $r->bar, 100; 98 | is $r->color, "blue"; 99 | 100 | my $pp = C1->new; 101 | ok !$pp->can('attr'); 102 | 103 | # Instantiate 2 ojects of the same class 104 | { 105 | my $x = B1->new; 106 | my $y = B1->new; 107 | $x->foo->{test} = 'present'; 108 | is $y->foo->{test}, undef; 109 | } 110 | 111 | done_testing; 112 | -------------------------------------------------------------------------------- /t/middleware.t: -------------------------------------------------------------------------------- 1 | use Kelp::Base -strict; 2 | 3 | use Kelp; 4 | use Kelp::Test; 5 | use HTTP::Request::Common; 6 | use Test::More; 7 | use Plack::Builder; 8 | 9 | my $app = Kelp->new(mode => 'test', __config => 1); 10 | $app->routes->base("main"); 11 | 12 | sub add_x_header 13 | { 14 | my $name = shift; 15 | sub { 16 | my $app = shift; 17 | return sub { 18 | my $ret = $app->($_[0]); 19 | push @{$ret->[1]}, "X_$name", 'OK'; 20 | return $ret; 21 | }; 22 | }; 23 | } 24 | 25 | $app->add_route('/mw', sub { "OK" }); 26 | 27 | $app->add_route( 28 | '/mw/*', { 29 | to => sub { 1 }, 30 | bridge => 1, 31 | psgi_middleware => builder { 32 | enable add_x_header('TestBridge'); 33 | Kelp->NEXT_APP; 34 | }, 35 | } 36 | ); 37 | 38 | $app->add_route( 39 | '/mw/2', { 40 | to => sub { "OK" }, 41 | psgi_middleware => builder { 42 | enable add_x_header('Test1'); 43 | Kelp->NEXT_APP; 44 | }, 45 | } 46 | ); 47 | 48 | $app->add_route( 49 | '/mw/2/3', { 50 | to => sub { "OK" }, 51 | psgi_middleware => builder { 52 | enable add_x_header('Test2'); 53 | Kelp->NEXT_APP; 54 | }, 55 | } 56 | ); 57 | 58 | my $t = Kelp::Test->new(app => $app); 59 | 60 | # No middleware 61 | $t->request(GET '/mw') 62 | ->header_is("X-Framework", "Perl Kelp"); 63 | 64 | # Add middleware 65 | $app->_cfg->merge( 66 | { 67 | middleware => ['XFramework', 'ContentLength'], 68 | middleware_init => { 69 | XFramework => { 70 | framework => 'Changed' 71 | } 72 | } 73 | } 74 | ); 75 | 76 | $t->request(GET '/mw') 77 | ->header_is("X-Framework", "Changed") 78 | ->header_is("Content-Length", 2); 79 | 80 | $t->request(GET '/mw/2') 81 | ->header_is("X-TestBridge", "OK") 82 | ->header_is("X-Test1", "OK") 83 | ->header_isnt("X-Test2", "OK") 84 | ->header_is("X-Framework", "Changed") 85 | ->header_is("Content-Length", 2); 86 | 87 | $t->request(GET '/mw/2/3') 88 | ->header_is("X-TestBridge", "OK") 89 | ->header_isnt("X-Test1", "OK") 90 | ->header_is("X-Test2", "OK") 91 | ->header_is("X-Framework", "Changed") 92 | ->header_is("Content-Length", 2); 93 | 94 | done_testing; 95 | 96 | -------------------------------------------------------------------------------- /t/less.t: -------------------------------------------------------------------------------- 1 | use Kelp::Test; 2 | use Kelp::Less mode => 'test'; 3 | use HTTP::Request::Common qw/GET PUT POST DELETE/; 4 | use Test::More; 5 | 6 | module 'JSON', utf8 => 1; 7 | module 'Template'; 8 | 9 | my $t = Kelp::Test->new(app => app); 10 | 11 | # route 12 | route '/route' => sub { "A" }; 13 | $t->request(GET '/route')->content_is("A"); 14 | $t->request(POST '/route')->content_is("A"); 15 | $t->request(PUT '/route')->content_is("A"); 16 | 17 | # get, post, put 18 | get '/get' => sub { "B" }; 19 | post '/post' => sub { "C" }; 20 | put '/put' => sub { "D" }; 21 | del '/del' => sub { "DD" }; 22 | $t->request(GET '/get')->content_is("B"); 23 | $t->request(POST '/get')->code_is(404); 24 | $t->request(GET '/post')->code_is(404); 25 | $t->request(POST '/post')->content_is("C"); 26 | $t->request(GET '/put')->code_is(404); 27 | $t->request(POST '/put')->code_is(404); 28 | $t->request(PUT '/put')->content_is("D"); 29 | $t->request(DELETE '/del')->content_is("DD"); 30 | $t->request(GET '/del')->code_is(404); 31 | 32 | # param 33 | route '/param' => sub { [sort(param())] }; 34 | $t->request(GET '/param?a=bar&b=foo')->json_cmp(['a', 'b']); 35 | route '/param2' => sub { param 'a' }; 36 | $t->request(GET '/param2?a=bar&b=foo')->content_is("bar"); 37 | 38 | # session 39 | route '/session' => sub { 40 | session(bar => 'foo'); 41 | is session('bar'), 'foo'; 42 | }; 43 | 44 | # stash 45 | route '/stash' => sub { stash->{a} = "E"; stash 'a' }; 46 | $t->request(GET '/stash')->content_is("E"); 47 | 48 | # named 49 | route '/named/:a' => sub { named 'a' }; 50 | $t->request(GET '/named/F')->content_is("F"); 51 | 52 | # req 53 | route '/req' => sub { ref(req) eq 'Kelp::Request' ? "G" : "FAIL" }; 54 | $t->request(POST '/req')->content_is("G"); 55 | 56 | # res 57 | route '/res' => sub { ref(res) eq 'Kelp::Response' ? "H" : "FAIL" }; 58 | $t->request(POST '/res')->content_is("H"); 59 | 60 | # template 61 | route '/template' => sub { template \"[% letter %]", {letter => 'I'} }; 62 | $t->request(GET '/template')->content_is("I"); 63 | 64 | # attr 65 | attr active => "J"; 66 | attr lazy => sub { app->active }; 67 | route '/attr' => sub { app->lazy }; 68 | $t->request(GET '/attr')->content_is("J"); 69 | 70 | # sub 71 | route '/sub' => 'func'; 72 | sub func { "K" } 73 | $t->request(GET '/sub')->content_is("K"); 74 | 75 | # config 76 | route '/config' => sub { config('charset') }; 77 | $t->request(GET '/config')->content_is('UTF-8'); 78 | 79 | done_testing; 80 | -------------------------------------------------------------------------------- /lib/Kelp/Exception.pm: -------------------------------------------------------------------------------- 1 | package Kelp::Exception; 2 | 3 | use Kelp::Base; 4 | 5 | use Carp; 6 | 7 | attr -code => sub { croak 'code is required' }; 8 | 9 | attr body => undef; 10 | 11 | sub new 12 | { 13 | my ($class, $code, %params) = @_; 14 | 15 | croak 'Kelp::Exception can only accept 4XX or 5XX codes' 16 | unless defined $code && $code =~ /^[45]\d\d$/; 17 | 18 | $params{code} = $code; 19 | return $class->SUPER::new(%params); 20 | } 21 | 22 | sub throw 23 | { 24 | my $self = shift; 25 | if (!ref $self) { 26 | $self = $self->new(@_); 27 | } 28 | 29 | die $self; 30 | } 31 | 32 | 1; 33 | 34 | __END__ 35 | 36 | =pod 37 | 38 | =head1 NAME 39 | 40 | Kelp::Exception - Tiny HTTP exceptions 41 | 42 | =head1 SYNOPSIS 43 | 44 | # will log the body to 'error' level logger 45 | Kelp::Exception->throw(400, body => 'The request was malformed and got aborted'); 46 | 47 | # will only show an error page with the code 48 | Kelp::Exception->throw(410); 49 | 50 | # code is optional - 500 by default 51 | Kelp::Exception->throw; 52 | 53 | =head1 DESCRIPTION 54 | 55 | This module offers a fine-grained control of what the user sees when an 56 | exception occurs. Generally, this could also be done by setting the 57 | result code manually, but that requires passing the Kelp instance around and 58 | does not immediately end the handling code. Exceptions are a way to end route 59 | handler execution from deep within the call stack. 60 | 61 | This implementation is very incomplete and can only handle 4XX and 5XX status 62 | codes, meaning that you can't do redirects and normal responses like this. It 63 | also tries to maintain some degree of compatibility with L 64 | without its complexity. 65 | 66 | =head1 ATTRIBUTES 67 | 68 | =head2 code 69 | 70 | HTTP status code. Only possible are 5XX and 4XX. 71 | 72 | Readonly. Required. 73 | 74 | =head2 body 75 | 76 | Body of the exception - can be anything that can be serialized and if passed 77 | will cause the application to log it on error level. 78 | 79 | Content type and status string for the response will be set accordingly. Will 80 | render HTML in template and plaintext if there is no template (as usual errors do). 81 | 82 | =head1 METHODS 83 | 84 | =head2 throw 85 | 86 | # both do exactly the same 87 | Kelp::Exception->throw(...); 88 | die Kelp::Exception->new(...); 89 | 90 | Same as simply constructing and calling die on an object. 91 | 92 | =cut 93 | 94 | -------------------------------------------------------------------------------- /lib/Kelp/Module/Encoder.pm: -------------------------------------------------------------------------------- 1 | package Kelp::Module::Encoder; 2 | 3 | use Kelp::Base 'Kelp::Module'; 4 | 5 | attr 'args' => undef; 6 | attr 'encoders' => sub { {} }; 7 | 8 | # need to be reimplemented 9 | sub encoder_name { ... } 10 | sub build_encoder { ... } 11 | 12 | sub build 13 | { 14 | my ($self, %args) = @_; 15 | $self->args(\%args); 16 | 17 | $self->app->encoder_modules->{$self->encoder_name} = $self; 18 | } 19 | 20 | sub get_encoder_config 21 | { 22 | my ($self, $name) = @_; 23 | 24 | return { 25 | %{$self->args}, 26 | %{$self->app->config(join '.', 'encoders', $self->encoder_name, $name) // {}}, 27 | }; 28 | } 29 | 30 | sub get_encoder 31 | { 32 | my ($self, $name) = @_; 33 | $name //= 'default'; 34 | 35 | return $self->encoders->{$name} //= 36 | $self->build_encoder($self->get_encoder_config($name)); 37 | } 38 | 39 | 1; 40 | 41 | __END__ 42 | 43 | =head1 NAME 44 | 45 | Kelp::Module::Encoder - Base class for encoder modules 46 | 47 | =head1 SYNOPSIS 48 | 49 | # Writing a new encoder module 50 | 51 | package My::Encoder; 52 | use Kelp::Base 'Kelp::Encoder'; 53 | 54 | use Some::Class; 55 | 56 | sub encoder_name { 'something' } 57 | sub build_encoder { 58 | my ($self, $args) = @_; 59 | return Some::Class->new(%$args); 60 | } 61 | 62 | sub build { 63 | my ($self, %args) = @_; 64 | $self->SUPER::build(%args); 65 | 66 | # rest of module building here if necessary 67 | } 68 | 69 | 1; 70 | 71 | # configuring a special encoder (in app's configuration) 72 | 73 | encoders => { 74 | something => { 75 | modified => { 76 | new_argument => 1, 77 | }, 78 | }, 79 | }, 80 | 81 | # In application's code 82 | # will croak if encoder was not loaded 83 | # default second argument is 'default' (if not passed) 84 | 85 | $self->get_encoder('something')->encode; 86 | $self->get_encoder(something => 'modified')->decode; 87 | 88 | =head1 DESCRIPTION 89 | 90 | This is a base class for encoders which want to be compilant with the new 91 | L method. L is one of such modules. 92 | 93 | This allows to have all encoders in one easy to reach spot rather than a bunch 94 | of unrelated methods attached to the main class. It also allows to configure a 95 | couple of named encoders with different config in 96 | L configuration of the app. 97 | 98 | -------------------------------------------------------------------------------- /lib/Kelp/Module/Routes.pm: -------------------------------------------------------------------------------- 1 | package Kelp::Module::Routes; 2 | 3 | use Carp; 4 | use Kelp::Base 'Kelp::Module'; 5 | use Plack::Util; 6 | 7 | our @CARP_NOT = qw(Kelp::Module Kelp); 8 | 9 | my $DEFAULT_ROUTER = 'Kelp::Routes'; 10 | 11 | sub build 12 | { 13 | my ($self, %args) = @_; 14 | 15 | my $router = delete($args{router}) // ('+' . $DEFAULT_ROUTER); 16 | 17 | my $router_class = Plack::Util::load_class($router, $DEFAULT_ROUTER); 18 | my $r = $router_class->new(%args); 19 | 20 | # Register two methods: 21 | # * routes - contains the routes instance 22 | # * add_route - a shortcut to the 'add' method 23 | $self->register( 24 | routes => $r, 25 | add_route => sub { 26 | my $app = shift; 27 | return $r->add(@_); 28 | } 29 | ); 30 | } 31 | 32 | 1; 33 | 34 | __END__ 35 | 36 | =head1 NAME 37 | 38 | Kelp::Module::Routes - Default router module for Kelp 39 | 40 | =head1 SYNOPSIS 41 | 42 | # config.pl 43 | { 44 | # This module is included by default 45 | # modules => ['Routes'], 46 | modules_init => { 47 | Routes => { 48 | base => 'MyApp' 49 | } 50 | } 51 | } 52 | 53 | # lib/MyApp.pm 54 | sub build { 55 | my $self = shift; 56 | mt $self->add_route('/', 'home'); 57 | } 58 | 59 | 60 | =head1 DESCRIPTION 61 | 62 | This module and L are automatically loaded into each Kelp 63 | application. It initializes the routing table for the web application. 64 | 65 | =head1 REGISTERED METHODS 66 | 67 | This module registers the following methods into the underlying app: 68 | 69 | =head2 routes 70 | 71 | An instance to L, or whichever router was specified in the 72 | configuration. 73 | 74 | =head2 add_route 75 | 76 | A shortcut to the L method. 77 | 78 | =head2 CONFIGURATION 79 | 80 | The configuration for this module contains the following keys: 81 | 82 | =head3 router 83 | 84 | The router class to use. The default value is C, but any other 85 | class can be specified. A normal string will be considered a subclass of 86 | C, for example: 87 | 88 | router => 'Custom' 89 | 90 | will look for C. To specify a fully qualified class, 91 | prefix it with a plus sign. 92 | 93 | router => '+My::Special::Router' 94 | 95 | =head3 configuration of the router 96 | 97 | All other configuration is passed to the router. For the configuration of the 98 | default router, see L. 99 | 100 | -------------------------------------------------------------------------------- /lib/Kelp/Template.pm: -------------------------------------------------------------------------------- 1 | package Kelp::Template; 2 | 3 | use Kelp::Base; 4 | use Template::Tiny; 5 | use Path::Tiny; 6 | use Carp; 7 | 8 | attr paths => sub { [] }; 9 | attr encoding => 'UTF-8'; 10 | attr tt => sub { Template::Tiny->new }; 11 | 12 | sub process 13 | { 14 | my ($self, $template, $vars) = @_; 15 | 16 | my $ref = ref $template; 17 | 18 | # A GLOB or an IO object will be read and returned as a SCALAR template 19 | # No reference means a file name 20 | if (!$ref) { 21 | $template = $self->_read_file($self->find_template($template)); 22 | } 23 | elsif ($ref =~ /^IO/ || $ref eq 'GLOB') { 24 | $template = $self->_read_file($template); 25 | } 26 | elsif ($ref ne 'SCALAR') { 27 | croak "Template reference must be SCALAR, GLOB or an IO object"; 28 | } 29 | 30 | my $output; 31 | $self->tt->process($template, $vars, \$output); 32 | return $output; 33 | } 34 | 35 | sub find_template 36 | { 37 | my ($self, $name) = @_; 38 | 39 | my $file; 40 | for my $p ('.', @{$self->paths}) { 41 | $file = "$p/$name"; 42 | return $file if -e $file; 43 | } 44 | 45 | return undef; 46 | } 47 | 48 | sub _read_file 49 | { 50 | my ($self, $file) = @_; 51 | my $text; 52 | 53 | if (ref $file) { 54 | 55 | # read the entire file 56 | local $/ = undef; 57 | 58 | # make sure to properly rewind the handle after we read from it 59 | my $pos = tell $file; 60 | $text = readline $file; 61 | seek $file, $pos, 0; 62 | } 63 | else { 64 | $text = path($file)->slurp( 65 | {binmode => ':encoding(' . $self->encoding . ')'} 66 | ); 67 | } 68 | 69 | return \$text; 70 | } 71 | 72 | 1; 73 | 74 | __END__ 75 | 76 | =pod 77 | 78 | =head1 NAME 79 | 80 | Kelp::Template - A very minimal template rendering engine for Kelp 81 | 82 | =head1 SYNOPSIS 83 | 84 | my $t = Kelp::Template->new; 85 | say $t->process('file.tt', { bar => 'foo' }); 86 | 87 | =head1 DESCRIPTION 88 | 89 | This module provides basic template rendering using L. 90 | 91 | =head1 ATTRIBUTES 92 | 93 | =head2 paths 94 | 95 | An arrayref of paths to use when looking for template files. 96 | 97 | =head2 encoding 98 | 99 | Specifies the text encoding of the template files. The default value is C. 100 | 101 | =head1 METHODS 102 | 103 | =head2 process( $template, \%vars ) 104 | 105 | Processes a template and returns the parsed text. The template may be a file name, 106 | a reference to a text, a GLOB or an IO object. 107 | 108 | say $t->process(\"Hello [% who %]", { who => 'you' }); 109 | 110 | =cut 111 | 112 | -------------------------------------------------------------------------------- /t/cookbook_yaml.t: -------------------------------------------------------------------------------- 1 | use Kelp::Base -strict; 2 | use Kelp::Test; 3 | use Kelp; 4 | use Test::More; 5 | use HTTP::Request::Common; 6 | use lib 't/lib'; 7 | 8 | my $has_yaml = eval { 9 | require Kelp::Module::YAML; 10 | 1; 11 | }; 12 | 13 | plan skip_all => 'These tests require Kelp::Module::YAML' 14 | unless $has_yaml; 15 | 16 | { 17 | 18 | package YAML::Request; 19 | use Kelp::Base 'Kelp::Request'; 20 | use Try::Tiny; 21 | 22 | sub is_yaml 23 | { 24 | my $self = shift; 25 | return 0 unless $self->content_type; 26 | return $self->content_type =~ m{^text/yaml}i; 27 | } 28 | 29 | sub yaml_content 30 | { 31 | my $self = shift; 32 | return undef unless $self->is_yaml; 33 | 34 | return try { 35 | $self->app->get_encoder(yaml => 'internal')->decode($self->content); 36 | } 37 | catch { 38 | undef; 39 | }; 40 | } 41 | } 42 | 43 | { 44 | 45 | package YAML::Response; 46 | use Kelp::Base 'Kelp::Response'; 47 | 48 | sub yaml 49 | { 50 | my $self = shift; 51 | $self->set_content_type('text/yaml', $self->charset || $self->app->charset); 52 | return $self; 53 | } 54 | 55 | sub _render_ref 56 | { 57 | my ($self, $body) = @_; 58 | 59 | if ($self->content_type =~ m{^text/yaml}i) { 60 | return $self->app->get_encoder(yaml => 'internal')->encode($body); 61 | } 62 | else { 63 | return $self->SUPER::_render_ref($body); 64 | } 65 | } 66 | 67 | } 68 | 69 | { 70 | 71 | package YAMLApp; 72 | use Kelp::Base 'Kelp'; 73 | use Kelp::Exception; 74 | 75 | sub build 76 | { 77 | my $self = shift; 78 | 79 | $self->load_module('YAML'); 80 | $self->request_obj('YAML::Request'); 81 | $self->response_obj('YAML::Response'); 82 | 83 | $self->add_route('/yaml' => 'handler'); 84 | } 85 | 86 | sub handler 87 | { 88 | my $self = shift; 89 | my $yaml_document = $self->req->yaml_content; 90 | 91 | Kelp::Exception->throw(400) 92 | unless defined $yaml_document; 93 | 94 | $yaml_document->{test} = 'kelp'; 95 | 96 | $self->res->yaml; 97 | return $yaml_document; 98 | } 99 | } 100 | 101 | my $app = YAMLApp->new(mode => 'test'); 102 | my $t = Kelp::Test->new(app => $app); 103 | 104 | $t->request(POST '/yaml', Content_Type => 'text/yaml', Content => "a: 1\nb: 2") 105 | ->code_is(200) 106 | ->content_like(qr{a: 1}) 107 | ->content_like(qr{b: 2}) 108 | ->content_like(qr{test: kelp}); 109 | 110 | $t->request(POST '/yaml', Content_Type => 'text/plain', Content => "not yaml") 111 | ->code_is(400); 112 | 113 | done_testing; 114 | 115 | -------------------------------------------------------------------------------- /bin/kelp-generator: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use Kelp::Base -strict; 4 | use Getopt::Long; 5 | use Kelp::Generator; 6 | use Path::Tiny; 7 | use Pod::Usage; 8 | 9 | my $path = '.'; 10 | my $verbose = 1; 11 | my $force = 0; 12 | my $type = 'kelp'; 13 | my $tabs = 0; 14 | my $help = 0; 15 | 16 | GetOptions( 17 | "path=s" => \$path, 18 | "type=s" => \$type, 19 | "verbose!" => \$verbose, 20 | "force!" => \$force, 21 | "tabs!" => \$tabs, 22 | "help" => \$help 23 | ); 24 | 25 | my $name = $ARGV[0]; 26 | my $generator = Kelp::Generator->new; 27 | 28 | if (!$name || $help) { 29 | say 'Error - no application name.' unless $help; 30 | pod2usage(-verbose => 1, -exitval => 'NOEXIT'); 31 | say 'Available application types:'; 32 | say for map { ' ' x 4 . $_ } $generator->list_templates; 33 | exit ($help ? 0 : 1); 34 | } 35 | 36 | # Remove the slash at the end 37 | $path =~ s{/$}{}; 38 | my $files = $generator->get_template($type, $name); 39 | 40 | for my $filedata (@$files) { 41 | my ($filename, $contents) = @$filedata; 42 | 43 | # replace spaces with tabs 44 | # each 4 spaces will become a tab character 45 | # last 2 spaces will also become a tab due to rounding (+0.5) 46 | $contents =~ s{ ^ ((?: [ ]{4} | [ ]{2} )+) }{ "\t" x (length($1) / 4 + 0.5) }xmeg 47 | if $tabs; 48 | 49 | my $dir = $path . path("/$filename")->parent; 50 | my $file = path($path . '/' . $filename); 51 | 52 | if (!-d $dir) { 53 | _say("Creating folder: $dir"); 54 | path($dir)->mkpath; 55 | } 56 | 57 | if ($file->is_dir) { 58 | say "$filename is a directory - manual action required. Skipping..."; 59 | next; 60 | } 61 | 62 | if ($file->exists && !$force) { 63 | say "File $filename exists. Use --force to overwrite. Skipping..."; 64 | next; 65 | } 66 | 67 | _say("Writing file: $filename"); 68 | $file->spew({binmode => ':encoding(UTF-8)'}, $contents); 69 | } 70 | 71 | sub _say { 72 | my $what = shift; 73 | if ($verbose) { 74 | say $what; 75 | } 76 | } 77 | 78 | __END__ 79 | 80 | =pod 81 | 82 | =head1 NAME 83 | 84 | kelp-generator - Generate Kelp applications 85 | 86 | =head1 SYNOPSIS 87 | 88 | kelp-generator [options] 89 | 90 | =head1 OPTIONS 91 | 92 | =over 4 93 | 94 | =item B<--path=s> 95 | 96 | Path where to create the files 97 | 98 | =item B<--type=s> 99 | 100 | Type of application to create (default: kelp) 101 | 102 | =item B<--(no)verbose> 103 | 104 | Display more or less information 105 | 106 | =item B<--force> 107 | 108 | Force overwriting existing files 109 | 110 | =item B<--tabs> 111 | 112 | Use tabs for indentation instead of spaces 113 | 114 | =item B<--help> 115 | 116 | This help screen 117 | 118 | =back 119 | 120 | =head1 DESCRIPTION 121 | 122 | This program will generate a Kelp project from one of the registered 123 | templates. C<< >> will be used as the name of the package. 124 | 125 | -------------------------------------------------------------------------------- /t/charset.t: -------------------------------------------------------------------------------- 1 | use Kelp::Base -strict; 2 | use Test::More; 3 | use Kelp::Test -utf8; 4 | use HTTP::Request::Common; 5 | use URI::Escape; 6 | use Kelp; 7 | use utf8; 8 | 9 | my $app = Kelp->new(mode => 'test'); 10 | my $t = Kelp::Test->new(app => $app); 11 | 12 | subtest 'should handle UTF-8 in paths' => sub { 13 | $t->charset('latin1'); # set charset for tests 14 | 15 | my $text = 'Ha nincs ló, jó a szamár is.'; 16 | $app->add_route( 17 | '/szamár' => sub { 18 | my $self = shift; 19 | $self->res->charset('latin1'); 20 | return $text; 21 | } 22 | ); 23 | 24 | $t->request(GET '/' . uri_escape_utf8('szamár')) 25 | ->full_content_type_is('text/html; charset=latin1') 26 | ->content_is($text); 27 | }; 28 | 29 | subtest 'should replace manually set charset in response' => sub { 30 | $t->charset('UTF-32'); # set charset for tests 31 | 32 | my $text = 'Il vaut mieux prévenir que guérir.'; 33 | $app->add_route( 34 | '/override' => sub { 35 | my $self = shift; 36 | $self->res->set_content_type('text/plain; encoding=UTF-16'); 37 | $self->res->charset('UTF-32'); 38 | return $text; 39 | } 40 | ); 41 | 42 | $t->request(GET '/override') 43 | ->full_content_type_is('text/plain; charset=UTF-32') 44 | ->content_is($text); 45 | }; 46 | 47 | subtest 'should copy charset from request to response' => sub { 48 | $t->charset('UTF-16'); # set charset for tests 49 | 50 | my $text = "Ten się śmieje, kto się śmieje ostatni."; 51 | $app->add_route( 52 | '/copy' => sub { 53 | my $self = shift; 54 | $self->res->charset($self->req->charset); 55 | return $text; 56 | } 57 | ); 58 | 59 | $t->request(GET '/copy', 'Content-Type' => 'text/plain; charset=UTF-16') 60 | ->full_content_type_is('text/html; charset=UTF-16') 61 | ->content_is($text); 62 | 63 | }; 64 | 65 | subtest 'should set but not not override charset' => sub { 66 | $t->charset('UTF-16'); # set charset for tests 67 | $app->charset('UTF-8'); 68 | 69 | my $text = "Lepszy wróbel w garści, niż gołąb na dachu."; 70 | $app->add_route( 71 | '/respect' => sub { 72 | my $self = shift; 73 | $self->res->charset('UTF-16'); 74 | $self->res->html; 75 | $self->res->json; 76 | $self->res->xml; 77 | $self->res->text; 78 | return $text; 79 | } 80 | ); 81 | 82 | $t->request(GET '/respect', 'Content-Type' => 'text/plain') 83 | ->full_content_type_is('text/plain; charset=UTF-16') 84 | ->content_is($text); 85 | }; 86 | 87 | subtest 'should json_cmp UTF16 without problems with disabled utf8' => sub { 88 | $t->charset('UTF-8'); # set charset for tests 89 | 90 | $app->json->utf8(0); 91 | $app->add_route( 92 | '/false' => sub { 93 | my $self = shift; 94 | $self->res->charset('UTF-8'); 95 | return {false => 'fałsz'}; 96 | } 97 | ); 98 | 99 | $t->request(GET '/false') 100 | ->json_cmp({false => 'fałsz'}); 101 | }; 102 | 103 | done_testing; 104 | 105 | -------------------------------------------------------------------------------- /t/exceptions.t: -------------------------------------------------------------------------------- 1 | use Kelp::Base -strict; 2 | 3 | use Kelp; 4 | use Kelp::Test; 5 | use HTTP::Request::Common; 6 | use Kelp::Exception; 7 | use Test::More; 8 | 9 | use lib 't/lib'; 10 | use StringifyingException; 11 | 12 | my $app = Kelp->new(mode => 'test'); 13 | my $t = Kelp::Test->new(app => $app); 14 | 15 | my $ex = StringifyingException->new(data => [qw(ab cd)]); 16 | 17 | $app->add_route("/0", sub { die 'died' }); 18 | $t->request(GET "/0") 19 | ->code_is(500) 20 | ->content_like(qr/died/) 21 | ->content_type_is('text/html'); 22 | 23 | $app->add_route("/1", sub { Kelp::Exception->throw(400) }); 24 | $app->add_route("/2", sub { Kelp::Exception->throw(403, body => 'body text') }); 25 | $app->add_route("/2alt", sub { Kelp::Exception->throw(404, body => 'body text') }); 26 | $app->add_route("/5", sub { shift->res->json; Kelp::Exception->throw(500, body => $ex) }); 27 | $app->add_route("/5alt", sub { shift->res->json; Kelp::Exception->throw(501, body => $ex) }); 28 | $app->add_route("/6", sub { Kelp::Exception->throw(300) }); 29 | 30 | # these errors should be the same regardless of mode 31 | subtest 'testing development' => sub { 32 | $app->mode('development'); 33 | 34 | $t->request(GET "/1") 35 | ->code_is(400) 36 | ->content_is('400 - Bad Request') 37 | ->content_type_is('text/plain'); 38 | 39 | $t->request(GET "/2") 40 | ->code_is(403) 41 | ->content_is('403 - Forbidden') 42 | ->content_type_is('text/plain'); 43 | 44 | $t->request(GET "/2alt") 45 | ->code_is(404) 46 | ->content_like(qr/Four Oh Four/) 47 | ->content_type_is('text/html'); 48 | 49 | $t->request(GET "/5") 50 | ->code_is(500) 51 | ->content_like(qr/\Q$ex\E/) 52 | ->content_type_is('text/html'); 53 | 54 | $t->request(GET "/5alt") 55 | ->code_is(501) 56 | ->content_like(qr/501 - Not Implemented/) 57 | ->content_type_is('text/plain'); 58 | 59 | $t->request(GET "/6") 60 | ->code_is(500) 61 | ->content_like(qr/5XX/) 62 | ->content_type_is('text/html'); 63 | }; 64 | 65 | subtest 'testing deployment' => sub { 66 | $app->mode('deployment'); 67 | 68 | $t->request(GET "/1") 69 | ->code_is(400) 70 | ->content_is('400 - Bad Request') 71 | ->content_type_is('text/plain'); 72 | 73 | $t->request(GET "/2") 74 | ->code_is(403) 75 | ->content_is('403 - Forbidden') 76 | ->content_type_is('text/plain'); 77 | 78 | $t->request(GET "/2alt") 79 | ->code_is(404) 80 | ->content_like(qr/Four Oh Four/) 81 | ->content_type_is('text/html'); 82 | 83 | $t->request(GET "/5") 84 | ->code_is(500) 85 | ->content_unlike(qr/Exception/) 86 | ->content_type_is('text/html'); 87 | 88 | $t->request(GET "/5alt") 89 | ->code_is(501) 90 | ->content_is('501 - Not Implemented') 91 | ->content_type_is('text/plain'); 92 | 93 | $t->request(GET "/6") 94 | ->code_is(500) 95 | ->content_like(qr/Five Hundred/) 96 | ->content_type_is('text/html'); 97 | }; 98 | 99 | subtest 'should be able to rethrow an exception' => sub { 100 | my $ex = Kelp::Exception->new(501); 101 | 102 | my $caught = do { 103 | local $@; 104 | eval { $ex->throw }; 105 | $@; 106 | }; 107 | 108 | is $ex, $caught, 'caught object ok'; 109 | }; 110 | 111 | done_testing; 112 | 113 | -------------------------------------------------------------------------------- /t/response.t: -------------------------------------------------------------------------------- 1 | use Kelp::Base -strict; 2 | 3 | use Kelp; 4 | use Kelp::Test; 5 | use HTTP::Request::Common; 6 | use Test::More; 7 | 8 | my $app = Kelp->new(mode => 'test'); 9 | my $t = Kelp::Test->new(app => $app); 10 | 11 | # Bare render 12 | $app->add_route("/1", sub { $_[0]->res->render }); 13 | $t->request(GET "/1") 14 | ->code_is(200) 15 | ->content_is('') 16 | ->content_type_is('text/html'); 17 | 18 | # Set code 19 | $app->add_route("/2", sub { $_[0]->res->set_code(401)->render }); 20 | $t->request(GET "/2")->code_is(401); 21 | 22 | # Set content type 23 | $app->add_route("/3", sub { $_[0]->res->html->render }); 24 | $t->request(GET "/3")->content_type_is('text/html'); 25 | 26 | $app->add_route("/4", sub { $_[0]->res->text->render }); 27 | $t->request(GET "/4")->content_type_is('text/plain'); 28 | 29 | $app->add_route("/5", sub { $_[0]->res->json->render({}) }); 30 | $t->request(GET "/5")->content_type_is('application/json'); 31 | 32 | $app->add_route("/51", sub { $_[0]->res->json->render("aaa") }); 33 | $t->request(GET "/51")->code_is(200)->content_type_is('application/json'); 34 | 35 | $app->add_route("/52", sub { $_[0]->res->json->render(\"aaa") }); 36 | $t->request(GET "/52")->code_is(500); 37 | 38 | $app->add_route("/53", sub { $_[0]->res->json->render([]) }); 39 | $t->request(GET "/53")->code_is(200)->content_type_is('application/json'); 40 | 41 | $app->add_route("/6", sub { $_[0]->res->xml->render }); 42 | $t->request(GET "/6")->content_type_is('application/xml'); 43 | 44 | $app->add_route("/7", sub { $_[0]->res->set_content_type('image/png')->render }); 45 | $t->request(GET "/7")->content_type_is('image/png'); 46 | 47 | # Set header 48 | $app->add_route("/8", sub { $_[0]->res->set_header('x-something', 'foo')->render }); 49 | $t->request(GET "/8")->header_is('x-something', 'foo'); 50 | 51 | # 404 52 | $app->add_route("/404", sub { $_[0]->res->render_404 }); 53 | $t->request(GET "/404")->code_is(404); 54 | 55 | # 500 56 | $app->add_route("/500", sub { $_[0]->res->render_500 }); 57 | $t->request(GET "/500")->code_is(500); 58 | 59 | # Redirect 60 | $app->add_route("/redi1", sub { $_[0]->res->redirect_to('/') }); 61 | $t->request(GET "/redi1")->code_is(302); 62 | $app->add_route("/redi2", sub { $_[0]->res->redirect_to('/', {}, 301) }); 63 | $t->request(GET "/redi2")->code_is(301); 64 | 65 | # Die 66 | $app->add_route("/die", sub { die "You all suck." }); 67 | $t->request(GET "/die")->code_is(500); 68 | 69 | # Render 70 | $app->add_route("/r1", sub { return "Ahoi" }); 71 | $t->request(GET "/r1") 72 | ->code_is(200) 73 | ->content_type_is('text/html') 74 | ->content_is("Ahoi"); 75 | 76 | $app->add_route("/r2", sub { return {a => 'foo'} }); 77 | $t->request(GET "/r2") 78 | ->code_is(200) 79 | ->content_type_is('application/json') 80 | ->json_cmp({a => 'foo'}); 81 | 82 | # json_content will return a hash 83 | is ref($t->request(GET "/r2")->json_content), 'HASH'; 84 | 85 | # Template 86 | $app->add_route("/t1", sub { $_[0]->res->text->template(\"[% word %]", {word => 'duck'}) }); 87 | $t->request(GET "/t1") 88 | ->code_is(200) 89 | ->content_type_is('text/plain') 90 | ->content_is("duck"); 91 | 92 | $app->add_route("/t2", sub { $_[0]->res->html->template(\"[% word %]", {word => 'swan'}) }); 93 | $t->request(GET "/t2") 94 | ->code_is(200) 95 | ->content_type_is('text/html') 96 | ->content_is("swan"); 97 | 98 | $app->add_route("/bin1", sub { $_[0]->res->render_binary("123") }); 99 | $t->request(GET "/bin1")->code_is(500); 100 | 101 | $app->add_route("/bin2", sub { $_[0]->res->set_content_type("image/png")->render_binary("123") }); 102 | $t->request(GET "/bin2")->code_is(200); 103 | 104 | done_testing; 105 | 106 | -------------------------------------------------------------------------------- /t/util.t: -------------------------------------------------------------------------------- 1 | 2 | use strict; 3 | use warnings; 4 | 5 | use Test::More; 6 | use Test::Exception; 7 | use Kelp::Util; 8 | 9 | subtest 'testing camelize' => sub { 10 | my %h = ( 11 | 'a#b' => 'A::b', 12 | 'bar#foo' => 'Bar::foo', 13 | 'bar_foo#baz' => 'BarFoo::baz', 14 | 'bar_foo#baz_bat' => 'BarFoo::baz_bat', 15 | 'BarFoo#baz' => 'Barfoo::baz', 16 | 'barfoo#BAZ' => 'Barfoo::BAZ', 17 | 'bar_foo_baz_bat#moo' => 'BarFooBazBat::moo', 18 | 'a' => 'a', 19 | 'M::D::f' => 'M::D::f', 20 | 'R_E_S_T#asured' => 'REST::asured', 21 | 'REST::Assured::ok' => 'REST::Assured::ok', 22 | 'REST' => 'REST', 23 | ); 24 | 25 | for my $k (keys %h) { 26 | is(Kelp::Util::camelize($k), $h{$k}, "base $k"); 27 | is(Kelp::Util::camelize($k, 'Boo'), 'Boo::' . $h{$k}, "$k with namespace"); 28 | is(Kelp::Util::camelize($k, ''), $h{$k}, "$k with empty namespace"); 29 | } 30 | 31 | is(Kelp::Util::camelize(''), '', 'empty ok'); 32 | is(Kelp::Util::camelize('', 'Boo'), '', 'empty with class ok'); 33 | }; 34 | 35 | subtest 'testing camelize (class only)' => sub { 36 | my %h = ( 37 | 'a#b' => 'A::B', 38 | 'bar#foo' => 'Bar::Foo', 39 | 'bar_foo#baz' => 'BarFoo::Baz', 40 | 'bar_foo#baz_bat' => 'BarFoo::BazBat', 41 | 'BarFoo#baz' => 'Barfoo::Baz', 42 | 'barfoo#BAZ' => 'Barfoo::Baz', 43 | 'bar_foo_baz_bat#moo_moo' => 'BarFooBazBat::MooMoo', 44 | 'a' => 'a', 45 | 'M::D::f' => 'M::D::f', 46 | 'R_E_S_T#asured' => 'REST::Asured', 47 | 'REST::Assured::ok' => 'REST::Assured::ok', 48 | 'REST' => 'REST', 49 | ); 50 | 51 | for my $k (keys %h) { 52 | is(Kelp::Util::camelize($k, undef, 1), $h{$k}, "base $k"); 53 | is(Kelp::Util::camelize($k, 'Boo', 1), 'Boo::' . $h{$k}, "$k with namespace"); 54 | is(Kelp::Util::camelize($k, '', 1), $h{$k}, "$k with empty namespace"); 55 | } 56 | 57 | is(Kelp::Util::camelize('', undef, 1), '', 'empty ok'); 58 | is(Kelp::Util::camelize('', 'Boo', 1), '', 'empty with class ok'); 59 | }; 60 | 61 | subtest 'testing extract_class' => sub { 62 | my %h = ( 63 | 'A::b' => 'A', 64 | 'Bar::foo' => 'Bar', 65 | 'BarFoo::baz' => 'BarFoo', 66 | 'BarFooBazBat::moo' => 'BarFooBazBat', 67 | 'a' => undef, 68 | 'M::D::f' => 'M::D', 69 | 'REST::Assured::ok' => 'REST::Assured', 70 | 'main::ok' => undef, 71 | '' => undef, 72 | ); 73 | 74 | for my $k (keys %h) { 75 | if (defined $h{$k}) { 76 | is(Kelp::Util::extract_class($k), $h{$k}, $k); 77 | } 78 | else { 79 | ok !defined Kelp::Util::extract_class($k), $k; 80 | } 81 | } 82 | 83 | }; 84 | 85 | subtest 'testing extract_function' => sub { 86 | my %h = ( 87 | 'A::b' => 'b', 88 | 'BarFoo::baz' => 'baz', 89 | 'a' => 'a', 90 | 'M::D::f' => 'f', 91 | '' => undef, 92 | ); 93 | 94 | for my $k (keys %h) { 95 | if (defined $h{$k}) { 96 | is(Kelp::Util::extract_function($k), $h{$k}, $k); 97 | } 98 | else { 99 | ok !defined Kelp::Util::extract_function($k), $k; 100 | } 101 | } 102 | }; 103 | 104 | subtest 'testing load_package' => sub { 105 | Kelp::Util::load_package('Kelp::Module::Logger::Simple'); 106 | can_ok 'Kelp::Module::Logger::Simple', 'build'; 107 | 108 | throws_ok { 109 | Kelp::Util::load_package('This::Package::Does::Not::Exist'); 110 | } qr{This/Package/Does/Not/Exist.pm}; 111 | 112 | note $@; 113 | }; 114 | 115 | done_testing; 116 | 117 | -------------------------------------------------------------------------------- /lib/Kelp/templates/kelp/views-welcome.tt: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | Welcome to Kelp 6 | 61 | 62 | 63 | 64 | 65 |
66 | Kelp framework logo 67 |

68 | Welcome to the Kelp web framework! 69 |

70 |
71 |

72 | [% name %] is ready to grow 73 | 74 | 75 | 76 | 77 | 78 | 79 |

80 | 81 |

82 | Your application has been configured successfully and is now operational. Thank you for choosing Kelp. 83 |

84 |

85 | This document has been rendered from views/welcome.tt using Template::Tiny. 86 |

87 |

88 | Please consult our extensive manual to get started. The cookbook is worth looking into if you're dealing with a more difficult problem. 89 |

90 | 91 |
92 |

93 | The list of registered routes is printed below: 94 |

95 | 96 | 97 | 98 | 99 | 100 | 101 | 102 | 103 | 104 | [% FOREACH route IN routes %] 105 | 106 | 107 | 108 | 109 | 110 | [% END %] 111 | 112 |
MethodRouteHandler
[% route.method %][% route.route %][% route.handler %]
113 | 114 |
115 |

116 | The current configuration is printed below: 117 |

118 | 
[% config %]
119 | 120 | 121 | 122 | 123 | -------------------------------------------------------------------------------- /lib/Kelp/Module/Logger.pm: -------------------------------------------------------------------------------- 1 | package Kelp::Module::Logger; 2 | 3 | use Kelp::Base 'Kelp::Module'; 4 | 5 | use Carp; 6 | use Log::Dispatch; 7 | use Time::Piece; 8 | use Data::Dumper; 9 | 10 | attr logger => undef; 11 | attr date_format => '%Y-%m-%d %T'; 12 | attr log_format => '%s - %s - %s'; 13 | 14 | sub _logger 15 | { 16 | my ($self, %args) = @_; 17 | 18 | return Log::Dispatch->new(%args); 19 | } 20 | 21 | sub load_configuration 22 | { 23 | my ($self, %args) = @_; 24 | 25 | for my $field (qw(date_format log_format)) { 26 | $self->$field(delete $args{$field}) 27 | if $args{$field}; 28 | } 29 | 30 | return %args; 31 | } 32 | 33 | sub build 34 | { 35 | my ($self, %args) = @_; 36 | 37 | # load module config 38 | %args = $self->load_configuration(%args); 39 | 40 | # load logger with the rest of the config 41 | $self->logger($self->_logger(%args)); 42 | 43 | # Build the registration hash 44 | my %LEVELS = map { 45 | my $level = $_; 46 | $level => sub { 47 | shift; 48 | $self->message($level, @_); 49 | }; 50 | } qw(debug info error); 51 | 52 | # Register a few levels 53 | $self->register(%LEVELS); 54 | 55 | # Also register the message method as 'logger' 56 | $self->register( 57 | logger => sub { 58 | shift; 59 | $self->message(@_); 60 | } 61 | ); 62 | } 63 | 64 | sub message 65 | { 66 | my ($self, $level, @messages) = @_; 67 | my $date = localtime->strftime($self->date_format); 68 | 69 | local $Data::Dumper::Sortkeys = 1; 70 | for my $message (@messages) { 71 | $message = sprintf $self->log_format, 72 | $date, 73 | $level, 74 | (ref $message ? Dumper($message) : $message), 75 | ; 76 | 77 | $self->logger->log(level => $level, message => $message); 78 | } 79 | } 80 | 81 | 1; 82 | 83 | __END__ 84 | 85 | =pod 86 | 87 | =head1 NAME 88 | 89 | Kelp::Module::Logger - Logger for Kelp applications 90 | 91 | =head1 SYNOPSIS 92 | 93 | # conf/config.pl 94 | { 95 | modules => ['Logger'], 96 | modules_init => { 97 | Logger => { 98 | outputs => [ 99 | [ 'Screen', min_level => 'debug', newline => 1 ], 100 | ] 101 | }, 102 | }, 103 | } 104 | 105 | # lib/MyApp.pm 106 | sub run { 107 | my $self = shift; 108 | my $app = $self->SUPER::run(@_); 109 | ...; 110 | $app->info('Kelp is ready to rock!'); 111 | return $app; 112 | } 113 | 114 | 115 | =head1 DESCRIPTION 116 | 117 | This module provides an log interface for Kelp web application. It uses 118 | L as underlying logging module. 119 | 120 | =head1 CONFIGURATION 121 | 122 | All module's configuration is passed to L, so consult its docs 123 | for details. In addition, following keys can be configured which change how the 124 | module behaves: 125 | 126 | =head2 date_format 127 | 128 | A string in L which will be used to 130 | generate the date. 131 | 132 | By default, value C<'%Y-%m-%d %T'> is used. 133 | 134 | =head2 log_format 135 | 136 | A string in L which 137 | will be used to generate the log. Three string values will be used in this 138 | string, in order: date, log level and the message itself. 139 | 140 | By default, value C<'%s - %s - %s'> is used. 141 | 142 | =head1 REGISTERED METHODS 143 | 144 | =head2 debug 145 | 146 | =head2 info 147 | 148 | =head2 error 149 | 150 | =head2 logger 151 | 152 | C<< $app->logger(info => 'message') >> is equivalent to C<< $app->info('message') >>. 153 | 154 | =head1 SEE ALSO 155 | 156 | L - always dumps to standard output 157 | 158 | =cut 159 | 160 | -------------------------------------------------------------------------------- /t/pattern_build.t: -------------------------------------------------------------------------------- 1 | 2 | use strict; 3 | use warnings; 4 | use v5.10; 5 | 6 | use Test::More; 7 | use Test::Exception; 8 | use Kelp::Routes::Pattern; 9 | 10 | { 11 | my $p = Kelp::Routes::Pattern->new(pattern => '/:a/:b'); 12 | is $p->build(a => 1, b => 2), '/1/2'; 13 | is $p->build(a => 'bar', b => 'foo'), '/bar/foo'; 14 | dies_ok { $p->build(a => 'bar') }; 15 | dies_ok { $p->build(b => 'bar') }; 16 | dies_ok { $p->build() }; 17 | } 18 | 19 | { 20 | my $p = Kelp::Routes::Pattern->new(pattern => '/:a/?b'); 21 | is $p->build(a => 1, b => 2), '/1/2'; 22 | is $p->build(a => 'bar', b => 'foo'), '/bar/foo'; 23 | is $p->build(a => 'bar'), '/bar/'; 24 | dies_ok { $p->build(b => 'bar') }; 25 | } 26 | 27 | # Checks 28 | { 29 | my $p = Kelp::Routes::Pattern->new( 30 | pattern => '/:a/:b', 31 | check => {a => '\d+', b => '[a-z]+'} 32 | ); 33 | is $p->build(a => 1, b => 'a'), '/1/a'; 34 | dies_ok { $p->build(a => 1, b => 2) }; 35 | dies_ok { $p->build(a => 'a', b => 'b') }; 36 | } 37 | 38 | # Defaults 39 | { 40 | my $p = Kelp::Routes::Pattern->new( 41 | pattern => '/:a/?b', 42 | defaults => {b => 'foo'} 43 | ); 44 | is $p->build(a => 'bar', b => 'baz'), '/bar/baz'; 45 | is $p->build(a => 'bar'), '/bar/foo'; 46 | dies_ok { $p->build(b => 'bar') }; 47 | } 48 | 49 | { 50 | my $p = Kelp::Routes::Pattern->new( 51 | pattern => '/?a/:b', 52 | defaults => {a => 'bar'} 53 | ); 54 | is $p->build(a => 'foo', b => 'baz'), '/foo/baz'; 55 | is $p->build(b => 'bar'), '/bar/bar'; 56 | dies_ok { $p->build(a => 'foo') }; 57 | } 58 | 59 | { 60 | my $p = Kelp::Routes::Pattern->new( 61 | pattern => '/:a/>b', 62 | defaults => {b => 'bar/baz'} 63 | ); 64 | is $p->build(a => 'bar', b => 'baz'), '/bar/baz'; 65 | is $p->build(a => 'foo'), '/foo/bar/baz'; 66 | dies_ok { $p->build(b => 'bar') }; 67 | } 68 | 69 | # Captures 70 | { 71 | my $p = Kelp::Routes::Pattern->new(pattern => '/{:a}ing/{:b}ing'); 72 | is $p->build(a => 'go', b => 'walk'), '/going/walking'; 73 | dies_ok { $p->build(a => 'go') }; 74 | } 75 | 76 | # Conditional captures 77 | { 78 | my $p = Kelp::Routes::Pattern->new( 79 | pattern => '/{:a}ing/{?b}ing', 80 | defaults => {b => 'fart'} 81 | ); 82 | is $p->build(a => 'sleep'), '/sleeping/farting'; 83 | dies_ok { $p->build(b => 'talk') }; 84 | } 85 | 86 | { 87 | my $p = Kelp::Routes::Pattern->new(pattern => '/{:a}ing/{?b}ing'); 88 | is $p->build(a => 'sleep'), '/sleeping/ing'; 89 | dies_ok { $p->build(b => 'talk') }; 90 | } 91 | 92 | # Globs 93 | { 94 | my $p = Kelp::Routes::Pattern->new(pattern => '/*a/:b'); 95 | is $p->build(a => 'bar', b => 'foo'), '/bar/foo'; 96 | is $p->build(a => 'bar/bat', b => 'foo'), '/bar/bat/foo'; 97 | dies_ok { $p->build(b => 'foo') }; 98 | dies_ok { $p->build(a => 'foo') }; 99 | } 100 | 101 | { 102 | my $p = Kelp::Routes::Pattern->new(pattern => '/a/*/*b'); 103 | is $p->build('*' => 'hello', b => 5), '/a/hello/5'; 104 | is $p->build('*' => 'b/c', b => 'd'), '/a/b/c/d'; 105 | dies_ok { $p->build(b => '??') }; 106 | dies_ok { $p->build('*' => 'foo') }; 107 | } 108 | 109 | # Slurpy 110 | { 111 | my $p = Kelp::Routes::Pattern->new(pattern => '/:a/>b'); 112 | is $p->build(a => 'bar', b => 'foo'), '/bar/foo'; 113 | is $p->build(a => 'bar', b => 'bat/foo'), '/bar/bat/foo'; 114 | dies_ok { $p->build(b => 'foo') }; 115 | is $p->build(a => 'foo'), '/foo/'; 116 | } 117 | 118 | { 119 | my $p = Kelp::Routes::Pattern->new(pattern => '/a/>'); 120 | is $p->build('>' => 'hello'), '/a/hello'; 121 | is $p->build('>' => 'b/c'), '/a/b/c'; 122 | is $p->build(), '/a/'; 123 | } 124 | 125 | # Two unnamed items 126 | { 127 | my $p = Kelp::Routes::Pattern->new(pattern => '/hello/*/>'); 128 | is $p->build('*' => 'kelp', '>' => 'world'), '/hello/kelp/world'; 129 | } 130 | 131 | # Regex pattern cannot be built 132 | { 133 | my $p = Kelp::Routes::Pattern->new(pattern => qr{^/hello}); 134 | dies_ok { $p->build() }; 135 | } 136 | 137 | done_testing; 138 | 139 | -------------------------------------------------------------------------------- /t/request.t: -------------------------------------------------------------------------------- 1 | use Kelp::Base -strict; 2 | 3 | use Kelp; 4 | use Kelp::Test -utf8; 5 | use HTTP::Request::Common; 6 | use Test::More; 7 | use utf8; 8 | 9 | my $app = Kelp->new(mode => 'test'); 10 | my $t = Kelp::Test->new(app => $app); 11 | 12 | # is_json 13 | $app->add_route( 14 | '/req_method', 15 | sub { 16 | my $method = $_[0]->req->query_param('m'); 17 | return $_[0]->req->$method ? "ok" : "fail"; 18 | } 19 | ); 20 | for my $ct ( 21 | 'application/json', 22 | 'application/json; charset=UTF-8', 23 | 'APPLICATION/json; charset=UTF-8', 24 | 'APPLICATION/JSON; somethin=blah' 25 | ) 26 | { 27 | $t->request(GET '/req_method?m=is_json', Content_Type => $ct) 28 | ->code_is(200) 29 | ->content_is('ok'); 30 | } 31 | 32 | $t->request(GET '/req_method?m=is_ajax', 'X-Requested-With' => 'XMLHttpRequest') 33 | ->code_is(200) 34 | ->content_is('ok'); 35 | 36 | $t->request(GET '/req_method?m=is_ajax') 37 | ->code_is(200) 38 | ->content_is('fail'); 39 | 40 | $t->request(GET '/req_method?m=is_text', Content_Type => 'text/plain') 41 | ->code_is(200) 42 | ->content_is('ok'); 43 | 44 | $t->request(GET '/req_method?m=is_text', Content_Type => 'text/html') 45 | ->code_is(200) 46 | ->content_is('fail'); 47 | 48 | $t->request(GET '/req_method?m=is_html', Content_Type => 'text/html') 49 | ->code_is(200) 50 | ->content_is('ok'); 51 | 52 | $t->request(GET '/req_method?m=is_html', Content_Type => 'text/plain') 53 | ->code_is(200) 54 | ->content_is('fail'); 55 | 56 | $t->request(GET '/req_method?m=is_xml', Content_Type => 'application/xml') 57 | ->code_is(200) 58 | ->content_is('ok'); 59 | 60 | $t->request(GET '/req_method?m=is_xml', Content_Type => 'application/json') 61 | ->code_is(200) 62 | ->content_is('fail'); 63 | 64 | # param 65 | $app->add_route( 66 | '/param/:n', 67 | sub { 68 | my ($self, $n) = @_; 69 | if ($n == 1) { 70 | [sort($self->param)]; 71 | } 72 | elsif ($n == 2) { 73 | my %h = map { $_ => $self->param($_) } $self->param; 74 | return \%h; 75 | } 76 | elsif ($n == 3) { 77 | return $self->req->json_content // {}; 78 | } 79 | } 80 | ); 81 | $t->request( 82 | POST '/param/1', 83 | 'Content-Type' => 'application/json', 84 | 'Content' => '{"a":"bar","b":"foo"}' 85 | ) 86 | ->code_is(200) 87 | ->json_cmp(['a', 'b'], "Get JSON list of params"); 88 | 89 | $t->request( 90 | POST '/param/2', 91 | 'Content-Type' => 'application/json', 92 | 'Content' => '{"a":"bar","b":"foo"}' 93 | ) 94 | ->code_is(200) 95 | ->json_cmp({a => "bar", b => "foo"}, "JSON array context"); 96 | 97 | $t->request( 98 | POST '/param/3', 99 | 'Content-Type' => 'application/json', 100 | 'Content' => '{"a":"bar","b":"foo"}' 101 | ) 102 | ->code_is(200) 103 | ->json_cmp({a => "bar", b => "foo"}, "JSON scalar context"); 104 | 105 | # No JSON content 106 | $t->request(POST '/param/3', 'Content-Type' => 'application/json') 107 | ->code_is(200) 108 | ->json_cmp({}, "No JSON content"); 109 | 110 | # JSON content is not a hash 111 | $t->request( 112 | POST '/param/3', 113 | 'Content-Type' => 'application/json', 114 | 'Content' => '[1,2,3]' 115 | ) 116 | ->code_is(200) 117 | ->json_cmp([1, 2, 3], "JSON content is not a hash"); 118 | 119 | $t->request(POST '/param/1', [a => "bar", b => "foo"]) 120 | ->code_is(200) 121 | ->json_cmp(['a', 'b'], "Get POST list of params"); 122 | 123 | $t->request(POST '/param/2', [a => "bar", b => "foo"]) 124 | ->code_is(200) 125 | ->json_cmp({a => "bar", b => "foo"}, "POST array context"); 126 | 127 | # UTF8 128 | my $utf_hash = { 129 | english => 'Well done', 130 | russian => 'Молодец' 131 | }; 132 | $app->add_route('/json/utf', sub { $utf_hash }); 133 | $t->request(GET '/json/utf')->json_cmp($utf_hash); 134 | 135 | # Make sure legacy 'via' attribute works for backwards 136 | # compatibiliry 137 | $app->add_route( 138 | '/via_legacy', { 139 | via => 'POST', 140 | to => sub { "OK" } 141 | } 142 | ); 143 | $t->request(POST 'via_legacy') 144 | ->code_is(200) 145 | ->content_is("OK"); 146 | 147 | done_testing; 148 | 149 | -------------------------------------------------------------------------------- /t/module_config_merge.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Test::More; 4 | use Kelp::Module::Config; 5 | 6 | # Merge different 7 | { 8 | my $H = {}; 9 | my $A = []; 10 | my @arr = ( 11 | [1, 2, 2], 12 | [1, undef, undef], 13 | [1, $H, $H], 14 | [1, $A, $A], 15 | [undef, 1, 1], 16 | [undef, undef, undef], 17 | [$H, $A, $A], 18 | [$A, $H, $H] 19 | ); 20 | _try(@arr); 21 | } 22 | 23 | # Overwrite 24 | { 25 | my @arr = ( 26 | [ 27 | {a => 1}, 28 | {a => 2}, 29 | {a => 2} 30 | ], 31 | [ 32 | {a => 1, b => 2}, 33 | {b => 3}, 34 | {a => 1, b => 3} 35 | ], 36 | [ 37 | {}, 38 | {a => 1}, 39 | {a => 1} 40 | ], 41 | [ 42 | {a => 1}, 43 | {}, 44 | {a => 1} 45 | ], 46 | [ 47 | {a => [1, 2, 3]}, 48 | {a => [4, 5]}, 49 | {a => [4, 5]}, 50 | ], 51 | [ 52 | {a => "bar", b => [1, 2]}, 53 | {a => [1, 2]}, 54 | {a => [1, 2], b => [1, 2]} 55 | ], 56 | [ 57 | {a => {b => 'bar'}}, 58 | {a => {c => 'foo'}}, 59 | {a => {b => 'bar', c => 'foo'}}, 60 | ], 61 | [ 62 | {a => {b => 'bar'}}, 63 | {a => {b => [1, 2]}}, 64 | {a => {b => [1, 2]}}, 65 | ], 66 | ); 67 | _try(@arr); 68 | } 69 | 70 | # Add to adday 71 | { 72 | my @arr = ( 73 | [ 74 | {a => {b => [1, 2]}}, 75 | {a => {"+b" => [3, 4]}}, 76 | {a => {b => [1, 2, 3, 4]}} 77 | ], 78 | 79 | [ 80 | {a => {b => [1, 2]}}, 81 | {a => {"+b" => [1, 2, 4]}}, 82 | {a => {b => [1, 2, 4]}} 83 | ], 84 | 85 | [ 86 | {a => {b => [1, 2]}}, 87 | {a => {"+b" => [1, 2]}}, 88 | {a => {b => [1, 2]}} 89 | ], 90 | 91 | [ 92 | {a => {b => [1, 'bar']}}, 93 | {a => {"+b" => [2, 'foo']}}, 94 | {a => {b => [1, 'bar', 2, 'foo']}} 95 | ], 96 | 97 | [ 98 | {a => {b => [1, {bar => 'foo'}]}}, 99 | {a => {"+b" => [2, {bar => 'foo'}]}}, 100 | {a => {b => [1, {bar => 'foo'}, 2]}} 101 | ], 102 | 103 | # Merging only applies to arrays 104 | [{a => "bar"}, {"+a" => "foo"}, {a => "bar", "+a" => "foo"}], 105 | 106 | # A real modules initialization test 107 | [ 108 | { 109 | modules => ["+MyApp::Fully::Qualified"], 110 | modules_init => { 111 | "+MyApp::Fully::Qualified" => {bar => 1, foo => 'baz'} 112 | } 113 | }, 114 | { 115 | modules_init => { 116 | "+MyApp::Fully::Qualified" => {coo => 'bah'} 117 | } 118 | }, 119 | { 120 | modules => ["+MyApp::Fully::Qualified"], 121 | modules_init => { 122 | "+MyApp::Fully::Qualified" => {bar => 1, foo => 'baz', coo => 'bah'} 123 | } 124 | } 125 | ] 126 | 127 | ); 128 | _try(@arr); 129 | } 130 | 131 | # Remove from adday 132 | { 133 | my @arr = ( 134 | [ 135 | {a => {b => [1, 2]}}, 136 | {a => {"-b" => [2]}}, 137 | {a => {b => [1]}} 138 | ], 139 | [ 140 | {a => {b => [1, 2]}}, 141 | {a => {"-b" => [2, 3, 4]}}, 142 | {a => {b => [1]}} 143 | ], 144 | [ 145 | {a => {b => [1, 2, "bar"]}}, 146 | {a => {"-b" => ["bar", 3, 2]}}, 147 | {a => {b => [1]}} 148 | ], 149 | [ 150 | {a => {b => [1, 2, {bar => 'foo'}]}}, 151 | {a => {"-b" => [{bar => 'foo'}, 1]}}, 152 | {a => {b => [2]}} 153 | ], 154 | ); 155 | _try(@arr); 156 | } 157 | 158 | sub _try 159 | { 160 | for (@_) { 161 | my ($a, $b, $c) = @$_; 162 | my $m = Kelp::Module::Config::_merge($a, $b); 163 | is_deeply($m, $c) or diag explain $m; 164 | } 165 | } 166 | 167 | done_testing; 168 | -------------------------------------------------------------------------------- /lib/Kelp/Base.pm: -------------------------------------------------------------------------------- 1 | package Kelp::Base; 2 | 3 | use strict; 4 | use warnings; 5 | use feature (); 6 | use Carp; 7 | 8 | require namespace::autoclean; 9 | require Kelp::Util; 10 | 11 | sub import 12 | { 13 | my $class = shift; 14 | my $caller = caller; 15 | 16 | # Do not import into inherited classes 17 | return if $class ne __PACKAGE__; 18 | 19 | my $base = shift || $class; 20 | 21 | if ($base ne '-strict') { 22 | no strict 'refs'; 23 | no warnings 'redefine'; 24 | 25 | if ($base ne '-attr') { 26 | Kelp::Util::load_package($base); 27 | push @{"${caller}::ISA"}, $base; 28 | } 29 | 30 | *{"${caller}::attr"} = sub { attr($caller, @_) }; 31 | 32 | namespace::autoclean->import( 33 | -cleanee => $caller 34 | ); 35 | } 36 | 37 | strict->import; 38 | warnings->import; 39 | feature->import(':5.10'); 40 | } 41 | 42 | sub new 43 | { 44 | my $self = shift; 45 | return bless {@_}, $self; 46 | } 47 | 48 | sub attr 49 | { 50 | my ($class, $name, $default) = @_; 51 | 52 | if (ref $default && ref $default ne 'CODE') { 53 | croak "Default value for '$name' can not be a reference."; 54 | } 55 | 56 | # Readonly attributes are marked with '-' 57 | my $readonly = $name =~ s/^\-//; 58 | 59 | # Remember if default is a function 60 | my $default_sub = ref $default eq 'CODE'; 61 | 62 | { 63 | no strict 'refs'; 64 | no warnings 'redefine'; 65 | 66 | *{"${class}::$name"} = sub { 67 | return $_[0]->{$name} = $_[1] if @_ > 1 && !$readonly; 68 | return $_[0]->{$name} if exists $_[0]->{$name}; 69 | return $_[0]->{$name} = $default_sub ? $default->($_[0]) : $default; 70 | }; 71 | } 72 | } 73 | 74 | 1; 75 | 76 | __END__ 77 | 78 | =pod 79 | 80 | =head1 NAME 81 | 82 | Kelp::Base - Simple lazy attributes 83 | 84 | =head1 SYNOPSIS 85 | 86 | use Kelp::Base; 87 | 88 | attr source => 'dbi:mysql:users'; 89 | attr user => 'test'; 90 | attr pass => 'secret'; 91 | attr opts => sub { { PrintError => 1, RaiseError => 1 } }; 92 | 93 | attr dbh => sub { 94 | my $self = shift; 95 | DBI->connect( $self->sourse, $self->user, $self->pass, $self->opts ); 96 | }; 97 | 98 | # Later ... 99 | sub do_stuff { 100 | my $self = shift; 101 | $self->dbh->do('DELETE FROM accounts'); 102 | } 103 | 104 | or 105 | 106 | use Kelp::Base 'Module::Name'; # Extend Module::Name 107 | 108 | or 109 | 110 | use Kelp::Base -strict; # Only use strict, warnings and v5.10 111 | # No magic 112 | 113 | =head1 DESCRIPTION 114 | 115 | This module provides simple lazy attributes. 116 | 117 | =head1 WHY? 118 | 119 | Some users will naturally want to ask F<"Why not use Moose/Mouse/Moo/Mo?">. The 120 | answer is that the Kelp web framework needs lazy attributes, but the author 121 | wanted to keep the code light and object manager agnostic. This allows the 122 | users of the framework to choose an object manager to their liking. As a nice 123 | addition, our getters and constructors are quite a bit faster than any non-XS 124 | variant of L, which makes the core code very fast. 125 | 126 | There is nothing more annoying than a module that forces you to use L 127 | when you are perfectly fine with L or L, for example. Since this 128 | module is so minimal, you should probably switch to a full-blown OO system of 129 | your choice when writing your application. Kelp::Base should be compatible with 130 | it as long as it uses blessed hashes under the hood. 131 | 132 | =head1 USAGE 133 | 134 | use Kelp::Base; 135 | 136 | The above will automatically include C, C and C. It will 137 | also inject a new sub in the current class called C. 138 | 139 | attr name1 => 1; # Fixed value 140 | attr name2 => sub { [ 1, 2, 3 ] }; # Array 141 | attr name3 => sub { 142 | $_[0]->other; 143 | } 144 | 145 | ... 146 | 147 | say $self->name1; # 1 148 | $self->name2( [ 6, 7, 8 ] ); # Set new value 149 | 150 | All those attributes will be available for reading and writing in each instance 151 | of the current class. If you want to create a read-only attribute, prefix its 152 | name with a dash. 153 | 154 | attr -readonly => "something"; 155 | 156 | # Later 157 | say $self->readonly; # something 158 | $self->readonly("nothing"); # no change 159 | 160 | Kelp::Base can also be imported without turning an object into a class: 161 | 162 | # imports strict, warnings and :5.10 163 | use Kelp::Base -strict; 164 | 165 | # imports all of the above plus attr 166 | use Kelp::Base -attr; 167 | 168 | The former is useful for less boilerplate in scripts on older perls. The latter 169 | is useful when using C with L. 170 | 171 | =head1 SEE ALSO 172 | 173 | L, L, L, L, L 174 | 175 | =cut 176 | 177 | -------------------------------------------------------------------------------- /lib/Kelp/Module/Template.pm: -------------------------------------------------------------------------------- 1 | package Kelp::Module::Template; 2 | 3 | use Kelp::Base 'Kelp::Module'; 4 | use Kelp::Template; 5 | 6 | attr ext => 'tt'; 7 | attr engine => sub { die "'engine' must be initialized" }; 8 | 9 | sub build 10 | { 11 | my ($self, %args) = @_; 12 | 13 | # Build and initialize the engine attribute 14 | $self->engine($self->build_engine(%args)); 15 | 16 | # Register one method - template 17 | $self->register( 18 | template => sub { 19 | my ($app, $template, $vars, @rest) = @_; 20 | $vars //= {}; 21 | $vars->{app} //= $app; 22 | 23 | return $self->render($self->_rename($template), $vars, @rest); 24 | } 25 | ); 26 | } 27 | 28 | sub build_engine 29 | { 30 | my ($self, %args) = @_; 31 | return Kelp::Template->new(%args); 32 | } 33 | 34 | sub render 35 | { 36 | my ($self, $template, $vars) = @_; 37 | return $self->engine->process($template, $vars); 38 | } 39 | 40 | sub _rename 41 | { 42 | my ($self, $name) = @_; 43 | $name //= ''; 44 | 45 | return $name if ref $name; 46 | return undef unless length $name; 47 | 48 | my $ext = $self->ext // ''; 49 | return $name unless length $ext; 50 | 51 | return $name if $name =~ /\./; 52 | return "$name.$ext"; 53 | } 54 | 55 | 1; 56 | 57 | __END__ 58 | 59 | =pod 60 | 61 | =head1 NAME 62 | 63 | Kelp::Module::Template - Template processing for Kelp applications 64 | 65 | =head1 SYNOPSIS 66 | 67 | First ... 68 | 69 | # conf/config.pl 70 | { 71 | modules => ['Template'], 72 | modules_init => { 73 | Template => { ... } 74 | } 75 | }; 76 | 77 | Then ... 78 | 79 | # lib/MyApp.pm 80 | sub some_route { 81 | my $self = shift; 82 | $self->template('some_template', { bar => 'foo' }); 83 | } 84 | 85 | =head1 DESCRIPTION 86 | 87 | This module provides an interface for using templates in a Kelp web application. It 88 | uses L, but it could be easily subclassed to use anything else. 89 | 90 | =head1 REGISTERED METHODS 91 | 92 | =head2 template 93 | 94 | C 95 | 96 | Renders a file using the currently loaded template engine. If the file doesn't 97 | have an extension, the one specified in L will be assigned to it. 98 | 99 | If there is no C in C<%vars>, it will be automatically added. 100 | 101 | =head1 ATTRIBUTES 102 | 103 | =head2 ext 104 | 105 | The default extension of the template files. This module sets this attribute to 106 | C, so 107 | 108 | $self->template( 'home' ); 109 | 110 | will look for C. Set to undef or empty string to skip adding the 111 | extension to filenames. 112 | 113 | =head2 engine 114 | 115 | This attribute will be initialized by the C method of this module, 116 | and it is available to all code that needs access to the template engine 117 | instance. See L for an example. 118 | 119 | =head1 METHODS 120 | 121 | =head2 build_engine 122 | 123 | C 124 | 125 | This method is responsible for creating, initializing and returning an instance 126 | of the template engine used, for example L