File Coverage

blib/lib/Class/Refresh.pm

Criterion	Covered	Total	%
statement	98	125	78.4
branch	22	40	55.0
condition	4	17	23.5
subroutine	23	23	100.0
pod	5	5	100.0
total	152	210	72.3

package Class::Refresh;
BEGIN {
  $Class::Refresh::AUTHORITY = 'cpan:DOY';
}
{
  $Class::Refresh::VERSION = '0.07';
}
use strict;
use warnings;
# ABSTRACT: refresh your classes during runtime

use Carp 'carp';
use Class::Unload;
use Class::Load;
use Try::Tiny;


our %CACHE;

sub import {
    my $package = shift;
    my %opts = @_;

    if ($opts{track_require}) {
        require Devel::OverrideGlobalRequire;
        require B;
        Devel::OverrideGlobalRequire::override_global_require(sub {
            my $next = shift;
            my ($file) = @_;

            my $ret = $next->();

            $package->_update_cache_for($file)
                # require v5.8.1;
                unless ref(\$file) eq 'VSTRING'
                # require 5.008001;
                || !(B::svref_2object(\$file)->FLAGS & B::SVf_POK());

            return $ret;
        });
    }
}


sub refresh {
    my $class = shift;

    $class->refresh_module($_) for $class->modified_modules;
}


sub modified_modules {
    my $class = shift;

    my @ret;
    for my $file (keys %CACHE) {
        # refresh files that are in our
        # %CACHE but not in %INC
        push @ret, $class->_file_to_mod($file)
            if (!$INC{$file});
    }

    for my $file (keys %INC) {
        if (exists $CACHE{$file}) {
            push @ret, $class->_file_to_mod($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 = grep { exists $INC{ $class->_mod_to_file($_) } }
                          $class->_dependent_modules($mod);

    # immutable metaclasses will be automatically recreated when the metaclass
    # itself is loaded, so we don't want to try to do it here (it won't work,
    # since it's an autogenerated class)
    my %metas_for_immutable;
    if (Class::Load::is_class_loaded('Class::MOP')) {
        my @immutable_metas = grep {
            defined $_ && $_->isa('Class::MOP::Class') && $_->is_immutable
        } map { Class::MOP::class_of($_) } @to_refresh;
        for my $meta (@immutable_metas) {
            $metas_for_immutable{ref $meta} = 1;
        }
    }

    # XXX don't know what else to do here
    if (Class::Load::is_class_loaded('Class::MOP')) {
        my @new_to_refresh;
        for my $to_refresh (@to_refresh) {
            my $inc = $INC{ $class->_mod_to_file($to_refresh) } || '';
            if (!$metas_for_immutable{$to_refresh} && $inc eq '(set by Moose)' && Class::MOP::class_of($to_refresh)) {
                carp("Not reloading $to_refresh since it was created dynamically");
                next;
            }
            push @new_to_refresh, $to_refresh;
        }
        @to_refresh = @new_to_refresh;
    }

    $class->unload_module($_) for @to_refresh;

    if (Class::Load::is_class_loaded('Class::MOP')) {
        @to_refresh = grep { !$metas_for_immutable{$_} } @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);

    my $file = $class->_mod_to_file($mod);
    my $last_require_failed = exists $INC{$file} && !defined $INC{$file};

    try {
        Class::Load::load_class($mod);
    }
    catch {
        if ($last_require_failed) {
                # This file failed to load previously.
                # Presumably that error has already been caught, so that's fine
        }
        else {
                die $_;
        }
    }
    finally {
        $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);

    return ($mod) unless $meta;

    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($mod) }
                                 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 1 if !$INC{$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 unless $mod =~ /^\w+(?:::\w+)*$/;

    my $file = $mod;
    $file =~ s{::}{/}g;
    $file .= '.pm';

    return $file;
}


1;

__END__