/[dtapublic]/projs/trunk/shared_source/c_tk_base_7_5_w_mods/tkobj.c
ViewVC logotype

Contents of /projs/trunk/shared_source/c_tk_base_7_5_w_mods/tkobj.c

Parent Directory Parent Directory | Revision Log Revision Log


Revision 69 - (show annotations) (download)
Sat Nov 5 10:54:17 2016 UTC (6 years, 2 months ago) by dashley
File MIME type: text/plain
File size: 17668 byte(s)
License and property (keyword) changes.
1 /* $Header$ */
2
3 /*
4 * tkObj.c --
5 *
6 * This file contains procedures that implement the common Tk object
7 * types
8 *
9 * Copyright (c) 1997 Sun Microsystems, Inc.
10 *
11 * See the file "license.terms" for information on usage and redistribution
12 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
13 *
14 * RCS: @(#) $Id: tkobj.c,v 1.1.1.1 2001/06/13 05:06:19 dtashley Exp $
15 */
16
17 #include "tkInt.h"
18
19 /*
20 * The following structure is the internal representation for pixel objects.
21 */
22
23 typedef struct PixelRep {
24 double value;
25 int units;
26 Tk_Window tkwin;
27 int returnValue;
28 } PixelRep;
29
30 #define SIMPLE_PIXELREP(objPtr) \
31 ((objPtr)->internalRep.twoPtrValue.ptr2 == 0)
32
33 #define SET_SIMPLEPIXEL(objPtr, intval) \
34 (objPtr)->internalRep.twoPtrValue.ptr1 = (VOID *) (intval); \
35 (objPtr)->internalRep.twoPtrValue.ptr2 = 0
36
37 #define GET_SIMPLEPIXEL(objPtr) \
38 ((int) (objPtr)->internalRep.twoPtrValue.ptr1)
39
40 #define SET_COMPLEXPIXEL(objPtr, repPtr) \
41 (objPtr)->internalRep.twoPtrValue.ptr1 = 0; \
42 (objPtr)->internalRep.twoPtrValue.ptr2 = (VOID *) repPtr
43
44 #define GET_COMPLEXPIXEL(objPtr) \
45 ((PixelRep *) (objPtr)->internalRep.twoPtrValue.ptr2)
46
47
48 /*
49 * The following structure is the internal representation for mm objects.
50 */
51
52 typedef struct MMRep {
53 double value;
54 int units;
55 Tk_Window tkwin;
56 double returnValue;
57 } MMRep;
58
59 /*
60 * Prototypes for procedures defined later in this file:
61 */
62
63 static void DupMMInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
64 Tcl_Obj *copyPtr));
65 static void DupPixelInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
66 Tcl_Obj *copyPtr));
67 static void FreeMMInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr));
68 static void FreePixelInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr));
69 static int SetMMFromAny _ANSI_ARGS_((Tcl_Interp *interp,
70 Tcl_Obj *objPtr));
71 static int SetPixelFromAny _ANSI_ARGS_((Tcl_Interp *interp,
72 Tcl_Obj *objPtr));
73 static int SetWindowFromAny _ANSI_ARGS_((Tcl_Interp *interp,
74 Tcl_Obj *objPtr));
75
76 /*
77 * The following structure defines the implementation of the "pixel"
78 * Tcl object, used for measuring distances. The pixel object remembers
79 * its initial display-independant settings.
80 */
81
82 static Tcl_ObjType pixelObjType = {
83 "pixel", /* name */
84 FreePixelInternalRep, /* freeIntRepProc */
85 DupPixelInternalRep, /* dupIntRepProc */
86 NULL, /* updateStringProc */
87 SetPixelFromAny /* setFromAnyProc */
88 };
89
90 /*
91 * The following structure defines the implementation of the "pixel"
92 * Tcl object, used for measuring distances. The pixel object remembers
93 * its initial display-independant settings.
94 */
95
96 static Tcl_ObjType mmObjType = {
97 "mm", /* name */
98 FreeMMInternalRep, /* freeIntRepProc */
99 DupMMInternalRep, /* dupIntRepProc */
100 NULL, /* updateStringProc */
101 SetMMFromAny /* setFromAnyProc */
102 };
103
104 /*
105 * The following structure defines the implementation of the "window"
106 * Tcl object.
107 */
108
109 static Tcl_ObjType windowObjType = {
110 "window", /* name */
111 (Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */
112 (Tcl_DupInternalRepProc *) NULL, /* dupIntRepProc */
113 NULL, /* updateStringProc */
114 SetWindowFromAny /* setFromAnyProc */
115 };
116
117
118
119 /*
120 *----------------------------------------------------------------------
121 *
122 * Tk_GetPixelsFromObj --
123 *
124 * Attempt to return a pixel value from the Tcl object "objPtr". If the
125 * object is not already a pixel value, an attempt will be made to convert
126 * it to one.
127 *
128 * Results:
129 * The return value is a standard Tcl object result. If an error occurs
130 * during conversion, an error message is left in the interpreter's
131 * result unless "interp" is NULL.
132 *
133 * Side effects:
134 * If the object is not already a pixel, the conversion will free
135 * any old internal representation.
136 *
137 *----------------------------------------------------------------------
138 */
139
140 int
141 Tk_GetPixelsFromObj(interp, tkwin, objPtr, intPtr)
142 Tcl_Interp *interp; /* Used for error reporting if not NULL. */
143 Tk_Window tkwin;
144 Tcl_Obj *objPtr; /* The object from which to get pixels. */
145 int *intPtr; /* Place to store resulting pixels. */
146 {
147 int result;
148 double d;
149 PixelRep *pixelPtr;
150 static double bias[] = {
151 1.0, 10.0, 25.4, 25.4 / 72.0
152 };
153
154 if (objPtr->typePtr != &pixelObjType) {
155 result = SetPixelFromAny(interp, objPtr);
156 if (result != TCL_OK) {
157 return result;
158 }
159 }
160
161 if (SIMPLE_PIXELREP(objPtr)) {
162 *intPtr = GET_SIMPLEPIXEL(objPtr);
163 } else {
164 pixelPtr = GET_COMPLEXPIXEL(objPtr);
165 if (pixelPtr->tkwin != tkwin) {
166 d = pixelPtr->value;
167 if (pixelPtr->units >= 0) {
168 d *= bias[pixelPtr->units] * WidthOfScreen(Tk_Screen(tkwin));
169 d /= WidthMMOfScreen(Tk_Screen(tkwin));
170 }
171 if (d < 0) {
172 pixelPtr->returnValue = (int) (d - 0.5);
173 } else {
174 pixelPtr->returnValue = (int) (d + 0.5);
175 }
176 pixelPtr->tkwin = tkwin;
177 }
178 *intPtr = pixelPtr->returnValue;
179 }
180 return TCL_OK;
181 }
182
183 /*
184 *----------------------------------------------------------------------
185 *
186 * FreePixelInternalRep --
187 *
188 * Deallocate the storage associated with a pixel object's internal
189 * representation.
190 *
191 * Results:
192 * None.
193 *
194 * Side effects:
195 * Frees objPtr's internal representation and sets objPtr's
196 * internalRep to NULL.
197 *
198 *----------------------------------------------------------------------
199 */
200
201 static void
202 FreePixelInternalRep(objPtr)
203 Tcl_Obj *objPtr; /* Pixel object with internal rep to free. */
204 {
205 PixelRep *pixelPtr;
206
207 if (!SIMPLE_PIXELREP(objPtr)) {
208 pixelPtr = GET_COMPLEXPIXEL(objPtr);
209 ckfree((char *) pixelPtr);
210 }
211 SET_SIMPLEPIXEL(objPtr, 0);
212 }
213
214 /*
215 *----------------------------------------------------------------------
216 *
217 * DupPixelInternalRep --
218 *
219 * Initialize the internal representation of a pixel Tcl_Obj to a
220 * copy of the internal representation of an existing pixel object.
221 *
222 * Results:
223 * None.
224 *
225 * Side effects:
226 * copyPtr's internal rep is set to the pixel corresponding to
227 * srcPtr's internal rep.
228 *
229 *----------------------------------------------------------------------
230 */
231
232 static void
233 DupPixelInternalRep(srcPtr, copyPtr)
234 register Tcl_Obj *srcPtr; /* Object with internal rep to copy. */
235 register Tcl_Obj *copyPtr; /* Object with internal rep to set. */
236 {
237 PixelRep *oldPtr, *newPtr;
238
239 copyPtr->typePtr = srcPtr->typePtr;
240
241 if (SIMPLE_PIXELREP(srcPtr)) {
242 SET_SIMPLEPIXEL(copyPtr, GET_SIMPLEPIXEL(srcPtr));
243 } else {
244 oldPtr = GET_COMPLEXPIXEL(srcPtr);
245 newPtr = (PixelRep *) ckalloc(sizeof(PixelRep));
246 newPtr->value = oldPtr->value;
247 newPtr->units = oldPtr->units;
248 newPtr->tkwin = oldPtr->tkwin;
249 newPtr->returnValue = oldPtr->returnValue;
250 SET_COMPLEXPIXEL(copyPtr, newPtr);
251 }
252 }
253
254 /*
255 *----------------------------------------------------------------------
256 *
257 * SetPixelFromAny --
258 *
259 * Attempt to generate a pixel internal form for the Tcl object
260 * "objPtr".
261 *
262 * Results:
263 * The return value is a standard Tcl result. If an error occurs during
264 * conversion, an error message is left in the interpreter's result
265 * unless "interp" is NULL.
266 *
267 * Side effects:
268 * If no error occurs, a pixel representation of the object is
269 * stored internally and the type of "objPtr" is set to pixel.
270 *
271 *----------------------------------------------------------------------
272 */
273
274 static int
275 SetPixelFromAny(interp, objPtr)
276 Tcl_Interp *interp; /* Used for error reporting if not NULL. */
277 Tcl_Obj *objPtr; /* The object to convert. */
278 {
279 Tcl_ObjType *typePtr;
280 char *string, *rest;
281 double d;
282 int i, units;
283 PixelRep *pixelPtr;
284
285 string = Tcl_GetStringFromObj(objPtr, NULL);
286
287 d = strtod(string, &rest);
288 if (rest == string) {
289 /*
290 * Must copy string before resetting the result in case a caller
291 * is trying to convert the interpreter's result to pixels.
292 */
293
294 char buf[100];
295
296 error:
297 sprintf(buf, "bad screen distance \"%.50s\"", string);
298 Tcl_ResetResult(interp);
299 Tcl_AppendResult(interp, buf, NULL);
300 return TCL_ERROR;
301 }
302 while ((*rest != '\0') && isspace(UCHAR(*rest))) {
303 rest++;
304 }
305 switch (*rest) {
306 case '\0':
307 units = -1;
308 break;
309
310 case 'm':
311 units = 0;
312 break;
313
314 case 'c':
315 units = 1;
316 break;
317
318 case 'i':
319 units = 2;
320 break;
321
322 case 'p':
323 units = 3;
324 break;
325
326 default:
327 goto error;
328 }
329
330 /*
331 * Free the old internalRep before setting the new one.
332 */
333
334 typePtr = objPtr->typePtr;
335 if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) {
336 (*typePtr->freeIntRepProc)(objPtr);
337 }
338
339 objPtr->typePtr = &pixelObjType;
340
341 i = (int) d;
342 if ((units < 0) && (i == d)) {
343 SET_SIMPLEPIXEL(objPtr, i);
344 } else {
345 pixelPtr = (PixelRep *) ckalloc(sizeof(PixelRep));
346 pixelPtr->value = d;
347 pixelPtr->units = units;
348 pixelPtr->tkwin = NULL;
349 pixelPtr->returnValue = i;
350 SET_COMPLEXPIXEL(objPtr, pixelPtr);
351 }
352 return TCL_OK;
353 }
354
355 /*
356 *----------------------------------------------------------------------
357 *
358 * Tk_GetMMFromObj --
359 *
360 * Attempt to return an mm value from the Tcl object "objPtr". If the
361 * object is not already an mm value, an attempt will be made to convert
362 * it to one.
363 *
364 * Results:
365 * The return value is a standard Tcl object result. If an error occurs
366 * during conversion, an error message is left in the interpreter's
367 * result unless "interp" is NULL.
368 *
369 * Side effects:
370 * If the object is not already a pixel, the conversion will free
371 * any old internal representation.
372 *
373 *----------------------------------------------------------------------
374 */
375
376 int
377 Tk_GetMMFromObj(interp, tkwin, objPtr, doublePtr)
378 Tcl_Interp *interp; /* Used for error reporting if not NULL. */
379 Tk_Window tkwin;
380 Tcl_Obj *objPtr; /* The object from which to get mms. */
381 double *doublePtr; /* Place to store resulting millimeters. */
382 {
383 int result;
384 double d;
385 MMRep *mmPtr;
386 static double bias[] = {
387 10.0, 25.4, 1.0, 25.4 / 72.0
388 };
389
390 if (objPtr->typePtr != &mmObjType) {
391 result = SetMMFromAny(interp, objPtr);
392 if (result != TCL_OK) {
393 return result;
394 }
395 }
396
397 mmPtr = (MMRep *) objPtr->internalRep.otherValuePtr;
398 if (mmPtr->tkwin != tkwin) {
399 d = mmPtr->value;
400 if (mmPtr->units == -1) {
401 d /= WidthOfScreen(Tk_Screen(tkwin));
402 d *= WidthMMOfScreen(Tk_Screen(tkwin));
403 } else {
404 d *= bias[mmPtr->units];
405 }
406 mmPtr->tkwin = tkwin;
407 mmPtr->returnValue = d;
408 }
409 *doublePtr = mmPtr->returnValue;
410
411 return TCL_OK;
412 }
413
414 /*
415 *----------------------------------------------------------------------
416 *
417 * FreeMMInternalRep --
418 *
419 * Deallocate the storage associated with a mm object's internal
420 * representation.
421 *
422 * Results:
423 * None.
424 *
425 * Side effects:
426 * Frees objPtr's internal representation and sets objPtr's
427 * internalRep to NULL.
428 *
429 *----------------------------------------------------------------------
430 */
431
432 static void
433 FreeMMInternalRep(objPtr)
434 Tcl_Obj *objPtr; /* MM object with internal rep to free. */
435 {
436 ckfree((char *) objPtr->internalRep.otherValuePtr);
437 objPtr->internalRep.otherValuePtr = NULL;
438 }
439
440 /*
441 *----------------------------------------------------------------------
442 *
443 * DupMMInternalRep --
444 *
445 * Initialize the internal representation of a pixel Tcl_Obj to a
446 * copy of the internal representation of an existing pixel object.
447 *
448 * Results:
449 * None.
450 *
451 * Side effects:
452 * copyPtr's internal rep is set to the pixel corresponding to
453 * srcPtr's internal rep.
454 *
455 *----------------------------------------------------------------------
456 */
457
458 static void
459 DupMMInternalRep(srcPtr, copyPtr)
460 register Tcl_Obj *srcPtr; /* Object with internal rep to copy. */
461 register Tcl_Obj *copyPtr; /* Object with internal rep to set. */
462 {
463 MMRep *oldPtr, *newPtr;
464
465 copyPtr->typePtr = srcPtr->typePtr;
466 oldPtr = (MMRep *) srcPtr->internalRep.otherValuePtr;
467 newPtr = (MMRep *) ckalloc(sizeof(MMRep));
468 newPtr->value = oldPtr->value;
469 newPtr->units = oldPtr->units;
470 newPtr->tkwin = oldPtr->tkwin;
471 newPtr->returnValue = oldPtr->returnValue;
472 copyPtr->internalRep.otherValuePtr = (VOID *) newPtr;
473 }
474
475 /*
476 *----------------------------------------------------------------------
477 *
478 * SetMMFromAny --
479 *
480 * Attempt to generate a mm internal form for the Tcl object
481 * "objPtr".
482 *
483 * Results:
484 * The return value is a standard Tcl result. If an error occurs during
485 * conversion, an error message is left in the interpreter's result
486 * unless "interp" is NULL.
487 *
488 * Side effects:
489 * If no error occurs, a mm representation of the object is
490 * stored internally and the type of "objPtr" is set to mm.
491 *
492 *----------------------------------------------------------------------
493 */
494
495 static int
496 SetMMFromAny(interp, objPtr)
497 Tcl_Interp *interp; /* Used for error reporting if not NULL. */
498 Tcl_Obj *objPtr; /* The object to convert. */
499 {
500 Tcl_ObjType *typePtr;
501 char *string, *rest;
502 double d;
503 int units;
504 MMRep *mmPtr;
505
506 string = Tcl_GetStringFromObj(objPtr, NULL);
507
508 d = strtod(string, &rest);
509 if (rest == string) {
510 /*
511 * Must copy string before resetting the result in case a caller
512 * is trying to convert the interpreter's result to mms.
513 */
514
515 error:
516 Tcl_AppendResult(interp, "bad screen distance \"", string,
517 "\"", (char *) NULL);
518 return TCL_ERROR;
519 }
520 while ((*rest != '\0') && isspace(UCHAR(*rest))) {
521 rest++;
522 }
523 switch (*rest) {
524 case '\0':
525 units = -1;
526 break;
527
528 case 'c':
529 units = 0;
530 break;
531
532 case 'i':
533 units = 1;
534 break;
535
536 case 'm':
537 units = 2;
538 break;
539
540 case 'p':
541 units = 3;
542 break;
543
544 default:
545 goto error;
546 }
547
548 /*
549 * Free the old internalRep before setting the new one.
550 */
551
552 typePtr = objPtr->typePtr;
553 if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) {
554 (*typePtr->freeIntRepProc)(objPtr);
555 }
556
557 objPtr->typePtr = &mmObjType;
558
559 mmPtr = (MMRep *) ckalloc(sizeof(MMRep));
560 mmPtr->value = d;
561 mmPtr->units = units;
562 mmPtr->tkwin = NULL;
563 mmPtr->returnValue = d;
564 objPtr->internalRep.otherValuePtr = (VOID *) mmPtr;
565 return TCL_OK;
566 }
567
568 /*
569 *----------------------------------------------------------------------
570 *
571 * TkGetWindowFromObj --
572 *
573 * Attempt to return a Tk_Window from the Tcl object "objPtr". If the
574 * object is not already a Tk_Window, an attempt will be made to convert
575 * it to one.
576 *
577 * Results:
578 * The return value is a standard Tcl object result. If an error occurs
579 * during conversion, an error message is left in the interpreter's
580 * result unless "interp" is NULL.
581 *
582 * Side effects:
583 * If the object is not already a Tk_Window, the conversion will free
584 * any old internal representation.
585 *
586 *----------------------------------------------------------------------
587 */
588
589 int
590 TkGetWindowFromObj(interp, tkwin, objPtr, windowPtr)
591 Tcl_Interp *interp; /* Used for error reporting if not NULL. */
592 Tk_Window tkwin; /* A token to get the main window from. */
593 register Tcl_Obj *objPtr; /* The object from which to get boolean. */
594 Tk_Window *windowPtr; /* Place to store resulting window. */
595 {
596 register int result;
597 Tk_Window lastWindow;
598
599 result = SetWindowFromAny(interp, objPtr);
600 if (result != TCL_OK) {
601 return result;
602 }
603
604 lastWindow = (Tk_Window) objPtr->internalRep.twoPtrValue.ptr1;
605 if (tkwin != lastWindow) {
606 Tk_Window foundWindow = Tk_NameToWindow(interp,
607 Tcl_GetStringFromObj(objPtr, NULL), tkwin);
608
609 if (foundWindow == NULL) {
610 return TCL_ERROR;
611 }
612 objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) tkwin;
613 objPtr->internalRep.twoPtrValue.ptr2 = (VOID *) foundWindow;
614 }
615 *windowPtr = (Tk_Window) objPtr->internalRep.twoPtrValue.ptr2;
616
617 return result;
618 }
619
620 /*
621 *----------------------------------------------------------------------
622 *
623 * SetWindowFromAny --
624 *
625 * Attempt to generate a Tk_Window internal form for the Tcl object
626 * "objPtr".
627 *
628 * Results:
629 * The return value is a standard Tcl result. If an error occurs during
630 * conversion, an error message is left in the interpreter's result
631 * unless "interp" is NULL.
632 *
633 * Side effects:
634 * If no error occurs, a standard window value is stored as "objPtr"s
635 * internal representation and the type of "objPtr" is set to Tk_Window.
636 *
637 *----------------------------------------------------------------------
638 */
639
640 static int
641 SetWindowFromAny(interp, objPtr)
642 Tcl_Interp *interp; /* Used for error reporting if not NULL. */
643 register Tcl_Obj *objPtr; /* The object to convert. */
644 {
645 Tcl_ObjType *typePtr;
646
647 /*
648 * Free the old internalRep before setting the new one.
649 */
650
651 Tcl_GetStringFromObj(objPtr, NULL);
652 typePtr = objPtr->typePtr;
653 if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) {
654 (*typePtr->freeIntRepProc)(objPtr);
655 }
656 objPtr->typePtr = &windowObjType;
657 objPtr->internalRep.twoPtrValue.ptr1 = NULL;
658 objPtr->internalRep.twoPtrValue.ptr2 = NULL;
659
660 return TCL_OK;
661 }
662
663 /* End of tkobj.c */

Properties

Name Value
svn:keywords Header

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25