From 129e7fac6fc245bf498a8bbea34a74edb2147784 Mon Sep 17 00:00:00 2001 From: Jesse Luehrs Date: Sat, 19 Dec 2009 14:05:25 -0600 Subject: initial implementation --- lib/MooseX/Module/Refresh.pm | 46 +++++++++++++++++++++++- t/001-basic.t | 70 ++++++++++++++++++++++++++++++++++++ t/002-moose.t | 86 ++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 201 insertions(+), 1 deletion(-) create mode 100644 t/001-basic.t create mode 100644 t/002-moose.t diff --git a/lib/MooseX/Module/Refresh.pm b/lib/MooseX/Module/Refresh.pm index ce42ead..d8a77a5 100644 --- a/lib/MooseX/Module/Refresh.pm +++ b/lib/MooseX/Module/Refresh.pm @@ -1,6 +1,8 @@ package MooseX::Module::Refresh; use Moose; +extends 'Module::Refresh'; + =head1 NAME MooseX::Module::Refresh - @@ -13,7 +15,49 @@ MooseX::Module::Refresh - =cut -__PACKAGE__->meta->make_immutable; +sub _pm_file_to_mod { + my ($file) = @_; + $file =~ s{\.pm$}{}; + $file =~ s{/}{::}g; + return $file; +} + +after unload_module => sub { + my $self = shift; + my $mod = _pm_file_to_mod($_[0]); + my $meta = Class::MOP::class_of($mod); + return unless defined $meta; + return unless $meta->isa('Moose::Meta::Class'); + if ($meta->is_immutable) { + warn "Can't modify an immutable class"; + return; + } + $self->unload_methods($meta); + $self->unload_attrs($meta); + # XXX: this is probably wrong, but... + $meta->superclasses('Moose::Object'); + bless $meta, 'Moose::Meta::Class'; + # XXX: why is this breaking + #for my $attr ($meta->meta->get_all_attributes) { + #$attr->set_value($meta, $attr->default($meta)); + #} +}; + +sub unload_methods { + my $self = shift; + my ($meta) = @_; + for my $meth ($meta->get_method_list) { + $meta->remove_method($meth) + unless exists $DB::sub{$meta->name . "::$meth"}; + } +} + +sub unload_attrs { + my $self = shift; + my ($meta) = @_; + $meta->remove_attribute($_) for $meta->get_attribute_list; +} + no Moose; =head1 BUGS diff --git a/t/001-basic.t b/t/001-basic.t new file mode 100644 index 0000000..05984d5 --- /dev/null +++ b/t/001-basic.t @@ -0,0 +1,70 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More tests => 7; + +use MooseX::Module::Refresh; + +use File::Temp 'tempdir'; +my $tmp = tempdir( CLEANUP => 1 ); + +my $file = $tmp."/".'FooBar.pm'; +push @INC, $tmp; + +write_out(<<"."); +package Foo::Bar; +sub foo { 'bar' } +1; +. + +use_ok('FooBar', "Required our dummy module"); + +my $r = MooseX::Module::Refresh->new(); + +# is our non-file-based method available? + +can_ok('Foo::Bar', 'not_in_foobarpm'); + +is(Foo::Bar->foo, 'bar', "We got the right result"); + +write_out(<<"."); +package Foo::Bar; +sub foo { 'baz' } +1; +. + +is(Foo::Bar->foo, 'bar', "We got the right result, still"); + +$r->refresh; + +is(Foo::Bar->foo, 'baz', "We got the right new result,"); + +# After a refresh, did we blow away our non-file-based comp? +can_ok('Foo::Bar', 'not_in_foobarpm'); + +$r->unload_subs($file); +ok(!defined(&Foo::Bar::foo), "We cleaned out the 'foo' method'"); + +#ok(!UNIVERSAL::can('Foo::Bar', 'foo'), "We cleaned out the 'foo' method'"); +#require "FooBar.pm"; +#is(Foo::Bar->foo, 'baz', "We got the right new result,"); + +sub write_out { + local *FH; + open FH, "> $file" or die "Cannot open $file: $!"; + print FH $_[0]; + close FH; +} + +END { + unlink $file; +} + + +package Foo::Bar; + +sub not_in_foobarpm { + return "woo"; +} + +1; diff --git a/t/002-moose.t b/t/002-moose.t new file mode 100644 index 0000000..9141eda --- /dev/null +++ b/t/002-moose.t @@ -0,0 +1,86 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More tests => 14; + +use MooseX::Module::Refresh; + +use File::Temp 'tempdir'; +my $tmp = tempdir( CLEANUP => 1 ); + +my $file = $tmp."/".'FooBar.pm'; +push @INC, $tmp; + +write_out(<<"."); +package FooBar; +use Moose; +has foo => (is => 'ro', clearer => 'clear_foo'); +sub bar { 'bar' } +1; +. + +use_ok('FooBar', "Required our dummy module"); + +my $r = MooseX::Module::Refresh->new(); + +# is our non-file-based method available? + +can_ok('FooBar', 'not_in_foobarpm'); + +can_ok('FooBar', 'new'); +my $foobar = FooBar->new(foo => 'FOO'); +is($foobar->bar, 'bar', "We got the right result"); +is($foobar->foo, 'FOO', "We got the right result"); +can_ok($foobar, 'clear_foo'); + +write_out(<<"."); +package FooBar; +has baz => (is => 'ro', predicate => 'foo'); +sub quux { 'baz' } +1; +. + +$foobar = FooBar->new(foo => 'FOO'); +is($foobar->bar, 'bar', "We got the right result, still"); +is($foobar->foo, 'FOO', "We got the right result, still"); + +$r->refresh; + +$foobar = FooBar->new(baz => 'FOO'); +is($foobar->quux, 'baz', "We got the right new result"); +is($foobar->baz, 'FOO', "We got the right new result"); +is($foobar->foo, 1, "We got the right new result"); +ok(!$foobar->can('bar'), "the bar method was removed"); +ok(!$foobar->can('clear_foo'), "the clear_foo method was removed"); + +# After a refresh, did we blow away our non-file-based comp? +can_ok('FooBar', 'not_in_foobarpm'); + +# XXX: figure out what to do about unload_subs +#$r->unload_subs($file); +#ok(!defined(&FooBar::foo), "We cleaned out the 'foo' method'"); + +#ok(!UNIVERSAL::can('FooBar', 'foo'), "We cleaned out the 'foo' method'"); +#require "FooBar.pm"; +#is(FooBar->foo, 'baz', "We got the right new result,"); + +sub write_out { + local *FH; + open FH, "> $file" or die "Cannot open $file: $!"; + print FH $_[0]; + close FH; +} + +END { + unlink $file; +} + + +package FooBar; +use Moose; + +sub not_in_foobarpm { + return "woo"; +} + +1; -- cgit v1.2.3