use
5.10.1;
binmode
STDOUT,
':encoding(UTF-8)'
;
my
%meta_cmd
= (
check
=> \
&check
,
dump
=> \
&dump_cds
,
'dump-yaml'
=> \
&dump_yaml
,
'gen-dot'
=> \
&gen_dot
,
edit
=> \
&edit
,
save
=> \
&save
,
plugin
=> \
&plugin
,
);
sub
validate_args {
my
(
$self
,
$opt
,
$args
) =
@_
;
my
$mc
=
$opt
->{
'_meta_command'
} =
shift
@$args
||
die
"please specify meta sub command\n"
;
if
(not
$meta_cmd
{
$mc
}) {
die
"Unexpected meta sub command: '$mc'. Expected "
.
join
(
' '
,
sort
keys
%meta_cmd
).
"\n"
;
}
my
(
$categories
,
$appli_info
,
$appli_map
) = Config::Model::Lister::available_models;
my
$application
=
shift
@$args
;
if
(
$mc
eq
'plugin'
) {
unless
(
$application
) {
die
"Missing application name after 'plugin' command"
;
}
$opt
->{_root_model} =
$appli_map
->{
$application
}
||
die
"Unknown application $application"
;
}
elsif
(
$application
) {
$opt
->{_root_model} =
$appli_map
->{
$application
} ||
$application
;
}
Config::Model::Exception::Any->Trace(1)
if
$opt
->{trace};
$opt
->{_application} =
$application
;
}
sub
opt_spec {
my
(
$class
,
$app
) =
@_
;
return
(
[
"dir=s"
=>
"directory where to read and write a model"
,
{
default
=>
'lib/Config/Model'
}
],
[
"dumptype=s"
=>
"dump every values (full), only preset values "
.
"or only customized values (default)"
,
{
callbacks
=> {
'expected values'
=>
sub
{
$_
[0] =~ m/^full|preset|custom$/ ; }}}
],
[
"dev!"
=>
'use model in ./lib to create a plugin'
],
[
"open-item=s"
=>
"force the UI to open the specified node"
],
[
"plugin-file=s"
=>
"create a model plugin in this file"
],
[
"load-yaml=s"
=>
"load model from YAML file"
],
[
"load=s"
=>
"load model from cds file (Config::Model serialisation file)"
],
[
"system!"
=>
"read model from system files"
],
[
"test-and-quit=s"
=>
"Used for tests"
],
$class
->cme_global_options()
);
}
sub
usage_desc {
my
(
$self
) =
@_
;
my
$desc
=
$self
->SUPER::usage_desc;
return
"$desc [ "
.
join
(
' | '
,
sort
keys
%meta_cmd
).
" ] your_model_class "
;
}
sub
description {
my
(
$self
) =
@_
;
return
$self
->get_documentation;
}
sub
read_data {
my
$load_file
=
shift
;
my
@data
;
if
(
$load_file
eq
'-'
) {
@data
= <STDIN> ;
}
else
{
open
my
$load
,
'<'
,
$load_file
||
die
"cannot open load file $load_file:$!"
;
@data
= <
$load
> ;
close
$load
;
}
return
wantarray
?
@data
:
join
(
''
,
@data
);
}
sub
load_optional_data {
my
(
$self
,
$args
,
$opt
,
$root_model
,
$meta_root
) =
@_
;
if
(
defined
$opt
->{load}) {
my
$data
= read_data(
$opt
->{load}) ;
$data
=
qq(class:"$root_model" )
.
$data
unless
$data
=~ /^\s
*class
:/ ;
$meta_root
->load(
$data
);
}
if
(
defined
$opt
->{
'load-yaml'
}) {
my
$yaml
= read_data(
$opt
->{
'load-yaml'
}) ;
my
$pdata
= Load(
$yaml
) ;
$meta_root
->load_data(
$pdata
) ;
}
}
sub
load_meta_model {
my
(
$self
,
$opt
,
$args
) =
@_
;
my
$root_model
=
$opt
->{_root_model};
my
$cm_lib_dir
= path(
split
m!/!,
$opt
->{dir}) ;
if
(!
$cm_lib_dir
->is_dir) {
$cm_lib_dir
->
mkdir
();
}
my
$meta_model
=
$self
->{meta_model} = Config::Model -> new();
my
$meta_inst
=
$meta_model
->instance(
root_class_name
=>
'Itself::Model'
,
instance_name
=>
'meta'
,
check
=>
$opt
->{
'force-load'
} ?
'no'
:
'yes'
,
);
my
$meta_root
=
$meta_inst
-> config_root ;
my
$system_cm_lib_dir
=
$INC
{
'Config/Model.pm'
} ;
$system_cm_lib_dir
=~ s/\.pm//;
return
(
$meta_inst
,
$meta_root
,
$cm_lib_dir
, path(
$system_cm_lib_dir
));
}
sub
load_meta_root {
my
(
$self
,
$opt
,
$args
) =
@_
;
my
(
$meta_inst
,
$meta_root
,
$cm_lib_dir
,
$system_cm_lib_dir
) =
$self
->load_meta_model(
$opt
,
$args
);
my
$root_model
=
$opt
->{_root_model};
say
"Reading model from $system_cm_lib_dir"
if
$opt
->
system
();
my
$rw_obj
= Config::Model::Itself -> new(
model_object
=>
$meta_root
,
cm_lib_dir
=>
$cm_lib_dir
->canonpath
);
$meta_inst
->initial_load_start ;
my
@read_args
= (
force_load
=>
$opt
->{
'force-load'
},
root_model
=>
$root_model
,
);
if
(
$opt
->
system
()) {
push
@read_args
,
application
=>
$opt
->{_application},
read_from
=>
$system_cm_lib_dir
;
}
$rw_obj
->read_all(
@read_args
);
$meta_inst
->initial_load_stop ;
$self
->load_optional_data(
$args
,
$opt
,
$root_model
,
$meta_root
) ;
my
$write_sub
=
sub
{
my
$wr_dir
=
shift
||
$cm_lib_dir
;
$rw_obj
->write_all( );
} ;
return
(
$rw_obj
,
$cm_lib_dir
,
$meta_root
,
$write_sub
);
}
sub
load_meta_plugin {
my
(
$self
,
$opt
,
$args
) =
@_
;
my
(
$meta_inst
,
$meta_root
,
$cm_lib_dir
,
$system_cm_lib_dir
) =
$self
->load_meta_model(
$opt
,
$args
);
my
$root_model
=
$opt
->{_root_model};
my
$meta_cm_lib_dir
=
$opt
->dev ?
$cm_lib_dir
:
$system_cm_lib_dir
;
my
$plugin_name
=
shift
@$args
or
die
"missing plugin file name after application name."
;
if
(
$plugin_name
=~ s/\.pl$//) {
warn
"removed '.pl' deprecated suffix from plugin name\n"
;
}
say
"Preparing plugin $plugin_name for model $root_model found in $meta_cm_lib_dir"
;
say
"Use -dev option to create a plugin for a local model (i.e. in $cm_lib_dir)"
unless
$opt
->dev;
my
$rw_obj
= Config::Model::Itself -> new(
model_object
=>
$meta_root
,
cm_lib_dir
=>
$meta_cm_lib_dir
->canonpath,
) ;
$meta_inst
->initial_load_start ;
$meta_inst
->layered_start;
$rw_obj
->read_all(
force_load
=>
$opt
->{
'force-load'
},
root_model
=>
$root_model
,
);
$meta_inst
->layered_stop;
$rw_obj
->read_model_plugin(
plugin_dir
=>
$cm_lib_dir
.
'/models/'
,
plugin_name
=>
$plugin_name
) ;
$meta_inst
->initial_load_stop ;
$self
->load_optional_data(
$args
,
$opt
,
$root_model
,
$meta_root
) ;
my
$root_model_dir
=
$root_model
;
$root_model_dir
=~ s!::!/!g;
my
$write_sub
=
sub
{
$rw_obj
->write_model_plugin(
plugin_dir
=>
"$cm_lib_dir/models/$root_model_dir.d"
,
plugin_name
=>
$plugin_name
);
} ;
return
(
$rw_obj
,
$cm_lib_dir
,
$meta_root
,
$write_sub
);
}
sub
execute {
my
(
$self
,
$opt
,
$args
) =
@_
;
my
$cmd_sub
=
$meta_cmd
{
$opt
->{_meta_command}};
$self
->
$cmd_sub
(
$opt
,
$args
);
}
sub
save {
my
(
$self
,
$opt
,
$args
) =
@_
;
my
(
$rw_obj
,
$cm_lib_dir
,
$meta_root
,
$write_sub
) =
$self
->load_meta_root(
$opt
,
$args
) ;
say
"Saving "
,
$rw_obj
->root_model.
' model'
. (
$opt
->dir ?
' in '
.
$opt
->dir :
''
);
&$write_sub
;
}
sub
gen_dot {
my
(
$self
,
$opt
,
$args
) =
@_
;
my
(
$rw_obj
,
$cm_lib_dir
,
$meta_root
,
$write_sub
) =
$self
->load_meta_root(
$opt
,
$args
) ;
my
$out
=
shift
@$args
||
"model.dot"
;
say
"Creating dot file $out"
;
path(
$out
) -> spew(
$rw_obj
->get_dot_diagram );
}
sub
check {
my
(
$self
,
$opt
,
$args
) =
@_
;
say
"loading model"
unless
$opt
->{quiet};
my
(
$rw_obj
,
$cm_lib_dir
,
$meta_root
,
$write_sub
) =
$self
->load_meta_root(
$opt
,
$args
) ;
Config::Model::ObjTreeScanner->new(
leaf_cb
=>
sub
{ } )->scan_node(
undef
,
$meta_root
);
say
"checking data"
unless
$opt
->{quiet};
$meta_root
->dump_tree(
mode
=>
'full'
);
say
"check done"
unless
$opt
->{quiet};
my
$ouch
=
$meta_root
->instance->has_warning;
if
(
$opt
->{strict} and
$ouch
) {
die
"Found $ouch warnings in strict mode\n"
;
}
}
sub
dump_cds {
my
(
$self
,
$opt
,
$args
) =
@_
;
my
(
$rw_obj
,
$cm_lib_dir
,
$meta_root
,
$write_sub
) =
$self
->load_meta_root(
$opt
,
$args
) ;
my
$dump_file
=
shift
@$args
||
'model.cds'
;
say
"Dumping "
.
$rw_obj
->root_model.
" in $dump_file"
;
my
$dump_string
=
$meta_root
->dump_tree(
mode
=>
$opt
->{dumptype} ||
'custom'
) ;
path(
$dump_file
)->spew_utf8(
$dump_string
);
}
sub
dump_yaml{
my
(
$self
,
$opt
,
$args
) =
@_
;
my
(
$rw_obj
,
$cm_lib_dir
,
$meta_root
,
$write_sub
) =
$self
->load_meta_root(
$opt
,
$args
) ;
my
$dump_file
=
shift
@$args
||
'model.yml'
;
say
"Dumping "
.
$rw_obj
->root_model.
" in $dump_file"
;
my
$dump_string
= Dump(
$meta_root
->dump_as_data(
ordered_hash_as_list
=> 0)) ;
path(
$dump_file
)->spew_utf8(
$dump_string
);
}
sub
plugin {
my
(
$self
,
$opt
,
$args
) =
@_
;
my
@info
=
$self
->load_meta_plugin(
$opt
,
$args
) ;
$self
->_edit(
$opt
,
$args
,
@info
);
}
sub
edit {
my
(
$self
,
$opt
,
$args
) =
@_
;
my
@info
=
$self
->load_meta_root(
$opt
,
$args
) ;
$self
->_edit(
$opt
,
$args
,
@info
);
}
sub
_edit {
my
(
$self
,
$opt
,
$args
,
$rw_obj
,
$cm_lib_dir
,
$meta_root
,
$write_sub
) =
@_
;
my
$root_model
=
$rw_obj
->root_model;
my
$mw
= MainWindow-> new;
$mw
->withdraw ;
$mw
->optionAdd(
'*BorderWidth'
=> 1);
my
$cmu
=
$mw
->ConfigModelEditUI(
-instance
=>
$meta_root
->instance,
-store_sub
=>
$write_sub
,
-model_name
=>
$root_model
,
-cm_lib_dir
=>
$cm_lib_dir
);
my
$open_item
=
$opt
->{
'open-item'
};
if
(
$root_model
and not
$meta_root
->fetch_element(
'class'
)->fetch_size) {
$open_item
||=
qq(class:"$root_model" )
;
}
else
{
$open_item
||=
'class'
;
}
my
$obj
=
$meta_root
->grab(
$open_item
) ;
$cmu
->
after
(10,
sub
{
$cmu
->force_element_display(
$obj
) });
if
(
my
$taq
=
$opt
->test_and_quit ) {
my
$bail_out
=
sub
{
warn
"save failed: $_[0]\n"
if
@_
;
$cmu
-> quit;
} ;
$cmu
->
after
( 2000 ,
sub
{
if
(
$taq
=~ /s/) {
say
"Test mode: save and quit"
;
$cmu
->save(
$bail_out
);
}
else
{
say
"Test mode: quit only"
;
&$bail_out
}
});
}
&MainLoop
;
say
"Exited GUI"
;
}
1;