1 /*
2 * win32.c --
3 *
4 * FIXME: This file needs a description here.
5 *
6 * Copyright (c) 1996-2002 The Regents of the University of California.
7 * All rights reserved.
8 *
9 * Redistribution and use in source and binary forms, with or without
10 * modification, are permitted provided that the following conditions are met:
11 *
12 * A. Redistributions of source code must retain the above copyright notice,
13 * this list of conditions and the following disclaimer.
14 * B. Redistributions in binary form must reproduce the above copyright notice,
15 * this list of conditions and the following disclaimer in the documentation
16 * and/or other materials provided with the distribution.
17 * C. Neither the names of the copyright holders nor the names of its
18 * contributors may be used to endorse or promote products derived from this
19 * software without specific prior written permission.
20 *
21 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS
22 * IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
23 * THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
24 * PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE
25 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
26 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
27 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
28 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
29 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
30 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
31 * POSSIBILITY OF SUCH DAMAGE.
32 *
33 * This module contributed by John Brezak <brezak@apollo.hp.com>.
34 * January 31, 1996
35 */
36
37 #ifndef lint
38 static char rcsid[] =
39 "@(#) $Header: /usr/mash/src/repository/mash/mash-1/compat/win32.c,v 1.22 2002/02/03 03:14:22 lim Exp $";
40 #endif
41
42 #include <assert.h>
43 #include <io.h>
44 #include <process.h>
45 #include <fcntl.h>
46 #include <windows.h>
47 #include <malloc.h>
48 #include <string.h>
49 #include <stdio.h>
50 #include <time.h>
51 #include <winsock.h>
52 #include <tk.h>
53 #include "config.h"
54 #include <locale.h>
55
56 /* forward declarations */
57 int WinGetUserName(ClientData, Tcl_Interp*, int ac, char**av);
58 int WinGetHostName(ClientData, Tcl_Interp*, int ac, char**av);
59 int WinPutRegistry(ClientData, Tcl_Interp*, int ac, char**av);
60 int WinGetRegistry(ClientData, Tcl_Interp*, int ac, char**av);
61 int WinExit(ClientData, Tcl_Interp*, int ac, char**av);
62 void TkConsoleCreate();
63 int TkConsoleInit(Tcl_Interp* interp);
64
65
66
67 extern void MashConsoleInit(HINSTANCE);
68 extern void MashConsoleShow(BOOL);
69 extern void MashConsoleDoModal();
70 extern BOOL MashConsoleAttach();
71
72 int
73 uname(struct utsname *ub)
74 {
75 char *ptr;
76 DWORD version;
77 SYSTEM_INFO sysinfo;
78 char hostname[4096];
79
80 version = GetVersion();
81 GetSystemInfo(&sysinfo);
82
83 switch (sysinfo.wProcessorArchitecture) {
84 case PROCESSOR_ARCHITECTURE_INTEL:
85 (void)strcpy(ub->machine, "ix86");
86 break;
87 case PROCESSOR_ARCHITECTURE_MIPS :
88 (void)strcpy(ub->machine, "mips");
89 break;
90 case PROCESSOR_ARCHITECTURE_ALPHA:
91 (void)strcpy(ub->machine, "alpha");
92 break;
93 case PROCESSOR_ARCHITECTURE_PPC:
94 (void)strcpy(ub->machine, "ppc");
95 break;
96 default:
97 (void)strcpy(ub->machine, "unknown");
98 break;
99 }
100
101 if (version < 0x80000000) {
102 (void)strcpy(ub->version, "NT");
103 }
104 else if (LOBYTE(LOWORD(version))<4) {
105 (void)strcpy(ub->version, "Win32s");
106 }
107 else /* Win95 */ {
108 (void)strcpy(ub->version, "Win95");
109 }
110 (void)sprintf(ub->release, "%u.%u",
111 (DWORD)(LOBYTE(LOWORD(version))),
112 (DWORD)(HIBYTE(LOWORD(version))));
113 (void)strcpy(ub->sysname, "Windows");
114 if (gethostname(hostname, sizeof(hostname)) == 0) {
115 if (ptr = strchr(hostname, '.'))
116 *ptr = '\0';
117 }
118 else {
119 perror("uname: gethostname failed");
120 strcpy(hostname, "FAILURE");
121 }
122 strncpy(ub->nodename, hostname, sizeof(ub->nodename));
123 ub->nodename[_SYS_NMLN - 1] = '\0';
124 return 0;
125 }
126
127 int strcasecmp(const char *s1, const char *s2)
128 {
129 return stricmp(s1, s2);
130 }
131
132 uid_t getuid(void)
133 {
134 return 1;
135
136 }
137
138 gid_t getgid(void)
139 {
140 return 0;
141 }
142
143 int gethostid(void)
144 {
145 /*FIXME*/
146 return 0;
147 }
148
149 __inline int nice(int pri)
150 {
151 return 0;
152 }
153
154 extern void TkWinXInit(HINSTANCE hInstance);
155 extern int main(int argc, const char *argv[]);
156
157 static char argv0[255]; /* Buffer used to hold argv0. */
158
159 char *__progname = "mash";
160
161 void
162 ShowMessage(int level, char *msg)
163 {
164 MessageBeep(level);
165 MessageBox(NULL, msg, __progname,
166 level | MB_OK | MB_TASKMODAL | MB_SETFOREGROUND);
167 }
168
169 int SetupConsole()
170 {
171 // stuff from knowledge base Q105305 (see that for details)
172 // open a console and do the work around to get the console to work in all
173 // cases
174 int hCrt;
175 FILE *hf=0;
176 const COORD screenSz = {80, 2000}; /* size of console buffer */
177
178 AllocConsole();
179
180 hf=0;
181 hCrt = _open_osfhandle(
182 (long)GetStdHandle(STD_OUTPUT_HANDLE), _O_TEXT);
183 if (hCrt!=-1) hf = _fdopen(hCrt, "w");
184 if (hf!=0) *stdout = *hf;
185 if (hCrt==-1 || hf==0 || 0!=setvbuf(stdout, NULL, _IONBF, 0)) {
186 ShowMessage(MB_ICONINFORMATION,
187 "unable to reroute stdout");
188 return FALSE;
189 }
190 SetConsoleScreenBufferSize(GetStdHandle(STD_OUTPUT_HANDLE), screenSz);
191
192 hf=0;
193 hCrt = _open_osfhandle(
194 (long)GetStdHandle(STD_ERROR_HANDLE), _O_TEXT);
195 if (hCrt!=-1) hf = _fdopen(hCrt, "w");
196 if (hf!=0) *stderr = *hf;
197 if (hCrt==-1 || hf==0 || 0!=setvbuf(stderr, NULL, _IONBF, 0)) {
198 ShowMessage(MB_ICONINFORMATION,
199 "reroute stderr failed in SetupConsole");
200 return FALSE;
201 }
202
203 hf=0;
204 hCrt = _open_osfhandle((long)GetStdHandle(STD_INPUT_HANDLE), _O_TEXT);
205 if (hCrt!=-1) hf = _fdopen(hCrt, "r");
206 if (hf!=0) *stdin = *hf;
207 if (hCrt==-1 || hf==0 || 0!=setvbuf(stdin, NULL, _IONBF, 0)) {
208 ShowMessage(MB_ICONINFORMATION,
209 "reroute stdin failed in SetupConsole");
210 return FALSE;
211 }
212 return TRUE;
213 }
214
215
216 int APIENTRY
217 WinMain(
218 HINSTANCE hInstance,
219 HINSTANCE hPrevInstance,
220 LPSTR lpszCmdLine,
221 int nCmdShow)
222 {
223 char *p;
224 WSADATA WSAdata;
225 int retcode;
226 // int i;
227 // char szTitle[_MAX_FNAME];
228
229 setlocale(LC_ALL, "C");
230
231 /* FIXME: how valid is the following statement with 8.0?
232 * initialize our socket interface plus the tcl 7.5 socket
233 * interface (since they redefine some routines we call).
234 * eventually we should just call the tcl sockets but at
235 * the moment that's hard to set up since they only support
236 * tcp in the notifier.
237 */
238 if (WSAStartup(MAKEWORD (1, 1), &WSAdata)) {
239 perror("Windows Sockets init failed");
240 abort();
241 }
242 #if 0
243 TclHasSockets(NULL);
244 #endif
245 /*
246 * Increase the application queue size from default value of 8.
247 * At the default value, cross application SendMessage of WM_KILLFOCUS
248 * will fail because the handler will not be able to do a PostMessage!
249 * This is only needed for Windows 3.x, since NT dynamically expands
250 * the queue.
251 */
252 SetMessageQueue(64);
253
254 GetModuleFileName(NULL, argv0, 255);
255 p = argv0;
256 __progname = strrchr(p, '/');
257 if (__progname != NULL) {
258 __progname++;
259 }
260 else {
261 __progname = strrchr(p, '\\');
262 if (__progname != NULL) {
263 __progname++;
264 } else {
265 __progname = p;
266 }
267 }
268
269 /*if (__argc>1) {
270 SetupConsole();
271 for (i=0; i<__argc; i++) {
272 if (!strcmp(__argv[i], "-name")) {
273 i++;
274 break;
275 }
276 }
277 if (i<__argc) {
278 strncpy(szTitle, __argv[i], _MAX_FNAME);
279 SetConsoleTitle(szTitle);
280 }
281
282 }*/
283
284 // create the mash console object
285 MashConsoleInit(hInstance);
286
287 retcode=main(__argc, (const char**)__argv);
288 if (retcode!=0) {
289 assert(FALSE); // don't die without letting user know why
290 }
291 return retcode;
292 }
293
294 static char szTemp[4096];
295
296 int outputErr(const char* szPrefix, Tcl_Interp* interp)
297 {
298 int l;
299 char *szError=Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
300 char *szMsg = szTemp;
301 l = strlen(szPrefix) + 2 + strlen(interp->result) + 1;
302 if (szError) {
303 l += strlen(szError) + 2;
304 }
305
306 if (l>4096) szMsg = (char*)malloc(l*sizeof(char));
307 strcpy(szMsg, szPrefix);
308 strcat(szMsg, "\n");
309 strcat(szMsg, interp->result);
310 if (szError) {
311 strcat(szMsg, "\n");
312 strcat(szMsg, szError);
313 }
314 OutputDebugString(szMsg);
315 ShowMessage(MB_ICONERROR, szMsg);
316 assert(FALSE);
317 if (szMsg != szTemp) free(szMsg);
318 return 0;
319 }
320
321 void
322 win_perror(const char *msg)
323 {
324 DWORD cMsgLen;
325 CHAR *msgBuf;
326 DWORD dwError = GetLastError();
327
328 cMsgLen = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM |
329 FORMAT_MESSAGE_ALLOCATE_BUFFER | 40, NULL,
330 dwError,
331 MAKELANGID(0, SUBLANG_ENGLISH_US),
332 (LPTSTR) &msgBuf, 512,
333 NULL);
334 if (!cMsgLen)
335 fprintf(stderr, "%s%sError code %lu\n",
336 msg?msg:"", msg?": ":"", dwError);
337 else {
338 fprintf(stderr, "%s%s%s\n", msg?msg:"", msg?": ":"", msgBuf);
339
340 LocalFree((HLOCAL)msgBuf);
341 }
342 }
343
344 #if 0
345
346 int
347 printf(const char *fmt, ...)
348 {
349 int retval;
350
351 va_list ap;
352 va_start (ap, fmt);
353 retval = vsprintf(szTemp, fmt, ap);
354 OutputDebugString(szTemp);
355 ShowMessage(MB_ICONINFORMATION, szTemp);
356 va_end (ap);
357
358 return(retval);
359 }
360
361 int
362 fprintf(FILE *f, const char *fmt, ...)
363 {
364 int retval;
365
366 va_list ap;
367 va_start (ap, fmt);
368 if (f == stderr) {
369 retval = vsprintf(szTemp, fmt, ap);
370 OutputDebugString(szTemp);
371 ShowMessage(MB_ICONERROR, szTemp);
372 va_end (ap);
373 }
374 else
375 retval = vfprintf(f, fmt, ap);
376
377 return(retval);
378 }
379
380
381 int
382 WinPutsCmd(clientData, interp, argc, argv)
383 ClientData clientData; /* ConsoleInfo pointer. */
384 Tcl_Interp *interp; /* Current interpreter. */
385 int argc; /* Number of arguments. */
386 char **argv; /* Argument strings. */
387 {
388 int i, newline;
389 char *fileId;
390
391 i = 1;
392 newline = 1;
393 if ((argc >= 2) && (strcmp(argv[1], "-nonewline") == 0)) {
394 newline = 0;
395 i++;
396 }
397 if ((i < (argc-3)) || (i >= argc)) {
398 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
399 " ?-nonewline? ?fileId? string\"", (char *) NULL);
400 return TCL_ERROR;
401 }
402
403 /*
404 * The code below provides backwards compatibility with an old
405 * form of the command that is no longer recommended or documented.
406 */
407
408 if (i == (argc-3)) {
409 if (strncmp(argv[i+2], "nonewline", strlen(argv[i+2])) != 0) {
410 Tcl_AppendResult(interp, "bad argument \"", argv[i+2],
411 "\": should be \"nonewline\"", (char *) NULL);
412 return TCL_ERROR;
413 }
414 newline = 0;
415 }
416 if (i == (argc-1)) {
417 fileId = "stdout";
418 } else {
419 fileId = argv[i];
420 i++;
421 }
422
423 if (strcmp(fileId, "stdout") == 0 || strcmp(fileId, "stderr") == 0) {
424 char *result;
425 int level;
426
427 if (newline) {
428 int len = strlen(argv[i]);
429 result = ckalloc(len+2);
430 memcpy(result, argv[i], len);
431 result[len] = '\n';
432 result[len+1] = 0;
433 } else {
434 result = argv[i];
435 }
436 if (strcmp(fileId, "stdout") == 0) {
437 level = MB_ICONINFORMATION;
438 } else {
439 level = MB_ICONERROR;
440 }
441 OutputDebugString(result);
442 ShowMessage(level, result);
443 if (newline)
444 ckfree(result);
445 return TCL_OK;
446 } else {
447 extern int Tcl_PutsCmd(ClientData clientData, Tcl_Interp *interp,
448 int argc, char **argv);
449
450 return (Tcl_PutsCmd(clientData, interp, argc, argv));
451 }
452 }
453 #endif //
454
455 int
456 WinGetUserName(clientData, interp, argc, argv)
457 ClientData clientData;
458 Tcl_Interp *interp; /* Current interpreter. */
459 int argc; /* Number of arguments. */
460 char *argv[]; /* Argument strings. */
461 {
462 char user[256];
463 int size = sizeof(user);
464
465 if (!GetUserName(user, &size)) {
466 Tcl_AppendResult(interp, "GetUserName failed", NULL);
467 return TCL_ERROR;
468 }
469 Tcl_AppendResult(interp, user, NULL);
470 return TCL_OK;
471 }
472
473 int WinGetHostName(clientData, interp, argc, argv)
474 ClientData clientData;
475 Tcl_Interp *interp; /* Current interpreter. */
476 int argc; /* Number of arguments. */
477 char *argv[]; /* Argument strings. */
478 {
479 char hostname[MAXGETHOSTSTRUCT];
480 if (SOCKET_ERROR == gethostname(hostname, MAXGETHOSTSTRUCT)) {
481 Tcl_AddErrorInfo(interp, "gethostname failed!");
482 }
483 Tcl_AppendResult(interp, hostname, NULL);
484 return TCL_OK;
485 }
486
487
488 #define MAX_REGROOT_LEN 80
489 static void
490 extract_root(const char **path, char *root)
491 {
492 char *slash = strchr(*path, '\\');
493 if (slash==NULL) { *root = '\0'; }
494 else {
495 int len = slash-(*path);
496 if (len >= MAX_REGROOT_LEN) len = MAX_REGROOT_LEN-1;
497 strncpy(root, *path, len);
498 root[len] = '\0';
499 *path = slash+1;
500 }
501 }
502
503 static HKEY
504 regroot(root)
505 char *root;
506 {
507 if (strcasecmp(root, "HKEY_LOCAL_MACHINE") == 0)
508 return HKEY_LOCAL_MACHINE;
509 else if (strcasecmp(root, "HKEY_CURRENT_USER") == 0)
510 return HKEY_CURRENT_USER;
511 else if (strcasecmp(root, "HKEY_USERS") == 0)
512 return HKEY_USERS;
513 else if (strcasecmp(root, "HKEY_CLASSES_ROOT") == 0)
514 return HKEY_CLASSES_ROOT;
515 else
516 return NULL;
517 }
518
519 int
520 WinGetRegistry(clientData, interp, argc, argv)
521 ClientData clientData;
522 Tcl_Interp *interp; /* Current interpreter. */
523 int argc; /* Number of arguments. */
524 char **argv; /* Argument strings. */
525 {
526 HKEY hKey, hRootKey;
527 DWORD dwType;
528 DWORD len, retCode;
529 CHAR *regPath, *keyValue, *keyData, regRoot[MAX_REGROOT_LEN];
530 int retval = TCL_ERROR;
531
532 if (argc != 3) {
533 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
534 "key value\"", (char *) NULL);
535 return TCL_ERROR;
536 }
537 regPath = argv[1];
538 keyValue = argv[2];
539
540 extract_root(®Path, regRoot);
541
542 if ((hRootKey = regroot(regRoot)) == NULL) {
543 Tcl_AppendResult(interp, "Unknown registry root \"",
544 regRoot, "\"", NULL);
545 return (TCL_ERROR);
546 }
547
548 retCode = RegOpenKeyEx(hRootKey, regPath, 0,
549 KEY_READ, &hKey);
550 if (retCode == ERROR_SUCCESS) {
551 retCode = RegQueryValueEx(hKey, keyValue, NULL, &dwType,
552 NULL, &len);
553 if (retCode == ERROR_SUCCESS &&
554 dwType == REG_SZ && len) {
555 keyData = (CHAR *) ckalloc(len);
556 retCode = RegQueryValueEx(hKey, keyValue, NULL, NULL,
557 keyData, &len);
558 if (retCode == ERROR_SUCCESS) {
559 Tcl_AppendResult(interp, keyData, NULL);
560 retval = TCL_OK;
561 }
562 ckfree(keyData);
563 }
564 RegCloseKey(hKey);
565 }
566 if (retval == TCL_ERROR) {
567 Tcl_AppendResult(interp, "Cannot find registry entry \"", regRoot,
568 "\\", regPath, "\\", keyValue, "\"", NULL);
569 }
570 return (retval);
571 }
572
573 int
574 WinPutRegistry(clientData, interp, argc, argv)
575 ClientData clientData;
576 Tcl_Interp *interp; /* Current interpreter. */
577 int argc; /* Number of arguments. */
578 char **argv; /* Argument strings. */
579 {
580 HKEY hKey, hRootKey;
581 DWORD retCode;
582 CHAR regRoot[MAX_REGROOT_LEN], *regPath, *keyValue, *keyData;
583 DWORD new;
584 int result = TCL_OK;
585
586 if (argc != 4) {
587 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
588 "key value data\"", (char *) NULL);
589 return TCL_ERROR;
590 }
591 regPath = argv[1];
592 keyValue = argv[2];
593 keyData = argv[3];
594
595 extract_root(®Path, regRoot);
596
597 if ((hRootKey = regroot(regRoot)) == NULL) {
598 Tcl_AppendResult(interp, "Unknown registry root \"",
599 regRoot, "\"", NULL);
600 return (TCL_ERROR);
601 }
602
603 retCode = RegCreateKeyEx(hRootKey, regPath, 0,
604 "",
605 REG_OPTION_NON_VOLATILE,
606 KEY_ALL_ACCESS,
607 NULL,
608 &hKey, &new);
609 if (retCode == ERROR_SUCCESS) {
610 retCode = RegSetValueEx(hKey, keyValue, 0, REG_SZ, keyData, strlen(keyData));
611 if (retCode != ERROR_SUCCESS) {
612 Tcl_AppendResult(interp, "unable to set key \"", regRoot, "\\",
613 regPath, "\" with value \"", keyValue, "\"",
614 (char *) NULL);
615 result = TCL_ERROR;
616 }
617 RegCloseKey(hKey);
618 }
619 else {
620 Tcl_AppendResult(interp, "unable to create key \"", regRoot, "\\",
621 regPath, "\"", (char *) NULL);
622 result = TCL_ERROR;
623 }
624 return (result);
625 }
626
627 /* does everything the normal exit command does, but shows a dialog box if
628 * there is an error so that the console does not vaporize */
629 int WinExit(dummy, interp, argc, argv)
630 ClientData dummy; /* Not used. */
631 Tcl_Interp *interp; /* Current interpreter. */
632 int argc; /* Number of arguments. */
633 char **argv;
634 {
635 int value;
636 char buffer[100];
637
638 if ((argc != 1) && (argc != 2)) {
639 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
640 " ?returnCode?\"", (char *) NULL);
641 return TCL_ERROR;
642 }
643 if (argc == 1) {
644 value = 0;
645 } else if (Tcl_GetInt(interp, argv[1], &value) != TCL_OK) {
646 return TCL_ERROR;
647 }
648 /* all the error information should be in the console, so just
649 * show the message and wait for user input */
650 if (value != 0) {
651 fprintf(stderr, "\nApplication exiting with error-code %d\n",
652 value);
653 MashConsoleShow(TRUE);
654 /* wait for console to exit */
655 MashConsoleDoModal();
656 }
657 /* call the usual (renamed) tcl exit command */
658 sprintf(buffer, "tcl_exit %d", value);
659 Tcl_Eval(interp, buffer);
660
661 /*NOTREACHED*/
662 return TCL_OK;
663 }
664
665 static char initScript[]=
666 "proc init {} {\n\
667 global tcl_library tcl_platform tcl_version tcl_patchLevel env errorInfo\n\
668 global tcl_pkgPath\n\
669 rename init {}\n\
670 set errors {}\n\
671 proc tcl_envTraceProc {lo n1 n2 op} {\n\
672 global env\n\
673 set x $env($n2)\n\
674 set env($lo) $x\n\
675 set env([string toupper $lo]) $x\n\
676 }\n\
677 foreach p [array names env] {\n\
678 set u [string toupper $p]\n\
679 if {$u != $p} {\n\
680 switch -- $u {\n\
681 COMSPEC -\n\
682 PATH {\n\
683 if {![info exists env($u)]} {\n\
684 set env($u) $env($p)\n\
685 }\n\
686 trace variable env($p) w [list tcl_envTraceProc $p]\n\
687 trace variable env($u) w [list tcl_envTraceProc $p]\n\
688 }\n\
689 }\n\
690 }\n\
691 }\n\
692 if {![info exists env(COMSPEC)]} {\n\
693 if {$tcl_platform(os) == {Windows NT}} {\n\
694 set env(COMSPEC) cmd.exe\n\
695 } else {\n\
696 set env(COMSPEC) command.com\n\
697 }\n\
698 } \n\
699 }\n\
700 init\n";
701
702 int Mash_TclPlatformInit(Tcl_Interp* interp)
703 {
704 /* tcl.CreateCommand("puts", WinPutsCmd, (ClientData)0); */
705 Tcl_CreateCommand(interp, "getusername", WinGetUserName,
706 (ClientData)0, (Tcl_CmdDeleteProc*)0);
707 Tcl_CreateCommand(interp, "gethostname", WinGetHostName,
708 (ClientData)0, (Tcl_CmdDeleteProc*)0);
709 Tcl_CreateCommand(interp, "putregistry", WinPutRegistry,
710 (ClientData)0, (Tcl_CmdDeleteProc*)0);
711 Tcl_CreateCommand(interp, "getregistry", WinGetRegistry,
712 (ClientData)0, (Tcl_CmdDeleteProc*)0);
713 Tcl_Eval(interp, initScript);
714 if (TCL_OK==Tcl_Eval(interp, "rename exit tcl_exit")) {
715 Tcl_CreateCommand(interp, "exit", WinExit,
716 (ClientData)0, (Tcl_CmdDeleteProc*)0);
717 } else {
718 fprintf(stderr, "rename of exit proc failed!");
719 }
720 return TCL_OK;
721 }
722
723 int Mash_TkPlatformInit(Tcl_Interp* interp)
724 {
725 /*
726 * Initialize the console only if we are running as an interactive
727 * application.
728 */
729 if (0==strcmp(Tcl_GetVar(interp, "tcl_interactive",
730 TCL_GLOBAL_ONLY), "1")) {
731 /*
732 * Create the console channels and install them as the standard
733 * channels. All I/O will be discarded until TkConsoleInit is
734 * called to attach the console to a text widget.
735 */
736 TkConsoleCreate();
737 if (TkConsoleInit(interp) == TCL_ERROR) {
738 fprintf(stderr, "error calling TkConsoleInit\n");
739 ShowMessage(0, "error in TkConsoleInit!");
740 ShowMessage(0, Tcl_GetVar(interp, "errorInfo",
741 TCL_GLOBAL_ONLY));
742 return TCL_ERROR;
743 }
744 //FreeConsole();
745 }
746
747 MashConsoleAttach();
748
749 {
750 char *evalString =
751 "set mash(prv:root_tags) [bindtags .]\n"
752 "lappend mash(prv:root_tags) CreateSysMenuTag\n"
753 "bindtags . $mash(prv:root_tags)\n"
754 "bind CreateSysMenuTag <Map> {after idle"
755 " {\n"
756 " $mash(console) create_sysmenu [winfo id .]\n"
757 " $mash(console) set_title \\\n"
758 " \"Mash Console ([file tail $argv0])\"\n"
759 " }\n"
760 " set idx [lsearch $mash(prv:root_tags) \\\n"
761 " CreateSysMenuTag]\n"
762 " if { $idx != -1 } {\n"
763 " set mash(prv:root_tags) [lreplace \\\n"
764 " $mash(prv:root_tags) $idx $idx]\n"
765 " }\n"
766 " bindtags . $mash(prv:root_tags)\n"
767 " unset mash(prv:root_tags)\n"
768 " bind CreateSysMenuTag <Map> {}\n"
769 "}";
770 return Tcl_Eval(interp, evalString);
771 }
772 }
773
774
This page was automatically generated by the
LXR engine.
Visit the LXR main site for more
information.