1 /* This file copied from Tk 8.4.19 and modified to continue support the now
2 deprecated TK_CONFIG_OPTION_SPECIFIED flag. */
3 /*
4 * tkOldConfig.c --
5 *
6 * This file contains the Tk_ConfigureWidget procedure. THIS FILE
7 * IS HERE FOR BACKWARD COMPATIBILITY; THE NEW CONFIGURATION
8 * PACKAGE SHOULD BE USED FOR NEW PROJECTS.
9 *
10 * Copyright (c) 1990-1994 The Regents of the University of California.
11 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
12 *
13 * See the file "license.terms" for information on usage and redistribution
14 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
15 *
16 * RCS: @(#) $Id: bltOldConfig.c,v 1.3 2009/10/25 04:30:52 pcmacdon Exp $
17 */
18
19 #include "tk.h"
20 #include "bltOldConfig.h"
21
22 /*
23 * Values for "flags" field of Tk_ConfigSpec structures. Be sure
24 * to coordinate these values with those defined in tk.h
25 * (TK_CONFIG_COLOR_ONLY, etc.). There must not be overlap!
26 *
27 * INIT - Non-zero means (char *) things have been
28 * converted to Tk_Uid's.
29 */
30
31 #define INIT 0x20
32
33 /*
34 * Forward declarations for procedures defined later in this file:
35 */
36
37 static int DoConfig _ANSI_ARGS_((Tcl_Interp *interp,
38 Tk_Window tkwin, Tk_ConfigSpec *specPtr,
39 Tk_Uid value, int valueIsUid, char *widgRec));
40 static Tk_ConfigSpec * FindConfigSpec _ANSI_ARGS_((Tcl_Interp *interp,
41 Tk_ConfigSpec *specs, CONST char *argvName,
42 int needFlags, int hateFlags));
43 static char * FormatConfigInfo _ANSI_ARGS_((Tcl_Interp *interp,
44 Tk_Window tkwin, Tk_ConfigSpec *specPtr,
45 char *widgRec));
46 static CONST char * FormatConfigValue _ANSI_ARGS_((Tcl_Interp *interp,
47 Tk_Window tkwin, Tk_ConfigSpec *specPtr,
48 char *widgRec, char *buffer,
49 Tcl_FreeProc **freeProcPtr));
50 static Tk_ConfigSpec * GetCachedSpecs _ANSI_ARGS_((Tcl_Interp *interp,
51 const Tk_ConfigSpec *staticSpecs));
52 static void DeleteSpecCacheTable _ANSI_ARGS_((
53 ClientData clientData, Tcl_Interp *interp));
54
55 /*
56 *--------------------------------------------------------------
57 *
58 * Blt_ConfigureWidget --
59 *
60 * Process command-line options and database options to
61 * fill in fields of a widget record with resources and
62 * other parameters.
63 *
64 * Results:
65 * A standard Tcl return value. In case of an error,
66 * the interp's result will hold an error message.
67 *
68 * Side effects:
69 * The fields of widgRec get filled in with information from
70 * argc/argv and the option database. Old information in
71 * widgRec's fields gets recycled. A copy of the spec-table is
72 * taken with (some of) the char* *fields converted into Tk_Uid
73 * fields; this copy will be released when *the interpreter
74 * terminates.
75 *
76 *--------------------------------------------------------------
77 */
78
79 int
Blt_ConfigureWidget(interp,tkwin,origSpecs,argc,argv,widgRec,flags)80 Blt_ConfigureWidget(interp, tkwin, origSpecs, argc, argv, widgRec, flags)
81 Tcl_Interp *interp; /* Interpreter for error reporting. */
82 Tk_Window tkwin; /* Window containing widget (needed to
83 * set up X resources). */
84 Tk_ConfigSpec *origSpecs; /* Describes legal options. */
85 int argc; /* Number of elements in argv. */
86 CONST char **argv; /* Command-line options. */
87 char *widgRec; /* Record whose fields are to be
88 * modified. Values must be properly
89 * initialized. */
90 int flags; /* Used to specify additional flags
91 * that must be present in config specs
92 * for them to be considered. Also,
93 * may have TK_CONFIG_ARGV_ONLY set. */
94 {
95 register Tk_ConfigSpec *specs, *specPtr, *origSpecPtr;
96 Tk_Uid value; /* Value of option from database. */
97 int needFlags; /* Specs must contain this set of flags
98 * or else they are not considered. */
99 int hateFlags; /* If a spec contains any bits here, it's
100 * not considered. */
101
102 if (tkwin == NULL) {
103 /*
104 * Either we're not really in Tk, or the main window was destroyed and
105 * we're on our way out of the application
106 */
107 Tcl_AppendResult(interp, "NULL main window", (char *)NULL);
108 return TCL_ERROR;
109 }
110
111 needFlags = flags & ~(TK_CONFIG_USER_BIT - 1);
112 if (Tk_Depth(tkwin) <= 1) {
113 hateFlags = TK_CONFIG_COLOR_ONLY;
114 } else {
115 hateFlags = TK_CONFIG_MONO_ONLY;
116 }
117
118 /*
119 * Get the build of the config for this interpreter and reset any
120 * indication of changed options.
121 */
122
123 specs = GetCachedSpecs(interp, origSpecs);
124
125 for (specPtr = specs; specPtr->type != TK_CONFIG_END; specPtr++) {
126 specPtr->specFlags &= ~TK_CONFIG_OPTION_SPECIFIED;
127 }
128
129 /*
130 * Pass one: scan through all of the arguments, processing those
131 * that match entries in the specs.
132 */
133
134 for ( ; argc > 0; argc -= 2, argv += 2) {
135 CONST char *arg;
136
137 if (flags & TK_CONFIG_OBJS) {
138 arg = Tcl_GetStringFromObj((Tcl_Obj *) *argv, NULL);
139 } else {
140 arg = *argv;
141 }
142 specPtr = FindConfigSpec(interp, specs, arg, needFlags, hateFlags);
143 if (specPtr == NULL) {
144 return TCL_ERROR;
145 }
146
147 /*
148 * Process the entry.
149 */
150
151 if (argc < 2) {
152 Tcl_AppendResult(interp, "value for \"", arg,
153 "\" missing", (char *) NULL);
154 return TCL_ERROR;
155 }
156 if (flags & TK_CONFIG_OBJS) {
157 arg = Tcl_GetString((Tcl_Obj *) argv[1]);
158 } else {
159 arg = argv[1];
160 }
161 if (DoConfig(interp, tkwin, specPtr, arg, 0, widgRec) != TCL_OK) {
162 char msg[100];
163
164 sprintf(msg, "\n (processing \"%.40s\" option)",
165 specPtr->argvName);
166 Tcl_AddErrorInfo(interp, msg);
167 return TCL_ERROR;
168 }
169 specPtr->specFlags |= TK_CONFIG_OPTION_SPECIFIED;
170 }
171
172 /*
173 * Thread Unsafe! For compatibility through 8.4.x, we set the original
174 * specPtr flags to indicate changed options. This has been removed
175 * from 8.5. Switch to Tcl_Obj-based options instead. [Bug 749908]
176 */
177
178 for (origSpecPtr = origSpecs, specPtr = specs;
179 specPtr->type != TK_CONFIG_END; origSpecPtr++, specPtr++) {
180 origSpecPtr->specFlags = specPtr->specFlags;
181 }
182
183 /*
184 * Pass two: scan through all of the specs again; if no
185 * command-line argument matched a spec, then check for info
186 * in the option database. If there was nothing in the
187 * database, then use the default.
188 */
189
190 if (!(flags & TK_CONFIG_ARGV_ONLY)) {
191 for (specPtr=specs; specPtr->type!=TK_CONFIG_END; specPtr++) {
192 if ((specPtr->specFlags & TK_CONFIG_OPTION_SPECIFIED)
193 || (specPtr->argvName == NULL)
194 || (specPtr->type == TK_CONFIG_SYNONYM)) {
195 continue;
196 }
197 if (((specPtr->specFlags & needFlags) != needFlags)
198 || (specPtr->specFlags & hateFlags)) {
199 continue;
200 }
201 value = NULL;
202 if (specPtr->dbName != NULL) {
203 value = Tk_GetOption(tkwin, specPtr->dbName, specPtr->dbClass);
204 }
205 if (value != NULL) {
206 if (DoConfig(interp, tkwin, specPtr, value, 1, widgRec) !=
207 TCL_OK) {
208 char msg[200];
209
210 sprintf(msg, "\n (%s \"%.50s\" in widget \"%.50s\")",
211 "database entry for",
212 specPtr->dbName, Tk_PathName(tkwin));
213 if (getenv("TCL_BADOPTS") == NULL) {
214 fprintf(stderr, "%s%s\n", Tcl_GetStringResult(interp), msg);
215 value = NULL;
216 goto dodefault;
217 }
218 Tcl_AddErrorInfo(interp, msg);
219 return TCL_ERROR;
220 }
221 } else {
222 dodefault:
223 if (specPtr->defValue != NULL) {
224 value = Tk_GetUid(specPtr->defValue);
225 } else {
226 value = NULL;
227 }
228 if ((value != NULL) && !(specPtr->specFlags
229 & TK_CONFIG_DONT_SET_DEFAULT)) {
230 if (DoConfig(interp, tkwin, specPtr, value, 1, widgRec) !=
231 TCL_OK) {
232 char msg[200];
233
234 sprintf(msg,
235 "\n (%s \"%.50s\" in widget \"%.50s\")",
236 "default value for",
237 specPtr->dbName, Tk_PathName(tkwin));
238 Tcl_AddErrorInfo(interp, msg);
239 return TCL_ERROR;
240 }
241 }
242 }
243 }
244 }
245
246 return TCL_OK;
247 }
248
249 /*
250 *--------------------------------------------------------------
251 *
252 * FindConfigSpec --
253 *
254 * Search through a table of configuration specs, looking for
255 * one that matches a given argvName.
256 *
257 * Results:
258 * The return value is a pointer to the matching entry, or NULL
259 * if nothing matched. In that case an error message is left
260 * in the interp's result.
261 *
262 * Side effects:
263 * None.
264 *
265 *--------------------------------------------------------------
266 */
267
268 static Tk_ConfigSpec *
FindConfigSpec(interp,specs,argvName,needFlags,hateFlags)269 FindConfigSpec(interp, specs, argvName, needFlags, hateFlags)
270 Tcl_Interp *interp; /* Used for reporting errors. */
271 Tk_ConfigSpec *specs; /* Pointer to table of configuration
272 * specifications for a widget. */
273 CONST char *argvName; /* Name (suitable for use in a "config"
274 * command) identifying particular option. */
275 int needFlags; /* Flags that must be present in matching
276 * entry. */
277 int hateFlags; /* Flags that must NOT be present in
278 * matching entry. */
279 {
280 register Tk_ConfigSpec *specPtr;
281 register char c; /* First character of current argument. */
282 Tk_ConfigSpec *matchPtr; /* Matching spec, or NULL. */
283 size_t length;
284
285 c = argvName[1];
286 length = strlen(argvName);
287 matchPtr = NULL;
288 for (specPtr = specs; specPtr->type != TK_CONFIG_END; specPtr++) {
289 if (specPtr->argvName == NULL) {
290 continue;
291 }
292 if ((specPtr->argvName[1] != c)
293 || (strncmp(specPtr->argvName, argvName, length) != 0)) {
294 continue;
295 }
296 if (((specPtr->specFlags & needFlags) != needFlags)
297 || (specPtr->specFlags & hateFlags)) {
298 continue;
299 }
300 if (specPtr->argvName[length] == 0) {
301 matchPtr = specPtr;
302 goto gotMatch;
303 }
304 if (matchPtr != NULL) {
305 Tcl_AppendResult(interp, "ambiguous option \"", argvName,
306 "\"", (char *) NULL);
307 return (Tk_ConfigSpec *) NULL;
308 }
309 matchPtr = specPtr;
310 }
311
312 if (matchPtr == NULL) {
313 Tcl_AppendResult(interp, "unknown option \"", argvName,
314 "\"", (char *) NULL);
315 return (Tk_ConfigSpec *) NULL;
316 }
317
318 /*
319 * Found a matching entry. If it's a synonym, then find the
320 * entry that it's a synonym for.
321 */
322
323 gotMatch:
324 specPtr = matchPtr;
325 if (specPtr->type == TK_CONFIG_SYNONYM) {
326 for (specPtr = specs; ; specPtr++) {
327 if (specPtr->type == TK_CONFIG_END) {
328 Tcl_AppendResult(interp,
329 "couldn't find synonym for option \"",
330 argvName, "\"", (char *) NULL);
331 return (Tk_ConfigSpec *) NULL;
332 }
333 if ((specPtr->dbName == matchPtr->dbName)
334 && (specPtr->type != TK_CONFIG_SYNONYM)
335 && ((specPtr->specFlags & needFlags) == needFlags)
336 && !(specPtr->specFlags & hateFlags)) {
337 break;
338 }
339 }
340 }
341 return specPtr;
342 }
343
344 /*
345 *--------------------------------------------------------------
346 *
347 * DoConfig --
348 *
349 * This procedure applies a single configuration option
350 * to a widget record.
351 *
352 * Results:
353 * A standard Tcl return value.
354 *
355 * Side effects:
356 * WidgRec is modified as indicated by specPtr and value.
357 * The old value is recycled, if that is appropriate for
358 * the value type.
359 *
360 *--------------------------------------------------------------
361 */
362
363 static int
DoConfig(interp,tkwin,specPtr,value,valueIsUid,widgRec)364 DoConfig(interp, tkwin, specPtr, value, valueIsUid, widgRec)
365 Tcl_Interp *interp; /* Interpreter for error reporting. */
366 Tk_Window tkwin; /* Window containing widget (needed to
367 * set up X resources). */
368 Tk_ConfigSpec *specPtr; /* Specifier to apply. */
369 Tk_Uid value; /* Value to use to fill in widgRec. */
370 int valueIsUid; /* Non-zero means value is a Tk_Uid;
371 * zero means it's an ordinary string. */
372 char *widgRec; /* Record whose fields are to be
373 * modified. Values must be properly
374 * initialized. */
375 {
376 char *ptr;
377 Tk_Uid uid;
378 int nullValue;
379
380 nullValue = 0;
381 if ((*value == 0) && (specPtr->specFlags & TK_CONFIG_NULL_OK)) {
382 nullValue = 1;
383 }
384
385 do {
386 ptr = widgRec + specPtr->offset;
387 switch (specPtr->type) {
388 case TK_CONFIG_BOOLEAN:
389 if (Tcl_GetBoolean(interp, value, (int *) ptr) != TCL_OK) {
390 return TCL_ERROR;
391 }
392 break;
393 case TK_CONFIG_INT:
394 if (Tcl_GetInt(interp, value, (int *) ptr) != TCL_OK) {
395 return TCL_ERROR;
396 }
397 break;
398 case TK_CONFIG_DOUBLE:
399 if (Tcl_GetDouble(interp, value, (double *) ptr) != TCL_OK) {
400 return TCL_ERROR;
401 }
402 break;
403 case TK_CONFIG_STRING: {
404 char *old, *new;
405
406 if (nullValue) {
407 new = NULL;
408 } else {
409 new = (char *) ckalloc((unsigned) (strlen(value) + 1));
410 strcpy(new, value);
411 }
412 old = *((char **) ptr);
413 if (old != NULL) {
414 ckfree(old);
415 }
416 *((char **) ptr) = new;
417 break;
418 }
419 case TK_CONFIG_UID:
420 if (nullValue) {
421 *((Tk_Uid *) ptr) = NULL;
422 } else {
423 uid = valueIsUid ? (Tk_Uid) value : Tk_GetUid(value);
424 *((Tk_Uid *) ptr) = uid;
425 }
426 break;
427 case TK_CONFIG_COLOR: {
428 XColor *newPtr, *oldPtr;
429
430 if (nullValue) {
431 newPtr = NULL;
432 } else {
433 uid = valueIsUid ? (Tk_Uid) value : Tk_GetUid(value);
434 newPtr = Tk_GetColor(interp, tkwin, uid);
435 if (newPtr == NULL) {
436 return TCL_ERROR;
437 }
438 }
439 oldPtr = *((XColor **) ptr);
440 if (oldPtr != NULL) {
441 Tk_FreeColor(oldPtr);
442 }
443 *((XColor **) ptr) = newPtr;
444 break;
445 }
446 case TK_CONFIG_FONT: {
447 Tk_Font new;
448
449 if (nullValue) {
450 new = NULL;
451 } else {
452 new = Tk_GetFont(interp, tkwin, value);
453 if (new == NULL) {
454 return TCL_ERROR;
455 }
456 }
457 Tk_FreeFont(*((Tk_Font *) ptr));
458 *((Tk_Font *) ptr) = new;
459 break;
460 }
461 case TK_CONFIG_BITMAP: {
462 Pixmap new, old;
463
464 if (nullValue) {
465 new = None;
466 } else {
467 uid = valueIsUid ? (Tk_Uid) value : Tk_GetUid(value);
468 new = Tk_GetBitmap(interp, tkwin, uid);
469 if (new == None) {
470 return TCL_ERROR;
471 }
472 }
473 old = *((Pixmap *) ptr);
474 if (old != None) {
475 Tk_FreeBitmap(Tk_Display(tkwin), old);
476 }
477 *((Pixmap *) ptr) = new;
478 break;
479 }
480 case TK_CONFIG_BORDER: {
481 Tk_3DBorder new, old;
482
483 if (nullValue) {
484 new = NULL;
485 } else {
486 uid = valueIsUid ? (Tk_Uid) value : Tk_GetUid(value);
487 new = Tk_Get3DBorder(interp, tkwin, uid);
488 if (new == NULL) {
489 return TCL_ERROR;
490 }
491 }
492 old = *((Tk_3DBorder *) ptr);
493 if (old != NULL) {
494 Tk_Free3DBorder(old);
495 }
496 *((Tk_3DBorder *) ptr) = new;
497 break;
498 }
499 case TK_CONFIG_RELIEF:
500 uid = valueIsUid ? (Tk_Uid) value : Tk_GetUid(value);
501 if (Tk_GetRelief(interp, uid, (int *) ptr) != TCL_OK) {
502 return TCL_ERROR;
503 }
504 break;
505 case TK_CONFIG_CURSOR:
506 case TK_CONFIG_ACTIVE_CURSOR: {
507 Tk_Cursor new, old;
508
509 if (nullValue) {
510 new = None;
511 } else {
512 uid = valueIsUid ? (Tk_Uid) value : Tk_GetUid(value);
513 new = Tk_GetCursor(interp, tkwin, uid);
514 if (new == None) {
515 return TCL_ERROR;
516 }
517 }
518 old = *((Tk_Cursor *) ptr);
519 if (old != None) {
520 Tk_FreeCursor(Tk_Display(tkwin), old);
521 }
522 *((Tk_Cursor *) ptr) = new;
523 if (specPtr->type == TK_CONFIG_ACTIVE_CURSOR) {
524 Tk_DefineCursor(tkwin, new);
525 }
526 break;
527 }
528 case TK_CONFIG_JUSTIFY:
529 uid = valueIsUid ? (Tk_Uid) value : Tk_GetUid(value);
530 if (Tk_GetJustify(interp, uid, (Tk_Justify *) ptr) != TCL_OK) {
531 return TCL_ERROR;
532 }
533 break;
534 case TK_CONFIG_ANCHOR:
535 uid = valueIsUid ? (Tk_Uid) value : Tk_GetUid(value);
536 if (Tk_GetAnchor(interp, uid, (Tk_Anchor *) ptr) != TCL_OK) {
537 return TCL_ERROR;
538 }
539 break;
540 case TK_CONFIG_CAP_STYLE:
541 uid = valueIsUid ? (Tk_Uid) value : Tk_GetUid(value);
542 if (Tk_GetCapStyle(interp, uid, (int *) ptr) != TCL_OK) {
543 return TCL_ERROR;
544 }
545 break;
546 case TK_CONFIG_JOIN_STYLE:
547 uid = valueIsUid ? (Tk_Uid) value : Tk_GetUid(value);
548 if (Tk_GetJoinStyle(interp, uid, (int *) ptr) != TCL_OK) {
549 return TCL_ERROR;
550 }
551 break;
552 case TK_CONFIG_PIXELS:
553 if (Tk_GetPixels(interp, tkwin, value, (int *) ptr)
554 != TCL_OK) {
555 return TCL_ERROR;
556 }
557 break;
558 case TK_CONFIG_MM:
559 if (Tk_GetScreenMM(interp, tkwin, value, (double *) ptr)
560 != TCL_OK) {
561 return TCL_ERROR;
562 }
563 break;
564 case TK_CONFIG_WINDOW: {
565 Tk_Window tkwin2;
566
567 if (nullValue) {
568 tkwin2 = NULL;
569 } else {
570 tkwin2 = Tk_NameToWindow(interp, value, tkwin);
571 if (tkwin2 == NULL) {
572 return TCL_ERROR;
573 }
574 }
575 *((Tk_Window *) ptr) = tkwin2;
576 break;
577 }
578 case TK_CONFIG_CUSTOM:
579 if ((*specPtr->customPtr->parseProc)(
580 specPtr->customPtr->clientData, interp, tkwin,
581 value, widgRec, specPtr->offset) != TCL_OK) {
582 return TCL_ERROR;
583 }
584 break;
585 default: {
586 char buf[64 + TCL_INTEGER_SPACE];
587
588 sprintf(buf, "bad config table: unknown type %d",
589 specPtr->type);
590 Tcl_SetResult(interp, buf, TCL_VOLATILE);
591 return TCL_ERROR;
592 }
593 }
594 specPtr++;
595 } while ((specPtr->argvName == NULL) && (specPtr->type != TK_CONFIG_END));
596 return TCL_OK;
597 }
598
599 /*
600 *--------------------------------------------------------------
601 *
602 * Blt_ConfigureInfo --
603 *
604 * Return information about the configuration options
605 * for a window, and their current values.
606 *
607 * Results:
608 * Always returns TCL_OK. The interp's result will be modified
609 * hold a description of either a single configuration option
610 * available for "widgRec" via "specs", or all the configuration
611 * options available. In the "all" case, the result will
612 * available for "widgRec" via "specs". The result will
613 * be a list, each of whose entries describes one option.
614 * Each entry will itself be a list containing the option's
615 * name for use on command lines, database name, database
616 * class, default value, and current value (empty string
617 * if none). For options that are synonyms, the list will
618 * contain only two values: name and synonym name. If the
619 * "name" argument is non-NULL, then the only information
620 * returned is that for the named argument (i.e. the corresponding
621 * entry in the overall list is returned).
622 *
623 * Side effects:
624 * None.
625 *
626 *--------------------------------------------------------------
627 */
628
629 int
Blt_ConfigureInfo(interp,tkwin,specs,widgRec,argvName,flags)630 Blt_ConfigureInfo(interp, tkwin, specs, widgRec, argvName, flags)
631 Tcl_Interp *interp; /* Interpreter for error reporting. */
632 Tk_Window tkwin; /* Window corresponding to widgRec. */
633 Tk_ConfigSpec *specs; /* Describes legal options. */
634 char *widgRec; /* Record whose fields contain current
635 * values for options. */
636 CONST char *argvName; /* If non-NULL, indicates a single option
637 * whose info is to be returned. Otherwise
638 * info is returned for all options. */
639 int flags; /* Used to specify additional flags
640 * that must be present in config specs
641 * for them to be considered. */
642 {
643 register Tk_ConfigSpec *specPtr;
644 int needFlags, hateFlags;
645 char *list;
646 char *leader = "{";
647
648 needFlags = flags & ~(TK_CONFIG_USER_BIT - 1);
649 if (Tk_Depth(tkwin) <= 1) {
650 hateFlags = TK_CONFIG_COLOR_ONLY;
651 } else {
652 hateFlags = TK_CONFIG_MONO_ONLY;
653 }
654
655 /*
656 * Get the build of the config for this interpreter.
657 */
658
659 specs = GetCachedSpecs(interp, specs);
660
661 /*
662 * If information is only wanted for a single configuration
663 * spec, then handle that one spec specially.
664 */
665
666 Tcl_SetResult(interp, (char *) NULL, TCL_STATIC);
667 if (argvName != NULL) {
668 specPtr = FindConfigSpec(interp, specs, argvName, needFlags,hateFlags);
669 if (specPtr == NULL) {
670 return TCL_ERROR;
671 }
672 Tcl_SetResult(interp,
673 FormatConfigInfo(interp, tkwin, specPtr, widgRec),
674 TCL_DYNAMIC);
675 return TCL_OK;
676 }
677
678 /*
679 * Loop through all the specs, creating a big list with all
680 * their information.
681 */
682
683 for (specPtr = specs; specPtr->type != TK_CONFIG_END; specPtr++) {
684 if ((argvName != NULL) && (specPtr->argvName != argvName)) {
685 continue;
686 }
687 if (((specPtr->specFlags & needFlags) != needFlags)
688 || (specPtr->specFlags & hateFlags)) {
689 continue;
690 }
691 if (specPtr->argvName == NULL) {
692 continue;
693 }
694 list = FormatConfigInfo(interp, tkwin, specPtr, widgRec);
695 Tcl_AppendResult(interp, leader, list, "}", (char *) NULL);
696 ckfree(list);
697 leader = " {";
698 }
699 return TCL_OK;
700 }
701
702 /*
703 *--------------------------------------------------------------
704 *
705 * FormatConfigInfo --
706 *
707 * Create a valid Tcl list holding the configuration information
708 * for a single configuration option.
709 *
710 * Results:
711 * A Tcl list, dynamically allocated. The caller is expected to
712 * arrange for this list to be freed eventually.
713 *
714 * Side effects:
715 * Memory is allocated.
716 *
717 *--------------------------------------------------------------
718 */
719
720 static char *
FormatConfigInfo(interp,tkwin,specPtr,widgRec)721 FormatConfigInfo(interp, tkwin, specPtr, widgRec)
722 Tcl_Interp *interp; /* Interpreter to use for things
723 * like floating-point precision. */
724 Tk_Window tkwin; /* Window corresponding to widget. */
725 register Tk_ConfigSpec *specPtr; /* Pointer to information describing
726 * option. */
727 char *widgRec; /* Pointer to record holding current
728 * values of info for widget. */
729 {
730 CONST char *argv[7];
731 char *result;
732 char buffer[200];
733 Tcl_FreeProc *freeProc = (Tcl_FreeProc *) NULL;
734
735 argv[0] = specPtr->argvName;
736 argv[1] = specPtr->dbName;
737 argv[2] = specPtr->dbClass;
738 argv[3] = specPtr->defValue;
739 if (specPtr->type == TK_CONFIG_SYNONYM) {
740 return Tcl_Merge(2, argv);
741 }
742 argv[4] = FormatConfigValue(interp, tkwin, specPtr, widgRec, buffer,
743 &freeProc);
744 if (argv[1] == NULL) {
745 argv[1] = "";
746 }
747 if (argv[2] == NULL) {
748 argv[2] = "";
749 }
750 if (argv[3] == NULL) {
751 argv[3] = "";
752 }
753 if (argv[4] == NULL) {
754 argv[4] = "";
755 }
756 if (strstr(Tk_PathName(tkwin), ".__##") &&
757 specPtr->type < TK_CONFIG_CUSTOM && specPtr->type >=0) {
758 static char *conftypes[TK_CONFIG_END+10] = {
759 "bool", "int", "double", "string", "uid", "color", "font",
760 "bitmap", "border", "relief", "cursor", "activecursor", "justify",
761 "anchor", "syn", "cap", "join", "pixels", "mm", "window", "custom",
762 "END"
763 };
764 if (conftypes[TK_CONFIG_END] == 0 ||
765 strcmp(conftypes[TK_CONFIG_END],"END")) {
766 fprintf(stderr, "Tk_ConfigTypes in blt changed\n");
767 }
768
769
770 argv[5] = conftypes[specPtr->type];
771 result = Tcl_Merge(6, argv);
772
773 } else {
774 result = Tcl_Merge(5, argv);
775 }
776 if (freeProc != NULL) {
777 if ((freeProc == TCL_DYNAMIC) || (freeProc == (Tcl_FreeProc *) free)) {
778 ckfree((char *)argv[4]);
779 } else {
780 (*freeProc)((char *)argv[4]);
781 }
782 }
783 return result;
784 }
785
786 /*
787 *----------------------------------------------------------------------
788 *
789 * FormatConfigValue --
790 *
791 * This procedure formats the current value of a configuration
792 * option.
793 *
794 * Results:
795 * The return value is the formatted value of the option given
796 * by specPtr and widgRec. If the value is static, so that it
797 * need not be freed, *freeProcPtr will be set to NULL; otherwise
798 * *freeProcPtr will be set to the address of a procedure to
799 * free the result, and the caller must invoke this procedure
800 * when it is finished with the result.
801 *
802 * Side effects:
803 * None.
804 *
805 *----------------------------------------------------------------------
806 */
807
808 static CONST char *
FormatConfigValue(interp,tkwin,specPtr,widgRec,buffer,freeProcPtr)809 FormatConfigValue(interp, tkwin, specPtr, widgRec, buffer, freeProcPtr)
810 Tcl_Interp *interp; /* Interpreter for use in real conversions. */
811 Tk_Window tkwin; /* Window corresponding to widget. */
812 Tk_ConfigSpec *specPtr; /* Pointer to information describing option.
813 * Must not point to a synonym option. */
814 char *widgRec; /* Pointer to record holding current
815 * values of info for widget. */
816 char *buffer; /* Static buffer to use for small values.
817 * Must have at least 200 bytes of storage. */
818 Tcl_FreeProc **freeProcPtr; /* Pointer to word to fill in with address
819 * of procedure to free the result, or NULL
820 * if result is static. */
821 {
822 CONST char *ptr, *result;
823
824 *freeProcPtr = NULL;
825 ptr = widgRec + specPtr->offset;
826 result = "";
827 switch (specPtr->type) {
828 case TK_CONFIG_BOOLEAN:
829 if (*((int *) ptr) == 0) {
830 result = "0";
831 } else {
832 result = "1";
833 }
834 break;
835 case TK_CONFIG_INT:
836 sprintf(buffer, "%d", *((int *) ptr));
837 result = buffer;
838 break;
839 case TK_CONFIG_DOUBLE:
840 Tcl_PrintDouble(interp, *((double *) ptr), buffer);
841 result = buffer;
842 break;
843 case TK_CONFIG_STRING:
844 result = (*(char **) ptr);
845 if (result == NULL) {
846 result = "";
847 }
848 break;
849 case TK_CONFIG_UID: {
850 Tk_Uid uid = *((Tk_Uid *) ptr);
851 if (uid != NULL) {
852 result = uid;
853 }
854 break;
855 }
856 case TK_CONFIG_COLOR: {
857 XColor *colorPtr = *((XColor **) ptr);
858 if (colorPtr != NULL) {
859 result = Tk_NameOfColor(colorPtr);
860 }
861 break;
862 }
863 case TK_CONFIG_FONT: {
864 Tk_Font tkfont = *((Tk_Font *) ptr);
865 if (tkfont != NULL) {
866 result = Tk_NameOfFont(tkfont);
867 }
868 break;
869 }
870 case TK_CONFIG_BITMAP: {
871 Pixmap pixmap = *((Pixmap *) ptr);
872 if (pixmap != None) {
873 result = Tk_NameOfBitmap(Tk_Display(tkwin), pixmap);
874 }
875 break;
876 }
877 case TK_CONFIG_BORDER: {
878 Tk_3DBorder border = *((Tk_3DBorder *) ptr);
879 if (border != NULL) {
880 result = Tk_NameOf3DBorder(border);
881 }
882 break;
883 }
884 case TK_CONFIG_RELIEF:
885 result = Tk_NameOfRelief(*((int *) ptr));
886 break;
887 case TK_CONFIG_CURSOR:
888 case TK_CONFIG_ACTIVE_CURSOR: {
889 Tk_Cursor cursor = *((Tk_Cursor *) ptr);
890 if (cursor != None) {
891 result = Tk_NameOfCursor(Tk_Display(tkwin), cursor);
892 }
893 break;
894 }
895 case TK_CONFIG_JUSTIFY:
896 result = Tk_NameOfJustify(*((Tk_Justify *) ptr));
897 break;
898 case TK_CONFIG_ANCHOR:
899 result = Tk_NameOfAnchor(*((Tk_Anchor *) ptr));
900 break;
901 case TK_CONFIG_CAP_STYLE:
902 result = Tk_NameOfCapStyle(*((int *) ptr));
903 break;
904 case TK_CONFIG_JOIN_STYLE:
905 result = Tk_NameOfJoinStyle(*((int *) ptr));
906 break;
907 case TK_CONFIG_PIXELS:
908 sprintf(buffer, "%d", *((int *) ptr));
909 result = buffer;
910 break;
911 case TK_CONFIG_MM:
912 Tcl_PrintDouble(interp, *((double *) ptr), buffer);
913 result = buffer;
914 break;
915 case TK_CONFIG_WINDOW: {
916 Tk_Window ntkwin;
917
918 ntkwin = *((Tk_Window *) ptr);
919 if (ntkwin != NULL) {
920 result = Tk_PathName(ntkwin);
921 }
922 break;
923 }
924 case TK_CONFIG_CUSTOM:
925 result = (*specPtr->customPtr->printProc)(
926 specPtr->customPtr->clientData, tkwin, widgRec,
927 specPtr->offset, freeProcPtr);
928 break;
929 default:
930 result = "?? unknown type ??";
931 }
932 return result;
933 }
934
935 /*
936 *----------------------------------------------------------------------
937 *
938 * _ConfigureValue --
939 *
940 * This procedure returns the current value of a configuration
941 * option for a widget.
942 *
943 * Results:
944 * The return value is a standard Tcl completion code (TCL_OK or
945 * TCL_ERROR). The interp's result will be set to hold either the value
946 * of the option given by argvName (if TCL_OK is returned) or
947 * an error message (if TCL_ERROR is returned).
948 *
949 * Side effects:
950 * None.
951 *
952 *----------------------------------------------------------------------
953 */
954
955 int
Blt_ConfigureValue(interp,tkwin,specs,widgRec,argvName,flags)956 Blt_ConfigureValue(interp, tkwin, specs, widgRec, argvName, flags)
957 Tcl_Interp *interp; /* Interpreter for error reporting. */
958 Tk_Window tkwin; /* Window corresponding to widgRec. */
959 Tk_ConfigSpec *specs; /* Describes legal options. */
960 char *widgRec; /* Record whose fields contain current
961 * values for options. */
962 CONST char *argvName; /* Gives the command-line name for the
963 * option whose value is to be returned. */
964 int flags; /* Used to specify additional flags
965 * that must be present in config specs
966 * for them to be considered. */
967 {
968 Tk_ConfigSpec *specPtr;
969 int needFlags, hateFlags;
970 Tcl_FreeProc *freeProc;
971 CONST char *result;
972 char buffer[200];
973
974 needFlags = flags & ~(TK_CONFIG_USER_BIT - 1);
975 if (Tk_Depth(tkwin) <= 1) {
976 hateFlags = TK_CONFIG_COLOR_ONLY;
977 } else {
978 hateFlags = TK_CONFIG_MONO_ONLY;
979 }
980
981 /*
982 * Get the build of the config for this interpreter.
983 */
984
985 specs = GetCachedSpecs(interp, specs);
986
987 specPtr = FindConfigSpec(interp, specs, argvName, needFlags, hateFlags);
988 if (specPtr == NULL) {
989 return TCL_ERROR;
990 }
991 result = FormatConfigValue(interp, tkwin, specPtr, widgRec, buffer, &freeProc);
992 Tcl_SetResult(interp, (char *) result, TCL_VOLATILE);
993 if (freeProc != NULL) {
994 if ((freeProc == TCL_DYNAMIC) || (freeProc == (Tcl_FreeProc *) free)) {
995 ckfree((char *)result);
996 } else {
997 (*freeProc)((char *)result);
998 }
999 }
1000 return TCL_OK;
1001 }
1002
1003 /*
1004 *----------------------------------------------------------------------
1005 *
1006 * Blt_FreeOptions --
1007 *
1008 * Free up all resources associated with configuration options.
1009 *
1010 * Results:
1011 * None.
1012 *
1013 * Side effects:
1014 * Any resource in widgRec that is controlled by a configuration
1015 * option (e.g. a Tk_3DBorder or XColor) is freed in the appropriate
1016 * fashion.
1017 *
1018 *----------------------------------------------------------------------
1019 */
1020
1021 /* ARGSUSED */
1022 void
Blt_FreeOptions(specs,widgRec,display,needFlags)1023 Blt_FreeOptions(specs, widgRec, display, needFlags)
1024 Tk_ConfigSpec *specs; /* Describes legal options. */
1025 char *widgRec; /* Record whose fields contain current
1026 * values for options. */
1027 Display *display; /* X display; needed for freeing some
1028 * resources. */
1029 int needFlags; /* Used to specify additional flags
1030 * that must be present in config specs
1031 * for them to be considered. */
1032 {
1033 register Tk_ConfigSpec *specPtr;
1034 char *ptr;
1035
1036 for (specPtr = specs; specPtr->type != TK_CONFIG_END; specPtr++) {
1037 if ((specPtr->specFlags & needFlags) != needFlags) {
1038 continue;
1039 }
1040 ptr = widgRec + specPtr->offset;
1041 switch (specPtr->type) {
1042 case TK_CONFIG_STRING:
1043 if (*((char **) ptr) != NULL) {
1044 ckfree(*((char **) ptr));
1045 *((char **) ptr) = NULL;
1046 }
1047 break;
1048 case TK_CONFIG_COLOR:
1049 if (*((XColor **) ptr) != NULL) {
1050 Tk_FreeColor(*((XColor **) ptr));
1051 *((XColor **) ptr) = NULL;
1052 }
1053 break;
1054 case TK_CONFIG_FONT:
1055 Tk_FreeFont(*((Tk_Font *) ptr));
1056 *((Tk_Font *) ptr) = NULL;
1057 break;
1058 case TK_CONFIG_BITMAP:
1059 if (*((Pixmap *) ptr) != None) {
1060 Tk_FreeBitmap(display, *((Pixmap *) ptr));
1061 *((Pixmap *) ptr) = None;
1062 }
1063 break;
1064 case TK_CONFIG_BORDER:
1065 if (*((Tk_3DBorder *) ptr) != NULL) {
1066 Tk_Free3DBorder(*((Tk_3DBorder *) ptr));
1067 *((Tk_3DBorder *) ptr) = NULL;
1068 }
1069 break;
1070 case TK_CONFIG_CURSOR:
1071 case TK_CONFIG_ACTIVE_CURSOR:
1072 if (*((Tk_Cursor *) ptr) != None) {
1073 Tk_FreeCursor(display, *((Tk_Cursor *) ptr));
1074 *((Tk_Cursor *) ptr) = None;
1075 }
1076 }
1077 }
1078 }
1079 Tk_ConfigSpec *
Blt_GetCachedSpecs(interp,staticSpecs)1080 Blt_GetCachedSpecs(interp, staticSpecs)
1081 Tcl_Interp *interp;
1082 const Tk_ConfigSpec *staticSpecs;
1083 {
1084 return GetCachedSpecs(interp, staticSpecs);
1085 }
1086
1087 /*
1088 *--------------------------------------------------------------
1089 *
1090 * GetCachedSpecs --
1091 *
1092 *Returns a writable per-interpreter (and hence thread-local) copy of
1093 *the given spec-table with (some of) the char* fields converted into
1094 *Tk_Uid fields; this copy will be released when the interpreter
1095 *terminates (during AssocData cleanup).
1096 *
1097 * Results:
1098 *A pointer to the copied table.
1099 *
1100 * Notes:
1101 *The conversion to Tk_Uid is only done the first time, when the table
1102 *copy is taken. After that, the table is assumed to have Tk_Uids where
1103 *they are needed. The time of deletion of the caches isn't very
1104 *important unless you've got a lot of code that uses Tk_ConfigureWidget
1105 *(or *Info or *Value} when the interpreter is being deleted.
1106 *
1107 *--------------------------------------------------------------
1108 */
1109
1110 static Tk_ConfigSpec *
GetCachedSpecs(interp,staticSpecs)1111 GetCachedSpecs(interp, staticSpecs)
1112 Tcl_Interp *interp; /* Interpreter in which to store the cache. */
1113 const Tk_ConfigSpec *staticSpecs;
1114 /* Value to cache a copy of; it is also used
1115 * as a key into the cache. */
1116 {
1117 Tk_ConfigSpec *cachedSpecs;
1118 Tcl_HashTable *specCacheTablePtr;
1119 Tcl_HashEntry *entryPtr;
1120 int isNew;
1121
1122 /*
1123 * Get (or allocate if it doesn't exist) the hash table that the writable
1124 * copies of the widget specs are stored in. In effect, this is
1125 * self-initializing code.
1126 */
1127
1128 specCacheTablePtr = (Tcl_HashTable *)
1129 Tcl_GetAssocData(interp, "tkConfigSpec.threadTable", NULL);
1130 if (specCacheTablePtr == NULL) {
1131 specCacheTablePtr = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
1132 Tcl_InitHashTable(specCacheTablePtr, TCL_ONE_WORD_KEYS);
1133 Tcl_SetAssocData(interp, "tkConfigSpec.threadTable",
1134 DeleteSpecCacheTable, (ClientData) specCacheTablePtr);
1135 }
1136
1137 /*
1138 * Look up or create the hash entry that the constant specs are mapped to,
1139 * which will have the writable specs as its associated value.
1140 */
1141
1142 entryPtr = Tcl_CreateHashEntry(specCacheTablePtr, (char *) staticSpecs,
1143 &isNew);
1144 if (isNew) {
1145 unsigned int entrySpace = sizeof(Tk_ConfigSpec);
1146 const Tk_ConfigSpec *staticSpecPtr;
1147 Tk_ConfigSpec *specPtr;
1148
1149 /*
1150 * OK, no working copy in this interpreter so copy. Need to work out
1151 * how much space to allocate first.
1152 */
1153
1154 for (staticSpecPtr=staticSpecs; staticSpecPtr->type!=TK_CONFIG_END;
1155 staticSpecPtr++) {
1156 entrySpace += sizeof(Tk_ConfigSpec);
1157 }
1158
1159 /*
1160 * Now allocate our working copy's space and copy over the contents
1161 * from the master copy.
1162 */
1163
1164 cachedSpecs = (Tk_ConfigSpec *) ckalloc(entrySpace);
1165 memcpy((void *) cachedSpecs, (void *) staticSpecs, entrySpace);
1166 Tcl_SetHashValue(entryPtr, (ClientData) cachedSpecs);
1167
1168 /*
1169 * Finally, go through and replace database names, database classes
1170 * and default values with Tk_Uids. This is the bit that has to be
1171 * per-thread.
1172 */
1173
1174 for (specPtr=cachedSpecs; specPtr->type!=TK_CONFIG_END; specPtr++) {
1175 if (specPtr->argvName != NULL) {
1176 if (specPtr->dbName != NULL) {
1177 specPtr->dbName = Tk_GetUid(specPtr->dbName);
1178 }
1179 if (specPtr->dbClass != NULL) {
1180 specPtr->dbClass = Tk_GetUid(specPtr->dbClass);
1181 }
1182 if (specPtr->defValue != NULL) {
1183 specPtr->defValue = Tk_GetUid(specPtr->defValue);
1184 }
1185 }
1186 }
1187 } else {
1188 cachedSpecs = (Tk_ConfigSpec *) Tcl_GetHashValue(entryPtr);
1189 }
1190
1191 return cachedSpecs;
1192 }
1193
1194 /*
1195 *--------------------------------------------------------------
1196 *
1197 * DeleteSpecCacheTable --
1198 *
1199 * Delete the per-interpreter copy of all the Tk_ConfigSpec tables which
1200 * were stored in the interpreter's assoc-data store.
1201 *
1202 * Results:
1203 * None
1204 *
1205 * Side effects:
1206 * None
1207 *
1208 *--------------------------------------------------------------
1209 */
1210
1211 static void
DeleteSpecCacheTable(clientData,interp)1212 DeleteSpecCacheTable(clientData, interp)
1213 ClientData clientData;
1214 Tcl_Interp *interp;
1215 {
1216 Tcl_HashTable *tablePtr = (Tcl_HashTable *) clientData;
1217 Tcl_HashEntry *entryPtr;
1218 Tcl_HashSearch search;
1219
1220 for (entryPtr = Tcl_FirstHashEntry(tablePtr,&search); entryPtr != NULL;
1221 entryPtr = Tcl_NextHashEntry(&search)) {
1222 /*
1223 * Someone else deallocates the Tk_Uids themselves.
1224 */
1225
1226 ckfree((char *) Tcl_GetHashValue(entryPtr));
1227 }
1228 Tcl_DeleteHashTable(tablePtr);
1229 ckfree((char *) tablePtr);
1230 }
1231