package Module::Refresh;

use strict;
use vars qw( $VERSION %CACHE );

$VERSION = "0.09";

BEGIN { 
    # Turn on the debugger's symbol source tracing
    $^P |= 0x10;

    # Work around bug in pre-5.8.7 perl where turning on $^P
    # causes caller() to be confused about eval {}'s in the stack.
    # (See http://rt.perl.org/rt3/Ticket/Display.html?id=35059 for more info.)
    eval 'sub DB::sub' if $] < 5.008007;
}

=head1 NAME

Module::Refresh - Refresh %INC files when updated on disk

=head1 SYNOPSIS

    # During each request, call this once to refresh changed modules:

    Module::Refresh->refresh;

    # Each night at midnight, you automatically download the latest
    # Acme::Current from CPAN.  Use this snippet to make your running
    # program pick it up off disk:

    $refresher->refresh_module('Acme/Current.pm');

=head1 DESCRIPTION

This module is a generalization of the functionality provided by
L<Apache::StatINC> and L<Apache::Reload>.  It's designed to make it
easy to do simple iterative development when working in a persistent
environment.

It does not require mod_perl.

=cut

=head2 new

Initialize the module refresher.

=cut

sub new {
    my $proto = shift;
    my $self = ref($proto) || $proto;
    $self->update_cache($_) for keys %INC;
    return ($self);
};

=head2 refresh

Refresh all modules that have mtimes on disk newer than the newest ones we've got.
Calls C<new> to initialize the cache if it had not yet been called.

Specifically, it will renew any module that was loaded before the previous call
to C<refresh> (or C<new>) and has changed on disk since then.  If a module was
both loaded for the first time B<and> changed on disk between the previous call 
and this one, it will B<not> be reloaded by this call (or any future one); you
will need to update the modification time again (by using the Unix C<touch> command or
making a change to it) in order for it to be reloaded.

=cut

sub refresh {
    my $self = shift;

    return $self->new if !%CACHE;

    foreach my $mod (sort keys %INC) {
        if ( !$CACHE{$mod} ) {
	    $self->update_cache($mod);
	} elsif ( $self->mtime($INC{$mod}) ne $CACHE{$mod} ) {
            $self->refresh_module($mod);
        }
    }
    return ($self);
};

=head2 refresh_module $module

Refresh a module.  It doesn't matter if it's already up to date.  Just do it.

Note that it only accepts module names like C<Foo/Bar.pm>, not C<Foo::Bar>.

=cut

sub refresh_module {
    my $self = shift;
    my $mod  = shift;

    $self->unload_module($mod);

    local $@;
    eval { require $mod; 1 } or warn $@;

    $self->update_cache($mod);

    return ($self);
};

=head2 unload_module $module

Remove a module from C<%INC>, and remove all subroutines defined in it.

=cut

sub unload_module {
    my $self = shift;
    my $mod  = shift;
    my $file = $INC{$mod};

    delete $INC{$mod};
    delete $CACHE{$mod};
    $self->unload_subs($file);

    return ($self);
};

=head2 mtime $file

Get the last modified time of $file in seconds since the epoch;

=cut

sub mtime {
    return join ' ', ( stat($_[1]) )[1, 7, 9];
};

=head2 update_cache $file

Updates the cached "last modified" time for $file.

=cut

sub update_cache {
    my $self = shift;
    my $module_pm = shift;

    $CACHE{$module_pm} = $self->mtime($INC{$module_pm});
};

=head2 unload_subs $file

Wipe out subs defined in $file.

=cut

sub unload_subs {
    my $self = shift;
    my $file = shift;

    foreach my $sym (
        grep { index( $DB::sub{$_}, "$file:" ) == 0 } keys %DB::sub
    ) {
        warn "Deleting $sym from $file" if ($sym =~ /freeze/);
        eval { undef &$sym };
        warn "$sym: $@" if $@;
        delete $DB::sub{$sym};
    }

    return $self;
};

# "Anonymize" all our subroutines into unnamed closures; so we can safely
# refresh this very package.
BEGIN {
    no strict 'refs';
    foreach my $sym (sort keys %{__PACKAGE__.'::'}) {
        next if $sym eq 'VERSION'; # Skip the version sub, inherited from UNIVERSAL
        my $code = __PACKAGE__->can($sym) or next;
        delete ${__PACKAGE__.'::'}{$sym};
        *$sym = sub { goto &$code };
    }

}

1;

=head1 BUGS

When we walk the symbol table to whack reloaded subroutines, we don't have a good way
to invalidate the symbol table.

=head1 SEE ALSO

L<Apache::StatINC>, L<Module::Reload>

=head1 COPYRIGHT

Copyright 2004 by Jesse Vincent E<lt>jesse@bestpractical.comE<gt>,
Autrijus Tang E<lt>autrijus@autrijus.orgE<gt>

This program is free software; you can redistribute it and/or 
modify it under the same terms as Perl itself.

See L<http://www.perl.com/perl/misc/Artistic.html>

=cut