├── .gitignore ├── .perlcriticrc ├── .perltidyrc ├── .tidyallrc ├── .travis.yml ├── Build.PL ├── Changes ├── LICENSE ├── META.json ├── README.md ├── cpanfile ├── lib ├── Tu.pm └── Tu │ ├── ACL.pm │ ├── ACL │ └── FromConfig.pm │ ├── Action.pm │ ├── Action │ └── FormMixin.pm │ ├── ActionFactory.pm │ ├── ActionFactory │ └── Observable.pm │ ├── ActionResponseResolver.pm │ ├── AssetsContainer.pm │ ├── Auth │ └── Session.pm │ ├── Config.pm │ ├── Config │ ├── Pl.pm │ └── Yml.pm │ ├── DispatchedRequest.pm │ ├── DispatchedRequest │ └── Routes.pm │ ├── Dispatcher.pm │ ├── Dispatcher │ └── Routes.pm │ ├── Displayer.pm │ ├── Factory.pm │ ├── Factory │ └── Observable.pm │ ├── FromConfig.pm │ ├── Helper.pm │ ├── Helper │ ├── Assets.pm │ └── Displayer.pm │ ├── HelperFactory.pm │ ├── HelperFactory │ └── Persistent.pm │ ├── Home.pm │ ├── Loader.pm │ ├── Mailer.pm │ ├── Mailer │ ├── SMTP.pm │ ├── Sendmail.pm │ └── Test.pm │ ├── Middleware.pm │ ├── Middleware │ ├── ACL.pm │ ├── ActionDispatcher.pm │ ├── Defaults.pm │ ├── I18N.pm │ ├── LanguageDetection.pm │ ├── MultilingualParser.pm │ ├── RequestDispatcher.pm │ ├── SerializerJSON.pm │ ├── Session │ │ └── Cookie.pm │ ├── Static.pm │ ├── User.pm │ └── ViewDisplayer.pm │ ├── ObservableMixin.pm │ ├── Observer │ └── Base.pm │ ├── Renderer.pm │ ├── Renderer │ ├── APL.pm │ └── Caml.pm │ ├── Request.pm │ ├── Response.pm │ ├── Routes.pm │ ├── Routes │ └── FromConfig.pm │ ├── Scope.pm │ ├── ServiceContainer.pm │ ├── ServiceContainer │ ├── Actions.pm │ ├── Common.pm │ ├── Config.pm │ ├── Displayer.pm │ ├── Mailer.pm │ └── Routes.pm │ ├── Util.pm │ ├── Validator.pm │ ├── Validator │ ├── Base.pm │ ├── Callback.pm │ ├── Compare.pm │ ├── In.pm │ └── Regexp.pm │ ├── ValidatorResult.pm │ └── X │ ├── Base.pm │ └── HTTP.pm ├── minil.toml └── t ├── acl.t ├── acl ├── from_config.t └── from_config_t │ ├── acl.yml │ └── empty.yml ├── action.t ├── action └── form_mixin.t ├── action_response_resolver.t ├── app.t ├── app ├── simple.t └── simple_t │ ├── app.psgi │ ├── config │ ├── config.dev.yml │ └── config.yml │ ├── lib │ ├── TestAppSimple.pm │ └── TestAppSimple │ │ └── Action │ │ └── Index.pm │ └── templates │ ├── index.apl │ └── layout.apl ├── assets_container.t ├── auth └── session.t ├── config.t ├── config_t ├── config.dev.yml ├── config.foo ├── config.test.yml ├── config.yml ├── empty.yml ├── error.yml ├── koi8.yml └── unknown ├── dispatcher └── routes.t ├── displayer.t ├── displayer └── renderer.t ├── factory.t ├── factory └── observable.t ├── factory_t ├── DieDuringCreation.pm ├── Foo.pm └── WithSyntaxErrors.pm ├── helper.t ├── helper └── displayer.t ├── helper_factory.t ├── helper_factory └── persistent.t ├── helper_t └── Helper.pm ├── home.t ├── loader.t ├── loader_t ├── Bar │ └── Class.pm ├── TryLoadClass.pm └── WithSyntaxErrors.pm ├── mailer.t ├── middleware ├── acl.t ├── action_dispatcher.t ├── action_dispatcher_t │ ├── CustomResponse.pm │ └── NoResponse.pm ├── language_detection.t ├── multiligual_parser.t ├── request_dispatcher.t ├── serializer_json.t ├── session_cookie.t ├── static.t ├── static_t │ └── public │ │ └── static │ │ └── file.txt ├── user.t └── view_displayer.t ├── observable_mixin.t ├── observer └── base.t ├── request.t ├── response.t ├── routes ├── from_config.t └── from_config_t │ ├── bad.yml │ ├── empty.yml │ └── routes.yml ├── scope.t ├── service_container.t ├── tidyall.t ├── validator.t ├── validator ├── compare.t ├── in.t └── regexp.t ├── validator_result.t ├── x.t └── x_http.t /.gitignore: -------------------------------------------------------------------------------- 1 | *.sw[p-z] 2 | blib 3 | Makefile 4 | MANIFEST 5 | Makefile.old 6 | pm_to_blib 7 | *.bak 8 | *~ 9 | cover_db 10 | _build/ 11 | Build 12 | MYMETA.* 13 | local/ 14 | .tidyall.d 15 | -------------------------------------------------------------------------------- /.perlcriticrc: -------------------------------------------------------------------------------- 1 | severity = 1 2 | color = 1 3 | 4 | # Perl::Critic::Dynamic 5 | [Dynamic::ValidateAgainstSymbolTable] 6 | 7 | # Perl::Critic::StricterSubs 8 | [Modules::RequireExplicitInclusion] 9 | [-Subroutines::ProhibitCallsToUnexportedSubs] 10 | 11 | # Perl::Critic::Bangs 12 | [Bangs::ProhibitVagueNames] 13 | 14 | # Useless 15 | 16 | [-CodeLayout::ProhibitParensWithBuiltins] 17 | [-ControlStructures::ProhibitCStyleForLoops] 18 | [-ControlStructures::ProhibitPostfixControls] 19 | [-Modules::ProhibitMultiplePackages] 20 | [-Modules::RequireVersionVar] 21 | [-References::ProhibitDoubleSigils] 22 | [-RegularExpressions::ProhibitEscapedMetacharacters] 23 | [-RegularExpressions::RequireDotMatchAnything] 24 | [-RegularExpressions::RequireExtendedFormatting] 25 | [-RegularExpressions::RequireLineBoundaryMatching] 26 | [-Subroutines::ProhibitAmpersandSigils] 27 | [-Subroutines::RequireArgUnpacking] 28 | [-Subroutines::RequireFinalReturn] 29 | [-ValuesAndExpressions::ProhibitEmptyQuotes] 30 | [-ValuesAndExpressions::ProhibitMagicNumbers] 31 | [-ValuesAndExpressions::RequireInterpolationOfMetachars] 32 | [-InputOutput::RequireBracedFileHandleWithPrint] 33 | [-Variables::ProhibitPunctuationVars] 34 | [-TestingAndDebugging::ProhibitNoStrict] 35 | [-BuiltinFunctions::ProhibitStringyEval] 36 | [-ValuesAndExpressions::ProhibitEscapedCharacters] 37 | [-ClassHierarchies::ProhibitAutoloading] 38 | [-RegularExpressions::ProhibitEnumeratedClasses] 39 | [-Variables::ProhibitPackageVars] 40 | [-Modules::ProhibitAutomaticExportation] 41 | [-InputOutput::RequireCheckedClose] 42 | [-InputOutput::RequireCheckedSyscalls] 43 | [-NamingConventions::Capitalization] 44 | 45 | # Not so sure 46 | 47 | [-Subroutines::ProhibitUnusedPrivateSubroutines] 48 | [-ValuesAndExpressions::ProhibitNoisyQuotes] 49 | [-Subroutines::ProhibitBuiltinHomonyms] 50 | -------------------------------------------------------------------------------- /.perltidyrc: -------------------------------------------------------------------------------- 1 | --paren-tightness=2 2 | --square-bracket-tightness=2 3 | --brace-tightness=2 4 | 5 | --nospace-terminal-semicolon 6 | --nospace-for-semicolon 7 | -------------------------------------------------------------------------------- /.tidyallrc: -------------------------------------------------------------------------------- 1 | [PerlTidy] 2 | select = {lib,t}/**/*.{pl,pm,t,psgi} 3 | argv = --profile=$ROOT/.perltidyrc 4 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: perl 2 | perl: 3 | - "5.22" 4 | - "5.24" 5 | before_install: 6 | # cpanm -n Devel::Cover::Report::Kritika 7 | - cpanm -n https://github.com/kritikaio/devel-cover-report-kritika-perl/archive/master.tar.gz 8 | install: 9 | - cpanm -n -q --with-recommends --skip-satisfied --installdeps . 10 | script: 11 | - perl Build.PL && ./Build build && cover -test -report kritika 12 | -------------------------------------------------------------------------------- /Build.PL: -------------------------------------------------------------------------------- 1 | # ========================================================================= 2 | # THIS FILE IS AUTOMATICALLY GENERATED BY MINILLA. 3 | # DO NOT EDIT DIRECTLY. 4 | # ========================================================================= 5 | 6 | use 5.008_001; 7 | use strict; 8 | 9 | use Module::Build::Tiny 0.035; 10 | 11 | Build_PL(); 12 | 13 | -------------------------------------------------------------------------------- /Changes: -------------------------------------------------------------------------------- 1 | Revision history for perl module Tu 2 | 3 | {{$NEXT}} 4 | -------------------------------------------------------------------------------- /META.json: -------------------------------------------------------------------------------- 1 | { 2 | "abstract" : "tu", 3 | "author" : [ 4 | "Viacheslav Tykhanovskyi, C" 5 | ], 6 | "dynamic_config" : 0, 7 | "generated_by" : "Minilla/v3.0.4, CPAN::Meta::Converter version 2.150010", 8 | "license" : [ 9 | "artistic_2" 10 | ], 11 | "meta-spec" : { 12 | "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", 13 | "version" : "2" 14 | }, 15 | "name" : "Tu", 16 | "no_index" : { 17 | "directory" : [ 18 | "t", 19 | "xt", 20 | "inc", 21 | "share", 22 | "eg", 23 | "examples", 24 | "author", 25 | "builder" 26 | ] 27 | }, 28 | "prereqs" : { 29 | "configure" : { 30 | "requires" : { 31 | "Module::Build::Tiny" : "0.035" 32 | } 33 | }, 34 | "develop" : { 35 | "requires" : { 36 | "Test::CPAN::Meta" : "0", 37 | "Test::MinimumVersion::Fast" : "0.04", 38 | "Test::PAUSE::Permissions" : "0.04", 39 | "Test::Pod" : "1.41", 40 | "Test::Spellunker" : "v0.2.7" 41 | } 42 | }, 43 | "runtime" : { 44 | "recommends" : { 45 | "Email::MIME" : "0", 46 | "I18N::AcceptLanguage" : "0", 47 | "JSON" : "0", 48 | "Plack::Middleware::Session" : "0", 49 | "Plack::Middleware::Session::Cookie" : "0", 50 | "Text::APL" : "0", 51 | "Text::Caml" : "0", 52 | "YAML::Tiny" : "0" 53 | }, 54 | "requires" : { 55 | "JSON" : "0", 56 | "Plack" : "0", 57 | "Routes::Tiny" : "0.14", 58 | "String::CamelCase" : "0", 59 | "perl" : "5.012" 60 | } 61 | }, 62 | "test" : { 63 | "requires" : { 64 | "Test::Fatal" : "0", 65 | "Test::MonkeyMock" : "0", 66 | "Test::More" : "0", 67 | "Test::Requires" : "0", 68 | "Test::TempDir::Tiny" : "0" 69 | } 70 | } 71 | }, 72 | "release_status" : "unstable", 73 | "resources" : { 74 | "bugtracker" : { 75 | "web" : "https://github.com///issues" 76 | }, 77 | "homepage" : "https://github.com//", 78 | "repository" : { 79 | "type" : "git", 80 | "url" : "git://github.com//.git", 81 | "web" : "https://github.com//" 82 | } 83 | }, 84 | "version" : "0.01", 85 | "x_contributors" : [ 86 | "forwardever ", 87 | "vti ", 88 | "vti " 89 | ], 90 | "x_serialization_backend" : "JSON::PP version 2.27300_01" 91 | } 92 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # NAME 2 | 3 | Tu - tu 4 | 5 | # SYNOPSIS 6 | 7 | # DESCRIPTION 8 | 9 | # DEVELOPMENT 10 | 11 | ## Repository 12 | 13 | http://github.com/vti/tu 14 | 15 | # AUTHOR 16 | 17 | Viacheslav Tykhanovskyi, `vti@cpan.org` 18 | 19 | # COPYRIGHT AND LICENSE 20 | 21 | Copyright (C) 2014-2017, Viacheslav Tykhanovskyi 22 | 23 | This program is free software, you can redistribute it and/or modify it under 24 | the terms of the Artistic License version 2.0. 25 | -------------------------------------------------------------------------------- /cpanfile: -------------------------------------------------------------------------------- 1 | requires 'JSON'; 2 | requires 'Plack'; 3 | requires 'Routes::Tiny' => '0.14'; 4 | requires 'String::CamelCase'; 5 | 6 | recommends 'Email::MIME'; 7 | recommends 'JSON'; 8 | recommends 'Text::Caml'; 9 | recommends 'Text::APL'; 10 | recommends 'YAML::Tiny'; 11 | recommends 'Plack::Middleware::Session'; 12 | recommends 'Plack::Middleware::Session::Cookie'; 13 | recommends 'I18N::AcceptLanguage'; 14 | 15 | on 'test' => sub { 16 | requires 'Test::Requires'; 17 | requires 'Test::Fatal'; 18 | requires 'Test::More'; 19 | requires 'Test::MonkeyMock'; 20 | requires 'Test::TempDir::Tiny'; 21 | }; 22 | -------------------------------------------------------------------------------- /lib/Tu.pm: -------------------------------------------------------------------------------- 1 | package Tu; 2 | 3 | use strict; 4 | use warnings; 5 | use 5.012; 6 | 7 | our $VERSION = '0.01'; 8 | 9 | use Tu::Home; 10 | use Tu::X::HTTP; 11 | use Tu::ServiceContainer; 12 | 13 | use overload q(&{}) => sub { shift->to_app }, fallback => 1; 14 | 15 | sub new { 16 | my $class = shift; 17 | my (%params) = @_; 18 | 19 | my $self = {}; 20 | bless $self, $class; 21 | 22 | $self->{builder} = $params{builder}; 23 | $self->{services} = $params{services}; 24 | 25 | my $app_class = ref $self; 26 | 27 | my $home = $params{home} || Tu::Home->new(app_class => $app_class); 28 | $home = Tu::Home->new(path => $home) unless ref $home; 29 | 30 | $self->{services} ||= Tu::ServiceContainer->new; 31 | $self->{services}->register(app_class => $app_class); 32 | $self->{services}->register(home => $home); 33 | 34 | $self->startup(%params); 35 | 36 | return $self; 37 | } 38 | 39 | sub services { $_[0]->{services} } 40 | 41 | sub service { 42 | my $self = shift; 43 | my ($name) = @_; 44 | 45 | $self->{services}->service($name); 46 | } 47 | 48 | sub startup { $_[0] } 49 | 50 | sub default_app { 51 | sub { Tu::X::HTTP->throw('Not Found', code => 404) } 52 | } 53 | 54 | sub to_app { 55 | my $self = shift; 56 | 57 | $self->{psgi_app} ||= $self->default_app; 58 | 59 | return $self->{psgi_app}; 60 | } 61 | 62 | 1; 63 | __END__ 64 | 65 | =head1 NAME 66 | 67 | Tu - tu 68 | 69 | =head1 SYNOPSIS 70 | 71 | =head1 DESCRIPTION 72 | 73 | =head1 DEVELOPMENT 74 | 75 | =head2 Repository 76 | 77 | http://github.com/vti/tu 78 | 79 | =head1 AUTHOR 80 | 81 | Viacheslav Tykhanovskyi, C 82 | 83 | =head1 COPYRIGHT AND LICENSE 84 | 85 | Copyright (C) 2014-2017, Viacheslav Tykhanovskyi 86 | 87 | This program is free software, you can redistribute it and/or modify it under 88 | the terms of the Artistic License version 2.0. 89 | 90 | =cut 91 | -------------------------------------------------------------------------------- /lib/Tu/ACL.pm: -------------------------------------------------------------------------------- 1 | package Tu::ACL; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Carp qw(croak); 7 | use List::Util qw(first); 8 | use Scalar::Util qw(blessed); 9 | 10 | sub new { 11 | my $class = shift; 12 | 13 | my $self = {}; 14 | bless $self, $class; 15 | 16 | return $self; 17 | } 18 | 19 | sub add_role { 20 | my $self = shift; 21 | my ($role, @parents) = @_; 22 | 23 | $self->{roles}->{$role} = {allow => [], deny => []}; 24 | 25 | foreach my $parent (@parents) { 26 | push @{$self->{roles}->{$role}->{deny}}, 27 | @{$self->{roles}->{$parent}->{deny}}; 28 | push @{$self->{roles}->{$role}->{allow}}, 29 | @{$self->{roles}->{$parent}->{allow}}; 30 | } 31 | 32 | return $self; 33 | } 34 | 35 | sub allow { 36 | my $self = shift; 37 | my ($role, $action, %options) = @_; 38 | 39 | if ($role eq '*') { 40 | foreach my $role (keys %{$self->{roles}}) { 41 | $self->allow($role, $action, %options); 42 | } 43 | } 44 | else { 45 | croak 'Unknown role' unless $self->_role_exists($role); 46 | 47 | push @{$self->{roles}->{$role}->{allow}}, {action => $action, options => \%options}; 48 | } 49 | 50 | return $self; 51 | } 52 | 53 | sub deny { 54 | my $self = shift; 55 | my ($role, $action, %options) = @_; 56 | 57 | if ($role eq '*') { 58 | foreach my $role (keys %{$self->{roles}}) { 59 | $self->deny($role, $action, %options); 60 | } 61 | } 62 | else { 63 | croak 'Unknown role' unless $self->_role_exists($role); 64 | 65 | push @{$self->{roles}->{$role}->{deny}}, {action => $action, options => \%options}; 66 | } 67 | 68 | return $self; 69 | } 70 | 71 | sub is_allowed { 72 | my $self = shift; 73 | my ($role, $action, %params) = @_; 74 | 75 | return 0 unless $self->_role_exists($role); 76 | 77 | foreach my $denied_action (@{$self->{roles}->{$role}->{deny}}) { 78 | if ($self->_equals($action, $denied_action->{action})) { 79 | if ($self->_eval_options($denied_action, $role, $action, %params)) { 80 | return 0; 81 | } 82 | } 83 | } 84 | 85 | if (my $allow_action = first { $_->{action} eq $action || $_->{action} eq '*' } 86 | @{$self->{roles}->{$role}->{allow}}) 87 | { 88 | return $self->_eval_options($allow_action, $role, $action, %params); 89 | 90 | return 1; 91 | } 92 | 93 | return 0; 94 | } 95 | 96 | sub _eval_options { 97 | my $self = shift; 98 | my ($action, @args) = @_; 99 | 100 | return 1 101 | unless $action 102 | && $action->{options} 103 | && (my $when = $action->{options}->{when}); 104 | 105 | if (ref $when eq 'CODE') { 106 | return $when->(@args); 107 | } 108 | elsif (blessed $when) { 109 | return $when->check(@args); 110 | } 111 | 112 | return 0; 113 | } 114 | 115 | sub _role_exists { 116 | my $self = shift; 117 | my ($role) = @_; 118 | 119 | return exists $self->{roles}->{$role}; 120 | } 121 | 122 | sub _equals { 123 | my $self = shift; 124 | my ($action, $denied_action) = @_; 125 | 126 | if (ref $denied_action eq 'Regexp') { 127 | return 1 if $action =~ $denied_action; 128 | } 129 | else { 130 | return 1 if $action eq $denied_action; 131 | } 132 | 133 | return 0; 134 | } 135 | 136 | 1; 137 | -------------------------------------------------------------------------------- /lib/Tu/ACL/FromConfig.pm: -------------------------------------------------------------------------------- 1 | package Tu::ACL::FromConfig; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use parent 'Tu::FromConfig'; 7 | 8 | use Tu::ACL; 9 | 10 | sub new { 11 | my $self = shift->SUPER::new(@_); 12 | my (%params) = @_; 13 | 14 | $self->{acl} = $params{acl} || Tu::ACL->new; 15 | 16 | return $self; 17 | } 18 | 19 | sub _from_config { 20 | my $self = shift; 21 | my ($config) = @_; 22 | 23 | my $acl = $self->{acl}; 24 | 25 | return $acl unless %$config; 26 | 27 | foreach my $role (@{$config->{roles}}) { 28 | $acl->add_role($role); 29 | } 30 | 31 | foreach my $role (keys %{$config->{allow}}) { 32 | foreach my $path (@{$config->{allow}->{$role}}) { 33 | $acl->allow($role, $path); 34 | } 35 | } 36 | 37 | foreach my $role (keys %{$config->{deny}}) { 38 | foreach my $path (@{$config->{deny}->{$role}}) { 39 | $acl->deny($role, $path); 40 | } 41 | } 42 | 43 | return $acl; 44 | } 45 | 46 | 1; 47 | -------------------------------------------------------------------------------- /lib/Tu/Action.pm: -------------------------------------------------------------------------------- 1 | package Tu::Action; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Carp qw(croak); 7 | use Scalar::Util qw(blessed); 8 | use Tu::X::HTTP; 9 | use Tu::Scope; 10 | use Tu::Request; 11 | 12 | sub new { 13 | my $class = shift; 14 | my (%params) = @_; 15 | 16 | my $self = {}; 17 | bless $self, $class; 18 | 19 | $self->{env} = $params{env} || croak '$env required'; 20 | $self->{services} = $params{services}; 21 | 22 | return $self; 23 | } 24 | 25 | sub service { 26 | my $self = shift; 27 | my ($name) = @_; 28 | 29 | return $self->{services}->service($name); 30 | } 31 | 32 | sub services { 33 | my $self = shift; 34 | 35 | return $self->{services}; 36 | } 37 | 38 | sub env { 39 | my $self = shift; 40 | 41 | return $self->{env}; 42 | } 43 | 44 | sub scope { Tu::Scope->new($_[0]->{env}) } 45 | 46 | sub req { 47 | my $self = shift; 48 | 49 | $self->{req} ||= Tu::Request->new($self->env); 50 | 51 | return $self->{req}; 52 | } 53 | 54 | sub new_response { 55 | my $self = shift; 56 | 57 | return $self->req->new_response(@_); 58 | } 59 | 60 | sub url_for { 61 | my $self = shift; 62 | my ($url_or_name, %params) = @_; 63 | 64 | my $url; 65 | 66 | if ($_[0] =~ m{^/}) { 67 | my $path = $url_or_name; 68 | $path =~ s{^/}{}; 69 | 70 | $url = $self->req->base; 71 | $url->path($url->path . $path); 72 | } 73 | elsif ($_[0] =~ m{^https?://}) { 74 | $url = $_[0]; 75 | } 76 | else { 77 | my $dispatched_request = $self->scope->dispatched_request; 78 | 79 | my $path = $dispatched_request->build_path($url_or_name, %params); 80 | 81 | $path =~ s{^/}{}; 82 | 83 | $url = $self->req->base; 84 | $url->path($url->path . $path); 85 | } 86 | 87 | return $url; 88 | } 89 | 90 | sub captures { $_[0]->scope->dispatched_request->captures } 91 | 92 | sub vars { $_[0]->scope->displayer->vars } 93 | 94 | sub set_var { 95 | my $self = shift; 96 | 97 | my $vars_scope = $self->vars; 98 | 99 | for (my $i = 0; $i < @_; $i += 2) { 100 | my $key = $_[$i]; 101 | my $value = $_[$i + 1]; 102 | 103 | $vars_scope->{$key} = $value; 104 | } 105 | 106 | return $self; 107 | } 108 | 109 | sub throw_forbidden { 110 | my $self = shift; 111 | my ($message) = @_; 112 | 113 | $self->throw_error($message, 403); 114 | } 115 | 116 | sub throw_not_found { 117 | my $self = shift; 118 | my ($message) = @_; 119 | 120 | $self->throw_error($message, 404); 121 | } 122 | 123 | sub throw_error { 124 | my $self = shift; 125 | my ($message, $code) = @_; 126 | 127 | Tu::X::HTTP->throw($message, code => $code || 500); 128 | } 129 | 130 | sub redirect { 131 | my $self = shift; 132 | my ($path, @args) = @_; 133 | 134 | my $status = 302; 135 | if (@args % 2 != 0) { 136 | $status = pop @args; 137 | } 138 | 139 | my $url = blessed($path) 140 | && $path->isa('URI') ? $path : $self->url_for($path, @args); 141 | 142 | my $res = $self->new_response($status); 143 | $res->header(Location => $url); 144 | 145 | return $res; 146 | } 147 | 148 | sub render { 149 | my $self = shift; 150 | my ($template, %args) = @_; 151 | 152 | my $displayer_scope = $self->scope->displayer; 153 | 154 | $args{vars} = {%{$displayer_scope->vars}, %{$args{vars} || {}}}; 155 | 156 | if ($displayer_scope->exists('layout') 157 | && !exists $args{layout}) 158 | { 159 | $args{layout} = $displayer_scope->layout; 160 | } 161 | 162 | return $self->service('displayer')->render($template, %args); 163 | } 164 | 165 | 1; 166 | -------------------------------------------------------------------------------- /lib/Tu/Action/FormMixin.pm: -------------------------------------------------------------------------------- 1 | package Tu::Action::FormMixin; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use parent 'Exporter'; 7 | 8 | our @EXPORT_OK = qw(validate_or_submit); 9 | 10 | sub validate_or_submit { 11 | my $self = shift; 12 | 13 | if ($self->req->method eq 'GET') { 14 | return $self->show if $self->can('show'); 15 | return; 16 | } 17 | 18 | my $params = $self->req->parameters->as_hashref_mixed; 19 | $params = {%$params, %{$self->req->uploads->as_hashref_mixed || {}}}; 20 | 21 | my $result = $self->build_validator->validate($params); 22 | 23 | my $ok = $result->is_success; 24 | 25 | if ($result->is_success && $self->can('validate')) { 26 | $ok = $self->validate($result, $result->validated_params); 27 | } 28 | 29 | if ($ok) { 30 | return $self->submit($result->validated_params); 31 | } 32 | 33 | $self->set_var(errors => $result->errors); 34 | $self->set_var(params => $result->all_params); 35 | 36 | return $self->show_errors if $self->can('show_errors'); 37 | return; 38 | } 39 | 40 | 1; 41 | -------------------------------------------------------------------------------- /lib/Tu/ActionFactory.pm: -------------------------------------------------------------------------------- 1 | package Tu::ActionFactory; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Tu::Factory; 7 | 8 | sub new { 9 | my $class = shift; 10 | my (%params) = @_; 11 | 12 | my $self = {}; 13 | bless $self, $class; 14 | 15 | $self->{factory} = $params{factory} || Tu::Factory->new(try => 1, %params); 16 | 17 | return $self; 18 | } 19 | 20 | sub build { 21 | my $self = shift; 22 | my ($action, %args) = @_; 23 | 24 | return $self->{factory}->build($action, %args); 25 | } 26 | 27 | 1; 28 | -------------------------------------------------------------------------------- /lib/Tu/ActionFactory/Observable.pm: -------------------------------------------------------------------------------- 1 | package Tu::ActionFactory::Observable; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use base 'Tu::ActionFactory'; 7 | 8 | use Tu::Factory::Observable; 9 | 10 | sub new { 11 | shift->SUPER::new(factory => Tu::Factory::Observable->new(try => 1, @_)); 12 | } 13 | 14 | sub build { 15 | my $self = shift; 16 | my ($action, %args) = @_; 17 | 18 | my $env = $args{env}; 19 | my $dispatched_request = $env->{'tu.dispatched_request'}; 20 | my $params = $dispatched_request->params; 21 | 22 | if (my $observers = $params->{observers}) { 23 | $args{observers} = $observers; 24 | } 25 | 26 | return $self->{factory}->build($action, %args); 27 | } 28 | 29 | 1; 30 | -------------------------------------------------------------------------------- /lib/Tu/ActionResponseResolver.pm: -------------------------------------------------------------------------------- 1 | package Tu::ActionResponseResolver; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Carp qw(croak); 7 | use Encode (); 8 | 9 | sub new { 10 | my $class = shift; 11 | my (%params) = @_; 12 | 13 | my $self = {}; 14 | bless $self, $class; 15 | 16 | $self->{encoding} = $params{encoding}; 17 | $self->{encoding} = 'UTF-8' unless exists $params{encoding}; 18 | 19 | return $self; 20 | } 21 | 22 | sub resolve { 23 | my $self = shift; 24 | my ($res) = @_; 25 | 26 | return unless defined $res; 27 | 28 | unless (ref $res) { 29 | my $charset = ''; 30 | 31 | if (my $encoding = $self->{encoding}) { 32 | $res = Encode::encode($encoding, $res); 33 | $charset = '; charset=' . lc($encoding); 34 | } 35 | 36 | return [ 37 | 200, 38 | [ 39 | 'Content-Type' => "text/html$charset", 40 | 'Content-Length' => length($res) 41 | ], 42 | [$res] 43 | ]; 44 | } 45 | 46 | return $res if ref $res eq 'ARRAY' || ref $res eq 'CODE'; 47 | 48 | return $res->finalize if $res->isa('Tu::Response'); 49 | 50 | croak 'unexpected return from action'; 51 | } 52 | 53 | 1; 54 | -------------------------------------------------------------------------------- /lib/Tu/AssetsContainer.pm: -------------------------------------------------------------------------------- 1 | package Tu::AssetsContainer; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Carp qw(croak); 7 | use List::Util qw(first); 8 | use File::Spec; 9 | 10 | sub new { 11 | my $class = shift; 12 | my (%params) = @_; 13 | 14 | my $self = {}; 15 | bless $self, $class; 16 | 17 | $self->{public_dir} = $params{public_dir}; 18 | $self->{paths} = []; 19 | 20 | return $self; 21 | } 22 | 23 | sub require { 24 | my $self = shift; 25 | my ($path, %options) = @_; 26 | 27 | return $self if first { $path eq $_->{path} } @{$self->{paths}}; 28 | 29 | my $type = $options{type}; 30 | ($type) = $path =~ m/\.([^\.]+)$/ unless $type; 31 | 32 | push @{$self->{paths}}, {%options, type => $type, path => $path}; 33 | 34 | if (!ref($path) && (my $public_dir = $self->{public_dir})) { 35 | my $file = File::Spec->catfile($public_dir, $path); 36 | 37 | if (-e $file) { 38 | my $mtime = (stat($file))[9]; 39 | 40 | $self->{paths}->[-1]->{v} = $mtime; 41 | } 42 | } 43 | 44 | return $self; 45 | } 46 | 47 | sub include { 48 | my $self = shift; 49 | my (%params) = @_; 50 | 51 | my @assets = @{$self->{paths}}; 52 | 53 | if (my $type = $params{type}) { 54 | @assets = grep { $_->{type} && $_->{type} eq $type } @assets; 55 | } 56 | 57 | @assets = sort { ($a->{index} || 999) <=> ($b->{index} || 999) } @assets; 58 | 59 | my @html; 60 | foreach my $asset (@assets) { 61 | push @html, $self->_include_type($asset); 62 | } 63 | 64 | return join "\n", @html; 65 | } 66 | 67 | sub _include_type { 68 | my $self = shift; 69 | my ($options) = @_; 70 | 71 | my $path = $options->{path}; 72 | my $type = $options->{type}; 73 | 74 | my $v = ''; 75 | $v = '?v=' . $options->{v} if $options->{v}; 76 | 77 | my $attrs = ''; 78 | if ($options->{attrs} && %{$options->{attrs}}) { 79 | $attrs = ' ' 80 | . join(' ', 81 | map { qq{$_="$options->{attrs}->{$_}"} } keys %{$options->{attrs}}); 82 | } 83 | 84 | if ($type eq 'js') { 85 | return qq|| 86 | if ref $path eq 'SCALAR'; 87 | return qq||; 88 | } 89 | elsif ($type eq 'css') { 90 | return qq||; 92 | } 93 | else { 94 | croak "unknown asset type '$type'"; 95 | } 96 | } 97 | 98 | 1; 99 | -------------------------------------------------------------------------------- /lib/Tu/Auth/Session.pm: -------------------------------------------------------------------------------- 1 | package Tu::Auth::Session; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Carp qw(croak); 7 | use Plack::Session; 8 | 9 | sub new { 10 | my $class = shift; 11 | my (%params) = @_; 12 | 13 | my $self = {}; 14 | bless $self, $class; 15 | 16 | $self->{user_loader} = $params{user_loader}; 17 | 18 | croak 'user_loader required' unless $self->{user_loader}; 19 | 20 | return $self; 21 | } 22 | 23 | sub session { 24 | my $self = shift; 25 | my ($env) = @_; 26 | 27 | my $session = $self->_build_session($env); 28 | 29 | return $session->dump || {}; 30 | } 31 | 32 | sub load { 33 | my $self = shift; 34 | my ($env) = @_; 35 | 36 | my $session = $self->_build_session($env); 37 | 38 | my $options = $session->dump || {}; 39 | 40 | return $self->{user_loader}->load($options); 41 | } 42 | 43 | sub finalize { 44 | my $self = shift; 45 | my ($env) = @_; 46 | 47 | if ($self->{user_loader}->can('finalize')) { 48 | my $session = $self->_build_session($env); 49 | 50 | my $options = $session->dump; 51 | $self->{user_loader}->finalize($options); 52 | 53 | foreach my $key (keys %$options) { 54 | $session->set($key => $options->{$key}); 55 | } 56 | } 57 | } 58 | 59 | sub login { 60 | my $self = shift; 61 | my ($env, $options) = @_; 62 | 63 | my $session = $self->_build_session($env); 64 | 65 | if ($options && ref $options eq 'HASH') { 66 | $session->set($_ => $options->{$_}) for keys %$options; 67 | } 68 | 69 | return $self; 70 | } 71 | 72 | sub logout { 73 | my $self = shift; 74 | my ($env) = @_; 75 | 76 | my $session = $self->_build_session($env); 77 | $session->expire; 78 | 79 | return $self; 80 | } 81 | 82 | sub _build_session { 83 | my $self = shift; 84 | my ($env) = @_; 85 | 86 | $env->{'psgix.session'} ||= {}; 87 | $env->{'psgix.session.options'} ||= {}; 88 | 89 | return Plack::Session->new($env); 90 | } 91 | 92 | 1; 93 | -------------------------------------------------------------------------------- /lib/Tu/Config.pm: -------------------------------------------------------------------------------- 1 | package Tu::Config; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Carp qw(croak); 7 | use File::Basename (); 8 | 9 | use Tu::Loader; 10 | use Tu::Util qw(slurp); 11 | 12 | sub new { 13 | my $class = shift; 14 | my (%params) = @_; 15 | 16 | my $self = {}; 17 | bless $self, $class; 18 | 19 | $self->{mode} = $params{mode}; 20 | $self->{encoding} = $params{encoding}; 21 | 22 | $self->{encoding} = 'UTF-8' unless exists $params{encoding}; 23 | 24 | return $self; 25 | } 26 | 27 | sub load { 28 | my $self = shift; 29 | my ($path) = @_; 30 | 31 | $path = $self->_change_based_on_mode($path) if $self->{mode}; 32 | 33 | my $class = $self->_detect_type($path); 34 | 35 | my $config = slurp($path, $self->{encoding}); 36 | 37 | return $class->new->parse($config); 38 | } 39 | 40 | sub _change_based_on_mode { 41 | my $self = shift; 42 | my ($path) = @_; 43 | 44 | if ((my $mode = $ENV{PLACK_ENV}) && $ENV{PLACK_ENV} ne 'production') { 45 | $mode = 'dev' if $mode eq 'development'; 46 | 47 | $path =~ s{\.([^\.]+)$}{.$mode.$1}; 48 | } 49 | 50 | return $path; 51 | } 52 | 53 | sub _detect_type { 54 | my $self = shift; 55 | my ($path) = @_; 56 | 57 | my $basename = File::Basename::basename($path); 58 | my ($ext) = $basename =~ m{\.([^\.]+)$}; 59 | 60 | croak q{Can't guess a config format} unless $ext; 61 | 62 | my $class = __PACKAGE__ . '::' . ucfirst($ext); 63 | 64 | Tu::Loader->new->load_class($class); 65 | 66 | return $class; 67 | } 68 | 69 | 1; 70 | -------------------------------------------------------------------------------- /lib/Tu/Config/Pl.pm: -------------------------------------------------------------------------------- 1 | package Tu::Config::Pl; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Carp qw(croak); 7 | 8 | sub new { 9 | my $class = shift; 10 | 11 | my $self = {}; 12 | bless $self, $class; 13 | 14 | return $self; 15 | } 16 | 17 | sub parse { 18 | my $self = shift; 19 | my ($config) = @_; 20 | 21 | return eval $config or croak $@; 22 | } 23 | 24 | 1; 25 | -------------------------------------------------------------------------------- /lib/Tu/Config/Yml.pm: -------------------------------------------------------------------------------- 1 | package Tu::Config::Yml; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Encode (); 7 | use YAML::Tiny; 8 | use constant HAVE_YAML_XS => eval { require YAML::XS }; 9 | 10 | sub new { 11 | my $class = shift; 12 | 13 | my $self = {}; 14 | bless $self, $class; 15 | 16 | return $self; 17 | } 18 | 19 | sub parse { 20 | my $self = shift; 21 | my ($config) = @_; 22 | 23 | if (HAVE_YAML_XS) { 24 | $config = Encode::encode('UTF-8', $config) if Encode::is_utf8($config); 25 | 26 | $config = YAML::XS::Load($config); 27 | } 28 | else { 29 | $config = YAML::Tiny->read_string($config); 30 | $config = $config->[0]; 31 | } 32 | 33 | return $config || {}; 34 | } 35 | 36 | 1; 37 | -------------------------------------------------------------------------------- /lib/Tu/DispatchedRequest.pm: -------------------------------------------------------------------------------- 1 | package Tu::DispatchedRequest; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | sub new { 7 | my $class = shift; 8 | my (%params) = @_; 9 | 10 | my $self = {}; 11 | bless $self, $class; 12 | 13 | $self->{action} = $params{action}; 14 | $self->{captures} = $params{captures} || {}; 15 | $self->{params} = $params{params} || {}; 16 | 17 | return $self; 18 | } 19 | 20 | sub build_path { ... } 21 | 22 | sub action { 23 | my $self = shift; 24 | 25 | return $self->{action}; 26 | } 27 | 28 | sub captures { 29 | my $self = shift; 30 | 31 | return $self->{captures}; 32 | } 33 | 34 | sub params { 35 | my $self = shift; 36 | 37 | return $self->{params}; 38 | } 39 | 40 | 1; 41 | -------------------------------------------------------------------------------- /lib/Tu/DispatchedRequest/Routes.pm: -------------------------------------------------------------------------------- 1 | package Tu::DispatchedRequest::Routes; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use parent 'Tu::DispatchedRequest'; 7 | 8 | sub new { 9 | my $self = shift->SUPER::new(@_); 10 | my (%params) = @_; 11 | 12 | $self->{routes} = $params{routes}; 13 | 14 | return $self; 15 | } 16 | 17 | sub build_path { 18 | my $self = shift; 19 | 20 | return $self->{routes}->build_path(@_); 21 | } 22 | 23 | 1; 24 | -------------------------------------------------------------------------------- /lib/Tu/Dispatcher.pm: -------------------------------------------------------------------------------- 1 | package Tu::Dispatcher; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | sub new { 7 | my $class = shift; 8 | 9 | my $self = {}; 10 | bless $self, $class; 11 | 12 | return $self; 13 | } 14 | 15 | sub dispatch { 16 | my $self = shift; 17 | my ($path, %args) = @_; 18 | 19 | ...; 20 | } 21 | 22 | 1; 23 | -------------------------------------------------------------------------------- /lib/Tu/Dispatcher/Routes.pm: -------------------------------------------------------------------------------- 1 | package Tu::Dispatcher::Routes; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use parent 'Tu::Dispatcher'; 7 | 8 | use Carp qw(croak); 9 | use URI::Escape qw(uri_unescape); 10 | use Tu::DispatchedRequest::Routes; 11 | 12 | sub new { 13 | my $self = shift->SUPER::new(@_); 14 | my (%params) = @_; 15 | 16 | $self->{routes} = $params{routes}; 17 | 18 | return $self; 19 | } 20 | 21 | sub dispatch { 22 | my $self = shift; 23 | my ($path, %args) = @_; 24 | 25 | my $routes = $self->{routes}; 26 | 27 | my $m = $routes->match($path, %args); 28 | return unless $m; 29 | 30 | my $action = $m->params->{action} || $m->name; 31 | croak q{Action is unknown. Nor 'action' neither ->name was declared} 32 | unless $action; 33 | 34 | my $captures = { map { $_ => uri_unescape( $m->params->{$_} ) } keys %{ $m->params } }; 35 | 36 | return $self->_build_dispatched_request( 37 | action => $action, 38 | routes => $self->{routes}, 39 | captures => $captures, 40 | params => $m->arguments 41 | ); 42 | } 43 | 44 | sub _build_dispatched_request { 45 | my $self = shift; 46 | 47 | return Tu::DispatchedRequest::Routes->new(@_); 48 | } 49 | 50 | 1; 51 | -------------------------------------------------------------------------------- /lib/Tu/Displayer.pm: -------------------------------------------------------------------------------- 1 | package Tu::Displayer; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Carp qw(croak); 7 | 8 | sub new { 9 | my $class = shift; 10 | my (%params) = @_; 11 | 12 | my $self = {}; 13 | bless $self, $class; 14 | 15 | $self->{renderer} = $params{renderer} || croak 'renderer required'; 16 | $self->{layout} = $params{layout}; 17 | 18 | return $self; 19 | } 20 | 21 | sub render { 22 | my $self = shift; 23 | my ($template) = shift; 24 | 25 | if (ref $template eq 'SCALAR') { 26 | return $self->_render_string($$template, @_); 27 | } 28 | 29 | return $self->_render_file($template, @_); 30 | } 31 | 32 | sub _render_file { 33 | my $self = shift; 34 | my ($template_file, %args) = @_; 35 | 36 | my $renderer = $self->{renderer}; 37 | 38 | my $vars = $args{vars} || {}; 39 | 40 | my $body = $renderer->render_file($template_file, $vars); 41 | 42 | return $body if exists $args{layout} && !defined $args{layout}; 43 | 44 | my $layout = $args{layout} || $self->{layout}; 45 | if ($layout) { 46 | $body = $renderer->render_file($layout, {%$vars, content => $body}); 47 | } 48 | 49 | return $body; 50 | } 51 | 52 | sub _render_string { 53 | my $self = shift; 54 | my ($template_string, %args) = @_; 55 | 56 | my $renderer = $self->{renderer}; 57 | 58 | my $vars = $args{vars} || {}; 59 | 60 | return $renderer->render_string($template_string, $vars); 61 | } 62 | 63 | 1; 64 | -------------------------------------------------------------------------------- /lib/Tu/Factory.pm: -------------------------------------------------------------------------------- 1 | package Tu::Factory; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use String::CamelCase (); 7 | 8 | use Tu::Loader; 9 | 10 | sub new { 11 | my $class = shift; 12 | my (%params) = @_; 13 | 14 | my $self = {}; 15 | bless $self, $class; 16 | 17 | $self->{try} = $params{try}; 18 | 19 | $self->{namespaces} = $params{namespaces}; 20 | $self->{namespaces} = [] unless defined $self->{namespaces}; 21 | $self->{namespaces} = [$self->{namespaces}] 22 | unless ref $self->{namespaces} eq 'ARRAY'; 23 | 24 | return $self; 25 | } 26 | 27 | sub build { 28 | my $self = shift; 29 | my ($name, @args) = @_; 30 | 31 | my $class = $self->_build_class_name($name); 32 | 33 | my $loaded_class = $self->_load_class($class); 34 | return unless $loaded_class; 35 | 36 | return $self->_build_object($loaded_class, @args); 37 | } 38 | 39 | sub _build_class_name { 40 | my $self = shift; 41 | my ($action) = @_; 42 | 43 | $action =~ s{-}{::}g; 44 | 45 | return String::CamelCase::camelize($action); 46 | } 47 | 48 | sub _load_class { 49 | my $self = shift; 50 | my ($class) = @_; 51 | 52 | my $loader = Tu::Loader->new(namespaces => $self->{namespaces}); 53 | 54 | return $loader->try_load_class($class) if $self->{try}; 55 | 56 | $loader->load_class($class); 57 | } 58 | 59 | sub _build_object { 60 | my $self = shift; 61 | my ($class, @args) = @_; 62 | 63 | return $class->new(@args); 64 | } 65 | 66 | 1; 67 | -------------------------------------------------------------------------------- /lib/Tu/Factory/Observable.pm: -------------------------------------------------------------------------------- 1 | package Tu::Factory::Observable; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use base 'Tu::Factory'; 7 | 8 | my $seen = {}; 9 | 10 | sub build { 11 | my $self = shift; 12 | my ($class_name, %options) = @_; 13 | 14 | my $observer_names = delete $options{observers}; 15 | 16 | my $object = $self->SUPER::build($class_name, %options); 17 | return $object unless $observer_names; 18 | 19 | foreach my $observer_name (@$observer_names) { 20 | my $observer_class = $self->_build_class_name($observer_name); 21 | $observer_class = $self->_load_class($observer_class); 22 | 23 | my $observer = $observer_class->new; 24 | 25 | $object->observe($observer); 26 | } 27 | 28 | return $object; 29 | } 30 | 31 | 1; 32 | -------------------------------------------------------------------------------- /lib/Tu/FromConfig.pm: -------------------------------------------------------------------------------- 1 | package Tu::FromConfig; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Tu::Config; 7 | 8 | sub new { 9 | my $class = shift; 10 | my (%params) = @_; 11 | 12 | my $self = {}; 13 | bless $self, $class; 14 | 15 | $self->{config} = $params{config}; 16 | 17 | $self->{config} ||= Tu::Config->new; 18 | 19 | return $self; 20 | } 21 | 22 | sub load { 23 | my $self = shift; 24 | my ($path) = @_; 25 | 26 | my $config = $self->{config}->load($path); 27 | 28 | return $self->_from_config($config); 29 | } 30 | 31 | sub _from_config { 32 | my $self = shift; 33 | my ($config) = @_; 34 | 35 | return $config; 36 | } 37 | 38 | 1; 39 | -------------------------------------------------------------------------------- /lib/Tu/Helper.pm: -------------------------------------------------------------------------------- 1 | package Tu::Helper; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Scalar::Util qw(weaken); 7 | use Tu::Scope; 8 | 9 | sub new { 10 | my $class = shift; 11 | my (%params) = @_; 12 | 13 | my $self = {}; 14 | bless $self, $class; 15 | 16 | $self->{env} = $params{env}; 17 | $self->{services} = $params{services}; 18 | 19 | weaken $self->{env}; 20 | 21 | return $self; 22 | } 23 | 24 | sub scope { 25 | my $self = shift; 26 | 27 | return Tu::Scope->new($self->{env}); 28 | } 29 | 30 | sub service { 31 | my $self = shift; 32 | my ($name) = @_; 33 | 34 | return $self->{services}->service($name); 35 | } 36 | 37 | sub services { 38 | my $self = shift; 39 | 40 | return $self->{services}; 41 | } 42 | 43 | sub params { 44 | my $self = shift; 45 | my ($key) = @_; 46 | 47 | return $self->scope->displayer->vars->{params} || {}; 48 | } 49 | 50 | sub param { 51 | my $self = shift; 52 | my ($key) = @_; 53 | 54 | my $params = $self->params; 55 | return $params->{$key}->[0] if ref $params->{$key} eq 'ARRAY'; 56 | return $params->{$key}; 57 | } 58 | 59 | sub param_multi { 60 | my $self = shift; 61 | my ($key) = @_; 62 | 63 | my $params = $self->params; 64 | return [] unless exists $params->{$key}; 65 | return $params->{$key} if ref $params->{$key} eq 'ARRAY'; 66 | return [$params->{$key}]; 67 | } 68 | 69 | 1; 70 | -------------------------------------------------------------------------------- /lib/Tu/Helper/Assets.pm: -------------------------------------------------------------------------------- 1 | package Tu::Helper::Assets; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use parent 'Tu::Helper'; 7 | 8 | use Tu::AssetsContainer; 9 | 10 | sub include { 11 | my $self = shift; 12 | 13 | return $self->_container->include(@_); 14 | } 15 | 16 | sub require { 17 | my $self = shift; 18 | 19 | $self->_container->require(@_); 20 | 21 | return $self; 22 | } 23 | 24 | sub _container { 25 | my $self = shift; 26 | 27 | my $home = $self->service('home'); 28 | $self->{container} ||= 29 | Tu::AssetsContainer->new(public_dir => $home->catfile('public')); 30 | 31 | return $self->{container}; 32 | } 33 | 34 | 1; 35 | -------------------------------------------------------------------------------- /lib/Tu/Helper/Displayer.pm: -------------------------------------------------------------------------------- 1 | package Tu::Helper::Displayer; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use parent 'Tu::Helper'; 7 | 8 | sub render { 9 | my $self = shift; 10 | my ($template, @vars) = @_; 11 | 12 | my $vars = {%{$self->scope->displayer->vars}, @vars}; 13 | 14 | return $self->service('displayer') 15 | ->render($template, layout => undef, vars => $vars); 16 | } 17 | 18 | 1; 19 | 20 | -------------------------------------------------------------------------------- /lib/Tu/HelperFactory.pm: -------------------------------------------------------------------------------- 1 | package Tu::HelperFactory; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use parent 'Tu::Factory'; 7 | 8 | require Carp; 9 | use Scalar::Util (); 10 | 11 | sub new { 12 | my $self = shift->SUPER::new(@_); 13 | my (%params) = @_; 14 | 15 | $self->{services} = $params{services}; 16 | 17 | $self->{env} = $params{env}; 18 | Scalar::Util::weaken($self->{env}); 19 | 20 | return $self; 21 | } 22 | 23 | sub register_helper { 24 | my $self = shift; 25 | my ($name, $instance) = @_; 26 | 27 | Carp::croak("Helper '$name' already registered") 28 | if exists $self->{helpers}->{$name}; 29 | 30 | $self->{helpers}->{$name} = $instance; 31 | } 32 | 33 | sub build { 34 | my $self = shift; 35 | my ($name, %params) = @_; 36 | 37 | return $self->SUPER::build( 38 | $name, 39 | services => $self->{services}, 40 | env => $self->{env}, 41 | %params 42 | ); 43 | } 44 | 45 | sub create_helper { 46 | my $self = shift; 47 | my ($name) = @_; 48 | 49 | if (exists $self->{helpers}->{$name}) { 50 | my $helper = $self->{helpers}->{$name}; 51 | 52 | return 53 | ref $helper eq 'CODE' ? $helper->() 54 | : Scalar::Util::blessed($helper) ? $helper 55 | : $self->build($helper); 56 | } 57 | 58 | return $self->build($name); 59 | } 60 | 61 | sub DESTROY { } 62 | 63 | our $AUTOLOAD; 64 | 65 | sub AUTOLOAD { 66 | my $self = shift; 67 | 68 | my ($method) = (split /::/, $AUTOLOAD)[-1]; 69 | 70 | return if $method =~ /^[A-Z]/; 71 | return if $method =~ /^_/; 72 | 73 | return $self->create_helper($method, @_); 74 | } 75 | 76 | 1; 77 | -------------------------------------------------------------------------------- /lib/Tu/HelperFactory/Persistent.pm: -------------------------------------------------------------------------------- 1 | package Tu::HelperFactory::Persistent; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use parent 'Tu::HelperFactory'; 7 | 8 | sub new { 9 | my $self = shift->SUPER::new(@_); 10 | 11 | $self->{cache} = {}; 12 | 13 | return $self; 14 | } 15 | 16 | sub create_helper { 17 | my $self = shift; 18 | my ($name) = @_; 19 | 20 | if (exists $self->{cache}->{$name}) { 21 | return $self->{cache}->{$name}; 22 | } 23 | 24 | return $self->{cache}->{$name} = $self->SUPER::create_helper(@_); 25 | } 26 | 27 | 1; 28 | -------------------------------------------------------------------------------- /lib/Tu/Home.pm: -------------------------------------------------------------------------------- 1 | package Tu::Home; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use overload 'bool' => sub { 1 }, fallback => 1; 7 | use overload '""' => sub { shift->to_string }, fallback => 1; 8 | 9 | require Carp; 10 | 11 | use Cwd (); 12 | use File::Basename (); 13 | use File::Spec (); 14 | 15 | sub new { 16 | my $class = shift; 17 | my (%params) = @_; 18 | 19 | my $self = {}; 20 | bless $self, $class; 21 | 22 | $self->{app_class} = $params{app_class}; 23 | $self->{path} = $params{path}; 24 | 25 | $self->{path} = $self->_detect unless defined $self->{path}; 26 | 27 | return $self; 28 | } 29 | 30 | sub to_string { 31 | my $self = shift; 32 | 33 | return $self->{path}; 34 | } 35 | 36 | sub catfile { 37 | my $self = shift; 38 | my (@paths) = @_; 39 | 40 | return ref($self)->new(path => File::Spec->catfile($self->{path}, @paths)); 41 | } 42 | 43 | sub _detect { 44 | my $self = shift; 45 | 46 | my $home; 47 | 48 | if (defined(my $namespace = $self->{app_class})) { 49 | $namespace =~ s{::}{/}g; 50 | 51 | if (exists $INC{$namespace . '.pm'}) { 52 | $home = $INC{$namespace . '.pm'}; 53 | 54 | $home = Cwd::realpath( 55 | File::Spec->catfile(File::Basename::dirname($home), '..')); 56 | } 57 | else { 58 | $home = '.'; 59 | } 60 | } 61 | else { 62 | Carp::croak('cannot detect home, pass it manually'); 63 | } 64 | 65 | return $home; 66 | } 67 | 68 | 1; 69 | -------------------------------------------------------------------------------- /lib/Tu/Loader.pm: -------------------------------------------------------------------------------- 1 | package Tu::Loader; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Carp qw(croak); 7 | 8 | sub new { 9 | my $class = shift; 10 | my (%params) = @_; 11 | 12 | my $self = {}; 13 | bless $self, $class; 14 | 15 | $self->{namespaces} = $params{namespaces}; 16 | 17 | return $self; 18 | } 19 | 20 | sub is_class_loaded { 21 | my $self = shift; 22 | my ($class) = @_; 23 | 24 | croak 'class name required' unless $class; 25 | 26 | my $path = $self->_class_to_path($class); 27 | 28 | return 1 if exists $INC{$path} && defined $INC{$path}; 29 | 30 | { 31 | no strict 'refs'; 32 | for (keys %{"$class\::"}) { 33 | return 1 if defined &{"$class\::$_"}; 34 | } 35 | } 36 | 37 | return 0; 38 | } 39 | 40 | sub try_load_class { 41 | my $self = shift; 42 | my ($class) = @_; 43 | 44 | croak 'class name required' unless $class; 45 | 46 | my $class_loaded = $self->_try_load_class_from_namespaces($class); 47 | return $class_loaded if $class_loaded; 48 | 49 | return unless $self->_try_load_class($class); 50 | 51 | return $class; 52 | } 53 | 54 | sub load_class { 55 | my $self = shift; 56 | my ($class) = @_; 57 | 58 | croak 'class name required' unless $class; 59 | 60 | my $class_loaded = $self->_try_load_class_from_namespaces($class); 61 | return $class_loaded if $class_loaded; 62 | 63 | $self->_try_load_class($class, throw => 1); 64 | return $class; 65 | } 66 | 67 | sub _try_load_class_from_namespaces { 68 | my $self = shift; 69 | my ($class) = @_; 70 | 71 | if (($class =~ s/^\+//) || !$self->{namespaces}) { 72 | return $class if $self->_try_load_class($class); 73 | } 74 | 75 | foreach my $namespace (@{$self->{namespaces}}) { 76 | if ($self->_try_load_class($namespace . $class)) { 77 | return $namespace . $class; 78 | } 79 | } 80 | 81 | return; 82 | } 83 | 84 | sub _try_load_class { 85 | my $self = shift; 86 | my ($class, %params) = @_; 87 | 88 | croak "invalid class name '$class'" unless $class =~ m/^[a-z0-9:]+$/i; 89 | 90 | my $path = $self->_class_to_path($class); 91 | 92 | return 1 if $self->is_class_loaded($class); 93 | 94 | eval { 95 | require $path; 96 | 97 | return 1; 98 | } || do { 99 | my $e = $@; 100 | 101 | delete $INC{$path}; 102 | 103 | { 104 | no strict 'refs'; 105 | 106 | %{"$class\::"} = (); 107 | } 108 | 109 | croak $e 110 | if $params{throw} || $e !~ m{^Can't locate \Q$path\E in \@INC }; 111 | 112 | return 0; 113 | }; 114 | } 115 | 116 | sub _class_to_path { 117 | my $self = shift; 118 | my ($class) = @_; 119 | 120 | $class =~ s{::}{/}g; 121 | 122 | return $class . '.pm'; 123 | } 124 | 125 | 1; 126 | -------------------------------------------------------------------------------- /lib/Tu/Mailer.pm: -------------------------------------------------------------------------------- 1 | package Tu::Mailer; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Carp qw(croak); 7 | use Email::MIME; 8 | 9 | use Tu::Mailer::Test; 10 | use Tu::Mailer::Sendmail; 11 | use Tu::Mailer::SMTP; 12 | 13 | sub new { 14 | my $class = shift; 15 | my (%params) = @_; 16 | 17 | my $self = {}; 18 | bless $self, $class; 19 | 20 | $self->{subject_prefix} = $params{subject_prefix}; 21 | $self->{signature} = $params{signature}; 22 | $self->{charset} = $params{charset} || 'UTF-8'; 23 | $self->{encoding} = $params{encoding} || 'base64'; 24 | 25 | $self->{headers} = $params{headers} || []; 26 | 27 | $self->{transport} = $params{transport}; 28 | croak 'transport required' unless $self->{transport}; 29 | 30 | return $self; 31 | } 32 | 33 | sub send { 34 | my $self = shift; 35 | my (%params) = @_; 36 | 37 | my $message = $self->build_message(%params); 38 | 39 | my $transport = $self->_build_transport($self->{transport}); 40 | 41 | $transport->send_message($message); 42 | 43 | return $self; 44 | } 45 | 46 | sub build_message { 47 | my $self = shift; 48 | my (%params) = @_; 49 | 50 | if (defined(my $signature = $self->{signature}) && $params{body}) { 51 | $params{body} .= "\n\n-- \n$signature"; 52 | } 53 | my $parts = 54 | $params{body} 55 | ? [ 56 | Email::MIME->create( 57 | attributes => { 58 | content_type => 'text/plain', 59 | charset => $self->{charset}, 60 | encoding => $self->{encoding} 61 | }, 62 | body_str => $params{body} 63 | ) 64 | ] 65 | : ($params{parts} || []); 66 | 67 | my $message = Email::MIME->create(attributes => $params{attributes}, parts => $parts); 68 | 69 | my @headers = (@{$self->{headers}}, @{$params{headers} || []}); 70 | $self->_set_headers($message, \@headers); 71 | 72 | $message->charset_set($self->{charset}); 73 | 74 | return $message->as_string; 75 | } 76 | 77 | sub _build_transport { 78 | my $self = shift; 79 | my ($options) = @_; 80 | 81 | my $name = $options->{name}; 82 | 83 | if ($name eq 'test') { 84 | return Tu::Mailer::Test->new(%$options); 85 | } 86 | elsif ($name eq 'sendmail') { 87 | return Tu::Mailer::Sendmail->new(%$options); 88 | } 89 | elsif ($name eq 'smtp') { 90 | return Tu::Mailer::SMTP->new(%$options); 91 | } 92 | elsif ($name eq 'smtp+tls') { 93 | return Tu::Mailer::SMTP->new(ssl => 'starttls', %$options); 94 | } 95 | else { 96 | croak 'Unknown transport'; 97 | } 98 | } 99 | 100 | sub _set_headers { 101 | my $self = shift; 102 | my ($message, $headers) = @_; 103 | 104 | while (my ($key, $value) = splice(@$headers, 0, 2)) { 105 | if ($key eq 'Subject' && (my $prefix = $self->{subject_prefix})) { 106 | $value = $prefix . ' ' . $value; 107 | } 108 | 109 | $message->header_str_set($key => $value); 110 | } 111 | } 112 | 113 | 1; 114 | -------------------------------------------------------------------------------- /lib/Tu/Mailer/SMTP.pm: -------------------------------------------------------------------------------- 1 | package Tu::Mailer::SMTP; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | sub new { 7 | my $class = shift; 8 | my (%params) = @_; 9 | 10 | my $self = {}; 11 | bless $self, $class; 12 | 13 | $self->{ssl} = $params{ssl}; 14 | $self->{host} = $params{host}; 15 | $self->{port} = $params{port}; 16 | $self->{username} = $params{username}; 17 | $self->{password} = $params{password}; 18 | 19 | return $self; 20 | } 21 | 22 | sub send_message { 23 | my $self = shift; 24 | my ($message) = @_; 25 | 26 | require Email::Sender::Simple; 27 | require Email::Sender::Transport::SMTP; 28 | 29 | my $sender = Email::Sender::Transport::SMTP->new( 30 | host => $self->{host}, 31 | port => $self->{port}, 32 | $self->{ssl} ? (ssl => $self->{ssl}) : (), 33 | $self->{username} && $self->{password} 34 | ? ( 35 | sasl_username => $self->{username}, 36 | sasl_password => $self->{password} 37 | ) 38 | : () 39 | ); 40 | 41 | Email::Sender::Simple->send($message, {transport => $sender}); 42 | 43 | return $self; 44 | } 45 | 46 | 1; 47 | -------------------------------------------------------------------------------- /lib/Tu/Mailer/Sendmail.pm: -------------------------------------------------------------------------------- 1 | package Tu::Mailer::Sendmail; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Carp qw(croak); 7 | 8 | sub new { 9 | my $class = shift; 10 | my (%params) = @_; 11 | 12 | my $self = {}; 13 | bless $self, $class; 14 | 15 | $self->{path} = $params{path}; 16 | 17 | return $self; 18 | } 19 | 20 | sub send_message { 21 | my $self = shift; 22 | my ($message) = @_; 23 | 24 | my $path = "| $self->{path} -t -oi -oem"; 25 | 26 | open my $fh, $path or croak "Can't start sendmail: $!"; 27 | print $fh $message; 28 | close $fh; 29 | 30 | return $self; 31 | } 32 | 33 | 1; 34 | -------------------------------------------------------------------------------- /lib/Tu/Mailer/Test.pm: -------------------------------------------------------------------------------- 1 | package Tu::Mailer::Test; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Carp qw(croak); 7 | 8 | sub new { 9 | my $class = shift; 10 | my (%params) = @_; 11 | 12 | my $self = {}; 13 | bless $self, $class; 14 | 15 | $self->{path} = $params{path}; 16 | 17 | return $self; 18 | } 19 | 20 | sub send_message { 21 | my $self = shift; 22 | my ($message) = @_; 23 | 24 | open my $mail, '>>', $self->{path} or croak "Can't open test file: $!"; 25 | print $mail $message; 26 | close $mail; 27 | 28 | return $self; 29 | } 30 | 31 | 1; 32 | -------------------------------------------------------------------------------- /lib/Tu/Middleware.pm: -------------------------------------------------------------------------------- 1 | package Tu::Middleware; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use parent 'Plack::Middleware'; 7 | 8 | use Plack::Util::Accessor qw(services); 9 | 10 | sub service { 11 | my $self = shift; 12 | my ($name) = @_; 13 | 14 | return $self->{services}->service($name); 15 | } 16 | 17 | 1; 18 | -------------------------------------------------------------------------------- /lib/Tu/Middleware/ACL.pm: -------------------------------------------------------------------------------- 1 | package Tu::Middleware::ACL; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use parent 'Tu::Middleware'; 7 | 8 | use Carp qw(croak); 9 | use Scalar::Util qw(blessed); 10 | use Tu::Scope; 11 | use Tu::X::HTTP; 12 | 13 | use Plack::Util::Accessor qw(acl); 14 | 15 | sub prepare_app { 16 | my $self = shift; 17 | 18 | $self->{acl} ||= $self->service('acl') || croak 'acl required'; 19 | 20 | return $self; 21 | } 22 | 23 | sub call { 24 | my $self = shift; 25 | my ($env) = @_; 26 | 27 | my $res = $self->_acl($env); 28 | return $res if $res; 29 | 30 | return $self->app->($env); 31 | } 32 | 33 | sub _acl { 34 | my $self = shift; 35 | my ($env) = @_; 36 | 37 | my $scope = Tu::Scope->new($env); 38 | 39 | return $self->_deny($env) 40 | unless $scope->exists('user_role') 41 | && (my $auth_role = $scope->get('user_role')); 42 | 43 | my $action = $self->_find_action($env); 44 | 45 | my $acl = $self->{acl} || $self->service('acl'); 46 | return $self->_deny($env) unless $acl->is_allowed($auth_role, $action, env => $env); 47 | 48 | return; 49 | } 50 | 51 | sub _find_action { 52 | my $self = shift; 53 | my ($env) = @_; 54 | 55 | return Tu::Scope->new($env)->dispatched_request->action; 56 | } 57 | 58 | sub _deny { 59 | my $self = shift; 60 | my ($env) = @_; 61 | 62 | my $redirect_to = $self->{redirect_to}; 63 | if (defined $redirect_to && $env->{PATH_INFO} ne $redirect_to) { 64 | return [302, ['Location' => $redirect_to], ['']]; 65 | } 66 | 67 | Tu::X::HTTP->throw('Not Found', code => 404); 68 | } 69 | 70 | 1; 71 | -------------------------------------------------------------------------------- /lib/Tu/Middleware/ActionDispatcher.pm: -------------------------------------------------------------------------------- 1 | package Tu::Middleware::ActionDispatcher; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use parent 'Tu::Middleware'; 7 | 8 | use Carp qw(croak); 9 | use Tu::Scope; 10 | use Tu::ActionResponseResolver; 11 | 12 | use Plack::Util::Accessor qw(action_factory response_resolver); 13 | 14 | sub prepare_app { 15 | my $self = shift; 16 | 17 | $self->{action_factory} ||= $self->service('action_factory') 18 | || croak 'action_factory required'; 19 | 20 | $self->{response_resolver} ||= Tu::ActionResponseResolver->new; 21 | 22 | return $self; 23 | } 24 | 25 | sub call { 26 | my $self = shift; 27 | my ($env) = @_; 28 | 29 | my $res = $self->_action($env); 30 | return $res if $res; 31 | 32 | return $self->app->($env); 33 | } 34 | 35 | sub _action { 36 | my $self = shift; 37 | my ($env) = @_; 38 | 39 | my $dispatched_request = Tu::Scope->new($env)->dispatched_request; 40 | 41 | my $action = $dispatched_request->action; 42 | return unless defined $action; 43 | 44 | $action = $self->_build_action($action, $env); 45 | return unless defined $action; 46 | 47 | my @res = $action->run; 48 | 49 | return $self->response_resolver->resolve(@res); 50 | } 51 | 52 | sub _build_action { 53 | my $self = shift; 54 | my ($action, $env) = @_; 55 | 56 | return $self->action_factory->build( 57 | $action, 58 | env => $env, 59 | services => $self->{services} 60 | ); 61 | } 62 | 63 | 1; 64 | -------------------------------------------------------------------------------- /lib/Tu/Middleware/Defaults.pm: -------------------------------------------------------------------------------- 1 | package Tu::Middleware::Defaults; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use parent 'Tu::Middleware'; 7 | 8 | use Tu::Scope; 9 | use Tu::HelperFactory::Persistent; 10 | 11 | sub call { 12 | my $self = shift; 13 | my ($env) = @_; 14 | 15 | my $scope = Tu::Scope->new($env); 16 | 17 | my $vars = $scope->set('displayer.vars' => {}); 18 | 19 | $vars->{mode} = $ENV{PLACK_ENV} || 'production'; 20 | 21 | $vars->{helpers} = Tu::HelperFactory::Persistent->new( 22 | services => $self->{services}, 23 | namespaces => [ 24 | $self->{services}->service('app_class') . '::Helper::', 25 | 'Tu::Helper::' 26 | ], 27 | env => $env 28 | ); 29 | 30 | return $self->app->($env); 31 | } 32 | 33 | 1; 34 | -------------------------------------------------------------------------------- /lib/Tu/Middleware/I18N.pm: -------------------------------------------------------------------------------- 1 | package Tu::Middleware::I18N; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use parent 'Tu::Middleware::LanguageDetection'; 7 | 8 | use Carp qw(croak); 9 | use Tu::Scope; 10 | 11 | use Plack::Util::Accessor qw(i18n); 12 | 13 | sub prepare_app { 14 | my $self = shift; 15 | 16 | $self->{i18n} ||= $self->service('i18n'); 17 | 18 | croak 'i18n is required' unless my $i18n = $self->{i18n}; 19 | 20 | $self->{default_language} ||= $i18n->default_language; 21 | $self->{languages} ||= [$i18n->languages]; 22 | 23 | return $self->SUPER::prepare_app; 24 | } 25 | 26 | sub _detect_language { 27 | my $self = shift; 28 | my ($env) = @_; 29 | 30 | $self->SUPER::_detect_language($env); 31 | 32 | my $scope = Tu::Scope->new($env); 33 | 34 | my $language = $scope->i18n->language; 35 | 36 | my $maketext_cb = $self->{i18n}->handle($language); 37 | $scope->set('i18n.maketext' => $maketext_cb); 38 | 39 | $scope->displayer->vars->{loc} = 40 | sub { $env->{'tu.i18n.maketext'}->loc(@_) }; 41 | 42 | $scope->displayer->vars->{lang} = $language; 43 | } 44 | 45 | 1; 46 | -------------------------------------------------------------------------------- /lib/Tu/Middleware/LanguageDetection.pm: -------------------------------------------------------------------------------- 1 | package Tu::Middleware::LanguageDetection; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use parent 'Tu::Middleware'; 7 | 8 | use Carp qw(croak); 9 | use List::Util qw(first); 10 | use I18N::AcceptLanguage; 11 | use Tu::Scope; 12 | 13 | use Plack::Util::Accessor 14 | qw(default_language languages use_path use_session use_header custom_cb); 15 | 16 | sub prepare_app { 17 | my $self = shift; 18 | 19 | my $config = $self->service('config')->{i18n} || {}; 20 | 21 | for (qw/default_language languages use_path use_session use_header/) { 22 | $self->{$_} = $config->{$_} if defined $config->{$_}; 23 | } 24 | 25 | croak 'default_language required' unless $self->{default_language}; 26 | croak 'languages required' unless $self->{languages}; 27 | 28 | $self->{use_path} = 1 unless defined $self->{use_path}; 29 | $self->{use_session} = 1 unless defined $self->{use_session}; 30 | $self->{use_header} = 1 unless defined $self->{use_header}; 31 | 32 | return $self; 33 | } 34 | 35 | sub call { 36 | my $self = shift; 37 | my ($env) = @_; 38 | 39 | $self->_detect_language($env); 40 | 41 | return $self->app->($env); 42 | } 43 | 44 | sub _detect_language { 45 | my $self = shift; 46 | my ($env) = @_; 47 | 48 | my $lang; 49 | $lang = $self->_detect_from_path($env) if $self->use_path; 50 | $lang ||= $self->_detect_from_session($env) if $self->use_session; 51 | $lang ||= $self->_detect_from_header($env) if $self->use_header; 52 | $lang = $self->_detect_from_custom_cb($env, $lang) if $self->custom_cb; 53 | 54 | $lang ||= $self->default_language; 55 | 56 | my $scope = Tu::Scope->new($env); 57 | $scope->set('i18n.language' => $lang); 58 | 59 | if ($self->{use_session}) { 60 | $env->{'psgix.session'}->{'tu.i18n.language'} = $lang; 61 | } 62 | } 63 | 64 | sub _detect_from_session { 65 | my $self = shift; 66 | my ($env) = @_; 67 | 68 | return unless my $session = $env->{'psgix.session'}; 69 | 70 | return unless my $lang = $session->{'tu.i18n.language'}; 71 | 72 | return unless $self->_is_allowed($lang); 73 | 74 | return $lang; 75 | } 76 | 77 | sub _detect_from_path { 78 | my $self = shift; 79 | my ($env) = @_; 80 | 81 | my $path = $env->{PATH_INFO}; 82 | 83 | my $languages_re = join '|', @{$self->{languages}}; 84 | if ($path =~ s{^/($languages_re)(?=/|$)}{}) { 85 | $env->{PATH_INFO} = $path; 86 | return $1 if $self->_is_allowed($1); 87 | } 88 | 89 | return; 90 | } 91 | 92 | sub _detect_from_header { 93 | my $self = shift; 94 | my ($env) = @_; 95 | 96 | return unless my $accept_header = $env->{HTTP_ACCEPT_LANGUAGE}; 97 | 98 | return 99 | unless my $lang = 100 | $self->_build_acceptor->accepts($accept_header, $self->{languages}); 101 | 102 | return unless $self->_is_allowed($lang); 103 | 104 | return $lang; 105 | } 106 | 107 | sub _detect_from_custom_cb { 108 | my $self = shift; 109 | my ($env, $detected_lang) = @_; 110 | 111 | my $lang = $self->custom_cb->($env, $detected_lang); 112 | 113 | return unless $lang; 114 | 115 | return unless $self->_is_allowed($lang); 116 | 117 | return $lang; 118 | } 119 | 120 | sub _build_acceptor { 121 | my $self = shift; 122 | 123 | return I18N::AcceptLanguage->new(); 124 | } 125 | 126 | sub _is_allowed { 127 | my $self = shift; 128 | my ($lang) = @_; 129 | 130 | return !!first { $lang eq $_ } $self->default_language, @{$self->languages}; 131 | } 132 | 133 | 1; 134 | -------------------------------------------------------------------------------- /lib/Tu/Middleware/MultilingualParser.pm: -------------------------------------------------------------------------------- 1 | package Tu::Middleware::MultilingualParser; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use parent 'Tu::Middleware'; 7 | 8 | use Carp qw(croak); 9 | use Plack::Util (); 10 | 11 | sub new { 12 | my $self = shift->SUPER::new(@_); 13 | 14 | croak 'default_language required' unless $self->{default_language}; 15 | croak 'languages required' unless $self->{languages}; 16 | 17 | return $self; 18 | } 19 | 20 | sub call { 21 | my $self = shift; 22 | my ($env) = @_; 23 | 24 | my $old_res = $self->app->(@_); 25 | 26 | return $self->response_cb( 27 | $old_res => sub { 28 | my $res = shift; 29 | my $h = Plack::Util::headers($res->[1]); 30 | 31 | return unless my $content_type = $h->get('Content-Type'); 32 | return unless $content_type =~ m{text/html}; 33 | 34 | my $language = $env->{'tu.language'}; 35 | return unless $language; 36 | 37 | my $pattern = 38 | "\\s*.*?<$language>\\s*(.*?)\\s*\\s*.*?"; 39 | 40 | my $body = ''; 41 | Plack::Util::foreach( 42 | $res->[2], 43 | sub { 44 | while ($_[0] =~ s/$pattern/$1/) { } 45 | $body .= $_[0]; 46 | } 47 | ); 48 | 49 | # TODO chunks 50 | 51 | $res->[2] = [$body]; 52 | 53 | $h->set('Content-Length', length $body); 54 | } 55 | ); 56 | } 57 | 58 | 1; 59 | -------------------------------------------------------------------------------- /lib/Tu/Middleware/RequestDispatcher.pm: -------------------------------------------------------------------------------- 1 | package Tu::Middleware::RequestDispatcher; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use parent 'Tu::Middleware'; 7 | 8 | use Carp qw(croak); 9 | use Encode (); 10 | use Tu::Scope; 11 | use Tu::X::HTTP; 12 | 13 | use Plack::Util::Accessor qw(encoding dispatcher); 14 | 15 | sub prepare_app { 16 | my $self = shift; 17 | 18 | $self->{encoding} ||= 'UTF-8'; 19 | 20 | $self->{dispatcher} ||= $self->service('dispatcher') 21 | || croak 'dispatcher required'; 22 | 23 | return $self; 24 | } 25 | 26 | sub call { 27 | my $self = shift; 28 | my ($env) = @_; 29 | 30 | $self->_dispatch($env); 31 | 32 | return $self->app->($env); 33 | } 34 | 35 | sub _dispatch { 36 | my $self = shift; 37 | my ($env) = @_; 38 | 39 | my $path = $env->{REQUEST_URI} || ''; 40 | my $method = $env->{REQUEST_METHOD}; 41 | 42 | $path =~ s{\?.*$}{}; 43 | 44 | if ($self->encoding && $self->encoding ne 'raw') { 45 | $path = Encode::decode($self->encoding, $path); 46 | } 47 | 48 | my $dispatcher = $self->dispatcher; 49 | 50 | my $dispatched_request = $dispatcher->dispatch($path, method => lc $method); 51 | Tu::X::HTTP->throw('Not found', code => 404) 52 | unless $dispatched_request; 53 | 54 | Tu::Scope->new($env)->set(dispatched_request => $dispatched_request); 55 | 56 | return $self; 57 | } 58 | 59 | 1; 60 | -------------------------------------------------------------------------------- /lib/Tu/Middleware/SerializerJSON.pm: -------------------------------------------------------------------------------- 1 | package Tu::Middleware::SerializerJSON; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use parent 'Tu::Middleware'; 7 | 8 | use JSON (); 9 | use Scalar::Util (); 10 | use Plack::Util (); 11 | use Tu::Request; 12 | use Tu::X::HTTP; 13 | 14 | sub call { 15 | my $self = shift; 16 | my ($env) = @_; 17 | 18 | my $method = $env->{REQUEST_METHOD}; 19 | if ($method eq 'PUT' || $method eq 'POST') { 20 | my $req = Tu::Request->new($env); 21 | 22 | my $json = eval { JSON::decode_json($req->content) } || do { 23 | my $error = $@; 24 | 25 | return $self->_wrap_json_response(400, [], 'Invalid JSON'); 26 | }; 27 | 28 | $env->{'tu.serializer.json'} = {foo => 'bar'}; 29 | } 30 | 31 | my $res = eval { $self->app->($env); } || do { 32 | my $error = $@; 33 | 34 | return $self->_wrap_json_response(500, [], 'Internal system error'); 35 | }; 36 | 37 | if (!Plack::Util::header_get($res->[1], 'Content-Type')) { 38 | return $self->_wrap_json_response($res->[0], $res->[1], $res->[2]->[0]); 39 | } 40 | 41 | return $res; 42 | } 43 | 44 | sub _wrap_json_response { 45 | my $self = shift; 46 | my ($code, $headers, $body) = @_; 47 | 48 | $body = {message => $body} unless ref $body; 49 | 50 | return [ 51 | $code, 52 | [@$headers, 'Content-Type' => 'application/json'], 53 | [JSON::encode_json($body)] 54 | ]; 55 | } 56 | 57 | 1; 58 | -------------------------------------------------------------------------------- /lib/Tu/Middleware/Session/Cookie.pm: -------------------------------------------------------------------------------- 1 | package Tu::Middleware::Session::Cookie; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use parent 'Plack::Middleware::Session::Cookie'; 7 | 8 | use Plack::Util::Accessor qw(services); 9 | 10 | sub new { 11 | my $class = shift; 12 | my $params = @_ == 1 ? $_[0] : {@_}; 13 | 14 | my $services = delete $params->{services}; 15 | 16 | my $config = $services->service('config') || {}; 17 | $config = $config->{session} || {}; 18 | 19 | return $class->SUPER::new(%$params, %$config); 20 | } 21 | 22 | sub service { 23 | my $self = shift; 24 | my ($name) = @_; 25 | 26 | return $self->{services}->service($name); 27 | } 28 | 29 | 1; 30 | -------------------------------------------------------------------------------- /lib/Tu/Middleware/Static.pm: -------------------------------------------------------------------------------- 1 | package Tu::Middleware::Static; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use base 'Plack::Middleware::Static'; 7 | 8 | sub new { 9 | my $class = shift; 10 | my $params = @_ == 1 ? $_[0] : {@_}; 11 | 12 | if (!$params->{path} && !$params->{root}) { 13 | my $config = $params->{services}->service('config'); 14 | 15 | my $public_dir = 16 | $params->{public_dir} || $config->{public_dir} || 'public'; 17 | $public_dir = 18 | $params->{services}->service('home')->catfile($public_dir); 19 | 20 | my @dirs = grep { -d } glob "$public_dir/*"; 21 | s/^$public_dir\/?// for @dirs; 22 | 23 | my $re = '^/(?:' . join('|', @dirs) . ')/'; 24 | $params->{path} = qr/$re/; 25 | $params->{root} = $public_dir; 26 | } 27 | 28 | return $class->SUPER::new($params); 29 | } 30 | 31 | 1; 32 | -------------------------------------------------------------------------------- /lib/Tu/Middleware/User.pm: -------------------------------------------------------------------------------- 1 | package Tu::Middleware::User; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use parent 'Tu::Middleware'; 7 | 8 | use Carp qw(croak); 9 | use Tu::Loader; 10 | use Tu::Scope; 11 | 12 | use Plack::Util::Accessor qw(user_session_class); 13 | 14 | sub call { 15 | my $self = shift; 16 | my ($env) = @_; 17 | 18 | my $user = $self->_user($env); 19 | 20 | my $res = $self->app->($env); 21 | 22 | return $self->response_cb( 23 | $res, 24 | sub { 25 | my $res = shift; 26 | 27 | $user->finalize if $user && $user->can('finalize'); 28 | } 29 | ); 30 | } 31 | 32 | sub _user { 33 | my $self = shift; 34 | my ($env) = @_; 35 | 36 | my $scope = Tu::Scope->new($env); 37 | 38 | Tu::Loader->new->load_class($self->user_session_class); 39 | 40 | my $user_session = $self->user_session_class->new(env => $env); 41 | 42 | my $user = $user_session->load; 43 | 44 | if ($user) { 45 | $scope->set(user => $user); 46 | $scope->set(user_role => $user->role); 47 | } 48 | else { 49 | $scope->set(user => undef); 50 | $scope->set(user_role => 'anonymous'); 51 | } 52 | 53 | return $user; 54 | } 55 | 56 | 1; 57 | -------------------------------------------------------------------------------- /lib/Tu/Middleware/ViewDisplayer.pm: -------------------------------------------------------------------------------- 1 | package Tu::Middleware::ViewDisplayer; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use parent 'Tu::Middleware'; 7 | 8 | use Carp qw(croak); 9 | use Encode (); 10 | use String::CamelCase (); 11 | use Tu::Scope; 12 | 13 | use Plack::Util::Accessor qw(encoding displayer); 14 | 15 | sub prepare_app { 16 | my $self = shift; 17 | 18 | $self->{encoding} ||= 'UTF-8'; 19 | 20 | $self->{displayer} ||= $self->service('displayer'); 21 | 22 | croak 'displayer required' unless $self->{displayer}; 23 | 24 | return $self; 25 | } 26 | 27 | sub call { 28 | my $self = shift; 29 | my ($env) = @_; 30 | 31 | my $res = $self->_display($env); 32 | return $res if $res; 33 | 34 | return $self->app->($env); 35 | } 36 | 37 | sub _display { 38 | my $self = shift; 39 | my ($env) = @_; 40 | 41 | my $template = $self->_find_template($env); 42 | return unless defined $template; 43 | 44 | my $displayer_scope = Tu::Scope->new($env)->displayer; 45 | 46 | my %args; 47 | $args{vars} = $displayer_scope->vars; 48 | $args{layout} = $displayer_scope->layout 49 | if $displayer_scope->exists('layout'); 50 | 51 | my $body = $self->{displayer}->render($template, %args); 52 | 53 | my $content_type = 'text/html'; 54 | 55 | my $encoding = $self->encoding; 56 | if ($encoding && $encoding ne 'raw') { 57 | $body = Encode::encode($encoding, $body); 58 | $content_type .= '; charset=' . lc($encoding); 59 | } 60 | 61 | return [ 62 | 200, 63 | [ 64 | 'Content-Length' => length($body), 65 | 'Content-Type' => $content_type 66 | ], 67 | [$body] 68 | ]; 69 | } 70 | 71 | sub _find_template { 72 | my $self = shift; 73 | my ($env) = @_; 74 | 75 | my $scope = Tu::Scope->new($env); 76 | 77 | my $template = 78 | $scope->displayer->exists('template') ? $scope->displayer->template : ''; 79 | return $template if $template; 80 | 81 | my $dispatched_request = $scope->dispatched_request; 82 | 83 | if (my $action = $dispatched_request->action) { 84 | my $template_from_action = String::CamelCase::decamelize($action); 85 | $template_from_action =~ s{::}{_}g; 86 | return $template_from_action; 87 | } 88 | 89 | return; 90 | } 91 | 92 | 1; 93 | -------------------------------------------------------------------------------- /lib/Tu/ObservableMixin.pm: -------------------------------------------------------------------------------- 1 | package Tu::ObservableMixin; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use parent 'Exporter'; 7 | 8 | our @EXPORT_OK = qw(observe notify); 9 | 10 | my $KEY = '__observable_mixin__'; 11 | 12 | sub observe { 13 | my $self = shift; 14 | my ($observer) = @_; 15 | 16 | $self->{$KEY} ||= {}; 17 | 18 | my $events = $observer->events; 19 | 20 | foreach my $event (keys %$events) { 21 | push @{$self->{$KEY}->{$event}}, $events->{$event}; 22 | } 23 | } 24 | 25 | sub notify { 26 | my $self = shift; 27 | my ($event, @args) = @_; 28 | 29 | my $observers = $self->{$KEY}->{$event}; 30 | return unless $observers; 31 | 32 | foreach my $observer (@$observers) { 33 | $observer->($self, @args); 34 | } 35 | } 36 | 37 | 1; 38 | -------------------------------------------------------------------------------- /lib/Tu/Observer/Base.pm: -------------------------------------------------------------------------------- 1 | package Tu::Observer::Base; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | sub new { 7 | my $class = shift; 8 | 9 | my $self = {}; 10 | bless $self, $class; 11 | 12 | $self->_init; 13 | 14 | return $self; 15 | } 16 | 17 | sub _init { 18 | } 19 | 20 | sub _register { 21 | my $self = shift; 22 | my ($event, $cb) = @_; 23 | 24 | $self->{events}->{$_} = $cb for split /,/, $event; 25 | 26 | return $self; 27 | } 28 | 29 | sub events { $_[0]->{events} } 30 | 31 | 1; 32 | -------------------------------------------------------------------------------- /lib/Tu/Renderer.pm: -------------------------------------------------------------------------------- 1 | package Tu::Renderer; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use File::Spec (); 7 | 8 | sub new { 9 | my $class = shift; 10 | my (%params) = @_; 11 | 12 | my $self = {}; 13 | bless $self, $class; 14 | 15 | $self->{home} = $params{home}; 16 | $self->{templates_path} = $params{templates_path}; 17 | $self->{engine_args} = $params{engine_args}; 18 | 19 | my $templates_path = delete $self->{templates_path} || 'templates'; 20 | if (!File::Spec->file_name_is_absolute($templates_path) && $self->{home}) { 21 | $templates_path = File::Spec->catfile($self->{home}, $templates_path); 22 | } 23 | $self->{templates_path} = $templates_path; 24 | 25 | $self->{engine} = $self->_build_engine(%{$self->{engine_args} || {}}); 26 | 27 | return $self; 28 | } 29 | 30 | sub unshift_templates_path { 31 | my $self = shift; 32 | my ($path) = @_; 33 | 34 | $self->{templates_path} = [$self->{templates_path}] unless ref $self->{templates_path} eq 'ARRAY'; 35 | 36 | unshift @{ $self->{templates_path}}, $path; 37 | } 38 | 39 | sub render_file { 40 | my $self = shift; 41 | my ($template_file, %params) = @_; 42 | 43 | ...; 44 | } 45 | 46 | sub render_string { 47 | my $self = shift; 48 | my ($template_string, %params) = @_; 49 | 50 | ...; 51 | } 52 | 53 | sub _build_engine { ... } 54 | 55 | 1; 56 | -------------------------------------------------------------------------------- /lib/Tu/Renderer/APL.pm: -------------------------------------------------------------------------------- 1 | package Tu::Renderer::APL; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use parent 'Tu::Renderer'; 7 | 8 | use Text::APL; 9 | use File::Spec; 10 | 11 | sub render_file { 12 | my $self = shift; 13 | my ($template, @rest) = @_; 14 | 15 | if ($template !~ m{\.[^\/\.]+$}) { 16 | $template .= '.apl'; 17 | } 18 | 19 | my @paths = ref $self->{templates_path} eq 'ARRAY' ? @{ $self->{templates_path} } : ( $self->{templates_path} ); 20 | 21 | my $file; 22 | foreach my $path (@paths) { 23 | $file = File::Spec->catfile($path, $template); 24 | last if -f $file; 25 | } 26 | 27 | my %helpers = 28 | map { $_ => $rest[0]->{$_} } 29 | grep { ref $rest[0]->{$_} eq 'CODE' } keys %{$rest[0]}; 30 | my %vars = 31 | map { $_ => $rest[0]->{$_} } 32 | grep { ref $rest[0]->{$_} ne 'CODE' } keys %{$rest[0]}; 33 | 34 | my $output = ''; 35 | $self->{engine}->render( 36 | name => $template, 37 | input => $file, 38 | output => \$output, 39 | vars => \%vars, 40 | helpers => \%helpers 41 | ); 42 | 43 | return $output; 44 | } 45 | 46 | sub render_string { 47 | my $self = shift; 48 | my ($template, @rest) = @_; 49 | 50 | my $output = ''; 51 | $self->{engine}->render(input => \$template, output => \$output, @rest); 52 | 53 | return $output; 54 | } 55 | 56 | sub _build_engine { 57 | my $self = shift; 58 | 59 | return Text::APL->new(cache => 1, @_); 60 | } 61 | 62 | 1; 63 | -------------------------------------------------------------------------------- /lib/Tu/Renderer/Caml.pm: -------------------------------------------------------------------------------- 1 | package Tu::Renderer::Caml; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use parent 'Tu::Renderer'; 7 | 8 | use Text::Caml; 9 | 10 | sub render_file { 11 | my $self = shift; 12 | my ($template, @rest) = @_; 13 | 14 | if ($template !~ m{\.[^\/\.]+$}) { 15 | $template .= '.caml'; 16 | } 17 | 18 | return $self->{engine}->render_file($template, @rest); 19 | } 20 | 21 | sub render_string { 22 | my $self = shift; 23 | 24 | return $self->{engine}->render(@_); 25 | } 26 | 27 | sub _build_engine { 28 | my $self = shift; 29 | 30 | return Text::Caml->new(templates_path => $self->{templates_path}, @_); 31 | } 32 | 33 | 1; 34 | -------------------------------------------------------------------------------- /lib/Tu/Request.pm: -------------------------------------------------------------------------------- 1 | package Tu::Request; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use parent 'Plack::Request'; 7 | 8 | use Encode (); 9 | 10 | use Tu::Response; 11 | 12 | sub new { 13 | my $class = shift; 14 | my ($env, %options) = @_; 15 | 16 | my $self = $class->SUPER::new($env); 17 | 18 | $self->{encoding} = $options{encoding} ||= 'UTF-8'; 19 | 20 | return $self; 21 | } 22 | 23 | sub new_response { 24 | my $self = shift; 25 | 26 | return Tu::Response->new(@_); 27 | } 28 | 29 | sub _query_parameters { shift->_decode_parameters('query_parameters', @_) } 30 | sub _body_parameters { shift->_decode_parameters('body_parameters', @_) } 31 | 32 | sub _decode_parameters { 33 | my $self = shift; 34 | my ($request_key, @args) = @_; 35 | 36 | my $method = "SUPER::_$request_key"; 37 | 38 | my $super = $self->$method(@args); 39 | 40 | my $params = $self->env->{"plack.request.$request_key"}; 41 | 42 | if (!$self->env->{"plack.request.$request_key.decoded"}++) { 43 | my $encoding = $self->{encoding}; 44 | foreach my $key (@$params) { 45 | $key = Encode::decode($encoding, $key); 46 | } 47 | } 48 | 49 | return $self->env->{"plack.request.$request_key"} = $params; 50 | } 51 | 52 | 1; 53 | -------------------------------------------------------------------------------- /lib/Tu/Response.pm: -------------------------------------------------------------------------------- 1 | package Tu::Response; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use parent 'Plack::Response'; 7 | 8 | use Encode (); 9 | use Plack::Util (); 10 | 11 | sub finalize { 12 | my $self = shift; 13 | 14 | $self->content_type('text/html') unless $self->content_type; 15 | 16 | my $arrayref = $self->SUPER::finalize; 17 | 18 | if (Plack::Util::is_real_fh($arrayref->[2])) { 19 | 20 | # TODO 21 | } 22 | elsif (ref $arrayref->[2] eq 'ARRAY') { 23 | $arrayref->[2] = 24 | [map { Encode::is_utf8($_) ? Encode::encode('UTF-8', $_) : $_ } 25 | @{$arrayref->[2]}]; 26 | } 27 | else { 28 | 29 | # TODO 30 | } 31 | 32 | return $arrayref; 33 | } 34 | 35 | 1; 36 | -------------------------------------------------------------------------------- /lib/Tu/Routes.pm: -------------------------------------------------------------------------------- 1 | package Tu::Routes; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use parent 'Routes::Tiny'; 7 | 8 | 1; 9 | -------------------------------------------------------------------------------- /lib/Tu/Routes/FromConfig.pm: -------------------------------------------------------------------------------- 1 | package Tu::Routes::FromConfig; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use parent 'Tu::FromConfig'; 7 | 8 | use Tu::Routes; 9 | 10 | sub new { 11 | my $self = shift->SUPER::new(@_); 12 | my (%params) = @_; 13 | 14 | $self->{routes} = $params{routes}; 15 | 16 | $self->{routes} ||= Tu::Routes->new; 17 | 18 | return $self; 19 | } 20 | 21 | sub _from_config { 22 | my $self = shift; 23 | my ($config) = @_; 24 | 25 | my $routes = $self->{routes}; 26 | 27 | return $routes unless $config && ref $config eq 'ARRAY'; 28 | 29 | foreach my $route (@{$config}) { 30 | $routes->add_route(delete $route->{route}, %$route); 31 | } 32 | 33 | return $routes; 34 | } 35 | 36 | 1; 37 | -------------------------------------------------------------------------------- /lib/Tu/Scope.pm: -------------------------------------------------------------------------------- 1 | package Tu::Scope; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Carp 'croak'; 7 | 8 | sub new { 9 | my $class = shift; 10 | my ($env) = @_; 11 | 12 | croak '$env required' unless $env; 13 | 14 | my $self = {env => $env}; 15 | bless $self, $class; 16 | 17 | return $self; 18 | } 19 | 20 | sub set { 21 | my $self = shift; 22 | my ($key, $value) = @_; 23 | 24 | return $self->{env}->{"tu.$key"} = $value; 25 | } 26 | 27 | sub exists : method { 28 | my $self = shift; 29 | my ($key) = @_; 30 | 31 | return $self->_key_exists($key); 32 | } 33 | 34 | sub get { 35 | my $self = shift; 36 | my ($key) = @_; 37 | 38 | my @subkeys = grep { /^tu\.$key\./ } keys %{$self->{env}}; 39 | if (@subkeys) { 40 | s/^tu\.$key\.// for @subkeys; 41 | 42 | my $new_env = {}; 43 | $new_env->{"tu.$_"} = $self->{env}->{"tu.$key.$_"} for @subkeys; 44 | 45 | return __PACKAGE__->new($new_env); 46 | } 47 | 48 | croak "unknown key '$key'" 49 | unless my $options = $self->_key_exists($key); 50 | 51 | return $self->{env}->{"tu.$key"}; 52 | } 53 | 54 | sub _key_exists { 55 | my $self = shift; 56 | my ($key) = @_; 57 | 58 | return exists $self->{env}->{"tu.$key"}; 59 | } 60 | 61 | sub DESTROY { } 62 | 63 | our $AUTOLOAD; 64 | 65 | sub AUTOLOAD { 66 | my $self = shift; 67 | 68 | my ($method) = (split /::/, $AUTOLOAD)[-1]; 69 | 70 | return if $method =~ /^[A-Z]/; 71 | return if $method =~ /^_/; 72 | 73 | return $self->get($method, @_); 74 | } 75 | 76 | 1; 77 | -------------------------------------------------------------------------------- /lib/Tu/ServiceContainer.pm: -------------------------------------------------------------------------------- 1 | package Tu::ServiceContainer; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Carp qw(croak); 7 | use Scalar::Util qw(blessed); 8 | use Tu::Loader; 9 | 10 | sub new { 11 | my $class = shift; 12 | my (%params) = @_; 13 | 14 | my $self = {}; 15 | bless $self, $class; 16 | 17 | $self->{services} = {}; 18 | $self->{loader} = $params{loader}; 19 | 20 | $self->{loader} ||= Tu::Loader->new; 21 | 22 | return $self; 23 | } 24 | 25 | sub register { 26 | my $self = shift; 27 | my ($name, $value, %params) = @_; 28 | 29 | if (exists $self->{services}->{$name}) { 30 | croak qq{service '$name' already registered}; 31 | } 32 | 33 | $self->{services}->{$name} = {value => $value, %params}; 34 | 35 | return $self; 36 | } 37 | 38 | sub register_group { 39 | my $self = shift; 40 | my ($group, %params) = @_; 41 | 42 | if (!blessed $group) { 43 | my $group_class = $self->{loader}->load_class($group); 44 | 45 | $group = $group_class->new; 46 | } 47 | 48 | $group->register($self, %params); 49 | 50 | return $self; 51 | } 52 | 53 | sub service { 54 | my $self = shift; 55 | my ($name) = @_; 56 | 57 | croak qq{unknown service '$name'} unless exists $self->{services}->{$name}; 58 | 59 | my $service = $self->{services}->{$name}; 60 | 61 | my $instance; 62 | 63 | if (ref $service->{value} eq 'CODE') { 64 | $instance = $service->{value}->($self); 65 | } 66 | elsif ($service->{new}) { 67 | if (!$service->{instance}) { 68 | my $service_class = $self->{loader}->load_class($service->{value}); 69 | 70 | my %deps; 71 | if (ref $service->{new} eq 'ARRAY') { 72 | $deps{$_} = $self->service($_) for @{$service->{new}}; 73 | } 74 | elsif (ref $service->{new} eq 'CODE') { 75 | $service->{instance} = $service->{new}->($service_class, $self); 76 | } 77 | 78 | $service->{instance} ||= $service_class->new(%deps); 79 | } 80 | 81 | $instance = $service->{instance}; 82 | } 83 | else { 84 | $instance = $service->{value}; 85 | } 86 | 87 | return $instance; 88 | } 89 | 90 | 1; 91 | -------------------------------------------------------------------------------- /lib/Tu/ServiceContainer/Actions.pm: -------------------------------------------------------------------------------- 1 | package Tu::ServiceContainer::Actions; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | sub new { 7 | my $class = shift; 8 | 9 | my $self = {}; 10 | bless $self, $class; 11 | 12 | return $self; 13 | } 14 | 15 | sub register { 16 | my $self = shift; 17 | my ($services, %params) = @_; 18 | 19 | $services->register( 20 | action_factory => $params{action_factory} || 'Tu::ActionFactory', 21 | new => sub { 22 | my ($class, $services) = @_; 23 | $class->new( 24 | namespaces => $services->service('app_class') . '::Action::'); 25 | } 26 | ); 27 | 28 | return $self; 29 | } 30 | 31 | 1; 32 | -------------------------------------------------------------------------------- /lib/Tu/ServiceContainer/Common.pm: -------------------------------------------------------------------------------- 1 | package Tu::ServiceContainer::Common; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | sub new { 7 | my $class = shift; 8 | 9 | my $self = {}; 10 | bless $self, $class; 11 | 12 | return $self; 13 | } 14 | 15 | sub register { 16 | my $self = shift; 17 | my ($services, %params) = @_; 18 | 19 | $services->register_group('+Tu::ServiceContainer::Config', %params); 20 | $services->register_group('+Tu::ServiceContainer::Routes', %params); 21 | $services->register_group('+Tu::ServiceContainer::Actions', %params); 22 | $services->register_group('+Tu::ServiceContainer::Displayer', %params); 23 | 24 | return $self; 25 | } 26 | 27 | 1; 28 | -------------------------------------------------------------------------------- /lib/Tu/ServiceContainer/Config.pm: -------------------------------------------------------------------------------- 1 | package Tu::ServiceContainer::Config; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | sub new { 7 | my $class = shift; 8 | 9 | my $self = {}; 10 | bless $self, $class; 11 | 12 | return $self; 13 | } 14 | 15 | sub register { 16 | my $self = shift; 17 | my ($services, %params) = @_; 18 | 19 | $self->{config_file} = $params{config_file} || 'config/config.yml'; 20 | 21 | my $config_file = $self->{config_file}; 22 | 23 | $services->register( 24 | config => 'Tu::Config', 25 | new => sub { 26 | my ($class, $services) = @_; 27 | 28 | my $home = $services->service('home'); 29 | $class->new(mode => 1)->load($home->catfile($config_file)); 30 | } 31 | ); 32 | 33 | return $self; 34 | } 35 | 36 | 1; 37 | -------------------------------------------------------------------------------- /lib/Tu/ServiceContainer/Displayer.pm: -------------------------------------------------------------------------------- 1 | package Tu::ServiceContainer::Displayer; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | sub new { 7 | my $class = shift; 8 | 9 | my $self = {}; 10 | bless $self, $class; 11 | 12 | return $self; 13 | } 14 | 15 | sub register { 16 | my $self = shift; 17 | my ($services, %params) = @_; 18 | 19 | $services->register( 20 | templates_path => $params{templates_path} || sub { 21 | shift->service('config')->{templates_path} || 'templates'; 22 | } 23 | ); 24 | $services->register( 25 | renderer => $params{renderer} || 'Tu::Renderer::APL', 26 | new => [qw/home templates_path/] 27 | ); 28 | 29 | $services->register(layout => $params{layout} || 'layout.apl'); 30 | $services->register( 31 | displayer => 'Tu::Displayer', 32 | new => [qw/renderer layout/] 33 | ); 34 | 35 | return $self; 36 | } 37 | 38 | 1; 39 | -------------------------------------------------------------------------------- /lib/Tu/ServiceContainer/Mailer.pm: -------------------------------------------------------------------------------- 1 | package Tu::ServiceContainer::Mailer; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Carp qw(croak); 7 | use Tu::Mailer; 8 | 9 | sub new { 10 | my $class = shift; 11 | 12 | my $self = {}; 13 | bless $self, $class; 14 | 15 | return $self; 16 | } 17 | 18 | sub register { 19 | my $self = shift; 20 | my ($services, %params) = @_; 21 | 22 | my $config = 23 | $params{config} 24 | || $services->service('config')->{mailer} 25 | || {}; 26 | 27 | croak 'mailer not configured' unless %$config; 28 | 29 | my $mailer = $self->_build_mailer(%$config); 30 | $services->register(mailer => $mailer); 31 | 32 | return $self; 33 | } 34 | 35 | sub _build_mailer { 36 | my $self = shift; 37 | 38 | Tu::Mailer->new(@_); 39 | } 40 | 41 | 1; 42 | -------------------------------------------------------------------------------- /lib/Tu/ServiceContainer/Routes.pm: -------------------------------------------------------------------------------- 1 | package Tu::ServiceContainer::Routes; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | sub new { 7 | my $class = shift; 8 | 9 | my $self = {}; 10 | bless $self, $class; 11 | 12 | return $self; 13 | } 14 | 15 | sub register { 16 | my $self = shift; 17 | my ($services, %params) = @_; 18 | 19 | $services->register(routes => 'Tu::Routes', new => 1); 20 | 21 | $services->register( 22 | dispatcher => 'Tu::Dispatcher::Routes', 23 | new => [qw/routes/] 24 | ); 25 | 26 | return $self; 27 | } 28 | 29 | 1; 30 | -------------------------------------------------------------------------------- /lib/Tu/Util.pm: -------------------------------------------------------------------------------- 1 | package Tu::Util; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use parent 'Exporter'; 7 | 8 | our @EXPORT = qw(slurp); 9 | 10 | use Carp qw(croak); 11 | use Encode (); 12 | 13 | sub slurp { 14 | my ($path, $encoding) = @_; 15 | 16 | local $/ = undef; 17 | open my $fh, '<', $path or croak "Can't open '$path': $!"; 18 | my $config = <$fh>; 19 | close $fh; 20 | 21 | if (defined($encoding)) { 22 | $config = Encode::decode($encoding, $config); 23 | } 24 | 25 | return $config; 26 | } 27 | 28 | 1; 29 | -------------------------------------------------------------------------------- /lib/Tu/Validator.pm: -------------------------------------------------------------------------------- 1 | package Tu::Validator; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Carp qw(croak); 7 | use Tu::Loader; 8 | use Tu::ValidatorResult; 9 | 10 | sub new { 11 | my $class = shift; 12 | my (%params) = @_; 13 | 14 | my $self = {}; 15 | bless $self, $class; 16 | 17 | $self->{messages} = $params{messages}; 18 | $self->{namespaces} = $params{namespaces}; 19 | 20 | $self->{messages} ||= {}; 21 | $self->{namespaces} ||= ['Tu::Validator::']; 22 | 23 | $self->{fields} = {}; 24 | $self->{rules} = {}; 25 | 26 | return $self; 27 | } 28 | 29 | sub add_field { 30 | my $self = shift; 31 | my ($field, %params) = @_; 32 | 33 | croak "field '$field' exists" 34 | if exists $self->{fields}->{$field}; 35 | 36 | $self->{fields}->{$field} = {required => 1, trim => 1, %params}; 37 | 38 | return $self; 39 | } 40 | 41 | sub add_optional_field { shift->add_field(@_, required => 0) } 42 | 43 | sub add_rule { 44 | my $self = shift; 45 | my ($field_name, $rule_name, @rule_args) = @_; 46 | 47 | croak "field '$field_name' does not exist" 48 | unless exists $self->{fields}->{$field_name}; 49 | 50 | my $rule = $self->_build_rule( 51 | $rule_name, 52 | fields => [$field_name], 53 | args => \@rule_args 54 | ); 55 | 56 | push @{$self->{rules}->{$field_name}}, $rule; 57 | 58 | return $rule; 59 | } 60 | 61 | sub add_group_rule { 62 | my $self = shift; 63 | my ($group_name, $fields_names, $rule_name, @rule_args) = @_; 64 | 65 | for my $field_name (@$fields_names) { 66 | croak "field '$field_name' does not exist" 67 | unless exists $self->{fields}->{$field_name}; 68 | } 69 | 70 | croak "rule '$group_name' exists" 71 | if exists $self->{rules}->{$group_name}; 72 | 73 | my $rule = $self->_build_rule( 74 | $rule_name, 75 | fields => $fields_names, 76 | args => \@rule_args 77 | ); 78 | 79 | push @{$self->{rules}->{$group_name}}, $rule; 80 | 81 | return $self; 82 | } 83 | 84 | sub validate { 85 | my $self = shift; 86 | my ($params) = @_; 87 | 88 | croak 'must be a hash ref' unless ref $params eq 'HASH'; 89 | 90 | $params = $self->_prepare_params($params); 91 | 92 | my $result = {params => $params}; 93 | 94 | $self->_validate_required($result); 95 | 96 | $self->_validate_rules($result); 97 | 98 | $result->{validated_params} = $self->_gather_validated_params($result); 99 | 100 | return Tu::ValidatorResult->new(%$result, messages => $self->{messages}); 101 | } 102 | 103 | sub _validate_required { 104 | my $self = shift; 105 | my ($result) = @_; 106 | 107 | foreach my $name (keys %{$self->{fields}}) { 108 | my $value = $result->{params}->{$name}; 109 | 110 | my $is_empty = $self->_is_field_empty($value); 111 | 112 | if ($is_empty) { 113 | if (exists $self->{fields}->{$name}->{default}) { 114 | $result->{params}->{$name} = $self->{fields}->{$name}->{default}; 115 | } 116 | elsif ($self->{fields}->{$name}->{required}) { 117 | $result->{errors}->{$name} = 'REQUIRED'; 118 | } 119 | } 120 | } 121 | } 122 | 123 | sub _validate_rules { 124 | my $self = shift; 125 | my ($result) = @_; 126 | 127 | my $params = $result->{params}; 128 | 129 | foreach my $rule_name (keys %{$self->{rules}}) { 130 | next if exists $self->{errors}->{$rule_name}; 131 | 132 | if (exists $self->{fields}->{$rule_name}) { 133 | next if $self->_is_field_empty($params->{$rule_name}); 134 | } 135 | 136 | my $rules = $self->{rules}->{$rule_name}; 137 | 138 | foreach my $rule (@$rules) { 139 | next if $rule->validate($params); 140 | 141 | if (exists $self->{fields}->{$rule_name} 142 | && $self->{fields}->{$rule_name}->{default_on_error}) 143 | { 144 | $params->{$rule_name} = 145 | $self->{fields}->{$rule_name}->{default}; 146 | last; 147 | } 148 | 149 | $result->{errors}->{$rule_name} = $rule->name; 150 | last; 151 | } 152 | } 153 | } 154 | 155 | sub _gather_validated_params { 156 | my $self = shift; 157 | my ($result) = @_; 158 | 159 | my $validated_params = {}; 160 | 161 | foreach my $name (keys %{$self->{fields}}) { 162 | next if exists $result->{errors}->{$name}; 163 | 164 | if (exists $result->{params}->{$name}) { 165 | my $value = $result->{params}->{$name}; 166 | 167 | $validated_params->{$name} = length $value ? $value : undef; 168 | } 169 | } 170 | 171 | return $validated_params; 172 | } 173 | 174 | sub _is_field_empty { 175 | my $self = shift; 176 | my ($value) = @_; 177 | 178 | $value = [$value] unless ref $value eq 'ARRAY'; 179 | return 1 unless @$value; 180 | 181 | my $all_empty = 1; 182 | 183 | foreach (@$value) { 184 | if (defined $_ && $_ ne '') { 185 | $all_empty = 0; 186 | last; 187 | } 188 | } 189 | 190 | return $all_empty; 191 | } 192 | 193 | sub _prepare_params { 194 | my $self = shift; 195 | my ($params) = @_; 196 | 197 | $params = $self->_prepare_array_like($params); 198 | 199 | foreach my $name (keys %{$self->{fields}}) { 200 | if ($self->{fields}->{$name}->{multiple}) { 201 | $params->{$name} = [$params->{$name}] 202 | unless ref $params->{$name} eq 'ARRAY'; 203 | } 204 | else { 205 | $params->{$name} = $params->{$name}->[0] 206 | if ref $params->{$name} eq 'ARRAY'; 207 | } 208 | 209 | $params->{$name} = $self->_trim($params->{$name}) 210 | if $self->{fields}->{$name}->{trim}; 211 | } 212 | 213 | return $params; 214 | } 215 | 216 | sub _prepare_array_like { 217 | my $self = shift; 218 | my ($params) = @_; 219 | 220 | my $prepared = {}; 221 | foreach my $key (keys %$params) { 222 | my $value = $params->{$key}; 223 | $value = [@$value] if ref $value eq 'ARRAY'; 224 | 225 | if ($key =~ m/^(.*?)\[(\d+)\]$/) { 226 | my ($name, $index) = ($1, $2); 227 | 228 | $prepared->{$name}->[$index] = 229 | ref $value eq 'ARRAY' ? $value->[0] : $value; 230 | } 231 | else { 232 | $prepared->{$key} = $value; 233 | } 234 | } 235 | 236 | return $prepared; 237 | } 238 | 239 | sub _trim { 240 | my $self = shift; 241 | my ($param) = @_; 242 | 243 | foreach my $param (ref $param eq 'ARRAY' ? @$param : $param) { 244 | next if !defined $param || ref $param; 245 | for ($param) { s/^\s*//g; s/\s*$//g; } 246 | } 247 | 248 | return $param; 249 | } 250 | 251 | sub _build_rule { 252 | my $self = shift; 253 | my ($rule_name, @args) = @_; 254 | 255 | my $rule_class = 256 | Tu::Loader->new(namespaces => $self->{namespaces}) 257 | ->load_class(ucfirst $rule_name); 258 | 259 | return $rule_class->new(@args); 260 | } 261 | 262 | 1; 263 | -------------------------------------------------------------------------------- /lib/Tu/Validator/Base.pm: -------------------------------------------------------------------------------- 1 | package Tu::Validator::Base; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | sub new { 7 | my $class = shift; 8 | my (%params) = @_; 9 | 10 | my $self = {}; 11 | bless $self, $class; 12 | 13 | $self->{fields} = $params{fields}; 14 | $self->{args} = $params{args}; 15 | 16 | return $self; 17 | } 18 | 19 | sub name { 20 | my $self = shift; 21 | 22 | my $name = ref $self; 23 | $name =~ s/^.*?::Validator:://; 24 | 25 | return uc $name; 26 | } 27 | 28 | sub validate { 29 | my $self = shift; 30 | my ($params) = @_; 31 | 32 | my $is_group = @{$self->{fields}} > 1; 33 | 34 | my $value; 35 | 36 | if ($is_group) { 37 | $value = []; 38 | $value = [map { $params->{$_} } @{$self->{fields}}]; 39 | 40 | return $self->is_valid($value, @{$self->{args}}); 41 | } 42 | 43 | $value = $params->{$self->{fields}->[0]}; 44 | 45 | $value = [$value] unless ref $value eq 'ARRAY'; 46 | foreach (@$value) { 47 | return 0 unless $self->is_valid($_, @{$self->{args}}); 48 | } 49 | 50 | return 1; 51 | } 52 | 53 | sub is_valid { ... } 54 | 55 | 1; 56 | -------------------------------------------------------------------------------- /lib/Tu/Validator/Callback.pm: -------------------------------------------------------------------------------- 1 | package Tu::Validator::Callback; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use parent 'Tu::Validator::Base'; 7 | 8 | sub is_valid { 9 | my $self = shift; 10 | my ($value, $cb) = @_; 11 | 12 | return $cb->($self, $value); 13 | } 14 | 15 | 1; 16 | -------------------------------------------------------------------------------- /lib/Tu/Validator/Compare.pm: -------------------------------------------------------------------------------- 1 | package Tu::Validator::Compare; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use parent 'Tu::Validator::Base'; 7 | 8 | sub is_valid { 9 | my $self = shift; 10 | my ($values) = @_; 11 | 12 | for (@$values[1 .. $#$values]) { 13 | return 0 unless $_ eq $values->[0]; 14 | } 15 | 16 | return 1; 17 | } 18 | 19 | 1; 20 | -------------------------------------------------------------------------------- /lib/Tu/Validator/In.pm: -------------------------------------------------------------------------------- 1 | package Tu::Validator::In; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use parent 'Tu::Validator::Base'; 7 | 8 | use List::Util qw(first); 9 | 10 | sub is_valid { 11 | my $self = shift; 12 | my ($value, $in) = @_; 13 | 14 | return !!first { $value eq $_ } @$in; 15 | } 16 | 17 | 1; 18 | -------------------------------------------------------------------------------- /lib/Tu/Validator/Regexp.pm: -------------------------------------------------------------------------------- 1 | package Tu::Validator::Regexp; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use parent 'Tu::Validator::Base'; 7 | 8 | sub is_valid { 9 | my $self = shift; 10 | my ($value, $re) = @_; 11 | 12 | return $value =~ m/$re/; 13 | } 14 | 15 | 1; 16 | -------------------------------------------------------------------------------- /lib/Tu/ValidatorResult.pm: -------------------------------------------------------------------------------- 1 | package Tu::ValidatorResult; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | sub new { 7 | my $class = shift; 8 | my (%params) = @_; 9 | 10 | my $self = {}; 11 | bless $self, $class; 12 | 13 | $self->{messages} = $params{messages}; 14 | $self->{params} = $params{params}; 15 | $self->{errors} = $params{errors} || {}; 16 | $self->{validated_params} = $params{validated_params} || {}; 17 | 18 | return $self; 19 | } 20 | 21 | sub add_error { 22 | my $self = shift; 23 | my ($name, $error) = @_; 24 | 25 | $self->{errors}->{$name} = $error; 26 | } 27 | 28 | sub errors { 29 | my $self = shift; 30 | 31 | my $errors = {}; 32 | 33 | foreach my $name (keys %{$self->{errors}}) { 34 | my $error = $self->{errors}->{$name}; 35 | $errors->{$name} = $self->_map_error($name, $error); 36 | } 37 | 38 | return $errors; 39 | } 40 | 41 | sub is_success { 42 | my $self = shift; 43 | 44 | return !%{$self->{errors}}; 45 | } 46 | 47 | sub all_params { $_[0]->{params} } 48 | sub validated_params { $_[0]->{validated_params} } 49 | 50 | sub _map_error { 51 | my $self = shift; 52 | my ($name, $error) = @_; 53 | 54 | for ("$name.$error", $error) { 55 | if (my $message = $self->{messages}->{$_}) { 56 | $error = $message; 57 | last; 58 | } 59 | } 60 | 61 | return $error; 62 | } 63 | 64 | 1; 65 | -------------------------------------------------------------------------------- /lib/Tu/X/Base.pm: -------------------------------------------------------------------------------- 1 | package Tu::X::Base; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use overload 7 | '""' => sub { $_[0]->to_string }, 8 | 'bool' => sub { 1 }, 9 | fallback => 1; 10 | 11 | require Carp; 12 | use Scalar::Util (); 13 | 14 | sub new { 15 | my $class = shift; 16 | my (%params) = @_; 17 | 18 | my $self = {}; 19 | bless $self, $class; 20 | 21 | $self->{message} = $params{message}; 22 | $self->{message} = "Exception: $class" unless defined $self->{message}; 23 | 24 | $self->{file} = $params{caller}->[1]; 25 | $self->{line} = $params{caller}->[2]; 26 | 27 | return $self; 28 | } 29 | 30 | sub message { 31 | $_[0]->{message}; 32 | } 33 | 34 | sub throw { 35 | my $class = shift; 36 | my ($message, %params) = @_; 37 | 38 | Carp::croak($class->new(message => $message, %params, caller => [caller])); 39 | } 40 | 41 | sub to_string { &as_string } 42 | 43 | sub as_string { 44 | my $self = shift; 45 | 46 | return sprintf('%s at %s line %s.', 47 | $self->{message}, $self->{file}, $self->{line}); 48 | } 49 | 50 | 1; 51 | -------------------------------------------------------------------------------- /lib/Tu/X/HTTP.pm: -------------------------------------------------------------------------------- 1 | package Tu::X::HTTP; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use parent 'Tu::X::Base'; 7 | 8 | sub new { 9 | my $self = shift->SUPER::new(@_); 10 | my (%params) = @_; 11 | 12 | $self->{code} = $params{code}; 13 | 14 | return $self; 15 | } 16 | 17 | sub code { $_[0]->{code} || 500 } 18 | 19 | sub as_string { $_[0]->{message} } 20 | 21 | 1; 22 | -------------------------------------------------------------------------------- /minil.toml: -------------------------------------------------------------------------------- 1 | name = "Tu" 2 | -------------------------------------------------------------------------------- /t/acl.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | use Test::Fatal; 6 | 7 | use Tu::ACL; 8 | 9 | subtest 'denied_by_default' => sub { 10 | my $acl = _build_acl(); 11 | 12 | ok !$acl->is_allowed('admin', 'login'); 13 | }; 14 | 15 | subtest 'throw when allow unknown role' => sub { 16 | my $acl = _build_acl(); 17 | 18 | like exception { $acl->allow('admin', 'foo') }, qr/Unknown role/; 19 | }; 20 | 21 | subtest 'allow_allowed_action' => sub { 22 | my $acl = _build_acl(); 23 | 24 | $acl->add_role('admin'); 25 | $acl->allow('admin', 'foo'); 26 | 27 | ok $acl->is_allowed('admin', 'foo'); 28 | }; 29 | 30 | subtest 'throw when deny unknown role' => sub { 31 | my $acl = _build_acl(); 32 | 33 | like exception { $acl->deny('admin', 'foo') }, qr/Unknown role/; 34 | }; 35 | 36 | subtest 'deny_unknown_role' => sub { 37 | my $acl = _build_acl(); 38 | 39 | ok !$acl->is_allowed('admin', 'foo'); 40 | }; 41 | 42 | subtest 'deny_unknown_action' => sub { 43 | my $acl = _build_acl(); 44 | 45 | $acl->add_role('admin'); 46 | $acl->allow('admin', 'foo'); 47 | 48 | ok !$acl->is_allowed('admin', 'bar'); 49 | }; 50 | 51 | subtest 'deny_denied_action' => sub { 52 | my $acl = _build_acl(); 53 | 54 | $acl->add_role('admin'); 55 | $acl->allow('admin', 'foo'); 56 | $acl->deny('admin', 'bar'); 57 | 58 | ok !$acl->is_allowed('admin', 'bar'); 59 | }; 60 | 61 | subtest 'allow_everything_with_star' => sub { 62 | my $acl = _build_acl(); 63 | 64 | $acl->add_role('admin'); 65 | $acl->allow('admin', '*'); 66 | 67 | ok $acl->is_allowed('admin', 'foo'); 68 | }; 69 | 70 | subtest 'deny_action_despite_of_star' => sub { 71 | my $acl = _build_acl(); 72 | 73 | $acl->add_role('admin'); 74 | $acl->allow('admin', '*'); 75 | $acl->deny('admin', 'foo'); 76 | 77 | ok !$acl->is_allowed('admin', 'foo'); 78 | }; 79 | 80 | subtest 'inherit_rules' => sub { 81 | my $acl = _build_acl(); 82 | 83 | $acl->add_role('user'); 84 | $acl->allow('user', 'foo'); 85 | 86 | $acl->add_role('admin', 'user'); 87 | 88 | ok $acl->is_allowed('admin', 'foo'); 89 | }; 90 | 91 | subtest 'allow_everyone' => sub { 92 | my $acl = _build_acl(); 93 | 94 | $acl->add_role('user1'); 95 | $acl->add_role('user2'); 96 | $acl->allow('*', 'foo'); 97 | 98 | ok $acl->is_allowed('user1', 'foo'); 99 | ok $acl->is_allowed('user2', 'foo'); 100 | }; 101 | 102 | subtest 'allow_everyone_everything' => sub { 103 | my $acl = _build_acl(); 104 | 105 | $acl->add_role('user1'); 106 | $acl->add_role('user2'); 107 | $acl->allow('*', '*'); 108 | 109 | ok $acl->is_allowed('user1', 'foo'); 110 | ok $acl->is_allowed('user2', 'foo'); 111 | }; 112 | 113 | subtest 'deny_everyone' => sub { 114 | my $acl = _build_acl(); 115 | 116 | $acl->add_role('user1'); 117 | $acl->add_role('user2'); 118 | $acl->allow('*', '*'); 119 | 120 | $acl->deny('*', 'foo'); 121 | 122 | ok !$acl->is_allowed('user1', 'foo'); 123 | ok !$acl->is_allowed('user2', 'foo'); 124 | }; 125 | 126 | subtest 'denies by regex' => sub { 127 | my $acl = _build_acl(); 128 | 129 | $acl->add_role('user'); 130 | $acl->add_role('admin'); 131 | $acl->allow('user', '*'); 132 | $acl->allow('admin', '*'); 133 | 134 | $acl->deny('user', qr/^admin/); 135 | 136 | ok $acl->is_allowed('user', 'foo'); 137 | ok $acl->is_allowed('admin', 'foo'); 138 | ok !$acl->is_allowed('user', 'admin_foo'); 139 | ok $acl->is_allowed('admin', 'admin_foo'); 140 | }; 141 | 142 | subtest 'allows by when' => sub { 143 | my $acl = _build_acl(); 144 | 145 | $acl->add_role('user'); 146 | $acl->allow('user', 'foo'); 147 | $acl->deny('user', 'foo', when => sub { 0 }); 148 | 149 | ok $acl->is_allowed('user', 'foo'); 150 | }; 151 | 152 | subtest 'denies by when' => sub { 153 | my $acl = _build_acl(); 154 | 155 | $acl->add_role('user'); 156 | $acl->allow('user', '*', when => sub { 0 }); 157 | 158 | ok !$acl->is_allowed('user', 'foo'); 159 | }; 160 | 161 | sub _build_acl { 162 | return Tu::ACL->new(@_); 163 | } 164 | 165 | done_testing; 166 | -------------------------------------------------------------------------------- /t/acl/from_config.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | 6 | use Tu::ACL; 7 | use Tu::ACL::FromConfig; 8 | 9 | subtest 'build acl from config' => sub { 10 | my $acl = _build_acl()->load('t/acl/from_config_t/acl.yml'); 11 | 12 | ok $acl->is_allowed('anonymous', 'login'); 13 | ok !$acl->is_allowed('anonymous', 'logout'); 14 | ok !$acl->is_allowed('user', 'login'); 15 | ok $acl->is_allowed('user', 'logout'); 16 | }; 17 | 18 | subtest 'do nothing when empty' => sub { 19 | my $acl = _build_acl()->load('t/acl/from_config_t/empty.yml'); 20 | 21 | ok !$acl->is_allowed('anonymous', 'login'); 22 | }; 23 | 24 | subtest 'accept acl from outside' => sub { 25 | my $acl = 26 | _build_acl(acl => Tu::ACL->new)->load('t/acl/from_config_t/acl.yml'); 27 | 28 | ok $acl->is_allowed('anonymous', 'login'); 29 | }; 30 | 31 | sub _build_acl { 32 | return Tu::ACL::FromConfig->new(@_); 33 | } 34 | 35 | done_testing; 36 | -------------------------------------------------------------------------------- /t/acl/from_config_t/acl.yml: -------------------------------------------------------------------------------- 1 | --- 2 | roles: 3 | - anonymous 4 | - user 5 | allow: 6 | anonymous: 7 | - login 8 | user: 9 | - '*' 10 | deny: 11 | user: 12 | - login 13 | -------------------------------------------------------------------------------- /t/acl/from_config_t/empty.yml: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /t/action.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | use Test::Fatal; 6 | use Test::MonkeyMock; 7 | 8 | use Tu::ServiceContainer; 9 | use Tu::Action; 10 | use Tu::Displayer; 11 | 12 | subtest 'builds correct redirect response' => sub { 13 | my $action = _build_action(); 14 | 15 | my $res = $action->redirect('http://localhost'); 16 | 17 | is($res->status, 302); 18 | is($res->headers->header('Location'), 'http://localhost'); 19 | }; 20 | 21 | subtest 'builds redirect response with custom status' => sub { 22 | my $action = _build_action(); 23 | 24 | my $res = $action->redirect('http://localhost', 301); 25 | 26 | is($res->status, 301); 27 | }; 28 | 29 | subtest 'throws correct not found exception' => sub { 30 | my $action = _build_action(); 31 | 32 | my $e = exception { $action->throw_not_found }; 33 | 34 | is($e->code, '404'); 35 | }; 36 | 37 | subtest 'throws correct forbidden exception' => sub { 38 | my $action = _build_action(); 39 | 40 | my $e = exception { $action->throw_forbidden }; 41 | 42 | is($e->code, '403'); 43 | }; 44 | 45 | subtest 'throws correct error exception' => sub { 46 | my $action = _build_action(); 47 | 48 | my $e = exception { $action->throw_error }; 49 | 50 | is($e->code, '500'); 51 | }; 52 | 53 | subtest 'throws correct error exception with custom status' => sub { 54 | my $action = _build_action(); 55 | 56 | my $e = exception { $action->throw_error('foo', 503) }; 57 | 58 | is($e->code, '503'); 59 | }; 60 | 61 | subtest 'renders template' => sub { 62 | my $action = _build_action(); 63 | 64 | my $res = $action->render('template'); 65 | 66 | is($res, 'template'); 67 | }; 68 | 69 | subtest 'merges default layout' => sub { 70 | my $displayer = _mock_displayer(); 71 | my $action = _build_action( 72 | displayer => $displayer, 73 | env => {'tu.displayer.layout' => 'default'} 74 | ); 75 | 76 | my $res = $action->render('template'); 77 | 78 | my ($template, %params) = $displayer->mocked_call_args('render'); 79 | is_deeply \%params, {layout => 'default', vars => {}}; 80 | }; 81 | 82 | subtest 'not merges default layout when layout present' => sub { 83 | my $displayer = _mock_displayer(); 84 | my $action = _build_action( 85 | displayer => $displayer, 86 | env => {'tu.displayer.layout' => 'default'} 87 | ); 88 | 89 | my $res = $action->render('template', layout => 'new'); 90 | 91 | my ($template, %params) = $displayer->mocked_call_args('render'); 92 | is_deeply \%params, {layout => 'new', vars => {}}; 93 | }; 94 | 95 | subtest 'not merges default layout even if new is undefined' => sub { 96 | my $displayer = _mock_displayer(); 97 | my $action = _build_action( 98 | displayer => $displayer, 99 | env => {'tu.displayer.layout' => 'default'} 100 | ); 101 | 102 | my $res = $action->render('template', layout => undef); 103 | 104 | my ($template, %params) = $displayer->mocked_call_args('render'); 105 | is_deeply \%params, {layout => undef, vars => {}}; 106 | }; 107 | 108 | subtest 'correctly merges displayer vars with existing' => sub { 109 | my $displayer = _mock_displayer(); 110 | my $action = _build_action( 111 | displayer => $displayer, 112 | env => {'tu.displayer.vars' => {old => 'vars'}} 113 | ); 114 | 115 | my $res = $action->render('template', vars => {foo => 'bar'}); 116 | 117 | my ($template, %params) = $displayer->mocked_call_args('render'); 118 | is_deeply \%params, {vars => {foo => 'bar', old => 'vars'}}; 119 | }; 120 | 121 | subtest 'url_for returns absolute url as is' => sub { 122 | my $action = _build_action(); 123 | 124 | is $action->url_for('http://foo.com'), 'http://foo.com'; 125 | }; 126 | 127 | subtest 'url_for returns url starting with slash as is' => sub { 128 | my $action = _build_action( 129 | env => {PATH_INFO => '/prefix', HTTP_HOST => 'example.com'}); 130 | 131 | is $action->url_for('/hello'), 'http://example.com/hello'; 132 | }; 133 | 134 | subtest 'url_for returns url from build_path' => sub { 135 | my $action = _build_action(env => {HTTP_HOST => 'example.com'}); 136 | 137 | is $action->url_for('route'), 'http://example.com/path'; 138 | }; 139 | 140 | subtest 'builds req' => sub { 141 | my $action = _build_action(env => {PATH_INFO => '/foo'}); 142 | 143 | is $action->req->path, '/foo'; 144 | }; 145 | 146 | subtest 'caches req' => sub { 147 | my $action = _build_action(env => {PATH_INFO => '/foo'}); 148 | 149 | my $ref = $action->req; 150 | is $action->req, $ref; 151 | }; 152 | 153 | subtest 'throws when no env' => sub { 154 | ok exception { Tu::Action->new }; 155 | }; 156 | 157 | subtest 'returns service from service container' => sub { 158 | my $action = _build_action(); 159 | 160 | ok $action->service('displayer'); 161 | }; 162 | 163 | subtest 'returns captures from dispatched request' => sub { 164 | my $action = 165 | _build_action(dispatched_request => 166 | _mock_dispatched_request(captures => {foo => 'bar'})); 167 | 168 | is_deeply $action->captures, {foo => 'bar'}; 169 | }; 170 | 171 | subtest 'sets and gets displayer vars' => sub { 172 | my $action = _build_action(); 173 | 174 | $action->set_var(foo => 'bar'); 175 | 176 | is_deeply $action->vars, {foo => 'bar'}; 177 | }; 178 | 179 | sub _mock_displayer { 180 | my $displayer = Tu::Displayer->new(renderer => 1); 181 | $displayer = Test::MonkeyMock->new($displayer); 182 | $displayer->mock(render => sub { $_[1] }); 183 | return $displayer; 184 | } 185 | 186 | sub _mock_dispatched_request { 187 | my (%params) = @_; 188 | 189 | my $dr = Test::MonkeyMock->new(); 190 | $dr->mock(build_path => sub { '/path' }); 191 | $dr->mock(captures => sub { $params{captures} }); 192 | return $dr; 193 | } 194 | 195 | sub _build_action { 196 | my (%params) = @_; 197 | 198 | my $displayer = delete $params{displayer} || _mock_displayer(); 199 | my $dispatched_request = 200 | delete $params{dispatched_request} || _mock_dispatched_request(); 201 | 202 | my $services = Tu::ServiceContainer->new; 203 | $services->register(displayer => $displayer); 204 | 205 | my $env = { 206 | 'tu.displayer.vars' => {}, 207 | 'tu.dispatched_request' => $dispatched_request, 208 | %{delete $params{env} || {}}, 209 | }; 210 | 211 | return Tu::Action->new(env => $env, services => $services, %params); 212 | } 213 | 214 | done_testing; 215 | -------------------------------------------------------------------------------- /t/action/form_mixin.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | use File::Temp; 6 | use HTTP::Request::Common; 7 | use HTTP::Message::PSGI; 8 | use Tu::Validator; 9 | 10 | subtest 'do nothing on get' => sub { 11 | my $action = _build_form('TestForm', GET '/'); 12 | 13 | ok !defined $action->run; 14 | }; 15 | 16 | subtest 'validate on POST' => sub { 17 | my $action = _build_form('TestForm', POST '/'); 18 | 19 | ok !defined $action->run; 20 | 21 | is_deeply $action->vars->{errors}, {foo => 'REQUIRED'}; 22 | }; 23 | 24 | subtest 'sets params on errors' => sub { 25 | my $action = _build_form('TestForm', POST '/', {foo => 'wrong'}); 26 | 27 | $action->run; 28 | 29 | is_deeply $action->vars->{params}, {foo => 'wrong'}; 30 | }; 31 | 32 | subtest 'calls submit on success' => sub { 33 | my $action = _build_form('TestForm', POST '/', {foo => 123}); 34 | 35 | is $action->run, 'SUBMIT 123'; 36 | 37 | is_deeply $action->vars, {}; 38 | }; 39 | 40 | subtest 'calls show when present' => sub { 41 | my $action = _build_form('TestFormWithShow', GET '/'); 42 | 43 | is $action->run, 'SHOW'; 44 | }; 45 | 46 | subtest 'calls show on errors when present' => sub { 47 | my $action = _build_form('TestFormWithShow', POST '/'); 48 | 49 | is $action->run, 'SHOW_ERRORS'; 50 | }; 51 | 52 | subtest 'calls custom validation' => sub { 53 | my $action = 54 | _build_form('TestFormWithCustomValidation', POST '/', {foo => 123}); 55 | 56 | $action->run; 57 | 58 | is_deeply $action->vars->{errors}, {foo => 'too big'}; 59 | }; 60 | 61 | subtest 'runs submit when passing custom validation' => sub { 62 | my $action = 63 | _build_form('TestFormWithCustomValidation', POST '/', {foo => 1}); 64 | 65 | is $action->run, 'ok'; 66 | 67 | is_deeply $action->vars, {}; 68 | }; 69 | 70 | subtest 'validates uploads' => sub { 71 | my $fh = File::Temp->new; 72 | my $action = _build_form( 73 | 'TestFormWithUploads', 74 | POST '/', 75 | Content_Type => 'multipart/form-data', 76 | Content => [upload => [$fh->filename]] 77 | ); 78 | 79 | is $action->run, 'ok'; 80 | 81 | is_deeply $action->vars, {}; 82 | }; 83 | 84 | done_testing; 85 | 86 | sub _build_form { 87 | my ($class, $req) = @_; 88 | 89 | my $env = req_to_psgi($req); 90 | 91 | $env->{'tu.displayer.vars'} = {}; 92 | 93 | return $class->new(env => $env); 94 | } 95 | 96 | package TestForm; 97 | use base 'Tu::Action'; 98 | 99 | use Tu::Action::FormMixin 'validate_or_submit'; 100 | 101 | sub build_validator { 102 | my $validator = Tu::Validator->new; 103 | 104 | $validator->add_field('foo'); 105 | $validator->add_rule('foo', 'regexp', qr/^\d+$/); 106 | 107 | return $validator; 108 | } 109 | 110 | sub submit { 111 | my $self = shift; 112 | my ($params) = @_; 113 | 'SUBMIT ' . $params->{foo}; 114 | } 115 | 116 | sub run { shift->validate_or_submit } 117 | 118 | package TestFormWithShow; 119 | use base 'Tu::Action'; 120 | 121 | use Tu::Action::FormMixin 'validate_or_submit'; 122 | 123 | sub build_validator { 124 | my $validator = Tu::Validator->new; 125 | $validator->add_field('foo'); 126 | } 127 | 128 | sub show { 'SHOW' } 129 | sub show_errors { 'SHOW_ERRORS' } 130 | 131 | sub submit { } 132 | 133 | sub run { shift->validate_or_submit } 134 | 135 | package TestFormWithCustomValidation; 136 | use base 'Tu::Action'; 137 | 138 | use Tu::Action::FormMixin 'validate_or_submit'; 139 | 140 | sub build_validator { 141 | my $validator = Tu::Validator->new; 142 | $validator->add_field('foo'); 143 | return $validator; 144 | } 145 | 146 | sub submit { 'ok' } 147 | 148 | sub validate { 149 | my $self = shift; 150 | my ($validator, $params) = @_; 151 | 152 | if (length $params->{foo} > 1) { 153 | $validator->add_error('foo', 'too big'); 154 | return 0; 155 | } 156 | 157 | return 1; 158 | } 159 | 160 | sub run { shift->validate_or_submit } 161 | 162 | package TestFormWithUploads; 163 | use base 'Tu::Action'; 164 | 165 | use Tu::Action::FormMixin 'validate_or_submit'; 166 | 167 | sub build_validator { 168 | my $validator = Tu::Validator->new; 169 | $validator->add_field('upload'); 170 | return $validator; 171 | } 172 | 173 | sub submit { 'ok' } 174 | 175 | sub validate { 176 | my $self = shift; 177 | my ($validator, $params) = @_; 178 | 179 | if (length $params->{upload} > 128) { 180 | $validator->add_error('foo', 'too big'); 181 | return 0; 182 | } 183 | 184 | return 1; 185 | } 186 | 187 | sub run { shift->validate_or_submit } 188 | -------------------------------------------------------------------------------- /t/action_response_resolver.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use utf8; 4 | 5 | use Test::More; 6 | use Test::Fatal; 7 | 8 | use Encode (); 9 | 10 | use Tu::Response; 11 | use Tu::ActionResponseResolver; 12 | 13 | subtest 'returns undef on undef' => sub { 14 | my $resolver = _build_resolver(); 15 | 16 | ok !defined $resolver->resolve; 17 | }; 18 | 19 | subtest 'returns array ref as is' => sub { 20 | my $resolver = _build_resolver(); 21 | 22 | is_deeply $resolver->resolve([200, [], ['body']]), [200, [], ['body']]; 23 | }; 24 | 25 | subtest 'returns code as is' => sub { 26 | my $resolver = _build_resolver(); 27 | 28 | is ref $resolver->resolve(sub { }), 'CODE'; 29 | }; 30 | 31 | subtest 'returns finalized object' => sub { 32 | my $resolver = _build_resolver(); 33 | 34 | is_deeply $resolver->resolve(Tu::Response->new(200)), 35 | [200, ['Content-Type' => 'text/html'], []]; 36 | }; 37 | 38 | subtest 'returns string' => sub { 39 | my $resolver = _build_resolver(); 40 | 41 | is_deeply $resolver->resolve('hello world'), 42 | [ 43 | 200, 44 | ['Content-Type' => 'text/html; charset=utf-8', 'Content-Length' => 11], 45 | ['hello world'] 46 | ]; 47 | }; 48 | 49 | subtest 'returns encoded string' => sub { 50 | my $resolver = _build_resolver(); 51 | 52 | is_deeply $resolver->resolve('привет'), 53 | [ 54 | 200, 55 | ['Content-Type' => 'text/html; charset=utf-8', 'Content-Length' => 12], 56 | [Encode::encode('UTF-8', 'привет')] 57 | ]; 58 | }; 59 | 60 | subtest 'throws when unexpected return type' => sub { 61 | my $resolver = _build_resolver(); 62 | 63 | like exception { $resolver->resolve(TestObject->new) }, 64 | qr/unexpected return from action/; 65 | }; 66 | 67 | sub _build_resolver { Tu::ActionResponseResolver->new(@_) } 68 | 69 | done_testing; 70 | 71 | package TestObject; 72 | 73 | use strict; 74 | use warnings; 75 | 76 | sub new { 77 | my $class = shift; 78 | 79 | my $self = {}; 80 | bless $self, $class; 81 | 82 | return $self; 83 | } 84 | 85 | 1; 86 | -------------------------------------------------------------------------------- /t/app.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | use Test::Fatal; 6 | 7 | use Tu; 8 | 9 | subtest 'returns coderef' => sub { 10 | my $app = TestApp->new; 11 | 12 | is ref $app->to_app, 'CODE'; 13 | }; 14 | 15 | subtest 'defaults to 404' => sub { 16 | my $app = Tu->new; 17 | 18 | like exception { $app->to_app->() }, qr/Not Found/; 19 | }; 20 | 21 | subtest 'registers services' => sub { 22 | my $app = TestApp->new(home => '/foo/bar'); 23 | 24 | my $home = $app->service('home'); 25 | is $home, '/foo/bar'; 26 | 27 | my $app_class = $app->service('app_class'); 28 | is $app_class, 'TestApp'; 29 | }; 30 | 31 | done_testing; 32 | 33 | package TestApp; 34 | use parent 'Tu'; 35 | 36 | sub startup { } 37 | -------------------------------------------------------------------------------- /t/app/simple.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | use Plack::Test; 6 | 7 | use lib 't/app/simple_t/lib'; 8 | 9 | use HTTP::Request; 10 | 11 | my $app = 12 | eval do { local $/; open my $fh, '<', 't/app/simple_t/app.psgi'; <$fh> }; 13 | 14 | subtest 'simple app' => sub { 15 | test_psgi 16 | app => $app, 17 | client => sub { 18 | my $cb = shift; 19 | my $req = HTTP::Request->new(GET => '/'); 20 | my $res = $cb->($req); 21 | 22 | like $res->content, qr/Hello world, bar!/; 23 | }; 24 | }; 25 | 26 | done_testing; 27 | -------------------------------------------------------------------------------- /t/app/simple_t/app.psgi: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Plack::Builder; 7 | use TestAppSimple; 8 | 9 | my $app = TestAppSimple->new; 10 | 11 | builder { 12 | enable 13 | 'ErrorDocument', 14 | 403 => '/forbidden', 15 | 404 => '/not_found', 16 | subrequest => 1; 17 | 18 | enable 'HTTPExceptions'; 19 | 20 | enable '+Tu::Middleware::Defaults', services => $app->services; 21 | enable '+Tu::Middleware::RequestDispatcher', services => $app->services; 22 | enable '+Tu::Middleware::ActionDispatcher', services => $app->services; 23 | enable '+Tu::Middleware::ViewDisplayer', services => $app->services; 24 | 25 | $app->to_app; 26 | } 27 | -------------------------------------------------------------------------------- /t/app/simple_t/config/config.dev.yml: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vti/tu/ee198e2d72d948c0beb2e53410c967fc50fa4206/t/app/simple_t/config/config.dev.yml -------------------------------------------------------------------------------- /t/app/simple_t/config/config.yml: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vti/tu/ee198e2d72d948c0beb2e53410c967fc50fa4206/t/app/simple_t/config/config.yml -------------------------------------------------------------------------------- /t/app/simple_t/lib/TestAppSimple.pm: -------------------------------------------------------------------------------- 1 | package TestAppSimple; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use parent 'Tu'; 7 | 8 | sub startup { 9 | my $self = shift; 10 | 11 | $self->services->register_group('Tu::ServiceContainer::Common'); 12 | 13 | $self->service('routes')->add_route('/', name => 'index'); 14 | } 15 | 16 | 1; 17 | -------------------------------------------------------------------------------- /t/app/simple_t/lib/TestAppSimple/Action/Index.pm: -------------------------------------------------------------------------------- 1 | package TestAppSimple::Action::Index; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use parent 'Tu::Action'; 7 | 8 | sub run { 9 | my $self = shift; 10 | 11 | $self->set_var(foo => 'bar'); 12 | 13 | return; 14 | } 15 | 16 | 1; 17 | -------------------------------------------------------------------------------- /t/app/simple_t/templates/index.apl: -------------------------------------------------------------------------------- 1 | Hello world, <%= $foo %>! 2 | -------------------------------------------------------------------------------- /t/app/simple_t/templates/layout.apl: -------------------------------------------------------------------------------- 1 | 2 | 3 | <%= $content %> 4 | 5 | 6 | -------------------------------------------------------------------------------- /t/assets_container.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | use Test::Fatal; 6 | use Test::TempDir::Tiny; 7 | 8 | use Tu::AssetsContainer; 9 | 10 | subtest 'requires js' => sub { 11 | my $assets = _build_assets(); 12 | 13 | $assets->require('/foo.js'); 14 | 15 | is($assets->include, 16 | ''); 17 | }; 18 | 19 | subtest 'requires js as is' => sub { 20 | my $assets = _build_assets(); 21 | 22 | $assets->require(\'1 + 1', type => 'js'); 23 | 24 | is($assets->include, ''); 25 | }; 26 | 27 | subtest 'requires with specified type' => sub { 28 | my $assets = _build_assets(); 29 | 30 | $assets->require('/foo.bar', type => 'js'); 31 | 32 | is($assets->include, 33 | ''); 34 | }; 35 | 36 | subtest 'requires css' => sub { 37 | my $assets = _build_assets(); 38 | 39 | $assets->require('/foo.css'); 40 | 41 | is($assets->include, 42 | '' 43 | ); 44 | }; 45 | 46 | subtest 'does not add same requires' => sub { 47 | my $assets = _build_assets(); 48 | 49 | $assets->require('/foo.js'); 50 | $assets->require('/foo.js'); 51 | 52 | is($assets->include, 53 | ''); 54 | }; 55 | 56 | subtest 'includes only specified type' => sub { 57 | my $assets = _build_assets(); 58 | 59 | $assets->require('/foo.js'); 60 | $assets->require('/foo.css'); 61 | 62 | is($assets->include(type => 'js'), 63 | ''); 64 | }; 65 | 66 | subtest 'orders by index' => sub { 67 | my $assets = _build_assets(); 68 | 69 | $assets->require('/foo.js', index => 10); 70 | $assets->require('/last.js'); 71 | $assets->require('/bar.js', index => 5); 72 | 73 | is( 74 | $assets->include(type => 'js'), 75 | '' . "\n" 76 | . '' . "\n" 77 | . '' 78 | ); 79 | }; 80 | 81 | subtest 'adds custom attributes' => sub { 82 | my $assets = _build_assets(); 83 | 84 | $assets->require('/foo.js', attrs => {foo => 'bar'}); 85 | 86 | is($assets->include(type => 'js'), 87 | ''); 88 | }; 89 | 90 | subtest 'throws when unknown type' => sub { 91 | my $assets = _build_assets(); 92 | 93 | $assets->require('/foo.foo'); 94 | 95 | like exception { $assets->include }, qr/unknown asset type 'foo'/; 96 | }; 97 | 98 | subtest 'add version if public_dir present' => sub { 99 | my $public_dir = tempdir(); 100 | 101 | my ($mtime) = (stat _write_file("$public_dir/foo.js", '1 + 1'))[9]; 102 | 103 | my $assets = _build_assets(public_dir => $public_dir); 104 | 105 | $assets->require('/foo.js'); 106 | 107 | is $assets->include(type => 'js'), 108 | qq{}; 109 | }; 110 | 111 | subtest 'not add version if public_dir present but no file' => sub { 112 | my $public_dir = tempdir(); 113 | 114 | my $assets = _build_assets(public_dir => $public_dir); 115 | 116 | $assets->require('/foo.js'); 117 | 118 | is $assets->include(type => 'js'), 119 | qq{}; 120 | }; 121 | 122 | sub _write_file { 123 | my ($file, $content) = @_; 124 | 125 | open my $fh, '>', $file or die $!; 126 | print $fh $content; 127 | close $fh; 128 | 129 | return $file; 130 | } 131 | 132 | sub _build_assets { 133 | return Tu::AssetsContainer->new(@_); 134 | } 135 | 136 | done_testing; 137 | -------------------------------------------------------------------------------- /t/auth/session.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | use Test::Requires; 6 | use Test::Fatal; 7 | 8 | BEGIN { test_requires 'Plack::Session' } 9 | 10 | use Tu::Auth::Session; 11 | 12 | subtest 'loads undef when no session' => sub { 13 | my $auth = _build_auth(); 14 | 15 | ok !$auth->load({'psgix.session' => {}}); 16 | }; 17 | 18 | subtest 'loads undef when no user' => sub { 19 | my $auth = _build_auth(); 20 | 21 | ok !$auth->load({'psgix.session' => {id => 5}}); 22 | }; 23 | 24 | subtest 'loads when user found' => sub { 25 | my $auth = _build_auth(); 26 | 27 | ok $auth->load({'psgix.session' => {id => 1}}); 28 | }; 29 | 30 | subtest 'loads with additional options' => sub { 31 | my $auth = _build_auth(); 32 | 33 | ok !$auth->load({'psgix.session' => {id => 1, fake => 1}}); 34 | }; 35 | 36 | subtest 'creates session on login' => sub { 37 | my $auth = _build_auth(); 38 | 39 | my $user = TestUserLoader->new; 40 | 41 | my $env = {'psgix.session' => {}, 'psgix.session.options' => {}}; 42 | $auth->login($env, {id => $user->id}); 43 | 44 | is $env->{'psgix.session'}->{id}, 1; 45 | }; 46 | 47 | subtest 'saves additional options' => sub { 48 | my $auth = _build_auth(); 49 | 50 | my $user = TestUserLoader->new; 51 | 52 | my $env = {'psgix.session' => {}, 'psgix.session.options' => {}}; 53 | $auth->login($env, {id => $user->id, foo => 'bar'}); 54 | 55 | is $env->{'psgix.session'}->{foo}, 'bar'; 56 | }; 57 | 58 | subtest 'expires session on logout' => sub { 59 | my $auth = _build_auth(); 60 | 61 | my $env = 62 | {'psgix.session' => {id => 1}, 'psgix.session.options' => {}}; 63 | $auth->logout($env); 64 | 65 | is_deeply $env, 66 | {'psgix.session' => {}, 'psgix.session.options' => {expire => 1}}; 67 | }; 68 | 69 | subtest 'calls finalize' => sub { 70 | my $auth = _build_auth(); 71 | 72 | my $env = 73 | {'psgix.session' => {id => 1}, 'psgix.session.options' => {}}; 74 | $auth->finalize($env); 75 | 76 | is_deeply $env, 77 | { 78 | 'psgix.session' => {id => 1, new => 'options'}, 79 | 'psgix.session.options' => {} 80 | }; 81 | }; 82 | 83 | sub _build_auth { 84 | return Tu::Auth::Session->new(user_loader => TestUserLoader->new, @_); 85 | } 86 | 87 | done_testing; 88 | 89 | package TestUserLoader; 90 | 91 | sub new { 92 | my $class = shift; 93 | 94 | my $self = {}; 95 | bless $self, $class; 96 | 97 | return $self; 98 | } 99 | 100 | sub id { 1 } 101 | 102 | sub load { 103 | my $self = shift; 104 | my ($options) = @_; 105 | 106 | return if $options->{fake}; 107 | return $self if $options->{id} && $options->{id} == $self->id; 108 | return; 109 | } 110 | 111 | sub finalize { 112 | my $self = shift; 113 | my ($options) = @_; 114 | 115 | $options->{new} = 'options'; 116 | } 117 | 118 | 1; 119 | -------------------------------------------------------------------------------- /t/config.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use utf8; 4 | 5 | use Test::More; 6 | use Test::Fatal; 7 | 8 | use Tu::Config; 9 | 10 | subtest 'return empty hash when empty config' => sub { 11 | my $config = _build_config(); 12 | 13 | my $data = $config->load('t/config_t/empty.yml'); 14 | 15 | is_deeply($data, {}); 16 | }; 17 | 18 | subtest 'rethrow yaml error' => sub { 19 | my $config = _build_config(); 20 | 21 | like exception { $config->load('t/config_t/error.yml') }, 22 | qr/error|fail/i; 23 | }; 24 | 25 | subtest 'loads config based on extension' => sub { 26 | my $config = _build_config(); 27 | 28 | my $data = $config->load('t/config_t/config.yml'); 29 | 30 | is_deeply($data, {foo => 'bar', 'привет' => 'там'}); 31 | }; 32 | 33 | subtest 'throws when no extension' => sub { 34 | my $config = _build_config(); 35 | 36 | like exception { $config->load('t/config_t/unknown') }, 37 | qr/Can't guess a config format/; 38 | }; 39 | 40 | subtest 'loads config without mode' => sub { 41 | my $config = _build_config(mode => 0); 42 | 43 | my $data = $config->load('t/config_t/config.yml'); 44 | 45 | is_deeply($data, {foo => 'bar', 'привет' => 'там'}); 46 | }; 47 | 48 | subtest 'loads config with production mode' => sub { 49 | my $config = _build_config(mode => 1); 50 | 51 | local $ENV{PLACK_ENV} = 'production'; 52 | 53 | my $data = $config->load('t/config_t/config.yml'); 54 | 55 | is_deeply($data, {foo => 'bar', 'привет' => 'там'}); 56 | }; 57 | 58 | subtest 'loads config based on mode' => sub { 59 | my $config = _build_config(mode => 1); 60 | 61 | local $ENV{PLACK_ENV} = 'development'; 62 | 63 | my $data = $config->load('t/config_t/config.yml'); 64 | 65 | is_deeply($data, {dev => 1}); 66 | }; 67 | 68 | subtest 'loads config based on other mode' => sub { 69 | my $config = _build_config(mode => 1); 70 | 71 | local $ENV{PLACK_ENV} = 'test'; 72 | 73 | my $data = $config->load('t/config_t/config.yml'); 74 | 75 | is_deeply($data, {test => 'bar'}); 76 | }; 77 | 78 | subtest 'loads config with specified encoding' => sub { 79 | my $config = _build_config(encoding => 'koi8-r'); 80 | 81 | my $data = $config->load('t/config_t/koi8.yml'); 82 | 83 | my $bytes = Encode::encode('UTF-8', 'там'); 84 | Encode::from_to($bytes, 'UTF-8', 'koi8-r'); 85 | $bytes = Encode::decode('koi8-r', $bytes); 86 | 87 | is $data->{foo}, $bytes; 88 | }; 89 | 90 | sub _build_config { 91 | return Tu::Config->new(@_); 92 | } 93 | 94 | done_testing; 95 | -------------------------------------------------------------------------------- /t/config_t/config.dev.yml: -------------------------------------------------------------------------------- 1 | --- 2 | dev: 1 3 | -------------------------------------------------------------------------------- /t/config_t/config.foo: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vti/tu/ee198e2d72d948c0beb2e53410c967fc50fa4206/t/config_t/config.foo -------------------------------------------------------------------------------- /t/config_t/config.test.yml: -------------------------------------------------------------------------------- 1 | --- 2 | test: bar 3 | -------------------------------------------------------------------------------- /t/config_t/config.yml: -------------------------------------------------------------------------------- 1 | --- 2 | foo: bar 3 | привет: там 4 | -------------------------------------------------------------------------------- /t/config_t/empty.yml: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vti/tu/ee198e2d72d948c0beb2e53410c967fc50fa4206/t/config_t/empty.yml -------------------------------------------------------------------------------- /t/config_t/error.yml: -------------------------------------------------------------------------------- 1 | * 2 | -------------------------------------------------------------------------------- /t/config_t/koi8.yml: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vti/tu/ee198e2d72d948c0beb2e53410c967fc50fa4206/t/config_t/koi8.yml -------------------------------------------------------------------------------- /t/config_t/unknown: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vti/tu/ee198e2d72d948c0beb2e53410c967fc50fa4206/t/config_t/unknown -------------------------------------------------------------------------------- /t/dispatcher/routes.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | use Test::Fatal; 6 | 7 | use Tu::Dispatcher::Routes; 8 | use Tu::Routes; 9 | 10 | subtest 'throws on unknown action' => sub { 11 | my $d = _build_dispatcher(); 12 | 13 | like(exception { $d->dispatch('/unknown/action') }, qr/action is unknown/i); 14 | }; 15 | 16 | subtest 'returns action from name' => sub { 17 | my $d = _build_dispatcher(); 18 | 19 | my $dispatched = $d->dispatch('/'); 20 | 21 | is($dispatched->action, 'root'); 22 | }; 23 | 24 | subtest 'returns action from capture' => sub { 25 | my $d = _build_dispatcher(); 26 | 27 | my $dispatched = $d->dispatch('/foo'); 28 | 29 | is($dispatched->action, 'foo'); 30 | }; 31 | 32 | subtest 'returns captures' => sub { 33 | my $d = _build_dispatcher(); 34 | 35 | my $dispatched = $d->dispatch('/foo'); 36 | 37 | is_deeply $dispatched->captures, {action => 'foo'}; 38 | }; 39 | 40 | subtest 'returns empty params' => sub { 41 | my $d = _build_dispatcher(); 42 | 43 | my $dispatched = $d->dispatch('/foo'); 44 | 45 | is_deeply $dispatched->params, {}; 46 | }; 47 | 48 | subtest 'returns params' => sub { 49 | my $d = _build_dispatcher(); 50 | 51 | my $dispatched = $d->dispatch('/with_arguments'); 52 | 53 | is_deeply $dispatched->params, {foo => 'bar'}; 54 | }; 55 | 56 | subtest 'builds path' => sub { 57 | my $d = _build_dispatcher(); 58 | 59 | my $dispatched = $d->dispatch('/foo'); 60 | 61 | is($dispatched->build_path('root'), '/'); 62 | }; 63 | 64 | subtest 'returns undef when not matched' => sub { 65 | my $d = _build_dispatcher(); 66 | 67 | my $dispatched = $d->dispatch('/foo/bar/baz'); 68 | 69 | ok !$dispatched; 70 | }; 71 | 72 | sub _build_dispatcher { 73 | my $routes = Tu::Routes->new; 74 | $routes->add_route('/', name => 'root'); 75 | $routes->add_route( 76 | '/with_arguments', 77 | arguments => {foo => 'bar'}, 78 | name => 'with-arguments' 79 | ); 80 | $routes->add_route('/:action'); 81 | $routes->add_route('/unknown/action'); 82 | 83 | Tu::Dispatcher::Routes->new(routes => $routes); 84 | } 85 | 86 | done_testing; 87 | -------------------------------------------------------------------------------- /t/displayer.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | use Test::Fatal; 6 | use Test::MonkeyMock; 7 | 8 | use Tu::Displayer; 9 | 10 | subtest 'throws when no renderer' => sub { 11 | like exception { 12 | Tu::Displayer->new 13 | }, qr/renderer required/; 14 | }; 15 | 16 | subtest 'correctly renders string' => sub { 17 | my $r = _mock_renderer(content_string => 'hi there'); 18 | my $d = _build_displayer(renderer => $r); 19 | 20 | is $d->render(\'template', vars => {foo => 'bar'}), 'hi there'; 21 | 22 | my ($string, $vars) = $r->mocked_call_args('render_string'); 23 | is $string, 'template'; 24 | is_deeply $vars, {foo => 'bar'}; 25 | }; 26 | 27 | subtest 'correctly renders file' => sub { 28 | my $r = _mock_renderer(content_file => 'hi there'); 29 | my $d = _build_displayer(renderer => $r); 30 | 31 | is $d->render('template', vars => {foo => 'bar'}), 'hi there'; 32 | 33 | my ($file, $vars) = $r->mocked_call_args('render_file'); 34 | is $file, 'template'; 35 | is_deeply $vars, {foo => 'bar'}; 36 | }; 37 | 38 | subtest 'forces global layout' => sub { 39 | my $r = _mock_renderer(content_file => 'hi there'); 40 | my $d = _build_displayer(renderer => $r, layout => 'custom_layout'); 41 | 42 | $d->render('template', vars => {foo => 'bar'}); 43 | 44 | my ($file, $vars) = $r->mocked_call_args('render_file'); 45 | 46 | is $file, 'template'; 47 | is_deeply $vars, {foo => 'bar'}; 48 | 49 | ($file, $vars) = $r->mocked_call_args('render_file', 1); 50 | 51 | is $file, 'custom_layout'; 52 | is_deeply $vars, {content => 'hi there', foo => 'bar'}; 53 | }; 54 | 55 | subtest 'skips global layout when local undef' => sub { 56 | my $r = _mock_renderer(content_file => 'hi there'); 57 | my $d = _build_displayer(renderer => $r, layout => 'custom_layout'); 58 | 59 | $d->render('template', vars => {foo => 'bar'}, layout => undef); 60 | 61 | is $r->mocked_called('render_file'), 1; 62 | }; 63 | 64 | subtest 'uses local layout' => sub { 65 | my $r = _mock_renderer(content_file => 'hi there'); 66 | my $d = _build_displayer(renderer => $r, layout => 'custom_layout'); 67 | 68 | $d->render('template', vars => {foo => 'bar'}, layout => 'local_layout'); 69 | 70 | my ($file, $vars) = $r->mocked_call_args('render_file', 1); 71 | 72 | is $file, 'local_layout'; 73 | is_deeply $vars, {content => 'hi there', foo => 'bar'}; 74 | }; 75 | 76 | sub _mock_renderer { 77 | my (%params) = @_; 78 | 79 | my $renderer = Test::MonkeyMock->new; 80 | $renderer->mock(render_file => sub { $params{content_file} }); 81 | $renderer->mock(render_string => sub { $params{content_string} }); 82 | } 83 | 84 | sub _build_displayer { 85 | my (%params) = @_; 86 | 87 | my $renderer = $params{renderer} || _mock_renderer(); 88 | 89 | Tu::Displayer->new(renderer => $renderer, @_); 90 | } 91 | 92 | done_testing; 93 | -------------------------------------------------------------------------------- /t/displayer/renderer.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | use Test::Fatal; 6 | 7 | use Tu::Renderer; 8 | 9 | subtest 'throws on unimplemented methods' => sub { 10 | like exception { Tu::Renderer->new->render_string }, qr/Unimplemented/; 11 | like exception { Tu::Renderer->new->render_file }, qr/Unimplemented/; 12 | }; 13 | 14 | subtest 'renders string' => sub { 15 | my $renderer = _build_renderer(); 16 | 17 | my (undef, $string) = $renderer->render_string('my template string'); 18 | 19 | is $string, 'my template string'; 20 | }; 21 | 22 | subtest 'renders template' => sub { 23 | my $renderer = _build_renderer(); 24 | 25 | my (undef, $path, $template) = $renderer->render_file('template.tpl'); 26 | 27 | is $path, 'templates'; 28 | is $template, 'template.tpl'; 29 | }; 30 | 31 | subtest 'renderes templates from overwritten templates_path' => sub { 32 | my $renderer = _build_renderer(templates_path => 'views'); 33 | 34 | my (undef, $path, undef) = $renderer->render_file('template.tpl'); 35 | 36 | is $path, 'views'; 37 | }; 38 | 39 | subtest 'prefixes templates path with home' => sub { 40 | my $renderer = _build_renderer(home => '/root/'); 41 | 42 | my (undef, $path, $template) = $renderer->render_file('template.tpl'); 43 | 44 | is $path, '/root/templates'; 45 | is $template, 'template.tpl'; 46 | }; 47 | 48 | subtest 'does not prefix templates path with home when absolute' => sub { 49 | my $renderer = _build_renderer(home => '/root/'); 50 | 51 | my (undef, undef, $template) = 52 | $renderer->render_file('/path/to/template.tpl'); 53 | 54 | is $template, '/path/to/template.tpl'; 55 | }; 56 | 57 | subtest 'does not prefix templates path with anything when absolute' => sub { 58 | my $renderer = _build_renderer(); 59 | 60 | my (undef, undef, $template) = 61 | $renderer->render_file('/path/to/template.tpl'); 62 | 63 | is $template, '/path/to/template.tpl'; 64 | }; 65 | 66 | subtest 'passes engine arguments' => sub { 67 | my $renderer = _build_renderer(engine_args => {foo => 'bar'}); 68 | 69 | my ($engine) = $renderer->render_file('/path/to/template.tpl'); 70 | 71 | is $engine->{foo}, 'bar'; 72 | }; 73 | 74 | sub _build_renderer { 75 | TestRenderer->new(@_); 76 | } 77 | 78 | done_testing; 79 | 80 | package TestEngine; 81 | 82 | sub new { 83 | my $class = shift; 84 | 85 | my $self = {@_}; 86 | bless $self, $class; 87 | 88 | return $self; 89 | } 90 | 91 | package TestRenderer; 92 | use parent 'Tu::Renderer'; 93 | 94 | sub _build_engine { 95 | shift; 96 | TestEngine->new(@_); 97 | } 98 | 99 | sub render_string { 100 | my $self = shift; 101 | return $self->{engine}, @_; 102 | } 103 | 104 | sub render_file { 105 | my $self = shift; 106 | return $self->{engine}, $self->{templates_path}, @_; 107 | } 108 | -------------------------------------------------------------------------------- /t/factory.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use lib 't/factory_t'; 5 | 6 | use Test::More; 7 | use Test::Fatal; 8 | 9 | use Tu::Factory; 10 | 11 | subtest 'build_an_object' => sub { 12 | my $factory = _build_factory(); 13 | 14 | my $foo = $factory->build('Foo'); 15 | 16 | ok($foo); 17 | }; 18 | 19 | subtest 'not_throw_on_unknown_class' => sub { 20 | my $factory = _build_factory(try => 1); 21 | 22 | ok !$factory->build('Unknown'); 23 | }; 24 | 25 | subtest 'throw_on_unknown_class' => sub { 26 | my $factory = _build_factory(); 27 | 28 | like exception { $factory->build('Unknown') }, 29 | qr/Can't locate Unknown\.pm in \@INC/; 30 | }; 31 | 32 | subtest 'rethrow_during_creation_errors' => sub { 33 | my $factory = _build_factory(); 34 | 35 | ok exception { $factory->build('DieDuringCreation') }; 36 | }; 37 | 38 | sub _build_factory { 39 | return Tu::Factory->new(@_); 40 | } 41 | 42 | done_testing; 43 | -------------------------------------------------------------------------------- /t/factory/observable.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | 6 | use Tu::Factory::Observable; 7 | 8 | subtest 'builds an observable object' => sub { 9 | my $factory = _build_factory(); 10 | 11 | my $foo = $factory->build('+TestFactoryObservable::Foo', 12 | observers => ['+TestFactoryObservable::Foo::Observer']); 13 | 14 | my $var = {hi => ''}; 15 | $foo->hi($var); 16 | 17 | is $var->{hi}, 'before hi after'; 18 | }; 19 | 20 | sub _build_factory { 21 | return Tu::Factory::Observable->new(@_); 22 | } 23 | 24 | done_testing; 25 | 26 | package TestFactoryObservable::Foo; 27 | use Tu::ObservableMixin qw(observe notify); 28 | 29 | sub new { 30 | my $class = shift; 31 | 32 | my $self = {}; 33 | bless $self, $class; 34 | 35 | return $self; 36 | } 37 | 38 | sub hi { 39 | my $self = shift; 40 | my ($foo) = @_; 41 | 42 | $self->notify('BEFORE:hi', $foo); 43 | 44 | $foo->{hi} .= 'hi'; 45 | 46 | $self->notify('AFTER:hi', $foo); 47 | 48 | return $foo; 49 | } 50 | 51 | package TestFactoryObservable::Foo::Observer; 52 | use parent 'Tu::Observer::Base'; 53 | 54 | sub _init { 55 | my $self = shift; 56 | 57 | $self->_register('BEFORE:hi' => sub { $_[1]->{hi} = 'before ' }); 58 | $self->_register('AFTER:hi' => sub { $_[1]->{hi} .= ' after' }); 59 | } 60 | -------------------------------------------------------------------------------- /t/factory_t/DieDuringCreation.pm: -------------------------------------------------------------------------------- 1 | package DieDuringCreation; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | sub new { 7 | die 'here'; 8 | } 9 | 10 | 1; 11 | -------------------------------------------------------------------------------- /t/factory_t/Foo.pm: -------------------------------------------------------------------------------- 1 | package Foo; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | sub new { 7 | my $class = shift; 8 | 9 | my $self = {@_}; 10 | bless $self, $class; 11 | 12 | return $self; 13 | } 14 | 15 | 1; 16 | -------------------------------------------------------------------------------- /t/factory_t/WithSyntaxErrors.pm: -------------------------------------------------------------------------------- 1 | package WithSyntaxErrors; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | sub run { 7 | w; 8 | } 9 | 10 | 1; 11 | -------------------------------------------------------------------------------- /t/helper.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | use Test::MonkeyMock; 6 | 7 | use Tu::Helper; 8 | 9 | subtest 'returns empty hash ref' => sub { 10 | my $env = {'tu.displayer.vars' => {}}; 11 | my $helper = _build_helper(env => $env); 12 | 13 | is_deeply $helper->params, {}; 14 | }; 15 | 16 | subtest 'returns params' => sub { 17 | my $env = {'tu.displayer.vars' => {params => {foo => 'bar'}}}; 18 | my $helper = _build_helper(env => $env); 19 | 20 | is_deeply $helper->params, {foo => 'bar'}; 21 | }; 22 | 23 | subtest 'returns param' => sub { 24 | my $env = {'tu.displayer.vars' => {params => {foo => 'bar'}}}; 25 | my $helper = _build_helper(env => $env); 26 | 27 | is_deeply $helper->param('foo'), 'bar'; 28 | }; 29 | 30 | subtest 'returns param if array ref' => sub { 31 | my $env = {'tu.displayer.vars' => {params => {foo => ['bar', 'baz']}}}; 32 | my $helper = _build_helper(env => $env); 33 | 34 | is_deeply $helper->param('foo'), 'bar'; 35 | }; 36 | 37 | subtest 'returns all params when single' => sub { 38 | my $env = {'tu.displayer.vars' => {params => {foo => 'bar'}}}; 39 | my $helper = _build_helper(env => $env); 40 | 41 | is_deeply $helper->param_multi('foo'), ['bar']; 42 | }; 43 | 44 | subtest 'returns all params when array ref' => sub { 45 | my $env = {'tu.displayer.vars' => {params => {foo => ['bar', 'baz']}}}; 46 | my $helper = _build_helper(env => $env); 47 | 48 | is_deeply $helper->param_multi('foo'), ['bar', 'baz']; 49 | }; 50 | 51 | subtest 'returns empty arrray ref on multi' => sub { 52 | my $env = {'tu.displayer.vars' => {}}; 53 | my $helper = _build_helper(env => $env); 54 | 55 | is_deeply $helper->param_multi('unknown'), []; 56 | }; 57 | 58 | sub _build_helper { 59 | my $services = Test::MonkeyMock->new; 60 | Tu::Helper->new(services => $services, @_); 61 | } 62 | 63 | done_testing; 64 | -------------------------------------------------------------------------------- /t/helper/displayer.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | use Test::MonkeyMock; 6 | 7 | use Tu::Helper::Displayer; 8 | 9 | subtest 'calls displayer' => sub { 10 | my $displayer = _mock_displayer(); 11 | my $helper = _build_helper(displayer => $displayer); 12 | 13 | $helper->render('template', foo => 'bar'); 14 | 15 | my ($template, @vars) = $displayer->mocked_call_args('render'); 16 | is $template, 'template'; 17 | is_deeply \@vars, [layout => undef, vars => {foo => 'bar'}]; 18 | }; 19 | 20 | subtest 'calls displayer with merged vars' => sub { 21 | my $env = {'tu.displayer.vars' => {another => 'var'}}; 22 | 23 | my $displayer = _mock_displayer(); 24 | my $helper = _build_helper(displayer => $displayer, env => $env); 25 | 26 | $helper->render('template', foo => 'bar'); 27 | 28 | my ($template, @vars) = $displayer->mocked_call_args('render'); 29 | is $template, 'template'; 30 | is_deeply \@vars, 31 | [layout => undef, vars => {another => 'var', foo => 'bar'}]; 32 | }; 33 | 34 | sub _mock_displayer { 35 | my $displayer = Test::MonkeyMock->new; 36 | $displayer->mock(render => sub { '' }); 37 | return $displayer; 38 | } 39 | 40 | my $env; 41 | 42 | sub _build_helper { 43 | my (%params) = @_; 44 | my $displayer = $params{displayer} || _mock_displayer(); 45 | 46 | my $services = Test::MonkeyMock->new; 47 | $services->mock(service => sub { $displayer }); 48 | 49 | $env = $params{env} || {'tu.displayer.vars' => {}}; 50 | Tu::Helper::Displayer->new( 51 | env => $env, 52 | services => $services 53 | ); 54 | } 55 | 56 | done_testing; 57 | -------------------------------------------------------------------------------- /t/helper_factory.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | use Test::Fatal; 6 | 7 | use Tu::HelperFactory; 8 | 9 | use lib 't/helper_t'; 10 | 11 | use Helper; 12 | 13 | subtest 'throws when registering existing helper' => sub { 14 | my $factory = _build_factory(); 15 | 16 | $factory->register_helper('foo' => sub { 'bar' }); 17 | 18 | ok exception { 19 | $factory->register_helper('foo' => sub { 'bar' }) 20 | }; 21 | }; 22 | 23 | subtest 'registers helper as sub' => sub { 24 | my $factory = _build_factory(); 25 | 26 | $factory->register_helper('foo' => sub { 'bar' }); 27 | 28 | my $foo = $factory->create_helper('foo'); 29 | 30 | is $foo, 'bar'; 31 | }; 32 | 33 | subtest 'registers helper as class' => sub { 34 | my $factory = _build_factory(); 35 | 36 | $factory->register_helper('foo' => 'Helper'); 37 | 38 | my $foo = $factory->create_helper('foo')->hi; 39 | 40 | is $foo, 'there'; 41 | }; 42 | 43 | subtest 'registers helper as instance' => sub { 44 | my $factory = _build_factory(); 45 | 46 | $factory->register_helper('foo' => Helper->new); 47 | 48 | my $foo = $factory->create_helper('foo')->hi; 49 | 50 | is $foo, 'there'; 51 | }; 52 | 53 | subtest 'autoloads methods' => sub { 54 | my $factory = _build_factory(); 55 | 56 | my $foo = $factory->helper; 57 | 58 | ok($foo); 59 | }; 60 | 61 | subtest 'does not autoload DESTROY method' => sub { 62 | my $factory = _build_factory(); 63 | 64 | ok !$factory->DESTROY; 65 | }; 66 | 67 | subtest 'does not autoload method starting with uppercase' => sub { 68 | my $factory = _build_factory(); 69 | 70 | ok !$factory->BUILD; 71 | }; 72 | 73 | subtest 'does not autoload private methods' => sub { 74 | my $factory = _build_factory(); 75 | 76 | ok !$factory->_helper; 77 | }; 78 | 79 | sub _build_factory { 80 | Tu::HelperFactory->new(@_); 81 | } 82 | 83 | done_testing; 84 | -------------------------------------------------------------------------------- /t/helper_factory/persistent.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | 6 | use Tu::HelperFactory::Persistent; 7 | 8 | use lib 't/helper_t'; 9 | 10 | use Helper; 11 | 12 | subtest 'should return same instance' => sub { 13 | my $factory = _build_factory(); 14 | 15 | $factory->register_helper('foo' => 'Helper'); 16 | 17 | my $foo = $factory->create_helper('foo'); 18 | my $bar = $factory->create_helper('foo'); 19 | 20 | is "$foo", "$bar"; 21 | }; 22 | 23 | sub _build_factory { Tu::HelperFactory::Persistent->new(@_) } 24 | 25 | done_testing; 26 | -------------------------------------------------------------------------------- /t/helper_t/Helper.pm: -------------------------------------------------------------------------------- 1 | package Helper; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | sub new { 7 | my $class = shift; 8 | 9 | my $self = {}; 10 | bless $self, $class; 11 | 12 | return $self; 13 | } 14 | 15 | sub hi { 'there' } 16 | 17 | 1; 18 | -------------------------------------------------------------------------------- /t/home.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | use Test::Fatal; 6 | 7 | use Tu::Home; 8 | 9 | subtest 'builds home from path' => sub { 10 | my $home = _build_home(path => '/foo/bar'); 11 | 12 | is $home => '/foo/bar'; 13 | }; 14 | 15 | subtest 'detect from loaded app_class' => sub { 16 | my $home = _build_home(app_class => 'Tu::Home'); 17 | 18 | like $home, qr{/lib$}; 19 | }; 20 | 21 | subtest 'defaults to current dir when unknown app_class' => sub { 22 | my $home = _build_home(app_class => 'UnlikelyToBeKnownClass'); 23 | 24 | is $home, '.'; 25 | }; 26 | 27 | subtest 'returns true in bool context' => sub { 28 | my $home = _build_home(path => '/foo/bar'); 29 | 30 | ok $home; 31 | }; 32 | 33 | subtest 'throws when cannot detect home' => sub { 34 | like exception { _build_home() }, qr/cannot detect home, pass it manually/; 35 | }; 36 | 37 | subtest 'implements catfile' => sub { 38 | my $home = _build_home(path => '/foo/bar'); 39 | 40 | is $home->catfile('hello', 'there'), 41 | File::Spec->catfile('/foo/bar/hello/there'); 42 | }; 43 | 44 | sub _build_home { Tu::Home->new(@_) } 45 | 46 | done_testing; 47 | -------------------------------------------------------------------------------- /t/loader.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | use Test::Fatal; 6 | 7 | use lib 't/loader_t'; 8 | 9 | use Tu::Loader; 10 | 11 | subtest 'throws when no class passed' => sub { 12 | my $loader = _build_loader(); 13 | 14 | like exception { $loader->is_class_loaded() }, qr/class name required/; 15 | like exception { $loader->load_class() }, qr/class name required/; 16 | like exception { $loader->try_load_class() }, qr/class name required/; 17 | }; 18 | 19 | subtest 'knows when class is already loaded' => sub { 20 | my $loader = _build_loader(); 21 | 22 | ok $loader->is_class_loaded('LoaderTestFoo'); 23 | }; 24 | 25 | subtest 'returns false when INC but undefined' => sub { 26 | my $loader = _build_loader(); 27 | 28 | local $INC{'Not/Defined.pm'} = undef; 29 | ok !$loader->is_class_loaded('Not::Defined'); 30 | }; 31 | 32 | subtest 'loads already loaded class' => sub { 33 | my $loader = _build_loader(); 34 | 35 | is $loader->load_class('LoaderTestFoo'), 'LoaderTestFoo'; 36 | }; 37 | 38 | subtest 'loads existing class searching namespaces' => sub { 39 | my $loader = _build_loader(namespaces => [qw/Foo:: Bar::/]); 40 | 41 | is $loader->load_class('Class'), 'Bar::Class'; 42 | }; 43 | 44 | subtest 'loads class by absolute name' => sub { 45 | my $loader = _build_loader(); 46 | 47 | is $loader->load_class('+Bar::Class'), 'Bar::Class'; 48 | }; 49 | 50 | subtest 'throws on invalid class name' => sub { 51 | my $loader = _build_loader(); 52 | 53 | like exception { $loader->load_class('@#$@') }, 54 | qr/invalid class name 'Foo::@#\$\@'/; 55 | }; 56 | 57 | subtest 'throws on unknown class' => sub { 58 | my $loader = _build_loader(); 59 | 60 | like exception { $loader->load_class('Unknown') }, 61 | qr/Can't locate Unknown\.pm in \@INC/; 62 | }; 63 | 64 | subtest 'throws on class with syntax errors' => sub { 65 | my $loader = _build_loader(); 66 | 67 | like exception { $loader->load_class('WithSyntaxErrors') }, 68 | qr/Bareword "w" not allowed while "strict subs" in use/; 69 | }; 70 | 71 | subtest 'returns false when class not found' => sub { 72 | my $loader = _build_loader(); 73 | 74 | ok !$loader->try_load_class('UnknownClass'); 75 | }; 76 | 77 | subtest 'returns class when class already loaded' => sub { 78 | my $loader = _build_loader(); 79 | 80 | is $loader->try_load_class('LoaderTestFoo'), 'LoaderTestFoo'; 81 | }; 82 | 83 | subtest 'returns class when class found' => sub { 84 | my $loader = _build_loader(); 85 | 86 | is $loader->try_load_class('TryLoadClass'), 'TryLoadClass'; 87 | }; 88 | 89 | subtest 'returns true when class loaded' => sub { 90 | my $loader = _build_loader(); 91 | 92 | ok $loader->is_class_loaded('LoaderTestFoo'); 93 | }; 94 | 95 | subtest 'returns false when class not loaded' => sub { 96 | my $loader = _build_loader(); 97 | 98 | ok !$loader->is_class_loaded('Foo123'); 99 | }; 100 | 101 | sub _build_loader { 102 | Tu::Loader->new(namespaces => [qw/Foo::/], @_); 103 | } 104 | 105 | done_testing; 106 | 107 | package LoaderTestFoo; 108 | sub bar { } 109 | -------------------------------------------------------------------------------- /t/loader_t/Bar/Class.pm: -------------------------------------------------------------------------------- 1 | package Bar::Class; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | 1; 7 | -------------------------------------------------------------------------------- /t/loader_t/TryLoadClass.pm: -------------------------------------------------------------------------------- 1 | package TryLoadClass; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | sub new { 7 | my $class = shift; 8 | 9 | my $self = {}; 10 | bless $self, $class; 11 | 12 | return $self; 13 | } 14 | 15 | 1; 16 | -------------------------------------------------------------------------------- /t/loader_t/WithSyntaxErrors.pm: -------------------------------------------------------------------------------- 1 | package WithSyntaxErrors; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | sub run { 7 | w; 8 | } 9 | 10 | 1; 11 | -------------------------------------------------------------------------------- /t/mailer.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use utf8; 4 | 5 | use Test::More; 6 | use Test::Requires; 7 | use Test::Fatal; 8 | 9 | BEGIN { test_requires 'Email::MIME' } 10 | 11 | use File::Temp; 12 | use MIME::Base64; 13 | use Tu::Mailer; 14 | 15 | subtest 'throws when no transport' => sub { 16 | like exception { _build_mailer(transport => undef) }, 17 | qr/transport required/; 18 | }; 19 | 20 | subtest 'builds message' => sub { 21 | my $mailer = _build_mailer(); 22 | 23 | my $message = $mailer->build_message( 24 | headers => [ 25 | To => 'Foo ', 26 | Subject => 'Bar' 27 | ], 28 | parts => ['Baz!'] 29 | ); 30 | 31 | like($message, qr{From: root }); 32 | like($message, qr{Date: }); 33 | like($message, qr{MIME-Version: 1\.0}); 34 | like($message, qr{Content-Transfer-Encoding: 7bit}); 35 | like($message, qr{Content-Type: text/plain; charset="UTF-8"}); 36 | like($message, qr{To: Foo }); 37 | like($message, qr{Subject: Bar}); 38 | like($message, qr{Baz!}); 39 | }; 40 | 41 | subtest 'builds message without headers' => sub { 42 | my $mailer = _build_mailer(headers => undef); 43 | 44 | my $message = $mailer->build_message(body => 'Hi'); 45 | 46 | like($message, qr{SGk=\s*$}); 47 | }; 48 | 49 | subtest 'builds message with specified encoding' => sub { 50 | my $mailer = _build_mailer(encoding => '8bit'); 51 | 52 | my $message = $mailer->build_message(body => 'Hi'); 53 | 54 | like($message, qr{Hi$}); 55 | }; 56 | 57 | subtest 'builds message with specified charset' => sub { 58 | my $mailer = _build_mailer(charset => 'koi8-r'); 59 | 60 | my $body = 'привет'; 61 | Encode::from_to(Encode::encode('UTF-8', $body), 'UTF-8', 'koi8-r'); 62 | my $message = $mailer->build_message(body => $body); 63 | 64 | like($message, qr{0NLJ18XU\s*$}); 65 | }; 66 | 67 | subtest 'builds message with simple body' => sub { 68 | my $mailer = _build_mailer(); 69 | 70 | my $message = $mailer->build_message(body => 'Hi'); 71 | 72 | like($message, qr{SGk=\s*$}); 73 | }; 74 | 75 | subtest 'builds message with unicode' => sub { 76 | my $mailer = _build_mailer(); 77 | 78 | my $message = $mailer->build_message( 79 | headers => [ 80 | To => 'Петр 1 ', 81 | Subject => 'Привет' 82 | ], 83 | body => 'Привет!' 84 | ); 85 | 86 | like($message, qr{\QTo: =?UTF-8?B?0J/QtdGC0YAgMQ==?=\E }); 87 | like($message, qr{\QSubject: =?UTF-8?B?0J/RgNC40LLQtdGC?=\E}); 88 | like($message, qr{\Q0J/RgNC40LLQtdGCIQ==\E}); 89 | }; 90 | 91 | subtest 'builds message with custom headers' => sub { 92 | my $mailer = _build_mailer(headers => ['Foo' => 'http://foo.com']); 93 | 94 | my $message = $mailer->build_message(); 95 | 96 | like($message, qr{Foo:[ ]http://foo.com}xms); 97 | }; 98 | 99 | subtest 'builds message with defaults' => sub { 100 | my $mailer = 101 | _build_mailer(headers => [To => 'foo@bar.com', Subject => 'Hello!']); 102 | 103 | my $message = $mailer->build_message(); 104 | 105 | like($message, qr/To:\s*foo\@bar\.com/xms); 106 | like($message, qr/Subject:\s*Hello!/xms); 107 | }; 108 | 109 | subtest 'builds message with overriden headers' => sub { 110 | my $mailer = _build_mailer(headers => [To => 'foo@bar.com'],); 111 | 112 | my $message = $mailer->build_message(headers => [To => 'bar@foo.com']); 113 | 114 | like($message, qr{bar\@foo.com}); 115 | unlike($message, qr{foo\@bar.com}); 116 | }; 117 | 118 | subtest 'builds message with subject prefix' => sub { 119 | my $mailer = _build_mailer(subject_prefix => '[Tu]'); 120 | 121 | my $message = $mailer->build_message(headers => [Subject => 'Hello!']); 122 | 123 | like($message, qr/Subject:\s*\[Tu\]\s*Hello!/xms); 124 | }; 125 | 126 | subtest 'does not build message with signature but without body' => sub { 127 | my $mailer = _build_mailer(signature => 'hello!'); 128 | 129 | my $message = $mailer->build_message(); 130 | 131 | like $message, qr/\r?\n\r?\n$/; 132 | }; 133 | 134 | subtest 'builds message with signature' => sub { 135 | my $mailer = _build_mailer(signature => 'hello!'); 136 | 137 | my $message = $mailer->build_message(body => 'Hi!'); 138 | 139 | like($message, qr/SGkhCgotLSAKaGVsbG8h/); 140 | }; 141 | 142 | subtest 'builds message with unicode signature' => sub { 143 | my $mailer = _build_mailer(signature => 'Привет!'); 144 | 145 | my $message = $mailer->build_message(body => 'Да!'); 146 | 147 | like($message, qr/0JTQsCEKCi0tIArQn9GA0LjQstC10YIh/); 148 | }; 149 | 150 | subtest 'send mail' => sub { 151 | my $file = File::Temp->new; 152 | 153 | my $mailer = 154 | _build_mailer(transport => {name => 'test', path => $file->filename}); 155 | 156 | $mailer->send(headers => [From => 'me@bar.com', To => 'you@bar.com'], body => 'Hi!'); 157 | 158 | my $message = do { local $/; open my $fh, '<', $file; <$fh> }; 159 | like($message, qr{me}); 160 | like($message, qr{you}); 161 | like($message, qr{SGkh}); 162 | }; 163 | 164 | sub _build_mailer { 165 | return Tu::Mailer->new( 166 | test => 1, 167 | headers => [From => 'root '], 168 | transport => {name => 'test'}, 169 | @_ 170 | ); 171 | } 172 | 173 | done_testing; 174 | -------------------------------------------------------------------------------- /t/middleware/acl.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | use Test::Fatal; 6 | 7 | use Tu::ACL; 8 | use Tu::DispatchedRequest; 9 | use Tu::Middleware::ACL; 10 | 11 | subtest 'allows when role is correct' => sub { 12 | my $mw = _build_middleware(); 13 | 14 | my $env = _build_env(user_role => 'user', action => 'foo'); 15 | 16 | my $res = $mw->prepare_app->call($env); 17 | 18 | ok $res; 19 | }; 20 | 21 | subtest 'denies when unknown role' => sub { 22 | my $mw = _build_middleware(); 23 | 24 | ok exception { 25 | $mw->prepare_app->call( 26 | _build_env(user_role => 'admin', action => 'bar')); 27 | }; 28 | }; 29 | 30 | subtest 'denies when denied action' => sub { 31 | my $mw = _build_middleware(); 32 | 33 | ok exception { 34 | $mw->prepare_app->call( 35 | _build_env(user_role => 'user', action => 'bar')); 36 | }; 37 | }; 38 | 39 | subtest 'denies when no role' => sub { 40 | my $mw = _build_middleware(); 41 | 42 | ok exception { $mw->prepare_app->call({}) }; 43 | }; 44 | 45 | subtest 'redirects instead of throw' => sub { 46 | my $mw = _build_middleware(redirect_to => '/login'); 47 | 48 | my $res = $mw->prepare_app->call({PATH_INFO => '/'}); 49 | 50 | is_deeply $res, [302, ['Location' => '/login'], ['']]; 51 | }; 52 | 53 | subtest 'prevents redirect recursion' => sub { 54 | my $mw = _build_middleware(redirect_to => '/login'); 55 | 56 | ok exception { 57 | $mw->prepare_app->call({PATH_INFO => '/login', 'tu.user_role' => undef}) 58 | }; 59 | }; 60 | 61 | sub _build_middleware { 62 | my $acl = Tu::ACL->new; 63 | 64 | $acl->add_role('user'); 65 | $acl->allow('user', 'foo'); 66 | 67 | return Tu::Middleware::ACL->new( 68 | app => sub { [200, [], ['OK']] }, 69 | acl => $acl, 70 | @_ 71 | ); 72 | } 73 | 74 | sub _build_env { 75 | my %params = @_; 76 | 77 | my $action = delete $params{action}; 78 | 79 | my $env = {}; 80 | 81 | $env->{'tu.user_role'} = undef; 82 | $env->{'tu.dispatched_request'} = 83 | Tu::DispatchedRequest->new(action => $action); 84 | 85 | foreach my $key (keys %params) { 86 | $env->{"tu.$key"} = $params{$key}; 87 | } 88 | 89 | return $env; 90 | } 91 | 92 | done_testing; 93 | -------------------------------------------------------------------------------- /t/middleware/action_dispatcher.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use lib 't/middleware/action_dispatcher_t'; 5 | 6 | use Test::More; 7 | use Test::Fatal; 8 | use Test::MonkeyMock; 9 | 10 | use Tu::DispatchedRequest; 11 | use Tu::ActionFactory; 12 | use Tu::Middleware::ActionDispatcher; 13 | 14 | subtest 'throws when no action_factory' => sub { 15 | like exception { 16 | _build_middleware(action_factory => undef)->prepare_app 17 | }, qr/action_factory required/; 18 | }; 19 | 20 | subtest 'does nothing when no action' => sub { 21 | my $mw = _build_middleware(); 22 | 23 | my $res = $mw->prepare_app->call(_build_env()); 24 | 25 | is_deeply($res, [200, [], ['OK']]); 26 | }; 27 | 28 | subtest 'does nothing when unknown action' => sub { 29 | my $mw = _build_middleware(); 30 | 31 | my $res = $mw->prepare_app->call(_build_env(action => 'unknown')); 32 | 33 | is_deeply($res, [200, [], ['OK']]); 34 | }; 35 | 36 | subtest 'skips when no response' => sub { 37 | my $mw = _build_middleware(); 38 | 39 | my $res = $mw->prepare_app->call(_build_env(action => 'no_response')); 40 | 41 | is_deeply($res, [200, [], ['OK']]); 42 | }; 43 | 44 | subtest 'runs action with custom response' => sub { 45 | my $mw = _build_middleware(); 46 | 47 | my $res = $mw->prepare_app->call(_build_env(action => 'custom_response')); 48 | 49 | is_deeply $res => 50 | [200, ['Content-Type' => 'text/html'], ['Custom response!']]; 51 | }; 52 | 53 | sub _build_env { 54 | my (%params) = @_; 55 | 56 | my $env = 57 | {'tu.dispatched_request' => 58 | Tu::DispatchedRequest->new(action => delete $params{action})}; 59 | 60 | foreach my $key (keys %params) { 61 | if ($key =~ m/^tu/) { 62 | $env->{$key} = $params{$key}; 63 | } 64 | else { 65 | $env->{"tu.$key"} = $params{$key}; 66 | } 67 | } 68 | 69 | return $env; 70 | } 71 | 72 | sub _mock_services { 73 | my $services = Test::MonkeyMock->new; 74 | $services->mock(service => sub { }); 75 | } 76 | 77 | sub _build_middleware { 78 | my (%params) = @_; 79 | 80 | $params{services} ||= _mock_services(); 81 | 82 | return Tu::Middleware::ActionDispatcher->new( 83 | action_factory => Tu::ActionFactory->new(), 84 | app => sub { [200, [], ['OK']] }, 85 | %params 86 | ); 87 | } 88 | 89 | done_testing; 90 | -------------------------------------------------------------------------------- /t/middleware/action_dispatcher_t/CustomResponse.pm: -------------------------------------------------------------------------------- 1 | package CustomResponse; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use parent 'Tu::Action'; 7 | 8 | sub run { 9 | my $self = shift; 10 | 11 | my $res = $self->new_response(200); 12 | $res->body('Custom response!'); 13 | 14 | return $res; 15 | } 16 | 17 | 1; 18 | -------------------------------------------------------------------------------- /t/middleware/action_dispatcher_t/NoResponse.pm: -------------------------------------------------------------------------------- 1 | package NoResponse; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use parent 'Tu::Action'; 7 | 8 | sub run { 9 | my $self = shift; 10 | 11 | return; 12 | } 13 | 14 | 1; 15 | -------------------------------------------------------------------------------- /t/middleware/language_detection.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | use Test::Requires; 6 | use Test::Fatal; 7 | use Test::MonkeyMock; 8 | 9 | BEGIN { test_requires 'I18N::AcceptLanguage' } 10 | 11 | use Tu::Middleware::LanguageDetection; 12 | 13 | subtest 'throws when no language' => sub { 14 | like 15 | exception { _build_middleware(default_language => undef)->prepare_app }, 16 | qr/default_language required/; 17 | }; 18 | 19 | subtest 'throws when languages' => sub { 20 | like exception { 21 | _build_middleware(languages => undef)->prepare_app 22 | }, qr/languages required/; 23 | }; 24 | 25 | subtest 'detects from session' => sub { 26 | my $mw = _build_middleware(); 27 | 28 | my $env = { 29 | PATH_INFO => '', 30 | 'psgix.session' => {'tu.i18n.language' => 'ru'} 31 | }; 32 | 33 | $mw->prepare_app->call($env); 34 | 35 | is($env->{'tu.i18n.language'}, 'ru'); 36 | }; 37 | 38 | subtest 'does not detect from session when off' => sub { 39 | my $mw = _build_middleware(use_session => 0); 40 | 41 | my $env = { 42 | PATH_INFO => '', 43 | 'psgix.session' => {'tu.i18n.language' => 'ru'} 44 | }; 45 | 46 | $mw->prepare_app->call($env); 47 | 48 | is $env->{'tu.i18n.language'}, 'en'; 49 | }; 50 | 51 | subtest 'detects from custom cb' => sub { 52 | my $mw = _build_middleware( 53 | languages => [qw/ru en/], 54 | custom_cb => sub { 'en' } 55 | ); 56 | 57 | my $env = {PATH_INFO => '/ru/'}; 58 | 59 | $mw->prepare_app->call($env); 60 | 61 | is $env->{'tu.i18n.language'}, 'en'; 62 | }; 63 | 64 | subtest 'defaults when cannot detect from custom_cb' => sub { 65 | my $mw = _build_middleware( 66 | languages => [qw/ru en/], 67 | custom_cb => sub { } 68 | ); 69 | 70 | my $env = {PATH_INFO => ''}; 71 | 72 | $mw->prepare_app->call($env); 73 | 74 | is $env->{'tu.i18n.language'}, 'en'; 75 | }; 76 | 77 | subtest 'detects from path' => sub { 78 | my $mw = _build_middleware(); 79 | 80 | my $env = {PATH_INFO => '/ru/'}; 81 | 82 | $mw->prepare_app->call($env); 83 | 84 | is $env->{'tu.i18n.language'}, 'ru'; 85 | }; 86 | 87 | subtest 'does not detect from path when off' => sub { 88 | my $mw = _build_middleware(use_path => 0); 89 | 90 | my $env = {PATH_INFO => '/ru/'}; 91 | 92 | $mw->prepare_app->call($env); 93 | 94 | is $env->{'tu.i18n.language'}, 'en'; 95 | }; 96 | 97 | subtest 'modifies path' => sub { 98 | my $mw = _build_middleware(); 99 | 100 | my $env = {PATH_INFO => '/ru/hello'}; 101 | 102 | $mw->prepare_app->call($env); 103 | 104 | is $env->{PATH_INFO}, '/hello'; 105 | }; 106 | 107 | subtest 'detects from headers' => sub { 108 | my $mw = _build_middleware(); 109 | 110 | my $env = {PATH_INFO => '', HTTP_ACCEPT_LANGUAGE => 'ru'}; 111 | 112 | $mw->prepare_app->call($env); 113 | 114 | is $env->{'tu.i18n.language'}, 'ru'; 115 | }; 116 | 117 | subtest 'does not detect from headers when off' => sub { 118 | my $mw = _build_middleware(use_header => 0); 119 | 120 | my $env = {PATH_INFO => '', HTTP_ACCEPT_LANGUAGE => 'ru'}; 121 | 122 | $mw->prepare_app->call($env); 123 | 124 | is $env->{'tu.i18n.language'}, 'en'; 125 | }; 126 | 127 | subtest 'set_default_language_when_unknown_detected' => sub { 128 | my $mw = _build_middleware(); 129 | 130 | my $env = { 131 | PATH_INFO => '', 132 | 'psgix.session' => {'tu.i18n.language' => 'es'} 133 | }; 134 | 135 | $mw->prepare_app->call($env); 136 | 137 | is($env->{'tu.i18n.language'}, 'en'); 138 | }; 139 | 140 | subtest 'set_default_language_when_not_detected' => sub { 141 | my $mw = _build_middleware(); 142 | 143 | my $env = {PATH_INFO => ''}; 144 | 145 | $mw->prepare_app->call($env); 146 | 147 | is($env->{'tu.i18n.language'}, 'en'); 148 | }; 149 | 150 | subtest 'save_to_session' => sub { 151 | my $mw = _build_middleware(); 152 | 153 | my $env = {PATH_INFO => '/ru/'}; 154 | 155 | $mw->prepare_app->call($env); 156 | 157 | is($env->{'psgix.session'}->{'tu.i18n.language'}, 'ru'); 158 | }; 159 | 160 | sub _mock_services { 161 | my $services = Test::MonkeyMock->new; 162 | $services->mock(service => sub { {} }); 163 | return $services; 164 | } 165 | 166 | sub _build_middleware { 167 | my $services = _mock_services(); 168 | 169 | return Tu::Middleware::LanguageDetection->new( 170 | services => $services, 171 | app => sub { [200, [], ['OK']] }, 172 | default_language => 'en', 173 | languages => ['ru'], 174 | @_ 175 | ); 176 | } 177 | 178 | done_testing; 179 | -------------------------------------------------------------------------------- /t/middleware/multiligual_parser.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | use Test::Fatal; 6 | 7 | use Tu::Middleware::MultilingualParser; 8 | 9 | subtest 'throws when no default_language' => sub { 10 | like exception { _build_middleware(default_language => undef) }, 11 | qr/default_language required/; 12 | }; 13 | 14 | subtest 'throws when no languages' => sub { 15 | like exception { _build_middleware(languages => undef) }, 16 | qr/languages required/; 17 | }; 18 | 19 | subtest 'parses nothing when no content-type' => sub { 20 | my $mw = _build_middleware( 21 | headers => ['Content-Type' => undef], 22 | body => 'EnglishDeutsch' 23 | ); 24 | 25 | my $env = {'tu.language' => 'en'}; 26 | 27 | my $res = $mw->call($env); 28 | 29 | like $res->[2]->[0], qr//; 30 | }; 31 | 32 | subtest 'parses nothing when content-type not html' => sub { 33 | my $mw = _build_middleware( 34 | headers => ['Content-Type' => 'text/plain'], 35 | body => 'EnglishDeutsch' 36 | ); 37 | 38 | my $env = {'tu.language' => 'en'}; 39 | 40 | my $res = $mw->call($env); 41 | 42 | like $res->[2]->[0], qr//; 43 | }; 44 | 45 | subtest 'parses nothing when no language' => sub { 46 | my $mw = 47 | _build_middleware(body => 'EnglishDeutsch'); 48 | 49 | my $env = {}; 50 | 51 | my $res = $mw->call($env); 52 | 53 | like $res->[2]->[0], qr//; 54 | }; 55 | 56 | subtest 'parses tag' => sub { 57 | my $mw = 58 | _build_middleware(body => 'EnglishDeutsch'); 59 | 60 | my $env = {'tu.language' => 'en'}; 61 | 62 | my $res = $mw->call($env); 63 | 64 | is $res->[2]->[0], 'English'; 65 | is $res->[1]->[3], 7; 66 | }; 67 | 68 | subtest 'parses second tag' => sub { 69 | my $mw = 70 | _build_middleware(body => 'EnglishDeutsch'); 71 | 72 | my $env = {'tu.language' => 'de'}; 73 | 74 | my $res = $mw->call($env); 75 | 76 | is $res->[2]->[0], 'Deutsch'; 77 | is $res->[1]->[3], 7; 78 | }; 79 | 80 | sub _build_middleware { 81 | my (%params) = @_; 82 | 83 | my @headers = 84 | $params{headers} ? @{$params{headers}} : ('Content-Type' => 'text/html'); 85 | 86 | return Tu::Middleware::MultilingualParser->new( 87 | default_language => 'en', 88 | languages => [qw/en ru/], 89 | app => sub { [200, [@headers], [delete $params{body}]] }, 90 | %params 91 | ); 92 | } 93 | 94 | done_testing; 95 | -------------------------------------------------------------------------------- /t/middleware/request_dispatcher.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use utf8; 4 | 5 | use Test::More; 6 | use Test::Fatal; 7 | use Test::MonkeyMock; 8 | 9 | use Tu::Routes; 10 | use Tu::Dispatcher::Routes; 11 | use Tu::Middleware::RequestDispatcher; 12 | 13 | subtest 'throws 404 when nothing dispatched' => sub { 14 | my $mw = _build_middleware(); 15 | my $env = {REQUEST_URI => '/', REQUEST_METHOD => 'GET'}; 16 | 17 | isa_ok(exception { $mw->prepare_app->call($env) }, 'Tu::X::HTTP'); 18 | }; 19 | 20 | subtest 'throws 404 when path info is empty' => sub { 21 | my $mw = _build_middleware(); 22 | my $env = {REQUEST_URI => '', REQUEST_METHOD => 'GET'}; 23 | 24 | isa_ok(exception { $mw->prepare_app->call($env) }, 'Tu::X::HTTP'); 25 | }; 26 | 27 | subtest 'dispatches when path found' => sub { 28 | my $mw = _build_middleware(); 29 | my $env = {REQUEST_URI => '/foo', REQUEST_METHOD => 'GET'}; 30 | 31 | $mw->prepare_app->call($env); 32 | 33 | ok $env->{'tu.dispatched_request'}; 34 | }; 35 | 36 | subtest 'dispatches when path found removing query string' => sub { 37 | my $mw = _build_middleware(); 38 | my $env = {REQUEST_URI => '/foo?foo=bar', REQUEST_METHOD => 'GET'}; 39 | 40 | $mw->prepare_app->call($env); 41 | 42 | ok $env->{'tu.dispatched_request'}; 43 | }; 44 | 45 | subtest 'does nothing when method is wrong' => sub { 46 | my $mw = _build_middleware(); 47 | my $env = {REQUEST_METHOD => 'GET', REQUEST_URI => '/only_post'}; 48 | 49 | isa_ok(exception { $mw->prepare_app->call($env) }, 'Tu::X::HTTP'); 50 | }; 51 | 52 | subtest 'dispatches when path and method are found' => sub { 53 | my $mw = _build_middleware(); 54 | my $env = {REQUEST_METHOD => 'POST', REQUEST_URI => '/only_post'}; 55 | 56 | $mw->prepare_app->call($env); 57 | 58 | ok $env->{'tu.dispatched_request'}; 59 | }; 60 | 61 | subtest 'dispatches utf path' => sub { 62 | my $mw = _build_middleware(); 63 | my $env = { 64 | REQUEST_METHOD => 'GET', 65 | REQUEST_URI => '/unicode/' . Encode::encode('UTF-8', 'привет') 66 | }; 67 | 68 | $mw->prepare_app->call($env); 69 | 70 | my $dr = $env->{'tu.dispatched_request'}; 71 | is $dr->captures->{name}, 'привет'; 72 | }; 73 | 74 | subtest 'dispatches without encoding' => sub { 75 | my $mw = _build_middleware(encoding => 'raw'); 76 | my $env = { 77 | REQUEST_METHOD => 'GET', 78 | REQUEST_URI => '/unicode/' . Encode::encode('UTF-8', 'привет') 79 | }; 80 | 81 | $mw->prepare_app->call($env); 82 | 83 | my $dr = $env->{'tu.dispatched_request'}; 84 | is $dr->captures->{name}, Encode::encode('UTF-8', 'привет'); 85 | }; 86 | 87 | subtest 'loads dispatcher from service container' => sub { 88 | my $dispatcher = Tu::Dispatcher::Routes->new(routes => _build_routes()); 89 | my $services = Test::MonkeyMock->new; 90 | $services->mock(service => sub { $dispatcher }); 91 | 92 | my $mw = _build_middleware(dispatcher => undef, services => $services); 93 | my $env = { 94 | REQUEST_METHOD => 'GET', 95 | REQUEST_URI => '/foo' 96 | }; 97 | 98 | $mw->prepare_app->call($env); 99 | 100 | ok $env->{'tu.dispatched_request'}; 101 | }; 102 | 103 | subtest 'throws when no dispatcher' => sub { 104 | my $services = Test::MonkeyMock->new; 105 | $services->mock(service => sub { }); 106 | 107 | like exception { 108 | _build_middleware(dispatcher => undef, services => $services) 109 | ->prepare_app 110 | }, qr/dispatcher required/; 111 | }; 112 | 113 | sub _build_routes { 114 | my $routes = Tu::Routes->new; 115 | $routes->add_route('/foo', defaults => {action => 'foo'}); 116 | $routes->add_route( 117 | '/only_post', 118 | defaults => {action => 'bar'}, 119 | method => 'post' 120 | ); 121 | $routes->add_route('/unicode/:name', name => 'bar'); 122 | return $routes; 123 | } 124 | 125 | sub _build_middleware { 126 | my $routes = _build_routes(); 127 | return Tu::Middleware::RequestDispatcher->new( 128 | app => sub { [200, [], ['OK']] }, 129 | dispatcher => Tu::Dispatcher::Routes->new(routes => $routes), 130 | @_ 131 | ); 132 | } 133 | 134 | done_testing; 135 | -------------------------------------------------------------------------------- /t/middleware/serializer_json.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | use Test::Fatal; 6 | use Test::Requires; 7 | 8 | BEGIN { test_requires 'JSON' } 9 | 10 | use Tu::Request; 11 | use Tu::Middleware::SerializerJSON; 12 | 13 | subtest 'decode_JSON' => sub { 14 | my $mw = _build_middleware(); 15 | 16 | my $json = '{"foo":"bar"}'; 17 | open my $fh, '<', \$json; 18 | 19 | my $env = { 20 | REQUEST_METHOD => 'POST', 21 | CONTENT_TYPE => 'application/json', 22 | CONTENT_LENGTH => length($json), 23 | 'psgi.input' => $fh 24 | }; 25 | 26 | $mw->call($env); 27 | 28 | my $req = Tu::Request->new($env); 29 | 30 | is_deeply($env->{'tu.serializer.json'}, {foo => 'bar'}); 31 | }; 32 | 33 | subtest 'return_when_cannot_decode_JSON' => sub { 34 | my $mw = _build_middleware(); 35 | 36 | my $json = '{"foo""bar"}'; 37 | open my $fh, '<', \$json; 38 | 39 | my $env = { 40 | REQUEST_METHOD => 'POST', 41 | CONTENT_TYPE => 'application/json', 42 | CONTENT_LENGTH => length($json), 43 | 'psgi.input' => $fh 44 | }; 45 | 46 | my $res = $mw->call($env); 47 | 48 | is_deeply( 49 | $res, 50 | [ 51 | 400, 52 | ['Content-Type' => 'application/json'], 53 | ['{"message":"Invalid JSON"}'] 54 | ] 55 | ); 56 | }; 57 | 58 | subtest 'catch_internal_exception' => sub { 59 | my $mw = _build_middleware(app => sub { die 'error' }); 60 | 61 | my $env = {REQUEST_METHOD => 'GET'}; 62 | 63 | my $res = $mw->call($env); 64 | 65 | is_deeply( 66 | $res, 67 | [ 68 | 500, 69 | ['Content-Type' => 'application/json'], 70 | ['{"message":"Internal system error"}'] 71 | ] 72 | ); 73 | }; 74 | 75 | subtest 'encode_JSON' => sub { 76 | my $mw = _build_middleware(); 77 | 78 | my $env = {REQUEST_METHOD => 'GET'}; 79 | 80 | my $res = $mw->call($env); 81 | 82 | is_deeply($res, 83 | [200, ['Content-Type' => 'application/json'], ['{"foo":"bar"}']]); 84 | }; 85 | 86 | subtest 'not_encode_JSON_when_content_type' => sub { 87 | my $mw = _build_middleware( 88 | app => sub { [200, ['Content-Type' => 'text/plain'], ['hi']] }); 89 | 90 | my $env = {REQUEST_METHOD => 'GET'}; 91 | 92 | my $res = $mw->call($env); 93 | 94 | is_deeply($res, [200, ['Content-Type' => 'text/plain'], ['hi']]); 95 | }; 96 | 97 | sub _build_middleware { 98 | return Tu::Middleware::SerializerJSON->new( 99 | app => sub { [200, [], [{foo => 'bar'}]] }, 100 | @_ 101 | ); 102 | } 103 | 104 | done_testing; 105 | -------------------------------------------------------------------------------- /t/middleware/session_cookie.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | use Test::Requires; 6 | use Test::MonkeyMock; 7 | 8 | BEGIN { test_requires 'Plack::Middleware::Session::Cookie' } 9 | 10 | use Tu::Middleware::Session::Cookie; 11 | 12 | subtest 'pass session config' => sub { 13 | my $services = Test::MonkeyMock->new; 14 | $services->mock(service => sub { {session => {secret => '123'}} }); 15 | my $mw = _build_middleware(services => $services); 16 | 17 | is $mw->secret, '123'; 18 | }; 19 | 20 | sub _build_middleware { Tu::Middleware::Session::Cookie->new(@_) } 21 | 22 | done_testing; 23 | -------------------------------------------------------------------------------- /t/middleware/static.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | use Test::MonkeyMock; 6 | 7 | use Tu::Home; 8 | use Tu::Middleware::Static; 9 | 10 | subtest 'discovers static files automatically' => sub { 11 | my $mw = _build_middleware(); 12 | 13 | my $res = $mw->call( 14 | { 15 | REQUEST_METHOD => 'GET', 16 | SCRIPT_NAME => '/', 17 | PATH_INFO => '/static/file.txt' 18 | } 19 | ); 20 | 21 | my $fh = $res->[2]; 22 | is <$fh>, "hello\n"; 23 | }; 24 | 25 | sub _build_home { 26 | Tu::Home->new(path => 't/middleware/static_t'); 27 | } 28 | 29 | sub _mock_services { 30 | my $services = Test::MonkeyMock->new; 31 | $services->mock(service => sub { _build_home() }); 32 | } 33 | 34 | sub _build_middleware { 35 | my (%params) = @_; 36 | 37 | $params{services} ||= _mock_services(); 38 | 39 | return Tu::Middleware::Static->new( 40 | app => sub { [200, [], ['OK']] }, 41 | %params 42 | ); 43 | } 44 | 45 | done_testing; 46 | -------------------------------------------------------------------------------- /t/middleware/static_t/public/static/file.txt: -------------------------------------------------------------------------------- 1 | hello 2 | -------------------------------------------------------------------------------- /t/middleware/user.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | use Test::Fatal; 6 | 7 | use Tu::Middleware::User; 8 | 9 | subtest 'sets anonymous role when no user' => sub { 10 | my $mw = _build_middleware(); 11 | 12 | my $env = {'psgix.session' => {}}; 13 | 14 | my $res = $mw->call($env); 15 | 16 | is $env->{'tu.user_role'}, 'anonymous'; 17 | }; 18 | 19 | subtest 'sets anonymous role when session but no user' => sub { 20 | my $mw = _build_middleware(); 21 | 22 | my $env = {'psgix.session' => {foo => 'bar'}}; 23 | 24 | my $res = $mw->call($env); 25 | 26 | is $env->{'tu.user_role'}, 'anonymous'; 27 | }; 28 | 29 | subtest 'set anonymous when user not found' => sub { 30 | my $mw = _build_middleware(); 31 | 32 | my $env = {'psgix.session' => {id => 5}}; 33 | 34 | my $res = $mw->call($env); 35 | 36 | is $env->{'tu.user_role'}, 'anonymous'; 37 | }; 38 | 39 | subtest 'sets user and role' => sub { 40 | my $mw = _build_middleware(); 41 | 42 | my $env = {'psgix.session' => {id => 1}, 'tu.displayer.vars' => {}}; 43 | 44 | my $res = $mw->call($env); 45 | 46 | is $env->{'tu.user_role'}, 'user'; 47 | is $env->{'tu.user'}->role, 'user'; 48 | }; 49 | 50 | subtest 'finalizes session' => sub { 51 | my $mw = _build_middleware(); 52 | 53 | my $env = {'psgix.session' => {id => 1}, 'tu.displayer.vars' => {}}; 54 | 55 | my $res = $mw->call($env); 56 | 57 | is_deeply $env->{'psgix.session'}, {id => 1, foo => 'bar'}; 58 | }; 59 | 60 | subtest 'not registers displayer var when user not found' => sub { 61 | my $mw = _build_middleware(); 62 | 63 | my $env = {'psgix.session' => {}}; 64 | 65 | my $res = $mw->call($env); 66 | 67 | ok !$env->{'tu.displayer.vars'}->{user}; 68 | }; 69 | 70 | sub _build_middleware { 71 | return Tu::Middleware::User->new( 72 | app => sub { [200, [], ['OK']] }, 73 | user_session_class => 'TestUserLoader' 74 | ); 75 | } 76 | 77 | done_testing; 78 | 79 | package TestUserLoader; 80 | 81 | sub new { 82 | my $class = shift; 83 | my (%params) = @_; 84 | 85 | my $self = {}; 86 | bless $self, $class; 87 | 88 | $self->{env} = $params{env}; 89 | 90 | return $self; 91 | } 92 | 93 | sub env { shift->{env} } 94 | 95 | sub scope { 96 | my $self = shift; 97 | 98 | return Tu::Scope->new($self->env); 99 | } 100 | 101 | sub role { 'user' } 102 | 103 | sub load { 104 | my $self = shift; 105 | 106 | my $env = $self->env; 107 | my $options = $env->{'psgix.session'}; 108 | 109 | return $self if $options->{id} && $options->{id} == 1; 110 | return; 111 | } 112 | 113 | sub finalize { 114 | my $self = shift; 115 | 116 | my $env = $self->env; 117 | $env->{'psgix.session'}->{foo} = 'bar'; 118 | } 119 | 120 | sub to_hash { {} } 121 | -------------------------------------------------------------------------------- /t/middleware/view_displayer.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use utf8; 4 | 5 | use Test::More; 6 | use Test::MonkeyMock; 7 | use Test::Fatal; 8 | 9 | use Encode (); 10 | use Tu::Middleware::ViewDisplayer; 11 | 12 | subtest 'throws when no displayer' => sub { 13 | my $services = Test::MonkeyMock->new; 14 | $services->mock(service => sub { }); 15 | 16 | like exception { 17 | _build_middleware(displayer => undef, services => $services) 18 | ->prepare_app 19 | }, qr/displayer required/; 20 | }; 21 | 22 | subtest 'gets displayer from services' => sub { 23 | my $displayer = _mock_displayer(); 24 | my $services = Test::MonkeyMock->new; 25 | $services->mock(service => sub { $displayer }); 26 | 27 | ok ! 28 | exception { _build_middleware(displayer => undef, services => $services) }; 29 | }; 30 | 31 | subtest 'renders template' => sub { 32 | my $mw = _build_middleware(content => 'there'); 33 | 34 | my $env = _build_env( 35 | 'tu.displayer.template' => 'template.caml', 36 | 'tu.displayer.vars' => {hello => 'there'} 37 | ); 38 | 39 | my $res = $mw->prepare_app->call($env); 40 | 41 | is_deeply $res, 42 | [ 43 | 200, 44 | ['Content-Length' => 5, 'Content-Type' => 'text/html; charset=utf-8'], 45 | ['there'] 46 | ]; 47 | }; 48 | 49 | subtest 'render template with utf8' => sub { 50 | my $mw = _build_middleware(content => 'привет'); 51 | 52 | my $env = _build_env('tu.displayer.template' => 'template-utf8.caml',); 53 | 54 | my $res = $mw->prepare_app->call($env); 55 | 56 | is_deeply $res, 57 | [ 58 | 200, 59 | [ 60 | 'Content-Length' => 12, 61 | 'Content-Type' => 'text/html; charset=utf-8' 62 | ], 63 | [Encode::encode_utf8('привет')] 64 | ]; 65 | }; 66 | 67 | subtest 'does no encode when encoding undefined' => sub { 68 | my $mw = _build_middleware(encoding => 'raw', content => 'привет'); 69 | 70 | my $env = _build_env('tu.displayer.template' => 'template-utf8.caml',); 71 | 72 | my $res = $mw->prepare_app->call($env); 73 | 74 | is_deeply $res, 75 | [ 76 | 200, 77 | [ 78 | 'Content-Length' => 6, 79 | 'Content-Type' => 'text/html' 80 | ], 81 | ['привет'] 82 | ]; 83 | }; 84 | 85 | subtest 'calls displayer with correct params' => sub { 86 | my $displayer = _mock_displayer(); 87 | my $mw = _build_middleware(displayer => $displayer); 88 | 89 | my $env = _build_env( 90 | 'tu.displayer.template' => 'custom_template', 91 | 'tu.displayer.layout' => 'custom_layout', 92 | 'tu.displayer.vars' => {foo => 'bar'} 93 | ); 94 | 95 | $mw->prepare_app->call($env); 96 | 97 | my ($template, %args) = $displayer->mocked_call_args('render'); 98 | 99 | is $template, 'custom_template'; 100 | is_deeply \%args, 101 | { 102 | layout => 'custom_layout', 103 | vars => {foo => 'bar'} 104 | }; 105 | }; 106 | 107 | subtest 'gets template name from dispatched request' => sub { 108 | my $dr = Test::MonkeyMock->new; 109 | $dr->mock(action => sub { 'from_action' }); 110 | 111 | my $displayer = _mock_displayer(); 112 | my $mw = _build_middleware(displayer => $displayer); 113 | 114 | my $env = _build_env('tu.dispatched_request' => $dr,); 115 | 116 | $mw->prepare_app->call($env); 117 | 118 | my ($template) = $displayer->mocked_call_args('render'); 119 | 120 | is $template, 'from_action'; 121 | }; 122 | 123 | subtest 'does nothing when dispatched_request has no action' => sub { 124 | my $dr = Test::MonkeyMock->new; 125 | $dr->mock(action => sub { '' }); 126 | 127 | my $mw = _build_middleware(); 128 | 129 | my $env = _build_env('tu.dispatched_request' => $dr,); 130 | 131 | my $res = $mw->prepare_app->call($env); 132 | 133 | is_deeply $res, [200, [], ['OK']]; 134 | }; 135 | 136 | sub _build_env { 137 | my (%params) = @_; 138 | 139 | return {'tu.displayer.vars' => {}, %params}; 140 | } 141 | 142 | sub _mock_displayer { 143 | my (%params) = @_; 144 | 145 | my $displayer = Test::MonkeyMock->new; 146 | $displayer->mock(render => sub { $params{content} }); 147 | } 148 | 149 | sub _build_middleware { 150 | my (%params) = @_; 151 | 152 | my $displayer = $params{displayer} || _mock_displayer(%params); 153 | 154 | return Tu::Middleware::ViewDisplayer->new( 155 | app => sub { [200, [], ['OK']] }, 156 | displayer => $displayer, 157 | @_ 158 | ); 159 | } 160 | 161 | done_testing; 162 | -------------------------------------------------------------------------------- /t/observable_mixin.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | 6 | subtest 'notifies observers' => sub { 7 | my $observable = TestObservableMixin::Foo->new; 8 | 9 | my $observer = TestObservableMixin::Observer->new; 10 | $observable->observe($observer); 11 | 12 | my $bar = {}; 13 | $observable->foo($bar); 14 | 15 | is_deeply $bar, {bar => 2}; 16 | }; 17 | 18 | done_testing; 19 | 20 | package TestObservableMixin::Foo; 21 | use Tu::ObservableMixin qw(observe notify); 22 | 23 | sub new { 24 | my $class = shift; 25 | 26 | my $self = {}; 27 | bless $self, $class; 28 | 29 | return $self; 30 | } 31 | 32 | sub foo { 33 | my $self = shift; 34 | my ($foo) = @_; 35 | 36 | $foo->{bar}++; 37 | 38 | $self->notify('AFTER:foo', $foo); 39 | } 40 | 41 | package TestObservableMixin::Observer; 42 | use parent 'Tu::Observer::Base'; 43 | 44 | sub _init { 45 | my $self = shift; 46 | 47 | $self->_register( 48 | 'AFTER:foo' => sub { 49 | my $self = shift; 50 | my ($foo) = @_; 51 | 52 | $foo->{bar}++; 53 | } 54 | ); 55 | } 56 | -------------------------------------------------------------------------------- /t/observer/base.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | 6 | use Tu::Observer::Base; 7 | 8 | subtest 'registers events' => sub { 9 | my $observer = _build_observer(); 10 | 11 | my $cb = $observer->events->{foo}; 12 | 13 | is $cb->(), 'foo'; 14 | }; 15 | 16 | sub _build_observer { 17 | return TestObserverBase::Foo->new(@_); 18 | } 19 | 20 | done_testing; 21 | 22 | package TestObserverBase::Foo; 23 | use base 'Tu::Observer::Base'; 24 | 25 | sub _init { 26 | my $self = shift; 27 | 28 | $self->_register(foo => sub { 'foo' }); 29 | } 30 | -------------------------------------------------------------------------------- /t/request.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use utf8; 4 | 5 | use Test::More; 6 | use Test::Fatal; 7 | 8 | use Tu::Request; 9 | 10 | subtest 'should_handle_utf_in_query_parameters' => sub { 11 | my $req = _build_request({QUERY_STRING => '%E2%99%A5=%E2%99%A5'}, 12 | encoding => 'UTF-8'); 13 | 14 | is($req->param('♥'), '♥'); 15 | }; 16 | 17 | subtest 'should_handle_utf_in_multi_query_parameters' => sub { 18 | my $req = 19 | _build_request({QUERY_STRING => '%E2%99%A5=%E2%99%A5&%E2%99%A5=b'}, 20 | encoding => 'UTF-8'); 21 | 22 | my @params = $req->param('♥'); 23 | 24 | is_deeply(\@params, ['♥', 'b']); 25 | }; 26 | 27 | subtest 'should_handle_utf_in_post_parameters' => sub { 28 | my $bytes = Encode::encode('UTF-8', '♥=♥'); 29 | open my $fh, '<', \$bytes; 30 | 31 | my $req = _build_request( 32 | { 33 | REQUEST_METHOD => 'POST', 34 | CONTENT_TYPE => 'application/x-www-form-urlencoded', 35 | CONTENT_LENGTH => 7, 36 | 'psgi.input' => $fh 37 | }, 38 | encoding => 'UTF-8' 39 | ); 40 | 41 | is($req->param('♥'), '♥'); 42 | }; 43 | 44 | subtest 'should_handle_utf_in_multi_post_parameters' => sub { 45 | my $bytes = Encode::encode('UTF-8', '♥=♥&♥=b'); 46 | open my $fh, '<', \$bytes; 47 | 48 | my $req = _build_request( 49 | { 50 | REQUEST_METHOD => 'POST', 51 | CONTENT_TYPE => 'application/x-www-form-urlencoded', 52 | CONTENT_LENGTH => 13, 53 | 'psgi.input' => $fh 54 | }, 55 | encoding => 'UTF-8' 56 | ); 57 | 58 | my @params = $req->param('♥'); 59 | 60 | is_deeply(\@params, ['♥', 'b']); 61 | }; 62 | 63 | sub _build_request { 64 | return Tu::Request->new(@_); 65 | } 66 | 67 | done_testing; 68 | -------------------------------------------------------------------------------- /t/response.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use utf8; 4 | 5 | use Test::More; 6 | use Test::Fatal; 7 | 8 | use Encode (); 9 | 10 | use Tu::Response; 11 | 12 | subtest 'encode_body' => sub { 13 | my $res = _build_response(200); 14 | 15 | $res->body('привет'); 16 | 17 | is_deeply( 18 | $res->finalize, 19 | [ 20 | 200, 21 | ['Content-Type' => 'text/html'], 22 | [Encode::encode('UTF-8', 'привет')] 23 | ] 24 | ); 25 | }; 26 | 27 | subtest 'set default content type' => sub { 28 | my $res = _build_response(200); 29 | 30 | is_deeply($res->finalize, [200, ['Content-Type' => 'text/html'], []]); 31 | }; 32 | 33 | subtest 'not set default content type when present' => sub { 34 | my $res = _build_response(200); 35 | $res->content_type('text/plain'); 36 | 37 | is_deeply($res->finalize, [200, ['Content-Type' => 'text/plain'], []]); 38 | }; 39 | 40 | sub _build_response { Tu::Response->new(@_) } 41 | 42 | done_testing; 43 | -------------------------------------------------------------------------------- /t/routes/from_config.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | 6 | use Tu::Routes::FromConfig; 7 | 8 | subtest 'add_routes' => sub { 9 | my $routes = _build_routes()->load('t/routes/from_config_t/routes.yml'); 10 | 11 | ok $routes->match('/'); 12 | }; 13 | 14 | subtest 'no_route_when_config_empty' => sub { 15 | my $routes = _build_routes()->load('t/routes/from_config_t/empty.yml'); 16 | 17 | ok !$routes->match('/'); 18 | }; 19 | 20 | sub _build_routes { Tu::Routes::FromConfig->new(@_) } 21 | 22 | done_testing; 23 | -------------------------------------------------------------------------------- /t/routes/from_config_t/bad.yml: -------------------------------------------------------------------------------- 1 | bad file 2 | -------------------------------------------------------------------------------- /t/routes/from_config_t/empty.yml: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vti/tu/ee198e2d72d948c0beb2e53410c967fc50fa4206/t/routes/from_config_t/empty.yml -------------------------------------------------------------------------------- /t/routes/from_config_t/routes.yml: -------------------------------------------------------------------------------- 1 | --- 2 | - route: / 3 | name: index 4 | - route: /login 5 | name: login 6 | -------------------------------------------------------------------------------- /t/scope.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | use Test::Fatal; 6 | 7 | use Tu::Scope; 8 | 9 | subtest 'throws when no env' => sub { 10 | like exception { Tu::Scope->new }, qr/\$env required/; 11 | }; 12 | 13 | subtest 'returns true if key exists' => sub { 14 | my $scope = _build_scope(); 15 | 16 | $scope->set('dispatched_request' => 'bar'); 17 | 18 | ok $scope->exists('dispatched_request'); 19 | }; 20 | 21 | subtest 'returns false when key does not exist' => sub { 22 | my $scope = _build_scope(); 23 | 24 | ok !$scope->exists('dispatched_request'); 25 | }; 26 | 27 | subtest 'sets value' => sub { 28 | my $scope = _build_scope(); 29 | 30 | $scope->set('dispatched_request' => 'bar'); 31 | 32 | is $scope->dispatched_request, 'bar'; 33 | }; 34 | 35 | subtest 'returns set value' => sub { 36 | my $scope = _build_scope(); 37 | 38 | is $scope->set('dispatched_request' => 'bar'), 'bar'; 39 | }; 40 | 41 | subtest 'sets multi values' => sub { 42 | my $scope = _build_scope(); 43 | 44 | $scope->set('displayer.vars' => {foo => 'bar'}); 45 | $scope->set('displayer.layout' => 'layout.tpl'); 46 | $scope->set('displayer.template' => 'template'); 47 | 48 | is_deeply $scope->displayer->vars, {foo => 'bar'}; 49 | is $scope->displayer->layout, 'layout.tpl'; 50 | is $scope->displayer->template, 'template'; 51 | }; 52 | 53 | subtest 'works with existing env' => sub { 54 | my $scope = _build_scope(env => {'tu.displayer.vars' => {foo => 'bar'}}); 55 | 56 | is_deeply $scope->displayer->vars, {foo => 'bar'}; 57 | }; 58 | 59 | subtest 'throw on unknown key' => sub { 60 | my $scope = _build_scope(); 61 | 62 | like exception { $scope->get('foo') }, qr/unknown key 'foo'/; 63 | }; 64 | 65 | sub _build_scope { 66 | my (%params) = @_; 67 | 68 | my $env = $params{env} || {}; 69 | Tu::Scope->new($env); 70 | } 71 | 72 | done_testing; 73 | -------------------------------------------------------------------------------- /t/service_container.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | use Test::Fatal; 6 | 7 | use Scalar::Util qw(blessed); 8 | use Tu::ServiceContainer; 9 | 10 | subtest 'throws on getting unknown service' => sub { 11 | my $c = _build_container(); 12 | 13 | like exception { $c->service('foo') }, qr/unknown service 'foo'/; 14 | }; 15 | 16 | subtest 'throws on registering already registered service' => sub { 17 | my $c = _build_container(); 18 | 19 | $c->register(foo => 'bar'); 20 | 21 | like exception { $c->register(foo => 'baz') }, 22 | qr/service 'foo' already registered/; 23 | }; 24 | 25 | subtest 'registers scalar service' => sub { 26 | my $c = _build_container(); 27 | 28 | $c->register(foo => 'bar'); 29 | 30 | is $c->service('foo'), 'bar'; 31 | }; 32 | 33 | subtest 'registers instance service' => sub { 34 | my $c = _build_container(); 35 | 36 | $c->register(foo => FooInstance->new); 37 | 38 | isa_ok($c->service('foo'), 'FooInstance'); 39 | }; 40 | 41 | subtest 'registers service via sub' => sub { 42 | my $c = _build_container(); 43 | 44 | $c->register(foo => sub { 'foo' }); 45 | 46 | is($c->service('foo'), 'foo'); 47 | }; 48 | 49 | subtest 'registers service as a class' => sub { 50 | my $c = _build_container(); 51 | 52 | $c->register(foo => 'FooInstance', new => 1); 53 | 54 | ok blessed $c->service('foo'); 55 | isa_ok($c->service('foo'), 'FooInstance'); 56 | }; 57 | 58 | subtest 'registers service as a class with deps' => sub { 59 | my $c = _build_container(); 60 | 61 | $c->register(bar => 'bar'); 62 | $c->register(foo => 'FooInstance', new => [qw/bar/]); 63 | 64 | is $c->service('foo')->{bar}, 'bar'; 65 | }; 66 | 67 | subtest 'creates instance with custom construction' => sub { 68 | my $c = _build_container(); 69 | 70 | $c->register(bar => 'bar'); 71 | $c->register( 72 | foo => 'FooInstance', 73 | new => sub { 74 | my ($class, $services) = @_; 75 | 76 | $class->new(custom => $services->service('bar')); 77 | } 78 | ); 79 | 80 | is $c->service('foo')->{custom}, 'bar'; 81 | }; 82 | 83 | subtest 'registers group of services from class name' => sub { 84 | my $c = _build_container(); 85 | 86 | $c->register_group('+TestServiceContainer::Group'); 87 | 88 | is $c->service('foo'), 'bar'; 89 | }; 90 | 91 | subtest 'registers group of services from instance' => sub { 92 | my $c = _build_container(); 93 | 94 | $c->register_group(TestServiceContainer::Group->new); 95 | 96 | is $c->service('foo'), 'bar'; 97 | }; 98 | 99 | sub _build_container { Tu::ServiceContainer->new(@_) } 100 | 101 | done_testing; 102 | 103 | package FooInstance; 104 | 105 | sub new { 106 | my $class = shift; 107 | 108 | my $self = {@_}; 109 | bless $self, $class; 110 | 111 | return $self; 112 | } 113 | 114 | package TestServiceContainer::Group; 115 | 116 | sub new { 117 | my $class = shift; 118 | 119 | my $self = {}; 120 | bless $self, $class; 121 | 122 | return $self; 123 | } 124 | 125 | sub register { 126 | my $self = shift; 127 | my ($services, %params) = @_; 128 | 129 | $services->register(foo => 'bar'); 130 | } 131 | 132 | 1; 133 | -------------------------------------------------------------------------------- /t/tidyall.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::Requires; 5 | 6 | BEGIN { test_requires 'Test::Code::TidyAll' } 7 | 8 | use Test::Code::TidyAll; 9 | 10 | tidyall_ok(); 11 | -------------------------------------------------------------------------------- /t/validator/compare.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | 6 | use Tu::Validator::Compare; 7 | 8 | subtest 'returns true when all same' => sub { 9 | my $rule = _build_rule(); 10 | 11 | ok $rule->is_valid(['foo', 'foo', 'foo']); 12 | }; 13 | 14 | subtest 'returns false when not same' => sub { 15 | my $rule = _build_rule(); 16 | 17 | ok !$rule->is_valid(['foo', 'foo', 'bar']); 18 | }; 19 | 20 | sub _build_rule { 21 | return Tu::Validator::Compare->new(@_); 22 | } 23 | 24 | done_testing; 25 | -------------------------------------------------------------------------------- /t/validator/in.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | 6 | use Tu::Validator::In; 7 | 8 | subtest 'returns true when in' => sub { 9 | my $rule = _build_rule(); 10 | 11 | ok $rule->is_valid('foo', [qw/foo bar/]); 12 | }; 13 | 14 | subtest 'returns false when not in' => sub { 15 | my $rule = _build_rule(); 16 | 17 | ok !$rule->is_valid('baz', [qw/foo bar/]); 18 | }; 19 | 20 | sub _build_rule { 21 | return Tu::Validator::In->new(@_); 22 | } 23 | 24 | done_testing; 25 | -------------------------------------------------------------------------------- /t/validator/regexp.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | 6 | use Tu::Validator::Regexp; 7 | 8 | subtest 'returns true when matches' => sub { 9 | my $rule = _build_rule(); 10 | 11 | ok $rule->is_valid(1, qr/^\d+$/); 12 | }; 13 | 14 | subtest 'returns false when not matches' => sub { 15 | my $rule = _build_rule(); 16 | 17 | ok !$rule->is_valid('a1c', qr/^\d+$/); 18 | }; 19 | 20 | sub _build_rule { 21 | return Tu::Validator::Regexp->new(@_); 22 | } 23 | 24 | done_testing; 25 | -------------------------------------------------------------------------------- /t/validator_result.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | 6 | use Tu::ValidatorResult; 7 | 8 | subtest 'returns true when no errors' => sub { 9 | my $result = _build_result(); 10 | 11 | ok $result->is_success; 12 | }; 13 | 14 | subtest 'returns false when errors' => sub { 15 | my $result = _build_result(errors => {foo => 'REQUIRED'}); 16 | 17 | ok !$result->is_success; 18 | }; 19 | 20 | subtest 'returns errors' => sub { 21 | my $result = _build_result(errors => {foo => 'REQUIRED'}); 22 | 23 | is_deeply $result->errors, {foo => 'REQUIRED'}; 24 | }; 25 | 26 | subtest 'returns errors added manually' => sub { 27 | my $result = _build_result(); 28 | 29 | $result->add_error(foo => 'REQUIRED'); 30 | 31 | is_deeply $result->errors, {foo => 'REQUIRED'}; 32 | }; 33 | 34 | subtest 'returns mapped errors added manually' => sub { 35 | my $result = _build_result(messages => {REQUIRED => 'Required'}); 36 | 37 | $result->add_error(foo => 'REQUIRED'); 38 | 39 | is_deeply $result->errors, {foo => 'Required'}; 40 | }; 41 | 42 | subtest 'returns errors mapped' => sub { 43 | my $result = _build_result( 44 | messages => 45 | {'foo.REQUIRED' => 'Foo is required', REQUIRED => 'Required'}, 46 | errors => {foo => 'REQUIRED', bar => 'REQUIRED'} 47 | ); 48 | 49 | is_deeply $result->errors, {foo => 'Foo is required', bar => 'Required'}; 50 | }; 51 | 52 | subtest 'returns all_params' => sub { 53 | my $result = _build_result(params => {foo => 'bar'}); 54 | 55 | is_deeply $result->all_params, {foo => 'bar'}; 56 | }; 57 | 58 | subtest 'returns validated_params' => sub { 59 | my $result = _build_result(validated_params => {foo => 'bar'}); 60 | 61 | is_deeply $result->validated_params, {foo => 'bar'}; 62 | }; 63 | 64 | sub _build_result { Tu::ValidatorResult->new(@_) } 65 | 66 | done_testing; 67 | -------------------------------------------------------------------------------- /t/x.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | use Test::Fatal; 6 | 7 | use Tu::X::Base; 8 | 9 | subtest 'stringifies' => sub { 10 | my $e = exception { Tu::X::Base->throw('hi there') }; 11 | 12 | is $e, 'hi there at t/x.t line 10.'; 13 | }; 14 | 15 | subtest 'returns message' => sub { 16 | my $e = exception { Tu::X::Base->throw('hi there') }; 17 | 18 | is $e->message, 'hi there'; 19 | }; 20 | 21 | subtest 'returns exception class when no message was passed' => sub { 22 | my $e = exception { Tu::X::Base->throw }; 23 | 24 | like $e, qr/Exception: Tu::X::Base /; 25 | }; 26 | 27 | done_testing; 28 | -------------------------------------------------------------------------------- /t/x_http.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | use Test::Fatal; 6 | 7 | use Tu::X::HTTP; 8 | 9 | subtest 'throws correct isa' => sub { 10 | isa_ok( 11 | exception { 12 | Tu::X::HTTP->throw('error', code => '500'); 13 | }, 14 | 'Tu::X::HTTP' 15 | ); 16 | }; 17 | 18 | subtest 'returns code' => sub { 19 | my $e = exception { 20 | Tu::X::HTTP->throw('foo', code => '400'); 21 | }; 22 | 23 | is $e->code, 400; 24 | }; 25 | 26 | subtest 'returns default code' => sub { 27 | my $e = exception { 28 | Tu::X::HTTP->throw('foo'); 29 | }; 30 | 31 | is $e->code, 500; 32 | }; 33 | 34 | subtest 'supports stringification via as_string' => sub { 35 | my $e = exception { 36 | Tu::X::HTTP->throw('foo'); 37 | }; 38 | 39 | like $e->as_string, qr/foo/; 40 | }; 41 | 42 | done_testing; 43 | --------------------------------------------------------------------------------