Tk.xs

/*
  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"

static STRLEN na; /* Quick and dirty fix */

#include "pTk/tkPort.h"
#include "pTk/tkInt.h"
#include "pTk/tkFont.h"
#include "pTk/tkXrm.h"
#include "pTk/default.h"

#if defined(__WIN32__) && !defined(__EMX__)
#  include "pTk/tkWinInt.h"
#endif

#include "tkGlue.h"

#ifdef NEED_PRELOAD
#ifdef I_DLFCN
#include <dlfcn.h>	/* the dynamic linker include file for Sunos/Solaris */
#else
#include <nlist.h>
#include <link.h>
#endif
#define NeedPreload() 1
#else

#define NeedPreload() 0
#endif

#define Tk_tainting() (PL_tainting)
#define Tk_tainted(sv) ((sv) ? SvTAINTED(sv) : PL_tainted)

static void
DebugHook(SV *sv)
{

}

#define XEvent_DESTROY(obj)

#define Tk_XRaiseWindow(w) XRaiseWindow(Tk_Display(w),Tk_WindowId(w))

#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)

#ifndef SELECT_FG
/* Should really depend on color/mono */
#define SELECT_FG BLACK
#endif

#define Const_NORMAL_BG()     (NORMAL_BG)
#define Const_ACTIVE_BG()     (ACTIVE_BG)
#define Const_SELECT_BG()     (SELECT_BG)
#define Const_SELECT_FG()     (SELECT_FG)
#define Const_TROUGH()        (TROUGH)
#define Const_INDICATOR()     (INDICATOR)
#define Const_DISABLED()      (DISABLED)
#define Const_BLACK()         (BLACK)
#define Const_WHITE()         (WHITE)

static XFontStruct * TkwinFont _((Tk_Window tkwin, Tk_Uid name));

#define pTk_Synchronize(win,flag) \
   XSynchronize(Tk_Display(win), flag)

static IV
PointToWindow(Tk_Window tkwin, int x, int y, Window dest)
{
 Display *dpy = Tk_Display(tkwin);
 Window root = RootWindowOfScreen(Tk_Screen(tkwin));
 Window win = None;
 if (dest == None)
  dest = root;
#ifdef WIN32
 { 
  HWND hwnd = (HWND) Tk_GetHWND(dest);
  RECT  r;
  if (GetWindowRect(hwnd,&r))
   { 
    POINT pt;
    HWND child;
    pt.x = x - r.left;
    pt.y = y - r.top;
    child = ChildWindowFromPoint(hwnd, pt);
    if (child != hwnd)
     {
      TkWindow *winPtr = (TkWindow *) Tk_HWNDToWindow(child);
      if (winPtr) 
       {
        win = winPtr->window;
      } 
     }
   } 
  return (IV) win;
 }
#else
 if (!XTranslateCoordinates(dpy, root, dest, x, y, &x, &y, &win))
  {
   win = None;
  }
 return (IV) win;
#endif
}

static SV *
StringAlias(pTHX_ const char *s)
{
 SV *sv = newSV(0);
 sv_upgrade(sv,SVt_PV);
 SvPVX(sv) = (char *) s;
 SvCUR_set(sv,strlen(s));
 SvLEN(sv) = 0;
 SvPOK_only(sv);
 SvREADONLY_on(sv);
 return sv;
}

typedef struct
{
 CONST char *foundary;
 CONST char *encoding;
 TkFontAttributes attrib;
 const char *name;
} LangFontInfo;

static SV *
FontInfo(pTHX_ const char *encoding, const char *foundary,
         const TkFontAttributes *attrib, const char *name)
{
 SV *sv = newSV(sizeof(LangFontInfo));
 LangFontInfo *info = (LangFontInfo *) SvPVX(sv);
 SvCUR_set(sv,sizeof(LangFontInfo));
 SvPOK_only(sv);
 info->encoding = encoding;
 info->foundary = foundary;
 info->attrib   = *attrib;
 /* FIXME */
 info->name     = name;
 return sv_bless(newRV_noinc(sv),gv_stashpv("Tk::FontRankInfo", TRUE));
}

#define Boolean int

#define FontInfo_encoding(p) (StringAlias(aTHX_ (p)->encoding))
#define FontInfo_foundary(p) (StringAlias(aTHX_ (p)->foundary))
#define FontInfo_Xname(p)    (StringAlias(aTHX_ (p)->name))
#define FontInfo_family(p)   (StringAlias(aTHX_ (p)->attrib.family))
#define FontInfo_size(p)     ((p)->attrib.size)
#define FontInfo_bold(p)     ((p)->attrib.weight == TK_FW_BOLD)
#define FontInfo_italic(p)   ((p)->attrib.slant  == TK_FS_ITALIC)

unsigned int
LangFontRank(unsigned int suggested,
	     int ch,
	     CONST char *gotName,
	     CONST char *wantFoundary,
	     CONST TkFontAttributes *wantAttrib,
	     CONST char *wantEncoding,
	     CONST char *gotFoundary,
	     CONST TkFontAttributes *gotAttrib,
	     CONST char *gotEncoding)
{
 dTHX;
 SV *hook = get_sv("Tk::FontRank",0);
 if (hook && SvOK(hook))
  {
   dSP;
   int flags = (suggested == 0 || suggested == (unsigned int) -1)
                ? G_VOID : G_SCALAR;
   SV *result, *sv;
   int count;
   ENTER;
   SAVETMPS;
   LangPushCallbackArgs(&hook);
   result = Nullsv;
   sv = newSV(UTF8_MAXLEN);
   sv_upgrade(sv,SVt_PVIV);
#ifdef UNICODE_ALLOW_ANY
   count = uvchr_to_utf8_flags((U8 *) SvPVX(sv),ch, UNICODE_ALLOW_ANY)
               - (U8 *) SvPVX(sv);
#else
   count = Perl_uv_to_utf8(aTHX_ (U8 *) SvPVX(sv),ch) - (U8 *) SvPVX(sv);
#endif
   SvCUR_set(sv,count);
   SvPOK_on(sv);
   SvUTF8_on(sv);
   SvIVX(sv) = ch;
   SvIOK_on(sv);
   SPAGAIN;
   XPUSHs(sv_2mortal(newSViv((IV) suggested)));
   XPUSHs(sv_2mortal(sv));
   XPUSHs(sv_2mortal(FontInfo(aTHX_ wantEncoding, wantFoundary, wantAttrib, Nullch)));
   XPUSHs(sv_2mortal(FontInfo(aTHX_ gotEncoding, gotFoundary, gotAttrib,gotName)));
   PUTBACK;
   if ((count  = LangCallCallback(hook, G_EVAL | flags)))
    {
     SPAGAIN;
     result = POPs;
     PUTBACK;
    }
   if (SvTRUE(ERRSV))
    {
     warn("%"SVf,ERRSV);
     sv_setsv(hook,&PL_sv_undef);
    }
   else
    {
     if (result && SvOK(result))
      {
       if (SvPOK(result) && !SvCUR(result))
        {
         suggested = (unsigned int) -2;
        }
       else
        suggested = (unsigned int) SvIV(result);
      }
     else
      {
       suggested = (unsigned int) -1;
      }
    }
   FREETMPS;
   LEAVE;
  }
 /* Placeholder for a hook */
 if (0 && !suggested)
  LangDebug("%08x for U+%04x %s from %s\n",suggested,ch, gotEncoding, gotName);
 return suggested;
}


MODULE = Tk	PACKAGE = Tk::FontRankInfo	PREFIX = FontInfo_
PROTOTYPES: ENABLE

SV *
FontInfo_encoding(LangFontInfo *p)

SV *
FontInfo_foundary(LangFontInfo *p)

SV *
FontInfo_Xname(LangFontInfo *p)

SV *
FontInfo_family(LangFontInfo *p)

int
FontInfo_size(LangFontInfo *p)

Boolean
FontInfo_bold(LangFontInfo *p)

Boolean
FontInfo_italic(LangFontInfo *p)


MODULE = Tk	PACKAGE = Tk	PREFIX = Const_
PROTOTYPES: ENABLE

char *
Const_BLACK()

char *
Const_WHITE()

char *
Const_NORMAL_BG()

char *
Const_ACTIVE_BG()

char *
Const_SELECT_BG()

char *
Const_SELECT_FG()

char *
Const_TROUGH()

char *
Const_INDICATOR()

char *
Const_DISABLED()


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	PACKAGE = Tk::Xrm	PREFIX = Xrm_
PROTOTYPES: DISABLE

void
Xrm_import(class,...)
char *	class

MODULE = Tk	PACKAGE = XEvent	PREFIX = XEvent_

void
XEvent_Info(obj,s)
EventAndKeySym *	obj
char *	s
CODE:
{
 ST(0) = XEvent_Info(obj,s);
}

void
XEvent_DESTROY(obj)
SV *	obj

MODULE = Tk	PACKAGE = Tk::MainWindow	PREFIX = pTk_

PROTOTYPES: DISABLE

void
pTk_Synchronize(win,flag = True)
Tk_Window	win
int		flag

int
Count(self)
SV *	self
CODE:
 {
  ST(0) = sv_2mortal(newSViv(Tk_GetNumMainWindows()));
 }


MODULE = Tk	PACKAGE = Tk::Callback	PREFIX = Callback_

void
new(package,what)
char *	package
SV *	what
CODE:
 {
  ST(0) = sv_2mortal(sv_bless(LangMakeCallback(what),gv_stashpv(package, TRUE)));
 }

void
Substitute(cb,src,dst)
SV *	cb
SV *	src
SV *	dst
CODE:
{
 if (!SvROK(cb))
  croak("callback is not a reference");
 cb = SvRV(cb);
 if (!SvROK(src))
  croak("src is not a reference");
 src = SvRV(src);
 if (!SvROK(dst))
  croak("dst is not a reference");

 if (SvTYPE(cb) == SVt_PVAV)
  {
   AV *av = newAV();
   int n = av_len((AV *) cb);
   int i;
   int match = 0;
   for (i=0; i <= n; i++)
    {
     SV **svp = av_fetch((AV *) cb,i,0);
     if (svp)
      {
       if (SvROK(*svp) && SvRV(*svp) == src)
        {
         av_store(av, i, SvREFCNT_inc(dst));
         match++;
        }
       else
        {
         av_store(av, i, SvREFCNT_inc(*svp));
        }
      }
    }
   if (match)
    {
     ST(0) = sv_2mortal(sv_bless(MakeReference((SV *) av),SvSTASH(cb)));
    }
   else
    {
     SvREFCNT_dec(av);
    }
  }
}

MODULE = Tk	PACKAGE = Tk	PREFIX = Tk

int
NeedPreload()

void
Preload(filename)
    char *		filename
    CODE:
#ifdef NEED_PRELOAD
    void *h = dlopen(filename, RTLD_LAZY|RTLD_GLOBAL) ;
    if (!h)
     croak("Cannot load %s",filename);
#endif

double
timeofday()
CODE:
{
 Tcl_Time t;
 Tcl_GetTime(&t);
 RETVAL = t.sec + (double) t.usec/1e6;
}
OUTPUT:
 RETVAL

TkWindow *
TkGetFocusWin(win)
TkWindow *	win

void
TkGetPointerCoords(win)
Tk_Window	win
PPCODE:
 {
  int x, y;
  TkGetPointerCoords(win, &x, &y);
  PUSHs(sv_2mortal(newSViv(x)));
  PUSHs(sv_2mortal(newSViv(y)));
 }

MODULE = Tk	PACKAGE = Tk	PREFIX = Tk_

void
Tk_CheckHash(widget)
SV *	widget
CODE:
 {
  Tk_CheckHash(widget,NULL);
 }

void
Debug(widget,string)
SV *	widget;
char *	string
CODE:
 {
  LangDumpVec(string,1,&SvRV(widget));
 }

void
WidgetMethod(widget,name,...)
SV *	widget;
SV *	name;
CODE:
 {
  Lang_CmdInfo *info = WindowCommand(widget, NULL, 1);
  TKXSRETURN(Call_Tk(info, items, &ST(0)));
 }

void
OldEnterMethods(package,file,...)
char *	package
char *	file
CODE:
 {int i;
  char buf[80];  /* FIXME Size of buffer */
  for (i=2; i < items; i++)
   {
    STRLEN len;
    SV *method = newSVsv(ST(i));
    CV *cv;
    sprintf(buf, "%s::%s", package, SvPV(method,len));
    cv = newXS(buf, XStoWidget, file);
    CvXSUBANY(cv).any_ptr = method;
   }
 }

IV
GetFILE(arg,w)
SV *	arg
int	w
CODE:
 {
  IO *io = sv_2io(arg);
  RETVAL = -1;
  if (io)
   {
    PerlIO *f = (w) ? IoOFP(io) : IoIFP(io);
    if (f)
     {
      RETVAL = PerlIO_fileno(f);
     }
   }
 }
OUTPUT:
 RETVAL

MODULE = Tk	PACKAGE = Tk::Widget	PREFIX = pTk_

IV
PointToWindow(tkwin,x,y,parent = None)
Tk_Window	tkwin
int		x
int		y
IV		parent

void
WindowXY(tkwin,src = None, dst = None)
Tk_Window	tkwin
IV		src
IV		dst
PPCODE:
{
 Display *dpy = Tk_Display(tkwin);
 Window root = RootWindowOfScreen(Tk_Screen(tkwin));
 int x = 0;
 int y = 0;
 if (src == None)
  src = Tk_WindowId(tkwin);
 if (dst == None)
  dst = root;
 XTranslateCoordinates(dpy, src, dst, 0, 0, &x, &y, &root);
 XPUSHs(sv_2mortal(newSViv(x)));
 XPUSHs(sv_2mortal(newSViv(y)));
}

void
pTk_DefineBitmap (tkwin, name, width, height, source)
Tk_Window	tkwin;
char *	name;
int	width;
int	height;
SV *	source;
CODE:
{
 Tcl_Interp *interp;
 if (TkToWidget(tkwin,&interp) && interp)
  {STRLEN len;
   SV * source_copy = newSVsv(source); /* technically this is leaking a SV, but there's no DeleteBitmap or so anyway */
   unsigned char *data = (unsigned char *) SvPV(source_copy, len);
   STRLEN byte_line = (width + 7) / 8;
   if (len == height * byte_line)
    {
     Tcl_ResetResult(interp);
     if (Tk_DefineBitmap(interp, Tk_GetUid(name), data, width, height) != TCL_OK)
      croak("%s",Tcl_GetStringResult(interp));
    }
   else
    {
     croak("Data wrong size for %dx%d bitmap",width,height);
    }
  }
 else
  {
   croak("Invalid widget");
  }
}

void
pTk_GetBitmap(tkwin, name)
Tk_Window	tkwin;
char *	name;
PPCODE:
 {
  Tcl_Interp *interp;
  Pixmap pixmap;
  if (TkToWidget(tkwin,&interp) && interp)
   {
    pixmap = Tk_GetBitmap(interp, tkwin, name);
    if (pixmap == None)
     PUSHs(&PL_sv_undef);
    else
     PUSHs(sv_2mortal(newSViv((IV)pixmap)));
   }
  else
   {
    croak("Invalid widget");
   }
 }


MODULE = Tk	PACKAGE = Tk::Widget	PREFIX = Tk_

void
UnmanageGeometry(win)
Tk_Window	win
CODE:
 {
  Tk_ManageGeometry(win, NULL, NULL);
 }

void
DisableButtonEvents(win)
Tk_Window	win
CODE:
 {
  Tk_Attributes(win)->event_mask
    &= ~(ButtonPressMask | ButtonReleaseMask | ButtonMotionMask);
  Tk_ChangeWindowAttributes(win, CWEventMask, Tk_Attributes(win));
 }

void
MakeAtom(win,...)
Tk_Window	win
CODE:
 {
  int i;
  for (i=1; i < items; i++)
   {
    SV *sv = ST(i);
    Atom a = None;
    const char *name = Nullch;
    if (SvGMAGICAL(sv))
     mg_get(sv);
    if (SvIOK(sv) && !SvPOK(sv))
     {
      a = (Atom) SvIVX(sv);
      if (a != None)
       {
        sv_upgrade(sv,SVt_PVIV);
        name = Tk_GetAtomName(win,a);
        sv_setpvn(sv,name,strlen(name));
        SvIVX(sv) = (IV) a;
        SvIOK_on(sv);
       }
     }
    else if (SvPOK(sv) && !SvIOK(sv))
     {
      name = SvPVX(sv);
      if (name && *name)
       {
        sv_upgrade(sv,SVt_PVIV);
        a = Tk_InternAtom(win,name);
        SvIVX(sv) = (IV) a;
        SvIOK_on(sv);
       }
     }
    else if (SvPOK(sv) && SvIOK(sv))
     {
      name = SvPVX(sv);
      a    = (Atom) SvIVX(sv);
      if (a != Tk_InternAtom(win,name))
       {
        croak("%s/%ld is not a valid atom for %s\n",name,a,Tk_PathName(win));
       }
     }
   }
 }


int
SendClientMessage(win,type,xid,format,data)
Tk_Window	win
char *		type
IV		xid
IV		format
SV *		data
CODE:
 {
  XClientMessageEvent cM;
  STRLEN len;
  char *s = SvPV(data,len);
  if (len > sizeof(cM.data))
   len = sizeof(cM.data);
  cM.type = ClientMessage;
  cM.serial  = 0;
  cM.send_event = 0;
  cM.display = Tk_Display(win);
  cM.window = xid;
  cM.message_type = Tk_InternAtom(win,type);
  cM.format = format;
  memmove(cM.data.b,s,len);
  if ((RETVAL = XSendEvent(cM.display, cM.window, False, NoEventMask, (XEvent *) & cM)))
   {
    /* XSync may be overkill - but need XFlush ... */
    XSync(cM.display, False);
   }
  else
   {
    croak("XSendEvent failed");
   }
 }
OUTPUT:
  RETVAL

#if 0
int
SendNetWMClientMessage(win,type,xid,format,data)
Tk_Window	win
char *		type
IV		xid
IV		format
SV *		data
CODE:
 {
/*
   It's not clear if this function should go into Perl/Tk. This
   function would make is possible to send some netwm messages, for
   example NET_WM_STATE_ABOVE:

   my($wrapper) = $toplevel->wrapper;
   my $_NET_WM_STATE_ADD = 1;
   my $data = pack("LLLLL", $_NET_WM_STATE_ADD, $w->InternAtom('_NET_WM_STATE_ABOVE'), 0, 0, 0);
   $w->SendNetWMClientMessage('_NET_WM_STATE', $wrapper, 32, $data);
*/
  XClientMessageEvent cM;
  Window root = RootWindowOfScreen(Tk_Screen(win));
  STRLEN len;
  char *s = SvPV(data,len);
  if (len > sizeof(cM.data))
   len = sizeof(cM.data);
  cM.type = ClientMessage;
  cM.serial  = 0;
  cM.send_event = 0;
  cM.display = Tk_Display(win);
  cM.window = xid;
  cM.message_type = Tk_InternAtom(win,type);
  cM.format = format;
  memmove(cM.data.b,s,len);
  if ((RETVAL = XSendEvent(cM.display, root, False, SubstructureNotifyMask|SubstructureRedirectMask, (XEvent *) & cM)))
   {
    /* XSync may be overkill - but need XFlush ... */
    XSync(cM.display, False);
   }
  else
   {
    croak("XSendEvent failed");
   }
 }
OUTPUT:
  RETVAL

#endif

void
XSync(win,flush)
Tk_Window	win
int		flush
CODE:
 {
  XSync(Tk_Display(win),flush);
 }

void
Tk_GetRootCoords(win)
Tk_Window	win
PPCODE:
 {
  int x, y;
  Tk_GetRootCoords(win, &x, &y);
  PUSHs(sv_2mortal(newSViv(x)));
  PUSHs(sv_2mortal(newSViv(y)));
 }

void
Tk_GetVRootGeometry(win)
Tk_Window	win
PPCODE:
 {
  int x, y;
  int width, height;
  Tk_GetVRootGeometry(win, &x, &y, &width, &height);
  PUSHs(sv_2mortal(newSViv(x)));
  PUSHs(sv_2mortal(newSViv(y)));
  PUSHs(sv_2mortal(newSViv(width)));
  PUSHs(sv_2mortal(newSViv(height)));
 }

Colormap
Tk_Colormap(win)
Tk_Window	win

Display *
Tk_Display(win)
Tk_Window	win

int
Tk_ScreenNumber(win)
Tk_Window	win

Screen *
Tk_Screen(win)
Tk_Window	win

Visual *
Tk_Visual(win)
Tk_Window	win

Window
Tk_WindowId(win)
Tk_Window	win

int
Tk_X(win)
Tk_Window	win

int
Tk_Y(win)
Tk_Window	win

int
Tk_ReqWidth(win)
Tk_Window	win

int
Tk_ReqHeight(win)
Tk_Window	win

int
Tk_Width(win)
Tk_Window	win

int
Tk_Height(win)
Tk_Window	win

int
Tk_IsMapped(win)
Tk_Window	win

int
Tk_Depth(win)
Tk_Window	win

int
Tk_InternalBorderWidth(win)
Tk_Window	win

int
Tk_IsTopLevel(win)
Tk_Window	win

const char *
Tk_Name(win)
Tk_Window	win

char *
Tk_PathName(win)
Tk_Window	win

const char *
Tk_Class(win)
Tk_Window	win

void
Tk_MakeWindowExist(win)
Tk_Window	win

void
Tk_SetClass(win,class)
Tk_Window	win
char *		class

void
Tk_MoveWindow(win,x,y)
Tk_Window	win
int		x
int		y

void
Tk_XRaiseWindow(win)
Tk_Window	win

void
Tk_MoveToplevelWindow(win,x,y)
Tk_Window	win
int		x
int		y
CODE:
 { 
  TkWindow *winPtr = (TkWindow *) win;
  if (!(winPtr->flags & TK_TOP_LEVEL))
   {
    croak("Tk_MoveToplevelWindow called with non-toplevel window");
   }
  Tk_MoveToplevelWindow(win,x,y);
 }

void
Tk_MoveResizeWindow(win,x,y,width,height)
Tk_Window	win
int		x
int		y
int		width
int		height

void
Tk_ResizeWindow(win,width,height)
Tk_Window	win
int		width
int		height

void
Tk_GeometryRequest(win,width,height)
Tk_Window	win
int		width
int		height

void
Tk_MaintainGeometry(slave,master,x,y,width,height)
Tk_Window	slave
Tk_Window	master
int		x
int		y
int		width
int		height

void
Tk_SetGrid(win,reqWidth,reqHeight,gridWidth,gridHeight)
Tk_Window	win
int		reqWidth
int		reqHeight
int		gridWidth
int		gridHeight


void
Tk_UnmaintainGeometry(slave,master)
Tk_Window	slave
Tk_Window	master

void
Tk_MapWindow(win)
Tk_Window	win

void
Tk_UnmapWindow(win)
Tk_Window	win

void
Tk_UnsetGrid(win)
Tk_Window	win

void
Tk_AddOption(win,name,value,priority)
Tk_Window	win
char *	name
char *	value
int	priority

const char *
Tk_GetAtomName(win,atom)
Tk_Window	win
Atom		atom

void
Tk_ClearSelection(win,selection)
Tk_Window	win
Atom		selection

const char *
Tk_DisplayName(win)
Tk_Window	win

const char *
Tk_GetOption(win,name,class)
Tk_Window	win
char *	name
char *	class

IV
Tk_InternAtom(win,name)
Tk_Window	win
char *		name

void
Tk_Ungrab(win)
Tk_Window	win

const char *
Tk_SetAppName(win,name)
Tk_Window	win
char *		name

int
IsWidget(win)
SV *	win
CODE:
 {
  if (!SvROK(win) || SvTYPE(SvRV(win)) != SVt_PVHV)
   RETVAL = 0;
  else
   {
    Lang_CmdInfo *info = WindowCommand(win,NULL,0);
    RETVAL = (info && info->tkwin);
   }
 }
OUTPUT:
 RETVAL

int
Tk_Grab(win,global)
SV *	win
int	global
CODE:
 {
  Lang_CmdInfo *info = WindowCommand(win,NULL,3);
  RETVAL = Tk_Grab(info->interp,info->tkwin,global);
 }

SV *
Widget(win,path)
SV *	win
char *	path
CODE:
 {
  Lang_CmdInfo *info = WindowCommand(win,NULL,1);
  ST(0) = sv_mortalcopy(WidgetRef(info->interp,path));
 }

SV *
_object(win,name)
SV *	win
char *	name
CODE:
 {
  Lang_CmdInfo *info = WindowCommand(win,NULL,1);
  ST(0) = sv_mortalcopy(ObjectRef(info->interp,name));
 }

Tk_Window
Containing(win,X,Y)
Tk_Window	win
int	X
int	Y
CODE:
 {
  RETVAL = Tk_CoordsToWindow(X, Y, win);
 }
OUTPUT:
  RETVAL

Tk_Window
Tk_Parent(win)
Tk_Window	win

SV *
MainWindow(interp)
Tcl_Interp *	interp
CODE:
 {
  RETVAL = SvREFCNT_inc(WidgetRef(interp,"."));
 }
OUTPUT:
 RETVAL

MODULE = Tk	PACKAGE = Tk	PREFIX = Tcl_

void
Tcl_AddErrorInfo(interp,message)
Tcl_Interp *	interp
char *		message

void
Tcl_BackgroundError(interp)
Tcl_Interp *	interp

void
Fail(interp,message)
Tcl_Interp *	interp
char *		message
CODE:
 {
  Tcl_SetResult(interp,message,TCL_VOLATILE);
  Tcl_BackgroundError(interp);
 }

int
Tcl_DoOneEvent(...)
CODE:
 {
  int flags = 0;
  if (items)
   {int i;
    for (i=0; i < items; i++)
     {
      SV *sv = ST(i);
      if (SvIOK(sv) || looks_like_number(sv))
       flags |= SvIV(sv);
      else if (!sv_isobject(sv))
       {STRLEN l;
        char *s = SvPV(sv,l);
        if (strcmp(s,BASEEXT))
         {
          /* string to integer lookup here */
          croak("Usage [$object->]DoOneEvent([flags]) got '%s'\n",s);
         }
       }
     }
   }
  RETVAL = Tcl_DoOneEvent(flags);
 }
OUTPUT:
  RETVAL

MODULE = Tk	PACKAGE = Tk::Font	PREFIX = Font_

void
Font_DESTROY(sv)
SV *	sv

MODULE = Tk	PACKAGE = Tk::Font	PREFIX = Tk_

int
Tk_PostscriptFontName(tkfont,name)
Tk_Font	tkfont
SV *	&name
OUTPUT:
	name

MODULE = Tk	PACKAGE = Tk	PREFIX = Lang_

SV *
Lang_SystemEncoding()

MODULE = Tk	PACKAGE = Tk	PREFIX = Tk_



void
abort()

int
Tk_tainting()

int
Tk_tainted(sv = NULL)
SV *	sv

void
DebugHook(arg)
SV *	arg

void
ClearErrorInfo(win)
SV *	win

BOOT:
 {
  Boot_Glue(aTHX);
#ifdef WIN32
  /* Force inclusion of DllMain() */
  TkWin32DllPresent();
  TkWinXInit(Tk_GetHINSTANCE());
#endif
  /* We need to call Tcl_Preserve() on something so
     its exit handler is first on the list, and so last
     to be called
   */
  Tcl_Preserve((ClientData) cv);
  Tcl_Release((ClientData) cv);
}