File Coverage

blib/lib/YATT/Lite/WebMVC0/Partial/LangSwitch.pm
Criterion Covered Total %
statement 15 44 34.0
branch 0 16 0.0
condition 0 20 0.0
subroutine 5 9 55.5
pod 0 2 0.0
total 20 91 21.9


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