initial implementation

8 files changed, 302 insertions, 0 deletions

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;