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/backup 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 => (
is => 'ro',
isa => 'Config::Model',
weak_ref => 1,
lib/Config/Model/AnyId.pm view on Meta::CPAN
return $self;
}
# this method can be called by the warp mechanism to alter (warp) the
# feature of the Id object.
sub set_properties ($self, @args) {
# mega cleanup
for ( @allowed_warp_params ) { delete $self->{$_}; }
my %args = ( %{ $self->{backup} }, @args );
# these are handled by Node or Warper
for ( qw/level/ ) { delete $args{$_}; }
$logger->trace( $self->name, " set_properties called with @args" );
for ( @common_params ) {
$self->{$_} = delete $args{$_} if defined $args{$_};
}
lib/Config/Model/AnyId.pm view on Meta::CPAN
}
# internal. Handle model declaration arguments
sub handle_args ($self, %args) {
my $warp_info = delete $args{warp};
for (qw/index_class index_type morph ordered/) {
$self->{$_} = delete $args{$_} if defined $args{$_};
}
$self->{backup} = dclone( \%args );
$self->set_properties(%args) if defined $self->{index_type};
if ( defined $warp_info ) {
$self->{warper} = Config::Model::Warper->new(
warped_object => $self,
%$warp_info,
allowed => \@allowed_warp_params
);
}
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
}
return 0;
}
sub open_read_file {
my ($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
#
# New subroutine "load_backend_class" extracted - Thu Aug 12 18:32:37 2010.
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);
}
}
sub open_file_to_write {
my ( $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 {
my ( $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
with "Config::Model::Role::ComputeFunction";
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/ );
has [qw/backup data preset layered/] => ( is => 'rw', isa => 'HashRef', default => sub { {}; } );
has computed_refer_to => ( is => 'rw', isa => 'Maybe[HashRef]' );
has [qw/refer_to/] => ( is => 'rw', isa => 'Str' );
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 ), @_ );
};
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
delete $self->{$_},
}
if ( $logger->is_trace() ) {
my %h = @_;
my $keys = join( ',', keys %h );
$logger->trace("set_properties called on $self->{element_name} with $keys");
}
# merge data passed to the constructor with data passed to set
my %args = ( %{ $self->{backup} }, @_ );
# these are handled by Node or Warper
for (qw/level/) {
delete $args{$_}
}
$self->{ordered} = delete $args{ordered} || 0;
if ( defined $args{choice} ) {
my @choice = @{ delete $args{choice} };
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
}
}
# 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];
}
# 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/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/Value.pm view on Meta::CPAN
my $user_logger = get_logger("User");
my $change_logger = get_logger("Anything::Change");
my $fix_logger = get_logger("Anything::Fix");
our $nowarning = 0; # global variable to silence warnings. Only used for tests
enum ValueType => qw/boolean enum uniline string integer number reference file dir/;
has fixes => ( is => 'rw', isa => 'ArrayRef', default => sub { [] } );
has [qw/warp compute computed_refer_to backup migrate_from/] =>
( is => 'rw', isa => 'Maybe[HashRef]' );
has compute_obj => (
is => 'ro',
isa => 'Maybe[Config::Model::ValueComputer]',
builder => '_build_compute_obj',
lazy => 1
);
has [qw/write_as/] => ( is => 'rw', isa => 'Maybe[ArrayRef]' );
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 );
};
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
}
# warning : call to 'set' are not cumulative. Default value are always
# restored. Lest keeping track of what was modified with 'set' is
# too confusing.
sub set_properties ($self, @args) {
# cleanup all parameters that are handled by warp
for ( @allowed_warp_params ) { delete $self->{$_} }
# merge data passed to the constructor with data passed to set_properties
my %args = ( %{ $self->backup // {} }, @args );
# these are handled by Node or Warper
for ( qw/level/ ) { delete $args{$_} }
if ( $logger->is_trace ) {
$logger->trace( "Leaf '" . $self->name . "' set_properties called with '",
join( "','", sort keys %args ), "'" );
}
if ( defined $args{value_type}
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
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 'backup' => ( is => 'rw', isa => 'HashRef', default => sub { {}; } );
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 {
my $orig = shift;
my $class = shift;
my %args = @_;
my %h = map { ( $_ => $args{$_} ); } grep { defined $args{$_} } @backup_list;
return $class->$orig( backup => dclone( \%h ), @_ );
};
sub BUILD {
my $self = shift;
# WarpedNode registers this object in a Value object (the
# warper). When the warper gets a new value, it modifies the
# WarpedNode according to the data passed by the user.
my $warp_info = $self->warp;
lib/Config/Model/WarpedNode.pm view on Meta::CPAN
else {
return 0;
}
}
return 1;
}
sub set_properties {
my $self = shift;
my %args = ( %{ $self->backup }, @_ );
# mega cleanup
for (@allowed_warp_params) { delete $self->{$_} }
$logger->trace( $self->name . " set_properties called with ",
Data::Dumper->Dump( [ \%args ], ['set_properties_args'] ) );
my $config_class_name = delete $args{config_class_name};
my $node_class = delete $args{class} || 'Config::Model::Node';
( run in 1.259 second using v1.01-cache-2.11-cpan-49f99fa48dc )