File Coverage

blib/lib/CTK/App.pm
Criterion Covered Total %
statement 85 102 83.3
branch 26 46 56.5
condition 12 31 38.7
subroutine 13 16 81.2
pod 7 7 100.0
total 143 202 70.7


line stmt bran cond sub pod time code
1             package CTK::App;
2 2     2   64450 use strict;
  2         14  
  2         52  
3 2     2   559 use utf8;
  2         16  
  2         7  
4              
5             =encoding utf-8
6              
7             =head1 NAME
8              
9             CTK::App - Application interface
10              
11             =head1 VERSION
12              
13             Version 1.02
14              
15             =head1 SYNOPSIS
16              
17             use CTK::App;
18              
19             my $ctk = CTK::App->new;
20             my $ctk = CTK::App->new(
21             project => 'MyApp',
22             ident => "myapp",
23             root => ".",
24             confopts => {... Config::General options ...},
25             configfile => '/path/to/conf/file.conf',
26             logfile => '/path/to/log/file.log',
27             );
28              
29             =head1 DESCRIPTION
30              
31             The module provides application functionality
32              
33             Features:
34              
35             =over 8
36              
37             =item *
38              
39             Configuration supported as CTK plugin
40              
41             =item *
42              
43             Logging supported as CTK plugin
44              
45             =back
46              
47             =head2 CONFIGURATION
48              
49             For enabling configuration specify the follow arguments in constructor:
50              
51             root => "/path/to/conf",
52             configfile => '/path/to/conf/file.conf',
53              
54             See L
55              
56             =head3 ARGUMENTS
57              
58             =over 8
59              
60             =item B
61              
62             Path to the configuration file of the your project
63              
64             Default: /etc//.conf
65              
66             See L
67              
68             =item B
69              
70             root => "/path/to/conf",
71              
72             The main directory of project (confdir)
73              
74             Default: /etc/
75              
76             See L
77              
78             =back
79              
80             =head2 LOGGER
81              
82             For logger enable include follow config-section:
83              
84             #
85             # Logging
86             #
87             # Activate or deactivate the logging: on/off (yes/no). Default: off
88             #
89             LogEnable on
90              
91             #
92             # Loglevel: debug, info, notice, warning, error,
93             # crit, alert, emerg, fatal, except
94             # Default: debug
95             #
96             LogLevel debug
97              
98             #
99             # LogIdent string. Default: none
100             #
101             #LogIdent "foo"
102              
103             #
104             # LogFile: path to log file
105             #
106             # Default: using syslog
107             #
108             #LogFile /var/log/foo.log
109              
110             For forcing disable this logger specify the follow arguments in constructor:
111              
112             no_logger_init => 1,
113              
114             =head3 ARGUMENTS
115              
116             =over 8
117              
118             =item B
119              
120             ident => "foo"
121              
122             Ident string for logs and debugging
123              
124             Default:
125              
126             See L
127              
128             =item B
129              
130             logfacility => Sys::Syslog::LOG_USER
131              
132             Sets facility. See L and L
133              
134             =item B
135              
136             logfile => '/var/log/myapp/myapp.log'
137              
138             Full path to the log file
139              
140             Default: syslog
141              
142             See L
143              
144             =item B
145              
146             Set to 1 for forcing disabling automatic logger initialization on start the your application
147              
148             Default: 0 (logger is enabled)
149              
150             =item B
151              
152             loglevel => "info"
153              
154             This directive specifies the minimum possible priority level. You can use:
155              
156             'debug'
157             'info'
158             'notice' or 'note'
159             'warning' or 'warn'
160             'error' or 'err'
161             'crit'
162             'alert'
163             'emerg' or 'emergency'
164             'fatal'
165             'except' or 'exception'
166              
167             Default: "debug"
168              
169             See L
170              
171             =item B
172              
173             logopts => {
174             utf8 => undef, # Default: 1
175             syslogopts => undef, # Defaukt: "ndelay,pid"
176             socketopts => undef, # Default: undef
177             pure => undef, # Default: 0
178             separator => undef, # Default: " "
179             }
180              
181             Default: undef
182              
183             Logger options. See See L
184              
185             =back
186              
187             =head1 METHODS
188              
189             List of application methods
190              
191             =head2 again
192              
193             This method is called immediately after creating the CTK object.
194              
195             Internal use only!
196              
197             =head2 handle
198              
199             $ctk->handle($handler, @params) or die $ctk->error;
200              
201             Runs handler with parameters
202              
203             Internal use only!
204              
205             =head2 list_handlers
206              
207             my @handlers = $ctk->list_handlers
208              
209             Returns list of registered handlers
210              
211             =head2 lookup_handler
212              
213             my $handler = $ctk->lookup_handler($name) or die "Handler lookup failed";
214              
215             Lookup handler by name. Returns handler or undef while error
216              
217             =head2 register_handler
218              
219             use base qw/ CTK::App /;
220              
221             __PACKAGE__->register_handler(
222             handler => "foo",
223             description => "Foo CLI handler",
224             parameters => {
225             param1 => "foo",
226             param2 => "bar",
227             param3 => 123,
228             },
229             code => sub {
230             ### CODE:
231             my $self = shift;
232             my $meta = shift;
233             my @params = @_;
234              
235             $self->debug(Dumper({
236             meta => $meta,
237             params => [@params],
238             }));
239              
240             return 1;
241             });
242              
243             Method for register new cli handler
244              
245             =head2 run, run_handler
246              
247             my $app = CTK::MyApp->new;
248             my $result = $app->run("foo",
249             foo => "one",
250             bar => 1
251             ) or die $app->error;
252              
253             Run handler by name
254              
255             Example of result:
256              
257             {
258             'meta' => {
259             'params' => {
260             'param3' => 123,
261             'param1' => 'foo',
262             'param2' => 'bar'
263             },
264             'name' => 'foo',
265             'description' => 'Foo CLI handler'
266             },
267             'params' => [
268             'foo',
269             'one',
270             'bar',
271             1
272             ],
273             };
274              
275             =head1 HISTORY
276              
277             =over 8
278              
279             =item B<1.00 Mon 29 Apr 22:26:18 MSK 2019>
280              
281             Init version
282              
283             =back
284              
285             See C file
286              
287             =head1 TO DO
288              
289             See C file
290              
291             =head1 BUGS
292              
293             * none noted
294              
295             =head1 SEE ALSO
296              
297             L, L
298              
299             =head1 AUTHOR
300              
301             Serż Minus (Sergey Lepenkov) L Eabalama@cpan.orgE
302              
303             =head1 COPYRIGHT
304              
305             Copyright (C) 1998-2022 D&D Corporation. All Rights Reserved
306              
307             =head1 LICENSE
308              
309             This program is free software; you can redistribute it and/or
310             modify it under the same terms as Perl itself.
311              
312             See C file and L
313              
314             =cut
315              
316 2     2   123 use vars qw($VERSION);
  2         4  
  2         104  
317             $VERSION = '1.02';
318              
319 2     2   10 use base qw/ CTK /;
  2         3  
  2         820  
320              
321 2     2   17 use Carp;
  2         3  
  2         133  
322 2     2   1096 use CTK::ConfGenUtil qw/lvalue/;
  2         5  
  2         151  
323              
324             use constant {
325 2         1773 APP_PLUGINS => [qw/
326             cli config log
327             /],
328 2     2   13 };
  2         4  
329              
330             my %handler_registry;
331              
332             sub again {
333 2     2 1 5 my $self = shift;
334 2         15 my $args = $self->origin;
335 2         4 my $status = $self->load_plugins(@{(APP_PLUGINS)});
  2         9  
336 2 50       9 $self->{status} = 0 unless $status;
337 2         31 my $config = $self->configobj;
338              
339             # Autoloading logger (settings data from config only, no use logmode!!)
340 2   100     15 my $log_on = lvalue($config->get("logenable")) || lvalue($config->get("logenabled")) || 0;
341 2 100 66     14 if ($log_on && !$args->{no_logger_init}) {
342 1   50     7 my $logopts = $args->{logopts} || {};
343 1 50       6 my $logfile = defined($args->{logfile}) ? $self->logfile : lvalue($config->get("logfile")); # From args or config
344 1 50       3 $logopts->{facility} = $args->{logfacility} if defined($args->{logfacility}); # From args only!
345 1 50 33     4 $logopts->{file} = $logfile if defined($logfile) && length($logfile);
346             $logopts->{ident} = defined($args->{ident})
347             ? $args->{ident}
348 1 50 33     5 : (lvalue($config->get("logident")) // $self->project); # From args or config
349             $logopts->{level} = defined($args->{loglevel})
350             ? $args->{loglevel}
351 1 50       6 : lvalue($config->get("loglevel")); # From args or config
352 1 50       19 $self->logger_init(%$logopts) or do {
353 0         0 $self->error("Can't initialize logger");
354 0         0 $self->{status} = 0;
355             };
356             }
357              
358 2         18 return $self;
359             }
360              
361             sub register_handler {
362 5     5 1 807 my $class = shift;
363 5 100       14 $class = ref($class) if ref($class);
364 5         16 my %info = @_;
365 5 100       14 $handler_registry{$class} = {} unless exists($handler_registry{$class});
366 5         7 my $handlers = $handler_registry{$class};
367              
368             # Handler data
369 5   33     20 my $name = $info{handler} // $info{name} // '';
      0        
370 5 50       12 croak("Incorrect handler name") unless length($name);
371 5         8 delete $info{handler};
372 5         8 $info{name} = $name;
373             croak("The $name duplicate handler definition")
374 5 50       11 if defined($handlers->{$name});
375 5   50     10 $info{description} //= '';
376 5   50     21 my $params = $info{parameters} || $info{params} || {};
377 5         7 delete $info{parameters};
378 5 50       11 $params = {} unless ref($params) eq "HASH";
379 5         11 $info{params} = $params;
380 5   50 0   7 my $code = $info{code} || sub {return 1};
  0         0  
381 5 50       11 if (ref($code) eq 'CODE') {
382 5         7 $info{code} = $code;
383             } else {
384 0     0   0 $info{code} = sub { $code };
  0         0  
385             }
386              
387 5         17 $handlers->{$name} = {%info};
388 5         22 return 1;
389             }
390             sub lookup_handler {
391 3     3 1 700 my $self = shift;
392 3         3 my $name = shift;
393 3 50       8 return undef unless $name;
394 3   50     7 my $invocant = ref($self) || scalar(caller(0));
395 3         5 my $handlers = $handler_registry{$invocant};
396 3 50       16 return undef unless $handlers;
397 3         11 return $handlers->{$name}
398             }
399             sub list_handlers {
400 0     0 1 0 my $self = shift;
401 0   0     0 my $invocant = ref($self) || scalar(caller(0));
402 0         0 my $handlers = $handler_registry{$invocant};
403 0 0 0     0 return () unless $handlers && ref($handlers) eq 'HASH';
404 0         0 return (sort {$a cmp $b} keys %$handlers);
  0         0  
405             }
406             sub handle {
407 1     1 1 3 my $self = shift;
408 1         1 my $meta = shift;
409 1         11 my @params = @_;
410 1         2 my %info;
411             my $func;
412 1         6 foreach my $k (keys %$meta) {
413 4 50       7 next unless defined $k;
414 4 100       7 if ($k eq 'code') {
415 1         2 $func = $meta->{code};
416 1         2 next;
417             }
418 3         6 $info{$k} = $meta->{$k};
419             }
420 1 50       5 unless(ref($func) eq 'CODE') {
421 0         0 $self->error("Handler code not found!");
422 0         0 return 0;
423             }
424 1         5 my $result = &$func($self, {%info}, @params);
425 1         8 return $result;
426             }
427             sub run_handler {
428 1     1 1 2 my $self = shift;
429 1         3 my $name = shift;
430 1         2 my @params = @_;
431 1 50       4 unless($name) {
432 0         0 $self->error("Incorrect handler name");
433 0         0 return 0;
434             }
435 1 50       3 my $handler = $self->lookup_handler($name) or do {
436 0         0 $self->error(sprintf("Handler lookup failed: %s", $name));
437 0         0 return 0;
438             };
439 1 50       7 return 0 unless $self->status; # Error occured on constructor or the again() method
440 1         9 return $self->handle($handler, @params);
441             }
442 1     1 1 5 sub run { goto &run_handler }
443              
444             1;
445              
446             __END__