?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Merge branch 'master' into xcircuit-3.10
[xcircuit.git] / tclxcircuit.c
blobbcd8a9523d04548907f58d98b2267a75cfe36ba4
1 /*--------------------------------------------------------------*/
2 /* tclxcircuit.c: */
3 /* Tcl routines for xcircuit command-line functions */
4 /* Copyright (c) 2003 Tim Edwards, Johns Hopkins University */
5 /* Copyright (c) 2004 Tim Edwards, MultiGiG, Inc. */
6 /*--------------------------------------------------------------*/
7
8 #if defined(TCL_WRAPPER) && !defined(HAVE_PYTHON)
9
10 #include <stdio.h>
11 #include <stdarg.h> /* for va_copy() */
12 #include <stdlib.h> /* for atoi() and others */
13 #include <ctype.h>
14 #include <string.h>
15 #include <sys/types.h>
16 #include <sys/stat.h>
17 #include <errno.h>
18
19 #include <tk.h>
20
21 #ifdef HAVE_CAIRO
22 #include <cairo/cairo-xlib.h>
23 #endif
24
25 #ifndef _MSC_VER
26 #include <X11/Intrinsic.h>
27 #include <X11/StringDefs.h>
28 #endif
29
30 #include "xcircuit.h"
31 #include "colordefs.h"
32 #include "menudep.h"
33 #include "prototypes.h"
34
35 Tcl_HashTable XcTagTable;
36
37 extern Tcl_Interp *xcinterp;
38 extern Tcl_Interp *consoleinterp;
39 extern Display *dpy;
40 extern Colormap cmap;
41 extern Pixmap STIPPLE[STIPPLES]; /* Polygon fill-style stipple patterns */
42 extern char _STR[150], _STR2[250];
43 extern XCWindowData *areawin;
44 extern Globaldata xobjs;
45 extern int screenDPI;
46 extern int number_colors;
47 extern colorindex *colorlist;
48 extern Cursor appcursors[NUM_CURSORS];
49 extern ApplicationData appdata;
50 extern fontinfo *fonts;
51 extern short fontcount;
52 extern u_char param_select[];
53 extern keybinding *keylist;
54 extern Boolean spice_end;
55 extern short flstart;
56 extern int pressmode;
57 extern u_char undo_collect;
58
59 char STIPDATA[STIPPLES][4] = {
60 "\000\004\000\001",
61 "\000\005\000\012",
62 "\001\012\005\010",
63 "\005\012\005\012",
64 "\016\005\012\007",
65 "\017\012\017\005",
66 "\017\012\017\016",
67 "\000\000\000\000"
68 };
69
70 short flags = -1;
71
72 #define LIBOVERRIDE 1
73 #define LIBLOADED 2
74 #define COLOROVERRIDE 4
75 #define FONTOVERRIDE 8
76 #define KEYOVERRIDE 16
77
78 /*-----------------------*/
79 /* Tcl 8.4 compatibility */
80 /*-----------------------*/
81
82 #ifndef CONST84
83 #define CONST84
84 #endif
85
86 /*----------------------------------------------------------------------*/
87 /* Procedure for waiting on X to map a window */
88 /* This code copied from Tk sources, where it is used for the "tkwait" */
89 /* command. */
90 /*----------------------------------------------------------------------*/
91
92 static void
93 WaitVisibilityProc(ClientData clientData, XEvent *eventPtr)
94 {
95 int *donePtr = (int *) clientData;
96
97 if (eventPtr->type == VisibilityNotify) {
98 *donePtr = 1;
99 }
100 if (eventPtr->type == DestroyNotify) {
101 *donePtr = 2;
102 }
103 }
104
105 /*----------------------------------------------------------------------*/
106 /* Deal with systems which don't define va_copy(). */
107 /*----------------------------------------------------------------------*/
108
109 #ifndef HAVE_VA_COPY
110 #ifdef HAVE___VA_COPY
111 #define va_copy(a, b) __va_copy(a, b)
112 #else
113 #define va_copy(a, b) a = b
114 #endif
115 #endif
116
117 #ifdef ASG
118 extern int SetDebugLevel(int *level);
119 #endif
120
121 /*----------------------------------------------------------------------*/
122 /* Reimplement strdup() to use Tcl_Alloc(). */
123 /* Note that "strdup" is defined as "Tcl_Strdup" in xcircuit.h. */
124 /*----------------------------------------------------------------------*/
125
126 char *Tcl_Strdup(const char *s)
127 {
128 char *snew;
129 int slen;
130
131 slen = 1 + strlen(s);
132 snew = Tcl_Alloc(slen);
133 if (snew != NULL)
134 memcpy(snew, s, slen);
135
136 return snew;
137 }
138
139 /*----------------------------------------------------------------------*/
140 /* Reimplement vfprintf() as a call to Tcl_Eval(). */
141 /*----------------------------------------------------------------------*/
142
143 void tcl_vprintf(FILE *f, const char *fmt, va_list args_in)
144 {
145 va_list args;
146 static char outstr[128] = "puts -nonewline std";
147 char *outptr, *bigstr = NULL, *finalstr = NULL;
148 int i, nchars, result, escapes = 0;
149
150 /* If we are printing an error message, we want to bring attention */
151 /* to it by mapping the console window and raising it, as necessary. */
152 /* I'd rather do this internally than by Tcl_Eval(), but I can't */
153 /* find the right window ID to map! */
154
155 if ((f == stderr) && (consoleinterp != xcinterp)) {
156 Tk_Window tkwind;
157 tkwind = Tk_MainWindow(consoleinterp);
158 if ((tkwind != NULL) && (!Tk_IsMapped(tkwind)))
159 result = Tcl_Eval(consoleinterp, "wm deiconify .\n");
160 result = Tcl_Eval(consoleinterp, "raise .\n");
161 }
162
163 strcpy (outstr + 19, (f == stderr) ? "err \"" : "out \"");
164 outptr = outstr;
165
166 /* This mess circumvents problems with systems which do not have */
167 /* va_copy() defined. Some define __va_copy(); otherwise we must */
168 /* assume that args = args_in is valid. */
169
170 va_copy(args, args_in);
171 nchars = vsnprintf(outptr + 24, 102, fmt, args);
172 va_end(args);
173
174 if (nchars >= 102) {
175 va_copy(args, args_in);
176 bigstr = Tcl_Alloc(nchars + 26);
177 strncpy(bigstr, outptr, 24);
178 outptr = bigstr;
179 vsnprintf(outptr + 24, nchars + 2, fmt, args);
180 va_end(args);
181 }
182 else if (nchars == -1) nchars = 126;
183
184 for (i = 24; *(outptr + i) != '\0'; i++) {
185 if (*(outptr + i) == '\"' || *(outptr + i) == '[' ||
186 *(outptr + i) == ']' || *(outptr + i) == '\\')
187 escapes++;
188 }
189
190 if (escapes > 0) {
191 finalstr = Tcl_Alloc(nchars + escapes + 26);
192 strncpy(finalstr, outptr, 24);
193 escapes = 0;
194 for (i = 24; *(outptr + i) != '\0'; i++) {
195 if (*(outptr + i) == '\"' || *(outptr + i) == '[' ||
196 *(outptr + i) == ']' || *(outptr + i) == '\\') {
197 *(finalstr + i + escapes) = '\\';
198 escapes++;
199 }
200 *(finalstr + i + escapes) = *(outptr + i);
201 }
202 outptr = finalstr;
203 }
204
205 *(outptr + 24 + nchars + escapes) = '\"';
206 *(outptr + 25 + nchars + escapes) = '\0';
207
208 result = Tcl_Eval(consoleinterp, outptr);
209
210 if (bigstr != NULL) Tcl_Free(bigstr);
211 if (finalstr != NULL) Tcl_Free(finalstr);
212 }
213
214 /*------------------------------------------------------*/
215 /* Console output flushing which goes along with the */
216 /* routine tcl_vprintf() above. */
217 /*------------------------------------------------------*/
218
219 void tcl_stdflush(FILE *f)
220 {
221 Tcl_SavedResult state;
222 static char stdstr[] = "::flush stdxxx";
223 char *stdptr = stdstr + 11;
224
225 if ((f != stderr) && (f != stdout)) {
226 fflush(f);
227 }
228 else {
229 Tcl_SaveResult(xcinterp, &state);
230 strcpy(stdptr, (f == stderr) ? "err" : "out");
231 Tcl_Eval(xcinterp, stdstr);
232 Tcl_RestoreResult(xcinterp, &state);
233 }
234 }
235
236 /*----------------------------------------------------------------------*/
237 /* Reimplement fprintf() as a call to Tcl_Eval(). */
238 /* Make sure that files (not stdout or stderr) get treated normally. */
239 /*----------------------------------------------------------------------*/
240
241 void tcl_printf(FILE *f, const char *format, ...)
242 {
243 va_list ap;
244
245 va_start(ap, format);
246 if ((f != stderr) && (f != stdout))
247 vfprintf(f, format, ap);
248 else
249 tcl_vprintf(f, format, ap);
250 va_end(ap);
251 }
252
253 /*----------------------------------------------------------------------*/
254 /* Fill in standard areas of a key event structure. This includes */
255 /* everything necessary except type, keycode, and state (although */
256 /* state defaults to zero). This is also good for button events, which */
257 /* share the same structure as key events (except that keycode is */
258 /* changed to button). */
259 /*----------------------------------------------------------------------*/
260
261 void make_new_event(XKeyEvent *event)
262 {
263 XPoint newpos, wpoint;
264
265 newpos = UGetCursorPos();
266 user_to_window(newpos, &wpoint);
267 event->x = wpoint.x;
268 event->y = wpoint.y;
269
270 event->same_screen = TRUE;
271 event->send_event = TRUE;
272 event->display = dpy;
273 event->window = Tk_WindowId(areawin->area);
274
275 event->state = 0;
276 }
277
278 /*----------------------------------------------------------------------*/
279 /* Implement tag callbacks on functions */
280 /* Find any tags associated with a command and execute them. */
281 /*----------------------------------------------------------------------*/
282
283 int XcTagCallback(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])
284 {
285 int objidx, result = TCL_OK;
286 char *postcmd, *substcmd, *newcmd, *sptr, *sres;
287 char *croot = Tcl_GetString(objv[0]);
288 Tcl_HashEntry *entry;
289 Tcl_SavedResult state;
290 int reset = FALSE;
291 int i, llen;
292
293 /* Skip over technology qualifier, if any */
294
295 if (!strncmp(croot, "::", 2)) croot += 2;
296 if (!strncmp(croot, "xcircuit::", 10)) croot += 10;
297
298 entry = Tcl_FindHashEntry(&XcTagTable, croot);
299 postcmd = (entry) ? (char *)Tcl_GetHashValue(entry) : NULL;
300
301 if (postcmd)
302 {
303 substcmd = (char *)Tcl_Alloc(strlen(postcmd) + 1);
304 strcpy(substcmd, postcmd);
305 sptr = substcmd;
306
307 /*--------------------------------------------------------------*/
308 /* Parse "postcmd" for Tk-substitution escapes */
309 /* Allowed escapes are: */
310 /* %W substitute the tk path of the calling window */
311 /* %r substitute the previous Tcl result string */
312 /* %R substitute the previous Tcl result string and */
313 /* reset the Tcl result. */
314 /* %[0-5] substitute the argument to the original command */
315 /* %N substitute all arguments as a list */
316 /* %% substitute a single percent character */
317 /* %# substitute the number of arguments passed */
318 /* %* (all others) no action: print as-is. */
319 /*--------------------------------------------------------------*/
320
321 while ((sptr = strchr(sptr, '%')) != NULL)
322 {
323 switch (*(sptr + 1))
324 {
325 case 'W': {
326 char *tkpath = NULL;
327 Tk_Window tkwind = Tk_MainWindow(interp);
328 if (tkwind != NULL) tkpath = Tk_PathName(tkwind);
329 if (tkpath == NULL)
330 newcmd = (char *)Tcl_Alloc(strlen(substcmd));
331 else
332 newcmd = (char *)Tcl_Alloc(strlen(substcmd) + strlen(tkpath));
333
334 strcpy(newcmd, substcmd);
335
336 if (tkpath == NULL)
337 strcpy(newcmd + (int)(sptr - substcmd), sptr + 2);
338 else
339 {
340 strcpy(newcmd + (int)(sptr - substcmd), tkpath);
341 strcat(newcmd, sptr + 2);
342 }
343 Tcl_Free(substcmd);
344 substcmd = newcmd;
345 sptr = substcmd;
346 } break;
347
348 case 'R':
349 reset = TRUE;
350 case 'r':
351 sres = (char *)Tcl_GetStringResult(interp);
352 newcmd = (char *)Tcl_Alloc(strlen(substcmd)
353 + strlen(sres) + 1);
354 strcpy(newcmd, substcmd);
355 sprintf(newcmd + (int)(sptr - substcmd), "\"%s\"", sres);
356 strcat(newcmd, sptr + 2);
357 Tcl_Free(substcmd);
358 substcmd = newcmd;
359 sptr = substcmd;
360 break;
361
362 case '#':
363 if (objc < 100) {
364 newcmd = (char *)Tcl_Alloc(strlen(substcmd) + 3);
365 strcpy(newcmd, substcmd);
366 sprintf(newcmd + (int)(sptr - substcmd), "%d", objc);
367 strcat(newcmd, sptr + 2);
368 Tcl_Free(substcmd);
369 substcmd = newcmd;
370 sptr = substcmd;
371 }
372 break;
373
374 case '0': case '1': case '2': case '3': case '4': case '5':
375 objidx = (int)(*(sptr + 1) - '0');
376 if ((objidx >= 0) && (objidx < objc))
377 {
378 newcmd = (char *)Tcl_Alloc(strlen(substcmd)
379 + strlen(Tcl_GetString(objv[objidx])) + 1);
380 strcpy(newcmd, substcmd);
381 strcpy(newcmd + (int)(sptr - substcmd),
382 Tcl_GetString(objv[objidx]));
383 strcat(newcmd, sptr + 2);
384 Tcl_Free(substcmd);
385 substcmd = newcmd;
386 sptr = substcmd;
387 }
388 else if (objidx >= objc)
389 {
390 newcmd = (char *)Tcl_Alloc(strlen(substcmd) + 1);
391 strcpy(newcmd, substcmd);
392 strcpy(newcmd + (int)(sptr - substcmd), sptr + 2);
393 Tcl_Free(substcmd);
394 substcmd = newcmd;
395 sptr = substcmd;
396 }
397 else sptr++;
398 break;
399
400 case 'N':
401 llen = 1;
402 for (i = 1; i < objc; i++)
403 llen += (1 + strlen(Tcl_GetString(objv[i])));
404 newcmd = (char *)Tcl_Alloc(strlen(substcmd) + llen);
405 strcpy(newcmd, substcmd);
406 strcpy(newcmd + (int)(sptr - substcmd), "{");
407 for (i = 1; i < objc; i++) {
408 strcat(newcmd, Tcl_GetString(objv[i]));
409 if (i < (objc - 1))
410 strcat(newcmd, " ");
411 }
412 strcat(newcmd, "}");
413 strcat(newcmd, sptr + 2);
414 Tcl_Free(substcmd);
415 substcmd = newcmd;
416 sptr = substcmd;
417 break;
418
419 case '%':
420 newcmd = (char *)Tcl_Alloc(strlen(substcmd) + 1);
421 strcpy(newcmd, substcmd);
422 strcpy(newcmd + (int)(sptr - substcmd), sptr + 1);
423 Tcl_Free(substcmd);
424 substcmd = newcmd;
425 sptr = substcmd;
426 break;
427
428 default:
429 sptr++;
430 break;
431 }
432 }
433
434 /* Fprintf(stderr, "Substituted tag callback is \"%s\"\n", substcmd); */
435 /* Flush(stderr); */
436
437 Tcl_SaveResult(interp, &state);
438 result = Tcl_Eval(interp, substcmd);
439 if ((result == TCL_OK) && (reset == FALSE))
440 Tcl_RestoreResult(interp, &state);
441 else
442 Tcl_DiscardResult(&state);
443
444 Tcl_Free(substcmd);
445 }
446 return result;
447 }
448
449 /*--------------------------------------------------------------*/
450 /* XcInternalTagCall --- */
451 /* */
452 /* Execute the tag callback for a command without actually */
453 /* evaluating the command itself. The command and arguments */
454 /* are passed as a variable number or char * arguments, since */
455 /* usually this routine will called with constant arguments */
456 /* (e.g., XcInternalTagCall(interp, 2, "set", "color");) */
457 /* */
458 /* objv declared static because this routine is used a lot */
459 /* (e.g., during select/unselect operations). */
460 /*--------------------------------------------------------------*/
461
462 int XcInternalTagCall(Tcl_Interp *interp, int argc, ...)
463 {
464 int i;
465 static Tcl_Obj **objv = NULL;
466 char *aptr;
467 va_list ap;
468
469
470 if (objv == (Tcl_Obj **)NULL)
471 objv = (Tcl_Obj **)malloc(argc * sizeof(Tcl_Obj *));
472 else
473 objv = (Tcl_Obj **)realloc(objv, argc * sizeof(Tcl_Obj *));
474
475 va_start(ap, argc);
476 for (i = 0; i < argc; i++) {
477 aptr = va_arg(ap, char *);
478 /* We are depending on Tcl's heap allocation of objects */
479 /* so that we do not have to manage memory for these */
480 /* string representations. . . */
481
482 objv[i] = Tcl_NewStringObj(aptr, -1);
483 }
484 va_end(ap);
485
486 return XcTagCallback(interp, argc, objv);
487 }
488
489 /*--------------------------------------------------------------*/
490 /* Return the event mode */
491 /* Event mode can be set in specific cases. */
492 /*--------------------------------------------------------------*/
493
494 int xctcl_eventmode(ClientData clientData,
495 Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])
496 {
497 static char *modeNames[] = {
498 "normal", "undo", "move", "copy", "pan",
499 "selarea", "rescale", "catalog", "cattext",
500 "fontcat", "efontcat", "text", "wire", "box",
501 "arc", "spline", "etext", "epoly", "earc",
502 "espline", "epath", "einst", "assoc", "catmove",
503 NULL
504 };
505
506 /* This routine is diagnostic only */
507
508 if (objc != 1) return TCL_ERROR;
509
510 Tcl_SetResult(interp, modeNames[eventmode], NULL);
511 return TCL_OK;
512 }
513
514 /*--------------------------------------------------------------*/
515 /* Add a command tag callback */
516 /*--------------------------------------------------------------*/
517
518 int xctcl_tag(ClientData clientData,
519 Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])
520 {
521 Tcl_HashEntry *entry;
522 char *hstring;
523 int new;
524
525 if (objc != 2 && objc != 3)
526 return TCL_ERROR;
527
528 entry = Tcl_CreateHashEntry(&XcTagTable, Tcl_GetString(objv[1]), &new);
529 if (entry == NULL) return TCL_ERROR;
530
531 hstring = (char *)Tcl_GetHashValue(entry);
532 if (objc == 2)
533 {
534 Tcl_SetResult(interp, hstring, NULL);
535 return TCL_OK;
536 }
537
538 if (strlen(Tcl_GetString(objv[2])) == 0)
539 {
540 Tcl_DeleteHashEntry(entry);
541 }
542 else
543 {
544 hstring = strdup(Tcl_GetString(objv[2]));
545 Tcl_SetHashValue(entry, hstring);
546 }
547 return TCL_OK;
548 }
549
550 /*----------------------------------------------------------------------*/
551 /* Turn a selection list into a Tcl List object (may be empty list) */
552 /*----------------------------------------------------------------------*/
553
554 Tcl_Obj *SelectToTclList(Tcl_Interp *interp, short *slist, int snum)
555 {
556 int i;
557 Tcl_Obj *objPtr, *listPtr;
558
559 if (snum == 1) {
560 objPtr = Tcl_NewHandleObj(SELTOGENERIC(slist));
561 return objPtr;
562 }
563
564 listPtr = Tcl_NewListObj(0, NULL);
565 for (i = 0; i < snum; i++) {
566 objPtr = Tcl_NewHandleObj(SELTOGENERIC(slist + i));
567 Tcl_ListObjAppendElement(interp, listPtr, objPtr);
568 }
569 return listPtr;
570 }
571
572 /*----------------------------------------------------------------------*/
573 /* Get an x,y position (as an XPoint structure) from a list of size 2 */
574 /*----------------------------------------------------------------------*/
575
576 int GetPositionFromList(Tcl_Interp *interp, Tcl_Obj *list, XPoint *rpoint)
577 {
578 int result, numobjs;
579 Tcl_Obj *lobj, *tobj;
580 int pos;
581
582 if (!strcmp(Tcl_GetString(list), "here")) {
583 if (rpoint) *rpoint = UGetCursorPos();
584 return TCL_OK;
585 }
586 result = Tcl_ListObjLength(interp, list, &numobjs);
587 if (result != TCL_OK) return result;
588
589 if (numobjs == 1) {
590 /* Try decomposing the object into a list */
591 result = Tcl_ListObjIndex(interp, list, 0, &tobj);
592 if (result == TCL_OK) {
593 result = Tcl_ListObjLength(interp, tobj, &numobjs);
594 if (numobjs == 2)
595 list = tobj;
596 }
597 if (result != TCL_OK) Tcl_ResetResult(interp);
598 }
599 if (numobjs != 2) {
600 Tcl_SetResult(interp, "list must contain x y positions", NULL);
601 return TCL_ERROR;
602 }
603 result = Tcl_ListObjIndex(interp, list, 0, &lobj);
604 if (result != TCL_OK) return result;
605 result = Tcl_GetIntFromObj(interp, lobj, &pos);
606 if (result != TCL_OK) return result;
607 if (rpoint) rpoint->x = pos;
608
609 result = Tcl_ListObjIndex(interp, list, 1, &lobj);
610 if (result != TCL_OK) return result;
611 result = Tcl_GetIntFromObj(interp, lobj, &pos);
612 if (result != TCL_OK) return result;
613 if (rpoint) rpoint->y = pos;
614
615 return TCL_OK;
616 }
617
618 /*--------------------------------------------------------------*/
619 /* Convert color index to a list of 3 elements */
620 /* We assume that this color exists in the color table. */
621 /*--------------------------------------------------------------*/
622
623 Tcl_Obj *TclIndexToRGB(int cidx)
624 {
625 Tcl_Obj *RGBTuple;
626
627 if (cidx < 0) { /* Handle "default color" */
628 return Tcl_NewStringObj("Default", 7);
629 }
630 else if (cidx >= number_colors) {
631 Tcl_SetResult(xcinterp, "Bad color index", NULL);
632 return NULL;
633 }
634
635 RGBTuple = Tcl_NewListObj(0, NULL);
636 Tcl_ListObjAppendElement(xcinterp, RGBTuple,
637 Tcl_NewIntObj((int)(colorlist[cidx].color.red / 256)));
638 Tcl_ListObjAppendElement(xcinterp, RGBTuple,
639 Tcl_NewIntObj((int)(colorlist[cidx].color.green / 256)));
640 Tcl_ListObjAppendElement(xcinterp, RGBTuple,
641 Tcl_NewIntObj((int)(colorlist[cidx].color.blue / 256)));
642 return RGBTuple;
643 }
644
645
646 /*--------------------------------------------------------------*/
647 /* Convert a stringpart* to a Tcl list object */
648 /*--------------------------------------------------------------*/
649
650 Tcl_Obj *TclGetStringParts(stringpart *thisstring)
651 {
652 Tcl_Obj *lstr, *sdict, *stup;
653 int i;
654 stringpart *strptr;
655
656 lstr = Tcl_NewListObj(0, NULL);
657 for (strptr = thisstring, i = 0; strptr != NULL;
658 strptr = strptr->nextpart, i++) {
659 switch(strptr->type) {
660 case TEXT_STRING:
661 sdict = Tcl_NewListObj(0, NULL);
662 Tcl_ListObjAppendElement(xcinterp, sdict, Tcl_NewStringObj("Text", 4));
663 Tcl_ListObjAppendElement(xcinterp, sdict,
664 Tcl_NewStringObj(strptr->data.string,
665 strlen(strptr->data.string)));
666 Tcl_ListObjAppendElement(xcinterp, lstr, sdict);
667 break;
668 case PARAM_START:
669 sdict = Tcl_NewListObj(0, NULL);
670 Tcl_ListObjAppendElement(xcinterp, sdict, Tcl_NewStringObj("Parameter", 9));
671 Tcl_ListObjAppendElement(xcinterp, sdict,
672 Tcl_NewStringObj(strptr->data.string,
673 strlen(strptr->data.string)));
674 Tcl_ListObjAppendElement(xcinterp, lstr, sdict);
675 break;
676 case PARAM_END:
677 Tcl_ListObjAppendElement(xcinterp, lstr,
678 Tcl_NewStringObj("End Parameter", 13));
679 break;
680 case FONT_NAME:
681 sdict = Tcl_NewListObj(0, NULL);
682 Tcl_ListObjAppendElement(xcinterp, sdict, Tcl_NewStringObj("Font", 4));
683 Tcl_ListObjAppendElement(xcinterp, sdict,
684 Tcl_NewStringObj(fonts[strptr->data.font].psname,
685 strlen(fonts[strptr->data.font].psname)));
686 Tcl_ListObjAppendElement(xcinterp, lstr, sdict);
687 break;
688 case FONT_SCALE:
689 sdict = Tcl_NewListObj(0, NULL);
690 Tcl_ListObjAppendElement(xcinterp, sdict,
691 Tcl_NewStringObj("Font Scale", 10));
692 Tcl_ListObjAppendElement(xcinterp, sdict,
693 Tcl_NewDoubleObj((double)strptr->data.scale));
694 Tcl_ListObjAppendElement(xcinterp, lstr, sdict);
695 break;
696 case KERN:
697 sdict = Tcl_NewListObj(0, NULL);
698 stup = Tcl_NewListObj(0, NULL);
699 Tcl_ListObjAppendElement(xcinterp, stup,
700 Tcl_NewIntObj((int)strptr->data.kern[0]));
701 Tcl_ListObjAppendElement(xcinterp, stup,
702 Tcl_NewIntObj((int)strptr->data.kern[1]));
703
704 Tcl_ListObjAppendElement(xcinterp, sdict, Tcl_NewStringObj("Kern", 4));
705 Tcl_ListObjAppendElement(xcinterp, sdict, stup);
706 Tcl_ListObjAppendElement(xcinterp, lstr, sdict);
707 break;
708 case FONT_COLOR:
709 stup = TclIndexToRGB(strptr->data.color);
710 if (stup != NULL) {
711 sdict = Tcl_NewListObj(0, NULL);
712 Tcl_ListObjAppendElement(xcinterp, sdict,
713 Tcl_NewStringObj("Color", 5));
714 Tcl_ListObjAppendElement(xcinterp, sdict, stup);
715 Tcl_ListObjAppendElement(xcinterp, lstr, sdict);
716 }
717 break;
718 case MARGINSTOP:
719 sdict = Tcl_NewListObj(0, NULL);
720 Tcl_ListObjAppendElement(xcinterp, sdict,
721 Tcl_NewStringObj("Margin Stop", 11));
722 Tcl_ListObjAppendElement(xcinterp, sdict,
723 Tcl_NewIntObj((int)strptr->data.width));
724 Tcl_ListObjAppendElement(xcinterp, lstr, sdict);
725 break;
726 case TABSTOP:
727 Tcl_ListObjAppendElement(xcinterp, lstr,
728 Tcl_NewStringObj("Tab Stop", 8));
729 break;
730 case TABFORWARD:
731 Tcl_ListObjAppendElement(xcinterp, lstr,
732 Tcl_NewStringObj("Tab Forward", 11));
733 break;
734 case TABBACKWARD:
735 Tcl_ListObjAppendElement(xcinterp, lstr,
736 Tcl_NewStringObj("Tab Backward", 12));
737 break;
738 case RETURN:
739 // Don't show automatically interted line breaks
740 if (strptr->data.flags == 0)
741 Tcl_ListObjAppendElement(xcinterp, lstr,
742 Tcl_NewStringObj("Return", 6));
743 break;
744 case SUBSCRIPT:
745 Tcl_ListObjAppendElement(xcinterp, lstr,
746 Tcl_NewStringObj("Subscript", 9));
747 break;
748 case SUPERSCRIPT:
749 Tcl_ListObjAppendElement(xcinterp, lstr,
750 Tcl_NewStringObj("Superscript", 11));
751 break;
752 case NORMALSCRIPT:
753 Tcl_ListObjAppendElement(xcinterp, lstr,
754 Tcl_NewStringObj("Normalscript", 12));
755 break;
756 case UNDERLINE:
757 Tcl_ListObjAppendElement(xcinterp, lstr,
758 Tcl_NewStringObj("Underline", 9));
759 break;
760 case OVERLINE:
761 Tcl_ListObjAppendElement(xcinterp, lstr,
762 Tcl_NewStringObj("Overline", 8));
763 break;
764 case NOLINE:
765 Tcl_ListObjAppendElement(xcinterp, lstr,
766 Tcl_NewStringObj("No Line", 7));
767 break;
768 case HALFSPACE:
769 Tcl_ListObjAppendElement(xcinterp, lstr,
770 Tcl_NewStringObj("Half Space", 10));
771 break;
772 case QTRSPACE:
773 Tcl_ListObjAppendElement(xcinterp, lstr,
774 Tcl_NewStringObj("Quarter Space", 13));
775 break;
776 }
777 }
778 return lstr;
779 }
780
781 /*----------------------------------------------------------------------*/
782 /* Get a stringpart linked list from a Tcl list */
783 /*----------------------------------------------------------------------*/
784
785 int GetXCStringFromList(Tcl_Interp *interp, Tcl_Obj *list, stringpart **rstring)
786 {
787 int result, j, k, numobjs, idx, numparts, ptype, ival;
788 Tcl_Obj *lobj, *pobj, *tobj, *t2obj;
789 stringpart *newpart;
790 char *fname;
791 double fscale;
792
793 static char *partTypes[] = {"Text", "Subscript", "Superscript",
794 "Normalscript", "Underline", "Overline", "No Line", "Tab Stop",
795 "Tab Forward", "Tab Backward", "Half Space", "Quarter Space",
796 "Return", "Font", "Font Scale", "Color", "Margin Stop", "Kern",
797 "Parameter", "End Parameter", "Special", NULL};
798
799 static int partTypesIdx[] = {TEXT_STRING, SUBSCRIPT, SUPERSCRIPT,
800 NORMALSCRIPT, UNDERLINE, OVERLINE, NOLINE, TABSTOP, TABFORWARD,
801 TABBACKWARD, HALFSPACE, QTRSPACE, RETURN, FONT_NAME, FONT_SCALE,
802 FONT_COLOR, MARGINSTOP, KERN, PARAM_START, PARAM_END, SPECIAL};
803
804 /* No place to put result! */
805 if (rstring == NULL) return TCL_ERROR;
806
807 result = Tcl_ListObjLength(interp, list, &numobjs);
808 if (result != TCL_OK) return result;
809
810 newpart = NULL;
811 for (j = 0; j < numobjs; j++) {
812 result = Tcl_ListObjIndex(interp, list, j, &lobj);
813 if (result != TCL_OK) return result;
814
815 result = Tcl_ListObjLength(interp, lobj, &numparts);
816 if (result != TCL_OK) return result;
817
818 result = Tcl_ListObjIndex(interp, lobj, 0, &pobj);
819 if (result != TCL_OK) return result;
820
821 /* Must define TCL_EXACT in flags, or else, for instance, "u" gets */
822 /* interpreted as "underline", which is usually not intended. */
823
824 if (pobj == NULL)
825 return TCL_ERROR;
826 else if (Tcl_GetIndexFromObj(interp, pobj, (CONST84 char **)partTypes,
827 "string part types", TCL_EXACT, &idx) != TCL_OK) {
828 Tcl_ResetResult(interp);
829 idx = -1;
830
831 // If there's only one object and the first item doesn't match
832 // a stringpart itentifying word, then assume that "list" is a
833 // single text string.
834
835 if (numobjs == 1)
836 tobj = list;
837 else
838 result = Tcl_ListObjIndex(interp, lobj, 0, &tobj);
839 }
840 else {
841 result = Tcl_ListObjIndex(interp, lobj, (numparts > 1) ? 1 : 0, &tobj);
842 }
843 if (result != TCL_OK) return result;
844
845 if (idx < 0) {
846 if ((newpart == NULL) || (newpart->type != TEXT_STRING))
847 idx = 0;
848 else {
849 /* We have an implicit text string which should be appended */
850 /* to the previous text string with a space character. */
851 newpart->data.string = (char *)realloc(newpart->data.string,
852 strlen(newpart->data.string) + strlen(Tcl_GetString(tobj))
853 + 2);
854 strcat(newpart->data.string, " ");
855 strcat(newpart->data.string, Tcl_GetString(tobj));
856 continue;
857 }
858 }
859 ptype = partTypesIdx[idx];
860
861 newpart = makesegment(rstring, NULL);
862 newpart->nextpart = NULL;
863 newpart->type = ptype;
864
865 switch(ptype) {
866 case TEXT_STRING:
867 case PARAM_START:
868 newpart->data.string = strdup(Tcl_GetString(tobj));
869 break;
870 case FONT_NAME:
871 fname = Tcl_GetString(tobj);
872 for (k = 0; k < fontcount; k++) {
873 if (!strcmp(fonts[k].psname, fname)) {
874 newpart->data.font = k;
875 break;
876 }
877 }
878 if (k == fontcount) {
879 Tcl_SetResult(interp, "Bad font name", NULL);
880 return TCL_ERROR;
881 }
882 break;
883 case FONT_SCALE:
884 result = Tcl_GetDoubleFromObj(interp, tobj, &fscale);
885 if (result != TCL_OK) return result;
886 newpart->data.scale = (float)fscale;
887 break;
888 case MARGINSTOP:
889 result = Tcl_GetIntFromObj(interp, tobj, &ival);
890 if (result != TCL_OK) return result;
891 newpart->data.width = ival;
892 break;
893 case KERN:
894 result = Tcl_ListObjLength(interp, tobj, &numparts);
895 if (result != TCL_OK) return result;
896 if (numparts != 2) {
897 Tcl_SetResult(interp, "Bad kern list: need 2 values", NULL);
898 return TCL_ERROR;
899 }
900 result = Tcl_ListObjIndex(interp, tobj, 0, &t2obj);
901 if (result != TCL_OK) return result;
902 result = Tcl_GetIntFromObj(interp, t2obj, &ival);
903 if (result != TCL_OK) return result;
904 newpart->data.kern[0] = (short)ival;
905
906 result = Tcl_ListObjIndex(interp, tobj, 1, &t2obj);
907 if (result != TCL_OK) return result;
908 result = Tcl_GetIntFromObj(interp, t2obj, &ival);
909 if (result != TCL_OK) return result;
910 newpart->data.kern[1] = (short)ival;
911
912 break;
913 case FONT_COLOR:
914 /* Not implemented: Need TclRGBToIndex() function */
915 break;
916
917 /* All other types have no arguments */
918 }
919 }
920 return TCL_OK;
921 }
922
923 /*----------------------------------------------------------------------*/
924 /* Handle (integer representation of internal xcircuit object) checking */
925 /* if "checkobject" is NULL, then */
926 /*----------------------------------------------------------------------*/
927
928 genericptr *CheckHandle(pointertype eaddr, objectptr checkobject)
929 {
930 genericptr *gelem;
931 int i, j;
932 objectptr thisobj;
933 Library *thislib;
934
935 if (checkobject != NULL) {
936 for (gelem = checkobject->plist; gelem < checkobject->plist +
937 checkobject->parts; gelem++)
938 if ((pointertype)(*gelem) == eaddr) goto exists;
939 return NULL;
940 }
941
942 /* Look through all the pages. */
943
944 for (i = 0; i < xobjs.pages; i++) {
945 if (xobjs.pagelist[i]->pageinst == NULL) continue;
946 thisobj = xobjs.pagelist[i]->pageinst->thisobject;
947 for (gelem = thisobj->plist; gelem < thisobj->plist + thisobj->parts; gelem++)
948 if ((pointertype)(*gelem) == eaddr) goto exists;
949 }
950
951 /* Not found? Maybe in a library */
952
953 for (i = 0; i < xobjs.numlibs; i++) {
954 thislib = xobjs.userlibs + i;
955 for (j = 0; j < thislib->number; j++) {
956 thisobj = thislib->library[j];
957 for (gelem = thisobj->plist; gelem < thisobj->plist + thisobj->parts; gelem++)
958 if ((pointertype)(*gelem) == eaddr) goto exists;
959 }
960 }
961
962 /* Either in the delete list (where we don't want to go) or */
963 /* is an invalid number. */
964 return NULL;
965
966 exists:
967 return gelem;
968 }
969
970 /*----------------------------------------------------------------------*/
971 /* Find the index into the "plist" list of elements */
972 /* Part number must be of a type in "mask" or no selection occurs. */
973 /* return values: -1 = no object found, -2 = found, but wrong type */
974 /*----------------------------------------------------------------------*/
975
976 short GetPartNumber(genericptr egen, objectptr checkobject, int mask)
977 {
978 genericptr *gelem;
979 objectptr thisobject = checkobject;
980 int i;
981
982 if (checkobject == NULL) thisobject = topobject;
983
984 for (i = 0, gelem = thisobject->plist; gelem < thisobject->plist +
985 thisobject->parts; gelem++, i++) {
986 if ((*gelem) == egen) {
987 if ((*gelem)->type & mask)
988 return i;
989 else
990 return -2;
991 }
992 }
993 return -1;
994 }
995
996 /*----------------------------------------------------------------------*/
997 /* This routine is used by a number of menu functions. It looks for */
998 /* the arguments "selected" or an integer (object handle). If the */
999 /* argument is a valid object handle, it is added to the select list. */
1000 /* The argument can be a list of handles, of which each is checked and */
1001 /* added to the select list. */
1002 /* "extra" indicates the number of required arguments beyond 2. */
1003 /* "next" returns the integer of the argument after the handle, or the */
1004 /* argument after the command, if there is no handle. If the handle is */
1005 /* specified as a hierarchical list of element handles then */
1006 /* areawin->hierstack contains the hierarchy of object instances. */
1007 /*----------------------------------------------------------------------*/
1008
1009 int ParseElementArguments(Tcl_Interp *interp, int objc,
1010 Tcl_Obj *CONST objv[], int *next, int mask) {
1011
1012 short *newselect;
1013 char *argstr;
1014 int i, j, result, numobjs;
1015 pointertype ehandle;
1016 Tcl_Obj *lobj;
1017 int extra = 0, goodobjs = 0;
1018
1019 if (next != NULL) {
1020 extra = *next;
1021 *next = 1;
1022 }
1023
1024 if ((objc > (2 + extra)) || (objc == 1)) {
1025 Tcl_WrongNumArgs(interp, 1, objv, "[selected | <element_handle>] <option>");
1026 return TCL_ERROR;
1027 }
1028 else if (objc == 1) {
1029 *next = 0;
1030 return TCL_OK;
1031 }
1032 else {
1033 argstr = Tcl_GetString(objv[1]);
1034
1035 if (strcmp(argstr, "selected")) {
1036
1037 /* check for object handle (special type) */
1038
1039 result = Tcl_ListObjLength(interp, objv[1], &numobjs);
1040 if (result != TCL_OK) return result;
1041 goodobjs = 0;
1042
1043 /* Non-integer, non-list types: assume operation is to be applied */
1044 /* to currently selected elements, and return to caller. */
1045
1046 if (numobjs == 1) {
1047 result = Tcl_GetHandleFromObj(interp, objv[1], (void *)&ehandle);
1048 if (result != TCL_OK) {
1049 Tcl_ResetResult(interp);
1050 return TCL_OK;
1051 }
1052 }
1053 if (numobjs == 0) {
1054 Tcl_SetResult(interp, "No elements.", NULL);
1055 return TCL_ERROR;
1056 }
1057 else
1058 newselect = (short *)malloc(numobjs * sizeof(short));
1059
1060 /* Prepare a new selection, in case the new selection is */
1061 /* smaller than the original selection, but don't blanket */
1062 /* delete an existing selection, which will destroy cycle */
1063 /* information. */
1064
1065 for (j = 0; j < numobjs; j++) {
1066 result = Tcl_ListObjIndex(interp, objv[1], j, &lobj);
1067 if (result != TCL_OK) {
1068 free(newselect);
1069 return result;
1070 }
1071 result = Tcl_GetHandleFromObj(interp, lobj, (void *)&ehandle);
1072 if (result != TCL_OK) {
1073 free(newselect);
1074 return result;
1075 }
1076 if (areawin->hierstack != NULL)
1077 i = GetPartNumber((genericptr)ehandle,
1078 areawin->hierstack->thisinst->thisobject, mask);
1079 else
1080 i = GetPartNumber((genericptr)ehandle, topobject, mask);
1081
1082 if (i == -1) {
1083 free_stack(&areawin->hierstack);
1084 Tcl_SetResult(interp, "No such element exists.", NULL);
1085 free(newselect);
1086 return TCL_ERROR;
1087 }
1088 else if (i >= 0) {
1089 *(newselect + goodobjs) = i;
1090 if (next != NULL) *next = 2;
1091 goodobjs++;
1092 }
1093 }
1094 if (goodobjs == 0) {
1095 Tcl_SetResult(interp, "No element matches required type.", NULL);
1096 unselect_all();
1097 free(newselect);
1098 return TCL_ERROR;
1099 }
1100 else {
1101 selection aselect, bselect;
1102
1103 /* To avoid unnecessarily blasting the existing selection */
1104 /* and its cycles, we compare the two selection lists. */
1105 /* This is not an excuse for not fixing the selection list */
1106 /* mess in general! */
1107
1108 aselect.selectlist = newselect;
1109 aselect.selects = goodobjs;
1110 bselect.selectlist = areawin->selectlist;
1111 bselect.selects = areawin->selects;
1112 if (compareselection(&aselect, &bselect)) {
1113 free(newselect);
1114 }
1115 else {
1116 unselect_all();
1117 areawin->selects = goodobjs;
1118 areawin->selectlist = newselect;
1119 }
1120 }
1121
1122 draw_normal_selected(topobject, areawin->topinstance);
1123 }
1124 else if (next != NULL) *next = 2;
1125 }
1126 return TCL_OK;
1127 }
1128
1129 /*----------------------------------------------------------------------*/
1130 /* Generate a transformation matrix according to the object instance */
1131 /* hierarchy left on the hierstack. */
1132 /*----------------------------------------------------------------------*/
1133
1134 void MakeHierCTM(Matrix *hierCTM)
1135 {
1136 objinstptr thisinst;
1137 pushlistptr cs;
1138
1139 UResetCTM(hierCTM);
1140 for (cs = areawin->hierstack; cs != NULL; cs = cs->next) {
1141 thisinst = cs->thisinst;
1142 UMultCTM(hierCTM, thisinst->position, thisinst->scale, thisinst->rotation);
1143 }
1144 }
1145
1146 /*----------------------------------------------------------------------*/
1147 /* This routine is similar to ParseElementArguments. It looks for a */
1148 /* page number or page name in the second argument position. If it */
1149 /* finds one, it sets the page number in the return value. Otherwise, */
1150 /* it sets the return value to the value of areawin->page. */
1151 /*----------------------------------------------------------------------*/
1152
1153 int ParsePageArguments(Tcl_Interp *interp, int objc,
1154 Tcl_Obj *CONST objv[], int *next, int *pageret) {
1155
1156 char *pagename;
1157 int i, page, result;
1158 Tcl_Obj *objPtr;
1159
1160 if (next != NULL) *next = 1;
1161 if (pageret != NULL) *pageret = areawin->page; /* default */
1162
1163 if ((objc == 1) || ((objc == 2) && !strcmp(Tcl_GetString(objv[1]), ""))) {
1164 objPtr = Tcl_NewIntObj(areawin->page + 1);
1165 Tcl_SetObjResult(interp, objPtr);
1166 if (next) *next = -1;
1167 return TCL_OK;
1168 }
1169 else {
1170 pagename = Tcl_GetString(objv[1]);
1171 if (strcmp(pagename, "directory")) {
1172
1173 /* check for page number (integer) */
1174
1175 result = Tcl_GetIntFromObj(interp, objv[1], &page);
1176 if (result != TCL_OK) {
1177 Tcl_ResetResult(interp);
1178
1179 /* check for page name (string) */
1180
1181 for (i = 0; i < xobjs.pages; i++) {
1182 if (xobjs.pagelist[i]->pageinst == NULL) continue;
1183 if (!strcmp(pagename, xobjs.pagelist[i]->pageinst->thisobject->name)) {
1184 if (pageret) *pageret = i;
1185 break;
1186 }
1187 }
1188 if (i == xobjs.pages) {
1189 if (next != NULL) *next = 0;
1190 }
1191 }
1192 else {
1193 if (page < 1) {
1194 Tcl_SetResult(interp, "Illegal page number: zero or negative", NULL);
1195 return TCL_ERROR;
1196 }
1197 else if (page > xobjs.pages) {
1198 Tcl_SetResult(interp, "Illegal page number: page does not exist", NULL);
1199 if (pageret) *pageret = (page - 1);
1200 return TCL_ERROR;
1201 }
1202 else if (pageret) *pageret = (page - 1);
1203 }
1204 }
1205 else {
1206 *next = 0;
1207 }
1208 }
1209 return TCL_OK;
1210 }
1211
1212 /*----------------------------------------------------------------------*/
1213 /* This routine is similar to ParsePageArguments. It looks for a */
1214 /* library number or library name in the second argument position. If */
1215 /* it finds one, it sets the page number in the return value. */
1216 /* Otherwise, if a library page is currently being viewed, it sets the */
1217 /* return value to that library. Otherwise, it sets the return value */
1218 /* to the User Library. */
1219 /*----------------------------------------------------------------------*/
1220
1221 int ParseLibArguments(Tcl_Interp *interp, int objc,
1222 Tcl_Obj *CONST objv[], int *next, int *libret) {
1223
1224 char *libname;
1225 int library, result;
1226 Tcl_Obj *objPtr;
1227
1228 if (next != NULL) *next = 1;
1229
1230 if (objc == 1) {
1231 library = is_library(topobject);
1232 if (library < 0) {
1233 Tcl_SetResult(interp, "No current library.", NULL);
1234 return TCL_ERROR;
1235 }
1236 objPtr = Tcl_NewIntObj(library + 1);
1237 Tcl_SetObjResult(interp, objPtr);
1238 if (next) *next = -1;
1239 return TCL_OK;
1240 }
1241 else {
1242 libname = Tcl_GetString(objv[1]);
1243 if (strcmp(libname, "directory")) {
1244
1245 /* check for library number (integer) or name */
1246
1247 result = Tcl_GetIntFromObj(interp, objv[1], &library);
1248 if (result != TCL_OK) {
1249 Tcl_ResetResult(xcinterp);
1250 *libret = NameToLibrary(libname);
1251 if (*libret < 0) {
1252 *libret = -1;
1253 if (next != NULL) *next = 0;
1254 }
1255 }
1256 else {
1257 if (library < 1) {
1258 Tcl_SetResult(interp, "Illegal library number: zero or negative", NULL);
1259 return TCL_ERROR;
1260 }
1261 else if (library > xobjs.numlibs) {
1262 Tcl_SetResult(interp, "Illegal library number: library "
1263 "does not exist", NULL);
1264 return TCL_ERROR;
1265 }
1266 else *libret = (library - 1);
1267 }
1268 }
1269 else *next = 0;
1270 }
1271 return TCL_OK;
1272 }
1273
1274 /*----------------------------------------------------------------------*/
1275 /* Schematic and symbol creation and association */
1276 /*----------------------------------------------------------------------*/
1277
1278 int xctcl_symschem(ClientData clientData, Tcl_Interp *interp,
1279 int objc, Tcl_Obj *CONST objv[])
1280 {
1281 int i, idx, result, stype;
1282 objectptr otherobj = NULL;
1283 char *objname;
1284
1285 static char *subCmds[] = {
1286 "associate", "disassociate", "make", "goto", "get", "type", NULL
1287 };
1288 enum SubIdx {
1289 AssocIdx, DisAssocIdx, MakeIdx, GoToIdx, NameIdx, TypeIdx
1290 };
1291
1292 /* The order of these must match the definitions in xcircuit.h */
1293 static char *schemTypes[] = {
1294 "primary", "secondary", "trivial", "symbol", "fundamental",
1295 "nonetwork", NULL /* (jdk) */
1296 };
1297
1298 if (objc == 1 || objc > 4) {
1299 Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
1300 return TCL_ERROR;
1301 }
1302 else if ((result = Tcl_GetIndexFromObj(interp, objv[1],
1303 (CONST84 char **)subCmds, "option", 0, &idx)) != TCL_OK) {
1304 return result;
1305 }
1306
1307 switch(idx) {
1308 case AssocIdx:
1309 if (objc == 3) {
1310
1311 /* To do: accept name for association */
1312 objname = Tcl_GetString(objv[2]);
1313
1314 if (topobject->schemtype == PRIMARY) {
1315
1316 /* Name has to be that of a library object */
1317
1318 otherobj = NameToObject(Tcl_GetString(objv[2]), NULL, FALSE);
1319 if (otherobj == NULL) {
1320 Tcl_SetResult(interp, "Name is not a known object", NULL);
1321 return TCL_ERROR;
1322 }
1323 }
1324 else {
1325
1326 /* Name has to be that of a page label */
1327
1328 objectptr pageobj;
1329 for (i = 0; i < xobjs.pages; i++) {
1330 pageobj = xobjs.pagelist[i]->pageinst->thisobject;
1331 if (!strcmp(objname, pageobj->name)) {
1332 otherobj = pageobj;
1333 break;
1334 }
1335 }
1336 if (otherobj == NULL)
1337 {
1338 Tcl_SetResult(interp, "Name is not a known page label", NULL);
1339 return TCL_ERROR;
1340 }
1341 }
1342 if (schemassoc(topobject, otherobj) == False)
1343 return TCL_ERROR;
1344 }
1345 else
1346 startschemassoc(NULL, 0, NULL);
1347 break;
1348 case DisAssocIdx:
1349 schemdisassoc();
1350 break;
1351 case MakeIdx:
1352 if (topobject->symschem != NULL)
1353 Wprintf("Error: Schematic already has an associated symbol.");
1354 else if (topobject->schemtype != PRIMARY)
1355 Wprintf("Error: Current page is not a primary schematic.");
1356 else if (!strncmp(topobject->name, "Page ", 5))
1357 Wprintf("Error: Schematic page must have a valid name.");
1358 else {
1359 int libnum = -1;
1360 if (objc >= 3) {
1361
1362 objname = Tcl_GetString(objv[2]);
1363
1364 if (objc == 4) {
1365 ParseLibArguments(xcinterp, 2, &objv[2], NULL, &libnum);
1366 if (libnum < 0) {
1367 Tcl_SetResult(interp, "Invalid library name.", NULL);
1368 return TCL_ERROR;
1369 }
1370 }
1371 }
1372 else {
1373 /* Use this error condition to generate the popup prompt */
1374 Tcl_SetResult(interp, "Must supply a name for the page", NULL);
1375 return TCL_ERROR;
1376 }
1377 swapschem(1, libnum, objname);
1378 return TCL_OK;
1379 }
1380 return TCL_ERROR;
1381 break;
1382 case GoToIdx:
1383 /* This is supposed to specifically go to the specified type, */
1384 /* so don't call swapschem to change views if we're already */
1385 /* on the right view. */
1386
1387 if (topobject->schemtype == PRIMARY || topobject->schemtype == SECONDARY) {
1388 if (!strncmp(Tcl_GetString(objv[0]), "sym", 3)) {
1389 swapschem(0, -1, NULL);
1390 }
1391 }
1392 else {
1393 if (!strncmp(Tcl_GetString(objv[0]), "sch", 3)) {
1394 swapschem(0, -1, NULL);
1395 }
1396 }
1397 break;
1398 case NameIdx:
1399 if (topobject->symschem != NULL)
1400 Tcl_AppendElement(interp, topobject->symschem->name);
1401 break;
1402 case TypeIdx:
1403 if (objc == 3) {
1404 if (topobject->schemtype == PRIMARY || topobject->schemtype == SECONDARY) {
1405 Tcl_SetResult(interp, "Make object to change from schematic to symbol",
1406 NULL);
1407 return TCL_ERROR;
1408 }
1409 if ((result = Tcl_GetIndexFromObj(interp, objv[2],
1410 (CONST84 char **)schemTypes, "schematic types",
1411 0, &stype)) != TCL_OK)
1412 return result;
1413 if (stype == PRIMARY || stype == SECONDARY) {
1414 Tcl_SetResult(interp, "Cannot change symbol into a schematic", NULL);
1415 return TCL_ERROR;
1416 }
1417 topobject->schemtype = stype;
1418 if (topobject->symschem) schemdisassoc();
1419 }
1420 else
1421 Tcl_AppendElement(interp, schemTypes[topobject->schemtype]);
1422
1423 break;
1424 }
1425 return XcTagCallback(interp, objc, objv);
1426 }
1427
1428 /*----------------------------------------------------------------------*/
1429 /* Generate netlist into a Tcl hierarchical list */
1430 /* (plus other netlist functions) */
1431 /*----------------------------------------------------------------------*/
1432
1433 int xctcl_netlist(ClientData clientData, Tcl_Interp *interp,
1434 int objc, Tcl_Obj *CONST objv[])
1435 {
1436 Tcl_Obj *rdict;
1437 int idx, result, mpage, spage, bvar, j;
1438 Boolean valid, quiet;
1439 char *option, *extension, *mode = NULL;
1440 pushlistptr stack;
1441 objectptr master, slave;
1442 objinstptr schemtopinst;
1443
1444 static char *subCmds[] = {
1445 "write", "highlight", "unhighlight", "goto", "get", "select", "parse",
1446 "position", "make", "connect", "unconnect", "autonumber", "ratsnest",
1447 "update", NULL
1448 };
1449 enum SubIdx {
1450 WriteIdx, HighLightIdx, UnHighLightIdx, GoToIdx, GetIdx, SelectIdx,
1451 ParseIdx, PositionIdx, MakeIdx, ConnectIdx, UnConnectIdx,
1452 AutoNumberIdx, RatsNestIdx, UpdateIdx
1453 };
1454
1455 if (objc == 1) {
1456 Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
1457 return TCL_ERROR;
1458 }
1459 else if ((result = Tcl_GetIndexFromObj(interp, objv[1],
1460 (CONST84 char **)subCmds, "option", 0, &idx)) != TCL_OK) {
1461 return result;
1462 }
1463
1464 /* Look for the "-quiet" option (more options processed by "netlist get") */
1465
1466 j = 1;
1467 quiet = FALSE;
1468 while (option = Tcl_GetString(objv[objc - (j++)]), option[0] == '-') {
1469 if (!strncmp(option + 1, "quiet", 5))
1470 quiet = TRUE;
1471 }
1472
1473 /* Make sure a valid netlist exists for the current schematic */
1474 /* for those commands which require a valid netlist (non-ASG */
1475 /* functions). Some functions (e.g., "parse") require that */
1476 /* the next object up in the hierarchy have a valid netlist, */
1477 /* if we have descended to the current symbol from there. */
1478
1479 valid = False;
1480 switch(idx) {
1481 case RatsNestIdx:
1482 /* Specifically avoid calling updatenets() */
1483 if ((topobject->labels != NULL) || (topobject->polygons != NULL))
1484 valid = True;
1485 break;
1486 }
1487
1488 if (!valid) {
1489 objinstptr tinst;
1490
1491 /* Ignore libraries */
1492 if (is_library(topobject) >= 0 || (eventmode == CATALOG_MODE))
1493 return TCL_ERROR;
1494
1495 if ((topobject->schemtype) != PRIMARY && (areawin->stack != NULL))
1496 tinst = areawin->stack->thisinst;
1497 else
1498 tinst = areawin->topinstance;
1499
1500 if ((result = updatenets(tinst, quiet)) < 0) {
1501 Tcl_SetResult(interp, "Check circuit for infinite recursion.", NULL);
1502 return TCL_ERROR;
1503 }
1504 else if (result == 0) {
1505 Tcl_SetResult(interp, "No netlist.", NULL);
1506 return TCL_ERROR;
1507 }
1508 }
1509
1510 switch(idx) {
1511 case WriteIdx: /* write netlist formats */
1512 if (objc < 3) {
1513 Tcl_WrongNumArgs(interp, 1, objv, "write format [extension] "
1514 "[spice_end] [-option]");
1515 return TCL_ERROR;
1516 }
1517
1518 /* Check for forcing option */
1519
1520 option = Tcl_GetString(objv[objc - 1]);
1521 if (option[0] == '-')
1522 {
1523 option++;
1524 if (!strncmp(option, "flat", 4) || !strncmp(option, "pseu", 4))
1525 {
1526 mode = (char *)malloc(5 + strlen(Tcl_GetString(objv[2])));
1527 option[4] = '\0';
1528 sprintf(mode, "%s%s", option, Tcl_GetString(objv[2]));
1529 }
1530 else if (strncmp(option, "hier", 4))
1531 {
1532 Tcl_SetResult(interp, "Unknown netlist option.", NULL);
1533 return TCL_ERROR;
1534 }
1535 objc--;
1536 }
1537
1538 if ((result = Tcl_GetBooleanFromObj(interp, objv[objc - 1], &bvar))
1539 != TCL_OK) {
1540 spice_end = True;
1541 Tcl_ResetResult(interp);
1542 }
1543 else {
1544 spice_end = (Boolean)bvar;
1545 objc--;
1546 }
1547
1548 /* If no extension is specified, the extension is the same as */
1549 /* the format name. */
1550
1551 if (objc == 3)
1552 extension = Tcl_GetString(objv[2]);
1553 else
1554 extension = Tcl_GetString(objv[3]);
1555 writenet(topobject, (mode == NULL) ? Tcl_GetString(objv[2]) : mode,
1556 extension);
1557 if (mode != NULL) free(mode);
1558 break;
1559
1560 case GoToIdx: /* go to top-level page having specified name */
1561 if (objc != 2 && objc != 3) {
1562 Tcl_WrongNumArgs(interp, 1, objv, "goto [hierarchical-network-name]");
1563 return TCL_ERROR;
1564 }
1565
1566 /* Find the top of the schematic hierarchy, regardless of */
1567 /* where the current page is in it. */
1568
1569 if (areawin->stack == NULL)
1570 schemtopinst = areawin->topinstance;
1571 else {
1572 pushlistptr sstack = areawin->stack;
1573 while (sstack->next != NULL) sstack = sstack->next;
1574 schemtopinst = sstack->thisinst;
1575 }
1576
1577 stack = NULL;
1578 push_stack(&stack, schemtopinst, NULL);
1579 valid = TRUE;
1580 if (objc == 3)
1581 valid = HierNameToObject(schemtopinst, Tcl_GetString(objv[2]), &stack);
1582
1583 if (valid) {
1584 /* Add the current edit object to the push stack, then append */
1585 /* the new push stack */
1586 free_stack(&areawin->stack);
1587 topobject->viewscale = areawin->vscale;
1588 topobject->pcorner = areawin->pcorner;
1589 areawin->topinstance = stack->thisinst;
1590 pop_stack(&stack);
1591 areawin->stack = stack;
1592 setpage(TRUE);
1593 transferselects();
1594 refresh(NULL, NULL, NULL);
1595 setsymschem();
1596
1597 /* If the current object is a symbol that has a schematic, */
1598 /* go to the schematic. */
1599
1600 if (topobject->schemtype != PRIMARY && topobject->symschem != NULL)
1601 swapschem(0, -1, NULL);
1602 }
1603 else {
1604 Tcl_SetResult(interp, "Not a valid network.", NULL);
1605 return TCL_ERROR;
1606 }
1607 break;
1608
1609 case GetIdx: { /* return hierarchical name of selected network */
1610 int stype, netid, lbus;
1611 Boolean uplevel, hier, canon;
1612 char *prefix = NULL;
1613 Matrix locctm;
1614 short *newselect;
1615 Genericlist *netlist;
1616 CalllistPtr calls;
1617 objinstptr refinstance;
1618 objectptr refobject;
1619 XPoint refpoint, *refptptr;
1620 stringpart *ppin;
1621 char *snew;
1622 buslist *sbus;
1623 Tcl_Obj *tlist;
1624
1625 option = Tcl_GetString(objv[objc - 1]);
1626 uplevel = FALSE;
1627 hier = FALSE;
1628 canon = FALSE;
1629 quiet = FALSE;
1630 while (option[0] == '-') {
1631 if (!strncmp(option + 1, "up", 2)) {
1632 uplevel = TRUE;
1633 }
1634 else if (!strncmp(option + 1, "hier", 4)) {
1635 hier = TRUE;
1636 }
1637 else if (!strncmp(option + 1, "canon", 5)) {
1638 canon = TRUE;
1639 }
1640 else if (!strncmp(option + 1, "quiet", 5)) {
1641 quiet = TRUE;
1642 }
1643 else if (sscanf(option, "%hd", &refpoint.x) == 1) {
1644 break; /* This is probably a negative point position! */
1645 }
1646 objc--;
1647 option = Tcl_GetString(objv[objc - 1]);
1648 }
1649
1650 refinstance = (areawin->hierstack) ? areawin->hierstack->thisinst
1651 : areawin->topinstance;
1652
1653 if (uplevel) {
1654 if (areawin->hierstack == NULL) {
1655 if (areawin->stack == NULL) {
1656 if (quiet) return TCL_OK;
1657 Fprintf(stderr, "Option \"up\" used, but current page is the"
1658 " top of the schematic\n");
1659 return TCL_ERROR;
1660 }
1661 else {
1662 UResetCTM(&locctm);
1663 UPreMultCTM(&locctm, refinstance->position, refinstance->scale,
1664 refinstance->rotation);
1665 refinstance = areawin->stack->thisinst;
1666 refobject = refinstance->thisobject;
1667 }
1668 }
1669 else {
1670 if (areawin->hierstack->next == NULL) {
1671 if (quiet) return TCL_OK;
1672 Fprintf(stderr, "Option \"up\" used, but current page is the"
1673 " top of the drawing stack\n");
1674 return TCL_ERROR;
1675 }
1676 else {
1677 UResetCTM(&locctm);
1678 UPreMultCTM(&locctm, refinstance->position, refinstance->scale,
1679 refinstance->rotation);
1680 refinstance = areawin->hierstack->next->thisinst;
1681 refobject = refinstance->thisobject;
1682 }
1683 }
1684 }
1685 else {
1686 refobject = topobject;
1687 }
1688 if ((objc != 2) && (objc != 3)) {
1689 Tcl_WrongNumArgs(interp, 1, objv,
1690 "get [selected|here|<name>] [-up][-hier][-canon][-quiet]");
1691 return TCL_ERROR;
1692 }
1693 if ((objc == 3) && !strcmp(Tcl_GetString(objv[2]), "here")) {
1694 /* If "here", make a selection. */
1695 areawin->save = UGetCursorPos();
1696 newselect = select_element(POLYGON | LABEL | OBJINST);
1697 objc--;
1698 }
1699 if ((objc == 2) || (!strcmp(Tcl_GetString(objv[2]), "selected"))) {
1700 /* If no argument, or "selected", use the selected element */
1701 newselect = areawin->selectlist;
1702 if (areawin->selects == 0) {
1703 if (hier) {
1704 Tcl_SetResult(interp, GetHierarchy(&areawin->stack, canon),
1705 TCL_DYNAMIC);
1706 break;
1707 }
1708 else {
1709 Fprintf(stderr, "Either select an element or use \"-hier\"\n");
1710 return TCL_ERROR;
1711 }
1712 }
1713 if (areawin->selects != 1) {
1714 Fprintf(stderr, "Choose only one network element\n");
1715 return TCL_ERROR;
1716 }
1717 else {
1718 stype = SELECTTYPE(newselect);
1719 if (stype == LABEL) {
1720 labelptr nlabel = SELTOLABEL(newselect);
1721 refptptr = &(nlabel->position);
1722 if ((nlabel->pin != LOCAL) && (nlabel->pin != GLOBAL)) {
1723 Fprintf(stderr, "Selected label is not a pin\n");
1724 return TCL_ERROR;
1725 }
1726 }
1727 else if (stype == POLYGON) {
1728 polyptr npoly = SELTOPOLY(newselect);
1729 refptptr = npoly->points;
1730 if (nonnetwork(npoly)) {
1731 Fprintf(stderr, "Selected polygon is not a wire\n");
1732 return TCL_ERROR;
1733 }
1734 }
1735 else if (stype == OBJINST) {
1736 objinstptr ninst = SELTOOBJINST(newselect);
1737 char *devptr;
1738
1739 for (calls = topobject->calls; calls != NULL; calls = calls->next)
1740 if (calls->callinst == ninst)
1741 break;
1742 if (calls == NULL) {
1743 Fprintf(stderr, "Selected instance is not a circuit component\n");
1744 return TCL_ERROR;
1745 }
1746 else if (calls->devindex == -1) {
1747 cleartraversed(topobject);
1748 resolve_indices(topobject, FALSE);
1749 }
1750 push_stack(&areawin->stack, ninst, NULL);
1751 prefix = GetHierarchy(&areawin->stack, canon);
1752 pop_stack(&areawin->stack);
1753 if (prefix == NULL) break;
1754 devptr = prefix;
1755 if (!hier) {
1756 devptr = strrchr(prefix, '/');
1757 if (devptr == NULL)
1758 devptr = prefix;
1759 else
1760 devptr++;
1761 }
1762 Tcl_SetResult(interp, devptr, TCL_VOLATILE);
1763 free(prefix);
1764 break;
1765 }
1766 }
1767 }
1768 else if ((objc == 3) && (result = GetPositionFromList(interp, objv[2],
1769 &refpoint)) == TCL_OK) {
1770 /* Find net at indicated position in reference object. */
1771 /* This allows us to query points without generating a pin */
1772 /* at the position, which can alter the netlist under */
1773 /* observation. */
1774 refptptr = &refpoint;
1775 }
1776 else {
1777 /* If a name, find the pin label element matching the name */
1778 int x, y;
1779 objinstptr instofname = (areawin->hierstack) ?
1780 areawin->hierstack->thisinst :
1781 areawin->topinstance;
1782
1783 Tcl_ResetResult(interp);
1784
1785 if (NameToPinLocation(instofname, Tcl_GetString(objv[2]),
1786 &x, &y) == 0) {
1787 refpoint.x = x; /* conversion from int to short */
1788 refpoint.y = y;
1789 refptptr = &refpoint;
1790 }
1791 else {
1792 /* This is not necessarily an error. Use "-quiet" to shut it up */
1793 if (quiet) return TCL_OK;
1794 Tcl_SetResult(interp, "Cannot find position for pin ", NULL);
1795 Tcl_AppendElement(interp, Tcl_GetString(objv[2]));
1796 return TCL_ERROR;
1797 }
1798 }
1799
1800 /* Now that we have a reference point, convert it to a netlist */
1801 if (uplevel) {
1802 UTransformbyCTM(&locctm, refptptr, &refpoint, 1);
1803 refptptr = &refpoint;
1804 }
1805 netlist = pointtonet(refobject, refinstance, refptptr);
1806 if (netlist == NULL) {
1807 if (quiet) return TCL_OK;
1808 Fprintf(stderr, "Error: No network found!\n");
1809 return TCL_ERROR;
1810 }
1811
1812 /* If refobject is a secondary schematic, we need to find the */
1813 /* corresponding primary page to call nettopin(). */
1814 master = (refobject->schemtype == SECONDARY) ?
1815 refobject->symschem : refobject;
1816
1817 /* Now that we have a netlist, convert it to a name */
1818 /* Need to get prefix from the current call stack so we */
1819 /* can represent flat names as well as hierarchical names. */
1820
1821 if (hier) {
1822 int plen;
1823 prefix = GetHierarchy(&areawin->stack, canon);
1824 if (prefix) {
1825 plen = strlen(prefix);
1826 if (*(prefix + plen - 1) != '/') {
1827 prefix = realloc(prefix, plen + 2);
1828 strcat(prefix, "/");
1829 }
1830 }
1831 }
1832
1833 if (netlist->subnets == 0) {
1834 netid = netlist->net.id;
1835 ppin = nettopin(netid, master, (prefix == NULL) ? "" : prefix);
1836 snew = textprint(ppin, refinstance);
1837 Tcl_SetResult(interp, snew, TCL_DYNAMIC);
1838 }
1839 else if (netlist->subnets == 1) {
1840
1841 /* Need to get prefix from the current call stack! */
1842 sbus = netlist->net.list;
1843 netid = sbus->netid;
1844 ppin = nettopin(netid, master, (prefix == NULL) ? "" : prefix);
1845 snew = textprintsubnet(ppin, refinstance, sbus->subnetid);
1846 Tcl_SetResult(interp, snew, TCL_DYNAMIC);
1847 }
1848 else {
1849 tlist = Tcl_NewListObj(0, NULL);
1850 for (lbus = 0; lbus < netlist->subnets; lbus++) {
1851 sbus = netlist->net.list + lbus;
1852 netid = sbus->netid;
1853 ppin = nettopin(netid, master, (prefix == NULL) ? "" : prefix);
1854 snew = textprintsubnet(ppin, refinstance, sbus->subnetid);
1855 Tcl_ListObjAppendElement(interp, tlist, Tcl_NewStringObj(snew, -1));
1856 Tcl_SetObjResult(interp, tlist);
1857 free(snew);
1858 }
1859 }
1860 if (prefix != NULL) free(prefix);
1861 } break;
1862
1863 case ParseIdx: { /* generate output from info labels */
1864 char *mode, *snew;
1865 objectptr cfrom;
1866
1867 if (objc != 3) {
1868 Tcl_WrongNumArgs(interp, 1, objv, "parse <mode>");
1869 return TCL_ERROR;
1870 }
1871 mode = Tcl_GetString(objv[2]);
1872 master = topobject;
1873 if ((master->schemtype == SECONDARY) && (master->symschem != NULL))
1874 master = master->symschem;
1875
1876 if (master->schemtype != PRIMARY && areawin->stack != NULL) {
1877 cfrom = areawin->stack->thisinst->thisobject;
1878 snew = parseinfo(cfrom, master, cfrom->calls, NULL, mode, FALSE, TRUE);
1879 }
1880 else {
1881 Calllist loccalls;
1882
1883 loccalls.cschem = NULL;
1884 loccalls.callobj = master;
1885 loccalls.callinst = areawin->topinstance;
1886 loccalls.devindex = -1;
1887 loccalls.ports = NULL;
1888 loccalls.next = NULL;
1889
1890 snew = parseinfo(NULL, master, &loccalls, NULL, mode, FALSE, TRUE);
1891 }
1892 Tcl_SetResult(interp, snew, TCL_DYNAMIC);
1893
1894 } break;
1895
1896 case UnConnectIdx: /* disassociate the page with another one */
1897 if ((objc != 2) && (objc != 3)) {
1898 Tcl_WrongNumArgs(interp, 1, objv, "unconnect [<secondary>]");
1899 return TCL_ERROR;
1900 }
1901 else if (objc == 3) {
1902 result = Tcl_GetIntFromObj(interp, objv[2], &spage);
1903 if (result != TCL_OK) {
1904 Tcl_ResetResult(interp);
1905 slave = NameToPageObject(Tcl_GetString(objv[2]), NULL, &spage);
1906 }
1907 else {
1908 if (spage >= xobjs.pages) {
1909 Tcl_SetResult(interp, "Bad page number for secondary schematic", NULL);
1910 return TCL_ERROR;
1911 }
1912 slave = xobjs.pagelist[spage]->pageinst->thisobject;
1913 }
1914 if ((slave == NULL) || (is_page(slave) < 0)) {
1915 Tcl_SetResult(interp, "Error determining secondary schematic", NULL);
1916 return TCL_ERROR;
1917 }
1918 }
1919 else {
1920 slave = topobject;
1921 spage = areawin->page;
1922 }
1923 if (slave->symschem == NULL || slave->symschem->schemtype !=
1924 PRIMARY) {
1925 Tcl_SetResult(interp, "Page is not a secondary schematic", NULL);
1926 return TCL_ERROR;
1927 }
1928
1929 destroynets(slave->symschem);
1930 slave->schemtype = PRIMARY;
1931 slave->symschem = NULL;
1932 break;
1933
1934 case ConnectIdx: /* associate the page with another one */
1935 if ((objc != 3) && (objc != 4)) {
1936 Tcl_WrongNumArgs(interp, 1, objv, "connect <primary> [<secondary>]");
1937 return TCL_ERROR;
1938 }
1939 else if (objc == 4) {
1940 result = Tcl_GetIntFromObj(interp, objv[3], &spage);
1941 if (result != TCL_OK) {
1942 Tcl_ResetResult(interp);
1943 slave = NameToPageObject(Tcl_GetString(objv[3]), NULL, &spage);
1944 }
1945 else {
1946 if (spage >= xobjs.pages) {
1947 Tcl_SetResult(interp, "Bad page number for secondary schematic", NULL);
1948 return TCL_ERROR;
1949 }
1950 slave = xobjs.pagelist[spage]->pageinst->thisobject;
1951 }
1952 if ((slave == NULL) || (is_page(slave) < 0)) {
1953 Tcl_SetResult(interp, "Error determining secondary schematic", NULL);
1954 return TCL_ERROR;
1955 }
1956 }
1957 else {
1958 slave = topobject;
1959 spage = areawin->page;
1960 destroynets(slave);
1961 }
1962
1963 result = Tcl_GetIntFromObj(interp, objv[2], &mpage);
1964 if (result != TCL_OK) {
1965 Tcl_ResetResult(interp);
1966 master = NameToPageObject(Tcl_GetString(objv[2]), NULL, &mpage);
1967 }
1968 else
1969 mpage--;
1970
1971 if ((mpage >= xobjs.pages) || (xobjs.pagelist[mpage]->pageinst == NULL)) {
1972 Tcl_SetResult(interp, "Bad page number for master schematic", NULL);
1973 return TCL_ERROR;
1974 }
1975 else if (mpage == areawin->page) {
1976 Tcl_SetResult(interp, "Attempt to specify schematic "
1977 "as its own master", NULL);
1978 return TCL_ERROR;
1979 }
1980 if (xobjs.pagelist[mpage]->pageinst->thisobject->symschem == slave) {
1981 Tcl_SetResult(interp, "Attempt to create recursive "
1982 "primary/secondary schematic relationship", NULL);
1983 return TCL_ERROR;
1984 }
1985 master = xobjs.pagelist[mpage]->pageinst->thisobject;
1986 destroynets(master);
1987
1988 if ((master == NULL) || (is_page(master) < 0)) {
1989 Tcl_SetResult(interp, "Error determining master schematic", NULL);
1990 return TCL_ERROR;
1991 }
1992
1993 slave->schemtype = SECONDARY;
1994 slave->symschem = master;
1995 break;
1996
1997 case UnHighLightIdx: /* remove network connectivity highlight */
1998 if (objc == 2) {
1999 highlightnetlist(topobject, areawin->topinstance, 0);
2000 }
2001 else {
2002 Tcl_WrongNumArgs(interp, 1, objv, "(no options)");
2003 return TCL_ERROR;
2004 }
2005 break;
2006
2007 case HighLightIdx: /* highlight network connectivity */
2008 if (objc == 2) {
2009 startconnect(NULL, NULL, NULL);
2010 break;
2011 }
2012 /* drop through */
2013 case PositionIdx:
2014 case SelectIdx: /* select the first element in the indicated net */
2015 {
2016 int netid, lbus, i;
2017 XPoint newpos, *netpos;
2018 char *tname;
2019 Genericlist *lnets, *netlist;
2020 buslist *sbus;
2021 LabellistPtr llist;
2022 PolylistPtr plist;
2023 short *newselect;
2024
2025 if (objc < 3) {
2026 Tcl_WrongNumArgs(interp, 1, objv, "network");
2027 return TCL_ERROR;
2028 }
2029
2030 result = GetPositionFromList(interp, objv[2], &newpos);
2031 if (result == TCL_OK) { /* find net at indicated position */
2032 areawin->save = newpos;
2033 connectivity(NULL, NULL, NULL);
2034 /* should there be any result here? */
2035 break;
2036 }
2037 else { /* assume objv[2] is net name */
2038 Tcl_ResetResult(interp);
2039 tname = Tcl_GetString(objv[2]);
2040 lnets = nametonet(topobject, areawin->topinstance, tname);
2041 if (lnets == NULL) {
2042 Tcl_SetResult(interp, "No such network ", NULL);
2043 Tcl_AppendElement(interp, tname);
2044 break;
2045 }
2046 switch (idx) {
2047 case HighLightIdx:
2048 netlist = (Genericlist *)malloc(sizeof(Genericlist));
2049
2050 /* Erase any existing highlights first */
2051 highlightnetlist(topobject, areawin->topinstance, 0);
2052 netlist->subnets = 0;
2053 copy_bus(netlist, lnets);
2054 topobject->highlight.netlist = netlist;
2055 topobject->highlight.thisinst = areawin->topinstance;
2056 highlightnetlist(topobject, areawin->topinstance, 1);
2057 if (netlist->subnets == 0) {
2058 netid = netlist->net.id;
2059 Tcl_SetObjResult(interp, Tcl_NewIntObj(netlist->net.id));
2060 }
2061 else {
2062 rdict = Tcl_NewListObj(0, NULL);
2063 for (lbus = 0; lbus < netlist->subnets; lbus++) {
2064 sbus = netlist->net.list + lbus;
2065 netid = sbus->netid;
2066 Tcl_ListObjAppendElement(interp, rdict, Tcl_NewIntObj(netid));
2067 }
2068 Tcl_SetObjResult(interp, rdict);
2069 }
2070 break;
2071
2072 /* Return a position belonging to the net. If this is a bus, */
2073 /* we return the position of the 1st subnet. At some point, */
2074 /* this should be expanded to return a point per subnet. */
2075
2076 case PositionIdx:
2077 if (lnets->subnets == 0)
2078 netid = lnets->net.id;
2079 else
2080 netid = (lnets->net.list)->netid;
2081
2082 netpos = NetToPosition(lnets->net.id, topobject);
2083 rdict = Tcl_NewListObj(0, NULL);
2084 Tcl_ListObjAppendElement(interp, rdict, Tcl_NewIntObj(netpos->x));
2085 Tcl_ListObjAppendElement(interp, rdict, Tcl_NewIntObj(netpos->y));
2086 Tcl_SetObjResult(interp, rdict);
2087 break;
2088
2089 /* Select everything in the network. To-do: allow specific */
2090 /* selection of labels, wires, or a single element in the net */
2091
2092 case SelectIdx:
2093 unselect_all();
2094 rdict = Tcl_NewListObj(0, NULL);
2095 for (llist = topobject->labels; llist != NULL;
2096 llist = llist->next) {
2097 if (match_buses((Genericlist *)llist, (Genericlist *)lnets, 0)) {
2098 i = GetPartNumber((genericptr)llist->label, topobject, LABEL);
2099 if (i >= 0) {
2100 newselect = allocselect();
2101 *newselect = i;
2102 Tcl_ListObjAppendElement(interp, rdict,
2103 Tcl_NewHandleObj((genericptr)llist->label));
2104 }
2105 }
2106 }
2107 for (plist = topobject->polygons; plist != NULL;
2108 plist = plist->next) {
2109 if (match_buses((Genericlist *)plist, (Genericlist *)lnets, 0)) {
2110 i = GetPartNumber((genericptr)plist->poly, topobject, POLYGON);
2111 if (i >= 0) {
2112 newselect = allocselect();
2113 *newselect = i;
2114 Tcl_ListObjAppendElement(interp, rdict,
2115 Tcl_NewHandleObj((genericptr)plist->poly));
2116 }
2117 }
2118 }
2119 Tcl_SetObjResult(interp, rdict);
2120 refresh(NULL, NULL, NULL);
2121 break;
2122 }
2123 }
2124 } break;
2125
2126 case UpdateIdx: /* destroy and regenerate the current netlist */
2127 destroynets(areawin->topinstance->thisobject);
2128 if ((result = updatenets(areawin->topinstance, quiet)) < 0) {
2129 Tcl_SetResult(interp, "Check circuit for infinite recursion.", NULL);
2130 return TCL_ERROR;
2131 }
2132 else if (result == 0) {
2133 Tcl_SetResult(interp, "Failure to generate a network.", NULL);
2134 return TCL_ERROR;
2135 }
2136 break;
2137
2138 case MakeIdx: /* generate Tcl-list netlist */
2139 rdict = Tcl_NewListObj(0, NULL);
2140 Tcl_ListObjAppendElement(interp, rdict, Tcl_NewStringObj("globals", 7));
2141 Tcl_ListObjAppendElement(interp, rdict, tclglobals(areawin->topinstance));
2142 Tcl_ListObjAppendElement(interp, rdict, Tcl_NewStringObj("circuit", 7));
2143 Tcl_ListObjAppendElement(interp, rdict, tcltoplevel(areawin->topinstance));
2144
2145 Tcl_SetObjResult(interp, rdict);
2146 break;
2147
2148 case AutoNumberIdx: /* auto-number circuit components */
2149 if (checkvalid(topobject) == -1) {
2150 destroynets(topobject);
2151 createnets(areawin->topinstance, FALSE);
2152 }
2153 else {
2154 cleartraversed(topobject);
2155 clear_indices(topobject);
2156 }
2157 if ((objc == 3) && !strcmp(Tcl_GetString(objv[2]), "-forget")) {
2158 cleartraversed(topobject);
2159 unnumber(topobject);
2160 }
2161 else {
2162 cleartraversed(topobject);
2163 resolve_indices(topobject, FALSE); /* Do fixed assignments first */
2164 cleartraversed(topobject);
2165 resolve_indices(topobject, TRUE); /* Now do the auto-numbering */
2166 }
2167 break;
2168
2169 case RatsNestIdx:
2170 /* Experimental netlist stuff! */
2171 ratsnest(areawin->topinstance);
2172 break;
2173 }
2174 return XcTagCallback(interp, objc, objv);
2175 }
2176
2177 /*----------------------------------------------------------------------*/
2178 /* Return current position */
2179 /*----------------------------------------------------------------------*/
2180
2181 int xctcl_here(ClientData clientData, Tcl_Interp *interp,
2182 int objc, Tcl_Obj *CONST objv[])
2183 {
2184 Tcl_Obj *listPtr, *objPtr;
2185 XPoint newpos;
2186
2187 if (objc != 1) {
2188 Tcl_WrongNumArgs(interp, 0, objv, "(no arguments)");
2189 return TCL_ERROR;
2190 }
2191 newpos = UGetCursorPos();
2192
2193 listPtr = Tcl_NewListObj(0, NULL);
2194 objPtr = Tcl_NewIntObj((int)newpos.x);
2195 Tcl_ListObjAppendElement(interp, listPtr, objPtr);
2196
2197 objPtr = Tcl_NewIntObj((int)newpos.y);
2198 Tcl_ListObjAppendElement(interp, listPtr, objPtr);
2199
2200 Tcl_SetObjResult(interp, listPtr);
2201
2202 return XcTagCallback(interp, objc, objv);
2203 }
2204
2205
2206 /*----------------------------------------------------------------------*/
2207 /* Argument-converting wrappers from Tcl command callback to xcircuit */
2208 /*----------------------------------------------------------------------*/
2209
2210 int xctcl_pan(ClientData clientData, Tcl_Interp *interp,
2211 int objc, Tcl_Obj *CONST objv[])
2212 {
2213 int result, idx;
2214 double frac = 0.0;
2215 XPoint newpos, wpoint;
2216 static char *directions[] = {"here", "left", "right", "up", "down",
2217 "center", "follow", NULL};
2218 enum DirIdx {
2219 DirHere, DirLeft, DirRight, DirUp, DirDown, DirCenter, DirFollow
2220 };
2221
2222 if (objc != 2 && objc != 3) {
2223 Tcl_WrongNumArgs(interp, 0, objv, "option ?arg ...?");
2224 return TCL_ERROR;
2225 }
2226
2227 /* Check against keywords */
2228
2229 if (Tcl_GetIndexFromObj(interp, objv[1], (CONST84 char **)directions,
2230 "option", 0, &idx) != TCL_OK) {
2231 result = GetPositionFromList(interp, objv[1], &newpos);
2232 if (result != TCL_OK) return result;
2233 idx = 5;
2234 }
2235 else
2236 newpos = UGetCursorPos();
2237
2238 user_to_window(newpos, &wpoint);
2239
2240 switch(idx) {
2241 case DirHere:
2242 case DirCenter:
2243 case DirFollow:
2244 if (objc != 2) {
2245 Tcl_WrongNumArgs(interp, 0, objv, "(no arguments)");
2246 }
2247 break;
2248 default:
2249 if (objc == 2) frac = 0.3;
2250 else
2251 Tcl_GetDoubleFromObj(interp, objv[2], &frac);
2252 }
2253
2254 panbutton((u_int)idx, wpoint.x, wpoint.y, (float)frac);
2255 return XcTagCallback(interp, objc, objv);
2256 }
2257
2258 /*----------------------------------------------------------------------*/
2259
2260 int xctcl_zoom(ClientData clientData, Tcl_Interp *interp,
2261 int objc, Tcl_Obj *CONST objv[])
2262 {
2263 int result, idx;
2264 float save;
2265 double factor;
2266 XPoint newpos, wpoint;
2267
2268 static char *subCmds[] = {"in", "out", "view", "factor", NULL};
2269 enum SubIdx {
2270 InIdx, OutIdx, ViewIdx, FactorIdx
2271 };
2272
2273 newpos = UGetCursorPos();
2274 user_to_window(newpos, &wpoint);
2275
2276 if (objc == 1)
2277 zoomview(NULL, NULL, NULL);
2278 else if ((result = Tcl_GetDoubleFromObj(interp, objv[1], &factor)) != TCL_OK)
2279 {
2280 Tcl_ResetResult(interp);
2281 if (Tcl_GetIndexFromObj(interp, objv[1], (CONST84 char **)subCmds,
2282 "option", 0, &idx) != TCL_OK) {
2283 Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
2284 return TCL_ERROR;
2285 }
2286 switch(idx) {
2287 case InIdx:
2288 zoominrefresh(wpoint.x, wpoint.y);
2289 break;
2290 case OutIdx:
2291 zoomoutrefresh(wpoint.x, wpoint.y);
2292 break;
2293 case ViewIdx:
2294 zoomview(NULL, NULL, NULL);
2295 break;
2296 case FactorIdx:
2297 if (objc == 2) {
2298 Tcl_Obj *objPtr = Tcl_NewDoubleObj((double)areawin->zoomfactor);
2299 Tcl_SetObjResult(interp, objPtr);
2300 break;
2301 }
2302 else if (objc != 3) {
2303 Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
2304 return TCL_ERROR;
2305 }
2306 if (!strcmp(Tcl_GetString(objv[2]), "default"))
2307 factor = SCALEFAC;
2308 else {
2309 result = Tcl_GetDoubleFromObj(interp, objv[2], &factor);
2310 if (result != TCL_OK) return result;
2311 if (factor <= 0) {
2312 Tcl_SetResult(interp, "Negative/Zero zoom factors not allowed.",
2313 NULL);
2314 return TCL_ERROR;
2315 }
2316 if (factor < 1.0) factor = 1.0 / factor;
2317 }
2318 if ((float)factor == areawin->zoomfactor) break;
2319 Wprintf("Zoom factor changed from %2.1f to %2.1f",
2320 areawin->zoomfactor, (float)factor);
2321 areawin->zoomfactor = (float) factor;
2322 break;
2323 }
2324 }
2325 else {
2326 save = areawin->zoomfactor;
2327
2328 if (factor < 1.0) {
2329 areawin->zoomfactor = (float)(1.0 / factor);
2330 zoomout(wpoint.x, wpoint.y);
2331 }
2332 else {
2333 areawin->zoomfactor = (float)factor;
2334 zoomin(wpoint.x, wpoint.y);
2335 }
2336 refresh(NULL, NULL, NULL);
2337 areawin->zoomfactor = save;
2338 }
2339 return XcTagCallback(interp, objc, objv);
2340 }
2341
2342 /*----------------------------------------------------------------------*/
2343 /* Get a color, either by name or by integer index. */
2344 /* If "append" is TRUE, then if the color is not in the existing list */
2345 /* of colors, it will be added to the list. */
2346 /*----------------------------------------------------------------------*/
2347
2348 int GetColorFromObj(Tcl_Interp *interp, Tcl_Obj *obj, int *cindex, Boolean append)
2349 {
2350 char *cname;
2351 int result;
2352
2353 if (cindex == NULL) return TCL_ERROR;
2354
2355 cname = Tcl_GetString(obj);
2356 if (!strcmp(cname, "inherit")) {
2357 *cindex = DEFAULTCOLOR;
2358 }
2359 else {
2360 result = Tcl_GetIntFromObj(interp, obj, cindex);
2361 if (result != TCL_OK) {
2362 Tcl_ResetResult(interp);
2363 *cindex = query_named_color(cname);
2364 if (*cindex == BADCOLOR) {
2365 *cindex = ERRORCOLOR;
2366 Tcl_SetResult(interp, "Unknown color name ", NULL);
2367 Tcl_AppendElement(interp, cname);
2368 return TCL_ERROR;
2369 }
2370 else if (*cindex == ERRORCOLOR) {
2371 if (append)
2372 *cindex = addnewcolorentry(xc_alloccolor(cname));
2373 else {
2374 Tcl_SetResult(interp, "Color ", NULL);
2375 Tcl_AppendElement(interp, cname);
2376 Tcl_AppendElement(interp, "is not in the color table.");
2377 return TCL_ERROR;
2378 }
2379 }
2380 return TCL_OK;
2381 }
2382
2383 if ((*cindex >= number_colors) || (*cindex < DEFAULTCOLOR)) {
2384 Tcl_SetResult(interp, "Color index out of range", NULL);
2385 return TCL_ERROR;
2386 }
2387 }
2388 return TCL_OK;
2389 }
2390
2391 /*----------------------------------------------------------------------*/
2392
2393 int xctcl_color(ClientData clientData, Tcl_Interp *interp,
2394 int objc, Tcl_Obj *CONST objv[])
2395 {
2396 int result, nidx, cindex, ccol, idx, i;
2397 char *colorname, *option;
2398
2399 static char *subCmds[] = {"set", "index", "value", "get", "add",
2400 "override", NULL};
2401 enum SubIdx { SetIdx, IndexIdx, ValueIdx, GetIdx, AddIdx, OverrideIdx };
2402
2403 nidx = 2;
2404 result = ParseElementArguments(interp, objc, objv, &nidx, ALL_TYPES);
2405 if (result != TCL_OK) return result;
2406
2407 if ((result = Tcl_GetIndexFromObj(interp, objv[nidx],
2408 (CONST84 char **)subCmds, "option", 0,
2409 &idx)) != TCL_OK)
2410 return result;
2411
2412 switch (idx) {
2413 case SetIdx:
2414 if ((objc - nidx) == 2) {
2415 result = GetColorFromObj(interp, objv[nidx + 1], &cindex, TRUE);
2416 if (result != TCL_OK) return result;
2417 setcolor((Tk_Window)clientData, cindex);
2418 /* Tag callback performed by setcolormarks() via setcolor() */
2419 return TCL_OK;
2420 }
2421 else {
2422 Tcl_WrongNumArgs(interp, 1, objv, "set <color> | inherit");
2423 return TCL_ERROR;
2424 }
2425 break;
2426
2427 case IndexIdx:
2428 /* Return the index of the color. For use with parameterized color */
2429 if ((objc - nidx) == 2) {
2430 result = GetColorFromObj(interp, objv[nidx + 1], &cindex, TRUE);
2431 if (result != TCL_OK) return result;
2432 Tcl_SetObjResult(interp, Tcl_NewIntObj(cindex));
2433 return TCL_OK;
2434 }
2435 else {
2436 Tcl_WrongNumArgs(interp, 1, objv, "index <color> | inherit");
2437 return TCL_ERROR;
2438 }
2439 break;
2440
2441 case ValueIdx:
2442 /* Return the value of the color as an {R G B} list */
2443 if ((objc - nidx) == 2) {
2444 result = GetColorFromObj(interp, objv[nidx + 1], &cindex, TRUE);
2445 if (result != TCL_OK) return result;
2446 else if (cindex < 0 || cindex >= number_colors) {
2447 Tcl_SetResult(interp, "Color index out of range", NULL);
2448 return TCL_ERROR;
2449 }
2450 Tcl_SetObjResult(interp, TclIndexToRGB(cindex));
2451 return TCL_OK;
2452 }
2453 else {
2454 Tcl_WrongNumArgs(interp, 1, objv, "value <color>");
2455 return TCL_ERROR;
2456 }
2457 break;
2458
2459 case GetIdx:
2460 /* Check for "-all" switch */
2461 if ((objc - nidx) == 2) {
2462 option = Tcl_GetString(objv[nidx + 1]);
2463 if (!strncmp(option, "-all", 4)) {
2464 for (i = NUMBER_OF_COLORS; i < number_colors; i++) {
2465 char colorstr[14];
2466 sprintf(colorstr, "#%04x%04x%04x",
2467 colorlist[i].color.red,
2468 colorlist[i].color.green,
2469 colorlist[i].color.blue);
2470 Tcl_AppendElement(interp, colorstr);
2471 }
2472 }
2473 else {
2474 Tcl_WrongNumArgs(interp, 1, objv, "get [-all]");
2475 return TCL_ERROR;
2476 }
2477 break;
2478 }
2479
2480 if (areawin->selects > 0) { /* operation on element */
2481 genericptr genobj = SELTOGENERIC(areawin->selectlist);
2482 ccol = (int)genobj->color;
2483 }
2484 else /* global setting */
2485 ccol = areawin->color;
2486
2487 /* Find and return the index of the color */
2488 if (ccol == DEFAULTCOLOR)
2489 Tcl_SetObjResult(interp, Tcl_NewStringObj("inherit", 7));
2490 else {
2491 for (i = NUMBER_OF_COLORS; i < number_colors; i++)
2492 if (colorlist[i].color.pixel == ccol)
2493 break;
2494 Tcl_SetObjResult(interp, Tcl_NewIntObj(i));
2495 }
2496 break;
2497
2498 case AddIdx:
2499 if ((objc - nidx) == 2) {
2500 colorname = Tcl_GetString(objv[nidx + 1]);
2501 if (strlen(colorname) == 0) return TCL_ERROR;
2502 cindex = addnewcolorentry(xc_alloccolor(colorname));
2503 Tcl_SetObjResult(interp, Tcl_NewIntObj(cindex));
2504 }
2505 else {
2506 Tcl_WrongNumArgs(interp, 1, objv, "add <color_name>");
2507 return TCL_ERROR;
2508 }
2509 break;
2510
2511 case OverrideIdx:
2512 flags |= COLOROVERRIDE;
2513 return TCL_OK; /* no tag callback */
2514 break;
2515 }
2516 return XcTagCallback(interp, objc, objv);
2517 }
2518
2519 /*----------------------------------------------------------------------*/
2520
2521 int xctcl_delete(ClientData clientData, Tcl_Interp *interp,
2522 int objc, Tcl_Obj *CONST objv[])
2523 {
2524 int result = ParseElementArguments(interp, objc, objv, NULL, ALL_TYPES);
2525
2526 if (result != TCL_OK) return result;
2527
2528 /* delete element (call library delete if in catalog) */
2529 if (areawin->selects > 0) {
2530 if (eventmode == CATALOG_MODE)
2531 catdelete();
2532 else
2533 deletebutton(0, 0); /* Note: arguments are not used */
2534 }
2535
2536 return XcTagCallback(interp, objc, objv);
2537 }
2538
2539 /*----------------------------------------------------------------------*/
2540 /* Note that when using "undo series", it is the responsibility of the */
2541 /* caller to make sure that every "start" is matched by an "end". */
2542 /*----------------------------------------------------------------------*/
2543
2544 int xctcl_undo(ClientData clientData, Tcl_Interp *interp,
2545 int objc, Tcl_Obj *CONST objv[])
2546 {
2547 if ((objc == 3) && !strcmp(Tcl_GetString(objv[1]), "series")) {
2548
2549 if (!strcmp(Tcl_GetString(objv[2]), "start")) {
2550 if (undo_collect < 255) undo_collect++;
2551 }
2552 else if (!strcmp(Tcl_GetString(objv[2]), "end")) {
2553 if (undo_collect > 0) undo_collect--;
2554 undo_finish_series();
2555 }
2556 else if (!strcmp(Tcl_GetString(objv[2]), "cancel")) {
2557 undo_collect = (u_char)0;
2558 undo_finish_series();
2559 }
2560 else {
2561 Tcl_SetResult(interp, "Usage: undo series <start|end|cancel>", NULL);
2562 return TCL_ERROR;
2563 }
2564 }
2565 else if (objc == 1) {
2566 undo_action();
2567 }
2568 else {
2569 Tcl_WrongNumArgs(interp, 1, objv, "[series <start|end>");
2570 return TCL_ERROR;
2571 }
2572 return XcTagCallback(interp, objc, objv);
2573 }
2574
2575 /*----------------------------------------------------------------------*/
2576
2577 int xctcl_redo(ClientData clientData, Tcl_Interp *interp,
2578 int objc, Tcl_Obj *CONST objv[])
2579 {
2580 if (objc != 1) {
2581 Tcl_WrongNumArgs(interp, 1, objv, "(no arguments)");
2582 return TCL_ERROR;
2583 }
2584 redo_action();
2585 return XcTagCallback(interp, objc, objv);
2586 }
2587
2588 /*----------------------------------------------------------------------*/
2589
2590 int xctcl_move(ClientData clientData, Tcl_Interp *interp,
2591 int objc, Tcl_Obj *CONST objv[])
2592 {
2593 XPoint position;
2594 int nidx = 3;
2595 int result = ParseElementArguments(interp, objc, objv, &nidx, ALL_TYPES);
2596
2597 if (result != TCL_OK) return result;
2598
2599 if (areawin->selects == 0) {
2600 Tcl_SetResult(interp, "Error in move setup: nothing selected.", NULL);
2601 return TCL_ERROR;
2602 }
2603
2604 if ((objc - nidx) == 0) {
2605 eventmode = MOVE_MODE;
2606 u2u_snap(&areawin->save);
2607 Tk_CreateEventHandler(areawin->area, PointerMotionMask,
2608 (Tk_EventProc *)xctk_drag, NULL);
2609 }
2610 else if ((objc - nidx) >= 1) {
2611 if ((objc - nidx) == 2) {
2612 if (!strcmp(Tcl_GetString(objv[nidx]), "relative")) {
2613 if ((result = GetPositionFromList(interp, objv[nidx + 1],
2614 &position)) != TCL_OK) {
2615 Tcl_SetResult(interp, "Position must be {x y} list", NULL);
2616 return TCL_ERROR;
2617 }
2618 }
2619 else {
2620 Tcl_WrongNumArgs(interp, 1, objv, "relative {x y}");
2621 return TCL_ERROR;
2622 }
2623 }
2624 else {
2625 if ((result = GetPositionFromList(interp, objv[nidx],
2626 &position)) != TCL_OK) {
2627 Tcl_SetResult(interp, "Position must be {x y} list", NULL);
2628 return TCL_ERROR;
2629 }
2630 position.x -= areawin->save.x;
2631 position.y -= areawin->save.y;
2632 }
2633 placeselects(position.x, position.y, NULL);
2634 }
2635 else {
2636 Tcl_WrongNumArgs(interp, 1, objv, "[relative] {x y}");
2637 return TCL_ERROR;
2638 }
2639 return XcTagCallback(interp, objc, objv);
2640 }
2641
2642 /*----------------------------------------------------------------------*/
2643
2644 int xctcl_copy(ClientData clientData, Tcl_Interp *interp,
2645 int objc, Tcl_Obj *CONST objv[])
2646 {
2647 XPoint position;
2648 Tcl_Obj *listPtr;
2649 int nidx = 3;
2650 int result = ParseElementArguments(interp, objc, objv, &nidx, ALL_TYPES);
2651
2652 if (result != TCL_OK) return result;
2653
2654 if ((objc - nidx) == 0) {
2655 if (areawin->selects > 0) {
2656 createcopies();
2657 copydrag();
2658 }
2659 }
2660 else if ((objc - nidx) >= 1) {
2661 if (areawin->selects == 0) {
2662 Tcl_SetResult(interp, "Error in copy: nothing selected.", NULL);
2663 return TCL_ERROR;
2664 }
2665 if ((objc - nidx) == 2) {
2666 if (!strcmp(Tcl_GetString(objv[nidx]), "relative")) {
2667 if ((result = GetPositionFromList(interp, objv[nidx + 1],
2668 &position)) != TCL_OK) {
2669 Tcl_SetResult(interp, "Position must be {x y} list", NULL);
2670 return TCL_ERROR;
2671 }
2672 }
2673 else {
2674 Tcl_WrongNumArgs(interp, 1, objv, "relative {x y}");
2675 return TCL_ERROR;
2676 }
2677 }
2678 else {
2679 if ((result = GetPositionFromList(interp, objv[nidx],
2680 &position)) != TCL_OK) {
2681 Tcl_SetResult(interp, "Position must be {x y} list", NULL);
2682 return TCL_ERROR;
2683 }
2684 position.x -= areawin->save.x;
2685 position.y -= areawin->save.y;
2686 }
2687 createcopies();
2688
2689 listPtr = SelectToTclList(interp, areawin->selectlist, areawin->selects);
2690 Tcl_SetObjResult(interp, listPtr);
2691
2692 placeselects(position.x, position.y, NULL);
2693 }
2694 else {
2695 Tcl_WrongNumArgs(interp, 1, objv, "[relative] {x y}");
2696 return TCL_ERROR;
2697 }
2698 return XcTagCallback(interp, objc, objv);
2699 }
2700
2701 /*----------------------------------------------------------------------*/
2702
2703 int xctcl_flip(ClientData clientData, Tcl_Interp *interp,
2704 int objc, Tcl_Obj *CONST objv[])
2705 {
2706 char *teststr;
2707 int nidx = 2;
2708 int result = ParseElementArguments(interp, objc, objv, &nidx, ALL_TYPES);
2709 XPoint position;
2710
2711 if (result != TCL_OK) return result;
2712
2713 if ((objc - nidx) == 2) {
2714 if ((result = GetPositionFromList(interp, objv[nidx + 1],
2715 &position)) != TCL_OK)
2716 return result;
2717 }
2718 else if ((objc - nidx) == 1) {
2719 if (areawin->selects > 1)
2720 position = UGetCursorPos();
2721 }
2722 else {
2723 Tcl_WrongNumArgs(interp, 1, objv, "horizontal|vertical [<center>]");
2724 return TCL_ERROR;
2725 }
2726
2727 teststr = Tcl_GetString(objv[nidx]);
2728
2729 switch(teststr[0]) {
2730 case 'h': case 'H':
2731 elementflip(&position);
2732 break;
2733 case 'v': case 'V':
2734 elementvflip(&position);
2735 break;
2736 default:
2737 Tcl_SetResult(interp, "Error: options are horizontal or vertical", NULL);
2738 return TCL_ERROR;
2739 }
2740 return XcTagCallback(interp, objc, objv);
2741 }
2742
2743 /*----------------------------------------------------------------------*/
2744
2745 int xctcl_rotate(ClientData clientData, Tcl_Interp *interp,
2746 int objc, Tcl_Obj *CONST objv[])
2747 {
2748 int rval, nidx = 2;
2749 int result = ParseElementArguments(interp, objc, objv, &nidx, ALL_TYPES);
2750 XPoint position;
2751
2752 if (result != TCL_OK) return result;
2753
2754 /* No options --- return the rotation value(s) */
2755 if ((objc - nidx) == 0) {
2756 int i, numfound = 0;
2757 Tcl_Obj *listPtr, *objPtr;
2758 for (i = 0; i < areawin->selects; i++) {
2759 objPtr = NULL;
2760 if (SELECTTYPE(areawin->selectlist + i) == OBJINST) {
2761 objinstptr pinst = SELTOOBJINST(areawin->selectlist + i);
2762 objPtr = Tcl_NewDoubleObj((double)(pinst->rotation));
2763 }
2764 else if (SELECTTYPE(areawin->selectlist + i) == LABEL) {
2765 labelptr plab = SELTOLABEL(areawin->selectlist + i);
2766 objPtr = Tcl_NewDoubleObj((double)(plab->rotation));
2767 }
2768 else if (SELECTTYPE(areawin->selectlist + i) == GRAPHIC) {
2769 graphicptr gp = SELTOGRAPHIC(areawin->selectlist + i);
2770 objPtr = Tcl_NewDoubleObj((double)(gp->rotation));
2771 }
2772 if (objPtr != NULL) {
2773 if (numfound > 0)
2774 Tcl_ListObjAppendElement(interp, listPtr, objPtr);
2775 if ((++numfound) == 1)
2776 listPtr = objPtr;
2777 }
2778 }
2779 switch (numfound) {
2780 case 0:
2781 Tcl_SetResult(interp, "Error: no object instances, graphic "
2782 "images, or labels selected", NULL);
2783 return TCL_ERROR;
2784 break;
2785 case 1:
2786 Tcl_SetObjResult(interp, objPtr);
2787 break;
2788 default:
2789 Tcl_SetObjResult(interp, listPtr);
2790 break;
2791 }
2792 return XcTagCallback(interp, objc, objv);
2793 }
2794
2795 result = Tcl_GetIntFromObj(interp, objv[nidx], &rval);
2796 if (result != TCL_OK) return result;
2797
2798 if ((objc - nidx) == 2) {
2799 if ((result = GetPositionFromList(interp, objv[nidx + 1],
2800 &position)) != TCL_OK)
2801 return result;
2802 else {
2803 elementrotate(rval, &position);
2804 return XcTagCallback(interp, objc, objv);
2805 }
2806 }
2807 else if ((objc - nidx) == 1) {
2808 position = UGetCursorPos();
2809 elementrotate(rval, &position);
2810 return XcTagCallback(interp, objc, objv);
2811 }
2812
2813 Tcl_WrongNumArgs(interp, 1, objv, "<angle> [<center>]");
2814 return TCL_ERROR;
2815 }
2816
2817 /*----------------------------------------------------------------------*/
2818
2819 int xctcl_edit(ClientData clientData, Tcl_Interp *interp,
2820 int objc, Tcl_Obj *CONST objv[])
2821 {
2822 int result = ParseElementArguments(interp, objc, objv, NULL, ALL_TYPES);
2823
2824 if (result != TCL_OK) return result;
2825
2826 /* To be done---edit element */
2827
2828 return XcTagCallback(interp, objc, objv);
2829 }
2830
2831 /*----------------------------------------------------------------------*/
2832 /* Support procedure for xctcl_param: Given a pointer to a parameter, */
2833 /* return the value of the parameter as a pointer to a Tcl object. */
2834 /* This takes care of the fact that the parameter value can be a */
2835 /* string, integer, or float, depending on the parameter type. */
2836 /* */
2837 /* If "verbatim" is true, then expression parameters return the string */
2838 /* representation of the expression, not the result, and indirect */
2839 /* parameters return the parameter name referenced, not the value. */
2840 /* */
2841 /* refinst, if non-NULL, is the instance containing ops, used when */
2842 /* "verbatim" is true and the parameter is indirectly referenced. */
2843 /*----------------------------------------------------------------------*/
2844
2845 Tcl_Obj *GetParameterValue(objectptr refobj, oparamptr ops, Boolean verbatim,
2846 objinstptr refinst)
2847 {
2848 Tcl_Obj *robj;
2849 char *refkey;
2850
2851 if (verbatim && (refinst != NULL) &&
2852 ((refkey = find_indirect_param(refinst, ops->key)) != NULL)) {
2853 robj = Tcl_NewStringObj(refkey, strlen(refkey));
2854 return robj;
2855 }
2856
2857 switch (ops->type) {
2858 case XC_STRING:
2859 robj = TclGetStringParts(ops->parameter.string);
2860 break;
2861 case XC_EXPR:
2862 if (verbatim)
2863 robj = Tcl_NewStringObj(ops->parameter.expr,
2864 strlen(ops->parameter.expr));
2865 else
2866 robj = evaluate_raw(refobj, ops, refinst, NULL);
2867 break;
2868 case XC_INT:
2869 robj = Tcl_NewIntObj(ops->parameter.ivalue);
2870 break;
2871 case XC_FLOAT:
2872 robj = Tcl_NewDoubleObj((double)ops->parameter.fvalue);
2873 break;
2874 }
2875 return robj;
2876 }
2877
2878 /*----------------------------------------------------------------------*/
2879 /* Given a pointer to a parameter and a Tcl object, set the parameter */
2880 /* to the value of the object. Return the standard Tcl return type */
2881 /* */
2882 /* If searchinst is non-NULL, then it refers to the level above in the */
2883 /* hierarchy, and we are supposed to set an indirect reference. */
2884 /*----------------------------------------------------------------------*/
2885
2886 int SetParameterValue(Tcl_Interp *interp, oparamptr ops, Tcl_Obj *objv)
2887 {
2888 int result, ivalue;
2889 double dvalue;
2890 stringpart *strptr = NULL, *newpart;
2891
2892 if (ops == NULL) {
2893 Tcl_SetResult(interp, "Cannot set parameter value", NULL);
2894 return TCL_ERROR;
2895 }
2896 switch (ops->type) {
2897 case XC_FLOAT:
2898 result = Tcl_GetDoubleFromObj(interp, objv, &dvalue);
2899 if (result != TCL_OK) return result;
2900 ops->parameter.fvalue = (float)dvalue;
2901 break;
2902 case XC_INT:
2903 result = Tcl_GetIntFromObj(interp, objv, &ivalue);
2904 if (result != TCL_OK) return result;
2905 ops->parameter.ivalue = ivalue;
2906 break;
2907 case XC_EXPR:
2908 ops->parameter.expr = strdup(Tcl_GetString(objv));
2909 break;
2910 case XC_STRING:
2911 result = GetXCStringFromList(interp, objv, &strptr);
2912 if (result != TCL_OK) return result;
2913 freelabel(ops->parameter.string);
2914 /* Must add a "param end" */
2915 newpart = makesegment(&strptr, NULL);
2916 newpart->nextpart = NULL;
2917 newpart->type = PARAM_END;
2918 newpart->data.string = (u_char *)NULL;
2919 ops->parameter.string = strptr;
2920 break;
2921 }
2922 return TCL_OK;
2923 }
2924
2925 /*----------------------------------------------------------------------*/
2926 /* Translate the numeric parameter types to a string that the Tcl */
2927 /* "parameter" routine will recognize from the command line. */
2928 /*----------------------------------------------------------------------*/
2929
2930 char *
2931 translateparamtype(int type)
2932 {
2933 const char *param_types[] = {"numeric", "substring", "x position",
2934 "y position", "style", "anchoring", "start angle", "end angle",
2935 "radius", "minor axis", "rotation", "scale", "linewidth", "color",
2936 "expression", "position", NULL};
2937
2938 if (type < 0) return NULL;
2939 return (char *)param_types[type];
2940 }
2941
2942 /*----------------------------------------------------------------------*/
2943 /* Parameter command: */
2944 /* */
2945 /* Normally, a selected element will produce a list of backwards- */
2946 /* referenced parameters (eparam). However, it is useful to pick up */
2947 /* the forwards-referenced parameters of an object instance, so that */
2948 /* parameters can be modified from the level above (e.g., to change */
2949 /* circuit component values, component indices, etc.). The optional */
2950 /* final argument "-forward" can be used to access this mode. */
2951 /*----------------------------------------------------------------------*/
2952
2953 int xctcl_param(ClientData clientData, Tcl_Interp *interp,
2954 int objc, Tcl_Obj *CONST objv[])
2955 {
2956 int i, j, value, idx, nidx = 4;
2957 int result = ParseElementArguments(interp, objc, objv, &nidx, ALL_TYPES);
2958 oparamptr ops, instops;
2959 oparam temps;
2960 eparamptr epp;
2961 genericptr thiselem = NULL;
2962 Tcl_Obj *plist, *kpair, *exprres;
2963 objinstptr refinst;
2964 objectptr refobj;
2965 char *dash_opt;
2966 Boolean verbatim = FALSE, indirection = FALSE, forwarding = FALSE;
2967
2968 static char *subCmds[] = {"allowed", "get", "type", "default", "set", "make",
2969 "replace", "forget", "delete", NULL};
2970 enum SubIdx {
2971 AllowedIdx, GetIdx, TypeIdx, DefaultIdx, SetIdx, MakeIdx, ReplaceIdx,
2972 ForgetIdx, DeleteIdx
2973 };
2974
2975 /* The order of these type names must match the enumeration in xcircuit.h */
2976
2977 static char *param_types[] = {"numeric", "substring", "x position",
2978 "y position", "style", "anchoring", "start angle", "end angle",
2979 "radius", "minor axis", "rotation", "scale", "linewidth", "color",
2980 "expression", "position", NULL}; /* (jdk) */
2981
2982 /* The first object instance in the select list becomes "thiselem", */
2983 /* if such exists. Otherwise, it remains null. */
2984
2985 for (j = 0; j < areawin->selects; j++) {
2986 if (SELECTTYPE(areawin->selectlist + j) == OBJINST) {
2987 thiselem = SELTOGENERIC(areawin->selectlist + j);
2988 break;
2989 }
2990 }
2991
2992 if (objc - nidx < 1)
2993 idx = GetIdx;
2994 else {
2995 dash_opt = Tcl_GetString(objv[nidx]);
2996 if (*dash_opt == '-')
2997 idx = GetIdx;
2998 else {
2999 if ((result = Tcl_GetIndexFromObj(interp, objv[nidx],
3000 (CONST84 char **)subCmds, "option", 0, &idx)) != TCL_OK)
3001 return result;
3002 }
3003 }
3004
3005 /* Use the topobject by default */
3006 refinst = areawin->topinstance;
3007 refobj = topobject;
3008
3009 /* command-line switches */
3010
3011 dash_opt = Tcl_GetString(objv[objc - 1]);
3012 while (*dash_opt == '-') {
3013
3014 /* If an object instance is selected, we list backwards-referenced */
3015 /* (eparam) parameters, unless the command ends in "-forward". */
3016
3017 if (!strncmp(dash_opt + 1, "forw", 4)) {
3018 switch (idx) {
3019 case SetIdx:
3020 case GetIdx:
3021 case TypeIdx:
3022 case MakeIdx:
3023 case DeleteIdx:
3024 case ForgetIdx:
3025 case DefaultIdx:
3026 if (thiselem && IS_OBJINST(thiselem)) {
3027 refinst = (objinstptr)thiselem;
3028 refobj = refinst->thisobject;
3029 thiselem = NULL;
3030 forwarding = TRUE;
3031 }
3032 break;
3033 }
3034 }
3035 else if (!strncmp(dash_opt + 1, "verb", 4)) {
3036 verbatim = TRUE;
3037 }
3038 else if (!strncmp(dash_opt + 1, "ind", 3)) {
3039 indirection = TRUE;
3040 }
3041
3042 objc--;
3043 if (objc == 0) {
3044 Tcl_SetResult(interp, "Must have a valid option", NULL);
3045 return TCL_ERROR;
3046 }
3047 dash_opt = Tcl_GetString(objv[objc - 1]);
3048 }
3049
3050
3051 switch (idx) {
3052 case AllowedIdx:
3053 for (i = 0; i < (sizeof(param_types) / sizeof(char *)); i++)
3054 if ((thiselem == NULL) || (param_select[i] & thiselem->type))
3055 Tcl_AppendElement(interp, param_types[i]);
3056
3057 break;
3058
3059 case GetIdx:
3060 case TypeIdx:
3061
3062 if (objc == nidx + 2) {
3063
3064 /* Check argument against all parameter keys */
3065 ops = find_param(refinst, Tcl_GetString(objv[nidx + 1]));
3066 if (ops == NULL) {
3067 /* Otherwise, the argument must be a parameter type. */
3068 if ((result = Tcl_GetIndexFromObj(interp, objv[nidx + 1],
3069 (CONST84 char **)param_types, "parameter type",
3070 0, &value)) != TCL_OK) {
3071 Tcl_SetResult(interp, "Must have a valid key or parameter type",
3072 NULL);
3073 return result;
3074 }
3075 }
3076
3077 /* Return the value of the indicated parameter */
3078
3079 plist = Tcl_NewListObj(0, NULL);
3080 if (thiselem == NULL) {
3081 if (ops != NULL) {
3082 if (idx == GetIdx)
3083 Tcl_ListObjAppendElement(interp, plist,
3084 GetParameterValue(refobj, ops, verbatim, refinst));
3085 else
3086 Tcl_ListObjAppendElement(interp, plist,
3087 Tcl_NewStringObj(param_types[ops->which],
3088 strlen(param_types[ops->which])));
3089 }
3090 else {
3091 for (ops = refobj->params; ops != NULL; ops = ops->next) {
3092 instops = find_param(refinst, ops->key);
3093 if (instops->which == value) {
3094 kpair = Tcl_NewListObj(0, NULL);
3095 Tcl_ListObjAppendElement(interp, kpair,
3096 Tcl_NewStringObj(instops->key, strlen(instops->key)));
3097 if (idx == GetIdx)
3098 Tcl_ListObjAppendElement(interp, kpair,
3099 GetParameterValue(refobj, instops, verbatim,
3100 refinst));
3101 else
3102 Tcl_ListObjAppendElement(interp, kpair,
3103 Tcl_NewStringObj(param_types[instops->which],
3104 strlen(param_types[instops->which])));
3105 Tcl_ListObjAppendElement(interp, plist, kpair);
3106 }
3107 }
3108 }
3109 }
3110 else {
3111 for (epp = thiselem->passed; epp != NULL; epp = epp->next) {
3112 instops = find_param(refinst, epp->key);
3113 if (instops->which == value) {
3114 if (idx == GetIdx)
3115 Tcl_ListObjAppendElement(interp, plist,
3116 GetParameterValue(refobj, instops, verbatim, refinst));
3117 else
3118 Tcl_ListObjAppendElement(interp, plist,
3119 Tcl_NewStringObj(param_types[instops->which],
3120 strlen(param_types[instops->which])));
3121 }
3122 }
3123
3124 /* Search label for parameterized substrings. These are */
3125 /* backwards-referenced parameters, although they are */
3126 /* not stored in the eparam record of the label. */
3127
3128 if ((value == P_SUBSTRING) && IS_LABEL(thiselem)) {
3129 stringpart *cstr;
3130 labelptr clab = (labelptr)thiselem;
3131 for (cstr = clab->string; cstr != NULL; cstr = cstr->nextpart) {
3132 if (cstr->type == PARAM_START) {
3133 kpair = Tcl_NewListObj(0, NULL);
3134 ops = find_param(refinst, cstr->data.string);
3135 Tcl_ListObjAppendElement(interp, kpair,
3136 Tcl_NewStringObj(ops->key, strlen(ops->key)));
3137 if (idx == GetIdx)
3138 Tcl_ListObjAppendElement(interp, kpair,
3139 GetParameterValue(refobj, ops, verbatim,
3140 refinst));
3141 else
3142 Tcl_ListObjAppendElement(interp, kpair,
3143 Tcl_NewStringObj(param_types[ops->which],
3144 strlen(param_types[ops->which])));
3145 Tcl_ListObjAppendElement(interp, plist, kpair);
3146 }
3147 }
3148 }
3149 }
3150 Tcl_SetObjResult(interp, plist);
3151 }
3152 else {
3153 plist = Tcl_NewListObj(0, NULL);
3154 if (thiselem == NULL) {
3155 for (ops = refobj->params; ops != NULL; ops = ops->next) {
3156 kpair = Tcl_NewListObj(0, NULL);
3157 Tcl_ListObjAppendElement(interp, kpair,
3158 Tcl_NewStringObj(ops->key, strlen(ops->key)));
3159 if (idx == GetIdx) {
3160 instops = find_param(refinst, ops->key);
3161 Tcl_ListObjAppendElement(interp, kpair,
3162 GetParameterValue(refobj, instops, verbatim, refinst));
3163 }
3164 else
3165 Tcl_ListObjAppendElement(interp, kpair,
3166 Tcl_NewStringObj(param_types[ops->which],
3167 strlen(param_types[ops->which])));
3168 Tcl_ListObjAppendElement(interp, plist, kpair);
3169 }
3170 }
3171 else {
3172 for (epp = thiselem->passed; epp != NULL; epp = epp->next) {
3173 kpair = Tcl_NewListObj(0, NULL);
3174 ops = find_param(refinst, epp->key);
3175 Tcl_ListObjAppendElement(interp, kpair,
3176 Tcl_NewStringObj(ops->key, strlen(ops->key)));
3177 if (idx == GetIdx)
3178 Tcl_ListObjAppendElement(interp, kpair,
3179 GetParameterValue(refobj, ops, verbatim, refinst));
3180 else
3181 Tcl_ListObjAppendElement(interp, kpair,
3182 Tcl_NewStringObj(param_types[ops->which],
3183 strlen(param_types[ops->which])));
3184 Tcl_ListObjAppendElement(interp, plist, kpair);
3185 }
3186
3187 /* Search label for parameterized substrings. These are */
3188 /* backwards-referenced parameters, although they are */
3189 /* not stored in the eparam record of the label. */
3190
3191 if (IS_LABEL(thiselem)) {
3192 stringpart *cstr;
3193 labelptr clab = (labelptr)thiselem;
3194 for (cstr = clab->string; cstr != NULL; cstr = cstr->nextpart) {
3195 if (cstr->type == PARAM_START) {
3196 kpair = Tcl_NewListObj(0, NULL);
3197 ops = find_param(refinst, cstr->data.string);
3198 Tcl_ListObjAppendElement(interp, kpair,
3199 Tcl_NewStringObj(ops->key, strlen(ops->key)));
3200 if (idx == GetIdx)
3201 Tcl_ListObjAppendElement(interp, kpair,
3202 GetParameterValue(refobj, ops, verbatim,
3203 refinst));
3204 else
3205 Tcl_ListObjAppendElement(interp, kpair,
3206 Tcl_NewStringObj(param_types[ops->which],
3207 strlen(param_types[ops->which])));
3208 Tcl_ListObjAppendElement(interp, plist, kpair);
3209 }
3210 }
3211 }
3212 }
3213 Tcl_SetObjResult(interp, plist);
3214 }
3215 break;
3216
3217 case DefaultIdx:
3218 if (objc == nidx + 2) {
3219 /* Check against keys */
3220 ops = match_param(refobj, Tcl_GetString(objv[nidx + 1]));
3221 if (ops == NULL) {
3222 if ((result = Tcl_GetIndexFromObj(interp, objv[nidx + 1],
3223 (CONST84 char **)param_types, "parameter type",
3224 0, &value)) != TCL_OK) {
3225 Tcl_SetResult(interp, "Must have a valid key or parameter type",
3226 NULL);
3227 return result;
3228 }
3229 }
3230 else { /* get default value(s) */
3231 plist = Tcl_NewListObj(0, NULL);
3232 if (thiselem == NULL) {
3233 if (ops != NULL) {
3234 Tcl_ListObjAppendElement(interp, plist,
3235 GetParameterValue(refobj, ops, verbatim, refinst));
3236 }
3237 else {
3238 for (ops = refobj->params; ops != NULL; ops = ops->next) {
3239 if (ops->which == value) {
3240 Tcl_ListObjAppendElement(interp, plist,
3241 GetParameterValue(refobj, ops, verbatim, refinst));
3242 }
3243 }
3244 }
3245 }
3246 else {
3247 for (epp = thiselem->passed; epp != NULL; epp = epp->next) {
3248 ops = match_param(refobj, epp->key);
3249 if (ops->which == value) {
3250 Tcl_ListObjAppendElement(interp, plist,
3251 GetParameterValue(refobj, ops, verbatim, refinst));
3252 }
3253 }
3254
3255 /* search label for parameterized substrings */
3256
3257 if ((value == P_SUBSTRING) && IS_LABEL(thiselem)) {
3258 stringpart *cstr;
3259 labelptr clab = (labelptr)thiselem;
3260 for (cstr = clab->string; cstr != NULL; cstr = cstr->nextpart) {
3261 if (cstr->type == PARAM_START) {
3262 ops = match_param(refobj, cstr->data.string);
3263 if (ops != NULL)
3264 Tcl_ListObjAppendElement(interp, plist,
3265 GetParameterValue(refobj, ops, verbatim,
3266 refinst));
3267 }
3268 }
3269 }
3270 }
3271 Tcl_SetObjResult(interp, plist);
3272 }
3273 }
3274 else if (objc == nidx + 1) { /* list all parameters and their defaults */
3275 plist = Tcl_NewListObj(0, NULL);
3276 for (ops = refobj->params; ops != NULL; ops = ops->next) {
3277 kpair = Tcl_NewListObj(0, NULL);
3278 Tcl_ListObjAppendElement(interp, kpair,
3279 Tcl_NewStringObj(ops->key, strlen(ops->key)));
3280 Tcl_ListObjAppendElement(interp, kpair,
3281 GetParameterValue(refobj, ops, verbatim, refinst));
3282 Tcl_ListObjAppendElement(interp, plist, kpair);
3283 }
3284 Tcl_SetObjResult(interp, plist);
3285 }
3286 else {
3287 Tcl_WrongNumArgs(interp, 1, objv, "default <type|key> [<value>]");
3288 return TCL_ERROR;
3289 }
3290 break;
3291
3292 case SetIdx: /* currently, instances only. . .*/
3293 if (objc == nidx + 3) { /* possibly to be expanded. . . */
3294 char *key = Tcl_GetString(objv[nidx + 1]);
3295 objinstptr searchinst = NULL;
3296
3297 /* Allow option "set" to act on more than one selection */
3298
3299 if (areawin->selects == 0) goto keycheck;
3300
3301 while (j < areawin->selects) {
3302
3303 refinst = SELTOOBJINST(areawin->selectlist + j);
3304 refobj = refinst->thisobject;
3305
3306 /* Check against keys */
3307 keycheck:
3308 instops = match_instance_param(refinst, key);
3309 ops = match_param(refobj, key);
3310 if (instops == NULL) {
3311 if (ops == NULL) {
3312 if (!forwarding || (areawin->selects <= 1)) {
3313 Tcl_SetResult(interp, "Invalid key ", NULL);
3314 Tcl_AppendElement(interp, key);
3315 return TCL_ERROR;
3316 }
3317 else
3318 goto next_param;
3319 }
3320 copyparams(refinst, refinst);
3321 instops = match_instance_param(refinst, key);
3322 }
3323 else if (ops->type == XC_EXPR) {
3324 /* If the expression is currently the default expression */
3325 /* but the instance value is holding the last evaluated */
3326 /* result, then we have to delete and regenerate the */
3327 /* existing instance parameter ("verbatim" assumed even */
3328 /* if not declared because you can't change the result */
3329 /* of the expression). */
3330
3331 free_instance_param(refinst, instops);
3332 instops = copyparameter(ops);
3333 instops->next = refinst->params;
3334 refinst->params = instops;
3335 }
3336 if (indirection) {
3337 char *refkey = Tcl_GetString(objv[nidx + 2]);
3338
3339 if (refinst != areawin->topinstance)
3340 searchinst = areawin->topinstance;
3341 else if (areawin->stack) {
3342 searchinst = areawin->stack->thisinst;
3343 }
3344 else {
3345 resolveparams(refinst);
3346 Tcl_SetResult(interp, "On top-level page: "
3347 "no indirection possible!", NULL);
3348 return TCL_ERROR;
3349 }
3350 if (match_param(searchinst->thisobject, refkey) == NULL) {
3351 resolveparams(refinst);
3352 Tcl_SetResult(interp, "Invalid indirect reference key", NULL);
3353 return TCL_ERROR;
3354 }
3355 /* Create an eparam record in the instance */
3356 epp = make_new_eparam(refkey);
3357 epp->flags |= P_INDIRECT;
3358 epp->pdata.refkey = strdup(key);
3359 epp->next = refinst->passed;
3360 refinst->passed = epp;
3361 }
3362 else
3363 SetParameterValue(interp, instops, objv[nidx + 2]);
3364 resolveparams(refinst);
3365
3366 /* Check if there are more selections to modify */
3367
3368 next_param:
3369 if (!forwarding) break;
3370 while (++j != areawin->selects)
3371 if (SELECTTYPE(areawin->selectlist + j) == OBJINST)
3372 break;
3373 }
3374
3375 /* Redraw everything (this could be finessed. . .) */
3376 areawin->redraw_needed = True;
3377 drawarea(areawin->area, (caddr_t)NULL, (caddr_t)NULL);
3378 }
3379 else {
3380 Tcl_WrongNumArgs(interp, 1, objv, "set <key>");
3381 return TCL_ERROR;
3382 }
3383 break;
3384
3385 case MakeIdx:
3386 if (objc >= (nidx + 2) && objc <= (nidx + 4)) {
3387 if ((result = Tcl_GetIndexFromObj(interp, objv[nidx + 1],
3388 (CONST84 char **)param_types, "parameter type",
3389 0, &value)) != TCL_OK)
3390 return result;
3391
3392 if ((value == P_SUBSTRING) && (objc == (nidx + 4))) {
3393 stringpart *strptr = NULL, *newpart;
3394 result = GetXCStringFromList(interp, objv[nidx + 3], &strptr);
3395 if (result != TCL_ERROR) {
3396 if (makestringparam(refobj, Tcl_GetString(objv[nidx + 2]),
3397 strptr) == -1)
3398 return TCL_ERROR;
3399 /* Add the "parameter end" marker to this string */
3400 newpart = makesegment(&strptr, NULL);
3401 newpart->nextpart = NULL;
3402 newpart->type = PARAM_END;
3403 newpart->data.string = (u_char *)NULL;
3404 }
3405 }
3406 else if (value == P_SUBSTRING) {
3407 /* Get parameter value from selection */
3408 startparam((Tk_Window)clientData, (pointertype)value,
3409 (caddr_t)Tcl_GetString(objv[nidx + 2]));
3410 }
3411 else if ((value == P_EXPRESSION) && (objc == (nidx + 4))) {
3412 temps.type = XC_EXPR;
3413 temps.parameter.expr = Tcl_GetString(objv[nidx + 3]);
3414 exprres = evaluate_raw(refobj, &temps, refinst, &result);
3415
3416 if (result != TCL_OK) {
3417 Tcl_SetResult(xcinterp, "Bad result from expression!", NULL);
3418 /* Not fatal to have a bad expression result. . . */
3419 /* return result; */
3420 }
3421 if (makeexprparam(refobj, Tcl_GetString(objv[nidx + 2]),
3422 temps.parameter.expr, P_EXPRESSION) == NULL)
3423 return TCL_ERROR;
3424 }
3425
3426 /* All other types are parsed as either a numeric value */
3427 /* (integer or float), or an expression that evaluates */
3428 /* to a numeric value. */
3429
3430 else if (((value == P_NUMERIC) && (objc == (nidx + 4))) ||
3431 objc == (nidx + 3)) {
3432 double tmpdbl;
3433
3434 i = (value == P_NUMERIC) ? 3 : 2;
3435
3436 result = Tcl_GetDoubleFromObj(interp, objv[nidx + i], &tmpdbl);
3437 if (result != TCL_ERROR) {
3438 if (makefloatparam(refobj, Tcl_GetString(objv[nidx + i - 1]),
3439 (float)tmpdbl) == -1)
3440 return TCL_ERROR;
3441 }
3442 else {
3443 char *newkey;
3444
3445 /* This may be an expression. Do a quick check to */
3446 /* see if the string can be evaluated as a Tcl */
3447 /* expression. If it returns a valid numeric result, */
3448 /* then accept the expression. */
3449
3450 Tcl_ResetResult(interp);
3451 temps.type = XC_EXPR;
3452 temps.parameter.expr = Tcl_GetString(objv[nidx + i]);
3453
3454 exprres = evaluate_raw(refobj, &temps, refinst, &result);
3455 if (result != TCL_OK) {
3456 Tcl_SetResult(xcinterp, "Bad result from expression!", NULL);
3457 return result;
3458 }
3459 result = Tcl_GetDoubleFromObj(interp, exprres, &tmpdbl);
3460 if (result != TCL_ERROR) {
3461 if ((newkey = makeexprparam(refobj, (value == P_NUMERIC) ?
3462 Tcl_GetString(objv[nidx + i - 1]) : NULL,
3463 temps.parameter.expr, value)) == NULL)
3464 return TCL_ERROR;
3465 else if (value != P_NUMERIC) {
3466 /* Link the expression parameter to the element */
3467 /* To-do: Handle cycles (one extra argument) */
3468 genericptr pgen;
3469 for (i = 0; i < areawin->selects; i++) {
3470 pgen = SELTOGENERIC(areawin->selectlist + i);
3471 makenumericalp(&pgen, value, newkey, 0);
3472 }
3473 }
3474 }
3475 else {
3476 Tcl_SetResult(xcinterp, "Expression evaluates to "
3477 "non-numeric type!", NULL);
3478 return result;
3479 }
3480 }
3481 }
3482 else if (((value != P_NUMERIC) && (objc == (nidx + 4))) ||
3483 objc == (nidx + 3)) {
3484 int cycle;
3485 i = objc - 1;
3486 if (value == P_POSITION || value == P_POSITION_X ||
3487 value == P_POSITION_Y) {
3488 if (objc == nidx + 4) {
3489 result = Tcl_GetIntFromObj(interp, objv[i - 1], &cycle);
3490 if (result == TCL_ERROR) {
3491 Tcl_ResetResult(interp);
3492 startparam((Tk_Window)clientData, (pointertype)value,
3493 Tcl_GetString(objv[i]));
3494 }
3495 else {
3496 parameterize(value, NULL, (short)cycle);
3497 }
3498 }
3499 else {
3500 Tcl_WrongNumArgs(interp, 1, objv, "make position cycle <value>");
3501 return TCL_ERROR;
3502 }
3503 }
3504 else {
3505 if (objc == nidx + 3)
3506 startparam((Tk_Window)clientData, (pointertype)value,
3507 Tcl_GetString(objv[i]));
3508 else {
3509 Tcl_WrongNumArgs(interp, 1, objv, "make <numeric_type> <value>");
3510 return TCL_ERROR;
3511 }
3512 }
3513 }
3514 else {
3515 if ((value == P_SUBSTRING) || (value == P_NUMERIC) ||
3516 (value == P_EXPRESSION)) {
3517 Tcl_WrongNumArgs(interp, 1, objv,
3518 "make substring|numeric|expression <key>");
3519 return TCL_ERROR;
3520 }
3521 else
3522 startparam((Tk_Window)clientData, (pointertype)value, NULL);
3523 }
3524 }
3525 else {
3526 Tcl_WrongNumArgs(interp, 1, objv, "make <type> [<key>]");
3527 return TCL_ERROR;
3528 }
3529 break;
3530
3531 case ReplaceIdx:
3532 /* Calls unparameterize---replaces text with the instance value, */
3533 /* or replaces a numeric parameter with the instance values by */
3534 /* unparameterizing the element. Don't use with parameter keys. */
3535
3536 if (objc == nidx + 2) {
3537 if ((result = Tcl_GetIndexFromObj(interp, objv[nidx + 1],
3538 (CONST84 char **)param_types, "parameter type",
3539 0, &value)) != TCL_OK)
3540 return result;
3541 unparameterize(value);
3542 }
3543 else {
3544 Tcl_WrongNumArgs(interp, 1, objv, "replace <type>");
3545 return TCL_ERROR;
3546 }
3547 break;
3548
3549 case DeleteIdx:
3550 case ForgetIdx:
3551
3552 if (objc == nidx + 2) {
3553 /* Check against keys */
3554 ops = match_param(refobj, Tcl_GetString(objv[nidx + 1]));
3555 if (ops == NULL) {
3556 Tcl_SetResult(interp, "Invalid parameter key", NULL);
3557 return TCL_ERROR;
3558 }
3559 else {
3560 free_object_param(refobj, ops);
3561 /* Redraw everything */
3562 drawarea(areawin->area, (caddr_t)NULL, (caddr_t)NULL);
3563 }
3564 }
3565 else {
3566 Tcl_WrongNumArgs(interp, 1, objv, "forget <key>");
3567 return TCL_ERROR;
3568 }
3569 break;
3570 }
3571 return XcTagCallback(interp, objc, objv);
3572 }
3573
3574 /*----------------------------------------------------------------------*/
3575
3576 int xctcl_select(ClientData clientData, Tcl_Interp *interp,
3577 int objc, Tcl_Obj *CONST objv[])
3578 {
3579 char *argstr;
3580 short *newselect;
3581 int selected_prior, selected_new, nidx, result;
3582 Tcl_Obj *listPtr;
3583 XPoint newpos;
3584
3585 if (objc == 1) {
3586 /* Special case: "select" by itself returns the number of */
3587 /* selected objects. */
3588 Tcl_SetObjResult(interp, Tcl_NewIntObj((int)areawin->selects));
3589 return XcTagCallback(interp, objc, objv);
3590 }
3591 else {
3592 nidx = 1;
3593 result = ParseElementArguments(interp, objc, objv, &nidx, ALL_TYPES);
3594 if (result != TCL_OK) return result;
3595 }
3596
3597 if (objc != 2) {
3598 Tcl_WrongNumArgs(interp, 1, objv, "here | get | <element_handle>");
3599 return TCL_ERROR;
3600 }
3601
3602 if (nidx == 1) {
3603 argstr = Tcl_GetString(objv[1]);
3604 if (!strcmp(argstr, "here")) {
3605 newpos = UGetCursorPos();
3606 areawin->save = newpos;
3607 selected_prior = areawin->selects;
3608 newselect = select_element(ALL_TYPES);
3609 selected_new = areawin->selects - selected_prior;
3610 }
3611 else if (!strcmp(argstr, "get")) {
3612 newselect = areawin->selectlist;
3613 selected_new = areawin->selects;
3614 }
3615 else {
3616 Tcl_WrongNumArgs(interp, 1, objv, "here | get | <object_handle>");
3617 return TCL_ERROR;
3618 }
3619
3620 listPtr = SelectToTclList(interp, newselect, selected_new);
3621 Tcl_SetObjResult(interp, listPtr);
3622 }
3623 return XcTagCallback(interp, objc, objv);
3624 }
3625
3626 /*----------------------------------------------------------------------*/
3627
3628 int xctcl_deselect(ClientData clientData, Tcl_Interp *interp,
3629 int objc, Tcl_Obj *CONST objv[])
3630 {
3631 int i, j, k, result, numobjs;
3632 pointertype ehandle;
3633 char *argstr;
3634 Tcl_Obj *lobj;
3635
3636 if (objc > 3) {
3637 Tcl_WrongNumArgs(interp, 1, objv, "[element_handle]");
3638 return TCL_ERROR;
3639 }
3640 else if (objc == 3 || (objc == 2 && !strcmp(Tcl_GetString(objv[0]), "deselect"))) {
3641
3642 argstr = Tcl_GetString(objv[1]);
3643 if (strcmp(argstr, "selected")) {
3644
3645 /* check for object handles (integer list) */
3646
3647 result = Tcl_ListObjLength(interp, objv[1], &numobjs);
3648 if (result != TCL_OK) return result;
3649
3650 for (j = 0; j < numobjs; j++) {
3651 result = Tcl_ListObjIndex(interp, objv[1], j, &lobj);
3652 if (result != TCL_OK) return result;
3653 result = Tcl_GetHandleFromObj(interp, lobj, (void *)&ehandle);
3654 if (result != TCL_OK) return result;
3655 i = GetPartNumber((genericptr)ehandle, topobject, ALL_TYPES);
3656 if (i == -1) {
3657 Tcl_SetResult(interp, "No such element exists.", NULL);
3658 return TCL_ERROR;
3659 }
3660 for (i = 0; i < areawin->selects; i++) {
3661 short *newselect = areawin->selectlist + i;
3662 if ((genericptr)ehandle == SELTOGENERIC(newselect)) {
3663 XTopSetForeground(SELTOCOLOR(newselect));
3664 geneasydraw(*newselect, DEFAULTCOLOR, topobject,
3665 areawin->topinstance);
3666
3667 areawin->selects--;
3668 for (k = i; k < areawin->selects; k++)
3669 *(areawin->selectlist + k) = *(areawin->selectlist + k + 1);
3670 if (areawin->selects == 0) {
3671 free(areawin->selectlist);
3672 freeselects(); /* specifically, free hierstack */
3673 }
3674 }
3675 }
3676 }
3677 }
3678 else
3679 unselect_all();
3680 }
3681 else
3682 startdesel((Tk_Window)clientData, NULL, NULL);
3683
3684 return XcTagCallback(interp, objc, objv);
3685 }
3686
3687 /*----------------------------------------------------------------------*/
3688
3689 int xctcl_push(ClientData clientData, Tcl_Interp *interp,
3690 int objc, Tcl_Obj *CONST objv[])
3691 {
3692 int result = ParseElementArguments(interp, objc, objv, NULL, OBJINST);
3693
3694 if (result != TCL_OK) return result;
3695
3696 pushobject(NULL);
3697
3698 return XcTagCallback(interp, objc, objv);
3699 }
3700
3701 /*----------------------------------------------------------------------*/
3702
3703 int xctcl_pop(ClientData clientData, Tcl_Interp *interp,
3704 int objc, Tcl_Obj *CONST objv[])
3705 {
3706 if (objc != 1) {
3707 Tcl_WrongNumArgs(interp, 1, objv, "(no arguments)");
3708 return TCL_ERROR;
3709 }
3710 popobject((Tk_Window)clientData, 0, NULL);
3711
3712 return XcTagCallback(interp, objc, objv);
3713 }
3714
3715 /*----------------------------------------------------------------------*/
3716 /* Object queries */
3717 /*----------------------------------------------------------------------*/
3718
3719 int xctcl_object(ClientData clientData, Tcl_Interp *interp,
3720 int objc, Tcl_Obj *CONST objv[])
3721 {
3722 int i, j, idx, result, nidx, libno;
3723 genericptr egen;
3724 Tcl_Obj **newobjv, *ilist, *plist, *hobj;
3725 pointertype ehandle;
3726 objinstptr thisinst;
3727 Boolean forceempty = FALSE;
3728
3729 static char *subCmds[] = {"make", "name", "parts", "library",
3730 "handle", "hide", "unhide", "bbox", NULL};
3731 enum SubIdx {
3732 MakeIdx, NameIdx, PartsIdx, LibraryIdx, HandleIdx, HideIdx,
3733 UnhideIdx, BBoxIdx
3734 };
3735
3736 /* Check for option "-force" (create an object even if it has no contents) */
3737 if (!strncmp(Tcl_GetString(objv[objc - 1]), "-forc", 5)) {
3738 forceempty = TRUE;
3739 objc--;
3740 }
3741
3742 /* (revision) "object handle <name>" returns a handle (or null), so */
3743 /* all commands can unambiguously operate on a handle (or nothing) */
3744 /* in the second position. */
3745
3746 nidx = 0;
3747
3748 /* 2nd argument may be a handle, object name, or nothing. */
3749 /* If nothing, the instance of the top-level page is assumed. */
3750
3751 if (objc < 2) {
3752 Tcl_WrongNumArgs(interp, 0, objv, "object [handle] <option> ...");
3753 return TCL_ERROR;
3754 }
3755
3756 result = Tcl_GetHandleFromObj(interp, objv[1], (void *)&ehandle);
3757 if (result != TCL_OK) {
3758 Tcl_ResetResult(interp);
3759 ehandle = (pointertype)(areawin->topinstance);
3760 }
3761 else {
3762 nidx = 1;
3763 objc--;
3764 }
3765 egen = (genericptr)ehandle;
3766
3767 if (ELEMENTTYPE(egen) != OBJINST) {
3768 Tcl_SetResult(interp, "handle does not point to an object instance!", NULL);
3769 return TCL_ERROR;
3770 }
3771 if (objc < 2) {
3772 Tcl_WrongNumArgs(interp, 0, objv, "object <handle> <option> ...");
3773 return TCL_ERROR;
3774 }
3775 thisinst = (objinstptr)egen;
3776
3777 if ((result = Tcl_GetIndexFromObj(interp, objv[1 + nidx],
3778 (CONST84 char **)subCmds, "option", 0, &idx)) != TCL_OK)
3779 return result;
3780
3781 switch (idx) {
3782 case LibraryIdx:
3783 case HideIdx:
3784 case UnhideIdx:
3785
3786 if ((libno = libfindobject(thisinst->thisobject, &j)) < 0) {
3787 Tcl_SetResult(interp, "No such object.", NULL);
3788 return TCL_ERROR;
3789 }
3790 break;
3791 }
3792
3793 switch (idx) {
3794 case BBoxIdx:
3795 ilist = Tcl_NewListObj(0, NULL);
3796 hobj = Tcl_NewIntObj((int)thisinst->thisobject->bbox.lowerleft.x);
3797 Tcl_ListObjAppendElement(interp, ilist, hobj);
3798 hobj = Tcl_NewIntObj((int)thisinst->thisobject->bbox.lowerleft.y);
3799 Tcl_ListObjAppendElement(interp, ilist, hobj);
3800 hobj = Tcl_NewIntObj((int)(thisinst->thisobject->bbox.lowerleft.x +
3801 thisinst->thisobject->bbox.width));
3802 Tcl_ListObjAppendElement(interp, ilist, hobj);
3803 hobj = Tcl_NewIntObj((int)(thisinst->thisobject->bbox.lowerleft.y +
3804 thisinst->thisobject->bbox.height));
3805 Tcl_ListObjAppendElement(interp, ilist, hobj);
3806 Tcl_SetObjResult(interp, ilist);
3807 break;
3808
3809 case HandleIdx:
3810 if ((objc == 3) && (!NameToObject(Tcl_GetString(objv[nidx + 2]),
3811 (objinstptr *)&ehandle, TRUE))) {
3812 Tcl_SetResult(interp, "Object is not loaded.", NULL);
3813 return TCL_ERROR;
3814 }
3815 else {
3816 Tcl_SetObjResult(interp, Tcl_NewHandleObj((genericptr)ehandle));
3817 }
3818 break;
3819
3820 case LibraryIdx:
3821 if (objc == 3) {
3822 int libtarget;
3823 if (ParseLibArguments(xcinterp, 2, &objv[objc - 2 + nidx], NULL,
3824 &libtarget) == TCL_ERROR)
3825 return TCL_ERROR;
3826 else if (libno != libtarget) {
3827 libmoveobject(thisinst->thisobject, libtarget);
3828 /* Regenerate the source and target library pages */
3829 composelib(libno + LIBRARY);
3830 composelib(libtarget + LIBRARY);
3831 }
3832 }
3833 Tcl_SetObjResult(interp, Tcl_NewIntObj(libno + 1));
3834 break;
3835
3836 case HideIdx:
3837 thisinst->thisobject->hidden = True;
3838 composelib(libno + LIBRARY);
3839 break;
3840
3841 case UnhideIdx:
3842 thisinst->thisobject->hidden = False;
3843 composelib(libno + LIBRARY);
3844 break;
3845
3846 case MakeIdx:
3847
3848 if ((areawin->selects == 0) && (nidx == 0)) {
3849 /* h = object make "name" [{element_list}] [library]*/
3850 newobjv = (Tcl_Obj **)(&objv[2]);
3851 result = ParseElementArguments(interp, objc - 2, newobjv, NULL, ALL_TYPES);
3852 if (forceempty && result != TCL_OK) Tcl_ResetResult(interp);
3853 else if (!forceempty && result == TCL_OK && areawin->selects == 0)
3854 {
3855 Tcl_SetResult(interp, "Cannot create empty object. Use "
3856 "\"-force\" option.", NULL);
3857 return TCL_ERROR;
3858 }
3859 else if (result != TCL_OK) return result;
3860 }
3861 else if (nidx == 1) {
3862 Tcl_SetResult(interp, "\"object <handle> make\" is illegal", NULL);
3863 return TCL_ERROR;
3864 }
3865 else if (objc < 3) {
3866 Tcl_WrongNumArgs(interp, 1, objv, "make <name> [element_list] [<library>]");
3867 return TCL_ERROR;
3868 }
3869 if (objc >= 4)
3870 ParseLibArguments(xcinterp, 2, &objv[objc - 2], NULL, &libno);
3871 else
3872 libno = -1;
3873 thisinst = domakeobject(libno, Tcl_GetString(objv[nidx + 2]), forceempty);
3874 Tcl_SetObjResult(interp, Tcl_NewHandleObj(thisinst));
3875 break;
3876
3877 case NameIdx:
3878 if (nidx == 1 || areawin->selects == 0) {
3879 if (objc == 3) {
3880 sprintf(thisinst->thisobject->name, Tcl_GetString(objv[nidx + 2]));
3881 checkname(thisinst->thisobject);
3882 }
3883 Tcl_AppendElement(interp, thisinst->thisobject->name);
3884 }
3885 else {
3886 for (i = 0; i < areawin->selects; i++) {
3887 if (SELECTTYPE(areawin->selectlist + i) == OBJINST) {
3888 thisinst = SELTOOBJINST(areawin->selectlist + i);
3889 Tcl_AppendElement(interp, thisinst->thisobject->name);
3890 }
3891 }
3892 }
3893 break;
3894 case PartsIdx:
3895 /* Make a list of the handles of all parts in the object */
3896 if (nidx == 1 || areawin->selects == 0) {
3897 plist = Tcl_NewListObj(0, NULL);
3898 for (j = 0; j < thisinst->thisobject->parts; j++) {
3899 hobj = Tcl_NewHandleObj(*(thisinst->thisobject->plist + j));
3900 Tcl_ListObjAppendElement(interp, plist, hobj);
3901 }
3902 Tcl_SetObjResult(interp, plist);
3903 }
3904 else {
3905 ilist = Tcl_NewListObj(0, NULL);
3906 for (i = 0; i < areawin->selects; i++) {
3907 if (SELECTTYPE(areawin->selectlist + i) == OBJINST) {
3908 objinstptr thisinst = SELTOOBJINST(areawin->selectlist + i);
3909 Tcl_ListObjAppendElement(interp, ilist,
3910 Tcl_NewStringObj(thisinst->thisobject->name,
3911 strlen(thisinst->thisobject->name)));
3912 plist = Tcl_NewListObj(0, NULL);
3913 for (j = 0; j < thisinst->thisobject->parts; j++) {
3914 hobj = Tcl_NewHandleObj(*(thisinst->thisobject->plist + j));
3915 Tcl_ListObjAppendElement(interp, plist, hobj);
3916 }
3917 Tcl_ListObjAppendElement(interp, ilist, plist);
3918 }
3919 }
3920 Tcl_SetObjResult(interp, ilist);
3921 }
3922 break;
3923 }
3924 return XcTagCallback(interp, objc, objv);
3925 }
3926
3927 /*----------------------------------------------------------------------*/
3928 /* Get anchoring (or associated fields) global setting, or apply */
3929 /* to selected labels. */
3930 /*----------------------------------------------------------------------*/
3931
3932 int
3933 getanchoring(Tcl_Interp *interp, short bitfield)
3934 {
3935 int i, rval;
3936 labelptr tlab;
3937
3938 if (areawin->selects == 0) {
3939 if (bitfield & RIGHT) {
3940 Tcl_AppendElement(interp, (areawin->anchor & RIGHT) ?
3941 "right" : (areawin->anchor & NOTLEFT) ? "center" : "left");
3942 }
3943 else if (bitfield & TOP) {
3944 Tcl_AppendElement(interp, (areawin->anchor & TOP) ?
3945 "top" : (areawin->anchor & NOTBOTTOM) ? "middle" : "bottom");
3946 }
3947 else if (bitfield & JUSTIFYRIGHT) {
3948 Tcl_AppendElement(interp, (areawin->anchor & JUSTIFYRIGHT) ? "right" :
3949 (areawin->anchor & TEXTCENTERED) ? "center" :
3950 (areawin->anchor & JUSTIFYBOTH) ? "both" :
3951 "left");
3952 }
3953 else {
3954 Tcl_AppendElement(interp, (areawin->anchor & bitfield) ?
3955 "true" : "false");
3956 }
3957 return (areawin->anchor & bitfield);
3958 }
3959 for (i = 0; i < areawin->selects; i++) {
3960 if (SELECTTYPE(areawin->selectlist + i) != LABEL) continue;
3961 tlab = SELTOLABEL(areawin->selectlist + i);
3962 if (bitfield == PINVISIBLE && tlab->pin == NORMAL) continue;
3963 if (bitfield & RIGHT) {
3964 Tcl_AppendElement(interp, (tlab->anchor & RIGHT) ?
3965 "right" : (tlab->anchor & NOTLEFT) ? "center" : "left");
3966 }
3967 else if (bitfield & TOP) {
3968 Tcl_AppendElement(interp, (tlab->anchor & TOP) ?
3969 "top" : (tlab->anchor & NOTBOTTOM) ? "middle" : "bottom");
3970 }
3971 else if (bitfield & JUSTIFYRIGHT) {
3972 Tcl_AppendElement(interp, (tlab->anchor & JUSTIFYRIGHT) ? "right" :
3973 (tlab->anchor & TEXTCENTERED) ? "center" :
3974 (tlab->anchor & JUSTIFYBOTH) ? "both" :
3975 "left");
3976 }
3977 else {
3978 Tcl_AppendElement(interp, (tlab->anchor & bitfield) ? "true" : "false");
3979 }
3980 rval = tlab->anchor;
3981 }
3982 return (rval & bitfield);
3983 }
3984
3985
3986 /*----------------------------------------------------------------------*/
3987 /* Set anchoring (and associated fields) global setting, or apply */
3988 /* to selected labels. */
3989 /*----------------------------------------------------------------------*/
3990
3991 void
3992 setanchoring(short bitfield, short value)
3993 {
3994 int i;
3995 labelptr tlab;
3996
3997 if (areawin->selects == 0) {
3998 areawin->anchor &= (~bitfield);
3999 if (value > 0) areawin->anchor |= value;
4000 return;
4001 }
4002 for (i = 0; i < areawin->selects; i++) {
4003 if (SELECTTYPE(areawin->selectlist + i) != LABEL) continue;
4004 tlab = SELTOLABEL(areawin->selectlist + i);
4005 if (bitfield == PINVISIBLE && tlab->pin == NORMAL) continue;
4006 tlab->anchor &= (~bitfield);
4007 if (value > 0) tlab->anchor |= value;
4008 }
4009 }
4010
4011 /*----------------------------------------------------------------------*/
4012 /* Translate the label encoding bits to a string that the Tcl routine */
4013 /* will recognize from the command line. */
4014 /* */
4015 /* (note to self---is there a good way to not have to declare these */
4016 /* constant character arrays twice in two different routines?) */
4017 /*----------------------------------------------------------------------*/
4018
4019 char *
4020 translateencoding(int psfont)
4021 {
4022 const char *encValues[] = {"Standard", "special", "ISOLatin1",
4023 "ISOLatin2", "ISOLatin3", "ISOLatin4", "ISOLatin5",
4024 "ISOLatin6", "ISO8859-5", NULL};
4025 int i;
4026
4027 i = (fonts[psfont].flags & 0xf80) >> 7;
4028 if (i < 0) return NULL;
4029 return (char *)encValues[i];
4030 }
4031
4032 /*----------------------------------------------------------------------*/
4033 /* Translate the label style bits to a string that the Tcl routine */
4034 /* will recognize from the command line. */
4035 /*----------------------------------------------------------------------*/
4036
4037 char *
4038 translatestyle(int psfont)
4039 {
4040 const char *styValues[] = {"normal", "bold", "italic", "bolditalic", NULL};
4041 int i;
4042
4043 i = fonts[psfont].flags & 0x3;
4044 if (i < 0) return NULL;
4045 return (char *)styValues[i];
4046 }
4047
4048 /*----------------------------------------------------------------------*/
4049 /* Individual element handling. */
4050 /*----------------------------------------------------------------------*/
4051
4052 int xctcl_label(ClientData clientData, Tcl_Interp *interp,
4053 int objc, Tcl_Obj *CONST objv[])
4054 {
4055 int i, idx, idx2, nidx, result, value, jval, jval2;
4056 double tmpdbl;
4057 char *tmpstr;
4058 Tcl_Obj *objPtr, *listPtr;
4059 labelptr tlab;
4060
4061 static char *subCmds[] = {"make", "type", "insert", "anchor", "justify",
4062 "flipinvariant", "visible", "font", "scale", "encoding", "style",
4063 "family", "substring", "text", "latex", "list", "replace", "position",
4064 NULL};
4065 enum SubIdx {
4066 MakeIdx, TypeIdx, InsertIdx, AnchorIdx, JustifyIdx, FlipIdx, VisibleIdx,
4067 FontIdx, ScaleIdx, EncodingIdx, StyleIdx, FamilyIdx, SubstringIdx,
4068 TextIdx, LaTeXIdx, ListIdx, ReplaceIdx, PositionIdx
4069 };
4070
4071 /* These must match the order of string part types defined in xcircuit.h */
4072 static char *subsubCmds[] = {"text", "subscript", "superscript",
4073 "normalscript", "underline", "overline", "noline", "stop",
4074 "forward", "backward", "halfspace", "quarterspace", "return",
4075 "name", "scale", "color", "margin", "kern", "parameter",
4076 "special", NULL};
4077
4078 static char *pinTypeNames[] = {"normal", "text", "local", "pin", "global",
4079 "info", "netlist", NULL};
4080
4081 static int pinTypes[] = {NORMAL, NORMAL, LOCAL, LOCAL, GLOBAL, INFO, INFO};
4082
4083 static char *anchorValues[] = {"left", "center", "right", "top", "middle",
4084 "bottom", NULL};
4085
4086 static char *justifyValues[] = {"left", "center", "right", "both", NULL};
4087
4088 const char *styValues[] = {"normal", "bold", "italic", "bolditalic", NULL};
4089
4090 const char *encValues[] = {"Standard", "special", "ISOLatin1",
4091 "ISOLatin2", "ISOLatin3", "ISOLatin4", "ISOLatin5",
4092 "ISOLatin6", "ISO8859-5", NULL};
4093
4094 /* Tk "label" has been renamed to "tcl_label", but we want to */
4095 /* consider the "label" command to be overloaded, such that the */
4096 /* command "label" may be used without reference to technology. */
4097
4098 Tcl_Obj **newobjv = (Tcl_Obj **)Tcl_Alloc(objc * sizeof(Tcl_Obj *));
4099
4100 newobjv[0] = Tcl_NewStringObj("tcl_label", 9);
4101 Tcl_IncrRefCount(newobjv[0]);
4102 for (i = 1; i < objc; i++) {
4103 if (Tcl_IsShared(objv[i]))
4104 newobjv[i] = Tcl_DuplicateObj(objv[i]);
4105 else
4106 newobjv[i] = objv[i];
4107 Tcl_IncrRefCount(newobjv[i]);
4108 }
4109
4110 result = Tcl_EvalObjv(interp, objc, newobjv, 0);
4111
4112 for (i = 0; i < objc; i++)
4113 Tcl_DecrRefCount(newobjv[i]);
4114 Tcl_Free((char *)newobjv);
4115
4116 if (result == TCL_OK) return result;
4117 Tcl_ResetResult(interp);
4118
4119 /* Now, assuming that Tcl didn't like the syntax, we continue on with */
4120 /* our own version. */
4121
4122 nidx = 4;
4123 result = ParseElementArguments(interp, objc, objv, &nidx, LABEL);
4124 if (result != TCL_OK) return result;
4125
4126 if ((result = Tcl_GetIndexFromObj(interp, objv[nidx],
4127 (CONST84 char **)subCmds, "option", 0, &idx)) != TCL_OK)
4128 return result;
4129
4130 /* If there are no selections at this point, check if the command is */
4131 /* appropriate for setting a default value. */
4132
4133 switch (idx) {
4134 case MakeIdx:
4135 if ((areawin->selects == 0) && (nidx == 1)) {
4136 if (objc != 2) {
4137 result = Tcl_GetIndexFromObj(interp, objv[2],
4138 (CONST84 char **)pinTypeNames, "pin type", 0, &idx2);
4139 if (result != TCL_OK) {
4140 if (objc == 3) return result;
4141 else {
4142 Tcl_ResetResult(interp);
4143 idx2 = 0;
4144 }
4145 }
4146 else {
4147 nidx++;
4148 idx2 = pinTypes[idx2]; /* idx2 now matches defs in xcircuit.h */
4149 }
4150 }
4151 if ((objc != 4) && (objc != 5)) {
4152 Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
4153 return TCL_ERROR;
4154 }
4155 else {
4156 labelptr newlab;
4157 stringpart *strptr = NULL;
4158 XPoint position;
4159
4160 if ((result = GetXCStringFromList(interp, objv[nidx + 1],
4161 &strptr)) != TCL_OK)
4162 return result;
4163
4164 /* Should probably have some mechanism to create an empty */
4165 /* string from a script, even though empty strings are */
4166 /* disallowed from the GUI. */
4167
4168 if (strptr == NULL) {
4169 Tcl_SetResult(interp, "Empty string. No element created.", NULL);
4170 break;
4171 }
4172 if ((objc - nidx) <= 2) {
4173 Tcl_WrongNumArgs(interp, 3, objv, "<text> {position}");
4174 return TCL_ERROR;
4175 }
4176
4177 if ((result = GetPositionFromList(interp, objv[nidx + 2],
4178 &position)) != TCL_OK)
4179 return result;
4180
4181 newlab = new_label(NULL, strptr, idx2, position.x, position.y,
4182 (u_char)1);
4183 singlebbox((genericptr *)&newlab);
4184 objPtr = Tcl_NewHandleObj(newlab);
4185 Tcl_SetObjResult(interp, objPtr);
4186 }
4187 }
4188 else if (nidx == 2) {
4189 Tcl_SetResult(interp, "\"label <handle> make\" is illegal", NULL);
4190 return TCL_ERROR;
4191 }
4192 else {
4193 Tcl_SetResult(interp, "No selections allowed", NULL);
4194 return TCL_ERROR;
4195 }
4196 break;
4197
4198 case ScaleIdx:
4199 if (objc == 2) {
4200 if ((areawin->selects == 0) && (nidx == 1) &&
4201 eventmode != TEXT_MODE && eventmode != ETEXT_MODE) {
4202 objPtr = Tcl_NewDoubleObj((double)areawin->textscale);
4203 Tcl_SetObjResult(interp, objPtr);
4204 }
4205 else {
4206 float *floatptr;
4207 gettextsize(&floatptr);
4208 objPtr = Tcl_NewDoubleObj((double)((float)(*floatptr)));
4209 Tcl_SetObjResult(interp, objPtr);
4210 }
4211 }
4212 else if (objc >= 3) {
4213 result = Tcl_GetDoubleFromObj(interp, objv[nidx + 1], &tmpdbl);
4214 if (result != TCL_OK) return result;
4215 if (tmpdbl <= 0.0) {
4216 Tcl_SetResult(interp, "Illegal scale value", NULL);
4217 return TCL_ERROR;
4218 }
4219
4220 if ((areawin->selects == 0) && (nidx == 1) && (eventmode != TEXT_MODE)
4221 && (eventmode != ETEXT_MODE))
4222 areawin->textscale = (float)tmpdbl;
4223 else
4224 changetextscale((float)tmpdbl);
4225 }
4226 break;
4227
4228 case FontIdx:
4229 if (objc == 2) {
4230 tmpstr = fonts[areawin->psfont].psname;
4231 objPtr = Tcl_NewStringObj(tmpstr, strlen(tmpstr));
4232 Tcl_SetObjResult(interp, objPtr);
4233 }
4234 else {
4235 tmpstr = Tcl_GetString(objv[2]);
4236 for (i = 0; i < fontcount; i++)
4237 if (!strcmp(fonts[i].psname, tmpstr)) break;
4238 setfont((Tk_Window)clientData, (u_int)i, NULL);
4239 }
4240 break;
4241
4242 case FamilyIdx:
4243
4244 /* Check for "-all" switch */
4245 if ((objc - nidx) == 2) {
4246 tmpstr = Tcl_GetString(objv[nidx + 1]);
4247 if (!strncmp(tmpstr, "-all", 4)) {
4248
4249 /* Create a list of all font families. This does a simple */
4250 /* check against contiguous entries, but the result is not */
4251 /* guaranteed to be a list of unique entries (i.e., the */
4252 /* calling script should sort the list) */
4253
4254 for (i = 0; i < fontcount; i++) {
4255 if (i == 0 || strcmp(fonts[i].family, fonts[i-1].family))
4256 Tcl_AppendElement(interp, fonts[i].family);
4257 }
4258 break;
4259 }
4260 }
4261
4262 if (objc == 2) {
4263 tmpstr = fonts[areawin->psfont].family;
4264 objPtr = Tcl_NewStringObj(tmpstr, strlen(tmpstr));
4265 Tcl_SetObjResult(interp, objPtr);
4266 }
4267 else {
4268 tmpstr = Tcl_GetString(objv[2]);
4269 for (i = 0; i < fontcount; i++)
4270 if (!strcmp(fonts[i].family, tmpstr)) break;
4271 setfont((Tk_Window)clientData, (u_int)i, NULL);
4272 }
4273 break;
4274
4275 case EncodingIdx:
4276 if (objc == 2) {
4277 tmpstr = translateencoding(areawin->psfont);
4278 objPtr = Tcl_NewStringObj(tmpstr, -1);
4279 Tcl_SetObjResult(interp, objPtr);
4280 }
4281 else {
4282 if (Tcl_GetIndexFromObj(interp, objv[2],
4283 (CONST84 char **)encValues, "encodings", 0,
4284 &idx2) != TCL_OK) {
4285 return TCL_ERROR;
4286 }
4287 fontencoding((Tk_Window)clientData, idx2, NULL);
4288 refresh(NULL, NULL, NULL);
4289 }
4290 break;
4291
4292 case StyleIdx:
4293 if (objc == 2) {
4294 tmpstr = translatestyle(areawin->psfont);
4295 objPtr = Tcl_NewStringObj(tmpstr, -1);
4296 Tcl_SetObjResult(interp, objPtr);
4297 }
4298 else {
4299 if (Tcl_GetIndexFromObj(interp, objv[2],
4300 (CONST84 char **)styValues,
4301 "styles", 0, &idx2) != TCL_OK) {
4302 return TCL_ERROR;
4303 }
4304 fontstyle((Tk_Window)clientData, idx2, NULL);
4305 }
4306 break;
4307
4308 case TypeIdx: /* Change type of label */
4309 if ((areawin->selects == 0) && (nidx == 1)) {
4310 Tcl_SetResult(interp, "Must have a label selection.", NULL);
4311 return TCL_ERROR;
4312 }
4313 if (objc == nidx + 1) { /* Return pin type(s) */
4314 for (i = 0; i < areawin->selects; i++) {
4315 if (SELECTTYPE(areawin->selectlist + i) != LABEL) continue;
4316 tlab = SELTOLABEL(areawin->selectlist + i);
4317 for (idx2 = 0; idx2 < sizeof(pinTypeNames); idx2++) {
4318 if (tlab->pin == pinTypes[idx2]) {
4319 Tcl_AppendElement(interp, pinTypeNames[idx2]);
4320 break;
4321 }
4322 }
4323 }
4324 }
4325 else {
4326 if (Tcl_GetIndexFromObj(interp, objv[nidx + 1],
4327 (CONST84 char **)pinTypeNames,
4328 "pin types", 0, &idx2) != TCL_OK) {
4329 return TCL_ERROR;
4330 }
4331 for (i = 0; i < areawin->selects; i++) {
4332 if (SELECTTYPE(areawin->selectlist + i) != LABEL) continue;
4333 tlab = SELTOLABEL(areawin->selectlist + i);
4334 tlab->pin = pinTypes[idx2];
4335 pinconvert(tlab, tlab->pin);
4336 setobjecttype(topobject);
4337 }
4338 }
4339 break;
4340
4341 case InsertIdx: /* Text insertion */
4342 if (nidx != 1) {
4343 Tcl_SetResult(interp, "Insertion into handle or selection"
4344 " not supported (yet)", NULL);
4345 return TCL_ERROR;
4346 }
4347 if (eventmode != TEXT_MODE && eventmode != ETEXT_MODE) {
4348 Tcl_SetResult(interp, "Must be in edit mode to insert into label.",
4349 NULL);
4350 return TCL_ERROR;
4351 }
4352 if (objc <= nidx + 1) {
4353 Tcl_WrongNumArgs(interp, 2, objv, "insert_type");
4354 return TCL_ERROR;
4355 }
4356 if (Tcl_GetIndexFromObj(interp, objv[nidx + 1],
4357 (CONST84 char **)subsubCmds,
4358 "insertions", 0, &idx2) != TCL_OK) {
4359 return TCL_ERROR;
4360 }
4361 if ((idx2 > TEXT_STRING) && (idx2 < FONT_NAME) && (objc - nidx == 2)) {
4362 labeltext(idx2, (char *)1);
4363 }
4364 else if (idx2 == MARGINSTOP) {
4365 if (objc - nidx == 3) {
4366 result = Tcl_GetIntFromObj(interp, objv[nidx + 2], &value);
4367 if (result != TCL_OK) return result;
4368 }
4369 else value = 1;
4370 labeltext(idx2, (char *)&value);
4371 }
4372 else if ((idx2 == PARAM_START) && (objc - nidx == 3)) {
4373 labeltext(idx2, Tcl_GetString(objv[nidx + 2]));
4374 }
4375 else if ((idx2 == FONT_COLOR) && (objc - nidx == 3)) {
4376 result = GetColorFromObj(interp, objv[nidx + 2], &value, TRUE);
4377 if (result != TCL_OK) return result;
4378 labeltext(idx2, (char *)&value);
4379 }
4380 else if ((idx2 == FONT_NAME) && (objc - nidx == 3)) {
4381 tmpstr = Tcl_GetString(objv[nidx + 2]);
4382 for (i = 0; i < fontcount; i++)
4383 if (!strcmp(fonts[i].psname, tmpstr)) break;
4384 if (i == fontcount) {
4385 Tcl_SetResult(interp, "Invalid font name.", NULL);
4386 return TCL_ERROR;
4387 }
4388 else
4389 labeltext(idx2, (char *)&i);
4390 }
4391 else if ((idx2 == FONT_SCALE) && (objc - nidx == 3)) {
4392 float fvalue;
4393 double dvalue;
4394 result = Tcl_GetDoubleFromObj(interp, objv[nidx + 2], &dvalue);
4395 if (result != TCL_OK) return result;
4396 fvalue = (float)dvalue;
4397 labeltext(idx2, (char *)&fvalue);
4398 }
4399 else if ((idx2 == KERN) && (objc - nidx == 3)) {
4400 strcpy(_STR2, Tcl_GetString(objv[nidx + 2]));
4401 setkern(NULL, NULL);
4402 }
4403 else if ((idx2 == TEXT_STRING) && (objc - nidx == 3)) {
4404 char *substring = Tcl_GetString(objv[nidx + 2]);
4405 for (i = 0; i < strlen(substring); i++) {
4406 /* Special handling allows newlines from cutbuffer selections */
4407 /* to be translated into embedded carriage returns. */
4408 if (substring[i] == '\012')
4409 labeltext(RETURN, (char *)1);
4410 else
4411 labeltext(substring[i], NULL);
4412 }
4413 }
4414
4415 /* PARAM_END in xcircuit.h is actually mapped to the same */
4416 /* position as "special" in subsubCommands[] above; don't */
4417 /* be confused. . . */
4418
4419 else if ((idx2 == PARAM_END) && (objc - nidx == 2)) {
4420 dospecial();
4421 }
4422 else if ((idx2 == PARAM_END) && (objc - nidx == 3)) {
4423 result = Tcl_GetIntFromObj(interp, objv[nidx + 2], &value);
4424 if (result != TCL_OK) return result;
4425 labeltext(value, NULL);
4426 }
4427 else {
4428 Tcl_WrongNumArgs(interp, 2, objv, "insertion_type ?arg ...?");
4429 return TCL_ERROR;
4430 }
4431 break;
4432
4433 case SubstringIdx:
4434 objPtr = Tcl_NewListObj(0, NULL);
4435 if (areawin != NULL && areawin->selects == 1) {
4436 if (SELECTTYPE(areawin->selectlist) == LABEL) {
4437 Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewIntObj(areawin->textend));
4438 Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewIntObj(areawin->textpos));
4439 }
4440 }
4441 Tcl_SetObjResult(interp, objPtr);
4442 break;
4443
4444 /* Fixed issue where LaTeX mode wasn't assigned to labels */
4445 /* by Agustín Campeny, April 2020 */
4446
4447 case VisibleIdx: /* Change visibility of pin */
4448 if (objc == nidx + 1)
4449 jval = getanchoring(interp, PINVISIBLE);
4450 else {
4451 if ((result = Tcl_GetBooleanFromObj(interp, objv[nidx + 1],
4452 &value)) != TCL_OK)
4453 return result;
4454 setanchoring(PINVISIBLE, (value) ? PINVISIBLE : NORMAL);
4455 }
4456 break;
4457
4458 case FlipIdx:
4459 if (objc == nidx + 1)
4460 jval = getanchoring(interp, FLIPINV);
4461 else {
4462 if ((result = Tcl_GetBooleanFromObj(interp, objv[nidx + 1],
4463 &value)) != TCL_OK)
4464 return result;
4465 setanchoring(FLIPINV, (value) ? FLIPINV : NORMAL);
4466 }
4467 break;
4468
4469 case LaTeXIdx:
4470 if (objc == nidx + 1)
4471 jval = getanchoring(interp, LATEXLABEL);
4472 else {
4473 if ((result = Tcl_GetBooleanFromObj(interp, objv[nidx + 1],
4474 &value)) != TCL_OK)
4475 return result;
4476 setanchoring(LATEXLABEL, (value) ? LATEXLABEL : NORMAL);
4477 }
4478 break;
4479
4480 case JustifyIdx:
4481 if (objc == nidx + 1) {
4482 jval = getanchoring(interp, JUSTIFYRIGHT | JUSTIFYBOTH | TEXTCENTERED);
4483 }
4484 else {
4485 if (Tcl_GetIndexFromObj(interp, objv[nidx + 1],
4486 (CONST84 char **)justifyValues,
4487 "justification", 0, &idx2) != TCL_OK) {
4488 return TCL_ERROR;
4489 }
4490 switch (idx2) {
4491 case 0: value = NORMAL; break;
4492 case 1: value = TEXTCENTERED; break;
4493 case 2: value = JUSTIFYRIGHT; break;
4494 case 3: value = JUSTIFYBOTH; break;
4495 }
4496 setanchoring(JUSTIFYRIGHT | JUSTIFYBOTH | TEXTCENTERED, value);
4497 refresh(NULL, NULL, NULL);
4498 }
4499 break;
4500
4501 case AnchorIdx:
4502 if (objc == nidx + 1) {
4503 jval = getanchoring(interp, RIGHT | NOTLEFT);
4504 jval2 = getanchoring(interp, TOP | NOTBOTTOM);
4505 }
4506 else {
4507 if (Tcl_GetIndexFromObj(interp, objv[nidx + 1],
4508 (CONST84 char **)anchorValues,
4509 "anchoring", 0, &idx2) != TCL_OK) {
4510 return TCL_ERROR;
4511 }
4512 switch (idx2) {
4513 case 0: value = NORMAL; break;
4514 case 1: value = NOTLEFT; break;
4515 case 2: value = NOTLEFT | RIGHT; break;
4516 case 3: value = NOTBOTTOM | TOP; break;
4517 case 4: value = NOTBOTTOM; break;
4518 case 5: value = NORMAL; break;
4519 }
4520 switch (idx2) {
4521 case 0: case 1: case 2:
4522 setanchoring(RIGHT | NOTLEFT, value);
4523 refresh(NULL, NULL, NULL);
4524 break;
4525 case 3: case 4: case 5:
4526 setanchoring(TOP | NOTBOTTOM, value);
4527 refresh(NULL, NULL, NULL);
4528 break;
4529 }
4530 }
4531 break;
4532
4533 case TextIdx:
4534 if ((areawin->selects == 0) && (nidx == 1)) {
4535 Tcl_SetResult(interp, "Must have a label selection.", NULL);
4536 return TCL_ERROR;
4537 }
4538 if (objc == nidx + 1) { /* Return label as printable string */
4539 char *tstr;
4540 objPtr = Tcl_NewListObj(0, NULL);
4541 for (i = 0; i < areawin->selects; i++) {
4542 if (SELECTTYPE(areawin->selectlist + i) != LABEL) continue;
4543 tlab = SELTOLABEL(areawin->selectlist + i);
4544 tstr = textprint(tlab->string, areawin->topinstance);
4545 Tcl_ListObjAppendElement(interp, objPtr,
4546 Tcl_NewStringObj(tstr, strlen(tstr)));
4547 free(tstr);
4548 }
4549 Tcl_SetObjResult(interp, objPtr);
4550 }
4551 break;
4552
4553 case ListIdx:
4554 if ((areawin->selects == 0) && (nidx == 1)) {
4555 Tcl_SetResult(interp, "Must have a label selection.", NULL);
4556 return TCL_ERROR;
4557 }
4558 if (objc == nidx + 1) { /* Return label as printable string */
4559 listPtr = Tcl_NewListObj(0, NULL);
4560 for (i = 0; i < areawin->selects; i++) {
4561 if (SELECTTYPE(areawin->selectlist + i) != LABEL) continue;
4562 tlab = SELTOLABEL(areawin->selectlist + i);
4563 objPtr = TclGetStringParts(tlab->string);
4564 Tcl_ListObjAppendElement(interp, listPtr, objPtr);
4565 }
4566 Tcl_SetObjResult(interp, listPtr);
4567 }
4568 break;
4569
4570 case ReplaceIdx: /* the opposite of "list" */
4571 if ((areawin->selects == 0) && (nidx == 1)) {
4572 Tcl_SetResult(interp, "Must have a label selection.", NULL);
4573 return TCL_ERROR;
4574 }
4575 if (objc == nidx + 2) { /* Replace string from list */
4576 stringpart *strptr = NULL;
4577
4578 if ((result = GetXCStringFromList(interp, objv[nidx + 1],
4579 &strptr)) != TCL_OK)
4580 return result;
4581
4582 for (i = 0; i < areawin->selects; i++) {
4583 if (SELECTTYPE(areawin->selectlist + i) != LABEL) continue;
4584 tlab = SELTOLABEL(areawin->selectlist + i);
4585 register_for_undo(XCF_Edit, UNDO_MORE, areawin->topinstance, tlab);
4586 freelabel(tlab->string);
4587 tlab->string = stringcopy(strptr);
4588 }
4589 freelabel(strptr);
4590 undo_finish_series();
4591 refresh(NULL, NULL, NULL);
4592 }
4593 break;
4594
4595 case PositionIdx:
4596 if ((areawin->selects == 0) && (nidx == 1)) {
4597 Tcl_SetResult(interp, "Must have a label selection.", NULL);
4598 return TCL_ERROR;
4599 }
4600 if (objc == nidx + 1) { /* Return position of label */
4601 Tcl_Obj *cpair;
4602
4603 listPtr = Tcl_NewListObj(0, NULL);
4604 for (i = 0; i < areawin->selects; i++) {
4605 if (SELECTTYPE(areawin->selectlist + i) != LABEL) continue;
4606 tlab = SELTOLABEL(areawin->selectlist + i);
4607 cpair = Tcl_NewListObj(0, NULL);
4608 objPtr = Tcl_NewIntObj((int)tlab->position.x);
4609 Tcl_ListObjAppendElement(interp, cpair, objPtr);
4610 objPtr = Tcl_NewIntObj((int)tlab->position.y);
4611 Tcl_ListObjAppendElement(interp, cpair, objPtr);
4612 Tcl_ListObjAppendElement(interp, listPtr, cpair);
4613 }
4614 Tcl_SetObjResult(interp, listPtr);
4615 }
4616 else if (objc == nidx + 2) { /* Change position of label */
4617 XPoint position;
4618
4619 if ((areawin->selects != 1) || (SELECTTYPE(areawin->selectlist)
4620 != LABEL)) {
4621 Tcl_SetResult(interp, "Must have exactly one selected label", NULL);
4622 return TCL_ERROR;
4623 }
4624 if ((result = GetPositionFromList(interp, objv[nidx + 1],
4625 &position)) != TCL_OK)
4626 return result;
4627
4628 tlab = SELTOLABEL(areawin->selectlist);
4629 tlab->position.x = position.x;
4630 tlab->position.y = position.y;
4631 }
4632 break;
4633 }
4634 return XcTagCallback(interp, objc, objv);
4635 }
4636
4637 /*----------------------------------------------------------------------*/
4638 /* Element Fill Styles */
4639 /*----------------------------------------------------------------------*/
4640
4641 int xctcl_dofill(ClientData clientData, Tcl_Interp *interp,
4642 int objc, Tcl_Obj *CONST objv[])
4643 {
4644 u_int value;
4645 int i, idx, result, rval = -1;
4646
4647 static char *Styles[] = {"opaque", "transparent", "filled", "unfilled",
4648 "solid", NULL};
4649 enum StylesIdx {
4650 OpaqueIdx, TransparentIdx, FilledIdx, UnfilledIdx, SolidIdx
4651 };
4652
4653 if (objc == 1) {
4654 value = areawin->style;
4655 Tcl_AppendElement(interp, ((value & OPAQUE) ? "opaque" : "transparent"));
4656 if (value & FILLED) {
4657 Tcl_AppendElement(interp, "filled");
4658 switch (value & FILLSOLID) {
4659 case 0:
4660 Tcl_AppendElement(interp, "12"); break;
4661 case STIP0:
4662 Tcl_AppendElement(interp, "25"); break;
4663 case STIP1:
4664 Tcl_AppendElement(interp, "37"); break;
4665 case STIP1 | STIP0:
4666 Tcl_AppendElement(interp, "50"); break;
4667 case STIP2:
4668 Tcl_AppendElement(interp, "62"); break;
4669 case STIP2 | STIP0:
4670 Tcl_AppendElement(interp, "75"); break;
4671 case STIP2 | STIP1:
4672 Tcl_AppendElement(interp, "87"); break;
4673 case FILLSOLID:
4674 Tcl_AppendElement(interp, "solid"); break;
4675 }
4676 }
4677 else {
4678 Tcl_AppendElement(interp, "unfilled");
4679 }
4680 return TCL_OK;
4681 }
4682
4683 for (i = 1; i < objc; i++) {
4684 if (Tcl_GetIndexFromObj(interp, objv[i],
4685 (CONST84 char **)Styles, "fill styles",
4686 0, &idx) != TCL_OK) {
4687 Tcl_ResetResult(interp);
4688 result = Tcl_GetIntFromObj(interp, objv[i], &value);
4689 if (result != TCL_OK) {
4690 Tcl_SetResult(interp, "Expected fill style or fillfactor 0 to 100", NULL);
4691 return result;
4692 }
4693 else {
4694 if (value >= 0 && value < 6) value = FILLSOLID;
4695 else if (value >= 6 && value < 19) value = FILLED;
4696 else if (value >= 19 && value < 31) value = FILLED | STIP0;
4697 else if (value >= 31 && value < 44) value = FILLED | STIP1;
4698 else if (value >= 44 && value < 56) value = FILLED | STIP0 | STIP1;
4699 else if (value >= 56 && value < 69) value = FILLED | STIP2;
4700 else if (value >= 69 && value < 81) value = FILLED | STIP2 | STIP0;
4701 else if (value >= 81 && value < 94) value = FILLED | STIP2 | STIP1;
4702 else if (value >= 94 && value <= 100) value = FILLED | FILLSOLID;
4703 else {
4704 Tcl_SetResult(interp, "Fill value should be 0 to 100", NULL);
4705 return TCL_ERROR;
4706 }
4707 rval = setelementstyle((Tk_Window)clientData, (pointertype)value,
4708 FILLED | FILLSOLID);
4709 }
4710 }
4711 else {
4712 switch(idx) {
4713 case OpaqueIdx:
4714 rval = setelementstyle((Tk_Window)clientData, OPAQUE, OPAQUE);
4715 break;
4716 case TransparentIdx:
4717 rval = setelementstyle((Tk_Window)clientData, NORMAL, OPAQUE);
4718 break;
4719 case UnfilledIdx:
4720 rval = setelementstyle((Tk_Window)clientData, FILLSOLID,
4721 FILLED | FILLSOLID);
4722 break;
4723 case SolidIdx:
4724 rval = setelementstyle((Tk_Window)clientData, FILLED | FILLSOLID,
4725 FILLED | FILLSOLID);
4726 break;
4727 case FilledIdx:
4728 break;
4729 }
4730 }
4731 }
4732 if (rval < 0)
4733 return TCL_ERROR;
4734
4735 return XcTagCallback(interp, objc, objv);
4736 }
4737
4738 /*----------------------------------------------------------------------*/
4739 /* Element border styles */
4740 /*----------------------------------------------------------------------*/
4741
4742 int xctcl_doborder(ClientData clientData, Tcl_Interp *interp,
4743 int objc, Tcl_Obj *CONST objv[])
4744 {
4745 int result, i, idx, value, rval = -1;
4746 u_short mask;
4747 double wvalue;
4748
4749 static char *borderStyles[] = {"solid", "dashed", "dotted", "none",
4750 "unbordered", "unclosed", "closed", "bbox", "set", "get", "square",
4751 "round", "clipmask", NULL};
4752 enum StyIdx {
4753 SolidIdx, DashedIdx, DottedIdx, NoneIdx, UnborderedIdx,
4754 UnclosedIdx, ClosedIdx, BBoxIdx, SetIdx, GetIdx, SquareIdx,
4755 RoundIdx, ClipMaskIdx
4756 };
4757
4758 if (objc == 1) {
4759 Tcl_Obj *listPtr;
4760 listPtr = Tcl_NewListObj(0, NULL);
4761 value = areawin->style;
4762 wvalue = (double)areawin->linewidth;
4763 switch (value & (DASHED | DOTTED | NOBORDER | SQUARECAP)) {
4764 case NORMAL:
4765 Tcl_ListObjAppendElement(interp, listPtr,
4766 Tcl_NewStringObj("solid", 5)); break;
4767 case DASHED:
4768 Tcl_ListObjAppendElement(interp, listPtr,
4769 Tcl_NewStringObj("dashed", 6)); break;
4770 case DOTTED:
4771 Tcl_ListObjAppendElement(interp, listPtr,
4772 Tcl_NewStringObj("dotted", 6)); break;
4773 case NOBORDER:
4774 Tcl_ListObjAppendElement(interp, listPtr,
4775 Tcl_NewStringObj("unbordered", 10)); break;
4776 case SQUARECAP:
4777 Tcl_ListObjAppendElement(interp, listPtr,
4778 Tcl_NewStringObj("square-endcaps", 10)); break;
4779 }
4780 if (value & UNCLOSED)
4781 Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj("unclosed", 8));
4782 else
4783 Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj("closed", 6));
4784
4785 if (value & BBOX)
4786 Tcl_ListObjAppendElement(interp, listPtr,
4787 Tcl_NewStringObj("bounding box", 12));
4788
4789 if (value & CLIPMASK)
4790 Tcl_ListObjAppendElement(interp, listPtr,
4791 Tcl_NewStringObj("clipmask", 8));
4792
4793 Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewDoubleObj(wvalue));
4794 Tcl_SetObjResult(interp, listPtr);
4795 return TCL_OK;
4796 }
4797
4798 for (i = 1; i < objc; i++) {
4799 result = Tcl_GetIndexFromObj(interp, objv[i],
4800 (CONST84 char **)borderStyles,
4801 "border style", 0, &idx);
4802 if (result != TCL_OK)
4803 return result;
4804
4805 switch (idx) {
4806 case GetIdx:
4807 {
4808 int j, numfound = 0;
4809 genericptr setel;
4810 Tcl_Obj *objPtr, *listPtr = NULL;
4811
4812 for (j = 0; j < areawin->selects; j++) {
4813 setel = SELTOGENERIC(areawin->selectlist + j);
4814 if (IS_ARC(setel) || IS_POLYGON(setel) ||
4815 IS_SPLINE(setel) || IS_PATH(setel)) {
4816 switch(ELEMENTTYPE(setel)) {
4817 case ARC: wvalue = ((arcptr)setel)->width; break;
4818 case POLYGON: wvalue = ((polyptr)setel)->width; break;
4819 case SPLINE: wvalue = ((splineptr)setel)->width; break;
4820 case PATH: wvalue = ((pathptr)setel)->width; break;
4821 }
4822 if ((++numfound) == 2) {
4823 listPtr = Tcl_NewListObj(0, NULL);
4824 Tcl_ListObjAppendElement(interp, listPtr, objPtr);
4825 }
4826 objPtr = Tcl_NewDoubleObj(wvalue);
4827 if (numfound > 1)
4828 Tcl_ListObjAppendElement(interp, listPtr, objPtr);
4829 }
4830 }
4831 switch (numfound) {
4832 case 0:
4833 objPtr = Tcl_NewDoubleObj(areawin->linewidth);
4834 /* fall through */
4835 case 1:
4836 Tcl_SetObjResult(interp, objPtr);
4837 break;
4838 default:
4839 Tcl_SetObjResult(interp, listPtr);
4840 break;
4841 }
4842 }
4843 break;
4844 case SetIdx:
4845 if ((objc - i) != 2) {
4846 Tcl_SetResult(interp, "Error: no linewidth given.", NULL);
4847 return TCL_ERROR;
4848 }
4849 result = Tcl_GetDoubleFromObj(interp, objv[++i], &wvalue);
4850 if (result == TCL_OK) {
4851 sprintf(_STR2, "%f", wvalue);
4852 setwwidth((Tk_Window)clientData, NULL);
4853 }
4854 else {
4855 Tcl_SetResult(interp, "Error: invalid border linewidth.", NULL);
4856 return TCL_ERROR;
4857 }
4858 break;
4859 case SolidIdx: value = NORMAL; mask = DASHED | DOTTED | NOBORDER; break;
4860 case DashedIdx: value = DASHED; mask = DASHED | DOTTED | NOBORDER; break;
4861 case DottedIdx: value = DOTTED; mask = DASHED | DOTTED | NOBORDER; break;
4862 case NoneIdx: case UnborderedIdx:
4863 value = NOBORDER; mask = DASHED | DOTTED | NOBORDER; break;
4864 case UnclosedIdx: value = UNCLOSED; mask = UNCLOSED; break;
4865 case ClosedIdx: value = NORMAL; mask = UNCLOSED; break;
4866 case SquareIdx: value = SQUARECAP; mask = SQUARECAP; break;
4867 case RoundIdx: value = NORMAL; mask = SQUARECAP; break;
4868 case BBoxIdx:
4869 mask = BBOX;
4870 if ((objc - i) < 2) value = BBOX;
4871 else {
4872 char *yesno = Tcl_GetString(objv[++i]);
4873 value = (tolower(yesno[0]) == 'y' || tolower(yesno[0]) == 't') ?
4874 BBOX : NORMAL;
4875 }
4876 break;
4877 case ClipMaskIdx:
4878 mask = CLIPMASK;
4879 if ((objc - i) < 2) value = CLIPMASK;
4880 else {
4881 char *yesno = Tcl_GetString(objv[++i]);
4882 value = (tolower(yesno[0]) == 'y' || tolower(yesno[0]) == 't') ?
4883 CLIPMASK : NORMAL;
4884 }
4885 break;
4886 }
4887 if (idx != SetIdx && idx != GetIdx)
4888 rval = setelementstyle((Tk_Window)clientData, (u_short)value, mask);
4889 }
4890
4891 return XcTagCallback(interp, objc, objv);
4892 }
4893
4894 /*----------------------------------------------------------------------*/
4895
4896 int xctcl_polygon(ClientData clientData, Tcl_Interp *interp,
4897 int objc, Tcl_Obj *CONST objv[])
4898 {
4899 int idx, nidx, result, npoints, j;
4900 polyptr newpoly, ppoly;
4901 XPoint ppt;
4902 pointlist points;
4903 Tcl_Obj *objPtr, *coord, *cpair, **newobjv;
4904 Boolean is_box = FALSE;
4905 Matrix hierCTM;
4906
4907 static char *subCmds[] = {"make", "border", "fill", "points", "number", NULL};
4908 enum SubIdx {
4909 MakeIdx, BorderIdx, FillIdx, PointsIdx, NumberIdx
4910 };
4911
4912 nidx = 255;
4913 result = ParseElementArguments(interp, objc, objv, &nidx, POLYGON);
4914 if (result != TCL_OK) return result;
4915
4916 if ((result = Tcl_GetIndexFromObj(interp, objv[nidx],
4917 (CONST84 char **)subCmds,
4918 "option", 0, &idx)) != TCL_OK)
4919 return result;
4920
4921 switch (idx) {
4922 case MakeIdx:
4923 if ((areawin->selects == 0) && (nidx == 1)) {
4924 if (objc < 5) {
4925 Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
4926 return TCL_ERROR;
4927 }
4928 if (!strcmp(Tcl_GetString(objv[2]), "box")) {
4929 npoints = objc - 3;
4930 is_box = TRUE;
4931 if (npoints != 4 && npoints != 2) {
4932 Tcl_SetResult(interp, "Box must have 2 or 4 points", NULL);
4933 return TCL_ERROR;
4934 }
4935 }
4936 else {
4937 result = Tcl_GetIntFromObj(interp, objv[2], &npoints);
4938 if (result != TCL_OK) return result;
4939 }
4940 if (objc != npoints + 3) {
4941 Tcl_WrongNumArgs(interp, 1, objv, "N {x1 y1}...{xN yN}");
4942 return TCL_ERROR;
4943 }
4944 points = (pointlist)malloc(npoints * sizeof(XPoint));
4945 for (j = 0; j < npoints; j++) {
4946 result = GetPositionFromList(interp, objv[3 + j], &ppt);
4947 if (result == TCL_OK) {
4948 points[j].x = ppt.x;
4949 points[j].y = ppt.y;
4950 }
4951 }
4952 if (is_box && (npoints == 2)) {
4953 npoints = 4;
4954 points = (pointlist)realloc(points, npoints * sizeof(XPoint));
4955 points[2].x = points[1].x;
4956 points[2].y = points[1].y;
4957 points[1].y = points[0].y;
4958 points[3].x = points[0].x;
4959 points[3].y = points[2].y;
4960 }
4961 newpoly = new_polygon(NULL, &points, npoints);
4962 if (!is_box) newpoly->style |= UNCLOSED;
4963 singlebbox((genericptr *)&newpoly);
4964
4965 objPtr = Tcl_NewHandleObj(newpoly);
4966 Tcl_SetObjResult(interp, objPtr);
4967 }
4968 else if (nidx == 2) {
4969 Tcl_SetResult(interp, "\"polygon <handle> make\" is illegal", NULL);
4970 return TCL_ERROR;
4971 }
4972 else {
4973 Tcl_SetResult(interp, "No selections allowed", NULL);
4974 return TCL_ERROR;
4975 }
4976 break;
4977
4978 case BorderIdx:
4979 newobjv = (Tcl_Obj **)(&objv[nidx]);
4980 result = xctcl_doborder(clientData, interp, objc - nidx, newobjv);
4981 break;
4982
4983 case FillIdx:
4984 newobjv = (Tcl_Obj **)(&objv[nidx]);
4985 result = xctcl_dofill(clientData, interp, objc - nidx, newobjv);
4986 break;
4987
4988 case NumberIdx:
4989 if (areawin->selects != 1) {
4990 Tcl_SetResult(interp, "Must have exactly one selection to "
4991 "query points", NULL);
4992 return TCL_ERROR;
4993 }
4994 else {
4995 if (SELECTTYPE(areawin->selectlist) != POLYGON) {
4996 Tcl_SetResult(interp, "Selected element is not a polygon", NULL);
4997 return TCL_ERROR;
4998 }
4999 else
5000 ppoly = SELTOPOLY(areawin->selectlist);
5001
5002 if ((objc - nidx) == 1) {
5003 objPtr = Tcl_NewIntObj(ppoly->number);
5004 Tcl_SetObjResult(interp, objPtr);
5005 }
5006 else
5007 {
5008 Tcl_SetResult(interp, "Cannot change number of points.\n", NULL);
5009 return TCL_ERROR;
5010 }
5011 }
5012 break;
5013
5014 case PointsIdx:
5015 if (areawin->selects != 1) {
5016 Tcl_SetResult(interp, "Must have exactly one selection to "
5017 "query or manipulate points", NULL);
5018 return TCL_ERROR;
5019 }
5020 else {
5021 ppoly = SELTOPOLY(areawin->selectlist);
5022 MakeHierCTM(&hierCTM);
5023 if (ppoly->type != POLYGON) {
5024 Tcl_SetResult(interp, "Selected element is not a polygon", NULL);
5025 return TCL_ERROR;
5026 }
5027 points = ppoly->points;
5028
5029 if ((objc - nidx) == 1) /* Return a list of all points */
5030 {
5031 objPtr = Tcl_NewListObj(0, NULL);
5032 for (npoints = 0; npoints < ppoly->number; npoints++) {
5033 cpair = Tcl_NewListObj(0, NULL);
5034 UTransformbyCTM(&hierCTM, points + npoints, &ppt, 1);
5035 coord = Tcl_NewIntObj((int)ppt.x);
5036 Tcl_ListObjAppendElement(interp, cpair, coord);
5037 coord = Tcl_NewIntObj((int)ppt.y);
5038 Tcl_ListObjAppendElement(interp, cpair, coord);
5039 Tcl_ListObjAppendElement(interp, objPtr, cpair);
5040 }
5041 Tcl_SetObjResult(interp, objPtr);
5042 }
5043 else if ((objc - nidx) == 2) /* Return a specific point */
5044 {
5045 result = Tcl_GetIntFromObj(interp, objv[2], &npoints);
5046 if (result != TCL_OK) return result;
5047 if (npoints >= ppoly->number) {
5048 Tcl_SetResult(interp, "Point number out of range", NULL);
5049 return TCL_ERROR;
5050 }
5051 objPtr = Tcl_NewListObj(0, NULL);
5052 UTransformbyCTM(&hierCTM, points + npoints, &ppt, 1);
5053 coord = Tcl_NewIntObj((int)ppt.x);
5054 Tcl_ListObjAppendElement(interp, objPtr, coord);
5055 coord = Tcl_NewIntObj((int)ppt.y);
5056 Tcl_ListObjAppendElement(interp, objPtr, coord);
5057 Tcl_SetObjResult(interp, objPtr);
5058 }
5059 else
5060 {
5061 Tcl_SetResult(interp, "Individual point setting unimplemented\n", NULL);
5062 return TCL_ERROR;
5063 }
5064 }
5065 break;
5066 }
5067 return XcTagCallback(interp, objc, objv);
5068 }
5069
5070 /*----------------------------------------------------------------------*/
5071
5072 int xctcl_spline(ClientData clientData, Tcl_Interp *interp,
5073 int objc, Tcl_Obj *CONST objv[])
5074 {
5075 int idx, nidx, result, j, npoints;
5076 splineptr newspline, pspline;
5077 XPoint ppt, ctrlpoints[4];
5078 Tcl_Obj *objPtr, *cpair, *coord, **newobjv;
5079 Matrix hierCTM;
5080
5081 static char *subCmds[] = {"make", "border", "fill", "points", NULL};
5082 enum SubIdx {
5083 MakeIdx, BorderIdx, FillIdx, PointsIdx
5084 };
5085
5086 nidx = 5;
5087 result = ParseElementArguments(interp, objc, objv, &nidx, SPLINE);
5088 if (result != TCL_OK) return result;
5089
5090 if ((result = Tcl_GetIndexFromObj(interp, objv[nidx],
5091 (CONST84 char **)subCmds,
5092 "option", 0, &idx)) != TCL_OK)
5093 return result;
5094
5095 /* h = spline make {x1 y1} ... {x4 y4} */
5096
5097 switch (idx) {
5098 case MakeIdx:
5099 if ((areawin->selects == 0) && (nidx == 1)) {
5100 if (objc != 6) {
5101 Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
5102 return TCL_ERROR;
5103 }
5104 for (j = 0; j < 4; j++) {
5105 result = GetPositionFromList(interp, objv[2 + j], &ppt);
5106 if (result == TCL_OK) {
5107 ctrlpoints[j].x = ppt.x;
5108 ctrlpoints[j].y = ppt.y;
5109 }
5110 }
5111 newspline = new_spline(NULL, ctrlpoints);
5112 singlebbox((genericptr *)&newspline);
5113
5114 objPtr = Tcl_NewHandleObj(newspline);
5115 Tcl_SetObjResult(interp, objPtr);
5116 }
5117 else if (areawin->selects == 1) {
5118 if (ELEMENTTYPE(*(topobject->plist + (*areawin->selectlist))) == POLYGON) {
5119 converttocurve();
5120 }
5121 else {
5122 Tcl_SetResult(interp, "\"spline make\": must have a polygon selected",
5123 NULL);
5124 return TCL_ERROR;
5125 }
5126 }
5127 else if (nidx == 2) {
5128 Tcl_SetResult(interp, "\"spline <handle> make\" is illegal", NULL);
5129 return TCL_ERROR;
5130 }
5131 else {
5132 Tcl_SetResult(interp, "No selections allowed except single polygon", NULL);
5133 return TCL_ERROR;
5134 }
5135 break;
5136
5137 case BorderIdx:
5138 newobjv = (Tcl_Obj **)(&objv[nidx]);
5139 result = xctcl_doborder(clientData, interp, objc - nidx, newobjv);
5140 break;
5141
5142 case FillIdx:
5143 newobjv = (Tcl_Obj **)(&objv[nidx]);
5144 result = xctcl_dofill(clientData, interp, objc - nidx, newobjv);
5145 break;
5146
5147 case PointsIdx:
5148 if (areawin->selects != 1) {
5149 Tcl_SetResult(interp, "Must have exactly one selection to "
5150 "query or manipulate points", NULL);
5151 return TCL_ERROR;
5152 }
5153 else {
5154 /* check for ESPLINE mode? */
5155 if (SELECTTYPE(areawin->selectlist) != SPLINE) {
5156 Tcl_SetResult(interp, "Selected element is not a spline", NULL);
5157 return TCL_ERROR;
5158 }
5159 else
5160 pspline = SELTOSPLINE(areawin->selectlist);
5161
5162 MakeHierCTM(&hierCTM);
5163
5164 if ((objc - nidx) == 1) /* Return a list of all points */
5165 {
5166 objPtr = Tcl_NewListObj(0, NULL);
5167 for (npoints = 0; npoints < 4; npoints++) {
5168 cpair = Tcl_NewListObj(0, NULL);
5169 UTransformbyCTM(&hierCTM, pspline->ctrl + npoints, &ppt, 1);
5170 coord = Tcl_NewIntObj((int)ppt.x);
5171 Tcl_ListObjAppendElement(interp, cpair, coord);
5172 coord = Tcl_NewIntObj((int)ppt.y);
5173 Tcl_ListObjAppendElement(interp, cpair, coord);
5174 Tcl_ListObjAppendElement(interp, objPtr, cpair);
5175 }
5176 Tcl_SetObjResult(interp, objPtr);
5177 }
5178 else if ((objc - nidx) == 2) /* Return a specific point */
5179 {
5180 result = Tcl_GetIntFromObj(interp, objv[objc - nidx + 1], &npoints);
5181 if (result != TCL_OK) return result;
5182 if (npoints >= 4) {
5183 Tcl_SetResult(interp, "Point number out of range", NULL);
5184 return TCL_ERROR;
5185 }
5186 objPtr = Tcl_NewListObj(0, NULL);
5187 UTransformbyCTM(&hierCTM, pspline->ctrl + npoints, &ppt, 1);
5188 coord = Tcl_NewIntObj((int)ppt.x);
5189 Tcl_ListObjAppendElement(interp, objPtr, coord);
5190 coord = Tcl_NewIntObj((int)ppt.y);
5191 Tcl_ListObjAppendElement(interp, objPtr, coord);
5192 Tcl_SetObjResult(interp, objPtr);
5193 }
5194 else
5195 {
5196 Tcl_SetResult(interp, "Individual control point setting "
5197 "unimplemented\n", NULL);
5198 return TCL_ERROR;
5199 }
5200 }
5201 }
5202 return XcTagCallback(interp, objc, objv);
5203 }
5204
5205 /*----------------------------------------------------------------------*/
5206
5207 int xctcl_graphic(ClientData clientData, Tcl_Interp *interp,
5208 int objc, Tcl_Obj *CONST objv[])
5209 {
5210 int i, idx, nidx, result;
5211 double dvalue;
5212 graphicptr newgp, gp;
5213 XPoint ppt;
5214 Tcl_Obj *objPtr, *listPtr;
5215 char *filename;
5216
5217 static char *subCmds[] = {"make", "scale", "position", NULL};
5218 enum SubIdx {
5219 MakeIdx, ScaleIdx, PositionIdx
5220 };
5221
5222 nidx = 7;
5223 result = ParseElementArguments(interp, objc, objv, &nidx, GRAPHIC);
5224 if (result != TCL_OK) return result;
5225
5226 if ((result = Tcl_GetIndexFromObj(interp, objv[nidx],
5227 (CONST84 char **)subCmds,
5228 "option", 0, &idx)) != TCL_OK)
5229 return result;
5230
5231 switch (idx) {
5232 case MakeIdx:
5233 if ((areawin->selects == 0) && (nidx == 1)) {
5234 if ((objc != 5) && (objc != 7)) {
5235 Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
5236 return TCL_ERROR;
5237 }
5238
5239 filename = Tcl_GetString(objv[2]);
5240
5241 result = GetPositionFromList(interp, objv[3], &ppt);
5242 if (result != TCL_OK) return result;
5243
5244 result = Tcl_GetDoubleFromObj(interp, objv[4], &dvalue);
5245 if (result != TCL_OK) return result;
5246
5247 if (!strcmp(filename, "gradient")) {
5248 if (objc == 7) {
5249 int c1, c2;
5250 result = GetColorFromObj(interp, objv[5], &c1, TRUE);
5251 if (result != TCL_OK) return result;
5252 result = GetColorFromObj(interp, objv[6], &c2, TRUE);
5253 if (result != TCL_OK) return result;
5254 newgp = gradient_field(NULL, ppt.x, ppt.y, c1, c2);
5255 }
5256 else
5257 newgp = gradient_field(NULL, ppt.x, ppt.y, 0, 1);
5258 }
5259 else if (objc != 5) {
5260 Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
5261 return TCL_ERROR;
5262 }
5263 else
5264 newgp = new_graphic(NULL, filename, ppt.x, ppt.y);
5265
5266 if (newgp == NULL) return TCL_ERROR;
5267
5268 newgp->scale = (float)dvalue;
5269 singlebbox((genericptr *)&newgp);
5270
5271 objPtr = Tcl_NewHandleObj(newgp);
5272 Tcl_SetObjResult(interp, objPtr);
5273 }
5274 else if (nidx == 2) {
5275 Tcl_SetResult(interp, "\"graphic <handle> make\" is illegal", NULL);
5276 return TCL_ERROR;
5277 }
5278 else {
5279 Tcl_SetResult(interp, "No selections allowed", NULL);
5280 return TCL_ERROR;
5281 }
5282 break;
5283
5284 case ScaleIdx:
5285 case PositionIdx:
5286 if ((areawin->selects == 0) && (nidx == 1)) {
5287 Tcl_SetResult(interp, "Must have a graphic selection.", NULL);
5288 return TCL_ERROR;
5289 }
5290 if (objc == nidx + 1) { /* Return position of graphic origin */
5291 Tcl_Obj *cpair;
5292 graphicptr gp;
5293
5294 listPtr = Tcl_NewListObj(0, NULL);
5295 for (i = 0; i < areawin->selects; i++) {
5296 if (SELECTTYPE(areawin->selectlist + i) != GRAPHIC) continue;
5297 gp = SELTOGRAPHIC(areawin->selectlist + i);
5298
5299 switch (idx) {
5300 case ScaleIdx:
5301 objPtr = Tcl_NewDoubleObj(gp->scale);
5302 Tcl_ListObjAppendElement(interp, listPtr, objPtr);
5303 break;
5304 case PositionIdx:
5305 cpair = Tcl_NewListObj(0, NULL);
5306 objPtr = Tcl_NewIntObj((int)gp->position.x);
5307 Tcl_ListObjAppendElement(interp, cpair, objPtr);
5308 objPtr = Tcl_NewIntObj((int)gp->position.y);
5309 Tcl_ListObjAppendElement(interp, cpair, objPtr);
5310 Tcl_ListObjAppendElement(interp, listPtr, cpair);
5311 break;
5312 }
5313 }
5314 Tcl_SetObjResult(interp, listPtr);
5315 }
5316 else if (objc == nidx + 2) { /* Change position or scale */
5317 if (idx == ScaleIdx) {
5318 result = Tcl_GetDoubleFromObj(interp, objv[nidx + 1], &dvalue);
5319 if (result == TCL_OK) {
5320 for (i = 0; i < areawin->selects; i++) {
5321 float oldscale;
5322
5323 if (SELECTTYPE(areawin->selectlist + i) != GRAPHIC) continue;
5324 gp = SELTOGRAPHIC(areawin->selectlist + i);
5325 oldscale = gp->scale;
5326 gp->scale = (float)dvalue;
5327 if (gp->scale != oldscale) {
5328 #ifndef HAVE_CAIRO
5329 gp->valid = False;
5330 #endif /* !HAVE_CAIRO */
5331 drawarea(areawin->area, (caddr_t)clientData, (caddr_t)NULL);
5332 calcbboxvalues(areawin->topinstance,
5333 topobject->plist + *(areawin->selectlist + i));
5334 register_for_undo(XCF_Rescale, UNDO_MORE, areawin->topinstance,
5335 (genericptr)gp, (double)oldscale);
5336 }
5337 }
5338 undo_finish_series();
5339 }
5340 }
5341 else {
5342 result = GetPositionFromList(interp, objv[nidx + 1], &ppt);
5343 if (result == TCL_OK) {
5344 for (i = 0; i < areawin->selects; i++) {
5345 if (SELECTTYPE(areawin->selectlist + i) != GRAPHIC) continue;
5346 gp = SELTOGRAPHIC(areawin->selectlist + i);
5347 gp->position.x = ppt.x;
5348 gp->position.y = ppt.y;
5349 calcbboxvalues(areawin->topinstance,
5350 topobject->plist + *(areawin->selectlist + i));
5351 }
5352 }
5353 }
5354 updatepagebounds(topobject);
5355 incr_changes(topobject);
5356 }
5357 break;
5358 }
5359 return XcTagCallback(interp, objc, objv);
5360 }
5361
5362 /*----------------------------------------------------------------------*/
5363
5364 int xctcl_arc(ClientData clientData, Tcl_Interp *interp,
5365 int objc, Tcl_Obj *CONST objv[])
5366 {
5367 int idx, nidx, result, value;
5368 double angle;
5369 arcptr newarc;
5370 XPoint ppt;
5371 Tcl_Obj *objPtr, *listPtr, **newobjv;
5372
5373 static char *subCmds[] = {"make", "border", "fill", "radius", "minor",
5374 "angle", "position", NULL};
5375 enum SubIdx {
5376 MakeIdx, BorderIdx, FillIdx, RadiusIdx, MinorIdx, AngleIdx,
5377 PositionIdx
5378 };
5379
5380 nidx = 7;
5381 result = ParseElementArguments(interp, objc, objv, &nidx, ARC);
5382 if (result != TCL_OK) return result;
5383
5384 if ((result = Tcl_GetIndexFromObj(interp, objv[nidx],
5385 (CONST84 char **)subCmds,
5386 "option", 0, &idx)) != TCL_OK)
5387 return result;
5388
5389 switch (idx) {
5390 case MakeIdx:
5391 if ((areawin->selects == 0) && (nidx == 1)) {
5392 if ((objc < 4) || (objc > 7)) {
5393 Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
5394 return TCL_ERROR;
5395 }
5396 result = GetPositionFromList(interp, objv[2], &ppt);
5397 if (result != TCL_OK) return result;
5398
5399 result = Tcl_GetIntFromObj(interp, objv[3], &value);
5400 if (result != TCL_OK) return result;
5401
5402 newarc = new_arc(NULL, value, ppt.x, ppt.y);
5403
5404 switch (objc) {
5405 case 6:
5406 result = Tcl_GetDoubleFromObj(interp, objv[4], &angle);
5407 if (result == TCL_OK) newarc->angle1 = (float)angle;
5408 result = Tcl_GetDoubleFromObj(interp, objv[5], &angle);
5409 if (result == TCL_OK) newarc->angle2 = (float)angle;
5410 break;
5411 case 7:
5412 result = Tcl_GetDoubleFromObj(interp, objv[5], &angle);
5413 if (result == TCL_OK) newarc->angle1 = (float)angle;
5414 result = Tcl_GetDoubleFromObj(interp, objv[6], &angle);
5415 if (result == TCL_OK) newarc->angle2 = (float)angle;
5416 case 5:
5417 result = Tcl_GetIntFromObj(interp, objv[4], &value);
5418 if (result == TCL_OK) newarc->yaxis = value;
5419 break;
5420 }
5421 if (objc >= 6) {
5422 /* Check that angle2 > angle1. Swap if necessary. */
5423 if (newarc->angle2 < newarc->angle1) {
5424 int tmp = newarc->angle2;
5425 newarc->angle2 = newarc->angle1;
5426 newarc->angle1 = tmp;
5427 }
5428
5429 /* Check for 0 length chords (assume full circle was intended) */
5430 if (newarc->angle1 == newarc->angle2) {
5431 Tcl_SetResult(interp, "Changed zero-length arc chord!\n", NULL);
5432 newarc->angle2 = newarc->angle1 + 360;
5433 }
5434
5435 /* Normalize */
5436 if (newarc->angle1 >= 360) {
5437 newarc->angle1 -= 360;
5438 newarc->angle2 -= 360;
5439 }
5440 else if (newarc->angle2 <= 0) {
5441 newarc->angle1 += 360;
5442 newarc->angle2 += 360;
5443 }
5444 }
5445 if (objc >= 5) {
5446 calcarc(newarc);
5447 singlebbox((genericptr *)&newarc);
5448 }
5449 objPtr = Tcl_NewHandleObj(newarc);
5450 Tcl_SetObjResult(interp, objPtr);
5451 }
5452 else if (nidx == 2) {
5453 Tcl_SetResult(interp, "\"arc <handle> make\" is illegal", NULL);
5454 return TCL_ERROR;
5455 }
5456 else {
5457 Tcl_SetResult(interp, "No selections allowed", NULL);
5458 return TCL_ERROR;
5459 }
5460 break;
5461
5462 case BorderIdx:
5463 newobjv = (Tcl_Obj **)(&objv[nidx]);
5464 result = xctcl_doborder(clientData, interp, objc - nidx, newobjv);
5465 break;
5466
5467 case FillIdx:
5468 newobjv = (Tcl_Obj **)(&objv[nidx]);
5469 result = xctcl_dofill(clientData, interp, objc - nidx, newobjv);
5470 break;
5471
5472 case RadiusIdx:
5473 case MinorIdx:
5474 case AngleIdx:
5475 case PositionIdx:
5476 if ((areawin->selects == 0) && (nidx == 1)) {
5477 Tcl_SetResult(interp, "Must have an arc selection.", NULL);
5478 return TCL_ERROR;
5479 }
5480 if (objc == nidx + 1) { /* Return position of arc center */
5481 Tcl_Obj *cpair;
5482 int i;
5483 arcptr parc;
5484
5485 listPtr = Tcl_NewListObj(0, NULL);
5486 for (i = 0; i < areawin->selects; i++) {
5487 if (SELECTTYPE(areawin->selectlist + i) != ARC) continue;
5488 parc = SELTOARC(areawin->selectlist + i);
5489
5490 switch (idx) {
5491 case RadiusIdx:
5492 objPtr = Tcl_NewIntObj(parc->radius);
5493 Tcl_ListObjAppendElement(interp, listPtr, objPtr);
5494 break;
5495 case MinorIdx:
5496 objPtr = Tcl_NewIntObj(parc->yaxis);
5497 Tcl_ListObjAppendElement(interp, listPtr, objPtr);
5498 break;
5499 case AngleIdx:
5500 cpair = Tcl_NewListObj(0, NULL);
5501 objPtr = Tcl_NewDoubleObj(parc->angle1);
5502 Tcl_ListObjAppendElement(interp, cpair, objPtr);
5503 objPtr = Tcl_NewDoubleObj(parc->angle2);
5504 Tcl_ListObjAppendElement(interp, cpair, objPtr);
5505 Tcl_ListObjAppendElement(interp, listPtr, cpair);
5506 break;
5507 case PositionIdx:
5508 cpair = Tcl_NewListObj(0, NULL);
5509 objPtr = Tcl_NewIntObj((int)parc->position.x);
5510 Tcl_ListObjAppendElement(interp, cpair, objPtr);
5511 objPtr = Tcl_NewIntObj((int)parc->position.y);
5512 Tcl_ListObjAppendElement(interp, cpair, objPtr);
5513 Tcl_ListObjAppendElement(interp, listPtr, cpair);
5514 break;
5515 }
5516 }
5517 Tcl_SetObjResult(interp, listPtr);
5518 }
5519 break;
5520 }
5521 return XcTagCallback(interp, objc, objv);
5522 }
5523
5524 /*----------------------------------------------------------------------*/
5525
5526 int xctcl_path(ClientData clientData, Tcl_Interp *interp,
5527 int objc, Tcl_Obj *CONST objv[])
5528 {
5529 int idx, nidx, result, j, i;
5530 genericptr newgen, *eptr;
5531 pathptr ppath;
5532 Tcl_Obj *elist, *objPtr, *cpair, *coord, **newobjv;
5533 XPoint ppt;
5534 Matrix hierCTM;
5535
5536 static char *subCmds[] = {"join", "make", "border", "fill", "point", "unjoin",
5537 "points", NULL};
5538 enum SubIdx {
5539 JoinIdx, MakeIdx, BorderIdx, FillIdx, PointIdx, UnJoinIdx, PointsIdx
5540 };
5541
5542 nidx = 5;
5543 result = ParseElementArguments(interp, objc, objv, &nidx, PATH);
5544 if (result != TCL_OK) return result;
5545
5546 if ((result = Tcl_GetIndexFromObj(interp, objv[nidx],
5547 (CONST84 char **)subCmds,
5548 "option", 0, &idx)) != TCL_OK)
5549 return result;
5550
5551 switch (idx) {
5552 case MakeIdx: case JoinIdx:
5553 if ((areawin->selects == 0) && (nidx == 1)) {
5554 /* h = path make {element_list} */
5555 newobjv = (Tcl_Obj **)(&objv[1]);
5556 result = ParseElementArguments(interp, objc - 1, newobjv, NULL,
5557 POLYGON | ARC | SPLINE | PATH);
5558 if (result != TCL_OK) return result;
5559 }
5560 else if (nidx == 2) {
5561 Tcl_SetResult(interp, "\"path <handle> make\" is illegal", NULL);
5562 return TCL_ERROR;
5563 }
5564 /* h = path make */
5565 join();
5566 newgen = *(topobject->plist + topobject->parts - 1);
5567 objPtr = Tcl_NewHandleObj(newgen);
5568 Tcl_SetObjResult(interp, objPtr);
5569 break;
5570
5571 case BorderIdx:
5572 newobjv = (Tcl_Obj **)(&objv[nidx]);
5573 result = xctcl_doborder(clientData, interp, objc - nidx, newobjv);
5574 break;
5575
5576 case FillIdx:
5577 newobjv = (Tcl_Obj **)(&objv[nidx]);
5578 result = xctcl_dofill(clientData, interp, objc - nidx, newobjv);
5579 break;
5580
5581 case PointIdx:
5582 Tcl_SetResult(interp, "Unimplemented function.", NULL);
5583 return TCL_ERROR;
5584 break;
5585
5586 case UnJoinIdx:
5587 unjoin();
5588 /* Would be nice to return the list of constituent elements. . . */
5589 break;
5590
5591 case PointsIdx:
5592 /* Make a list of the polygon and spline elements in the path, */
5593 /* returning a nested list enumerating the points. This is */
5594 /* ad-hoc, as it does not match any other method of returning */
5595 /* point information about a part. This is because returning */
5596 /* a handle list is useless, since the handles cannot be */
5597 /* accessed directly. */
5598
5599 if (areawin->selects != 1) {
5600 Tcl_SetResult(interp, "Must have exactly one selection to "
5601 "query parts", NULL);
5602 return TCL_ERROR;
5603 }
5604 else {
5605 if (SELECTTYPE(areawin->selectlist) != PATH) {
5606 Tcl_SetResult(interp, "Selected element is not a path", NULL);
5607 return TCL_ERROR;
5608 }
5609 else
5610 ppath = SELTOPATH(areawin->selectlist);
5611
5612 MakeHierCTM(&hierCTM);
5613
5614 objPtr = Tcl_NewListObj(0, NULL);
5615 for (j = 0; j < ppath->parts; j++) {
5616 eptr = (genericptr *)(ppath->plist + j);
5617 elist = Tcl_NewListObj(0, NULL);
5618 if ((*eptr)->type == POLYGON) {
5619 polyptr ppoly;
5620 ppoly = (polyptr)(*eptr);
5621 Tcl_ListObjAppendElement(interp, elist,
5622 Tcl_NewStringObj("polygon", -1));
5623 for (i = 0; i < ppoly->number; i++) {
5624 cpair = Tcl_NewListObj(0, NULL);
5625 UTransformbyCTM(&hierCTM, ppoly->points + i, &ppt, 1);
5626 coord = Tcl_NewIntObj((int)ppt.x);
5627 Tcl_ListObjAppendElement(interp, cpair, coord);
5628 coord = Tcl_NewIntObj((int)ppt.y);
5629 Tcl_ListObjAppendElement(interp, cpair, coord);
5630 Tcl_ListObjAppendElement(interp, elist, cpair);
5631 }
5632 }
5633 else {
5634 splineptr pspline;
5635 pspline = (splineptr)(*eptr);
5636 Tcl_ListObjAppendElement(interp, elist,
5637 Tcl_NewStringObj("spline", -1));
5638 for (i = 0; i < 4; i++) {
5639 cpair = Tcl_NewListObj(0, NULL);
5640 UTransformbyCTM(&hierCTM, pspline->ctrl + i, &ppt, 1);
5641 coord = Tcl_NewIntObj((int)ppt.x);
5642 Tcl_ListObjAppendElement(interp, cpair, coord);
5643 coord = Tcl_NewIntObj((int)ppt.y);
5644 Tcl_ListObjAppendElement(interp, cpair, coord);
5645 Tcl_ListObjAppendElement(interp, elist, cpair);
5646 }
5647 }
5648 Tcl_ListObjAppendElement(interp, objPtr, elist);
5649 }
5650 Tcl_SetObjResult(interp, objPtr);
5651 }
5652 break;
5653 }
5654 return XcTagCallback(interp, objc, objv);
5655 }
5656
5657 /*----------------------------------------------------------------------*/
5658
5659 int xctcl_instance(ClientData clientData, Tcl_Interp *interp,
5660 int objc, Tcl_Obj *CONST objv[])
5661 {
5662 int i, numfound, idx, nidx, result;
5663 objectptr pobj;
5664 objinstptr pinst, newinst;
5665 short *newselect;
5666 XPoint newpos, ppt;
5667 Tcl_Obj *objPtr;
5668 Matrix hierCTM;
5669
5670 static char *subCmds[] = {"make", "object", "scale", "center", "linewidth",
5671 "bbox", NULL};
5672 enum SubIdx {
5673 MakeIdx, ObjectIdx, ScaleIdx, CenterIdx, LineWidthIdx, BBoxIdx
5674 };
5675
5676 static char *lwsubCmds[] = {"scale_variant", "variant", "scale_invariant",
5677 "invariant", NULL};
5678
5679 nidx = 3;
5680 result = ParseElementArguments(interp, objc, objv, &nidx, OBJINST);
5681 if (result != TCL_OK) return result;
5682
5683 if ((result = Tcl_GetIndexFromObj(interp, objv[nidx],
5684 (CONST84 char **)subCmds,
5685 "option", 0, &idx)) != TCL_OK)
5686 return result;
5687
5688 switch (idx) {
5689 case MakeIdx:
5690 if ((areawin->selects == 0) && (nidx == 1)) {
5691 if (objc == 3) {
5692 pobj = NameToObject(Tcl_GetString(objv[2]), &pinst, False);
5693 if (pobj == NULL) {
5694 Tcl_SetResult(interp, "no such object ", NULL);
5695 Tcl_AppendResult(interp, Tcl_GetString(objv[2]), NULL);
5696 return TCL_ERROR;
5697 }
5698 newpos = UGetCursorPos();
5699 u2u_snap(&newpos);
5700 newinst = new_objinst(NULL, pinst, newpos.x, newpos.y);
5701 newinst->color = areawin->color;
5702 newselect = allocselect();
5703 *newselect = (short)(topobject->parts - 1);
5704 draw_normal_selected(topobject, areawin->topinstance);
5705 eventmode = COPY_MODE;
5706 Tk_CreateEventHandler(areawin->area, PointerMotionMask,
5707 (Tk_EventProc *)xctk_drag, NULL);
5708 return XcTagCallback(interp, objc, objv);
5709 }
5710 else if (objc != 4) {
5711 Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
5712 return TCL_ERROR;
5713 }
5714 pobj = NameToObject(Tcl_GetString(objv[2]), &pinst, False);
5715 if (pobj == NULL) {
5716 Tcl_SetResult(interp, "no such object ", NULL);
5717 Tcl_AppendResult(interp, Tcl_GetString(objv[2]), NULL);
5718 return TCL_ERROR;
5719 }
5720 result = GetPositionFromList(interp, objv[3], &newpos);
5721 if (result != TCL_OK) return result;
5722
5723 newinst = new_objinst(NULL, pinst, newpos.x, newpos.y);
5724 newinst->color = areawin->color;
5725 singlebbox((genericptr *)&newinst);
5726 objPtr = Tcl_NewHandleObj(newinst);
5727 Tcl_SetObjResult(interp, objPtr);
5728 }
5729 else if (nidx == 2) {
5730 Tcl_SetResult(interp, "\"instance <handle> make\" is illegal", NULL);
5731 return TCL_ERROR;
5732 }
5733 else {
5734 Tcl_SetResult(interp, "No selections allowed.", NULL);
5735 return TCL_ERROR;
5736 }
5737 break;
5738
5739 case ObjectIdx:
5740 if ((objc - nidx) == 1) {
5741 Tcl_Obj *listPtr;
5742 numfound = 0;
5743 for (i = 0; i < areawin->selects; i++) {
5744 if (SELECTTYPE(areawin->selectlist + i) == OBJINST) {
5745 pinst = SELTOOBJINST(areawin->selectlist + i);
5746 objPtr = Tcl_NewStringObj(pinst->thisobject->name, -1);
5747 if (numfound > 0)
5748 Tcl_ListObjAppendElement(interp, listPtr, objPtr);
5749 if ((++numfound) == 1)
5750 listPtr = objPtr;
5751 }
5752 }
5753 switch (numfound) {
5754 case 0:
5755 Tcl_SetResult(interp, "Error: no object instances selected", NULL);
5756 return TCL_ERROR;
5757 break;
5758 case 1:
5759 Tcl_SetObjResult(interp, objPtr);
5760 break;
5761 default:
5762 Tcl_SetObjResult(interp, listPtr);
5763 break;
5764 }
5765 }
5766 else {
5767 Tcl_Obj *listPtr;
5768 int listlen;
5769 objectptr pobj;
5770
5771 /* If the number of additional arguments matches the number */
5772 /* of selected items, or if there is one additional item */
5773 /* that is a list with a number of items equal to the */
5774 /* number of selected items, then change each element to */
5775 /* the corresponding object in the list. If there is only */
5776 /* one additional item, change all elements to that object. */
5777
5778 if ((objc - nidx) == 1 + areawin->selects) {
5779 // Change each element in turn to the corresponding object
5780 // taken from the command arguments
5781 for (i = 0; i < areawin->selects; i++) {
5782 pobj = NameToObject(Tcl_GetString(objv[2 + i]), NULL, FALSE);
5783 if (pobj == NULL) {
5784 Tcl_SetResult(interp, "Name is not a known object", NULL);
5785 return TCL_ERROR;
5786 }
5787 pinst = SELTOOBJINST(areawin->selectlist + i);
5788 pinst->thisobject = pobj;
5789 calcbboxinst(pinst);
5790 }
5791 }
5792 else if ((objc - nidx) == 2) {
5793 result = Tcl_ListObjLength(interp, objv[2], &listlen);
5794 if (result != TCL_OK) return result;
5795 if (listlen == 1) {
5796 // Check if the indicated object exists
5797 pobj = NameToObject(Tcl_GetString(objv[2]), NULL, FALSE);
5798 if (pobj == NULL) {
5799 Tcl_SetResult(interp, "Name is not a known object", NULL);
5800 return TCL_ERROR;
5801 }
5802
5803 // Change all selected elements to the object specified
5804 for (i = 0; i < areawin->selects; i++) {
5805 pinst = SELTOOBJINST(areawin->selectlist + i);
5806 pinst->thisobject = pobj;
5807 calcbboxinst(pinst);
5808 }
5809 }
5810 else if (listlen != areawin->selects) {
5811 Tcl_SetResult(interp, "Error: list length does not match"
5812 "the number of selected elements.", NULL);
5813 return TCL_ERROR;
5814 }
5815 else {
5816 // Change each element in turn to the corresponding object
5817 // in the list
5818 for (i = 0; i < areawin->selects; i++) {
5819 result = Tcl_ListObjIndex(interp, objv[2], i, &listPtr);
5820 if (result != TCL_OK) return result;
5821
5822 pobj = NameToObject(Tcl_GetString(listPtr), NULL, FALSE);
5823 if (pobj == NULL) {
5824 Tcl_SetResult(interp, "Name is not a known object", NULL);
5825 return TCL_ERROR;
5826 }
5827 pinst = SELTOOBJINST(areawin->selectlist + i);
5828 pinst->thisobject = pobj;
5829 calcbboxinst(pinst);
5830 }
5831 }
5832 }
5833 drawarea(areawin->area, NULL, NULL);
5834 }
5835 break;
5836
5837 case ScaleIdx:
5838 if ((objc - nidx) == 1) {
5839 Tcl_Obj *listPtr;
5840 numfound = 0;
5841 for (i = 0; i < areawin->selects; i++) {
5842 if (SELECTTYPE(areawin->selectlist + i) == OBJINST) {
5843 pinst = SELTOOBJINST(areawin->selectlist + i);
5844 objPtr = Tcl_NewDoubleObj(pinst->scale);
5845 if (numfound > 0)
5846 Tcl_ListObjAppendElement(interp, listPtr, objPtr);
5847 if ((++numfound) == 1)
5848 listPtr = objPtr;
5849 }
5850 }
5851 switch (numfound) {
5852 case 0:
5853 Tcl_SetResult(interp, "Error: no object instances selected", NULL);
5854 return TCL_ERROR;
5855 break;
5856 case 1:
5857 Tcl_SetObjResult(interp, objPtr);
5858 break;
5859 default:
5860 Tcl_SetObjResult(interp, listPtr);
5861 break;
5862 }
5863 }
5864 else {
5865 strcpy(_STR2, Tcl_GetString(objv[2]));
5866 setosize((Tk_Window)clientData, NULL);
5867 }
5868 break;
5869
5870 case CenterIdx:
5871
5872 if ((objc - nidx) == 1) {
5873 Tcl_Obj *listPtr, *coord;
5874 numfound = 0;
5875 for (i = 0; i < areawin->selects; i++) {
5876 if (SELECTTYPE(areawin->selectlist + i) == OBJINST) {
5877 pinst = SELTOOBJINST(areawin->selectlist + i);
5878 MakeHierCTM(&hierCTM);
5879 objPtr = Tcl_NewListObj(0, NULL);
5880 UTransformbyCTM(&hierCTM, &pinst->position, &ppt, 1);
5881 coord = Tcl_NewIntObj((int)ppt.x);
5882 Tcl_ListObjAppendElement(interp, objPtr, coord);
5883 coord = Tcl_NewIntObj((int)ppt.y);
5884 Tcl_ListObjAppendElement(interp, objPtr, coord);
5885 if (numfound > 0)
5886 Tcl_ListObjAppendElement(interp, listPtr, objPtr);
5887 if ((++numfound) == 1)
5888 listPtr = objPtr;
5889 }
5890 }
5891 switch (numfound) {
5892 case 0:
5893 Tcl_SetResult(interp, "Error: no object instances selected", NULL);
5894 return TCL_ERROR;
5895 break;
5896 case 1:
5897 Tcl_SetObjResult(interp, objPtr);
5898 break;
5899 default:
5900 Tcl_SetObjResult(interp, listPtr);
5901 break;
5902 }
5903 }
5904 else if (((objc - nidx) == 2) && (areawin->selects == 1)) {
5905 result = GetPositionFromList(interp, objv[objc - 1], &newpos);
5906 if (result != TCL_OK) return result;
5907 if (SELECTTYPE(areawin->selectlist) == OBJINST) {
5908 pinst = SELTOOBJINST(areawin->selectlist);
5909 MakeHierCTM(&hierCTM);
5910 UTransformbyCTM(&hierCTM, &newpos, &pinst->position, 1);
5911 }
5912 }
5913 else {
5914 Tcl_SetResult(interp, "Usage: instance center {x y}; only one"
5915 "instance should be selected.", NULL);
5916 return TCL_ERROR;
5917 }
5918 break;
5919
5920 case LineWidthIdx:
5921 if ((objc - nidx) == 1) {
5922 Tcl_Obj *listPtr;
5923 numfound = 0;
5924 for (i = 0; i < areawin->selects; i++) {
5925 if (SELECTTYPE(areawin->selectlist + i) == OBJINST) {
5926 pinst = SELTOOBJINST(areawin->selectlist + i);
5927 if (pinst->style & LINE_INVARIANT)
5928 objPtr = Tcl_NewStringObj("scale_invariant", -1);
5929 else
5930 objPtr = Tcl_NewStringObj("scale_variant", -1);
5931 if (numfound > 0)
5932 Tcl_ListObjAppendElement(interp, listPtr, objPtr);
5933 if ((++numfound) == 1)
5934 listPtr = objPtr;
5935 }
5936 }
5937 switch (numfound) {
5938 case 0:
5939 Tcl_SetResult(interp, "Error: no object instances selected", NULL);
5940 return TCL_ERROR;
5941 break;
5942 case 1:
5943 Tcl_SetObjResult(interp, objPtr);
5944 break;
5945 default:
5946 Tcl_SetObjResult(interp, listPtr);
5947 break;
5948 }
5949 }
5950 else {
5951 int subidx;
5952 if ((result = Tcl_GetIndexFromObj(interp, objv[nidx + 1],
5953 (CONST84 char **)lwsubCmds,
5954 "value", 0, &subidx)) == TCL_OK) {
5955 for (i = 0; i < areawin->selects; i++) {
5956 if (SELECTTYPE(areawin->selectlist + i) == OBJINST) {
5957 pinst = SELTOOBJINST(areawin->selectlist);
5958 if (subidx < 2)
5959 pinst->style &= ~LINE_INVARIANT;
5960 else
5961 pinst->style |= LINE_INVARIANT;
5962 }
5963 }
5964 }
5965 }
5966 break;
5967
5968 case BBoxIdx:
5969 if ((objc - nidx) == 1) {
5970 Tcl_Obj *listPtr, *coord;
5971 numfound = 0;
5972 for (i = 0; i < areawin->selects; i++) {
5973 if (SELECTTYPE(areawin->selectlist + i) == OBJINST) {
5974 pinst = SELTOOBJINST(areawin->selectlist + i);
5975 objPtr = Tcl_NewListObj(0, NULL);
5976 coord = Tcl_NewIntObj((int)pinst->bbox.lowerleft.x);
5977 Tcl_ListObjAppendElement(interp, objPtr, coord);
5978 coord = Tcl_NewIntObj((int)pinst->bbox.lowerleft.y);
5979 Tcl_ListObjAppendElement(interp, objPtr, coord);
5980 coord = Tcl_NewIntObj((int)(pinst->bbox.lowerleft.x +
5981 pinst->bbox.width));
5982 Tcl_ListObjAppendElement(interp, objPtr, coord);
5983 coord = Tcl_NewIntObj((int)(pinst->bbox.lowerleft.y +
5984 pinst->bbox.height));
5985 Tcl_ListObjAppendElement(interp, objPtr, coord);
5986 if (numfound > 0)
5987 Tcl_ListObjAppendElement(interp, listPtr, objPtr);
5988 if ((++numfound) == 1)
5989 listPtr = objPtr;
5990 }
5991 }
5992 switch (numfound) {
5993 case 0:
5994 Tcl_SetResult(interp, "Error: no object instances selected", NULL);
5995 return TCL_ERROR;
5996 break;
5997 case 1:
5998 Tcl_SetObjResult(interp, objPtr);
5999 break;
6000 default:
6001 Tcl_SetObjResult(interp, listPtr);
6002 break;
6003 }
6004 }
6005 else {
6006 /* e.g., "instance bbox recompute" */
6007 for (i = 0; i < areawin->selects; i++) {
6008 if (SELECTTYPE(areawin->selectlist + i) == OBJINST) {
6009 pinst = SELTOOBJINST(areawin->selectlist + i);
6010 calcbbox(pinst);
6011 }
6012 }
6013 }
6014 break;
6015 }
6016 return XcTagCallback(interp, objc, objv);
6017 }
6018
6019 /*----------------------------------------------------------------------*/
6020 /* "element" configures properties of elements. Note that if the */
6021 /* second argument is not an element handle (pointer), then operations */
6022 /* will be applied to all selected elements. If there is no element */
6023 /* handle and no objects are selected, the operation will be applied */
6024 /* to default settings, like the "xcircuit::set" command. */
6025 /*----------------------------------------------------------------------*/
6026
6027 int xctcl_element(ClientData clientData, Tcl_Interp *interp,
6028 int objc, Tcl_Obj *CONST objv[])
6029 {
6030 int result, nidx, idx, i, flags;
6031 Tcl_Obj *listPtr;
6032 Tcl_Obj **newobjv;
6033 int newobjc;
6034 genericptr egen;
6035 short *newselect, *tempselect, *orderlist;
6036
6037 /* Commands */
6038 static char *subCmds[] = {
6039 "delete", "copy", "flip", "rotate", "edit", "select", "snap", "move",
6040 "color", "parameters", "raise", "lower", "exchange", "hide", "show",
6041 "handle", "deselect", NULL
6042 };
6043 enum SubIdx {
6044 DeleteIdx, CopyIdx, FlipIdx, RotateIdx, EditIdx, SelectIdx, SnapIdx,
6045 MoveIdx, ColorIdx, ParamIdx, RaiseIdx, LowerIdx, ExchangeIdx,
6046 HideIdx, ShowIdx, HandleIdx, DeselectIdx
6047 };
6048
6049 static char *etypes[] = {
6050 "Label", "Polygon", "Bezier Curve", "Object Instance", "Path",
6051 "Arc", "Graphic", NULL /* (jdk) */
6052 };
6053
6054 /* Before doing a standard parse, we need to check for the single case */
6055 /* "element X deselect"; otherwise, calling ParseElementArguements() */
6056 /* is going to destroy the selection list. */
6057
6058 if ((objc == 3) && (!strcmp(Tcl_GetString(objv[2]), "deselect"))) {
6059 result = xctcl_deselect(clientData, interp, objc, objv);
6060 return result;
6061 }
6062
6063 /* All other commands are dispatched to individual element commands */
6064 /* for the indicated element or for each selected element. */
6065
6066 nidx = 7;
6067 result = ParseElementArguments(interp, objc, objv, &nidx, ALL_TYPES);
6068 if (result != TCL_OK) return result;
6069
6070 if ((objc - nidx) < 1) {
6071 Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
6072 return TCL_ERROR;
6073 }
6074
6075 if (!strcmp(Tcl_GetString(objv[nidx]), "type")) {
6076 /* Return a list of types of the selected elements */
6077
6078 if (areawin->selects > 1)
6079 listPtr = Tcl_NewListObj(0, NULL);
6080
6081 for (i = 0; i < areawin->selects; i++) {
6082 Tcl_Obj *objPtr;
6083 int idx2, type = SELECTTYPE(areawin->selectlist + i);
6084 switch (type) {
6085 case LABEL: idx2 = 0; break;
6086 case POLYGON: idx2 = 1; break;
6087 case SPLINE: idx2 = 2; break;
6088 case OBJINST: idx2 = 3; break;
6089 case PATH: idx2 = 4; break;
6090 case ARC: idx2 = 5; break;
6091 case GRAPHIC: idx2 = 6; break;
6092 default: return TCL_ERROR;
6093 }
6094 objPtr = Tcl_NewStringObj(etypes[idx2], strlen(etypes[idx2]));
6095 if (areawin->selects == 1) {
6096 Tcl_SetObjResult(interp, objPtr);
6097 return TCL_OK;
6098 }
6099 else {
6100 Tcl_ListObjAppendElement(interp, listPtr, objPtr);
6101 }
6102 Tcl_SetObjResult(interp, listPtr);
6103 }
6104 return XcTagCallback(interp, objc, objv);
6105 }
6106 else if (!strcmp(Tcl_GetString(objv[nidx]), "handle")) {
6107 /* Return a list of handles of the selected elements */
6108
6109 listPtr = SelectToTclList(interp, areawin->selectlist, areawin->selects);
6110 Tcl_SetObjResult(interp, listPtr);
6111 return XcTagCallback(interp, objc, objv);
6112 }
6113
6114 if (Tcl_GetIndexFromObj(interp, objv[nidx],
6115 (CONST84 char **)subCmds,
6116 "option", 0, &idx) == TCL_OK) {
6117
6118 newobjv = (Tcl_Obj **)(&objv[nidx]);
6119 newobjc = objc - nidx;
6120
6121 /* Shift the argument list and call the indicated function. */
6122
6123 switch(idx) {
6124 case DeleteIdx:
6125 result = xctcl_delete(clientData, interp, newobjc, newobjv);
6126 break;
6127 case CopyIdx:
6128 result = xctcl_copy(clientData, interp, newobjc, newobjv);
6129 break;
6130 case FlipIdx:
6131 result = xctcl_flip(clientData, interp, newobjc, newobjv);
6132 break;
6133 case RotateIdx:
6134 result = xctcl_rotate(clientData, interp, newobjc, newobjv);
6135 break;
6136 case EditIdx:
6137 result = xctcl_edit(clientData, interp, newobjc, newobjv);
6138 break;
6139 case ParamIdx:
6140 result = xctcl_param(clientData, interp, newobjc, newobjv);
6141 break;
6142 case HideIdx:
6143 for (i = 0; i < areawin->selects; i++) {
6144 newselect = areawin->selectlist + i;
6145 egen = SELTOGENERIC(newselect);
6146 egen->type |= DRAW_HIDE;
6147 }
6148 refresh(NULL, NULL, NULL);
6149 break;
6150 case ShowIdx:
6151 if (newobjc == 2) {
6152 if (!strcmp(Tcl_GetString(newobjv[1]), "all")) {
6153 for (i = 0; i < topobject->parts; i++) {
6154 egen = *(topobject->plist + i);
6155 egen->type &= (~DRAW_HIDE);
6156 }
6157 }
6158 }
6159 else {
6160 for (i = 0; i < areawin->selects; i++) {
6161 newselect = areawin->selectlist + i;
6162 egen = SELTOGENERIC(newselect);
6163 egen->type &= (~DRAW_HIDE);
6164 }
6165 }
6166 refresh(NULL, NULL, NULL);
6167 break;
6168 case SelectIdx:
6169 if (newobjc == 2) {
6170 if (!strncmp(Tcl_GetString(newobjv[1]), "hide", 4)) {
6171 for (i = 0; i < areawin->selects; i++) {
6172 newselect = areawin->selectlist + i;
6173 egen = SELTOGENERIC(newselect);
6174 egen->type |= SELECT_HIDE;
6175 }
6176 }
6177 else if (!strncmp(Tcl_GetString(newobjv[1]), "allow", 5)) {
6178 for (i = 0; i < topobject->parts; i++) {
6179 egen = *(topobject->plist + i);
6180 egen->type &= (~SELECT_HIDE);
6181 }
6182 }
6183 else {
6184 Tcl_SetResult(interp, "Select options are \"hide\" "
6185 "and \"allow\"", NULL);
6186 return TCL_ERROR;
6187 }
6188 }
6189 /* If nidx == 2, then we've already done the selection! */
6190 else if (nidx == 1)
6191 result = xctcl_select(clientData, interp, newobjc, newobjv);
6192 else
6193 result = TCL_OK;
6194 break;
6195 case DeselectIdx:
6196 /* case nidx == 2 was already taken care of. case nidx == 1 */
6197 /* implies "deselect all". */
6198 unselect_all();
6199 result = TCL_OK;
6200 break;
6201 case ColorIdx:
6202 result = xctcl_color(clientData, interp, newobjc, newobjv);
6203 break;
6204 case SnapIdx:
6205 snapelement();
6206 break;
6207 case ExchangeIdx:
6208 exchange();
6209 break;
6210 case LowerIdx:
6211
6212 /* Improved method thanks to Dimitri Princen */
6213
6214 /* First move the selected parts to the bottom. This sets */
6215 /* all the values pointed by (selectlist + i) to zero, and */
6216 /* inverts the order between the selected elements. */
6217 /* Finally *tempselect += i inverts the original numbering, */
6218 /* so the second loop inverts the placing again, regaining */
6219 /* the correct order (and writes it so). */
6220 /* */
6221 /* RaiseIdx works similar but starts from the top. */
6222
6223 if (newobjc == 2) {
6224 if (!strcmp(Tcl_GetString(newobjv[1]), "all")) {
6225 orderlist = (short *)malloc(topobject->parts * sizeof(short));
6226 for (i = 0; i < topobject->parts; i++) *(orderlist + i) = i;
6227
6228 for (i = 0; i < areawin->selects; i++) {
6229 tempselect = areawin->selectlist + i;
6230 xc_bottom(tempselect, orderlist);
6231 *tempselect += i;
6232 }
6233 for (i = 0; i < areawin->selects; i++) {
6234 tempselect = areawin->selectlist + i;
6235 xc_bottom(tempselect, orderlist);
6236 *tempselect += (areawin->selects - 1 - i);
6237 }
6238 register_for_undo(XCF_Reorder, UNDO_MORE, areawin->topinstance,
6239 orderlist, topobject->parts);
6240 }
6241 }
6242 else {
6243 xc_lower();
6244 }
6245 break;
6246
6247 case RaiseIdx:
6248
6249 /* Improved method thanks to Dimitri Princen */
6250
6251 if (newobjc == 2) {
6252 if (!strcmp(Tcl_GetString(newobjv[1]), "all")) {
6253 orderlist = (short *)malloc(topobject->parts * sizeof(short));
6254 for (i = 0; i < topobject->parts; i++) *(orderlist + i) = i;
6255
6256 for (i = areawin->selects - 1; i >= 0 ; i--) {
6257 tempselect = areawin->selectlist + i;
6258 xc_top(tempselect, orderlist);
6259 *tempselect -= (areawin->selects - 1 - i);
6260 }
6261 for (i = areawin->selects - 1; i >= 0 ; i--) {
6262 tempselect = areawin->selectlist + i;
6263 xc_top(tempselect, orderlist);
6264 *tempselect -= i;
6265 }
6266 register_for_undo(XCF_Reorder, UNDO_MORE, areawin->topinstance,
6267 orderlist, topobject->parts);
6268 }
6269 }
6270 else {
6271 xc_raise();
6272 }
6273 break;
6274
6275 case MoveIdx:
6276 result = xctcl_move(clientData, interp, newobjc, newobjv);
6277 break;
6278 }
6279 return result;
6280 }
6281
6282 /* Call each individual element function. */
6283 /* Each function is responsible for filtering the select list to */
6284 /* choose only the appropriate elements. However, we first check */
6285 /* if at least one of that type exists in the list, so the function */
6286 /* won't return an error. */
6287
6288 Tcl_ResetResult(interp);
6289
6290 newobjv = (Tcl_Obj **)(&objv[nidx - 1]);
6291 newobjc = objc - nidx + 1;
6292
6293 flags = 0;
6294 for (i = 0; i < areawin->selects; i++)
6295 flags |= SELECTTYPE(areawin->selectlist + i);
6296
6297 if (flags & LABEL) {
6298 result = xctcl_label(clientData, interp, newobjc, newobjv);
6299 if (result != TCL_OK) return result;
6300 }
6301 if (flags & POLYGON) {
6302 result = xctcl_polygon(clientData, interp, newobjc, newobjv);
6303 if (result != TCL_OK) return result;
6304 }
6305 if (flags & OBJINST) {
6306 result = xctcl_instance(clientData, interp, newobjc, newobjv);
6307 if (result != TCL_OK) return result;
6308 }
6309 if (flags & SPLINE) {
6310 result = xctcl_spline(clientData, interp, newobjc, newobjv);
6311 if (result != TCL_OK) return result;
6312 }
6313 if (flags & PATH) {
6314 result = xctcl_path(clientData, interp, newobjc, newobjv);
6315 if (result != TCL_OK) return result;
6316 }
6317 if (flags & ARC) {
6318 result = xctcl_arc(clientData, interp, newobjc, newobjv);
6319 }
6320 if (flags & GRAPHIC) {
6321 result = xctcl_graphic(clientData, interp, newobjc, newobjv);
6322 }
6323 return result;
6324 }
6325
6326 /*----------------------------------------------------------------------*/
6327 /* "config" manipulates a whole bunch of option settings. */
6328 /*----------------------------------------------------------------------*/
6329
6330 int xctcl_config(ClientData clientData, Tcl_Interp *interp,
6331 int objc, Tcl_Obj *CONST objv[])
6332 {
6333 int tmpint, i;
6334 int result, idx;
6335 char *tmpstr, buffer[30], **sptr;
6336 Pagedata *curpage;
6337
6338 static char *boxsubCmds[] = {"manhattan", "rhomboidx", "rhomboidy",
6339 "rhomboida", "normal", NULL};
6340 static char *pathsubCmds[] = {"tangents", "normal", NULL};
6341 static char *coordsubCmds[] = {"decimal inches", "fractional inches",
6342 "centimeters", "internal units", NULL};
6343 static char *filterTypes[] = {"instances", "labels", "polygons", "arcs",
6344 "splines", "paths", "graphics", NULL};
6345 static char *searchOpts[] = {"files", "lib", "libs", "library", "libraries", NULL};
6346
6347 static char *subCmds[] = {
6348 "axis", "axes", "grid", "snap", "bbox", "editinplace",
6349 "pinpositions", "pinattach", "clipmasks", "boxedit", "pathedit", "linewidth",
6350 "colorscheme", "coordstyle", "drawingscale", "manhattan", "centering",
6351 "filter", "buschar", "backup", "search", "focus", "init",
6352 "delete", "windownames", "hold", "database", "suspend",
6353 "technologies", "fontnames", "debug", NULL
6354 };
6355 enum SubIdx {
6356 AxisIdx, AxesIdx, GridIdx, SnapIdx, BBoxIdx, EditInPlaceIdx,
6357 PinPosIdx, PinAttachIdx, ShowClipIdx, BoxEditIdx, PathEditIdx, LineWidthIdx,
6358 ColorSchemeIdx, CoordStyleIdx, ScaleIdx, ManhattanIdx, CenteringIdx,
6359 FilterIdx, BusCharIdx, BackupIdx, SearchIdx, FocusIdx,
6360 InitIdx, DeleteIdx, WindowNamesIdx, HoldIdx, DatabaseIdx,
6361 SuspendIdx, TechnologysIdx, FontNamesIdx, DebugIdx
6362 };
6363
6364 if ((objc == 1) || (objc > 5)) {
6365 Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
6366 return TCL_ERROR;
6367 }
6368 if (Tcl_GetIndexFromObj(interp, objv[1],
6369 (CONST84 char **)subCmds,
6370 "option", 0, &idx) != TCL_OK) {
6371 return TCL_ERROR;
6372 }
6373
6374 /* Set curpage for those routines that need it */
6375
6376 switch(idx) {
6377 case GridIdx:
6378 case SnapIdx:
6379 case LineWidthIdx:
6380 case CoordStyleIdx:
6381 case ScaleIdx:
6382 if (areawin == NULL) {
6383 Tcl_SetResult(interp, "No current window set, assuming default\n",
6384 NULL);
6385 curpage = xobjs.pagelist[0];
6386 if (curpage == NULL) return TCL_ERROR;
6387 }
6388 else
6389 curpage = xobjs.pagelist[areawin->page];
6390 break;
6391 }
6392
6393 /* Check number of arguments wholesale (to be done) */
6394
6395 switch(idx) {
6396 case SuspendIdx:
6397 if (objc == 2) {
6398 switch (xobjs.suspend) {
6399 case -1:
6400 Tcl_SetResult(interp, "normal drawing", NULL);
6401 break;
6402 case 0:
6403 Tcl_SetResult(interp, "drawing suspended", NULL);
6404 break;
6405 case 1:
6406 Tcl_SetResult(interp, "refresh pending", NULL);
6407 break;
6408 case 2:
6409 Tcl_SetResult(interp, "drawing locked", NULL);
6410 break;
6411 }
6412 }
6413 else {
6414 result = Tcl_GetBooleanFromObj(interp, objv[2], &tmpint);
6415 if (result != TCL_OK) return result;
6416 if (tmpint == 0) {
6417
6418 /* Pending drawing */
6419
6420 if (xobjs.suspend == 1) {
6421 xobjs.suspend = -1;
6422 refresh(NULL, NULL, NULL);
6423 }
6424 else
6425 xobjs.suspend = -1;
6426 }
6427 else {
6428 /* Calling "config suspend true" twice effectively */
6429 /* locks the graphics in a state that can only be */
6430 /* removed by a call to "config suspend false". */
6431 if (xobjs.suspend >= 0)
6432 xobjs.suspend = 2;
6433 else
6434 xobjs.suspend = 0;
6435 }
6436 }
6437 break;
6438
6439 case DatabaseIdx:
6440 /* Regenerate the database of colors, fonts, etc. from Tk options */
6441 if (objc == 3) {
6442 Tk_Window tkwind, tktop;
6443
6444 tktop = Tk_MainWindow(interp);
6445 tkwind = Tk_NameToWindow(interp, Tcl_GetString(objv[2]), tktop);
6446 build_app_database(tkwind);
6447 setcolorscheme(!areawin->invert);
6448 }
6449 break;
6450
6451 case FontNamesIdx:
6452 /* To do: Return a list of known font names. The Tk wrapper uses */
6453 /* this list to regenerate the font menu for each new window. */
6454 break;
6455
6456 case WindowNamesIdx:
6457 /* Generate and return a list of existing window names */
6458
6459 if (objc == 2) {
6460 XCWindowData *winptr;
6461 for (winptr = xobjs.windowlist; winptr != NULL; winptr = winptr->next)
6462 Tcl_AppendElement(interp, Tk_PathName(winptr->area));
6463 }
6464 break;
6465
6466 case DeleteIdx:
6467 if (objc == 3) {
6468 XCWindowData *winptr;
6469 Tk_Window tkwind, tktop;
6470
6471 tktop = Tk_MainWindow(interp);
6472 tkwind = Tk_NameToWindow(interp, Tcl_GetString(objv[2]), tktop);
6473 for (winptr = xobjs.windowlist; winptr != NULL; winptr = winptr->next) {
6474 if (winptr->area == tkwind) {
6475 delete_window(winptr);
6476 break;
6477 }
6478 }
6479 if (winptr == NULL) {
6480 Tcl_SetResult(interp, "No such window\n", NULL);
6481 return TCL_ERROR;
6482 }
6483 }
6484 break;
6485
6486 case DebugIdx:
6487 #ifdef ASG
6488 if (objc == 3) {
6489 result = Tcl_GetIntFromObj(interp, objv[2], &tmpint);
6490 if (result != TCL_OK) return result;
6491 SetDebugLevel(&tmpint);
6492 }
6493 else {
6494 Tcl_SetObjResult(interp, Tcl_NewIntObj(SetDebugLevel(NULL)));
6495 }
6496 #endif
6497 break;
6498
6499
6500 case InitIdx:
6501 /* Create a data structure for a new drawing window. */
6502 /* Give it the same page number and view as the current window */
6503
6504 if (objc == 3) {
6505 XCWindowData *newwin, *savewin;
6506 savewin = areawin; // In case focus callback overwrites areawin.
6507 newwin = GUI_init(objc - 2, objv + 2);
6508 if (newwin != NULL) {
6509 newwin->page = savewin->page;
6510 newwin->vscale = savewin->vscale;
6511 newwin->pcorner = savewin->pcorner;
6512 newwin->topinstance = savewin->topinstance;
6513 }
6514 else {
6515 Tcl_SetResult(interp, "Unable to create new window structure\n", NULL);
6516 return TCL_ERROR;
6517 }
6518 }
6519 break;
6520
6521 case FocusIdx:
6522 if (objc == 2) {
6523 Tcl_SetResult(interp, Tk_PathName(areawin->area), NULL);
6524 }
6525 else if (objc == 3) {
6526 Tk_Window tkwind, tktop;
6527 XCWindowData *winptr;
6528 XPoint locsave;
6529
6530 tktop = Tk_MainWindow(interp);
6531 tkwind = Tk_NameToWindow(interp, Tcl_GetString(objv[2]), tktop);
6532 /* (Diagnostic) */
6533 /* printf("Focusing: %s\n", Tcl_GetString(objv[2])); */
6534 for (winptr = xobjs.windowlist; winptr != NULL; winptr = winptr->next) {
6535 if (winptr->area == tkwind) {
6536 int savemode;
6537 objectptr savestack;
6538
6539 if (areawin == winptr) break;
6540 else if (areawin == NULL) {
6541 areawin = winptr;
6542 break;
6543 }
6544 if ((eventmode == MOVE_MODE || eventmode == COPY_MODE) &&
6545 winptr->editstack->parts == 0) {
6546 locsave = areawin->save;
6547 delete_for_xfer(NORMAL, areawin->selectlist, areawin->selects);
6548 /* Swap editstacks */
6549 savestack = winptr->editstack;
6550 winptr->editstack = areawin->editstack;
6551 areawin->editstack = savestack;
6552 savemode = eventmode;
6553 eventmode = NORMAL_MODE;
6554
6555 /* Change event handlers */
6556 xcRemoveEventHandler(areawin->area, PointerMotionMask, False,
6557 (xcEventHandler)xctk_drag, NULL);
6558 drawarea(areawin->area, NULL, NULL);
6559 Tk_CreateEventHandler(winptr->area, PointerMotionMask,
6560 (Tk_EventProc *)xctk_drag, NULL);
6561
6562 /* Set new window */
6563 areawin = winptr;
6564 eventmode = savemode;
6565 areawin->save = locsave;
6566 transferselects();
6567 drawarea(areawin->area, NULL, NULL);
6568 }
6569 else
6570 areawin = winptr;
6571 break;
6572 }
6573 }
6574 if (winptr == NULL) {
6575 Tcl_SetResult(interp, "No such xcircuit drawing window\n", NULL);
6576 return TCL_ERROR;
6577 }
6578 }
6579 else {
6580 Tcl_WrongNumArgs(interp, 2, objv, "[window]");
6581 return TCL_ERROR;
6582 }
6583 break;
6584
6585 case AxisIdx: case AxesIdx:
6586 if (objc == 2) {
6587 Tcl_SetResult(interp, (areawin->axeson) ? "true" : "false", NULL);
6588 break;
6589 }
6590 else {
6591 result = Tcl_GetBooleanFromObj(interp, objv[2], &tmpint);
6592 if (result != TCL_OK) return result;
6593 areawin->axeson = (Boolean) tmpint;
6594 }
6595 break;
6596
6597 case GridIdx:
6598 if (objc == 2) {
6599 Tcl_SetResult(interp, (areawin->gridon) ? "true" : "false", NULL);
6600 break;
6601 }
6602 else {
6603 if (!strncmp("spac", Tcl_GetString(objv[2]), 4)) {
6604 if (objc == 3) {
6605 measurestr((float)curpage->gridspace, buffer);
6606 Tcl_SetObjResult(interp, Tcl_NewStringObj(buffer, strlen(buffer)));
6607 break;
6608 }
6609 else {
6610 strcpy(_STR2, Tcl_GetString(objv[3]));
6611 setgrid(NULL, &(curpage->gridspace));
6612 }
6613 }
6614 else {
6615 result = Tcl_GetBooleanFromObj(interp, objv[2], &tmpint);
6616 if (result != TCL_OK) return result;
6617 areawin->gridon = (Boolean) tmpint;
6618 }
6619 }
6620 break;
6621
6622 case SnapIdx:
6623 if (objc == 2) {
6624 Tcl_SetResult(interp, (areawin->snapto) ? "true" : "false", NULL);
6625 }
6626 else {
6627 if (!strncmp("spac", Tcl_GetString(objv[2]), 4)) {
6628 if (objc == 3) {
6629 measurestr((float)curpage->snapspace, buffer);
6630 Tcl_SetObjResult(interp, Tcl_NewStringObj(buffer, strlen(buffer)));
6631 break;
6632 }
6633 else {
6634 strcpy(_STR2, Tcl_GetString(objv[3]));
6635 setgrid(NULL, &(curpage->snapspace));
6636 }
6637 }
6638 else {
6639 result = Tcl_GetBooleanFromObj(interp, objv[2], &tmpint);
6640 if (result != TCL_OK) return result;
6641 areawin->snapto = (Boolean) tmpint;
6642 }
6643 }
6644 break;
6645
6646 case BoxEditIdx:
6647 if (objc == 2) {
6648 switch (areawin->boxedit) {
6649 case MANHATTAN: idx = 0; break;
6650 case RHOMBOIDX: idx = 1; break;
6651 case RHOMBOIDY: idx = 2; break;
6652 case RHOMBOIDA: idx = 3; break;
6653 case NORMAL: idx = 4; break;
6654 }
6655 Tcl_SetObjResult(interp, Tcl_NewStringObj(boxsubCmds[idx],
6656 strlen(boxsubCmds[idx])));
6657 }
6658 else if (objc != 3) {
6659 Tcl_WrongNumArgs(interp, 2, objv, "boxedit ?arg ...?");
6660 return TCL_ERROR;
6661 }
6662 else {
6663 if (Tcl_GetIndexFromObj(interp, objv[2],
6664 (CONST84 char **)boxsubCmds,
6665 "option", 0, &idx) != TCL_OK) {
6666 return TCL_ERROR;
6667 }
6668 switch (idx) {
6669 case 0: tmpint = MANHATTAN; break;
6670 case 1: tmpint = RHOMBOIDX; break;
6671 case 2: tmpint = RHOMBOIDY; break;
6672 case 3: tmpint = RHOMBOIDA; break;
6673 case 4: tmpint = NORMAL; break;
6674 }
6675 areawin->boxedit = tmpint;
6676 }
6677 break;
6678
6679 case PathEditIdx:
6680 if (objc == 2) {
6681 switch (areawin->pathedit) {
6682 case TANGENTS: idx = 0; break;
6683 case NORMAL: idx = 1; break;
6684 }
6685 Tcl_SetObjResult(interp, Tcl_NewStringObj(pathsubCmds[idx],
6686 strlen(pathsubCmds[idx])));
6687 }
6688 else if (objc != 3) {
6689 Tcl_WrongNumArgs(interp, 2, objv, "pathedit ?arg ...?");
6690 return TCL_ERROR;
6691 }
6692 else {
6693 if (Tcl_GetIndexFromObj(interp, objv[2],
6694 (CONST84 char **)pathsubCmds,
6695 "option", 0, &idx) != TCL_OK) {
6696 return TCL_ERROR;
6697 }
6698 switch (idx) {
6699 case 0: tmpint = TANGENTS; break;
6700 case 1: tmpint = NORMAL; break;
6701 }
6702 areawin->pathedit = tmpint;
6703 }
6704 break;
6705
6706 case LineWidthIdx:
6707 if (objc == 2) {
6708 Tcl_SetObjResult(interp,
6709 Tcl_NewDoubleObj((double)curpage->wirewidth / 2.0));
6710 }
6711 else if (objc != 3) {
6712 Tcl_WrongNumArgs(interp, 3, objv, "linewidth");
6713 return TCL_ERROR;
6714 }
6715 else {
6716 strcpy(_STR2, Tcl_GetString(objv[2]));
6717 setwidth(NULL, &(curpage->wirewidth));
6718 }
6719 break;
6720
6721 case BBoxIdx:
6722 if (objc == 2) {
6723 Tcl_SetResult(interp, (areawin->bboxon) ? "visible" : "invisible", NULL);
6724 }
6725 else {
6726 tmpstr = Tcl_GetString(objv[2]);
6727 if (strstr(tmpstr, "visible"))
6728 tmpint = (tmpstr[0] == 'i') ? False : True;
6729 else {
6730 result = Tcl_GetBooleanFromObj(interp, objv[2], &tmpint);
6731 if (result != TCL_OK) return result;
6732 }
6733 areawin->bboxon = (Boolean) tmpint;
6734 }
6735 break;
6736
6737 case HoldIdx:
6738 if (objc == 2) {
6739 Tcl_SetResult(interp, (xobjs.hold) ? "true" : "false", NULL);
6740 }
6741 else {
6742 result = Tcl_GetBooleanFromObj(interp, objv[2], &tmpint);
6743 if (result != TCL_OK) return result;
6744 xobjs.hold = (Boolean) tmpint;
6745 }
6746 break;
6747
6748 case EditInPlaceIdx:
6749 if (objc == 2) {
6750 Tcl_SetResult(interp, (areawin->editinplace) ? "true" : "false", NULL);
6751 }
6752 else {
6753 result = Tcl_GetBooleanFromObj(interp, objv[2], &tmpint);
6754 if (result != TCL_OK) return result;
6755 areawin->editinplace = (Boolean) tmpint;
6756 }
6757 break;
6758
6759 case ShowClipIdx:
6760 if (objc == 2) {
6761 Tcl_SetResult(interp, (areawin->showclipmasks) ? "show" : "hide", NULL);
6762 }
6763 else {
6764 tmpstr = Tcl_GetString(objv[2]);
6765 if (!strcmp(tmpstr, "show"))
6766 tmpint = True;
6767 else if (!strcmp(tmpstr, "hide"))
6768 tmpint = False;
6769 else {
6770 result = Tcl_GetBooleanFromObj(interp, objv[2], &tmpint);
6771 if (result != TCL_OK) return result;
6772 }
6773 areawin->showclipmasks = (Boolean) tmpint;
6774 }
6775 break;
6776
6777 case PinPosIdx:
6778 if (objc == 2) {
6779 Tcl_SetResult(interp, (areawin->pinpointon) ? "visible" : "invisible", NULL);
6780 }
6781 else {
6782 tmpstr = Tcl_GetString(objv[2]);
6783 if (strstr(tmpstr, "visible"))
6784 tmpint = (tmpstr[0] == 'i') ? False : True;
6785 else {
6786 result = Tcl_GetBooleanFromObj(interp, objv[2], &tmpint);
6787 if (result != TCL_OK) return result;
6788 }
6789 areawin->pinpointon = (Boolean) tmpint;
6790 }
6791 break;
6792
6793 case PinAttachIdx:
6794 if (objc == 2) {
6795 Tcl_SetResult(interp, (areawin->pinattach) ? "true" : "false", NULL);
6796 }
6797 else {
6798 result = Tcl_GetBooleanFromObj(interp, objv[2], &tmpint);
6799 if (result != TCL_OK) return result;
6800 areawin->pinattach = (Boolean) tmpint;
6801 }
6802 break;
6803
6804 case ColorSchemeIdx:
6805 if (objc == 2) {
6806 Tcl_SetResult(interp, (areawin->invert) ? "inverse" : "normal", NULL);
6807 }
6808 else {
6809 tmpstr = Tcl_GetString(objv[2]);
6810 if (!strcmp(tmpstr, "normal") || !strcmp(tmpstr, "standard"))
6811 tmpint = False;
6812 else if (!strcmp(tmpstr, "inverse") || !strcmp(tmpstr, "alternate"))
6813 tmpint = True;
6814 else {
6815 result = Tcl_GetBooleanFromObj(interp, objv[2], &tmpint);
6816 if (result != TCL_OK) return result;
6817 }
6818 areawin->invert = (Boolean) tmpint;
6819 setcolorscheme(!areawin->invert);
6820 }
6821 break;
6822
6823 case CoordStyleIdx:
6824 if (objc == 2) {
6825 switch (curpage->coordstyle) {
6826 case DEC_INCH: idx = 0; break;
6827 case FRAC_INCH: idx = 1; break;
6828 case CM: idx = 2; break;
6829 case INTERNAL: idx = 3; break;
6830 }
6831 Tcl_SetObjResult(interp, Tcl_NewStringObj(coordsubCmds[idx],
6832 strlen(coordsubCmds[idx])));
6833 }
6834 else if (objc != 3) {
6835 Tcl_WrongNumArgs(interp, 2, objv, "coordstyle ?arg ...?");
6836 return TCL_ERROR;
6837 }
6838 else {
6839 if (Tcl_GetIndexFromObj(interp, objv[2],
6840 (CONST84 char **)coordsubCmds,
6841 "option", 0, &idx) != TCL_OK) {
6842 return TCL_ERROR;
6843 }
6844 switch (idx) {
6845 case 0: tmpint = DEC_INCH; break;
6846 case 1: tmpint = FRAC_INCH; break;
6847 case 2: tmpint = CM; break;
6848 case 3: tmpint = INTERNAL; break;
6849 }
6850 getgridtype(NULL, tmpint, NULL);
6851 }
6852 break;
6853
6854 case ScaleIdx:
6855 if (objc == 2) {
6856 Tcl_Obj *objPtr = Tcl_NewListObj(0, NULL);
6857 Tcl_ListObjAppendElement(interp, objPtr,
6858 Tcl_NewIntObj((int)curpage->drawingscale.x));
6859 Tcl_ListObjAppendElement(interp, objPtr,
6860 Tcl_NewStringObj(":", 1));
6861 Tcl_ListObjAppendElement(interp, objPtr,
6862 Tcl_NewIntObj((int)curpage->drawingscale.y));
6863 Tcl_SetObjResult(interp, objPtr);
6864 }
6865 else if (objc == 3) {
6866 strcpy(_STR2, Tcl_GetString(objv[2]));
6867 setdscale(NULL, &(curpage->drawingscale));
6868 }
6869 else {
6870 Tcl_WrongNumArgs(interp, 2, objv, "drawingscale ?arg ...?");
6871 return TCL_ERROR;
6872 }
6873 break;
6874
6875 case TechnologysIdx:
6876 if (objc == 2) {
6877 Tcl_SetResult(interp, (xobjs.showtech) ? "true" : "false", NULL);
6878 }
6879 else {
6880 short libnum;
6881
6882 result = Tcl_GetBooleanFromObj(interp, objv[2], &tmpint);
6883 if (result != TCL_OK) return result;
6884 if (xobjs.showtech != (Boolean) tmpint) {
6885 xobjs.showtech = (Boolean) tmpint;
6886
6887 /* When namespaces are included, the length of the printed */
6888 /* name may cause names to overlap, so recompose each */
6889 /* library when the showtech flag is changed. */
6890 for (libnum = 0; libnum < xobjs.numlibs; libnum++)
6891 composelib(LIBRARY + libnum);
6892
6893 if (eventmode == CATALOG_MODE) refresh(NULL, NULL, NULL);
6894 }
6895 }
6896 break;
6897
6898 case ManhattanIdx:
6899 if (objc == 2) {
6900 Tcl_SetResult(interp, (areawin->manhatn) ? "true" : "false", NULL);
6901 }
6902 else {
6903 result = Tcl_GetBooleanFromObj(interp, objv[2], &tmpint);
6904 if (result != TCL_OK) return result;
6905 areawin->manhatn = (Boolean) tmpint;
6906 }
6907 break;
6908
6909 case CenteringIdx:
6910 if (objc == 2) {
6911 Tcl_SetResult(interp, (areawin->center) ? "true" : "false", NULL);
6912 }
6913 else {
6914 result = Tcl_GetBooleanFromObj(interp, objv[2], &tmpint);
6915 if (result != TCL_OK) return result;
6916 areawin->center = (Boolean) tmpint;
6917 }
6918 break;
6919
6920 case FilterIdx:
6921 if (objc == 2) {
6922 for (i = 0; i < 6; i++) {
6923 tmpint = 1 << i;
6924 if (areawin->filter & tmpint) {
6925 Tcl_AppendElement(interp, filterTypes[i]);
6926 }
6927 }
6928 }
6929 else if (objc >= 3) {
6930 if (Tcl_GetIndexFromObj(interp, objv[2],
6931 (CONST84 char **)filterTypes,
6932 "filter_type", 0, &tmpint) != TCL_OK) {
6933 return TCL_ERROR;
6934 }
6935 if (objc == 3) {
6936 if (areawin->filter & (1 << tmpint))
6937 Tcl_SetResult(interp, "true", NULL);
6938 else
6939 Tcl_SetResult(interp, "false", NULL);
6940 }
6941 else {
6942 int ftype = 1 << tmpint;
6943 if (!strcmp(Tcl_GetString(objv[3]), "true"))
6944 areawin->filter |= ftype;
6945 else
6946 areawin->filter &= (~ftype);
6947 }
6948 }
6949 break;
6950
6951 case BusCharIdx:
6952 if (objc == 2) {
6953 buffer[0] = '\\';
6954 buffer[1] = areawin->buschar;
6955 buffer[2] = '\0';
6956 Tcl_SetResult(interp, buffer, TCL_VOLATILE);
6957 }
6958 else if (objc == 3) {
6959 tmpstr = Tcl_GetString(objv[2]);
6960 areawin->buschar = (tmpstr[0] == '\\') ? tmpstr[1] : tmpstr[0];
6961 }
6962 break;
6963
6964 case BackupIdx:
6965 if (objc == 2) {
6966 Tcl_SetResult(interp, (xobjs.retain_backup) ? "true" : "false", NULL);
6967 }
6968 else {
6969 result = Tcl_GetBooleanFromObj(interp, objv[2], &tmpint);
6970 if (result != TCL_OK) return result;
6971 xobjs.retain_backup = (Boolean) tmpint;
6972 }
6973 break;
6974
6975 case SearchIdx:
6976 if (objc < 3) {
6977 Tcl_WrongNumArgs(interp, 2, objv, "search files|libraries ?arg ...?");
6978 return TCL_ERROR;
6979 }
6980 if (Tcl_GetIndexFromObj(interp, objv[2],
6981 (CONST84 char **)searchOpts, "options", 0, &idx) != TCL_OK) {
6982 return TCL_ERROR;
6983 }
6984 sptr = (idx == 0) ? &xobjs.filesearchpath : &xobjs.libsearchpath;
6985 if (objc == 3) {
6986 if (*sptr != NULL) Tcl_SetResult(interp, *sptr, TCL_VOLATILE);
6987 }
6988 else {
6989 if (*sptr != NULL) free(*sptr);
6990 *sptr = NULL;
6991 tmpstr = Tcl_GetString(objv[3]);
6992 if (strlen(tmpstr) > 0)
6993 *sptr = strdup(Tcl_GetString(objv[3]));
6994 }
6995 break;
6996 }
6997 return XcTagCallback(interp, objc, objv);
6998 }
6999
7000 /*----------------------------------------------------------------------*/
7001
7002 int xctcl_promptsavepage(ClientData clientData, Tcl_Interp *interp,
7003 int objc, Tcl_Obj *CONST objv[])
7004 {
7005 int page = areawin->page;
7006 int result;
7007 Pagedata *curpage;
7008 objectptr pageobj;
7009 struct stat statbuf;
7010
7011 /* save page popup */
7012
7013 if (objc > 2) {
7014 Tcl_WrongNumArgs(interp, 1, objv, "[page_number]");
7015 return TCL_ERROR;
7016 }
7017 else if (objc == 2) {
7018 result = Tcl_GetIntFromObj(interp, objv[1], &page);
7019 if (result != TCL_OK) return result;
7020 }
7021 else page = areawin->page;
7022
7023 curpage = xobjs.pagelist[page];
7024 if (curpage->pageinst == NULL) {
7025 Tcl_SetResult(interp, "Page does not exist. . . cannot save.", NULL);
7026 return TCL_ERROR;
7027 }
7028 pageobj = curpage->pageinst->thisobject;
7029
7030 /* recompute bounding box and auto-scale, if set */
7031
7032 calcbbox(xobjs.pagelist[page]->pageinst);
7033 if (curpage->pmode & 2) autoscale(page);
7034
7035 /* get file information, if filename is set */
7036
7037 if (curpage->filename != NULL) {
7038 if (strstr(curpage->filename, ".") == NULL)
7039 sprintf(_STR2, "%s.ps", curpage->filename);
7040 else sprintf(_STR2, "%s", curpage->filename);
7041 if (stat(_STR2, &statbuf) == 0) {
7042 Wprintf(" Warning: File exists");
7043 }
7044 else {
7045 if (errno == ENOTDIR)
7046 Wprintf("Error: Incorrect pathname");
7047 else if (errno == EACCES)
7048 Wprintf("Error: Path not readable");
7049 else
7050 W3printf(" ");
7051 }
7052 }
7053 Tcl_SetObjResult(interp, Tcl_NewIntObj((int)page));
7054
7055 return XcTagCallback(interp, objc, objv);
7056 }
7057
7058 /*----------------------------------------------------------------------*/
7059
7060 int xctcl_quit(ClientData clientData, Tcl_Interp *interp,
7061 int objc, Tcl_Obj *CONST objv[])
7062 {
7063 Boolean is_intr = False;
7064
7065 /* quit, without checks */
7066 if (objc != 1) {
7067 if (strncasecmp(Tcl_GetString(objv[0]), "intr", 4))
7068 is_intr = True;
7069 else {
7070 Tcl_WrongNumArgs(interp, 1, objv, "(no arguments)");
7071 return TCL_ERROR;
7072 }
7073 }
7074 quit(areawin->area, NULL);
7075
7076 if (consoleinterp == interp)
7077 Tcl_Exit(XcTagCallback(interp, objc, objv));
7078 else {
7079 /* Ham-fisted, but prevents hanging on Ctrl-C kill */
7080 if (is_intr) exit(1);
7081 Tcl_Eval(interp, "catch {tkcon eval exit}\n");
7082 }
7083
7084 return TCL_OK; /* Not reached */
7085 }
7086
7087 /*----------------------------------------------------------------------*/
7088
7089 int xctcl_promptquit(ClientData clientData, Tcl_Interp *interp,
7090 int objc, Tcl_Obj *CONST objv[])
7091 {
7092 int result;
7093
7094 /* quit, with checks */
7095 if (objc != 1) {
7096 Tcl_WrongNumArgs(interp, 1, objv, "(no arguments)");
7097 return TCL_ERROR;
7098 }
7099 if (areawin != NULL) {
7100 result = quitcheck(areawin->area, NULL, NULL);
7101 if (result == 1) {
7102 /* Immediate exit */
7103 if (consoleinterp == interp)
7104 Tcl_Exit(XcTagCallback(interp, objc, objv));
7105 else
7106 Tcl_Eval(interp, "catch {tkcon eval exit}\n");
7107 }
7108 }
7109 return XcTagCallback(interp, objc, objv);
7110 }
7111
7112 /*----------------------------------------------------------------------*/
7113
7114 int xctcl_refresh(ClientData clientData, Tcl_Interp *interp,
7115 int objc, Tcl_Obj *CONST objv[])
7116 {
7117 /* refresh */
7118 if (objc != 1) {
7119 Tcl_WrongNumArgs(interp, 1, objv, "(no arguments)");
7120 return TCL_ERROR;
7121 }
7122 areawin->redraw_needed = True;
7123 drawarea(areawin->area, (caddr_t)clientData, (caddr_t)NULL);
7124 if (areawin->scrollbarh)
7125 drawhbar(areawin->scrollbarh, NULL, NULL);
7126 if (areawin->scrollbarv)
7127 drawvbar(areawin->scrollbarv, NULL, NULL);
7128 printname(topobject);
7129 return XcTagCallback(interp, objc, objv);
7130 }
7131
7132 /*----------------------------------------------------------------------*/
7133 /* Load a schematic that belongs to a symbol referenced by the current */
7134 /* schematic by loading the file pointed to by the "link" parameter */
7135 /* in the symbol. */
7136 /* */
7137 /* Return 1 on success, 0 if the link has already been loaded, and -1 */
7138 /* on failure to find, open, or read the link's schematic. */
7139 /*----------------------------------------------------------------------*/
7140
7141 int loadlinkfile(objinstptr tinst, char *filename, int target, Boolean do_load)
7142 {
7143 int j, savepage;
7144 FILE *ps;
7145 char file_return[150];
7146 int result;
7147 Boolean fgood;
7148
7149 /* Shorthand: "%n" can be used to indicate that the link filename is */
7150 /* the same as the name of the object, minus technology prefix. */
7151 /* While unlikely to be used, "%N" includes the technology prefix. */
7152
7153 if (!strcmp(filename, "%n")) {
7154 char *suffix = strstr(tinst->thisobject->name, "::");
7155 if (suffix == NULL)
7156 suffix = tinst->thisobject->name;
7157 else
7158 suffix += 2;
7159 strcpy(_STR, suffix);
7160 }
7161 else if (!strcmp(filename, "%N"))
7162 strcpy(_STR, tinst->thisobject->name);
7163 else
7164 strcpy(_STR, filename);
7165
7166 /* When loading links, we want to avoid */
7167 /* loading the same file more than once, so */
7168 /* compare filename against all existing */
7169 /* page filenames. Also compare links; any */
7170 /* page with a link to the same object is a */
7171 /* duplicate. */
7172
7173 ps = fileopen(_STR, ".ps", file_return, 149);
7174 if (ps != NULL) {
7175 fgood = TRUE;
7176 fclose(ps);
7177 }
7178 else
7179 fgood = FALSE;
7180
7181 for (j = 0; j < xobjs.pages; j++) {
7182 if (xobjs.pagelist[j]->filename == NULL)
7183 continue;
7184 else if (!strcmp(file_return, xobjs.pagelist[j]->filename))
7185 break;
7186 else if ((strlen(xobjs.pagelist[j]->filename) > 0) &&
7187 !strcmp(file_return + strlen(file_return) - 3, ".ps")
7188 && !strncmp(xobjs.pagelist[j]->filename, file_return,
7189 strlen(file_return) - 3))
7190 break;
7191 else if ((xobjs.pagelist[j]->pageinst != NULL) && (tinst->thisobject ==
7192 xobjs.pagelist[j]->pageinst->thisobject->symschem))
7193 break;
7194 }
7195 if (j < xobjs.pages) {
7196
7197 /* Duplicate page. Don't load it, but make sure that an association */
7198 /* exists between the symbol and schematic. */
7199
7200 if (tinst->thisobject->symschem == NULL) {
7201 tinst->thisobject->symschem =
7202 xobjs.pagelist[j]->pageinst->thisobject;
7203 if (xobjs.pagelist[j]->pageinst->thisobject->symschem == NULL)
7204 xobjs.pagelist[j]->pageinst->thisobject->symschem = tinst->thisobject;
7205 }
7206 return 0;
7207 }
7208
7209 if (fgood == FALSE) {
7210 Fprintf(stderr, "Failed to open dependency \"%s\"\n", _STR);
7211 return -1;
7212 }
7213
7214 /* Report that a pending link exists, but do not load it. */
7215 if (!do_load) return 1;
7216
7217 savepage = areawin->page;
7218 while (areawin->page < xobjs.pages &&
7219 xobjs.pagelist[areawin->page]->pageinst != NULL &&
7220 xobjs.pagelist[areawin->page]->pageinst->thisobject->parts > 0)
7221 areawin->page++;
7222
7223 changepage(areawin->page);
7224 result = (loadfile(0, (target >= 0) ? target + LIBRARY : -1) == TRUE) ? 1 : -1;
7225
7226 /* Make symschem link if not done by loadfile() */
7227
7228 if (tinst->thisobject->symschem == NULL) {
7229 tinst->thisobject->symschem =
7230 xobjs.pagelist[areawin->page]->pageinst->thisobject;
7231
7232 /* Many symbols may link to one schematic, but a schematic can */
7233 /* only link to one symbol (the first one associated). */
7234
7235 if (xobjs.pagelist[areawin->page]->pageinst->thisobject->symschem == NULL)
7236 xobjs.pagelist[areawin->page]->pageinst->thisobject->symschem
7237 = tinst->thisobject;
7238 }
7239 changepage(savepage);
7240 return result;
7241 }
7242
7243 /*----------------------------------------------------------------------*/
7244
7245 int xctcl_page(ClientData clientData, Tcl_Interp *interp,
7246 int objc, Tcl_Obj *CONST objv[])
7247 {
7248 int result, idx, nidx, aval, i, locidx;
7249 int cpage, multi, savepage, pageno = -1, linktype, importtype;
7250 char *filename, *froot, *astr;
7251 Tcl_Obj *objPtr;
7252 double newheight, newwidth, newscale;
7253 float oldscale;
7254 int newrot, newmode;
7255 objectptr pageobj;
7256 oparamptr ops;
7257 char *oldstr, *newstr, *key, *argv;
7258 Pagedata *curpage, *lpage;
7259 short *pagelist;
7260 u_short changes;
7261 int target = -1;
7262 Boolean forcepage = FALSE;
7263
7264 char *subCmds[] = {
7265 "load", "list", "import", "save", "saveonly", "make", "directory",
7266 "reset", "links", "fit", "filename", "label", "scale", "width",
7267 "height", "size", "margins", "bbox", "goto", "orientation",
7268 "encapsulation", "handle", "update", "changes", NULL
7269 };
7270 enum SubIdx {
7271 LoadIdx, ListIdx, ImportIdx, SaveIdx, SaveOnlyIdx, MakeIdx, DirIdx,
7272 ResetIdx, LinksIdx, FitIdx, FileIdx, LabelIdx, ScaleIdx,
7273 WidthIdx, HeightIdx, SizeIdx, MarginsIdx, BBoxIdx, GoToIdx,
7274 OrientIdx, EPSIdx, HandleIdx, UpdateIdx, ChangesIdx
7275 };
7276
7277 char *importTypes[] = {"xcircuit", "postscript", "background", "spice", NULL};
7278 enum ImportTypes {
7279 XCircuitIdx, PostScriptIdx, BackGroundIdx, SPICEIdx
7280 };
7281
7282 char *linkTypes[] = {"independent", "dependent", "total", "linked",
7283 "pagedependent", "all", "pending", "sheet", "load", NULL};
7284 enum LinkTypes {
7285 IndepIdx, DepIdx, TotalIdx, LinkedIdx, PageDepIdx, AllIdx, PendingIdx,
7286 SheetIdx, LinkLoadIdx
7287 };
7288 char *psTypes[] = {"eps", "full", NULL};
7289
7290 if (areawin == NULL) {
7291 Tcl_SetResult(interp, "No database!", NULL);
7292 return TCL_ERROR;
7293 }
7294 savepage = areawin->page;
7295
7296 /* Check for option "-force" (create page if it doesn't exist) */
7297 if (!strncmp(Tcl_GetString(objv[objc - 1]), "-forc", 5)) {
7298 forcepage = TRUE;
7299 objc--;
7300 }
7301
7302 result = ParsePageArguments(interp, objc, objv, &nidx, &pageno);
7303 if ((result != TCL_OK) || (nidx < 0)) {
7304 if (forcepage && (pageno == xobjs.pages)) {
7305 /* For now, allow a page to be created only if the page number */
7306 /* is one higher than the current last page. */
7307 Tcl_ResetResult(interp);
7308 idx = MakeIdx;
7309 nidx = 0;
7310 pageno = areawin->page; /* so we don't get a segfault */
7311 }
7312 else
7313 return result;
7314 }
7315 else if (nidx == 1 && objc == 2) {
7316 idx = GoToIdx;
7317 }
7318 else if (Tcl_GetIndexFromObj(interp, objv[1 + nidx],
7319 (CONST84 char **)subCmds, "option", 0, &idx) != TCL_OK) {
7320 return result;
7321 }
7322
7323 result = TCL_OK;
7324
7325 curpage = xobjs.pagelist[pageno];
7326
7327 if (curpage->pageinst != NULL)
7328 pageobj = curpage->pageinst->thisobject;
7329 else {
7330 if (idx != LoadIdx && idx != MakeIdx && idx != DirIdx && idx != GoToIdx) {
7331 Tcl_SetResult(interp, "Cannot do function on non-initialized page.", NULL);
7332 return TCL_ERROR;
7333 }
7334 }
7335
7336 switch (idx) {
7337 case HandleIdx:
7338 /* return handle of page instance */
7339 objPtr = Tcl_NewHandleObj(curpage->pageinst);
7340 Tcl_SetObjResult(interp, objPtr);
7341 break;
7342
7343 case ResetIdx:
7344 /* clear page */
7345 resetbutton(NULL, (pointertype)(pageno + 1), NULL);
7346 break;
7347
7348 case ListIdx:
7349 /* return a list of all non-empty pages */
7350 objPtr = Tcl_NewListObj(0, NULL);
7351 for (i = 0; i < xobjs.pages; i++) {
7352 lpage = xobjs.pagelist[i];
7353 if ((lpage != NULL) && (lpage->pageinst != NULL)) {
7354 Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewIntObj(i + 1));
7355 }
7356 }
7357 Tcl_SetObjResult(interp, objPtr);
7358 break;
7359
7360 case LoadIdx:
7361 TechReplaceSave();
7362 sprintf(_STR2, Tcl_GetString(objv[2 + nidx]));
7363 for (i = 3 + nidx; i < objc; i++) {
7364 argv = Tcl_GetString(objv[i]);
7365 if ((*argv == '-') && !strncmp(argv, "-repl", 5)) {
7366 if (i < objc - 1) {
7367 char *techstr = Tcl_GetString(objv[i + 1]);
7368 if (!strcmp(techstr, "all") || !strcmp(techstr, "any"))
7369 TechReplaceAll();
7370 else if (!strcmp(techstr, "none")) TechReplaceNone();
7371 else {
7372 TechPtr nsptr = LookupTechnology(techstr);
7373 if (nsptr != NULL) nsptr->flags |= TECH_REPLACE;
7374 }
7375 i++;
7376 }
7377 else
7378 TechReplaceAll(); /* replace ALL */
7379 }
7380 else if ((*argv == '-') && !strncmp(argv, "-targ", 5)) {
7381 if (i < objc - 1) {
7382 ParseLibArguments(interp, 2, &objv[i], NULL, &target);
7383 i++;
7384 }
7385 }
7386 else {
7387 strcat(_STR2, ",");
7388 strcat(_STR2, argv);
7389 }
7390 }
7391
7392 if (savepage != pageno) newpage(pageno);
7393 startloadfile((target >= 0) ? target + LIBRARY : -1);
7394 if (savepage != pageno) newpage(savepage);
7395 TechReplaceRestore();
7396 break;
7397
7398 case ImportIdx:
7399 if ((objc - nidx) < 3) {
7400 Tcl_WrongNumArgs(interp, 2, objv, "option");
7401 return TCL_ERROR;
7402 }
7403
7404 if (Tcl_GetIndexFromObj(interp, objv[2 + nidx],
7405 (CONST84 char **)importTypes, "file type",
7406 0, &importtype) != TCL_OK)
7407 return TCL_ERROR;
7408
7409 /* First check the number of arguments, which varies by option. */
7410
7411 switch (importtype) {
7412
7413 /* Xcircuit imports may specify any number of files > 1. */
7414
7415 case XCircuitIdx:
7416 if ((objc - nidx) == 3) {
7417 Tcl_SetResult(interp, "Must specify a filename to import!", NULL);
7418 return TCL_ERROR;
7419 }
7420 break;
7421
7422 /* Postscript imports may specify 1 or 0 files. 0 causes */
7423 /* the function to report back what file is the background. */
7424
7425 case PostScriptIdx:
7426 case BackGroundIdx:
7427 if ((objc - nidx) != 3 && (objc - nidx) != 4) {
7428 Tcl_SetResult(interp, "Can only specify one filename "
7429 "for background", NULL);
7430 return TCL_ERROR;
7431 }
7432
7433 /* All other import types must specify exactly one filename. */
7434
7435 default:
7436 if ((objc - nidx) != 4) {
7437 Tcl_SetResult(interp, "Must specify one filename "
7438 "for import", NULL);
7439 return TCL_ERROR;
7440 }
7441 break;
7442 }
7443
7444 /* Now process the option */
7445
7446 switch (importtype) {
7447 case XCircuitIdx:
7448 sprintf(_STR2, Tcl_GetString(objv[3 + nidx]));
7449 for (i = 4; i < objc; i++) {
7450 strcat(_STR2, ",");
7451 strcat(_STR2, Tcl_GetString(objv[i + nidx]));
7452 }
7453 if (savepage != pageno) newpage(pageno);
7454 importfile();
7455 if (savepage != pageno) newpage(savepage);
7456 break;
7457 case PostScriptIdx: /* replaces "background" */
7458 case BackGroundIdx:
7459 if (objc - nidx == 2) {
7460 objPtr = Tcl_NewStringObj(curpage->background.name,
7461 strlen(curpage->background.name));
7462 Tcl_SetObjResult(interp, objPtr);
7463 return XcTagCallback(interp, objc, objv);
7464 }
7465 sprintf(_STR2, Tcl_GetString(objv[3 + nidx]));
7466 if (savepage != pageno) newpage(pageno);
7467 loadbackground();
7468 if (savepage != pageno) newpage(savepage);
7469 break;
7470
7471 case SPICEIdx:
7472 #ifdef ASG
7473 /* Make sure that the ASG library is present */
7474
7475 if (NameToLibrary(ASG_SPICE_LIB) < 0) {
7476 short ilib;
7477
7478 strcpy(_STR, ASG_SPICE_LIB);
7479 ilib = createlibrary(FALSE);
7480 if (loadlibrary(ilib) == FALSE) {
7481 Tcl_SetResult(interp, "Error loading library.\n", NULL);
7482 return TCL_ERROR;
7483 }
7484
7485 }
7486
7487 sprintf(_STR2, Tcl_GetString(objv[3 + nidx]));
7488 if (savepage != pageno) newpage(pageno);
7489 importspice();
7490 if (savepage != pageno) newpage(savepage);
7491 #else
7492 Tcl_SetResult(interp, "ASG not compiled in; "
7493 "function is unavailable.\n", NULL);
7494 return TCL_ERROR;
7495 #endif
7496 break;
7497 }
7498
7499 /* Redraw */
7500 drawarea(areawin->area, NULL, NULL);
7501 break;
7502
7503 case MakeIdx:
7504 if (nidx == 1) {
7505 Tcl_SetResult(interp, "syntax is: \"page make [<name>]\"", NULL);
7506 return TCL_ERROR;
7507 }
7508 if (objc != 2 && objc != 3) {
7509 Tcl_WrongNumArgs(interp, 2, objv, "make [<name>]");
7510 return TCL_ERROR;
7511 }
7512 newpage((short)255);
7513 if (objc == 3) {
7514 curpage = xobjs.pagelist[areawin->page];
7515 strcpy(curpage->pageinst->thisobject->name,
7516 Tcl_GetString(objv[2]));
7517 }
7518 updatepagelib(PAGELIB, areawin->page);
7519 printname(topobject);
7520 break;
7521 case SaveOnlyIdx:
7522 case SaveIdx:
7523 if (objc - nidx > 3) {
7524 Tcl_WrongNumArgs(interp, 2, objv, "[filename]");
7525 return TCL_ERROR;
7526 }
7527 else if (objc - nidx == 3) {
7528 filename = Tcl_GetString(objv[nidx + 2]);
7529 if (strcmp(filename, curpage->filename)) {
7530 Wprintf("Warning: Filename is \"%s\" but will be "
7531 "saved as \"%s\"\n", curpage->filename, filename);
7532 }
7533 }
7534 else if (curpage->filename == NULL) {
7535 Fprintf(stderr, "Warning: Filename created to match object name\n");
7536 filename = curpage->pageinst->thisobject->name;
7537 }
7538 else
7539 filename = curpage->filename;
7540
7541 if (savepage != pageno) newpage(pageno);
7542 if (!strncmp(Tcl_GetString(objv[nidx + 1]), "saveo", 5))
7543 setfile(filename, NO_SUBCIRCUITS);
7544 else
7545 setfile(filename, CURRENT_PAGE);
7546 if (savepage != pageno) newpage(savepage);
7547 break;
7548
7549 case LinksIdx:
7550 if ((objc - nidx) < 2 && (objc - nidx) > 6) {
7551 Tcl_WrongNumArgs(interp, 1, objv, "links");
7552 return TCL_ERROR;
7553 }
7554 if ((objc - nidx) == 2)
7555 linktype = TOTAL_PAGES;
7556 else {
7557 if (Tcl_GetIndexFromObj(interp, objv[2 + nidx],
7558 (CONST84 char **)linkTypes,
7559 "link type", 0, &linktype) != TCL_OK)
7560 return TCL_ERROR;
7561 }
7562 multi = 0;
7563 pagelist = pagetotals(pageno, (linktype >= PendingIdx) ?
7564 LINKED_PAGES : linktype);
7565 TechReplaceSave();
7566 switch (linktype) {
7567
7568 /* Load any pending links, that is, objects that have a */
7569 /* "link" parameter containing a string indicating a file */
7570 /* defining the schematic for that symbol. Allow the use */
7571 /* of the same "-replace" flag used by "page load". */
7572
7573 case LinkLoadIdx:
7574 locidx = objc - 1;
7575 argv = Tcl_GetString(objv[locidx]);
7576 if (*argv != '-') argv = Tcl_GetString(objv[--locidx]);
7577 if ((*argv == '-') && !strncmp(argv, "-repl", 5)) {
7578 if (locidx < objc - 1) {
7579 char *techstr = Tcl_GetString(objv[locidx + 1]);
7580 if (!strcmp(techstr, "all")) TechReplaceAll();
7581 else if (!strcmp(techstr, "none")) TechReplaceNone();
7582 else {
7583 TechPtr nsptr = LookupTechnology(techstr);
7584 if (nsptr != NULL)
7585 nsptr->flags |= TECH_REPLACE;
7586 }
7587 objc--;
7588 }
7589 else
7590 TechReplaceAll(); /* replace ALL */
7591 objc--;
7592 }
7593 if ((*argv == '-') && !strncmp(argv, "-targ", 5)) {
7594 if (locidx < objc - 1) {
7595 ParseLibArguments(interp, 2, &objv[locidx], NULL, &target);
7596 objc--;
7597 }
7598 objc--;
7599 }
7600 /* drop through */
7601
7602 case PendingIdx:
7603 key = ((objc - nidx) == 4) ? Tcl_GetString(objv[3 + nidx]) : "link";
7604 for (i = 0; i < xobjs.pages; i++) {
7605 if (pagelist[i] > 0) {
7606 objinstptr tinst;
7607 objectptr tpage = xobjs.pagelist[i]->pageinst->thisobject;
7608 genericptr *tgen;
7609
7610 for (tgen = tpage->plist; tgen < tpage->plist
7611 + tpage->parts; tgen++) {
7612 if ((*tgen)->type == OBJINST) {
7613 tinst = TOOBJINST(tgen);
7614 /* Corrected 8/31/07: Instance value of "link" has */
7615 /* priority over any default value in the object! */
7616 ops = find_param(tinst, key);
7617 if ((ops != NULL) && (ops->type == XC_STRING)) {
7618 filename = textprint(ops->parameter.string, tinst);
7619 if (strlen(filename) > 0) {
7620 if ((result = loadlinkfile(tinst, filename, target,
7621 (linktype == LinkLoadIdx))) > 0) {
7622 multi++;
7623 setsymschem(); /* Update GUI */
7624 result = TCL_OK;
7625 }
7626 else if (result < 0) {
7627 Tcl_SetResult(interp, "Cannot load link", NULL);
7628 result = TCL_ERROR;
7629 }
7630 else result = TCL_OK;
7631 }
7632 free(filename);
7633 }
7634 }
7635 }
7636 }
7637 }
7638 break;
7639 default:
7640 for (i = 0; i < xobjs.pages; i++) {
7641 if (pagelist[i] > 0) {
7642 multi++;
7643 if ((linktype == SheetIdx) && (i == pageno) && (pagelist[i] > 0))
7644 break;
7645 }
7646 }
7647 break;
7648 }
7649 TechReplaceRestore();
7650 free((char *)pagelist);
7651 if (result == TCL_ERROR) return result;
7652 Tcl_SetObjResult(interp, Tcl_NewIntObj(multi));
7653 break;
7654
7655 case DirIdx:
7656 startcatalog(NULL, PAGELIB, NULL);
7657 break;
7658
7659 case GoToIdx:
7660 newpage((short)pageno);
7661 break;
7662
7663 case UpdateIdx:
7664 calcbbox(curpage->pageinst);
7665 if (curpage->pmode & 2) autoscale(pageno);
7666 break;
7667
7668 case BBoxIdx:
7669 if (((objc - nidx) == 2) || ((objc - nidx) == 3)) {
7670 Tcl_Obj *tuple;
7671 BBox *bbox, *sbbox;
7672 int value;
7673
7674 bbox = &curpage->pageinst->bbox;
7675 if (bbox == NULL)
7676 bbox = &curpage->pageinst->thisobject->bbox;
7677 sbbox = bbox;
7678
7679 if ((objc - nidx) == 3) {
7680 sbbox = curpage->pageinst->schembbox;
7681 if (sbbox == NULL) sbbox = bbox;
7682 }
7683
7684 objPtr = Tcl_NewListObj(0, NULL);
7685
7686 tuple = Tcl_NewListObj(0, NULL);
7687 value = min(sbbox->lowerleft.x, bbox->lowerleft.x);
7688 Tcl_ListObjAppendElement(interp, tuple, Tcl_NewIntObj(value));
7689 value = min(sbbox->lowerleft.y, bbox->lowerleft.y);
7690 Tcl_ListObjAppendElement(interp, tuple, Tcl_NewIntObj(value));
7691 Tcl_ListObjAppendElement(interp, objPtr, tuple);
7692
7693 tuple = Tcl_NewListObj(0, NULL);
7694 value = max(sbbox->lowerleft.x + sbbox->width,
7695 bbox->lowerleft.x + bbox->width);
7696 Tcl_ListObjAppendElement(interp, tuple, Tcl_NewIntObj(value));
7697 value = max(sbbox->lowerleft.y + sbbox->height,
7698 bbox->lowerleft.y + bbox->height);
7699 Tcl_ListObjAppendElement(interp, tuple, Tcl_NewIntObj(value));
7700 Tcl_ListObjAppendElement(interp, objPtr, tuple);
7701
7702 Tcl_SetObjResult(interp, objPtr);
7703 return XcTagCallback(interp, objc, objv);
7704 }
7705 else {
7706 Tcl_WrongNumArgs(interp, 1, objv, "bbox [all]");
7707 return TCL_ERROR;
7708 }
7709 break;
7710
7711 case SizeIdx:
7712 if ((objc - nidx) != 2 && (objc - nidx) != 3) {
7713 Tcl_WrongNumArgs(interp, 1, objv, "size ?\"width x height\"?");
7714 return TCL_ERROR;
7715 }
7716 if ((objc - nidx) == 2) {
7717 float xsize, ysize, cfact;
7718
7719 objPtr = Tcl_NewListObj(0, NULL);
7720
7721 cfact = (curpage->coordstyle == CM) ? IN_CM_CONVERT
7722 : 72.0;
7723 xsize = (float)curpage->pagesize.x / cfact;
7724 ysize = (float)curpage->pagesize.y / cfact;
7725
7726 Tcl_ListObjAppendElement(interp, objPtr,
7727 Tcl_NewDoubleObj((double)xsize));
7728 Tcl_ListObjAppendElement(interp, objPtr,
7729 Tcl_NewStringObj("x", 1));
7730 Tcl_ListObjAppendElement(interp, objPtr,
7731 Tcl_NewDoubleObj((double)ysize));
7732 Tcl_ListObjAppendElement(interp, objPtr,
7733 Tcl_NewStringObj(((curpage->coordstyle == CM) ?
7734 "cm" : "in"), 2));
7735 Tcl_SetObjResult(interp, objPtr);
7736
7737 return XcTagCallback(interp, objc, objv);
7738 }
7739
7740 strcpy(_STR2, Tcl_GetString(objv[2 + nidx]));
7741 setoutputpagesize(&curpage->pagesize);
7742
7743 /* Only need to recompute values and refresh if autoscaling is enabled */
7744 if (curpage->pmode & 2) autoscale(pageno);
7745 break;
7746
7747 case MarginsIdx:
7748 if ((objc - nidx) < 2 && (objc - nidx) > 4) {
7749 Tcl_WrongNumArgs(interp, 1, objv, "margins ?x y?");
7750 return TCL_ERROR;
7751 }
7752 if ((objc - nidx) == 2) {
7753 newwidth = (double)curpage->margins.x / 72.0;
7754 newheight = (double)curpage->margins.y / 72.0;
7755 objPtr = Tcl_NewListObj(0, NULL);
7756 Tcl_ListObjAppendElement(interp, objPtr,
7757 Tcl_NewDoubleObj(newwidth));
7758 Tcl_ListObjAppendElement(interp, objPtr,
7759 Tcl_NewDoubleObj(newheight));
7760 Tcl_SetObjResult(interp, objPtr);
7761 return XcTagCallback(interp, objc, objv);
7762 }
7763 newwidth = (double)parseunits(Tcl_GetString(objv[2 + nidx]));
7764 if ((objc - nidx) == 4)
7765 newheight = (double)parseunits(Tcl_GetString(objv[3 + nidx]));
7766 else
7767 newheight = newwidth;
7768
7769 newheight *= 72.0;
7770 newwidth *= 72.0;
7771 curpage->margins.x = (int)newwidth;
7772 curpage->margins.y = (int)newheight;
7773 break;
7774
7775 case HeightIdx:
7776 if ((objc - nidx) != 2 && (objc - nidx) != 3) {
7777 Tcl_WrongNumArgs(interp, 1, objv, "height ?output_height?");
7778 return TCL_ERROR;
7779 }
7780 if ((objc - nidx) == 2) {
7781 newheight = toplevelheight(curpage->pageinst, NULL);
7782 newheight *= getpsscale(curpage->outscale, pageno);
7783 newheight /= (curpage->coordstyle == CM) ? IN_CM_CONVERT : 72.0;
7784 objPtr = Tcl_NewDoubleObj((double)newheight);
7785 Tcl_SetObjResult(interp, objPtr);
7786 return XcTagCallback(interp, objc, objv);
7787 }
7788 newheight = (double)parseunits(Tcl_GetString(objv[2 + nidx]));
7789 if (newheight <= 0 || topobject->bbox.height == 0) {
7790 Tcl_SetResult(interp, "Illegal height value", NULL);
7791 return TCL_ERROR;
7792 }
7793 newheight = (newheight * ((curpage->coordstyle == CM) ?
7794 IN_CM_CONVERT : 72.0)) / topobject->bbox.height;
7795 newheight /= getpsscale(1.0, pageno);
7796 curpage->outscale = (float)newheight;
7797
7798 if (curpage->pmode & 2) autoscale(pageno);
7799 break;
7800
7801 case WidthIdx:
7802 if ((objc - nidx) != 2 && (objc - nidx) != 3) {
7803 Tcl_WrongNumArgs(interp, 1, objv, "output_width");
7804 return TCL_ERROR;
7805 }
7806 if ((objc - nidx) == 2) {
7807 newwidth = toplevelwidth(curpage->pageinst, NULL);
7808 newwidth *= getpsscale(curpage->outscale, pageno);
7809 newwidth /= (curpage->coordstyle == CM) ? IN_CM_CONVERT : 72.0;
7810 objPtr = Tcl_NewDoubleObj((double)newwidth);
7811 Tcl_SetObjResult(interp, objPtr);
7812 return XcTagCallback(interp, objc, objv);
7813 }
7814 newwidth = (double)parseunits(Tcl_GetString(objv[2 + nidx]));
7815 if (newwidth <= 0 || topobject->bbox.width == 0) {
7816 Tcl_SetResult(interp, "Illegal width value", NULL);
7817 return TCL_ERROR;
7818 }
7819
7820 newwidth = (newwidth * ((curpage->coordstyle == CM) ?
7821 IN_CM_CONVERT : 72.0)) / topobject->bbox.width;
7822 newwidth /= getpsscale(1.0, pageno);
7823 curpage->outscale = (float)newwidth;
7824
7825 if (curpage->pmode & 2) autoscale(pageno);
7826 break;
7827
7828 case ScaleIdx:
7829 if ((objc - nidx) != 2 && (objc - nidx) != 3) {
7830 Tcl_WrongNumArgs(interp, 1, objv, "output_scale");
7831 return TCL_ERROR;
7832 }
7833 if ((objc - nidx) == 2) {
7834 objPtr = Tcl_NewDoubleObj((double)curpage->outscale);
7835 Tcl_SetObjResult(interp, objPtr);
7836 return XcTagCallback(interp, objc, objv);
7837 }
7838 result = Tcl_GetDoubleFromObj(interp, objv[2 + nidx], &newscale);
7839 if (result != TCL_OK) return result;
7840
7841 oldscale = curpage->outscale;
7842
7843 if (oldscale == (float)newscale) return TCL_OK; /* nothing to do */
7844 else curpage->outscale = (float)newscale;
7845
7846 if (curpage->pmode & 2) autoscale(pageno);
7847 break;
7848
7849 case OrientIdx:
7850 if ((objc - nidx) != 2 && (objc - nidx) != 3) {
7851 Tcl_WrongNumArgs(interp, 1, objv, "orientation");
7852 return TCL_ERROR;
7853 }
7854 if ((objc - nidx) == 2) {
7855 objPtr = Tcl_NewIntObj((int)curpage->orient);
7856 Tcl_SetObjResult(interp, objPtr);
7857 return XcTagCallback(interp, objc, objv);
7858 }
7859 result = Tcl_GetIntFromObj(interp, objv[2 + nidx], &newrot);
7860 if (result != TCL_OK) return result;
7861 curpage->orient = (short)newrot;
7862
7863 /* rescale after rotation if "auto-scale" is set */
7864 if (curpage->pmode & 2) autoscale(pageno);
7865 break;
7866
7867 case EPSIdx:
7868 if ((objc - nidx) != 2 && (objc - nidx) != 3) {
7869 Tcl_WrongNumArgs(interp, 1, objv, "encapsulation");
7870 return TCL_ERROR;
7871 }
7872 if ((objc - nidx) == 2) {
7873 newstr = psTypes[curpage->pmode & 1];
7874 Tcl_SetResult(interp, newstr, NULL);
7875 return XcTagCallback(interp, objc, objv);
7876 }
7877 newstr = Tcl_GetString(objv[2 + nidx]);
7878 if (Tcl_GetIndexFromObj(interp, objv[2 + nidx],
7879 (CONST84 char **)psTypes,
7880 "encapsulation", 0, &newmode) != TCL_OK) {
7881 return result;
7882 }
7883 curpage->pmode &= 0x2; /* preserve auto-fit flag */
7884 curpage->pmode |= (short)newmode;
7885 break;
7886
7887 case LabelIdx:
7888 if ((objc - nidx) != 2 && (objc - nidx) != 3) {
7889 Tcl_WrongNumArgs(interp, 1, objv, "label ?name?");
7890 return TCL_ERROR;
7891 }
7892 if ((objc - nidx) == 2) {
7893 objPtr = Tcl_NewStringObj(pageobj->name, strlen(pageobj->name));
7894 Tcl_SetObjResult(interp, objPtr);
7895 return XcTagCallback(interp, objc, objv);
7896 }
7897
7898 /* Whitespace and non-printing characters not allowed */
7899
7900 strcpy(_STR2, Tcl_GetString(objv[2 + nidx]));
7901 for (i = 0; i < strlen(_STR2); i++) {
7902 if ((!isprint(_STR2[i])) || (isspace(_STR2[i]))) {
7903 _STR2[i] = '_';
7904 Wprintf("Replaced illegal whitespace in name with underscore");
7905 }
7906 }
7907
7908 if (!strcmp(pageobj->name, _STR2)) return TCL_OK; /* no change in string */
7909 if (strlen(_STR2) == 0)
7910 sprintf(pageobj->name, "Page %d", areawin->page + 1);
7911 else
7912 sprintf(pageobj->name, "%.79s", _STR2);
7913
7914 /* For schematics, all pages with associations to symbols must have */
7915 /* unique names. */
7916 if (pageobj->symschem != NULL) checkpagename(pageobj);
7917
7918 if (pageobj == topobject) printname(pageobj);
7919 renamepage(pageno);
7920 break;
7921
7922 case FileIdx:
7923
7924 if ((objc - nidx) != 2 && (objc - nidx) != 3) {
7925 Tcl_WrongNumArgs(interp, 1, objv, "filename ?name?");
7926 return TCL_ERROR;
7927 }
7928
7929 oldstr = curpage->filename;
7930
7931 if ((objc - nidx) == 2) {
7932 if (oldstr)
7933 objPtr = Tcl_NewStringObj(oldstr, strlen(oldstr));
7934 else
7935 objPtr = Tcl_NewListObj(0, NULL); /* NULL list */
7936 Tcl_SetObjResult(interp, objPtr);
7937 return XcTagCallback(interp, objc, objv);
7938 }
7939
7940 newstr = Tcl_GetString(objv[2 + nidx]);
7941 if (strlen(newstr) > 0) {
7942 froot = strrchr(newstr, '/');
7943 if (froot == NULL) froot = newstr;
7944 if (strchr(froot, '.') == NULL) {
7945 astr = malloc(strlen(newstr) + 4);
7946 sprintf(astr, "%s.ps", newstr);
7947 newstr = astr;
7948 }
7949 }
7950
7951 if (oldstr && (!strcmp(oldstr, newstr))) { /* no change in string */
7952 if (newstr == astr) free(astr);
7953 return XcTagCallback(interp, objc, objv);
7954 }
7955
7956 if (strlen(newstr) == 0) { /* empty string */
7957 Tcl_SetResult(interp, "Warning: No filename!", NULL);
7958 multi = 1;
7959 }
7960 else {
7961 multi = pagelinks(pageno); /* Are there multiple pages? */
7962 }
7963
7964 /* Make the change to the current page */
7965 curpage->filename = strdup(newstr);
7966 if (newstr == astr) free(astr);
7967
7968 /* All existing filenames which match the old string should */
7969 /* also be changed unless the filename has been set to the */
7970 /* null string, which unlinks the page. */
7971
7972 if ((strlen(curpage->filename) > 0) && (multi > 1)) {
7973 for (cpage = 0; cpage < xobjs.pages; cpage++) {
7974 lpage = xobjs.pagelist[cpage];
7975 if ((lpage->pageinst != NULL) && (cpage != pageno)) {
7976 if (lpage->filename && (!filecmp(lpage->filename, oldstr))) {
7977 free(lpage->filename);
7978 lpage->filename = strdup(newstr);
7979 }
7980 }
7981 }
7982 }
7983 free(oldstr);
7984 autoscale(pageno);
7985
7986 /* Run pagelinks again; this checks if a page has been attached */
7987 /* to existing schematics by being renamed to match. */
7988
7989 if ((strlen(curpage->filename) > 0) && (multi <= 1)) {
7990 for (cpage = 0; cpage < xobjs.pages; cpage++) {
7991 lpage = xobjs.pagelist[cpage];
7992 if ((lpage->pageinst != NULL) && (cpage != pageno)) {
7993 if (lpage->filename && (!filecmp(lpage->filename,
7994 curpage->filename))) {
7995 free(curpage->filename);
7996 curpage->filename = strdup(lpage->filename);
7997 break;
7998 }
7999 }
8000 }
8001 }
8002 break;
8003
8004 case FitIdx:
8005 if ((objc - nidx) > 3) {
8006 Tcl_WrongNumArgs(interp, 1, objv, "fit ?true|false?");
8007 return TCL_ERROR;
8008 }
8009 else if ((objc - nidx) == 3) {
8010 result = Tcl_GetBooleanFromObj(interp, objv[2 + nidx], &aval);
8011 if (result != TCL_OK) return result;
8012 if (aval)
8013 curpage->pmode |= 2;
8014 else
8015 curpage->pmode &= 1;
8016 }
8017 else
8018 Tcl_SetResult(interp, ((curpage->pmode & 2) > 0) ? "true" : "false", NULL);
8019
8020 /* Refresh values (does autoscale if specified) */
8021 autoscale(pageno);
8022 break;
8023
8024 case ChangesIdx:
8025 if ((objc - nidx) != 2 && (objc - nidx) != 3) {
8026 Tcl_WrongNumArgs(interp, 1, objv, "changes");
8027 return TCL_ERROR;
8028 }
8029 /* Allow changes to be set, so that a page can be forced to be */
8030 /* recognized as either modified or unmodified. */
8031
8032 if ((objc - nidx) == 3) {
8033 int value;
8034 Tcl_GetIntFromObj(interp, objv[2 + nidx], &value);
8035 curpage->pageinst->thisobject->changes = (u_short)value;
8036 }
8037 changes = getchanges(curpage->pageinst->thisobject);
8038 objPtr = Tcl_NewIntObj((double)changes);
8039 Tcl_SetObjResult(interp, objPtr);
8040 return XcTagCallback(interp, objc, objv);
8041 break;
8042 }
8043 return XcTagCallback(interp, objc, objv);
8044 }
8045
8046 /*----------------------------------------------------------------------*/
8047 /* The "technology" command deals with library *technologies*, where */
8048 /* they differ from files or pages (see the "library" command */
8049 /* xctcl_library, below). Specifically, "library load" loads a file */
8050 /* (containing object defintions in a specific technology) onto a page, */
8051 /* whereas "technology save" writes back the object definitions that */
8052 /* came from the specified file. Although one would typically have one */
8053 /* library page per technology, this is not necessarily the case. */
8054 /* */
8055 /* Only one technology is defined by a library file, but the library */
8056 /* may contain (copies of) dependent objects from another technology. */
8057 /*----------------------------------------------------------------------*/
8058
8059 int xctcl_tech(ClientData clientData, Tcl_Interp *interp,
8060 int objc, Tcl_Obj *CONST objv[])
8061 {
8062 char *technology, *filename, *libobjname;
8063 short *pagelist;
8064 int idx, ilib, j, pageno, nidx, result;
8065 TechPtr nsptr = NULL;
8066 Tcl_Obj *olist;
8067 objectptr libobj;
8068 Boolean usertech = FALSE;
8069 FILE *chklib;
8070
8071 char *subCmds[] = {
8072 "save", "list", "objects", "filename", "changed", "used", "prefer",
8073 "writable", "writeable", NULL
8074 };
8075 enum SubIdx {
8076 SaveIdx, ListIdx, ObjectsIdx, FileNameIdx, ChangedIdx, UsedIdx,
8077 PreferIdx, WritableIdx, WriteableIdx
8078 };
8079
8080 if (objc < 2) {
8081 Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
8082 return TCL_ERROR;
8083 }
8084 if (Tcl_GetIndexFromObj(interp, objv[1],
8085 (CONST84 char **)subCmds, "option", 0, &idx) != TCL_OK) {
8086 return TCL_ERROR;
8087 }
8088
8089 /* All options except "list" and "used" expect a technology argument */
8090 if (idx != ListIdx && idx != UsedIdx) {
8091 if (objc > 2) {
8092 technology = Tcl_GetString(objv[2]);
8093 nsptr = LookupTechnology(technology);
8094 if (nsptr == NULL) {
8095
8096 /* If the command is "objects" and has one or more */
8097 /* additional arguments, then a NULL nsptr is okay (new */
8098 /* technology will be created and added to the list). */
8099
8100 if (idx != ObjectsIdx || objc <= 3) {
8101
8102 /* If nsptr is NULL, then the technology should be */
8103 /* "none", "user", or "default". */
8104
8105 if ((strstr(technology, "none") == NULL) &&
8106 (strstr(technology, "user") == NULL) &&
8107 (strstr(technology, "default") == NULL)) {
8108 Tcl_SetResult(interp, "Error: Unknown technology name!", NULL);
8109 return TCL_ERROR;
8110 }
8111 usertech = TRUE;
8112 }
8113 }
8114
8115 /* And if the user technology has been saved to a file, the technology */
8116 /* will have a NULL string. Also check for technology name "(user)", */
8117 /* although that is not supposed to happen. */
8118
8119 else if (*nsptr->technology == '\0')
8120 usertech = TRUE;
8121
8122 else if (!strcmp(nsptr->technology, "(user)"))
8123 usertech = TRUE;
8124 }
8125 else {
8126 Tcl_WrongNumArgs(interp, 1, objv, "<option> technology ?args ...?");
8127 return TCL_ERROR;
8128 }
8129 }
8130
8131 switch (idx) {
8132 case ListIdx:
8133 /* List all of the known technologies */
8134 olist = Tcl_NewListObj(0, NULL);
8135 for (nsptr = xobjs.technologies; nsptr != NULL; nsptr = nsptr->next) {
8136 Tcl_ListObjAppendElement(interp, olist,
8137 Tcl_NewStringObj(nsptr->technology,
8138 strlen(nsptr->technology)));
8139 }
8140 Tcl_SetObjResult(interp, olist);
8141 break;
8142
8143 case UsedIdx:
8144 /* List all of the technologies used by the schematic of the */
8145 /* indicated (or current) page. That is, enumerate all */
8146 /* in the hierarchy of the schematic, and list all unique */
8147 /* technology prefixes. */
8148
8149 result = ParsePageArguments(interp, objc - 1, objv + 1, &nidx, &pageno);
8150 if (result != TCL_OK) return result;
8151 olist = Tcl_NewListObj(0, NULL);
8152
8153 pagelist = pagetotals(pageno, TOTAL_PAGES);
8154 for (j = 0; j < xobjs.pages; j++) {
8155 if (pagelist[j] > 0) {
8156 objinstptr tinst;
8157 objectptr tpage = xobjs.pagelist[j]->pageinst->thisobject;
8158 genericptr *tgen;
8159
8160 for (tgen = tpage->plist; tgen < tpage->plist + tpage->parts; tgen++) {
8161 if ((*tgen)->type == OBJINST) {
8162 tinst = TOOBJINST(tgen);
8163 nsptr = GetObjectTechnology(tinst->thisobject);
8164 if (nsptr != NULL) {
8165 if ((nsptr->technology == NULL) ||
8166 (strlen(nsptr->technology) == 0)) continue;
8167 if (!(nsptr->flags & TECH_USED)) {
8168 Tcl_ListObjAppendElement(interp, olist,
8169 Tcl_NewStringObj(nsptr->technology,
8170 strlen(nsptr->technology)));
8171 nsptr->flags |= TECH_USED;
8172 }
8173 }
8174 }
8175 }
8176 }
8177 }
8178 Tcl_SetObjResult(interp, olist);
8179 for (nsptr = xobjs.technologies; nsptr != NULL; nsptr = nsptr->next)
8180 nsptr->flags &= ~TECH_USED;
8181 free((char *)pagelist);
8182 break;
8183
8184 case ObjectsIdx:
8185
8186 if (objc > 3) {
8187 int numobjs, objnamelen, technamelen;
8188 Tcl_Obj *tobj;
8189 char *cptr;
8190 TechPtr otech;
8191
8192 /* Check that 4th argument is a list of objects or that */
8193 /* 4th and higher arguments are all names of objects, and */
8194 /* that these objects are valid existing objects. */
8195
8196 if (objc == 4) {
8197 result = Tcl_ListObjLength(interp, objv[3], &numobjs);
8198 if (result != TCL_OK) return result;
8199 for (j = 0; j < numobjs; j++) {
8200 result = Tcl_ListObjIndex(interp, objv[3], j, &tobj);
8201 if (result != TCL_OK) return result;
8202 libobj = NameToObject(Tcl_GetString(tobj), NULL, FALSE);
8203 if (libobj == NULL) {
8204 Tcl_SetResult(interp, "No such object name", NULL);
8205 return TCL_ERROR;
8206 }
8207 }
8208 }
8209 else {
8210 for (j = 0; j < objc - 4; j++) {
8211 libobj = NameToObject(Tcl_GetString(objv[3 + j]), NULL, FALSE);
8212 if (libobj == NULL) {
8213 Tcl_SetResult(interp, "No such object name", NULL);
8214 return TCL_ERROR;
8215 }
8216 }
8217 }
8218
8219 /* Create a new technology if needed */
8220 technology = Tcl_GetString(objv[2]);
8221 if ((nsptr == NULL) && !usertech)
8222 AddNewTechnology(technology, NULL);
8223
8224 nsptr = LookupTechnology(technology);
8225 technamelen = (usertech) ? 0 : strlen(technology);
8226
8227
8228 /* Change the technology prefix of all the objects listed */
8229
8230 if (objc == 4) {
8231 result = Tcl_ListObjLength(interp, objv[3], &numobjs);
8232 if (result != TCL_OK) return result;
8233 for (j = 0; j < numobjs; j++) {
8234 result = Tcl_ListObjIndex(interp, objv[3], j, &tobj);
8235 if (result != TCL_OK) return result;
8236 libobj = NameToObject(Tcl_GetString(tobj), NULL, FALSE);
8237 cptr = strstr(libobj->name, "::");
8238 if (cptr == NULL) {
8239 objnamelen = strlen(libobj->name);
8240 memmove(libobj->name + technamelen + 2,
8241 libobj->name, (size_t)strlen(libobj->name));
8242 }
8243 else {
8244 otech = GetObjectTechnology(libobj);
8245 otech->flags |= TECH_CHANGED;
8246 objnamelen = strlen(cptr + 2);
8247 memmove(libobj->name + technamelen + 2,
8248 cptr + 2, (size_t)strlen(cptr + 2));
8249 }
8250
8251 if (!usertech) strcpy(libobj->name, technology);
8252 *(libobj->name + technamelen) = ':';
8253 *(libobj->name + technamelen + 1) = ':';
8254 *(libobj->name + technamelen + 2 + objnamelen) = '\0';
8255 }
8256 }
8257 else {
8258 for (j = 0; j < objc - 4; j++) {
8259 libobj = NameToObject(Tcl_GetString(objv[3 + j]), NULL, FALSE);
8260 cptr = strstr(libobj->name, "::");
8261 if (cptr == NULL) {
8262 objnamelen = strlen(libobj->name);
8263 memmove(libobj->name + technamelen + 2,
8264 libobj->name, (size_t)strlen(libobj->name));
8265 }
8266 else {
8267 otech = GetObjectTechnology(libobj);
8268 otech->flags |= TECH_CHANGED;
8269 objnamelen = strlen(cptr + 2);
8270 memmove(libobj->name + technamelen + 2,
8271 cptr + 2, (size_t)strlen(cptr + 2));
8272 }
8273
8274 if (!usertech) strcpy(libobj->name, technology);
8275 *(libobj->name + technamelen) = ':';
8276 *(libobj->name + technamelen + 1) = ':';
8277 *(libobj->name + technamelen + 2 + objnamelen) = '\0';
8278 }
8279 }
8280 if (nsptr != NULL) nsptr->flags |= TECH_CHANGED;
8281 break;
8282 }
8283
8284 /* List all objects having this technology */
8285
8286 olist = Tcl_NewListObj(0, NULL);
8287 for (ilib = 0; ilib < xobjs.numlibs; ilib++) {
8288 for (j = 0; j < xobjs.userlibs[ilib].number; j++) {
8289 libobj = *(xobjs.userlibs[ilib].library + j);
8290 if (GetObjectTechnology(libobj) == nsptr) {
8291 libobjname = strstr(libobj->name, "::");
8292 if (libobjname == NULL)
8293 libobjname = libobj->name;
8294 else
8295 libobjname += 2;
8296 Tcl_ListObjAppendElement(interp, olist,
8297 Tcl_NewStringObj(libobjname, strlen(libobjname)));
8298 }
8299 }
8300 }
8301 Tcl_SetObjResult(interp, olist);
8302 break;
8303
8304 case FileNameIdx:
8305 if (nsptr != NULL) {
8306 if (objc == 3) {
8307 if (nsptr->filename == NULL)
8308 Tcl_SetResult(interp, "(no associated file)", NULL);
8309 else
8310 Tcl_SetResult(interp, nsptr->filename, NULL);
8311 }
8312 else {
8313 if (nsptr->filename != NULL) free(nsptr->filename);
8314 nsptr->filename = strdup(Tcl_GetString(objv[3]));
8315 }
8316 }
8317 else {
8318 Tcl_SetResult(interp, "Valid technology is required", NULL);
8319 return TCL_ERROR;
8320 }
8321 break;
8322
8323 case ChangedIdx:
8324 if (objc == 4) {
8325 int bval;
8326 if (Tcl_GetBooleanFromObj(interp, objv[3], &bval) != TCL_OK)
8327 return TCL_ERROR;
8328 else if (bval == 1)
8329 nsptr->flags |= TECH_CHANGED;
8330 else
8331 nsptr->flags &= ~TECH_CHANGED;
8332 }
8333 else {
8334 tech_set_changes(nsptr); /* Ensure change flags are updated */
8335 Tcl_SetObjResult(interp,
8336 Tcl_NewBooleanObj(((nsptr->flags & TECH_CHANGED)
8337 == 0) ? FALSE : TRUE));
8338 }
8339 break;
8340
8341 case PreferIdx:
8342 if (nsptr) {
8343 if (objc == 3) {
8344 Tcl_SetObjResult(interp,
8345 Tcl_NewBooleanObj(((nsptr->flags & TECH_PREFER) == 0)
8346 ? TRUE : FALSE));
8347 }
8348 else if (objc == 4) {
8349 int bval;
8350
8351 Tcl_GetBooleanFromObj(interp, objv[3], &bval);
8352 if (bval == 0)
8353 nsptr->flags |= TECH_PREFER;
8354 else
8355 nsptr->flags &= (~TECH_PREFER);
8356 }
8357 }
8358 else {
8359 Tcl_SetResult(interp, "Valid technology is required", NULL);
8360 return TCL_ERROR;
8361 }
8362 break;
8363
8364 case WritableIdx:
8365 case WriteableIdx:
8366 if (nsptr) {
8367 if (objc == 3) {
8368 Tcl_SetObjResult(interp,
8369 Tcl_NewBooleanObj(((nsptr->flags & TECH_READONLY) == 0)
8370 ? TRUE : FALSE));
8371 }
8372 else if (objc == 4) {
8373 int bval;
8374
8375 Tcl_GetBooleanFromObj(interp, objv[3], &bval);
8376 if (bval == 0)
8377 nsptr->flags |= TECH_READONLY;
8378 else
8379 nsptr->flags &= (~TECH_READONLY);
8380 }
8381 }
8382 else {
8383 Tcl_SetResult(interp, "Valid technology is required", NULL);
8384 return TCL_ERROR;
8385 }
8386 break;
8387
8388 case SaveIdx:
8389
8390 /* technology save [filename] */
8391 if ((objc == 3) && ((nsptr == NULL) || (nsptr->filename == NULL))) {
8392 Tcl_SetResult(interp, "Error: Filename is required.", NULL);
8393 return TCL_ERROR;
8394 }
8395 else if ((nsptr != NULL) && (objc == 4)) {
8396 /* Technology being saved under a different filename. */
8397 filename = Tcl_GetString(objv[3]);
8398
8399 /* Re-check read-only status of the file */
8400 nsptr->flags &= ~(TECH_READONLY);
8401 chklib = fopen(filename, "a");
8402 if (chklib == NULL)
8403 nsptr->flags |= TECH_READONLY;
8404 else
8405 fclose(chklib);
8406 }
8407 else if (objc == 4) {
8408 filename = Tcl_GetString(objv[3]);
8409 if (!usertech) AddNewTechnology(technology, filename);
8410 }
8411 else
8412 filename = nsptr->filename;
8413
8414 savetechnology((usertech) ? NULL : technology, filename);
8415 break;
8416 }
8417 return XcTagCallback(interp, objc, objv);
8418 }
8419
8420 /*----------------------------------------------------------------------*/
8421 /* The "library" command deals with library *pages* */
8422 /*----------------------------------------------------------------------*/
8423
8424 int xctcl_library(ClientData clientData, Tcl_Interp *interp,
8425 int objc, Tcl_Obj *CONST objv[])
8426 {
8427 char *filename = NULL, *objname, *argv;
8428 int j = 0, libnum = -1;
8429 int idx, nidx, result, res;
8430 Tcl_Obj *olist;
8431 Tcl_Obj **newobjv;
8432 int newobjc, hidmode;
8433 objectptr libobj;
8434 liblistptr spec;
8435 char *subCmds[] = {
8436 "load", "make", "directory", "next", "goto", "override",
8437 "handle", "import", "list", "compose", NULL
8438 };
8439 enum SubIdx {
8440 LoadIdx, MakeIdx, DirIdx, NextIdx, GoToIdx, OverrideIdx,
8441 HandleIdx, ImportIdx, ListIdx, ComposeIdx
8442 };
8443
8444 result = ParseLibArguments(interp, objc, objv, &nidx, &libnum);
8445 if ((result != TCL_OK) || (nidx < 0)) return result;
8446 else if ((objc - nidx) > 5) {
8447 Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
8448 return TCL_ERROR;
8449 }
8450 else if (objc <= (1 + nidx)) { /* No subcommand */
8451
8452 /* return index if name given; return name if index given. */
8453 /* return index if neither is given (current library) */
8454
8455 if (objc > 1) {
8456 int lnum; /* unused; only checks if argument is integer */
8457 char *lname;
8458 result = Tcl_GetIntFromObj(interp, objv[1], &lnum);
8459 if (result == TCL_OK) {
8460 lname = xobjs.libtop[libnum + LIBRARY]->thisobject->name;
8461 Tcl_SetObjResult(interp, Tcl_NewStringObj(lname, strlen(lname)));
8462 }
8463 else {
8464 result = TCL_OK;
8465 Tcl_SetObjResult(interp, Tcl_NewIntObj(libnum + 1));
8466 }
8467 }
8468 else
8469 Tcl_SetObjResult(interp, Tcl_NewIntObj(libnum + 1));
8470 idx = -1;
8471 }
8472 else if (Tcl_GetIndexFromObj(interp, objv[1 + nidx],
8473 (CONST84 char **)subCmds, "option", 0, &idx) != TCL_OK) {
8474
8475 /* Backwards compatibility: "library filename [number]" is */
8476 /* the same as "library [number] load filename" */
8477
8478 Tcl_ResetResult(interp);
8479 newobjv = (Tcl_Obj **)(&objv[1]);
8480 newobjc = objc - 1;
8481
8482 result = ParseLibArguments(interp, newobjc, newobjv, &nidx, &libnum);
8483 if (result != TCL_OK) return result;
8484
8485 idx = LoadIdx;
8486 filename = Tcl_GetString(newobjv[0]);
8487 }
8488
8489 /* libnum = -1 is equivalent to "USER LIBRARY" */
8490 if (libnum < 0) libnum = xobjs.numlibs - 1;
8491
8492 switch (idx) {
8493 case LoadIdx:
8494 TechReplaceSave();
8495
8496 /* library [<name>|<number>] load <filename> [-replace [library]] */
8497 if (objc < (3 + nidx)) {
8498 Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
8499 return TCL_ERROR;
8500 }
8501 if (filename == NULL) filename = Tcl_GetString(objv[2 + nidx]);
8502
8503 /* if loading of default libraries is not overridden, load them first */
8504
8505 if (!(flags & (LIBOVERRIDE | LIBLOADED))) {
8506 result = defaultscript();
8507 flags |= LIBLOADED;
8508 }
8509
8510 /* If library number is out of range, create a new library */
8511 /* libnum = -1 is equivalent to the user library page. */
8512
8513 if (libnum > (xobjs.numlibs - 1))
8514 libnum = createlibrary(FALSE);
8515 else if (libnum < 0)
8516 libnum = USERLIB;
8517 else
8518 libnum += LIBRARY;
8519
8520 if (objc > (3 + nidx)) {
8521 argv = Tcl_GetString(objv[3 + nidx]);
8522 if ((*argv == '-') && !strncmp(argv, "-repl", 5)) {
8523 if (objc > (4 + nidx)) {
8524 char *techstr = Tcl_GetString(objv[3 + nidx]);
8525 if (!strcmp(techstr, "all")) TechReplaceAll();
8526 else if (!strcmp(techstr, "none")) TechReplaceNone();
8527 else {
8528 TechPtr nsptr = LookupTechnology(techstr);
8529 if (nsptr != NULL)
8530 nsptr->flags |= TECH_REPLACE;
8531 }
8532 }
8533 else
8534 TechReplaceAll(); /* replace ALL */
8535 }
8536 }
8537
8538 strcpy(_STR, filename);
8539 res = loadlibrary(libnum);
8540 if (res == False) {
8541 res = loadfile(2, libnum);
8542 TechReplaceRestore();
8543 if (res == False) {
8544 Tcl_SetResult(interp, "Error loading library.\n", NULL);
8545 return TCL_ERROR;
8546 }
8547 }
8548 TechReplaceRestore();
8549 break;
8550
8551 case ImportIdx:
8552 /* library [<name>|<number>] import <filename> <objectname> */
8553 if (objc != (4 + nidx)) {
8554 Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
8555 return TCL_ERROR;
8556 }
8557 if (filename == NULL) filename = Tcl_GetString(objv[2 + nidx]);
8558
8559 /* if loading of default libraries is not overridden, load them first */
8560
8561 if (!(flags & (LIBOVERRIDE | LIBLOADED))) {
8562 defaultscript();
8563 flags |= LIBLOADED;
8564 }
8565
8566 if ((libnum >= xobjs.numlibs) || (libnum < 0))
8567 libnum = createlibrary(FALSE);
8568 else
8569 libnum += LIBRARY;
8570
8571 objname = Tcl_GetString(objv[3 + nidx]);
8572 importfromlibrary(libnum, filename, objname);
8573 break;
8574
8575 case ListIdx:
8576
8577 if (!strncmp(Tcl_GetString(objv[objc - 1]), "-vis", 4))
8578 hidmode = 1; /* list visible objects only */
8579 else if (!strncmp(Tcl_GetString(objv[objc - 1]), "-hid", 4))
8580 hidmode = 2; /* list hidden objects only */
8581 else
8582 hidmode = 3; /* list everything */
8583
8584 /* library [name|number] list [-visible|-hidden] */
8585 olist = Tcl_NewListObj(0, NULL);
8586 for (j = 0; j < xobjs.userlibs[libnum].number; j++) {
8587 libobj = *(xobjs.userlibs[libnum].library + j);
8588 if (((libobj->hidden) && (hidmode & 2)) ||
8589 ((!libobj->hidden) && (hidmode & 1)))
8590 Tcl_ListObjAppendElement(interp, olist,
8591 Tcl_NewStringObj(libobj->name, strlen(libobj->name)));
8592 }
8593 Tcl_SetObjResult(interp, olist);
8594 break;
8595
8596 case HandleIdx:
8597
8598 if (objc == (3 + nidx)) {
8599 /* library [name|number] handle <object name> */
8600
8601 olist = Tcl_NewListObj(0, NULL);
8602 for (spec = xobjs.userlibs[libnum].instlist; spec != NULL;
8603 spec = spec->next) {
8604 libobj = spec->thisinst->thisobject;
8605 if (!strcmp(libobj->name, Tcl_GetString(objv[objc - 1])))
8606 Tcl_ListObjAppendElement(interp, olist,
8607 Tcl_NewHandleObj((genericptr)spec->thisinst));
8608 }
8609 Tcl_SetObjResult(interp, olist);
8610 }
8611 else if (objc == (2 + nidx)) {
8612 /* library [name|number] handle */
8613
8614 olist = Tcl_NewListObj(0, NULL);
8615 for (spec = xobjs.userlibs[libnum].instlist; spec != NULL;
8616 spec = spec->next) {
8617 Tcl_ListObjAppendElement(interp, olist,
8618 Tcl_NewHandleObj((genericptr)spec->thisinst));
8619 }
8620 Tcl_SetObjResult(interp, olist);
8621 }
8622 else {
8623 Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
8624 return TCL_ERROR;
8625 }
8626 break;
8627
8628 case ComposeIdx:
8629 composelib(libnum + LIBRARY);
8630 centerview(xobjs.libtop[libnum + LIBRARY]);
8631 break;
8632
8633 case MakeIdx:
8634 /* library make [name] */
8635 if (nidx == 1) {
8636 Tcl_SetResult(interp, "syntax is: library make [<name>]", NULL);
8637 return TCL_ERROR;
8638 }
8639
8640 /* If the (named or numbered) library exists, don't create it. */
8641 /* ParseLibArguments() returns the library number for the User */
8642 /* Library. The User Library always exists and cannot be */
8643 /* created or destroyed, so it's okay to use it as a check for */
8644 /* "no library found". */
8645
8646 if (libnum == xobjs.numlibs - 1)
8647 libnum = createlibrary(TRUE);
8648
8649 if (objc == 3) {
8650 strcpy(xobjs.libtop[libnum]->thisobject->name, Tcl_GetString(objv[2]));
8651 renamelib(libnum);
8652 composelib(LIBLIB);
8653 }
8654 /* Don't go to the library page---use "library goto" instead */
8655 /* startcatalog((Tk_Window)clientData, libnum, NULL); */
8656 break;
8657
8658 case DirIdx:
8659 /* library directory */
8660 if ((nidx == 0) && (objc == 2)) {
8661 startcatalog(NULL, LIBLIB, NULL);
8662 }
8663 else if ((nidx == 0) && (objc == 3) &&
8664 !strcmp(Tcl_GetString(objv[2]), "list")) {
8665 olist = Tcl_NewListObj(0, NULL);
8666 for (j = 0; j < xobjs.numlibs; j++) {
8667 libobj = xobjs.libtop[j + LIBRARY]->thisobject;
8668 Tcl_ListObjAppendElement(interp, olist,
8669 Tcl_NewStringObj(libobj->name, strlen(libobj->name)));
8670 }
8671 Tcl_SetObjResult(interp, olist);
8672 }
8673 else {
8674 Tcl_SetResult(interp, "syntax is: library directory [list]", NULL);
8675 return TCL_ERROR;
8676 }
8677 break;
8678
8679 case NextIdx:
8680 libnum = is_library(topobject);
8681 if (++libnum >= xobjs.numlibs) libnum = 0; /* fall through */
8682
8683 case GoToIdx:
8684 /* library go */
8685 startcatalog(NULL, LIBRARY + libnum, NULL);
8686 break;
8687 case OverrideIdx:
8688 flags |= LIBOVERRIDE;
8689 return TCL_OK; /* no tag callback */
8690 break;
8691 }
8692 return (result == TCL_OK) ? XcTagCallback(interp, objc, objv) : result;
8693 }
8694
8695 /*----------------------------------------------------------------------*/
8696 /* "bindkey" command --- this is a direct implementation of the same */
8697 /* key binding found in the "ad-hoc" and Python interfaces; it is */
8698 /* preferable to make use of the Tk "bind" command directly, and work */
8699 /* from the event handler. */
8700 /*----------------------------------------------------------------------*/
8701
8702 int xctcl_bind(ClientData clientData, Tcl_Interp *interp,
8703 int objc, Tcl_Obj *CONST objv[])
8704 {
8705 Tk_Window window = (Tk_Window)NULL;
8706 XCWindowDataPtr searchwin;
8707 char *keyname, *commandname, *binding;
8708 int keywstate, func = -1, value = -1;
8709 int result;
8710 Boolean compat = FALSE;
8711
8712 if (objc == 2) {
8713 keyname = Tcl_GetString(objv[1]);
8714 if (!strcmp(keyname, "override")) {
8715 flags |= KEYOVERRIDE;
8716 return TCL_OK; /* no tag callback */
8717 }
8718 }
8719
8720 if (!(flags & KEYOVERRIDE)) {
8721 default_keybindings();
8722 flags |= KEYOVERRIDE;
8723 }
8724
8725 if (objc == 1) {
8726 Tcl_Obj *list;
8727 int i;
8728
8729 list = Tcl_NewListObj(0, NULL);
8730 for (i = 0; i < NUM_FUNCTIONS; i++) {
8731 commandname = func_to_string(i);
8732 Tcl_ListObjAppendElement(interp, list,
8733 Tcl_NewStringObj(commandname, strlen(commandname)));
8734 }
8735 Tcl_SetObjResult(interp, list);
8736 return TCL_OK;
8737 }
8738 else if (objc > 5) {
8739 Tcl_WrongNumArgs(interp, 1, objv,
8740 "[<key> [<window>] [<command> [<value>|forget]]]");
8741 return TCL_ERROR;
8742 }
8743
8744 /* If 1st argument matches a window name, create a window-specific */
8745 /* binding. Otherwise, create a binding for all windows. */
8746
8747 if (objc > 1) {
8748 window = Tk_NameToWindow(interp, Tcl_GetString(objv[1]), Tk_MainWindow(interp));
8749 if (window == (Tk_Window)NULL)
8750 Tcl_ResetResult(interp);
8751 else {
8752 for (searchwin = xobjs.windowlist; searchwin != NULL; searchwin =
8753 searchwin->next)
8754 if (searchwin->area == window)
8755 break;
8756 if (searchwin != NULL) {
8757 /* Shift arguments */
8758 objc--;
8759 objv++;
8760 }
8761 else
8762 window = (xcWidget)NULL;
8763 }
8764 }
8765
8766 /* 1st argument can be option "-compatible" */
8767 if ((objc > 1) && !strncmp(Tcl_GetString(objv[1]), "-comp", 5)) {
8768 objc--;
8769 objv++;
8770 compat = TRUE;
8771 }
8772
8773 keyname = Tcl_GetString(objv[1]);
8774 keywstate = string_to_key(keyname);
8775
8776 /* 1st arg may be a function, not a key, if we want the binding returned */
8777 if ((objc == 3) && !strncmp(keyname, "-func", 5)) {
8778 keywstate = -1;
8779 func = string_to_func(Tcl_GetString(objv[2]), NULL);
8780 objc = 2;
8781 if (func == -1) {
8782 Tcl_SetResult(interp, "Invalid function name\n", NULL);
8783 return TCL_ERROR;
8784 }
8785 }
8786 else if ((objc == 2) && (keywstate == 0)) {
8787 keywstate = -1;
8788 func = string_to_func(keyname, NULL);
8789 }
8790
8791 if ((keywstate == -1 || keywstate == 0) && func == -1) {
8792 Tcl_SetResult(interp, "Invalid key name ", NULL);
8793 Tcl_AppendElement(interp, keyname);
8794 return TCL_ERROR;
8795 }
8796
8797 if (objc == 2) {
8798 if (keywstate == -1)
8799 binding = function_binding_to_string(window, func);
8800 else if (compat)
8801 binding = compat_key_to_string(window, keywstate);
8802 else
8803 binding = key_binding_to_string(window, keywstate);
8804 Tcl_SetResult(interp, binding, TCL_VOLATILE);
8805 free(binding);
8806 return TCL_OK;
8807 }
8808
8809 if (objc < 3) {
8810 Tcl_SetResult(interp, "Usage: bindkey <key> [<function>]\n", NULL);
8811 return TCL_ERROR;
8812 }
8813
8814 commandname = Tcl_GetString(objv[2]);
8815 if (strlen(commandname) == 0)
8816 func = -1;
8817 else
8818 func = string_to_func(commandname, NULL);
8819
8820 if (objc == 4) {
8821 result = Tcl_GetIntFromObj(interp, objv[3], &value);
8822 if (result != TCL_OK)
8823 {
8824 if (strcmp(Tcl_GetString(objv[3]), "forget"))
8825 return (result);
8826 else {
8827 /* Unbind command */
8828 Tcl_ResetResult(interp);
8829 result = remove_binding(window, keywstate, func);
8830 if (result == 0)
8831 return TCL_OK;
8832 else {
8833 Tcl_SetResult(interp, "Key/Function pair not found "
8834 "in binding list.\n", NULL);
8835 return TCL_ERROR;
8836 }
8837 }
8838 }
8839 }
8840 result = add_vbinding(window, keywstate, func, value);
8841 if (result == 1) {
8842 Tcl_SetResult(interp, "Key is already bound to a command.\n", NULL);
8843 return (result);
8844 }
8845 return (result == TCL_OK) ? XcTagCallback(interp, objc, objv) : result;
8846 }
8847
8848 /*----------------------------------------------------------------------*/
8849
8850 int xctcl_font(ClientData clientData, Tcl_Interp *interp,
8851 int objc, Tcl_Obj *CONST objv[])
8852 {
8853 char *fontname;
8854 int result;
8855
8856 /* font name */
8857 if (objc != 2) {
8858 Tcl_WrongNumArgs(interp, 1, objv, "fontname");
8859 return TCL_ERROR;
8860 }
8861 fontname = Tcl_GetString(objv[1]);
8862
8863 /* Allow overrides of the default font loading mechanism */
8864 if (!strcmp(fontname, "override")) {
8865 flags |= FONTOVERRIDE;
8866 return TCL_OK;
8867 }
8868
8869 /* If we need to load the default font "Helvetica" because no fonts */
8870 /* have been loaded yet, then we call this function twice, so that */
8871 /* the command tag callback gets applied both times. */
8872
8873 if (!(flags & FONTOVERRIDE)) {
8874 flags |= FONTOVERRIDE;
8875 xctcl_font(clientData, interp, objc, objv);
8876 loadfontfile("Helvetica");
8877 }
8878 result = loadfontfile((char *)fontname);
8879 if (result >= 1) {
8880 Tcl_SetObjResult(interp, Tcl_NewStringObj(fonts[fontcount - 1].family,
8881 strlen(fonts[fontcount - 1].family)));
8882 }
8883 switch (result) {
8884 case 1:
8885 return XcTagCallback(interp, objc, objv);
8886 case 0:
8887 return TCL_OK;
8888 case -1:
8889 return TCL_ERROR;
8890 }
8891 return TCL_ERROR; /* (jdk) */
8892 }
8893
8894 /*----------------------------------------------------------------------*/
8895 /* Set the X11 cursor to one of those defined in the XCircuit cursor */
8896 /* set (cursors.h) */
8897 /*----------------------------------------------------------------------*/
8898
8899 int xctcl_cursor(ClientData clientData, Tcl_Interp *interp,
8900 int objc, Tcl_Obj *CONST objv[])
8901 {
8902 int idx, result;
8903
8904 static char *cursNames[] = {
8905 "arrow", "cross", "scissors", "copy", "rotate", "edit",
8906 "text", "circle", "question", "wait", "hand", NULL
8907 };
8908
8909 if (!areawin) return TCL_ERROR;
8910
8911 /* cursor name */
8912 if (objc != 2) {
8913 Tcl_WrongNumArgs(interp, 1, objv, "cursor name");
8914 return TCL_ERROR;
8915 }
8916 if ((result = Tcl_GetIndexFromObj(interp, objv[1],
8917 (CONST84 char **)cursNames,
8918 "cursor name", 0, &idx)) != TCL_OK)
8919 return result;
8920
8921 XDefineCursor(dpy, areawin->window, appcursors[idx]);
8922 areawin->defaultcursor = &appcursors[idx];
8923 return XcTagCallback(interp, objc, objv);
8924 }
8925
8926 /*----------------------------------------------------------------------*/
8927
8928 int xctcl_filerecover(ClientData clientData, Tcl_Interp *interp,
8929 int objc, Tcl_Obj *CONST objv[])
8930 {
8931 if (objc != 1) {
8932 Tcl_WrongNumArgs(interp, 1, objv, "(no arguments)");
8933 return TCL_ERROR;
8934 }
8935 crashrecover();
8936 return XcTagCallback(interp, objc, objv);
8937 }
8938
8939 /*----------------------------------------------------------------------*/
8940 /* Replace the functions of the simple rcfile.c interpreter. */
8941 /*----------------------------------------------------------------------*/
8942
8943 /*----------------------------------------------------------------------*/
8944 /* Execute a single command from a script or from the command line */
8945 /*----------------------------------------------------------------------*/
8946
8947 short execcommand(short pflags, char *cmdptr)
8948 {
8949 flags = pflags;
8950 Tcl_Eval(xcinterp, cmdptr);
8951 refresh(NULL, NULL, NULL);
8952 return flags;
8953 }
8954
8955 /*----------------------------------------------------------------------*/
8956 /* Load the default script (like execscript() but don't allow recursive */
8957 /* loading of the startup script) */
8958 /*----------------------------------------------------------------------*/
8959
8960 int defaultscript()
8961 {
8962 FILE *fd;
8963 char *tmp_s = getenv((const char *)"XCIRCUIT_SRC_DIR");
8964 int result;
8965
8966 flags = LIBOVERRIDE | LIBLOADED | FONTOVERRIDE;
8967
8968 if (!tmp_s) tmp_s = SCRIPTS_DIR;
8969 sprintf(_STR2, "%s/%s", tmp_s, STARTUP_FILE);
8970
8971 if ((fd = fopen(_STR2, "r")) == NULL) {
8972 sprintf(_STR2, "%s/%s", SCRIPTS_DIR, STARTUP_FILE);
8973 if ((fd = fopen(_STR2, "r")) == NULL) {
8974 sprintf(_STR2, "%s/tcl/%s", SCRIPTS_DIR, STARTUP_FILE);
8975 if ((fd = fopen(_STR2, "r")) == NULL) {
8976 Wprintf("Failed to open startup script \"%s\"\n", STARTUP_FILE);
8977 return TCL_ERROR;
8978 }
8979 }
8980 }
8981 fclose(fd);
8982 result = Tcl_EvalFile(xcinterp, _STR2);
8983 return result;
8984 }
8985
8986 /*----------------------------------------------------------------------*/
8987 /* Execute a script */
8988 /*----------------------------------------------------------------------*/
8989
8990 void execscript()
8991 {
8992 FILE *fd;
8993
8994 flags = 0;
8995
8996 xc_tilde_expand(_STR2, 249);
8997 if ((fd = fopen(_STR2, "r")) != NULL) {
8998 fclose(fd);
8999 Tcl_EvalFile(xcinterp, _STR2);
9000 refresh(NULL, NULL, NULL);
9001 }
9002 else {
9003 Wprintf("Failed to open script file \"%s\"\n", _STR2);
9004 }
9005 }
9006
9007 /*----------------------------------------------------------------------*/
9008 /* Evaluate an expression from a parameter and return the result as a */
9009 /* Tcl object. The actual return value (TCL_OK, TCL_ERROR) is stored */
9010 /* in pointer "eval_status", if it is non-NULL. */
9011 /*----------------------------------------------------------------------*/
9012
9013 Tcl_Obj *evaluate_raw(objectptr thisobj, oparamptr ops, objinstptr pinst,
9014 int *eval_status)
9015 {
9016 Tcl_SavedResult state;
9017 Tcl_Obj *robj;
9018 int status;
9019 char *exprptr, *pptr, *pkey, *pnext;
9020
9021 /* Sanity check */
9022 if (ops->type != XC_EXPR) return NULL;
9023 exprptr = ops->parameter.expr;
9024 pnext = exprptr;
9025 if (pnext == NULL) return NULL;
9026
9027 /* Check for "@<parameter>" notation and substitute parameter values */
9028 while ((pptr = strchr(pnext, '@')) != NULL)
9029 {
9030 oparam temps;
9031 oparamptr ips;
9032 char psave, *promoted, *newexpr;
9033
9034 pptr++;
9035 for (pkey = pptr; *pkey && !isspace(*pkey); pkey++)
9036 if (*pkey == '{' || *pkey == '}' || *pkey == '[' || *pkey == ']' ||
9037 *pkey == '(' || *pkey == ')' || *pkey == ',')
9038 break;
9039
9040 if (pkey > pptr) {
9041 psave = *pkey;
9042 *pkey = '\0';
9043 if (pinst)
9044 ips = find_param(pinst, pptr);
9045 else
9046 ips = match_param(thisobj, pptr);
9047 if (ips == ops) {
9048 /* Avoid infinite recursion by treating a reference */
9049 /* to oneself as plain text. */
9050 ips = NULL;
9051 }
9052 if ((ips == NULL) && !strncmp(pptr, "p_", 2)) {
9053 ips = &temps;
9054 if (!strcmp(pptr + 2, "rotation")) {
9055 temps.type = XC_FLOAT;
9056 temps.parameter.fvalue = pinst ? pinst->rotation : 0;
9057 }
9058 else if (!strcmp(pptr + 2, "xposition")) {
9059 temps.type = XC_INT;
9060 temps.parameter.ivalue = pinst ? pinst->position.x : 0;
9061 }
9062 else if (!strcmp(pptr + 2, "yposition")) {
9063 temps.type = XC_INT;
9064 temps.parameter.ivalue = pinst ? pinst->position.y : 0;
9065 }
9066 else if (!strcmp(pptr + 2, "scale")) {
9067 temps.type = XC_FLOAT;
9068 temps.parameter.fvalue = pinst ? pinst->scale : 1.0;
9069 }
9070 else if (!strcmp(pptr + 2, "color")) {
9071 temps.type = XC_INT;
9072 temps.parameter.ivalue = pinst ? pinst->color : DEFAULTCOLOR;
9073 }
9074 else if (!strcmp(pptr + 2, "top_xposition")) {
9075 temps.type = XC_INT;
9076 UTopDrawingOffset(&temps.parameter.ivalue, NULL);
9077 }
9078 else if (!strcmp(pptr + 2, "top_yposition")) {
9079 temps.type = XC_INT;
9080 UTopDrawingOffset(NULL, &temps.parameter.ivalue);
9081 }
9082 else if (!strcmp(pptr + 2, "top_rotation")) {
9083 temps.type = XC_FLOAT;
9084 temps.parameter.fvalue = UTopRotation();
9085 }
9086 else if (!strcmp(pptr + 2, "top_scale")) {
9087 temps.type = XC_FLOAT;
9088 temps.parameter.fvalue = UTopDrawingScale();
9089 }
9090 else
9091 ips = NULL;
9092 }
9093 *pkey = psave;
9094 if (ips != NULL) {
9095 switch (ips->type) {
9096 case XC_INT:
9097 promoted = malloc(12);
9098 snprintf(promoted, 12, "%d", ips->parameter.ivalue);
9099 break;
9100 case XC_FLOAT:
9101 promoted = malloc(12);
9102 snprintf(promoted, 12, "%g", ips->parameter.fvalue);
9103 break;
9104 case XC_STRING:
9105 promoted = textprint(ips->parameter.string, pinst);
9106 break;
9107 case XC_EXPR:
9108 /* We really ought to prevent infinite loops here. . .*/
9109 promoted = evaluate_expr(thisobj, ips, pinst);
9110 break;
9111 }
9112 if (promoted == NULL) break;
9113 newexpr = (char *)malloc(1 + strlen(exprptr) +
9114 (max(strlen(promoted), strlen(pkey))));
9115 *(pptr - 1) = '\0';
9116 strcpy(newexpr, exprptr);
9117 *(pptr - 1) = '@';
9118 strcat(newexpr, promoted);
9119 pnext = newexpr + strlen(newexpr); /* For next search of '@' escape */
9120 strcat(newexpr, pkey);
9121 free(promoted);
9122 if (exprptr != ops->parameter.expr) free(exprptr);
9123 exprptr = newexpr;
9124 }
9125 else {
9126 /* Ignore the keyword and move to the end */
9127 pnext = pkey;
9128 }
9129 }
9130 }
9131
9132 /* Evaluate the expression in TCL */
9133
9134 Tcl_SaveResult(xcinterp, &state);
9135 status = Tcl_Eval(xcinterp, exprptr);
9136 robj = Tcl_GetObjResult(xcinterp);
9137 Tcl_IncrRefCount(robj);
9138 Tcl_RestoreResult(xcinterp, &state);
9139 if (eval_status) *eval_status = status;
9140 if (exprptr != ops->parameter.expr) free(exprptr);
9141 return robj;
9142 }
9143
9144 /*----------------------------------------------------------------------*/
9145 /* Evaluate an expression from a parameter and return the result as an */
9146 /* allocated string. */
9147 /*----------------------------------------------------------------------*/
9148
9149 char *evaluate_expr(objectptr thisobj, oparamptr ops, objinstptr pinst)
9150 {
9151 Tcl_Obj *robj;
9152 char *rexpr = NULL;
9153 int status, ip = 0;
9154 float fp = 0.0;
9155 stringpart *tmpptr, *promote = NULL;
9156 oparamptr ips = (pinst == NULL) ? NULL : match_instance_param(pinst, ops->key);
9157
9158 robj = evaluate_raw(thisobj, ops, pinst, &status);
9159 if (robj != NULL) {
9160 rexpr = strdup(Tcl_GetString(robj));
9161 Tcl_DecrRefCount(robj);
9162 }
9163
9164 if ((status == TCL_ERROR) && (ips != NULL)) {
9165 switch(ips->type) {
9166 case XC_STRING:
9167 rexpr = textprint(ips->parameter.string, pinst);
9168 break;
9169 case XC_FLOAT:
9170 fp = ips->parameter.fvalue;
9171 break;
9172 }
9173 }
9174
9175 /* If a TCL expression contains a three digit octal value \ooo */
9176 /* then the string returned by TclEval() can contain a */
9177 /* multi-byte UTF-8 character. */
9178 /* */
9179 /* This multi-byte character needs to be converted back to a */
9180 /* character that can be displayed. */
9181 /* */
9182 /* The following fix assumes that at most two bytes will */
9183 /* represent any converted character. In this case, the most */
9184 /* significant digit (octal) of the first byte will be 3, and */
9185 /* the most significant digit of the second byte will be 2. */
9186 /* */
9187 /* See: https://en.wikipedia.org/wiki/UTF-8 */
9188
9189 if ((rexpr != NULL) && ((status == TCL_RETURN) || (status == TCL_OK))) {
9190 u_char *strptr1 = rexpr;
9191 u_char *strptr2 = rexpr;
9192 while (*strptr1 != '\0') {
9193 if (*strptr1 >= 0300 && *(strptr1 + 1) >= 0200) {
9194 *strptr2 = ((*strptr1 & ~0300) << 6) | (*(strptr1 + 1) & 0077);
9195 strptr1 += 2;
9196 } else {
9197 *strptr2 = *strptr1;
9198 strptr1++;
9199 }
9200 strptr2++;
9201 }
9202 if (*strptr1 == '\0')
9203 *strptr2 = *strptr1;
9204 }
9205
9206 /* If an instance redefines an expression, don't preserve */
9207 /* the result. It is necessary in this case that the */
9208 /* expression does not reference objects during redisplay, */
9209 /* or else the correct result will not be written to the */
9210 /* output. */
9211
9212 if ((ips != NULL) && (ips->type == XC_EXPR))
9213 return rexpr;
9214
9215 /* Preserve the result in the object instance; this will be */
9216 /* used when writing the output or when the result cannot */
9217 /* be evaluated (see above). */
9218
9219 if ((rexpr != NULL) && (status == TCL_OK) && (pinst != NULL)) {
9220 switch (ops->which) {
9221 case P_SUBSTRING: case P_EXPRESSION:
9222 if (ips == NULL) {
9223 ips = make_new_parameter(ops->key);
9224 ips->which = ops->which;
9225 ips->type = XC_STRING;
9226 ips->next = pinst->params;
9227 pinst->params = ips;
9228 }
9229 else {
9230 free(ips->parameter.string);
9231 }
9232 /* Promote the expression result to an XCircuit string type */
9233 tmpptr = makesegment(&promote, NULL);
9234 tmpptr->type = TEXT_STRING;
9235 tmpptr = makesegment(&promote, NULL);
9236 tmpptr->type = PARAM_END;
9237 promote->data.string = strdup(rexpr);
9238 ips->parameter.string = promote;
9239 break;
9240
9241 case P_COLOR: /* must be integer, exact to 32 bits */
9242 if (ips == NULL) {
9243 ips = make_new_parameter(ops->key);
9244 ips->which = ops->which;
9245 ips->next = pinst->params;
9246 pinst->params = ips;
9247 }
9248 /* Promote the expression result to type float */
9249 if (rexpr != NULL) {
9250 if (sscanf(rexpr, "%i", &ip) == 1)
9251 ips->parameter.ivalue = ip;
9252 else
9253 ips->parameter.ivalue = 0;
9254 }
9255 else
9256 ips->parameter.ivalue = ip;
9257 ips->type = XC_INT;
9258 break;
9259
9260 default: /* all others convert to type float */
9261 if (ips == NULL) {
9262 ips = make_new_parameter(ops->key);
9263 ips->which = ops->which;
9264 ips->next = pinst->params;
9265 pinst->params = ips;
9266 }
9267 /* Promote the expression result to type float */
9268 if (rexpr != NULL) {
9269 if (sscanf(rexpr, "%g", &fp) == 1)
9270 ips->parameter.fvalue = fp;
9271 else
9272 ips->parameter.fvalue = 0.0;
9273 }
9274 else
9275 ips->parameter.fvalue = fp;
9276 ips->type = XC_FLOAT;
9277 break;
9278 }
9279 }
9280 return rexpr;
9281 }
9282
9283 /*----------------------------------------------------------------------*/
9284 /* Execute the .xcircuitrc startup script */
9285 /*----------------------------------------------------------------------*/
9286
9287 int loadrcfile()
9288 {
9289 char *userdir = getenv((const char *)"HOME");
9290 FILE *fd;
9291 short i;
9292 int result = TCL_OK, result1 = TCL_OK;
9293
9294 /* Initialize flags */
9295
9296 flags = 0;
9297
9298 /* Try first in current directory, then look in user's home directory */
9299 /* First try looking for a file .xcircuitrc followed by a dash and */
9300 /* the program version; this allows backward compatibility of the rc */
9301 /* file in cases where a new version (e.g., 3 vs. 2) introduces */
9302 /* incompatible syntax. Thanks to Romano Giannetti for this */
9303 /* suggestion plus provided code. */
9304
9305 /* (names USER_RC_FILE and PROG_VERSION imported from Makefile) */
9306
9307 sprintf(_STR2, "%s-%s", USER_RC_FILE, PROG_VERSION);
9308 xc_tilde_expand(_STR2, 249);
9309 if ((fd = fopen(_STR2, "r")) == NULL) {
9310 /* Not found; check for the same in $HOME directory */
9311 if (userdir != NULL) {
9312 sprintf(_STR2, "%s/%s-%s", userdir, USER_RC_FILE, PROG_VERSION);
9313 if ((fd = fopen(_STR2, "r")) == NULL) {
9314 /* Not found again; check for rc file w/o version # in CWD */
9315 sprintf(_STR2, "%s", USER_RC_FILE);
9316 xc_tilde_expand(_STR2, 249);
9317 if ((fd = fopen(_STR2, "r")) == NULL) {
9318 /* last try: plain USER_RC_FILE in $HOME */
9319 sprintf(_STR2, "%s/%s", userdir, USER_RC_FILE);
9320 fd = fopen(_STR2, "r");
9321 }
9322 }
9323 }
9324 }
9325 if (fd != NULL) {
9326 fclose(fd);
9327 result = Tcl_EvalFile(xcinterp, _STR2);
9328 if (result != TCL_OK) {
9329 Fprintf(stderr, "Encountered error in startup file.");
9330 Fprintf(stderr, "%s\n", Tcl_GetStringResult(xcinterp));
9331 Fprintf(stderr, "Running default startup script instead.\n");
9332 }
9333 }
9334
9335 /* Add the default font if not loaded already */
9336
9337 if (!(flags & FONTOVERRIDE)) {
9338 loadfontfile("Helvetica");
9339 if (areawin->psfont == -1)
9340 for (i = 0; i < fontcount; i++)
9341 if (!strcmp(fonts[i].psname, "Helvetica")) {
9342 areawin->psfont = i;
9343 break;
9344 }
9345 }
9346 if (areawin->psfont == -1) areawin->psfont = 0;
9347
9348 setdefaultfontmarks();
9349
9350 /* arrange the loaded libraries */
9351
9352 if ((result != TCL_OK) || !(flags & (LIBOVERRIDE | LIBLOADED))) {
9353 result1 = defaultscript();
9354 }
9355
9356 /* Add the default colors */
9357
9358 if (!(flags & COLOROVERRIDE)) {
9359 addnewcolorentry(xc_alloccolor("Gray40"));
9360 addnewcolorentry(xc_alloccolor("Gray60"));
9361 addnewcolorentry(xc_alloccolor("Gray80"));
9362 addnewcolorentry(xc_alloccolor("Gray90"));
9363 addnewcolorentry(xc_alloccolor("Red"));
9364 addnewcolorentry(xc_alloccolor("Blue"));
9365 addnewcolorentry(xc_alloccolor("Green2"));
9366 addnewcolorentry(xc_alloccolor("Yellow"));
9367 addnewcolorentry(xc_alloccolor("Purple"));
9368 addnewcolorentry(xc_alloccolor("SteelBlue2"));
9369 addnewcolorentry(xc_alloccolor("Red3"));
9370 addnewcolorentry(xc_alloccolor("Tan"));
9371 addnewcolorentry(xc_alloccolor("Brown"));
9372 addnewcolorentry(xc_alloccolor("#d20adc"));
9373 addnewcolorentry(xc_alloccolor("Pink"));
9374 }
9375
9376 if ((result != TCL_OK) || !(flags & KEYOVERRIDE)) {
9377 default_keybindings();
9378 }
9379 return (result1 != TCL_OK) ? result1 : result;
9380 }
9381
9382 /*----------------------------------------------------------------------*/
9383 /* Alternative button handler for use with Tk "bind" */
9384 /*----------------------------------------------------------------------*/
9385
9386 int xctcl_standardaction(ClientData clientData,
9387 Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])
9388 {
9389 int idx, result, knum, kstate;
9390 XKeyEvent kevent;
9391 static char *updown[] = {"up", "down", NULL};
9392
9393 if ((objc != 3) && (objc != 4)) goto badargs;
9394
9395 if ((result = Tcl_GetIntFromObj(interp, objv[1], &knum)) != TCL_OK)
9396 goto badargs;
9397
9398 if ((result = Tcl_GetIndexFromObj(interp, objv[2],
9399 (CONST84 char **)updown, "direction", 0, &idx)) != TCL_OK)
9400 goto badargs;
9401
9402 if (objc == 4) {
9403 if ((result = Tcl_GetIntFromObj(interp, objv[3], &kstate)) != TCL_OK)
9404 goto badargs;
9405 }
9406 else
9407 kstate = 0;
9408
9409 make_new_event(&kevent);
9410 kevent.state = kstate;
9411 kevent.keycode = 0;
9412
9413 if (idx == 0)
9414 kevent.type = KeyRelease;
9415 else
9416 kevent.type = KeyPress;
9417
9418 switch (knum) {
9419 case 1:
9420 kevent.state |= Button1Mask;
9421 break;
9422 case 2:
9423 kevent.state |= Button2Mask;
9424 break;
9425 case 3:
9426 kevent.state |= Button3Mask;
9427 break;
9428 case 4:
9429 kevent.state |= Button4Mask;
9430 break;
9431 case 5:
9432 kevent.state |= Button5Mask;
9433 break;
9434 default:
9435 kevent.keycode = knum;
9436 break;
9437 }
9438 #ifdef _MSC_VER
9439 if (kevent.state & Mod1Mask) {
9440 kevent.state &= ~Mod1Mask;
9441 }
9442 if (kevent.state & (AnyModifier<<2)) {
9443 kevent.state &= ~(AnyModifier<<2);
9444 kevent.state |= Mod1Mask;
9445 }
9446 #endif
9447 keyhandler((xcWidget)NULL, (caddr_t)NULL, &kevent);
9448 return TCL_OK;
9449
9450 badargs:
9451 Tcl_SetResult(interp, "Usage: standardaction <button_num> up|down [<keystate>]\n"
9452 "or standardaction <keycode> up|down [<keystate>]\n", NULL);
9453 return TCL_ERROR;
9454 }
9455
9456 /*----------------------------------------------------------------------*/
9457 /* Action handler for use with Tk "bind" */
9458 /* This dispatches events based on specific named actions that xcircuit */
9459 /* knows about, rather than by named key. This bypasses xcircuit's */
9460 /* key bindings. */
9461 /*----------------------------------------------------------------------*/
9462
9463 int xctcl_action(ClientData clientData,
9464 Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])
9465 {
9466 short value = 0;
9467 int function, result, ival;
9468 XPoint newpos, wpoint;
9469
9470 if (objc >= 2 && objc <= 4) {
9471 function = string_to_func(Tcl_GetString(objv[1]), &value);
9472 if (objc >= 3) {
9473 result = (short)Tcl_GetIntFromObj(interp, objv[2], &ival);
9474 if (result == TCL_ERROR) return TCL_ERROR;
9475 value = (short)ival;
9476 }
9477
9478 newpos = UGetCursorPos();
9479 user_to_window(newpos, &wpoint);
9480
9481 result = compatible_function(function);
9482 if (result == -1)
9483 Tcl_SetResult(interp, "Action not allowed\n", NULL);
9484
9485 result = functiondispatch(function, value, wpoint.x, wpoint.y);
9486 if (result == -1)
9487 Tcl_SetResult(interp, "Action not handled\n", NULL);
9488 }
9489 else {
9490 Tcl_SetResult(interp, "Usage: action <action_name> [<value>]\n", NULL);
9491 return TCL_ERROR;
9492 }
9493 return XcTagCallback(interp, objc, objv);
9494 }
9495
9496
9497 /*----------------------------------------------------------------------*/
9498 /* Argument-converting wrappers from Tk callback to Xt callback format */
9499 /*----------------------------------------------------------------------*/
9500
9501 void xctk_drawarea(ClientData clientData, XEvent *eventPtr)
9502 {
9503 Tcl_ServiceAll();
9504 if (areawin->topinstance != NULL)
9505 drawarea(areawin->area, (caddr_t)clientData, (caddr_t)NULL);
9506 }
9507
9508 /*----------------------------------------------------------------------*/
9509
9510 void xctk_resizearea(ClientData clientData, XEvent *eventPtr)
9511 {
9512 resizearea(areawin->area, (caddr_t)clientData, (caddr_t)NULL);
9513 /* Callback to function "arrangetoolbar" */
9514 Tcl_Eval(xcinterp, "catch {xcircuit::arrangetoolbar $XCOps(focus)}");
9515 }
9516
9517 /*----------------------------------------------------------------------*/
9518 /* Because Tk doesn't filter MotionEvent events based on context, we */
9519 /* have to filter the context here. */
9520 /*----------------------------------------------------------------------*/
9521
9522 void xctk_panhbar(ClientData clientData, XEvent *eventPtr)
9523 {
9524 XMotionEvent *mevent = (XMotionEvent *)eventPtr;
9525 u_int state = mevent->state;
9526 if (state & (Button1Mask | Button2Mask))
9527 panhbar(areawin->scrollbarh, (caddr_t)clientData, (XButtonEvent *)eventPtr);
9528 }
9529
9530 /*----------------------------------------------------------------------*/
9531
9532 void xctk_panvbar(ClientData clientData, XEvent *eventPtr)
9533 {
9534 XMotionEvent *mevent = (XMotionEvent *)eventPtr;
9535 u_int state = mevent->state;
9536 if (state & (Button1Mask | Button2Mask))
9537 panvbar(areawin->scrollbarv, (caddr_t)clientData, (XButtonEvent *)eventPtr);
9538 }
9539
9540 /*----------------------------------------------------------------------*/
9541
9542 void xctk_drawhbar(ClientData clientData, XEvent *eventPtr)
9543 {
9544 if (areawin->topinstance)
9545 drawhbar(areawin->scrollbarh, (caddr_t)clientData, (caddr_t)NULL);
9546 }
9547
9548 /*----------------------------------------------------------------------*/
9549
9550 void xctk_drawvbar(ClientData clientData, XEvent *eventPtr)
9551 {
9552 if (areawin->topinstance)
9553 drawvbar(areawin->scrollbarv, (caddr_t)clientData, (caddr_t)NULL);
9554 }
9555
9556 /*----------------------------------------------------------------------*/
9557
9558 void xctk_endhbar(ClientData clientData, XEvent *eventPtr)
9559 {
9560 if (areawin->topinstance)
9561 endhbar(areawin->scrollbarh, (caddr_t)clientData, (XButtonEvent *)eventPtr);
9562 }
9563
9564 /*----------------------------------------------------------------------*/
9565
9566 void xctk_endvbar(ClientData clientData, XEvent *eventPtr)
9567 {
9568 if (areawin->topinstance)
9569 endvbar(areawin->scrollbarv, (caddr_t)clientData, (XButtonEvent *)eventPtr);
9570 }
9571
9572 /*----------------------------------------------------------------------*/
9573
9574 void xctk_zoomview(ClientData clientData, XEvent *eventPtr)
9575 {
9576 zoomview((xcWidget)NULL, (caddr_t)clientData, (caddr_t)NULL);
9577 }
9578
9579 /*----------------------------------------------------------------------*/
9580
9581 void xctk_swapschem(ClientData clientData, XEvent *eventPtr)
9582 {
9583 swapschem((int)((pointertype)clientData), -1, NULL);
9584 }
9585
9586 /*----------------------------------------------------------------------*/
9587
9588 void xctk_drag(ClientData clientData, XEvent *eventPtr)
9589 {
9590 XButtonEvent *b_event = (XButtonEvent *)eventPtr;
9591
9592 drag((int)b_event->x, (int)b_event->y);
9593 flusharea();
9594 #ifdef HAVE_CAIRO
9595 if (areawin->redraw_needed)
9596 drawarea(NULL, NULL, NULL);
9597 #endif /* HAVE_CAIRO */
9598 }
9599
9600 /*----------------------------------------------------------------------*/
9601 /* This really should be set up so that the "okay" button command tcl */
9602 /* procedure does the job of lookdirectory(). */
9603 /*----------------------------------------------------------------------*/
9604
9605 void xctk_fileselect(ClientData clientData, XEvent *eventPtr)
9606 {
9607 XButtonEvent *beventPtr = (XButtonEvent *)eventPtr;
9608 popupstruct *listp = (popupstruct *)clientData;
9609 char curentry[150];
9610
9611 if (beventPtr->button == Button2) {
9612 Tcl_Eval(xcinterp, ".filelist.textent.txt get");
9613 sprintf(curentry, "%.149s", (char *)Tcl_GetStringResult(xcinterp));
9614
9615 if (strlen(curentry) > 0) {
9616 if (lookdirectory(curentry, 149))
9617 newfilelist(listp->filew, listp);
9618 else
9619 Tcl_Eval(xcinterp, ".filelist.bbar.okay invoke");
9620 }
9621 }
9622 else if (beventPtr->button == Button4) { /* scroll wheel binding */
9623 flstart--;
9624 showlscroll(listp->scroll, NULL, NULL);
9625 listfiles(listp->filew, listp, NULL);
9626 }
9627 else if (beventPtr->button == Button5) { /* scroll wheel binding */
9628 flstart++;
9629 showlscroll(listp->scroll, NULL, NULL);
9630 listfiles(listp->filew, listp, NULL);
9631 }
9632 else
9633 fileselect(listp->filew, listp, beventPtr);
9634 }
9635
9636 /*----------------------------------------------------------------------*/
9637
9638 void xctk_listfiles(ClientData clientData, XEvent *eventPtr)
9639 {
9640 popupstruct *listp = (popupstruct *)clientData;
9641 char *filter;
9642
9643 Tcl_Eval(xcinterp, ".filelist.listwin.win cget -data");
9644 filter = (char *)Tcl_GetStringResult(xcinterp);
9645
9646 if (filter != NULL) {
9647 if ((listp->filter == NULL) || (strcmp(filter, listp->filter))) {
9648 if (listp->filter != NULL)
9649 free(listp->filter);
9650 listp->filter = strdup(filter);
9651 newfilelist(listp->filew, listp);
9652 }
9653 else
9654 listfiles(listp->filew, listp, NULL);
9655 }
9656 else {
9657 if (listp->filter != NULL) {
9658 free(listp->filter);
9659 listp->filter = NULL;
9660 }
9661 listfiles(listp->filew, listp, NULL);
9662 }
9663 }
9664
9665 /*----------------------------------------------------------------------*/
9666
9667 void xctk_startfiletrack(ClientData clientData, XEvent *eventPtr)
9668 {
9669 startfiletrack((Tk_Window)clientData, NULL, (XCrossingEvent *)eventPtr);
9670 }
9671
9672 /*----------------------------------------------------------------------*/
9673
9674 void xctk_endfiletrack(ClientData clientData, XEvent *eventPtr)
9675 {
9676 endfiletrack((Tk_Window)clientData, NULL, (XCrossingEvent *)eventPtr);
9677 }
9678
9679 /*----------------------------------------------------------------------*/
9680
9681 void xctk_dragfilebox(ClientData clientData, XEvent *eventPtr)
9682 {
9683 dragfilebox((Tk_Window)clientData, NULL, (XMotionEvent *)eventPtr);
9684 }
9685
9686 /*----------------------------------------------------------------------*/
9687
9688 void xctk_draglscroll(ClientData clientData, XEvent *eventPtr)
9689 {
9690 popupstruct *listp = (popupstruct *)clientData;
9691 XMotionEvent *mevent = (XMotionEvent *)eventPtr;
9692 u_int state = mevent->state;
9693
9694 if (state & (Button1Mask | Button2Mask))
9695 draglscroll(listp->scroll, listp, (XButtonEvent *)eventPtr);
9696 }
9697
9698 /*----------------------------------------------------------------------*/
9699
9700 void xctk_showlscroll(ClientData clientData, XEvent *eventPtr)
9701 {
9702 showlscroll((Tk_Window)clientData, NULL, NULL);
9703 }
9704
9705 /*----------------------------------------------------------------------*/
9706 /* Build or rebuild the database of colors, fonts, and other settings */
9707 /* from the Tk option settings. */
9708 /*----------------------------------------------------------------------*/
9709
9710 void build_app_database(Tk_Window tkwind)
9711 {
9712 Tk_Uid xcuid;
9713
9714 /*--------------------------*/
9715 /* Build the color database */
9716 /*--------------------------*/
9717
9718 if ((xcuid = Tk_GetOption(tkwind, "globalpincolor", "Color")) == NULL)
9719 xcuid = "Orange2";
9720 appdata.globalcolor = xc_alloccolor((char *)xcuid);
9721 if ((xcuid = Tk_GetOption(tkwind, "localpincolor", "Color")) == NULL)
9722 xcuid = "Red";
9723 appdata.localcolor = xc_alloccolor((char *)xcuid);
9724 if ((xcuid = Tk_GetOption(tkwind, "infolabelcolor", "Color")) == NULL)
9725 xcuid = "SeaGreen";
9726 appdata.infocolor = xc_alloccolor((char *)xcuid);
9727 if ((xcuid = Tk_GetOption(tkwind, "ratsnestcolor", "Color")) == NULL)
9728 xcuid = "tan4";
9729 appdata.ratsnestcolor = xc_alloccolor((char *)xcuid);
9730
9731 if ((xcuid = Tk_GetOption(tkwind, "bboxcolor", "Color")) == NULL)
9732 xcuid = "greenyellow";
9733 appdata.bboxpix = xc_alloccolor((char *)xcuid);
9734
9735 if ((xcuid = Tk_GetOption(tkwind, "fixedbboxcolor", "Color")) == NULL)
9736 xcuid = "pink";
9737 appdata.fixedbboxpix = xc_alloccolor((char *)xcuid);
9738
9739 if ((xcuid = Tk_GetOption(tkwind, "clipcolor", "Color")) == NULL)
9740 xcuid = "powderblue";
9741 appdata.clipcolor = xc_alloccolor((char *)xcuid);
9742
9743 if ((xcuid = Tk_GetOption(tkwind, "paramcolor", "Color")) == NULL)
9744 xcuid = "Plum3";
9745 appdata.parampix = xc_alloccolor((char *)xcuid);
9746 if ((xcuid = Tk_GetOption(tkwind, "auxiliarycolor", "Color")) == NULL)
9747 xcuid = "Green3";
9748 appdata.auxpix = xc_alloccolor((char *)xcuid);
9749 if ((xcuid = Tk_GetOption(tkwind, "axescolor", "Color")) == NULL)
9750 xcuid = "Antique White";
9751 appdata.axespix = xc_alloccolor((char *)xcuid);
9752 if ((xcuid = Tk_GetOption(tkwind, "filtercolor", "Color")) == NULL)
9753 xcuid = "SteelBlue3";
9754 appdata.filterpix = xc_alloccolor((char *)xcuid);
9755 if ((xcuid = Tk_GetOption(tkwind, "selectcolor", "Color")) == NULL)
9756 xcuid = "Gold3";
9757 appdata.selectpix = xc_alloccolor((char *)xcuid);
9758 if ((xcuid = Tk_GetOption(tkwind, "snapcolor", "Color")) == NULL)
9759 xcuid = "Red";
9760 appdata.snappix = xc_alloccolor((char *)xcuid);
9761 if ((xcuid = Tk_GetOption(tkwind, "gridcolor", "Color")) == NULL)
9762 xcuid = "Gray95";
9763 appdata.gridpix = xc_alloccolor((char *)xcuid);
9764 if ((xcuid = Tk_GetOption(tkwind, "pagebackground", "Color")) == NULL)
9765 xcuid = "White";
9766 appdata.bg = xc_alloccolor((char *)xcuid);
9767 if ((xcuid = Tk_GetOption(tkwind, "pageforeground", "Color")) == NULL)
9768 xcuid = "Black";
9769 appdata.fg = xc_alloccolor((char *)xcuid);
9770
9771 if ((xcuid = Tk_GetOption(tkwind, "paramcolor2", "Color")) == NULL)
9772 xcuid = "Plum3";
9773 appdata.parampix2 = xc_alloccolor((char *)xcuid);
9774 if ((xcuid = Tk_GetOption(tkwind, "auxiliarycolor2", "Color")) == NULL)
9775 xcuid = "Green";
9776 appdata.auxpix2 = xc_alloccolor((char *)xcuid);
9777 if ((xcuid = Tk_GetOption(tkwind, "selectcolor2", "Color")) == NULL)
9778 xcuid = "Gold";
9779 appdata.selectpix2 = xc_alloccolor((char *)xcuid);
9780 if ((xcuid = Tk_GetOption(tkwind, "filtercolor2", "Color")) == NULL)
9781 xcuid = "SteelBlue1";
9782 appdata.gridpix2 = xc_alloccolor((char *)xcuid);
9783 if ((xcuid = Tk_GetOption(tkwind, "snapcolor2", "Color")) == NULL)
9784 xcuid = "Red";
9785 appdata.snappix2 = xc_alloccolor((char *)xcuid);
9786 if ((xcuid = Tk_GetOption(tkwind, "axescolor2", "Color")) == NULL)
9787 xcuid = "NavajoWhite4";
9788 appdata.axespix2 = xc_alloccolor((char *)xcuid);
9789 if ((xcuid = Tk_GetOption(tkwind, "background2", "Color")) == NULL)
9790 xcuid = "DarkSlateGray";
9791 appdata.bg2 = xc_alloccolor((char *)xcuid);
9792 if ((xcuid = Tk_GetOption(tkwind, "foreground2", "Color")) == NULL)
9793 xcuid = "White";
9794 appdata.fg2 = xc_alloccolor((char *)xcuid);
9795 if ((xcuid = Tk_GetOption(tkwind, "barcolor", "Color")) == NULL)
9796 xcuid = "Tan";
9797 appdata.barpix = xc_alloccolor((char *)xcuid);
9798
9799 /* These are GUI colors---unused by Tcl */
9800 appdata.buttonpix = xc_alloccolor("Gray85");
9801 appdata.buttonpix2 = xc_alloccolor("Gray50");
9802
9803 /* Get some default fonts (Should be using Tk calls here. . . ) */
9804
9805 if ((xcuid = Tk_GetOption(tkwind, "filelistfont", "Font")) == NULL)
9806 xcuid = "-*-helvetica-medium-r-normal--14-*";
9807 appdata.filefont = XLoadQueryFont(dpy, (char *)xcuid);
9808
9809 if (appdata.filefont == NULL)
9810 {
9811 appdata.filefont = XLoadQueryFont(dpy, "-*-*-medium-r-normal--14-*");
9812 if (appdata.filefont == NULL)
9813 appdata.filefont = XLoadQueryFont(dpy, "-*-*-*-*-*--*-*");
9814 }
9815
9816 /* Other defaults */
9817
9818 if ((xcuid = Tk_GetOption(tkwind, "timeout", "TimeOut")) == NULL)
9819 xcuid = "10";
9820 appdata.timeout = atoi((char *)xcuid);
9821 }
9822
9823 /*--------------------------------------------------------------*/
9824 /* GUI Initialization under Tk */
9825 /* First argument is the Tk path name of the drawing window. */
9826 /* This function should be called for each new window created. */
9827 /*--------------------------------------------------------------*/
9828
9829 XCWindowData *GUI_init(int objc, Tcl_Obj *CONST objv[])
9830 {
9831 Tk_Window tkwind, tktop, tkdraw, tksb;
9832 Tk_Window wsymb, wschema, corner;
9833 int i, locobjc, done = 1;
9834 XGCValues values;
9835 Window win;
9836 popupstruct *fileliststruct;
9837 char *xctopwin, *xcdrawwin;
9838 char winpath[512];
9839 XCWindowData *newwin;
9840
9841 tktop = Tk_MainWindow(xcinterp);
9842 if (tktop == (Tk_Window)NULL) {
9843 Fprintf(stderr, "No Top-Level Tk window available. . .\n");
9844
9845 /* No top level window, assuming batch mode. To get */
9846 /* access to font information requires that cairo be set */
9847 /* up with a surface, even if it is not an xlib target. */
9848
9849 newwin = create_new_window();
9850 newwin->area = NULL;
9851 newwin->scrollbarv = NULL;
9852 newwin->scrollbarh = NULL;
9853 newwin->width = 100;
9854 newwin->height = 100;
9855
9856 #ifdef HAVE_CAIRO
9857 newwin->surface = cairo_image_surface_create(CAIRO_FORMAT_RGB24,
9858 newwin->width, newwin->height);
9859 newwin->cr = cairo_create(newwin->surface);
9860 #endif /* !HAVE_CAIRO */
9861
9862 number_colors = NUMBER_OF_COLORS;
9863 colorlist = (colorindex *)malloc(NUMBER_OF_COLORS * sizeof(colorindex));
9864
9865 return newwin;
9866 }
9867
9868 /* Check if any parameter is a Tk window name */
9869
9870 locobjc = objc;
9871 while (locobjc > 0) {
9872 xctopwin = Tcl_GetString(objv[locobjc - 1]);
9873 tkwind = Tk_NameToWindow(xcinterp, xctopwin, tktop);
9874 if (tkwind != (Tk_Window)NULL)
9875 break;
9876 locobjc--;
9877 }
9878
9879 if (locobjc == 0) {
9880 /* Okay to have no GUI wrapper. However, if this is the case, */
9881 /* then the variable "XCOps(window)" must be set to the Tk path */
9882 /* name of the drawing window. */
9883
9884 xcdrawwin = (char *)Tcl_GetVar2(xcinterp, "XCOps", "window", 0);
9885 if (xcdrawwin == NULL) {
9886 Fprintf(stderr, "The Tk window hierarchy must be rooted at"
9887 " .xcircuit, or XCOps(top)");
9888 Fprintf(stderr, " must point to the hierarchy. If XCOps(top)"
9889 " is NULL, then XCOps(window) must");
9890 Fprintf(stderr, " point to the drawing window.\n");
9891 return NULL;
9892 }
9893 tkwind = Tk_NameToWindow(xcinterp, xcdrawwin, tktop);
9894 if (tkwind == NULL) {
9895 Fprintf(stderr, "Error: XCOps(window) is set but does not point to"
9896 " a valid Tk window.\n");
9897 return NULL;
9898 }
9899
9900 /* Create new window data structure */
9901 newwin = create_new_window();
9902 newwin->area = tkwind;
9903
9904 /* No GUI---GUI widget pointers need to be NULL'd */
9905 newwin->scrollbarv = NULL;
9906 newwin->scrollbarh = NULL;
9907 }
9908 else {
9909
9910 /* Expect a top-level window name passed as the first argument. */
9911 /* Having a fixed hierarchy is a total kludge and needs to be */
9912 /* rewritten. . . */
9913
9914 if (tkwind == NULL) {
9915 Fprintf(stderr, "Error: config init given a bad window name!\n");
9916 return NULL;
9917 }
9918 else {
9919 /* Make sure that this window does not already exist */
9920 XCWindowDataPtr searchwin;
9921 sprintf(winpath, "%s.mainframe.mainarea.drawing", xctopwin);
9922 tkdraw = Tk_NameToWindow(xcinterp, winpath, tktop);
9923 for (searchwin = xobjs.windowlist; searchwin != NULL; searchwin =
9924 searchwin->next) {
9925 if (searchwin->area == tkdraw) {
9926 Fprintf(stderr, "Error: window already exists!\n");
9927 return NULL;
9928 }
9929 }
9930 }
9931
9932 /* Create new window data structure and */
9933 /* fill in global variables from the Tk window values */
9934
9935 newwin = create_new_window();
9936 sprintf(winpath, "%s.mainframe.mainarea.sbleft", xctopwin);
9937 newwin->scrollbarv = Tk_NameToWindow(xcinterp, winpath, tktop);
9938 sprintf(winpath, "%s.mainframe.mainarea.sbbottom", xctopwin);
9939 newwin->scrollbarh = Tk_NameToWindow(xcinterp, winpath, tktop);
9940 sprintf(winpath, "%s.mainframe.mainarea.drawing", xctopwin);
9941 newwin->area = Tk_NameToWindow(xcinterp, winpath, tktop);
9942
9943 sprintf(winpath, "%s.mainframe.mainarea.corner", xctopwin);
9944 corner = Tk_NameToWindow(xcinterp, winpath, tktop);
9945
9946 sprintf(winpath, "%s.infobar.symb", xctopwin);
9947 wsymb = Tk_NameToWindow(xcinterp, winpath, tktop);
9948
9949 sprintf(winpath, "%s.infobar.schem", xctopwin);
9950 wschema = Tk_NameToWindow(xcinterp, winpath, tktop);
9951
9952 Tk_CreateEventHandler(newwin->scrollbarh, ButtonMotionMask,
9953 (Tk_EventProc *)xctk_panhbar, NULL);
9954 Tk_CreateEventHandler(newwin->scrollbarv, ButtonMotionMask,
9955 (Tk_EventProc *)xctk_panvbar, NULL);
9956 Tk_CreateEventHandler(newwin->scrollbarh, StructureNotifyMask | ExposureMask,
9957 (Tk_EventProc *)xctk_drawhbar, NULL);
9958 Tk_CreateEventHandler(newwin->scrollbarv, StructureNotifyMask | ExposureMask,
9959 (Tk_EventProc *)xctk_drawvbar, NULL);
9960 Tk_CreateEventHandler(newwin->scrollbarh, ButtonReleaseMask,
9961 (Tk_EventProc *)xctk_endhbar, NULL);
9962 Tk_CreateEventHandler(newwin->scrollbarv, ButtonReleaseMask,
9963 (Tk_EventProc *)xctk_endvbar, NULL);
9964
9965 Tk_CreateEventHandler(corner, ButtonPressMask,
9966 (Tk_EventProc *)xctk_zoomview, Number(1));
9967 Tk_CreateEventHandler(wsymb, ButtonPressMask,
9968 (Tk_EventProc *)xctk_swapschem, Number(0));
9969 Tk_CreateEventHandler(wschema, ButtonPressMask,
9970 (Tk_EventProc *)xctk_swapschem, Number(0));
9971
9972 /* Setup event handlers for the drawing area and scrollbars */
9973 /* There are purposely no callback functions for these windows---they are */
9974 /* defined as type "simple" to keep down the cruft, as I will define my */
9975 /* own event handlers. */
9976
9977 Tk_CreateEventHandler(newwin->area, StructureNotifyMask,
9978 (Tk_EventProc *)xctk_resizearea, NULL);
9979 Tk_CreateEventHandler(newwin->area, ExposureMask,
9980 (Tk_EventProc *)xctk_drawarea, NULL);
9981 }
9982
9983 if ((locobjc > 0) || !Tk_IsMapped(newwin->area)) {
9984
9985 /* This code copied from code for the "tkwait" command */
9986
9987 Tk_CreateEventHandler(newwin->area,
9988 VisibilityChangeMask|StructureNotifyMask,
9989 WaitVisibilityProc, (ClientData) &done);
9990 done = 0;
9991 }
9992
9993 /* Make sure the window is mapped */
9994
9995 Tk_MapWindow(tkwind);
9996 win = Tk_WindowId(tkwind);
9997 Tk_MapWindow(newwin->area);
9998
9999 if (!done) {
10000 while (!done) Tcl_DoOneEvent(0);
10001 Tk_DeleteEventHandler(newwin->area,
10002 VisibilityChangeMask|StructureNotifyMask,
10003 WaitVisibilityProc, (ClientData) &done);
10004 }
10005
10006 newwin->window = Tk_WindowId(newwin->area);
10007 newwin->width = Tk_Width(newwin->area);
10008 newwin->height = Tk_Height(newwin->area);
10009
10010 /* Things to set once only */
10011
10012 if (dpy == NULL) {
10013 dpy = Tk_Display(tkwind);
10014 cmap = Tk_Colormap(tkwind);
10015 // (The following may be required on some systems where
10016 // Tk will not report a valid colormap after Tk_MapWindow())
10017 // cmap = DefaultColormap(dpy, DefaultScreen(dpy));
10018
10019 /*------------------------------------------------------*/
10020 /* Handle different screen resolutions in a sane manner */
10021 /*------------------------------------------------------*/
10022
10023 screenDPI = getscreenDPI();
10024
10025 /*-------------------------*/
10026 /* Create stipple patterns */
10027 /*-------------------------*/
10028
10029 for (i = 0; i < STIPPLES; i++)
10030 STIPPLE[i] = XCreateBitmapFromData(dpy, win, STIPDATA[i], 4, 4);
10031
10032 /*----------------------------------------*/
10033 /* Allocate space for the basic color map */
10034 /*----------------------------------------*/
10035
10036 number_colors = NUMBER_OF_COLORS;
10037 colorlist = (colorindex *)malloc(NUMBER_OF_COLORS * sizeof(colorindex));
10038 areawin = newwin;
10039 build_app_database(tkwind);
10040 areawin = NULL;
10041
10042 /* Create the filelist window and its event handlers */
10043
10044 tksb = Tk_NameToWindow(xcinterp, ".filelist.listwin.sb", tktop);
10045 tkdraw = Tk_NameToWindow(xcinterp, ".filelist.listwin.win", tktop);
10046
10047 fileliststruct = (popupstruct *) malloc(sizeof(popupstruct));
10048 fileliststruct->popup = Tk_NameToWindow(xcinterp, ".filelist", tktop);
10049 fileliststruct->textw = Tk_NameToWindow(xcinterp, ".filelist.textent",
10050 fileliststruct->popup);
10051 fileliststruct->filew = tkdraw;
10052 fileliststruct->scroll = tksb;
10053 fileliststruct->setvalue = NULL;
10054 fileliststruct->filter = NULL;
10055
10056 if (tksb != NULL) {
10057 Tk_CreateEventHandler(tksb, ButtonMotionMask,
10058 (Tk_EventProc *)xctk_draglscroll, (ClientData)fileliststruct);
10059 Tk_CreateEventHandler(tksb, ExposureMask,
10060 (Tk_EventProc *)xctk_showlscroll, (ClientData)tksb);
10061 }
10062 if (tkdraw != NULL) {
10063 Tk_CreateEventHandler(tkdraw, ButtonPressMask,
10064 (Tk_EventProc *)xctk_fileselect, (ClientData)fileliststruct);
10065 Tk_CreateEventHandler(tkdraw, ExposureMask,
10066 (Tk_EventProc *)xctk_listfiles, (ClientData)fileliststruct);
10067 Tk_CreateEventHandler(tkdraw, EnterWindowMask,
10068 (Tk_EventProc *)xctk_startfiletrack, (ClientData)tkdraw);
10069 Tk_CreateEventHandler(tkdraw, LeaveWindowMask,
10070 (Tk_EventProc *)xctk_endfiletrack, (ClientData)tkdraw);
10071 }
10072 }
10073
10074 /*-------------------------------------------------------------------*/
10075 /* Generate the GC */
10076 /* Set "graphics_exposures" to False. Every XCopyArea function */
10077 /* copies from virtual memory (dbuf pixmap), which can never be */
10078 /* obscured. Otherwise, the server gets flooded with useless */
10079 /* NoExpose events. */
10080 /*-------------------------------------------------------------------*/
10081
10082 values.foreground = BlackPixel(dpy, DefaultScreen(dpy));
10083 values.background = WhitePixel(dpy, DefaultScreen(dpy));
10084 values.graphics_exposures = False;
10085 newwin->gc = XCreateGC(dpy, win, GCForeground | GCBackground
10086 | GCGraphicsExposures, &values);
10087
10088 #ifdef HAVE_CAIRO
10089 newwin->surface = cairo_xlib_surface_create(dpy, newwin->window,
10090 DefaultVisual(dpy, 0), newwin->width, newwin->height);
10091 newwin->cr = cairo_create(newwin->surface);
10092 #else /* HAVE_CAIRO */
10093 newwin->clipmask = XCreatePixmap(dpy, win, newwin->width,
10094 newwin->height, 1);
10095
10096 values.foreground = 0;
10097 values.background = 0;
10098 newwin->cmgc = XCreateGC(dpy, newwin->clipmask, GCForeground
10099 | GCBackground, &values);
10100 #endif /* HAVE_CAIRO */
10101
10102 XDefineCursor (dpy, win, *newwin->defaultcursor);
10103 return newwin;
10104 }
10105
10106 /*--------------------------------------*/
10107 /* Inline the main wrapper prodedure */
10108 /*--------------------------------------*/
10109
10110 int xctcl_start(ClientData clientData, Tcl_Interp *interp,
10111 int objc, Tcl_Obj *CONST objv[])
10112 {
10113 int result = TCL_OK;
10114 Boolean rcoverride = False;
10115 char *filearg = NULL;
10116 Tcl_Obj *cmdname = objv[0];
10117
10118 Fprintf(stdout, "Starting xcircuit under Tcl interpreter\n");
10119
10120 /* xcircuit initialization routines --- these assume that the */
10121 /* GUI has been created by the startup script; otherwise bad */
10122 /* things will probably occur. */
10123
10124 pre_initialize();
10125 areawin = GUI_init(--objc, ++objv);
10126 if (areawin == NULL) {
10127 /* Create new window data structure */
10128 areawin = create_new_window();
10129 areawin->area = NULL;
10130 areawin->scrollbarv = NULL;
10131 areawin->scrollbarh = NULL;
10132
10133 Tcl_SetResult(interp, "Invalid or missing top-level windowname"
10134 " given to start command, assuming batch mode.\n", NULL);
10135 }
10136 post_initialize();
10137
10138 ghostinit();
10139
10140 /* The Tcl version accepts some command-line arguments. Due */
10141 /* to the way ".wishrc" is processed, all arguments are */
10142 /* glommed into one Tcl (list) object, objv[1]. */
10143
10144 filearg = (char *)malloc(sizeof(char));
10145 *filearg = '\0';
10146
10147 if (objc == 2) {
10148 char **argv;
10149 int argc;
10150
10151 Tcl_SplitList(interp, Tcl_GetString(objv[1]), &argc,
10152 (CONST84 char ***)&argv);
10153 while (argc) {
10154 if (**argv == '-') {
10155 if (!strncmp(*argv, "-exec", 5)) {
10156 if (--argc > 0) {
10157 argv++;
10158 result = Tcl_EvalFile(interp, *argv);
10159 if (result != TCL_OK) {
10160 free(filearg);
10161 return result;
10162 }
10163 else
10164 rcoverride = True;
10165 }
10166 else {
10167 Tcl_SetResult(interp, "No filename given to exec argument.", NULL);
10168 free(filearg);
10169 return TCL_ERROR;
10170 }
10171 }
10172 else if (!strncmp(*argv, "-2", 2)) {
10173 /* 2-button mouse bindings option */
10174 pressmode = 1;
10175 }
10176 }
10177 else if (strcmp(*argv, ".xcircuit")) {
10178 filearg = (char *)realloc(filearg, sizeof(char) *
10179 (strlen(filearg) + strlen(*argv) + 2));
10180 strcat(filearg, ",");
10181 strcat(filearg, *argv);
10182 }
10183 argv++;
10184 argc--;
10185 }
10186 }
10187 else {
10188 /* Except---this appears to be no longer true. When did it change? */
10189 int argc = objc;
10190 char *argv;
10191
10192 for (argc = 0; argc < objc; argc++) {
10193 argv = Tcl_GetString(objv[argc]);
10194 if (*argv == '-') {
10195 if (!strncmp(argv, "-exec", 5)) {
10196 if (++argc < objc) {
10197 argv = Tcl_GetString(objv[argc]);
10198 result = Tcl_EvalFile(interp, argv);
10199 if (result != TCL_OK) {
10200 free(filearg);
10201 return result;
10202 }
10203 else
10204 rcoverride = True;
10205 }
10206 else {
10207 Tcl_SetResult(interp, "No filename given to exec argument.", NULL);
10208 free(filearg);
10209 return TCL_ERROR;
10210 }
10211 }
10212 else if (!strncmp(argv, "-2", 2)) {
10213 /* 2-button mouse bindings option */
10214 pressmode = 1;
10215 }
10216 }
10217 else if (strcmp(argv, ".xcircuit")) {
10218 filearg = (char *)realloc(filearg, sizeof(char) *
10219 (strlen(filearg) + strlen(argv) + 2));
10220 strcat(filearg, ",");
10221 strcat(filearg, argv);
10222 }
10223 }
10224 }
10225
10226 if (!rcoverride)
10227 result = loadrcfile();
10228
10229 composelib(PAGELIB); /* make sure we have a valid page list */
10230 composelib(LIBLIB); /* and library directory */
10231 if ((objc >= 2) && (*filearg != '\0')) {
10232 char *libname;
10233 int target = -1;
10234
10235 strcpy(_STR2, filearg);
10236 libname = (char *)Tcl_GetVar2(xcinterp, "XCOps", "library", 0);
10237 if (libname != NULL) {
10238 target = NameToLibrary(libname);
10239 }
10240 startloadfile((target >= 0) ? target + LIBRARY : -1);
10241 }
10242 else {
10243 findcrashfiles();
10244 }
10245 pressmode = 0; /* Done using this to track 2-button bindings */
10246
10247 /* Note that because the setup has the windows generated and */
10248 /* mapped prior to calling the xcircuit routines, nothing */
10249 /* gets CreateNotify, MapNotify, or other definitive events. */
10250 /* So, we have to do all the drawing once. */
10251
10252 xobjs.suspend = -1; /* Release from suspend mode */
10253 if (areawin->scrollbarv)
10254 drawvbar(areawin->scrollbarv, NULL, NULL);
10255 if (areawin->scrollbarh)
10256 drawhbar(areawin->scrollbarh, NULL, NULL);
10257 drawarea(areawin->area, NULL, NULL);
10258
10259 /* Return back to the interpreter; Tk is handling the GUI */
10260 free(filearg);
10261 return (result == TCL_OK) ? XcTagCallback(interp, 1, &cmdname) : result;
10262 }
10263
10264 /*--------------------------------------------------------------*/
10265 /* Message printing procedures for the Tcl version */
10266 /* */
10267 /* Evaluate the variable-length argument, and make a call to */
10268 /* the routine xcircuit::print, which should be defined. */
10269 /*--------------------------------------------------------------*/
10270
10271 void W0vprintf(char *window, const char *format, va_list args_in)
10272 {
10273 char tstr[128], *bigstr = NULL, *strptr;
10274 int n, size;
10275 va_list args;
10276
10277 if (window != NULL) {
10278 sprintf(tstr, "catch {xcircuit::print %s {", window);
10279 size = strlen(tstr);
10280
10281 va_copy(args, args_in);
10282 n = vsnprintf(tstr + size, 128 - size, format, args);
10283 va_end(args);
10284
10285 if (n <= -1 || n > 125 - size) {
10286 bigstr = malloc(n + size + 4);
10287 strncpy(bigstr, tstr, size);
10288 va_copy(args, args_in);
10289 vsnprintf(bigstr + size, n + 1, format, args);
10290 va_end(args);
10291 strptr = bigstr;
10292 strcat(bigstr, "}}");
10293 }
10294 else {
10295 strptr = tstr;
10296 strcat(tstr, "}}");
10297 }
10298 Tcl_Eval(xcinterp, strptr);
10299 if (bigstr != NULL) free(bigstr);
10300 }
10301 }
10302
10303 /* Prints to pagename window */
10304
10305 void W1printf(char *format, ...)
10306 {
10307 va_list args;
10308 va_start(args, format);
10309 W0vprintf("coord", format, args);
10310 va_end(args);
10311 }
10312
10313 /* Prints to coordinate window */
10314
10315 void W2printf(char *format, ...)
10316 {
10317 va_list args;
10318 va_start(args, format);
10319 W0vprintf("page", format, args);
10320 va_end(args);
10321 }
10322
10323 /* Prints to status window but does not tee output to the console. */
10324
10325 void W3printf(char *format, ...)
10326 {
10327 va_list args;
10328 va_start(args, format);
10329 W0vprintf("stat", format, args);
10330 va_end(args);
10331 }
10332
10333 /* Prints to status window and duplicates the output to stdout. */
10334
10335 void Wprintf(char *format, ...)
10336 {
10337 va_list args;
10338 va_start(args, format);
10339 W0vprintf("stat", format, args);
10340 if (strlen(format) > 0) {
10341 if (strstr(format, "Error")) {
10342 tcl_vprintf(stderr, format, args);
10343 tcl_printf(stderr, "\n");
10344 }
10345 else {
10346 tcl_vprintf(stdout, format, args);
10347 tcl_printf(stdout, "\n");
10348 }
10349 }
10350 va_end(args);
10351 }
10352
10353 /*------------------------------------------------------*/
10354
10355 #endif /* defined(TCL_WRAPPER) && !defined(HAVE_PYTHON) */
XCircuit is a program for drawing publishable-quality electrical circuit schematic diagrams and related figures, and produce circuit netlists through schematic capture.