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

#
# This file is part of Config-Model-Itself
#
# This software is Copyright (c) 2007-2017 by Dominique Dumont.
#
# This is free software, licensed under:
#
#   The GNU Lesser General Public License, Version 2.1, February 1999
#
# ABSTRACT: Work on the configuration model of an application

package App::Cme::Command::meta ;
$App::Cme::Command::meta::VERSION = '2.013';
use strict ;
use warnings ;
use 5.10.1;

use App::Cme -command ;

use base qw/App::Cme::Common/;

use Config::Model 2.075;

use Config::Model::Itself ;
use YAML::Tiny;

use Tk ;
use Config::Model::TkUI ;
use Config::Model::Itself::TkEditUI ;
use Path::Tiny ;

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; # "%c COMMAND %o"
  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 =  ;
    }
    else {
        open(LOAD,$load_file) || die "cannot open load file $load_file:$!";
        @data =  ;
        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}) ; # replace with cm_lib_dir ???

    if (! $cm_lib_dir->is_dir) {
        $cm_lib_dir->mkpath(0, 0755) || die "can't create $cm_lib_dir:$!";
    }

    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();

    # now load model
    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,
        # legacy     => 'ignore',
    );
    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;

    # now load model
    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,
        # legacy     => 'ignore',
    );

    $meta_inst->layered_stop;

    # load any existing plugin file
    $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) = @_;

    # how to specify root-model when starting from scratch ?
    # ask question and fill application file ?

    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($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) ;

    require YAML::Tiny;
    import YAML::Tiny qw/Dump/;
    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($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 ;
    # Thanks to Jerome Quelin for the tip
    $mw->optionAdd('*BorderWidth' => 1);

    my $cmu = $mw->ConfigModelEditUI(
        -root       => $meta_root,
        -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 ; # Tk's
    say "Exited GUI";
}

1;

__END__