File Coverage

blib/lib/Doit/Locale.pm
Criterion Covered Total %
statement 11 70 15.7
branch 0 34 0.0
condition 0 15 0.0
subroutine 5 8 62.5
pod 0 3 0.0
total 16 130 12.3


line stmt bran cond sub pod time code
1             # -*- perl -*-
2              
3             #
4             # Author: Slaven Rezic
5             #
6             # Copyright (C) 2017,2018,2020 Slaven Rezic. All rights reserved.
7             # This package is free software; you can redistribute it and/or
8             # modify it under the same terms as Perl itself.
9             #
10             # Mail: slaven@rezic.de
11             # WWW: http://www.rezic.de/eserte/
12             #
13              
14             package Doit::Locale;
15              
16 1     1   7 use strict;
  1         1  
  1         26  
17 1     1   4 use warnings;
  1         2  
  1         33  
18             our $VERSION = '0.024';
19              
20 1     1   5 use Doit::Log;
  1         1  
  1         663  
21              
22 1     1 0 8 sub new { bless {}, shift }
23 1     1 0 3 sub functions { qw(locale_enable_locale) }
24              
25             sub locale_enable_locale {
26 0     0 0   my($self, $locale) = @_;
27 0           my %locale;
28 0 0         if (ref $locale eq 'ARRAY') {
29 0           %locale = map{($_,1)} @$locale;
  0            
30             } else {
31 0           %locale = ($locale => 1);
32             }
33              
34             ######################################################################
35             # Is locale already present?
36             my $is_locale_present = sub {
37 0 0   0     open my $fh, '-|', 'locale', '-a'
38             or error "Error while running 'locale -a': $!";
39 0           while(<$fh>) {
40 0           chomp;
41 0 0         if ($locale{$_}) {
42 0           return 1;
43             }
44             }
45 0 0         close $fh
46             or error "Error while running 'locale -a': $!";
47 0           return 0;
48 0           };
49              
50 0 0         if ($is_locale_present->()) {
51 0           return 0; # no change
52             }
53              
54             ######################################################################
55             # locale-gen (e.g. Ubuntu 12.03)
56 0 0 0       if (-x "/usr/sbin/locale-gen" && !-e "/etc/locale.gen") {
57 0           $self->system('locale-gen', $locale->[0]);
58 0           return 1;
59             }
60              
61             ######################################################################
62             # /etc/locale.gen (e.g. Debian and Debian-like)
63 0 0         if (-e "/etc/locale.gen") {
64 0           my $all_locales = '(' . join('|', map { quotemeta $_ } keys %locale) . ')';
  0            
65             my $changes = $self->change_file("/etc/locale.gen",
66             {match => qr{^#\s+$all_locales(\s|$)},
67 0     0     action => sub { $_[0] =~ s{^#\s+}{}; },
68             },
69 0           );
70 0 0         if (!$changes) {
71 0           error "Cannot find prepared locale '$locale' in /etc/locale.gen";
72             }
73 0           $self->system('locale-gen');
74 0           return 1;
75             }
76              
77             ######################################################################
78             # localedef (e.g RedHat, CentOS)
79 0 0 0       if (-x "/usr/bin/localedef" && -e "/etc/redhat-release") {
80             # It also exists on Debian-based systems, but works differently there.
81 0           my $use_glibc_langpack;
82 0 0         if (open my $fh, "/etc/redhat-release") {
83 0           my $line = <$fh>;
84 0 0 0       if (
      0        
      0        
85             ($line =~ /^Fedora release (\d+) / && $1 >= 28) # XXX since when we should take this path?
86             || ($line =~ /^CentOS Linux release (\d+)/ && $1 >= 8)
87             ) {
88 0           $use_glibc_langpack = 1;
89             }
90             }
91             TRY_LOCALE: {
92 0           my @errors;
  0            
93 0 0         if ($use_glibc_langpack) {
94 0 0         if ((keys(%locale))[0] =~ m{^([^_]+)}) {
95 0           my $lang = $1;
96             # XXX requires a previous add_component("rpm"); should be done automatically!
97 0           my $package = 'glibc-langpack-'.$lang;
98 0           eval { $self->rpm_install_packages($package) };
  0            
99 0 0         if (!$@) {
100 0           last TRY_LOCALE;
101             }
102 0           push @errors, "Installing $package failed: $@";
103             }
104             }
105 0           for my $try_locale (sort keys %locale) {
106 0 0         if (my($lang_country, $charset) = $try_locale =~ m{^(.*)\.(.*)$}) {
107 0           my $stderr;
108 0           eval { $self->open3({errref => \$stderr}, '/usr/bin/localedef', '-c', '-i', $lang_country, '-f', $charset, $try_locale) };
  0            
109 0 0         if (!$@) {
110 0           last TRY_LOCALE;
111             }
112             # an error, but maybe successful?
113 0 0         if ($is_locale_present->()) {
114 0           last TRY_LOCALE;
115             }
116 0           push @errors, "Can't add '$try_locale': $stderr";
117             } else {
118 0           push @errors, "Can't parse '$try_locale' as lang_COUNTRY.charset";
119             }
120             }
121 0           error "Can't install locale. Errors:\n" . join("\n", @errors);
122             }
123 0           return 1;
124             }
125              
126             ######################################################################
127             # not implemented elsewhere
128 0           error "Don't know how to enable locales on this system";
129             }
130              
131             1;
132              
133             __END__