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