Config-Model

 view release on metacpan or  search on metacpan

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

#
# This file is part of Config-Model
#
# This software is Copyright (c) 2005-2022 by Dominique Dumont.
#
# This is free software, licensed under:
#
#   The GNU Lesser General Public License, Version 2.1, February 1999
#
package Config::Model::AnyId 2.162;

use 5.020;

use Mouse;
with "Config::Model::Role::NodeLoader";
with "Config::Model::Role::Utils";

use Config::Model::Exception;
use Config::Model::Warper;
use Carp qw/cluck croak carp/;
use Log::Log4perl qw(get_logger :levels);
use Storable qw/dclone/;
use Mouse::Util::TypeConstraints;
use Scalar::Util qw/weaken/;

extends qw/Config::Model::AnyThing/;

use feature qw/signatures postderef/;
no warnings qw/experimental::signatures experimental::postderef/;

subtype 'KeyArray' => as 'ArrayRef' ;
coerce 'KeyArray' => from 'Str' => via { [$_] } ;

my $logger = get_logger("Tree::Element::Id");
my $user_logger = get_logger("User");
my $deep_check_logger = get_logger('DeepCheck');
my $fix_logger = get_logger("Anything::Fix");
my $change_logger = get_logger("ChangeTracker");

enum 'DataMode' => [qw/preset layered normal/];

has data_mode => (
    is      => 'rw',
    isa     => 'HashRef[DataMode]',
    traits  => ['Hash'],
    handles => {
        get_data_mode    => 'get',
        set_data_mode    => 'set',
        delete_data_mode => 'delete',
        clear_data_mode  => 'clear',
    },
    default => sub { {}; }
);

# this is cleared and set by set_properties
has _warpable_check_content_actions => (
    is      => 'bare', # no direct accessor
    isa     => 'ArrayRef[CodeRef]',
    traits  => ['Array'],
    handles => {
        add_warpable_check_content   => 'push',
        clear_warpable_check_content => 'clear',
        get_all_warpable_content_checks => 'elements',
    },
    default => sub { []; }
);

has _check_content_actions => (
    is      => 'bare', # no direct accessor
    isa     => 'ArrayRef[CodeRef]',
    traits  => ['Array'],
    handles => {
        add_check_content   => 'push',
        get_all_content_checks => 'elements',
    },
    default => sub { []; }
);

# needs_content_check defaults to 1 to trap bad data right after loading
has needs_content_check => ( is => 'rw', isa => 'Bool', default => 1 );

has has_fixes => (
    is => 'ro',
    isa => 'Num',

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

sub config_class_name {
    my $self = shift;
    return $self->cargo->{config_class_name};
}

sub BUILD {
    my $self = shift;

    croak "Missing cargo->type parameter for element " . $self->{element_name} || 'unknown'
        unless defined $self->cargo->{type};

    if ( $self->cargo->{type} eq 'node' and not $self->cargo->{config_class_name} ) {
        croak "Missing cargo->config_class_name parameter for element "
        . $self->element_name || 'unknown';
    }

    if ( $self->{cargo}{type} eq 'hash' or $self->{cargo}{type} eq 'list' ) {
        die "$self->{element_name}: using $self->{cargo}{type} will probably not work";
    }

    $self->set_properties();

    if ( defined $self->warp ) {
        $self->{warper} = Config::Model::Warper->new(
            warped_object => $self,
            %{ $self->warp },
            allowed => \@allowed_warp_params
        );
    }

    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{$_};
    }

    $self->set_convert( \%args ) if defined $args{convert};

    $self-> clear_warpable_check_content;
    for ( $self-> get_all_content_checks ) {
        $self-> add_warpable_check_content($_);
    }
    for ( qw/duplicates/ ) {
        my $method = "check_$_";
        my $weak_self = $self;
        weaken($weak_self); # weaken reference loop ($self - check_content - closure - self)
        $self-> add_check_content( sub { $weak_self->$method(@_);} ) if  $self->{$_};
    }

    Config::Model::Exception::Model->throw(
        object => $self,
        error  => "Undefined index_type"
    ) unless defined $self->{index_type};

    Config::Model::Exception::Model->throw(
        object => $self,
        error  => "Unexpected index_type $self->{index_type}"
        )
        unless ( $self->{index_type} eq 'integer'
        or $self->{index_type} eq 'string' );

    my @current_idx = $self->_fetch_all_indexes();
    if (@current_idx) {
        my $first_idx = shift @current_idx;
        my $last_idx  = pop @current_idx;

        foreach my $idx ( ( $first_idx, $last_idx ) ) {
            my $ok = $self->check_idx($first_idx);
            next if $ok;

            # here a user input may trigger an exception even if fetch
            # or set value check is disabled. That's mostly because,
            # we cannot enforce more strict settings without random
            # deletion of data. For instance, if a hash contains 5
            # items and the max_nb of items is reduced to 3. Which 2
            # items should we remove ?

            # Since we cannot choose, we must raise an exception in
            # all cases.
            Config::Model::Exception::WrongValue->throw(
                error => "Error while setting id property:"
                    . join( "\n\t", @{ $self->{idx_error_list} } ),
                object => $self
            );
        }
    }

    $self->auto_create_elements;

    if (    defined $self->{duplicates}
        and defined $self->{cargo}
        and $self->{cargo}{type} ne 'leaf' ) {
        Config::Model::Exception::Model->throw(
            object => $self,
            error  => "Cannot specify 'duplicates' with cargo type '$self->{cargo}{type}'",
        );
    }

    my $ok_dup = 'forbid|suppress|warn|allow';
    if ( defined $self->{duplicates} and $self->{duplicates} !~ /^$ok_dup$/ ) {
        Config::Model::Exception::Model->throw(
            object => $self,
            error  => "Unexpected 'duplicates' $self->{duplicates} expected $ok_dup",
        );
    }

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

                                      },
                        cargo => { type => 'node',
                                   config_class_name => 'Dummy'
                                 }
                      },
     ]
  );

Setting C<macro> to C<A> means that C<warped_hash> can only accept
one C<Dummy> class item .

Setting C<macro> to C<B> means that C<warped_hash> accepts two
C<Dummy> class items.

Like other warped class, a HashId or ListId can have multiple warp
masters (See L<Config::Model::Warper/"Warp follow argument">:

  warp => { follow => { m1 => '- macro1', 
                        m2 => '- macro2' 
                      },
            rules  => [ '$m1 eq "A" and $m2 eq "A2"' => { max_nb => 1},
                        '$m1 eq "A" and $m2 eq "B2"' => { max_nb => 2}
                      ],
          }

=head2 Warp and auto_create_ids or auto_create_keys

When a warp is applied with C<auto_create_keys> or C<auto_create_ids>
parameter, the auto_created items are created if they are not already
present. But this warp never removes items that were previously
auto created.

For instance, when a tied hash is created with
C<< auto_create => [a,b,c] >>, the hash contains C<(a,b,c)>.

Then, once a warp with C<< auto_create_keys => [c,d,e] >> is applied,
the hash then contains C<(a,b,c,d,e)>. The items created by the first
auto_create_keys are not removed.

=head2 Warp and max_nb

When a warp is applied, the items that do not fit the constraint
(e.g. min_index, max_index) are removed.

For the max_nb constraint, an exception is raised if a warp
leads to a number of items greater than the max_nb constraint.

=head1 Content check

By default, this class provides an optional content check that checks
for duplicated values (when C<duplicates> parameter is set).

Derived classes can register more global checker with the following method.

=head2 add_check_content

This method expects a sub ref with signature C<( $self, $error, $warn,
$apply_fix )>.  Where C<$error> and C<$warn> are array ref. You can
push error or warning messages there.  C<$apply_fix> is a
boolean. When set to 1, the passed method can fix the warning or the
error. Please make sure to weaken C<$self> to avoid memory cycles.

Example:

 package MyId;
 use Mouse;
 extends qw/Config::Model::HashId/;
 use Scalar::Util qw/weaken/;

 sub setup {
    my $self = shift;
    weaken($self);
    $self-> add_check_content( sub { $self->check_usused_licenses(@_);} )
}

=head1 Introspection methods

The following methods returns the current value stored in the Id
object (as declared in the model unless they were warped):

=over

=item min_index 

=item max_index 

=item max_nb 

=item index_type 

=item default_keys 

=item default_with_init 

=item follow_keys_from

=item auto_create_ids

=item auto_create_keys

=item ordered

=item morph

=item config_model

=back

=head2 get_cargo_type

Returns the object type contained by the hash or list (i.e. returns
C<< cargo -> type >>).

=head2 get_cargo_info

Parameters: C<< ( < what > ) >>

Returns more info on the cargo contained by the hash or list. C<what>
may be C<value_type> or any other cargo info stored in the model.
Returns undef if the requested info is not provided in the model.

=head2 get_default_keys

Returns a list (or a list ref) of the current default keys. These keys
can be set by the C<default_keys> or C<default_with_init> parameters
or by the other hash pointed by C<follow_keys_from> parameter.

=head2 name

Returns the object name. The name finishes with ' id'.

=head2 config_class_name