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