1 /*
2 * win32-tcl.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-tcl.c,v 1.9 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 "config.h"
53 #include <locale.h>
54 #include <tcl.h>
55 #include <tkWin.h>
56
57 /* forward declarations */
58 int WinGetUserName(ClientData, Tcl_Interp*, int ac, char**av);
59 int WinGetHostName(ClientData, Tcl_Interp*, int ac, char**av);
60 int WinPutRegistry(ClientData, Tcl_Interp*, int ac, char**av);
61 int WinGetRegistry(ClientData, Tcl_Interp*, int ac, char**av);
62
63
64 int
65 uname(struct utsname *ub)
66 {
67 char *ptr;
68 DWORD version;
69 SYSTEM_INFO sysinfo;
70 char hostname[4096];
71
72 version = GetVersion();
73 GetSystemInfo(&sysinfo);
74
75 switch (sysinfo.wProcessorArchitecture) {
76 case PROCESSOR_ARCHITECTURE_INTEL:
77 (void)strcpy(ub->machine, "ix86");
78 break;
79 case PROCESSOR_ARCHITECTURE_MIPS :
80 (void)strcpy(ub->machine, "mips");
81 break;
82 case PROCESSOR_ARCHITECTURE_ALPHA:
83 (void)strcpy(ub->machine, "alpha");
84 break;
85 case PROCESSOR_ARCHITECTURE_PPC:
86 (void)strcpy(ub->machine, "ppc");
87 break;
88 default:
89 (void)strcpy(ub->machine, "unknown");
90 break;
91 }
92
93 if (version < 0x80000000) {
94 (void)strcpy(ub->version, "NT");
95 }
96 else if (LOBYTE(LOWORD(version))<4) {
97 (void)strcpy(ub->version, "Win32s");
98 }
99 else /* Win95 */ {
100 (void)strcpy(ub->version, "Win95");
101 }
102 (void)sprintf(ub->release, "%u.%u",
103 (DWORD)(LOBYTE(LOWORD(version))),
104 (DWORD)(HIBYTE(LOWORD(version))));
105 (void)strcpy(ub->sysname, "Windows");
106 if (gethostname(hostname, sizeof(hostname)) == 0) {
107 if (ptr = strchr(hostname, '.'))
108 *ptr = '\0';
109 }
110 else {
111 perror("uname: gethostname failed");
112 strcpy(hostname, "FAILURE");
113 }
114 strncpy(ub->nodename, hostname, sizeof(ub->nodename));
115 ub->nodename[_SYS_NMLN - 1] = '\0';
116 return 0;
117 }
118
119 int strcasecmp(const char *s1, const char *s2)
120 {
121 return stricmp(s1, s2);
122 }
123
124 uid_t getuid(void)
125 {
126 return 1;
127
128 }
129
130 gid_t getgid(void)
131 {
132 return 0;
133 }
134
135 #if __STDC__
136 int getpid()
137 {
138 return _getpid();
139 }
140 #endif
141
142 int gethostid(void)
143 {
144 /*FIXME*/
145 return 0;
146 }
147
148 __inline int nice(int pri)
149 {
150 return 0;
151 }
152
153 int
154 WinGetUserName(clientData, interp, argc, argv)
155 ClientData clientData;
156 Tcl_Interp *interp; /* Current interpreter. */
157 int argc; /* Number of arguments. */
158 char *argv[]; /* Argument strings. */
159 {
160 char user[256];
161 int size = sizeof(user);
162
163 if (!GetUserName(user, &size)) {
164 Tcl_AppendResult(interp, "GetUserName failed", NULL);
165 return TCL_ERROR;
166 }
167 Tcl_AppendResult(interp, user, NULL);
168 return TCL_OK;
169 }
170
171 static char szTemp[4096];
172
173 int outputErr(const char* szPrefix, Tcl_Interp* interp)
174 {
175 int l;
176 char *szError=Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
177 char *szMsg = szTemp;
178 l = strlen(szPrefix) + 2 + strlen(interp->result) + 1;
179 if (szError) {
180 l += strlen(szError) + 2;
181 }
182
183 if (l>4096) szMsg = (char*)malloc(l*sizeof(char));
184 strcpy(szMsg, szPrefix);
185 strcat(szMsg, "\n");
186 strcat(szMsg, interp->result);
187 if (szError) {
188 strcat(szMsg, "\n");
189 strcat(szMsg, szError);
190 }
191 OutputDebugString(szMsg);
192 assert(FALSE);
193 if (szMsg != szTemp) free(szMsg);
194 return 0;
195 }
196
197 int WinGetHostName(clientData, interp, argc, argv)
198 ClientData clientData;
199 Tcl_Interp *interp; /* Current interpreter. */
200 int argc; /* Number of arguments. */
201 char *argv[]; /* Argument strings. */
202 {
203 char hostname[MAXGETHOSTSTRUCT];
204 if (SOCKET_ERROR == gethostname(hostname, MAXGETHOSTSTRUCT)) {
205 Tcl_AddErrorInfo(interp, "gethostname failed!");
206 }
207 fprintf(stderr, "%s\n", hostname);
208 Tcl_AppendResult(interp, hostname, NULL);
209 return TCL_OK;
210 }
211
212
213 #define MAX_REGROOT_LEN 80
214 static void
215 extract_root(const char **path, char *root)
216 {
217 char *slash = strchr(*path, '\\');
218 if (slash==NULL) { *root = '\0'; }
219 else {
220 int len = slash-(*path);
221 if (len >= MAX_REGROOT_LEN) len = MAX_REGROOT_LEN-1;
222 strncpy(root, *path, len);
223 root[len] = '\0';
224 *path = slash+1;
225 }
226 }
227
228 static HKEY
229 regroot(root)
230 char *root;
231 {
232 if (strcasecmp(root, "HKEY_LOCAL_MACHINE") == 0)
233 return HKEY_LOCAL_MACHINE;
234 else if (strcasecmp(root, "HKEY_CURRENT_USER") == 0)
235 return HKEY_CURRENT_USER;
236 else if (strcasecmp(root, "HKEY_USERS") == 0)
237 return HKEY_USERS;
238 else if (strcasecmp(root, "HKEY_CLASSES_ROOT") == 0)
239 return HKEY_CLASSES_ROOT;
240 else
241 return NULL;
242 }
243
244 int
245 WinGetRegistry(clientData, interp, argc, argv)
246 ClientData clientData;
247 Tcl_Interp *interp; /* Current interpreter. */
248 int argc; /* Number of arguments. */
249 char **argv; /* Argument strings. */
250 {
251 HKEY hKey, hRootKey;
252 DWORD dwType;
253 DWORD len, retCode;
254 CHAR *regPath, *keyValue, *keyData, regRoot[MAX_REGROOT_LEN];
255 int retval = TCL_ERROR;
256
257 if (argc != 3) {
258 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
259 "key value\"", (char *) NULL);
260 return TCL_ERROR;
261 }
262 regPath = argv[1];
263 keyValue = argv[2];
264
265 extract_root(®Path, regRoot);
266
267 if ((hRootKey = regroot(regRoot)) == NULL) {
268 Tcl_AppendResult(interp, "Unknown registry root \"",
269 regRoot, "\"", NULL);
270 return (TCL_ERROR);
271 }
272
273 retCode = RegOpenKeyEx(hRootKey, regPath, 0,
274 KEY_READ, &hKey);
275 if (retCode == ERROR_SUCCESS) {
276 retCode = RegQueryValueEx(hKey, keyValue, NULL, &dwType,
277 NULL, &len);
278 if (retCode == ERROR_SUCCESS &&
279 dwType == REG_SZ && len) {
280 keyData = (CHAR *) ckalloc(len);
281 retCode = RegQueryValueEx(hKey, keyValue, NULL, NULL,
282 keyData, &len);
283 if (retCode == ERROR_SUCCESS) {
284 Tcl_AppendResult(interp, keyData, NULL);
285 retval = TCL_OK;
286 }
287 ckfree(keyData);
288 }
289 RegCloseKey(hKey);
290 }
291 if (retval == TCL_ERROR) {
292 Tcl_AppendResult(interp, "Cannot find registry entry \"", regRoot,
293 "\\", regPath, "\\", keyValue, "\"", NULL);
294 }
295 return (retval);
296 }
297
298 int
299 WinPutRegistry(clientData, interp, argc, argv)
300 ClientData clientData;
301 Tcl_Interp *interp; /* Current interpreter. */
302 int argc; /* Number of arguments. */
303 char **argv; /* Argument strings. */
304 {
305 HKEY hKey, hRootKey;
306 DWORD retCode;
307 CHAR regRoot[MAX_REGROOT_LEN], *regPath, *keyValue, *keyData;
308 DWORD new;
309 int result = TCL_OK;
310
311 if (argc != 4) {
312 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
313 "key value data\"", (char *) NULL);
314 return TCL_ERROR;
315 }
316 regPath = argv[1];
317 keyValue = argv[2];
318 keyData = argv[3];
319
320 extract_root(®Path, regRoot);
321
322 if ((hRootKey = regroot(regRoot)) == NULL) {
323 Tcl_AppendResult(interp, "Unknown registry root \"",
324 regRoot, "\"", NULL);
325 return (TCL_ERROR);
326 }
327
328 retCode = RegCreateKeyEx(hRootKey, regPath, 0,
329 "",
330 REG_OPTION_NON_VOLATILE,
331 KEY_ALL_ACCESS,
332 NULL,
333 &hKey, &new);
334 if (retCode == ERROR_SUCCESS) {
335 retCode = RegSetValueEx(hKey, keyValue, 0, REG_SZ, keyData, strlen(keyData));
336 if (retCode != ERROR_SUCCESS) {
337 Tcl_AppendResult(interp, "unable to set key \"", regRoot, "\\",
338 regPath, "\" with value \"", keyValue, "\"",
339 (char *) NULL);
340 result = TCL_ERROR;
341 }
342 RegCloseKey(hKey);
343 }
344 else {
345 Tcl_AppendResult(interp, "unable to create key \"", regRoot, "\\",
346 regPath, "\"", (char *) NULL);
347 result = TCL_ERROR;
348 }
349 return (result);
350 }
351
352 static char initScript[]=
353 "proc init {} {\n\
354 global tcl_library tcl_platform tcl_version tcl_patchLevel env errorInfo\n\
355 global tcl_pkgPath\n\
356 rename init {}\n\
357 set errors {}\n\
358 proc tcl_envTraceProc {lo n1 n2 op} {\n\
359 global env\n\
360 set x $env($n2)\n\
361 set env($lo) $x\n\
362 set env([string toupper $lo]) $x\n\
363 }\n\
364 foreach p [array names env] {\n\
365 set u [string toupper $p]\n\
366 if {$u != $p} {\n\
367 switch -- $u {\n\
368 COMSPEC -\n\
369 PATH {\n\
370 if {![info exists env($u)]} {\n\
371 set env($u) $env($p)\n\
372 }\n\
373 trace variable env($p) w [list tcl_envTraceProc $p]\n\
374 trace variable env($u) w [list tcl_envTraceProc $p]\n\
375 }\n\
376 }\n\
377 }\n\
378 }\n\
379 if {![info exists env(COMSPEC)]} {\n\
380 if {$tcl_platform(os) == {Windows NT}} {\n\
381 set env(COMSPEC) cmd.exe\n\
382 } else {\n\
383 set env(COMSPEC) command.com\n\
384 }\n\
385 } \n\
386 }\n\
387 init\n";
388
389 int Mash_TclPlatformInit(Tcl_Interp* interp)
390 {
391 /* tcl.CreateCommand("puts", WinPutsCmd, (ClientData)0); */
392 Tcl_CreateCommand(interp, "getusername", WinGetUserName,
393 (ClientData)0, (Tcl_CmdDeleteProc*)0);
394 Tcl_CreateCommand(interp, "gethostname", WinGetHostName,
395 (ClientData)0, (Tcl_CmdDeleteProc*)0);
396 Tcl_CreateCommand(interp, "putregistry", WinPutRegistry,
397 (ClientData)0, (Tcl_CmdDeleteProc*)0);
398 Tcl_CreateCommand(interp, "getregistry", WinGetRegistry,
399 (ClientData)0, (Tcl_CmdDeleteProc*)0);
400 Tcl_Eval(interp, initScript);
401 return TCL_OK;
402 }
403
This page was automatically generated by the
LXR engine.
Visit the LXR main site for more
information.