1package Reflex::Event;
2$Reflex::Event::VERSION = '0.100';
3use Moose;
4use Scalar::Util qw(weaken);
5
6# Class scoped storage.
7# Each event class has a set of attribute names.
8# There's no reason to calculate them every _clone() call.
9my %attribute_names;
10
11has _name => (
12	is      => 'ro',
13	isa     => 'Str',
14	default => 'generic',
15);
16
17has _emitters => (
18	is       => 'ro',
19	isa      => 'ArrayRef[Any]',
20	traits   => ['Array'],
21	required => 1,
22	handles  => {
23		get_first_emitter => [ 'get', 0  ],
24		get_last_emitter  => [ 'get', -1 ],
25		get_all_emitters  => 'elements',
26	}
27);
28
29sub _get_attribute_names {
30	my $self = shift();
31	return(
32		$attribute_names{ ref $self } ||= [
33			map { $_->name() }
34			$self->meta()->get_all_attributes()
35		]
36	);
37}
38
39#sub BUILD {
40#	my $self = shift();
41#
42#	# After build, weaken any emitters passed in.
43#	#my $emitters = $self->_emitters();
44#	#weaken($_) foreach @$emitters;
45#}
46
47sub push_emitter {
48	my ($self, $item) = @_;
49
50	use Carp qw(confess); confess "wtf" unless defined $item;
51
52	my $emitters = $self->_emitters();
53	push @$emitters, $item;
54	#weaken($emitters->[-1]);
55}
56
57sub _headers {
58	my $self = shift();
59	return (
60		map  { "-" . substr($_,1), $self->$_() }
61		grep /^_/,
62		@{ $self->_get_attribute_names() },
63	);
64}
65
66sub _body {
67	my $self = shift();
68	return (
69		map  { $_, $self->$_() }
70		grep /^[^_]/,
71		@{ $self->_get_attribute_names() },
72	);
73}
74
75sub make_event_cloner {
76	my $class = shift();
77
78	my $class_meta = $class->meta();
79
80	my @fetchers;
81	foreach my $attribute_name (
82		map { $_->name } $class_meta->get_all_attributes
83	) {
84		my $override_name = $attribute_name;
85		$override_name =~ s/^_/-/;
86
87		next if $attribute_name eq '_emitters';
88
89		push @fetchers, (
90			join ' ', (
91				"\"$attribute_name\" => (",
92				"(exists \$override_args{\"$override_name\"})",
93				"? \$override_args{\"$override_name\"}",
94				": \$self->$attribute_name()",
95				")",
96			)
97		);
98	}
99
100	my $cloner_code = join ' ', (
101		'sub {',
102		'my ($self, %override_args) = @_;',
103		'my %clone_args = ( ',
104		join(',', @fetchers),
105		');',
106		'my $type = $override_args{"-type"} || ref($self);',
107		'my $emitters = $self->_emitters() || [];',
108		'$type->new(%clone_args, _emitters => [ @$emitters ]);',
109		'}'
110	);
111
112	my $cloner = eval $cloner_code;
113	if ($@) {
114		die(
115			"cloner compile error: $@\n",
116			"cloner: $cloner_code\n"
117		);
118	}
119
120	$class_meta->add_method( _clone => $cloner );
121}
122
123# Override Moose's dump().
124sub dump {
125	my $self = shift;
126
127	my $dump = "=== $self ===\n";
128	my %clone = ($self->_headers(), $self->_body());
129	foreach my $k (sort keys %clone) {
130		$dump .= "  $k: " . ($clone{$k} // '(undef)') . "\n";
131		if ($k eq '-emitters') {
132			my @emitters = $self->get_all_emitters();
133			for my $i (0..$#emitters) {
134				$dump .= "    emitter $i: $emitters[$i]\n";
135			}
136		}
137	}
138
139	# No newline so we get line numbers.
140	$dump .= "===";
141
142	return $dump;
143}
144
145__PACKAGE__->make_event_cloner;
146__PACKAGE__->meta->make_immutable;
147
1481;
149
150__END__
151
152=pod
153
154=encoding UTF-8
155
156=for :stopwords Rocco Caputo
157
158=head1 VERSION
159
160This document describes version 0.100, released on April 02, 2017.
161
162=for Pod::Coverage make_event_cloner push_emitter
163
164=head1 SEE ALSO
165
166Please see those modules/websites for more information related to this module.
167
168=over 4
169
170=item *
171
172L<Reflex|Reflex>
173
174=back
175
176=head1 BUGS AND LIMITATIONS
177
178You can make new bug reports, and view existing ones, through the
179web interface at L<http://rt.cpan.org/Public/Dist/Display.html?Name=Reflex>.
180
181=head1 AUTHOR
182
183Rocco Caputo <rcaputo@cpan.org>
184
185=head1 COPYRIGHT AND LICENSE
186
187This software is copyright (c) 2017 by Rocco Caputo.
188
189This is free software; you can redistribute it and/or modify it under
190the same terms as the Perl 5 programming language system itself.
191
192=head1 AVAILABILITY
193
194The latest version of this module is available from the Comprehensive Perl
195Archive Network (CPAN). Visit L<http://www.perl.com/CPAN/> to find a CPAN
196site near you, or see L<https://metacpan.org/module/Reflex/>.
197
198=head1 DISCLAIMER OF WARRANTY
199
200BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
201FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT
202WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER
203PARTIES PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND,
204EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE
205IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
206PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE
207SOFTWARE IS WITH YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME
208THE COST OF ALL NECESSARY SERVICING, REPAIR, OR CORRECTION.
209
210IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
211WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
212REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE LIABLE
213TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL, OR
214CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE
215SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
216RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
217FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
218SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH
219DAMAGES.
220
221=cut
222