Config-Model
view release on metacpan or search on metacpan
Misc:
* update copyright year
* Tests require Config::Model::Tester 4.002
2.133 2019-01-13
Read/write backend improvements:
* Backend::Any: add auto_delete and auto_create
* IniFile: delete empty file when auto_delete is set
and config file contains no data
* warn when restoring backup file
2.132 2018-12-22
Bug fix:
* Value: really use old_value to track changes
* restore "return undef" in Value.pm to avoid breaking apply_fix
Add long forgotten credit (sorry):
* add Ylya Arosov to credit
Main change:
* use logger to warn about issues. By default, logged warnings
are shown on STDOUT. These warnings can be suppressed
using ~/.log4config-model file.
API change:
* Instance: root_dir parameter can be a Path::Tiny object
or a string
Bug fixes:
* BackendMgr: fix broken file backup
* Backend: create dir before creating file
* Yaml backend: avoid redefined sub warning
2.118 2018-03-26
On-going backend deprecation:
* BackendMgr: deprecate using STDIN to load config file. Which
means using '-' with cme '-file' option is deprecated.
Backend:
* ObjTreeScanner: tolerate deprecated experience parameter.
2.056 2014-05-18
This release deprecates experience associated with configuration element.
experience specification in models is now ignored.
Other Changes:
* added bash_completion snippet associated to a model. This will be useful
for dpkg-patch model
* C::M::Lister: skip backup files when listing available applications
* replace File::Slurp with Path::Tiny in yaml backend test and gen-class-pod
(RT #95692). (which changes the dependencies)
* replaced Path::Class with Path::Tiny dependency
2.055 2014-05-02
This release removes all code related to asynchronous stores. This code was
buggy. Making this work correctly would require re-writing most of
Config::Model.
* cme:
+ added -create option to force creation of missing configuration
file
* improved message about applied changes and don't show '0' as <undef>
* added examples in pod doc
* BackendMgr:
+ add note about cme in header of saved file (if comments
are supported in the configuration file format)
* Improved error message when no config file is found
* skip backup copy if no original file is found
* Node: avoid unknown element failure when check is 'no'
* ValueComputer:
* added note in doc about compute variable usage
* correctly handles &index(-x) where x is a number > 1
* improved error message if 'follow' parameter does not point to
a leaf in configuration tree
* overdue doc changes: s/WarpedThing/Warper/g in pod docs
2.045 2013-10-18
+ allow override of home directory for tests
+ can also use $model for internal tests
* check test item now accepts array refs
Doc:
* added log config file in contrib
2.038 2013-07-03
Framework changes:
* cme: added -backup option.
Application changes:
* popcon model:
* replace yes/no enum value with boolean written as yes/no
+ added ENCRYPT support
Backends:
* all: don't loose part of comment when '#' is embedded in comment
* Ini backend: handle storage to non available element by ditching data
* Framework changes:
* Build.PL: removed dead code that cause downstream pacaking problems.
* Model.pm: fix cosmetic issue with doc generation.
1.237 2011-04-04
* Framework changes:
* added MouseX::NativeTraits dependency (fix RT #67196)
* config-edit: fixed typo (fix RT #66403)
* Value, Node, AnyId: use dclone to backup constructor parameters
* Model: Correctly write author and copyright in doc (i.e not as ARRAY0x0...)
* Yaml backend: fill full_dump option (did not work when set to 0)
* Application changes:
* dpkg control dependency:
- Dependency filtering mechanism uses source package name to find
filter value in Meta. This makes more sense than using binary package
name
1.236 2011-04-01
lib/Config/Model/AnyId.pm view on Meta::CPAN
my @common_params =
( @common_int_params, @common_str_params, @common_list_params, @common_hash_params );
my @allowed_warp_params = ( @common_params, qw/level convert/ );
around BUILDARGS => sub {
my $orig = shift;
my $class = shift;
my %args = @_;
my %h = map { ( $_ => $args{$_} ); } grep { defined $args{$_} } @allowed_warp_params;
return $class->$orig( backup => dclone( \%h ), @_ );
};
has [qw/cargo/] => ( is => 'ro', isa => 'HashRef', required => 1 );
has warp => ( is => 'ro', isa => 'Maybe[HashRef]' );
has [qw/morph/] => ( is => 'ro', isa => 'Bool', default => 0 );
has content_warning_list => ( is => 'rw', isa => 'ArrayRef', default => sub { []; } );
has [qw/cargo_class max_index index_class index_type/] =>
( is => 'rw', isa => 'Maybe[Str]' );
has config_model => (
lib/Config/Model/AnyThing.pm view on Meta::CPAN
isa => 'Bool',
builder => '_backend_support_annotation',
lazy => 1
);
sub _backend_support_annotation ($self) {
# this method is overridden in Config::Model::Node
return $self->parent->backend_support_annotation;
};
has backup => (
is => 'bare',
isa => 'Maybe[HashRef]',
);
sub backup ($self) {
return dclone($self->{backup});
}
sub notify_change ($self, %args) {
return if $self->instance->initial_load and not $args{really};
if ($change_logger->is_trace) {
my @with = map { "'$_' -> '". ($args{$_} // '<undef>') ."'" } sort keys %args;
$change_logger->trace("called for ", $self->name, " from ",
lib/Config/Model/Backend/Any.pm view on Meta::CPAN
object => $obj, # Config::Model::Node object
root => $root_dir, # fake root directory, used for tests
auto_create => $auto_create, # boolean specified in backend declaration
auto_delete => $auto_delete, # boolean specified in backend declaration
backend => $backend, # backend name
config_dir => $write_dir, # override from instance
file => 'foo.conf', # file name
file_path => $full_name, # full file name (root+path+file)
write => 1, # always
check => [ yes|no|skip] ,
backup => [ undef || '' || suffix ] # backup strategy required by user
The L<IO::File> object is undef if the file cannot be written to.
This method must return 1 if the write was successful, 0 otherwise
=back
=head2 How to test your new backend
Using L<Config::Model::Tester>, you can test your model with your
lib/Config/Model/BackendMgr.pm view on Meta::CPAN
my $user_logger = get_logger('User');
# one BackendMgr per file
has 'node' => (
is => 'ro',
isa => 'Config::Model::Node',
weak_ref => 1,
required => 1
);
has 'file_backup' => ( is => 'rw', isa => 'ArrayRef', default => sub { [] } );
has 'rw_config' => (
is => 'ro',
isa => 'HashRef',
required => 1
);
has 'backend_obj' => (
is => 'rw',
isa => 'Config::Model::Backend::Any',
lib/Config/Model/BackendMgr.pm view on Meta::CPAN
$logger->trace("get_cfg_file_path: returns $res");
return ( $dir_ok, $res );
}
return 0;
}
sub open_read_file ($self, $file_path) {
if ( $file_path->is_file ) {
$logger->debug("open_read_file: open $file_path for read");
# store a backup in memory in case there's a problem
$self->file_backup( [ $file_path->lines_utf8 ] );
return $file_path->filehandle("<", ":utf8");
}
else {
return;
}
}
# called at configuration node creation
sub load_backend_class ($self, $backend, $function) {
$logger->trace("load_backend_class: called with backend $backend, function $function");
lib/Config/Model/BackendMgr.pm view on Meta::CPAN
$logger->debug( "write cb ($backend) called for $location ", $force_delete ? '' : ' (deleted)' );
my $backend_obj = $self->backend_obj();
my ($fh, $file_ok, $file_path );
if (not $backend_class->skip_open) {
( $file_ok, $file_path ) = $self->get_cfg_file_path( @wr_args, %cb_args);
}
if ($file_ok) {
$fh = $self->open_file_to_write( $backend, $file_path, delete $cb_args{backup} );
}
# override needed for "save as" button
my %backend_args = (
@wr_args,
file_path => $file_path,
object => $node,
%cb_args # override from user
);
lib/Config/Model/BackendMgr.pm view on Meta::CPAN
: ref($perl_data) eq 'ARRAY' ? scalar @$perl_data
: $perl_data ;
if (not $size) {
$logger->info( "Removing $file_path (no data to store)" );
unlink($file_path);
}
return;
}
sub open_file_to_write ($self, $backend, $file_path, $backup) {
my $do_backup = defined $backup;
$backup ||= 'old'; # use old only if defined
$backup = '.' . $backup unless $backup =~ /^\./;
# make sure that parent dir exists before creating file
$file_path->parent->mkpath;
if ( $do_backup and $file_path->is_file ) {
$file_path->copy( $file_path.$backup ) or die "Backup copy failed: $!";
}
$logger->debug("$backend backend opened file $file_path to write");
return $file_path->filehandle(">",":utf8");
}
sub close_file_to_write ($self, $error, $file_path, $file_mode) {
return unless defined $file_path;
if ($error) {
# restore backup and display error
$logger->warn("Error during write, restoring backup data in $file_path" );
$file_path->append_utf8({ truncate => 1 }, $self->file_backup );
$error->rethrow if ref($error) and $error->can('rethrow');
die $error;
}
# TODO: move chmod in a backend role
$file_path->chmod($file_mode) if $file_mode;
# TODO: move in a backend role
# check file size and remove empty files
$file_path->remove if -z $file_path and not -l $file_path;
lib/Config/Model/CheckList.pm view on Meta::CPAN
use Log::Log4perl qw(get_logger :levels);
use Storable qw/dclone/;
extends qw/Config::Model::AnyThing/;
with "Config::Model::Role::WarpMaster";
with "Config::Model::Role::Grab";
with "Config::Model::Role::HelpAsText";
with "Config::Model::Role::ComputeFunction";
with "Config::Model::Role::Utils";
# this requires backup method from Config::Model::AnyThing
with "Config::Model::Role::WarpSubject";
my $logger = get_logger("Tree.Element.CheckList");
my $user_logger = get_logger("User");
my @introspect_params = qw/refer_to computed_refer_to/;
my @accessible_params = qw/default_list upstream_default_list choice ordered/;
my @allowed_warp_params = ( @accessible_params, qw/level/ );
lib/Config/Model/CheckList.pm view on Meta::CPAN
has [qw/ordered_data choice/] => ( is => 'rw', isa => 'ArrayRef', default => sub { []; } );
has [qw/ordered/] => ( is => 'ro', isa => 'Bool' );
has [qw/warp help/] => ( is => 'rw', isa => 'Maybe[HashRef]' );
around BUILDARGS => sub {
my $orig = shift;
my $class = shift;
my %args = @_;
my %h = map { ( $_ => $args{$_} ); } grep { defined $args{$_} } @allowed_warp_params;
return $class->$orig( backup => dclone( \%h ), @_ );
};
# used by roles
sub allowed_warp_params {
return @allowed_warp_params;
}
sub BUILD {
my $self = shift;
if ( defined $self->refer_to or defined $self->computed_refer_to ) {
$self->submit_to_refer_to();
}
$self->set_properties(); # set will use backup data
if ( defined $self->warp ) {
my $warp_info = $self->warp;
$self->{warper} = Config::Model::Warper->new(
warped_object => $self,
%$warp_info,
allowed => \@allowed_warp_params
);
}
lib/Config/Model/CheckList.pm view on Meta::CPAN
my $def = $self->{default_data};
my $lay = $self->{layered};
my $ud = $self->{upstream_default_data};
# fill empty hash result
my %h = map { $_ => 0 } $self->get_choice;
my %predef = ( %$def, %$pre );
my %std = ( %$ud, %$lay, %$def, %$pre );
# use _std_backup if all data values are null (no checked items by user)
my %old_dat = ( none { $_; } values %$dat ) ? %{ $self->{_std_backup} || {} } : %$dat;
if ( not $mode and any { $_; } values %predef and none { $_; } values %old_dat ) {
# changed from nothing to default checked list that must be written
$self->{_std_backup} = { %$def, %$pre };
$self->notify_change( note => "use default checklist" );
}
# custom test must compare the whole list at once, not just one item at a time.
my %result =
$mode eq 'custom' ? ( ( grep { $dat->{$_} xor $std{$_} } keys %h ) ? ( %$pre, %$dat ) : () )
: $mode eq 'preset' ? (%$pre)
: $mode eq 'layered' ? (%$lay)
: $mode eq 'upstream_default' ? (%$ud)
: $mode eq 'default' ? (%$def)
lib/Config/Model/HashId.pm view on Meta::CPAN
coerce 'HaskKeyArray' => from 'Str' => via { [$_] } ;
use Log::Log4perl qw(get_logger :levels);
my $logger = get_logger("Tree::Element::Id::Hash");
extends qw/Config::Model::AnyId/;
with "Config::Model::Role::Grab";
with "Config::Model::Role::ComputeFunction";
# this requires backup method from Config::Model::AnyThing
with "Config::Model::Role::WarpSubject";
has data => ( is => 'rw', isa => 'HashRef', default => sub { {}; } );
has list => (
is => 'rw',
isa => 'ArrayRef[Str]',
traits => ['Array'],
default => sub { []; },
handles => {
_sort => 'sort_in_place',
lib/Config/Model/HashId.pm view on Meta::CPAN
}
}
# notify_change is placed in the loop so the notification
# is not sent if the user tries to move past last idx
return;
}
sub _load_data_from_hash ($self, %args) {
my $data = $args{data};
my %backup = %$data ;
my @ordered_keys;
my $from = '';
my $order_key = '__'.$self->element_name.'_order';
if ( $self->{ordered} and (defined $data->{$order_key} or defined $data->{__order} )) {
@ordered_keys = @{ delete $data->{$order_key} or delete $data->{__order} };
$from = ' with '.$order_key;
}
elsif ( $self->{ordered} and (not $data->{__skip_order} and keys %$data > 1)) {
lib/Config/Model/HashId.pm view on Meta::CPAN
foreach my $k (@ordered_keys) {
push @left_keys, $k unless delete $data_keys{$k};
}
if ( %data_keys or @left_keys) {
my @msg ;
push @msg, "Unlisted keys in __order:", keys %data_keys if %data_keys;
push @msg, "Extra keys in __order:", @left_keys if @left_keys;
Config::Model::Exception::LoadData->throw(
object => $self,
message => "load_data: ordered keys mistmatch: @msg",
wrong_data => \%backup,
);
}
}
my @load_keys = @ordered_keys ? @ordered_keys : sort keys %$data;
$logger->info(
"HashId load_data (" . $self->location .
") will load idx @load_keys from hash ref $from"
);
my $res = 0;
lib/Config/Model/Instance.pm view on Meta::CPAN
default => sub { {} },
);
sub register_write_back {
my ($self, $path, $backend, $wb) = @_;
push @{ $self->_write_back->{$path} //= [] }, [$backend, $wb];
return;
}
# used for auto_read auto_write feature
has [qw/name application backend_arg backup/] => (
is => 'ro',
isa => 'Maybe[Str]',
);
has 'root_dir' => (
is => 'ro',
isa => 'Config::Model::TypeContraints::Path',
coerce => 1
);
lib/Config/Model/Instance.pm view on Meta::CPAN
autoadd => 0,
);
foreach my $wb_info (@{ $self->write_back_node_info($path) }) {
my ($backend, $cb) = @$wb_info;
my @wb_args = (
%args,
config_file => $self->{config_file},
force => $force_write,
backup => $self->backup,
);
if (defined $node and ($node->needs_save or $force_write)) {
my $dir = $args{config_dir};
mkpath( $dir, 0, oct(755) ) if $dir and not -d $dir;
# exit when write is successfull
my $res = $cb->(@wb_args);
$logger->info( "write_back called with $backend backend, result is ",
defined $res ? $res : '<undef>' );
lib/Config/Model/ListId.pm view on Meta::CPAN
use Config::Model::Exception;
use Log::Log4perl qw(get_logger :levels);
use Carp;
extends qw/Config::Model::AnyId/;
with "Config::Model::Role::Grab";
with "Config::Model::Role::ComputeFunction";
with "Config::Model::Role::Utils";
# this requires backup method from Config::Model::AnyThing
with "Config::Model::Role::WarpSubject";
use feature qw/postderef signatures/;
no warnings qw/experimental::signatures experimental::postderef/;
my $logger = get_logger("Tree::Element::Id::List");
my $user_logger = get_logger("User");
has data => (
is => 'rw',
lib/Config/Model/Node.pm view on Meta::CPAN
}
sub init ($self, @args) {
return if $self->{initialized};
$self->{initialized} = 1; # avoid recursions
my $model = $self->{model};
return unless defined $model->{rw_config};
my $initial_load_backup = $self->instance->initial_load;
$self->instance->initial_load_start;
$self->{backend_mgr} ||= Config::Model::BackendMgr->new(
# config_dir spec given by application info
config_dir => $self->instance->config_dir,
node => $self,
rw_config => $model->{rw_config}
);
$self->read_config_data( check => $self->read_check );
# setup auto_write
$self->backend_mgr->auto_write_init();
$self->instance->initial_load($initial_load_backup);
return;
}
sub read_config_data {
my ( $self, %args ) = @_;
my $model = $self->{model};
if ( $self->location and $args{config_file} ) {
die "read_config_data: cannot override config_file in non root node (",
lib/Config/Model/Role/WarpSubject.pm view on Meta::CPAN
package Config::Model::Role::WarpSubject 2.166;
# ABSTRACT: common methods for a warped element
use Mouse::Role;
use Mouse::Util;
use feature qw/postderef signatures/;
no warnings qw/experimental::postderef experimental::signatures/;
requires 'backup', 'allowed_warp_params';
use Log::Log4perl qw(get_logger :levels);
my $logger = get_logger("WarpSubject");
sub merge_properties($self, %raw_args) {
my %args = %{ $self->backup // {} };
for my $p ( $self->allowed_warp_params() ) {
# cleanup all parameters that are handled by warp
delete $self->{$p};
next unless exists $raw_args{$p};
my $new = $raw_args{$p};
if (defined $args{$p} and ref $args{$p} eq 'HASH') {
if (ref $new eq 'HASH') {
lib/Config/Model/Role/WarpSubject.pm view on Meta::CPAN
package Config::Model::SomeStuff;
use Mouse;
with Config::Model::Role::WarpSubject
=head1 DESCRIPTION
This role enable a configuration element to become a warp master, i.e. a parameter
whose value can change the features of the configuration tree (by controlling a
warped_node) or the feature of various elements like leaf, hash ...
This roles requires C<backup> and C<allowed_warp_params> methods.
=head1 METHODS
=head2 merge_properties
Parameters: C<< ( %arguments_to_merge ) >>
Returns a hash containing a first level merge of the constructor
arguments (returned by C<backup> method) and the arguments to merge.
The merge is done only at first level where hash ref are merged (not a
deep merge), scalar and arrays are clobbered.
=head1 AUTHOR
Dominique Dumont
=head1 COPYRIGHT AND LICENSE
lib/Config/Model/Value.pm view on Meta::CPAN
use Carp;
use Storable qw/dclone/;
use Path::Tiny;
use List::Util qw(any) ;
extends qw/Config::Model::AnyThing/;
with "Config::Model::Role::WarpMaster";
with "Config::Model::Role::Grab";
with "Config::Model::Role::HelpAsText";
with "Config::Model::Role::ComputeFunction";
# this requires backup method from Config::Model::AnyThing
with "Config::Model::Role::WarpSubject";
use feature qw/postderef signatures/;
no warnings qw/experimental::postderef experimental::signatures/;
my $logger = get_logger("Tree::Element::Value");
my $user_logger = get_logger("User");
my $change_logger = get_logger("Anything::Change");
my $fix_logger = get_logger("Anything::Fix");
lib/Config/Model/Value.pm view on Meta::CPAN
my @common_list_params = qw/choice/;
has \@common_list_params => ( is => 'ro', isa => 'Maybe[ArrayRef]' );
my @common_str_params = qw/default upstream_default convert match grammar warn/;
has \@common_str_params => ( is => 'ro', isa => 'Maybe[Str]' );
my @warp_accessible_params =
( @common_int_params, @common_str_params, @common_list_params, @common_hash_params );
my @allowed_warp_params = ( @warp_accessible_params, qw/level help/ );
my @backup_list = ( @allowed_warp_params, qw/migrate_from/ );
has compute_is_upstream_default =>
( is => 'ro', isa => 'Bool', lazy => 1, builder => '_compute_is_upstream_default' );
sub _compute_is_upstream_default {
my $self = shift;
return 0 unless defined $self->compute;
return $self->compute_obj->use_as_upstream_default;
}
lib/Config/Model/Value.pm view on Meta::CPAN
clear_warnings => 'clear',
warning_msg => [ join => "\n\t" ],
has_warning => 'count',
has_warnings => 'count',
all_warnings => 'elements',
} );
# as some information must be backed up even though they are not
# attributes, we cannot move code below in BUILD.
around BUILDARGS => sub ($orig, $class, %args) {
my %h = map { ( $_ => $args{$_} ); } grep { defined $args{$_} } @backup_list;
return $class->$orig( backup => dclone( \%h ), %args );
};
# used by roles
sub allowed_warp_params {
return @allowed_warp_params;
}
sub BUILD {
my $self = shift;
$self->set_properties(); # set will use backup data
# used when self is a warped slave
if ( my $warp_info = $self->warp ) {
$self->{warper} = Config::Model::Warper->new(
warped_object => $self,
%$warp_info,
allowed => \@allowed_warp_params
);
}
lib/Config/Model/Value.pm view on Meta::CPAN
return 1;
}
if ( $self->compute_obj->allow_user_override ) {
return 1;
}
return;
}
sub get_default_choice {
my $self = shift;
return @{ $self->{backup}{choice} || [] };
}
sub get_choice {
my $self = shift;
# just in case the reference_object has been changed
if ( defined $self->{refer_to} or defined $self->{computed_refer_to} ) {
$self->{ref_object}->get_choice_from_referred_to;
}
lib/Config/Model/WarpedNode.pm view on Meta::CPAN
use Config::Model::Warper;
use Data::Dumper ();
use Log::Log4perl qw(get_logger :levels);
use Storable qw/dclone/;
use Scalar::Util qw/weaken/;
extends qw/Config::Model::AnyThing/;
with "Config::Model::Role::NodeLoader";
with "Config::Model::Role::Grab";
# this requires backup method from Config::Model::AnyThing
with "Config::Model::Role::WarpSubject";
use feature qw/postderef signatures/;
no warnings qw/experimental::postderef experimental::signatures/;
my $logger = get_logger("Tree::Node::Warped");
# don't authorize to warp 'morph' parameter as it may lead to
# difficult maintenance
# status is not warpable either as an obsolete parameter must stay
# obsolete
my @allowed_warp_params = qw/config_class_name level gist/;
has 'warp' => ( is => 'rw', isa => 'HashRef', default => sub { {}; });
has 'morph' => ( is => 'ro', isa => 'Bool', default => 0 );
has warper => ( is => 'rw', isa => 'Config::Model::Warper' );
my @backup_list = @allowed_warp_params;
around BUILDARGS => sub ($orig, $class, %args) {
my %h = map { ( $_ => $args{$_} ); } grep { defined $args{$_} } @backup_list;
return $class->$orig( backup => dclone( \%h ), %args );
};
# used by roles
sub allowed_warp_params {
return @allowed_warp_params;
}
sub BUILD ($self, $) {
# WarpedNode registers this object in a Value object (the
# warper). When the warper gets a new value, it modifies the
sub check_error {
my ( $obj, $v, $qr ) = @_;
my $old_v = $obj->fetch;
check_store_error(@_);
is( $obj->fetch, $old_v, "check that wrong value $v was not stored" );
}
my $root = $inst->config_root;
subtest "check backup immutability" => sub {
my $i = $root->fetch_element('scalar');
my $backup = $i->backup();
is($backup->{min},1, "check backedup value");
$backup->{min} = 0;
is($i->backup()->{min},1, "check stored backedup value");
};
subtest "simple scalar" => sub {
my $i = $root->fetch_element('scalar');
ok( $i, "test create bounded integer" );
is( $inst->needs_save, 0, "verify instance needs_save status after creation" );
is( $i->needs_check, 1, "verify check status after creation" );
( run in 0.780 second using v1.01-cache-2.11-cpan-af0e5977854 )