package Jabber::Reload;
use strict;
use Cwd qw(abs_path);
use vars qw/$DEBUG $VERSION/;
$DEBUG = 1;

$VERSION='0.01';

=pod

=head1 NAME

Jabber::Reload - reload modules 

=head1 DESCRIPTION 

Reload is a helper module to reload modules that have changed during run time.

it is a bit of a copy of Apache::Reload, but not nearly as sophisticated,
it just check the time stamp on the file of a module that is registerd,
whacks the INC entry for it and then reloads over the top.

=head1 EXAMPLES

in the main of your program:

 use Jabber::Reload;

 Jabber::Reload::register(q|Some::Module|);

.... later during the loop

 if ( Jabber::Reload::haveModule(q|Some::Module|) ){
    Jabber::Reload::reload(q|Some::Module|);
 } else {
    Jabber::Reload::loadModule(q|Some::Module|);
 }

also - to ensure that modules loaded and registered 
by Reload are properly available in the current scope,
when using JabberReload::loadModule(), you must put the load in 
a BEGIN {} block like so:

 use Reload;
 BEGIN { Jabber::Reload::loadModule("TTest"); };

so that you can still address methods like this:
 TTest::handler;

as opposed to having to do this:
 TTest->handler;


=head1 AUTHOR

Piers Harding - after a lot of plagarism


=cut


my $modules = {};
my $files = {};


sub register {

my $mod = shift;
  $modules->{$mod} = get_time($mod);
 debug("starting modification time for $mod: ".localtime($modules->{$mod}));

}


sub haveModule{

  my $mod = shift;
    return exists $modules->{$mod} ? 1 : undef;

}


sub loadModule{

  my $mod = shift;
  return unless $mod;
  unless ( exists $modules->{$mod} ){
    unless ( get_path( $mod ) ){
      debug( "Cant locate: $mod ");
      return undef;
    };
    debug( "Loading Module : $mod" );
    eval "use $mod;";
    debug("EVAL ERR: $@ ") if $@;
    register( $mod );
  }

}


sub get_time {

  my $mod = shift;
  my $file = get_path( $mod );
  return undef unless $file;
  return (stat($file) )[9];

}


sub get_path {

  my $mod = shift;

  if ( exists $files->{$mod} ){
    return $files->{$mod};
  } else {
    my $pkg = $mod;
    $pkg =~ s/::/\//g;
    $pkg .= '.pm';
    if ( -f $pkg ){
      $files->{$mod} = $pkg;
      return $pkg;
    } else {
      my @incy = ( @INC );
      foreach ( @incy ){
        if ( -f $_.'/'.$mod.'.pm' ){
          $files->{$mod} = abs_path($_).'/'.$mod.'.pm';
  	  return $files->{$mod};
        }
      }
      return undef;
    }
  }

}

    
sub packageInINC { 
  
  my $mod = shift;
  return undef unless $mod;
  #debug( " \%INC KEYS -  \n".join('',map {  "key: $_ \n" } keys %INC) );
  my $file = get_path($mod);
  return undef unless $file;

  my $pkg = $mod;
  $pkg =~ s/::/\//g;
  $pkg .= '.pm';
  debug("package name: $pkg - file: $file");
  if ( exists $INC{$pkg} ){
    return $pkg;
  }
  return undef;

}


sub reload {

  my $mod = shift;
  #debug("modules is: $mod\n");
  return unless $mod;
  my $mtime = get_time($mod);
  #debug("modification time for $mod is: $mtime\n");
  return undef unless $mtime;
  #debug("$mod comparing: $mtime $modules->{$mod} \n");
  if ( $mtime > $modules->{$mod} ){
    debug("$mod is changed: ".localtime($mtime));
    $modules->{$mod} = $mtime;
    my $file = packageInINC( $mod );
    unless ( $file ){
       debug("Package: $file ($mod) not available in \%INC to reload");
    } else {
      delete $INC{$file} if exists $INC{$file};
#      no strict "refs";
#      undef %{"$mod"};
      delete_package($mod);
      require "$file";
      #eval "use $mod;";
      debug("EVAL ERR: $@ ") if $@;
      debug("Module: $mod reloaded");
      return 1;
    }
  }
  return undef;

}


# cribed from package Symbol
sub delete_package ($) {

    my $mod = shift;
    my $pkg = $mod;

    # expand to full symbol table name if needed
    $pkg .= '::'            unless  $pkg =~ /::$/;

    no strict "refs";
    my $symtab = *{$pkg}{HASH};
    return unless defined $symtab;

    # free all the symbols in the package
    foreach my $name (keys %$symtab) {
      debug("undef: $pkg$name");
      undef %{$pkg . $name};
    }

    # delete the symbol table
    undef %{"$mod"};

}


sub debug {

  return unless $DEBUG;
  print  STDERR scalar localtime().": ", @_, "\n";

}


1;