File Coverage

blib/lib/YATT/Lite/WebMVC0/Partial/LangSwitch.pm
Criterion Covered Total %
statement 15 45 33.3
branch 0 18 0.0
condition 0 20 0.0
subroutine 5 9 55.5
pod 0 2 0.0
total 20 94 21.2


line stmt bran cond sub pod time code
1             package YATT::Lite::WebMVC0::Partial::LangSwitch;
2             sub MY () {__PACKAGE__}
3 1     1   8110 use strict;
  1         2  
  1         33  
4 1     1   6 use warnings qw(FATAL all NONFATAL misc);
  1         2  
  1         41  
5 1     1   5 use Carp;
  1         2  
  1         71  
6              
7 1     1   5 use mro 'c3'; # XXX: Is this ok?
  1         2  
  1         7  
8              
9             use YATT::Lite::Partial
10 1         10 (requires => [qw/error/]
11             , fields => [qw/cf_lang_list
12             cf_default_lang
13             cf_debug_lang
14             /]
15             , -Entity, -CON, -SYS
16 1     1   56 );
  1         2  
17              
18             Entity default_lang => sub {
19 0     0     my MY $self = $SYS;
20 0   0       $self->{cf_default_lang} // 'en';
21             };
22              
23             Entity current_lang => sub {
24 0     0     my ($this) = @_;
25 0           $CON->cget('lang');
26             };
27              
28             sub before_dirhandler {
29 0     0 0   (my MY $self, my ($dh, $con, $file)) = @_;
30 0           $self->load_current_lang($con);
31 0           &maybe::next::method;
32             }
33              
34             sub load_current_lang {
35 0     0 0   (my MY $self, my ($con, $user)) = @_;
36              
37 0 0         $con->logdump("lang.init") if $self->{cf_debug_lang};
38              
39 0 0 0       if (not $user
40             and my $sub = $self->can("load_current_user")) {
41 0           $user = $sub->($self, $con);
42             }
43              
44 0           my $lang_key = '--lang';
45 0           my $lang = $con->param($lang_key);
46 0 0         if ($lang) {
47 0 0         $self->error("Invalid lang code!") unless $lang =~ /^\w{2}$/;
48             }
49              
50 0 0         my ($ck_lang) = map {$_ ? $_->value : ()} $con->cookies_in->{$lang_key};
  0            
51              
52 0 0 0       unless ($lang) {
    0          
53 0           my $sub;
54 0 0 0       if ($user and $sub = $user->can('pref_lang') and my $ul = $sub->($user)) {
    0 0        
55 0           $lang = $ul;
56             # XXX: Should delete lang cookie.
57             } elsif ($ck_lang) {
58 0           $lang = $ck_lang;
59             }
60             } elsif (not $ck_lang or $ck_lang ne $lang) {
61 0           $con->set_cookie($lang_key, $lang, -path => $con->site_location);
62             }
63              
64 0           my $yatt = $con->cget('yatt');
65             $lang ||= +$con->accept_language(filter =>
66 0   0       $self->{cf_lang_list} // [qw/en ja/])
      0        
67             || $yatt->default_lang;
68 0           $con->configure(lang => $lang);
69 0           $yatt->get_lang_msg($lang);
70              
71 0           $con->set_header(Vary => "Accept-Language"); # XXX: Should be idempotent.
72 0           $con->set_header("Content-Language" => $lang);
73              
74 0           &maybe::next::method;
75             }
76              
77             1;