package MObject;

use strict;
use vars qw(@ISA %Fields %StaleObjects $AUTOLOAD %ModMethods %VerbDefs);
use MFreezer;
use MCoreTools;
use MModules;
use MIndex;
use File::Path qw();

use MObject::CommandInterpreter;

%Fields = (
  %Fields, # so that 'reuse'ing the module doesn't wipe out module field defs
  
  id             => {noset => 1, noinherit => 1},
  _last_age_time => {noset => 1},

  'prototype' => {noinherit => 1},
  connection  => {noinherit => 1, noset => 1, nostore => 1},

  article => {default => 'a'},
  name => {default => 'thing'},
  name_plural => {},
  gender => {default => 'neuter'},
  allow_genders => {default => {}}, # genders appropriate for this object, used in PC creation
);

### Module extensions ##########################################################################################

sub Fields {
  my ($class, %fields) = @_;
  $MModules::ModuleEvalContext or confess 'MObject::Fields called outside of module eval context';
  if ($MModules::ModuleEvalContext eq 'unload') {
    foreach (keys %fields) {delete $Fields{$_};}
  } else {
    foreach (keys %fields) {
      /^_/ and die "Module attempted to define field $_ starting with underscore";
      exists $Fields{$_} and die "Module attempted to redefine field $_";
      $Fields{$_} = $fields{$_};
    }
  }
}

sub Methods {
  my ($class, %methods) = @_;
  $MModules::ModuleEvalContext or croak 'MObject::Methods called outside of module eval context';
  no strict 'refs';
  if ($MModules::ModuleEvalContext eq 'unload') {
    foreach (keys %methods) {
      undef &{"MObject::$_"};
      delete $ModMethods{$_};
    }
  } else {
    foreach (keys %methods) {
      exists $ModMethods{$_} and die "Module attempted to redefine method $_";
      *{"MObject::$_"} = $methods{$_};
      $ModMethods{$_} = 1;
    }
  }
}

sub VerbDefs {
  my ($class, %defs) = @_;
  $MModules::ModuleEvalContext or confess 'MObject::VerbDefs called outside of module eval context';
  if ($MModules::ModuleEvalContext eq 'unload') {
    foreach (keys %defs) {delete $VerbDefs{$_};}
  } else {
    foreach (keys %defs) {
      exists $VerbDefs{$_} and die "Module attempted to redefine field $_";
      $VerbDefs{$_} = $defs{$_};
    }
  }
}

### Object methods - creation/destruction/storage ##########################################################################################

sub new {
  my $class = shift;

  my $self = bless {}, $class;
  print "$self CREATED\n" if ::GC_DEBUG;

  MObjectDB->register_object($self);

  # Initialize fields
  my $key;
  $self->set_val($key, shift()) while $key = shift;

  return $self;
}

sub thaw {
  my ($class, $bytes) = @_;

  my $self = $class->new;

  # add fields from frozen struct, but don't allow them
  # to override 'id' or other pre-set info
  %$self = (%{ MFreezer::thaw($bytes) }, %$self);
  
  __dirty($self);
  $self;
}

sub db_thaw {
  my ($class, $bytes) = @_;
  
  my $self = bless MFreezer::thaw($bytes), $class;
  if ($self->{_events}) {
    # NOTE: event classes must be able to be frozen with no special processing
    MScheduler->add_events(@{$self->{_events}});
    delete $self->{_events};
  }
  return $self;
}

sub freeze {
  my ($self) = @_;

  return MFreezer::freeze($self->clone_for_freeze);
}

sub clone_for_freeze {
  my ($self) = @_;
  my $clone = {};
  foreach (keys %$self) {
    $clone->{$_} = $self->{$_} unless $Fields{$_} and $Fields{$_}{nostore};
  }
  # $self->{_events} = [ map $_->clone, MScheduler->owned_events_for($self) ];
  $clone; 
}

sub dispose {
  my ($self) = @_;
  return unless %$self;

  print "$self disposing: name is @{[$self->name]}\n" if ::GC_DEBUG;
  
  print "$self disposing: calling hooks\n" if ::GC_DEBUG;
  call_hooks('object_destruction', $self);

  print "$self disposing: removing owned tasks\n" if ::GC_DEBUG;
  MScheduler->remove_owned($self) if $self->{id};
    
  print "$self disposing: final destruction\n" if ::GC_DEBUG;
  { ($self->{connection} or last)->detach; }
  
  if (my $id = $self->{id}) {
    $StaleObjects{$id} = 1;
    MObjectDB->unregister_object($self);
    %{$self} = (__UNSTALE => $id);
  }
}

sub DESTROY {
  my ($self) = @_;
  print "$self DESTROYING\n" if ::GC_DEBUG;
  if ($self->{id}) {
    cluck "ERROR/CORE: Registered object being GCed: #$self->{id}";
    $self->dispose;
  }
  if ($self->{__UNSTALE}) {
    delete $StaleObjects{$self->{__UNSTALE}};
  }
  print "$self DESTROYED\n" if ::GC_DEBUG;
  1;
}

sub __dirty { # NOT A METHOD
  MObjectDB->changed_id($_[0]{id});
  # FIXME: add watcher code here
}

### Object methods - game functions ##########################################################################################

sub send          {my $self = shift; ($self->{connection} or return)->send         (@_)}
sub send_page     {my $self = shift; ($self->{connection} or return)->send_page    (@_)}
sub send_multicol {my $self = shift; ($self->{connection} or return)->send_multicol(@_)}

sub uses_output {$_[0]{connection}} # pretend this is boolean

sub nphr {
  my ($self, $qty) = @_;
  my $a = $self->article;
  if ($qty and $qty != 1) {
    #if ($qty == 2) {
    #  return 'a pair of ' . ($self->name_plural || $self->name . 's');
    #} else {
      return ($qty+0) . ' ' . ($self->name_plural || $self->name . 's');
    #}
  } else {
    return ($a ? "$a " : '') . $self->name;
  }
}

sub do_verb {
  my ($self, $caller, $verb, %objects) = @_;
  
  #print("do_verb called on ".$self->nphr." by ".$caller->nphr.", objects:\n");
  #$caller->send_multicol(map {"$_ $objects{$_}"} keys %objects);
  if (exists $VerbDefs{$verb}) {
    $VerbDefs{$verb}->($self, $caller, %objects);
  } else {
    $caller->send($caller->desc_gen("You can't $verb <t>.", t => $self)); # FIXME: desc_gen in core
  }
  #print "do_verb done\n";
}


# this doesn't really fit well
sub as_ref {MObjectRef->new($_[0]->id)}

### Object methods - field management ##########################################################################################

sub fields { # dual method
  my ($this) = @_;
  
  if (ref $this) {
    return grep !/^_/, keys %$this;
  } else {
    return keys %Fields;
  }
}

sub field_attrs { # class method
  my ($class, $field) = @_;

  return $Fields{$field};
}

sub AUTOLOAD {
  my ($method) = $AUTOLOAD =~ /::([^:]+)$/;
  if ($Fields{$method}) {
    no strict 'refs';
    #mudlog "creating autoload sub for $method\n";
    *{$method} = sub {
      return $_[0]->set_val($method, $_[1]) if @_ > 1;
      return $_[0]->get_val($method);
    };
    goto &$AUTOLOAD;
  } else {
    croak "Undefined subroutine $AUTOLOAD called.";
  }
}

sub localize_field {
  my ($self, $field) = @_;
  
  {
    last if exists $self->{$field};
    last unless exists $Fields{$field};
    last unless exists $Fields{$field}{default};
    $self->{$field} = MFreezer::clone($Fields{$field}{default});
  }
  
  # we also make the field dirty because localization implies modification
  # of a complex field
  __dirty($self);
  
  $self;
}

sub get_val {
  my ($self, $field, %prev) = @_;

  return $self->{$field} if exists $self->{$field};
  my $finfo = $Fields{$field};
  my $proto_name = $self->{'prototype'};
  
  if (!$proto_name or ($finfo and $finfo->{noinherit})) {
    return $finfo ? $finfo->{default} : undef;
  }
  
  if ($prev{$proto_name}) {
    mudlog qq!ERROR/WORLD: PROTOTYPE LOOP FOR "$proto_name"!;
    return undef;
  }

  my $proto;
  if (not defined ( $proto = MIndex->get('proto.'.$proto_name) )) {
    mudlog qq!ERROR/WORLD: BAD PROTOTYPE "$proto_name" for object #$self->{id}!;
    return undef;
  }
  if (not ref $proto) {
    mudlog qq!ERROR/WORLD: DAMAGED PROTOTYPE "$proto_name" $proto for object #$self->{id}!;
    return undef;
  }

  return $proto->get_val($field, ($proto_name => 1, %prev));
}

sub set_val {
  @_ % 2 or cluck "Odd number of elements in options to set_val";
  my ($self, $field, $value, %opt) = @_;

  $field =~ /^_/ and croak "Attempt to set_val() field starting with underscore"; 
  my $old = $self->{$field};
  $self->{$field} = $value;

  __dirty($self) unless (defined $old and $old eq $value) or $opt{no_dirty};
  $value;
}

sub reset_val {
  my ($self, $field, $setter) = @_;

  delete $self->{$field};
}

use UNIVERSAL;
sub can {
  my ($self, $method) = @_;
  
  return 1 if $Fields{$method};
  return $self->SUPER::can($method);
}

1;
