From 07ef384ae88febde8aaccc3bfa44c2dff98c4cdd Mon Sep 17 00:00:00 2001 From: Gianni Ceccarelli Date: Mon, 9 Jan 2012 14:09:58 +0000 Subject: better leak tracing --- author_t/leaks.t | 72 +++++++++++++++++++++++++++++++++----------------------- 1 file changed, 42 insertions(+), 30 deletions(-) diff --git a/author_t/leaks.t b/author_t/leaks.t index f3c811b..629f141 100644 --- a/author_t/leaks.t +++ b/author_t/leaks.t @@ -21,53 +21,65 @@ use Test::Most 'die'; use Data::Printer; use JSON::XS; BEGIN { $ENV{DEBUG_MEM}=1 }; -use Dash::Leak; +use Test::LeakTrace; my $ropts={from=>10,to=>20}; +sub new_obj { + my $obj = Foo->new(rr=>'foo'); + $obj->rr_multi($ropts,777); + return $obj; +} + +my $LOOP=1; + my $json = JSON::XS->new->utf8; -my $obj = Foo->new(rr=>'foo'); -$obj->rr_multi($ropts,777); subtest 'serialisation memory leak' => sub { + my $obj = new_obj; $obj=Foo->new_in_place($json->decode($json->encode($obj->as_hash))); - leaksz 'start memory leak'; - for my $iter (0..2000) { - $obj=Foo->new_in_place($json->decode($json->encode($obj->as_hash))); - } - leaksz 'stop memory leak'; + leaktrace { + for my $iter (1..$LOOP) { + $obj=Foo->new_in_place($json->decode($json->encode($obj->as_hash))); + } + $obj=undef; + } -verbose; ok(1,'done'); }; subtest 'accessor memory leak' => sub { - leaksz 'start memory leak'; - for my $iter (0..1000) { - $obj->rr_multi({at=>35}); - } - leaksz 'stop memory leak non-exist'; - leaksz '...'; - for my $iter (0..1000) { - $obj->rr_multi({at=>15}); - } - leaksz 'stop memory leak exist'; + my $obj = new_obj; + leaktrace { + for my $iter (1..$LOOP) { + $obj->rr_multi({at=>35}); + } + $obj=undef; + } -verbose; + $obj = new_obj; + leaktrace { + for my $iter (1..$LOOP) { + $obj->rr_multi({at=>15}); + } + $obj=undef; + } -verbose; ok(1,'done'); }; subtest 'inner memory leak' => sub { - my $cont = $obj->{rr__MULTIVALUED_STORAGE__} - {_storage}; + my $obj = new_obj; + my $cont = $obj->{rr__MULTIVALUED_STORAGE__}{_storage}; - leaksz 'start memory leak'; - for my $iter (0..1000) { - eval { $cont->get({at=>35}) } - } - leaksz 'stop memory leak non-exist'; - leaksz '...'; - for my $iter (0..1000) { - $cont->get({at=>15}); - } - leaksz 'stop memory leak exist'; + leaktrace { + for my $iter (1..$LOOP) { + eval { $cont->get({at=>35}) } + } + } -verbose; + leaktrace { + for my $iter (1..$LOOP) { + $cont->get({at=>15}); + } + } -verbose; ok(1,'done'); }; -- cgit v1.2.3 From 881c8659c4046dd886c6dc2f73a977c1e1907af8 Mon Sep 17 00:00:00 2001 From: Gianni Ceccarelli Date: Tue, 24 Jan 2012 10:50:00 +0000 Subject: reminder: immutable classes don't work MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit constructor gets inlined, defaults and constructor params don't go through the attribute special methods… --- t/moose-tagged.t | 3 +++ 1 file changed, 3 insertions(+) diff --git a/t/moose-tagged.t b/t/moose-tagged.t index 2493aff..1273bed 100644 --- a/t/moose-tagged.t +++ b/t/moose-tagged.t @@ -24,6 +24,9 @@ has other => ( predicate => 'has_other', clearer => 'clear_other', ); + +#__PACKAGE__->meta->make_immutable; + } package main; use Test::Most 'die'; -- cgit v1.2.3 From f74481a7387de05f95b8ddfd690d8136fb12048f Mon Sep 17 00:00:00 2001 From: Gianni Ceccarelli Date: Tue, 24 Jan 2012 10:50:39 +0000 Subject: cache attributes per class, makes thinks faster MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit hopefully… --- .../MultiValued/UglySerializationHelperRole.pm | 58 +++++++++++++++++----- 1 file changed, 45 insertions(+), 13 deletions(-) diff --git a/lib/Data/MultiValued/UglySerializationHelperRole.pm b/lib/Data/MultiValued/UglySerializationHelperRole.pm index ebf783a..db5a4d8 100644 --- a/lib/Data/MultiValued/UglySerializationHelperRole.pm +++ b/lib/Data/MultiValued/UglySerializationHelperRole.pm @@ -60,10 +60,8 @@ sub new_in_place { my $self = bless $hash,$class; - for my $attr ($class->meta->get_all_attributes) { - if ($attr->does('Data::MultiValued::AttributeTrait')) { - $attr->_rebless_slot($self); - } + for my $attr (@{$class->_dmv_multi_attrs}) { + $attr->_rebless_slot($self); } return $self; } @@ -85,20 +83,54 @@ sub as_hash { my ($self) = @_; my %ret = %$self; - for my $attr ($self->meta->get_all_attributes) { - if ($attr->does('Data::MultiValued::AttributeTrait')) { - my $st = $attr->_as_hash($self); - if ($st) { - $ret{$attr->full_storage_slot} = $st; - } - else { - delete $ret{$attr->full_storage_slot}; - } + for my $attr (@{$self->_dmv_multi_attrs}) { + my $st = $attr->_as_hash($self); + if ($st) { + $ret{$attr->full_storage_slot} = $st; + } + else { + delete $ret{$attr->full_storage_slot}; } } return \%ret; } +{ +my ( + %all_attrs_for_class, + %tagged_attrs_for_class, + %ranged_attrs_for_class, + %multi_attrs_for_class, +); + +sub _dmv_all_attrs { + my ($class) = @_;$class=ref($class)||$class; + + return $all_attrs_for_class{$class} //= [$class->meta->get_all_attributes]; +} +sub _dmv_tagged_attrs { + my ($class) = @_;$class=ref($class)||$class; + + return $tagged_attrs_for_class{$class} //= + [ grep { $_->does('Data::MultiValued::AttributeTrait::Tags') } + @{$class->_dmv_all_attrs} ]; +} +sub _dmv_ranged_attrs { + my ($class) = @_;$class=ref($class)||$class; + + return $ranged_attrs_for_class{$class} //= + [ grep { $_->does('Data::MultiValued::AttributeTrait::Ranges') } + @{$class->_dmv_all_attrs} ]; +} +sub _dmv_multi_attrs { + my ($class) = @_;$class=ref($class)||$class; + + return $multi_attrs_for_class{$class} //= + [ grep { $_->does('Data::MultiValued::AttributeTrait') } + @{$class->_dmv_all_attrs} ]; +} +} + =head1 FINAL WARNING my $obj_clone = My::Class->new_in_place($obj->as_hash); -- cgit v1.2.3