1/*
2 * tkObj.c --
3 *
4 *	This file contains functions that implement the common Tk object types
5 *
6 * Copyright (c) 1997 Sun Microsystems, Inc.
7 *
8 * See the file "license.terms" for information on usage and redistribution of
9 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
10 *
11 * RCS: @(#) $Id$
12 */
13
14#include "tkInt.h"
15
16/*
17 * The following structure is the internal representation for pixel objects.
18 */
19
20typedef struct PixelRep {
21    double value;
22    int units;
23    Tk_Window tkwin;
24    int returnValue;
25} PixelRep;
26
27#define SIMPLE_PIXELREP(objPtr)				\
28    ((objPtr)->internalRep.twoPtrValue.ptr2 == 0)
29
30#define SET_SIMPLEPIXEL(objPtr, intval)			\
31    (objPtr)->internalRep.twoPtrValue.ptr1 = INT2PTR(intval);	\
32    (objPtr)->internalRep.twoPtrValue.ptr2 = 0
33
34#define GET_SIMPLEPIXEL(objPtr)				\
35    (PTR2INT((objPtr)->internalRep.twoPtrValue.ptr1))
36
37#define SET_COMPLEXPIXEL(objPtr, repPtr)		\
38    (objPtr)->internalRep.twoPtrValue.ptr1 = 0;		\
39    (objPtr)->internalRep.twoPtrValue.ptr2 = (VOID *) repPtr
40
41#define GET_COMPLEXPIXEL(objPtr)			\
42    ((PixelRep *) (objPtr)->internalRep.twoPtrValue.ptr2)
43
44
45/*
46 * The following structure is the internal representation for mm objects.
47 */
48
49typedef struct MMRep {
50    double value;
51    int units;
52    Tk_Window tkwin;
53    double returnValue;
54} MMRep;
55
56/*
57 * The following structure is the internal representation for window objects.
58 * A WindowRep caches name-to-window lookups. The cache is invalid if tkwin is
59 * NULL or if mainPtr->deletionEpoch does not match epoch.
60 */
61
62typedef struct WindowRep {
63    Tk_Window tkwin;		/* Cached window; NULL if not found. */
64    TkMainInfo *mainPtr;	/* MainWindow associated with tkwin. */
65    long epoch;			/* Value of mainPtr->deletionEpoch at last
66				 * successful lookup. */
67} WindowRep;
68
69/*
70 * Prototypes for functions defined later in this file:
71 */
72
73static void		DupMMInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr);
74static void		DupPixelInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr);
75static void		DupWindowInternalRep(Tcl_Obj *srcPtr,Tcl_Obj *copyPtr);
76static void		FreeMMInternalRep(Tcl_Obj *objPtr);
77static void		FreePixelInternalRep(Tcl_Obj *objPtr);
78static void		FreeWindowInternalRep(Tcl_Obj *objPtr);
79static void		UpdateStringOfMM(Tcl_Obj *objPtr);
80static int		SetMMFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
81static int		SetPixelFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
82static int		SetWindowFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
83
84/*
85 * The following structure defines the implementation of the "pixel" Tcl
86 * object, used for measuring distances. The pixel object remembers its
87 * initial display-independant settings.
88 */
89
90static Tcl_ObjType pixelObjType = {
91    "pixel",			/* name */
92    FreePixelInternalRep,	/* freeIntRepProc */
93    DupPixelInternalRep,	/* dupIntRepProc */
94    NULL,			/* updateStringProc */
95    SetPixelFromAny		/* setFromAnyProc */
96};
97
98/*
99 * The following structure defines the implementation of the "pixel" Tcl
100 * object, used for measuring distances. The pixel object remembers its
101 * initial display-independant settings.
102 */
103
104static Tcl_ObjType mmObjType = {
105    "mm",			/* name */
106    FreeMMInternalRep,		/* freeIntRepProc */
107    DupMMInternalRep,		/* dupIntRepProc */
108    UpdateStringOfMM,		/* updateStringProc */
109    SetMMFromAny		/* setFromAnyProc */
110};
111
112/*
113 * The following structure defines the implementation of the "window"
114 * Tcl object.
115 */
116
117static Tcl_ObjType windowObjType = {
118    "window",			/* name */
119    FreeWindowInternalRep,	/* freeIntRepProc */
120    DupWindowInternalRep,	/* dupIntRepProc */
121    NULL,			/* updateStringProc */
122    SetWindowFromAny		/* setFromAnyProc */
123};
124
125/*
126 *----------------------------------------------------------------------
127 *
128 * GetPixelsFromObjEx --
129 *
130 *	Attempt to return a pixel value from the Tcl object "objPtr". If the
131 *	object is not already a pixel value, an attempt will be made to
132 *	convert it to one.
133 *
134 * Results:
135 *	The return value is a standard Tcl object result. If an error occurs
136 *	during conversion, an error message is left in the interpreter's
137 *	result unless "interp" is NULL.
138 *
139 * Side effects:
140 *	If the object is not already a pixel, the conversion will free any old
141 *	internal representation.
142 *
143 *----------------------------------------------------------------------
144 */
145
146static
147int
148GetPixelsFromObjEx(
149    Tcl_Interp *interp, 	/* Used for error reporting if not NULL. */
150    Tk_Window tkwin,
151    Tcl_Obj *objPtr,		/* The object from which to get pixels. */
152    int *intPtr,
153    double *dblPtr)		/* Places to store resulting pixels. */
154{
155    int result,fresh;
156    double d;
157    PixelRep *pixelPtr;
158    static double bias[] = {
159	1.0,	10.0,	25.4,	0.35278 /*25.4 / 72.0*/
160    };
161
162 retry:
163    if (objPtr->typePtr != &pixelObjType) {
164	result = SetPixelFromAny(interp, objPtr);
165	if (result != TCL_OK) {
166	    return result;
167	}
168	fresh=1;
169    } else {
170	fresh=0;
171    }
172
173    if (SIMPLE_PIXELREP(objPtr)) {
174	*intPtr = GET_SIMPLEPIXEL(objPtr);
175	if (dblPtr) {
176	    *dblPtr=(double)(*intPtr);
177	}
178    } else {
179	pixelPtr = GET_COMPLEXPIXEL(objPtr);
180	if ((!fresh) && (pixelPtr->tkwin != tkwin))
181	    {
182		/* in case of exo-screen conversions of non-pixels
183		 * we force a recomputation from the string
184		 */
185
186		FreePixelInternalRep(objPtr);
187		goto retry;
188	    }
189	if ((pixelPtr->tkwin != tkwin)||dblPtr) {
190	    d = pixelPtr->value;
191	    if (pixelPtr->units >= 0) {
192		d *= bias[pixelPtr->units] * WidthOfScreen(Tk_Screen(tkwin));
193		d /= WidthMMOfScreen(Tk_Screen(tkwin));
194	    }
195	    if (d < 0) {
196		pixelPtr->returnValue = (int) (d - 0.5);
197	    } else {
198		pixelPtr->returnValue = (int) (d + 0.5);
199	    }
200	    pixelPtr->tkwin = tkwin;
201	    if (dblPtr) {
202		*dblPtr=(double)d;
203	    }
204	}
205	*intPtr = pixelPtr->returnValue;
206    }
207    return TCL_OK;
208}
209
210/*
211 *----------------------------------------------------------------------
212 *
213 * Tk_GetPixelsFromObj --
214 *
215 *	Attempt to return a pixel value from the Tcl object "objPtr". If the
216 *	object is not already a pixel value, an attempt will be made to
217 *	convert it to one.
218 *
219 * Results:
220 *	The return value is a standard Tcl object result. If an error occurs
221 *	during conversion, an error message is left in the interpreter's
222 *	result unless "interp" is NULL.
223 *
224 * Side effects:
225 *	If the object is not already a pixel, the conversion will free any old
226 *	internal representation.
227 *
228 *----------------------------------------------------------------------
229 */
230
231int
232Tk_GetPixelsFromObj(
233    Tcl_Interp *interp, 	/* Used for error reporting if not NULL. */
234    Tk_Window tkwin,
235    Tcl_Obj *objPtr,		/* The object from which to get pixels. */
236    int *intPtr)		/* Place to store resulting pixels. */
237{
238    return GetPixelsFromObjEx(interp,tkwin,objPtr,intPtr,NULL);
239}
240
241/*
242 *----------------------------------------------------------------------
243 *
244 * Tk_GetDoublePixelsFromObj --
245 *
246 *	Attempt  to  return   a  double  pixel  value  from   the  Tcl  object
247 *	"objPtr". If the object is not  already a pixel value, an attempt will
248 *	be made to convert it to one, the internal unit being pixels.
249 *
250 * Results:
251 *	The return value is a standard Tcl object result. If an error occurs
252 *	during conversion, an error message is left in the interpreter's
253 *	result unless "interp" is NULL.
254 *
255 * Side effects:
256 *	If the object is not already a pixel, the conversion will free any old
257 *	internal representation.
258 *
259 *----------------------------------------------------------------------
260 */
261
262int
263Tk_GetDoublePixelsFromObj(
264    Tcl_Interp *interp, 	/* Used for error reporting if not NULL. */
265    Tk_Window tkwin,
266    Tcl_Obj *objPtr,		/* The object from which to get pixels. */
267    double *doublePtr)		/* Place to store resulting pixels. */
268{
269    double d;
270    int result,val;
271
272    result=GetPixelsFromObjEx(interp, tkwin, objPtr, &val, &d);
273    if (result != TCL_OK) {
274	return result;
275    }
276    if (!SIMPLE_PIXELREP(objPtr)) {
277	PixelRep *pixelPtr;
278	pixelPtr = GET_COMPLEXPIXEL(objPtr);
279	if (pixelPtr->units >= 0) {
280	    /* internally "shimmer" to pixel units */
281	    pixelPtr->units=-1;
282	    pixelPtr->value=d;
283	}
284    }
285    *doublePtr = d;
286    return TCL_OK;
287}
288
289/*
290 *----------------------------------------------------------------------
291 *
292 * FreePixelInternalRep --
293 *
294 *	Deallocate the storage associated with a pixel object's internal
295 *	representation.
296 *
297 * Results:
298 *	None.
299 *
300 * Side effects:
301 *	Frees objPtr's internal representation and sets objPtr's internalRep
302 *	to NULL.
303 *
304 *----------------------------------------------------------------------
305 */
306
307static void
308FreePixelInternalRep(
309    Tcl_Obj *objPtr)		/* Pixel object with internal rep to free. */
310{
311    PixelRep *pixelPtr;
312
313    if (!SIMPLE_PIXELREP(objPtr)) {
314	pixelPtr = GET_COMPLEXPIXEL(objPtr);
315	ckfree((char *) pixelPtr);
316    }
317    SET_SIMPLEPIXEL(objPtr, 0);
318    objPtr->typePtr = NULL;
319}
320
321/*
322 *----------------------------------------------------------------------
323 *
324 * DupPixelInternalRep --
325 *
326 *	Initialize the internal representation of a pixel Tcl_Obj to a copy of
327 *	the internal representation of an existing pixel object.
328 *
329 * Results:
330 *	None.
331 *
332 * Side effects:
333 *	copyPtr's internal rep is set to the pixel corresponding to srcPtr's
334 *	internal rep.
335 *
336 *----------------------------------------------------------------------
337 */
338
339static void
340DupPixelInternalRep(
341    register Tcl_Obj *srcPtr,	/* Object with internal rep to copy. */
342    register Tcl_Obj *copyPtr)	/* Object with internal rep to set. */
343{
344    PixelRep *oldPtr, *newPtr;
345
346    copyPtr->typePtr = srcPtr->typePtr;
347
348    if (SIMPLE_PIXELREP(srcPtr)) {
349	SET_SIMPLEPIXEL(copyPtr, GET_SIMPLEPIXEL(srcPtr));
350    } else {
351	oldPtr = GET_COMPLEXPIXEL(srcPtr);
352	newPtr = (PixelRep *) ckalloc(sizeof(PixelRep));
353	newPtr->value = oldPtr->value;
354	newPtr->units = oldPtr->units;
355	newPtr->tkwin = oldPtr->tkwin;
356	newPtr->returnValue = oldPtr->returnValue;
357	SET_COMPLEXPIXEL(copyPtr, newPtr);
358    }
359}
360
361/*
362 *----------------------------------------------------------------------
363 *
364 * SetPixelFromAny --
365 *
366 *	Attempt to generate a pixel internal form for the Tcl object "objPtr".
367 *
368 * Results:
369 *	The return value is a standard Tcl result. If an error occurs during
370 *	conversion, an error message is left in the interpreter's result
371 *	unless "interp" is NULL.
372 *
373 * Side effects:
374 *	If no error occurs, a pixel representation of the object is stored
375 *	internally and the type of "objPtr" is set to pixel.
376 *
377 *----------------------------------------------------------------------
378 */
379
380static int
381SetPixelFromAny(
382    Tcl_Interp *interp,		/* Used for error reporting if not NULL. */
383    Tcl_Obj *objPtr)		/* The object to convert. */
384{
385    const Tcl_ObjType *typePtr;
386    char *string, *rest;
387    double d;
388    int i, units;
389
390    string = Tcl_GetStringFromObj(objPtr, NULL);
391
392    d = strtod(string, &rest);
393    if (rest == string) {
394	goto error;
395    }
396    while ((*rest != '\0') && isspace(UCHAR(*rest))) {
397	rest++;
398    }
399
400    switch (*rest) {
401    case '\0':
402	units = -1;
403	break;
404    case 'm':
405	units = 0;
406	break;
407    case 'c':
408	units = 1;
409	break;
410    case 'i':
411	units = 2;
412	break;
413    case 'p':
414	units = 3;
415	break;
416    default:
417	goto error;
418    }
419
420    /*
421     * Free the old internalRep before setting the new one.
422     */
423
424    typePtr = objPtr->typePtr;
425    if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) {
426	(*typePtr->freeIntRepProc)(objPtr);
427    }
428
429    objPtr->typePtr = &pixelObjType;
430
431    i = (int) d;
432    if ((units < 0) && (i == d)) {
433	SET_SIMPLEPIXEL(objPtr, i);
434    } else {
435	PixelRep *pixelPtr = (PixelRep *) ckalloc(sizeof(PixelRep));
436
437	pixelPtr->value = d;
438	pixelPtr->units = units;
439	pixelPtr->tkwin = NULL;
440	pixelPtr->returnValue = i;
441	SET_COMPLEXPIXEL(objPtr, pixelPtr);
442    }
443    return TCL_OK;
444
445  error:
446    if (interp != NULL) {
447	/*
448	 * Must copy string before resetting the result in case a caller is
449	 * trying to convert the interpreter's result to pixels.
450	 */
451
452	char buf[100];
453
454	sprintf(buf, "bad screen distance \"%.50s\"", string);
455	Tcl_ResetResult(interp);
456	Tcl_AppendResult(interp, buf, NULL);
457    }
458    return TCL_ERROR;
459}
460
461/*
462 *----------------------------------------------------------------------
463 *
464 * Tk_GetMMFromObj --
465 *
466 *	Attempt to return an mm value from the Tcl object "objPtr". If the
467 *	object is not already an mm value, an attempt will be made to convert
468 *	it to one.
469 *
470 * Results:
471 *	The return value is a standard Tcl object result. If an error occurs
472 *	during conversion, an error message is left in the interpreter's
473 *	result unless "interp" is NULL.
474 *
475 * Side effects:
476 *	If the object is not already a pixel, the conversion will free any old
477 *	internal representation.
478 *
479 *----------------------------------------------------------------------
480 */
481
482int
483Tk_GetMMFromObj(
484    Tcl_Interp *interp, 	/* Used for error reporting if not NULL. */
485    Tk_Window tkwin,
486    Tcl_Obj *objPtr,		/* The object from which to get mms. */
487    double *doublePtr)		/* Place to store resulting millimeters. */
488{
489    int result;
490    double d;
491    MMRep *mmPtr;
492    static double bias[] = {
493	10.0,	25.4,	1.0,	0.35278 /*25.4 / 72.0*/
494    };
495
496    if (objPtr->typePtr != &mmObjType) {
497	result = SetMMFromAny(interp, objPtr);
498	if (result != TCL_OK) {
499	    return result;
500	}
501    }
502
503    mmPtr = (MMRep *) objPtr->internalRep.otherValuePtr;
504    if (mmPtr->tkwin != tkwin) {
505	d = mmPtr->value;
506	if (mmPtr->units == -1) {
507	    d /= WidthOfScreen(Tk_Screen(tkwin));
508	    d *= WidthMMOfScreen(Tk_Screen(tkwin));
509	} else {
510	    d *= bias[mmPtr->units];
511	}
512	mmPtr->tkwin = tkwin;
513	mmPtr->returnValue = d;
514    }
515    *doublePtr = mmPtr->returnValue;
516
517    return TCL_OK;
518}
519
520/*
521 *----------------------------------------------------------------------
522 *
523 * FreeMMInternalRep --
524 *
525 *	Deallocate the storage associated with a mm object's internal
526 *	representation.
527 *
528 * Results:
529 *	None.
530 *
531 * Side effects:
532 *	Frees objPtr's internal representation and sets objPtr's internalRep
533 *	to NULL.
534 *
535 *----------------------------------------------------------------------
536 */
537
538static void
539FreeMMInternalRep(
540    Tcl_Obj *objPtr)		/* MM object with internal rep to free. */
541{
542    ckfree((char *) objPtr->internalRep.otherValuePtr);
543    objPtr->internalRep.otherValuePtr = NULL;
544    objPtr->typePtr = NULL;
545}
546
547/*
548 *----------------------------------------------------------------------
549 *
550 * DupMMInternalRep --
551 *
552 *	Initialize the internal representation of a pixel Tcl_Obj to a copy of
553 *	the internal representation of an existing pixel object.
554 *
555 * Results:
556 *	None.
557 *
558 * Side effects:
559 *	copyPtr's internal rep is set to the pixel corresponding to srcPtr's
560 *	internal rep.
561 *
562 *----------------------------------------------------------------------
563 */
564
565static void
566DupMMInternalRep(
567    register Tcl_Obj *srcPtr,	/* Object with internal rep to copy. */
568    register Tcl_Obj *copyPtr)	/* Object with internal rep to set. */
569{
570    MMRep *oldPtr, *newPtr;
571
572    copyPtr->typePtr = srcPtr->typePtr;
573    oldPtr = (MMRep *) srcPtr->internalRep.otherValuePtr;
574    newPtr = (MMRep *) ckalloc(sizeof(MMRep));
575    newPtr->value = oldPtr->value;
576    newPtr->units = oldPtr->units;
577    newPtr->tkwin = oldPtr->tkwin;
578    newPtr->returnValue = oldPtr->returnValue;
579    copyPtr->internalRep.otherValuePtr = (VOID *) newPtr;
580}
581
582/*
583 *----------------------------------------------------------------------
584 *
585 * UpdateStringOfMM --
586 *
587 *	Update the string representation for a pixel Tcl_Obj this function is
588 *	only called, if the pixel Tcl_Obj has no unit, because with units the
589 *	string representation is created by SetMMFromAny
590 *
591 * Results:
592 *	None.
593 *
594 * Side effects:
595 *	The object's string is set to a valid string that results from the
596 *	double-to-string conversion.
597 *
598 *----------------------------------------------------------------------
599 */
600
601static void
602UpdateStringOfMM(
603    register Tcl_Obj *objPtr)   /* pixel obj with string rep to update. */
604{
605    MMRep *mmPtr;
606    char buffer[TCL_DOUBLE_SPACE];
607    register int len;
608
609    mmPtr = (MMRep *) objPtr->internalRep.otherValuePtr;
610    /* assert( mmPtr->units == -1 && objPtr->bytes == NULL ); */
611    if ((mmPtr->units != -1) || (objPtr->bytes != NULL)) {
612	Tcl_Panic("UpdateStringOfMM: false precondition");
613    }
614
615    Tcl_PrintDouble(NULL, mmPtr->value, buffer);
616    len = (int)strlen(buffer);
617
618    objPtr->bytes = (char *) ckalloc((unsigned) len + 1);
619    strcpy(objPtr->bytes, buffer);
620    objPtr->length = len;
621}
622
623/*
624 *----------------------------------------------------------------------
625 *
626 * SetMMFromAny --
627 *
628 *	Attempt to generate a mm internal form for the Tcl object "objPtr".
629 *
630 * Results:
631 *	The return value is a standard Tcl result. If an error occurs during
632 *	conversion, an error message is left in the interpreter's result
633 *	unless "interp" is NULL.
634 *
635 * Side effects:
636 *	If no error occurs, a mm representation of the object is stored
637 *	internally and the type of "objPtr" is set to mm.
638 *
639 *----------------------------------------------------------------------
640 */
641
642static int
643SetMMFromAny(
644    Tcl_Interp *interp,		/* Used for error reporting if not NULL. */
645    Tcl_Obj *objPtr)		/* The object to convert. */
646{
647    const Tcl_ObjType *typePtr;
648    char *string, *rest;
649    double d;
650    int units;
651    MMRep *mmPtr;
652
653    static const Tcl_ObjType *tclDoubleObjType = NULL;
654    static const Tcl_ObjType *tclIntObjType = NULL;
655
656    if (tclDoubleObjType == NULL) {
657	/*
658	 * Cache the object types for comaprison below. This allows optimized
659	 * checks for standard cases.
660	 */
661
662	tclDoubleObjType = Tcl_GetObjType("double");
663	tclIntObjType    = Tcl_GetObjType("int");
664    }
665
666    if (objPtr->typePtr == tclDoubleObjType) {
667	Tcl_GetDoubleFromObj(interp, objPtr, &d);
668	units = -1;
669    } else if (objPtr->typePtr == tclIntObjType) {
670	Tcl_GetIntFromObj(interp, objPtr, &units);
671	d = (double) units;
672	units = -1;
673
674	/*
675	 * In the case of ints, we need to ensure that a valid string exists
676	 * in order for int-but-not-string objects to be converted back to
677	 * ints again from mm obj types.
678	 */
679
680	(void) Tcl_GetStringFromObj(objPtr, NULL);
681    } else {
682	/*
683	 * It wasn't a known int or double, so parse it.
684	 */
685
686	string = Tcl_GetStringFromObj(objPtr, NULL);
687
688	d = strtod(string, &rest);
689	if (rest == string) {
690	    /*
691	     * Must copy string before resetting the result in case a caller
692	     * is trying to convert the interpreter's result to mms.
693	     */
694
695	error:
696	    Tcl_AppendResult(interp, "bad screen distance \"", string,
697		    "\"", NULL);
698	    return TCL_ERROR;
699	}
700	while ((*rest != '\0') && isspace(UCHAR(*rest))) {
701	    rest++;
702	}
703
704	switch (*rest) {
705	case '\0':
706	    units = -1;
707	    break;
708	case 'c':
709	    units = 0;
710	    break;
711	case 'i':
712	    units = 1;
713	    break;
714	case 'm':
715	    units = 2;
716	    break;
717	case 'p':
718	    units = 3;
719	    break;
720	default:
721	    goto error;
722	}
723    }
724
725    /*
726     * Free the old internalRep before setting the new one.
727     */
728
729    typePtr = objPtr->typePtr;
730    if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) {
731	(*typePtr->freeIntRepProc)(objPtr);
732    }
733
734    objPtr->typePtr	= &mmObjType;
735
736    mmPtr		= (MMRep *) ckalloc(sizeof(MMRep));
737    mmPtr->value	= d;
738    mmPtr->units	= units;
739    mmPtr->tkwin	= NULL;
740    mmPtr->returnValue	= d;
741
742    objPtr->internalRep.otherValuePtr = (VOID *) mmPtr;
743
744    return TCL_OK;
745}
746
747/*
748 *----------------------------------------------------------------------
749 *
750 * TkGetWindowFromObj --
751 *
752 *	Attempt to return a Tk_Window from the Tcl object "objPtr". If the
753 *	object is not already a Tk_Window, an attempt will be made to convert
754 *	it to one.
755 *
756 * Results:
757 *	The return value is a standard Tcl object result. If an error occurs
758 *	during conversion, an error message is left in the interpreter's
759 *	result unless "interp" is NULL.
760 *
761 * Side effects:
762 *	If the object is not already a Tk_Window, the conversion will free any
763 *	old internal representation.
764 *
765 *----------------------------------------------------------------------
766 */
767
768int
769TkGetWindowFromObj(
770    Tcl_Interp *interp, 	/* Used for error reporting if not NULL. */
771    Tk_Window tkwin,		/* A token to get the main window from. */
772    Tcl_Obj *objPtr,		/* The object from which to get window. */
773    Tk_Window *windowPtr)	/* Place to store resulting window. */
774{
775    TkMainInfo *mainPtr = ((TkWindow *)tkwin)->mainPtr;
776    register WindowRep *winPtr;
777    int result;
778
779    result = Tcl_ConvertToType(interp, objPtr, &windowObjType);
780    if (result != TCL_OK) {
781	return result;
782    }
783
784    winPtr = (WindowRep *) objPtr->internalRep.otherValuePtr;
785    if (    winPtr->tkwin == NULL
786	 || winPtr->mainPtr == NULL
787	 || winPtr->mainPtr != mainPtr
788	 || winPtr->epoch != mainPtr->deletionEpoch)
789    {
790	/* Cache is invalid.
791	 */
792	winPtr->tkwin = Tk_NameToWindow(interp,
793		Tcl_GetStringFromObj(objPtr, NULL), tkwin);
794	winPtr->mainPtr = mainPtr;
795	winPtr->epoch = mainPtr ? mainPtr->deletionEpoch : 0;
796    }
797
798    *windowPtr = winPtr->tkwin;
799
800    if (winPtr->tkwin == NULL) {
801	/* ASSERT: Tk_NameToWindow has left error message in interp */
802	return TCL_ERROR;
803    }
804    return TCL_OK;
805}
806
807/*
808 *----------------------------------------------------------------------
809 *
810 * SetWindowFromAny --
811 *
812 *	Generate a windowObj internal form for the Tcl object "objPtr".
813 *
814 * Results:
815 *	Always returns TCL_OK.
816 *
817 * Side effects:
818 *	Sets objPtr's internal representation to an uninitialized windowObj.
819 *	Frees the old internal representation, if any.
820 *
821 * See also:
822 * 	TkGetWindowFromObj, which initializes the WindowRep cache.
823 *
824 *----------------------------------------------------------------------
825 */
826
827static int
828SetWindowFromAny(
829    Tcl_Interp *interp,		/* Used for error reporting if not NULL. */
830    register Tcl_Obj *objPtr)	/* The object to convert. */
831{
832    const Tcl_ObjType *typePtr;
833    WindowRep *winPtr;
834
835    /*
836     * Free the old internalRep before setting the new one.
837     */
838
839    Tcl_GetStringFromObj(objPtr, NULL);
840    typePtr = objPtr->typePtr;
841    if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) {
842	(*typePtr->freeIntRepProc)(objPtr);
843    }
844
845    winPtr = (WindowRep *) ckalloc(sizeof(WindowRep));
846    winPtr->tkwin = NULL;
847    winPtr->mainPtr = NULL;
848    winPtr->epoch = 0;
849
850    objPtr->internalRep.otherValuePtr = (VOID*)winPtr;
851    objPtr->typePtr = &windowObjType;
852
853    return TCL_OK;
854}
855
856/*
857 *----------------------------------------------------------------------
858 *
859 * DupWindowInternalRep --
860 *
861 *	Initialize the internal representation of a window Tcl_Obj to a copy
862 *	of the internal representation of an existing window object.
863 *
864 * Results:
865 *	None.
866 *
867 * Side effects:
868 *	copyPtr's internal rep is set to refer to the same window as srcPtr's
869 *	internal rep.
870 *
871 *----------------------------------------------------------------------
872 */
873
874static void
875DupWindowInternalRep(
876    register Tcl_Obj *srcPtr,
877    register Tcl_Obj *copyPtr)
878{
879    register WindowRep *oldPtr, *newPtr;
880
881    oldPtr = srcPtr->internalRep.otherValuePtr;
882    newPtr = (WindowRep *) ckalloc(sizeof(WindowRep));
883    newPtr->tkwin = oldPtr->tkwin;
884    newPtr->mainPtr = oldPtr->mainPtr;
885    newPtr->epoch = oldPtr->epoch;
886    copyPtr->internalRep.otherValuePtr = (VOID *)newPtr;
887    copyPtr->typePtr = srcPtr->typePtr;
888}
889
890/*
891 *----------------------------------------------------------------------
892 *
893 * FreeWindowInternalRep --
894 *
895 *	Deallocate the storage associated with a window object's internal
896 *	representation.
897 *
898 * Results:
899 *	None.
900 *
901 * Side effects:
902 *	Frees objPtr's internal representation and sets objPtr's internalRep
903 *	to NULL.
904 *
905 *----------------------------------------------------------------------
906 */
907
908static void
909FreeWindowInternalRep(
910    Tcl_Obj *objPtr)		/* Window object with internal rep to free. */
911{
912    ckfree((char *) objPtr->internalRep.otherValuePtr);
913    objPtr->internalRep.otherValuePtr = NULL;
914    objPtr->typePtr = NULL;
915}
916
917/*
918 *--------------------------------------------------------------
919 *
920 * TkParsePadAmount --
921 *
922 *	This function parses a padding specification and returns the
923 *	appropriate padding values. A padding specification can be either a
924 *	single pixel width, or a list of two pixel widths. If a single pixel
925 *	width, the amount specified is used for padding on both sides. If two
926 *	amounts are specified, then they specify the left/right or top/bottom
927 *	padding.
928 *
929 * Results:
930 *	A standard Tcl return value.
931 *
932 * Side effects:
933 *	An error message is written to the interpreter if something is not
934 *	right.
935 *
936 *--------------------------------------------------------------
937 */
938
939int
940TkParsePadAmount(
941    Tcl_Interp *interp,		/* Interpreter for error reporting. */
942    Tk_Window tkwin,		/* A window.  Needed by Tk_GetPixels() */
943    Tcl_Obj *specObj,		/* The argument to "-padx", "-pady", "-ipadx",
944				 * or "-ipady". The thing to be parsed. */
945    int *halfPtr,		/* Write the left/top part of padding here */
946    int *allPtr)		/* Write the total padding here */
947{
948    int firstInt, secondInt;    /* The two components of the padding */
949    int objc;			/* The length of the list (should be 1 or 2) */
950    Tcl_Obj **objv;		/* The objects in the list */
951
952    /*
953     * Check for a common case where a single object would otherwise
954     * be shimmered between a list and a pixel spec.
955     */
956
957    if (specObj->typePtr == &pixelObjType) {
958	if (Tk_GetPixelsFromObj(interp, tkwin, specObj, &firstInt) != TCL_OK) {
959	    Tcl_ResetResult(interp);
960	    Tcl_AppendResult(interp, "bad pad value \"",
961		    Tcl_GetString(specObj),
962		    "\": must be positive screen distance", NULL);
963	    return TCL_ERROR;
964	}
965	secondInt = firstInt;
966	goto done;
967    }
968
969    /*
970     * Pad specifications are a list of one or two elements, each of which is
971     * a pixel specification.
972     */
973
974    if (Tcl_ListObjGetElements(interp, specObj, &objc, &objv) != TCL_OK) {
975	return TCL_ERROR;
976    }
977    if (objc != 1 && objc != 2) {
978	Tcl_AppendResult(interp,
979		"wrong number of parts to pad specification", NULL);
980	return TCL_ERROR;
981    }
982
983    /*
984     * Parse the first part.
985     */
986
987    if (Tk_GetPixelsFromObj(interp, tkwin, objv[0], &firstInt) != TCL_OK ||
988	    (firstInt < 0)) {
989	Tcl_ResetResult(interp);
990	Tcl_AppendResult(interp, "bad pad value \"", Tcl_GetString(objv[0]),
991		"\": must be positive screen distance", NULL);
992	return TCL_ERROR;
993    }
994
995    /*
996     * Parse the second part if it exists, otherwise it is as if it was the
997     * same as the first part.
998     */
999
1000    if (objc == 1) {
1001	secondInt = firstInt;
1002    } else if (Tk_GetPixelsFromObj(interp, tkwin, objv[1],
1003	    &secondInt) != TCL_OK || (secondInt < 0)) {
1004	Tcl_ResetResult(interp);
1005	Tcl_AppendResult(interp, "bad 2nd pad value \"",
1006		Tcl_GetString(objv[1]),
1007		"\": must be positive screen distance", NULL);
1008	return TCL_ERROR;
1009    }
1010
1011    /*
1012     * Write the parsed bits back into the receiving variables.
1013     */
1014
1015  done:
1016    if (halfPtr != 0) {
1017	*halfPtr = firstInt;
1018    }
1019    *allPtr = firstInt + secondInt;
1020    return TCL_OK;
1021}
1022
1023/*
1024 *----------------------------------------------------------------------
1025 *
1026 * TkRegisterObjTypes --
1027 *
1028 *	Registers Tk's Tcl_ObjType structures with the Tcl run-time.
1029 *
1030 * Results:
1031 *	None
1032 *
1033 * Side effects:
1034 *	All instances of Tcl_ObjType structues used in Tk are registered with
1035 *	Tcl.
1036 *
1037 *----------------------------------------------------------------------
1038 */
1039
1040void
1041TkRegisterObjTypes(void)
1042{
1043    Tcl_RegisterObjType(&tkBorderObjType);
1044    Tcl_RegisterObjType(&tkBitmapObjType);
1045    Tcl_RegisterObjType(&tkColorObjType);
1046    Tcl_RegisterObjType(&tkCursorObjType);
1047    Tcl_RegisterObjType(&tkFontObjType);
1048    Tcl_RegisterObjType(&mmObjType);
1049    Tcl_RegisterObjType(&tkOptionObjType);
1050    Tcl_RegisterObjType(&pixelObjType);
1051    Tcl_RegisterObjType(&tkStateKeyObjType);
1052    Tcl_RegisterObjType(&windowObjType);
1053    Tcl_RegisterObjType(&tkTextIndexType);
1054}
1055
1056/*
1057 * Local Variables:
1058 * mode: c
1059 * c-basic-offset: 4
1060 * fill-column: 78
1061 * End:
1062 */
1063