File Coverage

blib/lib/App/Cme/Command/meta.pm
Criterion Covered Total %
statement 24 26 92.3
branch n/a
condition n/a
subroutine 9 9 100.0
pod n/a
total 33 35 94.2


line stmt bran cond sub pod time code
1             #
2             # This file is part of Config-Model-Itself
3             #
4             # This software is Copyright (c) 2007-2017 by Dominique Dumont.
5             #
6             # This is free software, licensed under:
7             #
8             # The GNU Lesser General Public License, Version 2.1, February 1999
9             #
10             # ABSTRACT: Work on the configuration model of an application
11              
12             package App::Cme::Command::meta ;
13             $App::Cme::Command::meta::VERSION = '2.012';
14 1     1   32937 use strict ;
  1         2  
  1         25  
15 1     1   4 use warnings ;
  1         2  
  1         19  
16 1     1   10 use 5.10.1;
  1         2  
17              
18 1     1   7 use App::Cme -command ;
  1         6  
  1         7  
19              
20 1     1   288 use base qw/App::Cme::Common/;
  1         3  
  1         99  
21              
22 1     1   6 use Config::Model 2.075;
  1         14  
  1         32  
23              
24 1     1   352 use Config::Model::Itself ;
  1         3  
  1         38  
25 1     1   393 use YAML::Tiny;
  1         4936  
  1         63  
26              
27 1     1   104 use Tk ;
  0            
  0            
28             use Config::Model::TkUI ;
29             use Config::Model::Itself::TkEditUI ;
30             use Path::Tiny ;
31              
32             my %meta_cmd = (
33             check => \&check,
34             dump => \&dump_cds,
35             'dump-yaml' => \&dump_yaml,
36             'gen-dot' => \&gen_dot,
37             edit => \&edit,
38             save => \&save,
39             plugin => \&plugin,
40             );
41              
42             sub validate_args {
43             my ($self, $opt, $args) = @_;
44              
45             my $mc = $opt->{'_meta_command'} = shift @$args || die "please specify meta sub command\n";
46              
47             if (not $meta_cmd{$mc}) {
48             die "Unexpected meta sub command: '$mc'. Expected ".join(' ', sort keys %meta_cmd)."\n";
49             }
50              
51             my ( $categories, $appli_info, $appli_map ) = Config::Model::Lister::available_models;
52             my $application = shift @$args;
53              
54             if ($mc eq 'plugin') {
55             unless ($application) {
56             die "Missing application name after 'plugin' command";
57             }
58             $opt->{_root_model} = $appli_map->{$application}
59             || die "Unknown application $application";
60             }
61             elsif ($application) {
62             $opt->{_root_model} = $appli_map->{$application} || $application;
63             }
64              
65             Config::Model::Exception::Any->Trace(1) if $opt->{trace};
66              
67             $opt->{_application} = $application ;
68              
69             }
70              
71             sub opt_spec {
72             my ( $class, $app ) = @_;
73              
74             return (
75             [
76             "dir=s" => "directory where to read and write a model",
77             {default => 'lib/Config/Model'}
78             ],
79             [
80             "dumptype=s" => "dump every values (full), only preset values "
81             . "or only customized values (default)",
82             {callbacks => { 'expected values' => sub { $_[0] =~ m/^full|preset|custom$/ ; }}}
83             ],
84             [ "dev!" => 'use model in ./lib to create a plugin'],
85             [ "open-item=s" => "force the UI to open the specified node"],
86             [ "plugin-file=s" => "create a model plugin in this file" ],
87             [ "load-yaml=s" => "load model from YAML file" ],
88             [ "load=s" => "load model from cds file (Config::Model serialisation file)"],
89             [ "system!" => "read model from system files" ],
90             [ "test-and-quit=s" => "Used for tests" ],
91             $class->cme_global_options()
92             );
93             }
94              
95             sub usage_desc {
96             my ($self) = @_;
97             my $desc = $self->SUPER::usage_desc; # "%c COMMAND %o"
98             return "$desc [ ".join(' | ', sort keys %meta_cmd)." ] your_model_class ";
99             }
100              
101             sub description {
102             my ($self) = @_;
103             return $self->get_documentation;
104             }
105              
106             sub read_data {
107             my $load_file = shift ;
108              
109             my @data ;
110             if ( $load_file eq '-' ) {
111             @data = ;
112             }
113             else {
114             open(LOAD,$load_file) || die "cannot open load file $load_file:$!";
115             @data = ;
116             close LOAD;
117             }
118              
119             return wantarray ? @data : join('',@data);
120             }
121              
122             sub load_optional_data {
123             my ($self, $args, $opt, $root_model, $meta_root) = @_;
124              
125             if (defined $opt->{load}) {
126             my $data = read_data($opt->{load}) ;
127             $data = qq(class:"$root_model" ).$data unless $data =~ /^\s*class:/ ;
128             $meta_root->load($data);
129             }
130              
131             if (defined $opt->{'load-yaml'}) {
132             my $yaml = read_data($opt->{'load-yaml'}) ;
133             my $pdata = Load($yaml) ;
134             $meta_root->load_data($pdata) ;
135             }
136             }
137              
138             sub load_meta_model {
139             my ($self, $opt, $args) = @_;
140              
141             my $root_model = $opt->{_root_model};
142             my $cm_lib_dir = path(split m!/!, $opt->{dir}) ; # replace with cm_lib_dir ???
143              
144             if (! $cm_lib_dir->is_dir) {
145             $cm_lib_dir->mkpath(0, 0755) || die "can't create $cm_lib_dir:$!";
146             }
147              
148             my $meta_model = $self->{meta_model} = Config::Model -> new();
149              
150             my $meta_inst = $meta_model->instance(
151             root_class_name => 'Itself::Model',
152             instance_name => 'meta',
153             check => $opt->{'force-load'} ? 'no' : 'yes',
154             );
155              
156             my $meta_root = $meta_inst -> config_root ;
157              
158             my $system_cm_lib_dir = $INC{'Config/Model.pm'} ;
159             $system_cm_lib_dir =~ s/\.pm//;
160              
161             return ($meta_inst, $meta_root, $cm_lib_dir, path($system_cm_lib_dir));
162             }
163              
164             sub load_meta_root {
165             my ($self, $opt, $args) = @_;
166              
167             my ($meta_inst, $meta_root, $cm_lib_dir, $system_cm_lib_dir) = $self->load_meta_model($opt,$args);
168              
169             my $root_model = $opt->{_root_model};
170              
171             say "Reading model from $system_cm_lib_dir" if $opt->system();
172              
173             # now load model
174             my $rw_obj = Config::Model::Itself -> new(
175             model_object => $meta_root,
176             cm_lib_dir => $cm_lib_dir->canonpath
177             );
178              
179             $meta_inst->initial_load_start ;
180              
181             my @read_args = (
182             force_load => $opt->{'force-load'},
183             root_model => $root_model,
184             # legacy => 'ignore',
185             );
186             if ($opt->system()) {
187             push @read_args,
188             application => $opt->{_application},
189             read_from => $system_cm_lib_dir ;
190             }
191             $rw_obj->read_all(@read_args);
192              
193             $meta_inst->initial_load_stop ;
194              
195             $self->load_optional_data($args, $opt, $root_model, $meta_root) ;
196              
197             my $write_sub = sub {
198             my $wr_dir = shift || $cm_lib_dir ;
199             $rw_obj->write_all( );
200             } ;
201             return ($rw_obj, $cm_lib_dir, $meta_root, $write_sub);
202             }
203              
204             sub load_meta_plugin {
205             my ($self, $opt, $args) = @_;
206              
207             my ($meta_inst, $meta_root, $cm_lib_dir, $system_cm_lib_dir) = $self->load_meta_model($opt, $args);
208              
209             my $root_model = $opt->{_root_model};
210             my $meta_cm_lib_dir = $opt->dev ? $cm_lib_dir : $system_cm_lib_dir ;
211             my $plugin_name = shift @$args or die "missing plugin file name after application name.";
212              
213             if ($plugin_name =~ s/\.pl$//) {
214             warn "removed '.pl' deprecated suffix from plugin name\n";
215             }
216              
217             say "Preparing plugin $plugin_name for model $root_model found in $meta_cm_lib_dir";
218             say "Use -dev option to create a plugin for a local model (i.e. in $cm_lib_dir)"
219             unless $opt->dev;
220              
221             # now load model
222             my $rw_obj = Config::Model::Itself -> new(
223             model_object => $meta_root,
224             cm_lib_dir => $meta_cm_lib_dir->canonpath,
225             ) ;
226              
227             $meta_inst->initial_load_start ;
228             $meta_inst->layered_start;
229              
230             $rw_obj->read_all(
231             force_load => $opt->{'force-load'},
232             root_model => $root_model,
233             # legacy => 'ignore',
234             );
235              
236             $meta_inst->layered_stop;
237              
238             # load any existing plugin file
239             $rw_obj->read_model_plugin(
240             plugin_dir => $cm_lib_dir.'/models/',
241             plugin_name => $plugin_name
242             ) ;
243              
244             $meta_inst->initial_load_stop ;
245              
246             $self->load_optional_data($args, $opt, $root_model, $meta_root) ;
247             my $root_model_dir = $root_model ;
248             $root_model_dir =~ s!::!/!g;
249             my $write_sub = sub {
250             $rw_obj->write_model_plugin(
251             plugin_dir => "$cm_lib_dir/models/$root_model_dir.d",
252             plugin_name => $plugin_name
253             );
254             } ;
255              
256             return ($rw_obj, $cm_lib_dir, $meta_root, $write_sub);
257             }
258              
259             sub execute {
260             my ($self, $opt, $args) = @_;
261              
262             # how to specify root-model when starting from scratch ?
263             # ask question and fill application file ?
264              
265             my $cmd_sub = $meta_cmd{$opt->{_meta_command}};
266              
267             $self->$cmd_sub($opt, $args);
268             }
269              
270             sub save {
271             my ($self, $opt, $args) = @_;
272             my ($rw_obj, $cm_lib_dir, $meta_root, $write_sub) = $self->load_meta_root($opt, $args) ;
273              
274             say "Saving ",$rw_obj->root_model. ' model'. ($opt->dir ? ' in '.$opt->dir : '');
275             &$write_sub;
276             }
277              
278             sub gen_dot {
279             my ($self, $opt, $args) = @_;
280             my ($rw_obj, $cm_lib_dir, $meta_root, $write_sub) = $self->load_meta_root($opt, $args) ;
281              
282             my $out = shift @$args || "model.dot";
283             say "Creating dot file $out";
284             path($out) -> spew( $rw_obj->get_dot_diagram );
285             }
286              
287             sub check {
288             my ($self, $opt, $args) = @_;
289              
290             say "loading model" unless $opt->{quiet};
291             my ($rw_obj, $cm_lib_dir, $meta_root, $write_sub) = $self->load_meta_root($opt, $args) ;
292              
293             Config::Model::ObjTreeScanner->new( leaf_cb => sub { } )->scan_node( undef, $meta_root );
294              
295             say "checking data" unless $opt->{quiet};
296             $meta_root->dump_tree( mode => 'full' );
297             say "check done" unless $opt->{quiet};
298              
299             my $ouch = $meta_root->instance->has_warning;
300              
301             if ( $opt->{strict} and $ouch ) {
302             die "Found $ouch warnings in strict mode\n";
303             }
304              
305             }
306              
307             sub dump_cds {
308             my ($self, $opt, $args) = @_;
309             my ($rw_obj, $cm_lib_dir, $meta_root, $write_sub) = $self->load_meta_root($opt, $args) ;
310              
311             my $dump_file = shift @$args || 'model.cds';
312             say "Dumping ".$rw_obj->root_model." in $dump_file";
313              
314             my $dump_string = $meta_root->dump_tree( mode => $opt->{dumptype} || 'custom' ) ;
315              
316             path($dump_file)->spew($dump_string);
317             }
318              
319             sub dump_yaml{
320             my ($self, $opt, $args) = @_;
321             my ($rw_obj, $cm_lib_dir, $meta_root, $write_sub) = $self->load_meta_root($opt, $args) ;
322              
323             require YAML::Tiny;
324             import YAML::Tiny qw/Dump/;
325             my $dump_file = shift @$args || 'model.yml';
326             say "Dumping ".$rw_obj->root_model." in $dump_file";
327              
328             my $dump_string = Dump($meta_root->dump_as_data(ordered_hash_as_list => 0)) ;
329              
330             path($dump_file)->spew($dump_string);
331              
332             }
333              
334             sub plugin {
335             my ($self, $opt, $args) = @_;
336             my @info = $self->load_meta_plugin($opt, $args) ;
337             $self->_edit($opt, $args, @info);
338             }
339              
340             sub edit {
341             my ($self, $opt, $args) = @_;
342             my @info = $self->load_meta_root($opt, $args) ;
343             $self->_edit($opt, $args, @info);
344             }
345              
346             sub _edit {
347             my ($self, $opt, $args, $rw_obj, $cm_lib_dir, $meta_root, $write_sub) = @_;
348              
349             my $root_model = $rw_obj->root_model;
350             my $mw = MainWindow-> new;
351              
352             $mw->withdraw ;
353             # Thanks to Jerome Quelin for the tip
354             $mw->optionAdd('*BorderWidth' => 1);
355              
356             my $cmu = $mw->ConfigModelEditUI(
357             -root => $meta_root,
358             -store_sub => $write_sub,
359             -model_name => $root_model,
360             -cm_lib_dir => $cm_lib_dir
361             );
362              
363             my $open_item = $opt->{'open-item'};
364             if ($root_model and not $meta_root->fetch_element('class')->fetch_size) {
365             $open_item ||= qq(class:"$root_model" );
366             }
367             else {
368             $open_item ||= 'class';
369             }
370              
371             my $obj = $meta_root->grab($open_item) ;
372             $cmu->after(10, sub { $cmu->force_element_display($obj) });
373              
374             if (my $taq = $opt->test_and_quit ) {
375             my $bail_out = sub {
376             warn "save failed: $_[0]\n" if @_;
377             $cmu -> quit;
378             } ;
379              
380             $cmu->after( 2000 , sub {
381             if ($taq =~ /s/) {
382             say "Test mode: save and quit";
383             $cmu->save( $bail_out );
384             }
385             else {
386             say "Test mode: quit only";
387             &$bail_out
388             }
389             });
390             }
391             &MainLoop ; # Tk's
392             say "Exited GUI";
393             }
394              
395             1;
396              
397             __END__