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