Profile of C4/Languages.pm

Filename	/home/vagrant/kohaclone/C4/Languages.pm
Statements	Executed 0 statements in 12.4ms

Line	State ments	Time on line	Calls	Time in subs	Code
1					package C4::Languages;
2
3					# Copyright 2006 (C) LibLime
4					# Joshua Ferraro <jmf@liblime.com>
5					# Portions Copyright 2009 Chris Cormack and the Koha Dev Team
6					# This file is part of Koha.
7					#
8					# Koha is free software; you can redistribute it and/or modify it
9					# under the terms of the GNU General Public License as published by
10					# the Free Software Foundation; either version 3 of the License, or
11					# (at your option) any later version.
12					#
13					# Koha is distributed in the hope that it will be useful, but
14					# WITHOUT ANY WARRANTY; without even the implied warranty of
15					# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16					# GNU General Public License for more details.
17					#
18					# You should have received a copy of the GNU General Public License
19					# along with Koha; if not, see <http://www.gnu.org/licenses>.
20
21
22					use strict;
23					use warnings;
24
25					use Carp;
26					use CGI;
27					use List::MoreUtils qw( any );
28					use C4::Context;
29					use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $DEBUG);
30
31					eval {
32					if (C4::Context->ismemcached) {
33					require Memoize::Memcached;
34					import Memoize::Memcached qw(memoize_memcached);
35
36					memoize_memcached('getTranslatedLanguages', memcached => C4::Context->memcached);
37					memoize_memcached('getFrameworkLanguages' , memcached => C4::Context->memcached);
38					memoize_memcached('getAllLanguages', memcached => C4::Context->memcached);
39					}
40					};
41
42					BEGIN {
43					$VERSION = 3.07.00.049;
44					require Exporter;
45					@ISA = qw(Exporter);
46					@EXPORT = qw(
47					&getFrameworkLanguages
48					&getTranslatedLanguages
49					&getLanguages
50					&getAllLanguages
51					);
52					@EXPORT_OK = qw(getFrameworkLanguages getTranslatedLanguages getAllLanguages getLanguages get_bidi regex_lang_subtags language_get_description accept_language getlanguage);
53					$DEBUG = 0;
54					}
55
56					=head1 NAME
57
58					C4::Languages - Perl Module containing language list functions for Koha
59
60					=head1 SYNOPSIS
61
62					use C4::Languages;
63
64					=head1 DESCRIPTION
65
66					=cut
67
68					=head1 FUNCTIONS
69
70					=head2 getFrameworkLanguages
71
72					Returns a reference to an array of hashes:
73
74					my $languages = getFrameworkLanguages();
75					for my $language(@$languages) {
76					print "$language->{language_code}\n"; # language code in iso 639-2
77					print "$language->{language_name}\n"; # language name in native script
78					print "$language->{language_locale_name}\n"; # language name in current locale
79					}
80
81					=cut
82
83					sub getFrameworkLanguages {
84					# get a hash with all language codes, names, and locale names
85					my $all_languages = getAllLanguages();
86					my @languages;
87
88					# find the available directory names
89					my $dir=C4::Context->config('intranetdir')."/installer/data/";
90					opendir (MYDIR,$dir);
91					my @listdir= grep { !/^\.\|CVS/ && -d "$dir/$_"} readdir(MYDIR);
92					closedir MYDIR;
93
94					# pull out all data for the dir names that exist
95					for my $dirname (@listdir) {
96					for my $language_set (@$all_languages) {
97
98					if ($dirname eq $language_set->{language_code}) {
99					push @languages, {
100					'language_code'=>$dirname,
101					'language_description'=>$language_set->{language_description},
102					'native_descrition'=>$language_set->{language_native_description} }
103					}
104					}
105					}
106					return \@languages;
107					}
108
109					=head2 getTranslatedLanguages
110
111					Returns a reference to an array of hashes:
112
113					my $languages = getTranslatedLanguages();
114					print "Available translated languages:\n";
115					for my $language(@$trlanguages) {
116					print "$language->{language_code}\n"; # language code in iso 639-2
117					print "$language->{language_name}\n"; # language name in native script
118					print "$language->{language_locale_name}\n"; # language name in current locale
119					}
120
121					=cut
122
123					sub getTranslatedLanguages {
124					my ($interface, $theme, $current_language, $which) = @_;
125					my $htdocs;
126					my @languages;
127					my @enabled_languages;
128
129					if ($interface && $interface eq 'opac' ) {
130					@enabled_languages = split ",", C4::Context->preference('opaclanguages');
131					$htdocs = C4::Context->config('opachtdocs');
132					if ( $theme and -d "$htdocs/$theme" ) {
133					(@languages) = _get_language_dirs($htdocs,$theme);
134					}
135					else {
136					for my $theme ( _get_themes('opac') ) {
137					push @languages, _get_language_dirs($htdocs,$theme);
138					}
139					}
140					}
141					elsif ($interface && $interface eq 'intranet' ) {
142					@enabled_languages = split ",", C4::Context->preference('language');
143					$htdocs = C4::Context->config('intrahtdocs');
144					if ( $theme and -d "$htdocs/$theme" ) {
145					@languages = _get_language_dirs($htdocs,$theme);
146					}
147					else {
148					foreach my $theme ( _get_themes('intranet') ) {
149					push @languages, _get_language_dirs($htdocs,$theme);
150					}
151					}
152					}
153					else {
154					@enabled_languages = split ",", C4::Context->preference('opaclanguages');
155					my $htdocs = C4::Context->config('intrahtdocs');
156					foreach my $theme ( _get_themes('intranet') ) {
157					push @languages, _get_language_dirs($htdocs,$theme);
158					}
159					$htdocs = C4::Context->config('opachtdocs');
160					foreach my $theme ( _get_themes('opac') ) {
161					push @languages, _get_language_dirs($htdocs,$theme);
162					}
163					my %seen;
164					$seen{$_}++ for @languages;
165					@languages = keys %seen;
166					}
167					return _build_languages_arrayref(\@languages,$current_language,\@enabled_languages);
168					}
169
170					=head2 getAllLanguages
171
172					Returns a reference to an array of hashes:
173
174					my $alllanguages = getAllLanguages();
175					print "Available translated languages:\n";
176					for my $language(@$alllanguages) {
177					print "$language->{language_code}\n";
178					print "$language->{language_name}\n";
179					print "$language->{language_locale_name}\n";
180					}
181
182					This routine is a wrapper for getLanguages().
183
184					=cut
185
186					sub getAllLanguages {
187					return getLanguages(shift);
188					}
189
190					=head2 getLanguages
191
192					my $lang_arrayref = getLanguages([$lang[, $isFiltered]]);
193
194					Returns a reference to an array of hashes of languages.
195
196					- If no parameter is passed to the function, it returns english languages names
197					- If a $lang parameter conforming to RFC4646 syntax is passed, the function returns languages names translated in $lang
198					If a language name is not translated in $lang in database, the function returns english language name
199					- If $isFiltered is set to true, only the detail of the languages selected in system preferences AdvanceSearchLanguages is returned.
200
201					=cut
202
203					sub getLanguages {
204					my $lang = shift;
205					my $isFiltered = shift;
206
207					my @languages_loop;
208					my $dbh=C4::Context->dbh;
209					my $default_language = 'en';
210					my $current_language = $default_language;
211					my $language_list = $isFiltered ? C4::Context->preference("AdvancedSearchLanguages") : undef;
212					if ($lang) {
213					$current_language = regex_lang_subtags($lang)->{'language'};
214					}
215					my $sth = $dbh->prepare('SELECT * FROM language_subtag_registry WHERE type=\'language\'');
216					$sth->execute();
217					while (my $language_subtag_registry = $sth->fetchrow_hashref) {
218					my $desc;
219					# check if language name is stored in current language
220					my $sth4= $dbh->prepare("SELECT description FROM language_descriptions WHERE type='language' AND subtag =? AND lang = ?");
221					$sth4->execute($language_subtag_registry->{subtag},$current_language);
222					while (my $language_desc = $sth4->fetchrow_hashref) {
223					$desc=$language_desc->{description};
224					}
225					my $sth2= $dbh->prepare("SELECT * FROM language_descriptions LEFT JOIN language_rfc4646_to_iso639 on language_rfc4646_to_iso639.rfc4646_subtag = language_descriptions.subtag WHERE type='language' AND subtag =? AND language_descriptions.lang = ?");
226					if ($desc) {
227					$sth2->execute($language_subtag_registry->{subtag},$current_language);
228					}
229					else {
230					$sth2->execute($language_subtag_registry->{subtag},$default_language);
231					}
232					my $sth3 = $dbh->prepare("SELECT description FROM language_descriptions WHERE type='language' AND subtag=? AND lang=?");
233					# add the correct description info
234					while (my $language_descriptions = $sth2->fetchrow_hashref) {
235					$sth3->execute($language_subtag_registry->{subtag},$language_subtag_registry->{subtag});
236					my $native_description;
237					while (my $description = $sth3->fetchrow_hashref) {
238					$native_description = $description->{description};
239					}
240
241					# fill in the ISO6329 code
242					$language_subtag_registry->{iso639_2_code} = $language_descriptions->{iso639_2_code};
243					# fill in the native description of the language, as well as the current language's translation of that if it exists
244					if ($native_description) {
245					$language_subtag_registry->{language_description} = $native_description;
246					$language_subtag_registry->{language_description}.=" ($language_descriptions->{description})" if $language_descriptions->{description};
247					}
248					else {
249					$language_subtag_registry->{language_description} = $language_descriptions->{description};
250					}
251					}
252					# Do not push unless valid iso639-2 code
253					if ( $language_subtag_registry->{ iso639_2_code } and ( !$language_list \|\| index ( $language_list, $language_subtag_registry->{ iso639_2_code } ) >= 0) ) {
254					push @languages_loop, $language_subtag_registry;
255					}
256					}
257					return \@languages_loop;
258					}
259
260					=head2 _get_themes
261
262					Internal function, returns an array of all available themes.
263
264					(@themes) = &_get_themes('opac');
265					(@themes) = &_get_themes('intranet');
266
267					=cut
268
269					sub _get_themes {
270					my $interface = shift;
271					my $htdocs;
272					my @themes;
273					if ( $interface && $interface eq 'intranet' ) {
274					$htdocs = C4::Context->config('intrahtdocs');
275					}
276					else {
277					$htdocs = C4::Context->config('opachtdocs');
278					}
279					opendir D, "$htdocs";
280					my @dirlist = readdir D;
281					foreach my $directory (@dirlist) {
282					# if there's an en dir, it's a valid theme
283					-d "$htdocs/$directory/en" and push @themes, $directory;
284					}
285					return @themes;
286					}
287
288					=head2 _get_language_dirs
289
290					Internal function, returns an array of directory names, excluding non-language directories
291
292					=cut
293
294					sub _get_language_dirs {
295					my ($htdocs,$theme) = @_;
296					$htdocs //= '';
297					$theme //= '';
298					my @lang_strings;
299					opendir D, "$htdocs/$theme";
300					for my $lang_string ( readdir D ) {
301					next if $lang_string =~/^\./;
302					next if $lang_string eq 'all';
303					next if $lang_string =~/png$/;
304					next if $lang_string =~/js$/;
305					next if $lang_string =~/css$/;
306					next if $lang_string =~/CVS$/;
307					next if $lang_string =~/\.txt$/i; #Don't read the readme.txt !
308					next if $lang_string =~/img\|images\|famfam\|js\|less\|lib\|sound\|pdf/;
309					push @lang_strings, $lang_string;
310					}
311					return (@lang_strings);
312					}
313
314					=head2 _build_languages_arrayref
315
316					Internal function for building the ref to array of hashes
317
318					FIXME: this could be rewritten and simplified using map
319
320					=cut
321
322					sub _build_languages_arrayref {
323					my ($translated_languages,$current_language,$enabled_languages) = @_;
324					$current_language //= '';
325					my @translated_languages = @$translated_languages;
326					my @languages_loop; # the final reference to an array of hashrefs
327					my @enabled_languages = @$enabled_languages;
328					# how many languages are enabled, if one, take note, some contexts won't need to display it
329					my %seen_languages; # the language tags we've seen
330					my %found_languages;
331					my $language_groups;
332					my $track_language_groups;
333					my $current_language_regex = regex_lang_subtags($current_language);
334					# Loop through the translated languages
335					for my $translated_language (@translated_languages) {
336					# separate the language string into its subtag types
337					my $language_subtags_hashref = regex_lang_subtags($translated_language);
338
339					# is this language string 'enabled'?
340					for my $enabled_language (@enabled_languages) {
341					#warn "Checking out if $translated_language eq $enabled_language";
342					$language_subtags_hashref->{'enabled'} = 1 if $translated_language eq $enabled_language;
343					}
344
345					# group this language, key by langtag
346					$language_subtags_hashref->{'sublanguage_current'} = 1 if $translated_language eq $current_language;
347					$language_subtags_hashref->{'rfc4646_subtag'} = $translated_language;
348			252	360µs	$language_subtags_hashref->{'native_description'} = language_get_description($language_subtags_hashref->{language},$language_subtags_hashref->{language},'language'); # spent 263µs making 168 calls to DBI::common::DESTROY, avg 2µs/call # spent 97µs making 84 calls to DBD::_mem::common::DESTROY, avg 1µs/call
349			252	279µs	$language_subtags_hashref->{'script_description'} = language_get_description($language_subtags_hashref->{script},$language_subtags_hashref->{'language'},'script'); # spent 214µs making 168 calls to DBI::common::DESTROY, avg 1µs/call # spent 65µs making 84 calls to DBD::_mem::common::DESTROY, avg 776ns/call
350			252	304µs	$language_subtags_hashref->{'region_description'} = language_get_description($language_subtags_hashref->{region},$language_subtags_hashref->{'language'},'region'); # spent 227µs making 168 calls to DBI::common::DESTROY, avg 1µs/call # spent 76µs making 84 calls to DBD::_mem::common::DESTROY, avg 910ns/call
351			252	303µs	$language_subtags_hashref->{'variant_description'} = language_get_description($language_subtags_hashref->{variant},$language_subtags_hashref->{'language'},'variant'); # spent 236µs making 168 calls to DBI::common::DESTROY, avg 1µs/call # spent 67µs making 84 calls to DBD::_mem::common::DESTROY, avg 793ns/call
352					$track_language_groups->{$language_subtags_hashref->{'language'}}++;
353					push ( @{ $language_groups->{$language_subtags_hashref->{language}} }, $language_subtags_hashref );
354					}
355					# $key is a language subtag like 'en'
356					while( my ($key, $value) = each %$language_groups) {
357
358					# is this language group enabled? are any of the languages within it enabled?
359					my $enabled;
360					for my $enabled_language (@enabled_languages) {
361					my $regex_enabled_language = regex_lang_subtags($enabled_language);
362					$enabled = 1 if $key eq ($regex_enabled_language->{language} // '');
363					}
364			228	323µs	push @languages_loop, { # spent 231µs making 152 calls to DBI::common::DESTROY, avg 2µs/call # spent 92µs making 76 calls to DBD::_mem::common::DESTROY, avg 1µs/call
365					# this is only use if there is one
366					rfc4646_subtag => @$value[0]->{rfc4646_subtag},
367					native_description => language_get_description($key,$key,'language'),
368					language => $key,
369					sublanguages_loop => $value,
370					plural => $track_language_groups->{$key} >1 ? 1 : 0,
371					current => ($current_language_regex->{language} // '') eq $key ? 1 : 0,
372					group_enabled => $enabled,
373					};
374					}
375					return \@languages_loop;
376					}
377
378					sub language_get_description {
379					my ($script,$lang,$type) = @_;
380					my $dbh = C4::Context->dbh;
381					my $desc;
382	1	4.82ms	412	12.1ms	my $sth = $dbh->prepare("SELECT description FROM language_descriptions WHERE subtag=? AND lang=? AND type=?"); # spent 12.1ms making 412 calls to DBD::mysql::db::prepare, avg 29µs/call
383					#warn "QUERY: SELECT description FROM language_descriptions WHERE subtag=$script AND lang=$lang AND type=$type";
384					$sth->execute($script,$lang,$type);
385	1	2.45ms	624	18.5ms	while (my $descriptions = $sth->fetchrow_hashref) { # spent 18.5ms making 624 calls to DBD::mysql::st::__ANON__[DBD/mysql.pm:799], avg 30µs/call
386					$desc = $descriptions->{'description'};
387					}
388					unless ($desc) {
389	1	2.79ms	200	5.24ms	$sth = $dbh->prepare("SELECT description FROM language_descriptions WHERE subtag=? AND lang=? AND type=?"); # spent 5.24ms making 200 calls to DBD::mysql::db::prepare, avg 26µs/call
390			600	760µs	$sth->execute($script,'en',$type); # spent 590µs making 400 calls to DBI::common::DESTROY, avg 1µs/call # spent 170µs making 200 calls to DBD::_mem::common::DESTROY, avg 851ns/call
391	1	2.33ms	220	5.31ms	while (my $descriptions = $sth->fetchrow_hashref) { # spent 5.31ms making 220 calls to DBD::mysql::st::__ANON__[DBD/mysql.pm:799], avg 24µs/call
392					$desc = $descriptions->{'description'};
393					}
394					}
395					return $desc;
396					}
397					=head2 regex_lang_subtags
398
399					This internal sub takes a string composed according to RFC 4646 as
400					an input and returns a reference to a hash containing keys and values
401					for ( language, script, region, variant, extension, privateuse )
402
403					=cut
404
405					sub regex_lang_subtags {
406					my $string = shift;
407
408					# Regex for recognizing RFC 4646 well-formed tags
409					# http://www.rfc-editor.org/rfc/rfc4646.txt
410
411					# regexes based on : http://unicode.org/cldr/data/tools/java/org/unicode/cldr/util/data/langtagRegex.txt
412					# The structure requires no forward references, so it reverses the order.
413					# The uppercase comments are fragments copied from RFC 4646
414					#
415					# Note: the tool requires that any real "=" or "#" or ";" in the regex be escaped.
416
417					my $alpha = qr/[a-zA-Z]/ ; # ALPHA
418					my $digit = qr/[0-9]/ ; # DIGIT
419					my $alphanum = qr/[a-zA-Z0-9]/ ; # ALPHA / DIGIT
420					my $x = qr/[xX]/ ; # private use singleton
421					my $singleton = qr/[a-w y-z A-W Y-Z]/ ; # other singleton
422					my $s = qr/[-]/ ; # separator -- lenient parsers will use [-_]
423
424					# Now do the components. The structure is slightly different to allow for capturing the right components.
425					# The notation (?:....) is a non-capturing version of (...): so the "?:" can be deleted if someone doesn't care about capturing.
426
427					my $extlang = qr{(?: $s $alpha{3} )}x ; # *3("-" 3ALPHA)
428					my $language = qr{(?: $alpha{2,3} \| $alpha{4,8} )}x ;
429					#my $language = qr{(?: $alpha{2,3}$extlang{0,3} \| $alpha{4,8} )}x ; # (23ALPHA [ extlang ]) / 4ALPHA / 58ALPHA
430
431					my $script = qr{(?: $alpha{4} )}x ; # 4ALPHA
432
433					my $region = qr{(?: $alpha{2} \| $digit{3} )}x ; # 2ALPHA / 3DIGIT
434
435					my $variantSub = qr{(?: $digit$alphanum{3} \| $alphanum{5,8} )}x ; # ("-" variant), 58alphanum / (DIGIT 3alphanum)
436					my $variant = qr{(?: $variantSub (?: $s$variantSub )* )}x ; # ("-" variant), 58alphanum / (DIGIT 3alphanum)
437
438					my $extensionSub = qr{(?: $singleton (?: $s$alphanum{2,8} )+ )}x ; # singleton 1("-" (28alphanum))
439					my $extension = qr{(?: $extensionSub (?: $s$extensionSub )* )}x ; # singleton 1("-" (28alphanum))
440
441					my $privateuse = qr{(?: $x (?: $s$alphanum{1,8} )+ )}x ; # ("x"/"X") 1("-" (18alphanum))
442
443					# Define certain grandfathered codes, since otherwise the regex is pretty useless.
444					# Since these are limited, this is safe even later changes to the registry --
445					# the only oddity is that it might change the type of the tag, and thus
446					# the results from the capturing groups.
447					# http://www.iana.org/assignments/language-subtag-registry
448					# Note that these have to be compared case insensitively, requiring (?i) below.
449
450					my $grandfathered = qr{(?: (?i)
451					en $s GB $s oed
452					\| i $s (?: ami \| bnn \| default \| enochian \| hak \| klingon \| lux \| mingo \| navajo \| pwn \| tao \| tay \| tsu )
453					\| sgn $s (?: BE $s fr \| BE $s nl \| CH $s de)
454					)}x;
455
456					# For well-formedness, we don't need the ones that would otherwise pass, so they are commented out here
457
458					# \| art $s lojban
459					# \| cel $s gaulish
460					# \| en $s (?: boont \| GB $s oed \| scouse )
461					# \| no $s (?: bok \| nyn)
462					# \| zh $s (?: cmn \| cmn $s Hans \| cmn $s Hant \| gan \| guoyu \| hakka \| min \| min $s nan \| wuu \| xiang \| yue)
463
464					# Here is the final breakdown, with capturing groups for each of these components
465					# The language, variants, extensions, grandfathered, and private-use may have interior '-'
466
467					#my $root = qr{(?: ($language) (?: $s ($script) )? 40% (?: $s ($region) )? 40% (?: $s ($variant) )? 10% (?: $s ($extension) )? 5% (?: $s ($privateuse) )? 5% ) 90% \| ($grandfathered) 5% \| ($privateuse) 5% };
468
469					$string =~ qr{^ (?:($language)) (?:$s($script))? (?:$s($region))? (?:$s($variant))? (?:$s($extension))? (?:$s($privateuse))? $}xi; # \|($grandfathered) \| ($privateuse) $}xi;
470					my %subtag = (
471					'rfc4646_subtag' => $string,
472					'language' => $1,
473					'script' => $2,
474					'region' => $3,
475					'variant' => $4,
476					'extension' => $5,
477					'privateuse' => $6,
478					);
479					return \%subtag;
480					}
481
482					# Script Direction Resources:
483					# http://www.w3.org/International/questions/qa-scripts
484					sub get_bidi {
485					my ($language_script)= @_;
486					my $dbh = C4::Context->dbh;
487					my $bidi;
488					my $sth = $dbh->prepare('SELECT bidi FROM language_script_bidi WHERE rfc4646_subtag=?');
489					$sth->execute($language_script);
490					while (my $result = $sth->fetchrow_hashref) {
491					$bidi = $result->{'bidi'};
492					}
493					return $bidi;
494					};
495
496					sub accept_language {
497					# referenced http://search.cpan.org/src/CGILMORE/I18N-AcceptLanguage-1.04/lib/I18N/AcceptLanguage.pm
498					my ($clientPreferences,$supportedLanguages) = @_;
499					my @languages = ();
500					if ($clientPreferences) {
501					# There should be no whitespace anways, but a cleanliness/sanity check
502					$clientPreferences =~ s/\s//g;
503					# Prepare the list of client-acceptable languages
504					foreach my $tag (split(/,/, $clientPreferences)) {
505					my ($language, $quality) = split(/\;/, $tag);
506					$quality =~ s/^q=//i if $quality;
507					$quality = 1 unless $quality;
508					next if $quality <= 0;
509					# We want to force the wildcard to be last
510					$quality = 0 if ($language eq '*');
511					# Pushing lowercase language here saves processing later
512					push(@languages, { quality => $quality,
513					language => $language,
514					lclanguage => lc($language) });
515					}
516					} else {
517					carp "accept_language(x,y) called with no clientPreferences (x).";
518					}
519					# Prepare the list of server-supported languages
520					my %supportedLanguages = ();
521					my %secondaryLanguages = ();
522					foreach my $language (@$supportedLanguages) {
523					# warn "Language supported: " . $language->{language};
524					my $subtag = $language->{rfc4646_subtag};
525					$supportedLanguages{lc($subtag)} = $subtag;
526					if ( $subtag =~ /^([^-]+)-?/ ) {
527					$secondaryLanguages{lc($1)} = $subtag;
528					}
529					}
530
531					# Reverse sort the list, making best quality at the front of the array
532					@languages = sort { $b->{quality} <=> $a->{quality} } @languages;
533					my $secondaryMatch = '';
534					foreach my $tag (@languages) {
535					if (exists($supportedLanguages{$tag->{lclanguage}})) {
536					# Client en-us eq server en-us
537					return $supportedLanguages{$tag->{language}} if exists($supportedLanguages{$tag->{language}});
538					return $supportedLanguages{$tag->{lclanguage}};
539					} elsif (exists($secondaryLanguages{$tag->{lclanguage}})) {
540					# Client en eq server en-us
541					return $secondaryLanguages{$tag->{language}} if exists($secondaryLanguages{$tag->{language}});
542					return $supportedLanguages{$tag->{lclanguage}};
543					} elsif ($tag->{lclanguage} =~ /^([^-]+)-/ && exists($secondaryLanguages{$1}) && $secondaryMatch eq '') {
544					# Client en-gb eq server en-us
545					$secondaryMatch = $secondaryLanguages{$1};
546					} elsif ($tag->{lclanguage} =~ /^([^-]+)-/ && exists($secondaryLanguages{$1}) && $secondaryMatch eq '') {
547					# FIXME: We just checked the exact same conditional!
548					# Client en-us eq server en
549					$secondaryMatch = $supportedLanguages{$1};
550					} elsif ($tag->{lclanguage} eq '*') {
551					# * matches every language not already specified.
552					# It doesn't care which we pick, so let's pick the default,
553					# if available, then the first in the array.
554					#return $acceptor->defaultLanguage() if $acceptor->defaultLanguage();
555					return $supportedLanguages->[0];
556					}
557					}
558					# No primary matches. Secondary? (ie, en-us requested and en supported)
559					return $secondaryMatch if $secondaryMatch;
560					return undef; # else, we got nothing.
561					}
562
563					=head2 getlanguage
564
565					Select a language based on the URL parameter 'language', a cookie,
566					syspref available languages & browser
567
568					=cut
569
570					sub getlanguage {
571					my ($cgi) = @_;
572
573					$cgi //= new CGI;
574					my $interface = C4::Context->interface;
575					my $theme = C4::Context->preference( ( $interface eq 'opac' ) ? 'opacthemes' : 'template' );
576					my $language;
577
578					my $preference_to_check =
579					$interface eq 'intranet' ? 'language' : 'opaclanguages';
580					# Get the available/valid languages list
581					my @languages = split /,/, C4::Context->preference($preference_to_check);
582
583					# Chose language from the URL
584					$language = $cgi->param( 'language' );
585					if ( defined $language && any { $_ eq $language } @languages) {
586					return $language;
587					}
588
589					# cookie
590	1	45µs			if ($language = $cgi->cookie('KohaOpacLanguage') ) {
591					$language =~ s/[^a-zA-Z_-]*//; # sanitize cookie
592					}
593
594					# HTTP_ACCEPT_LANGUAGE
595					if ( !$language && $ENV{HTTP_ACCEPT_LANGUAGE} ) {
596					$language = accept_language( $ENV{HTTP_ACCEPT_LANGUAGE},
597					getTranslatedLanguages( $interface, $theme ) );
598					}
599
600					# Ignore a lang not selected in sysprefs
601					if ( $language && any { $_ eq $language } @languages ) {
602					return $language;
603					}
604
605					# Pick the first selected syspref language
606					$language = shift @languages;
607					return $language if $language;
608
609					# Fall back to English if necessary
610					return 'en';
611					}
612
613					1;
614
615					__END__
616
617					=head1 AUTHOR
618
619					Joshua Ferraro
620
621					=cut