?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Continuing to track down the issue with a crash on startup on
[xcircuit.git] / tclxcircuit.c
bloba487c0203e8c05a53b961916e7f3d0f3811ccafe
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", "netlist", NULL};
5672 enum SubIdx {
5673 MakeIdx, ObjectIdx, ScaleIdx, CenterIdx, LineWidthIdx, BBoxIdx, NetListIdx
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 + i);
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 NetListIdx:
5969 if ((objc - nidx) == 1) {
5970 Tcl_Obj *listPtr;
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_NewBooleanObj((pinst->style & INST_NONETLIST) ?
5976 FALSE : TRUE);
5977 if (numfound > 0)
5978 Tcl_ListObjAppendElement(interp, listPtr, objPtr);
5979 if ((++numfound) == 1)
5980 listPtr = objPtr;
5981 }
5982 }
5983 switch (numfound) {
5984 case 0:
5985 Tcl_SetResult(interp, "Error: no object instances selected", NULL);
5986 return TCL_ERROR;
5987 break;
5988 case 1:
5989 Tcl_SetObjResult(interp, objPtr);
5990 break;
5991 default:
5992 Tcl_SetObjResult(interp, listPtr);
5993 break;
5994 }
5995 }
5996 else {
5997 int value;
5998 if ((result = Tcl_GetBooleanFromObj(interp, objv[nidx + 1], &value))
5999 == TCL_OK) {
6000 for (i = 0; i < areawin->selects; i++) {
6001 if (SELECTTYPE(areawin->selectlist + i) == OBJINST) {
6002 pinst = SELTOOBJINST(areawin->selectlist + i);
6003 if (value)
6004 pinst->style &= ~INST_NONETLIST;
6005 else
6006 pinst->style |= INST_NONETLIST;
6007 }
6008 }
6009 }
6010 }
6011 break;
6012
6013 case BBoxIdx:
6014 if ((objc - nidx) == 1) {
6015 Tcl_Obj *listPtr, *coord;
6016 numfound = 0;
6017 for (i = 0; i < areawin->selects; i++) {
6018 if (SELECTTYPE(areawin->selectlist + i) == OBJINST) {
6019 pinst = SELTOOBJINST(areawin->selectlist + i);
6020 objPtr = Tcl_NewListObj(0, NULL);
6021 coord = Tcl_NewIntObj((int)pinst->bbox.lowerleft.x);
6022 Tcl_ListObjAppendElement(interp, objPtr, coord);
6023 coord = Tcl_NewIntObj((int)pinst->bbox.lowerleft.y);
6024 Tcl_ListObjAppendElement(interp, objPtr, coord);
6025 coord = Tcl_NewIntObj((int)(pinst->bbox.lowerleft.x +
6026 pinst->bbox.width));
6027 Tcl_ListObjAppendElement(interp, objPtr, coord);
6028 coord = Tcl_NewIntObj((int)(pinst->bbox.lowerleft.y +
6029 pinst->bbox.height));
6030 Tcl_ListObjAppendElement(interp, objPtr, coord);
6031 if (numfound > 0)
6032 Tcl_ListObjAppendElement(interp, listPtr, objPtr);
6033 if ((++numfound) == 1)
6034 listPtr = objPtr;
6035 }
6036 }
6037 switch (numfound) {
6038 case 0:
6039 Tcl_SetResult(interp, "Error: no object instances selected", NULL);
6040 return TCL_ERROR;
6041 break;
6042 case 1:
6043 Tcl_SetObjResult(interp, objPtr);
6044 break;
6045 default:
6046 Tcl_SetObjResult(interp, listPtr);
6047 break;
6048 }
6049 }
6050 else {
6051 /* e.g., "instance bbox recompute" */
6052 for (i = 0; i < areawin->selects; i++) {
6053 if (SELECTTYPE(areawin->selectlist + i) == OBJINST) {
6054 pinst = SELTOOBJINST(areawin->selectlist + i);
6055 calcbbox(pinst);
6056 }
6057 }
6058 }
6059 break;
6060 }
6061 return XcTagCallback(interp, objc, objv);
6062 }
6063
6064 /*----------------------------------------------------------------------*/
6065 /* "element" configures properties of elements. Note that if the */
6066 /* second argument is not an element handle (pointer), then operations */
6067 /* will be applied to all selected elements. If there is no element */
6068 /* handle and no objects are selected, the operation will be applied */
6069 /* to default settings, like the "xcircuit::set" command. */
6070 /*----------------------------------------------------------------------*/
6071
6072 int xctcl_element(ClientData clientData, Tcl_Interp *interp,
6073 int objc, Tcl_Obj *CONST objv[])
6074 {
6075 int result, nidx, idx, i, flags;
6076 Tcl_Obj *listPtr;
6077 Tcl_Obj **newobjv;
6078 int newobjc;
6079 genericptr egen;
6080 short *newselect, *tempselect, *orderlist;
6081
6082 /* Commands */
6083 static char *subCmds[] = {
6084 "delete", "copy", "flip", "rotate", "edit", "select", "snap", "move",
6085 "color", "parameters", "raise", "lower", "exchange", "hide", "show",
6086 "handle", "deselect", NULL
6087 };
6088 enum SubIdx {
6089 DeleteIdx, CopyIdx, FlipIdx, RotateIdx, EditIdx, SelectIdx, SnapIdx,
6090 MoveIdx, ColorIdx, ParamIdx, RaiseIdx, LowerIdx, ExchangeIdx,
6091 HideIdx, ShowIdx, HandleIdx, DeselectIdx
6092 };
6093
6094 static char *etypes[] = {
6095 "Label", "Polygon", "Bezier Curve", "Object Instance", "Path",
6096 "Arc", "Graphic", NULL /* (jdk) */
6097 };
6098
6099 /* Before doing a standard parse, we need to check for the single case */
6100 /* "element X deselect"; otherwise, calling ParseElementArguements() */
6101 /* is going to destroy the selection list. */
6102
6103 if ((objc == 3) && (!strcmp(Tcl_GetString(objv[2]), "deselect"))) {
6104 result = xctcl_deselect(clientData, interp, objc, objv);
6105 return result;
6106 }
6107
6108 /* All other commands are dispatched to individual element commands */
6109 /* for the indicated element or for each selected element. */
6110
6111 nidx = 7;
6112 result = ParseElementArguments(interp, objc, objv, &nidx, ALL_TYPES);
6113 if (result != TCL_OK) return result;
6114
6115 if ((objc - nidx) < 1) {
6116 Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
6117 return TCL_ERROR;
6118 }
6119
6120 if (!strcmp(Tcl_GetString(objv[nidx]), "type")) {
6121 /* Return a list of types of the selected elements */
6122
6123 if (areawin->selects > 1)
6124 listPtr = Tcl_NewListObj(0, NULL);
6125
6126 for (i = 0; i < areawin->selects; i++) {
6127 Tcl_Obj *objPtr;
6128 int idx2, type = SELECTTYPE(areawin->selectlist + i);
6129 switch (type) {
6130 case LABEL: idx2 = 0; break;
6131 case POLYGON: idx2 = 1; break;
6132 case SPLINE: idx2 = 2; break;
6133 case OBJINST: idx2 = 3; break;
6134 case PATH: idx2 = 4; break;
6135 case ARC: idx2 = 5; break;
6136 case GRAPHIC: idx2 = 6; break;
6137 default: return TCL_ERROR;
6138 }
6139 objPtr = Tcl_NewStringObj(etypes[idx2], strlen(etypes[idx2]));
6140 if (areawin->selects == 1) {
6141 Tcl_SetObjResult(interp, objPtr);
6142 return TCL_OK;
6143 }
6144 else {
6145 Tcl_ListObjAppendElement(interp, listPtr, objPtr);
6146 }
6147 Tcl_SetObjResult(interp, listPtr);
6148 }
6149 return XcTagCallback(interp, objc, objv);
6150 }
6151 else if (!strcmp(Tcl_GetString(objv[nidx]), "handle")) {
6152 /* Return a list of handles of the selected elements */
6153
6154 listPtr = SelectToTclList(interp, areawin->selectlist, areawin->selects);
6155 Tcl_SetObjResult(interp, listPtr);
6156 return XcTagCallback(interp, objc, objv);
6157 }
6158
6159 if (Tcl_GetIndexFromObj(interp, objv[nidx],
6160 (CONST84 char **)subCmds,
6161 "option", 0, &idx) == TCL_OK) {
6162
6163 newobjv = (Tcl_Obj **)(&objv[nidx]);
6164 newobjc = objc - nidx;
6165
6166 /* Shift the argument list and call the indicated function. */
6167
6168 switch(idx) {
6169 case DeleteIdx:
6170 result = xctcl_delete(clientData, interp, newobjc, newobjv);
6171 break;
6172 case CopyIdx:
6173 result = xctcl_copy(clientData, interp, newobjc, newobjv);
6174 break;
6175 case FlipIdx:
6176 result = xctcl_flip(clientData, interp, newobjc, newobjv);
6177 break;
6178 case RotateIdx:
6179 result = xctcl_rotate(clientData, interp, newobjc, newobjv);
6180 break;
6181 case EditIdx:
6182 result = xctcl_edit(clientData, interp, newobjc, newobjv);
6183 break;
6184 case ParamIdx:
6185 result = xctcl_param(clientData, interp, newobjc, newobjv);
6186 break;
6187 case HideIdx:
6188 for (i = 0; i < areawin->selects; i++) {
6189 newselect = areawin->selectlist + i;
6190 egen = SELTOGENERIC(newselect);
6191 egen->type |= DRAW_HIDE;
6192 }
6193 refresh(NULL, NULL, NULL);
6194 break;
6195 case ShowIdx:
6196 if (newobjc == 2) {
6197 if (!strcmp(Tcl_GetString(newobjv[1]), "all")) {
6198 for (i = 0; i < topobject->parts; i++) {
6199 egen = *(topobject->plist + i);
6200 egen->type &= (~DRAW_HIDE);
6201 }
6202 }
6203 }
6204 else {
6205 for (i = 0; i < areawin->selects; i++) {
6206 newselect = areawin->selectlist + i;
6207 egen = SELTOGENERIC(newselect);
6208 egen->type &= (~DRAW_HIDE);
6209 }
6210 }
6211 refresh(NULL, NULL, NULL);
6212 break;
6213 case SelectIdx:
6214 if (newobjc == 2) {
6215 if (!strncmp(Tcl_GetString(newobjv[1]), "hide", 4)) {
6216 for (i = 0; i < areawin->selects; i++) {
6217 newselect = areawin->selectlist + i;
6218 egen = SELTOGENERIC(newselect);
6219 egen->type |= SELECT_HIDE;
6220 }
6221 }
6222 else if (!strncmp(Tcl_GetString(newobjv[1]), "allow", 5)) {
6223 for (i = 0; i < topobject->parts; i++) {
6224 egen = *(topobject->plist + i);
6225 egen->type &= (~SELECT_HIDE);
6226 }
6227 }
6228 else {
6229 Tcl_SetResult(interp, "Select options are \"hide\" "
6230 "and \"allow\"", NULL);
6231 return TCL_ERROR;
6232 }
6233 }
6234 /* If nidx == 2, then we've already done the selection! */
6235 else if (nidx == 1)
6236 result = xctcl_select(clientData, interp, newobjc, newobjv);
6237 else
6238 result = TCL_OK;
6239 break;
6240 case DeselectIdx:
6241 /* case nidx == 2 was already taken care of. case nidx == 1 */
6242 /* implies "deselect all". */
6243 unselect_all();
6244 result = TCL_OK;
6245 break;
6246 case ColorIdx:
6247 result = xctcl_color(clientData, interp, newobjc, newobjv);
6248 break;
6249 case SnapIdx:
6250 snapelement();
6251 break;
6252 case ExchangeIdx:
6253 exchange();
6254 break;
6255 case LowerIdx:
6256
6257 /* Improved method thanks to Dimitri Princen */
6258
6259 /* First move the selected parts to the bottom. This sets */
6260 /* all the values pointed by (selectlist + i) to zero, and */
6261 /* inverts the order between the selected elements. */
6262 /* Finally *tempselect += i inverts the original numbering, */
6263 /* so the second loop inverts the placing again, regaining */
6264 /* the correct order (and writes it so). */
6265 /* */
6266 /* RaiseIdx works similar but starts from the top. */
6267
6268 if (newobjc == 2) {
6269 if (!strcmp(Tcl_GetString(newobjv[1]), "all")) {
6270 orderlist = (short *)malloc(topobject->parts * sizeof(short));
6271 for (i = 0; i < topobject->parts; i++) *(orderlist + i) = i;
6272
6273 for (i = 0; i < areawin->selects; i++) {
6274 tempselect = areawin->selectlist + i;
6275 xc_bottom(tempselect, orderlist);
6276 *tempselect += i;
6277 }
6278 for (i = 0; i < areawin->selects; i++) {
6279 tempselect = areawin->selectlist + i;
6280 xc_bottom(tempselect, orderlist);
6281 *tempselect += (areawin->selects - 1 - i);
6282 }
6283 register_for_undo(XCF_Reorder, UNDO_MORE, areawin->topinstance,
6284 orderlist, topobject->parts);
6285 }
6286 }
6287 else {
6288 xc_lower();
6289 }
6290 break;
6291
6292 case RaiseIdx:
6293
6294 /* Improved method thanks to Dimitri Princen */
6295
6296 if (newobjc == 2) {
6297 if (!strcmp(Tcl_GetString(newobjv[1]), "all")) {
6298 orderlist = (short *)malloc(topobject->parts * sizeof(short));
6299 for (i = 0; i < topobject->parts; i++) *(orderlist + i) = i;
6300
6301 for (i = areawin->selects - 1; i >= 0 ; i--) {
6302 tempselect = areawin->selectlist + i;
6303 xc_top(tempselect, orderlist);
6304 *tempselect -= (areawin->selects - 1 - i);
6305 }
6306 for (i = areawin->selects - 1; i >= 0 ; i--) {
6307 tempselect = areawin->selectlist + i;
6308 xc_top(tempselect, orderlist);
6309 *tempselect -= i;
6310 }
6311 register_for_undo(XCF_Reorder, UNDO_MORE, areawin->topinstance,
6312 orderlist, topobject->parts);
6313 }
6314 }
6315 else {
6316 xc_raise();
6317 }
6318 break;
6319
6320 case MoveIdx:
6321 result = xctcl_move(clientData, interp, newobjc, newobjv);
6322 break;
6323 }
6324 return result;
6325 }
6326
6327 /* Call each individual element function. */
6328 /* Each function is responsible for filtering the select list to */
6329 /* choose only the appropriate elements. However, we first check */
6330 /* if at least one of that type exists in the list, so the function */
6331 /* won't return an error. */
6332
6333 Tcl_ResetResult(interp);
6334
6335 newobjv = (Tcl_Obj **)(&objv[nidx - 1]);
6336 newobjc = objc - nidx + 1;
6337
6338 flags = 0;
6339 for (i = 0; i < areawin->selects; i++)
6340 flags |= SELECTTYPE(areawin->selectlist + i);
6341
6342 if (flags & LABEL) {
6343 result = xctcl_label(clientData, interp, newobjc, newobjv);
6344 if (result != TCL_OK) return result;
6345 }
6346 if (flags & POLYGON) {
6347 result = xctcl_polygon(clientData, interp, newobjc, newobjv);
6348 if (result != TCL_OK) return result;
6349 }
6350 if (flags & OBJINST) {
6351 result = xctcl_instance(clientData, interp, newobjc, newobjv);
6352 if (result != TCL_OK) return result;
6353 }
6354 if (flags & SPLINE) {
6355 result = xctcl_spline(clientData, interp, newobjc, newobjv);
6356 if (result != TCL_OK) return result;
6357 }
6358 if (flags & PATH) {
6359 result = xctcl_path(clientData, interp, newobjc, newobjv);
6360 if (result != TCL_OK) return result;
6361 }
6362 if (flags & ARC) {
6363 result = xctcl_arc(clientData, interp, newobjc, newobjv);
6364 }
6365 if (flags & GRAPHIC) {
6366 result = xctcl_graphic(clientData, interp, newobjc, newobjv);
6367 }
6368 return result;
6369 }
6370
6371 /*----------------------------------------------------------------------*/
6372 /* "config" manipulates a whole bunch of option settings. */
6373 /*----------------------------------------------------------------------*/
6374
6375 int xctcl_config(ClientData clientData, Tcl_Interp *interp,
6376 int objc, Tcl_Obj *CONST objv[])
6377 {
6378 int tmpint, i;
6379 int result, idx;
6380 char *tmpstr, buffer[30], **sptr;
6381 Pagedata *curpage;
6382
6383 static char *boxsubCmds[] = {"manhattan", "rhomboidx", "rhomboidy",
6384 "rhomboida", "normal", NULL};
6385 static char *pathsubCmds[] = {"tangents", "normal", NULL};
6386 static char *coordsubCmds[] = {"decimal inches", "fractional inches",
6387 "centimeters", "internal units", NULL};
6388 static char *filterTypes[] = {"instances", "labels", "polygons", "arcs",
6389 "splines", "paths", "graphics", NULL};
6390 static char *searchOpts[] = {"files", "lib", "libs", "library", "libraries", NULL};
6391
6392 static char *subCmds[] = {
6393 "axis", "axes", "grid", "snap", "bbox", "editinplace",
6394 "pinpositions", "pinattach", "clipmasks", "boxedit", "pathedit", "linewidth",
6395 "colorscheme", "coordstyle", "drawingscale", "manhattan", "centering",
6396 "filter", "buschar", "backup", "search", "focus", "init",
6397 "delete", "windownames", "hold", "database", "suspend",
6398 "technologies", "fontnames", "debug", NULL
6399 };
6400 enum SubIdx {
6401 AxisIdx, AxesIdx, GridIdx, SnapIdx, BBoxIdx, EditInPlaceIdx,
6402 PinPosIdx, PinAttachIdx, ShowClipIdx, BoxEditIdx, PathEditIdx, LineWidthIdx,
6403 ColorSchemeIdx, CoordStyleIdx, ScaleIdx, ManhattanIdx, CenteringIdx,
6404 FilterIdx, BusCharIdx, BackupIdx, SearchIdx, FocusIdx,
6405 InitIdx, DeleteIdx, WindowNamesIdx, HoldIdx, DatabaseIdx,
6406 SuspendIdx, TechnologysIdx, FontNamesIdx, DebugIdx
6407 };
6408
6409 if ((objc == 1) || (objc > 5)) {
6410 Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
6411 return TCL_ERROR;
6412 }
6413 if (Tcl_GetIndexFromObj(interp, objv[1],
6414 (CONST84 char **)subCmds,
6415 "option", 0, &idx) != TCL_OK) {
6416 return TCL_ERROR;
6417 }
6418
6419 /* Set curpage for those routines that need it */
6420
6421 switch(idx) {
6422 case GridIdx:
6423 case SnapIdx:
6424 case LineWidthIdx:
6425 case CoordStyleIdx:
6426 case ScaleIdx:
6427 if (areawin == NULL) {
6428 Tcl_SetResult(interp, "No current window set, assuming default\n",
6429 NULL);
6430 curpage = xobjs.pagelist[0];
6431 if (curpage == NULL) return TCL_ERROR;
6432 }
6433 else
6434 curpage = xobjs.pagelist[areawin->page];
6435 break;
6436 }
6437
6438 /* Check number of arguments wholesale (to be done) */
6439
6440 switch(idx) {
6441 case SuspendIdx:
6442 if (objc == 2) {
6443 switch (xobjs.suspend) {
6444 case -1:
6445 Tcl_SetResult(interp, "normal drawing", NULL);
6446 break;
6447 case 0:
6448 Tcl_SetResult(interp, "drawing suspended", NULL);
6449 break;
6450 case 1:
6451 Tcl_SetResult(interp, "refresh pending", NULL);
6452 break;
6453 case 2:
6454 Tcl_SetResult(interp, "drawing locked", NULL);
6455 break;
6456 }
6457 }
6458 else {
6459 result = Tcl_GetBooleanFromObj(interp, objv[2], &tmpint);
6460 if (result != TCL_OK) return result;
6461 if (tmpint == 0) {
6462
6463 /* Pending drawing */
6464
6465 if (xobjs.suspend == 1) {
6466 xobjs.suspend = -1;
6467 refresh(NULL, NULL, NULL);
6468 }
6469 else
6470 xobjs.suspend = -1;
6471 }
6472 else {
6473 /* Calling "config suspend true" twice effectively */
6474 /* locks the graphics in a state that can only be */
6475 /* removed by a call to "config suspend false". */
6476 if (xobjs.suspend >= 0)
6477 xobjs.suspend = 2;
6478 else
6479 xobjs.suspend = 0;
6480 }
6481 }
6482 break;
6483
6484 case DatabaseIdx:
6485 /* Regenerate the database of colors, fonts, etc. from Tk options */
6486 if (objc == 3) {
6487 Tk_Window tkwind, tktop;
6488
6489 tktop = Tk_MainWindow(interp);
6490 tkwind = Tk_NameToWindow(interp, Tcl_GetString(objv[2]), tktop);
6491 build_app_database(tkwind);
6492 setcolorscheme(!areawin->invert);
6493 }
6494 break;
6495
6496 case FontNamesIdx:
6497 /* To do: Return a list of known font names. The Tk wrapper uses */
6498 /* this list to regenerate the font menu for each new window. */
6499 break;
6500
6501 case WindowNamesIdx:
6502 /* Generate and return a list of existing window names */
6503
6504 if (objc == 2) {
6505 XCWindowData *winptr;
6506 for (winptr = xobjs.windowlist; winptr != NULL; winptr = winptr->next)
6507 Tcl_AppendElement(interp, Tk_PathName(winptr->area));
6508 }
6509 break;
6510
6511 case DeleteIdx:
6512 if (objc == 3) {
6513 XCWindowData *winptr;
6514 Tk_Window tkwind, tktop;
6515
6516 tktop = Tk_MainWindow(interp);
6517 tkwind = Tk_NameToWindow(interp, Tcl_GetString(objv[2]), tktop);
6518 for (winptr = xobjs.windowlist; winptr != NULL; winptr = winptr->next) {
6519 if (winptr->area == tkwind) {
6520 delete_window(winptr);
6521 break;
6522 }
6523 }
6524 if (winptr == NULL) {
6525 Tcl_SetResult(interp, "No such window\n", NULL);
6526 return TCL_ERROR;
6527 }
6528 }
6529 break;
6530
6531 case DebugIdx:
6532 #ifdef ASG
6533 if (objc == 3) {
6534 result = Tcl_GetIntFromObj(interp, objv[2], &tmpint);
6535 if (result != TCL_OK) return result;
6536 SetDebugLevel(&tmpint);
6537 }
6538 else {
6539 Tcl_SetObjResult(interp, Tcl_NewIntObj(SetDebugLevel(NULL)));
6540 }
6541 #endif
6542 break;
6543
6544
6545 case InitIdx:
6546 /* Create a data structure for a new drawing window. */
6547 /* Give it the same page number and view as the current window */
6548
6549 if (objc == 3) {
6550 XCWindowData *newwin, *savewin;
6551 savewin = areawin; // In case focus callback overwrites areawin.
6552 newwin = GUI_init(objc - 2, objv + 2);
6553 if (newwin != NULL) {
6554 newwin->page = savewin->page;
6555 newwin->vscale = savewin->vscale;
6556 newwin->pcorner = savewin->pcorner;
6557 newwin->topinstance = savewin->topinstance;
6558 }
6559 else {
6560 Tcl_SetResult(interp, "Unable to create new window structure\n", NULL);
6561 return TCL_ERROR;
6562 }
6563 }
6564 break;
6565
6566 case FocusIdx:
6567 if (objc == 2) {
6568 Tcl_SetResult(interp, Tk_PathName(areawin->area), NULL);
6569 }
6570 else if (objc == 3) {
6571 Tk_Window tkwind, tktop;
6572 XCWindowData *winptr;
6573 XPoint locsave;
6574
6575 tktop = Tk_MainWindow(interp);
6576 tkwind = Tk_NameToWindow(interp, Tcl_GetString(objv[2]), tktop);
6577 /* (Diagnostic) */
6578 /* printf("Focusing: %s\n", Tcl_GetString(objv[2])); */
6579 for (winptr = xobjs.windowlist; winptr != NULL; winptr = winptr->next) {
6580 if (winptr->area == tkwind) {
6581 int savemode;
6582 objectptr savestack;
6583
6584 if (areawin == winptr) break;
6585 else if (areawin == NULL) {
6586 areawin = winptr;
6587 break;
6588 }
6589 if ((eventmode == MOVE_MODE || eventmode == COPY_MODE) &&
6590 winptr->editstack->parts == 0) {
6591 locsave = areawin->save;
6592 delete_for_xfer(NORMAL, areawin->selectlist, areawin->selects);
6593 /* Swap editstacks */
6594 savestack = winptr->editstack;
6595 winptr->editstack = areawin->editstack;
6596 areawin->editstack = savestack;
6597 savemode = eventmode;
6598 eventmode = NORMAL_MODE;
6599
6600 /* Change event handlers */
6601 xcRemoveEventHandler(areawin->area, PointerMotionMask, False,
6602 (xcEventHandler)xctk_drag, NULL);
6603 drawarea(areawin->area, NULL, NULL);
6604 Tk_CreateEventHandler(winptr->area, PointerMotionMask,
6605 (Tk_EventProc *)xctk_drag, NULL);
6606
6607 /* Set new window */
6608 areawin = winptr;
6609 eventmode = savemode;
6610 areawin->save = locsave;
6611 transferselects();
6612 drawarea(areawin->area, NULL, NULL);
6613 }
6614 else
6615 areawin = winptr;
6616 break;
6617 }
6618 }
6619 if (winptr == NULL) {
6620 Tcl_SetResult(interp, "No such xcircuit drawing window\n", NULL);
6621 return TCL_ERROR;
6622 }
6623 }
6624 else {
6625 Tcl_WrongNumArgs(interp, 2, objv, "[window]");
6626 return TCL_ERROR;
6627 }
6628 break;
6629
6630 case AxisIdx: case AxesIdx:
6631 if (objc == 2) {
6632 Tcl_SetResult(interp, (areawin->axeson) ? "true" : "false", NULL);
6633 break;
6634 }
6635 else {
6636 result = Tcl_GetBooleanFromObj(interp, objv[2], &tmpint);
6637 if (result != TCL_OK) return result;
6638 areawin->axeson = (Boolean) tmpint;
6639 }
6640 break;
6641
6642 case GridIdx:
6643 if (objc == 2) {
6644 Tcl_SetResult(interp, (areawin->gridon) ? "true" : "false", NULL);
6645 break;
6646 }
6647 else {
6648 if (!strncmp("spac", Tcl_GetString(objv[2]), 4)) {
6649 if (objc == 3) {
6650 measurestr((float)curpage->gridspace, buffer);
6651 Tcl_SetObjResult(interp, Tcl_NewStringObj(buffer, strlen(buffer)));
6652 break;
6653 }
6654 else {
6655 strcpy(_STR2, Tcl_GetString(objv[3]));
6656 setgrid(NULL, &(curpage->gridspace));
6657 }
6658 }
6659 else {
6660 result = Tcl_GetBooleanFromObj(interp, objv[2], &tmpint);
6661 if (result != TCL_OK) return result;
6662 areawin->gridon = (Boolean) tmpint;
6663 }
6664 }
6665 break;
6666
6667 case SnapIdx:
6668 if (objc == 2) {
6669 Tcl_SetResult(interp, (areawin->snapto) ? "true" : "false", NULL);
6670 }
6671 else {
6672 if (!strncmp("spac", Tcl_GetString(objv[2]), 4)) {
6673 if (objc == 3) {
6674 measurestr((float)curpage->snapspace, buffer);
6675 Tcl_SetObjResult(interp, Tcl_NewStringObj(buffer, strlen(buffer)));
6676 break;
6677 }
6678 else {
6679 strcpy(_STR2, Tcl_GetString(objv[3]));
6680 setgrid(NULL, &(curpage->snapspace));
6681 }
6682 }
6683 else {
6684 result = Tcl_GetBooleanFromObj(interp, objv[2], &tmpint);
6685 if (result != TCL_OK) return result;
6686 areawin->snapto = (Boolean) tmpint;
6687 }
6688 }
6689 break;
6690
6691 case BoxEditIdx:
6692 if (objc == 2) {
6693 switch (areawin->boxedit) {
6694 case MANHATTAN: idx = 0; break;
6695 case RHOMBOIDX: idx = 1; break;
6696 case RHOMBOIDY: idx = 2; break;
6697 case RHOMBOIDA: idx = 3; break;
6698 case NORMAL: idx = 4; break;
6699 }
6700 Tcl_SetObjResult(interp, Tcl_NewStringObj(boxsubCmds[idx],
6701 strlen(boxsubCmds[idx])));
6702 }
6703 else if (objc != 3) {
6704 Tcl_WrongNumArgs(interp, 2, objv, "boxedit ?arg ...?");
6705 return TCL_ERROR;
6706 }
6707 else {
6708 if (Tcl_GetIndexFromObj(interp, objv[2],
6709 (CONST84 char **)boxsubCmds,
6710 "option", 0, &idx) != TCL_OK) {
6711 return TCL_ERROR;
6712 }
6713 switch (idx) {
6714 case 0: tmpint = MANHATTAN; break;
6715 case 1: tmpint = RHOMBOIDX; break;
6716 case 2: tmpint = RHOMBOIDY; break;
6717 case 3: tmpint = RHOMBOIDA; break;
6718 case 4: tmpint = NORMAL; break;
6719 }
6720 areawin->boxedit = tmpint;
6721 }
6722 break;
6723
6724 case PathEditIdx:
6725 if (objc == 2) {
6726 switch (areawin->pathedit) {
6727 case TANGENTS: idx = 0; break;
6728 case NORMAL: idx = 1; break;
6729 }
6730 Tcl_SetObjResult(interp, Tcl_NewStringObj(pathsubCmds[idx],
6731 strlen(pathsubCmds[idx])));
6732 }
6733 else if (objc != 3) {
6734 Tcl_WrongNumArgs(interp, 2, objv, "pathedit ?arg ...?");
6735 return TCL_ERROR;
6736 }
6737 else {
6738 if (Tcl_GetIndexFromObj(interp, objv[2],
6739 (CONST84 char **)pathsubCmds,
6740 "option", 0, &idx) != TCL_OK) {
6741 return TCL_ERROR;
6742 }
6743 switch (idx) {
6744 case 0: tmpint = TANGENTS; break;
6745 case 1: tmpint = NORMAL; break;
6746 }
6747 areawin->pathedit = tmpint;
6748 }
6749 break;
6750
6751 case LineWidthIdx:
6752 if (objc == 2) {
6753 Tcl_SetObjResult(interp,
6754 Tcl_NewDoubleObj((double)curpage->wirewidth / 2.0));
6755 }
6756 else if (objc != 3) {
6757 Tcl_WrongNumArgs(interp, 3, objv, "linewidth");
6758 return TCL_ERROR;
6759 }
6760 else {
6761 strcpy(_STR2, Tcl_GetString(objv[2]));
6762 setwidth(NULL, &(curpage->wirewidth));
6763 }
6764 break;
6765
6766 case BBoxIdx:
6767 if (objc == 2) {
6768 Tcl_SetResult(interp, (areawin->bboxon) ? "visible" : "invisible", NULL);
6769 }
6770 else {
6771 tmpstr = Tcl_GetString(objv[2]);
6772 if (strstr(tmpstr, "visible"))
6773 tmpint = (tmpstr[0] == 'i') ? False : True;
6774 else {
6775 result = Tcl_GetBooleanFromObj(interp, objv[2], &tmpint);
6776 if (result != TCL_OK) return result;
6777 }
6778 areawin->bboxon = (Boolean) tmpint;
6779 }
6780 break;
6781
6782 case HoldIdx:
6783 if (objc == 2) {
6784 Tcl_SetResult(interp, (xobjs.hold) ? "true" : "false", NULL);
6785 }
6786 else {
6787 result = Tcl_GetBooleanFromObj(interp, objv[2], &tmpint);
6788 if (result != TCL_OK) return result;
6789 xobjs.hold = (Boolean) tmpint;
6790 }
6791 break;
6792
6793 case EditInPlaceIdx:
6794 if (objc == 2) {
6795 Tcl_SetResult(interp, (areawin->editinplace) ? "true" : "false", NULL);
6796 }
6797 else {
6798 result = Tcl_GetBooleanFromObj(interp, objv[2], &tmpint);
6799 if (result != TCL_OK) return result;
6800 areawin->editinplace = (Boolean) tmpint;
6801 }
6802 break;
6803
6804 case ShowClipIdx:
6805 if (objc == 2) {
6806 Tcl_SetResult(interp, (areawin->showclipmasks) ? "show" : "hide", NULL);
6807 }
6808 else {
6809 tmpstr = Tcl_GetString(objv[2]);
6810 if (!strcmp(tmpstr, "show"))
6811 tmpint = True;
6812 else if (!strcmp(tmpstr, "hide"))
6813 tmpint = False;
6814 else {
6815 result = Tcl_GetBooleanFromObj(interp, objv[2], &tmpint);
6816 if (result != TCL_OK) return result;
6817 }
6818 areawin->showclipmasks = (Boolean) tmpint;
6819 }
6820 break;
6821
6822 case PinPosIdx:
6823 if (objc == 2) {
6824 Tcl_SetResult(interp, (areawin->pinpointon) ? "visible" : "invisible", NULL);
6825 }
6826 else {
6827 tmpstr = Tcl_GetString(objv[2]);
6828 if (strstr(tmpstr, "visible"))
6829 tmpint = (tmpstr[0] == 'i') ? False : True;
6830 else {
6831 result = Tcl_GetBooleanFromObj(interp, objv[2], &tmpint);
6832 if (result != TCL_OK) return result;
6833 }
6834 areawin->pinpointon = (Boolean) tmpint;
6835 }
6836 break;
6837
6838 case PinAttachIdx:
6839 if (objc == 2) {
6840 Tcl_SetResult(interp, (areawin->pinattach) ? "true" : "false", NULL);
6841 }
6842 else {
6843 result = Tcl_GetBooleanFromObj(interp, objv[2], &tmpint);
6844 if (result != TCL_OK) return result;
6845 areawin->pinattach = (Boolean) tmpint;
6846 }
6847 break;
6848
6849 case ColorSchemeIdx:
6850 if (objc == 2) {
6851 Tcl_SetResult(interp, (areawin->invert) ? "inverse" : "normal", NULL);
6852 }
6853 else {
6854 tmpstr = Tcl_GetString(objv[2]);
6855 if (!strcmp(tmpstr, "normal") || !strcmp(tmpstr, "standard"))
6856 tmpint = False;
6857 else if (!strcmp(tmpstr, "inverse") || !strcmp(tmpstr, "alternate"))
6858 tmpint = True;
6859 else {
6860 result = Tcl_GetBooleanFromObj(interp, objv[2], &tmpint);
6861 if (result != TCL_OK) return result;
6862 }
6863 areawin->invert = (Boolean) tmpint;
6864 setcolorscheme(!areawin->invert);
6865 }
6866 break;
6867
6868 case CoordStyleIdx:
6869 if (objc == 2) {
6870 switch (curpage->coordstyle) {
6871 case DEC_INCH: idx = 0; break;
6872 case FRAC_INCH: idx = 1; break;
6873 case CM: idx = 2; break;
6874 case INTERNAL: idx = 3; break;
6875 }
6876 Tcl_SetObjResult(interp, Tcl_NewStringObj(coordsubCmds[idx],
6877 strlen(coordsubCmds[idx])));
6878 }
6879 else if (objc != 3) {
6880 Tcl_WrongNumArgs(interp, 2, objv, "coordstyle ?arg ...?");
6881 return TCL_ERROR;
6882 }
6883 else {
6884 if (Tcl_GetIndexFromObj(interp, objv[2],
6885 (CONST84 char **)coordsubCmds,
6886 "option", 0, &idx) != TCL_OK) {
6887 return TCL_ERROR;
6888 }
6889 switch (idx) {
6890 case 0: tmpint = DEC_INCH; break;
6891 case 1: tmpint = FRAC_INCH; break;
6892 case 2: tmpint = CM; break;
6893 case 3: tmpint = INTERNAL; break;
6894 }
6895 getgridtype(NULL, tmpint, NULL);
6896 }
6897 break;
6898
6899 case ScaleIdx:
6900 if (objc == 2) {
6901 Tcl_Obj *objPtr = Tcl_NewListObj(0, NULL);
6902 Tcl_ListObjAppendElement(interp, objPtr,
6903 Tcl_NewIntObj((int)curpage->drawingscale.x));
6904 Tcl_ListObjAppendElement(interp, objPtr,
6905 Tcl_NewStringObj(":", 1));
6906 Tcl_ListObjAppendElement(interp, objPtr,
6907 Tcl_NewIntObj((int)curpage->drawingscale.y));
6908 Tcl_SetObjResult(interp, objPtr);
6909 }
6910 else if (objc == 3) {
6911 strcpy(_STR2, Tcl_GetString(objv[2]));
6912 setdscale(NULL, &(curpage->drawingscale));
6913 }
6914 else {
6915 Tcl_WrongNumArgs(interp, 2, objv, "drawingscale ?arg ...?");
6916 return TCL_ERROR;
6917 }
6918 break;
6919
6920 case TechnologysIdx:
6921 if (objc == 2) {
6922 Tcl_SetResult(interp, (xobjs.showtech) ? "true" : "false", NULL);
6923 }
6924 else {
6925 short libnum;
6926
6927 result = Tcl_GetBooleanFromObj(interp, objv[2], &tmpint);
6928 if (result != TCL_OK) return result;
6929 if (xobjs.showtech != (Boolean) tmpint) {
6930 xobjs.showtech = (Boolean) tmpint;
6931
6932 /* When namespaces are included, the length of the printed */
6933 /* name may cause names to overlap, so recompose each */
6934 /* library when the showtech flag is changed. */
6935 for (libnum = 0; libnum < xobjs.numlibs; libnum++)
6936 composelib(LIBRARY + libnum);
6937
6938 if (eventmode == CATALOG_MODE) refresh(NULL, NULL, NULL);
6939 }
6940 }
6941 break;
6942
6943 case ManhattanIdx:
6944 if (objc == 2) {
6945 Tcl_SetResult(interp, (areawin->manhatn) ? "true" : "false", NULL);
6946 }
6947 else {
6948 result = Tcl_GetBooleanFromObj(interp, objv[2], &tmpint);
6949 if (result != TCL_OK) return result;
6950 areawin->manhatn = (Boolean) tmpint;
6951 }
6952 break;
6953
6954 case CenteringIdx:
6955 if (objc == 2) {
6956 Tcl_SetResult(interp, (areawin->center) ? "true" : "false", NULL);
6957 }
6958 else {
6959 result = Tcl_GetBooleanFromObj(interp, objv[2], &tmpint);
6960 if (result != TCL_OK) return result;
6961 areawin->center = (Boolean) tmpint;
6962 }
6963 break;
6964
6965 case FilterIdx:
6966 if (objc == 2) {
6967 for (i = 0; i < 6; i++) {
6968 tmpint = 1 << i;
6969 if (areawin->filter & tmpint) {
6970 Tcl_AppendElement(interp, filterTypes[i]);
6971 }
6972 }
6973 }
6974 else if (objc >= 3) {
6975 if (Tcl_GetIndexFromObj(interp, objv[2],
6976 (CONST84 char **)filterTypes,
6977 "filter_type", 0, &tmpint) != TCL_OK) {
6978 return TCL_ERROR;
6979 }
6980 if (objc == 3) {
6981 if (areawin->filter & (1 << tmpint))
6982 Tcl_SetResult(interp, "true", NULL);
6983 else
6984 Tcl_SetResult(interp, "false", NULL);
6985 }
6986 else {
6987 int ftype = 1 << tmpint;
6988 if (!strcmp(Tcl_GetString(objv[3]), "true"))
6989 areawin->filter |= ftype;
6990 else
6991 areawin->filter &= (~ftype);
6992 }
6993 }
6994 break;
6995
6996 case BusCharIdx:
6997 if (objc == 2) {
6998 buffer[0] = '\\';
6999 buffer[1] = areawin->buschar;
7000 buffer[2] = '\0';
7001 Tcl_SetResult(interp, buffer, TCL_VOLATILE);
7002 }
7003 else if (objc == 3) {
7004 tmpstr = Tcl_GetString(objv[2]);
7005 areawin->buschar = (tmpstr[0] == '\\') ? tmpstr[1] : tmpstr[0];
7006 }
7007 break;
7008
7009 case BackupIdx:
7010 if (objc == 2) {
7011 Tcl_SetResult(interp, (xobjs.retain_backup) ? "true" : "false", NULL);
7012 }
7013 else {
7014 result = Tcl_GetBooleanFromObj(interp, objv[2], &tmpint);
7015 if (result != TCL_OK) return result;
7016 xobjs.retain_backup = (Boolean) tmpint;
7017 }
7018 break;
7019
7020 case SearchIdx:
7021 if (objc < 3) {
7022 Tcl_WrongNumArgs(interp, 2, objv, "search files|libraries ?arg ...?");
7023 return TCL_ERROR;
7024 }
7025 if (Tcl_GetIndexFromObj(interp, objv[2],
7026 (CONST84 char **)searchOpts, "options", 0, &idx) != TCL_OK) {
7027 return TCL_ERROR;
7028 }
7029 sptr = (idx == 0) ? &xobjs.filesearchpath : &xobjs.libsearchpath;
7030 if (objc == 3) {
7031 if (*sptr != NULL) Tcl_SetResult(interp, *sptr, TCL_VOLATILE);
7032 }
7033 else {
7034 if (*sptr != NULL) free(*sptr);
7035 *sptr = NULL;
7036 tmpstr = Tcl_GetString(objv[3]);
7037 if (strlen(tmpstr) > 0)
7038 *sptr = strdup(Tcl_GetString(objv[3]));
7039 }
7040 break;
7041 }
7042 return XcTagCallback(interp, objc, objv);
7043 }
7044
7045 /*----------------------------------------------------------------------*/
7046
7047 int xctcl_promptsavepage(ClientData clientData, Tcl_Interp *interp,
7048 int objc, Tcl_Obj *CONST objv[])
7049 {
7050 int page = areawin->page;
7051 int result;
7052 Pagedata *curpage;
7053 objectptr pageobj;
7054 struct stat statbuf;
7055
7056 /* save page popup */
7057
7058 if (objc > 2) {
7059 Tcl_WrongNumArgs(interp, 1, objv, "[page_number]");
7060 return TCL_ERROR;
7061 }
7062 else if (objc == 2) {
7063 result = Tcl_GetIntFromObj(interp, objv[1], &page);
7064 if (result != TCL_OK) return result;
7065 }
7066 else page = areawin->page;
7067
7068 curpage = xobjs.pagelist[page];
7069 if (curpage->pageinst == NULL) {
7070 Tcl_SetResult(interp, "Page does not exist. . . cannot save.", NULL);
7071 return TCL_ERROR;
7072 }
7073 pageobj = curpage->pageinst->thisobject;
7074
7075 /* recompute bounding box and auto-scale, if set */
7076
7077 calcbbox(xobjs.pagelist[page]->pageinst);
7078 if (curpage->pmode & 2) autoscale(page);
7079
7080 /* get file information, if filename is set */
7081
7082 if (curpage->filename != NULL) {
7083 if (strstr(curpage->filename, ".") == NULL)
7084 sprintf(_STR2, "%s.ps", curpage->filename);
7085 else sprintf(_STR2, "%s", curpage->filename);
7086 if (stat(_STR2, &statbuf) == 0) {
7087 Wprintf(" Warning: File exists");
7088 }
7089 else {
7090 if (errno == ENOTDIR)
7091 Wprintf("Error: Incorrect pathname");
7092 else if (errno == EACCES)
7093 Wprintf("Error: Path not readable");
7094 else
7095 W3printf(" ");
7096 }
7097 }
7098 Tcl_SetObjResult(interp, Tcl_NewIntObj((int)page));
7099
7100 return XcTagCallback(interp, objc, objv);
7101 }
7102
7103 /*----------------------------------------------------------------------*/
7104
7105 int xctcl_quit(ClientData clientData, Tcl_Interp *interp,
7106 int objc, Tcl_Obj *CONST objv[])
7107 {
7108 Boolean is_intr = False;
7109
7110 /* quit, without checks */
7111 if (objc != 1) {
7112 if (strncasecmp(Tcl_GetString(objv[0]), "intr", 4))
7113 is_intr = True;
7114 else {
7115 Tcl_WrongNumArgs(interp, 1, objv, "(no arguments)");
7116 return TCL_ERROR;
7117 }
7118 }
7119 quit(areawin->area, NULL);
7120
7121 if (consoleinterp == interp)
7122 Tcl_Exit(XcTagCallback(interp, objc, objv));
7123 else {
7124 /* Ham-fisted, but prevents hanging on Ctrl-C kill */
7125 if (is_intr) exit(1);
7126 Tcl_Eval(interp, "catch {tkcon eval exit}\n");
7127 }
7128
7129 return TCL_OK; /* Not reached */
7130 }
7131
7132 /*----------------------------------------------------------------------*/
7133
7134 int xctcl_promptquit(ClientData clientData, Tcl_Interp *interp,
7135 int objc, Tcl_Obj *CONST objv[])
7136 {
7137 int result;
7138
7139 /* quit, with checks */
7140 if (objc != 1) {
7141 Tcl_WrongNumArgs(interp, 1, objv, "(no arguments)");
7142 return TCL_ERROR;
7143 }
7144 if (areawin != NULL) {
7145 result = quitcheck(areawin->area, NULL, NULL);
7146 if (result == 1) {
7147 /* Immediate exit */
7148 if (consoleinterp == interp)
7149 Tcl_Exit(XcTagCallback(interp, objc, objv));
7150 else
7151 Tcl_Eval(interp, "catch {tkcon eval exit}\n");
7152 }
7153 }
7154 return XcTagCallback(interp, objc, objv);
7155 }
7156
7157 /*----------------------------------------------------------------------*/
7158
7159 int xctcl_refresh(ClientData clientData, Tcl_Interp *interp,
7160 int objc, Tcl_Obj *CONST objv[])
7161 {
7162 /* refresh */
7163 if (objc != 1) {
7164 Tcl_WrongNumArgs(interp, 1, objv, "(no arguments)");
7165 return TCL_ERROR;
7166 }
7167 areawin->redraw_needed = True;
7168 drawarea(areawin->area, (caddr_t)clientData, (caddr_t)NULL);
7169 if (areawin->scrollbarh)
7170 drawhbar(areawin->scrollbarh, NULL, NULL);
7171 if (areawin->scrollbarv)
7172 drawvbar(areawin->scrollbarv, NULL, NULL);
7173 printname(topobject);
7174 return XcTagCallback(interp, objc, objv);
7175 }
7176
7177 /*----------------------------------------------------------------------*/
7178 /* Load a schematic that belongs to a symbol referenced by the current */
7179 /* schematic by loading the file pointed to by the "link" parameter */
7180 /* in the symbol. */
7181 /* */
7182 /* Return 1 on success, 0 if the link has already been loaded, and -1 */
7183 /* on failure to find, open, or read the link's schematic. */
7184 /*----------------------------------------------------------------------*/
7185
7186 int loadlinkfile(objinstptr tinst, char *filename, int target, Boolean do_load)
7187 {
7188 int j, savepage;
7189 FILE *ps;
7190 char file_return[150];
7191 int result;
7192 Boolean fgood;
7193
7194 /* Shorthand: "%n" can be used to indicate that the link filename is */
7195 /* the same as the name of the object, minus technology prefix. */
7196 /* While unlikely to be used, "%N" includes the technology prefix. */
7197
7198 if (!strcmp(filename, "%n")) {
7199 char *suffix = strstr(tinst->thisobject->name, "::");
7200 if (suffix == NULL)
7201 suffix = tinst->thisobject->name;
7202 else
7203 suffix += 2;
7204 strcpy(_STR, suffix);
7205 }
7206 else if (!strcmp(filename, "%N"))
7207 strcpy(_STR, tinst->thisobject->name);
7208 else
7209 strcpy(_STR, filename);
7210
7211 /* When loading links, we want to avoid */
7212 /* loading the same file more than once, so */
7213 /* compare filename against all existing */
7214 /* page filenames. Also compare links; any */
7215 /* page with a link to the same object is a */
7216 /* duplicate. */
7217
7218 ps = fileopen(_STR, ".ps", file_return, 149);
7219 if (ps != NULL) {
7220 fgood = TRUE;
7221 fclose(ps);
7222 }
7223 else
7224 fgood = FALSE;
7225
7226 for (j = 0; j < xobjs.pages; j++) {
7227 if (xobjs.pagelist[j]->filename == NULL)
7228 continue;
7229 else if (!strcmp(file_return, xobjs.pagelist[j]->filename))
7230 break;
7231 else if ((strlen(xobjs.pagelist[j]->filename) > 0) &&
7232 !strcmp(file_return + strlen(file_return) - 3, ".ps")
7233 && !strncmp(xobjs.pagelist[j]->filename, file_return,
7234 strlen(file_return) - 3))
7235 break;
7236 else if ((xobjs.pagelist[j]->pageinst != NULL) && (tinst->thisobject ==
7237 xobjs.pagelist[j]->pageinst->thisobject->symschem))
7238 break;
7239 }
7240 if (j < xobjs.pages) {
7241
7242 /* Duplicate page. Don't load it, but make sure that an association */
7243 /* exists between the symbol and schematic. */
7244
7245 if (tinst->thisobject->symschem == NULL) {
7246 tinst->thisobject->symschem =
7247 xobjs.pagelist[j]->pageinst->thisobject;
7248 if (xobjs.pagelist[j]->pageinst->thisobject->symschem == NULL)
7249 xobjs.pagelist[j]->pageinst->thisobject->symschem = tinst->thisobject;
7250 }
7251 return 0;
7252 }
7253
7254 if (fgood == FALSE) {
7255 Fprintf(stderr, "Failed to open dependency \"%s\"\n", _STR);
7256 return -1;
7257 }
7258
7259 /* Report that a pending link exists, but do not load it. */
7260 if (!do_load) return 1;
7261
7262 savepage = areawin->page;
7263 while (areawin->page < xobjs.pages &&
7264 xobjs.pagelist[areawin->page]->pageinst != NULL &&
7265 xobjs.pagelist[areawin->page]->pageinst->thisobject->parts > 0)
7266 areawin->page++;
7267
7268 changepage(areawin->page);
7269 result = (loadfile(0, (target >= 0) ? target + LIBRARY : -1) == TRUE) ? 1 : -1;
7270
7271 /* Make symschem link if not done by loadfile() */
7272
7273 if (tinst->thisobject->symschem == NULL) {
7274 tinst->thisobject->symschem =
7275 xobjs.pagelist[areawin->page]->pageinst->thisobject;
7276
7277 /* Many symbols may link to one schematic, but a schematic can */
7278 /* only link to one symbol (the first one associated). */
7279
7280 if (xobjs.pagelist[areawin->page]->pageinst->thisobject->symschem == NULL)
7281 xobjs.pagelist[areawin->page]->pageinst->thisobject->symschem
7282 = tinst->thisobject;
7283 }
7284 changepage(savepage);
7285 return result;
7286 }
7287
7288 /*----------------------------------------------------------------------*/
7289
7290 int xctcl_page(ClientData clientData, Tcl_Interp *interp,
7291 int objc, Tcl_Obj *CONST objv[])
7292 {
7293 int result, idx, nidx, aval, i, locidx;
7294 int cpage, multi, savepage, pageno = -1, linktype, importtype;
7295 char *filename, *froot, *astr;
7296 Tcl_Obj *objPtr;
7297 double newheight, newwidth, newscale;
7298 float oldscale;
7299 int newrot, newmode;
7300 objectptr pageobj;
7301 oparamptr ops;
7302 char *oldstr, *newstr, *key, *argv;
7303 Pagedata *curpage, *lpage;
7304 short *pagelist;
7305 u_short changes;
7306 int target = -1;
7307 Boolean forcepage = FALSE;
7308
7309 char *subCmds[] = {
7310 "load", "list", "import", "save", "saveonly", "make", "directory",
7311 "reset", "links", "fit", "filename", "label", "scale", "width",
7312 "height", "size", "margins", "bbox", "goto", "orientation",
7313 "encapsulation", "handle", "update", "changes", NULL
7314 };
7315 enum SubIdx {
7316 LoadIdx, ListIdx, ImportIdx, SaveIdx, SaveOnlyIdx, MakeIdx, DirIdx,
7317 ResetIdx, LinksIdx, FitIdx, FileIdx, LabelIdx, ScaleIdx,
7318 WidthIdx, HeightIdx, SizeIdx, MarginsIdx, BBoxIdx, GoToIdx,
7319 OrientIdx, EPSIdx, HandleIdx, UpdateIdx, ChangesIdx
7320 };
7321
7322 char *importTypes[] = {"xcircuit", "postscript", "background", "spice", NULL};
7323 enum ImportTypes {
7324 XCircuitIdx, PostScriptIdx, BackGroundIdx, SPICEIdx
7325 };
7326
7327 char *linkTypes[] = {"independent", "dependent", "total", "linked",
7328 "pagedependent", "all", "pending", "sheet", "load", NULL};
7329 enum LinkTypes {
7330 IndepIdx, DepIdx, TotalIdx, LinkedIdx, PageDepIdx, AllIdx, PendingIdx,
7331 SheetIdx, LinkLoadIdx
7332 };
7333 char *psTypes[] = {"eps", "full", NULL};
7334
7335 if (areawin == NULL) {
7336 Tcl_SetResult(interp, "No database!", NULL);
7337 return TCL_ERROR;
7338 }
7339 savepage = areawin->page;
7340
7341 /* Check for option "-force" (create page if it doesn't exist) */
7342 if (!strncmp(Tcl_GetString(objv[objc - 1]), "-forc", 5)) {
7343 forcepage = TRUE;
7344 objc--;
7345 }
7346
7347 result = ParsePageArguments(interp, objc, objv, &nidx, &pageno);
7348 if ((result != TCL_OK) || (nidx < 0)) {
7349 if (forcepage && (pageno == xobjs.pages)) {
7350 /* For now, allow a page to be created only if the page number */
7351 /* is one higher than the current last page. */
7352 Tcl_ResetResult(interp);
7353 idx = MakeIdx;
7354 nidx = 0;
7355 pageno = areawin->page; /* so we don't get a segfault */
7356 }
7357 else
7358 return result;
7359 }
7360 else if (nidx == 1 && objc == 2) {
7361 idx = GoToIdx;
7362 }
7363 else if (Tcl_GetIndexFromObj(interp, objv[1 + nidx],
7364 (CONST84 char **)subCmds, "option", 0, &idx) != TCL_OK) {
7365 return result;
7366 }
7367
7368 result = TCL_OK;
7369
7370 curpage = xobjs.pagelist[pageno];
7371
7372 if (curpage->pageinst != NULL)
7373 pageobj = curpage->pageinst->thisobject;
7374 else {
7375 if (idx != LoadIdx && idx != MakeIdx && idx != DirIdx && idx != GoToIdx) {
7376 Tcl_SetResult(interp, "Cannot do function on non-initialized page.", NULL);
7377 return TCL_ERROR;
7378 }
7379 }
7380
7381 switch (idx) {
7382 case HandleIdx:
7383 /* return handle of page instance */
7384 objPtr = Tcl_NewHandleObj(curpage->pageinst);
7385 Tcl_SetObjResult(interp, objPtr);
7386 break;
7387
7388 case ResetIdx:
7389 /* clear page */
7390 resetbutton(NULL, (pointertype)(pageno + 1), NULL);
7391 break;
7392
7393 case ListIdx:
7394 /* return a list of all non-empty pages */
7395 objPtr = Tcl_NewListObj(0, NULL);
7396 for (i = 0; i < xobjs.pages; i++) {
7397 lpage = xobjs.pagelist[i];
7398 if ((lpage != NULL) && (lpage->pageinst != NULL)) {
7399 Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewIntObj(i + 1));
7400 }
7401 }
7402 Tcl_SetObjResult(interp, objPtr);
7403 break;
7404
7405 case LoadIdx:
7406 TechReplaceSave();
7407 sprintf(_STR2, Tcl_GetString(objv[2 + nidx]));
7408 for (i = 3 + nidx; i < objc; i++) {
7409 argv = Tcl_GetString(objv[i]);
7410 if ((*argv == '-') && !strncmp(argv, "-repl", 5)) {
7411 if (i < objc - 1) {
7412 char *techstr = Tcl_GetString(objv[i + 1]);
7413 if (!strcmp(techstr, "all") || !strcmp(techstr, "any"))
7414 TechReplaceAll();
7415 else if (!strcmp(techstr, "none")) TechReplaceNone();
7416 else {
7417 TechPtr nsptr = LookupTechnology(techstr);
7418 if (nsptr != NULL) nsptr->flags |= TECH_REPLACE;
7419 }
7420 i++;
7421 }
7422 else
7423 TechReplaceAll(); /* replace ALL */
7424 }
7425 else if ((*argv == '-') && !strncmp(argv, "-targ", 5)) {
7426 if (i < objc - 1) {
7427 ParseLibArguments(interp, 2, &objv[i], NULL, &target);
7428 i++;
7429 }
7430 }
7431 else {
7432 strcat(_STR2, ",");
7433 strcat(_STR2, argv);
7434 }
7435 }
7436
7437 if (savepage != pageno) newpage(pageno);
7438 startloadfile((target >= 0) ? target + LIBRARY : -1);
7439 if (savepage != pageno) newpage(savepage);
7440 TechReplaceRestore();
7441 break;
7442
7443 case ImportIdx:
7444 if ((objc - nidx) < 3) {
7445 Tcl_WrongNumArgs(interp, 2, objv, "option");
7446 return TCL_ERROR;
7447 }
7448
7449 if (Tcl_GetIndexFromObj(interp, objv[2 + nidx],
7450 (CONST84 char **)importTypes, "file type",
7451 0, &importtype) != TCL_OK)
7452 return TCL_ERROR;
7453
7454 /* First check the number of arguments, which varies by option. */
7455
7456 switch (importtype) {
7457
7458 /* Xcircuit imports may specify any number of files > 1. */
7459
7460 case XCircuitIdx:
7461 if ((objc - nidx) == 3) {
7462 Tcl_SetResult(interp, "Must specify a filename to import!", NULL);
7463 return TCL_ERROR;
7464 }
7465 break;
7466
7467 /* Postscript imports may specify 1 or 0 files. 0 causes */
7468 /* the function to report back what file is the background. */
7469
7470 case PostScriptIdx:
7471 case BackGroundIdx:
7472 if ((objc - nidx) != 3 && (objc - nidx) != 4) {
7473 Tcl_SetResult(interp, "Can only specify one filename "
7474 "for background", NULL);
7475 return TCL_ERROR;
7476 }
7477
7478 /* All other import types must specify exactly one filename. */
7479
7480 default:
7481 if ((objc - nidx) != 4) {
7482 Tcl_SetResult(interp, "Must specify one filename "
7483 "for import", NULL);
7484 return TCL_ERROR;
7485 }
7486 break;
7487 }
7488
7489 /* Now process the option */
7490
7491 switch (importtype) {
7492 case XCircuitIdx:
7493 sprintf(_STR2, Tcl_GetString(objv[3 + nidx]));
7494 for (i = 4; i < objc; i++) {
7495 strcat(_STR2, ",");
7496 strcat(_STR2, Tcl_GetString(objv[i + nidx]));
7497 }
7498 if (savepage != pageno) newpage(pageno);
7499 importfile();
7500 if (savepage != pageno) newpage(savepage);
7501 break;
7502 case PostScriptIdx: /* replaces "background" */
7503 case BackGroundIdx:
7504 if (objc - nidx == 2) {
7505 objPtr = Tcl_NewStringObj(curpage->background.name,
7506 strlen(curpage->background.name));
7507 Tcl_SetObjResult(interp, objPtr);
7508 return XcTagCallback(interp, objc, objv);
7509 }
7510 sprintf(_STR2, Tcl_GetString(objv[3 + nidx]));
7511 if (savepage != pageno) newpage(pageno);
7512 loadbackground();
7513 if (savepage != pageno) newpage(savepage);
7514 break;
7515
7516 case SPICEIdx:
7517 #ifdef ASG
7518 /* Make sure that the ASG library is present */
7519
7520 if (NameToLibrary(ASG_SPICE_LIB) < 0) {
7521 short ilib;
7522
7523 strcpy(_STR, ASG_SPICE_LIB);
7524 ilib = createlibrary(FALSE);
7525 if (loadlibrary(ilib) == FALSE) {
7526 Tcl_SetResult(interp, "Error loading library.\n", NULL);
7527 return TCL_ERROR;
7528 }
7529
7530 }
7531
7532 sprintf(_STR2, Tcl_GetString(objv[3 + nidx]));
7533 if (savepage != pageno) newpage(pageno);
7534 importspice();
7535 if (savepage != pageno) newpage(savepage);
7536 #else
7537 Tcl_SetResult(interp, "ASG not compiled in; "
7538 "function is unavailable.\n", NULL);
7539 return TCL_ERROR;
7540 #endif
7541 break;
7542 }
7543
7544 /* Redraw */
7545 drawarea(areawin->area, NULL, NULL);
7546 break;
7547
7548 case MakeIdx:
7549 if (nidx == 1) {
7550 Tcl_SetResult(interp, "syntax is: \"page make [<name>]\"", NULL);
7551 return TCL_ERROR;
7552 }
7553 if (objc != 2 && objc != 3) {
7554 Tcl_WrongNumArgs(interp, 2, objv, "make [<name>]");
7555 return TCL_ERROR;
7556 }
7557 newpage((short)255);
7558 if (objc == 3) {
7559 curpage = xobjs.pagelist[areawin->page];
7560 strcpy(curpage->pageinst->thisobject->name,
7561 Tcl_GetString(objv[2]));
7562 }
7563 updatepagelib(PAGELIB, areawin->page);
7564 printname(topobject);
7565 break;
7566 case SaveOnlyIdx:
7567 case SaveIdx:
7568 if (objc - nidx > 3) {
7569 Tcl_WrongNumArgs(interp, 2, objv, "[filename]");
7570 return TCL_ERROR;
7571 }
7572 else if (objc - nidx == 3) {
7573 filename = Tcl_GetString(objv[nidx + 2]);
7574 if (strcmp(filename, curpage->filename)) {
7575 Wprintf("Warning: Filename is \"%s\" but will be "
7576 "saved as \"%s\"\n", curpage->filename, filename);
7577 }
7578 }
7579 else if (curpage->filename == NULL) {
7580 Fprintf(stderr, "Warning: Filename created to match object name\n");
7581 filename = curpage->pageinst->thisobject->name;
7582 }
7583 else
7584 filename = curpage->filename;
7585
7586 if (savepage != pageno) newpage(pageno);
7587 if (!strncmp(Tcl_GetString(objv[nidx + 1]), "saveo", 5))
7588 setfile(filename, NO_SUBCIRCUITS);
7589 else
7590 setfile(filename, CURRENT_PAGE);
7591 if (savepage != pageno) newpage(savepage);
7592 break;
7593
7594 case LinksIdx:
7595 if ((objc - nidx) < 2 && (objc - nidx) > 6) {
7596 Tcl_WrongNumArgs(interp, 1, objv, "links");
7597 return TCL_ERROR;
7598 }
7599 if ((objc - nidx) == 2)
7600 linktype = TOTAL_PAGES;
7601 else {
7602 if (Tcl_GetIndexFromObj(interp, objv[2 + nidx],
7603 (CONST84 char **)linkTypes,
7604 "link type", 0, &linktype) != TCL_OK)
7605 return TCL_ERROR;
7606 }
7607 multi = 0;
7608 pagelist = pagetotals(pageno, (linktype >= PendingIdx) ?
7609 LINKED_PAGES : linktype);
7610 TechReplaceSave();
7611 switch (linktype) {
7612
7613 /* Load any pending links, that is, objects that have a */
7614 /* "link" parameter containing a string indicating a file */
7615 /* defining the schematic for that symbol. Allow the use */
7616 /* of the same "-replace" flag used by "page load". */
7617
7618 case LinkLoadIdx:
7619 locidx = objc - 1;
7620 argv = Tcl_GetString(objv[locidx]);
7621 if (*argv != '-') argv = Tcl_GetString(objv[--locidx]);
7622 if ((*argv == '-') && !strncmp(argv, "-repl", 5)) {
7623 if (locidx < objc - 1) {
7624 char *techstr = Tcl_GetString(objv[locidx + 1]);
7625 if (!strcmp(techstr, "all")) TechReplaceAll();
7626 else if (!strcmp(techstr, "none")) TechReplaceNone();
7627 else {
7628 TechPtr nsptr = LookupTechnology(techstr);
7629 if (nsptr != NULL)
7630 nsptr->flags |= TECH_REPLACE;
7631 }
7632 objc--;
7633 }
7634 else
7635 TechReplaceAll(); /* replace ALL */
7636 objc--;
7637 }
7638 if ((*argv == '-') && !strncmp(argv, "-targ", 5)) {
7639 if (locidx < objc - 1) {
7640 ParseLibArguments(interp, 2, &objv[locidx], NULL, &target);
7641 objc--;
7642 }
7643 objc--;
7644 }
7645 /* drop through */
7646
7647 case PendingIdx:
7648 key = ((objc - nidx) == 4) ? Tcl_GetString(objv[3 + nidx]) : "link";
7649 for (i = 0; i < xobjs.pages; i++) {
7650 if (pagelist[i] > 0) {
7651 objinstptr tinst;
7652 objectptr tpage = xobjs.pagelist[i]->pageinst->thisobject;
7653 genericptr *tgen;
7654
7655 for (tgen = tpage->plist; tgen < tpage->plist
7656 + tpage->parts; tgen++) {
7657 if ((*tgen)->type == OBJINST) {
7658 tinst = TOOBJINST(tgen);
7659 /* Corrected 8/31/07: Instance value of "link" has */
7660 /* priority over any default value in the object! */
7661 ops = find_param(tinst, key);
7662 if ((ops != NULL) && (ops->type == XC_STRING)) {
7663 filename = textprint(ops->parameter.string, tinst);
7664 if (strlen(filename) > 0) {
7665 if ((result = loadlinkfile(tinst, filename, target,
7666 (linktype == LinkLoadIdx))) > 0) {
7667 multi++;
7668 setsymschem(); /* Update GUI */
7669 result = TCL_OK;
7670 }
7671 else if (result < 0) {
7672 Tcl_SetResult(interp, "Cannot load link", NULL);
7673 result = TCL_ERROR;
7674 }
7675 else result = TCL_OK;
7676 }
7677 free(filename);
7678 }
7679 }
7680 }
7681 }
7682 }
7683 break;
7684 default:
7685 for (i = 0; i < xobjs.pages; i++) {
7686 if (pagelist[i] > 0) {
7687 multi++;
7688 if ((linktype == SheetIdx) && (i == pageno) && (pagelist[i] > 0))
7689 break;
7690 }
7691 }
7692 break;
7693 }
7694 TechReplaceRestore();
7695 free((char *)pagelist);
7696 if (result == TCL_ERROR) return result;
7697 Tcl_SetObjResult(interp, Tcl_NewIntObj(multi));
7698 break;
7699
7700 case DirIdx:
7701 startcatalog(NULL, PAGELIB, NULL);
7702 break;
7703
7704 case GoToIdx:
7705 newpage((short)pageno);
7706 break;
7707
7708 case UpdateIdx:
7709 calcbbox(curpage->pageinst);
7710 if (curpage->pmode & 2) autoscale(pageno);
7711 break;
7712
7713 case BBoxIdx:
7714 if (((objc - nidx) == 2) || ((objc - nidx) == 3)) {
7715 Tcl_Obj *tuple;
7716 BBox *bbox, *sbbox;
7717 int value;
7718
7719 bbox = &curpage->pageinst->bbox;
7720 if (bbox == NULL)
7721 bbox = &curpage->pageinst->thisobject->bbox;
7722 sbbox = bbox;
7723
7724 if ((objc - nidx) == 3) {
7725 sbbox = curpage->pageinst->schembbox;
7726 if (sbbox == NULL) sbbox = bbox;
7727 }
7728
7729 objPtr = Tcl_NewListObj(0, NULL);
7730
7731 tuple = Tcl_NewListObj(0, NULL);
7732 value = min(sbbox->lowerleft.x, bbox->lowerleft.x);
7733 Tcl_ListObjAppendElement(interp, tuple, Tcl_NewIntObj(value));
7734 value = min(sbbox->lowerleft.y, bbox->lowerleft.y);
7735 Tcl_ListObjAppendElement(interp, tuple, Tcl_NewIntObj(value));
7736 Tcl_ListObjAppendElement(interp, objPtr, tuple);
7737
7738 tuple = Tcl_NewListObj(0, NULL);
7739 value = max(sbbox->lowerleft.x + sbbox->width,
7740 bbox->lowerleft.x + bbox->width);
7741 Tcl_ListObjAppendElement(interp, tuple, Tcl_NewIntObj(value));
7742 value = max(sbbox->lowerleft.y + sbbox->height,
7743 bbox->lowerleft.y + bbox->height);
7744 Tcl_ListObjAppendElement(interp, tuple, Tcl_NewIntObj(value));
7745 Tcl_ListObjAppendElement(interp, objPtr, tuple);
7746
7747 Tcl_SetObjResult(interp, objPtr);
7748 return XcTagCallback(interp, objc, objv);
7749 }
7750 else {
7751 Tcl_WrongNumArgs(interp, 1, objv, "bbox [all]");
7752 return TCL_ERROR;
7753 }
7754 break;
7755
7756 case SizeIdx:
7757 if ((objc - nidx) != 2 && (objc - nidx) != 3) {
7758 Tcl_WrongNumArgs(interp, 1, objv, "size ?\"width x height\"?");
7759 return TCL_ERROR;
7760 }
7761 if ((objc - nidx) == 2) {
7762 float xsize, ysize, cfact;
7763
7764 objPtr = Tcl_NewListObj(0, NULL);
7765
7766 cfact = (curpage->coordstyle == CM) ? IN_CM_CONVERT
7767 : 72.0;
7768 xsize = (float)curpage->pagesize.x / cfact;
7769 ysize = (float)curpage->pagesize.y / cfact;
7770
7771 Tcl_ListObjAppendElement(interp, objPtr,
7772 Tcl_NewDoubleObj((double)xsize));
7773 Tcl_ListObjAppendElement(interp, objPtr,
7774 Tcl_NewStringObj("x", 1));
7775 Tcl_ListObjAppendElement(interp, objPtr,
7776 Tcl_NewDoubleObj((double)ysize));
7777 Tcl_ListObjAppendElement(interp, objPtr,
7778 Tcl_NewStringObj(((curpage->coordstyle == CM) ?
7779 "cm" : "in"), 2));
7780 Tcl_SetObjResult(interp, objPtr);
7781
7782 return XcTagCallback(interp, objc, objv);
7783 }
7784
7785 strcpy(_STR2, Tcl_GetString(objv[2 + nidx]));
7786 setoutputpagesize(&curpage->pagesize);
7787
7788 /* Only need to recompute values and refresh if autoscaling is enabled */
7789 if (curpage->pmode & 2) autoscale(pageno);
7790 break;
7791
7792 case MarginsIdx:
7793 if ((objc - nidx) < 2 && (objc - nidx) > 4) {
7794 Tcl_WrongNumArgs(interp, 1, objv, "margins ?x y?");
7795 return TCL_ERROR;
7796 }
7797 if ((objc - nidx) == 2) {
7798 newwidth = (double)curpage->margins.x / 72.0;
7799 newheight = (double)curpage->margins.y / 72.0;
7800 objPtr = Tcl_NewListObj(0, NULL);
7801 Tcl_ListObjAppendElement(interp, objPtr,
7802 Tcl_NewDoubleObj(newwidth));
7803 Tcl_ListObjAppendElement(interp, objPtr,
7804 Tcl_NewDoubleObj(newheight));
7805 Tcl_SetObjResult(interp, objPtr);
7806 return XcTagCallback(interp, objc, objv);
7807 }
7808 newwidth = (double)parseunits(Tcl_GetString(objv[2 + nidx]));
7809 if ((objc - nidx) == 4)
7810 newheight = (double)parseunits(Tcl_GetString(objv[3 + nidx]));
7811 else
7812 newheight = newwidth;
7813
7814 newheight *= 72.0;
7815 newwidth *= 72.0;
7816 curpage->margins.x = (int)newwidth;
7817 curpage->margins.y = (int)newheight;
7818 break;
7819
7820 case HeightIdx:
7821 if ((objc - nidx) != 2 && (objc - nidx) != 3) {
7822 Tcl_WrongNumArgs(interp, 1, objv, "height ?output_height?");
7823 return TCL_ERROR;
7824 }
7825 if ((objc - nidx) == 2) {
7826 newheight = toplevelheight(curpage->pageinst, NULL);
7827 newheight *= getpsscale(curpage->outscale, pageno);
7828 newheight /= (curpage->coordstyle == CM) ? IN_CM_CONVERT : 72.0;
7829 objPtr = Tcl_NewDoubleObj((double)newheight);
7830 Tcl_SetObjResult(interp, objPtr);
7831 return XcTagCallback(interp, objc, objv);
7832 }
7833 newheight = (double)parseunits(Tcl_GetString(objv[2 + nidx]));
7834 if (newheight <= 0 || topobject->bbox.height == 0) {
7835 Tcl_SetResult(interp, "Illegal height value", NULL);
7836 return TCL_ERROR;
7837 }
7838 newheight = (newheight * ((curpage->coordstyle == CM) ?
7839 IN_CM_CONVERT : 72.0)) / topobject->bbox.height;
7840 newheight /= getpsscale(1.0, pageno);
7841 curpage->outscale = (float)newheight;
7842
7843 if (curpage->pmode & 2) autoscale(pageno);
7844 break;
7845
7846 case WidthIdx:
7847 if ((objc - nidx) != 2 && (objc - nidx) != 3) {
7848 Tcl_WrongNumArgs(interp, 1, objv, "output_width");
7849 return TCL_ERROR;
7850 }
7851 if ((objc - nidx) == 2) {
7852 newwidth = toplevelwidth(curpage->pageinst, NULL);
7853 newwidth *= getpsscale(curpage->outscale, pageno);
7854 newwidth /= (curpage->coordstyle == CM) ? IN_CM_CONVERT : 72.0;
7855 objPtr = Tcl_NewDoubleObj((double)newwidth);
7856 Tcl_SetObjResult(interp, objPtr);
7857 return XcTagCallback(interp, objc, objv);
7858 }
7859 newwidth = (double)parseunits(Tcl_GetString(objv[2 + nidx]));
7860 if (newwidth <= 0 || topobject->bbox.width == 0) {
7861 Tcl_SetResult(interp, "Illegal width value", NULL);
7862 return TCL_ERROR;
7863 }
7864
7865 newwidth = (newwidth * ((curpage->coordstyle == CM) ?
7866 IN_CM_CONVERT : 72.0)) / topobject->bbox.width;
7867 newwidth /= getpsscale(1.0, pageno);
7868 curpage->outscale = (float)newwidth;
7869
7870 if (curpage->pmode & 2) autoscale(pageno);
7871 break;
7872
7873 case ScaleIdx:
7874 if ((objc - nidx) != 2 && (objc - nidx) != 3) {
7875 Tcl_WrongNumArgs(interp, 1, objv, "output_scale");
7876 return TCL_ERROR;
7877 }
7878 if ((objc - nidx) == 2) {
7879 objPtr = Tcl_NewDoubleObj((double)curpage->outscale);
7880 Tcl_SetObjResult(interp, objPtr);
7881 return XcTagCallback(interp, objc, objv);
7882 }
7883 result = Tcl_GetDoubleFromObj(interp, objv[2 + nidx], &newscale);
7884 if (result != TCL_OK) return result;
7885
7886 oldscale = curpage->outscale;
7887
7888 if (oldscale == (float)newscale) return TCL_OK; /* nothing to do */
7889 else curpage->outscale = (float)newscale;
7890
7891 if (curpage->pmode & 2) autoscale(pageno);
7892 break;
7893
7894 case OrientIdx:
7895 if ((objc - nidx) != 2 && (objc - nidx) != 3) {
7896 Tcl_WrongNumArgs(interp, 1, objv, "orientation");
7897 return TCL_ERROR;
7898 }
7899 if ((objc - nidx) == 2) {
7900 objPtr = Tcl_NewIntObj((int)curpage->orient);
7901 Tcl_SetObjResult(interp, objPtr);
7902 return XcTagCallback(interp, objc, objv);
7903 }
7904 result = Tcl_GetIntFromObj(interp, objv[2 + nidx], &newrot);
7905 if (result != TCL_OK) return result;
7906 curpage->orient = (short)newrot;
7907
7908 /* rescale after rotation if "auto-scale" is set */
7909 if (curpage->pmode & 2) autoscale(pageno);
7910 break;
7911
7912 case EPSIdx:
7913 if ((objc - nidx) != 2 && (objc - nidx) != 3) {
7914 Tcl_WrongNumArgs(interp, 1, objv, "encapsulation");
7915 return TCL_ERROR;
7916 }
7917 if ((objc - nidx) == 2) {
7918 newstr = psTypes[curpage->pmode & 1];
7919 Tcl_SetResult(interp, newstr, NULL);
7920 return XcTagCallback(interp, objc, objv);
7921 }
7922 newstr = Tcl_GetString(objv[2 + nidx]);
7923 if (Tcl_GetIndexFromObj(interp, objv[2 + nidx],
7924 (CONST84 char **)psTypes,
7925 "encapsulation", 0, &newmode) != TCL_OK) {
7926 return result;
7927 }
7928 curpage->pmode &= 0x2; /* preserve auto-fit flag */
7929 curpage->pmode |= (short)newmode;
7930 break;
7931
7932 case LabelIdx:
7933 if ((objc - nidx) != 2 && (objc - nidx) != 3) {
7934 Tcl_WrongNumArgs(interp, 1, objv, "label ?name?");
7935 return TCL_ERROR;
7936 }
7937 if ((objc - nidx) == 2) {
7938 objPtr = Tcl_NewStringObj(pageobj->name, strlen(pageobj->name));
7939 Tcl_SetObjResult(interp, objPtr);
7940 return XcTagCallback(interp, objc, objv);
7941 }
7942
7943 /* Whitespace and non-printing characters not allowed */
7944
7945 strcpy(_STR2, Tcl_GetString(objv[2 + nidx]));
7946 for (i = 0; i < strlen(_STR2); i++) {
7947 if ((!isprint(_STR2[i])) || (isspace(_STR2[i]))) {
7948 _STR2[i] = '_';
7949 Wprintf("Replaced illegal whitespace in name with underscore");
7950 }
7951 }
7952
7953 if (!strcmp(pageobj->name, _STR2)) return TCL_OK; /* no change in string */
7954 if (strlen(_STR2) == 0)
7955 sprintf(pageobj->name, "Page %d", areawin->page + 1);
7956 else
7957 sprintf(pageobj->name, "%.79s", _STR2);
7958
7959 /* For schematics, all pages with associations to symbols must have */
7960 /* unique names. */
7961 if (pageobj->symschem != NULL) checkpagename(pageobj);
7962
7963 if (pageobj == topobject) printname(pageobj);
7964 renamepage(pageno);
7965 break;
7966
7967 case FileIdx:
7968
7969 if ((objc - nidx) != 2 && (objc - nidx) != 3) {
7970 Tcl_WrongNumArgs(interp, 1, objv, "filename ?name?");
7971 return TCL_ERROR;
7972 }
7973
7974 oldstr = curpage->filename;
7975
7976 if ((objc - nidx) == 2) {
7977 if (oldstr)
7978 objPtr = Tcl_NewStringObj(oldstr, strlen(oldstr));
7979 else
7980 objPtr = Tcl_NewListObj(0, NULL); /* NULL list */
7981 Tcl_SetObjResult(interp, objPtr);
7982 return XcTagCallback(interp, objc, objv);
7983 }
7984
7985 newstr = Tcl_GetString(objv[2 + nidx]);
7986 if (strlen(newstr) > 0) {
7987 froot = strrchr(newstr, '/');
7988 if (froot == NULL) froot = newstr;
7989 if (strchr(froot, '.') == NULL) {
7990 astr = malloc(strlen(newstr) + 4);
7991 sprintf(astr, "%s.ps", newstr);
7992 newstr = astr;
7993 }
7994 }
7995
7996 if (oldstr && (!strcmp(oldstr, newstr))) { /* no change in string */
7997 if (newstr == astr) free(astr);
7998 return XcTagCallback(interp, objc, objv);
7999 }
8000
8001 if (strlen(newstr) == 0) { /* empty string */
8002 Tcl_SetResult(interp, "Warning: No filename!", NULL);
8003 multi = 1;
8004 }
8005 else {
8006 multi = pagelinks(pageno); /* Are there multiple pages? */
8007 }
8008
8009 /* Make the change to the current page */
8010 curpage->filename = strdup(newstr);
8011 if (newstr == astr) free(astr);
8012
8013 /* All existing filenames which match the old string should */
8014 /* also be changed unless the filename has been set to the */
8015 /* null string, which unlinks the page. */
8016
8017 if ((strlen(curpage->filename) > 0) && (multi > 1)) {
8018 for (cpage = 0; cpage < xobjs.pages; cpage++) {
8019 lpage = xobjs.pagelist[cpage];
8020 if ((lpage->pageinst != NULL) && (cpage != pageno)) {
8021 if (lpage->filename && (!filecmp(lpage->filename, oldstr))) {
8022 free(lpage->filename);
8023 lpage->filename = strdup(newstr);
8024 }
8025 }
8026 }
8027 }
8028 free(oldstr);
8029 autoscale(pageno);
8030
8031 /* Run pagelinks again; this checks if a page has been attached */
8032 /* to existing schematics by being renamed to match. */
8033
8034 if ((strlen(curpage->filename) > 0) && (multi <= 1)) {
8035 for (cpage = 0; cpage < xobjs.pages; cpage++) {
8036 lpage = xobjs.pagelist[cpage];
8037 if ((lpage->pageinst != NULL) && (cpage != pageno)) {
8038 if (lpage->filename && (!filecmp(lpage->filename,
8039 curpage->filename))) {
8040 free(curpage->filename);
8041 curpage->filename = strdup(lpage->filename);
8042 break;
8043 }
8044 }
8045 }
8046 }
8047 break;
8048
8049 case FitIdx:
8050 if ((objc - nidx) > 3) {
8051 Tcl_WrongNumArgs(interp, 1, objv, "fit ?true|false?");
8052 return TCL_ERROR;
8053 }
8054 else if ((objc - nidx) == 3) {
8055 result = Tcl_GetBooleanFromObj(interp, objv[2 + nidx], &aval);
8056 if (result != TCL_OK) return result;
8057 if (aval)
8058 curpage->pmode |= 2;
8059 else
8060 curpage->pmode &= 1;
8061 }
8062 else
8063 Tcl_SetResult(interp, ((curpage->pmode & 2) > 0) ? "true" : "false", NULL);
8064
8065 /* Refresh values (does autoscale if specified) */
8066 autoscale(pageno);
8067 break;
8068
8069 case ChangesIdx:
8070 if ((objc - nidx) != 2 && (objc - nidx) != 3) {
8071 Tcl_WrongNumArgs(interp, 1, objv, "changes");
8072 return TCL_ERROR;
8073 }
8074 /* Allow changes to be set, so that a page can be forced to be */
8075 /* recognized as either modified or unmodified. */
8076
8077 if ((objc - nidx) == 3) {
8078 int value;
8079 Tcl_GetIntFromObj(interp, objv[2 + nidx], &value);
8080 curpage->pageinst->thisobject->changes = (u_short)value;
8081 }
8082 changes = getchanges(curpage->pageinst->thisobject);
8083 objPtr = Tcl_NewIntObj((double)changes);
8084 Tcl_SetObjResult(interp, objPtr);
8085 return XcTagCallback(interp, objc, objv);
8086 break;
8087 }
8088 return XcTagCallback(interp, objc, objv);
8089 }
8090
8091 /*----------------------------------------------------------------------*/
8092 /* The "technology" command deals with library *technologies*, where */
8093 /* they differ from files or pages (see the "library" command */
8094 /* xctcl_library, below). Specifically, "library load" loads a file */
8095 /* (containing object defintions in a specific technology) onto a page, */
8096 /* whereas "technology save" writes back the object definitions that */
8097 /* came from the specified file. Although one would typically have one */
8098 /* library page per technology, this is not necessarily the case. */
8099 /* */
8100 /* Only one technology is defined by a library file, but the library */
8101 /* may contain (copies of) dependent objects from another technology. */
8102 /*----------------------------------------------------------------------*/
8103
8104 int xctcl_tech(ClientData clientData, Tcl_Interp *interp,
8105 int objc, Tcl_Obj *CONST objv[])
8106 {
8107 char *technology, *filename, *libobjname;
8108 short *pagelist;
8109 int idx, ilib, j, pageno, nidx, result;
8110 TechPtr nsptr = NULL;
8111 Tcl_Obj *olist;
8112 objectptr libobj;
8113 Boolean usertech = FALSE;
8114 FILE *chklib;
8115
8116 char *subCmds[] = {
8117 "save", "list", "objects", "filename", "changed", "used", "prefer",
8118 "writable", "writeable", NULL
8119 };
8120 enum SubIdx {
8121 SaveIdx, ListIdx, ObjectsIdx, FileNameIdx, ChangedIdx, UsedIdx,
8122 PreferIdx, WritableIdx, WriteableIdx
8123 };
8124
8125 if (objc < 2) {
8126 Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
8127 return TCL_ERROR;
8128 }
8129 if (Tcl_GetIndexFromObj(interp, objv[1],
8130 (CONST84 char **)subCmds, "option", 0, &idx) != TCL_OK) {
8131 return TCL_ERROR;
8132 }
8133
8134 /* All options except "list" and "used" expect a technology argument */
8135 if (idx != ListIdx && idx != UsedIdx) {
8136 if (objc > 2) {
8137 technology = Tcl_GetString(objv[2]);
8138 nsptr = LookupTechnology(technology);
8139 if (nsptr == NULL) {
8140
8141 /* If the command is "objects" and has one or more */
8142 /* additional arguments, then a NULL nsptr is okay (new */
8143 /* technology will be created and added to the list). */
8144
8145 if (idx != ObjectsIdx || objc <= 3) {
8146
8147 /* If nsptr is NULL, then the technology should be */
8148 /* "none", "user", or "default". */
8149
8150 if ((strstr(technology, "none") == NULL) &&
8151 (strstr(technology, "user") == NULL) &&
8152 (strstr(technology, "default") == NULL)) {
8153 Tcl_SetResult(interp, "Error: Unknown technology name!", NULL);
8154 return TCL_ERROR;
8155 }
8156 usertech = TRUE;
8157 }
8158 }
8159
8160 /* And if the user technology has been saved to a file, the technology */
8161 /* will have a NULL string. Also check for technology name "(user)", */
8162 /* although that is not supposed to happen. */
8163
8164 else if (*nsptr->technology == '\0')
8165 usertech = TRUE;
8166
8167 else if (!strcmp(nsptr->technology, "(user)"))
8168 usertech = TRUE;
8169 }
8170 else {
8171 Tcl_WrongNumArgs(interp, 1, objv, "<option> technology ?args ...?");
8172 return TCL_ERROR;
8173 }
8174 }
8175
8176 switch (idx) {
8177 case ListIdx:
8178 /* List all of the known technologies */
8179 olist = Tcl_NewListObj(0, NULL);
8180 for (nsptr = xobjs.technologies; nsptr != NULL; nsptr = nsptr->next) {
8181 Tcl_ListObjAppendElement(interp, olist,
8182 Tcl_NewStringObj(nsptr->technology,
8183 strlen(nsptr->technology)));
8184 }
8185 Tcl_SetObjResult(interp, olist);
8186 break;
8187
8188 case UsedIdx:
8189 /* List all of the technologies used by the schematic of the */
8190 /* indicated (or current) page. That is, enumerate all */
8191 /* in the hierarchy of the schematic, and list all unique */
8192 /* technology prefixes. */
8193
8194 result = ParsePageArguments(interp, objc - 1, objv + 1, &nidx, &pageno);
8195 if (result != TCL_OK) return result;
8196 olist = Tcl_NewListObj(0, NULL);
8197
8198 pagelist = pagetotals(pageno, TOTAL_PAGES);
8199 for (j = 0; j < xobjs.pages; j++) {
8200 if (pagelist[j] > 0) {
8201 objinstptr tinst;
8202 objectptr tpage = xobjs.pagelist[j]->pageinst->thisobject;
8203 genericptr *tgen;
8204
8205 for (tgen = tpage->plist; tgen < tpage->plist + tpage->parts; tgen++) {
8206 if ((*tgen)->type == OBJINST) {
8207 tinst = TOOBJINST(tgen);
8208 nsptr = GetObjectTechnology(tinst->thisobject);
8209 if (nsptr != NULL) {
8210 if ((nsptr->technology == NULL) ||
8211 (strlen(nsptr->technology) == 0)) continue;
8212 if (!(nsptr->flags & TECH_USED)) {
8213 Tcl_ListObjAppendElement(interp, olist,
8214 Tcl_NewStringObj(nsptr->technology,
8215 strlen(nsptr->technology)));
8216 nsptr->flags |= TECH_USED;
8217 }
8218 }
8219 }
8220 }
8221 }
8222 }
8223 Tcl_SetObjResult(interp, olist);
8224 for (nsptr = xobjs.technologies; nsptr != NULL; nsptr = nsptr->next)
8225 nsptr->flags &= ~TECH_USED;
8226 free((char *)pagelist);
8227 break;
8228
8229 case ObjectsIdx:
8230
8231 if (objc > 3) {
8232 int numobjs, objnamelen, technamelen;
8233 Tcl_Obj *tobj;
8234 char *cptr;
8235 TechPtr otech;
8236
8237 /* Check that 4th argument is a list of objects or that */
8238 /* 4th and higher arguments are all names of objects, and */
8239 /* that these objects are valid existing objects. */
8240
8241 if (objc == 4) {
8242 result = Tcl_ListObjLength(interp, objv[3], &numobjs);
8243 if (result != TCL_OK) return result;
8244 for (j = 0; j < numobjs; j++) {
8245 result = Tcl_ListObjIndex(interp, objv[3], j, &tobj);
8246 if (result != TCL_OK) return result;
8247 libobj = NameToObject(Tcl_GetString(tobj), NULL, FALSE);
8248 if (libobj == NULL) {
8249 Tcl_SetResult(interp, "No such object name", NULL);
8250 return TCL_ERROR;
8251 }
8252 }
8253 }
8254 else {
8255 for (j = 0; j < objc - 4; j++) {
8256 libobj = NameToObject(Tcl_GetString(objv[3 + j]), NULL, FALSE);
8257 if (libobj == NULL) {
8258 Tcl_SetResult(interp, "No such object name", NULL);
8259 return TCL_ERROR;
8260 }
8261 }
8262 }
8263
8264 /* Create a new technology if needed */
8265 technology = Tcl_GetString(objv[2]);
8266 if ((nsptr == NULL) && !usertech)
8267 AddNewTechnology(technology, NULL);
8268
8269 nsptr = LookupTechnology(technology);
8270 technamelen = (usertech) ? 0 : strlen(technology);
8271
8272
8273 /* Change the technology prefix of all the objects listed */
8274
8275 if (objc == 4) {
8276 result = Tcl_ListObjLength(interp, objv[3], &numobjs);
8277 if (result != TCL_OK) return result;
8278 for (j = 0; j < numobjs; j++) {
8279 result = Tcl_ListObjIndex(interp, objv[3], j, &tobj);
8280 if (result != TCL_OK) return result;
8281 libobj = NameToObject(Tcl_GetString(tobj), NULL, FALSE);
8282 cptr = strstr(libobj->name, "::");
8283 if (cptr == NULL) {
8284 objnamelen = strlen(libobj->name);
8285 memmove(libobj->name + technamelen + 2,
8286 libobj->name, (size_t)strlen(libobj->name));
8287 }
8288 else {
8289 otech = GetObjectTechnology(libobj);
8290 otech->flags |= TECH_CHANGED;
8291 objnamelen = strlen(cptr + 2);
8292 memmove(libobj->name + technamelen + 2,
8293 cptr + 2, (size_t)strlen(cptr + 2));
8294 }
8295
8296 if (!usertech) strcpy(libobj->name, technology);
8297 *(libobj->name + technamelen) = ':';
8298 *(libobj->name + technamelen + 1) = ':';
8299 *(libobj->name + technamelen + 2 + objnamelen) = '\0';
8300 }
8301 }
8302 else {
8303 for (j = 0; j < objc - 4; j++) {
8304 libobj = NameToObject(Tcl_GetString(objv[3 + j]), NULL, FALSE);
8305 cptr = strstr(libobj->name, "::");
8306 if (cptr == NULL) {
8307 objnamelen = strlen(libobj->name);
8308 memmove(libobj->name + technamelen + 2,
8309 libobj->name, (size_t)strlen(libobj->name));
8310 }
8311 else {
8312 otech = GetObjectTechnology(libobj);
8313 otech->flags |= TECH_CHANGED;
8314 objnamelen = strlen(cptr + 2);
8315 memmove(libobj->name + technamelen + 2,
8316 cptr + 2, (size_t)strlen(cptr + 2));
8317 }
8318
8319 if (!usertech) strcpy(libobj->name, technology);
8320 *(libobj->name + technamelen) = ':';
8321 *(libobj->name + technamelen + 1) = ':';
8322 *(libobj->name + technamelen + 2 + objnamelen) = '\0';
8323 }
8324 }
8325 if (nsptr != NULL) nsptr->flags |= TECH_CHANGED;
8326 break;
8327 }
8328
8329 /* List all objects having this technology */
8330
8331 olist = Tcl_NewListObj(0, NULL);
8332 for (ilib = 0; ilib < xobjs.numlibs; ilib++) {
8333 for (j = 0; j < xobjs.userlibs[ilib].number; j++) {
8334 libobj = *(xobjs.userlibs[ilib].library + j);
8335 if (GetObjectTechnology(libobj) == nsptr) {
8336 libobjname = strstr(libobj->name, "::");
8337 if (libobjname == NULL)
8338 libobjname = libobj->name;
8339 else
8340 libobjname += 2;
8341 Tcl_ListObjAppendElement(interp, olist,
8342 Tcl_NewStringObj(libobjname, strlen(libobjname)));
8343 }
8344 }
8345 }
8346 Tcl_SetObjResult(interp, olist);
8347 break;
8348
8349 case FileNameIdx:
8350 if (nsptr != NULL) {
8351 if (objc == 3) {
8352 if (nsptr->filename == NULL)
8353 Tcl_SetResult(interp, "(no associated file)", NULL);
8354 else
8355 Tcl_SetResult(interp, nsptr->filename, NULL);
8356 }
8357 else {
8358 if (nsptr->filename != NULL) free(nsptr->filename);
8359 nsptr->filename = strdup(Tcl_GetString(objv[3]));
8360 }
8361 }
8362 else {
8363 Tcl_SetResult(interp, "Valid technology is required", NULL);
8364 return TCL_ERROR;
8365 }
8366 break;
8367
8368 case ChangedIdx:
8369 if (objc == 4) {
8370 int bval;
8371 if (Tcl_GetBooleanFromObj(interp, objv[3], &bval) != TCL_OK)
8372 return TCL_ERROR;
8373 else if (bval == 1)
8374 nsptr->flags |= TECH_CHANGED;
8375 else
8376 nsptr->flags &= ~TECH_CHANGED;
8377 }
8378 else {
8379 tech_set_changes(nsptr); /* Ensure change flags are updated */
8380 Tcl_SetObjResult(interp,
8381 Tcl_NewBooleanObj(((nsptr->flags & TECH_CHANGED)
8382 == 0) ? FALSE : TRUE));
8383 }
8384 break;
8385
8386 case PreferIdx:
8387 if (nsptr) {
8388 if (objc == 3) {
8389 Tcl_SetObjResult(interp,
8390 Tcl_NewBooleanObj(((nsptr->flags & TECH_PREFER) == 0)
8391 ? TRUE : FALSE));
8392 }
8393 else if (objc == 4) {
8394 int bval;
8395
8396 Tcl_GetBooleanFromObj(interp, objv[3], &bval);
8397 if (bval == 0)
8398 nsptr->flags |= TECH_PREFER;
8399 else
8400 nsptr->flags &= (~TECH_PREFER);
8401 }
8402 }
8403 else {
8404 Tcl_SetResult(interp, "Valid technology is required", NULL);
8405 return TCL_ERROR;
8406 }
8407 break;
8408
8409 case WritableIdx:
8410 case WriteableIdx:
8411 if (nsptr) {
8412 if (objc == 3) {
8413 Tcl_SetObjResult(interp,
8414 Tcl_NewBooleanObj(((nsptr->flags & TECH_READONLY) == 0)
8415 ? TRUE : FALSE));
8416 }
8417 else if (objc == 4) {
8418 int bval;
8419
8420 Tcl_GetBooleanFromObj(interp, objv[3], &bval);
8421 if (bval == 0)
8422 nsptr->flags |= TECH_READONLY;
8423 else
8424 nsptr->flags &= (~TECH_READONLY);
8425 }
8426 }
8427 else {
8428 Tcl_SetResult(interp, "Valid technology is required", NULL);
8429 return TCL_ERROR;
8430 }
8431 break;
8432
8433 case SaveIdx:
8434
8435 /* technology save [filename] */
8436 if ((objc == 3) && ((nsptr == NULL) || (nsptr->filename == NULL))) {
8437 Tcl_SetResult(interp, "Error: Filename is required.", NULL);
8438 return TCL_ERROR;
8439 }
8440 else if ((nsptr != NULL) && (objc == 4)) {
8441 /* Technology being saved under a different filename. */
8442 filename = Tcl_GetString(objv[3]);
8443
8444 /* Re-check read-only status of the file */
8445 nsptr->flags &= ~(TECH_READONLY);
8446 chklib = fopen(filename, "a");
8447 if (chklib == NULL)
8448 nsptr->flags |= TECH_READONLY;
8449 else
8450 fclose(chklib);
8451 }
8452 else if (objc == 4) {
8453 filename = Tcl_GetString(objv[3]);
8454 if (!usertech) AddNewTechnology(technology, filename);
8455 }
8456 else
8457 filename = nsptr->filename;
8458
8459 savetechnology((usertech) ? NULL : technology, filename);
8460 break;
8461 }
8462 return XcTagCallback(interp, objc, objv);
8463 }
8464
8465 /*----------------------------------------------------------------------*/
8466 /* The "library" command deals with library *pages* */
8467 /*----------------------------------------------------------------------*/
8468
8469 int xctcl_library(ClientData clientData, Tcl_Interp *interp,
8470 int objc, Tcl_Obj *CONST objv[])
8471 {
8472 char *filename = NULL, *objname, *argv;
8473 int j = 0, libnum = -1;
8474 int idx, nidx, result, res;
8475 Tcl_Obj *olist;
8476 Tcl_Obj **newobjv;
8477 int newobjc, hidmode;
8478 objectptr libobj;
8479 liblistptr spec;
8480 char *subCmds[] = {
8481 "load", "make", "directory", "next", "goto", "override",
8482 "handle", "import", "list", "compose", NULL
8483 };
8484 enum SubIdx {
8485 LoadIdx, MakeIdx, DirIdx, NextIdx, GoToIdx, OverrideIdx,
8486 HandleIdx, ImportIdx, ListIdx, ComposeIdx
8487 };
8488
8489 result = ParseLibArguments(interp, objc, objv, &nidx, &libnum);
8490 if ((result != TCL_OK) || (nidx < 0)) return result;
8491 else if ((objc - nidx) > 5) {
8492 Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
8493 return TCL_ERROR;
8494 }
8495 else if (objc <= (1 + nidx)) { /* No subcommand */
8496
8497 /* return index if name given; return name if index given. */
8498 /* return index if neither is given (current library) */
8499
8500 if (objc > 1) {
8501 int lnum; /* unused; only checks if argument is integer */
8502 char *lname;
8503 result = Tcl_GetIntFromObj(interp, objv[1], &lnum);
8504 if (result == TCL_OK) {
8505 lname = xobjs.libtop[libnum + LIBRARY]->thisobject->name;
8506 Tcl_SetObjResult(interp, Tcl_NewStringObj(lname, strlen(lname)));
8507 }
8508 else {
8509 result = TCL_OK;
8510 Tcl_SetObjResult(interp, Tcl_NewIntObj(libnum + 1));
8511 }
8512 }
8513 else
8514 Tcl_SetObjResult(interp, Tcl_NewIntObj(libnum + 1));
8515 idx = -1;
8516 }
8517 else if (Tcl_GetIndexFromObj(interp, objv[1 + nidx],
8518 (CONST84 char **)subCmds, "option", 0, &idx) != TCL_OK) {
8519
8520 /* Backwards compatibility: "library filename [number]" is */
8521 /* the same as "library [number] load filename" */
8522
8523 Tcl_ResetResult(interp);
8524 newobjv = (Tcl_Obj **)(&objv[1]);
8525 newobjc = objc - 1;
8526
8527 result = ParseLibArguments(interp, newobjc, newobjv, &nidx, &libnum);
8528 if (result != TCL_OK) return result;
8529
8530 idx = LoadIdx;
8531 filename = Tcl_GetString(newobjv[0]);
8532 }
8533
8534 /* libnum = -1 is equivalent to "USER LIBRARY" */
8535 if (libnum < 0) libnum = xobjs.numlibs - 1;
8536
8537 switch (idx) {
8538 case LoadIdx:
8539 TechReplaceSave();
8540
8541 /* library [<name>|<number>] load <filename> [-replace [library]] */
8542 if (objc < (3 + nidx)) {
8543 Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
8544 return TCL_ERROR;
8545 }
8546 if (filename == NULL) filename = Tcl_GetString(objv[2 + nidx]);
8547
8548 /* if loading of default libraries is not overridden, load them first */
8549
8550 if (!(flags & (LIBOVERRIDE | LIBLOADED))) {
8551 result = defaultscript();
8552 flags |= LIBLOADED;
8553 }
8554
8555 /* If library number is out of range, create a new library */
8556 /* libnum = -1 is equivalent to the user library page. */
8557
8558 if (libnum > (xobjs.numlibs - 1))
8559 libnum = createlibrary(FALSE);
8560 else if (libnum < 0)
8561 libnum = USERLIB;
8562 else
8563 libnum += LIBRARY;
8564
8565 if (objc > (3 + nidx)) {
8566 argv = Tcl_GetString(objv[3 + nidx]);
8567 if ((*argv == '-') && !strncmp(argv, "-repl", 5)) {
8568 if (objc > (4 + nidx)) {
8569 char *techstr = Tcl_GetString(objv[3 + nidx]);
8570 if (!strcmp(techstr, "all")) TechReplaceAll();
8571 else if (!strcmp(techstr, "none")) TechReplaceNone();
8572 else {
8573 TechPtr nsptr = LookupTechnology(techstr);
8574 if (nsptr != NULL)
8575 nsptr->flags |= TECH_REPLACE;
8576 }
8577 }
8578 else
8579 TechReplaceAll(); /* replace ALL */
8580 }
8581 }
8582
8583 strcpy(_STR, filename);
8584 res = loadlibrary(libnum);
8585 if (res == False) {
8586 res = loadfile(2, libnum);
8587 TechReplaceRestore();
8588 if (res == False) {
8589 Tcl_SetResult(interp, "Error loading library.\n", NULL);
8590 return TCL_ERROR;
8591 }
8592 }
8593 TechReplaceRestore();
8594 break;
8595
8596 case ImportIdx:
8597 /* library [<name>|<number>] import <filename> <objectname> */
8598 if (objc != (4 + nidx)) {
8599 Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
8600 return TCL_ERROR;
8601 }
8602 if (filename == NULL) filename = Tcl_GetString(objv[2 + nidx]);
8603
8604 /* if loading of default libraries is not overridden, load them first */
8605
8606 if (!(flags & (LIBOVERRIDE | LIBLOADED))) {
8607 defaultscript();
8608 flags |= LIBLOADED;
8609 }
8610
8611 if ((libnum >= xobjs.numlibs) || (libnum < 0))
8612 libnum = createlibrary(FALSE);
8613 else
8614 libnum += LIBRARY;
8615
8616 objname = Tcl_GetString(objv[3 + nidx]);
8617 importfromlibrary(libnum, filename, objname);
8618 break;
8619
8620 case ListIdx:
8621
8622 if (!strncmp(Tcl_GetString(objv[objc - 1]), "-vis", 4))
8623 hidmode = 1; /* list visible objects only */
8624 else if (!strncmp(Tcl_GetString(objv[objc - 1]), "-hid", 4))
8625 hidmode = 2; /* list hidden objects only */
8626 else
8627 hidmode = 3; /* list everything */
8628
8629 /* library [name|number] list [-visible|-hidden] */
8630 olist = Tcl_NewListObj(0, NULL);
8631 for (j = 0; j < xobjs.userlibs[libnum].number; j++) {
8632 libobj = *(xobjs.userlibs[libnum].library + j);
8633 if (((libobj->hidden) && (hidmode & 2)) ||
8634 ((!libobj->hidden) && (hidmode & 1)))
8635 Tcl_ListObjAppendElement(interp, olist,
8636 Tcl_NewStringObj(libobj->name, strlen(libobj->name)));
8637 }
8638 Tcl_SetObjResult(interp, olist);
8639 break;
8640
8641 case HandleIdx:
8642
8643 if (objc == (3 + nidx)) {
8644 /* library [name|number] handle <object name> */
8645
8646 olist = Tcl_NewListObj(0, NULL);
8647 for (spec = xobjs.userlibs[libnum].instlist; spec != NULL;
8648 spec = spec->next) {
8649 libobj = spec->thisinst->thisobject;
8650 if (!strcmp(libobj->name, Tcl_GetString(objv[objc - 1])))
8651 Tcl_ListObjAppendElement(interp, olist,
8652 Tcl_NewHandleObj((genericptr)spec->thisinst));
8653 }
8654 Tcl_SetObjResult(interp, olist);
8655 }
8656 else if (objc == (2 + nidx)) {
8657 /* library [name|number] handle */
8658
8659 olist = Tcl_NewListObj(0, NULL);
8660 for (spec = xobjs.userlibs[libnum].instlist; spec != NULL;
8661 spec = spec->next) {
8662 Tcl_ListObjAppendElement(interp, olist,
8663 Tcl_NewHandleObj((genericptr)spec->thisinst));
8664 }
8665 Tcl_SetObjResult(interp, olist);
8666 }
8667 else {
8668 Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
8669 return TCL_ERROR;
8670 }
8671 break;
8672
8673 case ComposeIdx:
8674 composelib(libnum + LIBRARY);
8675 centerview(xobjs.libtop[libnum + LIBRARY]);
8676 break;
8677
8678 case MakeIdx:
8679 /* library make [name] */
8680 if (nidx == 1) {
8681 Tcl_SetResult(interp, "syntax is: library make [<name>]", NULL);
8682 return TCL_ERROR;
8683 }
8684
8685 /* If the (named or numbered) library exists, don't create it. */
8686 /* ParseLibArguments() returns the library number for the User */
8687 /* Library. The User Library always exists and cannot be */
8688 /* created or destroyed, so it's okay to use it as a check for */
8689 /* "no library found". */
8690
8691 if (libnum == xobjs.numlibs - 1)
8692 libnum = createlibrary(TRUE);
8693
8694 if (objc == 3) {
8695 strcpy(xobjs.libtop[libnum]->thisobject->name, Tcl_GetString(objv[2]));
8696 renamelib(libnum);
8697 composelib(LIBLIB);
8698 }
8699 /* Don't go to the library page---use "library goto" instead */
8700 /* startcatalog((Tk_Window)clientData, libnum, NULL); */
8701 break;
8702
8703 case DirIdx:
8704 /* library directory */
8705 if ((nidx == 0) && (objc == 2)) {
8706 startcatalog(NULL, LIBLIB, NULL);
8707 }
8708 else if ((nidx == 0) && (objc == 3) &&
8709 !strcmp(Tcl_GetString(objv[2]), "list")) {
8710 olist = Tcl_NewListObj(0, NULL);
8711 for (j = 0; j < xobjs.numlibs; j++) {
8712 libobj = xobjs.libtop[j + LIBRARY]->thisobject;
8713 Tcl_ListObjAppendElement(interp, olist,
8714 Tcl_NewStringObj(libobj->name, strlen(libobj->name)));
8715 }
8716 Tcl_SetObjResult(interp, olist);
8717 }
8718 else {
8719 Tcl_SetResult(interp, "syntax is: library directory [list]", NULL);
8720 return TCL_ERROR;
8721 }
8722 break;
8723
8724 case NextIdx:
8725 libnum = is_library(topobject);
8726 if (++libnum >= xobjs.numlibs) libnum = 0; /* fall through */
8727
8728 case GoToIdx:
8729 /* library go */
8730 startcatalog(NULL, LIBRARY + libnum, NULL);
8731 break;
8732 case OverrideIdx:
8733 flags |= LIBOVERRIDE;
8734 return TCL_OK; /* no tag callback */
8735 break;
8736 }
8737 return (result == TCL_OK) ? XcTagCallback(interp, objc, objv) : result;
8738 }
8739
8740 /*----------------------------------------------------------------------*/
8741 /* "bindkey" command --- this is a direct implementation of the same */
8742 /* key binding found in the "ad-hoc" and Python interfaces; it is */
8743 /* preferable to make use of the Tk "bind" command directly, and work */
8744 /* from the event handler. */
8745 /*----------------------------------------------------------------------*/
8746
8747 int xctcl_bind(ClientData clientData, Tcl_Interp *interp,
8748 int objc, Tcl_Obj *CONST objv[])
8749 {
8750 Tk_Window window = (Tk_Window)NULL;
8751 XCWindowDataPtr searchwin;
8752 char *keyname, *commandname, *binding;
8753 int keywstate, func = -1, value = -1;
8754 int result;
8755 Boolean compat = FALSE;
8756
8757 if (objc == 2) {
8758 keyname = Tcl_GetString(objv[1]);
8759 if (!strcmp(keyname, "override")) {
8760 flags |= KEYOVERRIDE;
8761 return TCL_OK; /* no tag callback */
8762 }
8763 }
8764
8765 if (!(flags & KEYOVERRIDE)) {
8766 default_keybindings();
8767 flags |= KEYOVERRIDE;
8768 }
8769
8770 if (objc == 1) {
8771 Tcl_Obj *list;
8772 int i;
8773
8774 list = Tcl_NewListObj(0, NULL);
8775 for (i = 0; i < NUM_FUNCTIONS; i++) {
8776 commandname = func_to_string(i);
8777 Tcl_ListObjAppendElement(interp, list,
8778 Tcl_NewStringObj(commandname, strlen(commandname)));
8779 }
8780 Tcl_SetObjResult(interp, list);
8781 return TCL_OK;
8782 }
8783 else if (objc > 5) {
8784 Tcl_WrongNumArgs(interp, 1, objv,
8785 "[<key> [<window>] [<command> [<value>|forget]]]");
8786 return TCL_ERROR;
8787 }
8788
8789 /* If 1st argument matches a window name, create a window-specific */
8790 /* binding. Otherwise, create a binding for all windows. */
8791
8792 if (objc > 1) {
8793 window = Tk_NameToWindow(interp, Tcl_GetString(objv[1]), Tk_MainWindow(interp));
8794 if (window == (Tk_Window)NULL)
8795 Tcl_ResetResult(interp);
8796 else {
8797 for (searchwin = xobjs.windowlist; searchwin != NULL; searchwin =
8798 searchwin->next)
8799 if (searchwin->area == window)
8800 break;
8801 if (searchwin != NULL) {
8802 /* Shift arguments */
8803 objc--;
8804 objv++;
8805 }
8806 else
8807 window = (xcWidget)NULL;
8808 }
8809 }
8810
8811 /* 1st argument can be option "-compatible" */
8812 if ((objc > 1) && !strncmp(Tcl_GetString(objv[1]), "-comp", 5)) {
8813 objc--;
8814 objv++;
8815 compat = TRUE;
8816 }
8817
8818 keyname = Tcl_GetString(objv[1]);
8819 keywstate = string_to_key(keyname);
8820
8821 /* 1st arg may be a function, not a key, if we want the binding returned */
8822 if ((objc == 3) && !strncmp(keyname, "-func", 5)) {
8823 keywstate = -1;
8824 func = string_to_func(Tcl_GetString(objv[2]), NULL);
8825 objc = 2;
8826 if (func == -1) {
8827 Tcl_SetResult(interp, "Invalid function name\n", NULL);
8828 return TCL_ERROR;
8829 }
8830 }
8831 else if ((objc == 2) && (keywstate == 0)) {
8832 keywstate = -1;
8833 func = string_to_func(keyname, NULL);
8834 }
8835
8836 if ((keywstate == -1 || keywstate == 0) && func == -1) {
8837 Tcl_SetResult(interp, "Invalid key name ", NULL);
8838 Tcl_AppendElement(interp, keyname);
8839 return TCL_ERROR;
8840 }
8841
8842 if (objc == 2) {
8843 if (keywstate == -1)
8844 binding = function_binding_to_string(window, func);
8845 else if (compat)
8846 binding = compat_key_to_string(window, keywstate);
8847 else
8848 binding = key_binding_to_string(window, keywstate);
8849 Tcl_SetResult(interp, binding, TCL_VOLATILE);
8850 free(binding);
8851 return TCL_OK;
8852 }
8853
8854 if (objc < 3) {
8855 Tcl_SetResult(interp, "Usage: bindkey <key> [<function>]\n", NULL);
8856 return TCL_ERROR;
8857 }
8858
8859 commandname = Tcl_GetString(objv[2]);
8860 if (strlen(commandname) == 0)
8861 func = -1;
8862 else
8863 func = string_to_func(commandname, NULL);
8864
8865 if (objc == 4) {
8866 result = Tcl_GetIntFromObj(interp, objv[3], &value);
8867 if (result != TCL_OK)
8868 {
8869 if (strcmp(Tcl_GetString(objv[3]), "forget"))
8870 return (result);
8871 else {
8872 /* Unbind command */
8873 Tcl_ResetResult(interp);
8874 result = remove_binding(window, keywstate, func);
8875 if (result == 0)
8876 return TCL_OK;
8877 else {
8878 Tcl_SetResult(interp, "Key/Function pair not found "
8879 "in binding list.\n", NULL);
8880 return TCL_ERROR;
8881 }
8882 }
8883 }
8884 }
8885 result = add_vbinding(window, keywstate, func, value);
8886 if (result == 1) {
8887 Tcl_SetResult(interp, "Key is already bound to a command.\n", NULL);
8888 return (result);
8889 }
8890 return (result == TCL_OK) ? XcTagCallback(interp, objc, objv) : result;
8891 }
8892
8893 /*----------------------------------------------------------------------*/
8894
8895 int xctcl_font(ClientData clientData, Tcl_Interp *interp,
8896 int objc, Tcl_Obj *CONST objv[])
8897 {
8898 char *fontname;
8899 int result;
8900
8901 /* font name */
8902 if (objc != 2) {
8903 Tcl_WrongNumArgs(interp, 1, objv, "fontname");
8904 return TCL_ERROR;
8905 }
8906 fontname = Tcl_GetString(objv[1]);
8907
8908 /* Allow overrides of the default font loading mechanism */
8909 if (!strcmp(fontname, "override")) {
8910 flags |= FONTOVERRIDE;
8911 return TCL_OK;
8912 }
8913
8914 /* If we need to load the default font "Helvetica" because no fonts */
8915 /* have been loaded yet, then we call this function twice, so that */
8916 /* the command tag callback gets applied both times. */
8917
8918 if (!(flags & FONTOVERRIDE)) {
8919 flags |= FONTOVERRIDE;
8920 xctcl_font(clientData, interp, objc, objv);
8921 loadfontfile("Helvetica");
8922 }
8923 result = loadfontfile((char *)fontname);
8924 if (result >= 1) {
8925 Tcl_SetObjResult(interp, Tcl_NewStringObj(fonts[fontcount - 1].family,
8926 strlen(fonts[fontcount - 1].family)));
8927 }
8928 switch (result) {
8929 case 1:
8930 return XcTagCallback(interp, objc, objv);
8931 case 0:
8932 return TCL_OK;
8933 case -1:
8934 return TCL_ERROR;
8935 }
8936 return TCL_ERROR; /* (jdk) */
8937 }
8938
8939 /*----------------------------------------------------------------------*/
8940 /* Set the X11 cursor to one of those defined in the XCircuit cursor */
8941 /* set (cursors.h) */
8942 /*----------------------------------------------------------------------*/
8943
8944 int xctcl_cursor(ClientData clientData, Tcl_Interp *interp,
8945 int objc, Tcl_Obj *CONST objv[])
8946 {
8947 int idx, result;
8948
8949 static char *cursNames[] = {
8950 "arrow", "cross", "scissors", "copy", "rotate", "edit",
8951 "text", "circle", "question", "wait", "hand", NULL
8952 };
8953
8954 if (!areawin) return TCL_ERROR;
8955
8956 /* cursor name */
8957 if (objc != 2) {
8958 Tcl_WrongNumArgs(interp, 1, objv, "cursor name");
8959 return TCL_ERROR;
8960 }
8961 if ((result = Tcl_GetIndexFromObj(interp, objv[1],
8962 (CONST84 char **)cursNames,
8963 "cursor name", 0, &idx)) != TCL_OK)
8964 return result;
8965
8966 XDefineCursor(dpy, areawin->window, appcursors[idx]);
8967 areawin->defaultcursor = &appcursors[idx];
8968 return XcTagCallback(interp, objc, objv);
8969 }
8970
8971 /*----------------------------------------------------------------------*/
8972
8973 int xctcl_filerecover(ClientData clientData, Tcl_Interp *interp,
8974 int objc, Tcl_Obj *CONST objv[])
8975 {
8976 if (objc != 1) {
8977 Tcl_WrongNumArgs(interp, 1, objv, "(no arguments)");
8978 return TCL_ERROR;
8979 }
8980 crashrecover();
8981 return XcTagCallback(interp, objc, objv);
8982 }
8983
8984 /*----------------------------------------------------------------------*/
8985 /* Replace the functions of the simple rcfile.c interpreter. */
8986 /*----------------------------------------------------------------------*/
8987
8988 /*----------------------------------------------------------------------*/
8989 /* Execute a single command from a script or from the command line */
8990 /*----------------------------------------------------------------------*/
8991
8992 short execcommand(short pflags, char *cmdptr)
8993 {
8994 flags = pflags;
8995 Tcl_Eval(xcinterp, cmdptr);
8996 refresh(NULL, NULL, NULL);
8997 return flags;
8998 }
8999
9000 /*----------------------------------------------------------------------*/
9001 /* Load the default script (like execscript() but don't allow recursive */
9002 /* loading of the startup script) */
9003 /*----------------------------------------------------------------------*/
9004
9005 int defaultscript()
9006 {
9007 FILE *fd;
9008 char *tmp_s = getenv((const char *)"XCIRCUIT_SRC_DIR");
9009 int result;
9010
9011 flags = LIBOVERRIDE | LIBLOADED | FONTOVERRIDE;
9012
9013 if (!tmp_s) tmp_s = SCRIPTS_DIR;
9014 sprintf(_STR2, "%s/%s", tmp_s, STARTUP_FILE);
9015
9016 if ((fd = fopen(_STR2, "r")) == NULL) {
9017 sprintf(_STR2, "%s/%s", SCRIPTS_DIR, STARTUP_FILE);
9018 if ((fd = fopen(_STR2, "r")) == NULL) {
9019 sprintf(_STR2, "%s/tcl/%s", SCRIPTS_DIR, STARTUP_FILE);
9020 if ((fd = fopen(_STR2, "r")) == NULL) {
9021 Wprintf("Failed to open startup script \"%s\"\n", STARTUP_FILE);
9022 return TCL_ERROR;
9023 }
9024 }
9025 }
9026 fclose(fd);
9027 result = Tcl_EvalFile(xcinterp, _STR2);
9028 return result;
9029 }
9030
9031 /*----------------------------------------------------------------------*/
9032 /* Execute a script */
9033 /*----------------------------------------------------------------------*/
9034
9035 void execscript()
9036 {
9037 FILE *fd;
9038
9039 flags = 0;
9040
9041 xc_tilde_expand(_STR2, 249);
9042 if ((fd = fopen(_STR2, "r")) != NULL) {
9043 fclose(fd);
9044 Tcl_EvalFile(xcinterp, _STR2);
9045 refresh(NULL, NULL, NULL);
9046 }
9047 else {
9048 Wprintf("Failed to open script file \"%s\"\n", _STR2);
9049 }
9050 }
9051
9052 /*----------------------------------------------------------------------*/
9053 /* Evaluate an expression from a parameter and return the result as a */
9054 /* Tcl object. The actual return value (TCL_OK, TCL_ERROR) is stored */
9055 /* in pointer "eval_status", if it is non-NULL. */
9056 /*----------------------------------------------------------------------*/
9057
9058 Tcl_Obj *evaluate_raw(objectptr thisobj, oparamptr ops, objinstptr pinst,
9059 int *eval_status)
9060 {
9061 Tcl_SavedResult state;
9062 Tcl_Obj *robj;
9063 int status;
9064 char *exprptr, *pptr, *pkey, *pnext;
9065
9066 /* Sanity check */
9067 if (ops->type != XC_EXPR) return NULL;
9068 exprptr = ops->parameter.expr;
9069 pnext = exprptr;
9070 if (pnext == NULL) return NULL;
9071
9072 /* Check for "@<parameter>" notation and substitute parameter values */
9073 while ((pptr = strchr(pnext, '@')) != NULL)
9074 {
9075 oparam temps;
9076 oparamptr ips;
9077 char psave, *promoted, *newexpr;
9078
9079 pptr++;
9080 for (pkey = pptr; *pkey && !isspace(*pkey); pkey++)
9081 if (*pkey == '{' || *pkey == '}' || *pkey == '[' || *pkey == ']' ||
9082 *pkey == '(' || *pkey == ')' || *pkey == ',')
9083 break;
9084
9085 if (pkey > pptr) {
9086 psave = *pkey;
9087 *pkey = '\0';
9088 if (pinst)
9089 ips = find_param(pinst, pptr);
9090 else
9091 ips = match_param(thisobj, pptr);
9092 if (ips == ops) {
9093 /* Avoid infinite recursion by treating a reference */
9094 /* to oneself as plain text. */
9095 ips = NULL;
9096 }
9097 if ((ips == NULL) && !strncmp(pptr, "p_", 2)) {
9098 ips = &temps;
9099 if (!strcmp(pptr + 2, "rotation")) {
9100 temps.type = XC_FLOAT;
9101 temps.parameter.fvalue = pinst ? pinst->rotation : 0;
9102 }
9103 else if (!strcmp(pptr + 2, "xposition")) {
9104 temps.type = XC_INT;
9105 temps.parameter.ivalue = pinst ? pinst->position.x : 0;
9106 }
9107 else if (!strcmp(pptr + 2, "yposition")) {
9108 temps.type = XC_INT;
9109 temps.parameter.ivalue = pinst ? pinst->position.y : 0;
9110 }
9111 else if (!strcmp(pptr + 2, "scale")) {
9112 temps.type = XC_FLOAT;
9113 temps.parameter.fvalue = pinst ? pinst->scale : 1.0;
9114 }
9115 else if (!strcmp(pptr + 2, "color")) {
9116 temps.type = XC_INT;
9117 temps.parameter.ivalue = pinst ? pinst->color : DEFAULTCOLOR;
9118 }
9119 else if (!strcmp(pptr + 2, "top_xposition")) {
9120 temps.type = XC_INT;
9121 UTopDrawingOffset(&temps.parameter.ivalue, NULL);
9122 }
9123 else if (!strcmp(pptr + 2, "top_yposition")) {
9124 temps.type = XC_INT;
9125 UTopDrawingOffset(NULL, &temps.parameter.ivalue);
9126 }
9127 else if (!strcmp(pptr + 2, "top_rotation")) {
9128 temps.type = XC_FLOAT;
9129 temps.parameter.fvalue = UTopRotation();
9130 }
9131 else if (!strcmp(pptr + 2, "top_scale")) {
9132 temps.type = XC_FLOAT;
9133 temps.parameter.fvalue = UTopDrawingScale();
9134 }
9135 else
9136 ips = NULL;
9137 }
9138 *pkey = psave;
9139 if (ips != NULL) {
9140 switch (ips->type) {
9141 case XC_INT:
9142 promoted = malloc(12);
9143 snprintf(promoted, 12, "%d", ips->parameter.ivalue);
9144 break;
9145 case XC_FLOAT:
9146 promoted = malloc(12);
9147 snprintf(promoted, 12, "%g", ips->parameter.fvalue);
9148 break;
9149 case XC_STRING:
9150 promoted = textprint(ips->parameter.string, pinst);
9151 break;
9152 case XC_EXPR:
9153 /* We really ought to prevent infinite loops here. . .*/
9154 promoted = evaluate_expr(thisobj, ips, pinst);
9155 break;
9156 }
9157 if (promoted == NULL) break;
9158 newexpr = (char *)malloc(1 + strlen(exprptr) +
9159 (max(strlen(promoted), strlen(pkey))));
9160 *(pptr - 1) = '\0';
9161 strcpy(newexpr, exprptr);
9162 *(pptr - 1) = '@';
9163 strcat(newexpr, promoted);
9164 pnext = newexpr + strlen(newexpr); /* For next search of '@' escape */
9165 strcat(newexpr, pkey);
9166 free(promoted);
9167 if (exprptr != ops->parameter.expr) free(exprptr);
9168 exprptr = newexpr;
9169 }
9170 else {
9171 /* Ignore the keyword and move to the end */
9172 pnext = pkey;
9173 }
9174 }
9175 }
9176
9177 /* Evaluate the expression in TCL */
9178
9179 Tcl_SaveResult(xcinterp, &state);
9180 status = Tcl_Eval(xcinterp, exprptr);
9181 robj = Tcl_GetObjResult(xcinterp);
9182 Tcl_IncrRefCount(robj);
9183 Tcl_RestoreResult(xcinterp, &state);
9184 if (eval_status) *eval_status = status;
9185 if (exprptr != ops->parameter.expr) free(exprptr);
9186 return robj;
9187 }
9188
9189 /*----------------------------------------------------------------------*/
9190 /* Evaluate an expression from a parameter and return the result as an */
9191 /* allocated string. */
9192 /*----------------------------------------------------------------------*/
9193
9194 char *evaluate_expr(objectptr thisobj, oparamptr ops, objinstptr pinst)
9195 {
9196 Tcl_Obj *robj;
9197 char *rexpr = NULL;
9198 int status, ip = 0;
9199 float fp = 0.0;
9200 stringpart *tmpptr, *promote = NULL;
9201 oparamptr ips = (pinst == NULL) ? NULL : match_instance_param(pinst, ops->key);
9202
9203 robj = evaluate_raw(thisobj, ops, pinst, &status);
9204 if (robj != NULL) {
9205 rexpr = strdup(Tcl_GetString(robj));
9206 Tcl_DecrRefCount(robj);
9207 }
9208
9209 if ((status == TCL_ERROR) && (ips != NULL)) {
9210 switch(ips->type) {
9211 case XC_STRING:
9212 rexpr = textprint(ips->parameter.string, pinst);
9213 break;
9214 case XC_FLOAT:
9215 fp = ips->parameter.fvalue;
9216 break;
9217 }
9218 }
9219
9220 /* If a TCL expression contains a three digit octal value \ooo */
9221 /* then the string returned by TclEval() can contain a */
9222 /* multi-byte UTF-8 character. */
9223 /* */
9224 /* This multi-byte character needs to be converted back to a */
9225 /* character that can be displayed. */
9226 /* */
9227 /* The following fix assumes that at most two bytes will */
9228 /* represent any converted character. In this case, the most */
9229 /* significant digit (octal) of the first byte will be 3, and */
9230 /* the most significant digit of the second byte will be 2. */
9231 /* */
9232 /* See: https://en.wikipedia.org/wiki/UTF-8 */
9233
9234 if ((rexpr != NULL) && ((status == TCL_RETURN) || (status == TCL_OK))) {
9235 u_char *strptr1 = rexpr;
9236 u_char *strptr2 = rexpr;
9237 while (*strptr1 != '\0') {
9238 if (*strptr1 >= 0300 && *(strptr1 + 1) >= 0200) {
9239 *strptr2 = ((*strptr1 & ~0300) << 6) | (*(strptr1 + 1) & 0077);
9240 strptr1 += 2;
9241 } else {
9242 *strptr2 = *strptr1;
9243 strptr1++;
9244 }
9245 strptr2++;
9246 }
9247 if (*strptr1 == '\0')
9248 *strptr2 = *strptr1;
9249 }
9250
9251 /* If an instance redefines an expression, don't preserve */
9252 /* the result. It is necessary in this case that the */
9253 /* expression does not reference objects during redisplay, */
9254 /* or else the correct result will not be written to the */
9255 /* output. */
9256
9257 if ((ips != NULL) && (ips->type == XC_EXPR))
9258 return rexpr;
9259
9260 /* Preserve the result in the object instance; this will be */
9261 /* used when writing the output or when the result cannot */
9262 /* be evaluated (see above). */
9263
9264 if ((rexpr != NULL) && (status == TCL_OK) && (pinst != NULL)) {
9265 switch (ops->which) {
9266 case P_SUBSTRING: case P_EXPRESSION:
9267 if (ips == NULL) {
9268 ips = make_new_parameter(ops->key);
9269 ips->which = ops->which;
9270 ips->type = XC_STRING;
9271 ips->next = pinst->params;
9272 pinst->params = ips;
9273 }
9274 else {
9275 free(ips->parameter.string);
9276 }
9277 /* Promote the expression result to an XCircuit string type */
9278 tmpptr = makesegment(&promote, NULL);
9279 tmpptr->type = TEXT_STRING;
9280 tmpptr = makesegment(&promote, NULL);
9281 tmpptr->type = PARAM_END;
9282 promote->data.string = strdup(rexpr);
9283 ips->parameter.string = promote;
9284 break;
9285
9286 case P_COLOR: /* must be integer, exact to 32 bits */
9287 if (ips == NULL) {
9288 ips = make_new_parameter(ops->key);
9289 ips->which = ops->which;
9290 ips->next = pinst->params;
9291 pinst->params = ips;
9292 }
9293 /* Promote the expression result to type float */
9294 if (rexpr != NULL) {
9295 if (sscanf(rexpr, "%i", &ip) == 1)
9296 ips->parameter.ivalue = ip;
9297 else
9298 ips->parameter.ivalue = 0;
9299 }
9300 else
9301 ips->parameter.ivalue = ip;
9302 ips->type = XC_INT;
9303 break;
9304
9305 default: /* all others convert to type float */
9306 if (ips == NULL) {
9307 ips = make_new_parameter(ops->key);
9308 ips->which = ops->which;
9309 ips->next = pinst->params;
9310 pinst->params = ips;
9311 }
9312 /* Promote the expression result to type float */
9313 if (rexpr != NULL) {
9314 if (sscanf(rexpr, "%g", &fp) == 1)
9315 ips->parameter.fvalue = fp;
9316 else
9317 ips->parameter.fvalue = 0.0;
9318 }
9319 else
9320 ips->parameter.fvalue = fp;
9321 ips->type = XC_FLOAT;
9322 break;
9323 }
9324 }
9325 return rexpr;
9326 }
9327
9328 /*----------------------------------------------------------------------*/
9329 /* Execute the .xcircuitrc startup script */
9330 /*----------------------------------------------------------------------*/
9331
9332 int loadrcfile()
9333 {
9334 char *userdir = getenv((const char *)"HOME");
9335 FILE *fd;
9336 short i;
9337 int result = TCL_OK, result1 = TCL_OK;
9338
9339 /* Initialize flags */
9340
9341 flags = 0;
9342
9343 /* Try first in current directory, then look in user's home directory */
9344 /* First try looking for a file .xcircuitrc followed by a dash and */
9345 /* the program version; this allows backward compatibility of the rc */
9346 /* file in cases where a new version (e.g., 3 vs. 2) introduces */
9347 /* incompatible syntax. Thanks to Romano Giannetti for this */
9348 /* suggestion plus provided code. */
9349
9350 /* (names USER_RC_FILE and PROG_VERSION imported from Makefile) */
9351
9352 sprintf(_STR2, "%s-%s", USER_RC_FILE, PROG_VERSION);
9353 xc_tilde_expand(_STR2, 249);
9354 if ((fd = fopen(_STR2, "r")) == NULL) {
9355 /* Not found; check for the same in $HOME directory */
9356 if (userdir != NULL) {
9357 sprintf(_STR2, "%s/%s-%s", userdir, USER_RC_FILE, PROG_VERSION);
9358 if ((fd = fopen(_STR2, "r")) == NULL) {
9359 /* Not found again; check for rc file w/o version # in CWD */
9360 sprintf(_STR2, "%s", USER_RC_FILE);
9361 xc_tilde_expand(_STR2, 249);
9362 if ((fd = fopen(_STR2, "r")) == NULL) {
9363 /* last try: plain USER_RC_FILE in $HOME */
9364 sprintf(_STR2, "%s/%s", userdir, USER_RC_FILE);
9365 fd = fopen(_STR2, "r");
9366 }
9367 }
9368 }
9369 }
9370 if (fd != NULL) {
9371 fclose(fd);
9372 result = Tcl_EvalFile(xcinterp, _STR2);
9373 if (result != TCL_OK) {
9374 Fprintf(stderr, "Encountered error in startup file.");
9375 Fprintf(stderr, "%s\n", Tcl_GetStringResult(xcinterp));
9376 Fprintf(stderr, "Running default startup script instead.\n");
9377 }
9378 }
9379
9380 /* Add the default font if not loaded already */
9381
9382 if (!(flags & FONTOVERRIDE)) {
9383 loadfontfile("Helvetica");
9384 if (areawin->psfont == -1)
9385 for (i = 0; i < fontcount; i++)
9386 if (!strcmp(fonts[i].psname, "Helvetica")) {
9387 areawin->psfont = i;
9388 break;
9389 }
9390 }
9391 if (areawin->psfont == -1) areawin->psfont = 0;
9392
9393 setdefaultfontmarks();
9394
9395 /* arrange the loaded libraries */
9396
9397 if ((result != TCL_OK) || !(flags & (LIBOVERRIDE | LIBLOADED))) {
9398 result1 = defaultscript();
9399 }
9400
9401 /* Add the default colors */
9402
9403 if (!(flags & COLOROVERRIDE)) {
9404 addnewcolorentry(xc_alloccolor("Gray40"));
9405 addnewcolorentry(xc_alloccolor("Gray60"));
9406 addnewcolorentry(xc_alloccolor("Gray80"));
9407 addnewcolorentry(xc_alloccolor("Gray90"));
9408 addnewcolorentry(xc_alloccolor("Red"));
9409 addnewcolorentry(xc_alloccolor("Blue"));
9410 addnewcolorentry(xc_alloccolor("Green2"));
9411 addnewcolorentry(xc_alloccolor("Yellow"));
9412 addnewcolorentry(xc_alloccolor("Purple"));
9413 addnewcolorentry(xc_alloccolor("SteelBlue2"));
9414 addnewcolorentry(xc_alloccolor("Red3"));
9415 addnewcolorentry(xc_alloccolor("Tan"));
9416 addnewcolorentry(xc_alloccolor("Brown"));
9417 addnewcolorentry(xc_alloccolor("#d20adc"));
9418 addnewcolorentry(xc_alloccolor("Pink"));
9419 }
9420
9421 if ((result != TCL_OK) || !(flags & KEYOVERRIDE)) {
9422 default_keybindings();
9423 }
9424 return (result1 != TCL_OK) ? result1 : result;
9425 }
9426
9427 /*----------------------------------------------------------------------*/
9428 /* Alternative button handler for use with Tk "bind" */
9429 /*----------------------------------------------------------------------*/
9430
9431 int xctcl_standardaction(ClientData clientData,
9432 Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])
9433 {
9434 int idx, result, knum, kstate;
9435 XKeyEvent kevent;
9436 static char *updown[] = {"up", "down", NULL};
9437
9438 if ((objc != 3) && (objc != 4)) goto badargs;
9439
9440 if ((result = Tcl_GetIntFromObj(interp, objv[1], &knum)) != TCL_OK)
9441 goto badargs;
9442
9443 if ((result = Tcl_GetIndexFromObj(interp, objv[2],
9444 (CONST84 char **)updown, "direction", 0, &idx)) != TCL_OK)
9445 goto badargs;
9446
9447 if (objc == 4) {
9448 if ((result = Tcl_GetIntFromObj(interp, objv[3], &kstate)) != TCL_OK)
9449 goto badargs;
9450 }
9451 else
9452 kstate = 0;
9453
9454 make_new_event(&kevent);
9455 kevent.state = kstate;
9456 kevent.keycode = 0;
9457
9458 if (idx == 0)
9459 kevent.type = KeyRelease;
9460 else
9461 kevent.type = KeyPress;
9462
9463 switch (knum) {
9464 case 1:
9465 kevent.state |= Button1Mask;
9466 break;
9467 case 2:
9468 kevent.state |= Button2Mask;
9469 break;
9470 case 3:
9471 kevent.state |= Button3Mask;
9472 break;
9473 case 4:
9474 kevent.state |= Button4Mask;
9475 break;
9476 case 5:
9477 kevent.state |= Button5Mask;
9478 break;
9479 default:
9480 kevent.keycode = knum;
9481 break;
9482 }
9483 #ifdef _MSC_VER
9484 if (kevent.state & Mod1Mask) {
9485 kevent.state &= ~Mod1Mask;
9486 }
9487 if (kevent.state & (AnyModifier<<2)) {
9488 kevent.state &= ~(AnyModifier<<2);
9489 kevent.state |= Mod1Mask;
9490 }
9491 #endif
9492 keyhandler((xcWidget)NULL, (caddr_t)NULL, &kevent);
9493 return TCL_OK;
9494
9495 badargs:
9496 Tcl_SetResult(interp, "Usage: standardaction <button_num> up|down [<keystate>]\n"
9497 "or standardaction <keycode> up|down [<keystate>]\n", NULL);
9498 return TCL_ERROR;
9499 }
9500
9501 /*----------------------------------------------------------------------*/
9502 /* Action handler for use with Tk "bind" */
9503 /* This dispatches events based on specific named actions that xcircuit */
9504 /* knows about, rather than by named key. This bypasses xcircuit's */
9505 /* key bindings. */
9506 /*----------------------------------------------------------------------*/
9507
9508 int xctcl_action(ClientData clientData,
9509 Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])
9510 {
9511 short value = 0;
9512 int function, result, ival;
9513 XPoint newpos, wpoint;
9514
9515 if (objc >= 2 && objc <= 4) {
9516 function = string_to_func(Tcl_GetString(objv[1]), &value);
9517 if (objc >= 3) {
9518 result = (short)Tcl_GetIntFromObj(interp, objv[2], &ival);
9519 if (result == TCL_ERROR) return TCL_ERROR;
9520 value = (short)ival;
9521 }
9522
9523 newpos = UGetCursorPos();
9524 user_to_window(newpos, &wpoint);
9525
9526 result = compatible_function(function);
9527 if (result == -1)
9528 Tcl_SetResult(interp, "Action not allowed\n", NULL);
9529
9530 result = functiondispatch(function, value, wpoint.x, wpoint.y);
9531 if (result == -1)
9532 Tcl_SetResult(interp, "Action not handled\n", NULL);
9533 }
9534 else {
9535 Tcl_SetResult(interp, "Usage: action <action_name> [<value>]\n", NULL);
9536 return TCL_ERROR;
9537 }
9538 return XcTagCallback(interp, objc, objv);
9539 }
9540
9541
9542 /*----------------------------------------------------------------------*/
9543 /* Argument-converting wrappers from Tk callback to Xt callback format */
9544 /*----------------------------------------------------------------------*/
9545
9546 void xctk_drawarea(ClientData clientData, XEvent *eventPtr)
9547 {
9548 Tcl_ServiceAll();
9549 if (areawin->topinstance != NULL)
9550 drawarea(areawin->area, (caddr_t)clientData, (caddr_t)NULL);
9551 }
9552
9553 /*----------------------------------------------------------------------*/
9554
9555 void xctk_resizearea(ClientData clientData, XEvent *eventPtr)
9556 {
9557 resizearea(areawin->area, (caddr_t)clientData, (caddr_t)NULL);
9558 /* Callback to function "arrangetoolbar" */
9559 Tcl_Eval(xcinterp, "catch {xcircuit::arrangetoolbar $XCOps(focus)}");
9560 }
9561
9562 /*----------------------------------------------------------------------*/
9563 /* Because Tk doesn't filter MotionEvent events based on context, we */
9564 /* have to filter the context here. */
9565 /*----------------------------------------------------------------------*/
9566
9567 void xctk_panhbar(ClientData clientData, XEvent *eventPtr)
9568 {
9569 XMotionEvent *mevent = (XMotionEvent *)eventPtr;
9570 u_int state = mevent->state;
9571 if (state & (Button1Mask | Button2Mask))
9572 panhbar(areawin->scrollbarh, (caddr_t)clientData, (XButtonEvent *)eventPtr);
9573 }
9574
9575 /*----------------------------------------------------------------------*/
9576
9577 void xctk_panvbar(ClientData clientData, XEvent *eventPtr)
9578 {
9579 XMotionEvent *mevent = (XMotionEvent *)eventPtr;
9580 u_int state = mevent->state;
9581 if (state & (Button1Mask | Button2Mask))
9582 panvbar(areawin->scrollbarv, (caddr_t)clientData, (XButtonEvent *)eventPtr);
9583 }
9584
9585 /*----------------------------------------------------------------------*/
9586
9587 void xctk_drawhbar(ClientData clientData, XEvent *eventPtr)
9588 {
9589 if (areawin->topinstance)
9590 drawhbar(areawin->scrollbarh, (caddr_t)clientData, (caddr_t)NULL);
9591 }
9592
9593 /*----------------------------------------------------------------------*/
9594
9595 void xctk_drawvbar(ClientData clientData, XEvent *eventPtr)
9596 {
9597 if (areawin->topinstance)
9598 drawvbar(areawin->scrollbarv, (caddr_t)clientData, (caddr_t)NULL);
9599 }
9600
9601 /*----------------------------------------------------------------------*/
9602
9603 void xctk_endhbar(ClientData clientData, XEvent *eventPtr)
9604 {
9605 if (areawin->topinstance)
9606 endhbar(areawin->scrollbarh, (caddr_t)clientData, (XButtonEvent *)eventPtr);
9607 }
9608
9609 /*----------------------------------------------------------------------*/
9610
9611 void xctk_endvbar(ClientData clientData, XEvent *eventPtr)
9612 {
9613 if (areawin->topinstance)
9614 endvbar(areawin->scrollbarv, (caddr_t)clientData, (XButtonEvent *)eventPtr);
9615 }
9616
9617 /*----------------------------------------------------------------------*/
9618
9619 void xctk_zoomview(ClientData clientData, XEvent *eventPtr)
9620 {
9621 zoomview((xcWidget)NULL, (caddr_t)clientData, (caddr_t)NULL);
9622 }
9623
9624 /*----------------------------------------------------------------------*/
9625
9626 void xctk_swapschem(ClientData clientData, XEvent *eventPtr)
9627 {
9628 swapschem((int)((pointertype)clientData), -1, NULL);
9629 }
9630
9631 /*----------------------------------------------------------------------*/
9632
9633 void xctk_drag(ClientData clientData, XEvent *eventPtr)
9634 {
9635 XButtonEvent *b_event = (XButtonEvent *)eventPtr;
9636
9637 drag((int)b_event->x, (int)b_event->y);
9638 flusharea();
9639 #ifdef HAVE_CAIRO
9640 if (areawin->redraw_needed)
9641 drawarea(NULL, NULL, NULL);
9642 #endif /* HAVE_CAIRO */
9643 }
9644
9645 /*----------------------------------------------------------------------*/
9646 /* This really should be set up so that the "okay" button command tcl */
9647 /* procedure does the job of lookdirectory(). */
9648 /*----------------------------------------------------------------------*/
9649
9650 void xctk_fileselect(ClientData clientData, XEvent *eventPtr)
9651 {
9652 XButtonEvent *beventPtr = (XButtonEvent *)eventPtr;
9653 popupstruct *listp = (popupstruct *)clientData;
9654 char curentry[150];
9655
9656 if (beventPtr->button == Button2) {
9657 Tcl_Eval(xcinterp, ".filelist.textent.txt get");
9658 sprintf(curentry, "%.149s", (char *)Tcl_GetStringResult(xcinterp));
9659
9660 if (strlen(curentry) > 0) {
9661 if (lookdirectory(curentry, 149))
9662 newfilelist(listp->filew, listp);
9663 else
9664 Tcl_Eval(xcinterp, ".filelist.bbar.okay invoke");
9665 }
9666 }
9667 else if (beventPtr->button == Button4) { /* scroll wheel binding */
9668 flstart--;
9669 showlscroll(listp->scroll, NULL, NULL);
9670 listfiles(listp->filew, listp, NULL);
9671 }
9672 else if (beventPtr->button == Button5) { /* scroll wheel binding */
9673 flstart++;
9674 showlscroll(listp->scroll, NULL, NULL);
9675 listfiles(listp->filew, listp, NULL);
9676 }
9677 else
9678 fileselect(listp->filew, listp, beventPtr);
9679 }
9680
9681 /*----------------------------------------------------------------------*/
9682
9683 void xctk_listfiles(ClientData clientData, XEvent *eventPtr)
9684 {
9685 popupstruct *listp = (popupstruct *)clientData;
9686 char *filter;
9687
9688 Tcl_Eval(xcinterp, ".filelist.listwin.win cget -data");
9689 filter = (char *)Tcl_GetStringResult(xcinterp);
9690
9691 if (filter != NULL) {
9692 if ((listp->filter == NULL) || (strcmp(filter, listp->filter))) {
9693 if (listp->filter != NULL)
9694 free(listp->filter);
9695 listp->filter = strdup(filter);
9696 newfilelist(listp->filew, listp);
9697 }
9698 else
9699 listfiles(listp->filew, listp, NULL);
9700 }
9701 else {
9702 if (listp->filter != NULL) {
9703 free(listp->filter);
9704 listp->filter = NULL;
9705 }
9706 listfiles(listp->filew, listp, NULL);
9707 }
9708 }
9709
9710 /*----------------------------------------------------------------------*/
9711
9712 void xctk_startfiletrack(ClientData clientData, XEvent *eventPtr)
9713 {
9714 startfiletrack((Tk_Window)clientData, NULL, (XCrossingEvent *)eventPtr);
9715 }
9716
9717 /*----------------------------------------------------------------------*/
9718
9719 void xctk_endfiletrack(ClientData clientData, XEvent *eventPtr)
9720 {
9721 endfiletrack((Tk_Window)clientData, NULL, (XCrossingEvent *)eventPtr);
9722 }
9723
9724 /*----------------------------------------------------------------------*/
9725
9726 void xctk_dragfilebox(ClientData clientData, XEvent *eventPtr)
9727 {
9728 dragfilebox((Tk_Window)clientData, NULL, (XMotionEvent *)eventPtr);
9729 }
9730
9731 /*----------------------------------------------------------------------*/
9732
9733 void xctk_draglscroll(ClientData clientData, XEvent *eventPtr)
9734 {
9735 popupstruct *listp = (popupstruct *)clientData;
9736 XMotionEvent *mevent = (XMotionEvent *)eventPtr;
9737 u_int state = mevent->state;
9738
9739 if (state & (Button1Mask | Button2Mask))
9740 draglscroll(listp->scroll, listp, (XButtonEvent *)eventPtr);
9741 }
9742
9743 /*----------------------------------------------------------------------*/
9744
9745 void xctk_showlscroll(ClientData clientData, XEvent *eventPtr)
9746 {
9747 showlscroll((Tk_Window)clientData, NULL, NULL);
9748 }
9749
9750 /*----------------------------------------------------------------------*/
9751 /* Build or rebuild the database of colors, fonts, and other settings */
9752 /* from the Tk option settings. */
9753 /*----------------------------------------------------------------------*/
9754
9755 void build_app_database(Tk_Window tkwind)
9756 {
9757 Tk_Uid xcuid;
9758
9759 /*--------------------------*/
9760 /* Build the color database */
9761 /*--------------------------*/
9762
9763 if ((xcuid = Tk_GetOption(tkwind, "globalpincolor", "Color")) == NULL)
9764 xcuid = "Orange2";
9765 appdata.globalcolor = xc_alloccolor((char *)xcuid);
9766 if ((xcuid = Tk_GetOption(tkwind, "localpincolor", "Color")) == NULL)
9767 xcuid = "Red";
9768 appdata.localcolor = xc_alloccolor((char *)xcuid);
9769 if ((xcuid = Tk_GetOption(tkwind, "infolabelcolor", "Color")) == NULL)
9770 xcuid = "SeaGreen";
9771 appdata.infocolor = xc_alloccolor((char *)xcuid);
9772 if ((xcuid = Tk_GetOption(tkwind, "ratsnestcolor", "Color")) == NULL)
9773 xcuid = "tan4";
9774 appdata.ratsnestcolor = xc_alloccolor((char *)xcuid);
9775
9776 if ((xcuid = Tk_GetOption(tkwind, "bboxcolor", "Color")) == NULL)
9777 xcuid = "greenyellow";
9778 appdata.bboxpix = xc_alloccolor((char *)xcuid);
9779
9780 if ((xcuid = Tk_GetOption(tkwind, "fixedbboxcolor", "Color")) == NULL)
9781 xcuid = "pink";
9782 appdata.fixedbboxpix = xc_alloccolor((char *)xcuid);
9783
9784 if ((xcuid = Tk_GetOption(tkwind, "clipcolor", "Color")) == NULL)
9785 xcuid = "powderblue";
9786 appdata.clipcolor = xc_alloccolor((char *)xcuid);
9787
9788 if ((xcuid = Tk_GetOption(tkwind, "paramcolor", "Color")) == NULL)
9789 xcuid = "Plum3";
9790 appdata.parampix = xc_alloccolor((char *)xcuid);
9791 if ((xcuid = Tk_GetOption(tkwind, "auxiliarycolor", "Color")) == NULL)
9792 xcuid = "Green3";
9793 appdata.auxpix = xc_alloccolor((char *)xcuid);
9794 if ((xcuid = Tk_GetOption(tkwind, "axescolor", "Color")) == NULL)
9795 xcuid = "Antique White";
9796 appdata.axespix = xc_alloccolor((char *)xcuid);
9797 if ((xcuid = Tk_GetOption(tkwind, "filtercolor", "Color")) == NULL)
9798 xcuid = "SteelBlue3";
9799 appdata.filterpix = xc_alloccolor((char *)xcuid);
9800 if ((xcuid = Tk_GetOption(tkwind, "selectcolor", "Color")) == NULL)
9801 xcuid = "Gold3";
9802 appdata.selectpix = xc_alloccolor((char *)xcuid);
9803 if ((xcuid = Tk_GetOption(tkwind, "snapcolor", "Color")) == NULL)
9804 xcuid = "Red";
9805 appdata.snappix = xc_alloccolor((char *)xcuid);
9806 if ((xcuid = Tk_GetOption(tkwind, "gridcolor", "Color")) == NULL)
9807 xcuid = "Gray95";
9808 appdata.gridpix = xc_alloccolor((char *)xcuid);
9809 if ((xcuid = Tk_GetOption(tkwind, "pagebackground", "Color")) == NULL)
9810 xcuid = "White";
9811 appdata.bg = xc_alloccolor((char *)xcuid);
9812 if ((xcuid = Tk_GetOption(tkwind, "pageforeground", "Color")) == NULL)
9813 xcuid = "Black";
9814 appdata.fg = xc_alloccolor((char *)xcuid);
9815
9816 if ((xcuid = Tk_GetOption(tkwind, "paramcolor2", "Color")) == NULL)
9817 xcuid = "Plum3";
9818 appdata.parampix2 = xc_alloccolor((char *)xcuid);
9819 if ((xcuid = Tk_GetOption(tkwind, "auxiliarycolor2", "Color")) == NULL)
9820 xcuid = "Green";
9821 appdata.auxpix2 = xc_alloccolor((char *)xcuid);
9822 if ((xcuid = Tk_GetOption(tkwind, "selectcolor2", "Color")) == NULL)
9823 xcuid = "Gold";
9824 appdata.selectpix2 = xc_alloccolor((char *)xcuid);
9825 if ((xcuid = Tk_GetOption(tkwind, "filtercolor2", "Color")) == NULL)
9826 xcuid = "SteelBlue1";
9827 appdata.gridpix2 = xc_alloccolor((char *)xcuid);
9828 if ((xcuid = Tk_GetOption(tkwind, "snapcolor2", "Color")) == NULL)
9829 xcuid = "Red";
9830 appdata.snappix2 = xc_alloccolor((char *)xcuid);
9831 if ((xcuid = Tk_GetOption(tkwind, "axescolor2", "Color")) == NULL)
9832 xcuid = "NavajoWhite4";
9833 appdata.axespix2 = xc_alloccolor((char *)xcuid);
9834 if ((xcuid = Tk_GetOption(tkwind, "background2", "Color")) == NULL)
9835 xcuid = "DarkSlateGray";
9836 appdata.bg2 = xc_alloccolor((char *)xcuid);
9837 if ((xcuid = Tk_GetOption(tkwind, "foreground2", "Color")) == NULL)
9838 xcuid = "White";
9839 appdata.fg2 = xc_alloccolor((char *)xcuid);
9840 if ((xcuid = Tk_GetOption(tkwind, "barcolor", "Color")) == NULL)
9841 xcuid = "Tan";
9842 appdata.barpix = xc_alloccolor((char *)xcuid);
9843
9844 /* These are GUI colors---unused by Tcl */
9845 appdata.buttonpix = xc_alloccolor("Gray85");
9846 appdata.buttonpix2 = xc_alloccolor("Gray50");
9847
9848 /* Get some default fonts (Should be using Tk calls here. . . ) */
9849
9850 if ((xcuid = Tk_GetOption(tkwind, "filelistfont", "Font")) == NULL)
9851 xcuid = "-*-helvetica-medium-r-normal--14-*";
9852 appdata.filefont = XLoadQueryFont(dpy, (char *)xcuid);
9853
9854 if (appdata.filefont == NULL)
9855 {
9856 appdata.filefont = XLoadQueryFont(dpy, "-*-*-medium-r-normal--14-*");
9857 if (appdata.filefont == NULL)
9858 appdata.filefont = XLoadQueryFont(dpy, "-*-*-*-*-*--*-*");
9859 if (appdata.filefont == NULL)
9860 appdata.filefont = XLoadQueryFont(dpy, "*");
9861 if (appdata.filefont == NULL) {
9862 Fprintf(stderr, "Fatal error: No X11 fonts found.\n");
9863 }
9864 }
9865
9866 /* Other defaults */
9867
9868 if ((xcuid = Tk_GetOption(tkwind, "timeout", "TimeOut")) == NULL)
9869 xcuid = "10";
9870 appdata.timeout = atoi((char *)xcuid);
9871 }
9872
9873 /*--------------------------------------------------------------*/
9874 /* GUI Initialization under Tk */
9875 /* First argument is the Tk path name of the drawing window. */
9876 /* This function should be called for each new window created. */
9877 /*--------------------------------------------------------------*/
9878
9879 XCWindowData *GUI_init(int objc, Tcl_Obj *CONST objv[])
9880 {
9881 Tk_Window tkwind, tktop, tkdraw, tksb;
9882 Tk_Window wsymb, wschema, corner;
9883 int i, locobjc, done = 1;
9884 XGCValues values;
9885 Window win;
9886 popupstruct *fileliststruct;
9887 char *xctopwin, *xcdrawwin;
9888 char winpath[512];
9889 XCWindowData *newwin;
9890
9891 tktop = Tk_MainWindow(xcinterp);
9892 if (tktop == (Tk_Window)NULL) {
9893 Fprintf(stderr, "No Top-Level Tk window available. . .\n");
9894
9895 /* No top level window, assuming batch mode. To get */
9896 /* access to font information requires that cairo be set */
9897 /* up with a surface, even if it is not an xlib target. */
9898
9899 newwin = create_new_window();
9900 newwin->area = NULL;
9901 newwin->scrollbarv = NULL;
9902 newwin->scrollbarh = NULL;
9903 newwin->width = 100;
9904 newwin->height = 100;
9905
9906 #ifdef HAVE_CAIRO
9907 newwin->surface = cairo_image_surface_create(CAIRO_FORMAT_RGB24,
9908 newwin->width, newwin->height);
9909 newwin->cr = cairo_create(newwin->surface);
9910 #endif /* !HAVE_CAIRO */
9911
9912 number_colors = NUMBER_OF_COLORS;
9913 colorlist = (colorindex *)malloc(NUMBER_OF_COLORS * sizeof(colorindex));
9914
9915 return newwin;
9916 }
9917
9918 /* Check if any parameter is a Tk window name */
9919
9920 locobjc = objc;
9921 while (locobjc > 0) {
9922 xctopwin = Tcl_GetString(objv[locobjc - 1]);
9923 tkwind = Tk_NameToWindow(xcinterp, xctopwin, tktop);
9924 if (tkwind != (Tk_Window)NULL)
9925 break;
9926 locobjc--;
9927 }
9928
9929 if (locobjc == 0) {
9930 /* Okay to have no GUI wrapper. However, if this is the case, */
9931 /* then the variable "XCOps(window)" must be set to the Tk path */
9932 /* name of the drawing window. */
9933
9934 xcdrawwin = (char *)Tcl_GetVar2(xcinterp, "XCOps", "window", 0);
9935 if (xcdrawwin == NULL) {
9936 Fprintf(stderr, "The Tk window hierarchy must be rooted at"
9937 " .xcircuit, or XCOps(top)");
9938 Fprintf(stderr, " must point to the hierarchy. If XCOps(top)"
9939 " is NULL, then XCOps(window) must");
9940 Fprintf(stderr, " point to the drawing window.\n");
9941 return NULL;
9942 }
9943 tkwind = Tk_NameToWindow(xcinterp, xcdrawwin, tktop);
9944 if (tkwind == NULL) {
9945 Fprintf(stderr, "Error: XCOps(window) is set but does not point to"
9946 " a valid Tk window.\n");
9947 return NULL;
9948 }
9949
9950 /* Create new window data structure */
9951 newwin = create_new_window();
9952 newwin->area = tkwind;
9953
9954 /* No GUI---GUI widget pointers need to be NULL'd */
9955 newwin->scrollbarv = NULL;
9956 newwin->scrollbarh = NULL;
9957 }
9958 else {
9959
9960 /* Expect a top-level window name passed as the first argument. */
9961 /* Having a fixed hierarchy is a total kludge and needs to be */
9962 /* rewritten. . . */
9963
9964 if (tkwind == NULL) {
9965 Fprintf(stderr, "Error: config init given a bad window name!\n");
9966 return NULL;
9967 }
9968 else {
9969 /* Make sure that this window does not already exist */
9970 XCWindowDataPtr searchwin;
9971 sprintf(winpath, "%s.mainframe.mainarea.drawing", xctopwin);
9972 tkdraw = Tk_NameToWindow(xcinterp, winpath, tktop);
9973 for (searchwin = xobjs.windowlist; searchwin != NULL; searchwin =
9974 searchwin->next) {
9975 if (searchwin->area == tkdraw) {
9976 Fprintf(stderr, "Error: window already exists!\n");
9977 return NULL;
9978 }
9979 }
9980 }
9981
9982 /* Create new window data structure and */
9983 /* fill in global variables from the Tk window values */
9984
9985 newwin = create_new_window();
9986 sprintf(winpath, "%s.mainframe.mainarea.sbleft", xctopwin);
9987 newwin->scrollbarv = Tk_NameToWindow(xcinterp, winpath, tktop);
9988 sprintf(winpath, "%s.mainframe.mainarea.sbbottom", xctopwin);
9989 newwin->scrollbarh = Tk_NameToWindow(xcinterp, winpath, tktop);
9990 sprintf(winpath, "%s.mainframe.mainarea.drawing", xctopwin);
9991 newwin->area = Tk_NameToWindow(xcinterp, winpath, tktop);
9992
9993 sprintf(winpath, "%s.mainframe.mainarea.corner", xctopwin);
9994 corner = Tk_NameToWindow(xcinterp, winpath, tktop);
9995
9996 sprintf(winpath, "%s.infobar.symb", xctopwin);
9997 wsymb = Tk_NameToWindow(xcinterp, winpath, tktop);
9998
9999 sprintf(winpath, "%s.infobar.schem", xctopwin);
10000 wschema = Tk_NameToWindow(xcinterp, winpath, tktop);
10001
10002 Tk_CreateEventHandler(newwin->scrollbarh, ButtonMotionMask,
10003 (Tk_EventProc *)xctk_panhbar, NULL);
10004 Tk_CreateEventHandler(newwin->scrollbarv, ButtonMotionMask,
10005 (Tk_EventProc *)xctk_panvbar, NULL);
10006 Tk_CreateEventHandler(newwin->scrollbarh, StructureNotifyMask | ExposureMask,
10007 (Tk_EventProc *)xctk_drawhbar, NULL);
10008 Tk_CreateEventHandler(newwin->scrollbarv, StructureNotifyMask | ExposureMask,
10009 (Tk_EventProc *)xctk_drawvbar, NULL);
10010 Tk_CreateEventHandler(newwin->scrollbarh, ButtonReleaseMask,
10011 (Tk_EventProc *)xctk_endhbar, NULL);
10012 Tk_CreateEventHandler(newwin->scrollbarv, ButtonReleaseMask,
10013 (Tk_EventProc *)xctk_endvbar, NULL);
10014
10015 Tk_CreateEventHandler(corner, ButtonPressMask,
10016 (Tk_EventProc *)xctk_zoomview, Number(1));
10017 Tk_CreateEventHandler(wsymb, ButtonPressMask,
10018 (Tk_EventProc *)xctk_swapschem, Number(0));
10019 Tk_CreateEventHandler(wschema, ButtonPressMask,
10020 (Tk_EventProc *)xctk_swapschem, Number(0));
10021
10022 /* Setup event handlers for the drawing area and scrollbars */
10023 /* There are purposely no callback functions for these windows---they are */
10024 /* defined as type "simple" to keep down the cruft, as I will define my */
10025 /* own event handlers. */
10026
10027 Tk_CreateEventHandler(newwin->area, StructureNotifyMask,
10028 (Tk_EventProc *)xctk_resizearea, NULL);
10029 Tk_CreateEventHandler(newwin->area, ExposureMask,
10030 (Tk_EventProc *)xctk_drawarea, NULL);
10031 }
10032
10033 if ((locobjc > 0) || !Tk_IsMapped(newwin->area)) {
10034
10035 /* This code copied from code for the "tkwait" command */
10036
10037 Tk_CreateEventHandler(newwin->area,
10038 VisibilityChangeMask|StructureNotifyMask,
10039 WaitVisibilityProc, (ClientData) &done);
10040 done = 0;
10041 }
10042
10043 /* Make sure the window is mapped */
10044
10045 Tk_MapWindow(tkwind);
10046 win = Tk_WindowId(tkwind);
10047 Tk_MapWindow(newwin->area);
10048
10049 if (!done) {
10050 while (!done) Tcl_DoOneEvent(0);
10051 Tk_DeleteEventHandler(newwin->area,
10052 VisibilityChangeMask|StructureNotifyMask,
10053 WaitVisibilityProc, (ClientData) &done);
10054 }
10055
10056 newwin->window = Tk_WindowId(newwin->area);
10057 newwin->width = Tk_Width(newwin->area);
10058 newwin->height = Tk_Height(newwin->area);
10059
10060 /* Things to set once only */
10061
10062 if (dpy == NULL) {
10063 dpy = Tk_Display(tkwind);
10064 cmap = Tk_Colormap(tkwind);
10065 // (The following may be required on some systems where
10066 // Tk will not report a valid colormap after Tk_MapWindow())
10067 // cmap = DefaultColormap(dpy, DefaultScreen(dpy));
10068
10069 /*------------------------------------------------------*/
10070 /* Handle different screen resolutions in a sane manner */
10071 /*------------------------------------------------------*/
10072
10073 screenDPI = getscreenDPI();
10074
10075 /*-------------------------*/
10076 /* Create stipple patterns */
10077 /*-------------------------*/
10078
10079 for (i = 0; i < STIPPLES; i++)
10080 STIPPLE[i] = XCreateBitmapFromData(dpy, win, STIPDATA[i], 4, 4);
10081
10082 /*----------------------------------------*/
10083 /* Allocate space for the basic color map */
10084 /*----------------------------------------*/
10085
10086 number_colors = NUMBER_OF_COLORS;
10087 colorlist = (colorindex *)malloc(NUMBER_OF_COLORS * sizeof(colorindex));
10088 areawin = newwin;
10089 build_app_database(tkwind);
10090 areawin = NULL;
10091
10092 /* Create the filelist window and its event handlers */
10093
10094 tksb = Tk_NameToWindow(xcinterp, ".filelist.listwin.sb", tktop);
10095 tkdraw = Tk_NameToWindow(xcinterp, ".filelist.listwin.win", tktop);
10096
10097 fileliststruct = (popupstruct *) malloc(sizeof(popupstruct));
10098 fileliststruct->popup = Tk_NameToWindow(xcinterp, ".filelist", tktop);
10099 fileliststruct->textw = Tk_NameToWindow(xcinterp, ".filelist.textent",
10100 fileliststruct->popup);
10101 fileliststruct->filew = tkdraw;
10102 fileliststruct->scroll = tksb;
10103 fileliststruct->setvalue = NULL;
10104 fileliststruct->filter = NULL;
10105
10106 if (tksb != NULL) {
10107 Tk_CreateEventHandler(tksb, ButtonMotionMask,
10108 (Tk_EventProc *)xctk_draglscroll, (ClientData)fileliststruct);
10109 Tk_CreateEventHandler(tksb, ExposureMask,
10110 (Tk_EventProc *)xctk_showlscroll, (ClientData)tksb);
10111 }
10112 if (tkdraw != NULL) {
10113 Tk_CreateEventHandler(tkdraw, ButtonPressMask,
10114 (Tk_EventProc *)xctk_fileselect, (ClientData)fileliststruct);
10115 Tk_CreateEventHandler(tkdraw, ExposureMask,
10116 (Tk_EventProc *)xctk_listfiles, (ClientData)fileliststruct);
10117 Tk_CreateEventHandler(tkdraw, EnterWindowMask,
10118 (Tk_EventProc *)xctk_startfiletrack, (ClientData)tkdraw);
10119 Tk_CreateEventHandler(tkdraw, LeaveWindowMask,
10120 (Tk_EventProc *)xctk_endfiletrack, (ClientData)tkdraw);
10121 }
10122 }
10123
10124 /*-------------------------------------------------------------------*/
10125 /* Generate the GC */
10126 /* Set "graphics_exposures" to False. Every XCopyArea function */
10127 /* copies from virtual memory (dbuf pixmap), which can never be */
10128 /* obscured. Otherwise, the server gets flooded with useless */
10129 /* NoExpose events. */
10130 /*-------------------------------------------------------------------*/
10131
10132 values.foreground = BlackPixel(dpy, DefaultScreen(dpy));
10133 values.background = WhitePixel(dpy, DefaultScreen(dpy));
10134 values.graphics_exposures = False;
10135 newwin->gc = XCreateGC(dpy, win, GCForeground | GCBackground
10136 | GCGraphicsExposures, &values);
10137
10138 #ifdef HAVE_CAIRO
10139 newwin->surface = cairo_xlib_surface_create(dpy, newwin->window,
10140 DefaultVisual(dpy, 0), newwin->width, newwin->height);
10141 newwin->cr = cairo_create(newwin->surface);
10142 #else /* HAVE_CAIRO */
10143 newwin->clipmask = XCreatePixmap(dpy, win, newwin->width,
10144 newwin->height, 1);
10145
10146 values.foreground = 0;
10147 values.background = 0;
10148 newwin->cmgc = XCreateGC(dpy, newwin->clipmask, GCForeground
10149 | GCBackground, &values);
10150 #endif /* HAVE_CAIRO */
10151
10152 XDefineCursor (dpy, win, *newwin->defaultcursor);
10153 return newwin;
10154 }
10155
10156 /*--------------------------------------*/
10157 /* Inline the main wrapper prodedure */
10158 /*--------------------------------------*/
10159
10160 int xctcl_start(ClientData clientData, Tcl_Interp *interp,
10161 int objc, Tcl_Obj *CONST objv[])
10162 {
10163 int result = TCL_OK;
10164 Boolean rcoverride = False;
10165 char *filearg = NULL;
10166 Tcl_Obj *cmdname = objv[0];
10167
10168 Fprintf(stdout, "Starting xcircuit under Tcl interpreter\n");
10169
10170 /* xcircuit initialization routines --- these assume that the */
10171 /* GUI has been created by the startup script; otherwise bad */
10172 /* things will probably occur. */
10173
10174 pre_initialize();
10175 areawin = GUI_init(--objc, ++objv);
10176 if (areawin == NULL) {
10177 /* Create new window data structure */
10178 areawin = create_new_window();
10179 areawin->area = NULL;
10180 areawin->scrollbarv = NULL;
10181 areawin->scrollbarh = NULL;
10182
10183 Tcl_SetResult(interp, "Invalid or missing top-level windowname"
10184 " given to start command, assuming batch mode.\n", NULL);
10185 }
10186 post_initialize();
10187
10188 ghostinit();
10189
10190 /* The Tcl version accepts some command-line arguments. Due */
10191 /* to the way ".wishrc" is processed, all arguments are */
10192 /* glommed into one Tcl (list) object, objv[1]. */
10193
10194 filearg = (char *)malloc(sizeof(char));
10195 *filearg = '\0';
10196
10197 if (objc == 2) {
10198 char **argv;
10199 int argc;
10200
10201 Tcl_SplitList(interp, Tcl_GetString(objv[1]), &argc,
10202 (CONST84 char ***)&argv);
10203 while (argc) {
10204 if (**argv == '-') {
10205 if (!strncmp(*argv, "-exec", 5)) {
10206 if (--argc > 0) {
10207 argv++;
10208 result = Tcl_EvalFile(interp, *argv);
10209 if (result != TCL_OK) {
10210 free(filearg);
10211 return result;
10212 }
10213 else
10214 rcoverride = True;
10215 }
10216 else {
10217 Tcl_SetResult(interp, "No filename given to exec argument.", NULL);
10218 free(filearg);
10219 return TCL_ERROR;
10220 }
10221 }
10222 else if (!strncmp(*argv, "-2", 2)) {
10223 /* 2-button mouse bindings option */
10224 pressmode = 1;
10225 }
10226 }
10227 else if (strcmp(*argv, ".xcircuit")) {
10228 filearg = (char *)realloc(filearg, sizeof(char) *
10229 (strlen(filearg) + strlen(*argv) + 2));
10230 strcat(filearg, ",");
10231 strcat(filearg, *argv);
10232 }
10233 argv++;
10234 argc--;
10235 }
10236 }
10237 else {
10238 /* Except---this appears to be no longer true. When did it change? */
10239 int argc = objc;
10240 char *argv;
10241
10242 for (argc = 0; argc < objc; argc++) {
10243 argv = Tcl_GetString(objv[argc]);
10244 if (*argv == '-') {
10245 if (!strncmp(argv, "-exec", 5)) {
10246 if (++argc < objc) {
10247 argv = Tcl_GetString(objv[argc]);
10248 result = Tcl_EvalFile(interp, argv);
10249 if (result != TCL_OK) {
10250 free(filearg);
10251 return result;
10252 }
10253 else
10254 rcoverride = True;
10255 }
10256 else {
10257 Tcl_SetResult(interp, "No filename given to exec argument.", NULL);
10258 free(filearg);
10259 return TCL_ERROR;
10260 }
10261 }
10262 else if (!strncmp(argv, "-2", 2)) {
10263 /* 2-button mouse bindings option */
10264 pressmode = 1;
10265 }
10266 }
10267 else if (strcmp(argv, ".xcircuit")) {
10268 filearg = (char *)realloc(filearg, sizeof(char) *
10269 (strlen(filearg) + strlen(argv) + 2));
10270 strcat(filearg, ",");
10271 strcat(filearg, argv);
10272 }
10273 }
10274 }
10275
10276 if (!rcoverride)
10277 result = loadrcfile();
10278
10279 composelib(PAGELIB); /* make sure we have a valid page list */
10280 composelib(LIBLIB); /* and library directory */
10281 if ((objc >= 2) && (*filearg != '\0')) {
10282 char *libname;
10283 int target = -1;
10284
10285 strcpy(_STR2, filearg);
10286 libname = (char *)Tcl_GetVar2(xcinterp, "XCOps", "library", 0);
10287 if (libname != NULL) {
10288 target = NameToLibrary(libname);
10289 }
10290 startloadfile((target >= 0) ? target + LIBRARY : -1);
10291 }
10292 else {
10293 findcrashfiles();
10294 }
10295 pressmode = 0; /* Done using this to track 2-button bindings */
10296
10297 /* Note that because the setup has the windows generated and */
10298 /* mapped prior to calling the xcircuit routines, nothing */
10299 /* gets CreateNotify, MapNotify, or other definitive events. */
10300 /* So, we have to do all the drawing once. */
10301
10302 xobjs.suspend = -1; /* Release from suspend mode */
10303 if (areawin->scrollbarv)
10304 drawvbar(areawin->scrollbarv, NULL, NULL);
10305 if (areawin->scrollbarh)
10306 drawhbar(areawin->scrollbarh, NULL, NULL);
10307 drawarea(areawin->area, NULL, NULL);
10308
10309 /* Return back to the interpreter; Tk is handling the GUI */
10310 free(filearg);
10311 return (result == TCL_OK) ? XcTagCallback(interp, 1, &cmdname) : result;
10312 }
10313
10314 /*--------------------------------------------------------------*/
10315 /* Message printing procedures for the Tcl version */
10316 /* */
10317 /* Evaluate the variable-length argument, and make a call to */
10318 /* the routine xcircuit::print, which should be defined. */
10319 /*--------------------------------------------------------------*/
10320
10321 void W0vprintf(char *window, const char *format, va_list args_in)
10322 {
10323 char tstr[128], *bigstr = NULL, *strptr;
10324 int n, size;
10325 va_list args;
10326
10327 if (window != NULL) {
10328 sprintf(tstr, "catch {xcircuit::print %s {", window);
10329 size = strlen(tstr);
10330
10331 va_copy(args, args_in);
10332 n = vsnprintf(tstr + size, 128 - size, format, args);
10333 va_end(args);
10334
10335 if (n <= -1 || n > 125 - size) {
10336 bigstr = malloc(n + size + 4);
10337 strncpy(bigstr, tstr, size);
10338 va_copy(args, args_in);
10339 vsnprintf(bigstr + size, n + 1, format, args);
10340 va_end(args);
10341 strptr = bigstr;
10342 strcat(bigstr, "}}");
10343 }
10344 else {
10345 strptr = tstr;
10346 strcat(tstr, "}}");
10347 }
10348 Tcl_Eval(xcinterp, strptr);
10349 if (bigstr != NULL) free(bigstr);
10350 }
10351 }
10352
10353 /* Prints to pagename window */
10354
10355 void W1printf(char *format, ...)
10356 {
10357 va_list args;
10358 va_start(args, format);
10359 W0vprintf("coord", format, args);
10360 va_end(args);
10361 }
10362
10363 /* Prints to coordinate window */
10364
10365 void W2printf(char *format, ...)
10366 {
10367 va_list args;
10368 va_start(args, format);
10369 W0vprintf("page", format, args);
10370 va_end(args);
10371 }
10372
10373 /* Prints to status window but does not tee output to the console. */
10374
10375 void W3printf(char *format, ...)
10376 {
10377 va_list args;
10378 va_start(args, format);
10379 W0vprintf("stat", format, args);
10380 va_end(args);
10381 }
10382
10383 /* Prints to status window and duplicates the output to stdout. */
10384
10385 void Wprintf(char *format, ...)
10386 {
10387 va_list args;
10388 va_start(args, format);
10389 W0vprintf("stat", format, args);
10390 if (strlen(format) > 0) {
10391 if (strstr(format, "Error")) {
10392 tcl_vprintf(stderr, format, args);
10393 tcl_printf(stderr, "\n");
10394 }
10395 else {
10396 tcl_vprintf(stdout, format, args);
10397 tcl_printf(stdout, "\n");
10398 }
10399 }
10400 va_end(args);
10401 }
10402
10403 /*------------------------------------------------------*/
10404
10405 #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.