/*
  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 "tkGlue.def"

/* #define DO_CHECK_TCL_ALLOC */


#define TCL_EVENT_IMPLEMENT
#include "pTk/Lang.h"
#include "pTk/tkEvent.h"
#include "pTk/tkEvent_f.h"
#include "pTk/tkEvent_f.c"

extern void TclInitSubsystems(CONST char *argv0);

static int parent_pid = 0;

static SV *
FindVarName(pTHX_ char *varName,int flags)
{
 STRLEN len;
 SV *name = newSVpv("Tk",2);
 SV *sv;
 sv_catpv(name,"::");
 sv_catpv(name,varName);
 sv = perl_get_sv(SvPV(name,len),flags);
 SvREFCNT_dec(name);
 return sv;
}

#ifndef INT2PTR
#define INT2PTR(any,d) (any)(d)
#endif
#ifndef PTR2IV
#define PTR2IV(p)	INT2PTR(IV,p)
#endif

void
LangDebug(CONST char *fmt,...)
{
 dTHX; /* FIXME? */
 va_list ap;
 va_start(ap,fmt);
 if (SvIV(FindVarName(aTHX_ "LangDebug",GV_ADD|GV_ADDWARN)))
  {
   PerlIO_vprintf(PerlIO_stderr(), fmt, ap);
   PerlIO_flush(PerlIO_stderr());
  }
 va_end(ap);
}

void
#ifdef STANDARD_C
Tcl_Panic(CONST char *fmt,...)
#else
/*VARARGS0 */
Tcl_Panic(fmt, va_alist)
CONST char *fmt;
va_dcl
#endif
{
 dTHX;
 va_list ap;
#ifdef I_STDARG
 va_start(ap, fmt);
#else
 va_start(ap);
#endif
 PerlIO_flush(PerlIO_stderr());
 PerlIO_vprintf(PerlIO_stderr(), fmt, ap);
 PerlIO_putc(PerlIO_stderr(),'\n');
 va_end(ap);
#if defined(WIN32) && defined(DEBUGGING)
 {
  int *p = 0;
  if (*p)
   abort();
 }
#endif
 abort();
 croak("Tcl_Panic");
}

#undef Tcl_Realloc
#undef Tcl_Alloc
#undef Tcl_Free

#undef Tcl_DumpActiveMemory
#undef Tcl_ValidateAllMemory
void
Tcl_ValidateAllMemory (CONST char *file, int line)
{
}


#ifdef DO_CHECK_TCL_ALLOC

typedef struct alloc_s
{
 struct alloc_s *self;
 unsigned int size;
 struct alloc_s *next;
 struct alloc_s *prev;
 CONST char *file;
 int line;
 char space[1];
} alloc_t, *alloc_ptr;

static alloc_ptr allocated;

long Tcl_AllocCount = 0;

static int
is_perl_arena(void *ptr)
{
    SV *sv = ptr;
    SV* sva;
    register SV* svend;

    for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
	svend = &sva[SvREFCNT(sva)];
	if (sva <= sv && sv < svend)
	    return 1;
    }
    return 0;
}

static void
check_lp(alloc_ptr lp,CONST char *s, CONST char *file, int line)
{
 if (is_perl_arena(lp))
  {
   warn("Attempt to '%s(%p)' perl data @ %s:%d",s,&lp->space, file, line);
   abort();
  }
 if (lp->self != lp || lp[lp->size-1].self != lp)
  {
   warn("Invalid '%s(%p)' a=%p s=%p e=%p @ %s:%d/%s:%d",
         s,&lp->space,
         lp,lp->self, lp[lp->size-1].self, file, line, lp->file, lp->line);
   abort();
  }
}

static void
delink(alloc_ptr lp)
{
 lp->prev->next = lp->next;
 lp->next->prev = lp->prev;
 if (allocated == lp)
  {
   allocated = lp->prev;
   if (allocated == lp)
    allocated = NULL;
  }
}

static char *
enlink(alloc_ptr lp, unsigned int size, CONST char *file, int line)
{
 lp->next = (allocated) ? allocated : lp;
 lp->prev = (allocated) ? allocated->prev : lp;
 lp->prev->next = lp;
 lp->next->prev = lp;
 allocated = lp;
 lp->self = lp;
 lp->size = size;
 lp[size-1].self = lp;
 lp->file = file;
 lp->line = line;
 check_lp(lp,__FUNCTION__,file,line);
 return lp->space;
}

void
Lang_NoteOwner (void *owner,void *packet, CONST char *file, int line)
{
 alloc_ptr op = (alloc_ptr) ((char *)owner  - offsetof(alloc_t,space));
 alloc_ptr lp = (alloc_ptr) ((char *)packet - offsetof(alloc_t,space));
 check_lp(lp,__FUNCTION__, file, line);
 check_lp(op,__FUNCTION__, file, line);
 lp->file = op->file;
 lp->line = op->line;
}

char *
Tcl_DbCkrealloc (char *ptr,unsigned int size,CONST char *file,int line)
{
 alloc_ptr lp = (alloc_ptr) (ptr - offsetof(alloc_t,space));
 check_lp(lp,__FUNCTION__, file, line);
 file = lp->file;
 line = lp->line;
 delink(lp);
 if ((int) size < 0)
  abort();
 size = (sizeof(alloc_t)+size+sizeof(alloc_t)+sizeof(alloc_t)-1)/sizeof(alloc_t);
 lp = PerlMemShared_realloc(lp,size*sizeof(alloc_t));
 return enlink(lp,size,file,line);
}

char *
Tcl_DbCkalloc (unsigned int usize,CONST char *file,int line)
{
 char *res;
 alloc_t *lp;
 size_t size = (sizeof(alloc_t)+usize+sizeof(alloc_t)+sizeof(alloc_t)-1)/sizeof(alloc_t);
 if ((int) usize < 0)
  abort();
 lp = PerlMemShared_calloc(size, sizeof(alloc_t));
 Tcl_AllocCount++;
 res = enlink(lp,size,file,line);
 if (res+usize > (char *)(&lp[size-1].self))
  {
   warn("s=%x lp=%p res=%p..%p e=%p\n",usize,lp,res,res+usize,&lp[size-1].self);
   assert(res+usize <= (char *)(&lp[size-1].self));
  }
 return res;
}

int
Tcl_DbCkfree (char *ptr,CONST char *file ,int line)
{
 if (ptr)
  {
   alloc_ptr lp = (alloc_ptr) (ptr - offsetof(alloc_t,space));
   check_lp(lp,__FUNCTION__, file, line);
   delink(lp);
   Tcl_AllocCount--;
   memset(lp,-1,lp->size*sizeof(alloc_t));
   PerlMemShared_free(lp);
  }
 else
  {
#ifndef WIN32
   warn("Attempt to 'free(%p) @ %s:%s' NULL",ptr,file,line);
#endif
  }
 return 0;
}

int
Tcl_DumpActiveMemory (CONST char *fileName)
{
 alloc_ptr p = allocated;
 if (Tcl_AllocCount)
  {
   long count = 0;
   PerlIO_printf(PerlIO_stderr(),"\n%ld Tcl_Alloc packets un-freed\n",Tcl_AllocCount);
   do
    {
     PerlIO_printf(PerlIO_stderr(),"%3ld @ %s:%d\n",p->size,p->file,p->line);
     count++;
     p = p->next;
    } while (p != allocated);
   if (count != Tcl_AllocCount)
    {
     PerlIO_printf(PerlIO_stderr(),"%ld un-freed, %ld on chain",Tcl_AllocCount,count);
    }
  }
 return 0;
}

char *
Tcl_Realloc(char *p, unsigned int size)
{
 return Tcl_DbCkrealloc(p, size, __FILE__, __LINE__);
}

char *
Tcl_Alloc(unsigned int size)
{
 return Tcl_DbCkalloc(size,__FILE__,__LINE__);
}

void
Tcl_Free(char *p)
{
 Tcl_DbCkfree(p,__FILE__,__LINE__);
}

#else

void
Lang_NoteOwner (void *owner,void *packet, CONST char *file, int line)
{
}

int
Tcl_DumpActiveMemory (CONST char *fileName)
{
 return 0;
}

char *
Tcl_Realloc(char *p, unsigned int size)
{
 dTHXs;
 if ((int) size < 0)
  abort();
 p = PerlMemShared_realloc(p,size*sizeof(char));
 return p;
}

char *
Tcl_Alloc(unsigned int size)
{
 dTHXs;
 char *p;
 if ((int) size < 0)
  abort();
 p = PerlMemShared_calloc(size, sizeof(char));
 return p;
}

void
Tcl_Free(char *p)
{
 dTHXs;
 PerlMemShared_free(p);
}

char *
Tcl_DbCkalloc (unsigned int size,CONST char *file,int line)
{
 return Tcl_Alloc(size);
}

int
Tcl_DbCkfree (char *ptr,CONST char *file ,int line)
{
 Tcl_Free(ptr);
 return 0;
}

char *
Tcl_DbCkrealloc (char *ptr,unsigned int size,CONST char *file,int line)
{
 return Tcl_Realloc(ptr,size);
}

#endif

char *
Tcl_AttemptDbCkalloc(unsigned int usize,CONST char *file,int line)
{
 return Tcl_DbCkalloc(usize,file,line);
}

void
Event_CleanupGlue(void)
{

}


long
Lang_OSHandle(fd)
int fd;
{
#if defined(WIN32) && !defined(__CYGWIN__)
 return win32_get_osfhandle(fd);
#else
 return fd;
#endif
}

static void
install_vtab(pTHX_ char *name, void *table, size_t size)
{
 if (table)
  {
   typedef int (*fptr)_((void));
   fptr *q = table;
   unsigned i;
   sv_setiv(FindVarName(aTHX_ name,GV_ADD|GV_ADDMULTI),PTR2IV(table));
   if (size % sizeof(fptr))
    {
     warn("%s is strange size %d",name,size);
    }
   size /= sizeof(void *);
   for (i=0; i < size; i++)
    {
     if (!q[i])
      warn("%s slot %d is NULL",name,i);
    }
  }
 else
  {
   croak("%s pointer is NULL",name);
  }
}

static void SetupProc _ANSI_ARGS_((ClientData clientData, int flags));
static void CheckProc _ANSI_ARGS_((ClientData clientData, int flags));
static int EventProc  _ANSI_ARGS_((Tcl_Event *evPtr, int flags));

typedef struct PerlIOHandler
 {
  struct PerlIOHandler *nextPtr;  /* Next in list of all files we care about. */
  SV *handle;                     /* Handle we are tied to */
  IO *io;                         /* Current IO within handle */
  GV *untied;                     /* Another handle to pass to methods
                                   * it is untied to avoid recusion and
                                   * has IoIFP/IoOFP of its IO dynamically set to those
                                   * of io.
                                   */
  LangCallback *readHandler;
  LangCallback *writeHandler;
  LangCallback *exceptionHandler;
  int mask;                       /* Mask of desired events: TCL_READABLE etc. */
  int readyMask;                  /* Mask of events that have been seen since the
                                     * last time file handlers were invoked for
                                     * this file. */
  int waitMask;                   /* Events on which we are doing blocking wait */
  int handlerMask;                /* Events for which we have callbacks */
  int callingMask;                /* Events for which we are in callbacks */
  int pending;
  SV *mysv;
  IV extraRefs;
  } PerlIOHandler;

typedef struct PerlIOEvent
 {
  Tcl_Event header;               /* Information that is standard for all events. */
  IO *io;                         /* PerlIO descriptor that is ready. */
 } PerlIOEvent;


static int initialized = 0;

static PerlIOHandler *firstPerlIOHandler;

static void PerlIOEventInit(void);

static void PerlIO_watch(PerlIOHandler *filePtr);

static volatile int stuck;

void
PerlIO_MaskCheck(PerlIOHandler *filePtr)
{
 if (filePtr->mask & ~(filePtr->waitMask|filePtr->handlerMask))
  {
   warn("Mask=%d wait=%d handler=%d",
         filePtr->mask, filePtr->waitMask, filePtr->handlerMask);
   PerlIO_watch(filePtr);
  }
}

static void
PerlIOFileProc(ClientData clientData, int mask)
{
 PerlIOHandler *filePtr = (PerlIOHandler *) clientData;
 PerlIO_MaskCheck(filePtr);
 filePtr->readyMask |= (mask & filePtr->mask);
}

SV *
PerlIO_handle(filePtr)
PerlIOHandler *filePtr;
{
 dTHX; /* FIXME */
 filePtr->io = sv_2io(filePtr->handle);
 if (filePtr->io)
  {
   /* io exists - copy current PerlIO * from io to our un-tied IO */
   IO *tmpio = GvIOp(filePtr->untied);
   IoIFP(tmpio) = IoIFP(filePtr->io);
   IoOFP(tmpio) = IoOFP(filePtr->io);
   IoFLAGS(tmpio) = IoFLAGS(filePtr->io);
   return newRV((SV *) filePtr->untied);
  }
 return &PL_sv_undef;
}

void
PerlIO_unwatch(PerlIOHandler *filePtr)
{
 filePtr->waitMask = filePtr->handlerMask = 0;
 PerlIO_watch(filePtr);
}

void
PerlIO_watch(PerlIOHandler *filePtr)
{
 dTHX; /* FIXME */
 PerlIO *ip = IoIFP(filePtr->io);
 PerlIO *op = IoOFP(filePtr->io);
 int fd     = (ip) ? PerlIO_fileno(ip) : ((op) ? PerlIO_fileno(op) : -1);
 int mask   = filePtr->waitMask|filePtr->handlerMask;

 if (mask & ~(TCL_READABLE|TCL_EXCEPTION|TCL_WRITABLE))
  {
   LangDebug("Invalid mask %x",mask);
   croak("Invalid mask %x",mask);
  }

 if (mask & (TCL_READABLE|TCL_EXCEPTION))
  {
   if (!ip)
    croak("Handle not opened for input");
  }

 if (mask & (TCL_WRITABLE))
  {
   if (!op)
    croak("Handle not opened for output");
  }

 if ((mask & TCL_READABLE) && (mask & TCL_WRITABLE))
  {
   /* Both read and write IO - make sure buffers not shared */
   if (op && (op == ip) && fd >= 0)
    {
     IoOFP(filePtr->io) = op = PerlIO_fdopen(fd, "w");
    }
   if (PerlIO_fileno(ip) != PerlIO_fileno(op))
    {
     croak("fileno not same for read %d  and write %d",
           PerlIO_fileno(ip) , PerlIO_fileno(op));
    }
  }

 if (filePtr->mask != mask)
  {
   if (fd >= 0)
    {
     Tcl_DeleteFileHandler(fd);
    }
   if (mask && fd >= 0)
    {
     Tcl_CreateFileHandler(fd, mask, PerlIOFileProc, (ClientData) filePtr );
    }
   filePtr->mask = mask;
  }

}

int
PerlIO_is_writable(PerlIOHandler *filePtr)
{
 if (!(filePtr->readyMask & TCL_WRITABLE))
  {
   dTHX; /* FIXME */
   PerlIO *op = IoOFP(filePtr->io);
   if (op)
    {
     if (PerlIO_has_cntptr(op) && PerlIO_get_cnt(op) > 0)
      {
       filePtr->readyMask |= TCL_WRITABLE;
      }
    }
  }
 return (filePtr->readyMask & TCL_WRITABLE);
}

int
PerlIO_is_readable(PerlIOHandler *filePtr)
{
 dTHX; /* FIXME */
 if (!(filePtr->readyMask & TCL_READABLE))
  {
   PerlIO *io = IoIFP(filePtr->io);
   if (io)
    {
#ifdef PERLIO_LAYERS
     if (PerlIO_has_cntptr(io) && PerlIO_get_cnt(io) > 0)
      {
       filePtr->readyMask |= TCL_READABLE;
      }
#else
     /* Turn this buffer stuff off for now */
     if (PerlIO_has_cntptr(io) && PerlIO_get_cnt(io) > 0)
      {
       filePtr->readyMask |= TCL_READABLE;
      }
#endif
    }
  }
 return (filePtr->readyMask & TCL_READABLE);
}

int
PerlIO_has_exception(PerlIOHandler *filePtr)
{
 return (filePtr->readyMask & TCL_EXCEPTION);
}

void
PerlIO_wait(filePtr,mask)
PerlIOHandler *	filePtr;
int		mask;
{
 /* Return at once if we are in the callback */
 if (!(filePtr->callingMask & mask))
  {
   int oldMask = filePtr->mask & mask;
   int oldWait = filePtr->waitMask & mask;
   int (*check)(PerlIOHandler *) = NULL;
   /* Prepare to poll */
   switch (mask)
    {
     case TCL_EXCEPTION:
      check = PerlIO_has_exception;
      break;
     case TCL_WRITABLE:
      check = PerlIO_is_writable;
      break;
     case TCL_READABLE:
      check = PerlIO_is_readable;
      break;
     default:
      croak("Invalid wait type %d",mask);
    }

   /* Inhibit callbacks */
   filePtr->waitMask |= mask;

   /* Watch handle if we are not already */
   if (!oldMask)
    PerlIO_watch(filePtr);

   while (!(*check)(filePtr))
    {
     Tcl_DoOneEvent(0);
    }

   /* Restore watch state */
   filePtr->waitMask = (filePtr->waitMask&~mask)|oldWait;
   PerlIO_watch(filePtr);

   /* Re-enable callbacks */
   /* Consume the readiness */
   filePtr->readyMask &= ~mask;
  }
}

void
TkPerlIO_debug(filePtr,s)
PerlIOHandler *filePtr;
char *s;
{
 dTHX; /* FIXME */
 PerlIO *ip = IoIFP(filePtr->io);
 PerlIO *op = IoOFP(filePtr->io);
 int ifd    = (ip) ? PerlIO_fileno(ip) : -1;
 int ofd    = (op) ? PerlIO_fileno(op) : -1;
 LangDebug("%s: ip=%p count=%d, op=%p count=%d\n",s,
           ip,PerlIO_get_cnt(ip),
           op,PerlIO_get_cnt(op));
}

static void
PerlIOSetupProc(ClientData data, int flags)
{
 static Tcl_Time blockTime = {0, 0};
 if (flags & TCL_FILE_EVENTS)
  {
   PerlIOHandler *filePtr = firstPerlIOHandler;
   while (filePtr != NULL)
    {
     /* file is ready do not block */
     if ((filePtr->mask & TCL_READABLE)
          && PerlIO_is_readable(filePtr))
      Tcl_SetMaxBlockTime(&blockTime);
     if ((filePtr->mask & TCL_WRITABLE)
          && PerlIO_is_writable(filePtr))
      Tcl_SetMaxBlockTime(&blockTime);
     if ((filePtr->mask & TCL_EXCEPTION)
          && PerlIO_has_exception(filePtr))
      Tcl_SetMaxBlockTime(&blockTime);
     filePtr = filePtr->nextPtr;
    }
  }
}

static int
PerlIOEventProc(Tcl_Event *evPtr, int flags)
{
 if (flags & TCL_FILE_EVENTS)
  {
   PerlIOEvent *fileEvPtr = (PerlIOEvent *) evPtr;
   PerlIOHandler *filePtr = firstPerlIOHandler;
   dTHX;
   /*
    * Search through the file handlers to find the one whose handle matches
    * the event.  We do this rather than keeping a pointer to the file
    * handler directly in the event, so that the handler can be deleted
    * while the event is queued without leaving a dangling pointer.
    */

   while (filePtr != NULL)
    {
     if (filePtr->io == fileEvPtr->io)
      {
       int doMask;
       /*
        * The code is tricky for two reasons:
        * 1. The file handler's desired events could have changed
        *    since the time when the event was queued, so AND the
        *    ready mask with the desired mask.
        * 2. The file could have been closed and re-opened since
        *    the time when the event was queued.  This is why the
        *    ready mask is stored in the file handler rather than
        *    the queued event:  it will be zeroed when a new
        *    file handler is created for the newly opened file.
        */
       PerlIO_MaskCheck(filePtr);

       /* clear bits nobody cares about */
       filePtr->readyMask &= filePtr->mask;

       /* Decide which callbacks will be called */
       doMask = (filePtr->readyMask) & (~(filePtr->waitMask)) & (filePtr->handlerMask);

       /* clear bits we are going to callback */
       filePtr->readyMask &= ~doMask;
       filePtr->pending = 0;

       if ((doMask & TCL_READABLE) && filePtr->readHandler)
        {
         SV *sv = filePtr->readHandler;
         ENTER;
         SAVETMPS;
         SvREFCNT_inc(filePtr->mysv);
         filePtr->extraRefs++;
         filePtr->callingMask |= TCL_READABLE;
         LangPushCallbackArgs(&sv);
         LangCallCallback(sv,G_DISCARD);
         filePtr->callingMask &= ~TCL_READABLE;
         filePtr->extraRefs--;
         SvREFCNT_dec(filePtr->mysv);
         FREETMPS;
         LEAVE;
        }
       if ((doMask & TCL_WRITABLE) && filePtr->writeHandler)
        {
         SV *sv = filePtr->writeHandler;
         ENTER;
         SAVETMPS;
         SvREFCNT_inc(filePtr->mysv);
         filePtr->extraRefs++;
         filePtr->callingMask |= TCL_WRITABLE;
         LangPushCallbackArgs(&sv);
         LangCallCallback(sv,G_DISCARD);
         filePtr->callingMask &= ~TCL_WRITABLE;
         filePtr->extraRefs--;
         SvREFCNT_dec(filePtr->mysv);
         FREETMPS;
         LEAVE;
        }
       if ((doMask & TCL_EXCEPTION) && filePtr->exceptionHandler)
        {
         SV *sv = filePtr->exceptionHandler;
         ENTER;
         SAVETMPS;
         SvREFCNT_inc(filePtr->mysv);
         filePtr->extraRefs++;
         filePtr->callingMask |= TCL_EXCEPTION;
         LangPushCallbackArgs(&sv);
         LangCallCallback(sv,G_DISCARD);
         filePtr->callingMask &= ~TCL_EXCEPTION;
         filePtr->extraRefs--;
         SvREFCNT_dec(filePtr->mysv);
         FREETMPS;
         LEAVE;
        }
       break;
      }
     filePtr = filePtr->nextPtr;
    }
   return 1;    /* Say we have handled event */
  }
 return 0;      /* Event is deferred */
}

static void
PerlIOCheckProc(ClientData data, int flags)
{
 if (flags & TCL_FILE_EVENTS)
  {
   PerlIOEvent *fileEvPtr;
   PerlIOHandler *filePtr = firstPerlIOHandler;
   while (filePtr)
    {
     PerlIO_MaskCheck(filePtr);
     if ((filePtr->readyMask & ~filePtr->waitMask & filePtr->handlerMask)
         && !filePtr->pending)
      {
       fileEvPtr = (PerlIOEvent *) ckalloc(sizeof(PerlIOEvent));
       fileEvPtr->io = filePtr->io;
       Tcl_QueueProcEvent(PerlIOEventProc, (Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL);
       filePtr->pending = 1;
      }
     filePtr = filePtr->nextPtr;
    }
  }
}

static void
PerlIOExitHandler(ClientData clientData)
{
 Tcl_DeleteEventSource(PerlIOSetupProc, PerlIOCheckProc, NULL);
 initialized = 0;
}

static void
PerlIOEventInit(void)
{
 initialized = 1;
 firstPerlIOHandler = NULL;
 Tcl_CreateEventSource(PerlIOSetupProc, PerlIOCheckProc, NULL);
 Tcl_CreateExitHandler(PerlIOExitHandler, NULL);
}

PerlIOHandler *
SVtoPerlIOHandler(sv)
SV *sv;
{
 dTHX; /* FIXME */
 if (sv_isa(sv,"Tk::Event::IO"))
  return (PerlIOHandler *) SvPVX(SvRV(sv));
 croak("Not an Tk::Event::IO");
 return NULL;
}


SV *
PerlIO_TIEHANDLE(class, fh, mask)
char *class;
SV *fh;
int mask;                         /* OR'ed TCL_READABLE, TCL_WRITABLE, and TCL_EXCEPTION */
{
 dTHX; /* FIXME */
 HV *stash = gv_stashpv(class, TRUE);
 GV *tmpgv = (GV *) newSV(0);
 IO *tmpio = newIO();
 IO *io = sv_2io(fh);
 SV *obj = newSV(sizeof(PerlIOHandler));
 PerlIOHandler *filePtr = (PerlIOHandler *)SvPVX(obj);
 gv_init(tmpgv,stash,"Foo",3,0);
 GvIOp(tmpgv) = tmpio;
 if (!initialized)
  PerlIOEventInit();
 Zero(filePtr,1,PerlIOHandler);
 filePtr->io          = io;
 filePtr->handle      = SvREFCNT_inc(fh);
 filePtr->untied      = tmpgv;
 filePtr->readyMask   = 0;
 filePtr->handlerMask = 0;
 filePtr->mask        = 0;
 filePtr->waitMask    = mask;
 filePtr->pending     = 0;
 filePtr->nextPtr     = firstPerlIOHandler;
 filePtr->mysv        = obj;
 filePtr->extraRefs   = 0;
 firstPerlIOHandler   = filePtr;
 PerlIO_watch(filePtr);
 obj = newRV_noinc(obj);
 sv_bless(obj, stash);
 return obj;
}

void
PerlIO_DESTROY(thisPtr)
PerlIOHandler *thisPtr;
{
 dTHX; /* FIXME */
 if (initialized)
  {
   PerlIOHandler **link = &firstPerlIOHandler;
   PerlIOHandler *filePtr;
   while ((filePtr = *link))
    {
     if (!thisPtr || filePtr == thisPtr)
      {
       IO *tmpio;
       *link = filePtr->nextPtr;
       PerlIO_unwatch(filePtr);
       if (filePtr->readHandler)
        {
         LangFreeCallback(filePtr->readHandler);
         filePtr->readHandler = NULL;
        }
       if (filePtr->writeHandler)
        {
         LangFreeCallback(filePtr->writeHandler);
         filePtr->writeHandler = NULL;
        }
       if (filePtr->exceptionHandler)
        {
         LangFreeCallback(filePtr->exceptionHandler);
         filePtr->exceptionHandler = NULL;
        }
       tmpio = GvIOp(filePtr->untied);
       IoIFP(tmpio) = NULL;
       IoOFP(tmpio) = NULL;
       SvREFCNT_dec(filePtr->untied);
       SvREFCNT_dec(filePtr->handle);
      }
     else
      {
       link = &filePtr->nextPtr;
      }
    }
  }
}




SV *
PerlIO_handler(filePtr, mask, cb)
PerlIOHandler *filePtr;
int mask;
LangCallback *cb;
{
 dTHX; /* FIXME */
 STRLEN len;
 if (cb)
  {
   if (!SvROK(cb))
    cb = NULL;
   if (mask & TCL_READABLE)
    {
     if (filePtr->readHandler)
      {
       LangFreeCallback(filePtr->readHandler);
       filePtr->readHandler = NULL;
      }
     if (cb)
      {
       filePtr->readHandler = LangCopyCallback(cb);
      }
    }
   if (mask & TCL_WRITABLE)
    {
     if (filePtr->writeHandler)
      {
       LangFreeCallback(filePtr->writeHandler);
       filePtr->writeHandler = NULL;
      }
     if (cb)
      {
       filePtr->writeHandler = LangCopyCallback(cb);
      }
    }
   if (mask & TCL_EXCEPTION)
    {
     if (filePtr->exceptionHandler)
      {
       LangFreeCallback(filePtr->exceptionHandler);
       filePtr->exceptionHandler = NULL;
      }
     if (cb)
      {
       filePtr->exceptionHandler = LangCopyCallback(cb);
      }
    }
   if (cb)
    {
     filePtr->handlerMask |= mask;
    }
   else
    {
     filePtr->handlerMask &= ~mask;
    }
   PerlIO_watch(filePtr);
   /* What we return will be made mortal and free'd by caller
      which will balance the effective REFCNT_inc
      in LangMakeCallback()
    */
   return (cb) ? cb : &PL_sv_undef;
  }
 else
  {
   switch (mask)
    {
     case TCL_EXCEPTION:
      cb = filePtr->exceptionHandler;
      break;
     case TCL_WRITABLE:
      cb = filePtr->writeHandler;
      break;
     case TCL_READABLE:
      cb = filePtr->readHandler;
      break;
     default:
      croak("Invalid handler type %d",mask);
    }
   /* We need the REFCNT_inc from LangCallbackObj() to
      counter the mortal-ize of return result
    */
   return (cb) ? LangCallbackObj(cb) : &PL_sv_undef;
  }
}

void
PerlIO_Cleanup(PerlIOHandler *filePtr)
{
 PerlIO_unwatch(filePtr);
 if (filePtr->readHandler)
  {
   LangFreeCallback(filePtr->readHandler);
   filePtr->readHandler = NULL;
  }
 if (filePtr->writeHandler)
  {
   LangFreeCallback(filePtr->writeHandler);
   filePtr->writeHandler = NULL;
  }
 if (filePtr->exceptionHandler)
  {
   LangFreeCallback(filePtr->exceptionHandler);
   filePtr->exceptionHandler = NULL;
  }
}

void
PerlIO_UNTIE(SV *sv,IV count)
{
 PerlIOHandler *thisPtr = SVtoPerlIOHandler(sv);
 if ((count-thisPtr->extraRefs) > 0) {
  warn("untie called with %ld references",count);
 }
}

void
PerlIO_END(void)
{
 PerlIO_DESTROY(NULL);
}

static void
SetupProc(clientData,flags)
ClientData clientData;
int flags;
{
 dTHX; /* FIXME */
 dSP;
 ENTER;
 SAVETMPS;
 PUSHMARK(sp);
 XPUSHs(sv_2mortal(newRV((SV *)clientData)));
 XPUSHs(sv_2mortal(newSViv(flags)));
 PUTBACK;
 perl_call_method("setup",G_VOID);
 FREETMPS;
 LEAVE;
}

static void
CheckProc(clientData,flags)
ClientData clientData;
int flags;
{
 dTHX; /* FIXME */
 dSP;
 ENTER;
 SAVETMPS;
 PUSHMARK(sp);
 XPUSHs(sv_2mortal(newRV((SV *)clientData)));
 XPUSHs(sv_2mortal(newSViv(flags)));
 PUTBACK;
 perl_call_method("check",G_VOID);
 FREETMPS;
 LEAVE;
}

typedef struct
{
 Tcl_Event sv;
 SV *obj;
} PerlEvent;

static int
EventProc(evPtr, flags)
Tcl_Event *evPtr;
int flags;
{PerlEvent *pe = (PerlEvent *) evPtr;
 int code = 1;
 int count;
 dTHX; /* FIXME */
 dSP;
 ENTER;
 SAVETMPS;
 PUSHMARK(sp);
 XPUSHs(pe->obj);
 XPUSHs(sv_2mortal(newSViv(flags)));
 PUTBACK;
 count = perl_call_method("event",G_SCALAR);
 SPAGAIN;
 if (count)
  {
   SV *result = POPs;
   code = SvIV(result);
  }
 PUTBACK;
 FREETMPS;
 LEAVE;
 return code;
}

#ifndef NSIG
#define NSIG 64
#endif

static Signal_t handle_signal _((int sig));
static Signal_t (*old_handler) _((int sig)) = NULL;
static char seen[NSIG];

Tcl_AsyncHandler async[NSIG];

static Signal_t
handle_signal(sig)
int sig;
{
 if (sig >= 0 && sig < NSIG)
  {
   if (async[sig])
    Tcl_AsyncMark(async[sig]);
  }
}

void
HandleSignals(pTHX)
{
#if defined(PATCHLEVEL) && (PATCHLEVEL < 5)
 croak("Cannot HandleSignals with before perl5.005");
#else
 if (PL_sighandlerp != handle_signal)
  {
   old_handler    = PL_sighandlerp;
   PL_sighandlerp = handle_signal;
  }
#endif
}

XS(XS_Tk__Callback_Call)
{
 dXSARGS;
 STRLEN na;
 int i;
 int count;
 SV *cb = ST(0);
 SV *err;
 int wantarray = GIMME;
 if (!items)
  {
   croak("No arguments");
  }
 LangPushCallbackArgs(&cb);
 SPAGAIN;
 for (i=1; i < items; i++)
  {
   if (SvTAINTED(ST(i)))
    {
     croak("Tcl_Obj * %d to callback %"SVf" is tainted",i,ST(i));
    }
   XPUSHs(ST(i));
  }
 PUTBACK;

 count = LangCallCallback(cb,GIMME|G_EVAL);
 SPAGAIN;

 err = ERRSV;
 if (SvTRUE(err))
  {
   SV *save = sv_2mortal(newSVsv(err));
   STRLEN len;
   char *s = SvPV(save, len);
   if (len >= 11 && !strncmp("_TK_EXIT_(",s,10))
    {
     char *e = strchr(s+=10,')');
     sv_setpvn(save,s,e-s);
     TclpExit(SvIV(save));
    }
   else
    {
     LangDebug("%s error:%.*s\n",__FUNCTION__,len,s);
     croak("%s",s);
    }
  }
 if (count)
  {
   for (i=1; i <= count; i++)
    {
     ST(i-1) = sp[i-count];
    }
  }
 else
  {
   if (!(wantarray & G_ARRAY))
    {
     ST(0) = &PL_sv_undef;
     count++;
    }
  }
 PUTBACK;
 XSRETURN(count);
}

static void
Callback_DESTROY(SV *sv)
{
}

#define Tcl_setup(obj,flags)
#define Tcl_check(obj,flags)

#define Const_READABLE() TCL_READABLE
#define Const_WRITABLE() TCL_WRITABLE
#define Const_EXCEPTION() TCL_EXCEPTION

#define Const_DONT_WAIT()     (TCL_DONT_WAIT)
#define Const_WINDOW_EVENTS() (TCL_WINDOW_EVENTS)
#define Const_FILE_EVENTS()   (TCL_FILE_EVENTS)
#define Const_TIMER_EVENTS()  (TCL_TIMER_EVENTS)
#define Const_IDLE_EVENTS()   (TCL_IDLE_EVENTS)
#define Const_ALL_EVENTS()    (TCL_ALL_EVENTS)

#define Event_INIT()

extern XSdec(XS_Tk__Event_INIT);
XS(XS_Tk__Event_INIT)
{
 dXSARGS;
 install_vtab(aTHX_ "TkeventVtab",TkeventVGet(),sizeof(TkeventVtab));
 XSRETURN_EMPTY;
}

#define pTk_exit(status) TclpExit(status)

#define IsParentProcess() (PerlProc_getpid() == parent_pid)

void pTk_END()
{
 dTHX;
 if (IsParentProcess())
  {
   Tcl_Finalize();
  }
}

MODULE = Tk	PACKAGE = Tk	PREFIX = pTk_

PROTOTYPES: ENABLE

void
pTk_IsParentProcess(...)
CODE:
 {
  ST(0) = (IsParentProcess()) ? &PL_sv_yes : &PL_sv_no;
  XSRETURN(1);
 }

void
pTk_END()

void
pTk_exit(status = 0)
int	status

MODULE = Tk::Event	PACKAGE = Tk::Callback	PREFIX = Callback_
PROTOTYPES: DISABLE

void
Callback_DESTROY(object)
SV *	object

MODULE = Tk::Event	PACKAGE = Tk::Event::IO PREFIX = Const_

PROTOTYPES: ENABLE

int
Const_READABLE()

int
Const_WRITABLE()

int
Const_EXCEPTION()

MODULE = Tk::Event	PACKAGE = Tk::Event PREFIX = Const_

PROTOTYPES: ENABLE

IV
Const_DONT_WAIT()

IV
Const_WINDOW_EVENTS()

IV
Const_FILE_EVENTS()

IV
Const_TIMER_EVENTS()

IV
Const_IDLE_EVENTS()

IV
Const_ALL_EVENTS()

MODULE = Tk::Event	PACKAGE = Tk::Event::IO	PREFIX = TkPerlIO_

PROTOTYPES: DISABLE

void
TkPerlIO_debug(filePtr,s)
PerlIOHandler *	filePtr
char *	s

MODULE = Tk::Event	PACKAGE = Tk::Event::IO	PREFIX = PerlIO_

PROTOTYPES: DISABLE

SV *
PerlIO_TIEHANDLE(class,fh,mask = 0)
char *	class
SV *	fh
int	mask

SV *
PerlIO_handle(filePtr)
PerlIOHandler *	filePtr

void
PerlIO_unwatch(filePtr)
PerlIOHandler *	filePtr

void
PerlIO_wait(filePtr,mode)
PerlIOHandler *	filePtr
int		mode

int
PerlIO_is_readable(filePtr)
PerlIOHandler *	filePtr

int
PerlIO_has_exception(filePtr)
PerlIOHandler *	filePtr

int
PerlIO_is_writable(filePtr)
PerlIOHandler *	filePtr

SV *
PerlIO_handler(filePtr, mask = TCL_READABLE, cb = NULL)
PerlIOHandler *	filePtr
int		mask
LangCallback *	cb

void
PerlIO_DESTROY(filePtr)
PerlIOHandler *	filePtr

void
PerlIO_UNTIE(filePtr,count)
SV *		filePtr
IV		count


void
PerlIO_END()

MODULE = Tk::Event	PACKAGE = Tk::Event::Source	PREFIX = Tcl_

void
Tcl_setup(obj,flags)
SV *	obj
int	flags

void
Tcl_check(obj,flags)
SV *	obj
int	flags

void
new(class,sv)
char *	class
SV *	sv
CODE:
{
 HV *stash = gv_stashpv(class, TRUE);
 if (SvROK(sv))
  {
   sv = newSVsv(sv);
  }
 else
  {
   sv = newRV(sv);
  }
 sv_bless(sv, stash);
 Tcl_CreateEventSource(SetupProc,CheckProc,(ClientData)SvRV(sv));
 ST(0) = sv;
}

void
delete(sv)
SV *	sv
CODE:
{
 SV *obj = SvRV(sv);
 Tcl_DeleteEventSource(SetupProc,CheckProc,(ClientData)obj);
 SvREFCNT_dec(obj);
}

MODULE = Tk::Event	PACKAGE = Tk::Event	PREFIX = Tcl_

double
dGetTime()
CODE:
 {Tcl_Time time;
  Tcl_GetTime(&time);
  RETVAL = (double) time.sec + time.usec * 1e-6;
 }
OUTPUT:
 RETVAL

void
Tcl_Exit(status)
int	status

int
Tcl_DoOneEvent(flags)
int	flags

void
Tcl_QueueEvent(evPtr, position = TCL_QUEUE_TAIL)
Tcl_Event *		evPtr
Tcl_QueuePosition	position

void
Tcl_QueueProcEvent(proc, evPtr, position  = TCL_QUEUE_TAIL)
Tcl_EventProc *		proc
Tcl_Event *		evPtr
Tcl_QueuePosition	position

int
Tcl_ServiceEvent(flags)
int	flags

Tcl_TimerToken
Tcl_CreateTimerHandler(milliseconds, proc, clientData = NULL)
int		milliseconds
Tcl_TimerProc *	proc
ClientData	clientData

void
Tcl_DeleteTimerHandler(token)
Tcl_TimerToken	token

void
Tcl_SetMaxBlockTime(sec, usec = 0)
double	sec
IV	usec
CODE:
 {
  Tcl_Time ttime;
  ttime.sec  = sec;
  ttime.usec = (sec - ttime.sec) * 1e6 + usec;
  Tcl_SetMaxBlockTime(&ttime);
 }

void
Tcl_DoWhenIdle(proc,clientData = NULL)
Tcl_IdleProc *	proc
ClientData	clientData

void
Tcl_CancelIdleCall(proc,clientData = NULL)
Tcl_IdleProc *	proc
ClientData	clientData

void
Tcl_CreateExitHandler(proc,clientData = NULL)
Tcl_ExitProc *	proc
ClientData	clientData

void
Tcl_CreateFileHandler(fd, mask, proc, clientData = NULL)
int		fd
int		mask
Tcl_FileProc *	proc
ClientData	clientData

void
Tcl_DeleteFileHandler(fd)
int	fd

void
Tcl_Sleep(ms)
int	ms

int
Tcl_GetServiceMode()

int
Tcl_SetServiceMode(mode)
int	mode

int
Tcl_ServiceAll()

void
HandleSignals()
CODE:
 {
  HandleSignals(aTHX);
 }

MODULE = Tk::Event	PACKAGE = Tk::Event	PREFIX = Event_

void
Event_CleanupGlue()

MODULE = Tk::Event	PACKAGE = Tk::Event

PROTOTYPES: DISABLE

BOOT:
 {
#ifdef pWARN_NONE
  SV *old_warn = PL_curcop->cop_warnings;
  PL_curcop->cop_warnings = pWARN_NONE;
#endif
  newXS("Tk::Event::INIT", XS_Tk__Event_INIT, file);
#ifdef pWARN_NONE
 PL_curcop->cop_warnings = old_warn;
#endif
  newXS("Tk::Callback::Call", XS_Tk__Callback_Call, __FILE__);
  install_vtab(aTHX_ "TkeventVtab",TkeventVGet(),sizeof(TkeventVtab));
  sv_setiv(FindVarName(aTHX_ "LangDebug",GV_ADD|GV_ADDMULTI),1);
  TclInitSubsystems(SvPV_nolen(get_sv("0",FALSE)));
  parent_pid = PerlProc_getpid();
 }