/*
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();
}