our
$VERSION
=
'1.26'
;
our
$FIX
=
'0'
;
our
@AS
=
qw(
debug
init_done
preinit_done
check_use_properties_done
context
global
log
shell
)
;
__PACKAGE__->cgBuildAccessorsScalar(\
@AS
);
sub
brik_version {
my
$self
=
shift
;
my
$revision
=
$self
->brik_properties->{revision};
$revision
=~ s/^.*\s([a-f0-9]+)\s.*$/$1/;
return
$VERSION
.
'.'
.
$FIX
.
'-'
.
$revision
;
}
sub
brik_author {
my
$self
=
shift
;
my
$author
=
$self
->brik_properties->{author};
return
$author
||
'GomoR <GomoR[at]metabrik.org>'
;
}
sub
brik_license {
my
$self
=
shift
;
my
$license
=
$self
->brik_properties->{license};
}
sub
brik_properties {
return
{
revision
=>
'$Revision: 3592d9fef98d $'
,
author
=>
'GomoR <GomoR[at]metabrik.org>'
,
tags
=> [ ],
attributes
=> {
debug
=> [
qw(0|1)
],
init_done
=> [
qw(0|1)
],
context
=> [
qw(core::context)
],
global
=> [
qw(core::global)
],
log
=> [
qw(core::log)
],
shell
=> [
qw(core::shell)
],
},
attributes_default
=> {
debug
=> 0,
init_done
=> 0,
},
commands
=> {
brik_version
=> [ ],
brik_author
=> [ ],
brik_license
=> [ ],
brik_help_set
=> [
qw(Attribute)
],
brik_help_run
=> [
qw(Command)
],
brik_class
=> [ ],
brik_classes
=> [ ],
brik_name
=> [ ],
brik_repository
=> [ ],
brik_category
=> [ ],
brik_tags
=> [ ],
brik_has_tag
=> [
qw(Tag)
],
brik_commands
=> [ ],
brik_base_commands
=> [ ],
brik_inherited_commands
=> [ ],
brik_own_commands
=> [ ],
brik_has_command
=> [
qw(Command)
],
brik_attributes
=> [ ],
brik_base_attributes
=> [ ],
brik_inherited_attributes
=> [ ],
brik_own_attributes
=> [ ],
brik_has_attribute
=> [
qw(Attribute)
],
brik_preinit
=> [
qw(Arguments)
],
brik_preinit_no_checks
=> [
qw(Arguments)
],
brik_init
=> [
qw(Arguments)
],
brik_init_no_checks
=> [
qw(Arguments)
],
brik_self
=> [ ],
brik_fini
=> [
qw(Arguments)
],
brik_create_attributes
=> [ ],
brik_set_default_attributes
=> [ ],
brik_check_require_modules
=> [ ],
brik_check_require_binaries
=> [ ],
brik_check_properties
=> [ ],
brik_check_use_properties
=> [ ],
brik_checks
=> [ ],
brik_has_binary
=> [
qw(binary)
],
brik_has_module
=> [
qw(module)
],
brik_help_run_undef_arg
=> [
qw(Command Arg)
],
brik_help_set_undef_arg
=> [
qw(Command Arg)
],
brik_help_run_invalid_arg
=> [
qw(Command Arg valid_list)
],
brik_help_run_empty_array_arg
=> [
qw(Command Arg)
],
brik_help_run_file_not_found
=> [
qw(Command Arg)
],
brik_help_run_directory_not_found
=> [
qw(Command Arg)
],
brik_help_run_must_be_root
=> [
qw(Command)
],
},
require_modules
=> { },
optional_modules
=> { },
require_binaries
=> { },
optional_binaries
=> { },
need_packages
=> { },
need_services
=> { },
};
}
sub
brik_use_properties {
return
{ };
}
sub
brik_help_set {
my
$self
=
shift
;
my
(
$attribute
) =
@_
;
my
$name
=
$self
->brik_name;
if
(!
defined
(
$attribute
)) {
return
$self
->_log_info(
"run $name brik_help_set <attribute>"
);
}
my
$classes
=
$self
->brik_classes;
for
my
$class
(
reverse
@$classes
) {
my
$attributes
=
$class
->brik_attributes;
if
(
exists
(
$attributes
->{
$attribute
})) {
my
$help
=
sprintf
(
"%s "
,
$attribute
);
for
(@{
$attributes
->{
$attribute
}}) {
$help
.=
"<$_> "
;
}
return
$help
;
}
}
return
;
}
sub
brik_help_run {
my
$self
=
shift
;
my
(
$command
) =
@_
;
my
$name
=
$self
->brik_name;
if
(!
defined
(
$command
)) {
return
$self
->_log_info(
"run $name brik_help_run <command>"
);
}
my
$classes
=
$self
->brik_classes;
for
my
$class
(
reverse
@$classes
) {
my
$commands
=
$class
->brik_commands;
if
(
exists
(
$commands
->{
$command
})) {
my
$help
=
sprintf
(
"%s "
,
$command
);
for
(@{
$commands
->{
$command
}}) {
if
(m{\|OPTIONAL}) {
s/\|OPTIONAL\s*$//;
$help
.=
"[ <$_> ] "
;
}
else
{
$help
.=
"<$_> "
;
}
}
return
$help
;
}
}
return
;
}
sub
_msg {
my
$self
=
shift
;
my
(
$class
,
$msg
) =
@_
;
$msg
||=
'undef'
;
$class
=
lc
(
$class
);
$class
=~ s/^metabrik:://i;
return
lc
(
$class
).
": $msg"
;
}
sub
_log_info {
my
$self
=
shift
;
my
(
$msg
) =
@_
;
chomp
(
$msg
);
if
(
ref
(
$self
) &&
defined
(
$self
->{
log
})) {
$self
->
log
->info(
$msg
);
}
else
{
print
(
"[+] $msg\n"
);
}
return
1;
}
sub
_log_error {
my
$self
=
shift
;
my
(
$msg
) =
@_
;
chomp
(
$msg
);
my
$class
=
$self
->brik_class;
if
(
ref
(
$self
) &&
defined
(
$self
->{
log
})) {
return
$self
->
log
->error(
$msg
,
$class
);
}
else
{
my
$str
=
$self
->_msg(
$class
,
$msg
);
print
"[-] $str\n"
;
}
return
;
}
sub
_log_fatal {
my
$self
=
shift
;
my
(
$msg
) =
@_
;
chomp
(
$msg
);
my
$class
=
$self
->brik_class;
if
(
ref
(
$self
) &&
defined
(
$self
->{
log
})) {
return
$self
->
log
->fatal(
$msg
,
$class
);
}
else
{
my
$str
=
$self
->_msg(
$class
,
$msg
);
die
(
"[F] $str\n"
);
}
return
;
}
sub
_log_warning {
my
$self
=
shift
;
my
(
$msg
) =
@_
;
chomp
(
$msg
);
my
$class
=
$self
->brik_class;
if
(
ref
(
$self
) &&
defined
(
$self
->{
log
})) {
return
$self
->
log
->warning(
$msg
,
$class
);
}
else
{
my
$str
=
$self
->_msg(
$class
,
$msg
);
print
(
"[!] $str\n"
);
}
return
1;
}
sub
_log_verbose {
my
$self
=
shift
;
my
(
$msg
) =
@_
;
chomp
(
$msg
);
my
$class
=
$self
->brik_class;
if
(
ref
(
$self
) &&
defined
(
$self
->{
log
})) {
return
$self
->
log
->verbose(
$msg
,
$class
);
}
else
{
my
$str
=
$self
->_msg(
$class
,
$msg
);
print
(
"[*] $str\n"
);
}
return
1;
}
sub
_log_debug {
my
$self
=
shift
;
my
(
$msg
) =
@_
;
if
(!
$self
->debug) {
return
1;
}
chomp
(
$msg
);
my
$class
=
$self
->brik_class;
if
(
ref
(
$self
) &&
defined
(
$self
->{
log
})) {
return
$self
->
log
->debug(
$msg
,
$class
);
}
else
{
my
$str
=
$self
->_msg(
$class
,
$msg
);
print
(
"[D] $str\n"
);
}
return
1;
}
sub
brik_check_properties {
my
$self
=
shift
;
my
(
$properties
) =
@_
;
my
$name
=
$self
->brik_name;
if
(!
$self
->can(
'brik_properties'
)) {
return
$self
->_log_error(
"brik_check_properties: Brik [$name] has no brik_properties"
);
}
$properties
||=
$self
->brik_properties;
my
$error
= 0;
my
@mandatory_keys
=
qw(
tags
)
;
for
my
$key
(
@mandatory_keys
) {
if
(!
exists
(
$properties
->{
$key
})) {
print
(
"[-] brik_check_properties: Brik [$name]: brik_properties lacks mandatory key [$key]\n"
);
$error
++;
}
}
my
%valid_keys
= (
revision
=> 1,
author
=> 1,
license
=> 1,
tags
=> 1,
attributes
=> 1,
attributes_default
=> 1,
commands
=> 1,
require_modules
=> 1,
optional_modules
=> 1,
require_binaries
=> 1,
optional_binaries
=> 1,
need_packages
=> 1,
need_services
=> 1,
);
for
my
$key
(
keys
%$properties
) {
if
(!
exists
(
$valid_keys
{
$key
})) {
print
(
"[-] brik_check_properties: brik_properties has invalid key [$key]\n"
);
$error
++;
}
elsif
(
$key
eq
'tags'
&&
ref
(
$properties
->{
$key
}) ne
'ARRAY'
) {
print
(
"[-] brik_check_properties: brik_properties with key [$key] is not an ARRAYREF\n"
);
$error
++;
}
elsif
(
$key
ne
'revision'
&&
$key
ne
'author'
&&
$key
ne
'license'
&&
$key
ne
'tags'
&&
ref
(
$properties
->{
$key
}) ne
'HASH'
) {
print
(
"[-] brik_check_properties: brik_properties with key [$key] is not a HASHREF\n"
);
$error
++;
}
}
for
my
$key
(
keys
%$properties
) {
next
if
(
$key
eq
'revision'
||
$key
eq
'author'
||
$key
eq
'license'
||
$key
eq
'tags'
||
$key
eq
'attributes_default'
);
for
my
$subkey
(
keys
%{
$properties
->{
$key
}}) {
if
(
ref
(
$properties
->{
$key
}->{
$subkey
}) ne
'ARRAY'
) {
print
(
"[-] brik_check_properties: brik_properties with key [$key] and subkey [$subkey] is not an ARRAYREF\n"
);
$error
++;
}
}
}
if
(
$error
) {
print
(
"[-] brik_check_properties: Brik [$name] has invalid properties ($error error(s) found)\n"
);
return
0;
}
return
1;
}
sub
brik_check_use_properties {
my
$self
=
shift
;
my
(
$use_properties
) =
@_
;
return
1
if
$self
->check_use_properties_done;
my
$name
=
$self
->brik_name;
if
(!
$self
->can(
'brik_use_properties'
)) {
return
1;
}
$use_properties
||=
$self
->brik_use_properties;
my
$error
= 0;
my
@mandatory_keys
=
qw(
)
;
for
my
$key
(
@mandatory_keys
) {
if
(!
exists
(
$use_properties
->{
$key
})) {
print
(
"[-] brik_check_use_properties: Brik [$name]: brik_use_properties lacks mandatory key [$key]\n"
);
$error
++;
}
}
my
%valid_keys
= (
revision
=> 1,
author
=> 1,
license
=> 1,
tags
=> 1,
attributes
=> 1,
attributes_default
=> 1,
commands
=> 1,
require_modules
=> 1,
optional_modules
=> 1,
require_binaries
=> 1,
optional_binaries
=> 1,
need_packages
=> 1,
need_services
=> 1,
);
for
my
$key
(
keys
%$use_properties
) {
if
(!
exists
(
$valid_keys
{
$key
})) {
print
(
"[-] brik_check_use_properties: brik_use_properties has invalid key [$key]\n"
);
$error
++;
}
elsif
(
$key
eq
'tags'
&&
ref
(
$use_properties
->{
$key
}) ne
'ARRAY'
) {
print
(
"[-] brik_check_use_properties: brik_use_properties with key [$key] is not an ARRAYREF\n"
);
$error
++;
}
elsif
(
$key
ne
'revision'
&&
$key
ne
'author'
&&
$key
ne
'license'
&&
$key
ne
'tags'
&&
ref
(
$use_properties
->{
$key
}) ne
'HASH'
) {
print
(
"[-] brik_check_use_properties: brik_use_properties with key [$key] is not a HASHREF\n"
);
$error
++;
}
}
for
my
$key
(
keys
%$use_properties
) {
next
if
(
$key
eq
'revision'
||
$key
ne
'author'
&&
$key
ne
'license'
||
$key
eq
'tags'
||
$key
eq
'attributes_default'
);
for
my
$subkey
(
keys
%{
$use_properties
->{
$key
}}) {
if
(
ref
(
$use_properties
->{
$key
}->{
$subkey
}) ne
'ARRAY'
) {
print
(
"[-] brik_check_use_properties: brik_use_properties with key [$key] and subkey [$subkey] is not an ARRAYREF\n"
);
$error
++;
}
}
}
if
(
$error
) {
print
(
"[-] brik_check_use_properties: Brik [$name] has invalid properties ($error error(s) found)\n"
);
return
0;
}
$self
->check_use_properties_done(1);
return
1;
}
sub
brik_checks {
my
$self
=
shift
;
$self
->brik_check_properties or
return
;
$self
->brik_check_use_properties or
return
;
$self
->brik_check_require_modules or
return
;
$self
->brik_check_require_binaries or
return
;
return
$self
;
}
sub
new {
my
$self
=
shift
->SUPER::new(
@_
,
);
my
$r
=
$self
->brik_create_attributes;
if
(!
defined
(
$r
)) {
return
$self
->_log_error(
"new: brik_create_attributes failed"
);
}
return
$self
->brik_preinit;
}
sub
new_no_checks {
my
$self
=
shift
->SUPER::new(
@_
,
);
my
$r
=
$self
->brik_create_attributes;
if
(!
defined
(
$r
)) {
return
$self
->_log_error(
"new_no_checks: brik_create_attributes failed"
);
}
return
$self
->brik_preinit_no_checks;
}
sub
new_from_brik {
my
$self
=
shift
;
my
(
$brik
) =
@_
;
if
(!
defined
(
$brik
)) {
return
$self
->_log_error(
"new_from_brik: you must give a Brik object as argument"
);
}
my
$log
=
$brik
->
log
;
my
$glo
=
$brik
->global;
my
$con
=
$brik
->context;
my
$she
=
$brik
->shell;
if
(!
defined
(
$log
)) {
return
$self
->_log_error(
"new_from_brik: log Attribute is undef"
);
}
if
(!
defined
(
$glo
)) {
return
$self
->_log_error(
"new_from_brik: glo Attribute is undef"
);
}
if
(!
defined
(
$con
)) {
return
$self
->_log_error(
"new_from_brik: con Attribute is undef"
);
}
if
(!
defined
(
$she
)) {
return
$self
->_log_error(
"new_from_brik: she Attribute is undef"
);
}
return
$self
->new(
log
=>
$log
,
global
=>
$glo
,
context
=>
$con
,
shell
=>
$she
,
);
}
sub
new_from_brik_no_checks {
my
$self
=
shift
;
my
(
$brik
) =
@_
;
if
(!
defined
(
$brik
)) {
return
$self
->_log_error(
"new_from_brik_no_checks: you must give a Brik object as argument"
);
}
my
$log
=
$brik
->
log
;
my
$glo
=
$brik
->global;
my
$con
=
$brik
->context;
my
$she
=
$brik
->shell;
if
(!
defined
(
$log
)) {
return
$self
->_log_error(
"new_from_brik_no_checks: log Attribute is undef"
);
}
if
(!
defined
(
$glo
)) {
return
$self
->_log_error(
"new_from_brik_no_checks: glo Attribute is undef"
);
}
if
(!
defined
(
$con
)) {
return
$self
->_log_error(
"new_from_brik_no_checks: con Attribute is undef"
);
}
if
(!
defined
(
$she
)) {
return
$self
->_log_error(
"new_from_brik_no_checks: she Attribute is undef"
);
}
return
$self
->new_no_checks(
log
=>
$log
,
global
=>
$glo
,
context
=>
$con
,
shell
=>
$she
,
);
}
sub
new_from_brik_init {
my
$self
=
shift
;
my
$brik
=
$self
->new_from_brik(
@_
)
or
return
$self
->_log_error(
"new_from_brik_init: new_from_brik failed"
);
$brik
->brik_init
or
return
$self
->_log_error(
"new_from_brik_init: brik_init failed"
);
return
$brik
;
}
sub
new_from_brik_init_no_checks {
my
$self
=
shift
;
my
$brik
=
$self
->new_from_brik_no_checks(
@_
)
or
return
$self
->_log_error(
"new_from_brik_init_no_checks: new_from_brik_no_checks failed"
);
$brik
->brik_init_no_checks
or
return
$self
->_log_error(
"new_from_brik_init_no_checks: brik_init_no_checks failed"
);
return
$brik
;
}
sub
brik_create_attributes {
my
$self
=
shift
;
my
$classes
=
$self
->brik_classes;
for
my
$class
(
@$classes
) {
my
$attributes
=
$class
->brik_properties->{attributes};
my
@as
= (
keys
%$attributes
);
if
(
@as
> 0) {
no
strict
'refs'
;
my
%current
=
map
{
$_
=> 1 } @{
$class
.
'::AS'
};
my
@new
= ();
for
my
$this
(
@as
) {
if
(!
exists
(
$current
{
$this
})) {
push
@new
,
$this
;
}
}
push
@{
$class
.
'::AS'
},
@new
;
for
my
$this
(
@new
) {
if
(!
$class
->can(
$this
)) {
$class
->cgBuildAccessorsScalar([
$this
]);
}
}
}
}
return
1;
}
sub
brik_set_default_attributes {
my
$self
=
shift
;
my
$classes
=
$self
->brik_classes;
for
my
$class
(
@$classes
) {
if
(
exists
(
$class
->brik_properties->{attributes_default})) {
for
my
$attribute
(
keys
%{
$class
->brik_properties->{attributes_default}}) {
$self
->
$attribute
(
$class
->brik_properties->{attributes_default}->{
$attribute
});
}
}
}
my
$global
=
$self
->global;
if
(
defined
(
$global
)
&&
exists
(
$self
->brik_properties->{attributes})
&&
exists
(
$self
->brik_properties->{attributes}->{datadir})) {
my
$datadir
=
$self
->datadir;
my
$dir
;
if
(
defined
(
$datadir
)) {
$dir
=
$datadir
;
}
else
{
my
$global_datadir
=
$self
->global->datadir;
$dir
=
$global_datadir
;
(
my
$subdir
=
$self
->brik_name) =~ s/::/-/g;
if
(
length
(
$subdir
)) {
$dir
.=
'/'
.
$subdir
;
}
$self
->datadir(
$dir
);
}
if
(! -d
$dir
) {
mkdir
(
$dir
)
or
return
$self
->_log_error(
"brik_set_default_attributes: mkdir [$dir] failed: $!"
);
}
}
return
1;
}
sub
brik_set_use_default_attributes {
my
$self
=
shift
;
my
$class
=
$self
->brik_class;
if
(
$self
->can(
'brik_use_properties'
) &&
exists
(
$self
->brik_use_properties->{attributes_default})) {
for
my
$attribute
(
keys
%{
$self
->brik_use_properties->{attributes_default}}) {
next
if
exists
(
$class
->brik_properties->{attributes_default}->{
$attribute
});
$self
->
$attribute
(
$self
->brik_use_properties->{attributes_default}->{
$attribute
});
}
}
return
1;
}
sub
brik_check_require_modules {
my
$self
=
shift
;
my
(
$require_modules
) =
@_
;
my
@require_modules_list
= ();
if
(
defined
(
$require_modules
)) {
push
@require_modules_list
,
$require_modules
;
}
else
{
my
$classes
=
$self
->brik_classes;
for
my
$class
(
@$classes
) {
push
@require_modules_list
,
$class
->brik_properties->{require_modules};
}
}
my
$error
= 0;
for
my
$require_modules
(
@require_modules_list
) {
for
my
$module
(
keys
%$require_modules
) {
eval
(
"require $module;"
);
if
($@) {
chomp
($@);
$self
->_log_error(
"brik_check_require_modules: you have to install "
.
"module [$module]"
);
$self
->_log_debug(
"brik_check_require_modules: $@"
);
$error
++;
next
;
}
my
@imports
= @{
$require_modules
->{
$module
}};
if
(
@imports
> 0) {
eval
(
'$module->import(@imports);'
);
if
($@) {
chomp
($@);
$self
->_log_error(
"brik_check_require_modules: unable to import "
.
"functions [@imports] from module [$module]"
);
$self
->_log_debug(
"brik_check_require_modules: $@"
);
$error
++;
next
;
}
}
}
}
return
$error
? 0 : 1;
}
sub
brik_check_require_binaries {
my
$self
=
shift
;
my
(
$require_binaries
) =
@_
;
my
@require_binaries_list
= ();
if
(
defined
(
$require_binaries
)) {
push
@require_binaries_list
,
$require_binaries
;
}
else
{
my
$classes
=
$self
->brik_classes;
for
my
$class
(
@$classes
) {
push
@require_binaries_list
,
$class
->brik_properties->{require_binaries};
}
}
my
%binaries_found
= ();
for
my
$require_binaries
(
@require_binaries_list
) {
for
my
$binary
(
keys
%$require_binaries
) {
$binaries_found
{
$binary
} = 0;
my
@path
=
split
(
':'
,
$ENV
{PATH});
for
my
$path
(
@path
) {
if
(-f
"$path/$binary"
) {
$binaries_found
{
$binary
} = 1;
last
;
}
}
}
}
my
$error
= 0;
for
my
$binary
(
keys
%binaries_found
) {
if
(!
$binaries_found
{
$binary
}) {
$self
->_log_error(
"brik_check_require_binaries: binary [$binary] not found in PATH"
);
$error
++;
}
}
return
$error
? 0 : 1;
}
sub
brik_repository {
my
$self
=
shift
;
my
$name
=
$self
->brik_name;
my
@toks
=
split
(
'::'
,
$name
);
if
(
@toks
== 2) {
return
'main'
;
}
elsif
(
@toks
> 2) {
my
(
$repository
) =
$name
=~ /^(.*?)::.*/;
return
$repository
;
}
return
$self
->_log_fatal(
"brik_repository: no Repository found for Brik [$name] (invalid format?)"
);
}
sub
brik_category {
my
$self
=
shift
;
my
$name
=
$self
->brik_name;
my
@toks
=
split
(
'::'
,
$name
);
if
(
@toks
== 2) {
my
(
$category
) =
$name
=~ /^(.*?)::.*/;
return
$category
;
}
elsif
(
@toks
> 2) {
my
(
$category
) =
$name
=~ /^.*?::(.*?)::.*/;
return
$category
;
}
return
$self
->_log_fatal(
"brik_category: no Category found for Brik [$name] (invalid format?)"
);
}
sub
brik_name {
my
$self
=
shift
;
my
$module
=
lc
(
$self
->brik_class);
$module
=~ s/^metabrik:://;
return
$module
;
}
sub
brik_class {
my
$self
=
shift
;
return
ref
(
$self
) ||
$self
;
}
sub
brik_classes {
my
$self
=
shift
;
my
$class
=
$self
->brik_class;
my
$ary
= [
$class
];
$class
->cgGetIsaTree(
$ary
);
my
@classes
= ();
for
my
$class
(
@$ary
) {
next
if
(
$class
!~ /^Metabrik/);
push
@classes
,
$class
;
}
return
[
reverse
@classes
];
}
sub
brik_tags {
my
$self
=
shift
;
my
$tags
=
$self
->brik_properties->{tags};
my
$brik_name
=
$self
->brik_name;
my
@auto_tags
=
split
(/::/,
$brik_name
);
my
%uniq
=
map
{
$_
=> 1 } (
@auto_tags
,
@$tags
);
return
[
sort
{
$a
cmp
$b
}
keys
%uniq
];
}
sub
brik_has_tag {
my
$self
=
shift
;
my
(
$tag
) =
@_
;
if
(!
defined
(
$tag
)) {
return
$self
->_log_error(
$self
->brik_help_run(
'brik_has_tag'
));
}
my
%h
=
map
{
$_
=> 1 } @{
$self
->brik_tags};
if
(
exists
(
$h
{
$tag
})) {
return
1;
}
return
0;
}
sub
brik_commands {
my
$self
=
shift
;
my
$commands
= { };
my
$classes
=
$self
->brik_classes;
for
my
$class
(
@$classes
) {
if
(
exists
(
$class
->brik_properties->{commands})) {
for
my
$command
(
keys
%{
$class
->brik_properties->{commands}}) {
next
unless
$command
=~ /^[a-z]/;
next
if
$command
=~ /^cg[A-Z]/;
next
if
$command
=~ /^_/;
next
if
$command
=~ /^(?:a|b|
import
|new|SUPER::|BEGIN|isa|can|EXPORT|AA|AS|ISA|DESTROY|__ANON__)$/;
$commands
->{
$command
} =
$class
->brik_properties->{commands}->{
$command
};
}
}
}
return
$commands
;
}
sub
brik_base_commands {
my
$self
=
shift
;
my
$commands
= { };
for
my
$command
(
keys
%{Metabrik->brik_properties->{commands}}) {
next
unless
$command
=~ /^[a-z]/;
next
if
$command
=~ /^cg[A-Z]/;
next
if
$command
=~ /^_/;
next
if
$command
=~ /^(?:a|b|
import
|new|SUPER::|BEGIN|isa|can|EXPORT|AA|AS|ISA|DESTROY|__ANON__)$/;
$commands
->{
$command
} = Metabrik->brik_properties->{commands}->{
$command
};
}
return
$commands
;
}
sub
brik_inherited_commands {
my
$self
=
shift
;
my
$commands
= { };
my
$classes
=
$self
->brik_classes;
my
$own_class
=
ref
(
$self
);
for
my
$class
(
@$classes
) {
next
if
$class
eq
'Metabrik'
;
next
if
$class
eq
$own_class
;
if
(
exists
(
$class
->brik_properties->{commands})) {
for
my
$command
(
keys
%{
$class
->brik_properties->{commands}}) {
next
unless
$command
=~ /^[a-z]/;
next
if
$command
=~ /^cg[A-Z]/;
next
if
$command
=~ /^_/;
next
if
$command
=~ /^(?:a|b|
import
|new|SUPER::|BEGIN|isa|can|EXPORT|AA|AS|ISA|DESTROY|__ANON__)$/;
$commands
->{
$command
} =
$class
->brik_properties->{commands}->{
$command
};
}
}
}
return
$commands
;
}
sub
brik_own_commands {
my
$self
=
shift
;
my
$commands
= { };
if
(
exists
(
$self
->brik_properties->{commands})) {
for
my
$command
(
keys
%{
$self
->brik_properties->{commands}}) {
next
unless
$command
=~ /^[a-z]/;
next
if
$command
=~ /^cg[A-Z]/;
next
if
$command
=~ /^_/;
next
if
$command
=~ /^(?:a|b|
import
|new|SUPER::|BEGIN|isa|can|EXPORT|AA|AS|ISA|DESTROY|__ANON__)$/;
$commands
->{
$command
} =
$self
->brik_properties->{commands}->{
$command
};
}
}
return
$commands
;
}
sub
brik_has_command {
my
$self
=
shift
;
my
(
$command
) =
@_
;
if
(!
defined
(
$command
)) {
return
$self
->_log_error(
$self
->brik_help_run(
'brik_has_command'
));
}
if
(
exists
(
$self
->brik_commands->{
$command
})) {
return
1;
}
return
0;
}
sub
brik_attributes {
my
$self
=
shift
;
my
$attributes
= { };
my
$classes
=
$self
->brik_classes;
for
my
$class
(
@$classes
) {
if
(
exists
(
$class
->brik_properties->{attributes})) {
for
my
$attribute
(
keys
%{
$class
->brik_properties->{attributes}}) {
next
unless
$attribute
=~ /^[a-z]/;
next
if
$attribute
=~ /^_/;
$attributes
->{
$attribute
} =
$class
->brik_properties->{attributes}->{
$attribute
};
}
}
}
return
$attributes
;
}
sub
brik_base_attributes {
my
$self
=
shift
;
my
$attributes
= { };
for
my
$attribute
(
keys
%{Metabrik->brik_properties->{attributes}}) {
next
unless
$attribute
=~ /^[a-z]/;
next
if
$attribute
=~ /^_/;
$attributes
->{
$attribute
} = Metabrik->brik_properties->{attributes}->{
$attribute
};
}
return
$attributes
;
}
sub
brik_inherited_attributes {
my
$self
=
shift
;
my
$attributes
= { };
my
$classes
=
$self
->brik_classes;
my
$own_class
=
ref
(
$self
);
for
my
$class
(
@$classes
) {
next
if
$class
eq
'Metabrik'
;
next
if
$class
eq
$own_class
;
if
(
exists
(
$class
->brik_properties->{attributes})) {
for
my
$attribute
(
keys
%{
$class
->brik_properties->{attributes}}) {
next
unless
$attribute
=~ /^[a-z]/;
next
if
$attribute
=~ /^_/;
$attributes
->{
$attribute
} =
$class
->brik_properties->{attributes}->{
$attribute
};
}
}
}
return
$attributes
;
}
sub
brik_own_attributes {
my
$self
=
shift
;
my
$attributes
= { };
if
(
exists
(
$self
->brik_properties->{attributes})) {
for
my
$attribute
(
keys
%{
$self
->brik_properties->{attributes}}) {
next
unless
$attribute
=~ /^[a-z]/;
next
if
$attribute
=~ /^_/;
$attributes
->{
$attribute
} =
$self
->brik_properties->{attributes}->{
$attribute
};
}
}
return
$attributes
;
}
sub
brik_has_attribute {
my
$self
=
shift
;
my
(
$attribute
) =
@_
;
if
(!
defined
(
$attribute
)) {
return
$self
->_log_error(
$self
->brik_help_run(
'brik_has_attribute'
));
}
if
(
exists
(
$self
->brik_attributes->{
$attribute
})) {
return
1;
}
return
0;
}
sub
brik_has_module {
my
$self
=
shift
;
my
(
$module
) =
@_
;
if
(!
defined
(
$module
)) {
return
$self
->_log_error(
$self
->brik_help_run(
'brik_has_module'
));
}
eval
(
"require $module;"
);
if
($@) {
return
0;
}
return
1;
}
sub
brik_has_binary {
my
$self
=
shift
;
my
(
$binary
) =
@_
;
if
(!
defined
(
$binary
)) {
return
$self
->_log_error(
$self
->brik_help_run(
'brik_has_binary'
));
}
my
@path
=
split
(
':'
,
$ENV
{PATH});
for
my
$path
(
@path
) {
if
(-f
"$path/$binary"
) {
return
1;
}
}
return
0;
}
sub
brik_preinit {
my
$self
=
shift
;
return
$self
if
$self
->preinit_done;
my
$r
=
$self
->brik_set_default_attributes;
if
(!
defined
(
$r
)) {
return
$self
->_log_error(
"brik_preinit: brik_set_default_attributes failed"
);
}
$r
=
$self
->brik_checks;
if
(!
defined
(
$r
)) {
return
$self
->_log_error(
"brik_preinit: brik_checks failed"
);
}
$r
=
$self
->brik_set_use_default_attributes;
if
(!
defined
(
$r
)) {
return
$self
->_log_error(
"brik_preinit: brik_set_use_default_attributes failed"
);
}
$self
->preinit_done(1);
return
$self
;
}
sub
brik_preinit_no_checks {
my
$self
=
shift
;
return
$self
if
$self
->preinit_done;
my
$r
=
$self
->brik_set_default_attributes;
if
(!
defined
(
$r
)) {
return
$self
->_log_error(
"brik_preinit: brik_set_default_attributes failed"
);
}
$r
=
$self
->brik_set_use_default_attributes;
if
(!
defined
(
$r
)) {
return
$self
->_log_error(
"brik_preinit: brik_set_use_default_attributes failed"
);
}
$self
->preinit_done(1);
return
$self
;
}
sub
brik_init {
my
$self
=
shift
;
return
$self
->init_done(1);
}
sub
brik_init_no_checks {
my
$self
=
shift
;
return
$self
->init_done(1);
}
sub
brik_self {
my
$self
=
shift
;
return
$self
;
}
sub
brik_fini {
my
$self
=
shift
;
return
$self
;
}
sub
brik_help_run_undef_arg {
my
$self
=
shift
;
my
(
$command
,
$argument
) =
@_
;
my
(
$package
,
$filename
,
$line
) =
caller
();
my
$brik
=
lc
(
$package
);
$brik
=~ s/^metabrik:://;
if
(!
defined
(
$argument
)) {
return
$self
->
log
->error(
"$brik: "
.
$self
->brik_help_run(
$command
));
}
return
1;
}
sub
brik_help_set_undef_arg {
my
$self
=
shift
;
my
(
$command
,
$argument
) =
@_
;
my
(
$package
,
$filename
,
$line
) =
caller
();
my
$brik
=
lc
(
$package
);
$brik
=~ s/^metabrik:://;
if
(!
defined
(
$argument
)) {
return
$self
->
log
->error(
"$brik: "
.
$self
->brik_help_set(
$command
));
}
return
1;
}
sub
brik_help_run_invalid_arg {
my
$self
=
shift
;
my
(
$command
,
$argument
,
@values
) =
@_
;
my
(
$package
,
$filename
,
$line
) =
caller
();
my
$brik
=
lc
(
$package
);
$brik
=~ s/^metabrik:://;
my
$ref
=
ref
(
$argument
) ||
'SCALAR'
;
my
$values
= {
map
{
$_
=> 1 }
@values
};
if
(!
exists
(
$values
->{
$ref
})) {
my
$ok
=
join
(
', '
,
@values
);
return
$self
->
log
->error(
"$brik: $command: invalid Argument [$argument], must be from [$ok]"
);
}
return
$ref
;
}
sub
brik_help_run_empty_array_arg {
my
$self
=
shift
;
my
(
$command
,
$argument
) =
@_
;
my
(
$package
,
$filename
,
$line
) =
caller
();
my
$brik
=
lc
(
$package
);
$brik
=~ s/^metabrik:://;
if
(
ref
(
$argument
) ne
'ARRAY'
) {
return
$self
->
log
->error(
"$brik: $command: Argument [$argument] is not an ARRAY"
);
}
if
(
@$argument
<= 0) {
return
$self
->
log
->error(
"$brik: $command: ARRAY Argument [$argument] is empty"
);
}
return
1;
}
sub
brik_help_run_file_not_found {
my
$self
=
shift
;
my
(
$command
,
$argument
) =
@_
;
my
(
$package
,
$filename
,
$line
) =
caller
();
my
$brik
=
lc
(
$package
);
$brik
=~ s/^metabrik:://;
if
(! -f
$argument
) {
return
$self
->
log
->error(
"$brik: $command: file Argument [$argument] not found"
);
}
return
1;
}
sub
brik_help_run_directory_not_found {
my
$self
=
shift
;
my
(
$command
,
$argument
) =
@_
;
my
(
$package
,
$filename
,
$line
) =
caller
();
my
$brik
=
lc
(
$package
);
$brik
=~ s/^metabrik:://;
if
(! -d
$argument
) {
return
$self
->
log
->error(
"$brik: $command: directory Argument [$argument] not found"
);
}
return
1;
}
sub
brik_help_run_must_be_root {
my
$self
=
shift
;
my
(
$command
) =
@_
;
my
(
$package
,
$filename
,
$line
) =
caller
();
my
$brik
=
lc
(
$package
);
$brik
=~ s/^metabrik:://;
if
($< != 0) {
return
$self
->
log
->error(
"$brik: $command: must be root to run Command [$command]"
);
}
return
1;
}
1;