int ColorModel::command(int argc, const char*const* argv)
{
Tcl& tcl = Tcl::instance();
if (argc == 2) {
if (strcmp(argv[1], "alloc-colors") == 0) {
tcl.result(allocate() < 0 ? "0" : "1");
return (TCL_OK);
}
if (strcmp(argv[1], "free-colors") == 0) {
free_colors();
return (TCL_OK);
}
} else if (argc == 3) {
if (strcmp(argv[1], "visual") == 0) {
Tk_Window tk = Tk_NameToWindow(tcl.interp(),
(char*)argv[2],
tcl.tkmain());
setvisual(Tk_Visual(tk), Tk_Colormap(tk),
Tk_Depth(tk));
return (TCL_OK);
}
if (strcmp(argv[1], "gamma") == 0) {
double v = atof(argv[2]);
if (v < 0)
tcl.result("0");
gamma_ = v;
tcl.result("1");
return (TCL_OK);
}
}
return (TclObject::command(argc, argv));
}
bool
ParadynTkGUI::TryFirstCallGraphWindow( void )
{
if (haveSeenFirstCallGraphWindow)
return true;
Tk_Window topLevelTkWindow = Tk_MainWindow( interp );
Tk_Window theTkWindow = Tk_NameToWindow(interp,".callGraph.nontop.main.all",
topLevelTkWindow);
assert(theTkWindow);
if (Tk_WindowId(theTkWindow) == 0)
return false; // sigh...still invalid (that's why this routine is needed)
theCallGraphPrograms =
new callGraphs(".callGraph.titlearea.left.menu.mbar.program.m",
".callGraph.nontop.main.bottsb",
".callGraph.nontop.main.leftsb",
".callGraph.nontop.labelarea.current",
".callGraph.nontop.currprogramarea.label2",
interp, theTkWindow);
assert(theCallGraphPrograms);
initiateCallGraphRedraw(interp, true);
haveSeenFirstCallGraphWindow = true;
return true;
}
bool
ParadynTkGUI::TryFirstWhereAxisWindow( void )
{
if (haveSeenFirstWhereAxisWindow)
return true;
Tk_Window topLevelTkWindow = Tk_MainWindow( interp );
Tk_Window theTkWindow = Tk_NameToWindow(interp, ".whereAxis.nontop.main.all",
topLevelTkWindow);
assert(theTkWindow);
if (Tk_WindowId(theTkWindow) == 0)
return false; // sigh...still invalid (that's why this routine is needed)
haveSeenFirstWhereAxisWindow = true;
theAbstractions = new abstractions("",
".whereAxis.top.mbar.nav.m",
".whereAxis.nontop.main.bottsb",
".whereAxis.nontop.main.leftsb",
".whereAxis.nontop.find.entry",
interp, theTkWindow);
assert(theAbstractions);
return true;
}
int
Blt_GetWindowFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Window *windowPtr)
{
char *string;
string = Tcl_GetString(objPtr);
if (string[0] == '.') {
Tk_Window tkwin;
tkwin = Tk_NameToWindow(interp, string, Tk_MainWindow(interp));
if (tkwin == NULL) {
return TCL_ERROR;
}
if (Tk_WindowId(tkwin) == None) {
Tk_MakeWindowExist(tkwin);
}
*windowPtr = (Tk_IsTopLevel(tkwin)) ? Blt_GetWindowId(tkwin) :
Tk_WindowId(tkwin);
} else if (strcmp(string, "root") == 0) {
*windowPtr = Tk_RootWindow(Tk_MainWindow(interp));
} else {
static TkWinWindow tkWinWindow;
int id;
if (Tcl_GetIntFromObj(interp, objPtr, &id) != TCL_OK) {
return TCL_ERROR;
}
tkWinWindow.handle = (HWND)id;
tkWinWindow.winPtr = NULL;
tkWinWindow.type = TWD_WINDOW;
*windowPtr = (Window)&tkWinWindow;
}
return TCL_OK;
}
static PyObject *
name_to_window(PyObject * self, PyObject * args)
{
PyObject * app_or_interpaddr;
Tcl_Interp * interp;
Tk_Window tkwin;
char * name;
if (!PyArg_ParseTuple(args, "sO", &name, &app_or_interpaddr))
return NULL;
if (PyInt_Check(app_or_interpaddr))
{
interp = (Tcl_Interp*)PyInt_AsLong(app_or_interpaddr);
}
else
{
interp = ((TkappObject*)app_or_interpaddr)->interp;
}
tkwin = Tk_NameToWindow(interp, name, (ClientData)Tk_MainWindow(interp));
if (!tkwin)
{
PyErr_SetString(PyExc_ValueError, Tcl_GetStringResult(interp));
return NULL;
}
return TkWin_FromTkWindow(interp, tkwin);
}
/*
** zWin is the name of a child widget that is used to implement an
** input element. Query Tk for information about this widget (such
** as its size) and put that information in the pElem structure
** that represents the input.
*/
static void SizeAndLink(HtmlWidget *htmlPtr, char *zWin, HtmlElement *pElem){
pElem->input.tkwin = Tk_NameToWindow(htmlPtr->interp, zWin, htmlPtr->clipwin);
if( pElem->input.tkwin==0 ){
Tcl_ResetResult(htmlPtr->interp);
EmptyInput(pElem);
}else if( pElem->input.type==INPUT_TYPE_Hidden ){
pElem->input.w = 0;
pElem->input.h = 0;
pElem->base.flags &= !HTML_Visible;
pElem->base.style.flags |= STY_Invisible;
}else{
pElem->input.w = Tk_ReqWidth(pElem->input.tkwin);
pElem->input.h = Tk_ReqHeight(pElem->input.tkwin);
pElem->base.flags |= HTML_Visible;
pElem->input.htmlPtr = htmlPtr;
Tk_ManageGeometry(pElem->input.tkwin, &htmlGeomType, pElem);
Tk_CreateEventHandler(pElem->input.tkwin, StructureNotifyMask,
HtmlInputEventProc, pElem);
}
pElem->input.pNext = 0;
if( htmlPtr->firstInput==0 ){
htmlPtr->firstInput = pElem;
}else{
htmlPtr->lastInput->input.pNext = pElem;
}
htmlPtr->lastInput = pElem;
pElem->input.sized = 1;
}
/***************************************************************************
* test function
***************************************************************************/
int test() {
int code;
Tcl_Interp *interp;
interp = Tcl_CreateInterp();
Tk_Window tkwin;
tkwin=Tk_CreateMainWindow(interp,"unix:0.0","appName","className");
Tk_Window button;
button=Tk_CreateWindowFromPath(interp,tkwin,".appName","unix:0.0");
Tk_Window what;
what = Tk_NameToWindow(interp,".appName",tkwin);
what = Tk_NameToWindow(interp,".",tkwin);
Tk_MainLoop();
Tk_DestroyWindow(tkwin);
}
bool
ParadynTkGUI::TryFirstShgWindow( void )
{
// called in shgTcl.C
// like whereAxis's and barChart's techniques...
// Tk_WindowId() returns 0 until the tk window has been mapped for the first
// time, which takes a surprisingly long time. Therefore, this hack is needed.
if (haveSeenFirstShgWindow)
return true;
Tk_Window topLevelTkWindow = Tk_MainWindow( interp );
Tk_Window theTkWindow = Tk_NameToWindow(interp, ".shg.nontop.main.all",
topLevelTkWindow);
assert(theTkWindow);
if (Tk_WindowId(theTkWindow) == 0)
return false; // this happens in practice...that's why this routine is needed
haveSeenFirstShgWindow = true;
/* *********************************************************** */
// Why don't we construct "theShgPhases" earlier (perhaps at startup)?
// Why do we wait until the shg window has been opened?
// Because the constructor requires window names as arguments.
theShgPhases = new shgPhases(".shg.titlearea.left.menu.mbar.phase.m",
".shg.nontop.main.bottsb",
".shg.nontop.main.leftsb",
".shg.nontop.labelarea.current",
".shg.nontop.textarea.text",
".shg.nontop.buttonarea.left.search",
".shg.nontop.buttonarea.middle.pause",
".shg.nontop.currphasearea.label2",
interp, theTkWindow);
assert(theShgPhases);
// Now is as good a time as any to define the global phase.
const int GlobalPhaseId = 0; // a hardcoded constant
(void)theShgPhases->defineNewSearch(GlobalPhaseId,
"Global Phase");
// Also add the "current phase", if applicable.
// We check "latest_detected_new_phase_id", set by ui_newPhaseDetected (UImain.C)
if (latest_detected_new_phase_id >= 0) {
theShgPhases->defineNewSearch(latest_detected_new_phase_id,
latest_detected_new_phase_name);
}
initiateShgRedraw(interp, true);
return true;
}
int draw_image (ClientData cd, Tcl_Interp *interp, int argc, char **argv) {
Tk_Window tkwin;
Display *display;
Window window;
GC gc;
Tk_Window interpWin;
interpWin=(Tk_Window) cd;
tkwin=Tk_NameToWindow (interp,".c",interpWin);
display=Tk_Display (tkwin);
window=Tk_WindowId (tkwin);
gc=Tk_GetGC (tkwin,0,NULL);
if (ximage!=NULL) {
XPutImage (display,window,gc,ximage,0,0,0,0,RESX,RESY);
}
return 0;
}
void tcltk_set_graph_mode (int mode, void (*drawimage)()) {
if (Tcl_EvalFile (interp,"rbd.tcl")==TCL_ERROR) {
printf ("rbd.tcl script error <%s>\n",interp->result);
exit (1);
}
canvas=Tk_NameToWindow (interp,".c",window);
if (canvas==NULL) {
printf ("Error: <%s>\n",interp->result);
}
gen_image=drawimage;
Tcl_CreateCommand
(interp,"drawimage",draw_image,(ClientData)window,NULL);
Tk_CreateEventHandler
(canvas,ExposureMask,(Tk_EventProc *)expose_handler,(ClientData)canvas);
Tk_MainLoop ();
}
/* $pw insert $index $slave ?-option value ...?
* Insert new slave, or move existing one.
*/
static int PanedInsertCommand(
void *recordPtr, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[])
{
Paned *pw = recordPtr;
int nSlaves = Ttk_NumberSlaves(pw->paned.mgr);
int srcIndex, destIndex;
Tk_Window slaveWindow;
if (objc < 4) {
Tcl_WrongNumArgs(interp, 2,objv, "index slave ?-option value ...?");
return TCL_ERROR;
}
slaveWindow = Tk_NameToWindow(
interp, Tcl_GetString(objv[3]), pw->core.tkwin);
if (!slaveWindow) {
return TCL_ERROR;
}
if (!strcmp(Tcl_GetString(objv[2]), "end")) {
destIndex = Ttk_NumberSlaves(pw->paned.mgr);
} else if (TCL_OK != Ttk_GetSlaveIndexFromObj(
interp,pw->paned.mgr,objv[2],&destIndex))
{
return TCL_ERROR;
}
srcIndex = Ttk_SlaveIndex(pw->paned.mgr, slaveWindow);
if (srcIndex < 0) { /* New slave: */
return AddPane(interp, pw, destIndex, slaveWindow, objc-4, objv+4);
} /* else -- move existing slave: */
if (destIndex >= nSlaves)
destIndex = nSlaves - 1;
Ttk_ReorderSlave(pw->paned.mgr, srcIndex, destIndex);
return objc == 4 ? TCL_OK :
ConfigurePane(interp, pw,
Ttk_SlaveData(pw->paned.mgr, destIndex),
Ttk_SlaveWindow(pw->paned.mgr, destIndex),
objc-4,objv+4);
}
int Ttk_GetSlaveIndexFromObj(
Tcl_Interp *interp, Ttk_Manager *mgr, Tcl_Obj *objPtr, int *indexPtr)
{
const char *string = Tcl_GetString(objPtr);
int slaveIndex = 0;
Tk_Window tkwin;
/* Try interpreting as an integer first:
*/
if (Tcl_GetIntFromObj(NULL, objPtr, &slaveIndex) == TCL_OK) {
if (slaveIndex < 0 || slaveIndex >= mgr->nSlaves) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp,
"Slave index ", Tcl_GetString(objPtr), " out of bounds",
NULL);
return TCL_ERROR;
}
*indexPtr = slaveIndex;
return TCL_OK;
}
/* Try interpreting as a slave window name;
*/
if ( (*string == '.')
&& (tkwin = Tk_NameToWindow(interp, string, mgr->masterWindow)))
{
slaveIndex = Ttk_SlaveIndex(mgr, tkwin);
if (slaveIndex < 0) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp,
string, " is not managed by ", Tk_PathName(mgr->masterWindow),
NULL);
return TCL_ERROR;
}
*indexPtr = slaveIndex;
return TCL_OK;
}
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "Invalid slave specification ", string, NULL);
return TCL_ERROR;
}
/* $pw add window [ options ... ]
*/
static int PanedAddCommand(
void *recordPtr, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[])
{
Paned *pw = recordPtr;
Tk_Window slaveWindow;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 2, objv, "window");
return TCL_ERROR;
}
slaveWindow = Tk_NameToWindow(
interp, Tcl_GetString(objv[2]), pw->core.tkwin);
if (!slaveWindow) {
return TCL_ERROR;
}
return AddPane(interp, pw, Ttk_NumberSlaves(pw->paned.mgr), slaveWindow,
objc - 3, objv + 3);
}
int
TkGetWindowFromObj(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tk_Window tkwin, /* A token to get the main window from. */
Tcl_Obj *objPtr, /* The object from which to get window. */
Tk_Window *windowPtr) /* Place to store resulting window. */
{
TkMainInfo *mainPtr = ((TkWindow *) tkwin)->mainPtr;
register WindowRep *winPtr;
int result;
result = Tcl_ConvertToType(interp, objPtr, &windowObjType);
if (result != TCL_OK) {
return result;
}
winPtr = (WindowRep *) objPtr->internalRep.twoPtrValue.ptr1;
if (winPtr->tkwin == NULL
|| winPtr->mainPtr == NULL
|| winPtr->mainPtr != mainPtr
|| winPtr->epoch != mainPtr->deletionEpoch)
{
/*
* Cache is invalid.
*/
winPtr->tkwin = Tk_NameToWindow(interp,
Tcl_GetString(objPtr), tkwin);
if (winPtr->tkwin == NULL) {
/* ASSERT: Tk_NameToWindow has left error message in interp */
return TCL_ERROR;
}
winPtr->mainPtr = mainPtr;
winPtr->epoch = mainPtr ? mainPtr->deletionEpoch : 0;
}
*windowPtr = winPtr->tkwin;
return TCL_OK;
}
int Configure (ClientData, Tcl_Interp *interp,
int, char **argv)
{
if (view.m_started)
{
Tk_Window win;
Tcl_Eval(interp, "set f $CVLkDemo::curframe");
win = Tk_NameToWindow(interp, interp->result,
Tk_MainWindow(interp));
Tk_MapWindow(win);
int w = Tk_Width(win);
int h = Tk_Height(win);
cvcamSetProperty(0, CVCAM_RNDWIDTH, (void*)&w);
cvcamSetProperty(0, CVCAM_RNDHEIGHT, (void*)&h);
view.SetSize(w,h);
}
return TCL_OK;
}
/* Implement the Windows version of the ide_get_directory command. */
static int
get_directory_command (ClientData cd, Tcl_Interp *interp, int argc,
char **argv)
{
BROWSEINFO bi;
char buf[MAX_PATH + 1];
Tk_Window parent;
int i, oldMode;
LPITEMIDLIST idlist;
char *p;
int atts;
Tcl_DString tempBuffPtr;
#if (TCL_MAJOR_VERSION >= 8) && (TCL_MINOR_VERSION >= 1)
Tcl_DString titleDString;
Tcl_DString initialDirDString;
Tcl_DString resultDString;
Tcl_DStringInit(&titleDString);
Tcl_DStringInit(&initialDirDString);
#endif
Tcl_DStringInit(&tempBuffPtr);
bi.hwndOwner = NULL;
bi.pidlRoot = NULL;
bi.pszDisplayName = buf;
bi.lpszTitle = NULL;
bi.ulFlags = 0;
bi.lpfn = NULL;
bi.lParam = 0;
bi.iImage = 0;
parent = Tk_MainWindow (interp);
for (i = 1; i < argc; i += 2)
{
int v;
int len;
v = i + 1;
len = strlen (argv[i]);
if (strncmp (argv[i], "-parent", len) == 0)
{
if (v == argc)
goto arg_missing;
parent = Tk_NameToWindow (interp, argv[v],
Tk_MainWindow (interp));
if (parent == NULL)
return TCL_ERROR;
}
else if (strncmp (argv[i], "-title", len) == 0)
{
if (v == argc)
goto arg_missing;
#if (TCL_MAJOR_VERSION >= 8) && (TCL_MINOR_VERSION >= 1)
Tcl_UtfToExternalDString(NULL, argv[v], -1, &titleDString);
bi.lpszTitle = Tcl_DStringValue(&titleDString);
#else
bi.lpszTitle = argv[v];
#endif
}
else if (strncmp (argv[i], "-initialdir", len) == 0)
{
if (v == argc)
goto arg_missing;
/* bi.lParam will be passed to the callback function.(save the need for globals)*/
bi.lParam = (LPARAM) Tcl_TranslateFileName(interp, argv[v], &tempBuffPtr);
#if (TCL_MAJOR_VERSION >= 8) && (TCL_MINOR_VERSION >= 1)
Tcl_UtfToExternalDString(NULL, (char *) bi.lParam, -1, &initialDirDString);
bi.lParam = (LPARAM) Tcl_DStringValue(&initialDirDString);
#endif
bi.lpfn = MyBrowseCallbackProc;
}
else
{
Tcl_AppendResult (interp, "unknown option \"", argv[i],
"\", must be -parent or -title", (char *) NULL);
return TCL_ERROR;
}
}
if (Tk_WindowId (parent) == None)
Tk_MakeWindowExist (parent);
bi.hwndOwner = Tk_GetHWND (Tk_WindowId (parent));
oldMode = Tcl_SetServiceMode(TCL_SERVICE_ALL);
idlist = SHBrowseForFolder (&bi);
Tcl_SetServiceMode(oldMode);
if (idlist == NULL)
{
/* User pressed the cancel button. */
return TCL_OK;
}
if (! SHGetPathFromIDList (idlist, buf))
{
Tcl_SetResult (interp, "could not get path for directory", TCL_STATIC);
return TCL_ERROR;
}
/* Ensure the directory exists. */
atts = GetFileAttributesA (buf);
if (atts == -1 || ! (atts & FILE_ATTRIBUTE_DIRECTORY))
{
Tcl_AppendResult (interp, "path \"", buf, "\" is not a directory",
(char *) NULL);
/* FIXME: free IDLIST. */
return TCL_ERROR;
}
/* FIXME: We are supposed to free IDLIST using the shell task
allocator, but cygwin32 doesn't define the required interfaces
yet. */
/* Normalize the path for Tcl. */
#if (TCL_MAJOR_VERSION >= 8) && (TCL_MINOR_VERSION >= 1)
Tcl_ExternalToUtfDString(NULL, buf, -1, &resultDString);
p = Tcl_DStringValue(&resultDString);
#else
p = buf;
#endif
for (; *p != '\0'; ++p)
if (*p == '\\')
*p = '/';
Tcl_ResetResult(interp);
#if (TCL_MAJOR_VERSION >= 8) && (TCL_MINOR_VERSION >= 1)
Tcl_SetResult(interp, Tcl_DStringValue(&resultDString), TCL_VOLATILE);
Tcl_DStringFree(&resultDString);
Tcl_DStringFree(&titleDString);
Tcl_DStringFree(&initialDirDString);
#else
Tcl_SetResult(interp, buf, TCL_VOLATILE);
#endif
Tcl_DStringFree(&tempBuffPtr);
return TCL_OK;
arg_missing:
Tcl_AppendResult(interp, "value for \"", argv[argc - 1], "\" missing",
NULL);
return TCL_ERROR;
}
/* ARGSUSED */
int
Tk_GrabObjCmd(
ClientData clientData, /* Main window associated with interpreter. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int globalGrab;
Tk_Window tkwin;
TkDisplay *dispPtr;
const char *arg;
int index;
int len;
static const char *const optionStrings[] = {
"current", "release", "set", "status", NULL
};
static const char *const flagStrings[] = {
"-global", NULL
};
enum options {
GRABCMD_CURRENT, GRABCMD_RELEASE, GRABCMD_SET, GRABCMD_STATUS
};
if (objc < 2) {
/*
* Can't use Tcl_WrongNumArgs here because we want the message to
* read:
* wrong # args: should be "cmd ?-global? window" or "cmd option
* ?arg ...?"
* We can fake it with Tcl_WrongNumArgs if we assume the command name
* is "grab", but if it has been aliased, the message will be
* incorrect.
*/
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "wrong # args: should be \"",
Tcl_GetString(objv[0]), " ?-global? window\" or \"",
Tcl_GetString(objv[0]), " option ?arg ...?\"", NULL);
return TCL_ERROR;
}
/*
* First check for a window name or "-global" as the first argument.
*/
arg = Tcl_GetStringFromObj(objv[1], &len);
if (arg[0] == '.') {
/* [grab window] */
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?-global? window");
return TCL_ERROR;
}
tkwin = Tk_NameToWindow(interp, arg, clientData);
if (tkwin == NULL) {
return TCL_ERROR;
}
return Tk_Grab(interp, tkwin, 0);
} else if (arg[0] == '-' && len > 1) {
if (Tcl_GetIndexFromObj(interp, objv[1], flagStrings, "option", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
/* [grab -global window] */
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "?-global? window");
return TCL_ERROR;
}
tkwin = Tk_NameToWindow(interp, Tcl_GetString(objv[2]), clientData);
if (tkwin == NULL) {
return TCL_ERROR;
}
return Tk_Grab(interp, tkwin, 1);
}
/*
* First argument is not a window name and not "-global", find out which
* option it is.
*/
if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum options) index) {
case GRABCMD_CURRENT:
/* [grab current ?window?] */
if (objc > 3) {
Tcl_WrongNumArgs(interp, 1, objv, "current ?window?");
return TCL_ERROR;
}
if (objc == 3) {
tkwin = Tk_NameToWindow(interp, Tcl_GetString(objv[2]),
clientData);
if (tkwin == NULL) {
return TCL_ERROR;
}
dispPtr = ((TkWindow *) tkwin)->dispPtr;
if (dispPtr->eventualGrabWinPtr != NULL) {
Tcl_SetResult(interp, dispPtr->eventualGrabWinPtr->pathName,
TCL_STATIC);
}
} else {
for (dispPtr = TkGetDisplayList(); dispPtr != NULL;
dispPtr = dispPtr->nextPtr) {
if (dispPtr->eventualGrabWinPtr != NULL) {
Tcl_AppendElement(interp,
dispPtr->eventualGrabWinPtr->pathName);
}
}
}
return TCL_OK;
case GRABCMD_RELEASE:
/* [grab release window] */
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "release window");
return TCL_ERROR;
}
tkwin = Tk_NameToWindow(interp, Tcl_GetString(objv[2]), clientData);
if (tkwin == NULL) {
Tcl_ResetResult(interp);
} else {
Tk_Ungrab(tkwin);
}
break;
case GRABCMD_SET:
/* [grab set ?-global? window] */
if ((objc != 3) && (objc != 4)) {
Tcl_WrongNumArgs(interp, 1, objv, "set ?-global? window");
return TCL_ERROR;
}
if (objc == 3) {
globalGrab = 0;
tkwin = Tk_NameToWindow(interp, Tcl_GetString(objv[2]),
clientData);
} else {
globalGrab = 1;
/*
* We could just test the argument by hand instead of using
* Tcl_GetIndexFromObj; the benefit of using the function is that
* it sets up the error message for us, so we are certain to be
* consistant with the rest of Tcl.
*/
if (Tcl_GetIndexFromObj(interp, objv[2], flagStrings, "option",
0, &index) != TCL_OK) {
return TCL_ERROR;
}
tkwin = Tk_NameToWindow(interp, Tcl_GetString(objv[3]),
clientData);
}
if (tkwin == NULL) {
return TCL_ERROR;
}
return Tk_Grab(interp, tkwin, globalGrab);
case GRABCMD_STATUS: {
/* [grab status window] */
TkWindow *winPtr;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "status window");
return TCL_ERROR;
}
winPtr = (TkWindow *) Tk_NameToWindow(interp, Tcl_GetString(objv[2]),
clientData);
if (winPtr == NULL) {
return TCL_ERROR;
}
dispPtr = winPtr->dispPtr;
if (dispPtr->eventualGrabWinPtr != winPtr) {
Tcl_SetResult(interp, "none", TCL_STATIC);
} else if (dispPtr->grabFlags & GRAB_GLOBAL) {
Tcl_SetResult(interp, "global", TCL_STATIC);
} else {
Tcl_SetResult(interp, "local", TCL_STATIC);
}
break;
}
}
return TCL_OK;
}
BOOL CSemanticStrView::Create(LPCTSTR lpszClassName, LPCTSTR lpszWindowName, DWORD dwStyle, const RECT& rect, CWnd* pParentWnd, UINT nID, CCreateContext* pContext)
{
// TODO: Add your specialized code here and/or call the base class
m_Menu.LoadMenu(IDR_ROSSDETYPE);
pParentWnd->SetMenu( &m_Menu );
char s[2000];
CRect R = rect;
//R.right = rect.right + 100;
pParentWnd->SetWindowPos(0, 120, 120, 840, 500,0);
BOOL ok = CWnd::Create(lpszClassName, lpszWindowName, dwStyle, R, pParentWnd, nID, pContext);
if (ok) {
int retcode;
CString winhnd, cmd;
m_tkname.Format(".tk%d",++TclWindowCounter); // name this window .tk1 .tk2 etc
winhnd.Format("0x%08X",m_hWnd);
cmd.Format("toplevel %s -use %s",m_tkname,winhnd);
strcpy (s, cmd);
retcode = Tcl_Eval(theInterp,s);
if (retcode!=TCL_OK) {
Tcl_SetResult(theInterp,"Cannot create TK child window",TCL_VOLATILE);
return ok;
}
Tk_Window tkmain = Tk_MainWindow(theInterp);
if (tkmain) {
//get the tk window token
strcpy (s, m_tkname);
m_tkwin = Tk_NameToWindow(theInterp, s, tkmain);
Tcl_DoOneEvent(TCL_ALL_EVENTS|TCL_DONT_WAIT); //force window creation
// get the HWND
cmd.Format("winfo id %s",m_tkname);
strcpy (s, cmd);
retcode = Tcl_Eval(theInterp,s);
if (retcode==TCL_OK) {
int i;
retcode = Tcl_GetInt(theInterp,theInterp->result,&i);
if (retcode==TCL_OK) {
m_tkhwnd = (HWND)i;
}
}
SwitchGraph(m_tkname);
CString cmd;
cmd.Format("source $env(GRAPHLET_DIR)/lib/graphscript/ross/semstruct.tcl");
strcpy (s, cmd);
retcode = Tcl_Eval(theInterp,s);
if (retcode!=TCL_OK) {
AfxMessageBox (theInterp->result);
return FALSE;
};
cmd.Format("initialize_graphic $main");
strcpy (s, cmd);
retcode = Tcl_Eval(theInterp,s);
if (retcode!=TCL_OK) {
AfxMessageBox (theInterp->result);
return FALSE;
};
}
}
return ok;
}
int
Tk_SelectionObjCmd(
ClientData clientData, /* Main window associated with
* interpreter. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tk_Window tkwin = clientData;
char *path = NULL;
Atom selection;
char *selName = NULL, *string;
int count, index;
Tcl_Obj **objs;
static const char *const optionStrings[] = {
"clear", "get", "handle", "own", NULL
};
enum options {
SELECTION_CLEAR, SELECTION_GET, SELECTION_HANDLE, SELECTION_OWN
};
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum options) index) {
case SELECTION_CLEAR: {
static const char *const clearOptionStrings[] = {
"-displayof", "-selection", NULL
};
enum clearOptions { CLEAR_DISPLAYOF, CLEAR_SELECTION };
int clearIndex;
for (count = objc-2, objs = ((Tcl_Obj **)objv)+2; count > 0;
count-=2, objs+=2) {
string = Tcl_GetString(objs[0]);
if (string[0] != '-') {
break;
}
if (count < 2) {
Tcl_AppendResult(interp, "value for \"", string,
"\" missing", NULL);
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objs[0], clearOptionStrings,
"option", 0, &clearIndex) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum clearOptions) clearIndex) {
case CLEAR_DISPLAYOF:
path = Tcl_GetString(objs[1]);
break;
case CLEAR_SELECTION:
selName = Tcl_GetString(objs[1]);
break;
}
}
if (count == 1) {
path = Tcl_GetString(objs[0]);
} else if (count > 1) {
Tcl_WrongNumArgs(interp, 2, objv, "?-option value ...?");
return TCL_ERROR;
}
if (path != NULL) {
tkwin = Tk_NameToWindow(interp, path, tkwin);
}
if (tkwin == NULL) {
return TCL_ERROR;
}
if (selName != NULL) {
selection = Tk_InternAtom(tkwin, selName);
} else {
selection = XA_PRIMARY;
}
Tk_ClearSelection(tkwin, selection);
break;
}
case SELECTION_GET: {
Atom target;
char *targetName = NULL;
Tcl_DString selBytes;
int result;
static const char *const getOptionStrings[] = {
"-displayof", "-selection", "-type", NULL
};
enum getOptions { GET_DISPLAYOF, GET_SELECTION, GET_TYPE };
int getIndex;
for (count = objc-2, objs = ((Tcl_Obj **)objv)+2; count>0;
count-=2, objs+=2) {
string = Tcl_GetString(objs[0]);
if (string[0] != '-') {
break;
}
if (count < 2) {
Tcl_AppendResult(interp, "value for \"", string,
"\" missing", NULL);
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objs[0], getOptionStrings,
"option", 0, &getIndex) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum getOptions) getIndex) {
case GET_DISPLAYOF:
path = Tcl_GetString(objs[1]);
break;
case GET_SELECTION:
selName = Tcl_GetString(objs[1]);
break;
case GET_TYPE:
targetName = Tcl_GetString(objs[1]);
break;
}
}
if (path != NULL) {
tkwin = Tk_NameToWindow(interp, path, tkwin);
}
if (tkwin == NULL) {
return TCL_ERROR;
}
if (selName != NULL) {
selection = Tk_InternAtom(tkwin, selName);
} else {
selection = XA_PRIMARY;
}
if (count > 1) {
Tcl_WrongNumArgs(interp, 2, objv, "?-option value ...?");
return TCL_ERROR;
} else if (count == 1) {
target = Tk_InternAtom(tkwin, Tcl_GetString(objs[0]));
} else if (targetName != NULL) {
target = Tk_InternAtom(tkwin, targetName);
} else {
target = XA_STRING;
}
Tcl_DStringInit(&selBytes);
result = Tk_GetSelection(interp, tkwin, selection, target,
SelGetProc, &selBytes);
if (result == TCL_OK) {
Tcl_DStringResult(interp, &selBytes);
} else {
Tcl_DStringFree(&selBytes);
}
return result;
}
case SELECTION_HANDLE: {
Atom target, format;
char *targetName = NULL;
char *formatName = NULL;
register CommandInfo *cmdInfoPtr;
int cmdLength;
static const char *const handleOptionStrings[] = {
"-format", "-selection", "-type", NULL
};
enum handleOptions {
HANDLE_FORMAT, HANDLE_SELECTION, HANDLE_TYPE
};
int handleIndex;
for (count = objc-2, objs = ((Tcl_Obj **)objv)+2; count > 0;
count-=2, objs+=2) {
string = Tcl_GetString(objs[0]);
if (string[0] != '-') {
break;
}
if (count < 2) {
Tcl_AppendResult(interp, "value for \"", string,
"\" missing", NULL);
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objs[0],handleOptionStrings,
"option", 0, &handleIndex) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum handleOptions) handleIndex) {
case HANDLE_FORMAT:
formatName = Tcl_GetString(objs[1]);
break;
case HANDLE_SELECTION:
selName = Tcl_GetString(objs[1]);
break;
case HANDLE_TYPE:
targetName = Tcl_GetString(objs[1]);
break;
}
}
if ((count < 2) || (count > 4)) {
Tcl_WrongNumArgs(interp, 2, objv, "?-option value ...? window command");
return TCL_ERROR;
}
tkwin = Tk_NameToWindow(interp, Tcl_GetString(objs[0]), tkwin);
if (tkwin == NULL) {
return TCL_ERROR;
}
if (selName != NULL) {
selection = Tk_InternAtom(tkwin, selName);
} else {
selection = XA_PRIMARY;
}
if (count > 2) {
target = Tk_InternAtom(tkwin, Tcl_GetString(objs[2]));
} else if (targetName != NULL) {
target = Tk_InternAtom(tkwin, targetName);
} else {
target = XA_STRING;
}
if (count > 3) {
format = Tk_InternAtom(tkwin, Tcl_GetString(objs[3]));
} else if (formatName != NULL) {
format = Tk_InternAtom(tkwin, formatName);
} else {
format = XA_STRING;
}
string = Tcl_GetStringFromObj(objs[1], &cmdLength);
if (cmdLength == 0) {
Tk_DeleteSelHandler(tkwin, selection, target);
} else {
cmdInfoPtr = (CommandInfo *) ckalloc((unsigned) (
sizeof(CommandInfo) - 3 + cmdLength));
cmdInfoPtr->interp = interp;
cmdInfoPtr->charOffset = 0;
cmdInfoPtr->byteOffset = 0;
cmdInfoPtr->buffer[0] = '\0';
cmdInfoPtr->cmdLength = cmdLength;
strcpy(cmdInfoPtr->command, string);
Tk_CreateSelHandler(tkwin, selection, target, HandleTclCommand,
cmdInfoPtr, format);
}
return TCL_OK;
}
case SELECTION_OWN: {
register LostCommand *lostPtr;
char *script = NULL;
int cmdLength;
static const char *const ownOptionStrings[] = {
"-command", "-displayof", "-selection", NULL
};
enum ownOptions { OWN_COMMAND, OWN_DISPLAYOF, OWN_SELECTION };
int ownIndex;
for (count = objc-2, objs = ((Tcl_Obj **)objv)+2; count > 0;
count-=2, objs+=2) {
string = Tcl_GetString(objs[0]);
if (string[0] != '-') {
break;
}
if (count < 2) {
Tcl_AppendResult(interp, "value for \"", string,
"\" missing", NULL);
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objs[0], ownOptionStrings,
"option", 0, &ownIndex) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum ownOptions) ownIndex) {
case OWN_COMMAND:
script = Tcl_GetString(objs[1]);
break;
case OWN_DISPLAYOF:
path = Tcl_GetString(objs[1]);
break;
case OWN_SELECTION:
selName = Tcl_GetString(objs[1]);
break;
}
}
if (count > 2) {
Tcl_WrongNumArgs(interp, 2, objv, "?-option value ...? ?window?");
return TCL_ERROR;
}
if (selName != NULL) {
selection = Tk_InternAtom(tkwin, selName);
} else {
selection = XA_PRIMARY;
}
if (count == 0) {
TkSelectionInfo *infoPtr;
TkWindow *winPtr;
if (path != NULL) {
tkwin = Tk_NameToWindow(interp, path, tkwin);
}
if (tkwin == NULL) {
return TCL_ERROR;
}
winPtr = (TkWindow *)tkwin;
for (infoPtr = winPtr->dispPtr->selectionInfoPtr;
infoPtr != NULL; infoPtr = infoPtr->nextPtr) {
if (infoPtr->selection == selection) {
break;
}
}
/*
* Ignore the internal clipboard window.
*/
if ((infoPtr != NULL)
&& (infoPtr->owner != winPtr->dispPtr->clipWindow)) {
Tcl_SetResult(interp, Tk_PathName(infoPtr->owner), TCL_STATIC);
}
return TCL_OK;
}
tkwin = Tk_NameToWindow(interp, Tcl_GetString(objs[0]), tkwin);
if (tkwin == NULL) {
return TCL_ERROR;
}
if (count == 2) {
script = Tcl_GetString(objs[1]);
}
if (script == NULL) {
Tk_OwnSelection(tkwin, selection, NULL, NULL);
return TCL_OK;
}
cmdLength = strlen(script);
lostPtr = (LostCommand *)
ckalloc((unsigned) (sizeof(LostCommand) - 3 + cmdLength));
lostPtr->interp = interp;
strcpy(lostPtr->command, script);
Tk_OwnSelection(tkwin, selection, LostSelection, lostPtr);
return TCL_OK;
}
}
return TCL_OK;
}
/*ARGSUSED*/
static int
EmbWinLayoutProc(
TkText *textPtr, /* Text widget being layed out. */
TkTextIndex *indexPtr, /* Identifies first character in chunk. */
TkTextSegment *ewPtr, /* Segment corresponding to indexPtr. */
int offset, /* Offset within segPtr corresponding to
* indexPtr (always 0). */
int maxX, /* Chunk must not occupy pixels at this
* position or higher. */
int maxChars, /* Chunk must not include more than this many
* characters. */
int noCharsYet, /* Non-zero means no characters have been
* assigned to this line yet. */
TkWrapMode wrapMode, /* Wrap mode to use for line:
* TEXT_WRAPMODE_CHAR, TEXT_WRAPMODE_NONE, or
* TEXT_WRAPMODE_WORD. */
register TkTextDispChunk *chunkPtr)
/* Structure to fill in with information about
* this chunk. The x field has already been
* set by the caller. */
{
int width, height;
TkTextEmbWindowClient *client;
if (offset != 0) {
Tcl_Panic("Non-zero offset in EmbWinLayoutProc");
}
client = EmbWinGetClient(textPtr, ewPtr);
if (client == NULL) {
ewPtr->body.ew.tkwin = NULL;
} else {
ewPtr->body.ew.tkwin = client->tkwin;
}
if ((ewPtr->body.ew.tkwin == NULL) && (ewPtr->body.ew.create != NULL)) {
int code, isNew;
Tk_Window ancestor;
Tcl_HashEntry *hPtr;
const char *before, *string;
Tcl_DString name, buf, *dsPtr = NULL;
before = ewPtr->body.ew.create;
/*
* Find everything up to the next % character and append it to the
* result string.
*/
string = before;
while (*string != 0) {
if ((*string == '%') && (string[1] == '%' || string[1] == 'W')) {
if (dsPtr == NULL) {
Tcl_DStringInit(&buf);
dsPtr = &buf;
}
if (string != before) {
Tcl_DStringAppend(dsPtr, before, (int) (string-before));
before = string;
}
if (string[1] == '%') {
Tcl_DStringAppend(dsPtr, "%", 1);
} else {
/*
* Substitute string as proper Tcl list element.
*/
int spaceNeeded, cvtFlags, length;
const char *str = Tk_PathName(textPtr->tkwin);
spaceNeeded = Tcl_ScanElement(str, &cvtFlags);
length = Tcl_DStringLength(dsPtr);
Tcl_DStringSetLength(dsPtr, length + spaceNeeded);
spaceNeeded = Tcl_ConvertElement(str,
Tcl_DStringValue(dsPtr) + length,
cvtFlags | TCL_DONT_USE_BRACES);
Tcl_DStringSetLength(dsPtr, length + spaceNeeded);
}
before += 2;
string++;
}
string++;
}
/*
* The window doesn't currently exist. Create it by evaluating the
* creation script. The script must return the window's path name:
* look up that name to get back to the window token. Then register
* ourselves as the geometry manager for the window.
*/
if (dsPtr != NULL) {
Tcl_DStringAppend(dsPtr, before, (int) (string-before));
code = Tcl_GlobalEval(textPtr->interp, Tcl_DStringValue(dsPtr));
Tcl_DStringFree(dsPtr);
} else {
code = Tcl_GlobalEval(textPtr->interp, ewPtr->body.ew.create);
}
if (code != TCL_OK) {
createError:
Tcl_BackgroundException(textPtr->interp, code);
goto gotWindow;
}
Tcl_DStringInit(&name);
Tcl_DStringAppend(&name, Tcl_GetStringResult(textPtr->interp), -1);
Tcl_ResetResult(textPtr->interp);
ewPtr->body.ew.tkwin = Tk_NameToWindow(textPtr->interp,
Tcl_DStringValue(&name), textPtr->tkwin);
Tcl_DStringFree(&name);
if (ewPtr->body.ew.tkwin == NULL) {
goto createError;
}
for (ancestor = textPtr->tkwin; ; ancestor = Tk_Parent(ancestor)) {
if (ancestor == Tk_Parent(ewPtr->body.ew.tkwin)) {
break;
}
if (Tk_TopWinHierarchy(ancestor)) {
badMaster:
Tcl_AppendResult(textPtr->interp, "can't embed ",
Tk_PathName(ewPtr->body.ew.tkwin), " relative to ",
Tk_PathName(textPtr->tkwin), NULL);
Tcl_BackgroundError(textPtr->interp);
ewPtr->body.ew.tkwin = NULL;
goto gotWindow;
}
}
if (Tk_TopWinHierarchy(ewPtr->body.ew.tkwin)
|| (textPtr->tkwin == ewPtr->body.ew.tkwin)) {
goto badMaster;
}
if (client == NULL) {
/*
* We just used a '-create' script to make a new window, which we
* now need to add to our client list.
*/
client = (TkTextEmbWindowClient *)
ckalloc(sizeof(TkTextEmbWindowClient));
client->next = ewPtr->body.ew.clients;
client->textPtr = textPtr;
client->tkwin = NULL;
client->chunkCount = 0;
client->displayed = 0;
client->parent = ewPtr;
ewPtr->body.ew.clients = client;
}
client->tkwin = ewPtr->body.ew.tkwin;
Tk_ManageGeometry(client->tkwin, &textGeomType, client);
Tk_CreateEventHandler(client->tkwin, StructureNotifyMask,
EmbWinStructureProc, client);
/*
* Special trick! Must enter into the hash table *after* calling
* Tk_ManageGeometry: if the window was already managed elsewhere in
* this text, the Tk_ManageGeometry call will cause the entry to be
* removed, which could potentially lose the new entry.
*/
hPtr = Tcl_CreateHashEntry(&textPtr->sharedTextPtr->windowTable,
Tk_PathName(client->tkwin), &isNew);
Tcl_SetHashValue(hPtr, ewPtr);
}
/*
* See if there's room for this window on this line.
*/
gotWindow:
if (ewPtr->body.ew.tkwin == NULL) {
width = 0;
height = 0;
} else {
width = Tk_ReqWidth(ewPtr->body.ew.tkwin) + 2*ewPtr->body.ew.padX;
height = Tk_ReqHeight(ewPtr->body.ew.tkwin) + 2*ewPtr->body.ew.padY;
}
if ((width > (maxX - chunkPtr->x))
&& !noCharsYet && (textPtr->wrapMode != TEXT_WRAPMODE_NONE)) {
return 0;
}
/*
* Fill in the chunk structure.
*/
chunkPtr->displayProc = TkTextEmbWinDisplayProc;
chunkPtr->undisplayProc = EmbWinUndisplayProc;
chunkPtr->measureProc = NULL;
chunkPtr->bboxProc = EmbWinBboxProc;
chunkPtr->numBytes = 1;
if (ewPtr->body.ew.align == ALIGN_BASELINE) {
chunkPtr->minAscent = height - ewPtr->body.ew.padY;
chunkPtr->minDescent = ewPtr->body.ew.padY;
chunkPtr->minHeight = 0;
} else {
chunkPtr->minAscent = 0;
chunkPtr->minDescent = 0;
chunkPtr->minHeight = height;
}
chunkPtr->width = width;
chunkPtr->breakIndex = -1;
chunkPtr->breakIndex = 1;
chunkPtr->clientData = ewPtr;
if (client != NULL) {
client->chunkCount += 1;
}
return 1;
}
static int
win_choose_font (ClientData cd, Tcl_Interp *interp, int argc, char **argv)
{
char *deffont;
Tk_Window parent;
int i, oldMode;
CHOOSEFONT cf;
LOGFONT lf;
HDC hdc;
HFONT hfont;
char facebuf[LF_FACESIZE];
TEXTMETRIC tm;
int pointsize;
char *s;
Tcl_DString resultStr; /* used to translate result in UTF8 in Tcl/Tk8.1 */
deffont = NULL;
parent = Tk_MainWindow (interp);
for (i = 1; i < argc; i += 2)
{
if (i + 1 >= argc)
{
Tcl_ResetResult (interp);
Tcl_AppendStringsToObj (Tcl_GetObjResult (interp),
"value for \"", argv[i], "\" missing",
(char *) NULL);
return TCL_ERROR;
}
if (strcmp (argv[i], "-default") == 0)
deffont = argv[i + 1];
else if (strcmp (argv[i], "-parent") == 0)
{
parent = Tk_NameToWindow (interp, argv[i + 1],
Tk_MainWindow (interp));
if (parent == NULL)
return TCL_ERROR;
}
else
{
Tcl_ResetResult (interp);
Tcl_AppendStringsToObj (Tcl_GetObjResult (interp),
"unknown option \"", argv[i], "\"",
(char *) NULL);
return TCL_ERROR;
}
}
memset (&cf, 0, sizeof (CHOOSEFONT));
cf.lStructSize = sizeof (CHOOSEFONT);
if (Tk_WindowId (parent) == None)
Tk_MakeWindowExist (parent);
cf.hwndOwner = Tk_GetHWND (Tk_WindowId (parent));
cf.lpLogFont = &lf;
cf.Flags = CF_SCREENFONTS | CF_FORCEFONTEXIST;
memset (&lf, 0, sizeof (LOGFONT));
if (deffont != NULL)
{
Tk_Font tkfont;
const TkFontAttributes *fa;
tkfont = Tk_GetFont (interp, parent, deffont);
if (tkfont == NULL)
return TCL_ERROR;
cf.Flags |= CF_INITTOLOGFONTSTRUCT;
/* In order to initialize LOGFONT, we need to extract the real
font attributes from the Tk internal font information. */
fa = &((TkFont *) tkfont)->fa;
/* This code is taken from TkpGetFontFromAttributes. It
converts a TkFontAttributes structure into a LOGFONT
structure. */
#if (TCL_MAJOR_VERSION >= 8) && (TCL_MINOR_VERSION >= 1)
lf.lfHeight = - fa->size;
#else
lf.lfHeight = - fa->pointsize;
#endif
if (lf.lfHeight < 0)
lf.lfHeight = MulDiv (lf.lfHeight,
254 * WidthOfScreen (Tk_Screen (parent)),
720 * WidthMMOfScreen (Tk_Screen (parent)));
lf.lfWeight = fa->weight == TK_FW_NORMAL ? FW_NORMAL : FW_BOLD;
lf.lfItalic = fa->slant;
lf.lfUnderline = fa->underline;
lf.lfStrikeOut = fa->overstrike;
lf.lfCharSet = DEFAULT_CHARSET;
lf.lfOutPrecision = OUT_DEFAULT_PRECIS;
lf.lfClipPrecision = CLIP_DEFAULT_PRECIS;
lf.lfQuality = DEFAULT_QUALITY;
lf.lfPitchAndFamily = DEFAULT_PITCH | FF_DONTCARE;
if (fa->family == NULL)
lf.lfFaceName[0] = '\0';
else
strncpy (lf.lfFaceName, fa->family, sizeof (lf.lfFaceName));
Tk_FreeFont (tkfont);
}
oldMode = Tcl_SetServiceMode(TCL_SERVICE_ALL);
if (! ChooseFont (&cf))
{
DWORD code;
code = CommDlgExtendedError ();
if (code == 0)
{
/* The user pressed cancel. */
Tcl_ResetResult (interp);
return TCL_OK;
}
else
{
char buf[200];
sprintf (buf, "Windows common dialog error 0x%lx", (unsigned long) code);
Tcl_ResetResult (interp);
#if (TCL_MAJOR_VERSION >= 8) && (TCL_MINOR_VERSION >= 1)
Tcl_ExternalToUtfDString(NULL, buf, -1, &resultStr);
#else
Tcl_InitDString(&resultStr);
Tcl_DStingAppend(&resultStr, buf, -1);
#endif
Tcl_AppendStringsToObj (Tcl_GetObjResult (interp),
Tcl_DStringValue(&resultStr),
(char *) NULL);
Tcl_DStringFree(&resultStr);
return TCL_ERROR;
}
}
Tcl_SetServiceMode(oldMode);
/* We now have a LOGFONT structure. We store it into a device
context, and then extract enough information to build a Tk font
specification. With luck, when Tk interprets the font
specification it will wind up with the font that the user expects
to see. Some of this code is taken from AllocFont. */
hfont = CreateFontIndirect (&lf);
if (hfont == NULL)
{
/* This should be impossible. */
#if (TCL_MAJOR_VERSION >= 8) && (TCL_MINOR_VERSION >= 1)
Tcl_ExternalToUtfDString(NULL, "CreateFontIndirect failed on chosen font", -1, &resultStr);
#else
Tcl_InitDString(&resultStr);
Tcl_DStingAppend(&resultStr, "CreateFontIndirect failed on chosen font", -1);
#endif
Tcl_SetResult (interp, Tcl_DStringValue(&resultStr), TCL_STATIC);
Tcl_DStringFree(&resultStr);
return TCL_ERROR;
}
hdc = GetDC (cf.hwndOwner);
hfont = SelectObject (hdc, hfont);
GetTextFace (hdc, sizeof (facebuf), facebuf);
GetTextMetrics (hdc, &tm);
Tcl_ResetResult (interp);
#if (TCL_MAJOR_VERSION >= 8) && (TCL_MINOR_VERSION >= 1)
Tcl_ExternalToUtfDString(NULL, facebuf, -1, &resultStr);
#else
Tcl_InitDString(&resultStr);
Tcl_DStingAppend(&resultStr,facebuf,-1);
#endif
if (Tcl_ListObjAppendElement (interp, Tcl_GetObjResult (interp),
Tcl_NewStringObj (Tcl_DStringValue(&resultStr), -1)) != TCL_OK) {
Tcl_DStringFree(&resultStr);
return TCL_ERROR;
}
Tcl_DStringFree(&resultStr);
pointsize = MulDiv (tm.tmHeight - tm.tmInternalLeading,
720 * WidthMMOfScreen (Tk_Screen (parent)),
254 * WidthOfScreen (Tk_Screen (parent)));
if (Tcl_ListObjAppendElement (interp, Tcl_GetObjResult (interp),
Tcl_NewIntObj (pointsize)) != TCL_OK) {
return TCL_ERROR;
}
if (tm.tmWeight > FW_MEDIUM)
s = "bold";
else
s = "normal";
#if (TCL_MAJOR_VERSION >= 8) && (TCL_MINOR_VERSION >= 1)
Tcl_ExternalToUtfDString(NULL, s, -1, &resultStr);
#else
Tcl_InitDString(&resultStr);
Tcl_DStingAppend(&resultStr, s, -1);
#endif
if (Tcl_ListObjAppendElement (interp, Tcl_GetObjResult (interp),
Tcl_NewStringObj (Tcl_DStringValue(&resultStr), -1)) != TCL_OK) {
Tcl_DStringFree(&resultStr);
return TCL_ERROR;
}
Tcl_DStringFree(&resultStr);
if (tm.tmItalic)
s = "italic";
else
s = "roman";
#if (TCL_MAJOR_VERSION >= 8) && (TCL_MINOR_VERSION >= 1)
Tcl_ExternalToUtfDString(NULL, s, -1, &resultStr);
#else
Tcl_InitDString(&resultStr);
Tcl_DStingAppend(&resultStr, s, -1);
#endif
if (Tcl_ListObjAppendElement (interp, Tcl_GetObjResult (interp),
Tcl_NewStringObj (Tcl_DStringValue(&resultStr), -1)) != TCL_OK) {
Tcl_DStringFree(&resultStr);
return TCL_ERROR;
}
Tcl_DStringFree(&resultStr);
if (tm.tmUnderlined)
{
#if (TCL_MAJOR_VERSION >= 8) && (TCL_MINOR_VERSION >= 1)
Tcl_ExternalToUtfDString(NULL, "underline", -1, &resultStr);
#else
Tcl_InitDString(&resultStr);
Tcl_DStingAppend(&resultStr,"underline",-1);
#endif
if (Tcl_ListObjAppendElement (interp, Tcl_GetObjResult (interp),
Tcl_NewStringObj (Tcl_DStringValue(&resultStr), -1))
!= TCL_OK) {
Tcl_DStringFree(&resultStr);
return TCL_ERROR;
}
Tcl_DStringFree(&resultStr);
}
if (tm.tmStruckOut)
{
#if (TCL_MAJOR_VERSION >= 8) && (TCL_MINOR_VERSION >= 1)
Tcl_ExternalToUtfDString(NULL, "overstrike", -1, &resultStr);
#else
Tcl_InitDString(&resultStr);
Tcl_DStingAppend(&resultStr, "overstrike", -1);
#endif
if (Tcl_ListObjAppendElement (interp, Tcl_GetObjResult (interp),
Tcl_NewStringObj (Tcl_DStringValue(&resultStr), -1))
!= TCL_OK) {
Tcl_DStringFree(&resultStr);
return TCL_ERROR;
}
Tcl_DStringFree(&resultStr);
}
hfont = SelectObject (hdc, hfont);
ReleaseDC (cf.hwndOwner, hdc);
DeleteObject (hfont);
return TCL_OK;
}
static int
DoConfig(
Tcl_Interp *interp, /* Interpreter for error reporting. */
Tk_Window tkwin, /* Window containing widget (needed to set up
* X resources). */
Tk_ConfigSpec *specPtr, /* Specifier to apply. */
Tk_Uid value, /* Value to use to fill in widgRec. */
int valueIsUid, /* Non-zero means value is a Tk_Uid; zero
* means it's an ordinary string. */
char *widgRec) /* Record whose fields are to be modified.
* Values must be properly initialized. */
{
char *ptr;
Tk_Uid uid;
int nullValue;
nullValue = 0;
if ((*value == 0) && (specPtr->specFlags & TK_CONFIG_NULL_OK)) {
nullValue = 1;
}
do {
ptr = widgRec + specPtr->offset;
switch (specPtr->type) {
case TK_CONFIG_BOOLEAN:
if (Tcl_GetBoolean(interp, value, (int *) ptr) != TCL_OK) {
return TCL_ERROR;
}
break;
case TK_CONFIG_INT:
if (Tcl_GetInt(interp, value, (int *) ptr) != TCL_OK) {
return TCL_ERROR;
}
break;
case TK_CONFIG_DOUBLE:
if (Tcl_GetDouble(interp, value, (double *) ptr) != TCL_OK) {
return TCL_ERROR;
}
break;
case TK_CONFIG_STRING: {
char *oldStr, *newStr;
if (nullValue) {
newStr = NULL;
} else {
newStr = (char *) ckalloc((unsigned) (strlen(value) + 1));
strcpy(newStr, value);
}
oldStr = *((char **) ptr);
if (oldStr != NULL) {
ckfree(oldStr);
}
*((char **) ptr) = newStr;
break;
}
case TK_CONFIG_UID:
if (nullValue) {
*((Tk_Uid *) ptr) = NULL;
} else {
uid = valueIsUid ? (Tk_Uid) value : Tk_GetUid(value);
*((Tk_Uid *) ptr) = uid;
}
break;
case TK_CONFIG_COLOR: {
XColor *newPtr, *oldPtr;
if (nullValue) {
newPtr = NULL;
} else {
uid = valueIsUid ? (Tk_Uid) value : Tk_GetUid(value);
newPtr = Tk_GetColor(interp, tkwin, uid);
if (newPtr == NULL) {
return TCL_ERROR;
}
}
oldPtr = *((XColor **) ptr);
if (oldPtr != NULL) {
Tk_FreeColor(oldPtr);
}
*((XColor **) ptr) = newPtr;
break;
}
case TK_CONFIG_FONT: {
Tk_Font newFont;
if (nullValue) {
newFont = NULL;
} else {
newFont = Tk_GetFont(interp, tkwin, value);
if (newFont == NULL) {
return TCL_ERROR;
}
}
Tk_FreeFont(*((Tk_Font *) ptr));
*((Tk_Font *) ptr) = newFont;
break;
}
case TK_CONFIG_BITMAP: {
Pixmap newBmp, oldBmp;
if (nullValue) {
newBmp = None;
} else {
uid = valueIsUid ? (Tk_Uid) value : Tk_GetUid(value);
newBmp = Tk_GetBitmap(interp, tkwin, uid);
if (newBmp == None) {
return TCL_ERROR;
}
}
oldBmp = *((Pixmap *) ptr);
if (oldBmp != None) {
Tk_FreeBitmap(Tk_Display(tkwin), oldBmp);
}
*((Pixmap *) ptr) = newBmp;
break;
}
case TK_CONFIG_BORDER: {
Tk_3DBorder newBorder, oldBorder;
if (nullValue) {
newBorder = NULL;
} else {
uid = valueIsUid ? (Tk_Uid) value : Tk_GetUid(value);
newBorder = Tk_Get3DBorder(interp, tkwin, uid);
if (newBorder == NULL) {
return TCL_ERROR;
}
}
oldBorder = *((Tk_3DBorder *) ptr);
if (oldBorder != NULL) {
Tk_Free3DBorder(oldBorder);
}
*((Tk_3DBorder *) ptr) = newBorder;
break;
}
case TK_CONFIG_RELIEF:
uid = valueIsUid ? (Tk_Uid) value : Tk_GetUid(value);
if (Tk_GetRelief(interp, uid, (int *) ptr) != TCL_OK) {
return TCL_ERROR;
}
break;
case TK_CONFIG_CURSOR:
case TK_CONFIG_ACTIVE_CURSOR: {
Tk_Cursor newCursor, oldCursor;
if (nullValue) {
newCursor = None;
} else {
uid = valueIsUid ? (Tk_Uid) value : Tk_GetUid(value);
newCursor = Tk_GetCursor(interp, tkwin, uid);
if (newCursor == None) {
return TCL_ERROR;
}
}
oldCursor = *((Tk_Cursor *) ptr);
if (oldCursor != None) {
Tk_FreeCursor(Tk_Display(tkwin), oldCursor);
}
*((Tk_Cursor *) ptr) = newCursor;
if (specPtr->type == TK_CONFIG_ACTIVE_CURSOR) {
Tk_DefineCursor(tkwin, newCursor);
}
break;
}
case TK_CONFIG_JUSTIFY:
uid = valueIsUid ? (Tk_Uid) value : Tk_GetUid(value);
if (Tk_GetJustify(interp, uid, (Tk_Justify *) ptr) != TCL_OK) {
return TCL_ERROR;
}
break;
case TK_CONFIG_ANCHOR:
uid = valueIsUid ? (Tk_Uid) value : Tk_GetUid(value);
if (Tk_GetAnchor(interp, uid, (Tk_Anchor *) ptr) != TCL_OK) {
return TCL_ERROR;
}
break;
case TK_CONFIG_CAP_STYLE:
uid = valueIsUid ? (Tk_Uid) value : Tk_GetUid(value);
if (Tk_GetCapStyle(interp, uid, (int *) ptr) != TCL_OK) {
return TCL_ERROR;
}
break;
case TK_CONFIG_JOIN_STYLE:
uid = valueIsUid ? (Tk_Uid) value : Tk_GetUid(value);
if (Tk_GetJoinStyle(interp, uid, (int *) ptr) != TCL_OK) {
return TCL_ERROR;
}
break;
case TK_CONFIG_PIXELS:
if (Tk_GetPixels(interp, tkwin, value, (int *) ptr)
!= TCL_OK) {
return TCL_ERROR;
}
break;
case TK_CONFIG_MM:
if (Tk_GetScreenMM(interp, tkwin, value, (double*)ptr) != TCL_OK) {
return TCL_ERROR;
}
break;
case TK_CONFIG_WINDOW: {
Tk_Window tkwin2;
if (nullValue) {
tkwin2 = NULL;
} else {
tkwin2 = Tk_NameToWindow(interp, value, tkwin);
if (tkwin2 == NULL) {
return TCL_ERROR;
}
}
*((Tk_Window *) ptr) = tkwin2;
break;
}
case TK_CONFIG_CUSTOM:
if ((*specPtr->customPtr->parseProc)(
specPtr->customPtr->clientData, interp, tkwin, value,
widgRec, specPtr->offset) != TCL_OK) {
return TCL_ERROR;
}
break;
default: {
char buf[64 + TCL_INTEGER_SPACE];
sprintf(buf, "bad config table: unknown type %d", specPtr->type);
Tcl_SetResult(interp, buf, TCL_VOLATILE);
return TCL_ERROR;
}
}
specPtr++;
} while ((specPtr->argvName == NULL) && (specPtr->type != TK_CONFIG_END));
return TCL_OK;
}
HGLRC OpenGLGetContext(Tcl_Interp* interp,char* name)
#endif
{
Tcl_CmdInfo info;
OpenGLClientData* OpenGLPtr;
#ifdef _WIN32
HWND hWnd;
#endif
if(!Tcl_GetCommandInfo(interp, name, &info))
return 0;
OpenGLPtr=(OpenGLClientData*)info.clientData;
if (OpenGLPtr->tkwin != Tk_NameToWindow(interp, name, Tk_MainWindow(interp)))
return 0;
if (OpenGLPtr->display != Tk_Display(OpenGLPtr->tkwin))
return 0;
if (OpenGLPtr->display)
XSync(OpenGLPtr->display, False);
if (!OpenGLPtr->x11_win)
{
Tk_MakeWindowExist(OpenGLPtr->tkwin);
XSync(OpenGLPtr->display, False);
OpenGLPtr->x11_win = Tk_WindowId(OpenGLPtr->tkwin);
}
if (!OpenGLPtr->x11_win)
return 0;
#ifndef _WIN32
OpenGLPtr->glx_win = OpenGLPtr->x11_win;
if (!OpenGLPtr->cx)
{
OpenGLPtr->cx = glXCreateContext(OpenGLPtr->display,
OpenGLPtr->vi,
first_context,
OpenGLPtr->direct);
if (!first_context)
{
first_context = OpenGLPtr->cx;
}
}
if (!OpenGLPtr->cx)
{
Tcl_AppendResult(interp, "Error making GL context", (char*)NULL);
return 0;
}
if (!OpenGLPtr->glx_win)
return 0;
#else
hWnd = TkWinGetHWND(Tk_WindowId(OpenGLPtr->tkwin));
OpenGLPtr->hDC = GetDC(hWnd);
if (!OpenGLPtr->cx)
{
OpenGLPtr->cx = wglCreateContext(OpenGLPtr->hDC);
wglShareLists(first_context,OpenGLPtr->cx);
if (!first_context) first_context = OpenGLPtr->cx;
}
if (!OpenGLPtr->cx)
{
Tcl_AppendResult(interp, "Error making GL context", (char*)NULL);
printf("wglCreateContext() returned NULL; Error code: %d\n",
(int)GetLastError());
return 0;
}
#endif
return OpenGLPtr->cx;
}
int
Tk_OptionObjCmd(
ClientData clientData, /* Main window associated with interpreter. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of Tcl_Obj arguments. */
Tcl_Obj *const objv[]) /* Tcl_Obj arguments. */
{
Tk_Window tkwin = clientData;
int index, result;
ThreadSpecificData *tsdPtr =
Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
static const char *const optionCmds[] = {
"add", "clear", "get", "readfile", NULL
};
enum optionVals {
OPTION_ADD, OPTION_CLEAR, OPTION_GET, OPTION_READFILE
};
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "cmd arg ?arg ...?");
return TCL_ERROR;
}
result = Tcl_GetIndexFromObj(interp, objv[1], optionCmds, "option", 0,
&index);
if (result != TCL_OK) {
return result;
}
result = TCL_OK;
switch ((enum optionVals) index) {
case OPTION_ADD: {
int priority;
if ((objc != 4) && (objc != 5)) {
Tcl_WrongNumArgs(interp, 2, objv, "pattern value ?priority?");
return TCL_ERROR;
}
if (objc == 4) {
priority = TK_INTERACTIVE_PRIO;
} else {
priority = ParsePriority(interp, Tcl_GetString(objv[4]));
if (priority < 0) {
return TCL_ERROR;
}
}
Tk_AddOption(tkwin, Tcl_GetString(objv[2]), Tcl_GetString(objv[3]),
priority);
break;
}
case OPTION_CLEAR: {
TkMainInfo *mainPtr;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, "");
return TCL_ERROR;
}
mainPtr = ((TkWindow *) tkwin)->mainPtr;
if (mainPtr->optionRootPtr != NULL) {
ClearOptionTree(mainPtr->optionRootPtr);
mainPtr->optionRootPtr = NULL;
}
tsdPtr->cachedWindow = NULL;
break;
}
case OPTION_GET: {
Tk_Window window;
Tk_Uid value;
if (objc != 5) {
Tcl_WrongNumArgs(interp, 2, objv, "window name class");
return TCL_ERROR;
}
window = Tk_NameToWindow(interp, Tcl_GetString(objv[2]), tkwin);
if (window == NULL) {
return TCL_ERROR;
}
value = Tk_GetOption(window, Tcl_GetString(objv[3]),
Tcl_GetString(objv[4]));
if (value != NULL) {
Tcl_SetResult(interp, (char *) value, TCL_STATIC);
}
break;
}
case OPTION_READFILE: {
int priority;
if ((objc != 3) && (objc != 4)) {
Tcl_WrongNumArgs(interp, 2, objv, "fileName ?priority?");
return TCL_ERROR;
}
if (objc == 4) {
priority = ParsePriority(interp, Tcl_GetString(objv[3]));
if (priority < 0) {
return TCL_ERROR;
}
} else {
priority = TK_INTERACTIVE_PRIO;
}
result = ReadOptionFile(interp, tkwin, Tcl_GetString(objv[2]),
priority);
break;
}
}
return result;
}
int Init_Camera (ClientData, Tcl_Interp *interp,
int, char **argv)
{
cvcamWindow mainwin;
int ncameras,ret;
Tk_Window win;
char com[1000]="set dlg [Dialog .dlg -parent . -modal local -separator 1 -title \"Choice of cameras\" \
-side bottom -anchor s -default 0]";
CameraDescription cd;
ncameras = cvcamGetCamerasCount();
if (ncameras==0)
{
Tcl_Eval(interp,"tk_dialog .pattern {Error} { Cameras not found.} {} 0 OK");
return TCL_ERROR;
}
ret = Tcl_Eval(interp,com);
strcpy(com,"$dlg add -name ok -width 5");
ret = Tcl_Eval(interp,com);
strcpy(com, "set top [$dlg getframe]");
ret = Tcl_Eval(interp,com);
strcpy(com, "label $top.lab1 -text \"Several cameras has found in your system. Choose one of them.\" \n\
pack $top.lab1 -side top -anchor nw" );
ret = Tcl_Eval(interp,com);
strcpy(com, "label $top.lab2 -text \"\" \n\
pack $top.lab2 -side top -anchor nw");
ret = Tcl_Eval(interp,com);
strcpy(com, "label $top.lab3 -text \"Cameras:\" \n\
pack $top.lab3 -side top -anchor nw");
ret = Tcl_Eval(interp,com);
strcpy(com, "ComboBox $top.cb -width 50 -height 4 -editable no -modifycmd CVLkDemo::Modify");
ret = Tcl_Eval(interp,com);
strcpy(com, "pack $top.cb -side top");
ret = Tcl_Eval(interp,com);
strcpy(com, "$top.cb configure -values {");
for (int i=0; i<ncameras; i++)
{
cvcamGetProperty(i, CVCAM_DESCRIPTION, (void*)&cd);
strcat(com,"\"");
strcat(com,cd.DeviceDescription);
strcat(com,"\" ");
}
strcat(com,"}");
ret = Tcl_Eval(interp, com);
strcpy(com,"$top.cb setvalue @0 \n CVLkDemo::Modify \n set ret [$dlg draw]");
ret = Tcl_Eval(interp, com);
strcpy(com,"destroy $dlg");
ret = Tcl_Eval(interp, com);
ret = Tcl_Eval(interp, "set tmp $CVLkDemo::cam");
int n = atoi(interp->result);
ret = Tcl_Eval(interp, "set f $CVLkDemo::curframe");
win = Tk_NameToWindow(interp, interp->result,
Tk_MainWindow(interp));
Tk_MapWindow(win);
int w = Tk_Width(win);
int h = Tk_Height(win);
mainwin = SYSTEM_WIN_FROM_TK_WIN(win);
int prop;
cvcamSetProperty(n, CVCAM_PROP_ENABLE, CVCAMTRUE);
cvcamSetProperty(n, CVCAM_PROP_RENDER, CVCAMTRUE);
cvcamSetProperty(n, CVCAM_PROP_WINDOW, &mainwin);
cvcamSetProperty(n, CVCAM_PROP_CALLBACK, (void*)testcallback);
cvcamSetProperty(n, CVCAM_RNDWIDTH, (void*)&w);
cvcamSetProperty(n, CVCAM_RNDHEIGHT, (void*)&h);
view.SetSize(w,h);
cvcamInit();
cvcamGetProperty(n, CVCAM_DESCRIPTION, (void*)&cd);
sprintf(com,"set CVLkDemo::curcam \"%s\"",cd.DeviceDescription);
Tcl_Eval(interp, com);
return TCL_OK;
}
int
Tk_FocusObjCmd(
ClientData clientData, /* Main window associated with interpreter. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
static const char *const focusOptions[] = {
"-displayof", "-force", "-lastfor", NULL
};
Tk_Window tkwin = clientData;
TkWindow *winPtr = clientData;
TkWindow *newPtr, *focusWinPtr, *topLevelPtr;
ToplevelFocusInfo *tlFocusPtr;
const char *windowName;
int index;
/*
* If invoked with no arguments, just return the current focus window.
*/
if (objc == 1) {
focusWinPtr = TkGetFocusWin(winPtr);
if (focusWinPtr != NULL) {
Tcl_SetResult(interp, focusWinPtr->pathName, TCL_STATIC);
}
return TCL_OK;
}
/*
* If invoked with a single argument beginning with "." then focus on that
* window.
*/
if (objc == 2) {
windowName = Tcl_GetString(objv[1]);
/*
* The empty string case exists for backwards compatibility.
*/
if (windowName[0] == '\0') {
return TCL_OK;
}
if (windowName[0] == '.') {
newPtr = (TkWindow *) Tk_NameToWindow(interp, windowName, tkwin);
if (newPtr == NULL) {
return TCL_ERROR;
}
if (!(newPtr->flags & TK_ALREADY_DEAD)) {
TkSetFocusWin(newPtr, 0);
}
return TCL_OK;
}
}
/*
* We have a subcommand to parse and act upon.
*/
if (Tcl_GetIndexFromObj(interp, objv[1], focusOptions, "option", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "window");
return TCL_ERROR;
}
switch (index) {
case 0: /* -displayof */
windowName = Tcl_GetString(objv[2]);
newPtr = (TkWindow *) Tk_NameToWindow(interp, windowName, tkwin);
if (newPtr == NULL) {
return TCL_ERROR;
}
newPtr = TkGetFocusWin(newPtr);
if (newPtr != NULL) {
Tcl_SetResult(interp, newPtr->pathName, TCL_STATIC);
}
break;
case 1: /* -force */
windowName = Tcl_GetString(objv[2]);
/*
* The empty string case exists for backwards compatibility.
*/
if (windowName[0] == '\0') {
return TCL_OK;
}
newPtr = (TkWindow *) Tk_NameToWindow(interp, windowName, tkwin);
if (newPtr == NULL) {
return TCL_ERROR;
}
TkSetFocusWin(newPtr, 1);
break;
case 2: /* -lastfor */
windowName = Tcl_GetString(objv[2]);
newPtr = (TkWindow *) Tk_NameToWindow(interp, windowName, tkwin);
if (newPtr == NULL) {
return TCL_ERROR;
}
for (topLevelPtr = newPtr; topLevelPtr != NULL;
topLevelPtr = topLevelPtr->parentPtr) {
if (!(topLevelPtr->flags & TK_TOP_HIERARCHY)) {
continue;
}
for (tlFocusPtr = newPtr->mainPtr->tlFocusPtr; tlFocusPtr != NULL;
tlFocusPtr = tlFocusPtr->nextPtr) {
if (tlFocusPtr->topLevelPtr == topLevelPtr) {
Tcl_SetResult(interp,
tlFocusPtr->focusWinPtr->pathName, TCL_STATIC);
return TCL_OK;
}
}
Tcl_SetResult(interp, topLevelPtr->pathName, TCL_STATIC);
return TCL_OK;
}
break;
default:
Tcl_Panic("bad const entries to focusOptions in focus command");
}
return TCL_OK;
}
static int
winprint_page_setup_command (ClientData cd, Tcl_Interp *interp, int argc,
char **argv)
{
struct winprint_data *wd = (struct winprint_data *) cd;
Tk_Window parent;
int i, mode, ret;
PAGESETUPDLG psd;
parent = Tk_MainWindow (interp);
for (i = 2; i < argc; i += 2)
{
if (i + 1 >= argc)
{
Tcl_ResetResult (interp);
Tcl_AppendStringsToObj (Tcl_GetObjResult (interp),
"value for \"", argv[i], "\" missing",
(char *) NULL);
return TCL_ERROR;
}
if (strcmp (argv[i], "-parent") == 0)
{
parent = Tk_NameToWindow (interp, argv[i + 1],
Tk_MainWindow (interp));
if (parent == NULL)
return TCL_ERROR;
}
else
{
Tcl_ResetResult (interp);
Tcl_AppendStringsToObj (Tcl_GetObjResult (interp),
"unknown option \"", argv[i], "\"",
(char *) NULL);
return TCL_ERROR;
}
}
if (wd->page_setup != NULL)
psd = *wd->page_setup;
else
{
memset (&psd, 0, sizeof (PAGESETUPDLG));
psd.lStructSize = sizeof (PAGESETUPDLG);
psd.Flags = PSD_DEFAULTMINMARGINS;
}
if (Tk_WindowId (parent) == None)
Tk_MakeWindowExist (parent);
psd.hwndOwner = Tk_GetHWND (Tk_WindowId (parent));
mode = Tcl_SetServiceMode (TCL_SERVICE_ALL);
ret = PageSetupDlg (&psd);
(void) Tcl_SetServiceMode (mode);
if (! ret)
{
DWORD code;
code = CommDlgExtendedError ();
if (code == 0)
{
/* The user pressed cancel. */
return TCL_OK;
}
else
{
char buf[20];
sprintf (buf, "0x%lx", (unsigned long) code);
Tcl_ResetResult (interp);
Tcl_AppendStringsToObj (Tcl_GetObjResult (interp),
"Windows common dialog error ", buf,
(char *) NULL);
return TCL_ERROR;
}
}
if (wd->page_setup == NULL)
wd->page_setup = (PAGESETUPDLG *) ckalloc (sizeof (PAGESETUPDLG));
*wd->page_setup = psd;
return TCL_OK;
}
static void
FlashProc (ClientData clientData)
{
Tcl_Interp *interp = (Tcl_Interp *) clientData;
Tki_Object *object;
char *color;
FlashItem *p;
int max = 0;
Tk_Window window;
Tk_Window tkwin = Tk_MainWindow(interp);
for (p = flashList; p != NULL; p = p->nextPtr) {
if (p->id == NULL) continue;
object = Tki_LookupObject (p->id);
if (object == NULL) continue;
window = Tk_NameToWindow(interp, object->editor->toplevel, tkwin);
if (! window) {
continue;
}
if (! object->editor->color) {
if ((object->flash) % 2) {
color = "black";
} else {
color = "white";
}
} else {
color = object->color;
if ((object->flash) % 2) {
if (strcasecmp(color, "white") == 0) color = "black";
} else {
color = "white";
}
}
Tcl_VarEval (interp, type_to_string (object->type),
"__color ", object->id, " ", color,
(char *) NULL);
#if 1
if (object->editor) {
Tki_EditorAttribute(object->editor, interp, 1, &flashIcon);
const char *tresult = Tcl_GetStringResult(interp);
if ((*tresult != '\0') &&
(strcmp(tresult, "yes") == 0
|| strcmp(tresult, "true") == 0
|| strcmp(tresult, "on") == 0
|| strcmp(tresult, "1") == 0)) {
char *buf = (object->flash % 2) ? "icon" : "noicon";
Tcl_VarEval(interp, "if ![winfo ismapped ",
object->editor->toplevel,
"] {", "wm iconbitmap ", object->editor->toplevel,
" ", buf, "}", (char *) NULL);
}
}
#endif
object->flash -= 1;
if (object->flash == 0) {
TkiNoTrace (m_color, interp, object, 1, &object->color);
ckfree (p->id);
p->id = NULL;
}
max = ( object->flash > max ) ? object->flash : max;
}
if (max <= 0) { /* everything is done - remove the flashList */
FlashItem *q;
for (p = flashList; p != NULL; p = q) {
q = p->nextPtr;
if (p->id != NULL) ckfree (p->id);
ckfree ((char *) p);
}
flashList = NULL;
}
Tcl_Eval (interp, "update");
if (max > 0) {
Tk_CreateTimerHandler (500, FlashProc, (ClientData) interp);
}
}
static int
winprint_print_text_dialog (struct winprint_data *wd, Tcl_Interp *interp,
const struct print_text_options *pto,
PRINTDLG *pd, int *cancelled)
{
int mode, ret;
*cancelled = 0;
memset (pd, 0, sizeof (PRINTDLG));
pd->lStructSize = sizeof (PRINTDLG);
if (! pto->dialog)
pd->Flags = PD_RETURNDEFAULT | PD_RETURNDC;
else
{
Tk_Window parent;
if (pto->parent == NULL)
parent = Tk_MainWindow (interp);
else
{
parent = Tk_NameToWindow (interp, pto->parent,
Tk_MainWindow (interp));
if (parent == NULL)
return TCL_ERROR;
}
if (Tk_WindowId (parent) == None)
Tk_MakeWindowExist (parent);
pd->hwndOwner = Tk_GetHWND (Tk_WindowId (parent));
if (wd->page_setup != NULL)
{
pd->hDevMode = wd->page_setup->hDevMode;
pd->hDevNames = wd->page_setup->hDevNames;
}
pd->Flags = PD_NOSELECTION | PD_RETURNDC | PD_USEDEVMODECOPIES;
pd->nCopies = 1;
pd->nFromPage = 1;
pd->nToPage = 1;
pd->nMinPage = 1;
pd->nMaxPage = 0xffff;
}
mode = Tcl_SetServiceMode (TCL_SERVICE_ALL);
ret = PrintDlg (pd);
(void) Tcl_SetServiceMode (mode);
if (! ret)
{
DWORD code;
code = CommDlgExtendedError ();
/* For some errors, the print dialog will already have reported
an error. We treat those as though the user pressed cancel.
Unfortunately, I do not know just which errors those are. */
if (code == 0 || code == PDERR_NODEFAULTPRN)
{
*cancelled = 1;
return TCL_OK;
}
else
{
char buf[20];
sprintf (buf, "0x%lx", (unsigned long) code);
Tcl_ResetResult (interp);
Tcl_AppendStringsToObj (Tcl_GetObjResult (interp),
"Windows common dialog error ", buf,
(char *) NULL);
return TCL_ERROR;
}
}
return TCL_OK;
}
int
Tk_ClipboardObjCmd(
ClientData clientData, /* Main window associated with interpreter. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument strings. */
{
Tk_Window tkwin = (Tk_Window) clientData;
const char *path = NULL;
Atom selection;
static const char *const optionStrings[] = { "append", "clear", "get", NULL };
enum options { CLIPBOARD_APPEND, CLIPBOARD_CLEAR, CLIPBOARD_GET };
int index, i;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum options) index) {
case CLIPBOARD_APPEND: {
Atom target, format;
const char *targetName = NULL;
const char *formatName = NULL;
const char *string;
static const char *const appendOptionStrings[] = {
"-displayof", "-format", "-type", NULL
};
enum appendOptions { APPEND_DISPLAYOF, APPEND_FORMAT, APPEND_TYPE };
int subIndex, length;
for (i = 2; i < objc - 1; i++) {
string = Tcl_GetStringFromObj(objv[i], &length);
if (string[0] != '-') {
break;
}
/*
* If the argument is "--", it signifies the end of arguments.
*/
if (string[1] == '-' && length == 2) {
i++;
break;
}
if (Tcl_GetIndexFromObj(interp, objv[i], appendOptionStrings,
"option", 0, &subIndex) != TCL_OK) {
return TCL_ERROR;
}
/*
* Increment i so that it points to the value for the flag instead
* of the flag itself.
*/
i++;
if (i >= objc) {
Tcl_AppendResult(interp, "value for \"", string,
"\" missing", NULL);
return TCL_ERROR;
}
switch ((enum appendOptions) subIndex) {
case APPEND_DISPLAYOF:
path = Tcl_GetString(objv[i]);
break;
case APPEND_FORMAT:
formatName = Tcl_GetString(objv[i]);
break;
case APPEND_TYPE:
targetName = Tcl_GetString(objv[i]);
break;
}
}
if (objc - i != 1) {
Tcl_WrongNumArgs(interp, 2, objv, "?-option value ...? data");
return TCL_ERROR;
}
if (path != NULL) {
tkwin = Tk_NameToWindow(interp, path, tkwin);
}
if (tkwin == NULL) {
return TCL_ERROR;
}
if (targetName != NULL) {
target = Tk_InternAtom(tkwin, targetName);
} else {
target = XA_STRING;
}
if (formatName != NULL) {
format = Tk_InternAtom(tkwin, formatName);
} else {
format = XA_STRING;
}
return Tk_ClipboardAppend(interp, tkwin, target, format,
Tcl_GetString(objv[i]));
}
case CLIPBOARD_CLEAR: {
static const char *const clearOptionStrings[] = { "-displayof", NULL };
enum clearOptions { CLEAR_DISPLAYOF };
int subIndex;
if (objc != 2 && objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, "?-displayof window?");
return TCL_ERROR;
}
if (objc == 4) {
if (Tcl_GetIndexFromObj(interp, objv[2], clearOptionStrings,
"option", 0, &subIndex) != TCL_OK) {
return TCL_ERROR;
}
if ((enum clearOptions) subIndex == CLEAR_DISPLAYOF) {
path = Tcl_GetString(objv[3]);
}
}
if (path != NULL) {
tkwin = Tk_NameToWindow(interp, path, tkwin);
}
if (tkwin == NULL) {
return TCL_ERROR;
}
return Tk_ClipboardClear(interp, tkwin);
}
case CLIPBOARD_GET: {
Atom target;
const char *targetName = NULL;
Tcl_DString selBytes;
int result;
const char *string;
static const char *const getOptionStrings[] = {
"-displayof", "-type", NULL
};
enum getOptions { APPEND_DISPLAYOF, APPEND_TYPE };
int subIndex;
for (i = 2; i < objc; i++) {
string = Tcl_GetString(objv[i]);
if (string[0] != '-') {
break;
}
if (Tcl_GetIndexFromObj(interp, objv[i], getOptionStrings,
"option", 0, &subIndex) != TCL_OK) {
return TCL_ERROR;
}
i++;
if (i >= objc) {
Tcl_AppendResult(interp, "value for \"", string,
"\" missing", NULL);
return TCL_ERROR;
}
switch ((enum getOptions) subIndex) {
case APPEND_DISPLAYOF:
path = Tcl_GetString(objv[i]);
break;
case APPEND_TYPE:
targetName = Tcl_GetString(objv[i]);
break;
}
}
if (path != NULL) {
tkwin = Tk_NameToWindow(interp, path, tkwin);
}
if (tkwin == NULL) {
return TCL_ERROR;
}
selection = Tk_InternAtom(tkwin, "CLIPBOARD");
if (objc - i > 1) {
Tcl_WrongNumArgs(interp, 2, objv, "?-option value ...?");
return TCL_ERROR;
} else if (objc - i == 1) {
target = Tk_InternAtom(tkwin, Tcl_GetString(objv[i]));
} else if (targetName != NULL) {
target = Tk_InternAtom(tkwin, targetName);
} else {
target = XA_STRING;
}
Tcl_DStringInit(&selBytes);
result = Tk_GetSelection(interp, tkwin, selection, target,
ClipboardGetProc, &selBytes);
if (result == TCL_OK) {
Tcl_DStringResult(interp, &selBytes);
} else {
Tcl_DStringFree(&selBytes);
}
return result;
}
}
return TCL_OK;
}
