1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
|
package Config::Model::Role::WarpMaster;
# ABSTRACT: register and trigger a warped element
use Mouse::Role;
use strict;
use warnings;
use Mouse::Util;
use Log::Log4perl qw(get_logger :levels);
use Scalar::Util qw/weaken/;
my $logger = get_logger("Warper");
has 'warp_these_objects' => (
traits => ['Array'],
is => 'ro',
isa => 'ArrayRef',
default => sub { [] },
handles => {
_slave_info => 'elements',
_add_slave_info => 'push',
_delete_slave => 'delete',
has_warped_slaves => 'count',
# find_slave_idx => 'first_index', not available in Mouse
},
);
sub register {
my ( $self, $warped, $warper_name ) = @_;
my $w_name = $warped->name;
$logger->debug( $self->get_type . ": " . $self->name, " registered $w_name ($warper_name)" )
if $logger->is_debug;
# weaken only applies to the passed reference, and there's no way
# to duplicate a weak ref. Only a strong ref is created. See
# qw(weaken) module for weaken()
my @tmp = ( $warped, $w_name, $warper_name );
weaken( $tmp[0] );
$self->_add_slave_info( \@tmp );
return defined $self->{compute} ? 'computed' : 'regular';
}
sub unregister {
my ( $self, $w_name ) = @_;
$logger->debug( $self->get_type .": " . $self->name, " unregister $w_name" )
if $logger->is_debug;
my $idx = 0;
foreach my $info ($self->_slave_info) {
last if $info->[0] eq $w_name ;
$idx++;
}
$self->_delete_slave($idx);
return;
}
# And I'm going to warp them ...
sub trigger_warp {
my $self = shift;
my $value = shift;
my $str_val = shift // $value // 'undefined';
foreach my $ref ( $self->_slave_info ) {
my ( $warped, $w_name, $warp_index ) = @$ref;
next unless defined $warped; # $warped is a weak ref and may vanish
# pure warp of object
if ($logger->is_debug) {
$logger->debug("trigger_warp: ".$self->get_type." ", $self->name,
" warps '$w_name' with value <$str_val> ");
}
$warped->trigger( $value, $warp_index );
}
return;
}
sub get_warped_slaves {
my $self = shift;
# grep is used to clean up weak ref to object that were destroyed
return grep { defined $_ } map { $_->[0] } $self->_slave_info;
}
1;
__END__
=head1 SYNOPSIS
package Config::Model::Stuff;
use Mouse;
with Config::Model::Role::WarpMaster
=head1 DESCRIPTION
This role enable a configuration element to become a warp maser, 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 ...
=head1 METHODS
=head2 register
Parameters: C<< ( $warped_object, warper_name ) >>
Register a new warped object. Called by an element which has a C<warp> parameter.
This method is calling on the object pointed by C<follow> value.
=head2 unregister
Parameters: C<< ( warper_name ) >>
Remove a warped object from the object controlled by this warp master.
=head2 trigger_warp
Parameters: C<< ( value, stringified_value ) >>
Called by the object using this role when the value held by this object is changed (i.e.
something like store was called). The passed value can be a plain scalar (from a value
object) or a hash (from a check_list object). The stringified_value is a string shown
in debug log.
-head2 has_warped_slaves
Return the number of object controlled by this master.
=head2 get_warped_slaves
Return a list of object controlled by this master.
=cut
|
