From afab14beccad1c7d6cbbfe8ac4db893c96fab70a Mon Sep 17 00:00:00 2001 From: Jesse Luehrs Date: Tue, 5 Apr 2011 20:57:36 -0500 Subject: initial implementation --- dist.ini | 2 + lib/Class/Refresh.pm | 154 ++++++++++++++++++++++++++++++++++++++ t/01-basic.t | 44 +++++++++++ t/data/01/after/Foo.pm | 10 +++ t/data/01/after/Foo/Immutable.pm | 11 +++ t/data/01/before/Foo.pm | 10 +++ t/data/01/before/Foo/Immutable.pm | 11 +++ t/lib/Test/Class/Refresh.pm | 60 +++++++++++++++ 8 files changed, 302 insertions(+) create mode 100644 t/01-basic.t create mode 100644 t/data/01/after/Foo.pm create mode 100644 t/data/01/after/Foo/Immutable.pm create mode 100644 t/data/01/before/Foo.pm create mode 100644 t/data/01/before/Foo/Immutable.pm create mode 100644 t/lib/Test/Class/Refresh.pm diff --git a/dist.ini b/dist.ini index 8c1d6f3..cfd2dfe 100644 --- a/dist.ini +++ b/dist.ini @@ -7,3 +7,5 @@ copyright_holder = Jesse Luehrs dist = Class-Refresh [Prereqs] +Class::Load = 0 +Class::Unload = 0 diff --git a/lib/Class/Refresh.pm b/lib/Class/Refresh.pm index e69de29..9eea260 100644 --- a/lib/Class/Refresh.pm +++ b/lib/Class/Refresh.pm @@ -0,0 +1,154 @@ +package Class::Refresh; +use strict; +use warnings; + +use Class::Unload; +use Class::Load; + +our %CACHE; + +sub refresh { + my $class = shift; + + $class->refresh_module($_) for $class->modified_modules; +} + +sub modified_modules { + my $class = shift; + + my @ret; + for my $file (keys %INC) { + if (exists $CACHE{$file}) { + push @ret, $file + if $class->_mtime($file) ne $CACHE{$file}; + } + else { + $class->_update_cache_for($file); + } + } + + return @ret; +} + +sub refresh_module { + my $class = shift; + my ($mod) = @_; + $mod = $class->_file_to_mod($mod); + + my @to_refresh = $class->_dependent_modules($mod); + + $class->unload_module($_) for @to_refresh; + $class->load_module($_) for @to_refresh; +} + +sub unload_module { + my $class = shift; + my ($mod) = @_; + $mod = $class->_file_to_mod($mod); + + Class::Unload->unload($mod); + + if (Class::Load::is_class_loaded('Class::MOP')) { + Class::MOP::remove_metaclass_by_name($mod); + } + + $class->_clear_cache_for($mod); +} + +sub load_module { + my $class = shift; + my ($mod) = @_; + $mod = $class->_file_to_mod($mod); + + Class::Load::load_class($mod); + + $class->_update_cache_for($mod); +} + +sub _dependent_modules { + my $class = shift; + my ($mod) = @_; + $mod = $class->_file_to_mod($mod); + + return ($mod) unless Class::Load::is_class_loaded('Class::MOP'); + + my $meta = Class::MOP::class_of($mod); + + if ($meta->isa('Class::MOP::Class')) { + # attribute cloning (has '+foo') means that we can't skip refreshing + # mutable classes + return ( + # NOTE: this order is important! + $mod, + map { $class->_dependent_modules($_) } + ($meta->subclasses, + # XXX: metacircularity? what if $class is Class::MOP::Class? + ($mod->isa('Class::MOP::Class') + ? (map { $_->name } + grep { $_->isa($class) } + Class::MOP::get_all_metaclass_instances()) + : ())), + ); + } + elsif ($meta->isa('Moose::Meta::Role')) { + return ( + $mod, + map { $class->_dependent_modules($_) } $meta->consumers, + ); + } + else { + die "Unknown metaclass: $meta"; + } +} + +sub _update_cache_for { + my $class = shift; + my ($file) = @_; + $file = $class->_mod_to_file($file); + + $CACHE{$file} = $class->_mtime($file); +} + +sub _clear_cache_for { + my $class = shift; + my ($file) = @_; + $file = $class->_mod_to_file($file); + + delete $CACHE{$file}; +} + +sub _mtime { + my $class = shift; + my ($file) = @_; + $file = $class->_mod_to_file($file); + + return join ' ', (stat($INC{$file}))[1, 7, 9]; +} + +sub _file_to_mod { + my $class = shift; + my ($file) = @_; + + return $file unless $file =~ /\.pm$/; + + my $mod = $file; + $mod =~ s{\.pm$}{}; + $mod =~ s{/}{::}g; + + return $mod; +} + +sub _mod_to_file { + my $class = shift; + my ($mod) = @_; + + return $mod if $mod =~ /\.p[lm]$/; + + my $file = $mod; + $file =~ s{::}{/}g; + $file .= '.pm'; + + return $file; +} + +1; diff --git a/t/01-basic.t b/t/01-basic.t new file mode 100644 index 0000000..ce650f3 --- /dev/null +++ b/t/01-basic.t @@ -0,0 +1,44 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use lib 't/lib'; +use Test::Class::Refresh; + +use Class::Refresh; + +my $dir = prepare_temp_dir_for('01'); +push @INC, $dir->dirname; + +require Foo; +require Foo::Immutable; + +Class::Refresh->refresh; + +is_deeply([Foo->meta->get_attribute_list], ['foo'], + "correct starting attr list"); +can_ok('Foo', 'meth'); +ok(!Foo->can('other_meth'), "!Foo->can('other_meth')"); + +is_deeply([Foo::Immutable->meta->get_attribute_list], ['foo'], + "correct starting attr list"); +can_ok('Foo::Immutable', 'meth'); +ok(!Foo::Immutable->can('other_meth'), "!Foo::Immutable->can('other_meth')"); + + +sleep 2; +update_temp_dir_for('01', $dir); + +Class::Refresh->refresh; + +is_deeply([Foo->meta->get_attribute_list], ['bar'], + "correct refreshed attr list"); +can_ok('Foo', 'other_meth'); +ok(!Foo->can('meth'), "!Foo->can('meth')"); + +is_deeply([Foo::Immutable->meta->get_attribute_list], ['bar'], + "correct refreshed attr list"); +can_ok('Foo::Immutable', 'other_meth'); +ok(!Foo::Immutable->can('meth'), "!Foo::Immutable->can('meth')"); + +done_testing; diff --git a/t/data/01/after/Foo.pm b/t/data/01/after/Foo.pm new file mode 100644 index 0000000..716b5c8 --- /dev/null +++ b/t/data/01/after/Foo.pm @@ -0,0 +1,10 @@ +package Foo; +use Moose; + +has bar => (is => 'ro'); + +sub other_meth { } + +no Moose; + +1; diff --git a/t/data/01/after/Foo/Immutable.pm b/t/data/01/after/Foo/Immutable.pm new file mode 100644 index 0000000..9fad73d --- /dev/null +++ b/t/data/01/after/Foo/Immutable.pm @@ -0,0 +1,11 @@ +package Foo::Immutable; +use Moose; + +has bar => (is => 'ro'); + +sub other_meth { } + +__PACKAGE__->meta->make_immutable; +no Moose; + +1; diff --git a/t/data/01/before/Foo.pm b/t/data/01/before/Foo.pm new file mode 100644 index 0000000..a63046a --- /dev/null +++ b/t/data/01/before/Foo.pm @@ -0,0 +1,10 @@ +package Foo; +use Moose; + +has foo => (is => 'ro'); + +sub meth { } + +no Moose; + +1; diff --git a/t/data/01/before/Foo/Immutable.pm b/t/data/01/before/Foo/Immutable.pm new file mode 100644 index 0000000..df3fb53 --- /dev/null +++ b/t/data/01/before/Foo/Immutable.pm @@ -0,0 +1,11 @@ +package Foo::Immutable; +use Moose; + +has foo => (is => 'ro'); + +sub meth { } + +__PACKAGE__->meta->make_immutable; +no Moose; + +1; diff --git a/t/lib/Test/Class/Refresh.pm b/t/lib/Test/Class/Refresh.pm new file mode 100644 index 0000000..9259492 --- /dev/null +++ b/t/lib/Test/Class/Refresh.pm @@ -0,0 +1,60 @@ +package Test::Class::Refresh; +use strict; +use warnings; + +use File::Copy; +use File::Find; +use File::Temp; + +use Sub::Exporter -setup => { + exports => ['prepare_temp_dir_for', 'update_temp_dir_for'], + groups => { default => ['prepare_temp_dir_for', 'update_temp_dir_for'] }, +}; + +sub rcopy { + my ($from_dir, $to_dir) = @_; + + find( + { + no_chdir => 1, + wanted => sub { + my $from = $File::Find::name; + (my $base = $from) =~ s/^$from_dir//; + return unless length $base; + my $to = $to_dir . $base; + if (-d) { + if (!-d $to) { + mkdir $to or die "Couldn't create dir $to: $!"; + } + } + else { + copy($from, $to) or die "Couldn't copy $from to $to: $!"; + utime(undef, undef, $to) + or die "Couldn't set modification time for $to: $!"; + } + }, + }, + $from_dir + ); +} + +sub prepare_temp_dir_for { + my ($test_id) = @_; + + my $from_dir = 't/data/' . $test_id . '/before'; + my $to_dir = File::Temp->newdir; + + rcopy($from_dir, $to_dir); + + return $to_dir; +} + +sub update_temp_dir_for { + my ($test_id, $to_dir) = @_; + + my $from_dir = 't/data/' . $test_id . '/after'; + + rcopy($from_dir, $to_dir); +} + +1; -- cgit v1.2.3-54-g00ecf