File Coverage

blib/lib/Config/Model/Role/WarpMaster.pm
Criterion Covered Total %
statement 47 47 100.0
branch 10 12 83.3
condition 5 5 100.0
subroutine 10 10 100.0
pod 4 4 100.0
total 76 78 97.4


line stmt bran cond sub pod time code
1             #
2             # This file is part of Config-Model
3             #
4             # This software is Copyright (c) 2005-2022 by Dominique Dumont.
5             #
6             # This is free software, licensed under:
7             #
8             # The GNU Lesser General Public License, Version 2.1, February 1999
9             #
10              
11             # ABSTRACT: register and trigger a warped element
12              
13             use Mouse::Role;
14 59     59   28298 use strict;
  59         112  
  59         439  
15 59     59   17428 use warnings;
  59         139  
  59         1177  
16 59     59   287  
  59         114  
  59         1530  
17             use Mouse::Util;
18 59     59   280 use Log::Log4perl qw(get_logger :levels);
  59         118  
  59         341  
19 59     59   3992 use Scalar::Util qw/weaken/;
  59         118  
  59         398  
20 59     59   7180  
  59         122  
  59         28850  
21             my $logger = get_logger("Warper");
22              
23             has 'warp_these_objects' => (
24             traits => ['Array'],
25             is => 'ro',
26             isa => 'ArrayRef',
27             default => sub { [] },
28             handles => {
29             _slave_info => 'elements',
30             _add_slave_info => 'push',
31             _delete_slave => 'delete',
32             has_warped_slaves => 'count',
33             # find_slave_idx => 'first_index', not available in Mouse
34             },
35             );
36              
37             my ( $self, $warped, $warper_name ) = @_;
38              
39 482     482 1 1181 my $w_name = $warped->name;
40             $logger->debug( $self->get_type . ": " . $self->name, " registered $w_name ($warper_name)" )
41 482         1018 if $logger->is_debug;
42 482 100       1251  
43             # weaken only applies to the passed reference, and there's no way
44             # to duplicate a weak ref. Only a strong ref is created. See
45             # qw(weaken) module for weaken()
46             my @tmp = ( $warped, $w_name, $warper_name );
47             weaken( $tmp[0] );
48 482         3538 $self->_add_slave_info( \@tmp );
49 482         2043  
50 482         1977 return defined $self->{compute} ? 'computed' : 'regular';
51             }
52 482 100       7141  
53             my ( $self, $w_name ) = @_;
54             $logger->debug( $self->get_type .": " . $self->name, " unregister $w_name" )
55             if $logger->is_debug;
56 4     4 1 9  
57 4 50       176 my $idx = 0;
58             foreach my $info ($self->_slave_info) {
59             last if $info->[0] eq $w_name ;
60 4         30 $idx++;
61 4         12 }
62 7 50       62  
63 7         12 $self->_delete_slave($idx);
64             return;
65             }
66 4         15  
67 4         50 # And I'm going to warp them ...
68             my $self = shift;
69             my $value = shift;
70             my $str_val = shift // $value // 'undefined';
71              
72 123     123 1 215 foreach my $ref ( $self->_slave_info ) {
73 123         193 my ( $warped, $w_name, $warp_index ) = @$ref;
74 123   100     526 next unless defined $warped; # $warped is a weak ref and may vanish
      100        
75              
76 123         310 # pure warp of object
77 375         1575 if ($logger->is_debug) {
78 375 100       681 $logger->debug("trigger_warp: ".$self->get_type." ", $self->name,
79             " warps '$w_name' with value <$str_val> ");
80             }
81 340 100       815 $warped->trigger( $value, $warp_index );
82 3         16 }
83             return;
84             }
85 340         2231  
86             my $self = shift;
87 122         323  
88             # grep is used to clean up weak ref to object that were destroyed
89             return grep { defined $_ } map { $_->[0] } $self->_slave_info;
90             }
91 1298     1298 1 1995  
92             1;
93              
94 1298         3635  
  331         609  
  331         1298  
95             =pod
96              
97             =encoding UTF-8
98              
99             =head1 NAME
100              
101             Config::Model::Role::WarpMaster - register and trigger a warped element
102              
103             =head1 VERSION
104              
105             version 2.151
106              
107             =head1 SYNOPSIS
108              
109             package Config::Model::Stuff;
110             use Mouse;
111             with Config::Model::Role::WarpMaster
112              
113             =head1 DESCRIPTION
114              
115             This role enable a configuration element to become a warp maser, i.e. a parameter
116             whose value can change the features of the configuration tree (by controlling a
117             warped_node) or the feature of various elements like leaf, hash ...
118              
119             =head1 METHODS
120              
121             =head2 register
122              
123             Parameters: C<< ( $warped_object, warper_name ) >>
124              
125             Register a new warped object. Called by an element which has a C<warp> parameter.
126             This method is calling on the object pointed by C<follow> value.
127              
128             =head2 unregister
129              
130             Parameters: C<< ( warper_name ) >>
131              
132             Remove a warped object from the object controlled by this warp master.
133              
134             =head2 trigger_warp
135              
136             Parameters: C<< ( value, stringified_value ) >>
137              
138             Called by the object using this role when the value held by this object is changed (i.e.
139             something like store was called). The passed value can be a plain scalar (from a value
140             object) or a hash (from a check_list object). The stringified_value is a string shown
141             in debug log.
142              
143             -head2 has_warped_slaves
144              
145             Return the number of object controlled by this master.
146              
147             =head2 get_warped_slaves
148              
149             Return a list of object controlled by this master.
150              
151             =head1 AUTHOR
152              
153             Dominique Dumont
154              
155             =head1 COPYRIGHT AND LICENSE
156              
157             This software is Copyright (c) 2005-2022 by Dominique Dumont.
158              
159             This is free software, licensed under:
160              
161             The GNU Lesser General Public License, Version 2.1, February 1999
162              
163             =cut