view release on metacpan or  search on metacpan

lib/Config/Model.pm  view on Meta::CPAN

    my $behavior = shift || $self->legacy;

    my @msg = ref $ref ? @$ref : $ref;
    unshift @msg, "Model ";
    if ( $behavior eq 'die' ) {
        die @msg, "\n";
    }
    elsif ( $behavior eq 'warn' ) {
        $legacy_logger->warn(@msg);
    } elsif ( $behavior eq 'note' ) {
        $legacy_logger->info( @msg);
    }
    return;
}

sub _tweak_instance_args {
    my ($args) = @_  ;

    my $application = $args->{application} ;
    my $cat = '';
    if (defined $application) {
        my ( $categories, $appli_info, $appli_map ) = Config::Model::Lister::available_models;

        # root_class_name may override class found (or not) by appli in tests
        if (not $args->{root_class_name}) {
            $args->{root_class_name} = $appli_map->{$application} ||
                die "Unknown application $application. Expected one of "
                . join(' ',sort keys %$appli_map)."\n";
        }

        $cat = $appli_info->{_category} //  ''; # may be empty in tests
        # config_dir may be specified in application file
        $args->{config_dir} //= $appli_info->{$application}{config_dir};
        $args->{appli_info} = $appli_info->{$application} // {};
    }

    my $app_name = $application;
    if ($cat eq 'application') {
        # store dir in name to distinguish different runs of the same
        # app in different directories.
        $application .= " in " . cwd;
    }
    $args->{name}
        =  delete $args->{instance_name} # backward compat with test
        || delete $args->{name}          # preferred parameter
        || $app_name                     # fallback in most cases
        || 'default';                    # fallback mostly in tests
    return;
}

sub cme (@args) {
    my %args = @args == 1 ? ( application => $args[0]) : @args ;

    if (my $force = delete $args{'force-load'}) {
        $args{check} = 'no' if $force;
    }

    my $cat =_tweak_instance_args(\%args);

    my $m_args = delete $args{model_args} // {} ; # used for tests
    # model_storage is used to keep Config::Model object alive
    $model_storage //= Config::Model->new(%$m_args);

    return $model_storage->instance(%args);
}

sub instance ($self, @args) {
    my %args = @args == 1 ? ( application => $args[0]) : @args ;

    # also creates a default name
    _tweak_instance_args(\%args);

    if ( $args{name} and $self->has_instance($args{name}) ) {
        return $self->get_instance($args{name});
    }

    croak "Model: can't create instance without application or root_class_name "
        unless $args{root_class_name};

    if ( defined $args{model_file} ) {
        my $file = delete $args{model_file};
        $self->load( $args{root_class_name}, $file );
    }

    my $i = Config::Model::Instance->new(
        config_model    => $self,
        %args    # for optional parameters like *directory
    );

    $self->store_instance($args{name}, $i);
    return $i;
}

sub instance_names {
    my $self = shift;
    my @all = sort keys %{ $self->instances };
    return @all;
}

# unpacked model is:
# {
#   element_list  => [ ... ],
#   element       => { element_name => element_data (left as is)    },
#   class_description => <class description string>,
#   include       => 'class_name',
#   include_after => 'element_name',
# }
# description, summary, level, status are moved
# into element description.

my @legal_params_to_move = (
    qw/read_config write_config rw_config/,    # read/write stuff

    # this parameter is filled by class generated by a program. It may
    # be used to avoid interactive edition of a generated model
    'generated_by',
    qw/class_description author copyright gist license include include_after include_backend class/
);

my @other_legal_params = qw/ author element status description summary level accept/;