server/server/cfperl.xs

/*****************************************************************************/
/*  CrossFire, A Multiplayer game for the X Window System                    */
/*****************************************************************************/

/*
 *  This code is placed under the GNU General Public Licence (GPL)
 *
 *  Copyright (C) 2001-2005 by Chachkoff Yann                               
 *  Copyright (C) 2006      by Marc Lehmann <cf@schmorp.de>
 *                                                                          
 *  This program is free software; you can redistribute it and/or modify    
 *  it under the terms of the GNU General Public License as published by    
 *  the Free Software Foundation; either version 2 of the License, or       
 *  (at your option) any later version.                                     
 *                                                                          
 *  This program is distributed in the hope that it will be useful,         
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of          
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the           
 *  GNU General Public License for more details.                            
 *                                                                          
 *  You should have received a copy of the GNU General Public License       
 *  along with this program; if not, write to the Free Software             
 *  Foundation, Inc. 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301 USA 
*/

#define PLUGIN_NAME    "perl"
#define PLUGIN_VERSION "cfperl 0.5"

#include <plugin_common.h>
#include <sounds.h>
#include <cstdarg>
#include <sproto.h>

#include "cfperl.h"
#include "shstr.h"

#include <EXTERN.h>
#include <perl.h>
#include <XSUB.h>

#include "perlxsi.c"

extern sint64 *levels; // the experience table

typedef object    object_ornull;
typedef mapstruct mapstruct_ornull;

typedef double val64;
#define newSVval64 newSVnv
#define SvVAL64 SvNV

static f_plug_api gethook             = cfapi_get_hooks;
static f_plug_api object_set_property = cfapi_object_set_property;
static f_plug_api object_insert       = cfapi_object_insert;

static HV *obj_cache;
static PerlInterpreter *perl;

static AV *cb_global, *cb_object, *cb_player, *cb_type, *cb_map;

#define PUSHcfapi(type,value)    PUSHs (sv_2mortal (newSVcfapi (CFAPI_ ## type, (value))))
#define PUSHcfapi_va(type,ctype) PUSHcfapi (type, va_arg (args, ctype))
#define PUSH_OB  PUSHcfapi_va(POBJECT, object *)
#define PUSH_PL  PUSHcfapi_va(PPLAYER, player *)
#define PUSH_MAP PUSHcfapi_va(PMAP,    mapstruct *)
#define PUSH_PV  PUSHcfapi_va(STRING,  const char *)
#define PUSH_IV  PUSHs (sv_2mortal (newSViv (va_arg (args, int))))

//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////

static SV *
newSVptr (void *ptr, const char *klass, HV *hv = newHV ())
{
  SV *sv;

  if (!ptr)
    return &PL_sv_undef;

  sv_magic ((SV *)hv, 0, PERL_MAGIC_ext, (char *)ptr, 0);
  return sv_bless (newRV_noinc ((SV *)hv), gv_stashpv (klass, 1));
}

template<class attachable>
SV *
newSVattachable (attachable *obj, const char *klass)
{
  if (!obj)
    return &PL_sv_undef;

  if (!obj->self)
    obj->self = newSVptr (obj, klass);

  return newSVsv (obj->self);
}

static void
SVptr_cache_set (void *ptr, SV *sv)
{
  hv_store (obj_cache, (char *)&ptr, sizeof (ptr), sv, 0);
}

static SV *
SVptr_cache_get (void *ptr)
{
  SV **he = hv_fetch (obj_cache, (char *)&ptr, sizeof (ptr), 0);

  return he ? *he : 0;
}

static SV *
newSVptr_cached (void *ptr, const char *klass)
{
  SV *sv;

  if (!ptr)
    return &PL_sv_undef;

  sv = SVptr_cache_get (ptr);

  if (!sv)
    {
      HV *hv = newHV ();
      sv_magic ((SV *)hv, 0, PERL_MAGIC_ext, (char *)ptr, 0);
      sv = sv_bless (newRV_noinc ((SV *)hv), gv_stashpv (klass, 1));

      SVptr_cache_set (ptr, sv);
    }

  return newSVsv (sv);
}

static void
clearSVptr (SV *sv)
{
  if (SvROK (sv))
    sv = SvRV (sv);

  hv_clear ((HV *)sv);
  sv_unmagic (sv, PERL_MAGIC_ext);
}

static long
SvPTR (SV *sv, const char *klass)
{
  if (!sv_derived_from (sv, klass))
    croak ("object of type %s expected", klass);

  MAGIC *mg = mg_find (SvRV (sv), PERL_MAGIC_ext);

  if (!mg)
    croak ("perl code used %s object, but C object is already destroyed, caught", klass);

  return (long)mg->mg_ptr;
}

static long
SvPTR_ornull (SV *sv, const char *klass)
{
  if (SvOK (sv))
    return SvPTR (sv, klass);
  else
    return 0;
}

inline SV *to_sv (const shstr &  v) { return v ? newSVpvn ((const char *)v, v.length ()) : &PL_sv_undef; }
inline SV *to_sv (const char *   v) { return newSVpv (v, 0); }
inline SV *to_sv (bool           v) { return newSViv (v); }
inline SV *to_sv (  signed char  v) { return newSViv (v); }
inline SV *to_sv (unsigned char  v) { return newSViv (v); }
inline SV *to_sv (  signed short v) { return newSViv (v); }
inline SV *to_sv (unsigned short v) { return newSVuv (v); }
inline SV *to_sv (  signed int   v) { return newSViv (v); }
inline SV *to_sv (unsigned int   v) { return newSVuv (v); }
inline SV *to_sv (  signed long  v) { return newSViv (v); }
inline SV *to_sv (unsigned long  v) { return newSVuv (v); }
inline SV *to_sv (  signed long long v) { return newSVval64 (v); }
inline SV *to_sv (unsigned long long v) { return newSVval64 (v); }
inline SV *to_sv (float          v) { return newSVnv (v); }
inline SV *to_sv (double         v) { return newSVnv (v); }
inline SV *to_sv (player *       v) { return newSVattachable (v, "cf::player::wrap"); }
inline SV *to_sv (object *       v) { return newSVattachable (v, v && v->type == PLAYER ? "cf::object::player::wrap" : "cf::object::wrap"); }
inline SV *to_sv (mapstruct *    v) { return newSVattachable (v, "cf::map::wrap"); }
inline SV *to_sv (archetype *    v) { return newSVptr (v, "cf::arch::wrap"); }
inline SV *to_sv (partylist *    v) { return newSVptr (v, "cf::party::wrap"); }
inline SV *to_sv (region *       v) { return newSVptr (v, "cf::region::wrap"); }
inline SV *to_sv (living *       v) { return newSVptr (v, "cf::living::wrap"); }

inline SV *to_sv (object &       v) { return to_sv (&v); }
inline SV *to_sv (living &       v) { return to_sv (&v); }

//TODO:
inline SV *to_sv (New_Face *     v) { return to_sv (v->name); }
inline SV *to_sv (treasurelist * v) { return to_sv (v->name); }

inline void sv_to (SV *sv, shstr          &v) { v = SvPV_nolen (sv); }
inline void sv_to (SV *sv, char *         &v) { free (v); v = strdup (SvPV_nolen (sv)); } //TODO: verify that all simple pointers are strdup-managed
inline void sv_to (SV *sv, bool           &v) { v = SvIV (sv); }
inline void sv_to (SV *sv,   signed char  &v) { v = SvIV (sv); }
inline void sv_to (SV *sv, unsigned char  &v) { v = SvIV (sv); }
inline void sv_to (SV *sv,   signed short &v) { v = SvIV (sv); }
inline void sv_to (SV *sv, unsigned short &v) { v = SvIV (sv); }
inline void sv_to (SV *sv,   signed int   &v) { v = SvIV (sv); }
inline void sv_to (SV *sv, unsigned int   &v) { v = SvUV (sv); }
inline void sv_to (SV *sv,   signed long  &v) { v = SvIV (sv); }
inline void sv_to (SV *sv, unsigned long  &v) { v = SvUV (sv); }
inline void sv_to (SV *sv,   signed long long &v) { v = SvVAL64 (sv); }
inline void sv_to (SV *sv, unsigned long long &v) { v = SvVAL64 (sv); }
inline void sv_to (SV *sv, float          &v) { v = SvNV (sv); }
inline void sv_to (SV *sv, double         &v) { v = SvNV (sv); }
inline void sv_to (SV *sv, player *       &v) { v = (player *)SvPTR_ornull (sv, "cf::player"); }
inline void sv_to (SV *sv, object *       &v) { v = (object *)SvPTR_ornull (sv, "cf::object"); }
inline void sv_to (SV *sv, archetype *    &v) { v = (archetype *)SvPTR_ornull (sv, "cf::arch"); }
inline void sv_to (SV *sv, mapstruct *    &v) { v = (mapstruct *)SvPTR_ornull (sv, "cf::map"); }
inline void sv_to (SV *sv, partylist *    &v) { v = (partylist *)SvPTR_ornull (sv, "cf::party"); }
inline void sv_to (SV *sv, region *       &v) { v = (region *)SvPTR_ornull (sv, "cf::region"); }
inline void sv_to (SV *sv, living *       &v) { v = (living *)SvPTR_ornull (sv, "cf::living"); }

inline void sv_to (SV *sv, New_Face *     &v) { v = &new_faces[FindFace (SvPV_nolen (sv), 0)]; } //TODO
inline void sv_to (SV *sv, treasurelist * &v) { v = find_treasurelist (SvPV_nolen (sv)); } // TODO

template<int N>
inline void sv_to (SV *sv, char      (&v)[N]) { snprintf (v, N, "%s", SvPV_nolen (sv)); }

static SV *
newSVdt_va (va_list &ap, data_type type)
{
  SV *sv;

  switch (type)
    {
      case DT_INT:
        sv = newSViv (va_arg (ap, int));
        break;

      case DT_INT64:
        sv = newSVval64 ((val64)va_arg (ap, sint64));
        break;

      case DT_DOUBLE:
        sv = newSVnv (va_arg (ap, double));
        break;

      case DT_STRING:
        {
          char *str = (char *)va_arg (ap, const char *);
          sv = str ? newSVpv (str, 0) : &PL_sv_undef;
        }
        break;

      case DT_DATA:
        {
          char *str = (char *)va_arg (ap, const void *);
          int len = va_arg (ap, int);
          sv = str ? newSVpv (str, len) : &PL_sv_undef;
        }
        break;

      case DT_OBJECT:
        sv = to_sv (va_arg (ap, object *));
        break;

      case DT_MAP:
        // va_arg (object *) when void * is passed is an XSI extension
        sv = to_sv (va_arg (ap, mapstruct *));
        break;

      case DT_PLAYER:
        sv = to_sv (va_arg (ap, player *));
        break;

      case DT_ARCH:
        sv = to_sv (va_arg (ap, archetype *));
        break;

      case DT_PARTY:
        sv = to_sv (va_arg (ap, partylist *));
        break;

      case DT_REGION:
        sv = to_sv (va_arg (ap, region *));
        break;

      default:
        assert (("unhandled type in newSVdt_va", 0));
    }

  return sv;
}

static SV *
newSVdt (data_type type, ...)
{
  va_list ap;

  va_start (ap, type);
  SV *sv = newSVdt_va (ap, type);
  va_end (ap);

  return sv;
}

static SV *
newSVcfapi (int type, ...)
{
  SV *sv;

  va_list ap;
  va_start (ap, type);

  switch (type)
    {
      case CFAPI_INT:     sv = newSViv    (*va_arg (ap, int *   )); break;
      case CFAPI_LONG:    sv = newSVval64 (*va_arg (ap, sint64 *)); break;
      case CFAPI_DOUBLE:  sv = newSVnv    (*va_arg (ap, double *)); break;
      case CFAPI_STRING:  sv = newSVdt_va (ap, DT_STRING); break;
      case CFAPI_POBJECT: sv = newSVdt_va (ap, DT_OBJECT); break;
      case CFAPI_PMAP:    sv = newSVdt_va (ap, DT_MAP   ); break;
      case CFAPI_PPLAYER: sv = newSVdt_va (ap, DT_PLAYER); break;
      case CFAPI_PARCH:   sv = newSVdt_va (ap, DT_ARCH  ); break;
      case CFAPI_PPARTY:  sv = newSVdt_va (ap, DT_PARTY ); break;
      case CFAPI_PREGION: sv = newSVdt_va (ap, DT_REGION); break;

      default:
        assert (("unhandled type in newSVcfapi", 0));
    }

  va_end (ap);

  return sv;
}

//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////

SV *
registry_of (attachable_base *ext)
{
  if (!ext->cb)
    ext->cb = newAV ();

  return newRV_inc ((SV *)ext->cb);
}

void attachable_base::clear ()
{
  if (self)
    {
      if (cb)
        if (SvROK (*av_fetch (cb, EVENT_OBJECT_DESTROY, 1)))
          INVOKE_OBJECT (DESTROY, static_cast<object *>(this));
        else if (SvROK (*av_fetch (cb, EVENT_MAP_DESTROY, 1)))
          INVOKE_MAP (DESTROY, static_cast<mapstruct *>(this));

      // disconnect Perl from C, to avoid crashes
      sv_unmagic (SvRV ((SV *)self), PERL_MAGIC_ext);

      // clear the perl hash, might or might not be a good idea
      hv_clear ((HV *)SvRV ((SV *)self));

      SvREFCNT_dec (self);
      self = 0;
    }

  if (cb)
    {
      SvREFCNT_dec (cb);
      cb = 0;
    }

  attach = 0;
}

void attachable_base::optimise ()
{
  if (!self)
    return;

  HV *hv = (HV *)SvRV ((SV *)self);

  if (SvREFCNT ((SV *)self) == 1
      && SvREFCNT ((SV *)hv) == 1
      && !HvKEYS (hv))
    {
      SvREFCNT_dec ((SV *)self);
      self = 0;
    }
}

void attachable_base::instantiate (data_type type, void *obj)
{
  dSP;
  ENTER;
  SAVETMPS;
  PUSHMARK (SP);
  EXTEND (SP, 2);
  PUSHs (sv_2mortal (newSVdt (type, obj)));
  PUSHs (sv_2mortal (newSVpv (attach, 0)));

  attach = 0;

  PUTBACK;
  call_pv ("cf::instantiate", G_DISCARD | G_VOID | G_EVAL);
  FREETMPS;
  LEAVE;

  switch (type)
    {
      case DT_OBJECT: INVOKE_OBJECT (INSTANTIATE, obj); break;
      case DT_MAP:    INVOKE_MAP    (INSTANTIATE, obj); break;
    }
}

/////////////////////////////////////////////////////////////////////////////

void reattach (data_type type, void *obj)
{
  //TODO only do this when the object has _attachment's

  dSP;
  ENTER;
  SAVETMPS;
  PUSHMARK (SP);
  XPUSHs (sv_2mortal (newSVdt (type, obj)));
  PUTBACK;
  call_pv ("cf::reattach", G_DISCARD | G_VOID | G_EVAL);
  FREETMPS;
  LEAVE;

  switch (type)
    {
      case DT_OBJECT: INVOKE_OBJECT (REATTACH, obj); break;
      case DT_PLAYER: INVOKE_PLAYER (REATTACH, obj); break;
      case DT_MAP:    INVOKE_MAP    (REATTACH, obj); break;
    }
}

template<class subclass>
void reattach (attachable<subclass> *obj)
{
  obj->optimise ();

  if (obj->self)
    reattach ((data_type) cftype<subclass>::dt, (subclass *)obj);
}

#include "kw_hash.h"

object_freezer::object_freezer ()
: dynbuf (128 * 1024, 64 * 1024)
{
  av = newAV ();
}

object_freezer::~object_freezer ()
{
  SvREFCNT_dec (av);
}

void object_freezer::put (attachable_base *ext)
{
  ext->optimise ();

  if (ext->self)
    {
      int idx = AvFILLp ((AV *)av) + 1;
      av_store (av, idx, SvREFCNT_inc (ext->self));

      add ((void *)"oid ", 4);
      add ((sint32)idx);
      add ('\n');
    }
}

bool object_freezer::save (const char *filename)
{
  dSP;
  ENTER;
  SAVETMPS;
  PUSHMARK (SP);
  EXTEND (SP, 3);
  PUSHs (sv_2mortal (newSVpv (filename, 0)));
  PUSHs (sv_2mortal (newRV_noinc (newSVpvn ((char *)linearise (), size ()))));
  PUSHs (sv_2mortal (newRV_inc ((SV *)av)));
  PUTBACK;
  call_pv ("cf::object_freezer_save", G_VOID | G_DISCARD | G_EVAL);
  FREETMPS;
  LEAVE;
}

int fprintf (object_freezer &freezer, const char *format, ...)
{
  va_list ap;

  va_start (ap, format);

  int len = vsnprintf ((char *)freezer.force (1024), 1024, format, ap);

  if (len >= 0)
    freezer.alloc (len);

  va_end (ap);
}

int fputs (const char *s, object_freezer &freezer)
{
  freezer.add (s);
}

object_thawer::object_thawer (const char *filename)
{
  static const char eof[] = "\n\n\n\0\0\0";

  av   = 0;
  text = 0;
  line = 0;

  if (filename)
    {
      dSP;
      ENTER;
      SAVETMPS;
      PUSHMARK (SP);
      XPUSHs (sv_2mortal (newSVpv (filename, 0)));
      PUTBACK;

      if (2 == call_pv ("cf::object_thawer_load", G_ARRAY | G_EVAL))
        {
          SPAGAIN;

          // second value - perl objects
          {
            SV *sv = POPs;
            if (SvROK (sv))
              av = (AV *)SvREFCNT_inc (SvRV (sv));
          }

          // first value - text part, pad with 3 zeroes
          {
            SV *sv = POPs;
            STRLEN len;
            char *sv_ = SvPVbyte (sv, len);
            text = newSV (len + sizeof (eof));
            SvCUR_set (text, len);
            memcpy (SvPVX (text), sv_, len);
            memcpy (SvEND (text), eof, sizeof (eof)); // just to be sure

            line = SvPVX (text);
          }
        }

      PUTBACK;
      FREETMPS;
      LEAVE;
    }
}

void object_thawer::get (data_type type, void *obj, attachable_base *ext, int oid)
{
  if (!av || oid < 0) // this is actually an error of sorts
    return;

  // we have to "re-instantiate"/reattach to an object, so nuke ext->attach
  ext->clear ();

  SV **svp = av_fetch ((AV *)av, oid, 0);

  if (!svp || !SvROK (*svp))
    {
      printf ("trying to thaw duplicate or never-issued oid %d, ignoring.\n", oid);
      return;
    }

  ext->self = *svp; *svp = &PL_sv_undef;
  sv_magic (SvRV (ext->self), 0, PERL_MAGIC_ext, (char *)obj, 0);

  reattach (type, obj);
}

object_thawer::~object_thawer ()
{
  if (text) SvREFCNT_dec (text);
  if (av)   SvREFCNT_dec (av);
}

char *fgets (char *s, int n, object_thawer &thawer)
{
  char *p = thawer.line;
  char *q = s;

  if (!p)
    return 0;

  while (--n)
    {
      if (!*p)
        break;

      *q++ = *p;

      if (*p++ == '\n')
        break;
    }

  *q = 0;
  thawer.line = p;

  return s == q ? 0 : s;
}

keyword object_thawer::get_kv ()
{
  if (!line)
    return KW_EOF;

  for (;;)
    {
      char *p = line;

      if (!*p)
        return KW_EOF;

      // parse keyword
      while (*p > ' ')
        p++;

      int klen = p - line;

      if (*p++ != '\n')
        {
          // parse value
          while (*(unsigned char *)p <= ' ' && *p != '\n') // skip 0x01 .. 0x20
            ++p;

          last_value = p;

          while (*p != '\n')
            p++;

          *p++ = 0;
        }
      else
        last_value = 0;

      line [klen] = 0;
      keyword_idx *kw = kw_lex::match (line, klen);

      //printf ("KV %d<%s,%s>\n", kw ? kw->index : 0, line, last_value);//D

      if (kw)
        {
          line = p;
          return kw->index;
        }
      else if (!*line || *line == '#')
        {
          // empty/comment line
          line = p;
        }
      else
        return KW_ERROR;
    }
}
 
void object_thawer::get (shstr &sh) const
{
  if (last_value)
    sh = last_value;
  else
    {
      sh = "<value missing>";
      LOG (llevError, "keyword requires value: <%s>\n", line);//TODO: add filename
    }
}

void object_thawer::get_ml (keyword kend, shstr &sh)
{
  char kw[128];

  int klen = keyword_len [kend];

  kw [0] = '\n';
  memcpy (kw + 1, keyword_str [kend], klen);
  kw [klen + 1] = '\n';
  kw [klen + 2] = 0;

  // first test for completely empty msg... "endXXX\n"
  if (!strncmp (line, kw + 1, klen + 1))
    {
      sh = 0;

      line += klen + 1;

      return;
    }
  else
    {
      // multi-line strings are delimited by "\nendXXX\n" or "endXXX\n" (NULL)

      char *end = strstr (line, kw);

      if (!end)
        {
          sh = 0;
          return;
        }

      *end = 0;
      sh = line;

      line = end + keyword_len [kend] + 1;

      while (*line++ != '\n')
        ;
    }
}

sint32 object_thawer::get_sint32 () const
{
  char *p = last_value;

  if (!p)
    return 0;

  sint32 val = 0;
  bool negate;

  if (*p == '-')
    {
      negate = true;
      ++p;
    }
  else
    negate = false;

  do
    {
      val *= 10;
      val += *p++ - '0';
    }
  while (*p);

  return negate ? -val : val;
}

sint64 object_thawer::get_sint64 () const
{
  return last_value ? atoll (last_value) : 0;
}

double object_thawer::get_double () const
{
  return last_value ? atof (last_value) : 0;
}

/////////////////////////////////////////////////////////////////////////////

extern "C" int cfperl_initPlugin (const char *iversion, f_plug_api gethooksptr)
{
  return 0;
}

static CommArray_s rtn_cmd;

static int
runPluginCommand (object *obj, char *params)
{
  dSP;

  ENTER;
  SAVETMPS;

  PUSHMARK (SP);

  EXTEND (SP, 3);
  PUSHs (sv_2mortal (newSVpv (rtn_cmd.name, 0)));
  PUSHs (sv_2mortal (newSVcfapi (CFAPI_POBJECT, obj)));

  if (params)
    PUSHs (sv_2mortal (newSVpv (params, 0)));

  PUTBACK;
  int count = call_pv ("cf::inject_command", G_SCALAR | G_EVAL);
  SPAGAIN;

  if (SvTRUE (ERRSV))
    LOG (llevError, "command '%s' callback evaluation error: %s", rtn_cmd.name, SvPV_nolen (ERRSV));

  int returnvalue = count > 0 ? POPi : -1;

  PUTBACK;
  FREETMPS;
  LEAVE;

  return returnvalue;
}

extern "C" void *cfperl_getPluginProperty (int *type, ...)
{
  va_list args;
  char *propname;
  int i;
  va_start (args, type);
  propname = va_arg (args, char *);
  //printf ("Property name: %s\n", propname);
 
  if (!strcmp (propname, "command?"))
    {
      if (!perl)
        return NULL;

      const char *cmdname = va_arg (args, const char *);
      HV *hv = get_hv ("cf::COMMAND", 1);
      SV **svp = hv_fetch (hv, cmdname, strlen (cmdname) + 1, 0);

      va_end (args);

      if (svp)
        {
          // this is totaly broken, should stash it into %COMMAND
          rtn_cmd.name = cmdname;
          rtn_cmd.time = SvNV (*svp);
          rtn_cmd.func = runPluginCommand;

          return &rtn_cmd;
        }
    }
  else if (!strcmp (propname, "Identification"))
    {
      va_end (args);
      return (void*) PLUGIN_NAME;
    }
  else if (!strcmp (propname, "FullName"))
    {
      va_end (args);
      return (void*) PLUGIN_VERSION;
    }
  else
    va_end (args);

  return NULL;
}

extern "C" int cfperl_postInitPlugin ()
{
  int hooktype = 1;
  int rtype = 0;

  cf_init_plugin (gethook);

  return 0;
}

extern "C" int cfperl_closePlugin ()
{
  return 0;
}

void
cfperl_init ()
{
  PERL_SYS_INIT3 (&settings.argc, &settings.argv, 0);
  perl = perl_alloc ();
  perl_construct (perl);

  PL_exit_flags |= PERL_EXIT_DESTRUCT_END;

  char *argv[] = {
    "",
    "-e"
    "cf->bootstrap;"
    "unshift @INC, cf::datadir ();"
    "require cf;"
  };

  if (perl_parse (perl, xs_init, 2, argv, (char **)NULL) || perl_run (perl))
    {
      printf ("unable to initialize perl-interpreter, aborting.\n");
      exit (EXIT_FAILURE);
    }

  obj_cache = newHV ();
}

void cfperl_main ()
{
  dSP;

  PUSHMARK (SP);
  PUTBACK;
  call_pv ("cf::main", G_DISCARD | G_VOID);
}

static event_klass klass_of[NUM_EVENT_TYPES] = {
# define def(type,name) KLASS_ ## type,
#  include "eventinc.h"
# undef def
};

#define KLASS_OF(event) (((unsigned int)event) < NUM_EVENT_TYPES ? klass_of [event] : KLASS_NONE)

static void
gather_callbacks (AV *&callbacks, AV *registry, event_type event)
{
  // event must be in array
  if (event >= 0 && event <= AvFILLp (registry))
    {
      SV *cbs_ = AvARRAY (registry)[event];

      // element must be list of callback entries
      if (cbs_ && SvROK (cbs_) && SvTYPE (SvRV (cbs_)) == SVt_PVAV)
        {
          AV *cbs = (AV *)SvRV (cbs_);

          // no callback entries, no callbacks to call
          if (AvFILLp (cbs) >= 0)
            {
              if (!callbacks)
                {
                  callbacks = newAV ();
                  av_extend (callbacks, 16);
                }
              
              // never use SvREFCNT_inc to copy values, but its ok here :)
              for (int i = 0; i <= AvFILLp (cbs); ++i)
                av_push (callbacks, SvREFCNT_inc (AvARRAY (cbs)[i]));
            }
        }
    }
}

bool cfperl_invoke (event_type event, ...)
{
  data_type dt;
  va_list ap;

  va_start (ap, event);

  AV *callbacks = 0;

  object *op;
  player *pl;
  mapstruct *map;

  // callback call ordering is:
  // 1. per-object callback (NYI)
  // 2. per-class object
  // 2a. per-type callback
  // 4. global callbacks

  gather_callbacks (callbacks, cb_global, event);

  switch (KLASS_OF (event))
    {
      case KLASS_GLOBAL:
        break;

      case KLASS_OBJECT:
        dt = (data_type) va_arg (ap, int);
        assert (("first argument must be of type object", dt == DT_OBJECT));
        op = va_arg (ap, object *);

        if (op->cb)
          gather_callbacks (callbacks, op->cb, event);

        if (op->type)
          {
            if (op->subtype && op->type + op->subtype * NUM_SUBTYPES <= AvFILLp (cb_type))
              {
                SV *registry = AvARRAY (cb_type)[op->type + op->subtype * NUM_SUBTYPES];

                if (registry && SvROK (registry) && SvTYPE (SvRV (registry)) == SVt_PVAV)
                  gather_callbacks (callbacks, (AV *)SvRV (registry), event);
              }

            if (op->type <= AvFILLp (cb_type))
              {
                SV *registry = AvARRAY (cb_type)[op->type];

                if (registry && SvROK (registry) && SvTYPE (SvRV (registry)) == SVt_PVAV)
                  gather_callbacks (callbacks, (AV *)SvRV (registry), event);
              }
          }

        gather_callbacks (callbacks, cb_object, event);

        break;

      case KLASS_PLAYER:
        dt = (data_type) va_arg (ap, int);
        assert (("first argument must be of type player", dt == DT_PLAYER));
        pl = va_arg (ap, player *);

        if (pl->cb)
          gather_callbacks (callbacks, pl->cb, event);

        gather_callbacks (callbacks, cb_player, event);
        break;

      case KLASS_MAP:
        dt = (data_type) va_arg (ap, int);
        assert (("first argument must be of type object", dt == DT_MAP));
        map = va_arg (ap, mapstruct *);

        if (map->cb)
          gather_callbacks (callbacks, map->cb, event);

        gather_callbacks (callbacks, cb_map, event);
        break;

      default:
        assert (("unsupported event klass in cfperl_invoke", 0));
    }

  // short-circuit processing if no callbacks found/defined
  if (!callbacks)
    return 0;

  dSP;
  ENTER;
  SAVETMPS;

  PUSHMARK (SP);
  EXTEND (SP, 3);

  PUSHs (sv_2mortal (newSViv (event))); // only used for debugging nowadays
  PUSHs (sv_2mortal (newRV_noinc ((SV *)callbacks)));

  switch (KLASS_OF (event))
    {
      case KLASS_OBJECT: PUSHs (sv_2mortal (newSVdt (DT_OBJECT, op)));  break;
      case KLASS_PLAYER: PUSHs (sv_2mortal (newSVdt (DT_PLAYER, pl)));  break;
      case KLASS_MAP:    PUSHs (sv_2mortal (newSVdt (DT_MAP,    map))); break;
    }

  for (;;)
    {
      dt = (data_type) va_arg (ap, int);

      if (dt == DT_END)
        break;

      if (dt == DT_AV)
        {
          AV *av = va_arg (ap, AV *);

          for (int i = 0; i <= av_len (av); ++i)
            XPUSHs (*av_fetch (av, i, 1));
        }
      else
        XPUSHs (sv_2mortal (newSVdt_va (ap, dt)));
    }

  va_end (ap);

  PUTBACK;
  int count = call_pv ("cf::do_invoke", G_SCALAR | G_EVAL);
  SPAGAIN;

  count = count > 0 ? POPi : 0;

  FREETMPS;
  LEAVE;

  return count;
}

SV *
cfperl_result (int idx)
{
  AV *av = get_av ("cfperl::invoke_results", 0);
  if (!av)
    return &PL_sv_undef;

  SV **sv = av_fetch (av, idx, 0);
  if (!sv)
    return &PL_sv_undef;

  return *sv;
}

int
cfperl_result_INT (int idx)
{
  return SvIV (cfperl_result (idx));
}

MODULE = cf             PACKAGE = cf         PREFIX = cf_

BOOT:
{
  HV *stash = gv_stashpv ("cf", 1);

  static const struct {
    const char *name;
    IV iv;
  } *civ, const_iv[] = {
#   define const_iv(name) { # name, (IV)name },
    const_iv (llevError)
    const_iv (llevInfo)
    const_iv (llevDebug)
    const_iv (llevMonster)

    const_iv (MAX_TIME)
    const_iv (PLAYER)
    const_iv (TRANSPORT)
    const_iv (ROD)
    const_iv (TREASURE)
    const_iv (POTION)
    const_iv (FOOD)
    const_iv (POISON)
    const_iv (BOOK)
    const_iv (CLOCK)
    const_iv (LIGHTNING)
    const_iv (ARROW)
    const_iv (BOW)
    const_iv (WEAPON)
    const_iv (ARMOUR)
    const_iv (PEDESTAL)
    const_iv (ALTAR)
    const_iv (LOCKED_DOOR)
    const_iv (SPECIAL_KEY)
    const_iv (MAP)
    const_iv (DOOR)
    const_iv (KEY)
    const_iv (TIMED_GATE)
    const_iv (TRIGGER)
    const_iv (GRIMREAPER)
    const_iv (MAGIC_EAR)
    const_iv (TRIGGER_BUTTON)
    const_iv (TRIGGER_ALTAR)
    const_iv (TRIGGER_PEDESTAL)
    const_iv (SHIELD)
    const_iv (HELMET)
    const_iv (HORN)
    const_iv (MONEY)
    const_iv (CLASS)
    const_iv (GRAVESTONE)
    const_iv (AMULET)
    const_iv (PLAYERMOVER)
    const_iv (TELEPORTER)
    const_iv (CREATOR)
    const_iv (SKILL)
    const_iv (EXPERIENCE)
    const_iv (EARTHWALL)
    const_iv (GOLEM)
    const_iv (THROWN_OBJ)
    const_iv (BLINDNESS)
    const_iv (GOD)
    const_iv (DETECTOR)
    const_iv (TRIGGER_MARKER)
    const_iv (DEAD_OBJECT)
    const_iv (DRINK)
    const_iv (MARKER)
    const_iv (HOLY_ALTAR)
    const_iv (PLAYER_CHANGER)
    const_iv (BATTLEGROUND)
    const_iv (PEACEMAKER)
    const_iv (GEM)
    const_iv (FIREWALL)
    const_iv (ANVIL)
    const_iv (CHECK_INV)
    const_iv (MOOD_FLOOR)
    const_iv (EXIT)
    const_iv (ENCOUNTER)
    const_iv (SHOP_FLOOR)
    const_iv (SHOP_MAT)
    const_iv (RING)
    const_iv (FLOOR)
    const_iv (FLESH)
    const_iv (INORGANIC)
    const_iv (SKILL_TOOL)
    const_iv (LIGHTER)
    const_iv (TRAP_PART)
    const_iv (WALL)
    const_iv (LIGHT_SOURCE)
    const_iv (MISC_OBJECT)
    const_iv (MONSTER)
    const_iv (SPAWN_GENERATOR)
    const_iv (LAMP)
    const_iv (DUPLICATOR)
    const_iv (TOOL)
    const_iv (SPELLBOOK)
    const_iv (BUILDFAC)
    const_iv (CLOAK)
    const_iv (SPINNER)
    const_iv (GATE)
    const_iv (BUTTON)
    const_iv (CF_HANDLE)
    const_iv (HOLE)
    const_iv (TRAPDOOR)
    const_iv (SIGN)
    const_iv (BOOTS)
    const_iv (GLOVES)
    const_iv (SPELL)
    const_iv (SPELL_EFFECT)
    const_iv (CONVERTER)
    const_iv (BRACERS)
    const_iv (POISONING)
    const_iv (SAVEBED)
    const_iv (POISONCLOUD)
    const_iv (FIREHOLES)
    const_iv (WAND)
    const_iv (SCROLL)
    const_iv (DIRECTOR)
    const_iv (GIRDLE)
    const_iv (FORCE)
    const_iv (POTION_EFFECT)
    const_iv (EVENT_CONNECTOR)
    const_iv (CLOSE_CON)
    const_iv (CONTAINER)
    const_iv (ARMOUR_IMPROVER)
    const_iv (WEAPON_IMPROVER)
    const_iv (SKILLSCROLL)
    const_iv (DEEP_SWAMP)
    const_iv (IDENTIFY_ALTAR)
    const_iv (MENU)
    const_iv (RUNE)
    const_iv (TRAP)
    const_iv (POWER_CRYSTAL)
    const_iv (CORPSE)
    const_iv (DISEASE)
    const_iv (SYMPTOM)
    const_iv (BUILDER)
    const_iv (MATERIAL)
    const_iv (ITEM_TRANSFORMER)
    const_iv (QUEST)

    const_iv (NUM_SUBTYPES)

    const_iv (ST_BD_BUILD)
    const_iv (ST_BD_REMOVE)

    const_iv (ST_MAT_FLOOR)
    const_iv (ST_MAT_WALL)
    const_iv (ST_MAT_ITEM)

    const_iv (AT_PHYSICAL)
    const_iv (AT_MAGIC)
    const_iv (AT_FIRE)
    const_iv (AT_ELECTRICITY)
    const_iv (AT_COLD)
    const_iv (AT_CONFUSION)
    const_iv (AT_ACID)
    const_iv (AT_DRAIN)
    const_iv (AT_WEAPONMAGIC)
    const_iv (AT_GHOSTHIT)
    const_iv (AT_POISON)
    const_iv (AT_SLOW)
    const_iv (AT_PARALYZE)
    const_iv (AT_TURN_UNDEAD)
    const_iv (AT_FEAR)
    const_iv (AT_CANCELLATION)
    const_iv (AT_DEPLETE)
    const_iv (AT_DEATH)
    const_iv (AT_CHAOS)
    const_iv (AT_COUNTERSPELL)
    const_iv (AT_GODPOWER)
    const_iv (AT_HOLYWORD)
    const_iv (AT_BLIND)
    const_iv (AT_INTERNAL)
    const_iv (AT_LIFE_STEALING)
    const_iv (AT_DISEASE)

    const_iv (QUEST_IN_PROGRESS)
    const_iv (QUEST_DONE_QUEST)
    const_iv (QUEST_DONE_TASK)
    const_iv (QUEST_START_QUEST)
    const_iv (QUEST_END_QUEST)
    const_iv (QUEST_START_TASK)
    const_iv (QUEST_END_TASK)
    const_iv (QUEST_OVERRIDE)
    const_iv (QUEST_ON_ACTIVATE)

    const_iv (WEAP_HIT)
    const_iv (WEAP_SLASH)
    const_iv (WEAP_PIERCE)
    const_iv (WEAP_CLEAVE)
    const_iv (WEAP_SLICE)
    const_iv (WEAP_STAB)
    const_iv (WEAP_WHIP)
    const_iv (WEAP_CRUSH)
    const_iv (WEAP_BLUD)

    const_iv (FLAG_ALIVE)
    const_iv (FLAG_WIZ)
    const_iv (FLAG_REMOVED)
    const_iv (FLAG_FREED)
    const_iv (FLAG_WAS_WIZ)
    const_iv (FLAG_APPLIED)
    const_iv (FLAG_UNPAID)
    const_iv (FLAG_USE_SHIELD)
    const_iv (FLAG_NO_PICK)
    const_iv (FLAG_ANIMATE)
    const_iv (FLAG_MONSTER)
    const_iv (FLAG_FRIENDLY)
    const_iv (FLAG_GENERATOR)
    const_iv (FLAG_IS_THROWN)
    const_iv (FLAG_AUTO_APPLY)
    const_iv (FLAG_TREASURE)
    const_iv (FLAG_PLAYER_SOLD)
    const_iv (FLAG_SEE_INVISIBLE)
    const_iv (FLAG_CAN_ROLL)
    const_iv (FLAG_OVERLAY_FLOOR)
    const_iv (FLAG_IS_TURNABLE)
    const_iv (FLAG_IS_USED_UP)
    const_iv (FLAG_IDENTIFIED)
    const_iv (FLAG_REFLECTING)
    const_iv (FLAG_CHANGING)
    const_iv (FLAG_SPLITTING)
    const_iv (FLAG_HITBACK)
    const_iv (FLAG_STARTEQUIP)
    const_iv (FLAG_BLOCKSVIEW)
    const_iv (FLAG_UNDEAD)
    const_iv (FLAG_SCARED)
    const_iv (FLAG_UNAGGRESSIVE)
    const_iv (FLAG_REFL_MISSILE)
    const_iv (FLAG_REFL_SPELL)
    const_iv (FLAG_NO_MAGIC)
    const_iv (FLAG_NO_FIX_PLAYER)
    const_iv (FLAG_IS_LIGHTABLE)
    const_iv (FLAG_TEAR_DOWN)
    const_iv (FLAG_RUN_AWAY)
    const_iv (FLAG_PICK_UP)
    const_iv (FLAG_UNIQUE)
    const_iv (FLAG_NO_DROP)
    const_iv (FLAG_WIZCAST)
    const_iv (FLAG_CAST_SPELL)
    const_iv (FLAG_USE_SCROLL)
    const_iv (FLAG_USE_RANGE)
    const_iv (FLAG_USE_BOW)
    const_iv (FLAG_USE_ARMOUR)
    const_iv (FLAG_USE_WEAPON)
    const_iv (FLAG_USE_RING)
    const_iv (FLAG_READY_RANGE)
    const_iv (FLAG_READY_BOW)
    const_iv (FLAG_XRAYS)
    const_iv (FLAG_NO_APPLY)
    const_iv (FLAG_IS_FLOOR)
    const_iv (FLAG_LIFESAVE)
    const_iv (FLAG_NO_STRENGTH)
    const_iv (FLAG_SLEEP)
    const_iv (FLAG_STAND_STILL)
    const_iv (FLAG_RANDOM_MOVE)
    const_iv (FLAG_ONLY_ATTACK)
    const_iv (FLAG_CONFUSED)
    const_iv (FLAG_STEALTH)
    const_iv (FLAG_WIZPASS)
    const_iv (FLAG_IS_LINKED)
    const_iv (FLAG_CURSED)
    const_iv (FLAG_DAMNED)
    const_iv (FLAG_SEE_ANYWHERE)
    const_iv (FLAG_KNOWN_MAGICAL)
    const_iv (FLAG_KNOWN_CURSED)
    const_iv (FLAG_CAN_USE_SKILL)
    const_iv (FLAG_BEEN_APPLIED)
    const_iv (FLAG_READY_SCROLL)
    const_iv (FLAG_USE_ROD)
    const_iv (FLAG_USE_HORN)
    const_iv (FLAG_MAKE_INVIS)
    const_iv (FLAG_INV_LOCKED)
    const_iv (FLAG_IS_WOODED)
    const_iv (FLAG_IS_HILLY)
    const_iv (FLAG_READY_SKILL)
    const_iv (FLAG_READY_WEAPON)
    const_iv (FLAG_NO_SKILL_IDENT)
    const_iv (FLAG_BLIND)
    const_iv (FLAG_SEE_IN_DARK)
    const_iv (FLAG_IS_CAULDRON)
    const_iv (FLAG_NO_STEAL)
    const_iv (FLAG_ONE_HIT)
    const_iv (FLAG_CLIENT_SENT)
    const_iv (FLAG_BERSERK)
    const_iv (FLAG_NEUTRAL)
    const_iv (FLAG_NO_ATTACK)
    const_iv (FLAG_NO_DAMAGE)
    const_iv (FLAG_OBJ_ORIGINAL)
    const_iv (FLAG_OBJ_SAVE_ON_OVL)
    const_iv (FLAG_ACTIVATE_ON_PUSH)
    const_iv (FLAG_ACTIVATE_ON_RELEASE)
    const_iv (FLAG_IS_WATER)
    const_iv (FLAG_CONTENT_ON_GEN)
    const_iv (FLAG_IS_A_TEMPLATE)
    const_iv (FLAG_IS_BUILDABLE)
    const_iv (FLAG_AFK)

    const_iv (NDI_BLACK)
    const_iv (NDI_WHITE)
    const_iv (NDI_NAVY)
    const_iv (NDI_RED)
    const_iv (NDI_ORANGE)
    const_iv (NDI_BLUE)
    const_iv (NDI_DK_ORANGE)
    const_iv (NDI_GREEN)
    const_iv (NDI_LT_GREEN)
    const_iv (NDI_GREY)
    const_iv (NDI_BROWN)
    const_iv (NDI_GOLD)
    const_iv (NDI_TAN)
    const_iv (NDI_MAX_COLOR)
    const_iv (NDI_COLOR_MASK)
    const_iv (NDI_UNIQUE)
    const_iv (NDI_ALL)

    const_iv (F_APPLIED)
    const_iv (F_LOCATION)
    const_iv (F_UNPAID)
    const_iv (F_MAGIC)
    const_iv (F_CURSED)
    const_iv (F_DAMNED)
    const_iv (F_OPEN)
    const_iv (F_NOPICK)
    const_iv (F_LOCKED)

    const_iv (F_BUY)
    const_iv (F_SHOP)
    const_iv (F_SELL)

    const_iv (P_BLOCKSVIEW)
    const_iv (P_NO_MAGIC)
    const_iv (P_IS_ALIVE)
    const_iv (P_NO_CLERIC)
    const_iv (P_NEED_UPDATE)
    const_iv (P_NO_ERROR)
    const_iv (P_OUT_OF_MAP)
    const_iv (P_NEW_MAP)

    const_iv (UP_OBJ_INSERT)
    const_iv (UP_OBJ_REMOVE)
    const_iv (UP_OBJ_CHANGE)
    const_iv (UP_OBJ_FACE)

    const_iv (INS_NO_MERGE)
    const_iv (INS_ABOVE_FLOOR_ONLY)
    const_iv (INS_NO_WALK_ON)
    const_iv (INS_ON_TOP)
    const_iv (INS_BELOW_ORIGINATOR)
    const_iv (INS_MAP_LOAD)

    const_iv (WILL_APPLY_HANDLE)
    const_iv (WILL_APPLY_TREASURE)
    const_iv (WILL_APPLY_EARTHWALL)
    const_iv (WILL_APPLY_DOOR)
    const_iv (WILL_APPLY_FOOD)

    const_iv (SAVE_MODE)
    const_iv (SAVE_DIR_MODE)

    const_iv (M_PAPER)
    const_iv (M_IRON)
    const_iv (M_GLASS)
    const_iv (M_LEATHER)
    const_iv (M_WOOD)
    const_iv (M_ORGANIC)
    const_iv (M_STONE)
    const_iv (M_CLOTH)
    const_iv (M_ADAMANT)
    const_iv (M_LIQUID)
    const_iv (M_SOFT_METAL)
    const_iv (M_BONE)
    const_iv (M_ICE)
    const_iv (M_SPECIAL)

    const_iv (SK_EXP_ADD_SKILL)
    const_iv (SK_EXP_TOTAL)
    const_iv (SK_EXP_NONE)
    const_iv (SK_SUBTRACT_SKILL_EXP)
    const_iv (SK_EXP_SKILL_ONLY)

    const_iv (SK_LOCKPICKING)
    const_iv (SK_HIDING)
    const_iv (SK_SMITHERY)
    const_iv (SK_BOWYER)
    const_iv (SK_JEWELER)
    const_iv (SK_ALCHEMY)
    const_iv (SK_STEALING)
    const_iv (SK_LITERACY)
    const_iv (SK_BARGAINING)
    const_iv (SK_JUMPING)
    const_iv (SK_DET_MAGIC)
    const_iv (SK_ORATORY)
    const_iv (SK_SINGING)
    const_iv (SK_DET_CURSE)
    const_iv (SK_FIND_TRAPS)
    const_iv (SK_MEDITATION)
    const_iv (SK_PUNCHING)
    const_iv (SK_FLAME_TOUCH)
    const_iv (SK_KARATE)
    const_iv (SK_CLIMBING)
    const_iv (SK_WOODSMAN)
    const_iv (SK_INSCRIPTION)
    const_iv (SK_ONE_HANDED_WEAPON)
    const_iv (SK_MISSILE_WEAPON)
    const_iv (SK_THROWING)
    const_iv (SK_USE_MAGIC_ITEM)
    const_iv (SK_DISARM_TRAPS)
    const_iv (SK_SET_TRAP)
    const_iv (SK_THAUMATURGY)
    const_iv (SK_PRAYING)
    const_iv (SK_CLAWING)
    const_iv (SK_LEVITATION)
    const_iv (SK_SUMMONING)
    const_iv (SK_PYROMANCY)
    const_iv (SK_EVOCATION)
    const_iv (SK_SORCERY)
    const_iv (SK_TWO_HANDED_WEAPON)
    const_iv (SK_SPARK_TOUCH)
    const_iv (SK_SHIVER)
    const_iv (SK_ACID_SPLASH)
    const_iv (SK_POISON_NAIL)

    const_iv (SOUND_NEW_PLAYER)
    const_iv (SOUND_FIRE_ARROW)
    const_iv (SOUND_LEARN_SPELL)
    const_iv (SOUND_FUMBLE_SPELL)
    const_iv (SOUND_WAND_POOF)
    const_iv (SOUND_OPEN_DOOR)
    const_iv (SOUND_PUSH_PLAYER)
    const_iv (SOUND_PLAYER_HITS1)
    const_iv (SOUND_PLAYER_HITS2)
    const_iv (SOUND_PLAYER_HITS3)
    const_iv (SOUND_PLAYER_HITS4)
    const_iv (SOUND_PLAYER_IS_HIT1)
    const_iv (SOUND_PLAYER_IS_HIT2)
    const_iv (SOUND_PLAYER_IS_HIT3)
    const_iv (SOUND_PLAYER_KILLS)
    const_iv (SOUND_PET_IS_KILLED)
    const_iv (SOUND_PLAYER_DIES)
    const_iv (SOUND_OB_EVAPORATE)
    const_iv (SOUND_OB_EXPLODE)
    const_iv (SOUND_CLOCK)
    const_iv (SOUND_TURN_HANDLE)
    const_iv (SOUND_FALL_HOLE)
    const_iv (SOUND_DRINK_POISON)
    const_iv (SOUND_CAST_SPELL_0)

    const_iv (PREFER_LOW)
    const_iv (PREFER_HIGH)

    const_iv (ATNR_PHYSICAL)
    const_iv (ATNR_MAGIC)
    const_iv (ATNR_FIRE)
    const_iv (ATNR_ELECTRICITY)
    const_iv (ATNR_COLD)
    const_iv (ATNR_CONFUSION)
    const_iv (ATNR_ACID)
    const_iv (ATNR_DRAIN)
    const_iv (ATNR_WEAPONMAGIC)
    const_iv (ATNR_GHOSTHIT)
    const_iv (ATNR_POISON)
    const_iv (ATNR_SLOW)
    const_iv (ATNR_PARALYZE)
    const_iv (ATNR_TURN_UNDEAD)
    const_iv (ATNR_FEAR)
    const_iv (ATNR_CANCELLATION)
    const_iv (ATNR_DEPLETE)
    const_iv (ATNR_DEATH)
    const_iv (ATNR_CHAOS)
    const_iv (ATNR_COUNTERSPELL)
    const_iv (ATNR_GODPOWER)
    const_iv (ATNR_HOLYWORD)
    const_iv (ATNR_BLIND)
    const_iv (ATNR_INTERNAL)
    const_iv (ATNR_LIFE_STEALING)
    const_iv (ATNR_DISEASE)

    const_iv (MAP_FLUSH)
    const_iv (MAP_PLAYER_UNIQUE)
    const_iv (MAP_BLOCK)
    const_iv (MAP_STYLE)
    const_iv (MAP_OVERLAY)

    const_iv (MAP_IN_MEMORY)
    const_iv (MAP_SWAPPED)
    const_iv (MAP_LOADING)
    const_iv (MAP_SAVING)

    const_iv (KLASS_GLOBAL)
    const_iv (KLASS_OBJECT)
    const_iv (KLASS_PLAYER)
    const_iv (KLASS_MAP)
  };

  for (civ = const_iv + sizeof (const_iv) / sizeof (const_iv [0]); civ-- > const_iv; )
    newCONSTSUB (stash, (char *)civ->name, newSViv (civ->iv));

  static const struct {
    const char *name;
    int skip;
    IV klass;
    IV iv;
  } *eiv, event_iv[] = {
#  define def(klass,name) { "EVENT_" # klass "_" # name, sizeof ("EVENT_" # klass), (IV)KLASS_ ## klass, (IV)EVENT_ ## klass ## _ ## name },
#   include "eventinc.h"
#  undef def
  };

  AV *av = get_av ("cf::EVENT", 1);

  for (eiv = event_iv + sizeof (event_iv) / sizeof (event_iv [0]); eiv-- > event_iv; )
    {
      AV *event = newAV ();
      av_push (event, newSVpv ((char *)eiv->name + eiv->skip, 0));
      av_push (event, newSViv (eiv->klass));
      av_store (av, eiv->iv, newRV_noinc ((SV *)event));
      newCONSTSUB (stash, (char *)eiv->name, newSViv (eiv->iv));
    }

  //I_EVENT_API (PACKAGE);
}

void _init_vars ()
        CODE:
        cb_global = get_av ("cf::CB_GLOBAL", 1);
        cb_object = get_av ("cf::CB_OBJECT", 1);
        cb_player = get_av ("cf::CB_PLAYER", 1);
        cb_type   = get_av ("cf::CB_TYPE"  , 1);
        cb_map    = get_av ("cf::CB_MAP"   , 1);

void _global_reattach ()
        CODE:
{
        // reattach to all attachable objects in the game.
        for (player *pl = first_player; pl; pl = pl->next)
          reattach (pl);
        
        for (mapstruct *map = first_map; map; map = map->next)
          reattach (map);

        for (object *op = objects; op; op = op->next)
          reattach (op);
}

NV floor (NV x)

NV ceil (NV x)

void server_tick ()

void
LOG (int level, char *msg)
        PROTOTYPE: $$
        C_ARGS: (LogLevel)level, "%s", msg

char *path_combine (char *base, char *path)
        PROTOTYPE: $$

char *path_combine_and_normalize (char *base, char *path)
        PROTOTYPE: $$

const char *
get_maps_directory (char *path)
        PROTOTYPE: $
        ALIAS: maps_directory = 0
        CODE:
        RETVAL = create_pathname (path);
        OUTPUT: RETVAL

void
sub_generation_inc ()
        CODE:
        PL_sub_generation++;

char *
mapdir ()
        PROTOTYPE:
        ALIAS:
        mapdir    = 0
        uniquedir = 1
        tmpdir    = 2
        confdir   = 3
        localdir  = 4
        playerdir = 5
        datadir   = 6
        CODE:
        switch (ix)
          {
            case 0: RETVAL = settings.mapdir   ; break; 
            case 1: RETVAL = settings.uniquedir; break; 
            case 2: RETVAL = settings.tmpdir   ; break; 
            case 3: RETVAL = settings.confdir  ; break; 
            case 4: RETVAL = settings.localdir ; break; 
            case 5: RETVAL = settings.playerdir; break; 
            case 6: RETVAL = settings.datadir  ; break;
          }
        OUTPUT: RETVAL

int
cf_find_animation (char *text)
        PROTOTYPE: $

int random_roll(int min, int max, object *op, int goodbad);

const char *cost_string_from_value(uint64 cost, int approx = 0)

int invoke (int event, ...)
        CODE:
        if (KLASS_OF (event) != KLASS_GLOBAL) croak ("event class must be GLOBAL");
        AV *av = (AV *)sv_2mortal ((SV *)newAV ());
        for (int i = 1; i < items; i++) av_push (av, SvREFCNT_inc (ST (i)));
        RETVAL = INVOKE_((event_type)event, ARG_AV (av));
        OUTPUT: RETVAL

int
exp_to_level (val64 exp)
        CODE:
{
        int i = 0;

        RETVAL = settings.max_level;

        for (i = 1; i <= settings.max_level; i++)
          {
            if (levels[i] > exp)
              {
                RETVAL = i - 1;
                break;
              }
          }
}
        OUTPUT: RETVAL

val64
level_to_min_exp (int level)
       CODE:
       if (level > settings.max_level)
         RETVAL = levels[settings.max_level];
       else if (level < 1)
         RETVAL = 0;
       else
         RETVAL = levels[level];
       OUTPUT: RETVAL

SV *
resistance_to_string (int atnr)
        CODE:
        if (atnr >= 0 && atnr < NROFATTACKS)
          RETVAL = newSVpv (resist_plus[atnr], 0);
        else
          XSRETURN_UNDEF;
        OUTPUT: RETVAL

int
_valid (SV *obj)
        CODE:
        RETVAL = SvROK (obj) && mg_find (SvRV (obj), PERL_MAGIC_ext);
        OUTPUT:
        RETVAL

MODULE = cf        PACKAGE = cf::object         PREFIX = cf_object_

int invoke (object *op, int event, ...)
        CODE:
        if (KLASS_OF (event) != KLASS_OBJECT) croak ("event class must be OBJECT");
        AV *av = (AV *)sv_2mortal ((SV *)newAV ());
        for (int i = 2; i < items; i++) av_push (av, SvREFCNT_inc (ST (i)));
        RETVAL = INVOKE_((event_type)event, ARG_OBJECT (op), ARG_AV (av));
        OUTPUT: RETVAL

SV *registry (object *op)
        CODE:
        RETVAL = registry_of (op);
        OUTPUT:
        RETVAL

INCLUDE: $PERL genacc object ../include/object.h |

# missing properties

int flag (object *op, int flag, int value = 1)
        PROTOTYPE: $$;$
        CODE:
        RETVAL = QUERY_FLAG (op, flag);
        if (items >= 3)
          if (value)
            SET_FLAG (op, flag);
          else
            CLEAR_FLAG (op, flag);
        OUTPUT: RETVAL

void
inv (object *obj)
        PROTOTYPE: $
        PPCODE:
{
        object *o;
        for (o = obj->inv; o; o = o->below)
          XPUSHs (sv_2mortal (newSVcfapi (CFAPI_POBJECT, o)));
}

int cf_object_get_resistance (object *op, int rtype)
        ALIAS: resistance = 0

int need_identify (const object *obj);

int apply_shop_mat (object *shop_mat, object *op);

int move (object *op, int dir, object *originator = op)
        CODE:
        RETVAL = move_ob (op, dir, originator);
        OUTPUT:
        RETVAL

void cf_object_apply (object *op, object *author, int flags = 0)

void cf_object_apply_below (object *op)

void cf_object_remove (object *op)

void cf_object_free (object *op)

object *cf_object_present_archname_inside (object *op, char *whatstr)

int cf_object_transfer (object *op, int x, int y, int r = 0, object_ornull *orig = 0)

int cf_object_change_map (object *op, int x, int y, mapstruct *map)

object *cf_object_clone (object *op, int clonetype = 0)

int cf_object_pay_item (object *op, object *buyer)

int cf_object_pay_amount (object *op, uint64 amount)

void pay_player (object *op, uint64 amount)

val64 pay_player_arch (object *op, const char *arch, uint64 amount)

int cf_object_cast_spell (object *caster, object *ctoo, int dir, object *spell_ob, char *stringarg = 0)

int cf_object_cast_ability (object *caster, object *ctoo, int dir, object *sp_, char *stringarg = 0)

void cf_object_learn_spell (object *op, object *sp)

void cf_object_forget_spell (object *op, object *sp)

object *cf_object_check_for_spell (object *op, char *spellname)

int cf_object_query_money (object *op)
        ALIAS: money = 0

int cf_object_query_cost (object *op, object *who, int flags)
        ALIAS: cost = 0

void cf_object_activate_rune (object *op , object *victim)

int cf_object_check_trigger (object *op, object *cause)

int cf_object_out_of_map (object *op, int x, int y)

void cf_object_drop (object *op, object *author)

void cf_object_take (object *op, object *author)

object *cf_object_insert_object (object *op, object *container)

object *cf_object_insert_in_ob (object *ob, object *where)

int cf_object_teleport (object *op, mapstruct *map, int x, int y)

void cf_object_update (object *op, int flags)

void cf_object_pickup (object *op, object *what)

object *cf_create_object_by_name (const char *name)

void change_exp (object *op, uint64 exp, const char *skill_name = 0, int flag = 0)

void player_lvl_adj (object *who, object *skill = 0)

int kill_object (object *op, int dam = 0, object *hitter = 0, int type = AT_PHYSICAL)

int calc_skill_exp (object *who, object *op, object *skill);

void push_button (object *op);

void use_trigger (object *op);

void add_button_link (object *button, mapstruct *map, int connected);

void remove_button_link (object *op);

void
cf_object_set_resistance (object *op, int rtype, int val)
      CODE:
        if (rtype >= 0 && rtype < NROFATTACKS)
        op->resist[rtype] = val;


MODULE = cf        PACKAGE = cf::object         PREFIX = cf_

void cf_fix_object (object *pl)
        ALIAS: fix = 0

object *cf_insert_ob_in_ob (object *ob, object *where)

# no clean way to get an object from an archetype - stupid idiotic
# dumb kludgy misdesigned plug-in api slowly gets on my nerves.

object *new (const char *archetype = 0)
        PROTOTYPE: ;$
        CODE:
        RETVAL = archetype ? get_archetype (archetype) : cf_create_object ();
        OUTPUT:
        RETVAL

object *insert_ob_in_map_at (object *ob, mapstruct *where, object_ornull *orig, int flag, int x, int y)
        PROTOTYPE: $$$$$$
        CODE:
{
        int unused_type;
        RETVAL = (object *)object_insert (&unused_type, ob, 0, where, orig, flag, x, y);
}

# syntatic sugar for easier use in event callbacks.
const char *options (object *op)
        CODE:
        RETVAL = op->name;
        OUTPUT:
        RETVAL

player *contr (object *op)
        CODE:
        RETVAL = op->contr;
        OUTPUT: RETVAL

const char *get_ob_key_value (object *op, const char *key)

bool set_ob_key_value (object *op, const char *key, const char *value = 0, int add_key = 1)

object *get_nearest_player (object *ob)
        ALIAS: nearest_player = 0
        PREINIT:
        extern object *get_nearest_player (object *);

void rangevector (object *ob, object *other, int flags = 0)
        PROTOTYPE: $$;$
        PPCODE:
{
        rv_vector rv;
        get_rangevector (ob, other, &rv, flags);
        EXTEND (SP, 5);
        PUSHs (newSVuv (rv.distance));
        PUSHs (newSViv (rv.distance_x));
        PUSHs (newSViv (rv.distance_y));
        PUSHs (newSViv (rv.direction));
        PUSHs (newSVcfapi (CFAPI_POBJECT, rv.part));
}

bool on_same_map_as (object *ob, object *other)
        CODE:
        RETVAL = on_same_map (ob, other);
        OUTPUT: RETVAL

char *
base_name (object *ob, int plural)
        CODE:
        RETVAL = cf_query_base_name (ob, plural);
        OUTPUT: RETVAL

MODULE = cf        PACKAGE = cf::object::player PREFIX = cf_player_

player *player (object *op)
        CODE:
        RETVAL = op->contr;
        OUTPUT: RETVAL

void cf_player_message (object *obj, char *txt, int flags = NDI_ORANGE | NDI_UNIQUE)

object *cf_player_send_inventory (object *op)

char *cf_player_get_ip (object *op)
        ALIAS: ip = 0

object *cf_player_get_marked_item (object *op)
        ALIAS: marked_item = 0

void cf_player_set_marked_item (object *op, object *ob)

partylist *cf_player_get_party (object *op)
        ALIAS: party = 0

void cf_player_set_party (object *op, partylist *party)

void kill_player (object *op)

MODULE = cf        PACKAGE = cf::player         PREFIX = cf_player_

int invoke (player *pl, int event, ...)
        CODE:
        if (KLASS_OF (event) != KLASS_PLAYER) croak ("event class must be PLAYER");
        AV *av = (AV *)sv_2mortal ((SV *)newAV ());
        for (int i = 2; i < items; i++) av_push (av, SvREFCNT_inc (ST (i)));
        RETVAL = INVOKE_((event_type)event, ARG_PLAYER (pl), ARG_AV (av));
        OUTPUT: RETVAL

SV *registry (player *pl)
        CODE:
        RETVAL = registry_of (pl);
        OUTPUT:
        RETVAL

player *cf_player_find (char *name)
        PROTOTYPE: $

void cf_player_move (player *pl, int dir)

void play_sound_player_only (player *pl, int soundnum, int x = 0, int y = 0);

# nonstandard
object *ob (player *pl)
        CODE:
        RETVAL = pl->ob;
        OUTPUT: RETVAL

player *first ()
        CODE:
        RETVAL = first_player;
        OUTPUT: RETVAL

player *next (player *pl)
        CODE:
        RETVAL = pl->next;
        OUTPUT: RETVAL

bool
cell_visible (player *pl, int dx, int dy)
        CODE:
        RETVAL = FABS (dx) <= pl->socket.mapx / 2 && FABS (dy) <= pl->socket.mapy / 2
                 && !pl->blocked_los [dx + pl->socket.mapx / 2][dy + pl->socket.mapy / 2];
        OUTPUT:
        RETVAL

char *
client (player *pl)
        CODE:
        RETVAL = pl->socket.client;
        OUTPUT:
        RETVAL

char *
host (player *pl)
        CODE:
        RETVAL = pl->socket.host;
        OUTPUT:
        RETVAL

char *
killer (player *pl, char *killer = 0)
        CODE:
        if (killer)
          snprintf (pl->killer, sizeof (pl->killer), "%s", killer);
        RETVAL = pl->killer;
        OUTPUT:
        RETVAL

void
buggy_mapscroll (player *pl, int value = 1)
        CODE:
        pl->socket.buggy_mapscroll = value;

void
send (player *pl, SV *packet)
        CODE:
{
        STRLEN len;
        char *buf = SvPVbyte (packet, len);

        Write_String_To_Socket (&pl->socket, buf, len);
}

int
listening (player *pl, int new_value = -1)
        CODE:
        RETVAL = pl->listening;
        if (new_value >= 0)
          pl->listening = new_value;
        OUTPUT:
        RETVAL

void savebed (player *pl, SV *map_path = 0, SV *x = 0, SV *y = 0)
        PROTOTYPE: $;$$$
        PPCODE:
        if (GIMME_V != G_VOID)
          {
            EXTEND (SP, 3);
            PUSHs (sv_2mortal (newSVpv (pl->savebed_map, 0)));
            PUSHs (sv_2mortal (newSViv (pl->bed_x)));
            PUSHs (sv_2mortal (newSViv (pl->bed_y)));
          }
        if (map_path) sv_to (map_path, pl->savebed_map);
        if (x)        sv_to (x,        pl->bed_x);
        if (y)        sv_to (y,        pl->bed_y);

void
list ()
        PPCODE:
{
        player *pl;
        for (pl = first_player; pl; pl = pl->next)
          XPUSHs (newSVcfapi (CFAPI_PPLAYER, pl));
}

bool
peaceful (player *pl, bool new_setting = 0)
        PROTOTYPE: $;$
        CODE:
        RETVAL = pl->peaceful;
        if (items > 1)
          pl->peaceful = new_setting;
        OUTPUT:
        RETVAL

living *
orig_stats (player *pl)
        CODE:
        RETVAL = &pl->orig_stats;
        OUTPUT: RETVAL

living *
last_stats (player *pl)
        CODE:
        RETVAL = &pl->last_stats;
        OUTPUT: RETVAL


MODULE = cf        PACKAGE = cf::map            PREFIX = cf_map_

mapstruct *first ()
        PROTOTYPE:
        CODE:
        RETVAL = first_map;
        OUTPUT: RETVAL

int invoke (mapstruct *map, int event, ...)
        CODE:
        if (KLASS_OF (event) != KLASS_MAP) croak ("event class must be MAP");
        AV *av = (AV *)sv_2mortal ((SV *)newAV ());
        for (int i = 2; i < items; i++) av_push (av, SvREFCNT_inc (ST (i)));
        RETVAL = INVOKE_((event_type)event, ARG_MAP (map), ARG_AV (av));
        OUTPUT: RETVAL

SV *registry (mapstruct *map)
        CODE:
        RETVAL = registry_of (map);
        OUTPUT:
        RETVAL

INCLUDE: $PERL genacc mapstruct ../include/map.h |

mapstruct *new (int width, int height)
        PROTOTYPE:
        CODE:
{
        RETVAL = get_empty_map (width, height);
}
        OUTPUT:
        RETVAL

void delete_map (mapstruct *map)

void clean_tmp_map (mapstruct *map)

void play_sound_map (mapstruct *map, int x, int y, int sound_num)

mapstruct *tile_map (mapstruct *map, unsigned int dir)
        CODE:
        RETVAL = dir < 4 ? map->tile_map [dir] : 0;
        OUTPUT:
        RETVAL

char *tile_path (mapstruct *map, unsigned int dir)
        CODE:
        if (dir >= 4)
          XSRETURN_UNDEF;
        RETVAL = map->tile_path [dir];
        OUTPUT:
        RETVAL

mapstruct *ready_map_name (char *name, int flags = 0)
        PROTOTYPE: $;$
        ALIAS:
        find    = 0
        get_map = 1

mapstruct *has_been_loaded (char *name)
        PROTOTYPE: $

int in_memory (mapstruct *map)
        CODE:
        RETVAL = map->in_memory;
        OUTPUT:
        RETVAL

void
trigger (mapstruct *map, long connection, bool state = true)
        CODE:
        activate_connection (map, connection, state);

void
get_connection (mapstruct *map, long connection)
       PPCODE:
       oblinkpt *obp = get_connection_links (map, connection);
       if (obp)
         for (objectlink *ol = obp->link; ol; ol = ol->next)
           XPUSHs (sv_2mortal (newSVcfapi (CFAPI_POBJECT, ol->ob)));

object *cf_map_insert_object_there (mapstruct *where, object *op, object *originator, int flags)

object *cf_map_insert_object (mapstruct *where, object* op, int x, int y)

object* cf_map_present_arch_by_name (mapstruct *map, const char* str, int nx, int ny)
        C_ARGS: str, map, nx, ny

void
cf_map_normalise (mapstruct *map, int x, int y)
        PPCODE:
{
        mapstruct *nmap = 0;
        I16 nx = 0, ny = 0;
        int flags = get_map_flags (map, &nmap, x, y, &nx, &ny);

        EXTEND (SP, 4);
        PUSHs (sv_2mortal (newSViv (flags)));

        if (GIMME_V == G_ARRAY)
          {
            PUSHs (sv_2mortal (newSVcfapi (CFAPI_PMAP, nmap)));
            PUSHs (sv_2mortal (newSViv (nx)));
            PUSHs (sv_2mortal (newSViv (ny)));
          }
}

void
at (mapstruct *map, unsigned int x, unsigned int y)
        PROTOTYPE: $$$
        PPCODE:
{
        object *o;
        mapstruct *nmap = 0;
        I16 nx, ny;

        get_map_flags (map, &nmap, x, y, &nx, &ny);

        if (nmap)
          for (o = GET_MAP_OB (nmap, nx, ny); o; o = o->above)
            XPUSHs (sv_2mortal (newSVcfapi (CFAPI_POBJECT, o)));
}

SV *
bot_at (mapstruct *obj, unsigned int x, unsigned int y)
        PROTOTYPE: $$$
        ALIAS:
          top_at        = 1
          flags_at      = 2
          light_at      = 3
          move_block_at = 4
          move_slow_at  = 5
          move_on_at    = 6
          move_off_at   = 7
        INIT:
        if (x >= MAP_WIDTH (obj) || y >= MAP_HEIGHT (obj)) XSRETURN_UNDEF;
        CODE:
        switch (ix)
          {
            case 0: RETVAL = newSVcfapi (CFAPI_POBJECT, GET_MAP_OB         (obj, x, y)); break;
            case 1: RETVAL = newSVcfapi (CFAPI_POBJECT, GET_MAP_TOP        (obj, x, y)); break;
            case 2: RETVAL = newSVuv    (               GET_MAP_FLAGS      (obj, x, y)); break;
            case 3: RETVAL = newSViv    (               GET_MAP_LIGHT      (obj, x, y)); break;
            case 4: RETVAL = newSVuv    (               GET_MAP_MOVE_BLOCK (obj, x, y)); break;
            case 5: RETVAL = newSVuv    (               GET_MAP_MOVE_SLOW  (obj, x, y)); break;
            case 6: RETVAL = newSVuv    (               GET_MAP_MOVE_ON    (obj, x, y)); break;
            case 7: RETVAL = newSVuv    (               GET_MAP_MOVE_OFF   (obj, x, y)); break;
          }
        OUTPUT:
        RETVAL


MODULE = cf        PACKAGE = cf::arch

archetype *find (const char *name)
        CODE:
        RETVAL = find_archetype (name);
        OUTPUT:
        RETVAL

archetype *first()
        PROTOTYPE:
        CODE:
        RETVAL = first_archetype;
        OUTPUT: RETVAL

INCLUDE: $PERL genacc archetype ../include/object.h |

MODULE = cf        PACKAGE = cf::party

partylist *first ()
        PROTOTYPE:
        CODE:
        RETVAL = get_firstparty ();
        OUTPUT: RETVAL

partylist *next (partylist *party)
        CODE:
        RETVAL = party->next;
        OUTPUT: RETVAL

const char *name (partylist *party)
        CODE:
        RETVAL = party->partyname;
        OUTPUT: RETVAL

const char *password (partylist *party)
        CODE:
        RETVAL = party->passwd;
        OUTPUT: RETVAL

MODULE = cf        PACKAGE = cf::region

region  *first ()
        PROTOTYPE:
        CODE:
        RETVAL = first_region;
        OUTPUT: RETVAL

region *next (region *reg)
        CODE:
        RETVAL = reg->next;
        OUTPUT: RETVAL

const char *name (region *reg)
        CODE:
        RETVAL = reg->name;
        OUTPUT: RETVAL

region *parent (region *reg)
        CODE:
        RETVAL = reg->parent;
        OUTPUT: RETVAL

const char *longname (region *reg)
        CODE:
        RETVAL = reg->longname;
        OUTPUT: RETVAL

const char *msg (region *reg)
        CODE:
        RETVAL = reg->msg;
        OUTPUT: RETVAL

MODULE = cf        PACKAGE = cf::living

INCLUDE: $PERL genacc living ../include/living.h |

Revision:	1.50
Committed:	Mon Sep 11 01:16:20 2006 UTC (17 years, 8 months ago) by root
Branch:	MAIN
Changes since 1.49:	+2 -2 lines
Log Message:	fix perl class for archetype, never free once-allocated objects, or destruct them, there are too many long-lived references (and refcount doesn't help, likely because it isn't correctly being incremented/decremented).