view release on metacpan or  search on metacpan

lib/App/Cme/Common.pm  view on Meta::CPAN

        # let the backend handle a missing arg and provide a clear error message
        my $b_arg = $opt->{_backend_arg} = shift @$args ;
        if (not $b_arg) {
            my $message = $appli_info->{$application}{backend_argument_info} ;
            my $insert = $message ? " ( $message )": '';
            die "application $application requires a 3rd argument$insert. "
                . "I.e. 'cme $command $application <backend_arg>'\n";
        }

        if ( $appli_info->{$application}{use_backend_argument_as_config_file} ) {
            $config_file = $appli_info->{$application}{config_dir} . '/' . $b_arg;
        }
    }

    # remove legacy '~~'
    if ($args->[0] and $args->[0] eq '~~') {
        warn "Argument '~~' was a bad idea and is now ignored. Use -file option to "
            ."specify a target file or just forget about '~~' argument\n";
        shift @$args;
    }

    # override (or specify) configuration dir
    $opt->{_config_dir} = $appli_info->{$application}{config_dir};

    $opt->{_application} = $application ;
    $opt->{_config_file} = $config_file;
    $opt->{_root_model}  = $root_model;

    return;
}

sub model {
    my ($self, $opt, $args) = @_;

    my %cm_args;
    $cm_args{model_dir} = $opt->{model_dir} if $opt->{model_dir};

    if (not $self->{_model}) {
        initialize_log4perl( verbose => $opt->{_verbose} );

        my $model = $self->{_model} = Config::Model->new( %cm_args );
        push @store, $model;
    }
    return $self->{_model};
}

sub instance {
    my ($self, $opt, $args) = @_;

    my %instance_args = (
            root_class_name => $opt->{_root_model},
            instance_name   => $opt->{_application},
            application     => $opt->{_application},
            check           => $opt->{force_load} ? 'no' : 'yes',
            auto_create     => $opt->{create},
            backend_arg     => $opt->{_backend_arg},
            config_file     => $opt->{_config_file},
            config_dir      => $opt->{_config_dir},
    );

    foreach my $param (qw/root_dir canonical backup instance_name/) {
        $instance_args{$param} = $opt->{$param} if defined $opt->{$param};
    }

    return $self->{_instance} ||= $self->model->instance(%instance_args);
}

sub init_cme {
    my ($self, @args) = @_;
    # model and inst are deleted if not kept in a scope
    return ( $self->model(@args) , $self->instance(@args), $self->instance->config_root );
}

sub save {
    my ($self,$inst,$opt) = @_;

    $inst->say_changes unless $opt->{quiet};

    # if load was forced, must write back to clean up errors (even if they are not changes
    # at semantic level, i.e. removed unnecessary stuff)
    $inst->write_back( force => $opt->{force_load} || $opt->{save} );

    return;
}

sub run_tk_ui {
    my ($self, $instance, $opt) = @_;

    require Config::Model::TkUI;
    require Tk;
    require Tk::ErrorDialog;
    Tk->import;

    no warnings 'once'; ## no critic (TestingAndDebugging::ProhibitNoWarnings)
    my $mw = MainWindow->new;
    $mw->withdraw;

    # Thanks to Jerome Quelin for the tip
    $mw->optionAdd( '*BorderWidth' => 1 );

    # -root parameter is deprecated
    my $cmu = $mw->ConfigModelUI( -instance => $instance );

    $instance->on_message_cb(sub{$cmu->show_message(@_);});

    if ($opt->{open_item}) {
        my $obj = $instance->grab(step => $opt->{open_item}, autoadd => 0);
        # using afterIdle avoids geometry problem where the right side
        # of the widget is not visible
        $mw->afterIdle( sub {
            $cmu->force_element_display($obj);
            my $path = $cmu->{tktree}->selectionGet;
            $cmu->create_element_widget('edit', $path);
        })
    }

    &MainLoop;    # Tk's

    return;
}