File Coverage

blib/lib/CTK/Configuration.pm
Criterion Covered Total %
statement 102 107 95.3
branch 28 42 66.6
condition 14 34 41.1
subroutine 19 21 90.4
pod 9 9 100.0
total 172 213 80.7


line stmt bran cond sub pod time code
1             package CTK::Configuration;
2 3     3   57850 use strict;
  3         12  
  3         116  
3 3     3   522 use utf8;
  3         19  
  3         13  
4              
5             =encoding utf-8
6              
7             =head1 NAME
8              
9             CTK::Configuration - Configuration of CTK
10              
11             =head1 VERSION
12              
13             Version 1.01
14              
15             =head1 SYNOPSIS
16              
17             use CTK::Configuration;
18              
19             my $config = CTK::Configuration->new(
20             config => "foo.conf",
21             confdir => "conf",
22             options => {... Config::General options ...},
23             );
24              
25             =head1 DESCRIPTION
26              
27             The module works with the configuration
28              
29             =head2 new
30              
31             my $config = CTK::Configuration->new(
32             config => "/path/to/config/file.conf",
33             confdir => "/path/to/config/directory",
34             options => {... Config::General options ...},
35             );
36              
37             Example foo.conf file:
38              
39             Foo 1
40             Bar test
41             Flag true
42              
43             Example of the "conf" structure of $config object:
44              
45             print Dumper($config->{conf});
46             $VAR1 = {
47             'foo' => 1
48             'bar' => 'test',
49             'flag' => 1,
50             }
51              
52             =over 8
53              
54             =item B
55              
56             config => "/etc/myapp/myapp.conf"
57              
58             Specifies absolute or relative path to config-file.
59              
60             =item B
61              
62             confdir => "/etc"
63              
64             Specifies absolute or relative path to config-dir.
65              
66             =item B
67              
68             no_autoload => 1
69              
70             Disables auto loading configuration files. Default: false (loading is enabled)
71              
72             =item B
73              
74             options => { ... }
75              
76             Options of L
77              
78             =back
79              
80             =head1 METHODS
81              
82             =over 8
83              
84             =item B
85              
86             my $error = $config->error;
87              
88             Returns error string if occurred any errors while creating the object or reading the configuration file
89              
90             =item B
91              
92             my $value = $config->conf( 'key' );
93              
94             Gets value from config structure by key
95              
96             my $config_hash = $config->conf;
97              
98             Returns config hash structure
99              
100             =item B
101              
102             my $value = $config->get( 'key' );
103              
104             Gets value from config structure by key
105              
106             =item B
107              
108             my $config_hash = $config->getall;
109              
110             Returns config hash structure
111              
112             =item B
113              
114             my $config = $config->load;
115              
116             Loading config files
117              
118             =item B
119              
120             my $config = $config->reload;
121              
122             Reloading config files. All the previous config options will be flushes
123              
124             =item B
125              
126             $config->set( 'key', 'value' );
127              
128             Sets value to config structure by key. Returns setted value
129              
130             =item B
131              
132             print $config->error unless $config->status;
133              
134             Returns boolean status of loading config file
135              
136             =back
137              
138             =head1 HISTORY
139              
140             =over 8
141              
142             =item B<1.00 Mon Apr 29 10:36:06 MSK 2019>
143              
144             Init version
145              
146             =back
147              
148             See C file
149              
150             =head1 DEPENDENCIES
151              
152             L, L
153              
154             =head1 TO DO
155              
156             See C file
157              
158             =head1 BUGS
159              
160             * none noted
161              
162             =head1 SEE ALSO
163              
164             L
165              
166             =head1 AUTHOR
167              
168             Serż Minus (Sergey Lepenkov) L Eabalama@cpan.orgE
169              
170             =head1 COPYRIGHT
171              
172             Copyright (C) 1998-2022 D&D Corporation. All Rights Reserved
173              
174             =head1 LICENSE
175              
176             This program is free software; you can redistribute it and/or
177             modify it under the same terms as Perl itself.
178              
179             See C file and L
180              
181             =cut
182              
183 3     3   141 use vars qw($VERSION);
  3         5  
  3         137  
184             $VERSION = '1.01';
185              
186 3     3   14 use Carp;
  3         6  
  3         163  
187 3     3   1939 use Config::General;
  3         42422  
  3         198  
188 3     3   1030 use Try::Tiny;
  3         3568  
  3         170  
189 3     3   460 use Time::HiRes qw/gettimeofday/;
  3         1232  
  3         22  
190 3     3   409 use Cwd qw/getcwd/;
  3         7  
  3         117  
191 3     3   16 use File::Spec ();
  3         4  
  3         82  
192              
193             use constant {
194 3         2657 CONF_DIR => "conf",
195             LOCKED_KEYS => [qw/hitime loadstatus/],
196 3     3   14 };
  3         6  
197              
198             sub new {
199 4     4 1 442 my $class = shift;
200 4         11 my %args = @_;
201              
202             # Create object
203 4         22 my $myhitime = gettimeofday() * 1;
204 4         30 my $self = bless {
205             status => 0,
206             dirs => [],
207             error => "",
208             files => [],
209             created => time(),
210             orig => {},
211             myhitime=> $myhitime,
212             conf => {
213             hitime => $myhitime,
214             loadstatus => 0, # == $self->{status}
215             },
216             }, $class;
217              
218             # Set dirs
219 4         8 my @dirs = ();
220 4   66     27 my $mydir = $args{confdir} // $args{dir};
221 4         49 my $root = getcwd();
222 4         8 my $confdir;
223 4 100       11 if ($mydir) {
224 2 100       43 $confdir = File::Spec->file_name_is_absolute($mydir)
225             ? $mydir
226             : File::Spec->catdir($root, $mydir);
227 2 100       20 push (@dirs, $root) unless File::Spec->file_name_is_absolute($mydir);
228             } else {
229 2         17 $confdir = File::Spec->catdir($root, CONF_DIR);
230 2         5 push (@dirs, $root);
231             }
232 4 50       14 push(@dirs, $confdir) if length($confdir);
233 4 50       12 push(@dirs, CONF_DIR) if $confdir ne CONF_DIR;
234 4         17 $self->{dirs} = [@dirs];
235              
236             # Set files
237 4   66     17 my $fileconf = $args{config} // $args{file} // $args{fileconf};
      33        
238 4 100       13 unless ($fileconf) {
239 1         2 $self->{error} = "Config file not specified";
240 1         3 return $self;
241             }
242 3 100       35 $fileconf = File::Spec->catfile($root, $fileconf)
243             unless File::Spec->file_name_is_absolute($fileconf);
244 3         9 $self->{files} = [$fileconf];
245 3 100       117 unless (-e $fileconf) {
246 1         6 $self->{error} = sprintf("Config file not found: %s", $fileconf);
247 1         6 return $self;
248             }
249              
250             # Options
251 2   50     29 my $tmpopts = $args{options} || {};
252 2         7 my %options = %$tmpopts;
253 2         4 $options{"-ConfigFile"} = $fileconf;
254 2   50     13 $options{"-ConfigPath"} ||= [@dirs];
255 2 50       6 $options{"-ApacheCompatible"} = 1 unless exists $options{"-ApacheCompatible"};
256 2 50       5 $options{"-LowerCaseNames"} = 1 unless exists $options{"-LowerCaseNames"};
257 2 50       6 $options{"-AutoTrue"} = 1 unless exists $options{"-AutoTrue"};
258 2         8 $self->{orig} = {%options};
259              
260 2 50       15 return $self if $args{no_autoload};
261 2         8 return $self->load;
262             }
263             sub load {
264 2     2 1 3 my $self = shift;
265 2   50     6 my $orig = $self->{orig} || {};
266 2         4 $self->{error} = "";
267              
268             # Loading
269 2         3 my $cfg;
270             try {
271 2     2   150 $cfg = Config::General->new( %$orig );
272             } catch {
273 0   0 0   0 $self->{error} = $_ // '';
274 2         15 };
275 2 50       5322 return $self if length($self->{error});
276              
277             # Ok
278 2 50 33     29 my %newconfig = $cfg->getall if $cfg && $cfg->can('getall');
279 2 50 33     39 $self->{files} = [$cfg->files] if $cfg && $cfg->can('files');
280              
281             # Set only unlocked keys
282 2         19 my %lkeys = ();
283 2         3 foreach my $k (@{(LOCKED_KEYS)}) { $lkeys{$k} = 1 }
  2         6  
  4         8  
284 2 50 33     7 foreach my $k (keys(%newconfig)) { $self->{conf}->{$k} = $newconfig{$k} if $k && !$lkeys{$k} }
  12         40  
285              
286             # Set statuses
287 2         5 $self->{status} = 1;
288 2         3 $self->{conf}->{loadstatus} = 1;
289              
290 2         34 return $self;
291             }
292             sub reload {
293 0     0 1 0 my $self = shift;
294              
295             # Flush settings
296             $self->{conf} = {
297             hitime => $self->{myhitime},
298 0         0 loadstatus => 0,
299             };
300              
301 0         0 return $self->load;
302             }
303             sub error {
304 3     3 1 9 my $self = shift;
305 3   50     9 return $self->{error} // '';
306             }
307             sub status {
308 3     3 1 758 my $self = shift;
309 3 100       16 return $self->{status} ? 1 : 0;
310             }
311             sub set {
312 1     1 1 2 my $self = shift;
313 1         2 my $key = shift;
314 1 50 33     5 return undef unless defined($key) && length($key);
315 1         2 my $val = shift;
316 1         4 $self->{conf}->{$key} = $val;
317             }
318             sub get {
319 9     9 1 11 my $self = shift;
320 9         14 my $key = shift;
321 9 50 33     35 return undef unless defined($key) && length($key);
322 9         38 return $self->{conf}->{$key};
323             }
324             sub getall {
325 1     1 1 2 my $self = shift;
326 1         4 return $self->{conf};
327             }
328             sub conf {
329 1     1 1 2 my $self = shift;
330 1         2 my $key = shift;
331 1 50       4 return undef unless $self->{conf};
332 1 50       8 return $self->{conf} unless defined $key;
333 0           return $self->{conf}->{$key};
334             }
335              
336             1;
337              
338             __END__