File Coverage

lib/CallBackery/GuiPlugin/Abstract.pm
Criterion Covered Total %
statement 64 177 36.1
branch 3 60 5.0
condition 1 16 6.2
subroutine 18 32 56.2
pod 12 13 92.3
total 98 298 32.8


line stmt bran cond sub pod time code
1             package CallBackery::GuiPlugin::Abstract;
2 1     1   641 use strict;
  1         2  
  1         30  
3 1     1   12 use warnings;
  1         3  
  1         28  
4 1     1   5 use Carp qw(carp croak);
  1         2  
  1         66  
5 1     1   8 use Storable qw(dclone);
  1         2  
  1         55  
6 1     1   5 use Data::Dumper;
  1         7  
  1         52  
7 1     1   7 use Mojo::Template;
  1         2  
  1         15  
8 1     1   35 use Mojo::Util qw(monkey_patch);
  1         2  
  1         52  
9 1     1   8 use CallBackery::Exception qw(mkerror);
  1         4  
  1         44  
10 1     1   6 use autodie;
  1         2  
  1         6  
11 1     1   5722 use Scalar::Util 'blessed';
  1         3  
  1         53  
12 1     1   636 use IPC::Open3;
  1         3118  
  1         62  
13 1     1   11 use POSIX qw;
  1         2  
  1         44  
14 1     1   118 use Time::HiRes qw(usleep);
  1         3  
  1         5  
15 1     1   121 use Mojo::JSON qw(encode_json decode_json true false);
  1         7  
  1         58  
16 1     1   6 use Mojo::File;
  1         2  
  1         86  
17             # disable warnings below, otherwise testing will give warnings
18             eval { local $^W=0; require "sys/ioctl.ph" };
19              
20             =head1 NAME
21              
22             CallBackery::GuiPlugin::Abstract - GuiPlugin base class
23              
24             =head1 SYNOPSIS
25              
26             use Mojo::Base 'CallBackery::GuiPlugin::Abstract';
27              
28             =head1 DESCRIPTION
29              
30             The abstract base class for callbackery gui classes.
31              
32             =cut
33              
34 1     1   43 use Mojo::Base -base;
  1         4  
  1         7  
35              
36             =head1 ATTRIBUTES
37              
38             =head2 config
39              
40             The Plugin instance specific config section from the master config file.
41              
42             =cut
43              
44             has 'config';
45              
46             =head2 name
47              
48             The PLUGIN instance 'name' as specified in the C<*** PLUGIN:... ***> section.
49              
50             =cut
51              
52             has 'name';
53              
54             =head2 user
55              
56             The current user object
57              
58             =cut
59              
60             has 'user';
61              
62             =head2 tabName
63              
64             What should the tab holding this plugin be called
65              
66             =cut
67              
68             has tabName => sub {
69             return shift->config->{'tab-name'};
70             };
71              
72             =head2 instantiationMode
73              
74             Should the plugin in the webui be instantiated immediately or only when the tab gets selected
75              
76             =cut
77              
78             has instantiationMode => sub {
79             return 'onTabSelection'; # or onStartup
80             };
81              
82             =head2 grammar
83              
84             Returns the L parser for the configuration of this plugin.
85              
86             =cut
87              
88             has grammar => sub {
89             my $self = shift;
90             return {
91             _doc => 'Base class documentation string. Should be overwritten by the child class',
92             _vars => [qw(tab-name)],
93             _mandatory => [qw(tab-name)],
94             'tab-name' => {
95             _doc => 'Title of the Plugin Tab'
96             },
97             };
98             };
99              
100             =head2 schema
101              
102             A very simple minded grammar to json-schema convertor with no magic.
103             Better supply a proper schema.
104              
105             =cut
106              
107             has schema => sub {
108             my $self = shift;
109             my $grammar = $self->grammar;
110             return {
111             type => 'object',
112             properties => {
113             module => {
114             type => 'string'
115             },
116             unlisted => {
117             type => 'boolean'
118             },
119             map {
120             $_ => {
121             type => 'string',
122             $grammar->{$_}{_doc} ?
123             ( description => $grammar->{$_}{_doc} ) : (),
124             $grammar->{$_}{_re} ?
125             ( pattern => $grammar->{$_}{_re} ) : (),
126             $grammar->{$_}{_default} ?
127             ( default => $grammar->{$_}{_default} ) : (),
128             }
129             } @{$grammar->{_vars}},
130             map {
131             $_ => {
132             type => 'object',
133             $grammar->{$_}{_doc} ?
134             ( description => $grammar->{$_}{_doc} ) : (),
135             }
136             } @{$grammar->{_sections}},
137             },
138             required => [
139             'module',
140             ( $grammar->{_mandatory} ? (
141             @{$grammar->{_mandatory}} ) : ()
142             )
143             ],
144             additionalProperties => false
145             }
146             };
147              
148             =head2 controller
149              
150             the current controller
151              
152             =cut
153              
154             has controller => sub {
155             shift->user->controller;
156             };
157              
158             =head2 app
159              
160             the app object
161              
162             =cut
163              
164             has app => sub {
165             shift->user->app;
166             };
167              
168             =head2 log
169              
170             the log object
171              
172             =cut
173              
174             has log => sub {
175             my $self = shift;
176             $self->user and $self->controller and return $self->controller->log;
177             $self->app->log;
178             };
179              
180             =head2 args
181              
182             some meta information provided when instantiating the plugin.
183             for example when buidling the response to getUserConfig, args will contain the output of getUrlConfig from the frontend in the key urlConfig, which will allow to pass information from the url to calls like checkAccess.
184              
185             =cut
186              
187             has 'args' => sub { {} };
188              
189             =head2 screenCfg
190              
191             Returns the information for building a plugin configuration screen.
192              
193             =cut
194              
195             has screenCfg => sub {
196             return {
197             type => '*unknown*',
198             options => {},
199             # followed by type dependent keys
200             }
201             };
202              
203             =head2 checkAccess()
204              
205             Check if the current user may access the Plugin. Override in the Child
206             class to limit accessibility. By default plugins are not accessible
207             unless you have numeric UID or the word C<__CONFIG>.
208              
209             The L sets the userId to C<__SHELL>. If a
210             plugin should be configurable interactively it must allow access to
211             the C<__SHELL> user.
212              
213             checkAccess can also return a promise or be an async method
214              
215             =cut
216              
217             has checkAccess => sub {
218             my $self = shift;
219             my $userId = $self->user->userId;
220             return (defined $userId and ($userId eq '__CONFIG' or $userId =~ /^\d+$/));
221             };
222              
223             =head2 mayAnonymous
224              
225             may this gui plugin run for unauthenticated users ?
226              
227             =cut
228              
229             has mayAnonymous => sub {
230             return 0;
231             };
232              
233             =head2 stateFiles
234              
235             A list of files that contain the state of the settings configured by
236             this plugin this is used both for backup purposes and to replicate the
237             settings to a second installation.
238              
239             =cut
240              
241             has stateFiles => sub {
242             [];
243             };
244              
245             =head2 unconfigureFiles
246              
247             a list of files to be removed when 'unConfiguring' a device
248              
249             =cut
250              
251             has unConfigureFiles => sub {
252             [];
253             };
254              
255             =head2 eventActions
256              
257             A map of callbacks that will be called according to events in the
258             system. The following events are available:
259              
260             configChanged
261              
262             =cut
263              
264             has eventActions => sub {
265             {};
266             };
267              
268             =head1 METHODS
269              
270             All the methods of L plus:
271              
272             =cut
273              
274              
275             =head2 makeRxValidator(rx,error)
276              
277             Create a regular expression base validator function. The supplied
278             regular expression gets anchored front and back automatically.
279              
280             =cut
281              
282             sub createRxValidator {
283 0     0 0 0 my $self = shift;
284 0         0 my $rx = shift;
285 0         0 my $error = shift;
286             return sub {
287 0     0   0 my $value = shift;
288 0 0       0 return undef if $value =~ /^${rx}$/;
289 0         0 return $error;
290 0         0 };
291             }
292              
293             =head2 filterHashKey(data,key)
294              
295             Walks a hash/array structure and removes all occurrences of the given
296             key.
297              
298             CODE references get turned into 'true' values and JSON true/false get
299             passed on.
300              
301             =cut
302              
303             sub filterHashKey {
304 0     0 1 0 my $self = shift;
305 0         0 my $data = shift;
306 0         0 my $filterKey = shift;
307 0         0 my $ref = ref $data;
308 0 0 0     0 if (not $ref
    0 0        
    0          
    0          
309             or $ref eq ref true
310             or $ref eq 'CallBackery::Translate'){
311 0         0 return $data;
312             }
313             elsif ($ref eq 'CODE'){
314 0         0 return true;
315             }
316             elsif ($ref eq 'ARRAY'){
317 0         0 return [ map { $self->filterHashKey($_,$filterKey) } @$data ];
  0         0  
318             }
319             elsif ($ref eq 'HASH'){
320             return {
321             map {
322 0         0 $_ ne $filterKey
323 0 0       0 ? ( $_ => $self->filterHashKey($data->{$_},$filterKey) )
324             : ();
325             } keys %$data
326             }
327             }
328 0         0 return undef;
329             }
330              
331             =head2 processData(arguments)
332              
333             Take the data from the plug-in screen and process them.
334              
335             =cut
336              
337             sub processData {
338 0     0 1 0 my $self = shift;
339 0         0 warn "Processing ".Dumper(\@_);
340             }
341              
342             =head2 getData(arguments)
343              
344             Receive current data for plug-in screen content.
345              
346             =cut
347              
348       0 1   sub getData {
349             }
350              
351             =head2 reConfigure
352              
353             Re-generate all configuration that does not require direct user
354             input. This function may be called from within action handlers to
355             apply newly acquired data to to the running system.
356              
357             =cut
358              
359       0 1   sub reConfigure {
360             }
361              
362             =head2 validateData(arguments)
363              
364             Validate user supplied data prior to acting on it.
365              
366             =cut
367              
368       0 1   sub validateData {
369             }
370              
371             =head2 mergeGrammar
372              
373             A very simpleminded grammar merger with no recursion. For identical
374             keys, the later instance wins.
375              
376             =cut
377              
378             sub mergeGrammar {
379 1     1 1 2 my $self = shift;
380 1         92 my $grammar = dclone shift;
381 1         3 my $newGrammar = shift;
382 1         4 for my $key (keys %$newGrammar){
383 4         8 my $existing = $grammar->{$key};
384 4   50     12 my $ref = ref $existing // 'NONE';
385 4 100       10 $ref eq 'ARRAY' && do {
386 1         2 push @$existing, @{$newGrammar->{$key}};
  1         2  
387 1         3 next;
388             };
389 3 50       7 $ref eq 'HASH' && do {
390 0         0 for my $subKey (keys %{$newGrammar->{$key}}) {
  0         0  
391 0         0 $existing->{$subKey} = $newGrammar->{$key}{$subKey};
392             };
393 0         0 next;
394             };
395 3         6 $grammar->{$key} = $newGrammar->{$key};
396             }
397 1         7 return $grammar;
398             }
399              
400             =head2 varCompiler
401              
402             Returns a compiler sub reference for use in configuration variables or
403             _text sections with perl syntax. The resulting sub will provide access
404             to a hash called $variableName.
405              
406             =cut
407              
408             sub varCompiler {
409 0     0 1   my $self = shift;
410             return sub {
411 0   0 0     my $code = $_[0] // '';
412             # check and modify content in place
413 0           my $perl = 'sub {'.$code.'}';
414 0           my $sub = eval $perl; ## no critic (ProhibitStringyEval)
415 0 0         if ($@){
416 0           return "Failed to compile $code: $@ ";
417             }
418 0           eval { $sub->({}) };
  0            
419 0 0         if ($@){
420 0           return "Failed to run $code: $@ ";
421             }
422             # MODIFY the calling argument
423 0           $_[0] = $sub;
424 0           return;
425 0           };
426             }
427              
428             =head2 massageConfig($cfg)
429              
430             Allow the plugin to 'massage' the config hash ... doing this requires
431             deep knowledge of the cfg structure ...
432              
433             =cut
434              
435             sub massageConfig {
436 0     0 1   my $self = shift;
437 0           my $cfg = shift;
438             }
439              
440             =head2 renderTemplate(template,destination)
441              
442             Render the given template and write the result into the given
443             file. These templates support the L language enhanced
444             by the command C which looks up values from the
445             config database. The convention is that each plugin writes data in
446             it's own namespace.
447              
448             If the destination already exists, the method compares the current
449             content with the new one. It will only update the file if the content
450             differs.
451              
452             The method returns 0 when there was no change and 1 when a new version
453             of the file was written.
454              
455             These additional commands are available to the templates.
456              
457             =over
458              
459             =item *
460              
461             slurp(file)
462              
463             =back
464              
465             =cut
466              
467             has template => sub {
468             my $self = shift;
469             my $mt = Mojo::Template->new();
470             my $dbLookup = sub { $self->getConfigValue(@_) // ''};
471             # don't use L, use dbLookup instead
472             monkey_patch $mt->namespace,
473             L => $dbLookup;
474              
475             monkey_patch $mt->namespace,
476             dbLookup => $dbLookup;
477              
478             monkey_patch $mt->namespace,
479             app => sub { $self->app };
480              
481             monkey_patch $mt->namespace,
482             slurp => sub {
483             my $filename = shift;
484             return Mojo::File->new($filename)->slurp;
485             };
486             monkey_patch $mt->namespace,
487             cfgHash => sub { $self->app->config->cfgHash };
488             monkey_patch $mt->namespace,
489             pluginCfg => sub { my $instance = shift;
490             $self->app->config->cfgHash->{PLUGIN}{prototype}{$instance}->config
491             };
492             return $mt;
493             };
494              
495              
496             has homeDir => sub {
497             [getpwuid $>]->[7];
498             };
499              
500             sub renderTemplate{
501 0     0 1   my $self = shift;
502 0           my $template = shift;
503 0           my $destination = Mojo::File->new(shift);
504 0           $self->log->debug('['.$self->name.'] processing template '.$template);
505 0           my $newData = $self->template->render($self->app->home->rel_file('templates/system/'.$template)->slurp);
506 0 0         if (-r $destination){
507 0           my $oldData = Mojo::File->new($destination)->slurp;
508 0 0         if ($newData eq $oldData){
509 0           return 0
510             }
511             }
512 0           my $dir = $destination->dirname;
513 0 0         if (not -d $dir){
514 0           Mojo::File->new($dir)->make_path({mode => 755});
515             }
516              
517 0           $self->log->debug('['.$self->name."] writing $destination\n$newData");
518 0           eval {
519 0           local $SIG{__DIE__};
520 0           $destination->spurt($newData);
521             };
522 0 0         if ($@){
523 0 0 0       if (blessed $@ and $@->isa('autodie::exception')){
524 0           $self->log->error('['.$self->name."] writing $template -> $destination: ".$@->errno);
525             }
526             else {
527 0           die $@;
528             }
529             }
530 0 0 0       if ($self->controller and $self->controller->can('runEventActions')){
531 0           $self->controller->runEventActions('changeConfig');
532             }
533 0           return 1;
534             }
535              
536             =head2 getConfigValue(key)
537              
538             Read a config value from the database.
539              
540             =cut
541              
542             sub getConfigValue {
543 0     0 1   my $self = shift;
544 0           my $key = shift;
545 0           my $value = $self->user->db->getConfigValue($key);
546 0 0         return undef if not defined $value;
547 0           my $ret = eval { decode_json($value) };
  0            
548             # warn "GET $key -> ".Dumper($ret);
549 0 0         if ($@){
550 0           die mkerror (3984,$@);
551             }
552 0           return $ret->[0];
553             }
554              
555             =head2 setConfigValue(key)
556              
557             Save a config value to the database.
558              
559             =cut
560              
561             sub setConfigValue {
562 0     0 1   my $self = shift;
563 0           my $key = shift;
564 0           my $value = shift;
565             # warn "SET $key -> ".Dumper([$value]);
566 0           $self->user->db->setConfigValue($key,encode_json([$value]));
567 0 0         if ($self->controller->can('runEventActions')){
568 0           $self->controller->runEventActions('changeConfig');
569             }
570 0           return $value;
571             }
572              
573             =head2 systemNoFd(args)
574              
575             A version of the system function that makes sure to NOT to inherit any
576             extra filehandles to the kids and sends the output of the call system
577             log file. I would suggest to use this in preference to the normal
578             system function. Especially when launching daemons since Mojo seems to
579             fiddle with $^F and will thus inherit open sockets to child processes.
580              
581             If the binary name starts with -, the output will be ignored ... this
582             can be necessary for programs starting daemons that do not close their
583             output. Otherwhise you will read the output of the daemon and NOT
584             terminate. We are also using kill 0 to check if the process is still
585             active.
586              
587             =cut
588              
589             sub systemNoFd {
590 0     0 1   my $self = shift;
591 0           my $binary = shift;
592 0           my $logoutput = 1;
593 0 0         if ($binary =~ s/^-//){
594 0           $logoutput = 0;
595             }
596 0           my $rdr;
597             my $wtr;
598              
599             # make sure there is no inheriting any sockets
600             # mojo should actually take care of this
601 0           for my $path (glob '/proc/self/fd/*'){
602 1     1   3463 no autodie;
  1         12  
  1         6  
603 0 0         my ($fd) = $path =~ m{/proc/self/fd/(\d+)} or next;
604 0 0         $fd > 3 or next;
605 0 0         my $link = readlink $path or next;
606 0 0         $link =~ /socket/ or next;
607 0 0         if (open my $fh, q{>&=}, int($fd)){
608 0           $self->log->debug("Setting FIOCLEX on fd $fd ($link)");
609 0 0         if (defined &FIOCLEX){
    0          
610 0           ioctl $fh, FIOCLEX(),0;
611             }
612             elsif ($^O eq 'linux'){
613             # it seems we did not load the ioctl headers ...
614             # let's try this blindly since we are on linux after all
615 0           ioctl $fh, 21585, 0;
616             }
617             else {
618 0           die "investigate this (FD_CLOEXEC) since it should work but does not!";
619 0           fcntl($fh, F_SETFD, FD_CLOEXEC);
620             }
621             }
622             }
623 0           my $pid = eval {
624 0           open3($wtr, $rdr, undef,$binary,@_);
625             };
626 0           my $args = join " ",@_;
627 0 0         if ($@){
628 0           $self->log->warn("exec '$binary $args' failed: $!");
629             }
630             else {
631 0           $self->log->debug("running $binary($pid) $args");
632 0 0         if ($logoutput){
633 0           while (my $line = <$rdr>){
634 0           $line =~ s/[\r\n]//g;
635 0           $self->log->debug("$binary($pid) out: $line");
636 0           usleep 200; # give the process a chance to quit
637 0 0         last if not kill 0,$pid; # dead yet?
638             }
639             }
640 0           my $ret = waitpid( $pid, 0 );
641 0           $self->log->debug("running $binary($pid) done $ret");
642 0           return $ret;
643             }
644 0           return undef;
645             }
646              
647             1;
648             __END__