/[dtapublic]/projs/dtats/trunk/shared_source/c_tcl_base_7_5_w_mods/tclwindde.c
ViewVC logotype

Contents of /projs/dtats/trunk/shared_source/c_tcl_base_7_5_w_mods/tclwindde.c

Parent Directory Parent Directory | Revision Log Revision Log


Revision 98 - (show annotations) (download)
Sun Dec 18 00:57:31 2016 UTC (7 years, 9 months ago) by dashley
File MIME type: text/plain
File size: 37200 byte(s)
Reorganization.
1 /* $Header$ */
2 /*
3 * tclWinDde.c --
4 *
5 * This file provides procedures that implement the "send"
6 * command, allowing commands to be passed from interpreter
7 * to interpreter.
8 *
9 * Copyright (c) 1997 by Sun Microsystems, Inc.
10 *
11 * See the file "license.terms" for information on usage and redistribution
12 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
13 *
14 * RCS: @(#) $Id: tclwindde.c,v 1.1.1.1 2001/06/13 04:48:43 dtashley Exp $
15 */
16
17 #include "tclPort.h"
18 #include <ddeml.h>
19
20 /*
21 * TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the
22 * Registry_Init declaration is in the source file itself, which is only
23 * accessed when we are building a library.
24 */
25
26 #undef TCL_STORAGE_CLASS
27 #define TCL_STORAGE_CLASS DLLEXPORT
28
29 /*
30 * The following structure is used to keep track of the interpreters
31 * registered by this process.
32 */
33
34 typedef struct RegisteredInterp {
35 struct RegisteredInterp *nextPtr;
36 /* The next interp this application knows
37 * about. */
38 char *name; /* Interpreter's name (malloc-ed). */
39 Tcl_Interp *interp; /* The interpreter attached to this name. */
40 } RegisteredInterp;
41
42 /*
43 * Used to keep track of conversations.
44 */
45
46 typedef struct Conversation {
47 struct Conversation *nextPtr;
48 /* The next conversation in the list. */
49 RegisteredInterp *riPtr; /* The info we know about the conversation. */
50 HCONV hConv; /* The DDE handle for this conversation. */
51 Tcl_Obj *returnPackagePtr; /* The result package for this conversation. */
52 } Conversation;
53
54 typedef struct ThreadSpecificData {
55 Conversation *currentConversations;
56 /* A list of conversations currently
57 * being processed. */
58 RegisteredInterp *interpListPtr;
59 /* List of all interpreters registered
60 * in the current process. */
61 } ThreadSpecificData;
62 static Tcl_ThreadDataKey dataKey;
63
64 /*
65 * The following variables cannot be placed in thread-local storage.
66 * The Mutex ddeMutex guards access to the ddeInstance.
67 */
68 static HSZ ddeServiceGlobal = 0;
69 static DWORD ddeInstance; /* The application instance handle given
70 * to us by DdeInitialize. */
71 static int ddeIsServer = 0;
72
73 #define TCL_DDE_VERSION "1.1"
74 #define TCL_DDE_PACKAGE_NAME "dde"
75 #define TCL_DDE_SERVICE_NAME "TclEval"
76
77 TCL_DECLARE_MUTEX(ddeMutex)
78
79 /*
80 * Forward declarations for procedures defined later in this file.
81 */
82
83 static void DdeExitProc _ANSI_ARGS_((ClientData clientData));
84 static void DeleteProc _ANSI_ARGS_((ClientData clientData));
85 static Tcl_Obj * ExecuteRemoteObject _ANSI_ARGS_((
86 RegisteredInterp *riPtr,
87 Tcl_Obj *ddeObjectPtr));
88 static int MakeDdeConnection _ANSI_ARGS_((Tcl_Interp *interp,
89 char *name, HCONV *ddeConvPtr));
90 static HDDEDATA CALLBACK DdeServerProc _ANSI_ARGS_((UINT uType,
91 UINT uFmt, HCONV hConv, HSZ ddeTopic,
92 HSZ ddeItem, HDDEDATA hData, DWORD dwData1,
93 DWORD dwData2));
94 static void SetDdeError _ANSI_ARGS_((Tcl_Interp *interp));
95 int Tcl_DdeObjCmd(ClientData clientData, /* Used only for deletion */
96 Tcl_Interp *interp, /* The interp we are sending from */
97 int objc, /* Number of arguments */
98 Tcl_Obj *CONST objv[]); /* The arguments */
99
100 EXTERN int Dde_Init(Tcl_Interp *interp);
101
102 /*
103 *----------------------------------------------------------------------
104 *
105 * Dde_Init --
106 *
107 * This procedure initializes the dde command.
108 *
109 * Results:
110 * A standard Tcl result.
111 *
112 * Side effects:
113 * None.
114 *
115 *----------------------------------------------------------------------
116 */
117
118 int
119 Dde_Init(
120 Tcl_Interp *interp)
121 {
122 ThreadSpecificData *tsdPtr;
123
124 if (!Tcl_InitStubs(interp, "8.0", 0)) {
125 return TCL_ERROR;
126 }
127
128 Tcl_CreateObjCommand(interp, "dde", Tcl_DdeObjCmd, NULL, NULL);
129
130 tsdPtr = (ThreadSpecificData *)
131 Tcl_GetThreadData((Tcl_ThreadDataKey *) &dataKey, sizeof(ThreadSpecificData));
132
133 if (tsdPtr == NULL) {
134 tsdPtr = TCL_TSD_INIT(&dataKey);
135 tsdPtr->currentConversations = NULL;
136 tsdPtr->interpListPtr = NULL;
137 }
138 Tcl_CreateExitHandler(DdeExitProc, NULL);
139
140 return Tcl_PkgProvide(interp, TCL_DDE_PACKAGE_NAME, TCL_DDE_VERSION);
141 }
142
143
144 /*
145 *----------------------------------------------------------------------
146 *
147 * Initialize --
148 *
149 * Initialize the global DDE instance.
150 *
151 * Results:
152 * None.
153 *
154 * Side effects:
155 * Registers the DDE server proc.
156 *
157 *----------------------------------------------------------------------
158 */
159
160 static void
161 Initialize(void)
162 {
163 int nameFound = 0;
164 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
165
166 /*
167 * See if the application is already registered; if so, remove its
168 * current name from the registry. The deletion of the command
169 * will take care of disposing of this entry.
170 */
171
172 if (tsdPtr->interpListPtr != NULL) {
173 nameFound = 1;
174 }
175
176 /*
177 * Make sure that the DDE server is there. This is done only once,
178 * add an exit handler tear it down.
179 */
180
181 if (ddeInstance == 0) {
182 Tcl_MutexLock(&ddeMutex);
183 if (ddeInstance == 0) {
184 if (DdeInitialize(&ddeInstance, DdeServerProc,
185 CBF_SKIP_REGISTRATIONS
186 | CBF_SKIP_UNREGISTRATIONS
187 | CBF_FAIL_POKES, 0)
188 != DMLERR_NO_ERROR) {
189 ddeInstance = 0;
190 }
191 }
192 Tcl_MutexUnlock(&ddeMutex);
193 }
194 if ((ddeServiceGlobal == 0) && (nameFound != 0)) {
195 Tcl_MutexLock(&ddeMutex);
196 if ((ddeServiceGlobal == 0) && (nameFound != 0)) {
197 ddeIsServer = 1;
198 Tcl_CreateExitHandler(DdeExitProc, NULL);
199 ddeServiceGlobal = DdeCreateStringHandle(ddeInstance, \
200 TCL_DDE_SERVICE_NAME, 0);
201 DdeNameService(ddeInstance, ddeServiceGlobal, 0L, DNS_REGISTER);
202 } else {
203 ddeIsServer = 0;
204 }
205 Tcl_MutexUnlock(&ddeMutex);
206 }
207 }
208
209 /*
210 *--------------------------------------------------------------
211 *
212 * DdeSetServerName --
213 *
214 * This procedure is called to associate an ASCII name with a Dde
215 * server. If the interpreter has already been named, the
216 * name replaces the old one.
217 *
218 * Results:
219 * The return value is the name actually given to the interp.
220 * This will normally be the same as name, but if name was already
221 * in use for a Dde Server then a name of the form "name #2" will
222 * be chosen, with a high enough number to make the name unique.
223 *
224 * Side effects:
225 * Registration info is saved, thereby allowing the "send" command
226 * to be used later to invoke commands in the application. In
227 * addition, the "send" command is created in the application's
228 * interpreter. The registration will be removed automatically
229 * if the interpreter is deleted or the "send" command is removed.
230 *
231 *--------------------------------------------------------------
232 */
233
234 static char *
235 DdeSetServerName(
236 Tcl_Interp *interp,
237 char *name /* The name that will be used to
238 * refer to the interpreter in later
239 * "send" commands. Must be globally
240 * unique. */
241 )
242 {
243 int suffix, offset;
244 RegisteredInterp *riPtr, *prevPtr;
245 Tcl_DString dString;
246 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
247
248 /*
249 * See if the application is already registered; if so, remove its
250 * current name from the registry. The deletion of the command
251 * will take care of disposing of this entry.
252 */
253
254 for (riPtr = tsdPtr->interpListPtr, prevPtr = NULL; riPtr != NULL;
255 prevPtr = riPtr, riPtr = riPtr->nextPtr) {
256 if (riPtr->interp == interp) {
257 if (name != NULL) {
258 if (prevPtr == NULL) {
259 tsdPtr->interpListPtr = tsdPtr->interpListPtr->nextPtr;
260 } else {
261 prevPtr->nextPtr = riPtr->nextPtr;
262 }
263 break;
264 } else {
265 /*
266 * the name was NULL, so the caller is asking for
267 * the name of the current interp.
268 */
269
270 return riPtr->name;
271 }
272 }
273 }
274
275 if (name == NULL) {
276 /*
277 * the name was NULL, so the caller is asking for
278 * the name of the current interp, but it doesn't
279 * have a name.
280 */
281
282 return "";
283 }
284
285 /*
286 * Pick a name to use for the application. Use "name" if it's not
287 * already in use. Otherwise add a suffix such as " #2", trying
288 * larger and larger numbers until we eventually find one that is
289 * unique.
290 */
291
292 suffix = 1;
293 offset = 0;
294 Tcl_DStringInit(&dString);
295
296 /*
297 * We have found a unique name. Now add it to the registry.
298 */
299
300 riPtr = (RegisteredInterp *) ckalloc(sizeof(RegisteredInterp));
301 riPtr->interp = interp;
302 riPtr->name = ckalloc(strlen(name) + 1);
303 riPtr->nextPtr = tsdPtr->interpListPtr;
304 tsdPtr->interpListPtr = riPtr;
305 strcpy(riPtr->name, name);
306
307 Tcl_CreateObjCommand(interp, "dde", Tcl_DdeObjCmd,
308 (ClientData) riPtr, DeleteProc);
309 if (Tcl_IsSafe(interp)) {
310 Tcl_HideCommand(interp, "dde", "dde");
311 }
312 Tcl_DStringFree(&dString);
313
314 /*
315 * re-initialize with the new name
316 */
317 Initialize();
318
319 return riPtr->name;
320 }
321
322 /*
323 *--------------------------------------------------------------
324 *
325 * DeleteProc
326 *
327 * This procedure is called when the command "dde" is destroyed.
328 *
329 * Results:
330 * none
331 *
332 * Side effects:
333 * The interpreter given by riPtr is unregistered.
334 *
335 *--------------------------------------------------------------
336 */
337
338 static void
339 DeleteProc(clientData)
340 ClientData clientData; /* The interp we are deleting passed
341 * as ClientData. */
342 {
343 RegisteredInterp *riPtr = (RegisteredInterp *) clientData;
344 RegisteredInterp *searchPtr, *prevPtr;
345 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
346
347 for (searchPtr = tsdPtr->interpListPtr, prevPtr = NULL;
348 (searchPtr != NULL) && (searchPtr != riPtr);
349 prevPtr = searchPtr, searchPtr = searchPtr->nextPtr) {
350 /*
351 * Empty loop body.
352 */
353 }
354
355 if (searchPtr != NULL) {
356 if (prevPtr == NULL) {
357 tsdPtr->interpListPtr = tsdPtr->interpListPtr->nextPtr;
358 } else {
359 prevPtr->nextPtr = searchPtr->nextPtr;
360 }
361 }
362 ckfree(riPtr->name);
363 Tcl_EventuallyFree(clientData, TCL_DYNAMIC);
364 }
365
366 /*
367 *--------------------------------------------------------------
368 *
369 * ExecuteRemoteObject --
370 *
371 * Takes the package delivered by DDE and executes it in
372 * the server's interpreter.
373 *
374 * Results:
375 * A list Tcl_Obj * that describes what happened. The first
376 * element is the numerical return code (TCL_ERROR, etc.).
377 * The second element is the result of the script. If the
378 * return result was TCL_ERROR, then the third element
379 * will be the value of the global "errorCode", and the
380 * fourth will be the value of the global "errorInfo".
381 * The return result will have a refCount of 0.
382 *
383 * Side effects:
384 * A Tcl script is run, which can cause all kinds of other
385 * things to happen.
386 *
387 *--------------------------------------------------------------
388 */
389
390 static Tcl_Obj *
391 ExecuteRemoteObject(
392 RegisteredInterp *riPtr, /* Info about this server. */
393 Tcl_Obj *ddeObjectPtr) /* The object to execute. */
394 {
395 Tcl_Obj *errorObjPtr;
396 Tcl_Obj *returnPackagePtr;
397 int result;
398
399 result = Tcl_EvalObjEx(riPtr->interp, ddeObjectPtr, TCL_EVAL_GLOBAL);
400 returnPackagePtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
401 Tcl_ListObjAppendElement(NULL, returnPackagePtr,
402 Tcl_NewIntObj(result));
403 Tcl_ListObjAppendElement(NULL, returnPackagePtr,
404 Tcl_GetObjResult(riPtr->interp));
405 if (result == TCL_ERROR) {
406 errorObjPtr = Tcl_GetVar2Ex(riPtr->interp, "errorCode", NULL,
407 TCL_GLOBAL_ONLY);
408 Tcl_ListObjAppendElement(NULL, returnPackagePtr, errorObjPtr);
409 errorObjPtr = Tcl_GetVar2Ex(riPtr->interp, "errorInfo", NULL,
410 TCL_GLOBAL_ONLY);
411 Tcl_ListObjAppendElement(NULL, returnPackagePtr, errorObjPtr);
412 }
413
414 return returnPackagePtr;
415 }
416
417 /*
418 *--------------------------------------------------------------
419 *
420 * DdeServerProc --
421 *
422 * Handles all transactions for this server. Can handle
423 * execute, request, and connect protocols. Dde will
424 * call this routine when a client attempts to run a dde
425 * command using this server.
426 *
427 * Results:
428 * A DDE Handle with the result of the dde command.
429 *
430 * Side effects:
431 * Depending on which command is executed, arbitrary
432 * Tcl scripts can be run.
433 *
434 *--------------------------------------------------------------
435 */
436
437 static HDDEDATA CALLBACK
438 DdeServerProc (
439 UINT uType, /* The type of DDE transaction we
440 * are performing. */
441 UINT uFmt, /* The format that data is sent or
442 * received. */
443 HCONV hConv, /* The conversation associated with the
444 * current transaction. */
445 HSZ ddeTopic, /* A string handle. Transaction-type
446 * dependent. */
447 HSZ ddeItem, /* A string handle. Transaction-type
448 * dependent. */
449 HDDEDATA hData, /* DDE data. Transaction-type dependent. */
450 DWORD dwData1, /* Transaction-dependent data. */
451 DWORD dwData2) /* Transaction-dependent data. */
452 {
453 Tcl_DString dString;
454 int len;
455 char *utilString;
456 Tcl_Obj *ddeObjectPtr;
457 HDDEDATA ddeReturn = NULL;
458 RegisteredInterp *riPtr;
459 Conversation *convPtr, *prevConvPtr;
460 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
461
462 switch(uType) {
463 case XTYP_CONNECT:
464
465 /*
466 * Dde is trying to initialize a conversation with us. Check
467 * and make sure we have a valid topic.
468 */
469
470 len = DdeQueryString(ddeInstance, ddeTopic, NULL, 0, 0);
471 Tcl_DStringInit(&dString);
472 Tcl_DStringSetLength(&dString, len);
473 utilString = Tcl_DStringValue(&dString);
474 DdeQueryString(ddeInstance, ddeTopic, utilString, len + 1,
475 CP_WINANSI);
476
477 for (riPtr = tsdPtr->interpListPtr; riPtr != NULL;
478 riPtr = riPtr->nextPtr) {
479 if (stricmp(utilString, riPtr->name) == 0) {
480 Tcl_DStringFree(&dString);
481 return (HDDEDATA) TRUE;
482 }
483 }
484
485 Tcl_DStringFree(&dString);
486 return (HDDEDATA) FALSE;
487
488 case XTYP_CONNECT_CONFIRM:
489
490 /*
491 * Dde has decided that we can connect, so it gives us a
492 * conversation handle. We need to keep track of it
493 * so we know which execution result to return in an
494 * XTYP_REQUEST.
495 */
496
497 len = DdeQueryString(ddeInstance, ddeTopic, NULL, 0, 0);
498 Tcl_DStringInit(&dString);
499 Tcl_DStringSetLength(&dString, len);
500 utilString = Tcl_DStringValue(&dString);
501 DdeQueryString(ddeInstance, ddeTopic, utilString, len + 1,
502 CP_WINANSI);
503 for (riPtr = tsdPtr->interpListPtr; riPtr != NULL;
504 riPtr = riPtr->nextPtr) {
505 if (stricmp(riPtr->name, utilString) == 0) {
506 convPtr = (Conversation *) ckalloc(sizeof(Conversation));
507 convPtr->nextPtr = tsdPtr->currentConversations;
508 convPtr->returnPackagePtr = NULL;
509 convPtr->hConv = hConv;
510 convPtr->riPtr = riPtr;
511 tsdPtr->currentConversations = convPtr;
512 break;
513 }
514 }
515 Tcl_DStringFree(&dString);
516 return (HDDEDATA) TRUE;
517
518 case XTYP_DISCONNECT:
519
520 /*
521 * The client has disconnected from our server. Forget this
522 * conversation.
523 */
524
525 for (convPtr = tsdPtr->currentConversations, prevConvPtr = NULL;
526 convPtr != NULL;
527 prevConvPtr = convPtr, convPtr = convPtr->nextPtr) {
528 if (hConv == convPtr->hConv) {
529 if (prevConvPtr == NULL) {
530 tsdPtr->currentConversations = convPtr->nextPtr;
531 } else {
532 prevConvPtr->nextPtr = convPtr->nextPtr;
533 }
534 if (convPtr->returnPackagePtr != NULL) {
535 Tcl_DecrRefCount(convPtr->returnPackagePtr);
536 }
537 ckfree((char *) convPtr);
538 break;
539 }
540 }
541 return (HDDEDATA) TRUE;
542
543 case XTYP_REQUEST:
544
545 /*
546 * This could be either a request for a value of a Tcl variable,
547 * or it could be the send command requesting the results of the
548 * last execute.
549 */
550
551 if (uFmt != CF_TEXT) {
552 return (HDDEDATA) FALSE;
553 }
554
555 ddeReturn = (HDDEDATA) FALSE;
556 for (convPtr = tsdPtr->currentConversations; (convPtr != NULL)
557 && (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) {
558 /*
559 * Empty loop body.
560 */
561 }
562
563 if (convPtr != NULL) {
564 char *returnString;
565
566 len = DdeQueryString(ddeInstance, ddeItem, NULL, 0,
567 CP_WINANSI);
568 Tcl_DStringInit(&dString);
569 Tcl_DStringSetLength(&dString, len);
570 utilString = Tcl_DStringValue(&dString);
571 DdeQueryString(ddeInstance, ddeItem, utilString,
572 len + 1, CP_WINANSI);
573 if (stricmp(utilString, "$TCLEVAL$EXECUTE$RESULT") == 0) {
574 returnString =
575 Tcl_GetStringFromObj(convPtr->returnPackagePtr, &len);
576 ddeReturn = DdeCreateDataHandle(ddeInstance,
577 returnString, len+1, 0, ddeItem, CF_TEXT,
578 0);
579 } else {
580 Tcl_Obj *variableObjPtr = Tcl_GetVar2Ex(
581 convPtr->riPtr->interp, utilString, NULL,
582 TCL_GLOBAL_ONLY);
583 if (variableObjPtr != NULL) {
584 returnString = Tcl_GetStringFromObj(variableObjPtr,
585 &len);
586 ddeReturn = DdeCreateDataHandle(ddeInstance,
587 returnString, len+1, 0, ddeItem, CF_TEXT, 0);
588 } else {
589 ddeReturn = NULL;
590 }
591 }
592 Tcl_DStringFree(&dString);
593 }
594 return ddeReturn;
595
596 case XTYP_EXECUTE: {
597
598 /*
599 * Execute this script. The results will be saved into
600 * a list object which will be retreived later. See
601 * ExecuteRemoteObject.
602 */
603
604 Tcl_Obj *returnPackagePtr;
605
606 for (convPtr = tsdPtr->currentConversations; (convPtr != NULL)
607 && (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) {
608 /*
609 * Empty loop body.
610 */
611
612 }
613
614 if (convPtr == NULL) {
615 return (HDDEDATA) DDE_FNOTPROCESSED;
616 }
617
618 utilString = (char *) DdeAccessData(hData, &len);
619 ddeObjectPtr = Tcl_NewStringObj(utilString, -1);
620 Tcl_IncrRefCount(ddeObjectPtr);
621 DdeUnaccessData(hData);
622 if (convPtr->returnPackagePtr != NULL) {
623 Tcl_DecrRefCount(convPtr->returnPackagePtr);
624 }
625 convPtr->returnPackagePtr = NULL;
626 returnPackagePtr =
627 ExecuteRemoteObject(convPtr->riPtr, ddeObjectPtr);
628 for (convPtr = tsdPtr->currentConversations; (convPtr != NULL)
629 && (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) {
630 /*
631 * Empty loop body.
632 */
633
634 }
635 if (convPtr != NULL) {
636 Tcl_IncrRefCount(returnPackagePtr);
637 convPtr->returnPackagePtr = returnPackagePtr;
638 }
639 Tcl_DecrRefCount(ddeObjectPtr);
640 if (returnPackagePtr == NULL) {
641 return (HDDEDATA) DDE_FNOTPROCESSED;
642 } else {
643 return (HDDEDATA) DDE_FACK;
644 }
645 }
646
647 case XTYP_WILDCONNECT: {
648
649 /*
650 * Dde wants a list of services and topics that we support.
651 */
652
653 HSZPAIR *returnPtr;
654 int i;
655 int numItems;
656
657 for (i = 0, riPtr = tsdPtr->interpListPtr; riPtr != NULL;
658 i++, riPtr = riPtr->nextPtr) {
659 /*
660 * Empty loop body.
661 */
662
663 }
664
665 numItems = i;
666 ddeReturn = DdeCreateDataHandle(ddeInstance, NULL,
667 (numItems + 1) * sizeof(HSZPAIR), 0, 0, 0, 0);
668 returnPtr = (HSZPAIR *) DdeAccessData(ddeReturn, &len);
669 for (i = 0, riPtr = tsdPtr->interpListPtr; i < numItems;
670 i++, riPtr = riPtr->nextPtr) {
671 returnPtr[i].hszSvc = DdeCreateStringHandle(
672 ddeInstance, "TclEval", CP_WINANSI);
673 returnPtr[i].hszTopic = DdeCreateStringHandle(
674 ddeInstance, riPtr->name, CP_WINANSI);
675 }
676 returnPtr[i].hszSvc = NULL;
677 returnPtr[i].hszTopic = NULL;
678 DdeUnaccessData(ddeReturn);
679 return ddeReturn;
680 }
681
682 }
683 return NULL;
684 }
685
686 /*
687 *--------------------------------------------------------------
688 *
689 * DdeExitProc --
690 *
691 * Gets rid of our DDE server when we go away.
692 *
693 * Results:
694 * None.
695 *
696 * Side effects:
697 * The DDE server is deleted.
698 *
699 *--------------------------------------------------------------
700 */
701
702 static void
703 DdeExitProc(
704 ClientData clientData) /* Not used in this handler. */
705 {
706 DdeNameService(ddeInstance, NULL, 0, DNS_UNREGISTER);
707 DdeUninitialize(ddeInstance);
708 ddeInstance = 0;
709 }
710
711 /*
712 *--------------------------------------------------------------
713 *
714 * MakeDdeConnection --
715 *
716 * This procedure is a utility used to connect to a DDE
717 * server when given a server name and a topic name.
718 *
719 * Results:
720 * A standard Tcl result.
721 *
722 *
723 * Side effects:
724 * Passes back a conversation through ddeConvPtr
725 *
726 *--------------------------------------------------------------
727 */
728
729 static int
730 MakeDdeConnection(
731 Tcl_Interp *interp, /* Used to report errors. */
732 char *name, /* The connection to use. */
733 HCONV *ddeConvPtr)
734 {
735 HSZ ddeTopic, ddeService;
736 HCONV ddeConv;
737 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
738
739 ddeService = DdeCreateStringHandle(ddeInstance, "TclEval", 0);
740 ddeTopic = DdeCreateStringHandle(ddeInstance, name, 0);
741
742 ddeConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);
743 DdeFreeStringHandle(ddeInstance, ddeService);
744 DdeFreeStringHandle(ddeInstance, ddeTopic);
745
746 if (ddeConv == (HCONV) NULL) {
747 if (interp != NULL) {
748 Tcl_AppendResult(interp, "no registered server named \"",
749 name, "\"", (char *) NULL);
750 }
751 return TCL_ERROR;
752 }
753
754 *ddeConvPtr = ddeConv;
755 return TCL_OK;
756 }
757
758 /*
759 *--------------------------------------------------------------
760 *
761 * SetDdeError --
762 *
763 * Sets the interp result to a cogent error message
764 * describing the last DDE error.
765 *
766 * Results:
767 * None.
768 *
769 *
770 * Side effects:
771 * The interp's result object is changed.
772 *
773 *--------------------------------------------------------------
774 */
775
776 static void
777 SetDdeError(
778 Tcl_Interp *interp) /* The interp to put the message in.*/
779 {
780 Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
781 int err;
782
783 err = DdeGetLastError(ddeInstance);
784 switch (err) {
785 case DMLERR_DATAACKTIMEOUT:
786 case DMLERR_EXECACKTIMEOUT:
787 case DMLERR_POKEACKTIMEOUT:
788 Tcl_SetStringObj(resultPtr,
789 "remote interpreter did not respond", -1);
790 break;
791
792 case DMLERR_BUSY:
793 Tcl_SetStringObj(resultPtr, "remote server is busy", -1);
794 break;
795
796 case DMLERR_NOTPROCESSED:
797 Tcl_SetStringObj(resultPtr,
798 "remote server cannot handle this command", -1);
799 break;
800
801 default:
802 Tcl_SetStringObj(resultPtr, "dde command failed", -1);
803 }
804 }
805
806 /*
807 *--------------------------------------------------------------
808 *
809 * Tcl_DdeObjCmd --
810 *
811 * This procedure is invoked to process the "dde" Tcl command.
812 * See the user documentation for details on what it does.
813 *
814 * Results:
815 * A standard Tcl result.
816 *
817 * Side effects:
818 * See the user documentation.
819 *
820 *--------------------------------------------------------------
821 */
822
823 int
824 Tcl_DdeObjCmd(
825 ClientData clientData, /* Used only for deletion */
826 Tcl_Interp *interp, /* The interp we are sending from */
827 int objc, /* Number of arguments */
828 Tcl_Obj *CONST objv[]) /* The arguments */
829 {
830 enum {
831 DDE_SERVERNAME,
832 DDE_EXECUTE,
833 DDE_POKE,
834 DDE_REQUEST,
835 DDE_SERVICES,
836 DDE_EVAL
837 };
838
839 static char *ddeCommands[] = {"servername", "execute", "poke",
840 "request", "services", "eval",
841 (char *) NULL};
842 static char *ddeOptions[] = {"-async", (char *) NULL};
843 int index, argIndex;
844 int async = 0;
845 int result = TCL_OK;
846 HSZ ddeService = NULL;
847 HSZ ddeTopic = NULL;
848 HSZ ddeItem = NULL;
849 HDDEDATA ddeData = NULL;
850 HDDEDATA ddeItemData = NULL;
851 HCONV hConv = NULL;
852 HSZ ddeCookie = 0;
853 char *serviceName, *topicName, *itemString, *dataString;
854 char *string;
855 int firstArg, length, dataLength;
856 DWORD ddeResult;
857 HDDEDATA ddeReturn;
858 RegisteredInterp *riPtr;
859 Tcl_Interp *sendInterp;
860 Tcl_Obj *objPtr;
861 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
862
863 /*
864 * Initialize DDE server/client
865 */
866
867 if (objc < 2) {
868 Tcl_WrongNumArgs(interp, 1, objv,
869 "?-async? serviceName topicName value");
870 return TCL_ERROR;
871 }
872
873 if (Tcl_GetIndexFromObj(interp, objv[1], ddeCommands, "command", 0,
874 &index) != TCL_OK) {
875 return TCL_ERROR;
876 }
877
878 switch (index) {
879 case DDE_SERVERNAME:
880 if ((objc != 3) && (objc != 2)) {
881 Tcl_WrongNumArgs(interp, 1, objv,
882 "servername ?serverName?");
883 return TCL_ERROR;
884 }
885 firstArg = (objc - 1);
886 break;
887 case DDE_EXECUTE:
888 if ((objc < 5) || (objc > 6)) {
889 Tcl_WrongNumArgs(interp, 1, objv,
890 "execute ?-async? serviceName topicName value");
891 return TCL_ERROR;
892 }
893 if (Tcl_GetIndexFromObj(NULL, objv[2], ddeOptions, "option", 0,
894 &argIndex) != TCL_OK) {
895 if (objc != 5) {
896 Tcl_WrongNumArgs(interp, 1, objv,
897 "execute ?-async? serviceName topicName value");
898 return TCL_ERROR;
899 }
900 async = 0;
901 firstArg = 2;
902 } else {
903 if (objc != 6) {
904 Tcl_WrongNumArgs(interp, 1, objv,
905 "execute ?-async? serviceName topicName value");
906 return TCL_ERROR;
907 }
908 async = 1;
909 firstArg = 3;
910 }
911 break;
912 case DDE_POKE:
913 if (objc != 6) {
914 Tcl_WrongNumArgs(interp, 1, objv,
915 "poke serviceName topicName item value");
916 return TCL_ERROR;
917 }
918 firstArg = 2;
919 break;
920 case DDE_REQUEST:
921 if (objc != 5) {
922 Tcl_WrongNumArgs(interp, 1, objv,
923 "request serviceName topicName value");
924 return TCL_ERROR;
925 }
926 firstArg = 2;
927 break;
928 case DDE_SERVICES:
929 if (objc != 4) {
930 Tcl_WrongNumArgs(interp, 1, objv,
931 "services serviceName topicName");
932 return TCL_ERROR;
933 }
934 firstArg = 2;
935 break;
936 case DDE_EVAL:
937 if (objc < 4) {
938 Tcl_WrongNumArgs(interp, 1, objv,
939 "eval ?-async? serviceName args");
940 return TCL_ERROR;
941 }
942 if (Tcl_GetIndexFromObj(NULL, objv[2], ddeOptions, "option", 0,
943 &argIndex) != TCL_OK) {
944 if (objc < 4) {
945 Tcl_WrongNumArgs(interp, 1, objv,
946 "eval ?-async? serviceName args");
947 return TCL_ERROR;
948 }
949 async = 0;
950 firstArg = 2;
951 } else {
952 if (objc < 5) {
953 Tcl_WrongNumArgs(interp, 1, objv,
954 "eval ?-async? serviceName args");
955 return TCL_ERROR;
956 }
957 async = 1;
958 firstArg = 3;
959 }
960 break;
961 }
962
963 Initialize();
964
965 if (firstArg != 1) {
966 serviceName = Tcl_GetStringFromObj(objv[firstArg], &length);
967 } else {
968 length = 0;
969 }
970
971 if (length == 0) {
972 serviceName = NULL;
973 } else if ((index != DDE_SERVERNAME) && (index != DDE_EVAL)) {
974 ddeService = DdeCreateStringHandle(ddeInstance, serviceName,
975 CP_WINANSI);
976 }
977
978 if ((index != DDE_SERVERNAME) &&(index != DDE_EVAL)) {
979 topicName = Tcl_GetStringFromObj(objv[firstArg + 1], &length);
980 if (length == 0) {
981 topicName = NULL;
982 } else {
983 ddeTopic = DdeCreateStringHandle(ddeInstance,
984 topicName, CP_WINANSI);
985 }
986 }
987
988 switch (index) {
989 case DDE_SERVERNAME: {
990 serviceName = DdeSetServerName(interp, serviceName);
991 if (serviceName != NULL) {
992 Tcl_SetStringObj(Tcl_GetObjResult(interp),
993 serviceName, -1);
994 } else {
995 Tcl_ResetResult(interp);
996 }
997 break;
998 }
999 case DDE_EXECUTE: {
1000 dataString = Tcl_GetStringFromObj(objv[firstArg + 2], &dataLength);
1001 if (dataLength == 0) {
1002 Tcl_SetStringObj(Tcl_GetObjResult(interp),
1003 "cannot execute null data", -1);
1004 result = TCL_ERROR;
1005 break;
1006 }
1007 hConv = DdeConnect(ddeInstance, ddeService, ddeTopic,
1008 NULL);
1009 DdeFreeStringHandle (ddeInstance, ddeService) ;
1010 DdeFreeStringHandle (ddeInstance, ddeTopic) ;
1011
1012 if (hConv == NULL) {
1013 SetDdeError(interp);
1014 result = TCL_ERROR;
1015 break;
1016 }
1017
1018 ddeData = DdeCreateDataHandle(ddeInstance, dataString,
1019 dataLength+1, 0, 0, CF_TEXT, 0);
1020 if (ddeData != NULL) {
1021 if (async) {
1022 DdeClientTransaction((LPBYTE) ddeData, 0xFFFFFFFF, hConv, 0,
1023 CF_TEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult);
1024 DdeAbandonTransaction(ddeInstance, hConv,
1025 ddeResult);
1026 } else {
1027 ddeReturn = DdeClientTransaction((LPBYTE) ddeData, 0xFFFFFFFF,
1028 hConv, 0, CF_TEXT, XTYP_EXECUTE, 30000, NULL);
1029 if (ddeReturn == 0) {
1030 SetDdeError(interp);
1031 result = TCL_ERROR;
1032 }
1033 }
1034 DdeFreeDataHandle(ddeData);
1035 } else {
1036 SetDdeError(interp);
1037 result = TCL_ERROR;
1038 }
1039 break;
1040 }
1041 case DDE_REQUEST: {
1042 itemString = Tcl_GetStringFromObj(objv[firstArg + 2], &length);
1043 if (length == 0) {
1044 Tcl_SetStringObj(Tcl_GetObjResult(interp),
1045 "cannot request value of null data", -1);
1046 return TCL_ERROR;
1047 }
1048 hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);
1049 DdeFreeStringHandle (ddeInstance, ddeService) ;
1050 DdeFreeStringHandle (ddeInstance, ddeTopic) ;
1051
1052 if (hConv == NULL) {
1053 SetDdeError(interp);
1054 result = TCL_ERROR;
1055 } else {
1056 Tcl_Obj *returnObjPtr;
1057 ddeItem = DdeCreateStringHandle(ddeInstance,
1058 itemString, CP_WINANSI);
1059 if (ddeItem != NULL) {
1060 ddeData = DdeClientTransaction(NULL, 0, hConv, ddeItem,
1061 CF_TEXT, XTYP_REQUEST, 5000, NULL);
1062 if (ddeData == NULL) {
1063 SetDdeError(interp);
1064 result = TCL_ERROR;
1065 } else {
1066 dataString = DdeAccessData(ddeData, &dataLength);
1067 returnObjPtr = Tcl_NewStringObj(dataString, -1);
1068 DdeUnaccessData(ddeData);
1069 DdeFreeDataHandle(ddeData);
1070 Tcl_SetObjResult(interp, returnObjPtr);
1071 }
1072 } else {
1073 SetDdeError(interp);
1074 result = TCL_ERROR;
1075 }
1076 }
1077
1078 break;
1079 }
1080 case DDE_POKE: {
1081 itemString = Tcl_GetStringFromObj(objv[firstArg + 2], &length);
1082 if (length == 0) {
1083 Tcl_SetStringObj(Tcl_GetObjResult(interp),
1084 "cannot have a null item", -1);
1085 return TCL_ERROR;
1086 }
1087 dataString = Tcl_GetStringFromObj(objv[firstArg + 3], &length);
1088
1089 hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);
1090 DdeFreeStringHandle (ddeInstance,ddeService) ;
1091 DdeFreeStringHandle (ddeInstance, ddeTopic) ;
1092
1093 if (hConv == NULL) {
1094 SetDdeError(interp);
1095 result = TCL_ERROR;
1096 } else {
1097 ddeItem = DdeCreateStringHandle(ddeInstance, itemString, \
1098 CP_WINANSI);
1099 if (ddeItem != NULL) {
1100 ddeData = DdeClientTransaction(dataString,length+1, \
1101 hConv, ddeItem,
1102 CF_TEXT, XTYP_POKE, 5000, NULL);
1103 if (ddeData == NULL) {
1104 SetDdeError(interp);
1105 result = TCL_ERROR;
1106 }
1107 } else {
1108 SetDdeError(interp);
1109 result = TCL_ERROR;
1110 }
1111 }
1112 break;
1113 }
1114
1115 case DDE_SERVICES: {
1116 HCONVLIST hConvList;
1117 CONVINFO convInfo;
1118 Tcl_Obj *convListObjPtr, *elementObjPtr;
1119 Tcl_DString dString;
1120 char *name;
1121
1122 convInfo.cb = sizeof(CONVINFO);
1123 hConvList = DdeConnectList(ddeInstance, ddeService,
1124 ddeTopic, 0, NULL);
1125 DdeFreeStringHandle (ddeInstance,ddeService) ;
1126 DdeFreeStringHandle (ddeInstance, ddeTopic) ;
1127 hConv = 0;
1128 convListObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
1129 Tcl_DStringInit(&dString);
1130
1131 while (hConv = DdeQueryNextServer(hConvList, hConv), hConv != 0) {
1132 elementObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
1133 DdeQueryConvInfo(hConv, QID_SYNC, &convInfo);
1134 length = DdeQueryString(ddeInstance,
1135 convInfo.hszSvcPartner, NULL, 0, CP_WINANSI);
1136 Tcl_DStringSetLength(&dString, length);
1137 name = Tcl_DStringValue(&dString);
1138 DdeQueryString(ddeInstance, convInfo.hszSvcPartner,
1139 name, length + 1, CP_WINANSI);
1140 Tcl_ListObjAppendElement(interp, elementObjPtr,
1141 Tcl_NewStringObj(name, length));
1142 length = DdeQueryString(ddeInstance, convInfo.hszTopic,
1143 NULL, 0, CP_WINANSI);
1144 Tcl_DStringSetLength(&dString, length);
1145 name = Tcl_DStringValue(&dString);
1146 DdeQueryString(ddeInstance, convInfo.hszTopic, name,
1147 length + 1, CP_WINANSI);
1148 Tcl_ListObjAppendElement(interp, elementObjPtr,
1149 Tcl_NewStringObj(name, length));
1150 Tcl_ListObjAppendElement(interp, convListObjPtr, elementObjPtr);
1151 }
1152 DdeDisconnectList(hConvList);
1153 Tcl_SetObjResult(interp, convListObjPtr);
1154 Tcl_DStringFree(&dString);
1155 break;
1156 }
1157 case DDE_EVAL: {
1158 objc -= (async + 3);
1159 ((Tcl_Obj **) objv) += (async + 3);
1160
1161 /*
1162 * See if the target interpreter is local. If so, execute
1163 * the command directly without going through the DDE server.
1164 * Don't exchange objects between interps. The target interp could
1165 * compile an object, producing a bytecode structure that refers to
1166 * other objects owned by the target interp. If the target interp
1167 * is then deleted, the bytecode structure would be referring to
1168 * deallocated objects.
1169 */
1170
1171 for (riPtr = tsdPtr->interpListPtr; riPtr != NULL; riPtr
1172 = riPtr->nextPtr) {
1173 if (stricmp(serviceName, riPtr->name) == 0) {
1174 break;
1175 }
1176 }
1177
1178 if (riPtr != NULL) {
1179 /*
1180 * This command is to a local interp. No need to go through
1181 * the server.
1182 */
1183
1184 Tcl_Preserve((ClientData) riPtr);
1185 sendInterp = riPtr->interp;
1186 Tcl_Preserve((ClientData) sendInterp);
1187
1188 /*
1189 * Don't exchange objects between interps. The target interp would
1190 * compile an object, producing a bytecode structure that refers to
1191 * other objects owned by the target interp. If the target interp
1192 * is then deleted, the bytecode structure would be referring to
1193 * deallocated objects.
1194 */
1195
1196 if (objc == 1) {
1197 result = Tcl_EvalObjEx(sendInterp, objv[0], TCL_EVAL_GLOBAL);
1198 } else {
1199 objPtr = Tcl_ConcatObj(objc, objv);
1200 Tcl_IncrRefCount(objPtr);
1201 result = Tcl_EvalObjEx(sendInterp, objPtr, TCL_EVAL_GLOBAL);
1202 Tcl_DecrRefCount(objPtr);
1203 }
1204 if (interp != sendInterp) {
1205 if (result == TCL_ERROR) {
1206 /*
1207 * An error occurred, so transfer error information from the
1208 * destination interpreter back to our interpreter.
1209 */
1210
1211 Tcl_ResetResult(interp);
1212 objPtr = Tcl_GetVar2Ex(sendInterp, "errorInfo", NULL,
1213 TCL_GLOBAL_ONLY);
1214 string = Tcl_GetStringFromObj(objPtr, &length);
1215 Tcl_AddObjErrorInfo(interp, string, length);
1216
1217 objPtr = Tcl_GetVar2Ex(sendInterp, "errorCode", NULL,
1218 TCL_GLOBAL_ONLY);
1219 Tcl_SetObjErrorCode(interp, objPtr);
1220 }
1221 Tcl_SetObjResult(interp, Tcl_GetObjResult(sendInterp));
1222 }
1223 Tcl_Release((ClientData) riPtr);
1224 Tcl_Release((ClientData) sendInterp);
1225 } else {
1226 /*
1227 * This is a non-local request. Send the script to the server and poll
1228 * it for a result.
1229 */
1230
1231 if (MakeDdeConnection(interp, serviceName, &hConv) != TCL_OK) {
1232 goto error;
1233 }
1234
1235 objPtr = Tcl_ConcatObj(objc, objv);
1236 string = Tcl_GetStringFromObj(objPtr, &length);
1237 ddeItemData = DdeCreateDataHandle(ddeInstance, string, length+1, 0, 0,
1238 CF_TEXT, 0);
1239
1240 if (async) {
1241 ddeData = DdeClientTransaction((LPBYTE) ddeItemData, 0xFFFFFFFF, hConv, 0,
1242 CF_TEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult);
1243 DdeAbandonTransaction(ddeInstance, hConv, ddeResult);
1244 } else {
1245 ddeData = DdeClientTransaction((LPBYTE) ddeItemData, 0xFFFFFFFF, hConv, 0,
1246 CF_TEXT, XTYP_EXECUTE, 30000, NULL);
1247 if (ddeData != 0) {
1248
1249 ddeCookie = DdeCreateStringHandle(ddeInstance,
1250 "$TCLEVAL$EXECUTE$RESULT", CP_WINANSI);
1251 ddeData = DdeClientTransaction(NULL, 0, hConv, ddeCookie,
1252 CF_TEXT, XTYP_REQUEST, 30000, NULL);
1253 }
1254 }
1255
1256
1257 Tcl_DecrRefCount(objPtr);
1258
1259 if (ddeData == 0) {
1260 SetDdeError(interp);
1261 goto errorNoResult;
1262 }
1263
1264 if (async == 0) {
1265 Tcl_Obj *resultPtr;
1266
1267 /*
1268 * The return handle has a two or four element list in it. The first
1269 * element is the return code (TCL_OK, TCL_ERROR, etc.). The
1270 * second is the result of the script. If the return code is TCL_ERROR,
1271 * then the third element is the value of the variable "errorCode",
1272 * and the fourth is the value of the variable "errorInfo".
1273 */
1274
1275 resultPtr = Tcl_NewObj();
1276 length = DdeGetData(ddeData, NULL, 0, 0);
1277 Tcl_SetObjLength(resultPtr, length);
1278 string = Tcl_GetString(resultPtr);
1279 DdeGetData(ddeData, string, length, 0);
1280 Tcl_SetObjLength(resultPtr, strlen(string));
1281
1282 if (Tcl_ListObjIndex(NULL, resultPtr, 0, &objPtr) != TCL_OK) {
1283 Tcl_DecrRefCount(resultPtr);
1284 goto error;
1285 }
1286 if (Tcl_GetIntFromObj(NULL, objPtr, &result) != TCL_OK) {
1287 Tcl_DecrRefCount(resultPtr);
1288 goto error;
1289 }
1290 if (result == TCL_ERROR) {
1291 Tcl_ResetResult(interp);
1292
1293 if (Tcl_ListObjIndex(NULL, resultPtr, 3, &objPtr) != TCL_OK) {
1294 Tcl_DecrRefCount(resultPtr);
1295 goto error;
1296 }
1297 length = -1;
1298 string = Tcl_GetStringFromObj(objPtr, &length);
1299 Tcl_AddObjErrorInfo(interp, string, length);
1300
1301 Tcl_ListObjIndex(NULL, resultPtr, 2, &objPtr);
1302 Tcl_SetObjErrorCode(interp, objPtr);
1303 }
1304 if (Tcl_ListObjIndex(NULL, resultPtr, 1, &objPtr) != TCL_OK) {
1305 Tcl_DecrRefCount(resultPtr);
1306 goto error;
1307 }
1308 Tcl_SetObjResult(interp, objPtr);
1309 Tcl_DecrRefCount(resultPtr);
1310 }
1311 }
1312 }
1313 }
1314 if (ddeCookie != NULL) {
1315 DdeFreeStringHandle(ddeInstance, ddeCookie);
1316 }
1317 if (ddeItem != NULL) {
1318 DdeFreeStringHandle(ddeInstance, ddeItem);
1319 }
1320 if (ddeItemData != NULL) {
1321 DdeFreeDataHandle(ddeItemData);
1322 }
1323 if (ddeData != NULL) {
1324 DdeFreeDataHandle(ddeData);
1325 }
1326 if (hConv != NULL) {
1327 DdeDisconnect(hConv);
1328 }
1329 return result;
1330
1331 error:
1332 Tcl_SetStringObj(Tcl_GetObjResult(interp),
1333 "invalid data returned from server", -1);
1334
1335 errorNoResult:
1336 if (ddeCookie != NULL) {
1337 DdeFreeStringHandle(ddeInstance, ddeCookie);
1338 }
1339 if (ddeItem != NULL) {
1340 DdeFreeStringHandle(ddeInstance, ddeItem);
1341 }
1342 if (ddeItemData != NULL) {
1343 DdeFreeDataHandle(ddeItemData);
1344 }
1345 if (ddeData != NULL) {
1346 DdeFreeDataHandle(ddeData);
1347 }
1348 if (hConv != NULL) {
1349 DdeDisconnect(hConv);
1350 }
1351 return TCL_ERROR;
1352 }
1353
1354 /* End of tclwindde.c */

Properties

Name Value
svn:eol-style native
svn:keywords Header

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25