package MObject;

use AllocTracker;
use strict;
use vars qw(@ISA %Prototypes %Objects %VDefaults %Values $AUTOLOAD $NextID);
use Carp;
use MGlobals;
use MObject::Scripting;
use MObject::Magic;
use MCommandInterpreter;

#@ISA = qw(AllocTracker);

$NextID = 1 unless defined $NextID;
%Values = map {$_, 1} qw(
  prototype comment
  id container interp
  contents

  connection

  scripts
  aliases vistype flags
  name sdesc ldesc idesc
  c_hit c_move
  m_hit m_move
  weight volume inside
  level
  en_fire en_water en_air en_earth

  str      stradd      int      wis      dex      con      cha
  str_base stradd_base int_base wis_base dex_base con_base cha_base
  hitroll hitroll_base
  damroll damroll_base
  ac ac_base exp
  deaths kills

  ispc saveable myzone
  title gender
  position sdesc_pos
  fighting
  loadroom
  channels
  
  food water drunk

  exits roomflags terrain roomname
);

%VDefaults = (
  vistype => 'object',
  position => 8,
  sdesc_pos => 8,
  gender => 0,
  level => 1,
  flags => 0, roomflags => 0, terrain => 0,
  'exp' => 0, gold => 0,
  ac => 0,
  deaths => 0, kills => 0,
  str_base => 11, str => 11,
  stradd_base => 0, stradd => 0,
  int_base => 11, 'int'=>11,
  wis_base => 11, wis => 11,
  dex_base => 11, dex => 11,
  con_base => 11, con => 11,
  cha_base => 11, cha => 11,
  stradd_base => 0, stradd => 0,
  hitroll_base => 0, hitroll => 0,
  damroll_base => 0, damroll => 0,
  inside => 0,
  m_hit => 0, c_hit => 10000,
  en_fire => 0, en_water => 0, en_air => 0, en_earth => 0,
  m_move => 30, c_move => 10000,
  myzone => -1,
  loadroom => DEF_LOADROOM,
  ldesc => 'You see nothing special.',
  food => 0, water => 0, drunk => 0,

  idesc => 'ERROR: MISSING I-DESC',
  sdesc => 'An unfinished object is lying here.',
  name => 'an unfinished object',
  aliases => [qw(unfinished object)],
  volume => 99999, weight => 99999,
);

### Class methods ##########################################################################################

sub all_objects {
  my ($class) = @_;

  return wantarray ? values %Objects : (values %Objects)[0];
}

sub load_proto_zone {
  my ($self, $ref) = @_;

  my ($type, $path, $filepath) = split_file_ref($ref, 'obj');
  return unless $type eq 'obj';
  local *OBJ;
  open OBJ, $filepath or do {
    syslog("$type:$path - object file not found");
    return;
  };
  my ($oname, $buf) = (-2, '');
  while (defined (my $line = <OBJ>)) {
    if ($line =~ /^\s*(\w+)\s*$/) {
      if ($buf) {
        my $t = $Prototypes{"$path/$oname"};
        $t and $t->dispose;
        $Prototypes{"$path/$oname"} = MObject->thaw_proto($buf);
        $buf = '';
      }
      $oname = $1;
    } else {
      $buf .= $line;
    }
  }
  if ($buf) {
    my $t = $Prototypes{"$path/$oname"};
    $t and $t->dispose;
    $Prototypes{"$path/$oname"} = MObject->thaw_proto($buf);
    $buf = '';
  }
  close OBJ;
}

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

sub new {
  my $class = shift;

  my $self = bless {
    id => $NextID++,
  }, $class;
  $self->{interp} = MCommandInterpreter->new($self, 'any');
  print "$self CREATED\n" if ::GC_DEBUG;
  #$self->ALLOC;
  $Objects{$self->{id}} = $self;

  my $key;
  $self->$key(shift()) while $key = shift;
  $self->set_interp_type if $self->vistype;
  $self->tick;

  return $self;
}

sub new_proto {
  my $class = shift;

  my $self = bless {
  }, $class;
  #$self->ALLOC;

  my $key;
  $self->$key(shift()) while $key = shift;

  return $self;
}

sub thaw_proto {
  my ($class, $text) = @_;

  my $self = bless {}, $class;
  #$self->ALLOC;
  print "$self PROTO THAWED\n" if ::GC_DEBUG;
  $self->load_params($text);
}

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

  my $self = $class->new;
  $self->load_params($text);
}

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

  return () unless $self->{id} || $self->{vistype};
  my $buf = '';
  foreach my $key (sort keys %$self) {
    next if grep $_ eq $key, qw(id connection interp container);
    my $data = $self->{$key};
    if (ref($data) eq 'ARRAY') {
      $data = join(' ', map lwrap($_), @$data);
    } else {
      $data = lwrap($data);
    }
    $buf .= "\%$key=$data\n";
    $buf =~ s/\n{2,}$/\n/;
  }
  return $buf;
}

sub lwrap {
  my ($data) = @_;
  my $oflag = '';
  if (ref $data eq 'MObject') {
    $data = $data->freeze;
    $oflag = 'o';
  }
  $data = '' if not defined $data;
  return $oflag . ($data =~ /^[^{}\n%]*$/
                     ? $data
                     : length($data) . "{$data}");
}

sub load_params {
  my ($self, $text) = @_;

  while ($text) {
    $text =~ s/^[^%]+//;
    last unless $text;
    my ($name, $len, $data);
    $text =~ s/^%(\w+)=// or die "bad input: $text";
    $name = $1;
    $data = [];
    while ($text =~ s/^\s*(o?)(\d+){//) {
      my $str = substr($text, 0, $2);
      substr($text, 0, $2+1) = '';
      push @$data, $1 ? MObject->thaw($str) : $str;
    }
    $text =~ s/\A(.*)$//m;
    push @$data, $1 if length $1;
    # print "lp: data for $name is {@{[join ',', @$data]}}\n";
    $self->$name(@$data == 1 ? $data->[0] : $data);
  }

  $self->set_interp_type;
  # print Data::Dumper::Dumper $self;
  $self;
}

sub dispose {
  my ($self) = @_;
  return unless %$self;
  print "$self disposing: name is @{[$self->name]}\n" if ::GC_DEBUG;
  print "$self disposing: checking contents\n" if ::GC_DEBUG;
  if (my $con = $self->{contents}) {
    foreach (@$con) {
      next unless ref $_;
      $_->container(undef);
    }
    if ($self->{'container'}) {
      $self->{'container'}->add_contents(@$con);
    } else {
      foreach (@$con) {
        $_->dispose if ref $_;
      }
    }
    delete $self->{contents};
  }
  print "$self disposing: checking container\n" if ::GC_DEBUG;
  if ($self->{'container'}) {
    $self->{'container'}->remove_contents($self);
  }
  print "$self disposing: checking playersave\n" if ::GC_DEBUG;
  if ($self->saveable) {
    my ($dname) = lc($self->name) =~ /(^\w+$)/; # untaint, only allow "word" chars in name
    if ($dname) {
      syslog "Writing player file for @{[$self->name]}";
      open PLRSAVE, "> :players:$dname.obj" or die $!;
      print PLRSAVE $self->freeze;
      close PLRSAVE;
    }
  }
  print "$self disposing: final destruction\n" if ::GC_DEBUG;
  if ($self->{connection} and $self->{connection}->open) {
    $self->{connection}->detach;
  }
  delete $Objects{$self->{id}} if $self->{id};
  %{$self} = ();
}

sub DESTROY {
  my ($self) = @_;
  print "$self DESTROYING\n" if ::GC_DEBUG;
  $self->dispose;
  print "$self DESTROYED\n" if ::GC_DEBUG;
  #$self->SUPER::DESTROY;
  1;
}

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

sub find_exit_cmd {
  my ($self, $args) = @_;

  my ($word, $dir) = split /\s+/, $args;

  if (!$word) {
    $self->send("What?");
    return;
  }

  if ($dir) {
    if (my $exit = $self->container->exits->{$dir}) {
      if ($exit->{keywords} and $exit->{keywords} =~ /\b\Q$word\E\b/) {
        return $exit;
      } else {
        $self->send("There is no $word there.");
        return;
      }
    } else {
      $self->send("But there's nothing there!");
      return;
    }
  } else {
    foreach my $exit (values %{$self->container->exits}) {
      if ($exit->{keywords} and $exit->{keywords} =~ /\b\Q$word\E\b/) {
        return $exit;
      }
    }
    $self->send("You don't see a $word here.");
    return 0;
  }
}

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

  $self->check_triggers($TRIG_TYPES{Random});
}

sub command {
  my ($self, $input) = @_;

  $self->{interp}->do($input);
}

sub act {
  my ($self, $mestr, $theystr, $targstr, $targ) = @_;

  $self->send(ucfirst $mestr) if defined $mestr;
  $targ->send(ucfirst $targstr) if defined $targ and $targ->position != POS_SLEEP;

  return unless $self->container and defined $theystr;
  my @exclude = ($self, ($targ ? $targ : ()));

  $self->container->_gsend_from_inside($theystr, @exclude);
  foreach (grep {$_ != $self and ($_ != ($targ||0))} @{$self->container->contents}) {
    $_->_gsend_local($theystr, @exclude);
  }
}

sub _gsend_local {
  my ($self, $str, @exclude) = @_;

  $self->send(ucfirst $str) unless $self->position == POS_SLEEP;

  return unless ($self->flags & 1 << $OBJECTFLAGS{CONT_VIS});

  foreach (grep {my $o = $_; grep {$o != $_} @exclude} @{$self->contents}) {
    $_->_gsend_local("outside, $str", @exclude);
  }
}

sub _gsend_from_inside {
  my ($self, $str, @exclude) = @_;
  # Things happening inside an object are visible to that object, but not to
  # other objects unless the object is CONT_VIS

  $self->send("Inside, $str") unless $self->position == POS_SLEEP;
  
  return unless $self->container and ($self->flags & 1 << $OBJECTFLAGS{CONT_VIS});

  $self->container->_gsend_from_inside($str, @exclude);
  foreach (grep {my $o = $_; grep {$o != $_} @exclude} @{$self->container->contents}) {
    $_->_gsend_local("inside @{[$self->name]}, $str", @exclude);
  }
}

sub echo_to_contents {
  my ($self, $str) = @_;

  foreach (@{$self->contents}) {
    $_->_gsend_local($str);
  }
}

sub passert {
  my ($self, $minpos, $return) = @_;

  return 1 unless $self->position < $minpos;

  $self->send([
    "Er...you seem to be dead.",
    "You can't seem to get your body to do much of anything.",
    "You are incapacitated.",
    "You are stunned.",
    "In your dreams, or what?",
    "Nah...you feel too relaxed to do that.",
    "Maybe you should get on your feet first?",
    "No way! You're fighting for your life!",
    "&sb;[ERROR IN PASSERT]&n;", # shouldn't happen
    "&sb;[ERROR IN PASSERT]&n;", # shouldn't happen
  ]->[$self->position]);
  if ($return) {
    return 0;
  } else {
    die "silent abort";
  }
}

sub move_direction_cmd {
  my ($self, $dir) = @_;

  $self->passert(POS_STAND, 1) or return 0;
  $self->move_direction($dir);
}

sub move_direction {
  my ($self, $dir) = @_;

  return 0 unless %$self;
  my $exit = $self->container->exits->{$dir};
  return 0 unless $exit;

  $self->passert(POS_FIGHT, 1) or return 0;

  $::Rooms{$exit->{to}} or do {
    syslog "ERROR/WORLD: nonexistent room exit $exit->{to} at room @{[$self->container->roomname]}";
    $self->send('You try to go there, but a peculiar force prevents you.');
    return 0;
  };
  my $pts = $TERRAIN_MOVE[$::Rooms{$exit->{to}}->terrain];

  if ($exit->{flags} & (1 << $EXITFLAGS{CLOSED})) {
    $self->act("You try but bump your nose on the $exit->{keywords}.",
               $self->name . " tries to go $dir but bumps $GENDER_POSS[$self->gender] nose on the $exit->{keywords}.");
    return 0;
  }
  if ($self->level < 31) {
    if ($self->m_move and $pts > $self->c_move) {
      $self->send('You are too exhausted.');
      return 0;
    }
    $self->c_move($self->c_move - $pts);
  }

  $self->act(undef, $self->name . ($EXIT_LEAVE{$dir} || " leaves $dir."));
  $self->container->remove_contents($self);
  $::Rooms{$exit->{to}}->add_contents($self);
  $self->act(undef, $self->name . ($EXIT_ENTER{$EXIT_OPP{$dir} || ''} || " has arrived from the $EXIT_OPP{$dir}."));
  $self->command('look');
  return 1;
}

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

  my $maxen = $self->level * 10;
  $self->{en_fire} += ($maxen <=> ($self->{en_fire} || 0));
  $self->{en_water} += ($maxen <=> ($self->{en_water} || 0));
  $self->{en_air} += ($maxen <=> ($self->{en_air} || 0));
  $self->{en_earth} += ($maxen <=> ($self->{en_earth} || 0));

  if ($self->flags & 1 << $OBJECTFLAGS{'ALIVE'}) {
    my $gain = [0, -30, -3, 6, 30, 20, 15, 9, 10, 10]->[$self->position];
    $self->c_hit($self->c_hit + $gain) <= $self->m_hit or $self->c_hit($self->m_hit);
    $self->c_move($self->c_move + $gain) <= $self->m_move or $self->c_move($self->m_move);
    if ($self->level < LVL_IMMORTAL) {
      $self->{food}-- if $self->{food};
      $self->send("You are hungry.") if $self->food < 5;
      $self->{water}-- if $self->{water};
      $self->send("You are thirsty.") if $self->water < 10;
      $self->{drunk}-- if $self->{drunk};
      $self->send("You feel less unsteady.") if $self->drunk == 5;
    }
  }
}

sub speech_proc {
  (my $self, local $_) = @_;

  if ($self->drunk > 5) {for my $i (1..$self->drunk - 5) {
    &{[
      sub {s/s/th/i},
      sub {s/le/la/i},
      sub {s/\B([a-df-ln-z])\1\B/$1$1-$1$1/i},
      sub {s/je/she/i},
      sub {s/go/gaw/i},
      sub {s/ou/aw/i},
      sub {s/o/er/i},
      sub {s/u/ho/i},
      sub {s/e/ay/i},
      sub {s/e/ra/i},
      sub {s/\B[a-z]\B//i},
      sub {s/\s([\w])\B/ $1-$1-$1/i},
    ]->[rand 12]};
  }}
      
  return $_;
}

sub do_attack {
  my ($self, $target) = @_;

  unless ($target and $target->id and $self->container == $target->container) {
    $self->fighting(undef);
    return 0;
  }

  $self->act("&y;You hit @{[$target->name]}.&n",
             "@{[$self->name]} hits @{[$target->name]}.",
             "&r;@{[ucfirst $self->name]} hits you.&n",
             $target);
  $target->fighting($self->id) unless $target->fighting or 
    (not $target->flags & (1 << $OBJECTFLAGS{'ALIVE'}));
  $::Fighting{$target->id} = 1;
  $self->fighting($target->id) unless $self->fighting;
  $::Fighting{$self->id} = 1;
  $target->c_hit($target->c_hit - 6);

  if ($target->c_hit < 0) {
    $self->act(ucfirst $target->name . " is dead! R.I.P.",
               ucfirst $target->name . " is dead! R.I.P.",
               "You are dead! R.I.P.",
               $target);
    my $exp = int($target->exp / 3);
    $self->send("You receive $exp experience points.");
    $self->exp($self->exp + $exp);
    $self->fighting(undef);
    delete $::Fighting{$target->id};
    $target->deaths($target->deaths + 1);
    $self->kills($self->kills + 1);
    $target->dispose;
  }
  1;
}

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

  if ($self->fighting and my $target = $MObject::Objects{$self->fighting}) {
    $self->do_attack($target);
  } else {
    delete $::Fighting{$self->id};
  }
}

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

  if ($self->vistype eq 'character' and $self->position != $self->sdesc_pos) {
    my $flstr = (!$self->{connection} and $self->ispc) ? '(linkless) ' : '';
    return ucfirst $self->name . ($self->title || '') . "&fy; " . $flstr . $POSITIONS[$self->position];
  } else {
    return $self->get_val('sdesc');
  }
}

sub send {
  my ($self, $text) = @_;

  if (not defined $text) {
    carp "Undef passed to MConnection::send";
    return;
  }

  $self->{connection}->send($text) if $self->{connection};
}

sub do_page {$_[0]{connection}->do_page($_[1]) if $_[0]{connection}}

### Object methods - Object searching/contents ##########################################################################################

sub get_any_object {
  my ($self, $name) = @_;
  return $self if lc $name eq 'self' or lc $name eq 'me';
  return $self->container if grep {lc $_ eq lc $name} @{$self->container->aliases};
  my @ob;
  @ob = $self->get_inside_obj($name);
  return wantarray?@ob:$ob[0] if @ob;
  @ob = $self->container->get_inside_obj($name);
  return wantarray?@ob:$ob[0] if @ob;
  @ob = (ref $self)->get_world_obj($name);
  return wantarray?@ob:$ob[0] if @ob;
  return;
}

sub get_vis_object {
  my ($self, $name) = @_;
  return $self if lc $name eq 'self';
  return $self->container if grep {lc $_ eq lc $name} @{$self->container->aliases};
  my @ob;
  @ob = $self->get_inside_obj($name);
  return wantarray?@ob:$ob[0] if @ob;
  @ob = $self->container->get_inside_obj($name);
  return wantarray?@ob:$ob[0] if @ob;
  return;
}

sub get_inside_obj {
  my ($self, $name) = @_;
  (my $index) = $name =~ s/^(\d+)\.(.*)$/$2/;
  $index ||= 1;
  return wantarray ? @{$self->contents} : $self->contents->[0] if $name eq 'all';
  foreach my $obj (@{$self->contents}) {
    next unless grep {lc $_ eq lc $name} @{$obj->aliases};
    next if --$index;
    return $obj;
  }
  return;
}

sub get_world_obj {
  my ($class, $name) = @_;
  (my $index) = $name =~ s/^(\d+)\.(.*)$/$2/;
  $index ||= 1;
  foreach my $obj ($class->all_objects) {
    next unless grep {lc $_ eq lc $name} @{$obj->aliases || []};
    next if --$index;
    return $obj;
  }
  return;
}

sub add_contents {
  my ($self, @objs) = @_;
  
  # carp "add_contents: types of args are @{[join ',', map {ref $_} @objs]}";
  return unless %$self;
  foreach my $obj (@objs) {
    next unless ref $self;
    if ($obj->container) {
      $obj->container->remove_contents($obj);
    }
    $obj->container($self);
    push @{$self->{contents}}, $obj;
  }
}

sub contents {
  my ($self, $objs) = @_;

  if ($objs) {
    $objs = [$objs] if ref $objs ne 'ARRAY';
    $self->remove_contents(@{$self->contents || []});
    $self->add_contents(@$objs);
  } 
  return $self->{contents} || [];
}

sub remove_contents {
  my ($self, @objs) = @_;

  return unless %$self;
  my @new;
  foreach my $obj (@{$self->{'contents'}}) {
    push @new, $obj unless grep $obj == $_, @objs;
  }
  $self->{'contents'} = \@new;
  foreach my $obj (@objs) {
    $obj->{container} = undef if $obj->{container};
  }
}

### Object methods - accessors ##########################################################################################

sub vistype {
  my ($self, $new) = @_;

  if ($new) {
    $self->{vistype} = $new;
    $self->set_interp_type;
  }
  return $self->get_val('vistype');
}

sub flags {
  my ($self, $new) = @_;

  $self->{flags} = $new =~ /^\d*$/ ? $new : parse_flags($new, \%OBJECTFLAGS) if $new;
  return $self->get_val('flags');
}

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

  return unless $self->vistype and $self->{interp};
  $self->{interp}->type( join ' ',
    'v_' . $self->vistype,
    ($self->ispc ? ((map "immortal_$_", 1..($self->level - LVL_IMMORTAL + 1)), 'player') : ()),
    (!$self->ispc || $self->level > 31 ? 'special' : ()),
    (!$self->ispc || $self->level > 30 ? 'nonplayer' : ()),
  );
}

sub aliases {
  my ($self, $new) = @_;

  $self->{aliases} = ref $new ? $new : [split /\s+/, $new] if $new;
  return $self->get_val('aliases');
}

sub scripts {
  my ($self, $new) = @_;

  $self->{scripts} = ref $new ? $new : [split /\s+/, $new] if $new;
  return $self->get_val('scripts');
}

sub channels {
  my ($self, $new) = @_;

  $self->{channels} = ref $new ? $new : [split /\s+/, $new] if $new;
  return $self->get_val('channels');
}

sub AUTOLOAD {
  my ($method) = $AUTOLOAD =~ /::([^:]+)$/;
  if ($Values{$method}) {
    no strict 'refs';
    *{$method} = sub {
      if (@_ > 1) {
        #my $valstr = join ', ', map {defined $_ ? "'$_'" : 'undef'} @_[1..$#_];
        #$valstr =~ s/\n/\\n/g;
        #print "Setting $method to $valstr\n";
        $_[0]->{$method} = $_[1];
        #print "   Done $method to $valstr\n";
      }
      return $_[0]->get_val($method);
    };
    #print "autoload for $AUTOLOAD\n";
    goto &$AUTOLOAD;
  } else {
    croak "No such method: $AUTOLOAD.";
  }
}

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

  return unless defined wantarray;
  return $self->{$field} if defined $self->{$field};
  return $VDefaults{$field} unless defined $self->{'prototype'};
  # print "getting $field from proto $self->{'prototype'}\n";
  if (not defined $Prototypes{$self->{'prototype'}}) {
    # syslog qq/BAD PROTOTYPE "$self->{'prototype'}" for $self "@{[$self->name]}"/;
    return;
  }
  if (ref $Prototypes{$self->{'prototype'}} ne 'MObject') {
    syslog qq/BAD PROTOTYPE "$self->{'prototype'}" for $self "@{[$self->name]}"/;
    return;
  }
  # print "the proto's name: @{[$Prototypes{$self->{'prototype'}}->{'name'}]}\n";
  # print "the proto's proto: @{[$Prototypes{$self->{'prototype'}}->{'prototype'}]}\n"
  #   if $Prototypes{$self->{'prototype'}}->{'prototype'};
  return $Prototypes{$self->{'prototype'}}->get_val($field) || $VDefaults{$field};
}

1;
