/*
  Copyright (c) 1995-2004 Nick Ing-Simmons. All rights reserved.
  This program is free software; you can redistribute it and/or
  modify it under the same terms as Perl itself.
*/
#define PERL_NO_GET_CONTEXT
#include <EXTERN.h>
#include <perl.h>
#include <XSUB.h>
#include <patchlevel.h>


#include "tkGlue.def"
#define TCL_EVENT_IMPLEMENT

#include "pTk/tkInt.h"
#include "pTk/Lang.h"
#include "pTk/tkEvent.h"
#include "tkGlue.h"
/*
   For perl a "callback" is an SV
   - Simple case of ref to CV
   - A ref to an AV, 1st element is "method" rest are
   args to be passed on EACH call (before/after any Tk args ?)
   Akin to fact that TCL/TK evals an arbitary string
   (Perl code could pre-scan args and convert Malcolm's
   -method/-slave into this form.)
   - Special case of a "window" reference, treat 1st arg
   as a method. (e.g. for TCL/TK's .menu post x y )

 */


LangCallback *
LangMakeCallback(sv)
SV *sv;
{
 dTHX; /* FIXME */
 if (sv)
  {
   dTHX;
   AV *av;
   int old_taint = PL_tainted;
   if (SvTAINTED(sv))
    croak("Attempt to make callback from tainted %"SVf, sv);
   PL_tainted = 0;
   /* Case of a Tcl_Merge which returns an AV * */
   if (SvTYPE(sv) == SVt_PVAV)
    {
     sv = newRV(sv);
     warn("Making callback from array not reference");
    }
   else if (!SvOK(sv) || (SvPOK(sv) && SvCUR(sv) == 0))
    return sv;
   else if (SvREADONLY(sv) || SvROK(sv) || SvPOK(sv))
    sv = newSVsv(sv);  /* FIXME: Always do this ??? */
   else
    {
     SvREFCNT_inc(sv);
    }
   if (!SvROK(sv))
    {
     sv = newRV_noinc(sv);
    }
   else
    {
     if (SvTYPE(SvRV(sv)) == SVt_PVCV)
      {
       AV *av = newAV();
#if 0
       /* This leaks */
       av_push(av,SvREFCNT_inc(sv));  /* Increment REFCNT ! */
#else
       av_push(av,sv);  /* changed by SRT: do not increment REFCNT ! */
#endif
       sv = newRV_noinc((SV *) av);
      }
    }
   if (SvTYPE(SvRV(sv)) == SVt_PVAV)
    {
     if (av_len((AV *) SvRV(sv)) < 0)
      {
       croak("Empty list is not a valid callback");
      }
    }
   if (!sv_isa(sv,"Tk::Callback"))
    {
     HV *stash = gv_stashpv("Tk::Callback", TRUE);
     sv = sv_bless(sv, stash);
    }
   PL_tainted = old_taint;
  }
 if (sv && SvTAINTED(sv))
  croak("Making callback tainted %"SVf, sv);
 return sv;
}

LangCallback *
LangCopyCallback(sv)
SV *sv;
{
 if (sv)
  {
#if !defined(__GNUC__) || defined(__STRICT_ANSI__) || defined(PERL_GCC_PEDANTIC)
 /* Unless using GCC extensions we need PL_Sv */
   dTHX;
#endif
   SvREFCNT_inc(sv);
  }
 return sv;
}

void
LangFreeCallback(sv)
SV *sv;
{
 dTHX; /* FIXME */
 if (!sv_isa(sv,"Tk::Callback"))
  {
   warn("Free non-Callback %p RV=%p",sv,SvRV(sv));
   /*//   abort();*/
  }
 SvREFCNT_dec(sv);
}

Tcl_Obj *
LangCallbackObj(sv)
SV *sv;
{
 dTHX; /* FIXME */
 if (sv && !sv_isa(sv,"Tk::Callback"))
  {
   warn("non-Callback arg");
   sv_dump(sv);
  }
 return SvREFCNT_inc(sv);
}

Tcl_Obj *
LangOldCallbackArg(sv,file,line)
SV *sv;
char *file;
int line;
{
 dTHX; /* FIXME */
 LangDebug("%s:%d: LangCallbackArg is deprecated\n",file,line);
 sv = LangCallbackObj(sv);
 SvREFCNT_dec(sv);
 return sv;
}

int
LangCallCallback(sv, flags)
SV *sv;
int flags;
{
 dTHX; /* FIXME */
 dSP;
 STRLEN na;
 I32 myframe = TOPMARK;
 I32 count;
 ENTER;
 if (SvGMAGICAL(sv))
  mg_get(sv);
 if (SvTAINTED(sv))
  {
   croak("Call of tainted value %"SVf,sv);
  }
 if (!SvOK(sv))
  {
   char *s = "Call of undefined value";
   sv_setpvn(ERRSV,s,strlen(s));
   abort();
   return 0;
  }
 if (flags & G_EVAL)
  {
   CV *cv  = perl_get_cv("Tk::__DIE__", FALSE);
   if (cv)
    {
     HV *sig  = perl_get_hv("SIG",TRUE);
     SV **old = hv_fetch(sig, "__DIE__", 7, TRUE);
     save_svref(old);
     hv_store(sig,"__DIE__",7,newRV((SV *) cv),0);
    }
  }

 /* Belt-and-braces fix to callback destruction issues */
 /* Increment refcount of thing while we call it */
 SvREFCNT_inc(sv);
 /* Arrange to have it decremented on scope exit */
 save_freesv(sv);

 if (SvTYPE(sv) == SVt_PVCV)
  {
   count = perl_call_sv(sv, flags);
  }
 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV)
  {
   count = perl_call_sv(SvRV(sv), flags);
  }
 else
  {
   SV **top = PL_stack_base + myframe + 1;
   SV *obj = *top;
   if (SvGMAGICAL(obj))
    mg_get(obj);
   if (SvPOK(sv) && SvROK(obj) && SvOBJECT(SvRV(obj)))
    {
     count = perl_call_method(SvPV_nolen(sv), flags);
    }
   else if (SvPOK(obj) && SvROK(sv) && SvOBJECT(SvRV(sv)))
    {
     *top = sv;
     count = perl_call_method(SvPV_nolen(obj), flags);
    }
   else
    {
     count = perl_call_sv(sv, flags);
    }
  }
 LEAVE;
 return count;
}

void
LangPushCallbackArgs(SV **svp)
{
 dTHX; /* FIXME */
 SV *sv = *svp;
 dSP;
 STRLEN na;
 if (SvTAINTED(sv))
  {
   croak("Tainted callback %"SVf,sv);
  }
 if (SvROK(sv) && SvTYPE(SvRV(sv)) != SVt_PVCV)
  sv = SvRV(sv);
 PUSHMARK(sp);
 if (SvTYPE(sv) == SVt_PVAV)
  {
   AV *av = (AV *) sv;
   int n = av_len(av) + 1;
   SV **x = av_fetch(av, 0, 0);
   if (x)
    {
     int i = 1;
     sv = *x;
     if (SvTAINTED(sv))
      {
       croak("Callback slot 0 tainted %"SVf,sv);
      }
     for (i = 1; i < n; i++)
      {
       x = av_fetch(av, i, 0);
       if (x)
        {SV *arg = *x;
         if (SvTAINTED(arg))
          {
           croak("Callback slot %d tainted %"SVf,i,arg);
          }
         XPUSHs(sv_mortalcopy(arg));
        }
       else
        XPUSHs(&PL_sv_undef);
      }
    }
   else
    {
     sv = &PL_sv_undef;
    }
  }
 *svp = sv;
 PUTBACK;
}

int
LangCmpCallback(a, b)
SV *a;
SV *b;
{
 dTHX; /* FIXME */
 if (a == b)
  return 1;
 if (!a || !b)
  return 0;
 if (SvTYPE(a) != SvTYPE(b))
  return 0;
 switch(SvTYPE(a))
  {
   case SVt_PVAV:
    {
     AV *aa = (AV *) a;
     AV *ba = (AV *) a;
     if (av_len(aa) != av_len(ba))
      return 0;
     else
      {
       IV i;
       for (i=0; i <= av_len(aa); i++)
        {
         SV **ap = av_fetch(aa,i,0);
         SV **bp = av_fetch(ba,i,0);
         if (ap && !bp)
          return 0;
         if (bp && !ap)
          return 0;
         if (ap && bp && !LangCmpCallback(*ap,*bp))
          return 0;
        }
       return 1;
      }
    }
   default:
   case SVt_PVGV:
   case SVt_PVCV:
    return 0;
#ifdef HAS_REAL_SVT_RV
   case SVt_RV:
#endif
   case SVt_IV:
   case SVt_NV:
   case SVt_PV:
   case SVt_PVIV:
   case SVt_PVNV:
    if (SvROK(a) && SvROK(b))
     {
      return LangCmpCallback(SvRV(a),SvRV(b));
     }
    else
     {STRLEN asz;
      char *as = SvPV(a,asz);
      STRLEN bsz;
      char *bs = SvPV(b,bsz);
      if (bsz != asz)
       return 0;
      return !memcmp(as,bs,asz);
     }
  }
}

VOID *
Tcl_GetThreadData(keyPtr, size)
    Tcl_ThreadDataKey *keyPtr;	/* Identifier for the data chunk */
    int size;			/* Size of storage block */
{
    VOID *result;
    if (*keyPtr == NULL) {
	result = (VOID *)ckalloc((size_t)size);
	memset((char *)result, 0, (size_t)size);
	*keyPtr = (Tcl_ThreadDataKey)result;
	/* TclRememberDataKey(keyPtr); */
    }
    result = *(VOID **)keyPtr;
    return result;
}

VOID *
TclThreadDataKeyGet(keyPtr)
    Tcl_ThreadDataKey *keyPtr;	/* Identifier for the data chunk,
				 * really (pthread_key_t **) */
{
    char *result = *(char **)keyPtr;
    return (VOID *)result;
}


Tcl_ThreadId
Tcl_GetCurrentThread(void)
{
#if 0
 warn("%s not implemented",__FUNCTION__);
 abort();
#endif
 return 0;
}

void
TclpAsyncMark(async)
Tcl_AsyncHandler async;		/* Token for handler. */
{
#ifdef WIN32
 static DWORD mainThreadId;
 if (!mainThreadId)
   mainThreadId = GetCurrentThreadId();


    /*
     * Need a way to kick the Windows event loop and tell it to go look at
     * asynchronous events.
     */

    PostThreadMessage(mainThreadId, WM_USER, 0, 0);
#endif
}

void
TclpInitLock(void)
{
}

void
TclpExit(int status)
{
/*
 * Tk::exit comes here - via Tcl_Exit()
 * Once upon a time and we just called my_exit()
 * but that causes perl to longjmp() out of tkEvent.c and tkBind.c
 * which have stored stack addresses in Tk structures.
 * The die scheme works round this but imposes cost on normal execution.
 */
 dTHX; /* FIXME */
 if (PL_in_eval)
  croak("_TK_EXIT_(%d)\n",status);
 else
  my_exit(status);
}

void
TclpInitUnlock(void)
{
}

void
TclpInitPlatform(void)
{
}

void
TclInitIOSubsystem(void)
{
}

void
TclInitObjSubsystem(void)
{
}

void
TclFinalizeIOSubsystem(void)
{
}

void
TclFinalizeThreadData(void)
{
}

void
TclFinalizeObjSubsystem(void)
{
}

void
LangAsyncCheck(void)
{
#ifdef PERL_ASYNC_CHECK
 dTHX;
 PERL_ASYNC_CHECK();
#endif
}