package MObjectDB;

use strict;
use vars qw(
  @ISA
  %ObjCache
  %Config $NextID $ChunkSize
  %ChunkLastAccess %DirtyChunks %LoadedChunks
  %Names
  $Do_Not_Write
);

use MInitializable;
@ISA = qw(MInitializable);

use MCoreTools;
use MObject;
use MObjectRef;
use MEvent::Message;
use DB_File;

use constant DB_LOG => 0;
use constant DEBUG_STUFF => 0;

sub _initialize {
  my ($class) = @_;
  
  require MUser; initialize MUser;
  require MTransaction; initialize MTransaction;
  initialize MScheduler;
  initialize MFreezer;

  my @ckeys = grep /^db_/, keys %main::Config;
  @Config{@ckeys} = @main::Config{@ckeys};
  rmkpath($Config{db_path});

  $ChunkSize = $Config{db_file_size};

  if (my $fh = IO::File->new(rfile("$Config{db_path}/db_nextid"))) {
    <$fh> =~ /^(\d+)$/;
    $NextID = $1;
    $NextID or die "can't happen: db_nextid file does not contain valid id";
  } else {
    MEvent::Message->new(name => 'World Bootstrap',
                         target => 'MObjectDB', method => '_world_init', no_store => 1)->schedule;
  }
  $NextID ||= 1;

  MEvent::Message->new(name => 'DB Sync', reschedule => 5*60, no_catch_up => 1, is_real_time => 1,
                       target => 'MObjectDB', method => 'sync', no_store => 1)->schedule;
                       
  tie %Names, 'DB_File', rfile("$Config{db_path}/db_names"), O_CREAT|O_RDWR, DATA_PERMS, $DB_HASH
    or die "ERROR/DB: Names database could not be tied: $!";
}


### Primary interface ########################################################

=item get ID

Returns a MObjectRef for the object with the specified I<ID>, or C<undef> if
the object doesn't exist.

=cut

sub get {
  my ($class, $id) = @_;
  $NextID or confess "DB not initialized";
  if ($id !~ /^\d+$/) {
    croak "ERROR/DB: Non-numeric ID $id passed to MObjectDB::get()";
  }
  return ($class->get_real($id) or return undef)->as_ref;
}

sub get_name {return $_[0]->get($Names{$_[1]} or return undef)}

sub names {keys %Names}

sub is_open {!!$NextID}

### Secondary interface ######################################################

sub sync {
  my ($class) = @_;
  
  
  # alright, if possible, here we fork and do the syncing in a child process.
  # if we can't fork, or the OS doesn't support it, then we sync in the same process.
  
  # this is disabled right now because I realized that forking the sync stuff means
  # that 'dirty' flags/lists don't get cleared. --kpreid 2001-06-22
  
  my $pid;
  $! = 0;
  #if (IS_MACOS or $^O =~ /MSWin/ or !defined($pid = fork())) {
  #  mudlog "Couldn't fork for sync: $!" if $!;
  #} elsif ($pid) {
  #  return;
  #}  
  
  (
    IO::File->new(rfile("$Config{db_path}/db_nextid"), '>', DATA_PERMS) or do {warn $!; $::Quit = 'fatal error'; return}
  )->print($NextID) if $NextID;

  foreach (keys %DirtyChunks) {
    $class->chunk_write($_);
  }
  MScheduler->sync;
  MUser->sync;
  MDefList->sync; # FIXME: all these syncs ought to be somewhere else
  (tied %Names)->sync;
  if (defined $pid and $pid == 0) {
    $::Quit = "no_cleanup";
    exit;
  }
}

sub close {
  my ($class) = @_;
  $class->sync;
  undef $NextID; # must be before decaching
  foreach (keys %LoadedChunks) {
    $class->chunk_decache($_);
  }
  untie %Names;
}

sub cache_cleanup {
  my ($class) = @_;
  return if (scalar keys %LoadedChunks) < (my $siz = $Config{db_cache_size});
  my @chunks = sort {$ChunkLastAccess{$a} <=> $ChunkLastAccess{$b}} keys %LoadedChunks;
  splice @chunks, (@chunks - $siz), $siz;
  foreach (@chunks) {
    $class->chunk_decache($_);
  }
}

### MObject/MObjectRef interface ######################################################

sub OI_set_name {
  my ($class, $obj, $name) = @_;
  my $id = $obj->{_id} or return;
  
  $Names{$name} and croak "CFAIL:Name '$name' already exists.";
  $Names{$name} = $id;
  $obj->{_names}{$name} = 1;
  $class->OI_changed($obj);
}

sub OI_clear_name {
  my ($class, $obj, $name) = @_;
  my $id = $obj->{_id} or return;
  
  $obj->{_names}{$name} or croak "CFAIL:Name '$name' doesn't belong to this object.";
  delete $Names{$name};
  delete $obj->{_names}{$name};
  $class->OI_changed($obj);
}

sub OI_get_names {
  my ($class, $obj) = @_;
  return keys %{$obj->{_names} || {}};
}

sub OI_register_object {
  my ($class, $obj) = @_;
  
  $NextID or confess "DB not initialized";
  my $id = $NextID++;
  _chunk_cache(_chunk_find($id));
  $obj->{'_id'} = $id;
  $obj->{'_creation_time'} = "" . MScheduler::realclock(); # this should always be treated as a string
  $ObjCache{$id} = $obj;
  $class->OI_changed($obj);
}

sub OI_unregister_object {
  my ($class, $obj) = @_;

  $NextID or confess "DB not initialized";

  for (keys %{$obj->{_names} || {}}) {
    delete $Names{$_};
  }
  delete $obj->{_names};
  $class->OI_changed($obj);
  delete $ObjCache{$obj->{_id}};
  delete $obj->{_id};
}

sub OI_changed {
  my ($class, $obj) = @_;
  
  $NextID or confess "DB not initialized";

  my $id = ($obj or return)->{_id};

  my $chunk = _chunk_find($id);
  if (!$DirtyChunks{$chunk}) {
    mudlog "DB: #$id changed, chunk $chunk marked dirty" if DB_LOG;
  }
  $DirtyChunks{$chunk} = 1;
  $ChunkLastAccess{$chunk} = time();
  
  # FIXME: to implement watchers, should have a hook into here
}

sub get_real {
  my ($class, $id, $ctime) = @_;
  
  $NextID or confess "DB not initialized";

  if (!defined($id)) {
    carp "Use of uninitialized value in MObjectDB->get_real()";
    return undef;
  }
  
  my $chunk = _chunk_find($id);
  _chunk_cache($chunk); # no-op if chunk is already cached
  $ChunkLastAccess{$chunk} = time();

  # if the creation time of the requested object is different
  # than that of the object stored, then we pretend it doesn't exist.
  return (
    $ObjCache{$id} and (
      !defined($ctime)
      or $ctime eq $ObjCache{$id}{'_creation_time'}
    )
  ) ? $ObjCache{$id} : undef;
}

sub get_name_real {return $_[0]->get_real($Names{$_[1]} or return undef)}

### Internal functions ########################################################

sub _world_init {
  mudlog "BOOTSTRAP: No world database found. Generating seed world.";
  # putting this in one statement would invoke 'do SUBROUTINE' form
  my $f = rfile('config/seedworld.pl');
  do $f;
}

sub _chunk_find {
  defined $_[0] or croak "Undef passed to _chunk_find!" if DEBUG_STUFF;
  int($_[0] / $Config{db_file_size})
}

sub _chunk_file {
  my ($ch) = @_;
  
  (my $chunk) = $ch =~ /^([0-9]*)$/;
  defined $chunk or croak "Bad chunk ID";
  (join '/', $Config{db_path}, split(//, $chunk)) . '.odb';
}

sub _chunk_cache {
  my ($chunk) = @_;
  return unless !$LoadedChunks{$chunk};
  my $csize = $Config{db_file_size};
  my $start = $chunk * $csize;
  my $end = ($chunk+1) * $csize;
  $LoadedChunks{$chunk} = 1;
  my $cfile = rfile(_chunk_file($chunk));
  if (not -e $cfile) {
    mudlog "DB: Created chunk $chunk" if DB_LOG;
    return;
  }
  my $in = IO::File->new($cfile, '<') or do {
    warn "Couldn't read DB chunk $chunk: " . (0+$_) . $!;
    $::Quit = 'database error';
    $Do_Not_Write = 1;
    return;
  };
  local $/ = ':';
  for (my $i = $start; $i < $end; $i++) {
    my $data_length = <$in>;
    chomp $data_length;
    my $amt_read = read $in, my($buf), $data_length;
    $amt_read == $data_length or do {
      mudlog "ERROR/DB: in chunk $chunk, tried to read $data_length bytes of object data but only got $amt_read bytes";
      $::Quit = 'database corruption';
      return;
    };

    if (length $buf) {
      $buf =~ /^(.*)$/s; # yecch, untaint
      my $data = MFreezer::thaw($1);
      eval {$ObjCache{$i} = bless $data, 'MObject'};
      $@ and mudlog "ERROR/DB: Couldnt thaw #$i:\n$@";
    }
  }
  mudlog "DB: Read chunk $chunk" if DB_LOG;
}

sub chunk_write {
  my ($class, $chunk) = @_;
  return unless $LoadedChunks{$chunk} and !$Do_Not_Write;
  my $csize = $Config{db_file_size};
  my $start = $chunk * $csize;
  my $end = $chunk * $csize + $csize;
  mudlog "DB: Writing chunk $chunk" if DB_LOG;
  my $file = _chunk_file($chunk);
  (my $dir = $file) =~ s#/[^/]+$##;
  rmkpath($dir);
  my $out = IO::File->new(rfile($file), '>', DATA_PERMS);
  my $empties = 0;
  for (my $i = $start; $i < $end; $i++) {
    my $data;
    if ($ObjCache{$i}) {
      # we save a few bytes by not requiring the freezer to store the blessedness of the object
      $data = MFreezer::freeze( { %{$ObjCache{$i}} } );
    } else {
      $data = '';
      $empties++;
    }
    $out->print(length($data) . ':' . $data);
  }
  $out->close;
  if ($empties == $csize) {
    mudlog "DB: Deleting empty chunk file $chunk" if DB_LOG;
    unlink(rfile($file)) or mudlog "ERROR/DB: While attempting to delete empty .odb file: $!";
  }
  delete $DirtyChunks{$chunk};
}

sub chunk_decache {
  my ($class, $chunk) = @_;
  $class->chunk_write($chunk) if $DirtyChunks{$chunk};
  mudlog "DB: Decaching chunk $chunk" ;# if DB_LOG;
  my $csize = $Config{db_file_size};
  my $start = $chunk * $csize;
  my $end = $chunk * $csize + $csize;
  for (my $i = $start; $i < $end; $i++) {
    next unless $ObjCache{$i};
    delete $ObjCache{$i}->{_id};
    delete $ObjCache{$i};
  }
  delete $LoadedChunks{$chunk};
}

1;
__END__
