?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Corrected (maybe) an error in the old Xt code that must have been
[xcircuit.git] / tclxcircuit.c
blobb1a83c6c4b65b201800947942c090fbc99564966
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[2], &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 case VisibleIdx: /* Change visibility of pin */
4445 if (objc == nidx + 1)
4446 jval = getanchoring(interp, PINVISIBLE);
4447 else {
4448 if ((result = Tcl_GetBooleanFromObj(interp, objv[nidx + 1],
4449 &value)) != TCL_OK)
4450 return result;
4451 if (jval != value)
4452 setanchoring(PINVISIBLE, (value) ? PINVISIBLE : NORMAL);
4453 }
4454 break;
4455
4456 case FlipIdx:
4457 if (objc == nidx + 1)
4458 jval = getanchoring(interp, FLIPINV);
4459 else {
4460 if ((result = Tcl_GetBooleanFromObj(interp, objv[nidx + 1],
4461 &value)) != TCL_OK)
4462 return result;
4463 if (jval != value)
4464 setanchoring(FLIPINV, (value) ? FLIPINV : NORMAL);
4465 }
4466 break;
4467
4468 case LaTeXIdx:
4469 if (objc == nidx + 1)
4470 jval = getanchoring(interp, LATEXLABEL);
4471 else {
4472 if ((result = Tcl_GetBooleanFromObj(interp, objv[nidx + 1],
4473 &value)) != TCL_OK)
4474 return result;
4475 if (jval != value)
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 jval = getanchoring(interp, JUSTIFYRIGHT | JUSTIFYBOTH | TEXTCENTERED);
4497 if (jval != value) {
4498 setanchoring(JUSTIFYRIGHT | JUSTIFYBOTH | TEXTCENTERED, value);
4499 refresh(NULL, NULL, NULL);
4500 }
4501 }
4502 break;
4503
4504 case AnchorIdx:
4505 if (objc == nidx + 1) {
4506 jval = getanchoring(interp, RIGHT | NOTLEFT);
4507 jval2 = getanchoring(interp, TOP | NOTBOTTOM);
4508 }
4509 else {
4510 if (Tcl_GetIndexFromObj(interp, objv[nidx + 1],
4511 (CONST84 char **)anchorValues,
4512 "anchoring", 0, &idx2) != TCL_OK) {
4513 return TCL_ERROR;
4514 }
4515 switch (idx2) {
4516 case 0: value = NORMAL; break;
4517 case 1: value = NOTLEFT; break;
4518 case 2: value = NOTLEFT | RIGHT; break;
4519 case 3: value = NOTBOTTOM | TOP; break;
4520 case 4: value = NOTBOTTOM; break;
4521 case 5: value = NORMAL; break;
4522 }
4523 switch (idx2) {
4524 case 0: case 1: case 2:
4525 jval = getanchoring(interp, RIGHT | NOTLEFT);
4526 if (jval != value) {
4527 setanchoring(RIGHT | NOTLEFT, value);
4528 refresh(NULL, NULL, NULL);
4529 }
4530 break;
4531 case 3: case 4: case 5:
4532 jval2 = getanchoring(interp, TOP | NOTBOTTOM);
4533 if (jval2 != value) {
4534 setanchoring(TOP | NOTBOTTOM, value);
4535 refresh(NULL, NULL, NULL);
4536 }
4537 break;
4538 }
4539 }
4540 break;
4541
4542 case TextIdx:
4543 if ((areawin->selects == 0) && (nidx == 1)) {
4544 Tcl_SetResult(interp, "Must have a label selection.", NULL);
4545 return TCL_ERROR;
4546 }
4547 if (objc == nidx + 1) { /* Return label as printable string */
4548 char *tstr;
4549 objPtr = Tcl_NewListObj(0, NULL);
4550 for (i = 0; i < areawin->selects; i++) {
4551 if (SELECTTYPE(areawin->selectlist + i) != LABEL) continue;
4552 tlab = SELTOLABEL(areawin->selectlist + i);
4553 tstr = textprint(tlab->string, areawin->topinstance);
4554 Tcl_ListObjAppendElement(interp, objPtr,
4555 Tcl_NewStringObj(tstr, strlen(tstr)));
4556 free(tstr);
4557 }
4558 Tcl_SetObjResult(interp, objPtr);
4559 }
4560 break;
4561
4562 case ListIdx:
4563 if ((areawin->selects == 0) && (nidx == 1)) {
4564 Tcl_SetResult(interp, "Must have a label selection.", NULL);
4565 return TCL_ERROR;
4566 }
4567 if (objc == nidx + 1) { /* Return label as printable string */
4568 listPtr = Tcl_NewListObj(0, NULL);
4569 for (i = 0; i < areawin->selects; i++) {
4570 if (SELECTTYPE(areawin->selectlist + i) != LABEL) continue;
4571 tlab = SELTOLABEL(areawin->selectlist + i);
4572 objPtr = TclGetStringParts(tlab->string);
4573 Tcl_ListObjAppendElement(interp, listPtr, objPtr);
4574 }
4575 Tcl_SetObjResult(interp, listPtr);
4576 }
4577 break;
4578
4579 case ReplaceIdx: /* the opposite of "list" */
4580 if ((areawin->selects == 0) && (nidx == 1)) {
4581 Tcl_SetResult(interp, "Must have a label selection.", NULL);
4582 return TCL_ERROR;
4583 }
4584 if (objc == nidx + 2) { /* Replace string from list */
4585 stringpart *strptr = NULL;
4586
4587 if ((result = GetXCStringFromList(interp, objv[nidx + 1],
4588 &strptr)) != TCL_OK)
4589 return result;
4590
4591 for (i = 0; i < areawin->selects; i++) {
4592 if (SELECTTYPE(areawin->selectlist + i) != LABEL) continue;
4593 tlab = SELTOLABEL(areawin->selectlist + i);
4594 register_for_undo(XCF_Edit, UNDO_MORE, areawin->topinstance, tlab);
4595 freelabel(tlab->string);
4596 tlab->string = stringcopy(strptr);
4597 }
4598 freelabel(strptr);
4599 undo_finish_series();
4600 refresh(NULL, NULL, NULL);
4601 }
4602 break;
4603
4604 case PositionIdx:
4605 if ((areawin->selects == 0) && (nidx == 1)) {
4606 Tcl_SetResult(interp, "Must have a label selection.", NULL);
4607 return TCL_ERROR;
4608 }
4609 if (objc == nidx + 1) { /* Return position of label */
4610 Tcl_Obj *cpair;
4611
4612 listPtr = Tcl_NewListObj(0, NULL);
4613 for (i = 0; i < areawin->selects; i++) {
4614 if (SELECTTYPE(areawin->selectlist + i) != LABEL) continue;
4615 tlab = SELTOLABEL(areawin->selectlist + i);
4616 cpair = Tcl_NewListObj(0, NULL);
4617 objPtr = Tcl_NewIntObj((int)tlab->position.x);
4618 Tcl_ListObjAppendElement(interp, cpair, objPtr);
4619 objPtr = Tcl_NewIntObj((int)tlab->position.y);
4620 Tcl_ListObjAppendElement(interp, cpair, objPtr);
4621 Tcl_ListObjAppendElement(interp, listPtr, cpair);
4622 }
4623 Tcl_SetObjResult(interp, listPtr);
4624 }
4625 else if (objc == nidx + 2) { /* Change position of label */
4626 XPoint position;
4627
4628 if ((areawin->selects != 1) || (SELECTTYPE(areawin->selectlist)
4629 != LABEL)) {
4630 Tcl_SetResult(interp, "Must have exactly one selected label", NULL);
4631 return TCL_ERROR;
4632 }
4633 if ((result = GetPositionFromList(interp, objv[nidx + 1],
4634 &position)) != TCL_OK)
4635 return result;
4636
4637 tlab = SELTOLABEL(areawin->selectlist);
4638 tlab->position.x = position.x;
4639 tlab->position.y = position.y;
4640 }
4641 break;
4642 }
4643 return XcTagCallback(interp, objc, objv);
4644 }
4645
4646 /*----------------------------------------------------------------------*/
4647 /* Element Fill Styles */
4648 /*----------------------------------------------------------------------*/
4649
4650 int xctcl_dofill(ClientData clientData, Tcl_Interp *interp,
4651 int objc, Tcl_Obj *CONST objv[])
4652 {
4653 u_int value;
4654 int i, idx, result, rval = -1;
4655
4656 static char *Styles[] = {"opaque", "transparent", "filled", "unfilled",
4657 "solid", NULL};
4658 enum StylesIdx {
4659 OpaqueIdx, TransparentIdx, FilledIdx, UnfilledIdx, SolidIdx
4660 };
4661
4662 if (objc == 1) {
4663 value = areawin->style;
4664 Tcl_AppendElement(interp, ((value & OPAQUE) ? "opaque" : "transparent"));
4665 if (value & FILLED) {
4666 Tcl_AppendElement(interp, "filled");
4667 switch (value & FILLSOLID) {
4668 case 0:
4669 Tcl_AppendElement(interp, "12"); break;
4670 case STIP0:
4671 Tcl_AppendElement(interp, "25"); break;
4672 case STIP1:
4673 Tcl_AppendElement(interp, "37"); break;
4674 case STIP1 | STIP0:
4675 Tcl_AppendElement(interp, "50"); break;
4676 case STIP2:
4677 Tcl_AppendElement(interp, "62"); break;
4678 case STIP2 | STIP0:
4679 Tcl_AppendElement(interp, "75"); break;
4680 case STIP2 | STIP1:
4681 Tcl_AppendElement(interp, "87"); break;
4682 case FILLSOLID:
4683 Tcl_AppendElement(interp, "solid"); break;
4684 }
4685 }
4686 else {
4687 Tcl_AppendElement(interp, "unfilled");
4688 }
4689 return TCL_OK;
4690 }
4691
4692 for (i = 1; i < objc; i++) {
4693 if (Tcl_GetIndexFromObj(interp, objv[i],
4694 (CONST84 char **)Styles, "fill styles",
4695 0, &idx) != TCL_OK) {
4696 Tcl_ResetResult(interp);
4697 result = Tcl_GetIntFromObj(interp, objv[i], &value);
4698 if (result != TCL_OK) {
4699 Tcl_SetResult(interp, "Expected fill style or fillfactor 0 to 100", NULL);
4700 return result;
4701 }
4702 else {
4703 if (value >= 0 && value < 6) value = FILLSOLID;
4704 else if (value >= 6 && value < 19) value = FILLED;
4705 else if (value >= 19 && value < 31) value = FILLED | STIP0;
4706 else if (value >= 31 && value < 44) value = FILLED | STIP1;
4707 else if (value >= 44 && value < 56) value = FILLED | STIP0 | STIP1;
4708 else if (value >= 56 && value < 69) value = FILLED | STIP2;
4709 else if (value >= 69 && value < 81) value = FILLED | STIP2 | STIP0;
4710 else if (value >= 81 && value < 94) value = FILLED | STIP2 | STIP1;
4711 else if (value >= 94 && value <= 100) value = FILLED | FILLSOLID;
4712 else {
4713 Tcl_SetResult(interp, "Fill value should be 0 to 100", NULL);
4714 return TCL_ERROR;
4715 }
4716 rval = setelementstyle((Tk_Window)clientData, (pointertype)value,
4717 FILLED | FILLSOLID);
4718 }
4719 }
4720 else {
4721 switch(idx) {
4722 case OpaqueIdx:
4723 rval = setelementstyle((Tk_Window)clientData, OPAQUE, OPAQUE);
4724 break;
4725 case TransparentIdx:
4726 rval = setelementstyle((Tk_Window)clientData, NORMAL, OPAQUE);
4727 break;
4728 case UnfilledIdx:
4729 rval = setelementstyle((Tk_Window)clientData, FILLSOLID,
4730 FILLED | FILLSOLID);
4731 break;
4732 case SolidIdx:
4733 rval = setelementstyle((Tk_Window)clientData, FILLED | FILLSOLID,
4734 FILLED | FILLSOLID);
4735 break;
4736 case FilledIdx:
4737 break;
4738 }
4739 }
4740 }
4741 if (rval < 0)
4742 return TCL_ERROR;
4743
4744 return XcTagCallback(interp, objc, objv);
4745 }
4746
4747 /*----------------------------------------------------------------------*/
4748 /* Element border styles */
4749 /*----------------------------------------------------------------------*/
4750
4751 int xctcl_doborder(ClientData clientData, Tcl_Interp *interp,
4752 int objc, Tcl_Obj *CONST objv[])
4753 {
4754 int result, i, idx, value, rval = -1;
4755 u_short mask;
4756 double wvalue;
4757
4758 static char *borderStyles[] = {"solid", "dashed", "dotted", "none",
4759 "unbordered", "unclosed", "closed", "bbox", "set", "get", "square",
4760 "round", "clipmask", NULL};
4761 enum StyIdx {
4762 SolidIdx, DashedIdx, DottedIdx, NoneIdx, UnborderedIdx,
4763 UnclosedIdx, ClosedIdx, BBoxIdx, SetIdx, GetIdx, SquareIdx,
4764 RoundIdx, ClipMaskIdx
4765 };
4766
4767 if (objc == 1) {
4768 Tcl_Obj *listPtr;
4769 listPtr = Tcl_NewListObj(0, NULL);
4770 value = areawin->style;
4771 wvalue = (double)areawin->linewidth;
4772 switch (value & (DASHED | DOTTED | NOBORDER | SQUARECAP)) {
4773 case NORMAL:
4774 Tcl_ListObjAppendElement(interp, listPtr,
4775 Tcl_NewStringObj("solid", 5)); break;
4776 case DASHED:
4777 Tcl_ListObjAppendElement(interp, listPtr,
4778 Tcl_NewStringObj("dashed", 6)); break;
4779 case DOTTED:
4780 Tcl_ListObjAppendElement(interp, listPtr,
4781 Tcl_NewStringObj("dotted", 6)); break;
4782 case NOBORDER:
4783 Tcl_ListObjAppendElement(interp, listPtr,
4784 Tcl_NewStringObj("unbordered", 10)); break;
4785 case SQUARECAP:
4786 Tcl_ListObjAppendElement(interp, listPtr,
4787 Tcl_NewStringObj("square-endcaps", 10)); break;
4788 }
4789 if (value & UNCLOSED)
4790 Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj("unclosed", 8));
4791 else
4792 Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj("closed", 6));
4793
4794 if (value & BBOX)
4795 Tcl_ListObjAppendElement(interp, listPtr,
4796 Tcl_NewStringObj("bounding box", 12));
4797
4798 if (value & CLIPMASK)
4799 Tcl_ListObjAppendElement(interp, listPtr,
4800 Tcl_NewStringObj("clipmask", 8));
4801
4802 Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewDoubleObj(wvalue));
4803 Tcl_SetObjResult(interp, listPtr);
4804 return TCL_OK;
4805 }
4806
4807 for (i = 1; i < objc; i++) {
4808 result = Tcl_GetIndexFromObj(interp, objv[i],
4809 (CONST84 char **)borderStyles,
4810 "border style", 0, &idx);
4811 if (result != TCL_OK)
4812 return result;
4813
4814 switch (idx) {
4815 case GetIdx:
4816 {
4817 int j, numfound = 0;
4818 genericptr setel;
4819 Tcl_Obj *objPtr, *listPtr = NULL;
4820
4821 for (j = 0; j < areawin->selects; j++) {
4822 setel = SELTOGENERIC(areawin->selectlist + j);
4823 if (IS_ARC(setel) || IS_POLYGON(setel) ||
4824 IS_SPLINE(setel) || IS_PATH(setel)) {
4825 switch(ELEMENTTYPE(setel)) {
4826 case ARC: wvalue = ((arcptr)setel)->width; break;
4827 case POLYGON: wvalue = ((polyptr)setel)->width; break;
4828 case SPLINE: wvalue = ((splineptr)setel)->width; break;
4829 case PATH: wvalue = ((pathptr)setel)->width; break;
4830 }
4831 if ((++numfound) == 2) {
4832 listPtr = Tcl_NewListObj(0, NULL);
4833 Tcl_ListObjAppendElement(interp, listPtr, objPtr);
4834 }
4835 objPtr = Tcl_NewDoubleObj(wvalue);
4836 if (numfound > 1)
4837 Tcl_ListObjAppendElement(interp, listPtr, objPtr);
4838 }
4839 }
4840 switch (numfound) {
4841 case 0:
4842 objPtr = Tcl_NewDoubleObj(areawin->linewidth);
4843 /* fall through */
4844 case 1:
4845 Tcl_SetObjResult(interp, objPtr);
4846 break;
4847 default:
4848 Tcl_SetObjResult(interp, listPtr);
4849 break;
4850 }
4851 }
4852 break;
4853 case SetIdx:
4854 if ((objc - i) != 2) {
4855 Tcl_SetResult(interp, "Error: no linewidth given.", NULL);
4856 return TCL_ERROR;
4857 }
4858 result = Tcl_GetDoubleFromObj(interp, objv[++i], &wvalue);
4859 if (result == TCL_OK) {
4860 sprintf(_STR2, "%f", wvalue);
4861 setwwidth((Tk_Window)clientData, NULL);
4862 }
4863 else {
4864 Tcl_SetResult(interp, "Error: invalid border linewidth.", NULL);
4865 return TCL_ERROR;
4866 }
4867 break;
4868 case SolidIdx: value = NORMAL; mask = DASHED | DOTTED | NOBORDER; break;
4869 case DashedIdx: value = DASHED; mask = DASHED | DOTTED | NOBORDER; break;
4870 case DottedIdx: value = DOTTED; mask = DASHED | DOTTED | NOBORDER; break;
4871 case NoneIdx: case UnborderedIdx:
4872 value = NOBORDER; mask = DASHED | DOTTED | NOBORDER; break;
4873 case UnclosedIdx: value = UNCLOSED; mask = UNCLOSED; break;
4874 case ClosedIdx: value = NORMAL; mask = UNCLOSED; break;
4875 case SquareIdx: value = SQUARECAP; mask = SQUARECAP; break;
4876 case RoundIdx: value = NORMAL; mask = SQUARECAP; break;
4877 case BBoxIdx:
4878 mask = BBOX;
4879 if ((objc - i) < 2) value = BBOX;
4880 else {
4881 char *yesno = Tcl_GetString(objv[++i]);
4882 value = (tolower(yesno[0]) == 'y' || tolower(yesno[0]) == 't') ?
4883 BBOX : NORMAL;
4884 }
4885 break;
4886 case ClipMaskIdx:
4887 mask = CLIPMASK;
4888 if ((objc - i) < 2) value = CLIPMASK;
4889 else {
4890 char *yesno = Tcl_GetString(objv[++i]);
4891 value = (tolower(yesno[0]) == 'y' || tolower(yesno[0]) == 't') ?
4892 CLIPMASK : NORMAL;
4893 }
4894 break;
4895 }
4896 if (idx != SetIdx && idx != GetIdx)
4897 rval = setelementstyle((Tk_Window)clientData, (u_short)value, mask);
4898 }
4899
4900 return XcTagCallback(interp, objc, objv);
4901 }
4902
4903 /*----------------------------------------------------------------------*/
4904
4905 int xctcl_polygon(ClientData clientData, Tcl_Interp *interp,
4906 int objc, Tcl_Obj *CONST objv[])
4907 {
4908 int idx, nidx, result, npoints, j;
4909 polyptr newpoly, ppoly;
4910 XPoint ppt;
4911 pointlist points;
4912 Tcl_Obj *objPtr, *coord, *cpair, **newobjv;
4913 Boolean is_box = FALSE;
4914 Matrix hierCTM;
4915
4916 static char *subCmds[] = {"make", "border", "fill", "points", "number", NULL};
4917 enum SubIdx {
4918 MakeIdx, BorderIdx, FillIdx, PointsIdx, NumberIdx
4919 };
4920
4921 nidx = 255;
4922 result = ParseElementArguments(interp, objc, objv, &nidx, POLYGON);
4923 if (result != TCL_OK) return result;
4924
4925 if ((result = Tcl_GetIndexFromObj(interp, objv[nidx],
4926 (CONST84 char **)subCmds,
4927 "option", 0, &idx)) != TCL_OK)
4928 return result;
4929
4930 switch (idx) {
4931 case MakeIdx:
4932 if ((areawin->selects == 0) && (nidx == 1)) {
4933 if (objc < 5) {
4934 Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
4935 return TCL_ERROR;
4936 }
4937 if (!strcmp(Tcl_GetString(objv[2]), "box")) {
4938 npoints = objc - 3;
4939 is_box = TRUE;
4940 if (npoints != 4 && npoints != 2) {
4941 Tcl_SetResult(interp, "Box must have 2 or 4 points", NULL);
4942 return TCL_ERROR;
4943 }
4944 }
4945 else {
4946 result = Tcl_GetIntFromObj(interp, objv[2], &npoints);
4947 if (result != TCL_OK) return result;
4948 }
4949 if (objc != npoints + 3) {
4950 Tcl_WrongNumArgs(interp, 1, objv, "N {x1 y1}...{xN yN}");
4951 return TCL_ERROR;
4952 }
4953 points = (pointlist)malloc(npoints * sizeof(XPoint));
4954 for (j = 0; j < npoints; j++) {
4955 result = GetPositionFromList(interp, objv[3 + j], &ppt);
4956 if (result == TCL_OK) {
4957 points[j].x = ppt.x;
4958 points[j].y = ppt.y;
4959 }
4960 }
4961 if (is_box && (npoints == 2)) {
4962 npoints = 4;
4963 points = (pointlist)realloc(points, npoints * sizeof(XPoint));
4964 points[2].x = points[1].x;
4965 points[2].y = points[1].y;
4966 points[1].y = points[0].y;
4967 points[3].x = points[0].x;
4968 points[3].y = points[2].y;
4969 }
4970 newpoly = new_polygon(NULL, &points, npoints);
4971 if (!is_box) newpoly->style |= UNCLOSED;
4972 singlebbox((genericptr *)&newpoly);
4973
4974 objPtr = Tcl_NewHandleObj(newpoly);
4975 Tcl_SetObjResult(interp, objPtr);
4976 }
4977 else if (nidx == 2) {
4978 Tcl_SetResult(interp, "\"polygon <handle> make\" is illegal", NULL);
4979 return TCL_ERROR;
4980 }
4981 else {
4982 Tcl_SetResult(interp, "No selections allowed", NULL);
4983 return TCL_ERROR;
4984 }
4985 break;
4986
4987 case BorderIdx:
4988 newobjv = (Tcl_Obj **)(&objv[nidx]);
4989 result = xctcl_doborder(clientData, interp, objc - nidx, newobjv);
4990 break;
4991
4992 case FillIdx:
4993 newobjv = (Tcl_Obj **)(&objv[nidx]);
4994 result = xctcl_dofill(clientData, interp, objc - nidx, newobjv);
4995 break;
4996
4997 case NumberIdx:
4998 if (areawin->selects != 1) {
4999 Tcl_SetResult(interp, "Must have exactly one selection to "
5000 "query points", NULL);
5001 return TCL_ERROR;
5002 }
5003 else {
5004 if (SELECTTYPE(areawin->selectlist) != POLYGON) {
5005 Tcl_SetResult(interp, "Selected element is not a polygon", NULL);
5006 return TCL_ERROR;
5007 }
5008 else
5009 ppoly = SELTOPOLY(areawin->selectlist);
5010
5011 if ((objc - nidx) == 1) {
5012 objPtr = Tcl_NewIntObj(ppoly->number);
5013 Tcl_SetObjResult(interp, objPtr);
5014 }
5015 else
5016 {
5017 Tcl_SetResult(interp, "Cannot change number of points.\n", NULL);
5018 return TCL_ERROR;
5019 }
5020 }
5021 break;
5022
5023 case PointsIdx:
5024 if (areawin->selects != 1) {
5025 Tcl_SetResult(interp, "Must have exactly one selection to "
5026 "query or manipulate points", NULL);
5027 return TCL_ERROR;
5028 }
5029 else {
5030 ppoly = SELTOPOLY(areawin->selectlist);
5031 MakeHierCTM(&hierCTM);
5032 if (ppoly->type != POLYGON) {
5033 Tcl_SetResult(interp, "Selected element is not a polygon", NULL);
5034 return TCL_ERROR;
5035 }
5036 points = ppoly->points;
5037
5038 if ((objc - nidx) == 1) /* Return a list of all points */
5039 {
5040 objPtr = Tcl_NewListObj(0, NULL);
5041 for (npoints = 0; npoints < ppoly->number; npoints++) {
5042 cpair = Tcl_NewListObj(0, NULL);
5043 UTransformbyCTM(&hierCTM, points + npoints, &ppt, 1);
5044 coord = Tcl_NewIntObj((int)ppt.x);
5045 Tcl_ListObjAppendElement(interp, cpair, coord);
5046 coord = Tcl_NewIntObj((int)ppt.y);
5047 Tcl_ListObjAppendElement(interp, cpair, coord);
5048 Tcl_ListObjAppendElement(interp, objPtr, cpair);
5049 }
5050 Tcl_SetObjResult(interp, objPtr);
5051 }
5052 else if ((objc - nidx) == 2) /* Return a specific point */
5053 {
5054 result = Tcl_GetIntFromObj(interp, objv[2], &npoints);
5055 if (result != TCL_OK) return result;
5056 if (npoints >= ppoly->number) {
5057 Tcl_SetResult(interp, "Point number out of range", NULL);
5058 return TCL_ERROR;
5059 }
5060 objPtr = Tcl_NewListObj(0, NULL);
5061 UTransformbyCTM(&hierCTM, points + npoints, &ppt, 1);
5062 coord = Tcl_NewIntObj((int)ppt.x);
5063 Tcl_ListObjAppendElement(interp, objPtr, coord);
5064 coord = Tcl_NewIntObj((int)ppt.y);
5065 Tcl_ListObjAppendElement(interp, objPtr, coord);
5066 Tcl_SetObjResult(interp, objPtr);
5067 }
5068 else
5069 {
5070 Tcl_SetResult(interp, "Individual point setting unimplemented\n", NULL);
5071 return TCL_ERROR;
5072 }
5073 }
5074 break;
5075 }
5076 return XcTagCallback(interp, objc, objv);
5077 }
5078
5079 /*----------------------------------------------------------------------*/
5080
5081 int xctcl_spline(ClientData clientData, Tcl_Interp *interp,
5082 int objc, Tcl_Obj *CONST objv[])
5083 {
5084 int idx, nidx, result, j, npoints;
5085 splineptr newspline, pspline;
5086 XPoint ppt, ctrlpoints[4];
5087 Tcl_Obj *objPtr, *cpair, *coord, **newobjv;
5088 Matrix hierCTM;
5089
5090 static char *subCmds[] = {"make", "border", "fill", "points", NULL};
5091 enum SubIdx {
5092 MakeIdx, BorderIdx, FillIdx, PointsIdx
5093 };
5094
5095 nidx = 5;
5096 result = ParseElementArguments(interp, objc, objv, &nidx, SPLINE);
5097 if (result != TCL_OK) return result;
5098
5099 if ((result = Tcl_GetIndexFromObj(interp, objv[nidx],
5100 (CONST84 char **)subCmds,
5101 "option", 0, &idx)) != TCL_OK)
5102 return result;
5103
5104 /* h = spline make {x1 y1} ... {x4 y4} */
5105
5106 switch (idx) {
5107 case MakeIdx:
5108 if ((areawin->selects == 0) && (nidx == 1)) {
5109 if (objc != 6) {
5110 Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
5111 return TCL_ERROR;
5112 }
5113 for (j = 0; j < 4; j++) {
5114 result = GetPositionFromList(interp, objv[2 + j], &ppt);
5115 if (result == TCL_OK) {
5116 ctrlpoints[j].x = ppt.x;
5117 ctrlpoints[j].y = ppt.y;
5118 }
5119 }
5120 newspline = new_spline(NULL, ctrlpoints);
5121 singlebbox((genericptr *)&newspline);
5122
5123 objPtr = Tcl_NewHandleObj(newspline);
5124 Tcl_SetObjResult(interp, objPtr);
5125 }
5126 else if (areawin->selects == 1) {
5127 if (ELEMENTTYPE(*(topobject->plist + (*areawin->selectlist))) == POLYGON) {
5128 converttocurve();
5129 }
5130 else {
5131 Tcl_SetResult(interp, "\"spline make\": must have a polygon selected",
5132 NULL);
5133 return TCL_ERROR;
5134 }
5135 }
5136 else if (nidx == 2) {
5137 Tcl_SetResult(interp, "\"spline <handle> make\" is illegal", NULL);
5138 return TCL_ERROR;
5139 }
5140 else {
5141 Tcl_SetResult(interp, "No selections allowed except single polygon", NULL);
5142 return TCL_ERROR;
5143 }
5144 break;
5145
5146 case BorderIdx:
5147 newobjv = (Tcl_Obj **)(&objv[nidx]);
5148 result = xctcl_doborder(clientData, interp, objc - nidx, newobjv);
5149 break;
5150
5151 case FillIdx:
5152 newobjv = (Tcl_Obj **)(&objv[nidx]);
5153 result = xctcl_dofill(clientData, interp, objc - nidx, newobjv);
5154 break;
5155
5156 case PointsIdx:
5157 if (areawin->selects != 1) {
5158 Tcl_SetResult(interp, "Must have exactly one selection to "
5159 "query or manipulate points", NULL);
5160 return TCL_ERROR;
5161 }
5162 else {
5163 /* check for ESPLINE mode? */
5164 if (SELECTTYPE(areawin->selectlist) != SPLINE) {
5165 Tcl_SetResult(interp, "Selected element is not a spline", NULL);
5166 return TCL_ERROR;
5167 }
5168 else
5169 pspline = SELTOSPLINE(areawin->selectlist);
5170
5171 MakeHierCTM(&hierCTM);
5172
5173 if ((objc - nidx) == 1) /* Return a list of all points */
5174 {
5175 objPtr = Tcl_NewListObj(0, NULL);
5176 for (npoints = 0; npoints < 4; npoints++) {
5177 cpair = Tcl_NewListObj(0, NULL);
5178 UTransformbyCTM(&hierCTM, pspline->ctrl + npoints, &ppt, 1);
5179 coord = Tcl_NewIntObj((int)ppt.x);
5180 Tcl_ListObjAppendElement(interp, cpair, coord);
5181 coord = Tcl_NewIntObj((int)ppt.y);
5182 Tcl_ListObjAppendElement(interp, cpair, coord);
5183 Tcl_ListObjAppendElement(interp, objPtr, cpair);
5184 }
5185 Tcl_SetObjResult(interp, objPtr);
5186 }
5187 else if ((objc - nidx) == 2) /* Return a specific point */
5188 {
5189 result = Tcl_GetIntFromObj(interp, objv[objc - nidx + 1], &npoints);
5190 if (result != TCL_OK) return result;
5191 if (npoints >= 4) {
5192 Tcl_SetResult(interp, "Point number out of range", NULL);
5193 return TCL_ERROR;
5194 }
5195 objPtr = Tcl_NewListObj(0, NULL);
5196 UTransformbyCTM(&hierCTM, pspline->ctrl + npoints, &ppt, 1);
5197 coord = Tcl_NewIntObj((int)ppt.x);
5198 Tcl_ListObjAppendElement(interp, objPtr, coord);
5199 coord = Tcl_NewIntObj((int)ppt.y);
5200 Tcl_ListObjAppendElement(interp, objPtr, coord);
5201 Tcl_SetObjResult(interp, objPtr);
5202 }
5203 else
5204 {
5205 Tcl_SetResult(interp, "Individual control point setting "
5206 "unimplemented\n", NULL);
5207 return TCL_ERROR;
5208 }
5209 }
5210 }
5211 return XcTagCallback(interp, objc, objv);
5212 }
5213
5214 /*----------------------------------------------------------------------*/
5215
5216 int xctcl_graphic(ClientData clientData, Tcl_Interp *interp,
5217 int objc, Tcl_Obj *CONST objv[])
5218 {
5219 int i, idx, nidx, result;
5220 double dvalue;
5221 graphicptr newgp, gp;
5222 XPoint ppt;
5223 Tcl_Obj *objPtr, *listPtr;
5224 char *filename;
5225
5226 static char *subCmds[] = {"make", "scale", "position", NULL};
5227 enum SubIdx {
5228 MakeIdx, ScaleIdx, PositionIdx
5229 };
5230
5231 nidx = 7;
5232 result = ParseElementArguments(interp, objc, objv, &nidx, GRAPHIC);
5233 if (result != TCL_OK) return result;
5234
5235 if ((result = Tcl_GetIndexFromObj(interp, objv[nidx],
5236 (CONST84 char **)subCmds,
5237 "option", 0, &idx)) != TCL_OK)
5238 return result;
5239
5240 switch (idx) {
5241 case MakeIdx:
5242 if ((areawin->selects == 0) && (nidx == 1)) {
5243 if ((objc != 5) && (objc != 7)) {
5244 Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
5245 return TCL_ERROR;
5246 }
5247
5248 filename = Tcl_GetString(objv[2]);
5249
5250 result = GetPositionFromList(interp, objv[3], &ppt);
5251 if (result != TCL_OK) return result;
5252
5253 result = Tcl_GetDoubleFromObj(interp, objv[4], &dvalue);
5254 if (result != TCL_OK) return result;
5255
5256 if (!strcmp(filename, "gradient")) {
5257 if (objc == 7) {
5258 int c1, c2;
5259 result = GetColorFromObj(interp, objv[5], &c1, TRUE);
5260 if (result != TCL_OK) return result;
5261 result = GetColorFromObj(interp, objv[6], &c2, TRUE);
5262 if (result != TCL_OK) return result;
5263 newgp = gradient_field(NULL, ppt.x, ppt.y, c1, c2);
5264 }
5265 else
5266 newgp = gradient_field(NULL, ppt.x, ppt.y, 0, 1);
5267 }
5268 else if (objc != 5) {
5269 Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
5270 return TCL_ERROR;
5271 }
5272 else
5273 newgp = new_graphic(NULL, filename, ppt.x, ppt.y);
5274
5275 if (newgp == NULL) return TCL_ERROR;
5276
5277 newgp->scale = (float)dvalue;
5278 singlebbox((genericptr *)&newgp);
5279
5280 objPtr = Tcl_NewHandleObj(newgp);
5281 Tcl_SetObjResult(interp, objPtr);
5282 }
5283 else if (nidx == 2) {
5284 Tcl_SetResult(interp, "\"graphic <handle> make\" is illegal", NULL);
5285 return TCL_ERROR;
5286 }
5287 else {
5288 Tcl_SetResult(interp, "No selections allowed", NULL);
5289 return TCL_ERROR;
5290 }
5291 break;
5292
5293 case ScaleIdx:
5294 case PositionIdx:
5295 if ((areawin->selects == 0) && (nidx == 1)) {
5296 Tcl_SetResult(interp, "Must have a graphic selection.", NULL);
5297 return TCL_ERROR;
5298 }
5299 if (objc == nidx + 1) { /* Return position of graphic origin */
5300 Tcl_Obj *cpair;
5301 graphicptr gp;
5302
5303 listPtr = Tcl_NewListObj(0, NULL);
5304 for (i = 0; i < areawin->selects; i++) {
5305 if (SELECTTYPE(areawin->selectlist + i) != GRAPHIC) continue;
5306 gp = SELTOGRAPHIC(areawin->selectlist + i);
5307
5308 switch (idx) {
5309 case ScaleIdx:
5310 objPtr = Tcl_NewDoubleObj(gp->scale);
5311 Tcl_ListObjAppendElement(interp, listPtr, objPtr);
5312 break;
5313 case PositionIdx:
5314 cpair = Tcl_NewListObj(0, NULL);
5315 objPtr = Tcl_NewIntObj((int)gp->position.x);
5316 Tcl_ListObjAppendElement(interp, cpair, objPtr);
5317 objPtr = Tcl_NewIntObj((int)gp->position.y);
5318 Tcl_ListObjAppendElement(interp, cpair, objPtr);
5319 Tcl_ListObjAppendElement(interp, listPtr, cpair);
5320 break;
5321 }
5322 }
5323 Tcl_SetObjResult(interp, listPtr);
5324 }
5325 else if (objc == nidx + 2) { /* Change position or scale */
5326 if (idx == ScaleIdx) {
5327 result = Tcl_GetDoubleFromObj(interp, objv[nidx + 1], &dvalue);
5328 if (result == TCL_OK) {
5329 for (i = 0; i < areawin->selects; i++) {
5330 float oldscale;
5331
5332 if (SELECTTYPE(areawin->selectlist + i) != GRAPHIC) continue;
5333 gp = SELTOGRAPHIC(areawin->selectlist + i);
5334 oldscale = gp->scale;
5335 gp->scale = (float)dvalue;
5336 if (gp->scale != oldscale) {
5337 #ifndef HAVE_CAIRO
5338 gp->valid = False;
5339 #endif /* !HAVE_CAIRO */
5340 drawarea(areawin->area, (caddr_t)clientData, (caddr_t)NULL);
5341 calcbboxvalues(areawin->topinstance,
5342 topobject->plist + *(areawin->selectlist + i));
5343 register_for_undo(XCF_Rescale, UNDO_MORE, areawin->topinstance,
5344 (genericptr)gp, (double)oldscale);
5345 }
5346 }
5347 undo_finish_series();
5348 }
5349 }
5350 else {
5351 result = GetPositionFromList(interp, objv[nidx + 1], &ppt);
5352 if (result == TCL_OK) {
5353 for (i = 0; i < areawin->selects; i++) {
5354 if (SELECTTYPE(areawin->selectlist + i) != GRAPHIC) continue;
5355 gp = SELTOGRAPHIC(areawin->selectlist + i);
5356 gp->position.x = ppt.x;
5357 gp->position.y = ppt.y;
5358 calcbboxvalues(areawin->topinstance,
5359 topobject->plist + *(areawin->selectlist + i));
5360 }
5361 }
5362 }
5363 updatepagebounds(topobject);
5364 incr_changes(topobject);
5365 }
5366 break;
5367 }
5368 return XcTagCallback(interp, objc, objv);
5369 }
5370
5371 /*----------------------------------------------------------------------*/
5372
5373 int xctcl_arc(ClientData clientData, Tcl_Interp *interp,
5374 int objc, Tcl_Obj *CONST objv[])
5375 {
5376 int idx, nidx, result, value;
5377 double angle;
5378 arcptr newarc;
5379 XPoint ppt;
5380 Tcl_Obj *objPtr, *listPtr, **newobjv;
5381
5382 static char *subCmds[] = {"make", "border", "fill", "radius", "minor",
5383 "angle", "position", NULL};
5384 enum SubIdx {
5385 MakeIdx, BorderIdx, FillIdx, RadiusIdx, MinorIdx, AngleIdx,
5386 PositionIdx
5387 };
5388
5389 nidx = 7;
5390 result = ParseElementArguments(interp, objc, objv, &nidx, ARC);
5391 if (result != TCL_OK) return result;
5392
5393 if ((result = Tcl_GetIndexFromObj(interp, objv[nidx],
5394 (CONST84 char **)subCmds,
5395 "option", 0, &idx)) != TCL_OK)
5396 return result;
5397
5398 switch (idx) {
5399 case MakeIdx:
5400 if ((areawin->selects == 0) && (nidx == 1)) {
5401 if ((objc < 4) || (objc > 7)) {
5402 Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
5403 return TCL_ERROR;
5404 }
5405 result = GetPositionFromList(interp, objv[2], &ppt);
5406 if (result != TCL_OK) return result;
5407
5408 result = Tcl_GetIntFromObj(interp, objv[3], &value);
5409 if (result != TCL_OK) return result;
5410
5411 newarc = new_arc(NULL, value, ppt.x, ppt.y);
5412
5413 switch (objc) {
5414 case 6:
5415 result = Tcl_GetDoubleFromObj(interp, objv[4], &angle);
5416 if (result == TCL_OK) newarc->angle1 = (float)angle;
5417 result = Tcl_GetDoubleFromObj(interp, objv[5], &angle);
5418 if (result == TCL_OK) newarc->angle2 = (float)angle;
5419 break;
5420 case 7:
5421 result = Tcl_GetDoubleFromObj(interp, objv[5], &angle);
5422 if (result == TCL_OK) newarc->angle1 = (float)angle;
5423 result = Tcl_GetDoubleFromObj(interp, objv[6], &angle);
5424 if (result == TCL_OK) newarc->angle2 = (float)angle;
5425 case 5:
5426 result = Tcl_GetIntFromObj(interp, objv[4], &value);
5427 if (result == TCL_OK) newarc->yaxis = value;
5428 break;
5429 }
5430 if (objc >= 6) {
5431 /* Check that angle2 > angle1. Swap if necessary. */
5432 if (newarc->angle2 < newarc->angle1) {
5433 int tmp = newarc->angle2;
5434 newarc->angle2 = newarc->angle1;
5435 newarc->angle1 = tmp;
5436 }
5437
5438 /* Check for 0 length chords (assume full circle was intended) */
5439 if (newarc->angle1 == newarc->angle2) {
5440 Tcl_SetResult(interp, "Changed zero-length arc chord!\n", NULL);
5441 newarc->angle2 = newarc->angle1 + 360;
5442 }
5443
5444 /* Normalize */
5445 if (newarc->angle1 >= 360) {
5446 newarc->angle1 -= 360;
5447 newarc->angle2 -= 360;
5448 }
5449 else if (newarc->angle2 <= 0) {
5450 newarc->angle1 += 360;
5451 newarc->angle2 += 360;
5452 }
5453 }
5454 if (objc >= 5) {
5455 calcarc(newarc);
5456 singlebbox((genericptr *)&newarc);
5457 }
5458 objPtr = Tcl_NewHandleObj(newarc);
5459 Tcl_SetObjResult(interp, objPtr);
5460 }
5461 else if (nidx == 2) {
5462 Tcl_SetResult(interp, "\"arc <handle> make\" is illegal", NULL);
5463 return TCL_ERROR;
5464 }
5465 else {
5466 Tcl_SetResult(interp, "No selections allowed", NULL);
5467 return TCL_ERROR;
5468 }
5469 break;
5470
5471 case BorderIdx:
5472 newobjv = (Tcl_Obj **)(&objv[nidx]);
5473 result = xctcl_doborder(clientData, interp, objc - nidx, newobjv);
5474 break;
5475
5476 case FillIdx:
5477 newobjv = (Tcl_Obj **)(&objv[nidx]);
5478 result = xctcl_dofill(clientData, interp, objc - nidx, newobjv);
5479 break;
5480
5481 case RadiusIdx:
5482 case MinorIdx:
5483 case AngleIdx:
5484 case PositionIdx:
5485 if ((areawin->selects == 0) && (nidx == 1)) {
5486 Tcl_SetResult(interp, "Must have an arc selection.", NULL);
5487 return TCL_ERROR;
5488 }
5489 if (objc == nidx + 1) { /* Return position of arc center */
5490 Tcl_Obj *cpair;
5491 int i;
5492 arcptr parc;
5493
5494 listPtr = Tcl_NewListObj(0, NULL);
5495 for (i = 0; i < areawin->selects; i++) {
5496 if (SELECTTYPE(areawin->selectlist + i) != ARC) continue;
5497 parc = SELTOARC(areawin->selectlist + i);
5498
5499 switch (idx) {
5500 case RadiusIdx:
5501 objPtr = Tcl_NewIntObj(parc->radius);
5502 Tcl_ListObjAppendElement(interp, listPtr, objPtr);
5503 break;
5504 case MinorIdx:
5505 objPtr = Tcl_NewIntObj(parc->yaxis);
5506 Tcl_ListObjAppendElement(interp, listPtr, objPtr);
5507 break;
5508 case AngleIdx:
5509 cpair = Tcl_NewListObj(0, NULL);
5510 objPtr = Tcl_NewDoubleObj(parc->angle1);
5511 Tcl_ListObjAppendElement(interp, cpair, objPtr);
5512 objPtr = Tcl_NewDoubleObj(parc->angle2);
5513 Tcl_ListObjAppendElement(interp, cpair, objPtr);
5514 Tcl_ListObjAppendElement(interp, listPtr, cpair);
5515 break;
5516 case PositionIdx:
5517 cpair = Tcl_NewListObj(0, NULL);
5518 objPtr = Tcl_NewIntObj((int)parc->position.x);
5519 Tcl_ListObjAppendElement(interp, cpair, objPtr);
5520 objPtr = Tcl_NewIntObj((int)parc->position.y);
5521 Tcl_ListObjAppendElement(interp, cpair, objPtr);
5522 Tcl_ListObjAppendElement(interp, listPtr, cpair);
5523 break;
5524 }
5525 }
5526 Tcl_SetObjResult(interp, listPtr);
5527 }
5528 break;
5529 }
5530 return XcTagCallback(interp, objc, objv);
5531 }
5532
5533 /*----------------------------------------------------------------------*/
5534
5535 int xctcl_path(ClientData clientData, Tcl_Interp *interp,
5536 int objc, Tcl_Obj *CONST objv[])
5537 {
5538 int idx, nidx, result, j, i;
5539 genericptr newgen, *eptr;
5540 pathptr ppath;
5541 Tcl_Obj *elist, *objPtr, *cpair, *coord, **newobjv;
5542 XPoint ppt;
5543 Matrix hierCTM;
5544
5545 static char *subCmds[] = {"join", "make", "border", "fill", "point", "unjoin",
5546 "points", NULL};
5547 enum SubIdx {
5548 JoinIdx, MakeIdx, BorderIdx, FillIdx, PointIdx, UnJoinIdx, PointsIdx
5549 };
5550
5551 nidx = 5;
5552 result = ParseElementArguments(interp, objc, objv, &nidx, PATH);
5553 if (result != TCL_OK) return result;
5554
5555 if ((result = Tcl_GetIndexFromObj(interp, objv[nidx],
5556 (CONST84 char **)subCmds,
5557 "option", 0, &idx)) != TCL_OK)
5558 return result;
5559
5560 switch (idx) {
5561 case MakeIdx: case JoinIdx:
5562 if ((areawin->selects == 0) && (nidx == 1)) {
5563 /* h = path make {element_list} */
5564 newobjv = (Tcl_Obj **)(&objv[1]);
5565 result = ParseElementArguments(interp, objc - 1, newobjv, NULL,
5566 POLYGON | ARC | SPLINE | PATH);
5567 if (result != TCL_OK) return result;
5568 }
5569 else if (nidx == 2) {
5570 Tcl_SetResult(interp, "\"path <handle> make\" is illegal", NULL);
5571 return TCL_ERROR;
5572 }
5573 /* h = path make */
5574 join();
5575 newgen = *(topobject->plist + topobject->parts - 1);
5576 objPtr = Tcl_NewHandleObj(newgen);
5577 Tcl_SetObjResult(interp, objPtr);
5578 break;
5579
5580 case BorderIdx:
5581 newobjv = (Tcl_Obj **)(&objv[nidx]);
5582 result = xctcl_doborder(clientData, interp, objc - nidx, newobjv);
5583 break;
5584
5585 case FillIdx:
5586 newobjv = (Tcl_Obj **)(&objv[nidx]);
5587 result = xctcl_dofill(clientData, interp, objc - nidx, newobjv);
5588 break;
5589
5590 case PointIdx:
5591 Tcl_SetResult(interp, "Unimplemented function.", NULL);
5592 return TCL_ERROR;
5593 break;
5594
5595 case UnJoinIdx:
5596 unjoin();
5597 /* Would be nice to return the list of constituent elements. . . */
5598 break;
5599
5600 case PointsIdx:
5601 /* Make a list of the polygon and spline elements in the path, */
5602 /* returning a nested list enumerating the points. This is */
5603 /* ad-hoc, as it does not match any other method of returning */
5604 /* point information about a part. This is because returning */
5605 /* a handle list is useless, since the handles cannot be */
5606 /* accessed directly. */
5607
5608 if (areawin->selects != 1) {
5609 Tcl_SetResult(interp, "Must have exactly one selection to "
5610 "query parts", NULL);
5611 return TCL_ERROR;
5612 }
5613 else {
5614 if (SELECTTYPE(areawin->selectlist) != PATH) {
5615 Tcl_SetResult(interp, "Selected element is not a path", NULL);
5616 return TCL_ERROR;
5617 }
5618 else
5619 ppath = SELTOPATH(areawin->selectlist);
5620
5621 MakeHierCTM(&hierCTM);
5622
5623 objPtr = Tcl_NewListObj(0, NULL);
5624 for (j = 0; j < ppath->parts; j++) {
5625 eptr = (genericptr *)(ppath->plist + j);
5626 elist = Tcl_NewListObj(0, NULL);
5627 if ((*eptr)->type == POLYGON) {
5628 polyptr ppoly;
5629 ppoly = (polyptr)(*eptr);
5630 Tcl_ListObjAppendElement(interp, elist,
5631 Tcl_NewStringObj("polygon", -1));
5632 for (i = 0; i < ppoly->number; i++) {
5633 cpair = Tcl_NewListObj(0, NULL);
5634 UTransformbyCTM(&hierCTM, ppoly->points + i, &ppt, 1);
5635 coord = Tcl_NewIntObj((int)ppt.x);
5636 Tcl_ListObjAppendElement(interp, cpair, coord);
5637 coord = Tcl_NewIntObj((int)ppt.y);
5638 Tcl_ListObjAppendElement(interp, cpair, coord);
5639 Tcl_ListObjAppendElement(interp, elist, cpair);
5640 }
5641 }
5642 else {
5643 splineptr pspline;
5644 pspline = (splineptr)(*eptr);
5645 Tcl_ListObjAppendElement(interp, elist,
5646 Tcl_NewStringObj("spline", -1));
5647 for (i = 0; i < 4; i++) {
5648 cpair = Tcl_NewListObj(0, NULL);
5649 UTransformbyCTM(&hierCTM, pspline->ctrl + i, &ppt, 1);
5650 coord = Tcl_NewIntObj((int)ppt.x);
5651 Tcl_ListObjAppendElement(interp, cpair, coord);
5652 coord = Tcl_NewIntObj((int)ppt.y);
5653 Tcl_ListObjAppendElement(interp, cpair, coord);
5654 Tcl_ListObjAppendElement(interp, elist, cpair);
5655 }
5656 }
5657 Tcl_ListObjAppendElement(interp, objPtr, elist);
5658 }
5659 Tcl_SetObjResult(interp, objPtr);
5660 }
5661 break;
5662 }
5663 return XcTagCallback(interp, objc, objv);
5664 }
5665
5666 /*----------------------------------------------------------------------*/
5667
5668 int xctcl_instance(ClientData clientData, Tcl_Interp *interp,
5669 int objc, Tcl_Obj *CONST objv[])
5670 {
5671 int i, numfound, idx, nidx, result;
5672 objectptr pobj;
5673 objinstptr pinst, newinst;
5674 short *newselect;
5675 XPoint newpos, ppt;
5676 Tcl_Obj *objPtr;
5677 Matrix hierCTM;
5678
5679 static char *subCmds[] = {"make", "object", "scale", "center", "linewidth",
5680 "bbox", NULL};
5681 enum SubIdx {
5682 MakeIdx, ObjectIdx, ScaleIdx, CenterIdx, LineWidthIdx, BBoxIdx
5683 };
5684
5685 static char *lwsubCmds[] = {"scale_variant", "variant", "scale_invariant",
5686 "invariant", NULL};
5687
5688 nidx = 3;
5689 result = ParseElementArguments(interp, objc, objv, &nidx, OBJINST);
5690 if (result != TCL_OK) return result;
5691
5692 if ((result = Tcl_GetIndexFromObj(interp, objv[nidx],
5693 (CONST84 char **)subCmds,
5694 "option", 0, &idx)) != TCL_OK)
5695 return result;
5696
5697 switch (idx) {
5698 case MakeIdx:
5699 if ((areawin->selects == 0) && (nidx == 1)) {
5700 if (objc == 3) {
5701 pobj = NameToObject(Tcl_GetString(objv[2]), &pinst, False);
5702 if (pobj == NULL) {
5703 Tcl_SetResult(interp, "no such object", NULL);
5704 return TCL_ERROR;
5705 }
5706 newpos = UGetCursorPos();
5707 u2u_snap(&newpos);
5708 newinst = new_objinst(NULL, pinst, newpos.x, newpos.y);
5709 newinst->color = areawin->color;
5710 newselect = allocselect();
5711 *newselect = (short)(topobject->parts - 1);
5712 draw_normal_selected(topobject, areawin->topinstance);
5713 eventmode = COPY_MODE;
5714 Tk_CreateEventHandler(areawin->area, PointerMotionMask,
5715 (Tk_EventProc *)xctk_drag, NULL);
5716 return XcTagCallback(interp, objc, objv);
5717 }
5718 else if (objc != 4) {
5719 Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
5720 return TCL_ERROR;
5721 }
5722 pobj = NameToObject(Tcl_GetString(objv[2]), &pinst, False);
5723 if (pobj == NULL) {
5724 Tcl_SetResult(interp, "no such object", NULL);
5725 return TCL_ERROR;
5726 }
5727 result = GetPositionFromList(interp, objv[3], &newpos);
5728 if (result != TCL_OK) return result;
5729
5730 newinst = new_objinst(NULL, pinst, newpos.x, newpos.y);
5731 newinst->color = areawin->color;
5732 singlebbox((genericptr *)&newinst);
5733 objPtr = Tcl_NewHandleObj(newinst);
5734 Tcl_SetObjResult(interp, objPtr);
5735 }
5736 else if (nidx == 2) {
5737 Tcl_SetResult(interp, "\"instance <handle> make\" is illegal", NULL);
5738 return TCL_ERROR;
5739 }
5740 else {
5741 Tcl_SetResult(interp, "No selections allowed.", NULL);
5742 return TCL_ERROR;
5743 }
5744 break;
5745
5746 case ObjectIdx:
5747 if ((objc - nidx) == 1) {
5748 Tcl_Obj *listPtr;
5749 numfound = 0;
5750 for (i = 0; i < areawin->selects; i++) {
5751 if (SELECTTYPE(areawin->selectlist + i) == OBJINST) {
5752 pinst = SELTOOBJINST(areawin->selectlist + i);
5753 objPtr = Tcl_NewStringObj(pinst->thisobject->name, -1);
5754 if (numfound > 0)
5755 Tcl_ListObjAppendElement(interp, listPtr, objPtr);
5756 if ((++numfound) == 1)
5757 listPtr = objPtr;
5758 }
5759 }
5760 switch (numfound) {
5761 case 0:
5762 Tcl_SetResult(interp, "Error: no object instances selected", NULL);
5763 return TCL_ERROR;
5764 break;
5765 case 1:
5766 Tcl_SetObjResult(interp, objPtr);
5767 break;
5768 default:
5769 Tcl_SetObjResult(interp, listPtr);
5770 break;
5771 }
5772 }
5773 else {
5774 Tcl_Obj *listPtr;
5775 int listlen;
5776 objectptr pobj;
5777
5778 /* If the number of additional arguments matches the number */
5779 /* of selected items, or if there is one additional item */
5780 /* that is a list with a number of items equal to the */
5781 /* number of selected items, then change each element to */
5782 /* the corresponding object in the list. If there is only */
5783 /* one additional item, change all elements to that object. */
5784
5785 if ((objc - nidx) == 1 + areawin->selects) {
5786 // Change each element in turn to the corresponding object
5787 // taken from the command arguments
5788 for (i = 0; i < areawin->selects; i++) {
5789 pobj = NameToObject(Tcl_GetString(objv[2 + i]), NULL, FALSE);
5790 if (pobj == NULL) {
5791 Tcl_SetResult(interp, "Name is not a known object", NULL);
5792 return TCL_ERROR;
5793 }
5794 pinst = SELTOOBJINST(areawin->selectlist + i);
5795 pinst->thisobject = pobj;
5796 calcbboxinst(pinst);
5797 }
5798 }
5799 else if ((objc - nidx) == 2) {
5800 result = Tcl_ListObjLength(interp, objv[2], &listlen);
5801 if (result != TCL_OK) return result;
5802 if (listlen == 1) {
5803 // Check if the indicated object exists
5804 pobj = NameToObject(Tcl_GetString(objv[2]), NULL, FALSE);
5805 if (pobj == NULL) {
5806 Tcl_SetResult(interp, "Name is not a known object", NULL);
5807 return TCL_ERROR;
5808 }
5809
5810 // Change all selected elements to the object specified
5811 for (i = 0; i < areawin->selects; i++) {
5812 pinst = SELTOOBJINST(areawin->selectlist + i);
5813 pinst->thisobject = pobj;
5814 calcbboxinst(pinst);
5815 }
5816 }
5817 else if (listlen != areawin->selects) {
5818 Tcl_SetResult(interp, "Error: list length does not match"
5819 "the number of selected elements.", NULL);
5820 return TCL_ERROR;
5821 }
5822 else {
5823 // Change each element in turn to the corresponding object
5824 // in the list
5825 for (i = 0; i < areawin->selects; i++) {
5826 result = Tcl_ListObjIndex(interp, objv[2], i, &listPtr);
5827 if (result != TCL_OK) return result;
5828
5829 pobj = NameToObject(Tcl_GetString(listPtr), NULL, FALSE);
5830 if (pobj == NULL) {
5831 Tcl_SetResult(interp, "Name is not a known object", NULL);
5832 return TCL_ERROR;
5833 }
5834 pinst = SELTOOBJINST(areawin->selectlist + i);
5835 pinst->thisobject = pobj;
5836 calcbboxinst(pinst);
5837 }
5838 }
5839 }
5840 drawarea(areawin->area, NULL, NULL);
5841 }
5842 break;
5843
5844 case ScaleIdx:
5845 if ((objc - nidx) == 1) {
5846 Tcl_Obj *listPtr;
5847 numfound = 0;
5848 for (i = 0; i < areawin->selects; i++) {
5849 if (SELECTTYPE(areawin->selectlist + i) == OBJINST) {
5850 pinst = SELTOOBJINST(areawin->selectlist + i);
5851 objPtr = Tcl_NewDoubleObj(pinst->scale);
5852 if (numfound > 0)
5853 Tcl_ListObjAppendElement(interp, listPtr, objPtr);
5854 if ((++numfound) == 1)
5855 listPtr = objPtr;
5856 }
5857 }
5858 switch (numfound) {
5859 case 0:
5860 Tcl_SetResult(interp, "Error: no object instances selected", NULL);
5861 return TCL_ERROR;
5862 break;
5863 case 1:
5864 Tcl_SetObjResult(interp, objPtr);
5865 break;
5866 default:
5867 Tcl_SetObjResult(interp, listPtr);
5868 break;
5869 }
5870 }
5871 else {
5872 strcpy(_STR2, Tcl_GetString(objv[2]));
5873 setosize((Tk_Window)clientData, NULL);
5874 }
5875 break;
5876
5877 case CenterIdx:
5878
5879 if ((objc - nidx) == 1) {
5880 Tcl_Obj *listPtr, *coord;
5881 numfound = 0;
5882 for (i = 0; i < areawin->selects; i++) {
5883 if (SELECTTYPE(areawin->selectlist + i) == OBJINST) {
5884 pinst = SELTOOBJINST(areawin->selectlist + i);
5885 MakeHierCTM(&hierCTM);
5886 objPtr = Tcl_NewListObj(0, NULL);
5887 UTransformbyCTM(&hierCTM, &pinst->position, &ppt, 1);
5888 coord = Tcl_NewIntObj((int)ppt.x);
5889 Tcl_ListObjAppendElement(interp, objPtr, coord);
5890 coord = Tcl_NewIntObj((int)ppt.y);
5891 Tcl_ListObjAppendElement(interp, objPtr, coord);
5892 if (numfound > 0)
5893 Tcl_ListObjAppendElement(interp, listPtr, objPtr);
5894 if ((++numfound) == 1)
5895 listPtr = objPtr;
5896 }
5897 }
5898 switch (numfound) {
5899 case 0:
5900 Tcl_SetResult(interp, "Error: no object instances selected", NULL);
5901 return TCL_ERROR;
5902 break;
5903 case 1:
5904 Tcl_SetObjResult(interp, objPtr);
5905 break;
5906 default:
5907 Tcl_SetObjResult(interp, listPtr);
5908 break;
5909 }
5910 }
5911 else if (((objc - nidx) == 2) && (areawin->selects == 1)) {
5912 result = GetPositionFromList(interp, objv[objc - 1], &newpos);
5913 if (result != TCL_OK) return result;
5914 if (SELECTTYPE(areawin->selectlist) == OBJINST) {
5915 pinst = SELTOOBJINST(areawin->selectlist);
5916 MakeHierCTM(&hierCTM);
5917 UTransformbyCTM(&hierCTM, &newpos, &pinst->position, 1);
5918 }
5919 }
5920 else {
5921 Tcl_SetResult(interp, "Usage: instance center {x y}; only one"
5922 "instance should be selected.", NULL);
5923 return TCL_ERROR;
5924 }
5925 break;
5926
5927 case LineWidthIdx:
5928 if ((objc - nidx) == 1) {
5929 Tcl_Obj *listPtr;
5930 numfound = 0;
5931 for (i = 0; i < areawin->selects; i++) {
5932 if (SELECTTYPE(areawin->selectlist + i) == OBJINST) {
5933 pinst = SELTOOBJINST(areawin->selectlist + i);
5934 if (pinst->style & LINE_INVARIANT)
5935 objPtr = Tcl_NewStringObj("scale_invariant", -1);
5936 else
5937 objPtr = Tcl_NewStringObj("scale_variant", -1);
5938 if (numfound > 0)
5939 Tcl_ListObjAppendElement(interp, listPtr, objPtr);
5940 if ((++numfound) == 1)
5941 listPtr = objPtr;
5942 }
5943 }
5944 switch (numfound) {
5945 case 0:
5946 Tcl_SetResult(interp, "Error: no object instances selected", NULL);
5947 return TCL_ERROR;
5948 break;
5949 case 1:
5950 Tcl_SetObjResult(interp, objPtr);
5951 break;
5952 default:
5953 Tcl_SetObjResult(interp, listPtr);
5954 break;
5955 }
5956 }
5957 else {
5958 int subidx;
5959 if ((result = Tcl_GetIndexFromObj(interp, objv[nidx + 1],
5960 (CONST84 char **)lwsubCmds,
5961 "value", 0, &subidx)) == TCL_OK) {
5962 for (i = 0; i < areawin->selects; i++) {
5963 if (SELECTTYPE(areawin->selectlist + i) == OBJINST) {
5964 pinst = SELTOOBJINST(areawin->selectlist);
5965 if (subidx < 2)
5966 pinst->style &= ~LINE_INVARIANT;
5967 else
5968 pinst->style |= LINE_INVARIANT;
5969 }
5970 }
5971 }
5972 }
5973 break;
5974
5975 case BBoxIdx:
5976 if ((objc - nidx) == 1) {
5977 Tcl_Obj *listPtr, *coord;
5978 numfound = 0;
5979 for (i = 0; i < areawin->selects; i++) {
5980 if (SELECTTYPE(areawin->selectlist + i) == OBJINST) {
5981 pinst = SELTOOBJINST(areawin->selectlist + i);
5982 objPtr = Tcl_NewListObj(0, NULL);
5983 coord = Tcl_NewIntObj((int)pinst->bbox.lowerleft.x);
5984 Tcl_ListObjAppendElement(interp, objPtr, coord);
5985 coord = Tcl_NewIntObj((int)pinst->bbox.lowerleft.y);
5986 Tcl_ListObjAppendElement(interp, objPtr, coord);
5987 coord = Tcl_NewIntObj((int)(pinst->bbox.lowerleft.x +
5988 pinst->bbox.width));
5989 Tcl_ListObjAppendElement(interp, objPtr, coord);
5990 coord = Tcl_NewIntObj((int)(pinst->bbox.lowerleft.y +
5991 pinst->bbox.height));
5992 Tcl_ListObjAppendElement(interp, objPtr, coord);
5993 if (numfound > 0)
5994 Tcl_ListObjAppendElement(interp, listPtr, objPtr);
5995 if ((++numfound) == 1)
5996 listPtr = objPtr;
5997 }
5998 }
5999 switch (numfound) {
6000 case 0:
6001 Tcl_SetResult(interp, "Error: no object instances selected", NULL);
6002 return TCL_ERROR;
6003 break;
6004 case 1:
6005 Tcl_SetObjResult(interp, objPtr);
6006 break;
6007 default:
6008 Tcl_SetObjResult(interp, listPtr);
6009 break;
6010 }
6011 }
6012 else {
6013 /* e.g., "instance bbox recompute" */
6014 for (i = 0; i < areawin->selects; i++) {
6015 if (SELECTTYPE(areawin->selectlist + i) == OBJINST) {
6016 pinst = SELTOOBJINST(areawin->selectlist + i);
6017 calcbbox(pinst);
6018 }
6019 }
6020 }
6021 break;
6022 }
6023 return XcTagCallback(interp, objc, objv);
6024 }
6025
6026 /*----------------------------------------------------------------------*/
6027 /* "element" configures properties of elements. Note that if the */
6028 /* second argument is not an element handle (pointer), then operations */
6029 /* will be applied to all selected elements. If there is no element */
6030 /* handle and no objects are selected, the operation will be applied */
6031 /* to default settings, like the "xcircuit::set" command. */
6032 /*----------------------------------------------------------------------*/
6033
6034 int xctcl_element(ClientData clientData, Tcl_Interp *interp,
6035 int objc, Tcl_Obj *CONST objv[])
6036 {
6037 int result, nidx, idx, i, flags;
6038 Tcl_Obj *listPtr;
6039 Tcl_Obj **newobjv;
6040 int newobjc;
6041 genericptr egen;
6042 short *newselect, *tempselect, *orderlist;
6043
6044 /* Commands */
6045 static char *subCmds[] = {
6046 "delete", "copy", "flip", "rotate", "edit", "select", "snap", "move",
6047 "color", "parameters", "raise", "lower", "exchange", "hide", "show",
6048 "handle", "deselect", NULL
6049 };
6050 enum SubIdx {
6051 DeleteIdx, CopyIdx, FlipIdx, RotateIdx, EditIdx, SelectIdx, SnapIdx,
6052 MoveIdx, ColorIdx, ParamIdx, RaiseIdx, LowerIdx, ExchangeIdx,
6053 HideIdx, ShowIdx, HandleIdx, DeselectIdx
6054 };
6055
6056 static char *etypes[] = {
6057 "Label", "Polygon", "Bezier Curve", "Object Instance", "Path",
6058 "Arc", "Graphic", NULL /* (jdk) */
6059 };
6060
6061 /* Before doing a standard parse, we need to check for the single case */
6062 /* "element X deselect"; otherwise, calling ParseElementArguements() */
6063 /* is going to destroy the selection list. */
6064
6065 if ((objc == 3) && (!strcmp(Tcl_GetString(objv[2]), "deselect"))) {
6066 result = xctcl_deselect(clientData, interp, objc, objv);
6067 return result;
6068 }
6069
6070 /* All other commands are dispatched to individual element commands */
6071 /* for the indicated element or for each selected element. */
6072
6073 nidx = 7;
6074 result = ParseElementArguments(interp, objc, objv, &nidx, ALL_TYPES);
6075 if (result != TCL_OK) return result;
6076
6077 if ((objc - nidx) < 1) {
6078 Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
6079 return TCL_ERROR;
6080 }
6081
6082 if (!strcmp(Tcl_GetString(objv[nidx]), "type")) {
6083 /* Return a list of types of the selected elements */
6084
6085 if (areawin->selects > 1)
6086 listPtr = Tcl_NewListObj(0, NULL);
6087
6088 for (i = 0; i < areawin->selects; i++) {
6089 Tcl_Obj *objPtr;
6090 int idx2, type = SELECTTYPE(areawin->selectlist + i);
6091 switch (type) {
6092 case LABEL: idx2 = 0; break;
6093 case POLYGON: idx2 = 1; break;
6094 case SPLINE: idx2 = 2; break;
6095 case OBJINST: idx2 = 3; break;
6096 case PATH: idx2 = 4; break;
6097 case ARC: idx2 = 5; break;
6098 case GRAPHIC: idx2 = 6; break;
6099 default: return TCL_ERROR;
6100 }
6101 objPtr = Tcl_NewStringObj(etypes[idx2], strlen(etypes[idx2]));
6102 if (areawin->selects == 1) {
6103 Tcl_SetObjResult(interp, objPtr);
6104 return TCL_OK;
6105 }
6106 else {
6107 Tcl_ListObjAppendElement(interp, listPtr, objPtr);
6108 }
6109 Tcl_SetObjResult(interp, listPtr);
6110 }
6111 return XcTagCallback(interp, objc, objv);
6112 }
6113 else if (!strcmp(Tcl_GetString(objv[nidx]), "handle")) {
6114 /* Return a list of handles of the selected elements */
6115
6116 listPtr = SelectToTclList(interp, areawin->selectlist, areawin->selects);
6117 Tcl_SetObjResult(interp, listPtr);
6118 return XcTagCallback(interp, objc, objv);
6119 }
6120
6121 if (Tcl_GetIndexFromObj(interp, objv[nidx],
6122 (CONST84 char **)subCmds,
6123 "option", 0, &idx) == TCL_OK) {
6124
6125 newobjv = (Tcl_Obj **)(&objv[nidx]);
6126 newobjc = objc - nidx;
6127
6128 /* Shift the argument list and call the indicated function. */
6129
6130 switch(idx) {
6131 case DeleteIdx:
6132 result = xctcl_delete(clientData, interp, newobjc, newobjv);
6133 break;
6134 case CopyIdx:
6135 result = xctcl_copy(clientData, interp, newobjc, newobjv);
6136 break;
6137 case FlipIdx:
6138 result = xctcl_flip(clientData, interp, newobjc, newobjv);
6139 break;
6140 case RotateIdx:
6141 result = xctcl_rotate(clientData, interp, newobjc, newobjv);
6142 break;
6143 case EditIdx:
6144 result = xctcl_edit(clientData, interp, newobjc, newobjv);
6145 break;
6146 case ParamIdx:
6147 result = xctcl_param(clientData, interp, newobjc, newobjv);
6148 break;
6149 case HideIdx:
6150 for (i = 0; i < areawin->selects; i++) {
6151 newselect = areawin->selectlist + i;
6152 egen = SELTOGENERIC(newselect);
6153 egen->type |= DRAW_HIDE;
6154 }
6155 refresh(NULL, NULL, NULL);
6156 break;
6157 case ShowIdx:
6158 if (newobjc == 2) {
6159 if (!strcmp(Tcl_GetString(newobjv[1]), "all")) {
6160 for (i = 0; i < topobject->parts; i++) {
6161 egen = *(topobject->plist + i);
6162 egen->type &= (~DRAW_HIDE);
6163 }
6164 }
6165 }
6166 else {
6167 for (i = 0; i < areawin->selects; i++) {
6168 newselect = areawin->selectlist + i;
6169 egen = SELTOGENERIC(newselect);
6170 egen->type &= (~DRAW_HIDE);
6171 }
6172 }
6173 refresh(NULL, NULL, NULL);
6174 break;
6175 case SelectIdx:
6176 if (newobjc == 2) {
6177 if (!strncmp(Tcl_GetString(newobjv[1]), "hide", 4)) {
6178 for (i = 0; i < areawin->selects; i++) {
6179 newselect = areawin->selectlist + i;
6180 egen = SELTOGENERIC(newselect);
6181 egen->type |= SELECT_HIDE;
6182 }
6183 }
6184 else if (!strncmp(Tcl_GetString(newobjv[1]), "allow", 5)) {
6185 for (i = 0; i < topobject->parts; i++) {
6186 egen = *(topobject->plist + i);
6187 egen->type &= (~SELECT_HIDE);
6188 }
6189 }
6190 else {
6191 Tcl_SetResult(interp, "Select options are \"hide\" "
6192 "and \"allow\"", NULL);
6193 return TCL_ERROR;
6194 }
6195 }
6196 /* If nidx == 2, then we've already done the selection! */
6197 else if (nidx == 1)
6198 result = xctcl_select(clientData, interp, newobjc, newobjv);
6199 else
6200 result = TCL_OK;
6201 break;
6202 case DeselectIdx:
6203 /* case nidx == 2 was already taken care of. case nidx == 1 */
6204 /* implies "deselect all". */
6205 unselect_all();
6206 result = TCL_OK;
6207 break;
6208 case ColorIdx:
6209 result = xctcl_color(clientData, interp, newobjc, newobjv);
6210 break;
6211 case SnapIdx:
6212 snapelement();
6213 break;
6214 case ExchangeIdx:
6215 exchange();
6216 break;
6217 case LowerIdx:
6218
6219 /* Improved method thanks to Dimitri Princen */
6220
6221 /* First move the selected parts to the bottom. This sets */
6222 /* all the values pointed by (selectlist + i) to zero, and */
6223 /* inverts the order between the selected elements. */
6224 /* Finally *tempselect += i inverts the original numbering, */
6225 /* so the second loop inverts the placing again, regaining */
6226 /* the correct order (and writes it so). */
6227 /* */
6228 /* RaiseIdx works similar but starts from the top. */
6229
6230 if (newobjc == 2) {
6231 if (!strcmp(Tcl_GetString(newobjv[1]), "all")) {
6232 orderlist = (short *)malloc(topobject->parts * sizeof(short));
6233 for (i = 0; i < topobject->parts; i++) *(orderlist + i) = i;
6234
6235 for (i = 0; i < areawin->selects; i++) {
6236 tempselect = areawin->selectlist + i;
6237 xc_bottom(tempselect, orderlist);
6238 *tempselect += i;
6239 }
6240 for (i = 0; i < areawin->selects; i++) {
6241 tempselect = areawin->selectlist + i;
6242 xc_bottom(tempselect, orderlist);
6243 *tempselect += (areawin->selects - 1 - i);
6244 }
6245 register_for_undo(XCF_Reorder, UNDO_MORE, areawin->topinstance,
6246 orderlist, topobject->parts);
6247 }
6248 }
6249 else {
6250 xc_lower();
6251 }
6252 break;
6253
6254 case RaiseIdx:
6255
6256 /* Improved method thanks to Dimitri Princen */
6257
6258 if (newobjc == 2) {
6259 if (!strcmp(Tcl_GetString(newobjv[1]), "all")) {
6260 orderlist = (short *)malloc(topobject->parts * sizeof(short));
6261 for (i = 0; i < topobject->parts; i++) *(orderlist + i) = i;
6262
6263 for (i = areawin->selects - 1; i >= 0 ; i--) {
6264 tempselect = areawin->selectlist + i;
6265 xc_top(tempselect, orderlist);
6266 *tempselect -= (areawin->selects - 1 - i);
6267 }
6268 for (i = areawin->selects - 1; i >= 0 ; i--) {
6269 tempselect = areawin->selectlist + i;
6270 xc_top(tempselect, orderlist);
6271 *tempselect -= i;
6272 }
6273 register_for_undo(XCF_Reorder, UNDO_MORE, areawin->topinstance,
6274 orderlist, topobject->parts);
6275 }
6276 }
6277 else {
6278 xc_raise();
6279 }
6280 break;
6281
6282 case MoveIdx:
6283 result = xctcl_move(clientData, interp, newobjc, newobjv);
6284 break;
6285 }
6286 return result;
6287 }
6288
6289 /* Call each individual element function. */
6290 /* Each function is responsible for filtering the select list to */
6291 /* choose only the appropriate elements. However, we first check */
6292 /* if at least one of that type exists in the list, so the function */
6293 /* won't return an error. */
6294
6295 Tcl_ResetResult(interp);
6296
6297 newobjv = (Tcl_Obj **)(&objv[nidx - 1]);
6298 newobjc = objc - nidx + 1;
6299
6300 flags = 0;
6301 for (i = 0; i < areawin->selects; i++)
6302 flags |= SELECTTYPE(areawin->selectlist + i);
6303
6304 if (flags & LABEL) {
6305 result = xctcl_label(clientData, interp, newobjc, newobjv);
6306 if (result != TCL_OK) return result;
6307 }
6308 if (flags & POLYGON) {
6309 result = xctcl_polygon(clientData, interp, newobjc, newobjv);
6310 if (result != TCL_OK) return result;
6311 }
6312 if (flags & OBJINST) {
6313 result = xctcl_instance(clientData, interp, newobjc, newobjv);
6314 if (result != TCL_OK) return result;
6315 }
6316 if (flags & SPLINE) {
6317 result = xctcl_spline(clientData, interp, newobjc, newobjv);
6318 if (result != TCL_OK) return result;
6319 }
6320 if (flags & PATH) {
6321 result = xctcl_path(clientData, interp, newobjc, newobjv);
6322 if (result != TCL_OK) return result;
6323 }
6324 if (flags & ARC) {
6325 result = xctcl_arc(clientData, interp, newobjc, newobjv);
6326 }
6327 if (flags & GRAPHIC) {
6328 result = xctcl_graphic(clientData, interp, newobjc, newobjv);
6329 }
6330 return result;
6331 }
6332
6333 /*----------------------------------------------------------------------*/
6334 /* "config" manipulates a whole bunch of option settings. */
6335 /*----------------------------------------------------------------------*/
6336
6337 int xctcl_config(ClientData clientData, Tcl_Interp *interp,
6338 int objc, Tcl_Obj *CONST objv[])
6339 {
6340 int tmpint, i;
6341 int result, idx;
6342 char *tmpstr, buffer[30], **sptr;
6343 Pagedata *curpage;
6344
6345 static char *boxsubCmds[] = {"manhattan", "rhomboidx", "rhomboidy",
6346 "rhomboida", "normal", NULL};
6347 static char *pathsubCmds[] = {"tangents", "normal", NULL};
6348 static char *coordsubCmds[] = {"decimal inches", "fractional inches",
6349 "centimeters", "internal units", NULL};
6350 static char *filterTypes[] = {"instances", "labels", "polygons", "arcs",
6351 "splines", "paths", "graphics", NULL};
6352 static char *searchOpts[] = {"files", "lib", "libs", "library", "libraries", NULL};
6353
6354 static char *subCmds[] = {
6355 "axis", "axes", "grid", "snap", "bbox", "editinplace",
6356 "pinpositions", "pinattach", "clipmasks", "boxedit", "pathedit", "linewidth",
6357 "colorscheme", "coordstyle", "drawingscale", "manhattan", "centering",
6358 "filter", "buschar", "backup", "search", "focus", "init",
6359 "delete", "windownames", "hold", "database", "suspend",
6360 "technologies", "fontnames", "debug", NULL
6361 };
6362 enum SubIdx {
6363 AxisIdx, AxesIdx, GridIdx, SnapIdx, BBoxIdx, EditInPlaceIdx,
6364 PinPosIdx, PinAttachIdx, ShowClipIdx, BoxEditIdx, PathEditIdx, LineWidthIdx,
6365 ColorSchemeIdx, CoordStyleIdx, ScaleIdx, ManhattanIdx, CenteringIdx,
6366 FilterIdx, BusCharIdx, BackupIdx, SearchIdx, FocusIdx,
6367 InitIdx, DeleteIdx, WindowNamesIdx, HoldIdx, DatabaseIdx,
6368 SuspendIdx, TechnologysIdx, FontNamesIdx, DebugIdx
6369 };
6370
6371 if ((objc == 1) || (objc > 5)) {
6372 Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
6373 return TCL_ERROR;
6374 }
6375 if (Tcl_GetIndexFromObj(interp, objv[1],
6376 (CONST84 char **)subCmds,
6377 "option", 0, &idx) != TCL_OK) {
6378 return TCL_ERROR;
6379 }
6380
6381 /* Set curpage for those routines that need it */
6382
6383 switch(idx) {
6384 case GridIdx:
6385 case SnapIdx:
6386 case LineWidthIdx:
6387 case CoordStyleIdx:
6388 case ScaleIdx:
6389 if (areawin == NULL) {
6390 Tcl_SetResult(interp, "No current window set, assuming default\n",
6391 NULL);
6392 curpage = xobjs.pagelist[0];
6393 if (curpage == NULL) return TCL_ERROR;
6394 }
6395 else
6396 curpage = xobjs.pagelist[areawin->page];
6397 break;
6398 }
6399
6400 /* Check number of arguments wholesale (to be done) */
6401
6402 switch(idx) {
6403 case SuspendIdx:
6404 if (objc == 2) {
6405 switch (xobjs.suspend) {
6406 case -1:
6407 Tcl_SetResult(interp, "normal drawing", NULL);
6408 break;
6409 case 0:
6410 Tcl_SetResult(interp, "drawing suspended", NULL);
6411 break;
6412 case 1:
6413 Tcl_SetResult(interp, "refresh pending", NULL);
6414 break;
6415 case 2:
6416 Tcl_SetResult(interp, "drawing locked", NULL);
6417 break;
6418 }
6419 }
6420 else {
6421 result = Tcl_GetBooleanFromObj(interp, objv[2], &tmpint);
6422 if (result != TCL_OK) return result;
6423 if (tmpint == 0) {
6424
6425 /* Pending drawing */
6426
6427 if (xobjs.suspend == 1) {
6428 xobjs.suspend = -1;
6429 refresh(NULL, NULL, NULL);
6430 }
6431 else
6432 xobjs.suspend = -1;
6433 }
6434 else {
6435 /* Calling "config suspend true" twice effectively */
6436 /* locks the graphics in a state that can only be */
6437 /* removed by a call to "config suspend false". */
6438 if (xobjs.suspend >= 0)
6439 xobjs.suspend = 2;
6440 else
6441 xobjs.suspend = 0;
6442 }
6443 }
6444 break;
6445
6446 case DatabaseIdx:
6447 /* Regenerate the database of colors, fonts, etc. from Tk options */
6448 if (objc == 3) {
6449 Tk_Window tkwind, tktop;
6450
6451 tktop = Tk_MainWindow(interp);
6452 tkwind = Tk_NameToWindow(interp, Tcl_GetString(objv[2]), tktop);
6453 build_app_database(tkwind);
6454 setcolorscheme(!areawin->invert);
6455 }
6456 break;
6457
6458 case FontNamesIdx:
6459 /* To do: Return a list of known font names. The Tk wrapper uses */
6460 /* this list to regenerate the font menu for each new window. */
6461 break;
6462
6463 case WindowNamesIdx:
6464 /* Generate and return a list of existing window names */
6465
6466 if (objc == 2) {
6467 XCWindowData *winptr;
6468 for (winptr = xobjs.windowlist; winptr != NULL; winptr = winptr->next)
6469 Tcl_AppendElement(interp, Tk_PathName(winptr->area));
6470 }
6471 break;
6472
6473 case DeleteIdx:
6474 if (objc == 3) {
6475 XCWindowData *winptr;
6476 Tk_Window tkwind, tktop;
6477
6478 tktop = Tk_MainWindow(interp);
6479 tkwind = Tk_NameToWindow(interp, Tcl_GetString(objv[2]), tktop);
6480 for (winptr = xobjs.windowlist; winptr != NULL; winptr = winptr->next) {
6481 if (winptr->area == tkwind) {
6482 delete_window(winptr);
6483 break;
6484 }
6485 }
6486 if (winptr == NULL) {
6487 Tcl_SetResult(interp, "No such window\n", NULL);
6488 return TCL_ERROR;
6489 }
6490 }
6491 break;
6492
6493 case DebugIdx:
6494 #ifdef ASG
6495 if (objc == 3) {
6496 result = Tcl_GetIntFromObj(interp, objv[2], &tmpint);
6497 if (result != TCL_OK) return result;
6498 SetDebugLevel(&tmpint);
6499 }
6500 else {
6501 Tcl_SetObjResult(interp, Tcl_NewIntObj(SetDebugLevel(NULL)));
6502 }
6503 #endif
6504 break;
6505
6506
6507 case InitIdx:
6508 /* Create a data structure for a new drawing window. */
6509 /* Give it the same page number and view as the current window */
6510
6511 if (objc == 3) {
6512 XCWindowData *newwin, *savewin;
6513 savewin = areawin; // In case focus callback overwrites areawin.
6514 newwin = GUI_init(objc - 2, objv + 2);
6515 if (newwin != NULL) {
6516 newwin->page = savewin->page;
6517 newwin->vscale = savewin->vscale;
6518 newwin->pcorner = savewin->pcorner;
6519 newwin->topinstance = savewin->topinstance;
6520 }
6521 else {
6522 Tcl_SetResult(interp, "Unable to create new window structure\n", NULL);
6523 return TCL_ERROR;
6524 }
6525 }
6526 break;
6527
6528 case FocusIdx:
6529 if (objc == 2) {
6530 Tcl_SetResult(interp, Tk_PathName(areawin->area), NULL);
6531 }
6532 else if (objc == 3) {
6533 Tk_Window tkwind, tktop;
6534 XCWindowData *winptr;
6535 XPoint locsave;
6536
6537 tktop = Tk_MainWindow(interp);
6538 tkwind = Tk_NameToWindow(interp, Tcl_GetString(objv[2]), tktop);
6539 /* (Diagnostic) */
6540 /* printf("Focusing: %s\n", Tcl_GetString(objv[2])); */
6541 for (winptr = xobjs.windowlist; winptr != NULL; winptr = winptr->next) {
6542 if (winptr->area == tkwind) {
6543 int savemode;
6544 objectptr savestack;
6545
6546 if (areawin == winptr) break;
6547 else if (areawin == NULL) {
6548 areawin = winptr;
6549 break;
6550 }
6551 if ((eventmode == MOVE_MODE || eventmode == COPY_MODE) &&
6552 winptr->editstack->parts == 0) {
6553 locsave = areawin->save;
6554 delete_for_xfer(NORMAL, areawin->selectlist, areawin->selects);
6555 /* Swap editstacks */
6556 savestack = winptr->editstack;
6557 winptr->editstack = areawin->editstack;
6558 areawin->editstack = savestack;
6559 savemode = eventmode;
6560 eventmode = NORMAL_MODE;
6561
6562 /* Change event handlers */
6563 xcRemoveEventHandler(areawin->area, PointerMotionMask, False,
6564 (xcEventHandler)xctk_drag, NULL);
6565 drawarea(areawin->area, NULL, NULL);
6566 Tk_CreateEventHandler(winptr->area, PointerMotionMask,
6567 (Tk_EventProc *)xctk_drag, NULL);
6568
6569 /* Set new window */
6570 areawin = winptr;
6571 eventmode = savemode;
6572 areawin->save = locsave;
6573 transferselects();
6574 drawarea(areawin->area, NULL, NULL);
6575 }
6576 else
6577 areawin = winptr;
6578 break;
6579 }
6580 }
6581 if (winptr == NULL) {
6582 Tcl_SetResult(interp, "No such xcircuit drawing window\n", NULL);
6583 return TCL_ERROR;
6584 }
6585 }
6586 else {
6587 Tcl_WrongNumArgs(interp, 2, objv, "[window]");
6588 return TCL_ERROR;
6589 }
6590 break;
6591
6592 case AxisIdx: case AxesIdx:
6593 if (objc == 2) {
6594 Tcl_SetResult(interp, (areawin->axeson) ? "true" : "false", NULL);
6595 break;
6596 }
6597 else {
6598 result = Tcl_GetBooleanFromObj(interp, objv[2], &tmpint);
6599 if (result != TCL_OK) return result;
6600 areawin->axeson = (Boolean) tmpint;
6601 }
6602 break;
6603
6604 case GridIdx:
6605 if (objc == 2) {
6606 Tcl_SetResult(interp, (areawin->gridon) ? "true" : "false", NULL);
6607 break;
6608 }
6609 else {
6610 if (!strncmp("spac", Tcl_GetString(objv[2]), 4)) {
6611 if (objc == 3) {
6612 measurestr((float)curpage->gridspace, buffer);
6613 Tcl_SetObjResult(interp, Tcl_NewStringObj(buffer, strlen(buffer)));
6614 break;
6615 }
6616 else {
6617 strcpy(_STR2, Tcl_GetString(objv[3]));
6618 setgrid(NULL, &(curpage->gridspace));
6619 }
6620 }
6621 else {
6622 result = Tcl_GetBooleanFromObj(interp, objv[2], &tmpint);
6623 if (result != TCL_OK) return result;
6624 areawin->gridon = (Boolean) tmpint;
6625 }
6626 }
6627 break;
6628
6629 case SnapIdx:
6630 if (objc == 2) {
6631 Tcl_SetResult(interp, (areawin->snapto) ? "true" : "false", NULL);
6632 }
6633 else {
6634 if (!strncmp("spac", Tcl_GetString(objv[2]), 4)) {
6635 if (objc == 3) {
6636 measurestr((float)curpage->snapspace, buffer);
6637 Tcl_SetObjResult(interp, Tcl_NewStringObj(buffer, strlen(buffer)));
6638 break;
6639 }
6640 else {
6641 strcpy(_STR2, Tcl_GetString(objv[3]));
6642 setgrid(NULL, &(curpage->snapspace));
6643 }
6644 }
6645 else {
6646 result = Tcl_GetBooleanFromObj(interp, objv[2], &tmpint);
6647 if (result != TCL_OK) return result;
6648 areawin->snapto = (Boolean) tmpint;
6649 }
6650 }
6651 break;
6652
6653 case BoxEditIdx:
6654 if (objc == 2) {
6655 switch (areawin->boxedit) {
6656 case MANHATTAN: idx = 0; break;
6657 case RHOMBOIDX: idx = 1; break;
6658 case RHOMBOIDY: idx = 2; break;
6659 case RHOMBOIDA: idx = 3; break;
6660 case NORMAL: idx = 4; break;
6661 }
6662 Tcl_SetObjResult(interp, Tcl_NewStringObj(boxsubCmds[idx],
6663 strlen(boxsubCmds[idx])));
6664 }
6665 else if (objc != 3) {
6666 Tcl_WrongNumArgs(interp, 2, objv, "boxedit ?arg ...?");
6667 return TCL_ERROR;
6668 }
6669 else {
6670 if (Tcl_GetIndexFromObj(interp, objv[2],
6671 (CONST84 char **)boxsubCmds,
6672 "option", 0, &idx) != TCL_OK) {
6673 return TCL_ERROR;
6674 }
6675 switch (idx) {
6676 case 0: tmpint = MANHATTAN; break;
6677 case 1: tmpint = RHOMBOIDX; break;
6678 case 2: tmpint = RHOMBOIDY; break;
6679 case 3: tmpint = RHOMBOIDA; break;
6680 case 4: tmpint = NORMAL; break;
6681 }
6682 areawin->boxedit = tmpint;
6683 }
6684 break;
6685
6686 case PathEditIdx:
6687 if (objc == 2) {
6688 switch (areawin->pathedit) {
6689 case TANGENTS: idx = 0; break;
6690 case NORMAL: idx = 1; break;
6691 }
6692 Tcl_SetObjResult(interp, Tcl_NewStringObj(pathsubCmds[idx],
6693 strlen(pathsubCmds[idx])));
6694 }
6695 else if (objc != 3) {
6696 Tcl_WrongNumArgs(interp, 2, objv, "pathedit ?arg ...?");
6697 return TCL_ERROR;
6698 }
6699 else {
6700 if (Tcl_GetIndexFromObj(interp, objv[2],
6701 (CONST84 char **)pathsubCmds,
6702 "option", 0, &idx) != TCL_OK) {
6703 return TCL_ERROR;
6704 }
6705 switch (idx) {
6706 case 0: tmpint = TANGENTS; break;
6707 case 1: tmpint = NORMAL; break;
6708 }
6709 areawin->pathedit = tmpint;
6710 }
6711 break;
6712
6713 case LineWidthIdx:
6714 if (objc == 2) {
6715 Tcl_SetObjResult(interp,
6716 Tcl_NewDoubleObj((double)curpage->wirewidth / 2.0));
6717 }
6718 else if (objc != 3) {
6719 Tcl_WrongNumArgs(interp, 3, objv, "linewidth");
6720 return TCL_ERROR;
6721 }
6722 else {
6723 strcpy(_STR2, Tcl_GetString(objv[2]));
6724 setwidth(NULL, &(curpage->wirewidth));
6725 }
6726 break;
6727
6728 case BBoxIdx:
6729 if (objc == 2) {
6730 Tcl_SetResult(interp, (areawin->bboxon) ? "visible" : "invisible", NULL);
6731 }
6732 else {
6733 tmpstr = Tcl_GetString(objv[2]);
6734 if (strstr(tmpstr, "visible"))
6735 tmpint = (tmpstr[0] == 'i') ? False : True;
6736 else {
6737 result = Tcl_GetBooleanFromObj(interp, objv[2], &tmpint);
6738 if (result != TCL_OK) return result;
6739 }
6740 areawin->bboxon = (Boolean) tmpint;
6741 }
6742 break;
6743
6744 case HoldIdx:
6745 if (objc == 2) {
6746 Tcl_SetResult(interp, (xobjs.hold) ? "true" : "false", NULL);
6747 }
6748 else {
6749 result = Tcl_GetBooleanFromObj(interp, objv[2], &tmpint);
6750 if (result != TCL_OK) return result;
6751 xobjs.hold = (Boolean) tmpint;
6752 }
6753 break;
6754
6755 case EditInPlaceIdx:
6756 if (objc == 2) {
6757 Tcl_SetResult(interp, (areawin->editinplace) ? "true" : "false", NULL);
6758 }
6759 else {
6760 result = Tcl_GetBooleanFromObj(interp, objv[2], &tmpint);
6761 if (result != TCL_OK) return result;
6762 areawin->editinplace = (Boolean) tmpint;
6763 }
6764 break;
6765
6766 case ShowClipIdx:
6767 if (objc == 2) {
6768 Tcl_SetResult(interp, (areawin->showclipmasks) ? "show" : "hide", NULL);
6769 }
6770 else {
6771 tmpstr = Tcl_GetString(objv[2]);
6772 if (!strcmp(tmpstr, "show"))
6773 tmpint = True;
6774 else if (!strcmp(tmpstr, "hide"))
6775 tmpint = False;
6776 else {
6777 result = Tcl_GetBooleanFromObj(interp, objv[2], &tmpint);
6778 if (result != TCL_OK) return result;
6779 }
6780 areawin->showclipmasks = (Boolean) tmpint;
6781 }
6782 break;
6783
6784 case PinPosIdx:
6785 if (objc == 2) {
6786 Tcl_SetResult(interp, (areawin->pinpointon) ? "visible" : "invisible", NULL);
6787 }
6788 else {
6789 tmpstr = Tcl_GetString(objv[2]);
6790 if (strstr(tmpstr, "visible"))
6791 tmpint = (tmpstr[0] == 'i') ? False : True;
6792 else {
6793 result = Tcl_GetBooleanFromObj(interp, objv[2], &tmpint);
6794 if (result != TCL_OK) return result;
6795 }
6796 areawin->pinpointon = (Boolean) tmpint;
6797 }
6798 break;
6799
6800 case PinAttachIdx:
6801 if (objc == 2) {
6802 Tcl_SetResult(interp, (areawin->pinattach) ? "true" : "false", NULL);
6803 }
6804 else {
6805 result = Tcl_GetBooleanFromObj(interp, objv[2], &tmpint);
6806 if (result != TCL_OK) return result;
6807 areawin->pinattach = (Boolean) tmpint;
6808 }
6809 break;
6810
6811 case ColorSchemeIdx:
6812 if (objc == 2) {
6813 Tcl_SetResult(interp, (areawin->invert) ? "inverse" : "normal", NULL);
6814 }
6815 else {
6816 tmpstr = Tcl_GetString(objv[2]);
6817 if (!strcmp(tmpstr, "normal") || !strcmp(tmpstr, "standard"))
6818 tmpint = False;
6819 else if (!strcmp(tmpstr, "inverse") || !strcmp(tmpstr, "alternate"))
6820 tmpint = True;
6821 else {
6822 result = Tcl_GetBooleanFromObj(interp, objv[2], &tmpint);
6823 if (result != TCL_OK) return result;
6824 }
6825 areawin->invert = (Boolean) tmpint;
6826 setcolorscheme(!areawin->invert);
6827 }
6828 break;
6829
6830 case CoordStyleIdx:
6831 if (objc == 2) {
6832 switch (curpage->coordstyle) {
6833 case DEC_INCH: idx = 0; break;
6834 case FRAC_INCH: idx = 1; break;
6835 case CM: idx = 2; break;
6836 case INTERNAL: idx = 3; break;
6837 }
6838 Tcl_SetObjResult(interp, Tcl_NewStringObj(coordsubCmds[idx],
6839 strlen(coordsubCmds[idx])));
6840 }
6841 else if (objc != 3) {
6842 Tcl_WrongNumArgs(interp, 2, objv, "coordstyle ?arg ...?");
6843 return TCL_ERROR;
6844 }
6845 else {
6846 if (Tcl_GetIndexFromObj(interp, objv[2],
6847 (CONST84 char **)coordsubCmds,
6848 "option", 0, &idx) != TCL_OK) {
6849 return TCL_ERROR;
6850 }
6851 switch (idx) {
6852 case 0: tmpint = DEC_INCH; break;
6853 case 1: tmpint = FRAC_INCH; break;
6854 case 2: tmpint = CM; break;
6855 case 3: tmpint = INTERNAL; break;
6856 }
6857 getgridtype(NULL, tmpint, NULL);
6858 }
6859 break;
6860
6861 case ScaleIdx:
6862 if (objc == 2) {
6863 Tcl_Obj *objPtr = Tcl_NewListObj(0, NULL);
6864 Tcl_ListObjAppendElement(interp, objPtr,
6865 Tcl_NewIntObj((int)curpage->drawingscale.x));
6866 Tcl_ListObjAppendElement(interp, objPtr,
6867 Tcl_NewStringObj(":", 1));
6868 Tcl_ListObjAppendElement(interp, objPtr,
6869 Tcl_NewIntObj((int)curpage->drawingscale.y));
6870 Tcl_SetObjResult(interp, objPtr);
6871 }
6872 else if (objc == 3) {
6873 strcpy(_STR2, Tcl_GetString(objv[2]));
6874 setdscale(NULL, &(curpage->drawingscale));
6875 }
6876 else {
6877 Tcl_WrongNumArgs(interp, 2, objv, "drawingscale ?arg ...?");
6878 return TCL_ERROR;
6879 }
6880 break;
6881
6882 case TechnologysIdx:
6883 if (objc == 2) {
6884 Tcl_SetResult(interp, (xobjs.showtech) ? "true" : "false", NULL);
6885 }
6886 else {
6887 short libnum;
6888
6889 result = Tcl_GetBooleanFromObj(interp, objv[2], &tmpint);
6890 if (result != TCL_OK) return result;
6891 if (xobjs.showtech != (Boolean) tmpint) {
6892 xobjs.showtech = (Boolean) tmpint;
6893
6894 /* When namespaces are included, the length of the printed */
6895 /* name may cause names to overlap, so recompose each */
6896 /* library when the showtech flag is changed. */
6897 for (libnum = 0; libnum < xobjs.numlibs; libnum++)
6898 composelib(LIBRARY + libnum);
6899
6900 if (eventmode == CATALOG_MODE) refresh(NULL, NULL, NULL);
6901 }
6902 }
6903 break;
6904
6905 case ManhattanIdx:
6906 if (objc == 2) {
6907 Tcl_SetResult(interp, (areawin->manhatn) ? "true" : "false", NULL);
6908 }
6909 else {
6910 result = Tcl_GetBooleanFromObj(interp, objv[2], &tmpint);
6911 if (result != TCL_OK) return result;
6912 areawin->manhatn = (Boolean) tmpint;
6913 }
6914 break;
6915
6916 case CenteringIdx:
6917 if (objc == 2) {
6918 Tcl_SetResult(interp, (areawin->center) ? "true" : "false", NULL);
6919 }
6920 else {
6921 result = Tcl_GetBooleanFromObj(interp, objv[2], &tmpint);
6922 if (result != TCL_OK) return result;
6923 areawin->center = (Boolean) tmpint;
6924 }
6925 break;
6926
6927 case FilterIdx:
6928 if (objc == 2) {
6929 for (i = 0; i < 6; i++) {
6930 tmpint = 1 << i;
6931 if (areawin->filter & tmpint) {
6932 Tcl_AppendElement(interp, filterTypes[i]);
6933 }
6934 }
6935 }
6936 else if (objc >= 3) {
6937 if (Tcl_GetIndexFromObj(interp, objv[2],
6938 (CONST84 char **)filterTypes,
6939 "filter_type", 0, &tmpint) != TCL_OK) {
6940 return TCL_ERROR;
6941 }
6942 if (objc == 3) {
6943 if (areawin->filter & (1 << tmpint))
6944 Tcl_SetResult(interp, "true", NULL);
6945 else
6946 Tcl_SetResult(interp, "false", NULL);
6947 }
6948 else {
6949 int ftype = 1 << tmpint;
6950 if (!strcmp(Tcl_GetString(objv[3]), "true"))
6951 areawin->filter |= ftype;
6952 else
6953 areawin->filter &= (~ftype);
6954 }
6955 }
6956 break;
6957
6958 case BusCharIdx:
6959 if (objc == 2) {
6960 buffer[0] = '\\';
6961 buffer[1] = areawin->buschar;
6962 buffer[2] = '\0';
6963 Tcl_SetResult(interp, buffer, TCL_VOLATILE);
6964 }
6965 else if (objc == 3) {
6966 tmpstr = Tcl_GetString(objv[2]);
6967 areawin->buschar = (tmpstr[0] == '\\') ? tmpstr[1] : tmpstr[0];
6968 }
6969 break;
6970
6971 case BackupIdx:
6972 if (objc == 2) {
6973 Tcl_SetResult(interp, (xobjs.retain_backup) ? "true" : "false", NULL);
6974 }
6975 else {
6976 result = Tcl_GetBooleanFromObj(interp, objv[2], &tmpint);
6977 if (result != TCL_OK) return result;
6978 xobjs.retain_backup = (Boolean) tmpint;
6979 }
6980 break;
6981
6982 case SearchIdx:
6983 if (objc < 3) {
6984 Tcl_WrongNumArgs(interp, 2, objv, "search files|libraries ?arg ...?");
6985 return TCL_ERROR;
6986 }
6987 if (Tcl_GetIndexFromObj(interp, objv[2],
6988 (CONST84 char **)searchOpts, "options", 0, &idx) != TCL_OK) {
6989 return TCL_ERROR;
6990 }
6991 sptr = (idx == 0) ? &xobjs.filesearchpath : &xobjs.libsearchpath;
6992 if (objc == 3) {
6993 if (*sptr != NULL) Tcl_SetResult(interp, *sptr, TCL_VOLATILE);
6994 }
6995 else {
6996 if (*sptr != NULL) free(*sptr);
6997 *sptr = NULL;
6998 tmpstr = Tcl_GetString(objv[3]);
6999 if (strlen(tmpstr) > 0)
7000 *sptr = strdup(Tcl_GetString(objv[3]));
7001 }
7002 break;
7003 }
7004 return XcTagCallback(interp, objc, objv);
7005 }
7006
7007 /*----------------------------------------------------------------------*/
7008
7009 int xctcl_promptsavepage(ClientData clientData, Tcl_Interp *interp,
7010 int objc, Tcl_Obj *CONST objv[])
7011 {
7012 int page = areawin->page;
7013 int result;
7014 Pagedata *curpage;
7015 objectptr pageobj;
7016 struct stat statbuf;
7017
7018 /* save page popup */
7019
7020 if (objc > 2) {
7021 Tcl_WrongNumArgs(interp, 1, objv, "[page_number]");
7022 return TCL_ERROR;
7023 }
7024 else if (objc == 2) {
7025 result = Tcl_GetIntFromObj(interp, objv[1], &page);
7026 if (result != TCL_OK) return result;
7027 }
7028 else page = areawin->page;
7029
7030 curpage = xobjs.pagelist[page];
7031 if (curpage->pageinst == NULL) {
7032 Tcl_SetResult(interp, "Page does not exist. . . cannot save.", NULL);
7033 return TCL_ERROR;
7034 }
7035 pageobj = curpage->pageinst->thisobject;
7036
7037 /* recompute bounding box and auto-scale, if set */
7038
7039 calcbbox(xobjs.pagelist[page]->pageinst);
7040 if (curpage->pmode & 2) autoscale(page);
7041
7042 /* get file information, if filename is set */
7043
7044 if (curpage->filename != NULL) {
7045 if (strstr(curpage->filename, ".") == NULL)
7046 sprintf(_STR2, "%s.ps", curpage->filename);
7047 else sprintf(_STR2, "%s", curpage->filename);
7048 if (stat(_STR2, &statbuf) == 0) {
7049 Wprintf(" Warning: File exists");
7050 }
7051 else {
7052 if (errno == ENOTDIR)
7053 Wprintf("Error: Incorrect pathname");
7054 else if (errno == EACCES)
7055 Wprintf("Error: Path not readable");
7056 else
7057 W3printf(" ");
7058 }
7059 }
7060 Tcl_SetObjResult(interp, Tcl_NewIntObj((int)page));
7061
7062 return XcTagCallback(interp, objc, objv);
7063 }
7064
7065 /*----------------------------------------------------------------------*/
7066
7067 int xctcl_quit(ClientData clientData, Tcl_Interp *interp,
7068 int objc, Tcl_Obj *CONST objv[])
7069 {
7070 Boolean is_intr = False;
7071
7072 /* quit, without checks */
7073 if (objc != 1) {
7074 if (strncasecmp(Tcl_GetString(objv[0]), "intr", 4))
7075 is_intr = True;
7076 else {
7077 Tcl_WrongNumArgs(interp, 1, objv, "(no arguments)");
7078 return TCL_ERROR;
7079 }
7080 }
7081 quit(areawin->area, NULL);
7082
7083 if (consoleinterp == interp)
7084 Tcl_Exit(XcTagCallback(interp, objc, objv));
7085 else {
7086 /* Ham-fisted, but prevents hanging on Ctrl-C kill */
7087 if (is_intr) exit(1);
7088 Tcl_Eval(interp, "catch {tkcon eval exit}\n");
7089 }
7090
7091 return TCL_OK; /* Not reached */
7092 }
7093
7094 /*----------------------------------------------------------------------*/
7095
7096 int xctcl_promptquit(ClientData clientData, Tcl_Interp *interp,
7097 int objc, Tcl_Obj *CONST objv[])
7098 {
7099 int result;
7100
7101 /* quit, with checks */
7102 if (objc != 1) {
7103 Tcl_WrongNumArgs(interp, 1, objv, "(no arguments)");
7104 return TCL_ERROR;
7105 }
7106 if (areawin != NULL) {
7107 result = quitcheck(areawin->area, NULL, NULL);
7108 if (result == 1) {
7109 /* Immediate exit */
7110 if (consoleinterp == interp)
7111 Tcl_Exit(XcTagCallback(interp, objc, objv));
7112 else
7113 Tcl_Eval(interp, "catch {tkcon eval exit}\n");
7114 }
7115 }
7116 return XcTagCallback(interp, objc, objv);
7117 }
7118
7119 /*----------------------------------------------------------------------*/
7120
7121 int xctcl_refresh(ClientData clientData, Tcl_Interp *interp,
7122 int objc, Tcl_Obj *CONST objv[])
7123 {
7124 /* refresh */
7125 if (objc != 1) {
7126 Tcl_WrongNumArgs(interp, 1, objv, "(no arguments)");
7127 return TCL_ERROR;
7128 }
7129 areawin->redraw_needed = True;
7130 drawarea(areawin->area, (caddr_t)clientData, (caddr_t)NULL);
7131 if (areawin->scrollbarh)
7132 drawhbar(areawin->scrollbarh, NULL, NULL);
7133 if (areawin->scrollbarv)
7134 drawvbar(areawin->scrollbarv, NULL, NULL);
7135 printname(topobject);
7136 return XcTagCallback(interp, objc, objv);
7137 }
7138
7139 /*----------------------------------------------------------------------*/
7140 /* Load a schematic that belongs to a symbol referenced by the current */
7141 /* schematic by loading the file pointed to by the "link" parameter */
7142 /* in the symbol. */
7143 /* */
7144 /* Return 1 on success, 0 if the link has already been loaded, and -1 */
7145 /* on failure to find, open, or read the link's schematic. */
7146 /*----------------------------------------------------------------------*/
7147
7148 int loadlinkfile(objinstptr tinst, char *filename, int target, Boolean do_load)
7149 {
7150 int j, savepage;
7151 FILE *ps;
7152 char file_return[150];
7153 int result;
7154 Boolean fgood;
7155
7156 /* Shorthand: "%n" can be used to indicate that the link filename is */
7157 /* the same as the name of the object, minus technology prefix. */
7158 /* While unlikely to be used, "%N" includes the technology prefix. */
7159
7160 if (!strcmp(filename, "%n")) {
7161 char *suffix = strstr(tinst->thisobject->name, "::");
7162 if (suffix == NULL)
7163 suffix = tinst->thisobject->name;
7164 else
7165 suffix += 2;
7166 strcpy(_STR, suffix);
7167 }
7168 else if (!strcmp(filename, "%N"))
7169 strcpy(_STR, tinst->thisobject->name);
7170 else
7171 strcpy(_STR, filename);
7172
7173 /* When loading links, we want to avoid */
7174 /* loading the same file more than once, so */
7175 /* compare filename against all existing */
7176 /* page filenames. Also compare links; any */
7177 /* page with a link to the same object is a */
7178 /* duplicate. */
7179
7180 ps = fileopen(_STR, ".ps", file_return, 149);
7181 if (ps != NULL) {
7182 fgood = TRUE;
7183 fclose(ps);
7184 }
7185 else
7186 fgood = FALSE;
7187
7188 for (j = 0; j < xobjs.pages; j++) {
7189 if (xobjs.pagelist[j]->filename == NULL)
7190 continue;
7191 else if (!strcmp(file_return, xobjs.pagelist[j]->filename))
7192 break;
7193 else if ((strlen(xobjs.pagelist[j]->filename) > 0) &&
7194 !strcmp(file_return + strlen(file_return) - 3, ".ps")
7195 && !strncmp(xobjs.pagelist[j]->filename, file_return,
7196 strlen(file_return) - 3))
7197 break;
7198 else if ((xobjs.pagelist[j]->pageinst != NULL) && (tinst->thisobject ==
7199 xobjs.pagelist[j]->pageinst->thisobject->symschem))
7200 break;
7201 }
7202 if (j < xobjs.pages) {
7203
7204 /* Duplicate page. Don't load it, but make sure that an association */
7205 /* exists between the symbol and schematic. */
7206
7207 if (tinst->thisobject->symschem == NULL) {
7208 tinst->thisobject->symschem =
7209 xobjs.pagelist[j]->pageinst->thisobject;
7210 if (xobjs.pagelist[j]->pageinst->thisobject->symschem == NULL)
7211 xobjs.pagelist[j]->pageinst->thisobject->symschem = tinst->thisobject;
7212 }
7213 return 0;
7214 }
7215
7216 if (fgood == FALSE) {
7217 Fprintf(stderr, "Failed to open dependency \"%s\"\n", _STR);
7218 return -1;
7219 }
7220
7221 /* Report that a pending link exists, but do not load it. */
7222 if (!do_load) return 1;
7223
7224 savepage = areawin->page;
7225 while (areawin->page < xobjs.pages &&
7226 xobjs.pagelist[areawin->page]->pageinst != NULL &&
7227 xobjs.pagelist[areawin->page]->pageinst->thisobject->parts > 0)
7228 areawin->page++;
7229
7230 changepage(areawin->page);
7231 result = (loadfile(0, (target >= 0) ? target + LIBRARY : -1) == TRUE) ? 1 : -1;
7232
7233 /* Make symschem link if not done by loadfile() */
7234
7235 if (tinst->thisobject->symschem == NULL) {
7236 tinst->thisobject->symschem =
7237 xobjs.pagelist[areawin->page]->pageinst->thisobject;
7238
7239 /* Many symbols may link to one schematic, but a schematic can */
7240 /* only link to one symbol (the first one associated). */
7241
7242 if (xobjs.pagelist[areawin->page]->pageinst->thisobject->symschem == NULL)
7243 xobjs.pagelist[areawin->page]->pageinst->thisobject->symschem
7244 = tinst->thisobject;
7245 }
7246 changepage(savepage);
7247 return result;
7248 }
7249
7250 /*----------------------------------------------------------------------*/
7251
7252 int xctcl_page(ClientData clientData, Tcl_Interp *interp,
7253 int objc, Tcl_Obj *CONST objv[])
7254 {
7255 int result, idx, nidx, aval, i, locidx;
7256 int cpage, multi, savepage, pageno = -1, linktype, importtype;
7257 char *filename, *froot, *astr;
7258 Tcl_Obj *objPtr;
7259 double newheight, newwidth, newscale;
7260 float oldscale;
7261 int newrot, newmode;
7262 objectptr pageobj;
7263 oparamptr ops;
7264 char *oldstr, *newstr, *key, *argv;
7265 Pagedata *curpage, *lpage;
7266 short *pagelist;
7267 u_short changes;
7268 int target = -1;
7269 Boolean forcepage = FALSE;
7270
7271 char *subCmds[] = {
7272 "load", "list", "import", "save", "saveonly", "make", "directory",
7273 "reset", "links", "fit", "filename", "label", "scale", "width",
7274 "height", "size", "margins", "bbox", "goto", "orientation",
7275 "encapsulation", "handle", "update", "changes", NULL
7276 };
7277 enum SubIdx {
7278 LoadIdx, ListIdx, ImportIdx, SaveIdx, SaveOnlyIdx, MakeIdx, DirIdx,
7279 ResetIdx, LinksIdx, FitIdx, FileIdx, LabelIdx, ScaleIdx,
7280 WidthIdx, HeightIdx, SizeIdx, MarginsIdx, BBoxIdx, GoToIdx,
7281 OrientIdx, EPSIdx, HandleIdx, UpdateIdx, ChangesIdx
7282 };
7283
7284 char *importTypes[] = {"xcircuit", "postscript", "background", "spice", NULL};
7285 enum ImportTypes {
7286 XCircuitIdx, PostScriptIdx, BackGroundIdx, SPICEIdx
7287 };
7288
7289 char *linkTypes[] = {"independent", "dependent", "total", "linked",
7290 "pagedependent", "all", "pending", "sheet", "load", NULL};
7291 enum LinkTypes {
7292 IndepIdx, DepIdx, TotalIdx, LinkedIdx, PageDepIdx, AllIdx, PendingIdx,
7293 SheetIdx, LinkLoadIdx
7294 };
7295 char *psTypes[] = {"eps", "full", NULL};
7296
7297 if (areawin == NULL) {
7298 Tcl_SetResult(interp, "No database!", NULL);
7299 return TCL_ERROR;
7300 }
7301 savepage = areawin->page;
7302
7303 /* Check for option "-force" (create page if it doesn't exist) */
7304 if (!strncmp(Tcl_GetString(objv[objc - 1]), "-forc", 5)) {
7305 forcepage = TRUE;
7306 objc--;
7307 }
7308
7309 result = ParsePageArguments(interp, objc, objv, &nidx, &pageno);
7310 if ((result != TCL_OK) || (nidx < 0)) {
7311 if (forcepage && (pageno == xobjs.pages)) {
7312 /* For now, allow a page to be created only if the page number */
7313 /* is one higher than the current last page. */
7314 Tcl_ResetResult(interp);
7315 idx = MakeIdx;
7316 nidx = 0;
7317 pageno = areawin->page; /* so we don't get a segfault */
7318 }
7319 else
7320 return result;
7321 }
7322 else if (nidx == 1 && objc == 2) {
7323 idx = GoToIdx;
7324 }
7325 else if (Tcl_GetIndexFromObj(interp, objv[1 + nidx],
7326 (CONST84 char **)subCmds, "option", 0, &idx) != TCL_OK) {
7327 return result;
7328 }
7329
7330 result = TCL_OK;
7331
7332 curpage = xobjs.pagelist[pageno];
7333
7334 if (curpage->pageinst != NULL)
7335 pageobj = curpage->pageinst->thisobject;
7336 else {
7337 if (idx != LoadIdx && idx != MakeIdx && idx != DirIdx && idx != GoToIdx) {
7338 Tcl_SetResult(interp, "Cannot do function on non-initialized page.", NULL);
7339 return TCL_ERROR;
7340 }
7341 }
7342
7343 switch (idx) {
7344 case HandleIdx:
7345 /* return handle of page instance */
7346 objPtr = Tcl_NewHandleObj(curpage->pageinst);
7347 Tcl_SetObjResult(interp, objPtr);
7348 break;
7349
7350 case ResetIdx:
7351 /* clear page */
7352 resetbutton(NULL, (pointertype)(pageno + 1), NULL);
7353 break;
7354
7355 case ListIdx:
7356 /* return a list of all non-empty pages */
7357 objPtr = Tcl_NewListObj(0, NULL);
7358 for (i = 0; i < xobjs.pages; i++) {
7359 lpage = xobjs.pagelist[i];
7360 if ((lpage != NULL) && (lpage->pageinst != NULL)) {
7361 Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewIntObj(i + 1));
7362 }
7363 }
7364 Tcl_SetObjResult(interp, objPtr);
7365 break;
7366
7367 case LoadIdx:
7368 TechReplaceSave();
7369 sprintf(_STR2, Tcl_GetString(objv[2 + nidx]));
7370 for (i = 3 + nidx; i < objc; i++) {
7371 argv = Tcl_GetString(objv[i]);
7372 if ((*argv == '-') && !strncmp(argv, "-repl", 5)) {
7373 if (i < objc - 1) {
7374 char *techstr = Tcl_GetString(objv[i + 1]);
7375 if (!strcmp(techstr, "all") || !strcmp(techstr, "any"))
7376 TechReplaceAll();
7377 else if (!strcmp(techstr, "none")) TechReplaceNone();
7378 else {
7379 TechPtr nsptr = LookupTechnology(techstr);
7380 if (nsptr != NULL) nsptr->flags |= TECH_REPLACE;
7381 }
7382 i++;
7383 }
7384 else
7385 TechReplaceAll(); /* replace ALL */
7386 }
7387 else if ((*argv == '-') && !strncmp(argv, "-targ", 5)) {
7388 if (i < objc - 1) {
7389 ParseLibArguments(interp, 2, &objv[i], NULL, &target);
7390 i++;
7391 }
7392 }
7393 else {
7394 strcat(_STR2, ",");
7395 strcat(_STR2, argv);
7396 }
7397 }
7398
7399 if (savepage != pageno) newpage(pageno);
7400 startloadfile((target >= 0) ? target + LIBRARY : -1);
7401 if (savepage != pageno) newpage(savepage);
7402 TechReplaceRestore();
7403 break;
7404
7405 case ImportIdx:
7406 if ((objc - nidx) < 3) {
7407 Tcl_WrongNumArgs(interp, 2, objv, "option");
7408 return TCL_ERROR;
7409 }
7410
7411 if (Tcl_GetIndexFromObj(interp, objv[2 + nidx],
7412 (CONST84 char **)importTypes, "file type",
7413 0, &importtype) != TCL_OK)
7414 return TCL_ERROR;
7415
7416 /* First check the number of arguments, which varies by option. */
7417
7418 switch (importtype) {
7419
7420 /* Xcircuit imports may specify any number of files > 1. */
7421
7422 case XCircuitIdx:
7423 if ((objc - nidx) == 3) {
7424 Tcl_SetResult(interp, "Must specify a filename to import!", NULL);
7425 return TCL_ERROR;
7426 }
7427 break;
7428
7429 /* Postscript imports may specify 1 or 0 files. 0 causes */
7430 /* the function to report back what file is the background. */
7431
7432 case PostScriptIdx:
7433 case BackGroundIdx:
7434 if ((objc - nidx) != 3 && (objc - nidx) != 4) {
7435 Tcl_SetResult(interp, "Can only specify one filename "
7436 "for background", NULL);
7437 return TCL_ERROR;
7438 }
7439
7440 /* All other import types must specify exactly one filename. */
7441
7442 default:
7443 if ((objc - nidx) != 4) {
7444 Tcl_SetResult(interp, "Must specify one filename "
7445 "for import", NULL);
7446 return TCL_ERROR;
7447 }
7448 break;
7449 }
7450
7451 /* Now process the option */
7452
7453 switch (importtype) {
7454 case XCircuitIdx:
7455 sprintf(_STR2, Tcl_GetString(objv[3 + nidx]));
7456 for (i = 4; i < objc; i++) {
7457 strcat(_STR2, ",");
7458 strcat(_STR2, Tcl_GetString(objv[i + nidx]));
7459 }
7460 if (savepage != pageno) newpage(pageno);
7461 importfile();
7462 if (savepage != pageno) newpage(savepage);
7463 break;
7464 case PostScriptIdx: /* replaces "background" */
7465 case BackGroundIdx:
7466 if (objc - nidx == 2) {
7467 objPtr = Tcl_NewStringObj(curpage->background.name,
7468 strlen(curpage->background.name));
7469 Tcl_SetObjResult(interp, objPtr);
7470 return XcTagCallback(interp, objc, objv);
7471 }
7472 sprintf(_STR2, Tcl_GetString(objv[3 + nidx]));
7473 if (savepage != pageno) newpage(pageno);
7474 loadbackground();
7475 if (savepage != pageno) newpage(savepage);
7476 break;
7477
7478 case SPICEIdx:
7479 #ifdef ASG
7480 /* Make sure that the ASG library is present */
7481
7482 if (NameToLibrary(ASG_SPICE_LIB) < 0) {
7483 short ilib;
7484
7485 strcpy(_STR, ASG_SPICE_LIB);
7486 ilib = createlibrary(FALSE);
7487 if (loadlibrary(ilib) == FALSE) {
7488 Tcl_SetResult(interp, "Error loading library.\n", NULL);
7489 return TCL_ERROR;
7490 }
7491
7492 }
7493
7494 sprintf(_STR2, Tcl_GetString(objv[3 + nidx]));
7495 if (savepage != pageno) newpage(pageno);
7496 importspice();
7497 if (savepage != pageno) newpage(savepage);
7498 #else
7499 Tcl_SetResult(interp, "ASG not compiled in; "
7500 "function is unavailable.\n", NULL);
7501 return TCL_ERROR;
7502 #endif
7503 break;
7504 }
7505
7506 /* Redraw */
7507 drawarea(areawin->area, NULL, NULL);
7508 break;
7509
7510 case MakeIdx:
7511 if (nidx == 1) {
7512 Tcl_SetResult(interp, "syntax is: \"page make [<name>]\"", NULL);
7513 return TCL_ERROR;
7514 }
7515 if (objc != 2 && objc != 3) {
7516 Tcl_WrongNumArgs(interp, 2, objv, "make [<name>]");
7517 return TCL_ERROR;
7518 }
7519 newpage((short)255);
7520 if (objc == 3) {
7521 curpage = xobjs.pagelist[areawin->page];
7522 strcpy(curpage->pageinst->thisobject->name,
7523 Tcl_GetString(objv[2]));
7524 }
7525 updatepagelib(PAGELIB, areawin->page);
7526 printname(topobject);
7527 break;
7528 case SaveOnlyIdx:
7529 case SaveIdx:
7530 if (objc - nidx > 3) {
7531 Tcl_WrongNumArgs(interp, 2, objv, "[filename]");
7532 return TCL_ERROR;
7533 }
7534 else if (objc - nidx == 3) {
7535 filename = Tcl_GetString(objv[nidx + 2]);
7536 if (strcmp(filename, curpage->filename)) {
7537 Wprintf("Warning: Filename is \"%s\" but will be "
7538 "saved as \"%s\"\n", curpage->filename, filename);
7539 }
7540 }
7541 else if (curpage->filename == NULL) {
7542 Fprintf(stderr, "Warning: Filename created to match object name\n");
7543 filename = curpage->pageinst->thisobject->name;
7544 }
7545 else
7546 filename = curpage->filename;
7547
7548 if (savepage != pageno) newpage(pageno);
7549 if (!strncmp(Tcl_GetString(objv[nidx + 1]), "saveo", 5))
7550 setfile(filename, NO_SUBCIRCUITS);
7551 else
7552 setfile(filename, CURRENT_PAGE);
7553 if (savepage != pageno) newpage(savepage);
7554 break;
7555
7556 case LinksIdx:
7557 if ((objc - nidx) < 2 && (objc - nidx) > 6) {
7558 Tcl_WrongNumArgs(interp, 1, objv, "links");
7559 return TCL_ERROR;
7560 }
7561 if ((objc - nidx) == 2)
7562 linktype = TOTAL_PAGES;
7563 else {
7564 if (Tcl_GetIndexFromObj(interp, objv[2 + nidx],
7565 (CONST84 char **)linkTypes,
7566 "link type", 0, &linktype) != TCL_OK)
7567 return TCL_ERROR;
7568 }
7569 multi = 0;
7570 pagelist = pagetotals(pageno, (linktype >= PendingIdx) ?
7571 LINKED_PAGES : linktype);
7572 TechReplaceSave();
7573 switch (linktype) {
7574
7575 /* Load any pending links, that is, objects that have a */
7576 /* "link" parameter containing a string indicating a file */
7577 /* defining the schematic for that symbol. Allow the use */
7578 /* of the same "-replace" flag used by "page load". */
7579
7580 case LinkLoadIdx:
7581 locidx = objc - 1;
7582 argv = Tcl_GetString(objv[locidx]);
7583 if (*argv != '-') argv = Tcl_GetString(objv[--locidx]);
7584 if ((*argv == '-') && !strncmp(argv, "-repl", 5)) {
7585 if (locidx < objc - 1) {
7586 char *techstr = Tcl_GetString(objv[locidx + 1]);
7587 if (!strcmp(techstr, "all")) TechReplaceAll();
7588 else if (!strcmp(techstr, "none")) TechReplaceNone();
7589 else {
7590 TechPtr nsptr = LookupTechnology(techstr);
7591 if (nsptr != NULL)
7592 nsptr->flags |= TECH_REPLACE;
7593 }
7594 objc--;
7595 }
7596 else
7597 TechReplaceAll(); /* replace ALL */
7598 objc--;
7599 }
7600 if ((*argv == '-') && !strncmp(argv, "-targ", 5)) {
7601 if (locidx < objc - 1) {
7602 ParseLibArguments(interp, 2, &objv[locidx], NULL, &target);
7603 objc--;
7604 }
7605 objc--;
7606 }
7607 /* drop through */
7608
7609 case PendingIdx:
7610 key = ((objc - nidx) == 4) ? Tcl_GetString(objv[3 + nidx]) : "link";
7611 for (i = 0; i < xobjs.pages; i++) {
7612 if (pagelist[i] > 0) {
7613 objinstptr tinst;
7614 objectptr tpage = xobjs.pagelist[i]->pageinst->thisobject;
7615 genericptr *tgen;
7616
7617 for (tgen = tpage->plist; tgen < tpage->plist
7618 + tpage->parts; tgen++) {
7619 if ((*tgen)->type == OBJINST) {
7620 tinst = TOOBJINST(tgen);
7621 /* Corrected 8/31/07: Instance value of "link" has */
7622 /* priority over any default value in the object! */
7623 ops = find_param(tinst, key);
7624 if ((ops != NULL) && (ops->type == XC_STRING)) {
7625 filename = textprint(ops->parameter.string, tinst);
7626 if (strlen(filename) > 0) {
7627 if ((result = loadlinkfile(tinst, filename, target,
7628 (linktype == LinkLoadIdx))) > 0) {
7629 multi++;
7630 setsymschem(); /* Update GUI */
7631 result = TCL_OK;
7632 }
7633 else if (result < 0) {
7634 Tcl_SetResult(interp, "Cannot load link", NULL);
7635 result = TCL_ERROR;
7636 }
7637 else result = TCL_OK;
7638 }
7639 free(filename);
7640 }
7641 }
7642 }
7643 }
7644 }
7645 break;
7646 default:
7647 for (i = 0; i < xobjs.pages; i++) {
7648 if (pagelist[i] > 0) {
7649 multi++;
7650 if ((linktype == SheetIdx) && (i == pageno) && (pagelist[i] > 0))
7651 break;
7652 }
7653 }
7654 break;
7655 }
7656 TechReplaceRestore();
7657 free((char *)pagelist);
7658 if (result == TCL_ERROR) return result;
7659 Tcl_SetObjResult(interp, Tcl_NewIntObj(multi));
7660 break;
7661
7662 case DirIdx:
7663 startcatalog(NULL, PAGELIB, NULL);
7664 break;
7665
7666 case GoToIdx:
7667 newpage((short)pageno);
7668 break;
7669
7670 case UpdateIdx:
7671 calcbbox(curpage->pageinst);
7672 if (curpage->pmode & 2) autoscale(pageno);
7673 break;
7674
7675 case BBoxIdx:
7676 if (((objc - nidx) == 2) || ((objc - nidx) == 3)) {
7677 Tcl_Obj *tuple;
7678 BBox *bbox, *sbbox;
7679 int value;
7680
7681 bbox = &curpage->pageinst->bbox;
7682 if (bbox == NULL)
7683 bbox = &curpage->pageinst->thisobject->bbox;
7684 sbbox = bbox;
7685
7686 if ((objc - nidx) == 3) {
7687 sbbox = curpage->pageinst->schembbox;
7688 if (sbbox == NULL) sbbox = bbox;
7689 }
7690
7691 objPtr = Tcl_NewListObj(0, NULL);
7692
7693 tuple = Tcl_NewListObj(0, NULL);
7694 value = min(sbbox->lowerleft.x, bbox->lowerleft.x);
7695 Tcl_ListObjAppendElement(interp, tuple, Tcl_NewIntObj(value));
7696 value = min(sbbox->lowerleft.y, bbox->lowerleft.y);
7697 Tcl_ListObjAppendElement(interp, tuple, Tcl_NewIntObj(value));
7698 Tcl_ListObjAppendElement(interp, objPtr, tuple);
7699
7700 tuple = Tcl_NewListObj(0, NULL);
7701 value = max(sbbox->lowerleft.x + sbbox->width,
7702 bbox->lowerleft.x + bbox->width);
7703 Tcl_ListObjAppendElement(interp, tuple, Tcl_NewIntObj(value));
7704 value = max(sbbox->lowerleft.y + sbbox->height,
7705 bbox->lowerleft.y + bbox->height);
7706 Tcl_ListObjAppendElement(interp, tuple, Tcl_NewIntObj(value));
7707 Tcl_ListObjAppendElement(interp, objPtr, tuple);
7708
7709 Tcl_SetObjResult(interp, objPtr);
7710 return XcTagCallback(interp, objc, objv);
7711 }
7712 else {
7713 Tcl_WrongNumArgs(interp, 1, objv, "bbox [all]");
7714 return TCL_ERROR;
7715 }
7716 break;
7717
7718 case SizeIdx:
7719 if ((objc - nidx) != 2 && (objc - nidx) != 3) {
7720 Tcl_WrongNumArgs(interp, 1, objv, "size ?\"width x height\"?");
7721 return TCL_ERROR;
7722 }
7723 if ((objc - nidx) == 2) {
7724 float xsize, ysize, cfact;
7725
7726 objPtr = Tcl_NewListObj(0, NULL);
7727
7728 cfact = (curpage->coordstyle == CM) ? IN_CM_CONVERT
7729 : 72.0;
7730 xsize = (float)curpage->pagesize.x / cfact;
7731 ysize = (float)curpage->pagesize.y / cfact;
7732
7733 Tcl_ListObjAppendElement(interp, objPtr,
7734 Tcl_NewDoubleObj((double)xsize));
7735 Tcl_ListObjAppendElement(interp, objPtr,
7736 Tcl_NewStringObj("x", 1));
7737 Tcl_ListObjAppendElement(interp, objPtr,
7738 Tcl_NewDoubleObj((double)ysize));
7739 Tcl_ListObjAppendElement(interp, objPtr,
7740 Tcl_NewStringObj(((curpage->coordstyle == CM) ?
7741 "cm" : "in"), 2));
7742 Tcl_SetObjResult(interp, objPtr);
7743
7744 return XcTagCallback(interp, objc, objv);
7745 }
7746
7747 strcpy(_STR2, Tcl_GetString(objv[2 + nidx]));
7748 setoutputpagesize(&curpage->pagesize);
7749
7750 /* Only need to recompute values and refresh if autoscaling is enabled */
7751 if (curpage->pmode & 2) autoscale(pageno);
7752 break;
7753
7754 case MarginsIdx:
7755 if ((objc - nidx) < 2 && (objc - nidx) > 4) {
7756 Tcl_WrongNumArgs(interp, 1, objv, "margins ?x y?");
7757 return TCL_ERROR;
7758 }
7759 if ((objc - nidx) == 2) {
7760 newwidth = (double)curpage->margins.x / 72.0;
7761 newheight = (double)curpage->margins.y / 72.0;
7762 objPtr = Tcl_NewListObj(0, NULL);
7763 Tcl_ListObjAppendElement(interp, objPtr,
7764 Tcl_NewDoubleObj(newwidth));
7765 Tcl_ListObjAppendElement(interp, objPtr,
7766 Tcl_NewDoubleObj(newheight));
7767 Tcl_SetObjResult(interp, objPtr);
7768 return XcTagCallback(interp, objc, objv);
7769 }
7770 newwidth = (double)parseunits(Tcl_GetString(objv[2 + nidx]));
7771 if ((objc - nidx) == 4)
7772 newheight = (double)parseunits(Tcl_GetString(objv[3 + nidx]));
7773 else
7774 newheight = newwidth;
7775
7776 newheight *= 72.0;
7777 newwidth *= 72.0;
7778 curpage->margins.x = (int)newwidth;
7779 curpage->margins.y = (int)newheight;
7780 break;
7781
7782 case HeightIdx:
7783 if ((objc - nidx) != 2 && (objc - nidx) != 3) {
7784 Tcl_WrongNumArgs(interp, 1, objv, "height ?output_height?");
7785 return TCL_ERROR;
7786 }
7787 if ((objc - nidx) == 2) {
7788 newheight = toplevelheight(curpage->pageinst, NULL);
7789 newheight *= getpsscale(curpage->outscale, pageno);
7790 newheight /= (curpage->coordstyle == CM) ? IN_CM_CONVERT : 72.0;
7791 objPtr = Tcl_NewDoubleObj((double)newheight);
7792 Tcl_SetObjResult(interp, objPtr);
7793 return XcTagCallback(interp, objc, objv);
7794 }
7795 newheight = (double)parseunits(Tcl_GetString(objv[2 + nidx]));
7796 if (newheight <= 0 || topobject->bbox.height == 0) {
7797 Tcl_SetResult(interp, "Illegal height value", NULL);
7798 return TCL_ERROR;
7799 }
7800 newheight = (newheight * ((curpage->coordstyle == CM) ?
7801 IN_CM_CONVERT : 72.0)) / topobject->bbox.height;
7802 newheight /= getpsscale(1.0, pageno);
7803 curpage->outscale = (float)newheight;
7804
7805 if (curpage->pmode & 2) autoscale(pageno);
7806 break;
7807
7808 case WidthIdx:
7809 if ((objc - nidx) != 2 && (objc - nidx) != 3) {
7810 Tcl_WrongNumArgs(interp, 1, objv, "output_width");
7811 return TCL_ERROR;
7812 }
7813 if ((objc - nidx) == 2) {
7814 newwidth = toplevelwidth(curpage->pageinst, NULL);
7815 newwidth *= getpsscale(curpage->outscale, pageno);
7816 newwidth /= (curpage->coordstyle == CM) ? IN_CM_CONVERT : 72.0;
7817 objPtr = Tcl_NewDoubleObj((double)newwidth);
7818 Tcl_SetObjResult(interp, objPtr);
7819 return XcTagCallback(interp, objc, objv);
7820 }
7821 newwidth = (double)parseunits(Tcl_GetString(objv[2 + nidx]));
7822 if (newwidth <= 0 || topobject->bbox.width == 0) {
7823 Tcl_SetResult(interp, "Illegal width value", NULL);
7824 return TCL_ERROR;
7825 }
7826
7827 newwidth = (newwidth * ((curpage->coordstyle == CM) ?
7828 IN_CM_CONVERT : 72.0)) / topobject->bbox.width;
7829 newwidth /= getpsscale(1.0, pageno);
7830 curpage->outscale = (float)newwidth;
7831
7832 if (curpage->pmode & 2) autoscale(pageno);
7833 break;
7834
7835 case ScaleIdx:
7836 if ((objc - nidx) != 2 && (objc - nidx) != 3) {
7837 Tcl_WrongNumArgs(interp, 1, objv, "output_scale");
7838 return TCL_ERROR;
7839 }
7840 if ((objc - nidx) == 2) {
7841 objPtr = Tcl_NewDoubleObj((double)curpage->outscale);
7842 Tcl_SetObjResult(interp, objPtr);
7843 return XcTagCallback(interp, objc, objv);
7844 }
7845 result = Tcl_GetDoubleFromObj(interp, objv[2 + nidx], &newscale);
7846 if (result != TCL_OK) return result;
7847
7848 oldscale = curpage->outscale;
7849
7850 if (oldscale == (float)newscale) return TCL_OK; /* nothing to do */
7851 else curpage->outscale = (float)newscale;
7852
7853 if (curpage->pmode & 2) autoscale(pageno);
7854 break;
7855
7856 case OrientIdx:
7857 if ((objc - nidx) != 2 && (objc - nidx) != 3) {
7858 Tcl_WrongNumArgs(interp, 1, objv, "orientation");
7859 return TCL_ERROR;
7860 }
7861 if ((objc - nidx) == 2) {
7862 objPtr = Tcl_NewIntObj((int)curpage->orient);
7863 Tcl_SetObjResult(interp, objPtr);
7864 return XcTagCallback(interp, objc, objv);
7865 }
7866 result = Tcl_GetIntFromObj(interp, objv[2 + nidx], &newrot);
7867 if (result != TCL_OK) return result;
7868 curpage->orient = (short)newrot;
7869
7870 /* rescale after rotation if "auto-scale" is set */
7871 if (curpage->pmode & 2) autoscale(pageno);
7872 break;
7873
7874 case EPSIdx:
7875 if ((objc - nidx) != 2 && (objc - nidx) != 3) {
7876 Tcl_WrongNumArgs(interp, 1, objv, "encapsulation");
7877 return TCL_ERROR;
7878 }
7879 if ((objc - nidx) == 2) {
7880 newstr = psTypes[curpage->pmode & 1];
7881 Tcl_SetResult(interp, newstr, NULL);
7882 return XcTagCallback(interp, objc, objv);
7883 }
7884 newstr = Tcl_GetString(objv[2 + nidx]);
7885 if (Tcl_GetIndexFromObj(interp, objv[2 + nidx],
7886 (CONST84 char **)psTypes,
7887 "encapsulation", 0, &newmode) != TCL_OK) {
7888 return result;
7889 }
7890 curpage->pmode &= 0x2; /* preserve auto-fit flag */
7891 curpage->pmode |= (short)newmode;
7892 break;
7893
7894 case LabelIdx:
7895 if ((objc - nidx) != 2 && (objc - nidx) != 3) {
7896 Tcl_WrongNumArgs(interp, 1, objv, "label ?name?");
7897 return TCL_ERROR;
7898 }
7899 if ((objc - nidx) == 2) {
7900 objPtr = Tcl_NewStringObj(pageobj->name, strlen(pageobj->name));
7901 Tcl_SetObjResult(interp, objPtr);
7902 return XcTagCallback(interp, objc, objv);
7903 }
7904
7905 /* Whitespace and non-printing characters not allowed */
7906
7907 strcpy(_STR2, Tcl_GetString(objv[2 + nidx]));
7908 for (i = 0; i < strlen(_STR2); i++) {
7909 if ((!isprint(_STR2[i])) || (isspace(_STR2[i]))) {
7910 _STR2[i] = '_';
7911 Wprintf("Replaced illegal whitespace in name with underscore");
7912 }
7913 }
7914
7915 if (!strcmp(pageobj->name, _STR2)) return TCL_OK; /* no change in string */
7916 if (strlen(_STR2) == 0)
7917 sprintf(pageobj->name, "Page %d", areawin->page + 1);
7918 else
7919 sprintf(pageobj->name, "%.79s", _STR2);
7920
7921 /* For schematics, all pages with associations to symbols must have */
7922 /* unique names. */
7923 if (pageobj->symschem != NULL) checkpagename(pageobj);
7924
7925 if (pageobj == topobject) printname(pageobj);
7926 renamepage(pageno);
7927 break;
7928
7929 case FileIdx:
7930
7931 if ((objc - nidx) != 2 && (objc - nidx) != 3) {
7932 Tcl_WrongNumArgs(interp, 1, objv, "filename ?name?");
7933 return TCL_ERROR;
7934 }
7935
7936 oldstr = curpage->filename;
7937
7938 if ((objc - nidx) == 2) {
7939 if (oldstr)
7940 objPtr = Tcl_NewStringObj(oldstr, strlen(oldstr));
7941 else
7942 objPtr = Tcl_NewListObj(0, NULL); /* NULL list */
7943 Tcl_SetObjResult(interp, objPtr);
7944 return XcTagCallback(interp, objc, objv);
7945 }
7946
7947 newstr = Tcl_GetString(objv[2 + nidx]);
7948 if (strlen(newstr) > 0) {
7949 froot = strrchr(newstr, '/');
7950 if (froot == NULL) froot = newstr;
7951 if (strchr(froot, '.') == NULL) {
7952 astr = malloc(strlen(newstr) + 4);
7953 sprintf(astr, "%s.ps", newstr);
7954 newstr = astr;
7955 }
7956 }
7957
7958 if (oldstr && (!strcmp(oldstr, newstr))) { /* no change in string */
7959 if (newstr == astr) free(astr);
7960 return XcTagCallback(interp, objc, objv);
7961 }
7962
7963 if (strlen(newstr) == 0) { /* empty string */
7964 Tcl_SetResult(interp, "Warning: No filename!", NULL);
7965 multi = 1;
7966 }
7967 else {
7968 multi = pagelinks(pageno); /* Are there multiple pages? */
7969 }
7970
7971 /* Make the change to the current page */
7972 curpage->filename = strdup(newstr);
7973 if (newstr == astr) free(astr);
7974
7975 /* All existing filenames which match the old string should */
7976 /* also be changed unless the filename has been set to the */
7977 /* null string, which unlinks the page. */
7978
7979 if ((strlen(curpage->filename) > 0) && (multi > 1)) {
7980 for (cpage = 0; cpage < xobjs.pages; cpage++) {
7981 lpage = xobjs.pagelist[cpage];
7982 if ((lpage->pageinst != NULL) && (cpage != pageno)) {
7983 if (lpage->filename && (!filecmp(lpage->filename, oldstr))) {
7984 free(lpage->filename);
7985 lpage->filename = strdup(newstr);
7986 }
7987 }
7988 }
7989 }
7990 free(oldstr);
7991 autoscale(pageno);
7992
7993 /* Run pagelinks again; this checks if a page has been attached */
7994 /* to existing schematics by being renamed to match. */
7995
7996 if ((strlen(curpage->filename) > 0) && (multi <= 1)) {
7997 for (cpage = 0; cpage < xobjs.pages; cpage++) {
7998 lpage = xobjs.pagelist[cpage];
7999 if ((lpage->pageinst != NULL) && (cpage != pageno)) {
8000 if (lpage->filename && (!filecmp(lpage->filename,
8001 curpage->filename))) {
8002 free(curpage->filename);
8003 curpage->filename = strdup(lpage->filename);
8004 break;
8005 }
8006 }
8007 }
8008 }
8009 break;
8010
8011 case FitIdx:
8012 if ((objc - nidx) > 3) {
8013 Tcl_WrongNumArgs(interp, 1, objv, "fit ?true|false?");
8014 return TCL_ERROR;
8015 }
8016 else if ((objc - nidx) == 3) {
8017 result = Tcl_GetBooleanFromObj(interp, objv[2 + nidx], &aval);
8018 if (result != TCL_OK) return result;
8019 if (aval)
8020 curpage->pmode |= 2;
8021 else
8022 curpage->pmode &= 1;
8023 }
8024 else
8025 Tcl_SetResult(interp, ((curpage->pmode & 2) > 0) ? "true" : "false", NULL);
8026
8027 /* Refresh values (does autoscale if specified) */
8028 autoscale(pageno);
8029 break;
8030
8031 case ChangesIdx:
8032 if ((objc - nidx) != 2 && (objc - nidx) != 3) {
8033 Tcl_WrongNumArgs(interp, 1, objv, "changes");
8034 return TCL_ERROR;
8035 }
8036 /* Allow changes to be set, so that a page can be forced to be */
8037 /* recognized as either modified or unmodified. */
8038
8039 if ((objc - nidx) == 3) {
8040 int value;
8041 Tcl_GetIntFromObj(interp, objv[2 + nidx], &value);
8042 curpage->pageinst->thisobject->changes = (u_short)value;
8043 }
8044 changes = getchanges(curpage->pageinst->thisobject);
8045 objPtr = Tcl_NewIntObj((double)changes);
8046 Tcl_SetObjResult(interp, objPtr);
8047 return XcTagCallback(interp, objc, objv);
8048 break;
8049 }
8050 return XcTagCallback(interp, objc, objv);
8051 }
8052
8053 /*----------------------------------------------------------------------*/
8054 /* The "technology" command deals with library *technologies*, where */
8055 /* they differ from files or pages (see the "library" command */
8056 /* xctcl_library, below). Specifically, "library load" loads a file */
8057 /* (containing object defintions in a specific technology) onto a page, */
8058 /* whereas "technology save" writes back the object definitions that */
8059 /* came from the specified file. Although one would typically have one */
8060 /* library page per technology, this is not necessarily the case. */
8061 /* */
8062 /* Only one technology is defined by a library file, but the library */
8063 /* may contain (copies of) dependent objects from another technology. */
8064 /*----------------------------------------------------------------------*/
8065
8066 int xctcl_tech(ClientData clientData, Tcl_Interp *interp,
8067 int objc, Tcl_Obj *CONST objv[])
8068 {
8069 char *technology, *filename, *libobjname;
8070 short *pagelist;
8071 int idx, ilib, j, pageno, nidx, result;
8072 TechPtr nsptr = NULL;
8073 Tcl_Obj *olist;
8074 objectptr libobj;
8075 Boolean usertech = FALSE;
8076 FILE *chklib;
8077
8078 char *subCmds[] = {
8079 "save", "list", "objects", "filename", "changed", "used", "writable",
8080 "writeable", NULL
8081 };
8082 enum SubIdx {
8083 SaveIdx, ListIdx, ObjectsIdx, FileNameIdx, ChangedIdx, UsedIdx,
8084 WritableIdx, WriteableIdx
8085 };
8086
8087 if (objc < 2) {
8088 Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
8089 return TCL_ERROR;
8090 }
8091 if (Tcl_GetIndexFromObj(interp, objv[1],
8092 (CONST84 char **)subCmds, "option", 0, &idx) != TCL_OK) {
8093 return TCL_ERROR;
8094 }
8095
8096 /* All options except "list" and "used" expect a technology argument */
8097 if (idx != ListIdx && idx != UsedIdx) {
8098 if (objc > 2) {
8099 technology = Tcl_GetString(objv[2]);
8100 nsptr = LookupTechnology(technology);
8101 if (nsptr == NULL) {
8102
8103 /* If the command is "objects" and has one or more */
8104 /* additional arguments, then a NULL nsptr is okay (new */
8105 /* technology will be created and added to the list). */
8106
8107 if (idx != ObjectsIdx || objc <= 3) {
8108
8109 /* If nsptr is NULL, then the technology should be */
8110 /* "none" or "user" */
8111
8112 if ((strstr(technology, "none") == NULL) &&
8113 (strstr(technology, "user") == NULL)) {
8114 Tcl_SetResult(interp, "Error: Unknown technology name!", NULL);
8115 return TCL_ERROR;
8116 }
8117 usertech = TRUE;
8118 }
8119 }
8120
8121 /* And if the user technology has been saved to a file, the technology */
8122 /* will have a NULL string. Also check for technology name "(user)", */
8123 /* although that is not supposed to happen. */
8124
8125 else if (*nsptr->technology == '\0')
8126 usertech = TRUE;
8127
8128 else if (!strcmp(nsptr->technology, "(user)"))
8129 usertech = TRUE;
8130 }
8131 else {
8132 Tcl_WrongNumArgs(interp, 1, objv, "<option> technology ?args ...?");
8133 return TCL_ERROR;
8134 }
8135 }
8136
8137 switch (idx) {
8138 case ListIdx:
8139 /* List all of the known technologies */
8140 olist = Tcl_NewListObj(0, NULL);
8141 for (nsptr = xobjs.technologies; nsptr != NULL; nsptr = nsptr->next) {
8142 Tcl_ListObjAppendElement(interp, olist,
8143 Tcl_NewStringObj(nsptr->technology,
8144 strlen(nsptr->technology)));
8145 }
8146 Tcl_SetObjResult(interp, olist);
8147 break;
8148
8149 case UsedIdx:
8150 /* List all of the technologies used by the schematic of the */
8151 /* indicated (or current) page. That is, enumerate all */
8152 /* in the hierarchy of the schematic, and list all unique */
8153 /* technology prefixes. */
8154
8155 result = ParsePageArguments(interp, objc - 1, objv + 1, &nidx, &pageno);
8156 if (result != TCL_OK) return result;
8157 olist = Tcl_NewListObj(0, NULL);
8158
8159 pagelist = pagetotals(pageno, TOTAL_PAGES);
8160 for (j = 0; j < xobjs.pages; j++) {
8161 if (pagelist[j] > 0) {
8162 objinstptr tinst;
8163 objectptr tpage = xobjs.pagelist[j]->pageinst->thisobject;
8164 genericptr *tgen;
8165
8166 for (tgen = tpage->plist; tgen < tpage->plist + tpage->parts; tgen++) {
8167 if ((*tgen)->type == OBJINST) {
8168 tinst = TOOBJINST(tgen);
8169 nsptr = GetObjectTechnology(tinst->thisobject);
8170 if (nsptr != NULL) {
8171 if ((nsptr->technology == NULL) ||
8172 (strlen(nsptr->technology) == 0)) continue;
8173 if (!(nsptr->flags & TECH_USED)) {
8174 Tcl_ListObjAppendElement(interp, olist,
8175 Tcl_NewStringObj(nsptr->technology,
8176 strlen(nsptr->technology)));
8177 nsptr->flags |= TECH_USED;
8178 }
8179 }
8180 }
8181 }
8182 }
8183 }
8184 Tcl_SetObjResult(interp, olist);
8185 for (nsptr = xobjs.technologies; nsptr != NULL; nsptr = nsptr->next)
8186 nsptr->flags &= ~TECH_USED;
8187 free((char *)pagelist);
8188 break;
8189
8190 case ObjectsIdx:
8191
8192 if (objc > 3) {
8193 int numobjs, objnamelen, technamelen;
8194 Tcl_Obj *tobj;
8195 char *cptr;
8196 TechPtr otech;
8197
8198 /* Check that 4th argument is a list of objects or that */
8199 /* 4th and higher arguments are all names of objects, and */
8200 /* that these objects are valid existing objects. */
8201
8202 if (objc == 4) {
8203 result = Tcl_ListObjLength(interp, objv[3], &numobjs);
8204 if (result != TCL_OK) return result;
8205 for (j = 0; j < numobjs; j++) {
8206 result = Tcl_ListObjIndex(interp, objv[3], j, &tobj);
8207 if (result != TCL_OK) return result;
8208 libobj = NameToObject(Tcl_GetString(tobj), NULL, FALSE);
8209 if (libobj == NULL) {
8210 Tcl_SetResult(interp, "No such object name", NULL);
8211 return TCL_ERROR;
8212 }
8213 }
8214 }
8215 else {
8216 for (j = 0; j < objc - 4; j++) {
8217 libobj = NameToObject(Tcl_GetString(objv[3 + j]), NULL, FALSE);
8218 if (libobj == NULL) {
8219 Tcl_SetResult(interp, "No such object name", NULL);
8220 return TCL_ERROR;
8221 }
8222 }
8223 }
8224
8225 /* Create a new technology if needed */
8226 technology = Tcl_GetString(objv[2]);
8227 if ((nsptr == NULL) && !usertech)
8228 AddNewTechnology(technology, NULL);
8229
8230 nsptr = LookupTechnology(technology);
8231 technamelen = (usertech) ? 0 : strlen(technology);
8232
8233
8234 /* Change the technology prefix of all the objects listed */
8235
8236 if (objc == 4) {
8237 result = Tcl_ListObjLength(interp, objv[3], &numobjs);
8238 if (result != TCL_OK) return result;
8239 for (j = 0; j < numobjs; j++) {
8240 result = Tcl_ListObjIndex(interp, objv[3], j, &tobj);
8241 if (result != TCL_OK) return result;
8242 libobj = NameToObject(Tcl_GetString(tobj), NULL, FALSE);
8243 cptr = strstr(libobj->name, "::");
8244 if (cptr == NULL) {
8245 objnamelen = strlen(libobj->name);
8246 memmove(libobj->name + technamelen + 2,
8247 libobj->name, (size_t)strlen(libobj->name));
8248 }
8249 else {
8250 otech = GetObjectTechnology(libobj);
8251 otech->flags |= TECH_CHANGED;
8252 objnamelen = strlen(cptr + 2);
8253 memmove(libobj->name + technamelen + 2,
8254 cptr + 2, (size_t)strlen(cptr + 2));
8255 }
8256
8257 if (!usertech) strcpy(libobj->name, technology);
8258 *(libobj->name + technamelen) = ':';
8259 *(libobj->name + technamelen + 1) = ':';
8260 *(libobj->name + technamelen + 2 + objnamelen) = '\0';
8261 }
8262 }
8263 else {
8264 for (j = 0; j < objc - 4; j++) {
8265 libobj = NameToObject(Tcl_GetString(objv[3 + j]), NULL, FALSE);
8266 cptr = strstr(libobj->name, "::");
8267 if (cptr == NULL) {
8268 objnamelen = strlen(libobj->name);
8269 memmove(libobj->name + technamelen + 2,
8270 libobj->name, (size_t)strlen(libobj->name));
8271 }
8272 else {
8273 otech = GetObjectTechnology(libobj);
8274 otech->flags |= TECH_CHANGED;
8275 objnamelen = strlen(cptr + 2);
8276 memmove(libobj->name + technamelen + 2,
8277 cptr + 2, (size_t)strlen(cptr + 2));
8278 }
8279
8280 if (!usertech) strcpy(libobj->name, technology);
8281 *(libobj->name + technamelen) = ':';
8282 *(libobj->name + technamelen + 1) = ':';
8283 *(libobj->name + technamelen + 2 + objnamelen) = '\0';
8284 }
8285 }
8286 if (nsptr != NULL) nsptr->flags |= TECH_CHANGED;
8287 break;
8288 }
8289
8290 /* List all objects having this technology */
8291
8292 olist = Tcl_NewListObj(0, NULL);
8293 for (ilib = 0; ilib < xobjs.numlibs; ilib++) {
8294 for (j = 0; j < xobjs.userlibs[ilib].number; j++) {
8295 libobj = *(xobjs.userlibs[ilib].library + j);
8296 if (GetObjectTechnology(libobj) == nsptr) {
8297 libobjname = strstr(libobj->name, "::");
8298 if (libobjname == NULL)
8299 libobjname = libobj->name;
8300 else
8301 libobjname += 2;
8302 Tcl_ListObjAppendElement(interp, olist,
8303 Tcl_NewStringObj(libobjname, strlen(libobjname)));
8304 }
8305 }
8306 }
8307 Tcl_SetObjResult(interp, olist);
8308 break;
8309
8310 case FileNameIdx:
8311 if (nsptr != NULL) {
8312 if (objc == 3) {
8313 if (nsptr->filename == NULL)
8314 Tcl_SetResult(interp, "(no associated file)", NULL);
8315 else
8316 Tcl_SetResult(interp, nsptr->filename, NULL);
8317 }
8318 else {
8319 if (nsptr->filename != NULL) free(nsptr->filename);
8320 nsptr->filename = strdup(Tcl_GetString(objv[3]));
8321 }
8322 }
8323 else {
8324 Tcl_SetResult(interp, "Valid technology is required", NULL);
8325 return TCL_ERROR;
8326 }
8327 break;
8328
8329 case ChangedIdx:
8330 if (objc == 4) {
8331 int bval;
8332 if (Tcl_GetBooleanFromObj(interp, objv[3], &bval) != TCL_OK)
8333 return TCL_ERROR;
8334 else if (bval == 1)
8335 nsptr->flags |= TECH_CHANGED;
8336 else
8337 nsptr->flags &= ~TECH_CHANGED;
8338 }
8339 else {
8340 tech_set_changes(nsptr); /* Ensure change flags are updated */
8341 Tcl_SetObjResult(interp,
8342 Tcl_NewBooleanObj(((nsptr->flags & TECH_CHANGED)
8343 == 0) ? FALSE : TRUE));
8344 }
8345 break;
8346
8347 case WritableIdx:
8348 case WriteableIdx:
8349 if (nsptr) {
8350 if (objc == 3) {
8351 Tcl_SetObjResult(interp,
8352 Tcl_NewBooleanObj(((nsptr->flags & TECH_READONLY) == 0)
8353 ? TRUE : FALSE));
8354 }
8355 else if (objc == 4) {
8356 int bval;
8357
8358 Tcl_GetBooleanFromObj(interp, objv[3], &bval);
8359 if (bval == 0)
8360 nsptr->flags |= TECH_READONLY;
8361 else
8362 nsptr->flags &= (~TECH_READONLY);
8363 }
8364 }
8365 else {
8366 Tcl_SetResult(interp, "Valid technology is required", NULL);
8367 return TCL_ERROR;
8368 }
8369 break;
8370
8371 case SaveIdx:
8372
8373 /* technology save [filename] */
8374 if ((objc == 3) && ((nsptr == NULL) || (nsptr->filename == NULL))) {
8375 Tcl_SetResult(interp, "Error: Filename is required.", NULL);
8376 return TCL_ERROR;
8377 }
8378 else if ((nsptr != NULL) && (objc == 4)) {
8379 /* Technology being saved under a different filename. */
8380 filename = Tcl_GetString(objv[3]);
8381
8382 /* Re-check read-only status of the file */
8383 nsptr->flags &= ~(TECH_READONLY);
8384 chklib = fopen(filename, "a");
8385 if (chklib == NULL)
8386 nsptr->flags |= TECH_READONLY;
8387 else
8388 fclose(chklib);
8389 }
8390 else if (objc == 4) {
8391 filename = Tcl_GetString(objv[3]);
8392 if (!usertech) AddNewTechnology(technology, filename);
8393 }
8394 else
8395 filename = nsptr->filename;
8396
8397 savetechnology((usertech) ? NULL : technology, filename);
8398 break;
8399 }
8400 return XcTagCallback(interp, objc, objv);
8401 }
8402
8403 /*----------------------------------------------------------------------*/
8404 /* The "library" command deals with library *pages* */
8405 /*----------------------------------------------------------------------*/
8406
8407 int xctcl_library(ClientData clientData, Tcl_Interp *interp,
8408 int objc, Tcl_Obj *CONST objv[])
8409 {
8410 char *filename = NULL, *objname, *argv;
8411 int j = 0, libnum = -1;
8412 int idx, nidx, result, res;
8413 Tcl_Obj *olist;
8414 Tcl_Obj **newobjv;
8415 int newobjc, hidmode;
8416 objectptr libobj;
8417 liblistptr spec;
8418 char *subCmds[] = {
8419 "load", "make", "directory", "next", "goto", "override",
8420 "handle", "import", "list", "compose", NULL
8421 };
8422 enum SubIdx {
8423 LoadIdx, MakeIdx, DirIdx, NextIdx, GoToIdx, OverrideIdx,
8424 HandleIdx, ImportIdx, ListIdx, ComposeIdx
8425 };
8426
8427 result = ParseLibArguments(interp, objc, objv, &nidx, &libnum);
8428 if ((result != TCL_OK) || (nidx < 0)) return result;
8429 else if ((objc - nidx) > 5) {
8430 Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
8431 return TCL_ERROR;
8432 }
8433 else if (objc <= (1 + nidx)) { /* No subcommand */
8434
8435 /* return index if name given; return name if index given. */
8436 /* return index if neither is given (current library) */
8437
8438 if (objc > 1) {
8439 int lnum; /* unused; only checks if argument is integer */
8440 char *lname;
8441 result = Tcl_GetIntFromObj(interp, objv[1], &lnum);
8442 if (result == TCL_OK) {
8443 lname = xobjs.libtop[libnum + LIBRARY]->thisobject->name;
8444 Tcl_SetObjResult(interp, Tcl_NewStringObj(lname, strlen(lname)));
8445 }
8446 else {
8447 result = TCL_OK;
8448 Tcl_SetObjResult(interp, Tcl_NewIntObj(libnum + 1));
8449 }
8450 }
8451 else
8452 Tcl_SetObjResult(interp, Tcl_NewIntObj(libnum + 1));
8453 idx = -1;
8454 }
8455 else if (Tcl_GetIndexFromObj(interp, objv[1 + nidx],
8456 (CONST84 char **)subCmds, "option", 0, &idx) != TCL_OK) {
8457
8458 /* Backwards compatibility: "library filename [number]" is */
8459 /* the same as "library [number] load filename" */
8460
8461 Tcl_ResetResult(interp);
8462 newobjv = (Tcl_Obj **)(&objv[1]);
8463 newobjc = objc - 1;
8464
8465 result = ParseLibArguments(interp, newobjc, newobjv, &nidx, &libnum);
8466 if (result != TCL_OK) return result;
8467
8468 idx = LoadIdx;
8469 filename = Tcl_GetString(newobjv[0]);
8470 }
8471
8472 /* libnum = -1 is equivalent to "USER LIBRARY" */
8473 if (libnum < 0) libnum = xobjs.numlibs - 1;
8474
8475 switch (idx) {
8476 case LoadIdx:
8477 TechReplaceSave();
8478
8479 /* library [<name>|<number>] load <filename> [-replace [library]] */
8480 if (objc < (3 + nidx)) {
8481 Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
8482 return TCL_ERROR;
8483 }
8484 if (filename == NULL) filename = Tcl_GetString(objv[2 + nidx]);
8485
8486 /* if loading of default libraries is not overridden, load them first */
8487
8488 if (!(flags & (LIBOVERRIDE | LIBLOADED))) {
8489 result = defaultscript();
8490 flags |= LIBLOADED;
8491 }
8492
8493 /* If library number is out of range, create a new library */
8494 /* libnum = -1 is equivalent to the user library page. */
8495
8496 if (libnum > (xobjs.numlibs - 1))
8497 libnum = createlibrary(FALSE);
8498 else if (libnum < 0)
8499 libnum = USERLIB;
8500 else
8501 libnum += LIBRARY;
8502
8503 if (objc > (3 + nidx)) {
8504 argv = Tcl_GetString(objv[3 + nidx]);
8505 if ((*argv == '-') && !strncmp(argv, "-repl", 5)) {
8506 if (objc > (4 + nidx)) {
8507 char *techstr = Tcl_GetString(objv[3 + nidx]);
8508 if (!strcmp(techstr, "all")) TechReplaceAll();
8509 else if (!strcmp(techstr, "none")) TechReplaceNone();
8510 else {
8511 TechPtr nsptr = LookupTechnology(techstr);
8512 if (nsptr != NULL)
8513 nsptr->flags |= TECH_REPLACE;
8514 }
8515 }
8516 else
8517 TechReplaceAll(); /* replace ALL */
8518 }
8519 }
8520
8521 strcpy(_STR, filename);
8522 res = loadlibrary(libnum);
8523 if (res == False) {
8524 res = loadfile(2, libnum);
8525 TechReplaceRestore();
8526 if (res == False) {
8527 Tcl_SetResult(interp, "Error loading library.\n", NULL);
8528 return TCL_ERROR;
8529 }
8530 }
8531 TechReplaceRestore();
8532 break;
8533
8534 case ImportIdx:
8535 /* library [<name>|<number>] import <filename> <objectname> */
8536 if (objc != (4 + nidx)) {
8537 Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
8538 return TCL_ERROR;
8539 }
8540 if (filename == NULL) filename = Tcl_GetString(objv[2 + nidx]);
8541
8542 /* if loading of default libraries is not overridden, load them first */
8543
8544 if (!(flags & (LIBOVERRIDE | LIBLOADED))) {
8545 defaultscript();
8546 flags |= LIBLOADED;
8547 }
8548
8549 if ((libnum >= xobjs.numlibs) || (libnum < 0))
8550 libnum = createlibrary(FALSE);
8551 else
8552 libnum += LIBRARY;
8553
8554 objname = Tcl_GetString(objv[3 + nidx]);
8555 importfromlibrary(libnum, filename, objname);
8556 break;
8557
8558 case ListIdx:
8559
8560 if (!strncmp(Tcl_GetString(objv[objc - 1]), "-vis", 4))
8561 hidmode = 1; /* list visible objects only */
8562 else if (!strncmp(Tcl_GetString(objv[objc - 1]), "-hid", 4))
8563 hidmode = 2; /* list hidden objects only */
8564 else
8565 hidmode = 3; /* list everything */
8566
8567 /* library [name|number] list [-visible|-hidden] */
8568 olist = Tcl_NewListObj(0, NULL);
8569 for (j = 0; j < xobjs.userlibs[libnum].number; j++) {
8570 libobj = *(xobjs.userlibs[libnum].library + j);
8571 if (((libobj->hidden) && (hidmode & 2)) ||
8572 ((!libobj->hidden) && (hidmode & 1)))
8573 Tcl_ListObjAppendElement(interp, olist,
8574 Tcl_NewStringObj(libobj->name, strlen(libobj->name)));
8575 }
8576 Tcl_SetObjResult(interp, olist);
8577 break;
8578
8579 case HandleIdx:
8580
8581 if (objc == (3 + nidx)) {
8582 /* library [name|number] handle <object name> */
8583
8584 olist = Tcl_NewListObj(0, NULL);
8585 for (spec = xobjs.userlibs[libnum].instlist; spec != NULL;
8586 spec = spec->next) {
8587 libobj = spec->thisinst->thisobject;
8588 if (!strcmp(libobj->name, Tcl_GetString(objv[objc - 1])))
8589 Tcl_ListObjAppendElement(interp, olist,
8590 Tcl_NewHandleObj((genericptr)spec->thisinst));
8591 }
8592 Tcl_SetObjResult(interp, olist);
8593 }
8594 else if (objc == (2 + nidx)) {
8595 /* library [name|number] handle */
8596
8597 olist = Tcl_NewListObj(0, NULL);
8598 for (spec = xobjs.userlibs[libnum].instlist; spec != NULL;
8599 spec = spec->next) {
8600 Tcl_ListObjAppendElement(interp, olist,
8601 Tcl_NewHandleObj((genericptr)spec->thisinst));
8602 }
8603 Tcl_SetObjResult(interp, olist);
8604 }
8605 else {
8606 Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
8607 return TCL_ERROR;
8608 }
8609 break;
8610
8611 case ComposeIdx:
8612 composelib(libnum + LIBRARY);
8613 centerview(xobjs.libtop[libnum + LIBRARY]);
8614 break;
8615
8616 case MakeIdx:
8617 /* library make [name] */
8618 if (nidx == 1) {
8619 Tcl_SetResult(interp, "syntax is: library make [<name>]", NULL);
8620 return TCL_ERROR;
8621 }
8622
8623 /* If the (named or numbered) library exists, don't create it. */
8624 /* ParseLibArguments() returns the library number for the User */
8625 /* Library. The User Library always exists and cannot be */
8626 /* created or destroyed, so it's okay to use it as a check for */
8627 /* "no library found". */
8628
8629 if (libnum == xobjs.numlibs - 1)
8630 libnum = createlibrary(TRUE);
8631
8632 if (objc == 3) {
8633 strcpy(xobjs.libtop[libnum]->thisobject->name, Tcl_GetString(objv[2]));
8634 renamelib(libnum);
8635 composelib(LIBLIB);
8636 }
8637 /* Don't go to the library page---use "library goto" instead */
8638 /* startcatalog((Tk_Window)clientData, libnum, NULL); */
8639 break;
8640
8641 case DirIdx:
8642 /* library directory */
8643 if ((nidx == 0) && (objc == 2)) {
8644 startcatalog(NULL, LIBLIB, NULL);
8645 }
8646 else if ((nidx == 0) && (objc == 3) &&
8647 !strcmp(Tcl_GetString(objv[2]), "list")) {
8648 olist = Tcl_NewListObj(0, NULL);
8649 for (j = 0; j < xobjs.numlibs; j++) {
8650 libobj = xobjs.libtop[j + LIBRARY]->thisobject;
8651 Tcl_ListObjAppendElement(interp, olist,
8652 Tcl_NewStringObj(libobj->name, strlen(libobj->name)));
8653 }
8654 Tcl_SetObjResult(interp, olist);
8655 }
8656 else {
8657 Tcl_SetResult(interp, "syntax is: library directory [list]", NULL);
8658 return TCL_ERROR;
8659 }
8660 break;
8661
8662 case NextIdx:
8663 libnum = is_library(topobject);
8664 if (++libnum >= xobjs.numlibs) libnum = 0; /* fall through */
8665
8666 case GoToIdx:
8667 /* library go */
8668 startcatalog(NULL, LIBRARY + libnum, NULL);
8669 break;
8670 case OverrideIdx:
8671 flags |= LIBOVERRIDE;
8672 return TCL_OK; /* no tag callback */
8673 break;
8674 }
8675 return (result == TCL_OK) ? XcTagCallback(interp, objc, objv) : result;
8676 }
8677
8678 /*----------------------------------------------------------------------*/
8679 /* "bindkey" command --- this is a direct implementation of the same */
8680 /* key binding found in the "ad-hoc" and Python interfaces; it is */
8681 /* preferable to make use of the Tk "bind" command directly, and work */
8682 /* from the event handler. */
8683 /*----------------------------------------------------------------------*/
8684
8685 int xctcl_bind(ClientData clientData, Tcl_Interp *interp,
8686 int objc, Tcl_Obj *CONST objv[])
8687 {
8688 Tk_Window window = (Tk_Window)NULL;
8689 XCWindowDataPtr searchwin;
8690 char *keyname, *commandname, *binding;
8691 int keywstate, func = -1, value = -1;
8692 int result;
8693 Boolean compat = FALSE;
8694
8695 if (objc == 2) {
8696 keyname = Tcl_GetString(objv[1]);
8697 if (!strcmp(keyname, "override")) {
8698 flags |= KEYOVERRIDE;
8699 return TCL_OK; /* no tag callback */
8700 }
8701 }
8702
8703 if (!(flags & KEYOVERRIDE)) {
8704 default_keybindings();
8705 flags |= KEYOVERRIDE;
8706 }
8707
8708 if (objc == 1) {
8709 Tcl_Obj *list;
8710 int i;
8711
8712 list = Tcl_NewListObj(0, NULL);
8713 for (i = 0; i < NUM_FUNCTIONS; i++) {
8714 commandname = func_to_string(i);
8715 Tcl_ListObjAppendElement(interp, list,
8716 Tcl_NewStringObj(commandname, strlen(commandname)));
8717 }
8718 Tcl_SetObjResult(interp, list);
8719 return TCL_OK;
8720 }
8721 else if (objc > 5) {
8722 Tcl_WrongNumArgs(interp, 1, objv,
8723 "[<key> [<window>] [<command> [<value>|forget]]]");
8724 return TCL_ERROR;
8725 }
8726
8727 /* If 1st argument matches a window name, create a window-specific */
8728 /* binding. Otherwise, create a binding for all windows. */
8729
8730 if (objc > 1) {
8731 window = Tk_NameToWindow(interp, Tcl_GetString(objv[1]), Tk_MainWindow(interp));
8732 if (window == (Tk_Window)NULL)
8733 Tcl_ResetResult(interp);
8734 else {
8735 for (searchwin = xobjs.windowlist; searchwin != NULL; searchwin =
8736 searchwin->next)
8737 if (searchwin->area == window)
8738 break;
8739 if (searchwin != NULL) {
8740 /* Shift arguments */
8741 objc--;
8742 objv++;
8743 }
8744 else
8745 window = (xcWidget)NULL;
8746 }
8747 }
8748
8749 /* 1st argument can be option "-compatible" */
8750 if ((objc > 1) && !strncmp(Tcl_GetString(objv[1]), "-comp", 5)) {
8751 objc--;
8752 objv++;
8753 compat = TRUE;
8754 }
8755
8756 keyname = Tcl_GetString(objv[1]);
8757 keywstate = string_to_key(keyname);
8758
8759 /* 1st arg may be a function, not a key, if we want the binding returned */
8760 if ((objc == 3) && !strncmp(keyname, "-func", 5)) {
8761 keywstate = -1;
8762 func = string_to_func(Tcl_GetString(objv[2]), NULL);
8763 objc = 2;
8764 if (func == -1) {
8765 Tcl_SetResult(interp, "Invalid function name\n", NULL);
8766 return TCL_ERROR;
8767 }
8768 }
8769 else if ((objc == 2) && (keywstate == 0)) {
8770 keywstate = -1;
8771 func = string_to_func(keyname, NULL);
8772 }
8773
8774 if ((keywstate == -1 || keywstate == 0) && func == -1) {
8775 Tcl_SetResult(interp, "Invalid key name ", NULL);
8776 Tcl_AppendElement(interp, keyname);
8777 return TCL_ERROR;
8778 }
8779
8780 if (objc == 2) {
8781 if (keywstate == -1)
8782 binding = function_binding_to_string(window, func);
8783 else if (compat)
8784 binding = compat_key_to_string(window, keywstate);
8785 else
8786 binding = key_binding_to_string(window, keywstate);
8787 Tcl_SetResult(interp, binding, TCL_VOLATILE);
8788 free(binding);
8789 return TCL_OK;
8790 }
8791
8792 if (objc < 3) {
8793 Tcl_SetResult(interp, "Usage: bindkey <key> [<function>]\n", NULL);
8794 return TCL_ERROR;
8795 }
8796
8797 commandname = Tcl_GetString(objv[2]);
8798 if (strlen(commandname) == 0)
8799 func = -1;
8800 else
8801 func = string_to_func(commandname, NULL);
8802
8803 if (objc == 4) {
8804 result = Tcl_GetIntFromObj(interp, objv[3], &value);
8805 if (result != TCL_OK)
8806 {
8807 if (strcmp(Tcl_GetString(objv[3]), "forget"))
8808 return (result);
8809 else {
8810 /* Unbind command */
8811 Tcl_ResetResult(interp);
8812 result = remove_binding(window, keywstate, func);
8813 if (result == 0)
8814 return TCL_OK;
8815 else {
8816 Tcl_SetResult(interp, "Key/Function pair not found "
8817 "in binding list.\n", NULL);
8818 return TCL_ERROR;
8819 }
8820 }
8821 }
8822 }
8823 result = add_vbinding(window, keywstate, func, value);
8824 if (result == 1) {
8825 Tcl_SetResult(interp, "Key is already bound to a command.\n", NULL);
8826 return (result);
8827 }
8828 return (result == TCL_OK) ? XcTagCallback(interp, objc, objv) : result;
8829 }
8830
8831 /*----------------------------------------------------------------------*/
8832
8833 int xctcl_font(ClientData clientData, Tcl_Interp *interp,
8834 int objc, Tcl_Obj *CONST objv[])
8835 {
8836 char *fontname;
8837 int result;
8838
8839 /* font name */
8840 if (objc != 2) {
8841 Tcl_WrongNumArgs(interp, 1, objv, "fontname");
8842 return TCL_ERROR;
8843 }
8844 fontname = Tcl_GetString(objv[1]);
8845
8846 /* Allow overrides of the default font loading mechanism */
8847 if (!strcmp(fontname, "override")) {
8848 flags |= FONTOVERRIDE;
8849 return TCL_OK;
8850 }
8851
8852 /* If we need to load the default font "Helvetica" because no fonts */
8853 /* have been loaded yet, then we call this function twice, so that */
8854 /* the command tag callback gets applied both times. */
8855
8856 if (!(flags & FONTOVERRIDE)) {
8857 flags |= FONTOVERRIDE;
8858 xctcl_font(clientData, interp, objc, objv);
8859 loadfontfile("Helvetica");
8860 }
8861 result = loadfontfile((char *)fontname);
8862 if (result >= 1) {
8863 Tcl_SetObjResult(interp, Tcl_NewStringObj(fonts[fontcount - 1].family,
8864 strlen(fonts[fontcount - 1].family)));
8865 }
8866 switch (result) {
8867 case 1:
8868 return XcTagCallback(interp, objc, objv);
8869 case 0:
8870 return TCL_OK;
8871 case -1:
8872 return TCL_ERROR;
8873 }
8874 return TCL_ERROR; /* (jdk) */
8875 }
8876
8877 /*----------------------------------------------------------------------*/
8878 /* Set the X11 cursor to one of those defined in the XCircuit cursor */
8879 /* set (cursors.h) */
8880 /*----------------------------------------------------------------------*/
8881
8882 int xctcl_cursor(ClientData clientData, Tcl_Interp *interp,
8883 int objc, Tcl_Obj *CONST objv[])
8884 {
8885 int idx, result;
8886
8887 static char *cursNames[] = {
8888 "arrow", "cross", "scissors", "copy", "rotate", "edit",
8889 "text", "circle", "question", "wait", "hand", NULL
8890 };
8891
8892 if (!areawin) return TCL_ERROR;
8893
8894 /* cursor name */
8895 if (objc != 2) {
8896 Tcl_WrongNumArgs(interp, 1, objv, "cursor name");
8897 return TCL_ERROR;
8898 }
8899 if ((result = Tcl_GetIndexFromObj(interp, objv[1],
8900 (CONST84 char **)cursNames,
8901 "cursor name", 0, &idx)) != TCL_OK)
8902 return result;
8903
8904 XDefineCursor(dpy, areawin->window, appcursors[idx]);
8905 areawin->defaultcursor = &appcursors[idx];
8906 return XcTagCallback(interp, objc, objv);
8907 }
8908
8909 /*----------------------------------------------------------------------*/
8910
8911 int xctcl_filerecover(ClientData clientData, Tcl_Interp *interp,
8912 int objc, Tcl_Obj *CONST objv[])
8913 {
8914 if (objc != 1) {
8915 Tcl_WrongNumArgs(interp, 1, objv, "(no arguments)");
8916 return TCL_ERROR;
8917 }
8918 crashrecover();
8919 return XcTagCallback(interp, objc, objv);
8920 }
8921
8922 /*----------------------------------------------------------------------*/
8923 /* Replace the functions of the simple rcfile.c interpreter. */
8924 /*----------------------------------------------------------------------*/
8925
8926 /*----------------------------------------------------------------------*/
8927 /* Execute a single command from a script or from the command line */
8928 /*----------------------------------------------------------------------*/
8929
8930 short execcommand(short pflags, char *cmdptr)
8931 {
8932 flags = pflags;
8933 Tcl_Eval(xcinterp, cmdptr);
8934 refresh(NULL, NULL, NULL);
8935 return flags;
8936 }
8937
8938 /*----------------------------------------------------------------------*/
8939 /* Load the default script (like execscript() but don't allow recursive */
8940 /* loading of the startup script) */
8941 /*----------------------------------------------------------------------*/
8942
8943 int defaultscript()
8944 {
8945 FILE *fd;
8946 char *tmp_s = getenv((const char *)"XCIRCUIT_SRC_DIR");
8947 int result;
8948
8949 flags = LIBOVERRIDE | LIBLOADED | FONTOVERRIDE;
8950
8951 if (!tmp_s) tmp_s = SCRIPTS_DIR;
8952 sprintf(_STR2, "%s/%s", tmp_s, STARTUP_FILE);
8953
8954 if ((fd = fopen(_STR2, "r")) == NULL) {
8955 sprintf(_STR2, "%s/%s", SCRIPTS_DIR, STARTUP_FILE);
8956 if ((fd = fopen(_STR2, "r")) == NULL) {
8957 sprintf(_STR2, "%s/tcl/%s", SCRIPTS_DIR, STARTUP_FILE);
8958 if ((fd = fopen(_STR2, "r")) == NULL) {
8959 Wprintf("Failed to open startup script \"%s\"\n", STARTUP_FILE);
8960 return TCL_ERROR;
8961 }
8962 }
8963 }
8964 fclose(fd);
8965 result = Tcl_EvalFile(xcinterp, _STR2);
8966 return result;
8967 }
8968
8969 /*----------------------------------------------------------------------*/
8970 /* Execute a script */
8971 /*----------------------------------------------------------------------*/
8972
8973 void execscript()
8974 {
8975 FILE *fd;
8976
8977 flags = 0;
8978
8979 xc_tilde_expand(_STR2, 249);
8980 if ((fd = fopen(_STR2, "r")) != NULL) {
8981 fclose(fd);
8982 Tcl_EvalFile(xcinterp, _STR2);
8983 refresh(NULL, NULL, NULL);
8984 }
8985 else {
8986 Wprintf("Failed to open script file \"%s\"\n", _STR2);
8987 }
8988 }
8989
8990 /*----------------------------------------------------------------------*/
8991 /* Evaluate an expression from a parameter and return the result as a */
8992 /* Tcl object. The actual return value (TCL_OK, TCL_ERROR) is stored */
8993 /* in pointer "eval_status", if it is non-NULL. */
8994 /*----------------------------------------------------------------------*/
8995
8996 Tcl_Obj *evaluate_raw(objectptr thisobj, oparamptr ops, objinstptr pinst,
8997 int *eval_status)
8998 {
8999 Tcl_SavedResult state;
9000 Tcl_Obj *robj;
9001 int status;
9002 char *exprptr, *pptr, *pkey, *pnext;
9003
9004 /* Sanity check */
9005 if (ops->type != XC_EXPR) return NULL;
9006 exprptr = ops->parameter.expr;
9007 pnext = exprptr;
9008 if (pnext == NULL) return NULL;
9009
9010 /* Check for "@<parameter>" notation and substitute parameter values */
9011 while ((pptr = strchr(pnext, '@')) != NULL)
9012 {
9013 oparam temps;
9014 oparamptr ips;
9015 char psave, *promoted, *newexpr;
9016
9017 pptr++;
9018 for (pkey = pptr; *pkey && !isspace(*pkey); pkey++)
9019 if (*pkey == '{' || *pkey == '}' || *pkey == '[' || *pkey == ']' ||
9020 *pkey == '(' || *pkey == ')' || *pkey == ',')
9021 break;
9022
9023 if (pkey > pptr) {
9024 psave = *pkey;
9025 *pkey = '\0';
9026 if (pinst)
9027 ips = find_param(pinst, pptr);
9028 else
9029 ips = match_param(thisobj, pptr);
9030 if (ips == ops) {
9031 /* Avoid infinite recursion by treating a reference */
9032 /* to oneself as plain text. */
9033 ips = NULL;
9034 }
9035 if ((ips == NULL) && !strncmp(pptr, "p_", 2)) {
9036 ips = &temps;
9037 if (!strcmp(pptr + 2, "rotation")) {
9038 temps.type = XC_FLOAT;
9039 temps.parameter.fvalue = pinst ? pinst->rotation : 0;
9040 }
9041 else if (!strcmp(pptr + 2, "xposition")) {
9042 temps.type = XC_INT;
9043 temps.parameter.ivalue = pinst ? pinst->position.x : 0;
9044 }
9045 else if (!strcmp(pptr + 2, "yposition")) {
9046 temps.type = XC_INT;
9047 temps.parameter.ivalue = pinst ? pinst->position.y : 0;
9048 }
9049 else if (!strcmp(pptr + 2, "scale")) {
9050 temps.type = XC_FLOAT;
9051 temps.parameter.fvalue = pinst ? pinst->scale : 1.0;
9052 }
9053 else if (!strcmp(pptr + 2, "color")) {
9054 temps.type = XC_INT;
9055 temps.parameter.ivalue = pinst ? pinst->color : DEFAULTCOLOR;
9056 }
9057 else if (!strcmp(pptr + 2, "top_xposition")) {
9058 temps.type = XC_INT;
9059 UTopDrawingOffset(&temps.parameter.ivalue, NULL);
9060 }
9061 else if (!strcmp(pptr + 2, "top_yposition")) {
9062 temps.type = XC_INT;
9063 UTopDrawingOffset(NULL, &temps.parameter.ivalue);
9064 }
9065 else if (!strcmp(pptr + 2, "top_rotation")) {
9066 temps.type = XC_FLOAT;
9067 temps.parameter.fvalue = UTopRotation();
9068 }
9069 else if (!strcmp(pptr + 2, "top_scale")) {
9070 temps.type = XC_FLOAT;
9071 temps.parameter.fvalue = UTopDrawingScale();
9072 }
9073 else
9074 ips = NULL;
9075 }
9076 *pkey = psave;
9077 if (ips != NULL) {
9078 switch (ips->type) {
9079 case XC_INT:
9080 promoted = malloc(12);
9081 snprintf(promoted, 12, "%d", ips->parameter.ivalue);
9082 break;
9083 case XC_FLOAT:
9084 promoted = malloc(12);
9085 snprintf(promoted, 12, "%g", ips->parameter.fvalue);
9086 break;
9087 case XC_STRING:
9088 promoted = textprint(ips->parameter.string, pinst);
9089 break;
9090 case XC_EXPR:
9091 /* We really ought to prevent infinite loops here. . .*/
9092 promoted = evaluate_expr(thisobj, ips, pinst);
9093 break;
9094 }
9095 if (promoted == NULL) break;
9096 newexpr = (char *)malloc(1 + strlen(exprptr) +
9097 (max(strlen(promoted), strlen(pkey))));
9098 *(pptr - 1) = '\0';
9099 strcpy(newexpr, exprptr);
9100 *(pptr - 1) = '@';
9101 strcat(newexpr, promoted);
9102 pnext = newexpr + strlen(newexpr); /* For next search of '@' escape */
9103 strcat(newexpr, pkey);
9104 free(promoted);
9105 if (exprptr != ops->parameter.expr) free(exprptr);
9106 exprptr = newexpr;
9107 }
9108 else {
9109 /* Ignore the keyword and move to the end */
9110 pnext = pkey;
9111 }
9112 }
9113 }
9114
9115 /* Evaluate the expression in TCL */
9116
9117 Tcl_SaveResult(xcinterp, &state);
9118 status = Tcl_Eval(xcinterp, exprptr);
9119 robj = Tcl_GetObjResult(xcinterp);
9120 Tcl_IncrRefCount(robj);
9121 Tcl_RestoreResult(xcinterp, &state);
9122 if (eval_status) *eval_status = status;
9123 if (exprptr != ops->parameter.expr) free(exprptr);
9124 return robj;
9125 }
9126
9127 /*----------------------------------------------------------------------*/
9128 /* Evaluate an expression from a parameter and return the result as an */
9129 /* allocated string. */
9130 /*----------------------------------------------------------------------*/
9131
9132 char *evaluate_expr(objectptr thisobj, oparamptr ops, objinstptr pinst)
9133 {
9134 Tcl_Obj *robj;
9135 char *rexpr = NULL;
9136 int status, ip = 0;
9137 float fp = 0.0;
9138 stringpart *tmpptr, *promote = NULL;
9139 oparamptr ips = (pinst == NULL) ? NULL : match_instance_param(pinst, ops->key);
9140
9141 robj = evaluate_raw(thisobj, ops, pinst, &status);
9142 if (robj != NULL) {
9143 rexpr = strdup(Tcl_GetString(robj));
9144 Tcl_DecrRefCount(robj);
9145 }
9146
9147 if ((status == TCL_ERROR) && (ips != NULL)) {
9148 switch(ips->type) {
9149 case XC_STRING:
9150 rexpr = textprint(ips->parameter.string, pinst);
9151 break;
9152 case XC_FLOAT:
9153 fp = ips->parameter.fvalue;
9154 break;
9155 }
9156 }
9157
9158 /* If a TCL expression contains a three digit octal value \ooo */
9159 /* then the string returned by TclEval() can contain a */
9160 /* multi-byte UTF-8 character. */
9161 /* */
9162 /* This multi-byte character needs to be converted back to a */
9163 /* character that can be displayed. */
9164 /* */
9165 /* The following fix assumes that at most two bytes will */
9166 /* represent any converted character. In this case, the most */
9167 /* significant digit (octal) of the first byte will be 3, and */
9168 /* the most significant digit of the second byte will be 2. */
9169 /* */
9170 /* See: https://en.wikipedia.org/wiki/UTF-8 */
9171
9172 if ((rexpr != NULL) && ((status == TCL_RETURN) || (status == TCL_OK))) {
9173 u_char *strptr1 = rexpr;
9174 u_char *strptr2 = rexpr;
9175 while (*strptr1 != '\0') {
9176 if (*strptr1 >= 0300 && *(strptr1 + 1) >= 0200) {
9177 *strptr2 = ((*strptr1 & ~0300) << 6) | (*(strptr1 + 1) & 0077);
9178 strptr1 += 2;
9179 } else {
9180 *strptr2 = *strptr1;
9181 strptr1++;
9182 }
9183 strptr2++;
9184 }
9185 if (*strptr1 == '\0')
9186 *strptr2 = *strptr1;
9187 }
9188
9189 /* If an instance redefines an expression, don't preserve */
9190 /* the result. It is necessary in this case that the */
9191 /* expression does not reference objects during redisplay, */
9192 /* or else the correct result will not be written to the */
9193 /* output. */
9194
9195 if ((ips != NULL) && (ips->type == XC_EXPR))
9196 return rexpr;
9197
9198 /* Preserve the result in the object instance; this will be */
9199 /* used when writing the output or when the result cannot */
9200 /* be evaluated (see above). */
9201
9202 if ((rexpr != NULL) && (status == TCL_OK) && (pinst != NULL)) {
9203 switch (ops->which) {
9204 case P_SUBSTRING: case P_EXPRESSION:
9205 if (ips == NULL) {
9206 ips = make_new_parameter(ops->key);
9207 ips->which = ops->which;
9208 ips->type = XC_STRING;
9209 ips->next = pinst->params;
9210 pinst->params = ips;
9211 }
9212 else {
9213 free(ips->parameter.string);
9214 }
9215 /* Promote the expression result to an XCircuit string type */
9216 tmpptr = makesegment(&promote, NULL);
9217 tmpptr->type = TEXT_STRING;
9218 tmpptr = makesegment(&promote, NULL);
9219 tmpptr->type = PARAM_END;
9220 promote->data.string = strdup(rexpr);
9221 ips->parameter.string = promote;
9222 break;
9223
9224 case P_COLOR: /* must be integer, exact to 32 bits */
9225 if (ips == NULL) {
9226 ips = make_new_parameter(ops->key);
9227 ips->which = ops->which;
9228 ips->next = pinst->params;
9229 pinst->params = ips;
9230 }
9231 /* Promote the expression result to type float */
9232 if (rexpr != NULL) {
9233 if (sscanf(rexpr, "%i", &ip) == 1)
9234 ips->parameter.ivalue = ip;
9235 else
9236 ips->parameter.ivalue = 0;
9237 }
9238 else
9239 ips->parameter.ivalue = ip;
9240 ips->type = XC_INT;
9241 break;
9242
9243 default: /* all others convert to type float */
9244 if (ips == NULL) {
9245 ips = make_new_parameter(ops->key);
9246 ips->which = ops->which;
9247 ips->next = pinst->params;
9248 pinst->params = ips;
9249 }
9250 /* Promote the expression result to type float */
9251 if (rexpr != NULL) {
9252 if (sscanf(rexpr, "%g", &fp) == 1)
9253 ips->parameter.fvalue = fp;
9254 else
9255 ips->parameter.fvalue = 0.0;
9256 }
9257 else
9258 ips->parameter.fvalue = fp;
9259 ips->type = XC_FLOAT;
9260 break;
9261 }
9262 }
9263 return rexpr;
9264 }
9265
9266 /*----------------------------------------------------------------------*/
9267 /* Execute the .xcircuitrc startup script */
9268 /*----------------------------------------------------------------------*/
9269
9270 int loadrcfile()
9271 {
9272 char *userdir = getenv((const char *)"HOME");
9273 FILE *fd;
9274 short i;
9275 int result = TCL_OK, result1 = TCL_OK;
9276
9277 /* Initialize flags */
9278
9279 flags = 0;
9280
9281 /* Try first in current directory, then look in user's home directory */
9282 /* First try looking for a file .xcircuitrc followed by a dash and */
9283 /* the program version; this allows backward compatibility of the rc */
9284 /* file in cases where a new version (e.g., 3 vs. 2) introduces */
9285 /* incompatible syntax. Thanks to Romano Giannetti for this */
9286 /* suggestion plus provided code. */
9287
9288 /* (names USER_RC_FILE and PROG_VERSION imported from Makefile) */
9289
9290 sprintf(_STR2, "%s-%s", USER_RC_FILE, PROG_VERSION);
9291 xc_tilde_expand(_STR2, 249);
9292 if ((fd = fopen(_STR2, "r")) == NULL) {
9293 /* Not found; check for the same in $HOME directory */
9294 if (userdir != NULL) {
9295 sprintf(_STR2, "%s/%s-%s", userdir, USER_RC_FILE, PROG_VERSION);
9296 if ((fd = fopen(_STR2, "r")) == NULL) {
9297 /* Not found again; check for rc file w/o version # in CWD */
9298 sprintf(_STR2, "%s", USER_RC_FILE);
9299 xc_tilde_expand(_STR2, 249);
9300 if ((fd = fopen(_STR2, "r")) == NULL) {
9301 /* last try: plain USER_RC_FILE in $HOME */
9302 sprintf(_STR2, "%s/%s", userdir, USER_RC_FILE);
9303 fd = fopen(_STR2, "r");
9304 }
9305 }
9306 }
9307 }
9308 if (fd != NULL) {
9309 fclose(fd);
9310 result = Tcl_EvalFile(xcinterp, _STR2);
9311 if (result != TCL_OK) {
9312 Fprintf(stderr, "Encountered error in startup file.");
9313 Fprintf(stderr, "%s\n", Tcl_GetStringResult(xcinterp));
9314 Fprintf(stderr, "Running default startup script instead.\n");
9315 }
9316 }
9317
9318 /* Add the default font if not loaded already */
9319
9320 if (!(flags & FONTOVERRIDE)) {
9321 loadfontfile("Helvetica");
9322 if (areawin->psfont == -1)
9323 for (i = 0; i < fontcount; i++)
9324 if (!strcmp(fonts[i].psname, "Helvetica")) {
9325 areawin->psfont = i;
9326 break;
9327 }
9328 }
9329 if (areawin->psfont == -1) areawin->psfont = 0;
9330
9331 setdefaultfontmarks();
9332
9333 /* arrange the loaded libraries */
9334
9335 if ((result != TCL_OK) || !(flags & (LIBOVERRIDE | LIBLOADED))) {
9336 result1 = defaultscript();
9337 }
9338
9339 /* Add the default colors */
9340
9341 if (!(flags & COLOROVERRIDE)) {
9342 addnewcolorentry(xc_alloccolor("Gray40"));
9343 addnewcolorentry(xc_alloccolor("Gray60"));
9344 addnewcolorentry(xc_alloccolor("Gray80"));
9345 addnewcolorentry(xc_alloccolor("Gray90"));
9346 addnewcolorentry(xc_alloccolor("Red"));
9347 addnewcolorentry(xc_alloccolor("Blue"));
9348 addnewcolorentry(xc_alloccolor("Green2"));
9349 addnewcolorentry(xc_alloccolor("Yellow"));
9350 addnewcolorentry(xc_alloccolor("Purple"));
9351 addnewcolorentry(xc_alloccolor("SteelBlue2"));
9352 addnewcolorentry(xc_alloccolor("Red3"));
9353 addnewcolorentry(xc_alloccolor("Tan"));
9354 addnewcolorentry(xc_alloccolor("Brown"));
9355 addnewcolorentry(xc_alloccolor("#d20adc"));
9356 addnewcolorentry(xc_alloccolor("Pink"));
9357 }
9358
9359 if ((result != TCL_OK) || !(flags & KEYOVERRIDE)) {
9360 default_keybindings();
9361 }
9362 return (result1 != TCL_OK) ? result1 : result;
9363 }
9364
9365 /*----------------------------------------------------------------------*/
9366 /* Alternative button handler for use with Tk "bind" */
9367 /*----------------------------------------------------------------------*/
9368
9369 int xctcl_standardaction(ClientData clientData,
9370 Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])
9371 {
9372 int idx, result, knum, kstate;
9373 XKeyEvent kevent;
9374 static char *updown[] = {"up", "down", NULL};
9375
9376 if ((objc != 3) && (objc != 4)) goto badargs;
9377
9378 if ((result = Tcl_GetIntFromObj(interp, objv[1], &knum)) != TCL_OK)
9379 goto badargs;
9380
9381 if ((result = Tcl_GetIndexFromObj(interp, objv[2],
9382 (CONST84 char **)updown, "direction", 0, &idx)) != TCL_OK)
9383 goto badargs;
9384
9385 if (objc == 4) {
9386 if ((result = Tcl_GetIntFromObj(interp, objv[3], &kstate)) != TCL_OK)
9387 goto badargs;
9388 }
9389 else
9390 kstate = 0;
9391
9392 make_new_event(&kevent);
9393 kevent.state = kstate;
9394 kevent.keycode = 0;
9395
9396 if (idx == 0)
9397 kevent.type = KeyRelease;
9398 else
9399 kevent.type = KeyPress;
9400
9401 switch (knum) {
9402 case 1:
9403 kevent.state |= Button1Mask;
9404 break;
9405 case 2:
9406 kevent.state |= Button2Mask;
9407 break;
9408 case 3:
9409 kevent.state |= Button3Mask;
9410 break;
9411 case 4:
9412 kevent.state |= Button4Mask;
9413 break;
9414 case 5:
9415 kevent.state |= Button5Mask;
9416 break;
9417 default:
9418 kevent.keycode = knum;
9419 break;
9420 }
9421 #ifdef _MSC_VER
9422 if (kevent.state & Mod1Mask) {
9423 kevent.state &= ~Mod1Mask;
9424 }
9425 if (kevent.state & (AnyModifier<<2)) {
9426 kevent.state &= ~(AnyModifier<<2);
9427 kevent.state |= Mod1Mask;
9428 }
9429 #endif
9430 keyhandler((xcWidget)NULL, (caddr_t)NULL, &kevent);
9431 return TCL_OK;
9432
9433 badargs:
9434 Tcl_SetResult(interp, "Usage: standardaction <button_num> up|down [<keystate>]\n"
9435 "or standardaction <keycode> up|down [<keystate>]\n", NULL);
9436 return TCL_ERROR;
9437 }
9438
9439 /*----------------------------------------------------------------------*/
9440 /* Action handler for use with Tk "bind" */
9441 /* This dispatches events based on specific named actions that xcircuit */
9442 /* knows about, rather than by named key. This bypasses xcircuit's */
9443 /* key bindings. */
9444 /*----------------------------------------------------------------------*/
9445
9446 int xctcl_action(ClientData clientData,
9447 Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])
9448 {
9449 short value = 0;
9450 int function, result, ival;
9451 XPoint newpos, wpoint;
9452
9453 if (objc >= 2 && objc <= 4) {
9454 function = string_to_func(Tcl_GetString(objv[1]), &value);
9455 if (objc >= 3) {
9456 result = (short)Tcl_GetIntFromObj(interp, objv[2], &ival);
9457 if (result == TCL_ERROR) return TCL_ERROR;
9458 value = (short)ival;
9459 }
9460
9461 newpos = UGetCursorPos();
9462 user_to_window(newpos, &wpoint);
9463
9464 result = compatible_function(function);
9465 if (result == -1)
9466 Tcl_SetResult(interp, "Action not allowed\n", NULL);
9467
9468 result = functiondispatch(function, value, wpoint.x, wpoint.y);
9469 if (result == -1)
9470 Tcl_SetResult(interp, "Action not handled\n", NULL);
9471 }
9472 else {
9473 Tcl_SetResult(interp, "Usage: action <action_name> [<value>]\n", NULL);
9474 return TCL_ERROR;
9475 }
9476 return XcTagCallback(interp, objc, objv);
9477 }
9478
9479
9480 /*----------------------------------------------------------------------*/
9481 /* Argument-converting wrappers from Tk callback to Xt callback format */
9482 /*----------------------------------------------------------------------*/
9483
9484 void xctk_drawarea(ClientData clientData, XEvent *eventPtr)
9485 {
9486 Tcl_ServiceAll();
9487 if (areawin->topinstance != NULL)
9488 drawarea(areawin->area, (caddr_t)clientData, (caddr_t)NULL);
9489 }
9490
9491 /*----------------------------------------------------------------------*/
9492
9493 void xctk_resizearea(ClientData clientData, XEvent *eventPtr)
9494 {
9495 resizearea(areawin->area, (caddr_t)clientData, (caddr_t)NULL);
9496 /* Callback to function "arrangetoolbar" */
9497 Tcl_Eval(xcinterp, "catch {xcircuit::arrangetoolbar $XCOps(focus)}");
9498 }
9499
9500 /*----------------------------------------------------------------------*/
9501 /* Because Tk doesn't filter MotionEvent events based on context, we */
9502 /* have to filter the context here. */
9503 /*----------------------------------------------------------------------*/
9504
9505 void xctk_panhbar(ClientData clientData, XEvent *eventPtr)
9506 {
9507 XMotionEvent *mevent = (XMotionEvent *)eventPtr;
9508 u_int state = mevent->state;
9509 if (state & (Button1Mask | Button2Mask))
9510 panhbar(areawin->scrollbarh, (caddr_t)clientData, (XButtonEvent *)eventPtr);
9511 }
9512
9513 /*----------------------------------------------------------------------*/
9514
9515 void xctk_panvbar(ClientData clientData, XEvent *eventPtr)
9516 {
9517 XMotionEvent *mevent = (XMotionEvent *)eventPtr;
9518 u_int state = mevent->state;
9519 if (state & (Button1Mask | Button2Mask))
9520 panvbar(areawin->scrollbarv, (caddr_t)clientData, (XButtonEvent *)eventPtr);
9521 }
9522
9523 /*----------------------------------------------------------------------*/
9524
9525 void xctk_drawhbar(ClientData clientData, XEvent *eventPtr)
9526 {
9527 if (areawin->topinstance)
9528 drawhbar(areawin->scrollbarh, (caddr_t)clientData, (caddr_t)NULL);
9529 }
9530
9531 /*----------------------------------------------------------------------*/
9532
9533 void xctk_drawvbar(ClientData clientData, XEvent *eventPtr)
9534 {
9535 if (areawin->topinstance)
9536 drawvbar(areawin->scrollbarv, (caddr_t)clientData, (caddr_t)NULL);
9537 }
9538
9539 /*----------------------------------------------------------------------*/
9540
9541 void xctk_endhbar(ClientData clientData, XEvent *eventPtr)
9542 {
9543 if (areawin->topinstance)
9544 endhbar(areawin->scrollbarh, (caddr_t)clientData, (XButtonEvent *)eventPtr);
9545 }
9546
9547 /*----------------------------------------------------------------------*/
9548
9549 void xctk_endvbar(ClientData clientData, XEvent *eventPtr)
9550 {
9551 if (areawin->topinstance)
9552 endvbar(areawin->scrollbarv, (caddr_t)clientData, (XButtonEvent *)eventPtr);
9553 }
9554
9555 /*----------------------------------------------------------------------*/
9556
9557 void xctk_zoomview(ClientData clientData, XEvent *eventPtr)
9558 {
9559 zoomview((xcWidget)NULL, (caddr_t)clientData, (caddr_t)NULL);
9560 }
9561
9562 /*----------------------------------------------------------------------*/
9563
9564 void xctk_swapschem(ClientData clientData, XEvent *eventPtr)
9565 {
9566 swapschem((int)((pointertype)clientData), -1, NULL);
9567 }
9568
9569 /*----------------------------------------------------------------------*/
9570
9571 void xctk_drag(ClientData clientData, XEvent *eventPtr)
9572 {
9573 XButtonEvent *b_event = (XButtonEvent *)eventPtr;
9574
9575 drag((int)b_event->x, (int)b_event->y);
9576 flusharea();
9577 #ifdef HAVE_CAIRO
9578 if (areawin->redraw_needed)
9579 drawarea(NULL, NULL, NULL);
9580 #endif /* HAVE_CAIRO */
9581 }
9582
9583 /*----------------------------------------------------------------------*/
9584 /* This really should be set up so that the "okay" button command tcl */
9585 /* procedure does the job of lookdirectory(). */
9586 /*----------------------------------------------------------------------*/
9587
9588 void xctk_fileselect(ClientData clientData, XEvent *eventPtr)
9589 {
9590 XButtonEvent *beventPtr = (XButtonEvent *)eventPtr;
9591 popupstruct *listp = (popupstruct *)clientData;
9592 char curentry[150];
9593
9594 if (beventPtr->button == Button2) {
9595 Tcl_Eval(xcinterp, ".filelist.textent.txt get");
9596 sprintf(curentry, "%.149s", (char *)Tcl_GetStringResult(xcinterp));
9597
9598 if (strlen(curentry) > 0) {
9599 if (lookdirectory(curentry, 149))
9600 newfilelist(listp->filew, listp);
9601 else
9602 Tcl_Eval(xcinterp, ".filelist.bbar.okay invoke");
9603 }
9604 }
9605 else if (beventPtr->button == Button4) { /* scroll wheel binding */
9606 flstart--;
9607 showlscroll(listp->scroll, NULL, NULL);
9608 listfiles(listp->filew, listp, NULL);
9609 }
9610 else if (beventPtr->button == Button5) { /* scroll wheel binding */
9611 flstart++;
9612 showlscroll(listp->scroll, NULL, NULL);
9613 listfiles(listp->filew, listp, NULL);
9614 }
9615 else
9616 fileselect(listp->filew, listp, beventPtr);
9617 }
9618
9619 /*----------------------------------------------------------------------*/
9620
9621 void xctk_listfiles(ClientData clientData, XEvent *eventPtr)
9622 {
9623 popupstruct *listp = (popupstruct *)clientData;
9624 char *filter;
9625
9626 Tcl_Eval(xcinterp, ".filelist.listwin.win cget -data");
9627 filter = (char *)Tcl_GetStringResult(xcinterp);
9628
9629 if (filter != NULL) {
9630 if ((listp->filter == NULL) || (strcmp(filter, listp->filter))) {
9631 if (listp->filter != NULL)
9632 free(listp->filter);
9633 listp->filter = strdup(filter);
9634 newfilelist(listp->filew, listp);
9635 }
9636 else
9637 listfiles(listp->filew, listp, NULL);
9638 }
9639 else {
9640 if (listp->filter != NULL) {
9641 free(listp->filter);
9642 listp->filter = NULL;
9643 }
9644 listfiles(listp->filew, listp, NULL);
9645 }
9646 }
9647
9648 /*----------------------------------------------------------------------*/
9649
9650 void xctk_startfiletrack(ClientData clientData, XEvent *eventPtr)
9651 {
9652 startfiletrack((Tk_Window)clientData, NULL, (XCrossingEvent *)eventPtr);
9653 }
9654
9655 /*----------------------------------------------------------------------*/
9656
9657 void xctk_endfiletrack(ClientData clientData, XEvent *eventPtr)
9658 {
9659 endfiletrack((Tk_Window)clientData, NULL, (XCrossingEvent *)eventPtr);
9660 }
9661
9662 /*----------------------------------------------------------------------*/
9663
9664 void xctk_dragfilebox(ClientData clientData, XEvent *eventPtr)
9665 {
9666 dragfilebox((Tk_Window)clientData, NULL, (XMotionEvent *)eventPtr);
9667 }
9668
9669 /*----------------------------------------------------------------------*/
9670
9671 void xctk_draglscroll(ClientData clientData, XEvent *eventPtr)
9672 {
9673 popupstruct *listp = (popupstruct *)clientData;
9674 XMotionEvent *mevent = (XMotionEvent *)eventPtr;
9675 u_int state = mevent->state;
9676
9677 if (state & (Button1Mask | Button2Mask))
9678 draglscroll(listp->scroll, listp, (XButtonEvent *)eventPtr);
9679 }
9680
9681 /*----------------------------------------------------------------------*/
9682
9683 void xctk_showlscroll(ClientData clientData, XEvent *eventPtr)
9684 {
9685 showlscroll((Tk_Window)clientData, NULL, NULL);
9686 }
9687
9688 /*----------------------------------------------------------------------*/
9689 /* Build or rebuild the database of colors, fonts, and other settings */
9690 /* from the Tk option settings. */
9691 /*----------------------------------------------------------------------*/
9692
9693 void build_app_database(Tk_Window tkwind)
9694 {
9695 Tk_Uid xcuid;
9696
9697 /*--------------------------*/
9698 /* Build the color database */
9699 /*--------------------------*/
9700
9701 if ((xcuid = Tk_GetOption(tkwind, "globalpincolor", "Color")) == NULL)
9702 xcuid = "Orange2";
9703 appdata.globalcolor = xc_alloccolor((char *)xcuid);
9704 if ((xcuid = Tk_GetOption(tkwind, "localpincolor", "Color")) == NULL)
9705 xcuid = "Red";
9706 appdata.localcolor = xc_alloccolor((char *)xcuid);
9707 if ((xcuid = Tk_GetOption(tkwind, "infolabelcolor", "Color")) == NULL)
9708 xcuid = "SeaGreen";
9709 appdata.infocolor = xc_alloccolor((char *)xcuid);
9710 if ((xcuid = Tk_GetOption(tkwind, "ratsnestcolor", "Color")) == NULL)
9711 xcuid = "tan4";
9712 appdata.ratsnestcolor = xc_alloccolor((char *)xcuid);
9713
9714 if ((xcuid = Tk_GetOption(tkwind, "bboxcolor", "Color")) == NULL)
9715 xcuid = "greenyellow";
9716 appdata.bboxpix = xc_alloccolor((char *)xcuid);
9717
9718 if ((xcuid = Tk_GetOption(tkwind, "fixedbboxcolor", "Color")) == NULL)
9719 xcuid = "pink";
9720 appdata.fixedbboxpix = xc_alloccolor((char *)xcuid);
9721
9722 if ((xcuid = Tk_GetOption(tkwind, "clipcolor", "Color")) == NULL)
9723 xcuid = "powderblue";
9724 appdata.clipcolor = xc_alloccolor((char *)xcuid);
9725
9726 if ((xcuid = Tk_GetOption(tkwind, "paramcolor", "Color")) == NULL)
9727 xcuid = "Plum3";
9728 appdata.parampix = xc_alloccolor((char *)xcuid);
9729 if ((xcuid = Tk_GetOption(tkwind, "auxiliarycolor", "Color")) == NULL)
9730 xcuid = "Green3";
9731 appdata.auxpix = xc_alloccolor((char *)xcuid);
9732 if ((xcuid = Tk_GetOption(tkwind, "axescolor", "Color")) == NULL)
9733 xcuid = "Antique White";
9734 appdata.axespix = xc_alloccolor((char *)xcuid);
9735 if ((xcuid = Tk_GetOption(tkwind, "filtercolor", "Color")) == NULL)
9736 xcuid = "SteelBlue3";
9737 appdata.filterpix = xc_alloccolor((char *)xcuid);
9738 if ((xcuid = Tk_GetOption(tkwind, "selectcolor", "Color")) == NULL)
9739 xcuid = "Gold3";
9740 appdata.selectpix = xc_alloccolor((char *)xcuid);
9741 if ((xcuid = Tk_GetOption(tkwind, "snapcolor", "Color")) == NULL)
9742 xcuid = "Red";
9743 appdata.snappix = xc_alloccolor((char *)xcuid);
9744 if ((xcuid = Tk_GetOption(tkwind, "gridcolor", "Color")) == NULL)
9745 xcuid = "Gray95";
9746 appdata.gridpix = xc_alloccolor((char *)xcuid);
9747 if ((xcuid = Tk_GetOption(tkwind, "pagebackground", "Color")) == NULL)
9748 xcuid = "White";
9749 appdata.bg = xc_alloccolor((char *)xcuid);
9750 if ((xcuid = Tk_GetOption(tkwind, "pageforeground", "Color")) == NULL)
9751 xcuid = "Black";
9752 appdata.fg = xc_alloccolor((char *)xcuid);
9753
9754 if ((xcuid = Tk_GetOption(tkwind, "paramcolor2", "Color")) == NULL)
9755 xcuid = "Plum3";
9756 appdata.parampix2 = xc_alloccolor((char *)xcuid);
9757 if ((xcuid = Tk_GetOption(tkwind, "auxiliarycolor2", "Color")) == NULL)
9758 xcuid = "Green";
9759 appdata.auxpix2 = xc_alloccolor((char *)xcuid);
9760 if ((xcuid = Tk_GetOption(tkwind, "selectcolor2", "Color")) == NULL)
9761 xcuid = "Gold";
9762 appdata.selectpix2 = xc_alloccolor((char *)xcuid);
9763 if ((xcuid = Tk_GetOption(tkwind, "filtercolor2", "Color")) == NULL)
9764 xcuid = "SteelBlue1";
9765 appdata.gridpix2 = xc_alloccolor((char *)xcuid);
9766 if ((xcuid = Tk_GetOption(tkwind, "snapcolor2", "Color")) == NULL)
9767 xcuid = "Red";
9768 appdata.snappix2 = xc_alloccolor((char *)xcuid);
9769 if ((xcuid = Tk_GetOption(tkwind, "axescolor2", "Color")) == NULL)
9770 xcuid = "NavajoWhite4";
9771 appdata.axespix2 = xc_alloccolor((char *)xcuid);
9772 if ((xcuid = Tk_GetOption(tkwind, "background2", "Color")) == NULL)
9773 xcuid = "DarkSlateGray";
9774 appdata.bg2 = xc_alloccolor((char *)xcuid);
9775 if ((xcuid = Tk_GetOption(tkwind, "foreground2", "Color")) == NULL)
9776 xcuid = "White";
9777 appdata.fg2 = xc_alloccolor((char *)xcuid);
9778 if ((xcuid = Tk_GetOption(tkwind, "barcolor", "Color")) == NULL)
9779 xcuid = "Tan";
9780 appdata.barpix = xc_alloccolor((char *)xcuid);
9781
9782 /* These are GUI colors---unused by Tcl */
9783 appdata.buttonpix = xc_alloccolor("Gray85");
9784 appdata.buttonpix2 = xc_alloccolor("Gray50");
9785
9786 /* Get some default fonts (Should be using Tk calls here. . . ) */
9787
9788 if ((xcuid = Tk_GetOption(tkwind, "filelistfont", "Font")) == NULL)
9789 xcuid = "-*-helvetica-medium-r-normal--14-*";
9790 appdata.filefont = XLoadQueryFont(dpy, (char *)xcuid);
9791
9792 if (appdata.filefont == NULL)
9793 {
9794 appdata.filefont = XLoadQueryFont(dpy, "-*-*-medium-r-normal--14-*");
9795 if (appdata.filefont == NULL)
9796 appdata.filefont = XLoadQueryFont(dpy, "-*-*-*-*-*--*-*");
9797 }
9798
9799 /* Other defaults */
9800
9801 if ((xcuid = Tk_GetOption(tkwind, "timeout", "TimeOut")) == NULL)
9802 xcuid = "10";
9803 appdata.timeout = atoi((char *)xcuid);
9804 }
9805
9806 /*--------------------------------------------------------------*/
9807 /* GUI Initialization under Tk */
9808 /* First argument is the Tk path name of the drawing window. */
9809 /* This function should be called for each new window created. */
9810 /*--------------------------------------------------------------*/
9811
9812 XCWindowData *GUI_init(int objc, Tcl_Obj *CONST objv[])
9813 {
9814 Tk_Window tkwind, tktop, tkdraw, tksb;
9815 Tk_Window wsymb, wschema, corner;
9816 int i, locobjc, done = 1;
9817 XGCValues values;
9818 Window win;
9819 popupstruct *fileliststruct;
9820 char *xctopwin, *xcdrawwin;
9821 char winpath[512];
9822 XCWindowData *newwin;
9823
9824 tktop = Tk_MainWindow(xcinterp);
9825 if (tktop == (Tk_Window)NULL) {
9826 Fprintf(stderr, "No Top-Level Tk window available. . .\n");
9827
9828 /* No top level window, assuming batch mode. To get */
9829 /* access to font information requires that cairo be set */
9830 /* up with a surface, even if it is not an xlib target. */
9831
9832 newwin = create_new_window();
9833 newwin->area = NULL;
9834 newwin->scrollbarv = NULL;
9835 newwin->scrollbarh = NULL;
9836 newwin->width = 100;
9837 newwin->height = 100;
9838
9839 #ifdef HAVE_CAIRO
9840 newwin->surface = cairo_image_surface_create(CAIRO_FORMAT_RGB24,
9841 newwin->width, newwin->height);
9842 newwin->cr = cairo_create(newwin->surface);
9843 #endif /* !HAVE_CAIRO */
9844
9845 number_colors = NUMBER_OF_COLORS;
9846 colorlist = (colorindex *)malloc(NUMBER_OF_COLORS * sizeof(colorindex));
9847
9848 return newwin;
9849 }
9850
9851 /* Check if any parameter is a Tk window name */
9852
9853 locobjc = objc;
9854 while (locobjc > 0) {
9855 xctopwin = Tcl_GetString(objv[locobjc - 1]);
9856 tkwind = Tk_NameToWindow(xcinterp, xctopwin, tktop);
9857 if (tkwind != (Tk_Window)NULL)
9858 break;
9859 locobjc--;
9860 }
9861
9862 if (locobjc == 0) {
9863 /* Okay to have no GUI wrapper. However, if this is the case, */
9864 /* then the variable "XCOps(window)" must be set to the Tk path */
9865 /* name of the drawing window. */
9866
9867 xcdrawwin = (char *)Tcl_GetVar2(xcinterp, "XCOps", "window", 0);
9868 if (xcdrawwin == NULL) {
9869 Fprintf(stderr, "The Tk window hierarchy must be rooted at"
9870 " .xcircuit, or XCOps(top)");
9871 Fprintf(stderr, " must point to the hierarchy. If XCOps(top)"
9872 " is NULL, then XCOps(window) must");
9873 Fprintf(stderr, " point to the drawing window.\n");
9874 return NULL;
9875 }
9876 tkwind = Tk_NameToWindow(xcinterp, xcdrawwin, tktop);
9877 if (tkwind == NULL) {
9878 Fprintf(stderr, "Error: XCOps(window) is set but does not point to"
9879 " a valid Tk window.\n");
9880 return NULL;
9881 }
9882
9883 /* Create new window data structure */
9884 newwin = create_new_window();
9885 newwin->area = tkwind;
9886
9887 /* No GUI---GUI widget pointers need to be NULL'd */
9888 newwin->scrollbarv = NULL;
9889 newwin->scrollbarh = NULL;
9890 }
9891 else {
9892
9893 /* Expect a top-level window name passed as the first argument. */
9894 /* Having a fixed hierarchy is a total kludge and needs to be */
9895 /* rewritten. . . */
9896
9897 if (tkwind == NULL) {
9898 Fprintf(stderr, "Error: config init given a bad window name!\n");
9899 return NULL;
9900 }
9901 else {
9902 /* Make sure that this window does not already exist */
9903 XCWindowDataPtr searchwin;
9904 sprintf(winpath, "%s.mainframe.mainarea.drawing", xctopwin);
9905 tkdraw = Tk_NameToWindow(xcinterp, winpath, tktop);
9906 for (searchwin = xobjs.windowlist; searchwin != NULL; searchwin =
9907 searchwin->next) {
9908 if (searchwin->area == tkdraw) {
9909 Fprintf(stderr, "Error: window already exists!\n");
9910 return NULL;
9911 }
9912 }
9913 }
9914
9915 /* Create new window data structure and */
9916 /* fill in global variables from the Tk window values */
9917
9918 newwin = create_new_window();
9919 sprintf(winpath, "%s.mainframe.mainarea.sbleft", xctopwin);
9920 newwin->scrollbarv = Tk_NameToWindow(xcinterp, winpath, tktop);
9921 sprintf(winpath, "%s.mainframe.mainarea.sbbottom", xctopwin);
9922 newwin->scrollbarh = Tk_NameToWindow(xcinterp, winpath, tktop);
9923 sprintf(winpath, "%s.mainframe.mainarea.drawing", xctopwin);
9924 newwin->area = Tk_NameToWindow(xcinterp, winpath, tktop);
9925
9926 sprintf(winpath, "%s.mainframe.mainarea.corner", xctopwin);
9927 corner = Tk_NameToWindow(xcinterp, winpath, tktop);
9928
9929 sprintf(winpath, "%s.infobar.symb", xctopwin);
9930 wsymb = Tk_NameToWindow(xcinterp, winpath, tktop);
9931
9932 sprintf(winpath, "%s.infobar.schem", xctopwin);
9933 wschema = Tk_NameToWindow(xcinterp, winpath, tktop);
9934
9935 Tk_CreateEventHandler(newwin->scrollbarh, ButtonMotionMask,
9936 (Tk_EventProc *)xctk_panhbar, NULL);
9937 Tk_CreateEventHandler(newwin->scrollbarv, ButtonMotionMask,
9938 (Tk_EventProc *)xctk_panvbar, NULL);
9939 Tk_CreateEventHandler(newwin->scrollbarh, StructureNotifyMask | ExposureMask,
9940 (Tk_EventProc *)xctk_drawhbar, NULL);
9941 Tk_CreateEventHandler(newwin->scrollbarv, StructureNotifyMask | ExposureMask,
9942 (Tk_EventProc *)xctk_drawvbar, NULL);
9943 Tk_CreateEventHandler(newwin->scrollbarh, ButtonReleaseMask,
9944 (Tk_EventProc *)xctk_endhbar, NULL);
9945 Tk_CreateEventHandler(newwin->scrollbarv, ButtonReleaseMask,
9946 (Tk_EventProc *)xctk_endvbar, NULL);
9947
9948 Tk_CreateEventHandler(corner, ButtonPressMask,
9949 (Tk_EventProc *)xctk_zoomview, Number(1));
9950 Tk_CreateEventHandler(wsymb, ButtonPressMask,
9951 (Tk_EventProc *)xctk_swapschem, Number(0));
9952 Tk_CreateEventHandler(wschema, ButtonPressMask,
9953 (Tk_EventProc *)xctk_swapschem, Number(0));
9954
9955 /* Setup event handlers for the drawing area and scrollbars */
9956 /* There are purposely no callback functions for these windows---they are */
9957 /* defined as type "simple" to keep down the cruft, as I will define my */
9958 /* own event handlers. */
9959
9960 Tk_CreateEventHandler(newwin->area, StructureNotifyMask,
9961 (Tk_EventProc *)xctk_resizearea, NULL);
9962 Tk_CreateEventHandler(newwin->area, ExposureMask,
9963 (Tk_EventProc *)xctk_drawarea, NULL);
9964 }
9965
9966 if ((locobjc > 0) || !Tk_IsMapped(newwin->area)) {
9967
9968 /* This code copied from code for the "tkwait" command */
9969
9970 Tk_CreateEventHandler(newwin->area,
9971 VisibilityChangeMask|StructureNotifyMask,
9972 WaitVisibilityProc, (ClientData) &done);
9973 done = 0;
9974 }
9975
9976 /* Make sure the window is mapped */
9977
9978 Tk_MapWindow(tkwind);
9979 win = Tk_WindowId(tkwind);
9980 Tk_MapWindow(newwin->area);
9981
9982 if (!done) {
9983 while (!done) Tcl_DoOneEvent(0);
9984 Tk_DeleteEventHandler(newwin->area,
9985 VisibilityChangeMask|StructureNotifyMask,
9986 WaitVisibilityProc, (ClientData) &done);
9987 }
9988
9989 newwin->window = Tk_WindowId(newwin->area);
9990 newwin->width = Tk_Width(newwin->area);
9991 newwin->height = Tk_Height(newwin->area);
9992
9993 /* Things to set once only */
9994
9995 if (dpy == NULL) {
9996 dpy = Tk_Display(tkwind);
9997 cmap = Tk_Colormap(tkwind);
9998 // (The following may be required on some systems where
9999 // Tk will not report a valid colormap after Tk_MapWindow())
10000 // cmap = DefaultColormap(dpy, DefaultScreen(dpy));
10001
10002 /*------------------------------------------------------*/
10003 /* Handle different screen resolutions in a sane manner */
10004 /*------------------------------------------------------*/
10005
10006 screenDPI = getscreenDPI();
10007
10008 /*-------------------------*/
10009 /* Create stipple patterns */
10010 /*-------------------------*/
10011
10012 for (i = 0; i < STIPPLES; i++)
10013 STIPPLE[i] = XCreateBitmapFromData(dpy, win, STIPDATA[i], 4, 4);
10014
10015 /*----------------------------------------*/
10016 /* Allocate space for the basic color map */
10017 /*----------------------------------------*/
10018
10019 number_colors = NUMBER_OF_COLORS;
10020 colorlist = (colorindex *)malloc(NUMBER_OF_COLORS * sizeof(colorindex));
10021 areawin = newwin;
10022 build_app_database(tkwind);
10023 areawin = NULL;
10024
10025 /* Create the filelist window and its event handlers */
10026
10027 tksb = Tk_NameToWindow(xcinterp, ".filelist.listwin.sb", tktop);
10028 tkdraw = Tk_NameToWindow(xcinterp, ".filelist.listwin.win", tktop);
10029
10030 fileliststruct = (popupstruct *) malloc(sizeof(popupstruct));
10031 fileliststruct->popup = Tk_NameToWindow(xcinterp, ".filelist", tktop);
10032 fileliststruct->textw = Tk_NameToWindow(xcinterp, ".filelist.textent",
10033 fileliststruct->popup);
10034 fileliststruct->filew = tkdraw;
10035 fileliststruct->scroll = tksb;
10036 fileliststruct->setvalue = NULL;
10037 fileliststruct->filter = NULL;
10038
10039 if (tksb != NULL) {
10040 Tk_CreateEventHandler(tksb, ButtonMotionMask,
10041 (Tk_EventProc *)xctk_draglscroll, (ClientData)fileliststruct);
10042 Tk_CreateEventHandler(tksb, ExposureMask,
10043 (Tk_EventProc *)xctk_showlscroll, (ClientData)tksb);
10044 }
10045 if (tkdraw != NULL) {
10046 Tk_CreateEventHandler(tkdraw, ButtonPressMask,
10047 (Tk_EventProc *)xctk_fileselect, (ClientData)fileliststruct);
10048 Tk_CreateEventHandler(tkdraw, ExposureMask,
10049 (Tk_EventProc *)xctk_listfiles, (ClientData)fileliststruct);
10050 Tk_CreateEventHandler(tkdraw, EnterWindowMask,
10051 (Tk_EventProc *)xctk_startfiletrack, (ClientData)tkdraw);
10052 Tk_CreateEventHandler(tkdraw, LeaveWindowMask,
10053 (Tk_EventProc *)xctk_endfiletrack, (ClientData)tkdraw);
10054 }
10055 }
10056
10057 /*-------------------------------------------------------------------*/
10058 /* Generate the GC */
10059 /* Set "graphics_exposures" to False. Every XCopyArea function */
10060 /* copies from virtual memory (dbuf pixmap), which can never be */
10061 /* obscured. Otherwise, the server gets flooded with useless */
10062 /* NoExpose events. */
10063 /*-------------------------------------------------------------------*/
10064
10065 values.foreground = BlackPixel(dpy, DefaultScreen(dpy));
10066 values.background = WhitePixel(dpy, DefaultScreen(dpy));
10067 values.graphics_exposures = False;
10068 newwin->gc = XCreateGC(dpy, win, GCForeground | GCBackground
10069 | GCGraphicsExposures, &values);
10070
10071 #ifdef HAVE_CAIRO
10072 newwin->surface = cairo_xlib_surface_create(dpy, newwin->window,
10073 DefaultVisual(dpy, 0), newwin->width, newwin->height);
10074 newwin->cr = cairo_create(newwin->surface);
10075 #else /* HAVE_CAIRO */
10076 newwin->clipmask = XCreatePixmap(dpy, win, newwin->width,
10077 newwin->height, 1);
10078
10079 values.foreground = 0;
10080 values.background = 0;
10081 newwin->cmgc = XCreateGC(dpy, newwin->clipmask, GCForeground
10082 | GCBackground, &values);
10083 #endif /* HAVE_CAIRO */
10084
10085 XDefineCursor (dpy, win, *newwin->defaultcursor);
10086 return newwin;
10087 }
10088
10089 /*--------------------------------------*/
10090 /* Inline the main wrapper prodedure */
10091 /*--------------------------------------*/
10092
10093 int xctcl_start(ClientData clientData, Tcl_Interp *interp,
10094 int objc, Tcl_Obj *CONST objv[])
10095 {
10096 int result = TCL_OK;
10097 Boolean rcoverride = False;
10098 char *filearg = NULL;
10099 Tcl_Obj *cmdname = objv[0];
10100
10101 Fprintf(stdout, "Starting xcircuit under Tcl interpreter\n");
10102
10103 /* xcircuit initialization routines --- these assume that the */
10104 /* GUI has been created by the startup script; otherwise bad */
10105 /* things will probably occur. */
10106
10107 pre_initialize();
10108 areawin = GUI_init(--objc, ++objv);
10109 if (areawin == NULL) {
10110 /* Create new window data structure */
10111 areawin = create_new_window();
10112 areawin->area = NULL;
10113 areawin->scrollbarv = NULL;
10114 areawin->scrollbarh = NULL;
10115
10116 Tcl_SetResult(interp, "Invalid or missing top-level windowname"
10117 " given to start command, assuming batch mode.\n", NULL);
10118 }
10119 post_initialize();
10120
10121 ghostinit();
10122
10123 /* The Tcl version accepts some command-line arguments. Due */
10124 /* to the way ".wishrc" is processed, all arguments are */
10125 /* glommed into one Tcl (list) object, objv[1]. */
10126
10127 filearg = (char *)malloc(sizeof(char));
10128 *filearg = '\0';
10129
10130 if (objc == 2) {
10131 char **argv;
10132 int argc;
10133
10134 Tcl_SplitList(interp, Tcl_GetString(objv[1]), &argc,
10135 (CONST84 char ***)&argv);
10136 while (argc) {
10137 if (**argv == '-') {
10138 if (!strncmp(*argv, "-exec", 5)) {
10139 if (--argc > 0) {
10140 argv++;
10141 result = Tcl_EvalFile(interp, *argv);
10142 if (result != TCL_OK) {
10143 free(filearg);
10144 return result;
10145 }
10146 else
10147 rcoverride = True;
10148 }
10149 else {
10150 Tcl_SetResult(interp, "No filename given to exec argument.", NULL);
10151 free(filearg);
10152 return TCL_ERROR;
10153 }
10154 }
10155 else if (!strncmp(*argv, "-2", 2)) {
10156 /* 2-button mouse bindings option */
10157 pressmode = 1;
10158 }
10159 }
10160 else if (strcmp(*argv, ".xcircuit")) {
10161 filearg = (char *)realloc(filearg, sizeof(char) *
10162 (strlen(filearg) + strlen(*argv) + 2));
10163 strcat(filearg, ",");
10164 strcat(filearg, *argv);
10165 }
10166 argv++;
10167 argc--;
10168 }
10169 }
10170 else {
10171 /* Except---this appears to be no longer true. When did it change? */
10172 int argc = objc;
10173 char *argv;
10174
10175 for (argc = 0; argc < objc; argc++) {
10176 argv = Tcl_GetString(objv[argc]);
10177 if (*argv == '-') {
10178 if (!strncmp(argv, "-exec", 5)) {
10179 if (++argc < objc) {
10180 argv = Tcl_GetString(objv[argc]);
10181 result = Tcl_EvalFile(interp, argv);
10182 if (result != TCL_OK) {
10183 free(filearg);
10184 return result;
10185 }
10186 else
10187 rcoverride = True;
10188 }
10189 else {
10190 Tcl_SetResult(interp, "No filename given to exec argument.", NULL);
10191 free(filearg);
10192 return TCL_ERROR;
10193 }
10194 }
10195 else if (!strncmp(argv, "-2", 2)) {
10196 /* 2-button mouse bindings option */
10197 pressmode = 1;
10198 }
10199 }
10200 else if (strcmp(argv, ".xcircuit")) {
10201 filearg = (char *)realloc(filearg, sizeof(char) *
10202 (strlen(filearg) + strlen(argv) + 2));
10203 strcat(filearg, ",");
10204 strcat(filearg, argv);
10205 }
10206 }
10207 }
10208
10209 if (!rcoverride)
10210 result = loadrcfile();
10211
10212 composelib(PAGELIB); /* make sure we have a valid page list */
10213 composelib(LIBLIB); /* and library directory */
10214 if ((objc >= 2) && (*filearg != '\0')) {
10215 char *libname;
10216 int target = -1;
10217
10218 strcpy(_STR2, filearg);
10219 libname = (char *)Tcl_GetVar2(xcinterp, "XCOps", "library", 0);
10220 if (libname != NULL) {
10221 target = NameToLibrary(libname);
10222 }
10223 startloadfile((target >= 0) ? target + LIBRARY : -1);
10224 }
10225 else {
10226 findcrashfiles();
10227 }
10228 pressmode = 0; /* Done using this to track 2-button bindings */
10229
10230 /* Note that because the setup has the windows generated and */
10231 /* mapped prior to calling the xcircuit routines, nothing */
10232 /* gets CreateNotify, MapNotify, or other definitive events. */
10233 /* So, we have to do all the drawing once. */
10234
10235 xobjs.suspend = -1; /* Release from suspend mode */
10236 if (areawin->scrollbarv)
10237 drawvbar(areawin->scrollbarv, NULL, NULL);
10238 if (areawin->scrollbarh)
10239 drawhbar(areawin->scrollbarh, NULL, NULL);
10240 drawarea(areawin->area, NULL, NULL);
10241
10242 /* Return back to the interpreter; Tk is handling the GUI */
10243 free(filearg);
10244 return (result == TCL_OK) ? XcTagCallback(interp, 1, &cmdname) : result;
10245 }
10246
10247 /*--------------------------------------------------------------*/
10248 /* Message printing procedures for the Tcl version */
10249 /* */
10250 /* Evaluate the variable-length argument, and make a call to */
10251 /* the routine xcircuit::print, which should be defined. */
10252 /*--------------------------------------------------------------*/
10253
10254 void W0vprintf(char *window, const char *format, va_list args_in)
10255 {
10256 char tstr[128], *bigstr = NULL, *strptr;
10257 int n, size;
10258 va_list args;
10259
10260 if (window != NULL) {
10261 sprintf(tstr, "catch {xcircuit::print %s {", window);
10262 size = strlen(tstr);
10263
10264 va_copy(args, args_in);
10265 n = vsnprintf(tstr + size, 128 - size, format, args);
10266 va_end(args);
10267
10268 if (n <= -1 || n > 125 - size) {
10269 bigstr = malloc(n + size + 4);
10270 strncpy(bigstr, tstr, size);
10271 va_copy(args, args_in);
10272 vsnprintf(bigstr + size, n + 1, format, args);
10273 va_end(args);
10274 strptr = bigstr;
10275 strcat(bigstr, "}}");
10276 }
10277 else {
10278 strptr = tstr;
10279 strcat(tstr, "}}");
10280 }
10281 Tcl_Eval(xcinterp, strptr);
10282 if (bigstr != NULL) free(bigstr);
10283 }
10284 }
10285
10286 /* Prints to pagename window */
10287
10288 void W1printf(char *format, ...)
10289 {
10290 va_list args;
10291 va_start(args, format);
10292 W0vprintf("coord", format, args);
10293 va_end(args);
10294 }
10295
10296 /* Prints to coordinate window */
10297
10298 void W2printf(char *format, ...)
10299 {
10300 va_list args;
10301 va_start(args, format);
10302 W0vprintf("page", format, args);
10303 va_end(args);
10304 }
10305
10306 /* Prints to status window but does not tee output to the console. */
10307
10308 void W3printf(char *format, ...)
10309 {
10310 va_list args;
10311 va_start(args, format);
10312 W0vprintf("stat", format, args);
10313 va_end(args);
10314 }
10315
10316 /* Prints to status window and duplicates the output to stdout. */
10317
10318 void Wprintf(char *format, ...)
10319 {
10320 va_list args;
10321 va_start(args, format);
10322 W0vprintf("stat", format, args);
10323 if (strlen(format) > 0) {
10324 if (strstr(format, "Error")) {
10325 tcl_vprintf(stderr, format, args);
10326 tcl_printf(stderr, "\n");
10327 }
10328 else {
10329 tcl_vprintf(stdout, format, args);
10330 tcl_printf(stdout, "\n");
10331 }
10332 }
10333 va_end(args);
10334 }
10335
10336 /*------------------------------------------------------*/
10337
10338 #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.