File Coverage

blib/lib/Metabrik.pm
Criterion Covered Total %
statement 15 649 2.3
branch 0 286 0.0
condition 0 82 0.0
subroutine 5 70 7.1
pod 55 55 100.0
total 75 1142 6.5


line stmt bran cond sub pod time code
1             #
2             # $Id: Metabrik.pm,v 25fdfba6a43e 2018/10/30 17:07:37 gomor $
3             #
4             package Metabrik;
5 1     1   611 use strict;
  1         3  
  1         27  
6 1     1   4 use warnings;
  1         3  
  1         44  
7              
8             # Breaking.Feature.Fix
9             our $VERSION = '1.31';
10             our $FIX = '0';
11              
12 1     1   5 use base qw(Class::Gomor::Hash);
  1         2  
  1         467  
13              
14             our @AS = qw(
15             init_done
16             preinit_done
17             check_use_properties_done
18             context
19             global
20             log
21             shell
22             );
23             __PACKAGE__->cgBuildAccessorsScalar(\@AS);
24              
25             sub brik_version {
26 0     0 1   my $self = shift;
27              
28 0           my $revision = $self->brik_properties->{revision};
29 0           $revision =~ s/^.*\s([a-f0-9]+)\s.*$/$1/;
30              
31 0           return $VERSION.'.'.$FIX.'-'.$revision;
32             }
33              
34             sub brik_author {
35 0     0 1   my $self = shift;
36              
37 0           my $author = $self->brik_properties->{author};
38              
39             # Default to GomoR
40 0   0       return $author || 'GomoR ';
41             }
42              
43             sub brik_license {
44 0     0 1   my $self = shift;
45              
46 0           my $license = $self->brik_properties->{license};
47              
48             # Default to BSD 3-Clause
49 0   0       return $license || 'http://opensource.org/licenses/BSD-3-Clause';
50             }
51              
52             sub brik_properties {
53             return {
54 0     0 1   revision => '$Revision: 25fdfba6a43e $',
55             author => 'GomoR ',
56             license => 'http://opensource.org/licenses/BSD-3-Clause',
57             tags => [ ],
58             attributes => {
59             init_done => [ qw(0|1) ],
60             context => [ qw(core::context) ],
61             global => [ qw(core::global) ],
62             log => [ qw(core::log) ],
63             shell => [ qw(core::shell) ],
64             },
65             attributes_default => {
66             init_done => 0,
67             },
68             commands => {
69             brik_version => [ ],
70             brik_author => [ ],
71             brik_license => [ ],
72             brik_help_set => [ qw(Attribute) ],
73             brik_help_run => [ qw(Command) ],
74             brik_class => [ ],
75             brik_classes => [ ],
76             brik_name => [ ],
77             brik_repository => [ ],
78             brik_category => [ ],
79             brik_tags => [ ],
80             brik_has_tag => [ qw(Tag) ],
81             brik_commands => [ ], # Return full list of Commands
82             brik_base_commands => [ ], # Return only base class Commands
83             brik_inherited_commands => [ ], # Return only inherited Commands
84             brik_own_commands => [ ], # Return only own Commands
85             brik_has_command => [ qw(Command) ],
86             brik_attributes => [ ], # Return full list of Attributes
87             brik_base_attributes => [ ], # Return only base class Attributes
88             brik_inherited_attributes => [ ], # Return only inherited Attributes
89             brik_own_attributes => [ ], # Return only own Attributes
90             brik_has_attribute => [ qw(Attribute) ],
91             brik_preinit => [ qw(Arguments) ],
92             brik_preinit_no_checks => [ qw(Arguments) ],
93             brik_init => [ qw(Arguments) ],
94             brik_init_no_checks => [ qw(Arguments) ],
95             brik_self => [ ],
96             brik_fini => [ qw(Arguments) ],
97             brik_create_attributes => [ ],
98             brik_set_default_attributes => [ ],
99             brik_check_require_modules => [ ],
100             brik_check_require_binaries => [ ],
101             brik_check_properties => [ ],
102             brik_check_use_properties => [ ],
103             brik_checks => [ ],
104             brik_has_binary => [ qw(binary) ],
105             brik_has_module => [ qw(module) ],
106             brik_help_run_undef_arg => [ qw(Command Arg) ],
107             brik_help_set_undef_arg => [ qw(Command Arg) ],
108             brik_help_run_invalid_arg => [ qw(Command Arg valid_list) ],
109             brik_help_run_empty_array_arg => [ qw(Command Arg) ],
110             brik_help_run_file_not_found => [ qw(Command Arg) ],
111             brik_help_run_directory_not_found => [ qw(Command Arg) ],
112             brik_help_run_must_be_root => [ qw(Command) ],
113             },
114             require_modules => { },
115             optional_modules => { },
116             require_binaries => { },
117             optional_binaries => { },
118             need_packages => { },
119             need_services => { },
120             };
121             }
122              
123             sub brik_use_properties {
124 0     0 1   return { };
125             }
126              
127             sub brik_help_set {
128 0     0 1   my $self = shift;
129 0           my ($attribute) = @_;
130              
131 0           my $name = $self->brik_name;
132              
133 0 0         if (! defined($attribute)) {
134 0           return $self->log->info("run $name brik_help_set ");
135             }
136              
137 0           my $classes = $self->brik_classes;
138              
139 0           for my $class (reverse @$classes) {
140 0           my $attributes = $class->brik_attributes;
141              
142 0 0         if (exists($attributes->{$attribute})) {
143 0           my $help = sprintf("%s ", $attribute);
144 0           for (@{$attributes->{$attribute}}) {
  0            
145 0           $help .= "<$_> ";
146             }
147 0           return $help;
148             }
149             }
150              
151 0           return;
152             }
153              
154             sub brik_help_run {
155 0     0 1   my $self = shift;
156 0           my ($command) = @_;
157              
158 0           my $name = $self->brik_name;
159              
160 0 0         if (! defined($command)) {
161 0           return $self->log->info("run $name brik_help_run ");
162             }
163              
164 0           my $classes = $self->brik_classes;
165              
166 0           for my $class (reverse @$classes) {
167 0           my $commands = $class->brik_commands;
168              
169 0 0         if (exists($commands->{$command})) {
170 0           my $help = sprintf("%s ", $command);
171 0           for (@{$commands->{$command}}) {
  0            
172 0 0         if (m{\|OPTIONAL}) {
173 0           s/\|OPTIONAL\s*$//;
174 0           $help .= "[ <$_> ] ";
175             }
176             else {
177 0           $help .= "<$_> ";
178             }
179             }
180 0           return $help;
181             }
182             }
183              
184 0           return;
185             }
186              
187             sub brik_check_properties {
188 0     0 1   my $self = shift;
189 0           my ($properties) = @_;
190              
191 0           my $name = $self->brik_name;
192 0 0         if (! $self->can('brik_properties')) {
193 0           return $self->log->error("brik_check_properties: Brik [$name] has no brik_properties");
194             }
195              
196 0   0       $properties ||= $self->brik_properties;
197              
198 0           my $error = 0;
199              
200             # Check all mandatory keys are present
201 0           my @mandatory_keys = qw(
202             tags
203             );
204 0           for my $key (@mandatory_keys) {
205 0 0         if (! exists($properties->{$key})) {
206 0           print("[-] brik_check_properties: Brik [$name]: brik_properties lacks mandatory key [$key]\n");
207 0           $error++;
208             }
209             }
210              
211             # Check all keys are valid
212 0           my %valid_keys = (
213             revision => 1,
214             author => 1,
215             license => 1,
216             tags => 1,
217             attributes => 1,
218             attributes_default => 1,
219             commands => 1,
220             require_modules => 1,
221             optional_modules => 1,
222             require_binaries => 1,
223             optional_binaries => 1,
224             need_packages => 1,
225             need_services => 1,
226             );
227 0           for my $key (keys %$properties) {
228 0 0 0       if (! exists($valid_keys{$key})) {
    0 0        
    0 0        
      0        
      0        
229 0           print("[-] brik_check_properties: brik_properties has invalid key [$key]\n");
230 0           $error++;
231             }
232             elsif ($key eq 'tags' && ref($properties->{$key}) ne 'ARRAY') {
233 0           print("[-] brik_check_properties: brik_properties with key [$key] is not an ARRAYREF\n");
234 0           $error++;
235             }
236             elsif ($key ne 'revision' && $key ne 'author' && $key ne 'license' && $key ne 'tags' && ref($properties->{$key}) ne 'HASH') {
237 0           print("[-] brik_check_properties: brik_properties with key [$key] is not a HASHREF\n");
238 0           $error++;
239             }
240             }
241              
242             # Check HASHREFs contains pointers to ARRAYREFs
243 0           for my $key (keys %$properties) {
244 0 0 0       next if ($key eq 'revision' || $key eq 'author' || $key eq 'license' || $key eq 'tags' || $key eq 'attributes_default');
      0        
      0        
      0        
245              
246 0           for my $subkey (keys %{$properties->{$key}}) {
  0            
247 0 0         if (ref($properties->{$key}->{$subkey}) ne 'ARRAY') {
248 0           print("[-] brik_check_properties: brik_properties with key [$key] and subkey [$subkey] is not an ARRAYREF\n");
249 0           $error++;
250             }
251             }
252             }
253              
254 0 0         if ($error) {
255 0           print("[-] brik_check_properties: Brik [$name] has invalid properties ($error error(s) found)\n");
256 0           return 0;
257             }
258              
259 0           return 1;
260             }
261              
262             sub brik_check_use_properties {
263 0     0 1   my $self = shift;
264 0           my ($use_properties) = @_;
265              
266             # Do it once.
267 0 0         return 1 if $self->check_use_properties_done;
268              
269 0           my $name = $self->brik_name;
270 0 0         if (! $self->can('brik_use_properties')) {
271 0           return 1;
272             }
273              
274 0   0       $use_properties ||= $self->brik_use_properties;
275              
276 0           my $error = 0;
277              
278             # Check all mandatory keys are present
279 0           my @mandatory_keys = qw(
280             );
281 0           for my $key (@mandatory_keys) {
282 0 0         if (! exists($use_properties->{$key})) {
283 0           print("[-] brik_check_use_properties: Brik [$name]: brik_use_properties lacks mandatory key [$key]\n");
284 0           $error++;
285             }
286             }
287              
288             # Check all keys are valid
289 0           my %valid_keys = (
290             revision => 1,
291             author => 1,
292             license => 1,
293             tags => 1,
294             attributes => 1,
295             attributes_default => 1,
296             commands => 1,
297             require_modules => 1,
298             optional_modules => 1,
299             require_binaries => 1,
300             optional_binaries => 1,
301             need_packages => 1,
302             need_services => 1,
303             );
304 0           for my $key (keys %$use_properties) {
305 0 0 0       if (! exists($valid_keys{$key})) {
    0 0        
    0 0        
      0        
      0        
306 0           print("[-] brik_check_use_properties: brik_use_properties has invalid key [$key]\n");
307 0           $error++;
308             }
309             elsif ($key eq 'tags' && ref($use_properties->{$key}) ne 'ARRAY') {
310 0           print("[-] brik_check_use_properties: brik_use_properties with key [$key] is not an ARRAYREF\n");
311 0           $error++;
312             }
313             elsif ($key ne 'revision' && $key ne 'author' && $key ne 'license' && $key ne 'tags' && ref($use_properties->{$key}) ne 'HASH') {
314 0           print("[-] brik_check_use_properties: brik_use_properties with key [$key] is not a HASHREF\n");
315 0           $error++;
316             }
317             }
318              
319             # Check HASHREFs contains pointers to ARRAYREFs
320 0           for my $key (keys %$use_properties) {
321 0 0 0       next if ($key eq 'revision' || $key ne 'author' && $key ne 'license' || $key eq 'tags' || $key eq 'attributes_default');
      0        
      0        
      0        
322              
323 0           for my $subkey (keys %{$use_properties->{$key}}) {
  0            
324 0 0         if (ref($use_properties->{$key}->{$subkey}) ne 'ARRAY') {
325 0           print("[-] brik_check_use_properties: brik_use_properties with key [$key] and subkey [$subkey] is not an ARRAYREF\n");
326 0           $error++;
327             }
328             }
329             }
330              
331 0 0         if ($error) {
332 0           print("[-] brik_check_use_properties: Brik [$name] has invalid properties ($error error(s) found)\n");
333 0           return 0;
334             }
335              
336 0           $self->check_use_properties_done(1);
337              
338 0           return 1;
339             }
340              
341             sub brik_checks {
342 0     0 1   my $self = shift;
343              
344 0 0         $self->brik_check_properties or return;
345 0 0         $self->brik_check_use_properties or return;
346 0 0         $self->brik_check_require_modules or return;
347 0 0         $self->brik_check_require_binaries or return;
348              
349 0           return $self;
350             }
351              
352             sub _msg {
353 0     0     my ($self, $msg) = @_;
354 0   0       $msg ||= 'undef';
355 0           chomp($msg);
356 0   0       my $class = ref($self) || $self;
357 0           $class = lc($class);
358 0           $class =~ s/^metabrik:://i;
359 0           return lc($class).": $msg";
360             }
361              
362             sub new {
363 0     0 1   my $self = shift->SUPER::new(
364             @_,
365             );
366              
367 0           my $r = $self->brik_create_attributes;
368 0 0         if (! defined($r)) {
369 0 0         if (defined($self->log)) {
370 0           return $self->log->error("new: brik_create_attributes failed");
371             }
372             else {
373 0           my $msg = _msg($self, "new: brik_create_attributes failed");
374 0           print("[-] $msg\n");
375 0           return;
376             }
377             }
378              
379             # Create a default core::loglite Brik, if not given.
380 0 0         if (! defined($self->log)) {
381             {
382 1     1   11095 no strict 'refs';
  1         2  
  1         1284  
  0            
383              
384 0           push @{'Metabrik::Core::Loglite::ISA'}, 'Metabrik';
  0            
385              
386 0           *{'Metabrik::Core::Loglite::allow_log_override'} = sub {
387 0     0     my $self = shift;
388 0           my ($value) = @_;
389 0 0         if (defined($value)) {
390 0           $self->{allow_log_override} = $value;
391             }
392 0           return $self->{allow_log_override};
393 0           };
394              
395 0           *{'Metabrik::Core::Loglite::level'} = sub {
396 0     0     my $self = shift;
397 0           my ($value) = @_;
398 0 0         if (defined($value)) {
399 0           $self->{level} = $value;
400             }
401 0           return $self->{level};
402 0           };
403              
404 0           *{'Metabrik::Core::Loglite::color'} = sub {
405 0     0     my $self = shift;
406 0           my ($value) = @_;
407 0 0         if (defined($value)) {
408 0           $self->{color} = $value;
409             }
410 0           return $self->{color};
411 0           };
412              
413 0           *{'Metabrik::Core::Loglite::info'} = sub {
414 0     0     my $self = shift;
415 0           my ($msg) = @_;
416 0 0         return 1 if ($self->level < 1);
417 0           $msg = _msg($self, $msg);
418 0           print("[+] $msg\n");
419 0           return 1;
420 0           };
421              
422 0           *{'Metabrik::Core::Loglite::error'} = sub {
423 0     0     my $self = shift;
424 0           my ($msg) = @_;
425 0 0         return 1 if ($self->level < 1);
426 0           $msg = _msg($self, $msg);
427 0           print("[-] $msg\n");
428 0           return;
429 0           };
430              
431 0           *{'Metabrik::Core::Loglite::fatal'} = sub {
432 0     0     my $self = shift;
433 0           my ($msg) = @_;
434             # In log level 0, we print nothing except fatal errors.
435 0           $msg = _msg($self, $msg);
436 0           die("[F] $msg\n");
437 0           return;
438 0           };
439              
440 0           *{'Metabrik::Core::Loglite::warning'} = sub {
441 0     0     my $self = shift;
442 0           my ($msg) = @_;
443 0 0         return 1 if ($self->level < 1);
444 0           $msg = _msg($self, $msg);
445 0           print("[!] $msg\n");
446 0           return 1;
447 0           };
448              
449 0           *{'Metabrik::Core::Loglite::verbose'} = sub {
450 0     0     my $self = shift;
451 0           my ($msg) = @_;
452 0 0         return 1 if ($self->level < 2);
453 0           $msg = _msg($self, $msg);
454 0           print("[*] $msg\n");
455 0           return 1;
456 0           };
457              
458 0           *{'Metabrik::Core::Loglite::debug'} = sub {
459 0     0     my $self = shift;
460 0           my ($msg) = @_;
461 0 0         return 1 if ($self->level < 3);
462 0           $msg = _msg($self, $msg);
463 0           print("[D] $msg\n");
464 0           return 1;
465 0           };
466             }
467              
468 0           $self->log(bless(
469             { level => 1, color => 0, allow_log_override => 0 },
470             'Metabrik::Core::Loglite',
471             ));
472             }
473              
474 0           return $self->brik_preinit;
475             }
476              
477             sub new_no_checks {
478 0     0 1   my $self = shift->SUPER::new(
479             @_,
480             );
481              
482 0           my $r = $self->brik_create_attributes;
483 0 0         if (! defined($r)) {
484 0           return $self->log->error("new_no_checks: brik_create_attributes failed");
485             }
486              
487 0           return $self->brik_preinit_no_checks;
488             }
489              
490             sub new_from_brik {
491 0     0 1   my $self = shift;
492 0           my ($brik) = @_;
493              
494 0 0         if (! defined($brik)) {
495 0           return $self->log->error("new_from_brik: you must give a Brik object as argument");
496             }
497              
498 0           my $log = $brik->log;
499 0           my $glo = $brik->global;
500 0           my $con = $brik->context;
501 0           my $she = $brik->shell;
502              
503 0           my %args = ();
504 0 0         if (defined($log)) {
505 0           $args{log} = $log;
506             }
507 0 0         if (defined($glo)) {
508 0           $args{global} = $glo;
509             }
510 0 0         if (defined($con)) {
511 0           $args{context} = $con;
512             }
513 0 0         if (defined($she)) {
514 0           $args{shell} = $she;
515             }
516              
517 0           return $self->new(%args);
518             }
519              
520             sub new_from_brik_no_checks {
521 0     0 1   my $self = shift;
522 0           my ($brik) = @_;
523              
524 0 0         if (! defined($brik)) {
525 0           return $self->log->error("new_from_brik_no_checks: you must give a Brik object as argument");
526             }
527              
528 0           my $log = $brik->log;
529 0           my $glo = $brik->global;
530 0           my $con = $brik->context;
531 0           my $she = $brik->shell;
532              
533 0           my %args = ();
534 0 0         if (defined($log)) {
535 0           $args{log} = $log;
536             }
537 0 0         if (defined($glo)) {
538 0           $args{global} = $glo;
539             }
540 0 0         if (defined($con)) {
541 0           $args{context} = $con;
542             }
543 0 0         if (defined($she)) {
544 0           $args{shell} = $she;
545             }
546              
547 0           return $self->new_no_checks(%args);
548             }
549              
550             sub new_from_brik_init {
551 0     0 1   my $self = shift;
552              
553 0 0         my $brik = $self->new_from_brik(@_)
554             or return $self->log->error("new_from_brik_init: new_from_brik failed");
555 0 0         $brik->brik_init
556             or return $self->log->error("new_from_brik_init: brik_init failed");
557              
558 0           return $brik;
559             }
560              
561             sub new_from_brik_init_no_checks {
562 0     0 1   my $self = shift;
563              
564 0 0         my $brik = $self->new_from_brik_no_checks(@_)
565             or return $self->log->error("new_from_brik_init_no_checks: new_from_brik_no_checks failed");
566 0 0         $brik->brik_init_no_checks
567             or return $self->log->error("new_from_brik_init_no_checks: brik_init_no_checks failed");
568              
569 0           return $brik;
570             }
571              
572             sub new_brik_init {
573 0     0 1   my $self = shift;
574              
575 0 0         my $brik = $self->new(@_)
576             or return $self->log->error("new_brik_init: new failed");
577 0 0         $brik->brik_init
578             or return $self->log->error("new_brik_init: brik_init failed");
579              
580 0           return $brik;
581             }
582              
583             sub new_brik_init_no_checks {
584 0     0 1   my $self = shift;
585              
586 0 0         my $brik = $self->new_no_checks(@_)
587             or return $self->log->error("new_brik_init_no_checks: new_no_checks failed");
588 0 0         $brik->brik_init_no_checks
589             or return $self->log->error("new_brik_init_no_checks: brik_init_no_checks failed");
590              
591 0           return $brik;
592             }
593              
594             # Build Attributes, Class::Gomor style
595             sub brik_create_attributes {
596 0     0 1   my $self = shift;
597              
598 0           my $classes = $self->brik_classes;
599              
600 0           for my $class (@$classes) {
601 0           my $attributes = $class->brik_properties->{attributes};
602              
603 0           my @as = ( keys %$attributes );
604 0 0         if (@as > 0) {
605 1     1   9 no strict 'refs';
  1         1  
  1         4608  
606              
607 0           my %current = map { $_ => 1 } @{$class.'::AS'};
  0            
  0            
608 0           my @new = ();
609 0           for my $this (@as) {
610 0 0         if (! exists($current{$this})) {
611 0           push @new, $this;
612             }
613             }
614              
615 0           push @{$class.'::AS'}, @new;
  0            
616 0           for my $this (@new) {
617 0 0         if (! $class->can($this)) {
618 0           $class->cgBuildAccessorsScalar([ $this ]);
619             }
620             }
621             }
622             }
623              
624 0           return 1;
625             }
626              
627             # Set default values for Attributes
628             sub brik_set_default_attributes {
629 0     0 1   my $self = shift;
630              
631 0           my $classes = $self->brik_classes;
632              
633             # Set default Attributes from brik_properties hierarchy
634 0           for my $class (@$classes) {
635             # brik_properties() is the general value to use for the default_attributes
636 0 0         if (exists($class->brik_properties->{attributes_default})) {
637 0           for my $attribute (keys %{$class->brik_properties->{attributes_default}}) {
  0            
638             #next unless defined($self->$attribute); # Do not overwrite if set on new
639 0           $self->$attribute($class->brik_properties->{attributes_default}->{$attribute});
640             }
641             }
642             }
643              
644             # Special case: automatic setting of some defaults (datadir)
645             # No inheritance here, it is just for currently instanciated Brik.
646             # We either take the global datadir if avail, or the Brik's one.
647             # Global datadir is just the base path, like $ENV{HOME}."/metabrik".
648 0           my $datadir;
649             my $global_datadir;
650 0           my $global = $self->global;
651 0 0         if (defined($global)) {
652 0           $global_datadir = $self->global->datadir;
653             }
654              
655 0 0 0       if (exists($self->brik_properties->{attributes})
656             && exists($self->brik_properties->{attributes}->{datadir})) {
657 0           $datadir = $self->datadir;
658              
659 0           my $dir;
660             # If datadir is set by user, we use it blindly.
661             # Usually, only core::global will have it set.
662 0 0         if (defined($datadir)) {
663 0           $dir = $datadir;
664             }
665             # Else, we build it
666             else {
667 0   0       $dir = $global_datadir || (defined($ENV{HOME}) && $ENV{HOME}."/metabrik")
668             || "/tmp/metabrik";
669 0 0         if (! -d $dir) {
670 0 0         mkdir($dir)
671             or return $self->log->error("brik_set_default_attributes: mkdir ".
672             "[$dir] failed: $!");
673             }
674              
675 0           (my $subdir = $self->brik_name) =~ s/::/-/g;
676 0 0         if (length($subdir)) {
677 0           $dir .= '/'.$subdir;
678             }
679              
680 0           $self->datadir($dir);
681             }
682              
683 0 0         if (! -d $dir) {
684 0 0         mkdir($dir)
685             or return $self->log->error("brik_set_default_attributes: mkdir [$dir] ".
686             "failed: $!");
687             }
688             }
689              
690 0           return 1;
691             }
692              
693             sub brik_set_use_default_attributes {
694 0     0 1   my $self = shift;
695              
696             # Set default Attributes from brik_use_properties, no hierarchy, just inheritance
697 0           my $class = $self->brik_class;
698 0 0 0       if ($self->can('brik_use_properties') && exists($self->brik_use_properties->{attributes_default})) {
699 0           for my $attribute (keys %{$self->brik_use_properties->{attributes_default}}) {
  0            
700             #next unless defined($self->$attribute); # Do not overwrite if set on new
701             # Do not overwrite if Attribute is set by brik_properties
702 0 0         next if exists($class->brik_properties->{attributes_default}->{$attribute});
703 0           $self->$attribute($self->brik_use_properties->{attributes_default}->{$attribute});
704             }
705             }
706              
707 0           return 1;
708             }
709              
710             # Module check
711             sub brik_check_require_modules {
712 0     0 1   my $self = shift;
713 0           my ($require_modules) = @_;
714              
715 0           my @require_modules_list = ();
716 0 0         if (defined($require_modules)) {
717 0           push @require_modules_list, $require_modules;
718             }
719             else {
720 0           my $classes = $self->brik_classes;
721 0           for my $class (@$classes) {
722 0           push @require_modules_list, $class->brik_properties->{require_modules};
723             }
724             }
725              
726 0           my $error = 0;
727 0           for my $require_modules (@require_modules_list) {
728 0           for my $module (keys %$require_modules) {
729 0           eval("require $module;");
730 0 0         if ($@) {
731 0           chomp($@);
732 0           $self->log->error("brik_check_require_modules: you have to install ".
733             "module [$module]");
734 0           $self->log->debug("brik_check_require_modules: $@");
735 0           $error++;
736 0           next;
737             }
738              
739 0           my @imports = @{$require_modules->{$module}};
  0            
740 0 0         if (@imports > 0) {
741 0           eval('$module->import(@imports);');
742 0 0         if ($@) {
743 0           chomp($@);
744 0           $self->log->error("brik_check_require_modules: unable to import ".
745             "functions [@imports] from module [$module]");
746 0           $self->log->debug("brik_check_require_modules: $@");
747 0           $error++;
748 0           next;
749             }
750             }
751             }
752             }
753              
754 0 0         return $error ? 0 : 1;
755             }
756              
757             sub brik_check_require_binaries {
758 0     0 1   my $self = shift;
759 0           my ($require_binaries) = @_;
760              
761 0           my @require_binaries_list = ();
762 0 0         if (defined($require_binaries)) {
763 0           push @require_binaries_list, $require_binaries;
764             }
765             else {
766 0           my $classes = $self->brik_classes;
767 0           for my $class (@$classes) {
768 0           push @require_binaries_list, $class->brik_properties->{require_binaries};
769             }
770             }
771              
772 0           my %binaries_found = ();
773 0           for my $require_binaries (@require_binaries_list) {
774 0           for my $binary (keys %$require_binaries) {
775 0           $binaries_found{$binary} = 0;
776 0           my @path = split(':', $ENV{PATH});
777 0           for my $path (@path) {
778 0 0         if (-f "$path/$binary") {
779 0           $binaries_found{$binary} = 1;
780 0           last;
781             }
782             }
783             }
784             }
785              
786 0           my $error = 0;
787 0           for my $binary (keys %binaries_found) {
788 0 0         if (! $binaries_found{$binary}) {
789 0           $self->log->error("brik_check_require_binaries: binary [$binary] not found in PATH");
790 0           $error++;
791             }
792             }
793              
794 0 0         return $error ? 0 : 1;
795             }
796              
797             sub brik_repository {
798 0     0 1   my $self = shift;
799              
800 0           my $name = $self->brik_name;
801              
802 0           my @toks = split('::', $name);
803              
804             # No repository defined
805 0 0         if (@toks == 2) {
    0          
806 0           return 'main';
807             }
808             elsif (@toks > 2) {
809 0           my ($repository) = $name =~ /^(.*?)::.*/;
810 0           return $repository;
811             }
812              
813             # Error, repository not found
814 0           return $self->log->fatal("brik_repository: no Repository found for Brik [$name] (invalid format?)");
815             }
816              
817             sub brik_category {
818 0     0 1   my $self = shift;
819              
820 0           my $name = $self->brik_name;
821              
822 0           my @toks = split('::', $name);
823              
824             # No repository defined
825 0 0         if (@toks == 2) {
    0          
826 0           my ($category) = $name =~ /^(.*?)::.*/;
827 0           return $category;
828             }
829             elsif (@toks > 2) {
830 0           my ($category) = $name =~ /^.*?::(.*?)::.*/;
831 0           return $category;
832             }
833              
834             # Error, category not found
835 0           return $self->log->fatal("brik_category: no Category found for Brik [$name] (invalid format?)");
836             }
837              
838             sub brik_name {
839 0     0 1   my $self = shift;
840              
841 0           my $module = lc($self->brik_class);
842 0           $module =~ s/^metabrik:://;
843              
844 0           return $module;
845             }
846              
847             sub brik_class {
848 0     0 1   my $self = shift;
849              
850 0   0       return ref($self) || $self;
851             }
852              
853             sub brik_classes {
854 0     0 1   my $self = shift;
855              
856 0           my $class = $self->brik_class;
857 0           my $ary = [ $class ];
858 0           $class->cgGetIsaTree($ary);
859              
860 0           my @classes = ();
861              
862 0           for my $class (@$ary) {
863             # We may have Metabrik subclasses from other stuff than Metabrik
864 0 0         next if ($class !~ /^Metabrik/);
865 0           push @classes, $class;
866             }
867              
868 0           return [ reverse @classes ];
869             }
870              
871             sub brik_tags {
872 0     0 1   my $self = shift;
873              
874 0           my $tags = $self->brik_properties->{tags};
875              
876 0           my $brik_name = $self->brik_name;
877 0           my @auto_tags = split(/::/, $brik_name);
878              
879 0           my %uniq = map { $_ => 1 } (@auto_tags, @$tags);
  0            
880              
881 0           return [ sort { $a cmp $b } keys %uniq ];
  0            
882             }
883              
884             sub brik_has_tag {
885 0     0 1   my $self = shift;
886 0           my ($tag) = @_;
887              
888 0 0         if (! defined($tag)) {
889 0           return $self->log->error($self->brik_help_run('brik_has_tag'));
890             }
891              
892 0           my %h = map { $_ => 1 } @{$self->brik_tags};
  0            
  0            
893              
894 0 0         if (exists($h{$tag})) {
895 0           return 1;
896             }
897              
898 0           return 0;
899             }
900              
901             # Will return all Commands, base, inherited, and own ones.
902             sub brik_commands {
903 0     0 1   my $self = shift;
904              
905 0           my $commands = { };
906              
907 0           my $classes = $self->brik_classes;
908              
909 0           for my $class (@$classes) {
910             #$self->log->info("brik_commands: class[$class]");
911              
912 0 0         if (exists($class->brik_properties->{commands})) {
913 0           for my $command (keys %{$class->brik_properties->{commands}}) {
  0            
914 0 0         next unless $command =~ /^[a-z]/; # Brik Commands always begin with a minuscule
915 0 0         next if $command =~ /^cg[A-Z]/; # Class::Gomor stuff
916 0 0         next if $command =~ /^_/; # Internal stuff
917 0 0         next if $command =~ /^(?:a|b|import|new|SUPER::|BEGIN|isa|can|EXPORT|AA|AS|ISA|DESTROY|__ANON__)$/; # Perl stuff
918              
919             #$self->log->info("command[$command]");
920              
921 0           $commands->{$command} = $class->brik_properties->{commands}->{$command};
922             }
923             }
924             }
925              
926 0           return $commands;
927             }
928              
929             # Will return only base Commands
930             sub brik_base_commands {
931 0     0 1   my $self = shift;
932              
933 0           my $commands = { };
934              
935 0           for my $command (keys %{Metabrik->brik_properties->{commands}}) {
  0            
936 0 0         next unless $command =~ /^[a-z]/; # Brik Commands always begin with a minuscule
937 0 0         next if $command =~ /^cg[A-Z]/; # Class::Gomor stuff
938 0 0         next if $command =~ /^_/; # Internal stuff
939 0 0         next if $command =~ /^(?:a|b|import|new|SUPER::|BEGIN|isa|can|EXPORT|AA|AS|ISA|DESTROY|__ANON__)$/; # Perl stuff
940              
941             #$self->log->info("command[$command]");
942              
943 0           $commands->{$command} = Metabrik->brik_properties->{commands}->{$command};
944             }
945              
946 0           return $commands;
947             }
948              
949             # Will return only inherited Commands
950             sub brik_inherited_commands {
951 0     0 1   my $self = shift;
952              
953 0           my $commands = { };
954              
955 0           my $classes = $self->brik_classes;
956 0           my $own_class = ref($self);
957              
958 0           for my $class (@$classes) {
959 0 0         next if $class eq 'Metabrik'; # Skip base class Commands
960 0 0         next if $class eq $own_class; # Skip own class Commands
961 0 0         if (exists($class->brik_properties->{commands})) {
962 0           for my $command (keys %{$class->brik_properties->{commands}}) {
  0            
963 0 0         next unless $command =~ /^[a-z]/; # Brik Commands always begin with a minuscule
964 0 0         next if $command =~ /^cg[A-Z]/; # Class::Gomor stuff
965 0 0         next if $command =~ /^_/; # Internal stuff
966 0 0         next if $command =~ /^(?:a|b|import|new|SUPER::|BEGIN|isa|can|EXPORT|AA|AS|ISA|DESTROY|__ANON__)$/; # Perl stuff
967              
968 0           $commands->{$command} = $class->brik_properties->{commands}->{$command};
969             }
970             }
971             }
972              
973 0           return $commands;
974             }
975              
976             # Will return only own Commands
977             sub brik_own_commands {
978 0     0 1   my $self = shift;
979              
980 0           my $commands = { };
981              
982 0 0         if (exists($self->brik_properties->{commands})) {
983 0           for my $command (keys %{$self->brik_properties->{commands}}) {
  0            
984 0 0         next unless $command =~ /^[a-z]/; # Brik Commands always begin with a minuscule
985 0 0         next if $command =~ /^cg[A-Z]/; # Class::Gomor stuff
986 0 0         next if $command =~ /^_/; # Internal stuff
987 0 0         next if $command =~ /^(?:a|b|import|new|SUPER::|BEGIN|isa|can|EXPORT|AA|AS|ISA|DESTROY|__ANON__)$/; # Perl stuff
988              
989             #$self->log->info("command[$command]");
990              
991 0           $commands->{$command} = $self->brik_properties->{commands}->{$command};
992             }
993             }
994              
995 0           return $commands;
996             }
997              
998             sub brik_has_command {
999 0     0 1   my $self = shift;
1000 0           my ($command) = @_;
1001              
1002 0 0         if (! defined($command)) {
1003 0           return $self->log->error($self->brik_help_run('brik_has_command'));
1004             }
1005              
1006 0 0         if (exists($self->brik_commands->{$command})) {
1007 0           return 1;
1008             }
1009              
1010 0           return 0;
1011             }
1012              
1013             # Will return all Attributes, base, inherited, and own ones.
1014             sub brik_attributes {
1015 0     0 1   my $self = shift;
1016              
1017 0           my $attributes = { };
1018              
1019 0           my $classes = $self->brik_classes;
1020              
1021 0           for my $class (@$classes) {
1022             #$self->log->info("brik_attributes: class[$class]");
1023              
1024 0 0         if (exists($class->brik_properties->{attributes})) {
1025 0           for my $attribute (keys %{$class->brik_properties->{attributes}}) {
  0            
1026 0 0         next unless $attribute =~ /^[a-z]/; # Brik Attributes always begin with a minuscule
1027 0 0         next if $attribute =~ /^_/; # Internal stuff
1028              
1029 0           $attributes->{$attribute} = $class->brik_properties->{attributes}->{$attribute};
1030             }
1031             }
1032             }
1033              
1034 0           return $attributes;
1035             }
1036              
1037             # Will return only base Attributes
1038             sub brik_base_attributes {
1039 0     0 1   my $self = shift;
1040              
1041 0           my $attributes = { };
1042              
1043 0           for my $attribute (keys %{Metabrik->brik_properties->{attributes}}) {
  0            
1044 0 0         next unless $attribute =~ /^[a-z]/; # Brik Attributes always begin with a minuscule
1045 0 0         next if $attribute =~ /^_/; # Internal stuff
1046              
1047 0           $attributes->{$attribute} = Metabrik->brik_properties->{attributes}->{$attribute};
1048             }
1049              
1050 0           return $attributes;
1051             }
1052              
1053             # Will return only inherited Attributes
1054             sub brik_inherited_attributes {
1055 0     0 1   my $self = shift;
1056              
1057 0           my $attributes = { };
1058              
1059 0           my $classes = $self->brik_classes;
1060 0           my $own_class = ref($self);
1061              
1062 0           for my $class (@$classes) {
1063 0 0         next if $class eq 'Metabrik'; # Skip base class Attributes
1064 0 0         next if $class eq $own_class; # Skip own class Attributes
1065 0 0         if (exists($class->brik_properties->{attributes})) {
1066 0           for my $attribute (keys %{$class->brik_properties->{attributes}}) {
  0            
1067 0 0         next unless $attribute =~ /^[a-z]/; # Brik Attributes always begin with a minuscule
1068 0 0         next if $attribute =~ /^_/; # Internal stuff
1069              
1070 0           $attributes->{$attribute} = $class->brik_properties->{attributes}->{$attribute};
1071             }
1072             }
1073             }
1074              
1075 0           return $attributes;
1076             }
1077              
1078             # Will return only own Attributes
1079             sub brik_own_attributes {
1080 0     0 1   my $self = shift;
1081              
1082 0           my $attributes = { };
1083              
1084 0 0         if (exists($self->brik_properties->{attributes})) {
1085 0           for my $attribute (keys %{$self->brik_properties->{attributes}}) {
  0            
1086 0 0         next unless $attribute =~ /^[a-z]/; # Brik Attributes always begin with a minuscule
1087 0 0         next if $attribute =~ /^_/; # Internal stuff
1088              
1089 0           $attributes->{$attribute} = $self->brik_properties->{attributes}->{$attribute};
1090             }
1091             }
1092              
1093 0           return $attributes;
1094             }
1095              
1096             sub brik_has_attribute {
1097 0     0 1   my $self = shift;
1098 0           my ($attribute) = @_;
1099              
1100 0 0         if (! defined($attribute)) {
1101 0           return $self->log->error($self->brik_help_run('brik_has_attribute'));
1102             }
1103              
1104 0 0         if (exists($self->brik_attributes->{$attribute})) {
1105 0           return 1;
1106             }
1107              
1108 0           return 0;
1109             }
1110              
1111             sub brik_has_module {
1112 0     0 1   my $self = shift;
1113 0           my ($module) = @_;
1114              
1115 0 0         if (! defined($module)) {
1116 0           return $self->log->error($self->brik_help_run('brik_has_module'));
1117             }
1118              
1119 0           eval("require $module;");
1120 0 0         if ($@) {
1121 0           return 0;
1122             }
1123              
1124 0           return 1;
1125             }
1126              
1127             sub brik_has_binary {
1128 0     0 1   my $self = shift;
1129 0           my ($binary) = @_;
1130              
1131 0 0         if (! defined($binary)) {
1132 0           return $self->log->error($self->brik_help_run('brik_has_binary'));
1133             }
1134              
1135 0           my @path = split(':', $ENV{PATH});
1136 0           for my $path (@path) {
1137 0 0         if (-f "$path/$binary") {
1138 0           return 1;
1139             }
1140             }
1141              
1142 0           return 0;
1143             }
1144              
1145             # brik_preinit() directly runs after new() is run. new() is called on use().
1146             sub brik_preinit {
1147 0     0 1   my $self = shift;
1148              
1149             # Do it once.
1150 0 0         return $self if $self->preinit_done;
1151              
1152 0           my $r = $self->brik_set_default_attributes;
1153 0 0         if (! defined($r)) {
1154 0           return $self->log->error("brik_preinit: brik_set_default_attributes failed");
1155             }
1156              
1157             # We have to put it here, cause brik_use_properties method is called, and
1158             # we want some default attributes to be set defore that (datadir special case)
1159             # brik_preinit method is called by new(), so no problem, it will be checked.
1160 0           $r = $self->brik_checks;
1161 0 0         if (! defined($r)) {
1162 0           return $self->log->error("brik_preinit: brik_checks failed");
1163             }
1164              
1165             # Now, we can set default Attributes from brik_use_properties, all brik_properties
1166             # Attributes should be inited with defaults.
1167 0           $r = $self->brik_set_use_default_attributes;
1168 0 0         if (! defined($r)) {
1169 0           return $self->log->error("brik_preinit: brik_set_use_default_attributes failed");
1170             }
1171              
1172 0           $self->preinit_done(1);
1173              
1174 0           return $self;
1175             }
1176              
1177             sub brik_preinit_no_checks {
1178 0     0 1   my $self = shift;
1179              
1180             # Do it once.
1181 0 0         return $self if $self->preinit_done;
1182              
1183 0           my $r = $self->brik_set_default_attributes;
1184 0 0         if (! defined($r)) {
1185 0           return $self->log->error("brik_preinit: brik_set_default_attributes failed");
1186             }
1187              
1188             # Now, we can set default Attributes from brik_use_properties, all brik_properties
1189             # Attributes should be inited with defaults.
1190 0           $r = $self->brik_set_use_default_attributes;
1191 0 0         if (! defined($r)) {
1192 0           return $self->log->error("brik_preinit: brik_set_use_default_attributes failed");
1193             }
1194              
1195 0           $self->preinit_done(1);
1196              
1197 0           return $self;
1198             }
1199              
1200             sub brik_init {
1201 0     0 1   my $self = shift;
1202              
1203 0           return $self->init_done(1);
1204             }
1205              
1206             sub brik_init_no_checks {
1207 0     0 1   my $self = shift;
1208              
1209 0           return $self->init_done(1);
1210             }
1211              
1212             sub brik_self {
1213 0     0 1   my $self = shift;
1214              
1215 0           return $self;
1216             }
1217              
1218             # brik_fini Command is run when core::shell run_exit Command is called
1219             # It itselves call core::context brik_fini Command which loops over all used Briks
1220             sub brik_fini {
1221 0     0 1   my $self = shift;
1222              
1223 0           return $self;
1224             }
1225              
1226             sub brik_help_run_undef_arg {
1227 0     0 1   my $self = shift;
1228 0           my ($command, $argument) = @_;
1229              
1230 0           my ($package, $filename, $line) = caller();
1231 0           my $brik = lc($package);
1232 0           $brik =~ s/^metabrik:://;
1233              
1234 0 0         if (! defined($argument)) {
1235 0           return $self->log->error("$brik: ".$self->brik_help_run($command));
1236             }
1237              
1238 0           return 1;
1239             }
1240              
1241             sub brik_help_set_undef_arg {
1242 0     0 1   my $self = shift;
1243 0           my ($command, $argument) = @_;
1244              
1245 0           my ($package, $filename, $line) = caller();
1246 0           my $brik = lc($package);
1247 0           $brik =~ s/^metabrik:://;
1248              
1249 0 0         if (! defined($argument)) {
1250 0           return $self->log->error("$brik: ".$self->brik_help_set($command));
1251             }
1252              
1253 0           return 1;
1254             }
1255              
1256             sub brik_help_run_invalid_arg {
1257 0     0 1   my $self = shift;
1258 0           my ($command, $argument, @values) = @_;
1259              
1260 0           my ($package, $filename, $line) = caller();
1261 0           my $brik = lc($package);
1262 0           $brik =~ s/^metabrik:://;
1263              
1264 0   0       my $ref = ref($argument) || 'SCALAR';
1265 0           my $values = { map { $_ => 1 } @values };
  0            
1266 0 0         if (! exists($values->{$ref})) {
1267 0           my $ok = join(', ', @values);
1268 0           return $self->log->error("$brik: $command: invalid Argument [$argument], must be from [$ok]");
1269             }
1270              
1271 0           return $ref;
1272             }
1273              
1274             sub brik_help_run_empty_array_arg {
1275 0     0 1   my $self = shift;
1276 0           my ($command, $argument) = @_;
1277              
1278 0           my ($package, $filename, $line) = caller();
1279 0           my $brik = lc($package);
1280 0           $brik =~ s/^metabrik:://;
1281              
1282 0 0         if (ref($argument) ne 'ARRAY') {
1283 0           return $self->log->error("$brik: $command: Argument [$argument] is not an ARRAY");
1284             }
1285              
1286 0 0         if (@$argument <= 0) {
1287 0           return $self->log->error("$brik: $command: ARRAY Argument [$argument] is empty");
1288             }
1289              
1290 0           return 1;
1291             }
1292              
1293             sub brik_help_run_file_not_found {
1294 0     0 1   my $self = shift;
1295 0           my ($command, $argument) = @_;
1296              
1297 0           my ($package, $filename, $line) = caller();
1298 0           my $brik = lc($package);
1299 0           $brik =~ s/^metabrik:://;
1300              
1301 0 0         if (! -f $argument) {
1302 0           return $self->log->error("$brik: $command: file Argument [$argument] not found");
1303             }
1304              
1305 0           return 1;
1306             }
1307              
1308             sub brik_help_run_directory_not_found {
1309 0     0 1   my $self = shift;
1310 0           my ($command, $argument) = @_;
1311              
1312 0           my ($package, $filename, $line) = caller();
1313 0           my $brik = lc($package);
1314 0           $brik =~ s/^metabrik:://;
1315              
1316 0 0         if (! -d $argument) {
1317 0           return $self->log->error("$brik: $command: directory Argument [$argument] not found");
1318             }
1319              
1320 0           return 1;
1321             }
1322              
1323             sub brik_help_run_must_be_root {
1324 0     0 1   my $self = shift;
1325 0           my ($command) = @_;
1326              
1327 0           my ($package, $filename, $line) = caller();
1328 0           my $brik = lc($package);
1329 0           $brik =~ s/^metabrik:://;
1330              
1331 0 0         if ($< != 0) {
1332 0           return $self->log->error("$brik: $command: must be root to run Command [$command]");
1333             }
1334              
1335 0           return 1;
1336             }
1337              
1338             1;
1339              
1340             __END__