Logo Search packages:      
Sourcecode: xcircuit version File versions

tclxcircuit.c

/*--------------------------------------------------------------*/
/* tclxcircuit.c:                               */
/*    Tcl routines for xcircuit command-line functions      */
/* Copyright (c) 2003  Tim Edwards, Johns Hopkins University    */
/*--------------------------------------------------------------*/

#if defined(TCL_WRAPPER) && !defined(HAVE_PYTHON)

#include <stdio.h>
#include <stdarg.h>     /* for va_copy() */
#include <stdlib.h>
#include <unistd.h>     /* for usleep() */
#include <string.h>
#include <sys/types.h>
#include <sys/stat.h>
#include <errno.h>

#include <tk.h>

#include <X11/Intrinsic.h>
#include <X11/StringDefs.h>

#include "xcircuit.h"
#include "cursors.h"
#include "colordefs.h"
#include "menudep.h"
#include "prototypes.h"

Tcl_HashTable XcTagTable;

extern Tcl_Interp *xcinterp;
extern Tcl_Interp *consoleinterp;
extern Display *dpy;
extern Colormap cmap;
extern Pixmap   STIPPLE[STIPPLES];  /* Polygon fill-style stipple patterns */
extern char _STR[150], _STR2[250];
extern Clientdata areastruct;
extern Globaldata xobjs;
extern int number_colors;
extern int *appcolors;
extern colorindex *colorlist;
extern Cursor appcursors[NUM_CURSORS];
extern ApplicationData appdata;
extern fontinfo *fonts;
extern short fontcount;
extern short eventmode;
extern u_char param_select[];

extern Tk_Window message1, message2, message3, wsymb, wschema, netbutton;
Tk_Window corner; /* In the Xt version, this was internal to xcircuit.c */

/* Can't be extern? */
static char STIPDATA[STIPPLES][4] = {
   "\000\004\000\001",
   "\000\005\000\012",
   "\001\012\005\010",
   "\005\012\005\012",
   "\016\005\012\007",
   "\017\012\017\005",
   "\017\012\017\016",
   "\000\000\000\000"
};

extern Tcl_Obj *Tcl_NewHandleObj();

short flags = -1;

#define LIBOVERRIDE     1
#define LIBLOADED       2
#define COLOROVERRIDE   4
#define FONTOVERRIDE    8
#define KEYOVERRIDE     16

/*----------------------------------------------------------------------*/
/* Deal with systems which don't define va_copy().                */
/*----------------------------------------------------------------------*/

#ifndef HAVE_VA_COPY
  #ifdef HAVE___VA_COPY
    #define va_copy(a, b) __va_copy(a, b)
  #else
    #define va_copy(a, b) a = b
  #endif
#endif

/*----------------------------------------------------------------------*/
/* Reimplement vfprintf() as a call to Tcl_Eval().                */
/*----------------------------------------------------------------------*/

void tcl_vprintf(FILE *f, const char *fmt, va_list args_in)
{
   va_list args;
   static char outstr[128] = "puts -nonewline std";
   char *outptr, *bigstr = NULL, *finalstr = NULL;
   int i, nchars, result, escapes = 0, limit;

   /* If we are printing an error message, we want to bring attention   */
   /* to it by mapping the console window and raising it, as necessary. */
   /* I'd rather do this internally than by Tcl_Eval(), but I can't     */
   /* find the right window ID to map!                            */

   if ((f == stderr) && (consoleinterp != xcinterp)) {
      Tk_Window tkwind;
      tkwind = Tk_MainWindow(consoleinterp);
      if ((tkwind != NULL) && (!Tk_IsMapped(tkwind)))
       result = Tcl_Eval(consoleinterp, "wm deiconify .\n");
      result = Tcl_Eval(consoleinterp, "raise .\n");
   }

   strcpy (outstr + 19, (f == stderr) ? "err \"" : "out \"");
   outptr = outstr;

   /* This mess circumvents problems with systems which do not have     */
   /* va_copy() defined.  Some define __va_copy();  otherwise we must   */
   /* assume that args = args_in is valid.                        */

   va_copy(args, args_in);
   nchars = vsnprintf(outptr + 24, 102, fmt, args);
   va_end(args);

   if (nchars >= 102) {
      va_copy(args, args_in);
      bigstr = Tcl_Alloc(nchars + 26);
      strncpy(bigstr, outptr, 24);
      outptr = bigstr;
      vsnprintf(outptr + 24, nchars + 2, fmt, args);
      va_end(args);
    }
    else if (nchars == -1) nchars = 126;

    for (i = 24; *(outptr + i) != '\0'; i++) {
       if (*(outptr + i) == '\"' || *(outptr + i) == '[' ||
            *(outptr + i) == ']' || *(outptr + i) == '\\')
        escapes++;
    }

    if (escapes > 0) {
      finalstr = Tcl_Alloc(nchars + escapes + 26);
      strncpy(finalstr, outptr, 24);
      escapes = 0;
      for (i = 24; *(outptr + i) != '\0'; i++) {
        if (*(outptr + i) == '\"' || *(outptr + i) == '[' ||
                  *(outptr + i) == ']' || *(outptr + i) == '\\') {
           *(finalstr + i + escapes) = '\\';
           escapes++;
        }
        *(finalstr + i + escapes) = *(outptr + i);
      }
      outptr = finalstr;
    }

    *(outptr + 24 + nchars + escapes) = '\"';
    *(outptr + 25 + nchars + escapes) = '\0';

    result = Tcl_Eval(consoleinterp, outptr);

    if (bigstr != NULL) Tcl_Free(bigstr);
    if (finalstr != NULL) Tcl_Free(finalstr);
}
    
/*------------------------------------------------------*/
/* Console output flushing which goes along with the  */
/* routine tcl_vprintf() above.                       */
/*------------------------------------------------------*/

void tcl_stdflush(FILE *f)
{   
   Tcl_SavedResult state;
   static char stdstr[] = "::flush stdxxx";
   char *stdptr = stdstr + 11;
    
   Tcl_SaveResult(xcinterp, &state);
   strcpy(stdptr, (f == stderr) ? "err" : "out");
   Tcl_Eval(xcinterp, stdstr);
   Tcl_RestoreResult(xcinterp, &state);
}

/*----------------------------------------------------------------------*/
/* Reimplement fprintf() as a call to Tcl_Eval().                 */
/*----------------------------------------------------------------------*/

void tcl_printf(FILE *f, const char *format, ...)
{
  va_list ap;

  va_start(ap, format);
  tcl_vprintf(f, format, ap);
  va_end(ap);
}

/*----------------------------------------------------------------------*/
/* Implement tag callbacks on functions                           */
/* Find any tags associated with a command and execute them.            */
/*----------------------------------------------------------------------*/

int XcTagCallback(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])
{
    int objidx, result = TCL_OK;
    char *postcmd, *substcmd, *newcmd, *sptr, *sres;
    char *croot = Tcl_GetString(objv[0]);
    Tcl_HashEntry *entry;
    Tcl_SavedResult state;
    int reset = FALSE;
    int cmdnum;

    /* Skip over namespace qualifier, if any */

    if (!strncmp(croot, "::", 2)) croot += 2;
    if (!strncmp(croot, "xcircuit::", 10)) croot += 10;

    entry = Tcl_FindHashEntry(&XcTagTable, croot);
    postcmd = (entry) ? (char *)Tcl_GetHashValue(entry) : NULL;

    if (postcmd)
    {
      substcmd = (char *)Tcl_Alloc(strlen(postcmd) + 1);
      strcpy(substcmd, postcmd);
      sptr = substcmd;

      /*--------------------------------------------------------------*/
      /* Parse "postcmd" for Tk-substitution escapes              */
      /* Allowed escapes are:                               */
      /*    %W    substitute the tk path of the calling window    */
      /*    %r    substitute the previous Tcl result string */
      /*    %R    substitute the previous Tcl result string and   */
      /*          reset the Tcl result.                     */
      /*    %[0-5]  substitute the argument to the original command     */
      /*    %%    substitute a single percent character           */
      /*    %*    (all others) no action: print as-is.            */
      /*--------------------------------------------------------------*/

      while ((sptr = strchr(sptr, '%')) != NULL)
      {
          switch (*(sptr + 1))
          {
            case 'W': {
                char *tkpath = NULL;
                Tk_Window tkwind = Tk_MainWindow(interp);
                if (tkwind != NULL) tkpath = Tk_PathName(tkwind);
                if (tkpath == NULL)
                  newcmd = (char *)Tcl_Alloc(strlen(substcmd));
                else
                  newcmd = (char *)Tcl_Alloc(strlen(substcmd) + strlen(tkpath));

                strcpy(newcmd, substcmd);

                if (tkpath == NULL)
                  strcpy(newcmd + (int)(sptr - substcmd), sptr + 2);
                else
                {
                  strcpy(newcmd + (int)(sptr - substcmd), tkpath);
                  strcat(newcmd, sptr + 2);
                }
                Tcl_Free(substcmd);
                substcmd = newcmd;
                sptr = substcmd;
                } break;

            case 'R':
                reset = TRUE;
            case 'r':
                sres = Tcl_GetStringResult(interp);
                newcmd = (char *)Tcl_Alloc(strlen(substcmd)
                        + strlen(sres) + 1);
                strcpy(newcmd, substcmd);
                sprintf(newcmd + (int)(sptr - substcmd), "\"%s\"", sres);
                strcat(newcmd, sptr + 2);
                Tcl_Free(substcmd);
                substcmd = newcmd;
                sptr = substcmd;
                break;

            case '0': case '1': case '2': case '3': case '4': case '5':
                objidx = (int)(*(sptr + 1) - '0');
                if ((objidx >= 0) && (objidx < objc))
                {
                    newcmd = (char *)Tcl_Alloc(strlen(substcmd)
                        + strlen(Tcl_GetString(objv[objidx])));
                    strcpy(newcmd, substcmd);
                  strcpy(newcmd + (int)(sptr - substcmd),
                        Tcl_GetString(objv[objidx]));
                  strcat(newcmd, sptr + 2);
                  Tcl_Free(substcmd);
                  substcmd = newcmd;
                  sptr = substcmd;
                }
                else if (objidx >= objc)
                {
                    newcmd = (char *)Tcl_Alloc(strlen(substcmd) + 1);
                    strcpy(newcmd, substcmd);
                  strcpy(newcmd + (int)(sptr - substcmd), sptr + 2);
                  Tcl_Free(substcmd);
                  substcmd = newcmd;
                  sptr = substcmd;
                }
                else sptr++;
                break;

            case '%':
                newcmd = (char *)Tcl_Alloc(strlen(substcmd) + 1);
                strcpy(newcmd, substcmd);
                strcpy(newcmd + (int)(sptr - substcmd), sptr + 1);
                Tcl_Free(substcmd);
                substcmd = newcmd;
                sptr = substcmd;
                break;

            default:
                break;
          }
      }

      /* Fprintf(stderr, "Substituted tag callback is \"%s\"\n", substcmd); */
      /* Flush(stderr); */

      Tcl_SaveResult(interp, &state);
      result = Tcl_Eval(interp, substcmd);
      if ((result == TCL_OK) && (reset == FALSE))
          Tcl_RestoreResult(interp, &state);
      else
          Tcl_DiscardResult(&state);

      Tcl_Free(substcmd);
    }
    return result;
}

/*--------------------------------------------------------------*/
/* Add a command tag callback                         */
/*--------------------------------------------------------------*/

int xctcl_tag(ClientData clientData,
        Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])
{
    Tcl_HashEntry *entry;
    char *hstring;
    int new;

    if (objc != 2 && objc != 3)
      return TCL_ERROR;

    entry = Tcl_CreateHashEntry(&XcTagTable, Tcl_GetString(objv[1]), &new);
    if (entry == NULL) return TCL_ERROR;

    hstring = (char *)Tcl_GetHashValue(entry);
    if (objc == 2)
    {
      Tcl_SetResult(interp, hstring, NULL);
      return TCL_OK;
    }

    if (strlen(Tcl_GetString(objv[2])) == 0)
    {
      Tcl_DeleteHashEntry(entry);
    }
    else
    {
      hstring = strdup(Tcl_GetString(objv[2]));
      Tcl_SetHashValue(entry, hstring);
    }
    return TCL_OK;
}

/*----------------------------------------------------------------------*/
/* Get an x,y position (as an XPoint structure) from a list of size 2   */
/*----------------------------------------------------------------------*/

int GetPositionFromList(Tcl_Interp *interp, Tcl_Obj *list, XPoint *rpoint)
{
   int result, numobjs;
   Tcl_Obj *lobj;
   int pos;

   if (!strcmp(Tcl_GetString(list), "here")) {
      if (rpoint) *rpoint = UGetCursorPos();
      return TCL_OK;
   }
   result = Tcl_ListObjLength(interp, list, &numobjs);
   if (result != TCL_OK) return result;

   if (numobjs != 2) {
      Tcl_SetResult(interp, "list must contain x y positions", NULL);
      return TCL_ERROR;
   }
   result = Tcl_ListObjIndex(interp, list, 0, &lobj);
   if (result != TCL_OK) return result;
   result = Tcl_GetIntFromObj(interp, lobj, &pos);
   if (result != TCL_OK) return result;
   if (rpoint) rpoint->x = pos;

   result = Tcl_ListObjIndex(interp, list, 1, &lobj);
   if (result != TCL_OK) return result;
   result = Tcl_GetIntFromObj(interp, lobj, &pos);
   if (result != TCL_OK) return result;
   if (rpoint) rpoint->y = pos;

   return TCL_OK;
}

/*--------------------------------------------------------------*/
/* Convert color index to a list of 3 elements              */
/* We assume that this color exists in the color table.           */
/*--------------------------------------------------------------*/

Tcl_Obj *TclIndexToRGB(int cidx)
{
   int i;
   Tcl_Obj *RGBTuple;

   if (cidx < 0) {      /* Handle "default color" */
      return Tcl_NewStringObj("Default", 7);
   }

   for (i = 0; i < number_colors; i++) {
      if (cidx == colorlist[i].color.pixel) {
       RGBTuple = Tcl_NewListObj(0, NULL);
       Tcl_ListObjAppendElement(xcinterp, RGBTuple,
            Tcl_NewIntObj((int)(colorlist[i].color.red / 256)));
       Tcl_ListObjAppendElement(xcinterp, RGBTuple,
            Tcl_NewIntObj((int)(colorlist[i].color.green / 256)));
       Tcl_ListObjAppendElement(xcinterp, RGBTuple,
            Tcl_NewIntObj((int)(colorlist[i].color.blue / 256)));
       return RGBTuple;
      }
   }
   Tcl_SetResult(xcinterp, "invalid or unknown color index", NULL);
   return NULL;
}


/*--------------------------------------------------------------*/
/* Convert a stringpart* to a Tcl list object               */
/*--------------------------------------------------------------*/

Tcl_Obj *TclGetStringParts(stringpart *thisstring)
{
   Tcl_Obj *lstr, *sdict, *stup;
   int i;
   stringpart *strptr;
   
   lstr = Tcl_NewListObj(0, NULL);
   for (strptr = thisstring, i = 0; strptr != NULL;
      strptr = strptr->nextpart, i++) {
      switch(strptr->type) {
       case TEXT_STRING:
          sdict = Tcl_NewListObj(0, NULL);
          Tcl_ListObjAppendElement(xcinterp, sdict, Tcl_NewStringObj("Text", 4));
          Tcl_ListObjAppendElement(xcinterp, sdict,
                  Tcl_NewStringObj(strptr->data.string,
                  strlen(strptr->data.string)));
          Tcl_ListObjAppendElement(xcinterp, lstr, sdict);
          break;
       case PARAM_START:
          sdict = Tcl_NewListObj(0, NULL);
          Tcl_ListObjAppendElement(xcinterp, sdict, Tcl_NewStringObj("Parameter", 9));
          Tcl_ListObjAppendElement(xcinterp, sdict,
                  Tcl_NewIntObj((int)strptr->data.paramno));
          Tcl_ListObjAppendElement(xcinterp, lstr, sdict);
          break;
       case PARAM_END:
          Tcl_ListObjAppendElement(xcinterp, lstr,
                  Tcl_NewStringObj("End Parameter", 13));
          break;
       case FONT_NAME:
          sdict = Tcl_NewListObj(0, NULL);
          Tcl_ListObjAppendElement(xcinterp, sdict, Tcl_NewStringObj("Font", 4));
          Tcl_ListObjAppendElement(xcinterp, sdict,
              Tcl_NewStringObj(fonts[strptr->data.font].psname,
              strlen(fonts[strptr->data.font].psname)));
          Tcl_ListObjAppendElement(xcinterp, lstr, sdict);
          break;
       case FONT_SCALE:
          sdict = Tcl_NewListObj(0, NULL);
          Tcl_ListObjAppendElement(xcinterp, sdict,
                  Tcl_NewStringObj("Font Scale", 10));
          Tcl_ListObjAppendElement(xcinterp, sdict,
                  Tcl_NewDoubleObj((double)strptr->data.scale));
          Tcl_ListObjAppendElement(xcinterp, lstr, sdict);
          break;
       case KERN:
          sdict = Tcl_NewListObj(0, NULL);
          stup = Tcl_NewListObj(0, NULL);
          Tcl_ListObjAppendElement(xcinterp, stup,
                  Tcl_NewIntObj((int)strptr->data.kern[0]));
          Tcl_ListObjAppendElement(xcinterp, stup,
                  Tcl_NewIntObj((int)strptr->data.kern[1]));

          Tcl_ListObjAppendElement(xcinterp, sdict, Tcl_NewStringObj("Kern", 4));
          Tcl_ListObjAppendElement(xcinterp, sdict, stup);
          Tcl_ListObjAppendElement(xcinterp, lstr, sdict);
          break;
       case FONT_COLOR:
          stup = TclIndexToRGB(strptr->data.color);
          if (stup != NULL) {
             sdict = Tcl_NewListObj(0, NULL);
             Tcl_ListObjAppendElement(xcinterp, sdict,
                  Tcl_NewStringObj("Color", 5));
             Tcl_ListObjAppendElement(xcinterp, sdict, stup); 
             Tcl_ListObjAppendElement(xcinterp, lstr, sdict);
          }
          break;
       case TABSTOP:
          Tcl_ListObjAppendElement(xcinterp, lstr,
                  Tcl_NewStringObj("Tab Stop", 8));
          break;
       case TABFORWARD:
          Tcl_ListObjAppendElement(xcinterp, lstr,
                  Tcl_NewStringObj("Tab Forward", 11));
          break;
       case TABBACKWARD:
          Tcl_ListObjAppendElement(xcinterp, lstr,
                  Tcl_NewStringObj("Tab Backward", 12));
          break;
       case RETURN:
          Tcl_ListObjAppendElement(xcinterp, lstr,
                  Tcl_NewStringObj("Return", 6));
          break;
       case SUBSCRIPT:
          Tcl_ListObjAppendElement(xcinterp, lstr,
                  Tcl_NewStringObj("Subscript", 9));
          break;
       case SUPERSCRIPT:
          Tcl_ListObjAppendElement(xcinterp, lstr,
                  Tcl_NewStringObj("Superscript", 11));
          break;
       case NORMALSCRIPT:
          Tcl_ListObjAppendElement(xcinterp, lstr,
                  Tcl_NewStringObj("Normalscript", 12));
          break;
       case UNDERLINE:
          Tcl_ListObjAppendElement(xcinterp, lstr,
                  Tcl_NewStringObj("Underline", 9));
          break;
       case OVERLINE:
          Tcl_ListObjAppendElement(xcinterp, lstr,
                  Tcl_NewStringObj("Overline", 8));
          break;
       case NOLINE:
          Tcl_ListObjAppendElement(xcinterp, lstr,
                  Tcl_NewStringObj("No Line", 7));
          break;
       case HALFSPACE:
          Tcl_ListObjAppendElement(xcinterp, lstr,
                  Tcl_NewStringObj("Half Space", 10));
          break;
       case QTRSPACE:
          Tcl_ListObjAppendElement(xcinterp, lstr,
                  Tcl_NewStringObj("Quarter Space", 13));
          break;
      }
   }
   return lstr;
}

/*----------------------------------------------------------------------*/
/* Get a stringpart linked list from a Tcl list                   */
/*----------------------------------------------------------------------*/

int GetXCStringFromList(Tcl_Interp *interp, Tcl_Obj *list, stringpart **rstring)
{
   int result, j, numobjs, idx;
   Tcl_Obj *lobj;
   stringpart *newpart;

   static char *partTypes[] = {"subscript", "superscript",
      "normalscript", "underline", "overline", "noline", "stop",
      "forward", "backward", "halfspace", "quarterspace", "return", NULL};

   result = Tcl_ListObjLength(interp, list, &numobjs);
   if (result != TCL_OK) return result;

   for (j = 0; j < numobjs; j++) {
      result = Tcl_ListObjIndex(interp, list, j, &lobj);
      if (result != TCL_OK) return result;
      if (Tcl_GetIndexFromObj(interp, lobj, partTypes,
            "string part types", 0, &idx) != TCL_OK) {
       Tcl_ResetResult(interp);
       idx = 0;
      }
      else idx++; /* Now idx matches xcircuit.h text string part types */

      if (rstring != NULL) {
         newpart = makesegment(rstring, NULL);
         newpart->nextpart = NULL;
         newpart->type = idx;
      
         switch(idx) {
          case TEXT_STRING:
             newpart->data.string = strdup(Tcl_GetString(lobj));
             break;
       }
      }
   }
   return TCL_OK;
}

/*----------------------------------------------------------------------*/
/* Handle (integer representation of internal xcircuit object) checking */
/* if "checkobject" is NULL, then 
/*----------------------------------------------------------------------*/

genericptr *CheckHandle(int eaddr, objectptr checkobject)
{
   genericptr *gelem;
   int i, j;
   objectptr thisobj;
   Library *thislib;

   if (checkobject != NULL) {
      for (gelem = checkobject->plist; gelem < checkobject->plist +
            checkobject->parts; gelem++)
       if ((int)(*gelem) == eaddr) goto exists;
      return NULL;
   }

   /* Look through all the pages. */

   for (i = 0; i < xobjs.pages; i++) {
      if (xobjs.pagelist[i]->pageinst == NULL) continue;
      thisobj = xobjs.pagelist[i]->pageinst->thisobject;
      for (gelem = thisobj->plist; gelem < thisobj->plist + thisobj->parts; gelem++)
         if ((int)(*gelem) == eaddr) goto exists;
   }

   /* Not found?  Maybe in a library */

   for (i = 0; i < xobjs.numlibs; i++) {
      thislib = xobjs.userlibs + i;
      for (j = 0; j < thislib->number; j++) {
         thisobj = thislib->library[j];
         for (gelem = thisobj->plist; gelem < thisobj->plist + thisobj->parts; gelem++)
            if ((int)(*gelem) == eaddr) goto exists;
      }
   }

   /* Either in the delete list (where we don't want to go) or    */
   /* is an invalid number.                           */
   return NULL;

exists:
   return gelem;
}

/*----------------------------------------------------------------------*/
/* Find the object with the indicated name.                       */
/*----------------------------------------------------------------------*/

objectptr NameToObject(char *objname, objinstptr *ret_inst, Boolean dopages)
{
   int i;
   liblistptr spec;

   for (i = 0; i < xobjs.numlibs; i++) {
      for (spec = xobjs.userlibs[i].instlist; spec != NULL; spec = spec->next) {
         if (!strcmp(objname, spec->thisinst->thisobject->name)) {
          *ret_inst = spec->thisinst;
          return spec->thisinst->thisobject;
       }
      }
   }

   if (dopages) {
      for (i = 0; i < xobjs.pages; i++) {
       if (xobjs.pagelist[i]->pageinst == NULL) continue;
       if (!strcmp(objname, xobjs.pagelist[i]->pageinst->thisobject->name)) {
          *ret_inst = xobjs.pagelist[i]->pageinst;
          return xobjs.pagelist[i]->pageinst->thisobject;
       }
      }
   }
   
   return NULL;
}

/*----------------------------------------------------------------------*/
/* Find the index into the "plist" list of elements               */
/* Part number must be of a type in "mask" or no selection occurs.      */
/* return values:  -1 = no object found, -2 = found, but wrong type     */
/*----------------------------------------------------------------------*/

short GetPartNumber(genericptr egen, objectptr checkobject, int mask)
{
   genericptr *gelem;
   objectptr thisobject = checkobject;
   int i;

   if (checkobject == NULL) thisobject = topobject;

   for (i = 0, gelem = thisobject->plist; gelem < thisobject->plist +
            thisobject->parts; gelem++, i++) {
      if ((*gelem) == egen) {
       if ((*gelem)->type & mask)
          return i;
       else
          return -2;
      }
   }
   return -1;
}

/*----------------------------------------------------------------------*/
/* This routine is used by a number of menu functions.  It looks for    */
/* the arguments "selected" or an integer (object handle).  If the      */
/* argument is a valid object handle, it is added to the select list.   */
/* The argument can be a list of handles, of which each is checked and  */
/* added to the select list.                                */
/* "extra" indicates the number of required arguments beyond 2.         */
/* "next" returns the integer of the argument after the handle, or the  */
/* argument after the command, if there is no handle.             */
/*----------------------------------------------------------------------*/

int ParseElementArguments(Tcl_Interp *interp, int objc,
            Tcl_Obj *CONST objv[], int *next, int mask) {

   short *newselect;
   char *argstr;
   int i, j, ehandle, result, numobjs;
   Tcl_Obj *lobj;
   int extra = 0, badobjs = 0;

   if (next != NULL) {
      extra = *next;
      *next = 1;
   }

   if ((objc > (2 + extra)) || (objc == 1)) {
      Tcl_WrongNumArgs(interp, 1, objv, "[selected | <object_handle>] <option>");
      return TCL_ERROR;
   }
   else if (objc == 1) {
      *next = 0;
      return TCL_OK;
   }
   else {
      argstr = Tcl_GetString(objv[1]);
      if (strcmp(argstr, "selected")) {

         /* check for object handle (integer) */

         result = Tcl_ListObjLength(interp, objv[1], &numobjs);
         if (result != TCL_OK) return result;

       /* Non-integer, non-list types: assume operation is to be applied */
       /* to currently selected elements, and return to caller.      */

       if (numobjs == 1) {
          result = Tcl_GetHandleFromObj(interp, objv[1], (void *)&ehandle);
          if (result != TCL_OK) {
             Tcl_ResetResult(interp);
             return TCL_OK;
          }
       }
         objectdeselect();

       for (j = 0; j < numobjs; j++) {
            result = Tcl_ListObjIndex(interp, objv[1], j, &lobj);
            if (result != TCL_OK) return result;
          result = Tcl_GetHandleFromObj(interp, lobj, (void *)&ehandle);
            if (result != TCL_OK) return result;
            i = GetPartNumber((genericptr)ehandle, topobject, mask);
            if (i == -1) {
             Tcl_SetResult(interp, "No such element exists.", NULL);
             return TCL_ERROR;
            }
          else if (i == -2)
             badobjs++;
          else {
               newselect = allocselect();
               *newselect = i;
             if (next != NULL) *next = 2;
          }
       }
       if (badobjs == numobjs) {
          Tcl_SetResult(interp, "No element matches required type.", NULL);
          return TCL_ERROR;
       }
         drawselects(topobject, areastruct.topinstance);
      }
      else if (next != NULL) *next = 2;
   }
   return TCL_OK;
}

/*----------------------------------------------------------------------*/
/* This routine is similar to ParseElementArguments.  It looks for a    */
/* page number or page name in the second argument position.  If it     */
/* finds one, it sets the page number in the return value.  Otherwise,  */
/* it sets the return value to the value of areastruct.page.            */
/*----------------------------------------------------------------------*/

int ParsePageArguments(Tcl_Interp *interp, int objc,
            Tcl_Obj *CONST objv[], int *next, int *pageret) {

   char *pagename;
   int i, page, result;
   Tcl_Obj *objPtr;

   if (next != NULL) *next = 1;
   if (pageret != NULL) *pageret = areastruct.page;  /* default */

   if ((objc == 1) || ((objc == 2) && !strcmp(Tcl_GetString(objv[1]), ""))) {
      objPtr = Tcl_NewIntObj(areastruct.page + 1);
      Tcl_SetObjResult(interp, objPtr);
      if (next) *next = -1;
      return TCL_OK;
   }
   else {
      pagename = Tcl_GetString(objv[1]);
      if (strcmp(pagename, "directory")) {

         /* check for page number (integer) */

       result = Tcl_GetIntFromObj(interp, objv[1], &page);
       if (result != TCL_OK) {
          Tcl_ResetResult(interp);

          /* check for page name (string) */

          for (i = 0; i < xobjs.pages; i++) {
             if (xobjs.pagelist[i]->pageinst == NULL) continue;
             if (!strcmp(pagename, xobjs.pagelist[i]->pageinst->thisobject->name)) {
              if (pageret) *pageret = i;
              break;
             }
          }
          if (i == xobjs.pages) {
             if (next != NULL) *next = 0;
          }
       }
         else {
          if (page < 1) {
             Tcl_SetResult(interp, "Illegal page number: zero or negative", NULL);
             return TCL_ERROR;
          }
          else if (page > xobjs.pages) {
             Tcl_SetResult(interp, "Illegal page number: page does not exist", NULL);
             return TCL_ERROR;
          }
          else if (pageret) *pageret = (page - 1);
       }
      }
      else {
       *next = 0;
      }
   }
   return TCL_OK;
}

/*----------------------------------------------------------------------*/
/* This routine is similar to ParsePageArguments.  It looks for a */
/* library number or library name in the second argument position.  If  */
/* it finds one, it sets the page number in the return value.           */
/* Otherwise, if a library page is currently being viewed, it sets the  */
/* return value to that library.  Otherwise, it sets the return value   */
/* to the User Library.                                     */
/*----------------------------------------------------------------------*/

int ParseLibArguments(Tcl_Interp *interp, int objc,
            Tcl_Obj *CONST objv[], int *next, int *libret) {

   char *libname;
   int i, library, result;
   Tcl_Obj *objPtr;

   if (next != NULL) *next = 1;

   if (objc == 1) {
      library = is_library(topobject);
      if (library < 0) {
       Tcl_SetResult(interp, "No current library.", NULL);
       return TCL_ERROR;
      }
      objPtr = Tcl_NewIntObj(library + 1);
      Tcl_SetObjResult(interp, objPtr);
      if (next) *next = -1;
      return TCL_OK;
   }
   else {
      libname = Tcl_GetString(objv[1]);
      if (strcmp(libname, "directory")) {

         /* check for library number (integer) */

       result = Tcl_GetIntFromObj(interp, objv[1], &library);
       if (result != TCL_OK) {
          Tcl_ResetResult(xcinterp);

          /* check for library name (string) */

          for (i = 0; i < xobjs.numlibs; i++) {
             if (!strcmp(libname, xobjs.libtop[i
                        + LIBRARY]->thisobject->name)) {
              *libret = i;
              break;
             }
          }
          if (i == xobjs.numlibs) {
             *libret = xobjs.numlibs - 1;
             if (next != NULL) *next = 0;
          }
       }
         else {
          if (library < 1) {
             Tcl_SetResult(interp, "Illegal library number: zero or negative", NULL);
             return TCL_ERROR;
          }
          else if (library > xobjs.numlibs) {
             Tcl_SetResult(interp, "Illegal library number: library "
                  "does not exist", NULL);
             return TCL_ERROR;
          }
          else *libret = (library - 1);
       }
      }
      else *next = 0;
   }
   return TCL_OK;
}

#ifdef SCHEMA
/*----------------------------------------------------------------------*/
/* Schematic and symbol creation and association                  */
/*----------------------------------------------------------------------*/

int xctcl_symschem(ClientData clientData, Tcl_Interp *interp,
      int objc, Tcl_Obj *CONST objv[])
{
   int i, idx, result, stype;
   objectptr otherobj = NULL;
   char *objname;

   static char *subCmds[] = {
      "associate", "disassociate", "make", "goto", "get", "type", NULL
   };
   enum SubIdx {
      AssocIdx, DisAssocIdx, MakeIdx, GoToIdx, NameIdx, TypeIdx
   };

   /* The order of these must match the definitions in xcircuit.h */
   static char *schemTypes[] = {
      "schematic", "trivial", "symbol", "fundamental"
   };

   if (objc == 1 || objc > 3) {
      Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
      return TCL_ERROR;
   }
   else if ((result = Tcl_GetIndexFromObj(interp, objv[1], subCmds,
      "option", 0, &idx)) != TCL_OK) {
      return result;
   }

   switch(idx) {
      case AssocIdx:
       if (objc == 3) {
          /* To do: accept name for association */
          objname = Tcl_GetString(objv[2]);
          if (topobject->schemtype == SCHEMATIC) {

             /* Name has to be that of a library object */

             int j;
             objectptr *libobj;

             for (i = 0; i < xobjs.numlibs; i++) {
              for (j = 0; j < xobjs.userlibs[i].number; j++) {
                 libobj = xobjs.userlibs[i].library + j;
                 if (!strcmp(objname, (*libobj)->name)) {
                    otherobj = *libobj;
                    break;
                 }
              }
              if (otherobj != NULL) break;
             }
             if (otherobj == NULL)
             {
                Tcl_SetResult(interp, "Name is not a known object", NULL);
              return TCL_ERROR;
             }
          }
          else {

             /* Name has to be that of a page label */

             objectptr pageobj;
             for (i = 0; i < xobjs.pages; i++) {
              pageobj = xobjs.pagelist[i]->pageinst->thisobject;
              if (!strcmp(objname, pageobj->name)) {
                 otherobj = pageobj;
                 break;
              }
             }
             if (otherobj == NULL)
             {
                Tcl_SetResult(interp, "Name is not a known page label", NULL);
              return TCL_ERROR;
             }
          }
          if (schemassoc(topobject, otherobj) == False)
             return TCL_ERROR;
       }
       else
          startschemassoc(NULL, 0, NULL);
       break;
      case DisAssocIdx:
       schemdisassoc();
       break;
      case MakeIdx:
       if ((topobject->symschem == NULL) && (topobject->schemtype == SCHEMATIC)
                  && (strstr(topobject->name, "Page ") != NULL)) {
          if (objc == 3) {
             objname = Tcl_GetString(objv[2]);
             strcpy(topobject->name,  Tcl_GetString(objv[2]));
             checkname(topobject);
          }
          else {
             /* Use this error condition to generate the popup prompt */
             Tcl_SetResult(interp, "Must supply a name for the page", NULL);
             return TCL_ERROR;
          }
       }
       swapschem(NULL, (pointertype)1, NULL);
       break;
      case GoToIdx:
       swapschem(NULL, (pointertype)0, NULL);
       break;
      case NameIdx:
       if (topobject->symschem != NULL)
          Tcl_AppendElement(interp, topobject->symschem->name);
       break;
      case TypeIdx:
       if (objc == 3) {
          if (topobject->schemtype == SCHEMATIC) {
             Tcl_SetResult(interp, "Make object to change from schematic to symbol",
                  NULL);
             return TCL_ERROR;
          }
          if ((result = Tcl_GetIndexFromObj(interp, objv[2], schemTypes,
            "schematic types", 0, &stype)) != TCL_OK)
             return result;
          if (stype == SCHEMATIC) {
             Tcl_SetResult(interp, "Cannot change symbol into a schematic", NULL);
             return TCL_ERROR;
          }
          topobject->schemtype = stype;
          if (topobject->symschem) schemdisassoc();
       }
       else
          Tcl_AppendElement(interp, schemTypes[topobject->schemtype]);

       break;
   }
   setsymschem(); /* Update GUI */
   return XcTagCallback(interp, objc, objv);
}

/*----------------------------------------------------------------------*/
/* Generate netlist into a Tcl hierarchical list                  */
/* (plus other netlist functions)                           */
/*----------------------------------------------------------------------*/

extern u_int subindex;
extern Tcl_Obj *tclglobals(objectptr);
extern Tcl_Obj *tcltoplevel(objectptr);

int xctcl_netlist(ClientData clientData, Tcl_Interp *interp,
      int objc, Tcl_Obj *CONST objv[])
{
   Tcl_Obj *rdict;
   int idx, format, result;
   Boolean valid;
   pushlistptr stack;

   static char *subCmds[] = {
      "write", "highlight", "goto", "get", "make", "autonumber", NULL
   };
   enum SubIdx {
      WriteIdx, HighLightIdx, GoToIdx, GetIdx, MakeIdx, AutoNumberIdx
   };

   static char *formats[] = {
      "spice", "spiceflat", "sim", "pcb", NULL
   };
   enum FmtIdx {
      SpiceIdx, FlatSpiceIdx, SimIdx, PcbIdx
   };

   if (objc == 1 || objc > 3) {
      Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
      return TCL_ERROR;
   }
   else if ((result = Tcl_GetIndexFromObj(interp, objv[1], subCmds,
      "option", 0, &idx)) != TCL_OK) {
      return result;
   }

   /* Make sure a valid netlist exists for the current schematic */

   if (checkvalid(topobject) == -1) {
      if (cleartraversed(topobject, 0) == -1) {
        Tcl_SetResult(interp, "Check circuit for infinite recursion.", NULL);
        return TCL_ERROR;
      }
      else {
       destroynets();
       createnets();
      }
   }

   switch(idx) {
      case WriteIdx:          /* write netlist formats */
         if (objc == 2) {
          Tcl_WrongNumArgs(interp, 1, objv, "write format");
          return TCL_ERROR;
       }
       else if ((result = Tcl_GetIndexFromObj(interp, objv[2], formats,
            "format", 0, &format)) != TCL_OK) {
          return result;
       }
       switch(format) {
          case SpiceIdx:
             gennet("spice", "spc");
             break;
          case FlatSpiceIdx:
             gennet("flatspice", "fspc");
             break;
          case SimIdx:
             gennet("sim", "sim");
             break;
          case PcbIdx:
             gennet("pcb", "pcbnet");
             break;
       }
       break;
      case GoToIdx:     /* go to top-level page having specified name */
         if (objc != 3) {
          Tcl_WrongNumArgs(interp, 1, objv, "goto hierarchical-network-name");
          return TCL_ERROR;
       }

       valid = hiernametoobject(topobject, Tcl_GetString(objv[2]), &stack);

       if (valid) {
           /* add the current edit object to the push stack, then append */
           /* the new push stack                               */
           fprintf(stderr, "freeing primary call stack\n");
           fflush(stderr);
           free_stack(&areastruct.stack);
           fprintf(stderr, "setting current object to %s\n",
                  stack->thisinst->thisobject->name);
           fflush(stderr);
           areastruct.topinstance = stack->thisinst;
           fprintf(stderr, "popping netlist call stack\n");
           fflush(stderr);
           pop_stack(&stack);
           areastruct.stack = stack;
           fprintf(stderr, "setting new page\n");
           fflush(stderr);
           setpage(TRUE);
           transferselects();
           fprintf(stderr, "redraw page\n");
           fflush(stderr);
           refresh(NULL, NULL, NULL);
           setsymschem();
       }
       else {
          Tcl_SetResult(interp, "Not a valid network.", NULL);
          return TCL_ERROR;
       }
       break;
      case GetIdx:      /* return hierarchical name of selected network */
         if ((objc != 2) || (objc != 3)) {
          Tcl_WrongNumArgs(interp, 1, objv, "get [selected|here]");
          return TCL_ERROR;
       }
       /* to be done */
       Tcl_SetResult(interp, "(sorry, unimplemented function)", NULL);
       break;
      case HighLightIdx:      /* highlight network connectivity */
         if (objc == 2) {
          startconnect(NULL, NULL, NULL);
       }
       else {
          int netid;
          XPoint newpos;
          char *tname;

          result = GetPositionFromList(interp, objv[2], &newpos);
          if (result == TCL_OK) {   /* find net at indicated position */
             areastruct.save = newpos;
             netid = connectivity(NULL, NULL, NULL);
             if (netid == 0)
              Tcl_SetResult(interp, "No network found", NULL);
             else if (netid < 0)
              Tcl_SetResult(interp, "Not a network element", NULL);
          }
          else {              /* assume objv[2] is net name */
             Tcl_ResetResult(interp);
             tname = Tcl_GetString(objv[2]);
             netid = nametonet(topobject, areastruct.topinstance, tname);
             if (netid == 0) {
              Tcl_SetResult(interp, "No such network ", NULL);
                Tcl_AppendElement(interp, tname);
             }
             else {
              /* Erase any existing highlights first */
              highlightnet(topobject, areastruct.topinstance, -1, 0);
              highlightnet(topobject, areastruct.topinstance, netid, 1);
              Tcl_SetObjResult(interp,  Tcl_NewIntObj(netid));
             }
          }
       }
       break;
      case MakeIdx:           /* generate Tcl-list netlist */
       if (checkvalid(topobject) == -1) {
          if (cleartraversed(topobject, 0) == -1) {
             Tcl_SetResult(interp, "Check circuit for infinite recursion.", NULL);
             return TCL_ERROR;
          }
          else {
             destroynets();
             createnets();
          }
       }
       subindex = 1;
       rdict = Tcl_NewListObj(0, NULL);
       Tcl_ListObjAppendElement(interp, rdict, Tcl_NewStringObj("globals", 7));
       Tcl_ListObjAppendElement(interp, rdict, tclglobals(topobject));
       Tcl_ListObjAppendElement(interp, rdict, Tcl_NewStringObj("circuit", 7));
       Tcl_ListObjAppendElement(interp, rdict, tcltoplevel(topobject));

       Tcl_SetObjResult(interp, rdict);
       break;
      case AutoNumberIdx:     /* auto-number circuit components */
       if (objc == 2)
          format = PcbIdx;
       else if (objc == 3)
          if ((result = Tcl_GetIndexFromObj(interp, objv[2], formats,
                  "format", 0, &format)) != TCL_OK)
             return result;

       switch(format) {
          case SpiceIdx:
             gennet("idxspice", "");
             break;
          case FlatSpiceIdx:
             gennet("idxflatspice", "");
             break;
          case SimIdx:
             gennet("idxsim", "");
             break;
          case PcbIdx:
             gennet("idxpcb", "");
             break;
       }
       break;
   }
   return XcTagCallback(interp, objc, objv);
}

#endif      /* SCHEMA */

/*----------------------------------------------------------------------*/
/* Return current position                                  */
/*----------------------------------------------------------------------*/

int xctcl_here(ClientData clientData, Tcl_Interp *interp,
      int objc, Tcl_Obj *CONST objv[])
{
   int result;
   Tcl_Obj *listPtr, *objPtr;
   XPoint newpos;

   if (objc != 1) {
      Tcl_WrongNumArgs(interp, 0, objv, "(no arguments)");
      return TCL_ERROR;
   }
   newpos = UGetCursorPos();

   listPtr = Tcl_NewListObj(0, NULL);
   objPtr = Tcl_NewIntObj((int)newpos.x);
   Tcl_ListObjAppendElement(interp, listPtr, objPtr);

   objPtr = Tcl_NewIntObj((int)newpos.y);
   Tcl_ListObjAppendElement(interp, listPtr, objPtr);

   Tcl_SetObjResult(interp, listPtr);

   return XcTagCallback(interp, objc, objv);
}


/*----------------------------------------------------------------------*/
/* Argument-converting wrappers from Tcl command callback to xcircuit   */
/*----------------------------------------------------------------------*/

int xctcl_pan(ClientData clientData, Tcl_Interp *interp,
      int objc, Tcl_Obj *CONST objv[])
{
   int result;
   XPoint newpos, wpoint;
   XButtonEvent bevent;

   if (objc == 1) {
      centerpan(NULL, NULL, NULL);
      return TCL_OK;
   }
   else if (objc != 2) {
      Tcl_WrongNumArgs(interp, 0, objv, "option ?arg ...?");
      return TCL_ERROR;
   }
   result = GetPositionFromList(interp, objv[1], &newpos);
   if (result != TCL_OK) return result;
   user_to_window(newpos, &wpoint);
   bevent.x = wpoint.x;
   bevent.y = wpoint.y;
   bevent.button = Button1;
   panbutton((u_int)5, &bevent);
   return XcTagCallback(interp, objc, objv);
}

/*----------------------------------------------------------------------*/

int xctcl_zoom(ClientData clientData, Tcl_Interp *interp,
      int objc, Tcl_Obj *CONST objv[])
{
   int result, idx;
   float save;
   double factor;

   static char *subCmds[] = {"in", "out", "box", "view", "factor", NULL};
   enum SubIdx {
      InIdx, OutIdx, BoxIdx, ViewIdx, FactorIdx
   };

   if (objc == 1)
      zoomview(NULL, NULL, NULL);
   else if ((result = Tcl_GetDoubleFromObj(interp, objv[1], &factor)) != TCL_OK)
   {
      Tcl_ResetResult(interp);
      if (Tcl_GetIndexFromObj(interp, objv[1], subCmds,
            "option", 0, &idx) != TCL_OK) {
       Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
       return TCL_ERROR;
      }
      switch(idx) {
       case InIdx:
          zoominrefresh(NULL, NULL, NULL);
          break;
       case OutIdx:
          zoomoutrefresh(NULL, NULL, NULL);
          break;
       case BoxIdx:
          zoombox(NULL, NULL, NULL);
          break;
       case ViewIdx:
          zoomview(NULL, NULL, NULL);
          break;
       case FactorIdx:
          if (objc == 2) {
             Tcl_Obj *objPtr = Tcl_NewDoubleObj((double)areastruct.zoomfactor);
             Tcl_SetObjResult(interp, objPtr);
             break;
          }
          else if (objc != 3) {
             Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
             return TCL_ERROR;
          }
          if (!strcmp(Tcl_GetString(objv[2]), "default"))
             factor = SCALEFAC;
          else {
             result = Tcl_GetDoubleFromObj(interp, objv[2], &factor);
             if (result != TCL_OK) return result;
             if (factor <= 0) {
                Tcl_SetResult(interp, "Negative/Zero zoom factors not allowed.",
                  NULL);
                return TCL_ERROR;
             }
             if (factor < 1.0) factor = 1.0 / factor;
          }
          if ((float)factor == areastruct.zoomfactor) break;
          sprintf(_STR2, "Zoom factor changed from %2.1f to %2.1f",
            areastruct.zoomfactor, (float)factor);
          areastruct.zoomfactor = (float) factor;
          Wprintf(_STR2);
          break;
      }
   }
   else {
    
      save = areastruct.zoomfactor;

      if (factor < 1.0) {
         areastruct.zoomfactor = (float)(1.0 / factor);
         zoomoutrefresh(NULL, NULL, NULL);
      }
      else {
         areastruct.zoomfactor = (float)factor;
         zoominrefresh(NULL, NULL, NULL);
      }
      areastruct.zoomfactor = save;
   }
   return XcTagCallback(interp, objc, objv);
}

/*----------------------------------------------------------------------*/
/* To do: check for color name before integer (index) value.            */
/*----------------------------------------------------------------------*/

int GetColorFromObj(Tcl_Interp *interp, Tcl_Obj *obj, int *cindex)
{
   int result;

   if (cindex == NULL) return TCL_ERROR;

   if (!strcmp(Tcl_GetString(obj), "inherit")) {
      *cindex = -1;
   }
   else {
      result = Tcl_GetIntFromObj(interp, obj, cindex);
      if (result != TCL_OK) {
       Tcl_SetResult(interp, "Color must be inherit or index", NULL);
       return result;
      }

      if ((*cindex >= number_colors) || (*cindex < -1)) {
       Tcl_SetResult(interp, "Color index out of range", NULL);
       return TCL_ERROR;
      }
   }
   return TCL_OK;
}

/*----------------------------------------------------------------------*/

int xctcl_color(ClientData clientData, Tcl_Interp *interp,
      int objc, Tcl_Obj *CONST objv[])
{
   int result, nidx, cindex;

   nidx = 1;
   result = ParseElementArguments(interp, objc, objv, &nidx, SEL_ANY);
   if (result != TCL_OK) return result;

   if (nidx < objc) {
      result = GetColorFromObj(interp, objv[nidx], &cindex);
      if (result != TCL_OK) return result;
      setcolor((Tk_Window)clientData, cindex);
   }
   else {
      /* Need a "get color" routine here. . . */
      Tcl_WrongNumArgs(interp, 1, objv, "color_index");
      return TCL_ERROR;
   }

   /* Tag callback is handled by setcolormarks() via setcolor() */
   /* return XcTagCallback(interp, objc, objv); */
   return TCL_OK;
}

/*----------------------------------------------------------------------*/

int xctcl_delete(ClientData clientData, Tcl_Interp *interp,
      int objc, Tcl_Obj *CONST objv[])
{
   int result = ParseElementArguments(interp, objc, objv, NULL, SEL_ANY);

   if (result != TCL_OK) return result;

   startdelete((Tk_Window)clientData, NULL, NULL);
   if ((eventmode == DELETE_MODE) || (areastruct.selects == 0))
      return XcTagCallback(interp, objc, objv);
   else
      return TCL_ERROR;
}

/*----------------------------------------------------------------------*/

int xctcl_undelete(ClientData clientData, Tcl_Interp *interp,
      int objc, Tcl_Obj *CONST objv[])
{
   if (objc != 1) {
      Tcl_WrongNumArgs(interp, 1, objv, "(no arguments)");
      return TCL_ERROR;
   }
   xc_undelete((Tk_Window)clientData, DRAW, NULL);

   return XcTagCallback(interp, objc, objv);
}

/*----------------------------------------------------------------------*/

int xctcl_move(ClientData clientData, Tcl_Interp *interp,
      int objc, Tcl_Obj *CONST objv[])
{
   XPoint position;
   int nidx = 3;
   int result = ParseElementArguments(interp, objc, objv, &nidx, SEL_ANY);

   if (result != TCL_OK) return result;

   if (areastruct.selects == 0) {
      Tcl_SetResult(interp, "Error in move setup:  nothing selected.", NULL);
      return TCL_ERROR;
   }

   if ((objc - nidx) == 0) {
      eventmode = PRESS_MODE;
      u2u_snap(&areastruct.save);
      Tk_CreateEventHandler(areastruct.area, PointerMotionMask,
            (Tk_EventProc *)xctk_drag, NULL);
   }
   else if ((objc - nidx) >= 1) {
      if ((objc - nidx) == 2) {
       if (!strcmp(Tcl_GetString(objv[nidx]), "relative")) {
          if ((result = GetPositionFromList(interp, objv[nidx + 1],
                  &position)) != TCL_OK) {
             Tcl_SetResult(interp, "Position must be {x y} list", NULL);
             return TCL_ERROR;
          }
       }
       else {
          Tcl_WrongNumArgs(interp, 1, objv, "relative {x y}");
          return TCL_ERROR;
       }
      }
      else {
       if ((result = GetPositionFromList(interp, objv[nidx],
                  &position)) != TCL_OK) {
          Tcl_SetResult(interp, "Position must be {x y} list", NULL);
          return TCL_ERROR;
       }
         position.x -= areastruct.save.x;
         position.y -= areastruct.save.y;
      }
      placeselects(position.x, position.y, NULL);
   }
   else {
      Tcl_WrongNumArgs(interp, 1, objv, "[relative] {x y}");
      return TCL_ERROR;
   }
}

/*----------------------------------------------------------------------*/

int xctcl_copy(ClientData clientData, Tcl_Interp *interp,
      int objc, Tcl_Obj *CONST objv[])
{
   XPoint position;
   int nidx = 3;
   int result = ParseElementArguments(interp, objc, objv, &nidx, SEL_ANY);

   if (result != TCL_OK) return result;

   if ((objc - nidx) == 0) {
      if (areastruct.selects > 0) {
       createcopies();
       copydrag();
      }
      else {
         startcopy((Tk_Window)clientData, NULL, NULL);
         if ((eventmode == COPY_MODE) || (areastruct.selects > 0))
            return XcTagCallback(interp, objc, objv);
         else {
          Tcl_SetResult(interp, "Error in copy setup:  nothing selected.", NULL);
            return TCL_ERROR;
         }
      }
   }
   else if ((objc - nidx) >= 1) {
      if (areastruct.selects == 0) {
         Tcl_SetResult(interp, "Error in copy:  nothing selected.", NULL);
         return TCL_ERROR;
      }
      if ((objc - nidx) == 2) {
       if (!strcmp(Tcl_GetString(objv[nidx]), "relative")) {
          if ((result = GetPositionFromList(interp, objv[nidx + 1],
                  &position)) != TCL_OK) {
             Tcl_SetResult(interp, "Position must be {x y} list", NULL);
             return TCL_ERROR;
          }
       }
       else {
          Tcl_WrongNumArgs(interp, 1, objv, "relative {x y}");
          return TCL_ERROR;
       }
      }
      else {
       if ((result = GetPositionFromList(interp, objv[nidx],
                  &position)) != TCL_OK) {
          Tcl_SetResult(interp, "Position must be {x y} list", NULL);
          return TCL_ERROR;
       }
         position.x -= areastruct.save.x;
         position.y -= areastruct.save.y;
      }
      createcopies();
      placeselects(position.x, position.y, NULL);
   }
   else {
      Tcl_WrongNumArgs(interp, 1, objv, "[relative] {x y}");
      return TCL_ERROR;
   }
}

/*----------------------------------------------------------------------*/

int xctcl_flip(ClientData clientData, Tcl_Interp *interp,
      int objc, Tcl_Obj *CONST objv[])
{
   char *teststr;
   int nidx = 1;
   int result = ParseElementArguments(interp, objc, objv, &nidx, SEL_ANY);

   if (result != TCL_OK) return result;

   teststr = Tcl_GetString(objv[nidx]);
   switch(teststr[0]) {
      case 'h': case 'H':
         startrotate((Tk_Window)clientData, 512, NULL);
       break;
      case 'v': case 'V':
         startrotate((Tk_Window)clientData, 1024, NULL);
       break;
   }

   if ((eventmode == ROTATE_MODE) || (areastruct.selects > 0))
      return XcTagCallback(interp, objc, objv);
   else
      return TCL_ERROR;
}

/*----------------------------------------------------------------------*/

int xctcl_rotate(ClientData clientData, Tcl_Interp *interp,
      int objc, Tcl_Obj *CONST objv[])
{
   int rval, nidx = 2;
   int result = ParseElementArguments(interp, objc, objv, &nidx, SEL_ANY);

   if (result != TCL_OK) return result;

   result = Tcl_GetIntFromObj(interp, objv[nidx], &rval);
   if (result != TCL_OK) return result;

   if ((objc - nidx) == 1) {
      startrotate((Tk_Window)clientData, rval, NULL);
      if ((eventmode == ROTATE_MODE) || (areastruct.selects > 0))
         return XcTagCallback(interp, objc, objv);
      else {
       Tcl_SetResult(interp, "Error in rotate setup:  nothing selected.", NULL);
         return TCL_ERROR;
      }
   }
   else if ((objc - nidx) == 2) {
      XPoint position, wpt;
      XButtonEvent bevent;
      if ((result = GetPositionFromList(interp, objv[nidx + 1],
                  &position)) != TCL_OK)
       return result;
      else {
       areastruct.save = position;
       objectrotate(rval);
         return XcTagCallback(interp, objc, objv);
      }
   }
   else {
      Tcl_WrongNumArgs(interp, 1, objv, "angle [<center>]");
      return TCL_ERROR;
   }
}

/*----------------------------------------------------------------------*/

int xctcl_edit(ClientData clientData, Tcl_Interp *interp,
      int objc, Tcl_Obj *CONST objv[])
{
   int result = ParseElementArguments(interp, objc, objv, NULL, SEL_ANY);

   if (result != TCL_OK) return result;

   startedit((Tk_Window)clientData, NULL, NULL);
   if ((eventmode == EDIT_MODE) || (areastruct.selects == 1))
      return XcTagCallback(interp, objc, objv);
   else
      return TCL_ERROR;
}

/*----------------------------------------------------------------------*/
/* Support procedure for xctcl_param:  Given a pointer to a parameter,  */
/* return the value of the parameter as a pointer to a Tcl object.      */
/* This takes care of the fact that the parameter value can be a  */
/* string, integer, or float, depending on the parameter type.          */
/*----------------------------------------------------------------------*/

Tcl_Obj *GetParameterValue(oparamptr ops)
{
   Tcl_Obj *robj;

   switch (ops->type) {
      case XC_STRING:
       robj = TclGetStringParts(ops->parameter.string);
       break;
      case XC_INT:
       robj = Tcl_NewIntObj(ops->parameter.ivalue);
       break;
      case XC_FLOAT:
       robj = Tcl_NewDoubleObj((double)ops->parameter.fvalue);
       break;
   }
   return robj;
}

/*----------------------------------------------------------------------*/

int xctcl_param(ClientData clientData, Tcl_Interp *interp,
      int objc, Tcl_Obj *CONST objv[])
{
   int i, j, value, idx, nidx = 2;
   int result = ParseElementArguments(interp, objc, objv, &nidx, SEL_ANY);
   oparamptr ops;
   genericptr thiselem = (areastruct.selects == 0) ? NULL :
      SELTOGENERIC(areastruct.selectlist);   
   Tcl_Obj *plist;

   static char *subCmds[] = {"allowed", "get", "default", "make",
      "forget", NULL};
   enum SubIdx {
      AllowedIdx, GetIdx, DefaultIdx, MakeIdx, ForgetIdx
   };

   /* The order of these type names must match the enumeration in xcircuit.h */

   static char *param_types[] = {"position", "substring", "x position",
        "y position", "style", "justification", "start angle", "end angle",
        "radius", "minor axis", "rotation", "scale", "linewidth", "color"};

   if (result != TCL_OK) return result;

   if ((objc - nidx) == 0) {
      startparam((Tk_Window)clientData, (pointertype)NULL, NULL);
      if ((eventmode == LPARAM_MODE) || (eventmode == IPARAM_MODE) ||
            (areastruct.selects > 0))
         return XcTagCallback(interp, objc, objv);
      else
         return TCL_ERROR;
   }
   if ((result = Tcl_GetIndexFromObj(interp, objv[nidx], subCmds,
      "option", nidx - 1, &idx)) != TCL_OK)
      return result;

   switch (idx) {
      case AllowedIdx:
       for (i = 0; i < (sizeof(param_types) / sizeof(char *)); i++)
          if ((thiselem == NULL) || (param_select[i] & thiselem->type))
             Tcl_AppendElement(interp, param_types[i]);
          
         break;

      case GetIdx:
       if (topobject->num_params == 0) {
          Tcl_SetResult(interp, "Object has no parameters", NULL);
          return TCL_ERROR;
       }
             
       if (objc == nidx + 2) {
            if ((result = Tcl_GetIndexFromObj(interp, objv[nidx + 1],
            param_types, "parameter type", nidx - 1, &value)) != TCL_OK) {
             Tcl_SetResult(interp, "Must have a valid parameter type", NULL);
             return result;
          }
          else {
             /* Return the value of the indicated parameter */
             /* Return error if the parameter does not exist. */
             /* Return empty list if the parameter has the default value. */
             if (areastruct.topinstance->params == NULL) {
              Tcl_SetResult(interp, "Instance has no non-default parameters", NULL);
              return TCL_ERROR;
             }
             if (thiselem == NULL) {
                plist = Tcl_NewListObj(0, NULL);
                for (i = 0; i < topobject->num_params; i++) { 
                   ops = areastruct.topinstance->params[i];
                 if (ops == NULL) 
                  Tcl_ListObjAppendElement(interp, plist,
                        Tcl_NewListObj(0, NULL));
                 else {
                    if (ops->which == value)
                       Tcl_ListObjAppendElement(interp, plist,
                           GetParameterValue(ops));
                 }
                }
             }
             else {
                if (thiselem->num_params == 0) {
                 Tcl_SetResult(interp, "Element has no parameters", NULL);
                 return TCL_ERROR;
              }
                plist = Tcl_NewListObj(0, NULL);
                for (i = 0; i < thiselem->num_params; i++) { 
                   j = thiselem->passed[i].paramno;
                   ops = areastruct.topinstance->params[j];
                 if (ops == NULL)
                  Tcl_ListObjAppendElement(interp, plist,
                        Tcl_NewListObj(0, NULL));
                 else {
                    if (ops->which == value)
                       Tcl_ListObjAppendElement(interp, plist,
                        GetParameterValue(ops));
                 }
                }

              /* search label for parameterized substrings */

              if ((value == P_SUBSTRING) && (thiselem->type == LABEL)) {
                 stringpart *cstr;
                 labelptr clab = (labelptr)thiselem;
                 for (cstr = clab->string; cstr != NULL; cstr = cstr->nextpart) {
                  if (cstr->type == PARAM_START) {
                     j = cstr->data.paramno;
                         ops = areastruct.topinstance->params[j];
                       if (ops == NULL)
                        Tcl_ListObjAppendElement(interp, plist,
                              Tcl_NewListObj(0, NULL));
                     else
                          Tcl_ListObjAppendElement(interp, plist,
                              GetParameterValue(ops));
                  }
                 }
              }
             }
             Tcl_SetObjResult(interp, plist);
          }
       }
       else {
          if (areastruct.topinstance->params == NULL) {
             Tcl_SetResult(interp, "Instance has no non-default parameters", NULL);
             return TCL_ERROR;
          }
          if (thiselem == NULL) {
             plist = Tcl_NewListObj(0, NULL);
             for (i = 0; i < topobject->num_params; i++) { 
                ops = areastruct.topinstance->params[i];
              if (ops->which > 13)  /* temporary; should not occur */
                   Tcl_ListObjAppendElement(interp, plist,
                  Tcl_NewIntObj(ops->which));
              else
                   Tcl_ListObjAppendElement(interp, plist,
                  Tcl_NewStringObj(param_types[ops->which],
                  strlen(param_types[ops->which])));
             }
          }
          else {
             if (thiselem->num_params == 0) {
              Tcl_SetResult(interp, "Element has no parameters", NULL);
              return TCL_ERROR;
             }
             plist = Tcl_NewListObj(0, NULL);
             for (i = 0; i < thiselem->num_params; i++) { 
                j = thiselem->passed[i].paramno;
                ops = areastruct.topinstance->params[j];
              if (ops == NULL)      /* default value */
                 ops = areastruct.topinstance->thisobject->params[j];
              if (ops->which > 13)  /* temporary; should not occur */
                   Tcl_ListObjAppendElement(interp, plist,
                  Tcl_NewIntObj(ops->which));
              else
                   Tcl_ListObjAppendElement(interp, plist,
                  Tcl_NewStringObj(param_types[ops->which],
                  strlen(param_types[ops->which])));
             }
          }
          Tcl_SetObjResult(interp, plist);
       }
         break;

      case DefaultIdx:
       if (topobject->num_params == 0) {
          Tcl_SetResult(interp, "Object has no parameters", NULL);
          return TCL_ERROR;
       }
       if (objc == nidx + 2) {
            if ((result = Tcl_GetIndexFromObj(interp, objv[nidx + 1],
            param_types, "parameter type", nidx - 1, &value)) != TCL_OK) {
             Tcl_SetResult(interp, "Must have a valid parameter type", NULL);
             return result;
          }
          else {        /* get default value(s) */
             plist = Tcl_NewListObj(0, NULL);
             if (thiselem == NULL) {
                for (i = 0; i < topobject->num_params; i++) { 
                   ops = topobject->params[i];
                 if (ops->which == value) {
                    Tcl_ListObjAppendElement(interp, plist,
                        GetParameterValue(ops));
                 }
                }
             }
             else {
                for (i = 0; i < thiselem->num_params; i++) { 
                   j = thiselem->passed[i].paramno;
                   ops = topobject->params[j];
                 if (ops->which == value) {
                    Tcl_ListObjAppendElement(interp, plist,
                        GetParameterValue(ops));
                 }
              }

              /* search label for parameterized substrings */

              if ((value == P_SUBSTRING) && (thiselem->type == LABEL)) {
                 stringpart *cstr;
                 labelptr clab = (labelptr)thiselem;
                 for (cstr = clab->string; cstr != NULL; cstr = cstr->nextpart) {
                  if (cstr->type == PARAM_START) {
                     j = cstr->data.paramno;
                         ops = topobject->params[j];
                          Tcl_ListObjAppendElement(interp, plist,
                              GetParameterValue(ops));
                  }
                 }
              }
             }
             Tcl_SetObjResult(interp, plist);
          }
       }
       else {
          Tcl_WrongNumArgs(interp, 1, objv, "default <type> [<value>]");
          return TCL_ERROR;
       }
       break;

      case MakeIdx: 
       if (objc == nidx + 2) {
            if ((result = Tcl_GetIndexFromObj(interp, objv[nidx + 1],
            param_types, "parameter type", nidx - 1, &value)) != TCL_OK)
             return result;
            startparam((Tk_Window)clientData, (pointertype)value, NULL);
       }
       else {
          Tcl_WrongNumArgs(interp, 1, objv, "make <type>");
          return TCL_ERROR;
       }
         break;

      case ForgetIdx: 
       if (objc == nidx + 2) {
            if ((result = Tcl_GetIndexFromObj(interp, objv[nidx + 1],
            param_types, "parameter type", nidx - 1, &value)) != TCL_OK)
             return result;
            startunparam((Tk_Window)clientData, (pointertype)value, NULL);
       }
       else {
          Tcl_WrongNumArgs(interp, 1, objv, "forget <type>");
          return TCL_ERROR;
       }
         break;
   }
   return XcTagCallback(interp, objc, objv);
}

/*----------------------------------------------------------------------*/

int xctcl_select(ClientData clientData, Tcl_Interp *interp,
      int objc, Tcl_Obj *CONST objv[])
{
   char *argstr;
   short *newselect;
   int selected_prior, selected_new, nidx;
   int ehandle, result;
   Tcl_Obj *objPtr, *listPtr;
   genericptr *egen, *esrch;
   XPoint newpos;

   if (objc == 1) {
      /* Special case: "select" by itself returns the number of   */
      /* selected objects.                            */
      Tcl_SetObjResult(interp, Tcl_NewIntObj((int)areastruct.selects));
      return XcTagCallback(interp, objc, objv);
   }
   else {
      nidx = 1;
      result = ParseElementArguments(interp, objc, objv, &nidx, SEL_ANY);
      if (result != TCL_OK) return result;
   }

   if (objc != 2) {
      Tcl_WrongNumArgs(interp, 1, objv, "here | get | <object_handle>");
      return TCL_ERROR;
   }

   if (nidx == 1) {
      argstr = Tcl_GetString(objv[1]);
      if (!strcmp(argstr, "here")) {
         newpos = UGetCursorPos();
         areastruct.save = newpos;
         selected_prior = areastruct.selects;
         newselect = objectselect(SEL_ANY);
         selected_new = areastruct.selects - selected_prior;
      }
      else if (!strcmp(argstr, "get")) {
         newselect = areastruct.selectlist;
         selected_new = areastruct.selects;
      }
      else {
         Tcl_WrongNumArgs(interp, 1, objv, "here | get | <object_handle>");
       return TCL_ERROR;
      }

      listPtr = Tcl_NewListObj(0, NULL);
      if (selected_new == 0) {
      }
      else if (selected_new == 1) {
         objPtr = Tcl_NewHandleObj(SELTOGENERIC(newselect));
       Tcl_ListObjAppendElement(interp, listPtr, objPtr);
      }
      else if (selected_new > 1) {
         int i;
         for (i = 0; i < selected_new; i++) {
          newselect = areastruct.selectlist + i;
            objPtr = Tcl_NewHandleObj(SELTOGENERIC(newselect));
          Tcl_ListObjAppendElement(interp, listPtr, objPtr);
         }
      }
      Tcl_SetObjResult(interp, listPtr);
   }
   return XcTagCallback(interp, objc, objv);
}

/*----------------------------------------------------------------------*/

int xctcl_deselect(ClientData clientData, Tcl_Interp *interp,
      int objc, Tcl_Obj *CONST objv[])
{
   int i, j, k, result, numobjs, ehandle;
   char *argstr;
   Tcl_Obj *lobj;

   if (objc > 3) {
      Tcl_WrongNumArgs(interp, 1, objv, "[element_handle]");
      return TCL_ERROR;
   }
   else if (objc == 3 || (objc == 2 && !strcmp(Tcl_GetString(objv[0]), "deselect"))) {

      argstr = Tcl_GetString(objv[1]);
      if (strcmp(argstr, "selected")) {

         /* check for object handles (integer list) */

         result = Tcl_ListObjLength(interp, objv[1], &numobjs);
         if (result != TCL_OK) return result;

       for (j = 0; j < numobjs; j++) {
            result = Tcl_ListObjIndex(interp, objv[1], j, &lobj);
            if (result != TCL_OK) return result;
          result = Tcl_GetHandleFromObj(interp, lobj, (void *)&ehandle);
            if (result != TCL_OK) return result;
            i = GetPartNumber((genericptr)ehandle, topobject, SEL_ANY);
            if (i == -1) {
             Tcl_SetResult(interp, "No such element exists.", NULL);
             return TCL_ERROR;
            }
          for (i = 0; i < areastruct.selects; i++) {
             short *newselect = areastruct.selectlist + i;
             if ((genericptr)ehandle == SELTOGENERIC(newselect)) {
              XSetFunction(dpy, areastruct.gc, GXcopy);
              XTopSetForeground(GSELTOCOLOR(topobject, newselect));
              geneasydraw(*newselect, DEFAULTCOLOR, topobject,
                  areastruct.topinstance);

              areastruct.selects--;
              for (k = i; k < areastruct.selects; k++)
                  *(areastruct.selectlist + k) = *(areastruct.selectlist + k + 1);
              if (areastruct.selects == 0) free(areastruct.selectlist);
             }
          }
       }
      }
      else
       objectdeselect();
   }
   else
      startdesel((Tk_Window)clientData, NULL, NULL);

   return XcTagCallback(interp, objc, objv);
}

/*----------------------------------------------------------------------*/

int xctcl_push(ClientData clientData, Tcl_Interp *interp,
      int objc, Tcl_Obj *CONST objv[])
{
   int result = ParseElementArguments(interp, objc, objv, NULL, OBJECT);

   if (result != TCL_OK) return result;

   startpush((Tk_Window)clientData, NULL, NULL);
   if ((eventmode == PUSH_MODE) || (areastruct.selects == 0))
      return XcTagCallback(interp, objc, objv);
   else
      return TCL_ERROR;
}

/*----------------------------------------------------------------------*/

int xctcl_pop(ClientData clientData, Tcl_Interp *interp,
      int objc, Tcl_Obj *CONST objv[])
{
   if (objc != 1) {
      Tcl_WrongNumArgs(interp, 1, objv, "(no arguments)");
      return TCL_ERROR;
   }
   popobject((Tk_Window)clientData, NULL, NULL);

   return XcTagCallback(interp, objc, objv);
}

/*----------------------------------------------------------------------*/
/* Individual element handling.                                   */
/*----------------------------------------------------------------------*/

int xctcl_object(ClientData clientData, Tcl_Interp *interp,
      int objc, Tcl_Obj *CONST objv[])
{
   int i, idx, idx2, nidx, result, value;
   double tmpdbl;
   char *tmpstr;
   Tcl_Obj *objPtr, **newobjv;

   static char *subCmds[] = {"make", NULL};
   enum SubIdx {
      MakeIdx
   };

   nidx = 3;
   result = ParseElementArguments(interp, objc, objv, &nidx, 0);
   if (result != TCL_OK) return result;

   if ((result = Tcl_GetIndexFromObj(interp, objv[nidx], subCmds,
      "option", nidx - 1, &idx)) != TCL_OK)
      return result;

   switch (idx) {
      case MakeIdx:
       if ((areastruct.selects == 0) && (nidx == 1)) {
          /* h = object make "name" {element_list} */
          newobjv = (Tcl_Obj **)(&objv[2]);
          result = ParseElementArguments(interp, objc - 2, newobjv, NULL, SEL_ANY);
          if (result != TCL_OK) return result;
       }
       else if (nidx == 2) {
          Tcl_SetResult(interp, "\"object <handle> make\" is illegal", NULL);
          return TCL_ERROR;
       }
       else if (objc < 3) {
          Tcl_WrongNumArgs(interp, 1, objv, "make <name> ?element_list?");
          return TCL_ERROR;
       }
       strcpy(_STR2, Tcl_GetString(objv[nidx + 1]));
       domakeobject((Tk_Window)clientData, NULL);
       break;
   }
   return XcTagCallback(interp, objc, objv);
}

/*----------------------------------------------------------------------*/

int xctcl_label(ClientData clientData, Tcl_Interp *interp,
      int objc, Tcl_Obj *CONST objv[])
{
   int i, idx, idx2, nidx, result, value;
   double tmpdbl;
   char *tmpstr;
   Tcl_Obj *objPtr;
   labelptr tlab;

   static char *subCmds[] = {"make", "type", "insert", "justify", "flipinvariant",
      "visible", "font", "scale", "encoding", "style", "family", NULL};
   enum SubIdx {
      MakeIdx, TypeIdx, InsertIdx, JustIdx, FlipIdx,
      VisibleIdx, FontIdx, ScaleIdx, EncodingIdx, StyleIdx, FamilyIdx
   };

   static char *subsubCmds[] = {"text", "subscript", "superscript",
      "normalscript", "underline", "overline", "noline", "stop",
      "forward", "backward", "halfspace", "quarterspace", "return",
      "name", "scale", "color", "kern", "parameter", "special", NULL};

   static char *pinTypes[] = {"normal", "pin", "local", "global", "info", NULL};

   static char *encValues[] = {"Standard", "special", "ISOLatin1",
      "ISOLatin2", "ISOLatin3", "ISOLatin4", "ISOLatin5",
      "ISOLatin6", NULL};

   static char *styValues[] = {"normal", "bold", "italic", "bolditalic", NULL};

   static char *justValues[] = {"left", "center", "right", "top", "middle",
      "bottom", NULL};

   /* Tk "label" has been renamed to "tcl_label", but we want to  */
   /* consider the "label" command to be overloaded, such that the      */
   /* command "label" may be used without reference to namespace. */

   Tcl_Obj **newobjv = (Tcl_Obj **)Tcl_Alloc(objc * sizeof(Tcl_Obj *));

   newobjv[0] = Tcl_NewStringObj("tcl_label", 9);
   Tcl_IncrRefCount(newobjv[0]);
   for (i = 1; i < objc; i++) {
      newobjv[i] = Tcl_DuplicateObj(objv[i]);
      Tcl_IncrRefCount(newobjv[i]);
   }

   result = Tcl_EvalObjv(interp, objc, newobjv, 0);

   for (i = 0; i < objc; i++)
      Tcl_DecrRefCount(newobjv[i]);
   Tcl_Free((char *)newobjv);

   if (result == TCL_OK) return result;
   Tcl_ResetResult(interp);

   /* Now, assuming that Tcl didn't like the syntax, we continue on with */
   /* our own version.                                       */

   nidx = 4;
   result = ParseElementArguments(interp, objc, objv, &nidx, LABEL);
   if (result != TCL_OK) return result;

   if ((result = Tcl_GetIndexFromObj(interp, objv[nidx], subCmds,
      "option", nidx - 1, &idx)) != TCL_OK)
      return result;

   /* If there are no selections at this point, check if the command is */
   /* appropriate for setting a default value.                    */

   switch (idx) {
      case MakeIdx:
       if ((areastruct.selects == 0) && (nidx == 1)) {
          if (objc == 2) {
             starttext((Tk_Window)clientData, NORMAL, NULL);
             return XcTagCallback(interp, objc, objv);
          }
          else {
             result = Tcl_GetIndexFromObj(interp, objv[2], pinTypes,
                  "pin type", 0, &idx2);
             if (result != TCL_OK) {
                if (objc == 3) return result;
                else {
                 Tcl_ResetResult(interp);
                 idx2 = 0;
              }
             }
             else {
                nidx++;
                if (idx2 > 1) idx2--;   /* idx2 now matches defs in xcircuit.h */
             }
          }
          if (objc == 3) {
             starttext((Tk_Window)clientData, idx2, NULL);
          }
          else if ((objc != 4) && (objc != 5)) {
             Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
             return TCL_ERROR;
          }
          else {
             labelptr *newlab;
             stringpart *strptr = NULL;
             XPoint position;

             if ((result = GetXCStringFromList(interp, objv[nidx + 1],
                  &strptr)) != TCL_OK)
              return result;

             if ((result = GetPositionFromList(interp, objv[nidx + 2],
                  &position)) != TCL_OK)
              return result;

             NEW_LABEL(newlab, topobject);
             labeldefaults(*newlab, idx2, position.x, position.y);
             (*newlab)->string->nextpart = strptr;
             topobject->parts++;
             singlebbox((genericptr *)newlab);
             incr_changes(topobject);

             objPtr = Tcl_NewHandleObj(*newlab);
             Tcl_SetObjResult(interp, objPtr);
          }
       }
       else if (nidx == 2) {
          Tcl_SetResult(interp, "\"label <handle> make\" is illegal", NULL);
          return TCL_ERROR;
       }
       else {
          Tcl_SetResult(interp, "No selections allowed", NULL);
          return TCL_ERROR;
       }
       break;

      case ScaleIdx:
       if (objc == 2) {
          if ((areastruct.selects == 0) && (nidx == 1) &&
            eventmode != TEXT2_MODE && eventmode != TEXT3_MODE) {
             objPtr = Tcl_NewDoubleObj((double)areastruct.textscale);
             Tcl_SetObjResult(interp, objPtr);
          }
          else {
             float *floatptr;
             gettextsize(&floatptr);
             objPtr = Tcl_NewDoubleObj((double)((float)(*floatptr)));
             Tcl_SetObjResult(interp, objPtr);
          }
       }
       else if ((areastruct.selects == 0) && (nidx == 1) &&
            eventmode != TEXT2_MODE && eventmode != TEXT3_MODE) {
          result = Tcl_GetDoubleFromObj(interp, objv[2], &tmpdbl);
          if (result != TCL_OK) return result;
          areastruct.textscale = (float)tmpdbl;
       }
       else {
          /* If we're in edit mode, it will use EDITPART; otherwise,  */
          /* 2nd argument is ignored and select list is used instead. */
          strcpy(_STR2, Tcl_GetString(objv[2]));
          settsize((Tk_Window)clientData, *((labelptr *)EDITPART));
       }
       break;

      case FontIdx:
       if (objc == 2) {
          tmpstr = fonts[areastruct.psfont].psname;
          objPtr = Tcl_NewStringObj(tmpstr, strlen(tmpstr));
          Tcl_SetObjResult(interp, objPtr);
       }
       else {
          tmpstr = Tcl_GetString(objv[2]);
          for (i = 0; i < fontcount; i++)
             if (!strcmp(fonts[i].psname, tmpstr)) break;
          setfont((Tk_Window)clientData, (u_int)i, NULL);
       }
       break;

      case FamilyIdx:
       if (objc == 2) {
          tmpstr = fonts[areastruct.psfont].family;
          objPtr = Tcl_NewStringObj(tmpstr, strlen(tmpstr));
          Tcl_SetObjResult(interp, objPtr);
       }
       else {
          tmpstr = Tcl_GetString(objv[2]);
          for (i = 0; i < fontcount; i++)
             if (!strcmp(fonts[i].family, tmpstr)) break;
          setfont((Tk_Window)clientData, (u_int)i, NULL);
       }
       break;

      case EncodingIdx:
       if (objc == 2) {
          i = (fonts[areastruct.psfont].flags & 0xe0) >> 5;
          tmpstr = encValues[i];
          objPtr = Tcl_NewStringObj(tmpstr, strlen(tmpstr));
          Tcl_SetObjResult(interp, objPtr);
       }
       else {
          if (Tcl_GetIndexFromObj(interp, objv[2], encValues,
                  "encodings", 0, &idx2) != TCL_OK) {
             return TCL_ERROR;
          }
          fontencoding((Tk_Window)clientData, idx2, NULL);
       }
       break;

      case StyleIdx:
       if (objc == 2) {
          i = fonts[areastruct.psfont].flags & 0x3;
          tmpstr = styValues[i];
          objPtr = Tcl_NewStringObj(tmpstr, strlen(tmpstr));
          Tcl_SetObjResult(interp, objPtr);
       }
       else {
          if (Tcl_GetIndexFromObj(interp, objv[2], styValues,
                  "styles", 0, &idx2) != TCL_OK) {
             return TCL_ERROR;
          }
          fontstyle((Tk_Window)clientData, idx2, NULL);
       }
       break;

      case VisibleIdx:  /* Change visibility of pin */
       if ((areastruct.selects == 0) && (nidx == 1)) {
          Tcl_SetResult(interp, "Must have a label selection.", NULL);
          return TCL_ERROR;
       }
       if (objc == nidx + 1) {      /* Return pin visibility flag(s) */
          for (i = 0; i < areastruct.selects; i++) {
             if (SELECTTYPE(areastruct.selectlist + i) != LABEL) continue;
             tlab = SELTOLABEL(areastruct.selectlist + i);
             if (tlab->pin == NORMAL) continue;
             Tcl_AppendElement(interp, (tlab->justify & PINVISIBLE) ?
                  "true" : "false");
          }
       }
       else {
          int pval;
          char *pstr = Tcl_GetString(objv[nidx + 1]);
          char pl = tolower(pstr[0]);
          pval = ((pl == 'v') || (pl == 'y') || (pl = 't')) ? True : False;
          for (i = 0; i < areastruct.selects; i++) {
             if (SELECTTYPE(areastruct.selectlist + i) != LABEL) continue;
             tlab = SELTOLABEL(areastruct.selectlist + i);
             if (tlab->pin == NORMAL) continue;
             if (pval)
                tlab->justify |= PINVISIBLE;
             else
                tlab->justify &= ~PINVISIBLE;
          }
       }
       break;

      case TypeIdx:     /* Change type of label */
       if ((areastruct.selects == 0) && (nidx == 1)) {
          Tcl_SetResult(interp, "Must have a label selection.", NULL);
          return TCL_ERROR;
       }
       if (objc == nidx + 1) {      /* Return pin type(s) */
          int pidx;
          for (i = 0; i < areastruct.selects; i++) {
             if (SELECTTYPE(areastruct.selectlist + i) != LABEL) continue;
             tlab = SELTOLABEL(areastruct.selectlist + i);
             switch(tlab->pin) {
              case NORMAL:
                 pidx = 0; break;
              case LOCAL:
                 pidx = 2; break;
              case GLOBAL:
                 pidx = 3; break;
              case INFO:
                 pidx = 4; break;
             }
             Tcl_AppendElement(interp, pinTypes[pidx]);
          }
       }
       else {
          if (Tcl_GetIndexFromObj(interp, objv[nidx + 1], pinTypes,
               "pin types", 0, &idx2) != TCL_OK) {
             return TCL_ERROR;
          }
          for (i = 0; i < areastruct.selects; i++) {
             if (SELECTTYPE(areastruct.selectlist + i) != LABEL) continue;
             tlab = SELTOLABEL(areastruct.selectlist + i);
             switch(idx2) {
                case 0: 
                 tlab->pin = NORMAL;
                   break;
                case 1: case 2:
                 tlab->pin = LOCAL;
                   break;
                case 3:
                 tlab->pin = GLOBAL;
                   break;
                case 4:
                 tlab->pin = INFO;
                   break;
             }
             pinconvert(tlab, tlab->pin);
             setobjecttype(topobject);
          }
       }
       break;

      case InsertIdx:   /* Text insertion */
       if ((areastruct.selects != 0) || (nidx != 1)) {
          Tcl_SetResult(interp, "Insertion into handle or selection"
                  " not supported (yet)", NULL);
          return TCL_ERROR;
       }
       if (eventmode != TEXT2_MODE && eventmode != TEXT3_MODE) {
          Tcl_SetResult(interp, "Must be in edit mode to insert into label.",
                  NULL);
          return TCL_ERROR;
       }
       if (Tcl_GetIndexFromObj(interp, objv[nidx + 1], subsubCmds,
            "insertions", 0, &idx2) != TCL_OK) {
          return TCL_ERROR;
       }
       if ((idx2 > TEXT_STRING) && (idx2 < FONT_NAME) && (objc - nidx == 2)) { 
          labeltext(idx2, (char *)1);
       }
       else if ((idx2 == PARAM_START) && (objc - nidx == 3)) { 
          result = Tcl_GetIntFromObj(interp, objv[nidx + 2], &value);
          if (result != TCL_OK) return result;
          labeltext(idx2, (char *)&value);
       }
       else if ((idx2 == PARAM_START) && (objc - nidx == 2)) { 
          insertparam();
       }
       else if ((idx2 == FONT_COLOR) && (objc - nidx == 3)) {
          result = GetColorFromObj(interp, objv[nidx + 2], &value);
          if (result != TCL_OK) return result;
          labeltext(idx2, (char *)&value);
       }
       else if ((idx2 == FONT_NAME) && (objc - nidx == 3)) {
          tmpstr = Tcl_GetString(objv[nidx + 2]);
          for (i = 0; i < fontcount; i++)
             if (!strcmp(fonts[i].psname, tmpstr)) break;
          if (i == fontcount) {
             Tcl_SetResult(interp, "Invalid font name.", NULL);
             return TCL_ERROR;
          }
          else
             labeltext(idx2, (char *)&i);
       }
       else if ((idx2 == FONT_SCALE) && (objc - nidx == 3)) {
          float fvalue;
          double dvalue;
          result = Tcl_GetDoubleFromObj(interp, objv[nidx + 2], &dvalue);
          if (result != TCL_OK) return result;
          fvalue = (float)dvalue;
          labeltext(idx2, (char *)&fvalue);
       }
       else if ((idx2 == KERN) && (objc - nidx == 3)) {
          strcpy(_STR2, Tcl_GetString(objv[nidx + 2]));
          setkern(NULL, NULL);
       }
       else if ((idx2 == TEXT_STRING) && (objc - nidx == 3)) {
          char *substring = Tcl_GetString(objv[nidx + 2]);
          for (i = 0; i < strlen(substring); i++)
             labeltext(substring[i], NULL);
       }

       /* PARAM_END in xcircuit.h is actually mapped to the same */
       /* position as "special" in subsubCommands[] above; don't */
       /* be confused. . .                               */

       else if ((idx2 == PARAM_END) && (objc - nidx == 2)) {
          dospecial();
       }
       else if ((idx2 == PARAM_END) && (objc - nidx == 3)) {
          result = Tcl_GetIntFromObj(interp, objv[nidx + 2], &value);
          if (result != TCL_OK) return result;
          labeltext(value, NULL);
       }
       else {
          Tcl_WrongNumArgs(interp, 2, objv, "insertion_type ?arg ...?");
          return TCL_ERROR;
       }
       break;

      case JustIdx:
       if (Tcl_GetIndexFromObj(interp, objv[2], justValues,
            "horizontal justification", 1, &idx2) != TCL_OK) {
          return TCL_ERROR;
       }
       switch (idx2) {
          case 0: value = NORMAL; break;
          case 1: value = NOTLEFT; break;
          case 2: value = NOTLEFT | RIGHT; break;
          case 3: value = NOTBOTTOM | TOP; break;
          case 4: value = NOTBOTTOM; break;
          case 5: value = NORMAL; break;
       }
       sethjust(NULL, value, NULL); /* does both hjust & vjust */
       break;

      case FlipIdx:
       if ((result = Tcl_GetBooleanFromObj(interp, objv[nidx + 1], &value)) != TCL_OK)
          return result;
       setflipinv(NULL, FLIPINV, NULL);
       break;
   }
   return XcTagCallback(interp, objc, objv);
}

/*----------------------------------------------------------------------*/
/* Element Fill Styles                                      */
/*----------------------------------------------------------------------*/

int xctcl_dofill(ClientData clientData, Tcl_Interp *interp,
      int objc, Tcl_Obj *CONST objv[])
{
   char *tstr;
   u_int value;
   int i, idx, result;

   static char *Styles[] = {"opaque", "transparent", "filled", "unfilled",
      "solid", NULL};
   enum StylesIdx {
      OpaqueIdx, TransparentIdx, FilledIdx, UnfilledIdx, SolidIdx
   };

   if (objc == 1) {
      value = areastruct.style;
      Tcl_AppendElement(interp, ((value & OPAQUE) ? "opaque" : "transparent"));
      if (value & FILLED) {
         Tcl_AppendElement(interp, "filled");
       switch (value & FILLSOLID) {
          case 0:
               Tcl_AppendElement(interp, "12"); break;
          case STIP0:
               Tcl_AppendElement(interp, "25"); break;
          case STIP1:
               Tcl_AppendElement(interp, "37"); break;
          case STIP1 | STIP0:
               Tcl_AppendElement(interp, "50"); break;
          case STIP2:
               Tcl_AppendElement(interp, "62"); break;
          case STIP2 | STIP0:
               Tcl_AppendElement(interp, "75"); break;
          case STIP2 | STIP1:
               Tcl_AppendElement(interp, "87"); break;
          case FILLSOLID:
               Tcl_AppendElement(interp, "solid"); break;
       }
      }
      else {
       Tcl_AppendElement(interp, "unfilled");
      }
      return TCL_OK;
   }

   for (i = 1; i < objc; i++) {
      if (Tcl_GetIndexFromObj(interp, objv[i], Styles, "fill styles",
                  0, &idx) != TCL_OK) {
       Tcl_ResetResult(interp);
         result = Tcl_GetIntFromObj(interp, objv[i], &value);
         if (result != TCL_OK) {
          Tcl_SetResult(interp, "Expected fill style or fillfactor 0 to 100", NULL);
          return result;
       }
       else {
            if (value >= 0 && value < 6) value = FILLSOLID;
            else if (value >= 6 && value < 19) value = FILLED;
            else if (value >= 19 && value < 31) value = FILLED | STIP0;
            else if (value >= 31 && value < 44) value = FILLED | STIP1;
            else if (value >= 44 && value < 56) value = FILLED | STIP0 | STIP1;
            else if (value >= 56 && value < 69) value = FILLED | STIP2;
            else if (value >= 69 && value < 81) value = FILLED | STIP2 | STIP0;
            else if (value >= 81 && value < 94) value = FILLED | STIP2 | STIP1;
            else if (value >= 94 && value <= 100) value = FILLED | FILLSOLID;
            else {
               Tcl_SetResult(interp, "Fill value should be 0 to 100", NULL);
               return TCL_ERROR;
            }
            setelementstyle((Tk_Window)clientData, (pointertype)value, 
            FILLED | FILLSOLID);
       }
      }
      else {
         switch(idx) {
          case OpaqueIdx:
               setelementstyle((Tk_Window)clientData, OPAQUE, OPAQUE);
             break;
          case TransparentIdx:
               setelementstyle((Tk_Window)clientData, NORMAL, OPAQUE);
             break;
          case UnfilledIdx:
               setelementstyle((Tk_Window)clientData, FILLSOLID,
                  FILLED | FILLSOLID);
             break;
          case SolidIdx:
               setelementstyle((Tk_Window)clientData, FILLED | FILLSOLID,
                  FILLED | FILLSOLID);
             break;
          case FilledIdx:
             break;
       }
      }
   }
   /* Tag callback is handled by setstylemarks() */
   /* return XcTagCallback(interp, objc, objv); */
   return TCL_OK;
}

/*----------------------------------------------------------------------*/
/* Element border styles                                    */
/*----------------------------------------------------------------------*/

int xctcl_doborder(ClientData clientData, Tcl_Interp *interp,
      int objc, Tcl_Obj *CONST objv[])
{
   int result, i, idx, value;
   u_short mask;
   double wvalue;

   static char *borderStyles[] = {"solid", "dashed", "dotted", "none",
      "unbordered", "unclosed", "closed", "bbox", "set", "get", NULL};
   enum StyIdx {
      SolidIdx, DashedIdx, DottedIdx, NoneIdx, UnborderedIdx,
      UnclosedIdx, ClosedIdx, BBoxIdx, SetIdx, GetIdx
   };

   if (objc == 1) {
      Tcl_Obj *listPtr;
      listPtr = Tcl_NewListObj(0, NULL);
      value = areastruct.style;
      wvalue = (double)areastruct.linewidth;
      switch (value & (DASHED | DOTTED | NOBORDER)) {
       case NORMAL:
          Tcl_ListObjAppendElement(interp, listPtr, 
                  Tcl_NewStringObj("solid", 5)); break;
       case DASHED:
          Tcl_ListObjAppendElement(interp, listPtr, 
                  Tcl_NewStringObj("dashed", 6)); break;
       case DOTTED:
          Tcl_ListObjAppendElement(interp, listPtr, 
                  Tcl_NewStringObj("dotted", 6)); break;
       case NOBORDER:
          Tcl_ListObjAppendElement(interp, listPtr, 
                  Tcl_NewStringObj("unbordered", 10)); break;
      }
      if (value & UNCLOSED)
         Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj("unclosed", 8));
      else
         Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj("closed", 6));

      if (value & BBOX) 
         Tcl_ListObjAppendElement(interp, listPtr,
            Tcl_NewStringObj("bounding box", 12));

      Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewDoubleObj(wvalue));
      Tcl_SetObjResult(interp, listPtr);
      return TCL_OK;
   }

   for (i = 1; i < objc; i++) {
      result = Tcl_GetIndexFromObj(interp, objv[i], borderStyles,
            "border style", 0, &idx);
      if (result != TCL_OK)
       return result;

      switch (idx) {
         case GetIdx:
          {
             int j, numfound = 0;
             genericptr setel;
             Tcl_Obj *objPtr, *listPtr;

             listPtr = Tcl_NewListObj(0, NULL);
             for (j = 0; j < areastruct.selects; j++) {
                setel = SELTOGENERIC(areastruct.selectlist + j);
                if (setel->type == ARC || setel->type == POLYGON ||
                  setel->type == SPLINE || setel->type == PATH) {
                   switch(setel->type) {
                    case ARC: wvalue = ((arcptr)setel)->width; break;
                    case POLYGON: wvalue = ((polyptr)setel)->width; break;
                    case SPLINE: wvalue = ((splineptr)setel)->width; break;
                    case PATH: wvalue = ((pathptr)setel)->width; break;
                   }
                 objPtr = Tcl_NewDoubleObj(wvalue);
                 if (numfound > 0)
                    Tcl_ListObjAppendElement(interp, listPtr, objPtr);
                 if ((++numfound) == 1)
                    listPtr = objPtr;
                }
             }
             switch (numfound) {
                case 0:
                 Tcl_SetResult(interp, "Error: no appropriate elements selected",
                        NULL);
                 return TCL_ERROR;
                 break;
                case 1:
                   Tcl_SetObjResult(interp, objPtr);
                 break;
                default:
                   Tcl_SetObjResult(interp, listPtr);
                 break;
             }
          }
          break;
         case SetIdx:
          if ((objc - i) != 2) {
             Tcl_SetResult(interp, "Error: no linewidth given.", NULL);
             return TCL_ERROR;
          }
          result = Tcl_GetDoubleFromObj(interp, objv[i + 1], &wvalue);
          if (result == TCL_OK) {
             sprintf(_STR2, "%f", wvalue);
             setwwidth((Tk_Window)clientData, NULL);
          }
          else {
             Tcl_SetResult(interp, "Error: invalid border linewidth.", NULL);
             return TCL_ERROR;
          }
          break;
         case SolidIdx: value = NORMAL; mask = DASHED | DOTTED | NOBORDER; break;
         case DashedIdx: value = DASHED; mask = DASHED | DOTTED | NOBORDER; break;
         case DottedIdx: value = DOTTED; mask = DASHED | DOTTED | NOBORDER; break;
         case NoneIdx: case UnborderedIdx:
          value = NOBORDER; mask = DASHED | DOTTED | NOBORDER; break;
         case UnclosedIdx: value = UNCLOSED; mask = UNCLOSED; break;
         case ClosedIdx: value = NORMAL; mask = UNCLOSED; break;
         case BBoxIdx:
          mask = BBOX;
          if ((objc - i) < 2) value = BBOX;
          else {
             char *yesno = Tcl_GetString(objv[i + 1]);
             value = (tolower(yesno[0]) == 'y' || tolower(yesno[0]) == 't') ?
               BBOX : NORMAL;
             i++;
          }
          break;
      }
      if (idx != SetIdx && idx != GetIdx)
         setelementstyle((Tk_Window)clientData, (u_short)value, mask);
   }
   return XcTagCallback(interp, objc, objv);
}

/*----------------------------------------------------------------------*/

int xctcl_polygon(ClientData clientData, Tcl_Interp *interp,
      int objc, Tcl_Obj *CONST objv[])
{
   int idx, idx2, nidx, result, value, npoints, j;
   polyptr *newpoly;
   XPoint ppt;
   Tcl_Obj *objPtr, **newobjv;

   static char *subCmds[] = {"make", "border", "fill", "point", NULL};
   enum SubIdx {
      MakeIdx, BorderIdx, FillIdx, PointIdx
   };

   nidx = 255;
   result = ParseElementArguments(interp, objc, objv, &nidx, POLYGON);
   if (result != TCL_OK) return result;

   if ((result = Tcl_GetIndexFromObj(interp, objv[nidx], subCmds,
      "option", nidx - 1, &idx)) != TCL_OK)
      return result;

   switch (idx) {
      case MakeIdx:
       if ((areastruct.selects == 0) && (nidx == 1)) {
          if (objc == 2) {
             startpoly((Tk_Window)clientData, NULL, NULL);
             return TCL_OK;
          }
          else if ((objc == 3) && (!strcmp(Tcl_GetString(objv[2]), "box"))) {
             startbox((Tk_Window)clientData, NULL, NULL);
             return TCL_OK;
          }
          else if (objc < 5) {
             Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
             return TCL_ERROR;
          }
          if (!strcmp(Tcl_GetString(objv[2]), "box"))
             npoints = 4;
          else {
             result = Tcl_GetIntFromObj(interp, objv[2], &npoints);
             if (result != TCL_OK) return result;
          }
          if (objc != npoints + 3) {
             Tcl_WrongNumArgs(interp, 1, objv, "N {x1 y1}...{xN yN}");
             return TCL_ERROR;
          }
          NEW_POLY(newpoly, topobject);
          polydefaults(*newpoly, npoints, 0, 0);
          for (j = 0; j < npoints; j++) {
             result = GetPositionFromList(interp, objv[3 + j], &ppt);
             if (result == TCL_OK) {
                (*newpoly)->points[j].x = ppt.x;
                (*newpoly)->points[j].y = ppt.y;
             }
          }

          topobject->parts++;
          singlebbox((genericptr *)newpoly);
          incr_changes(topobject);

          objPtr = Tcl_NewHandleObj(*newpoly);
          Tcl_SetObjResult(interp, objPtr);
       }
       else if (nidx == 2) {
          Tcl_SetResult(interp, "\"polygon <handle> make\" is illegal", NULL);
          return TCL_ERROR;
       }
       else {
          Tcl_SetResult(interp, "No selections allowed", NULL);
          return TCL_ERROR;
       }
       break;

      case BorderIdx:
       newobjv = (Tcl_Obj **)(&objv[nidx]);
       result = xctcl_doborder(clientData, interp, objc - nidx, newobjv);
       break;

      case FillIdx:
       newobjv = (Tcl_Obj **)(&objv[nidx]);
       result = xctcl_dofill(clientData, interp, objc - nidx, newobjv);
       break;

      case PointIdx:
       if ((areastruct.selects == 0) || (areastruct.selects > 1) || (nidx == 1)) {
          Tcl_SetResult(interp, "Must have exactly one selection to "
            "manipulate points", NULL);
          return TCL_ERROR;
       }
       else {
          /* check EPOLY_MODE */
          Tcl_SetResult(interp, "Unimpemented function.", NULL);
          return TCL_ERROR;
       }
       break;
   }
   return XcTagCallback(interp, objc, objv);
}

/*----------------------------------------------------------------------*/

int xctcl_spline(ClientData clientData, Tcl_Interp *interp,
      int objc, Tcl_Obj *CONST objv[])
{
   int idx, idx2, nidx, result, value, j;
   splineptr *newspline;
   XPoint ppt;
   Tcl_Obj *objPtr, **newobjv;

   static char *subCmds[] = {"make", "border", "fill", "point", NULL};
   enum SubIdx {
      MakeIdx, BorderIdx, FillIdx, PointIdx
   };

   nidx = 5;
   result = ParseElementArguments(interp, objc, objv, &nidx, SPLINE);
   if (result != TCL_OK) return result;

   if ((result = Tcl_GetIndexFromObj(interp, objv[nidx], subCmds,
      "option", nidx - 1, &idx)) != TCL_OK)
      return result;

   /* h = spline make {x1 y1} ... {x4 y4} */

   switch (idx) {
      case MakeIdx:
       if ((areastruct.selects == 0) && (nidx == 1)) {
          if (objc == 2) {
             startspline((Tk_Window)clientData, NULL, NULL);
             return TCL_OK;
          }
          if (objc != 6) {
             Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
             return TCL_ERROR;
          }
          NEW_SPLINE(newspline, topobject);
          splinedefaults(*newspline, 0, 0);
          for (j = 0; j < 4; j++) {
             result = GetPositionFromList(interp, objv[2 + j], &ppt);
             if (result == TCL_OK) {
                (*newspline)->ctrl[j].x = ppt.x;
                (*newspline)->ctrl[j].y = ppt.y;
             }
          }
          calcspline(*newspline);

          topobject->parts++;
          singlebbox((genericptr *)newspline);
          incr_changes(topobject);

          objPtr = Tcl_NewHandleObj(*newspline);
          Tcl_SetObjResult(interp, objPtr);
       }
       else if (nidx == 2) {
          Tcl_SetResult(interp, "\"spline <handle> make\" is illegal", NULL);
          return TCL_ERROR;
       }
       else {
          Tcl_SetResult(interp, "No selections allowed", NULL);
          return TCL_ERROR;
       }
       break;

      case BorderIdx:
       newobjv = (Tcl_Obj **)(&objv[nidx]);
       result = xctcl_doborder(clientData, interp, objc - nidx, newobjv);
       break;

      case FillIdx:
       newobjv = (Tcl_Obj **)(&objv[nidx]);
       result = xctcl_dofill(clientData, interp, objc - nidx, newobjv);
       break;

      case PointIdx:
       if ((areastruct.selects == 0) || (areastruct.selects > 1) || (nidx == 1)) {
          Tcl_SetResult(interp, "Must have exactly one selection to "
            "manipulate points", NULL);
          return TCL_ERROR;
       }
       else {
          /* check ESPLINE_MODE */
          Tcl_SetResult(interp, "Unimpemented function.", NULL);
          return TCL_ERROR;
       }
       break;
   }
   return XcTagCallback(interp, objc, objv);
}

/*----------------------------------------------------------------------*/

int xctcl_arc(ClientData clientData, Tcl_Interp *interp,
      int objc, Tcl_Obj *CONST objv[])
{
   int idx, idx2, nidx, result, value;
   double angle;
   arcptr *newarc;
   XPoint ppt;
   Tcl_Obj *objPtr, **newobjv;

   static char *subCmds[] = {"make", "border", "fill", "radius", "minor",
      "angle", NULL};
   enum SubIdx {
      MakeIdx, BorderIdx, FillIdx, RadiusIdx, MinorIdx, AngleIdx
   };

   nidx = 7;
   result = ParseElementArguments(interp, objc, objv, &nidx, ARC);
   if (result != TCL_OK) return result;

   if ((result = Tcl_GetIndexFromObj(interp, objv[nidx], subCmds,
      "option", nidx - 1, &idx)) != TCL_OK)
      return result;

   switch (idx) {
      case MakeIdx:
       if ((areastruct.selects == 0) && (nidx == 1)) {
          if (objc == 2) {
             startarc((Tk_Window)clientData, NULL, NULL);
             return XcTagCallback(interp, objc, objv);
          }
          if ((objc < 4) || (objc > 7)) {
             Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
             return TCL_ERROR;
          }
          result = GetPositionFromList(interp, objv[2], &ppt);
          if (result != TCL_OK) return result;

          result = Tcl_GetIntFromObj(interp, objv[3], &value);
          if (result != TCL_OK) return result;

          NEW_ARC(newarc, topobject);
          arcdefaults(*newarc, ppt.x, ppt.y);
          (*newarc)->radius = (*newarc)->yaxis = value;

          switch (objc) {
             case 6:
                result = Tcl_GetDoubleFromObj(interp, objv[4], &angle);
              if (result == TCL_OK) (*newarc)->angle1 = (float)angle;
                result = Tcl_GetDoubleFromObj(interp, objv[5], &angle);
              if (result == TCL_OK) (*newarc)->angle2 = (float)angle;
              break;
             case 7:
                result = Tcl_GetDoubleFromObj(interp, objv[5], &angle);
              if (result == TCL_OK) (*newarc)->angle1 = (float)angle;
                result = Tcl_GetDoubleFromObj(interp, objv[6], &angle);
              if (result == TCL_OK) (*newarc)->angle2 = (float)angle;
             case 5:
                result = Tcl_GetIntFromObj(interp, objv[4], &value);
              if (result == TCL_OK) (*newarc)->yaxis = value;
              break;
          }

          topobject->parts++;
          singlebbox((genericptr *)newarc);
          incr_changes(topobject);

          objPtr = Tcl_NewHandleObj(*newarc);
          Tcl_SetObjResult(interp, objPtr);
       }
       else if (nidx == 2) {
          Tcl_SetResult(interp, "\"arc <handle> make\" is illegal", NULL);
          return TCL_ERROR;
       }
       else {
          Tcl_SetResult(interp, "No selections allowed", NULL);
          return TCL_ERROR;
       }
       break;

      case BorderIdx:
       newobjv = (Tcl_Obj **)(&objv[nidx]);
       result = xctcl_doborder(clientData, interp, objc - nidx, newobjv);
       break;

      case FillIdx:
       newobjv = (Tcl_Obj **)(&objv[nidx]);
       result = xctcl_dofill(clientData, interp, objc - nidx, newobjv);
       break;

      case RadiusIdx:
      case MinorIdx:
      case AngleIdx:
       Tcl_SetResult(interp, "Unimpemented function.", NULL);
       return TCL_ERROR;
       break;
   }
   return XcTagCallback(interp, objc, objv);
}

/*----------------------------------------------------------------------*/

int xctcl_path(ClientData clientData, Tcl_Interp *interp,
      int objc, Tcl_Obj *CONST objv[])
{
   int idx, idx2, nidx, result, value;
   genericptr newgen;
   Tcl_Obj *objPtr, **newobjv;

   static char *subCmds[] = {"join", "make", "border", "fill", "point", "unjoin", NULL};
   enum SubIdx {
      JoinIdx, MakeIdx, BorderIdx, FillIdx, PointIdx, UnJoinIdx
   };

   nidx = 5;
   result = ParseElementArguments(interp, objc, objv, &nidx, PATH);
   if (result != TCL_OK) return result;

   if ((result = Tcl_GetIndexFromObj(interp, objv[nidx], subCmds,
      "option", nidx - 1, &idx)) != TCL_OK)
      return result;

   switch (idx) {
      case MakeIdx: case JoinIdx:
       if ((areastruct.selects == 0) && (nidx == 1)) {
          /* h = path make {element_list} */
          newobjv = (Tcl_Obj **)(&objv[1]);
          result = ParseElementArguments(interp, objc - 1, newobjv, NULL,
                  POLYGON | ARC | SPLINE | PATH);
          if (result != TCL_OK) return result;
       }
       else if (nidx == 2) {
          Tcl_SetResult(interp, "\"path <handle> make\" is illegal", NULL);
          return TCL_ERROR;
       }
       /* h = path make */
       join();
       newgen = *(topobject->plist + topobject->parts - 1);
       objPtr = Tcl_NewHandleObj(newgen);
       Tcl_SetObjResult(interp, objPtr);
       break;

      case BorderIdx:
       newobjv = (Tcl_Obj **)(&objv[nidx]);
       result = xctcl_doborder(clientData, interp, objc - nidx, newobjv);
       break;

      case FillIdx:
       newobjv = (Tcl_Obj **)(&objv[nidx]);
       result = xctcl_dofill(clientData, interp, objc - nidx, newobjv);
       break;

      case PointIdx:
       Tcl_SetResult(interp, "Unimpemented function.", NULL);
       return TCL_ERROR;
       break;

      case UnJoinIdx:
       unjoin();
       /* Would be nice to return the list of constituent elements. . . */
       break;
   }
   return XcTagCallback(interp, objc, objv);
}

/*----------------------------------------------------------------------*/

int xctcl_instance(ClientData clientData, Tcl_Interp *interp,
      int objc, Tcl_Obj *CONST objv[])
{
   int idx, idx2, nidx, result, value;
   objectptr pobj;
   objinstptr pinst, *newinst;
   short *newselect;
   XPoint newpos;
   Tcl_Obj *objPtr;

   static char *subCmds[] = {"make", "scale", "center", NULL};
   enum SubIdx {
      MakeIdx, ScaleIdx, CenterIdx
   };

   nidx = 3;
   result = ParseElementArguments(interp, objc, objv, &nidx, OBJECT);
   if (result != TCL_OK) return result;

   if ((result = Tcl_GetIndexFromObj(interp, objv[nidx], subCmds,
      "option", nidx - 1, &idx)) != TCL_OK)
      return result;

   switch (idx) {
      case MakeIdx:
       if ((areastruct.selects == 0) && (nidx == 1)) {
          if (objc == 3) {
             pobj = NameToObject(Tcl_GetString(objv[2]), &pinst, FALSE);
             if (pobj == NULL) {
              Tcl_SetResult(interp, "no such object", NULL);
              return TCL_ERROR;
             }
             NEW_OBJINST(newinst, topobject);
             topobject->parts++;
             instcopy(*newinst, pinst);
             (*newinst)->color = areastruct.color;
             newpos = UGetCursorPos();
             u2u_snap(&newpos);
             (*newinst)->position = newpos;
             newselect = allocselect();
             *newselect = (short)(newinst - (objinstptr *)topobject->plist);
             drawselects(topobject, areastruct.topinstance);
             eventmode = COPY2_MODE;
             Tk_CreateEventHandler(areastruct.area, PointerMotionMask,
                  (Tk_EventProc *)xctk_drag, NULL);
             return XcTagCallback(interp, objc, objv);
          }
          else if (objc != 4) {
             Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
             return TCL_ERROR;
          }
          pobj = NameToObject(Tcl_GetString(objv[2]), &pinst, FALSE);
          if (pobj == NULL) {
             Tcl_SetResult(interp, "no such object", NULL);
             return TCL_ERROR;
          }
          result = GetPositionFromList(interp, objv[3], &newpos);
          if (result != TCL_OK) return result;

          NEW_OBJINST(newinst, topobject);
          instcopy(*newinst, pinst);
          (*newinst)->color = areastruct.color;
          (*newinst)->position = newpos;

          topobject->parts++;
          singlebbox((genericptr *)newinst);
          incr_changes(topobject);

          objPtr = Tcl_NewHandleObj(*newinst);
          Tcl_SetObjResult(interp, objPtr);
       }
       else if (nidx == 2) {
          Tcl_SetResult(interp, "\"instance <handle> make\" is illegal", NULL);
          return TCL_ERROR;
       }
       else {
          Tcl_SetResult(interp, "No selections allowed.", NULL);
          return TCL_ERROR;
       }
       break;
      case ScaleIdx:
       if (objc == 2) {
          int i, numfound = 0;
          Tcl_Obj *listPtr;
          for (i = 0; i < areastruct.selects; i++) {
             if (SELECTTYPE(areastruct.selectlist + i) == OBJECT) {
              pinst = SELTOOBJINST(areastruct.selectlist + i);
              objPtr = Tcl_NewDoubleObj(pinst->scale);
              if (numfound > 0)
                 Tcl_ListObjAppendElement(interp, listPtr, objPtr);
              if ((++numfound) == 1)
                 listPtr = objPtr;
             }
          }
          switch (numfound) {
             case 0:
              Tcl_SetResult(interp, "Error: no objects selected", NULL);
              return TCL_ERROR;
              break;
             case 1:
                Tcl_SetObjResult(interp, objPtr);
              break;
             default:
                Tcl_SetObjResult(interp, listPtr);
              break;
          }
       }
       else {
          strcpy(_STR2, Tcl_GetString(objv[2]));
          setosize((Tk_Window)clientData, NULL);
       }
       break;
   }
   return XcTagCallback(interp, objc, objv);
}

/*----------------------------------------------------------------------*/
/* "element" configures properties of elements.  Note that if the       */
/* second argument is not an element handle (pointer), then operations  */
/* will be applied to all selected elements.  If there is no element    */
/* handle and no objects are selected, the operation will be applied    */
/* to default settings, like the "xcircuit::set" command.         */
/*----------------------------------------------------------------------*/

int xctcl_element(ClientData clientData, Tcl_Interp *interp,
      int objc, Tcl_Obj *CONST objv[])
{
   int result, nidx, idx, i, flags;
   Tcl_Obj *listPtr;
   Tcl_Obj **newobjv;
   int newobjc;

   /* Commands */
   static char *subCmds[] = {
      "delete", "copy", "flip", "rotate", "edit", "select", "snap", "move",
      "color", "parameters", "raise", "lower", "exchange",
      "deselect", NULL
   };
   enum SubIdx {
      DeleteIdx, CopyIdx, FlipIdx, RotateIdx, EditIdx,      SelectIdx, SnapIdx,
      MoveIdx, ColorIdx, ParamIdx, RaiseIdx, LowerIdx, ExchangeIdx,
      DeselectIdx
   };

   static char *etypes[] = {
      "Label", "Polygon", "Bezier Curve", "Object Instance", "Path", "Arc"
   };

   /* Before doing a standard parse, we need to check for the single case */
   /* "element X deselect"; otherwise, calling ParseElementArguements()  */
   /* is going to destroy the selection list.                       */

   if ((objc == 3) && (!strcmp(Tcl_GetString(objv[2]), "deselect"))) {
      result = xctcl_deselect(clientData, interp, objc, objv);
      return result;
   }

   /* All other commands are dispatched to individual element commands  */
   /* for the indicated element or for each selected element.           */

   nidx = 7;
   result = ParseElementArguments(interp, objc, objv, &nidx, SEL_ANY);
   if (result != TCL_OK) return result;

   if ((objc - nidx) < 1) {
      Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
      return TCL_ERROR;
   }

   if (!strcmp(Tcl_GetString(objv[nidx]), "type")) {
      /* Return a list of types of the selected objects */

      if (areastruct.selects > 1)
       listPtr = Tcl_NewListObj(0, NULL);

      for (i = 0; i < areastruct.selects; i++) {
       Tcl_Obj *objPtr;
       int idx2, type = SELECTTYPE(areastruct.selectlist + i);
       switch (type) {
          case LABEL: idx2 = 0; break;
          case POLYGON: idx2 = 1; break;
          case SPLINE: idx2 = 2; break;
          case OBJECT: idx2 = 3; break;
          case PATH: idx2 = 4; break;
          case ARC: idx2 = 5; break;
          default: return TCL_ERROR;
       }
       objPtr = Tcl_NewStringObj(etypes[idx2], strlen(etypes[idx2]));
       if (areastruct.selects == 1) {
          Tcl_SetObjResult(interp, objPtr);
          return TCL_OK;
       }
       else {
          Tcl_ListObjAppendElement(interp, listPtr, objPtr);
       }
       Tcl_SetObjResult(interp, listPtr);
      }
      return XcTagCallback(interp, objc, objv);
   }
   
   if (Tcl_GetIndexFromObj(interp, objv[nidx], subCmds,
      "option", 0, &idx) == TCL_OK) {

      newobjv = (Tcl_Obj **)(&objv[nidx]);
      newobjc = objc - nidx;

      /* Shift the argument list and call the indicated function. */

      switch(idx) {
       case DeleteIdx:
          result = xctcl_delete(clientData, interp, newobjc, newobjv);
          break;
       case CopyIdx:
          result = xctcl_copy(clientData, interp, newobjc, newobjv);
          break;
       case FlipIdx:
          result = xctcl_flip(clientData, interp, newobjc, newobjv);
          break;
       case RotateIdx:
          result = xctcl_rotate(clientData, interp, newobjc, newobjv);
          break;
       case EditIdx:
          result = xctcl_edit(clientData, interp, newobjc, newobjv);
          break;
       case ParamIdx:
          result = xctcl_param(clientData, interp, newobjc, newobjv);
          break;
       case SelectIdx:
          /* If nidx == 2, then we've already done the selection! */
          if (nidx == 1)
             result = xctcl_select(clientData, interp, newobjc, newobjv);
          else
             result = TCL_OK;
          break;
       case DeselectIdx:
          /* case nidx == 2 was already taken care of. case nidx == 1 */
          /* implies "deselect all".                              */
          objectdeselect();
          result = TCL_OK;
          break;
       case ColorIdx:
          result = xctcl_color(clientData, interp, newobjc, newobjv);
          break;
       case SnapIdx:
          snapobject();
          break;
       case ExchangeIdx:
          exchange();
          break;
       case LowerIdx:
          for (i = 0; i < areastruct.selects; i++)
             xc_lower(areastruct.selectlist + i);
          break;
       case RaiseIdx:
          for (i = 0; i < areastruct.selects; i++)
             xc_raise(areastruct.selectlist + i);
          break;
       case MoveIdx:
          result = xctcl_move(clientData, interp, newobjc, newobjv);
          break;
      }
      return result;
   }

   /* Call each individual element function.                      */
   /* Each function is responsible for filtering the select list to     */
   /* choose only the appropriate elements.  However, we first check    */
   /* if at least one of that type exists in the list, so the function  */
   /* won't return an error.                                */

   Tcl_ResetResult(interp);

   newobjv = (Tcl_Obj **)(&objv[nidx - 1]);
   newobjc = objc - nidx + 1;

   flags = 0;
   for (i = 0; i < areastruct.selects; i++)
      flags |= SELECTTYPE(areastruct.selectlist + i);

   if (flags & LABEL) {
      result = xctcl_label(clientData, interp, newobjc, newobjv);
      if (result != TCL_OK) return result;
   }
   if (flags & POLYGON) {
      result = xctcl_polygon(clientData, interp, newobjc, newobjv);
      if (result != TCL_OK) return result;
   }
   if (flags & OBJECT) {
      result = xctcl_instance(clientData, interp, newobjc, newobjv);
      if (result != TCL_OK) return result;
   }
   if (flags & SPLINE) {
      result = xctcl_spline(clientData, interp, newobjc, newobjv);
      if (result != TCL_OK) return result;
   }
   if (flags & PATH) {
      result = xctcl_path(clientData, interp, newobjc, newobjv);
      if (result != TCL_OK) return result;
   }
   if (flags & ARC) {
      result = xctcl_arc(clientData, interp, newobjc, newobjv);
   }
   return result;
}

/*----------------------------------------------------------------------*/
/* "set" sets a whole bunch of stuff.  Note that the conflict between   */
/* Tcl's internal "set" command and xcircuit's implies that one must    */
/* always use the fully-qualified name "xcircuit::set".                 */
/*----------------------------------------------------------------------*/

int xctcl_set(ClientData clientData, Tcl_Interp *interp,
      int objc, Tcl_Obj *CONST objv[])
{
   double tmpdbl;
   int tmpint, i;
   int result, idx, idx2;
   char *fontname, *tmpstr, buffer[30];
   Pagedata *curpage;

   static char *boxsubCmds[] = {"manhattan", "rhomboidx", "rhomboidy",
      "rhomboida", "normal", NULL};
   static char *coordsubCmds[] = {"decimal inches", "fractional inches",
      "centimeters", NULL};
   static char *filterTypes[] = {"instances", "labels", "polygons", "arcs",
      "splines", "paths", NULL};
   static char *filterVar[] = {"sel_obj", "sel_lab", "sel_poly", "sel_arc",
      "sel_spline", "sel_path", NULL};

   static char *subCmds[] = {
      "axis", "axes", "grid", "snap", "bbox", "editinplace",
      "pinpositions", "boxedit", "linewidth", "colorscheme",
      "coordstyle", "drawingscale", "manhattan", "centering",
      "filter", NULL
   };
   enum SubIdx {
      AxisIdx, AxesIdx, GridIdx, SnapIdx, BBoxIdx, EditInPlaceIdx,
      PinPosIdx, BoxEditIdx, LineWidthIdx, ColorSchemeIdx,
      CoordStyleIdx, ScaleIdx, ManhattanIdx, CenteringIdx,
      FilterIdx
   };

   if ((objc == 1) || (objc > 5)) {
      Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
      return TCL_ERROR;
   }
   if (Tcl_GetIndexFromObj(interp, objv[1], subCmds,
      "option", 0, &idx) != TCL_OK) {
      return TCL_ERROR;
   }

   curpage = xobjs.pagelist[areastruct.page];

   /* Check number of arguments wholesale (to be done) */

   switch(idx) {
      case AxisIdx: case AxesIdx:
       if (objc == 2) {
          Tcl_SetResult(interp, (areastruct.axeson) ? "true" : "false", NULL);
          break;
       }
       else {
          result = Tcl_GetBooleanFromObj(interp, objv[2], &tmpint);
          if (result != TCL_OK) return result;
          areastruct.axeson = (Boolean) tmpint;
       }
       Tcl_SetVar(interp, "showaxes", (areastruct.axeson) ? "true" : "false",
            TCL_NAMESPACE_ONLY);
       break;

      case GridIdx:
       if (objc == 2) {
          Tcl_SetResult(interp, (areastruct.gridon) ? "true" : "false", NULL);
          break;
       }
       else {
          if (!strncmp("spac", Tcl_GetString(objv[2]), 4)) {
             if (objc == 3) {
              measurestr((float)curpage->gridspace, buffer);
              Tcl_SetObjResult(interp, Tcl_NewStringObj(buffer, strlen(buffer)));
              break;
             }
             else {
                strcpy(_STR2, Tcl_GetString(objv[3]));
                setgrid(NULL, &(curpage->gridspace));
             }
          }
          else {
             result = Tcl_GetBooleanFromObj(interp, objv[2], &tmpint);
             if (result != TCL_OK) return result;
             areastruct.gridon = (Boolean) tmpint;
          }
       }
       Tcl_SetVar(interp, "showgrid", (areastruct.gridon) ?
            "true" : "false", TCL_NAMESPACE_ONLY);
       break;

      case SnapIdx:
       if (objc == 2) {
          Tcl_SetResult(interp, (areastruct.snapto) ? "true" : "false", NULL);
       }
       else {
          if (!strncmp("spac", Tcl_GetString(objv[2]), 4)) {
             if (objc == 3) {
              measurestr((float)curpage->snapspace, buffer);
              Tcl_SetObjResult(interp, Tcl_NewStringObj(buffer, strlen(buffer)));
              break;
             }
             else {
                strcpy(_STR2, Tcl_GetString(objv[3]));
                setgrid(NULL, &(curpage->snapspace));
             }
          }
          else {
             result = Tcl_GetBooleanFromObj(interp, objv[2], &tmpint);
             if (result != TCL_OK) return result;
             areastruct.snapto = (Boolean) tmpint;
          }
       }
       Tcl_SetVar(interp, "showsnap", (areastruct.snapto) ?
            "true" : "false", TCL_NAMESPACE_ONLY);
       break;

      case BoxEditIdx:
       if (objc == 2) {
          switch (areastruct.boxedit) {
             case MANHATTAN: idx = 0; break;
             case RHOMBOIDX: idx = 1; break;
             case RHOMBOIDY: idx = 2; break;
             case RHOMBOIDA: idx = 3; break;
             case NORMAL: idx = 4; break;
          }
          Tcl_SetObjResult(interp, Tcl_NewStringObj(boxsubCmds[idx],
            strlen(boxsubCmds[idx])));
       }
       else if (objc != 3) {
          Tcl_WrongNumArgs(interp, 2, objv, "boxedit ?arg ...?");
          return TCL_ERROR;
       }
       else {
          if (Tcl_GetIndexFromObj(interp, objv[2], boxsubCmds,
            "option", 0, &idx) != TCL_OK) {
             return TCL_ERROR;
          }
          switch (idx) {
             case 0: tmpint = MANHATTAN; break;
             case 1: tmpint = RHOMBOIDX; break;
             case 2: tmpint = RHOMBOIDY; break;
             case 3: tmpint = RHOMBOIDA; break;
             case 4: tmpint = NORMAL; break;
          }
          boxedit(NULL, tmpint, NULL);
       }
       Tcl_SetVar(interp, "polyedittype", boxsubCmds[idx], TCL_NAMESPACE_ONLY);
       break;

      case LineWidthIdx:
       if (objc == 2) {
          Tcl_SetObjResult(interp,
            Tcl_NewDoubleObj((double)curpage->wirewidth / 2.0));
       }
       else if (objc != 3) {
          Tcl_WrongNumArgs(interp, 3, objv, "linewidth");
          return TCL_ERROR;
       }
       else {
          strcpy(_STR2, Tcl_GetString(objv[2]));
          setwidth(NULL, &(curpage->wirewidth));
       }
       break;

      case BBoxIdx:
       if (objc == 2) {
          Tcl_SetResult(interp, (areastruct.bboxon) ? "true" : "false", NULL);
       }
       else {
          tmpstr = Tcl_GetString(objv[2]);
          if (strstr(tmpstr, "visible"))
             tmpint = (tmpstr[0] == 'i') ? False : True;
          else {
             result = Tcl_GetBooleanFromObj(interp, objv[2], &tmpint);
             if (result != TCL_OK) return result;
          }
          areastruct.bboxon = (Boolean) tmpint;
       }
       Tcl_SetVar(interp, "showbbox", (areastruct.bboxon) ?
            "visible" : "invisible", TCL_NAMESPACE_ONLY);
       break;

      case EditInPlaceIdx:
       if (objc == 2) {
          Tcl_SetResult(interp, (areastruct.editinplace) ? "true" : "false", NULL);
       }
       else {
          result = Tcl_GetBooleanFromObj(interp, objv[2], &tmpint);
          if (result != TCL_OK) return result;
          areastruct.editinplace = (Boolean) tmpint;
       }
       Tcl_SetVar(interp, "editinplace", (areastruct.editinplace) ?
            "true" : "false", TCL_NAMESPACE_ONLY);
       break;

      case PinPosIdx:
       if (objc == 2) {
          Tcl_SetResult(interp, (areastruct.pinpointon) ? "true" : "false", NULL);
       }
       else {
          tmpstr = Tcl_GetString(objv[2]);
          if (strstr(tmpstr, "visible"))
             tmpint = (tmpstr[0] == 'i') ? False : True;
          else {
             result = Tcl_GetBooleanFromObj(interp, objv[2], &tmpint);
             if (result != TCL_OK) return result;
          }
          areastruct.pinpointon = (Boolean) tmpint;
       }
       Tcl_SetVar(interp, "pinpositions", (areastruct.pinpointon) ?
            "visible" : "invisible", TCL_NAMESPACE_ONLY);
       break;

      case ColorSchemeIdx:
       if (objc == 2) {
          Tcl_SetResult(interp, (areastruct.invert) ? "inverse" : "normal", NULL);
       }
       else {
          tmpstr = Tcl_GetString(objv[2]);
          if (!strcmp(tmpstr, "normal") || !strcmp(tmpstr, "standard"))
             tmpint = False;
          else if (!strcmp(tmpstr, "inverse") || !strcmp(tmpstr, "alternate"))
             tmpint = True;
          else {
             result = Tcl_GetBooleanFromObj(interp, objv[2], &tmpint);
             if (result != TCL_OK) return result;
          }
          areastruct.invert = (Boolean) tmpint;
          setcolorscheme(!areastruct.invert);
       }
       Tcl_SetVar(interp, "colorscheme", (areastruct.invert) ?
            "alternate" : "normal", TCL_NAMESPACE_ONLY);
       break;

      case CoordStyleIdx:
       if (objc == 2) {
          switch (curpage->coordstyle) {
             case DEC_INCH: idx = 0; break;
             case FRAC_INCH: idx = 1; break;
             case CM: idx = 2; break;
          }
          Tcl_SetObjResult(interp, Tcl_NewStringObj(coordsubCmds[idx],
            strlen(coordsubCmds[idx])));
       }
       else if (objc != 3) {
          Tcl_WrongNumArgs(interp, 2, objv, "coordstyle ?arg ...?");
          return TCL_ERROR;
       }
       else {
          if (Tcl_GetIndexFromObj(interp, objv[2], coordsubCmds,
            "option", 0, &idx) != TCL_OK) {
             return TCL_ERROR;
          }
          switch (idx) {
             case 0: tmpint = DEC_INCH; break;
             case 1: tmpint = FRAC_INCH; break;
             case 2: tmpint = CM; break;
          }
          getgridtype(NULL, tmpint, NULL);
       }
       Tcl_SetVar(interp, "gridstyle", coordsubCmds[idx], TCL_NAMESPACE_ONLY);
       break;

      case ScaleIdx:
       if (objc == 2) {
          Tcl_Obj *objPtr = Tcl_NewListObj(0, NULL);
          Tcl_ListObjAppendElement(xcinterp, objPtr,
            Tcl_NewIntObj((int)curpage->drawingscale.x));
          Tcl_ListObjAppendElement(xcinterp, objPtr,
            Tcl_NewStringObj(":", 1));
          Tcl_ListObjAppendElement(xcinterp, objPtr,
            Tcl_NewIntObj((int)curpage->drawingscale.y));
          Tcl_SetObjResult(interp, objPtr);
       }
       else if (objc == 3) {
          strcpy(_STR2, Tcl_GetString(objv[2]));
          setdscale(NULL, &(curpage->drawingscale));
       }
       else {
          Tcl_WrongNumArgs(interp, 2, objv, "drawingscale ?arg ...?");
          return TCL_ERROR;
       }
       break;

      case ManhattanIdx:
       if (objc == 2) {
          Tcl_SetResult(interp, (areastruct.manhatn) ? "true" : "false", NULL);
       }
       else {
          result = Tcl_GetBooleanFromObj(interp, objv[2], &tmpint);
          if (result != TCL_OK) return result;
          areastruct.manhatn = (Boolean) tmpint;
       }
       Tcl_SetVar(interp, "manhattandraw", (areastruct.manhatn) ?
            "true" : "false", TCL_NAMESPACE_ONLY);
       break;

      case CenteringIdx:
       if (objc == 2) {
          Tcl_SetResult(interp, (areastruct.center) ? "true" : "false", NULL);
       }
       else {
          result = Tcl_GetBooleanFromObj(interp, objv[2], &tmpint);
          if (result != TCL_OK) return result;
          areastruct.center = (Boolean) tmpint;
       }
       Tcl_SetVar(interp, "centerobject", (areastruct.center) ?
            "true" : "false", TCL_NAMESPACE_ONLY);
       break;

      case FilterIdx:
       if (objc == 2) {
          for (i = 0; i < 6; i++) {
             tmpint = 1 << i;
             if (areastruct.filter & tmpint) {
              Tcl_AppendElement(interp, filterTypes[i]);
             }
          }
       }
       else if (objc >= 3) {
          if (Tcl_GetIndexFromObj(interp, objv[2], filterTypes,
            "filter_type", 0, &tmpint) != TCL_OK) {
             return TCL_ERROR;
          }
          if (objc == 3) {
             if (areastruct.filter & (1 << tmpint))
              Tcl_SetResult(interp, "true", NULL);
             else
              Tcl_SetResult(interp, "false", NULL);
          }
          else {
             int ftype = 1 << tmpint;
             if (!strcmp(Tcl_GetString(objv[3]), "true"))
                areastruct.filter |= ftype;
             else
                areastruct.filter &= (~ftype);

             Tcl_SetVar(interp, filterVar[tmpint], Tcl_GetString(objv[3]),
                  TCL_NAMESPACE_ONLY);
          }
       }
       break;
   }
   return XcTagCallback(interp, objc, objv);
}

/*----------------------------------------------------------------------*/

int xctcl_promptsavepage(ClientData clientData, Tcl_Interp *interp,
      int objc, Tcl_Obj *CONST objv[])
{
   int page = areastruct.page;
   int result, num_linked;
   Pagedata *curpage;
   objectptr pageobj;
   char scxstr[12], scystr[12], scsstr[12];
   struct stat statbuf;
   char *cstr;

   /* save page popup */

   if (objc > 2) {
      Tcl_WrongNumArgs(interp, 1, objv, "[page_number]");
      return TCL_ERROR;
   }
   else if (objc == 2) {
      result = Tcl_GetIntFromObj(interp, objv[1], &page);
      if (result != TCL_OK) return result;
   }
   else page = areastruct.page; 

   curpage = xobjs.pagelist[page];
   if (curpage->pageinst == NULL) {
      Tcl_SetResult(interp, "Page does not exist. . . cannot save.", NULL);
      return TCL_ERROR;
   }
   pageobj = curpage->pageinst->thisobject;

   /* recompute bounding box and auto-scale, if set */

   calcbbox(xobjs.pagelist[page]->pageinst);
   if (curpage->pmode & 2) autoscale(page);

   /* get file information */

   if (strstr(curpage->filename, ".") == NULL)
      sprintf(_STR2, "%s.ps", curpage->filename);
   else sprintf(_STR2, "%s", curpage->filename);
   if (stat(_STR2, &statbuf) == 0) {
      Wprintf("  Warning:  File exists");
   }
   else {
      if (errno == ENOTDIR)
         Wprintf("Error:  Incorrect pathname");
      else if (errno == EACCES)
         Wprintf("Error:  Path not readable");
      else
         Wprintf("  ");
   }
   Tcl_SetObjResult(interp, Tcl_NewIntObj((int)page));

   return XcTagCallback(interp, objc, objv);
}

/*----------------------------------------------------------------------*/

int xctcl_promptsavelib(ClientData clientData, Tcl_Interp *interp,
      int objc, Tcl_Obj *CONST objv[])
{
   int result;
   int libno = 0;

   /* save library */
   if (objc > 2) {
      Tcl_WrongNumArgs(interp, 1, objv, "[library_number]");
      return TCL_ERROR;
   }
   else if (objc == 2) {
      result = Tcl_GetIntFromObj(interp, objv[1], &libno);
      if (result != TCL_OK) return result;
   }
   savelibpopup((Tk_Window)clientData, (u_int)libno, NULL);

   return XcTagCallback(interp, objc, objv);
}

/*----------------------------------------------------------------------*/

int xctcl_quit(ClientData clientData, Tcl_Interp *interp,
      int objc, Tcl_Obj *CONST objv[])
{
   /* quit, without checks */
   if (objc != 1) {
      Tcl_WrongNumArgs(interp, 1, objv, "(no arguments)");
      return TCL_ERROR;
   }
   quit(areastruct.area, NULL);
   return XcTagCallback(interp, objc, objv);
}

/*----------------------------------------------------------------------*/

int xctcl_promptquit(ClientData clientData, Tcl_Interp *interp,
      int objc, Tcl_Obj *CONST objv[])
{
   /* quit, with checks */
   if (objc != 1) {
      Tcl_WrongNumArgs(interp, 1, objv, "(no arguments)");
      return TCL_ERROR;
   }
   quitcheck(NULL, NULL, NULL);
   return XcTagCallback(interp, objc, objv);
}

/*----------------------------------------------------------------------*/

int xctcl_refresh(ClientData clientData, Tcl_Interp *interp,
      int objc, Tcl_Obj *CONST objv[])
{
   /* refresh */
   if (objc != 1) {
      Tcl_WrongNumArgs(interp, 1, objv, "(no arguments)");
      return TCL_ERROR;
   }
   drawarea(areastruct.area, (caddr_t)clientData, (caddr_t)NULL);
   return XcTagCallback(interp, objc, objv);
}

/*----------------------------------------------------------------------*/

int xctcl_page(ClientData clientData, Tcl_Interp *interp,
      int objc, Tcl_Obj *CONST objv[])
{
   int result, idx, nidx, aval, i, j = 0;
   int cpage, multi, savepage, pageno = -1, linktype;
   char *tmpstr, *filename;
   Tcl_Obj *objPtr;
   double newheight, newwidth, newscale;
   float oldscale;
   int newrot, newmode;
   objectptr pageobj;
   char *oldstr, *newstr, *cstr;
   Pagedata *curpage, *lpage;
   short *pagelist;

   char *subCmds[] = {
      "load", "import", "background", "save", "saveonly", "make", "directory",
      "reset", "links", "fit", "filename", "label", "scale", "width",
      "height", "size", "goto", "orientation", "encapsulation", NULL
   };
   enum SubIdx {
      LoadIdx, ImportIdx, BackIdx, SaveIdx, SaveOnlyIdx, MakeIdx, DirIdx,
      ResetIdx, LinksIdx, FitIdx, FileIdx, LabelIdx, ScaleIdx, WidthIdx,
      HeightIdx, SizeIdx, GoToIdx, OrientIdx, EPSIdx
   };

   char *linkTypes[] = {"independent", "dependent", "total", "pagedependent",
            "all", NULL};
   char *psTypes[] = {"eps", "full", NULL};

   savepage = areastruct.page;

   result = ParsePageArguments(interp, objc, objv, &nidx, &pageno);
   if ((result != TCL_OK) || (nidx < 0)) return result;
   else if (nidx == 1 && objc == 2) {
      idx = GoToIdx;
   }
   else if (Tcl_GetIndexFromObj(interp, objv[1 + nidx], subCmds,
      "option", 0, &idx) != TCL_OK) {
      return result;
   }

   curpage = xobjs.pagelist[pageno];

   if (curpage->pageinst != NULL)
      pageobj = curpage->pageinst->thisobject;
   else {
      if (idx != LoadIdx && idx != MakeIdx && idx != DirIdx && idx != GoToIdx) {
       Tcl_SetResult(interp, "Cannot do function on non-initialized page.", NULL);
       return TCL_ERROR;
      }
   } 

   switch (idx) {
      case ResetIdx:
       /* clear page */
       resetbutton(NULL, (pointertype)pageno, NULL);
       break;

      case LoadIdx:
       sprintf(_STR2, Tcl_GetString(objv[2 + nidx]));
       for (i = 3 + nidx; i < objc; i++) {
          strcat(_STR2, ",");
          strcat(_STR2, Tcl_GetString(objv[i]));
       }
       
       if (savepage != pageno) newpage(pageno);
       startloadfile();
       if (savepage != pageno) newpage(savepage);
       break;

      case ImportIdx:
       sprintf(_STR2, Tcl_GetString(objv[1 + nidx]));
       for (i = 2; i < objc; i++) {
          strcat(_STR2, ",");
          strcat(_STR2, Tcl_GetString(objv[i + nidx]));
       }
       if (savepage != pageno) newpage(pageno);
       importfile();
       if (savepage != pageno) newpage(savepage);
       break;

      case BackIdx:
       if ((objc - nidx) != 2 && (objc - nidx) != 3) {
          Tcl_SetResult(interp, "Can only specify one filename for background", NULL);
          return TCL_ERROR;
       }
       if (objc - nidx == 2) {
          objPtr = Tcl_NewStringObj(curpage->background.name,
            strlen(curpage->background.name));
          Tcl_SetObjResult(interp, objPtr);
          return XcTagCallback(interp, objc, objv);
       }
       sprintf(_STR2, Tcl_GetString(objv[2 + nidx]));
       if (savepage != pageno) newpage(pageno);
       loadbackground();
       if (savepage != pageno) newpage(savepage);
       break;

      case MakeIdx:
       if (nidx == 1) {
          Tcl_SetResult(interp, "syntax is: \"page make [<name>]\"", NULL);
          return TCL_ERROR;
       }
       if (objc != 2 && objc != 3) {
          Tcl_WrongNumArgs(interp, 2, objv, "make [<name>]");
          return TCL_ERROR;
       }
       newpage((short)255);
       if (objc == 3) {
          strcpy(curpage->pageinst->thisobject->name,
            Tcl_GetString(objv[2]));
       }
       break;
      case SaveOnlyIdx:
      case SaveIdx:
       if (objc > 3) {
          Tcl_WrongNumArgs(interp, 2, objv, "[filename]");
          return TCL_ERROR;
       }
       else if (objc == 3) {
          filename = Tcl_GetString(objv[2]);
          if (strcmp(filename, curpage->filename)) {
             sprintf(_STR2, "Warning:  Filename is \"%s\" but will be "
               "saved as \"%s\"\n", curpage->filename, filename);
             Wprintf(_STR2);
          }
       }
       else
          filename = curpage->filename;

       if (savepage != pageno) newpage(pageno);
       if (!strncmp(Tcl_GetString(objv[1]), "saveo", 5))
           setfile(filename, NO_SUBCIRCUITS);
       else
           setfile(filename, CURRENT_PAGE);
       if (savepage != pageno) newpage(savepage);
       break;

      case LinksIdx:
       if ((objc - nidx) != 2 && (objc - nidx) != 3) {
          Tcl_WrongNumArgs(interp, 1, objv, "links");
          return TCL_ERROR;
       }
       if ((objc - nidx) == 2)
          linktype = TOTAL_PAGES;
       else {
          if (Tcl_GetIndexFromObj(interp, objv[2 + nidx], linkTypes,
            "link type", 0, &linktype) != TCL_OK)
             return TCL_ERROR;
       }
       pagelist = pagetotals(pageno, linktype);
       multi = 0;
       for (i = 0; i < xobjs.pages; i++)
          if (pagelist[i] > 0) multi++;
       Tcl_SetObjResult(interp, Tcl_NewIntObj(multi));
       free((char *)pagelist);
       break;
      case DirIdx:
       startcatalog(NULL, PAGELIB, NULL);
       break;
      case GoToIdx:
         newpage((short)pageno);
       break;
      case SizeIdx:
         if ((objc - nidx) != 2 && (objc - nidx) != 3) {
            Tcl_WrongNumArgs(interp, 1, objv, "size ?\"width x height\"?");
            return TCL_ERROR;
         }
       if ((objc - nidx) == 2) {
          float xsize, ysize, cfact;

          objPtr = Tcl_NewListObj(0, NULL);

          cfact = (curpage->coordstyle == CM) ? IN_CM_CONVERT
                  : 72.0;
            xsize = (float)curpage->pagesize.x / cfact;
            ysize = (float)curpage->pagesize.y / cfact;

          Tcl_ListObjAppendElement(xcinterp, objPtr,
            Tcl_NewDoubleObj((double)xsize));
          Tcl_ListObjAppendElement(xcinterp, objPtr,
            Tcl_NewStringObj("x", 1));
          Tcl_ListObjAppendElement(xcinterp, objPtr,
            Tcl_NewDoubleObj((double)ysize));
          Tcl_ListObjAppendElement(xcinterp, objPtr,
            Tcl_NewStringObj(((curpage->coordstyle == CM) ?
                  "cm" : "in"), 2));
          Tcl_SetObjResult(interp, objPtr);

          return XcTagCallback(interp, objc, objv);
       }

         strcpy(_STR2, Tcl_GetString(objv[2 + nidx]));
         setpagesize((Tk_Window)clientData, &curpage->pagesize);

         /* Only need to recompute values and refresh if autoscaling is enabled */
         if (curpage->pmode & 2) autoscale(pageno);
       break;

      case HeightIdx:
       if ((objc - nidx) != 2 && (objc - nidx) != 3) {
          Tcl_WrongNumArgs(interp, 1, objv, "height ?output_height?");
          return TCL_ERROR;
       }
       if ((objc - nidx) == 2) {
#ifdef SCHEMA
          newheight = toplevelheight(curpage->pageinst);
#else
          newheight = topobject->bbox.height;
#endif
          newheight *= getpsscale(curpage->outscale, pageno);
          newheight /= (curpage->coordstyle == CM) ?  IN_CM_CONVERT : 72.0;
          objPtr = Tcl_NewDoubleObj((double)newheight);
          Tcl_SetObjResult(interp, objPtr);
          return XcTagCallback(interp, objc, objv);
       }
       newheight = (double)parseunits(Tcl_GetString(objv[2 + nidx]));
       if (newheight <= 0 || topobject->bbox.height == 0) {
          Tcl_SetResult(interp, "Illegal height value", NULL);
            return TCL_ERROR;
       }
       newheight = (newheight * ((curpage->coordstyle == CM) ?
            IN_CM_CONVERT : 72.0)) / topobject->bbox.height;
       newheight /= getpsscale(1.0, pageno);
       curpage->outscale = (float)newheight;

       if (curpage->pmode & 2) autoscale(pageno);
       break;

      case WidthIdx:
       if ((objc - nidx) != 2 && (objc - nidx) != 3) {
          Tcl_WrongNumArgs(interp, 1, objv, "output_width");
          return TCL_ERROR;
       }
       if ((objc - nidx) == 2) {
#ifdef SCHEMA
          newwidth = toplevelwidth(curpage->pageinst);
#else
          newwidth = topobject->bbox.width;
#endif
          newwidth *= getpsscale(curpage->outscale, pageno);
          newwidth /= (curpage->coordstyle == CM) ?  IN_CM_CONVERT : 72.0;
          objPtr = Tcl_NewDoubleObj((double)newwidth);
          Tcl_SetObjResult(interp, objPtr);
          return XcTagCallback(interp, objc, objv);
       }
       newwidth = (double)parseunits(Tcl_GetString(objv[2 + nidx]));
       if (newwidth <= 0 || topobject->bbox.width == 0) {
          Tcl_SetResult(interp, "Illegal width value", NULL);
          return TCL_ERROR;
       }

       newwidth = (newwidth * ((curpage->coordstyle == CM) ?
            IN_CM_CONVERT : 72.0)) / topobject->bbox.width;
       newwidth /= getpsscale(1.0, pageno);
       curpage->outscale = (float)newwidth;

       if (curpage->pmode & 2) autoscale(pageno);
       break;

      case ScaleIdx:
       if ((objc - nidx) != 2 && (objc - nidx) != 3) {
          Tcl_WrongNumArgs(interp, 1, objv, "output_scale");
          return TCL_ERROR;
       }
       if ((objc - nidx) == 2) {
          objPtr = Tcl_NewDoubleObj((double)curpage->outscale);
          Tcl_SetObjResult(interp, objPtr);
          return XcTagCallback(interp, objc, objv);
       }
       result = Tcl_GetDoubleFromObj(interp, objv[2 + nidx], &newscale);
       if (result != TCL_OK) return result;

       oldscale = curpage->outscale;

       if (oldscale == (float)newscale) return TCL_OK;      /* nothing to do */
       else curpage->outscale = (float)newscale;

       if (curpage->pmode & 2) autoscale(pageno);
       break;

      case OrientIdx:
       if ((objc - nidx) != 2 && (objc - nidx) != 3) {
          Tcl_WrongNumArgs(interp, 1, objv, "orientation");
          return TCL_ERROR;
       }
       if ((objc - nidx) == 2) {
          objPtr = Tcl_NewIntObj((int)curpage->orient);
          Tcl_SetObjResult(interp, objPtr);
          return XcTagCallback(interp, objc, objv);
       }
       result = Tcl_GetIntFromObj(interp, objv[2 + nidx], &newrot);
       if (result != TCL_OK) return result;
       curpage->orient = (short)newrot;

       /* rescale after rotation if "auto-scale" is set */
       if (curpage->pmode & 2) autoscale(pageno);
       break;
       
      case EPSIdx:
       if ((objc - nidx) != 2 && (objc - nidx) != 3) {
          Tcl_WrongNumArgs(interp, 1, objv, "encapsulation");
          return TCL_ERROR;
       }
       if ((objc - nidx) == 2) {
          newstr = psTypes[curpage->pmode & 1];
          Tcl_SetResult(interp, newstr, NULL);
          return XcTagCallback(interp, objc, objv);
       }
       newstr = Tcl_GetString(objv[2 + nidx]);
       if (Tcl_GetIndexFromObj(interp, objv[2 + nidx], psTypes,
            "encapsulation", 0, &newmode) != TCL_OK) {
          return result;
       }
       curpage->pmode &= 0x2;             /* preserve auto-fit flag */
       curpage->pmode |= (short)newmode;
       if (curpage->pmode == 2)
          curpage->pmode = 0;    /* auto-fit does not apply to EPS mode */
       break;

      case LabelIdx:
       if ((objc - nidx) != 2 && (objc - nidx) != 3) {
          Tcl_WrongNumArgs(interp, 1, objv, "label ?name?");
          return TCL_ERROR;
       }
       if ((objc - nidx) == 2) {
          objPtr = Tcl_NewStringObj(pageobj->name, strlen(pageobj->name));
          Tcl_SetObjResult(interp, objPtr);
          return XcTagCallback(interp, objc, objv);
       }

       /* Whitespace and non-printing characters not allowed */

       strcpy(_STR2, Tcl_GetString(objv[2 + nidx]));
       for (i = 0; i < strlen(_STR2); i++) {
          if ((!isprint(_STR2[i])) || (isspace(_STR2[i]))) {
             _STR2[i] = '_';
             Wprintf("Replaced illegal whitespace in name with underscore");
          }
       }

       if (!strcmp(pageobj->name, _STR2)) return TCL_OK; /* no change in string */
       if (strlen(_STR2) == 0)
          sprintf(pageobj->name, "Page %d", areastruct.page + 1);
       else
          sprintf(pageobj->name, "%.79s", _STR2);

#ifdef SCHEMA
       /* For schematics, all pages with associations to symbols must have  */
       /* unique names.                                                     */
       if (pageobj->symschem != NULL) checkpagename(pageobj);
#endif

       if (pageobj == topobject) printname(pageobj);
       renamepage(pageno);
       break;

      case FileIdx:

       if ((objc - nidx) != 2 && (objc - nidx) != 3) {
          Tcl_WrongNumArgs(interp, 1, objv, "filename ?name?");
          return TCL_ERROR;
       }

       oldstr = curpage->filename;

       if ((objc - nidx) == 2) {
          objPtr = Tcl_NewStringObj(oldstr, strlen(oldstr));
          Tcl_SetObjResult(interp, objPtr);
          return XcTagCallback(interp, objc, objv);
         }

       newstr = Tcl_GetString(objv[2 + nidx]);

       if (!strcmp(oldstr, newstr)) return;   /* no change in string */

       multi = pagelinks(pageno);   /* Are there multiple pages? */

       /* Make the change to the current page */
       curpage->filename = strdup(newstr);

       /* All existing filenames which match the old string should      */
       /* also be changed unless the filename has been set to the */
       /* null string, which unlinks the page.              */ 

       if ((strlen(curpage->filename) > 0) && (multi > 1)) {
          for (cpage = 0; cpage < xobjs.pages; cpage++) {
             lpage = xobjs.pagelist[cpage];
             if ((lpage->pageinst != NULL) && (cpage != pageno)) {
                if (!strcmp(lpage->filename, oldstr)) {
                   free(lpage->filename);
                   lpage->filename = strdup(newstr);
                }
             }
          }
       }
       free(oldstr);
       autoscale(pageno);
       break;

      case FitIdx:
       if ((objc - nidx) > 3) {
          Tcl_WrongNumArgs(interp, 1, objv, "fit ?true|false?");
          return TCL_ERROR;
       }
       else if ((objc - nidx) == 3) {
          result = Tcl_GetBooleanFromObj(interp, objv[2], &aval);
          if (result != TCL_OK) return result;
          if (aval)
             curpage->pmode |= 2;
          else
             curpage->pmode &= 1;
       }
       else
          Tcl_SetResult(interp, ((curpage->pmode & 2) > 0) ? "true" : "false", NULL);

       /* Refresh values (does autoscale if specified) */
       autoscale(pageno);
       break;
   }
   return XcTagCallback(interp, objc, objv);
}

/*----------------------------------------------------------------------*/

int xctcl_library(ClientData clientData, Tcl_Interp *interp,
      int objc, Tcl_Obj *CONST objv[])
{
   char *libname, *filename = NULL;
   int j = 0, libnum = -1;
   int idx, nidx, result;
   Tcl_Obj *objPtr;
   Tcl_Obj **newobjv;
   int newobjc;
   char *subCmds[] = {
      "load", "make", "save", "directory", "next", "goto", NULL
   };
   enum SubIdx {
      LoadIdx, MakeIdx, SaveIdx, DirIdx, NextIdx, GoToIdx
   };

   result = ParseLibArguments(interp, objc, objv, &nidx, &libnum);
   if ((result != TCL_OK) || (nidx < 0)) return result;
   else if ((objc - nidx) > 4) {
      Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
      return TCL_ERROR;
   }
   else if (objc <= (1 + nidx)) {  /* No subcommand */

      /* return index if name given; return name if index given. */
      /* return index if neither is given (current library)  */
      
      if (objc > 1) {
       int lnum;  /* unused; only checks if argument is integer */
       char *lname;
       result = Tcl_GetIntFromObj(interp, objv[1], &lnum);
       if (result == TCL_OK) {
          lname = xobjs.libtop[libnum + LIBRARY]->thisobject->name;
            Tcl_SetObjResult(interp, Tcl_NewStringObj(lname, strlen(lname)));
       }
       else
            Tcl_SetObjResult(interp, Tcl_NewIntObj(libnum + 1));
      }
      else
         Tcl_SetObjResult(interp, Tcl_NewIntObj(libnum + 1));
      idx = -1;
   }
   else if (Tcl_GetIndexFromObj(interp, objv[1 + nidx], subCmds,
      "option", 0, &idx) != TCL_OK) {

      /* Backwards compatibility: "library filename [number]" is */
      /* the same as "library [number] load filename"        */

      Tcl_ResetResult(interp);
      newobjv = (Tcl_Obj **)(&objv[1]);
      newobjc = objc - 1;

      result = ParseLibArguments(interp, newobjc, newobjv, &nidx, &libnum);
      if (result != TCL_OK) return result;

      idx = LoadIdx;
      filename = Tcl_GetString(newobjv[0]);
   }

   switch (idx) {
      case LoadIdx:
       /* library [<name>|<number>] load <filename> */
       if (objc > (3 + nidx)) {
          Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
          return TCL_ERROR;
       }
       if (filename == NULL) filename = Tcl_GetString(objv[2 + nidx]);

       /* if loading of default libraries is not overridden, load them first */

       if (!(flags & (LIBOVERRIDE | LIBLOADED))) {                          
          defaultscript();
          flags |= LIBLOADED;
       }

       if (libnum >= (xobjs.numlibs - 1) || libnum < 0)
          libnum = createlibrary();
       else
          libnum += LIBRARY;

       strcpy(_STR, filename);
       loadlibrary(libnum);
       break;
      case MakeIdx:
       /* library make [name] */
       if (nidx == 1) {
          Tcl_SetResult(interp, "syntax is: library make [<name>]", NULL);
          return TCL_ERROR;
       }

       libnum = createlibrary();
       if (objc == 3) {
          strcpy(xobjs.libtop[libnum]->thisobject->name, Tcl_GetString(objv[2]));
          renamelib(libnum);
       }
       startcatalog((Tk_Window)clientData, libnum, NULL);
       break;
      case SaveIdx:
       /* library [name|number] save filename */
       if ((objc - nidx) != 3) {
          Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
          return TCL_ERROR;
       }
       filename = Tcl_GetString(objv[2 + nidx]);

       if (xobjs.userlibs[libnum].number == 0) {
          Tcl_SetResult(interp, "No objects in library to save.", NULL);
          return TCL_ERROR;
       }
       strcpy(_STR2, filename);
       savelibrary((Tk_Window)clientData, libnum);
       break;
      case DirIdx:
       /* library directory */
       if (nidx == 1) {
          Tcl_SetResult(interp, "syntax is: library directory", NULL);
          return TCL_ERROR;
       }
       startcatalog(NULL, LIBLIB, NULL);
       break;
      case NextIdx:
         libnum = is_library(topobject);
       if (++libnum >= xobjs.numlibs) libnum = 0;     /* fall through */
      case GoToIdx:
       /* library go */ 
       startcatalog(NULL, LIBRARY + libnum, NULL);
       break;
   }
   return XcTagCallback(interp, objc, objv);
}

/*----------------------------------------------------------------------*/
/* "bindkey" command --- this is a direct implementation of the same    */
/* key binding found in the "ad-hoc" and Python interfaces;  it would   */
/* be preferable to make use of the Tk "bind" command directly, and     */
/* work from the event handler.                                   */
/*----------------------------------------------------------------------*/

int xctcl_bind(ClientData clientData, Tcl_Interp *interp,
      int objc, Tcl_Obj *CONST objv[])
{
   char *keyname, *commandname, *binding;
   int keywstate, func = -1, value = -1;
   int result;

   if (!(flags & KEYOVERRIDE)) {
      default_keybindings();
      flags |= KEYOVERRIDE;
   }

   if ((objc == 1) || (objc > 4)) {
      Tcl_WrongNumArgs(interp, 1, objv, "[<key> [<command> [<value>|forget]]]");
      return TCL_ERROR;
   }
   keyname = Tcl_GetString(objv[1]);
   keywstate = string_to_key(keyname);

   /* 1st arg may be a function, not a key, if we want the binding returned */
   if ((objc == 2) && (keywstate == 0)) {
      keywstate = -1;
      func = string_to_func(keyname, NULL);
   }

   if (objc == 2) {
      binding = binding_to_string(keywstate, func);
      Tcl_SetResult(interp, binding, TCL_VOLATILE);
      free(binding);
      return TCL_OK;
   }

   commandname = Tcl_GetString(objv[2]);
   if (strlen(commandname) == 0)
      func = -1;
   else
      func = string_to_func(commandname, NULL);

   if (objc == 4) {
      result = Tcl_GetIntFromObj(interp, objv[3], &value);
      if (result != TCL_OK)
      {
       if (strcmp(Tcl_GetString(objv[3]), "forget"))
          return (result);
       else {
          /*  Unbind command */
          Tcl_ResetResult(interp);
          result = remove_binding(keywstate, func);
          if (result == 0)
            return TCL_OK;
          else {
             Tcl_SetResult(interp, "Key/Function pair not found "
                  "in binding list.\n", NULL);
             return TCL_ERROR;
          }
       }
      }
   }
   result = add_vbinding(keywstate, func, value);
   if (result == 1) {
      Tcl_SetResult(interp, "Key is already bound to a command.\n", NULL);
      return (result);
   }
   return TCL_OK;
}

/*----------------------------------------------------------------------*/

int xctcl_font(ClientData clientData, Tcl_Interp *interp,
      int objc, Tcl_Obj *CONST objv[])
{
   char *fontname;
   int result;

   /* font name */
   if (objc != 2) {
      Tcl_WrongNumArgs(interp, 1, objv, "fontname");
      return TCL_ERROR;
   }
   fontname = Tcl_GetString(objv[1]);
   
   /* If we need to load the default font "Helvetica" because no fonts  */
   /* have been loaded yet, then we call this function twice, so that   */
   /* the command tag callback gets applied both times.                 */

   if (!(flags & FONTOVERRIDE)) {
      xctcl_font(clientData, interp, objc, objv);
      loadfontfile("Helvetica");
      flags |= FONTOVERRIDE;
   }
   result = loadfontfile((char *)fontname);
   if (result >= 1) {
      Tcl_SetObjResult(interp, Tcl_NewStringObj(fonts[fontcount - 1].family,
            strlen(fonts[fontcount - 1].family)));
   }
   switch (result) {
      case 1:
       return XcTagCallback(interp, objc, objv);
      case 0:
       return TCL_OK;
      case -1:
         return TCL_ERROR;
   }
}

/*----------------------------------------------------------------------*/

int xctcl_filerecover(ClientData clientData, Tcl_Interp *interp,
      int objc, Tcl_Obj *CONST objv[])
{
   int i;

   if (objc != 1) {
      Tcl_WrongNumArgs(interp, 1, objv, "(no arguments)");
      return TCL_ERROR;
   }
   crashrecover();
   return XcTagCallback(interp, objc, objv);
}

/*----------------------------------------------------------------------*/
/* Replace the functions of the simple rcfile.c interpreter.      */
/*----------------------------------------------------------------------*/

/*----------------------------------------------------------------------*/
/* Execute a single command from a script or from the command line      */
/*----------------------------------------------------------------------*/

short execcommand(short pflags, char *cmdptr)
{
   flags = pflags;
   Tcl_Eval(xcinterp, cmdptr);
   refresh(NULL, NULL, NULL);
   return flags;
}

/*----------------------------------------------------------------------*/
/* Load the default script (like execscript() but don't allow recursive */
/* loading of the startup script)                                       */
/*----------------------------------------------------------------------*/

void defaultscript()
{
   FILE *fd;
   char *tmp_s = getenv((const char *)"XCIRCUIT_LIB_DIR");

   flags = LIBOVERRIDE | LIBLOADED | FONTOVERRIDE;

   if (!tmp_s) tmp_s = BUILTINS_DIR;
   sprintf(_STR2, "%s/%s", tmp_s, STARTUP_FILE);

   if ((fd = fopen(_STR2, "r")) == NULL) {
      sprintf(_STR2, "%s/%s", BUILTINS_DIR, STARTUP_FILE);
      if ((fd = fopen(_STR2, "r")) == NULL) {
         sprintf(_STR2, "%s/tcl/%s", BUILTINS_DIR, STARTUP_FILE);
         if ((fd = fopen(_STR2, "r")) == NULL) {
            sprintf(_STR, "Failed to open startup script \"%s\"\n", STARTUP_FILE);
            Wprintf(_STR);
            return;
       }
      }
   }
   fclose(fd);
   Tcl_EvalFile(xcinterp, _STR2);
}

/*----------------------------------------------------------------------*/
/* Execute a script                                                     */
/*----------------------------------------------------------------------*/

void execscript()
{
   FILE *fd;
   
   flags = 0;

   xc_tilde_expand(_STR2);
   if ((fd = fopen(_STR2, "r")) != NULL) {
      fclose(fd);
      Tcl_EvalFile(xcinterp, _STR2);
      refresh(NULL, NULL, NULL);
   }
   else {
      sprintf(_STR, "Failed to open script file \"%s\"\n", _STR2);
      Wprintf(_STR);
   }
}

/*----------------------------------------------------------------------*/
/* Execute the .xcircuitrc startup script                               */
/*----------------------------------------------------------------------*/

void loadrcfile()
{
   char *userdir = getenv((const char *)"HOME");
   FILE *fd;
   short i;

   /* Initialize flags */

   flags = 0;

   sprintf(_STR2, "%s", USER_RC_FILE);     /* Name imported from Makefile */

   /* try first in current directory, then look in user's home directory */

   xc_tilde_expand(_STR2);
   if ((fd = fopen(_STR2, "r")) == NULL) {
      if (userdir != NULL) {
         sprintf(_STR2, "%s/%s", userdir, USER_RC_FILE);
         fd = fopen(_STR2, "r");
      }
   }
   if (fd != NULL) {
      fclose(fd);
      Tcl_EvalFile(xcinterp, _STR2);
   }

   /* Add the default font if not loaded already */
   
   if (!(flags & FONTOVERRIDE)) {
      loadfontfile("Helvetica");
      if (areastruct.psfont == -1)
         for (i = 0; i < fontcount; i++)
            if (!strcmp(fonts[i].psname, "Helvetica")) {
               areastruct.psfont = i;
               break;
            }
   }
   if (areastruct.psfont == -1) areastruct.psfont = 0;

   setdefaultfontmarks();

   /* arrange the loaded libraries */

   if (!(flags & (LIBOVERRIDE | LIBLOADED)))
      defaultscript();

   /* Add the default colors */

   if (!(flags & COLOROVERRIDE)) {
      addnewcolorentry(xc_alloccolor("Gray40"));
      addnewcolorentry(xc_alloccolor("Gray60"));
      addnewcolorentry(xc_alloccolor("Gray80"));
      addnewcolorentry(xc_alloccolor("Gray90"));
      addnewcolorentry(xc_alloccolor("Red"));
      addnewcolorentry(xc_alloccolor("Blue"));
      addnewcolorentry(xc_alloccolor("Green2"));
      addnewcolorentry(xc_alloccolor("Yellow"));
      addnewcolorentry(xc_alloccolor("Purple"));
      addnewcolorentry(xc_alloccolor("SteelBlue2"));
      addnewcolorentry(xc_alloccolor("Red3"));
      addnewcolorentry(xc_alloccolor("Tan"));
      addnewcolorentry(xc_alloccolor("Brown"));
   }  
     
#ifdef SCHEMA
   /* These colors must be enabled whether or not colors are overridden, */
   /* because they are needed by the schematic capture system.           */
      
   addnewcolorentry(xc_getlayoutcolor(LOCALPINCOLOR));
   addnewcolorentry(xc_getlayoutcolor(GLOBALPINCOLOR));
   addnewcolorentry(xc_getlayoutcolor(INFOLABELCOLOR));
#endif
   addnewcolorentry(xc_getlayoutcolor(BBOXCOLOR));
      
   if (!(flags & KEYOVERRIDE))
      default_keybindings();
}

/*----------------------------------------------------------------------*/
/* Argument-converting wrappers from Tk callback to Xt callback format  */
/*----------------------------------------------------------------------*/

Tk_EventProc *xctk_drawarea(ClientData clientData, XEvent *eventPtr)
{
   Tcl_ServiceAll();
   drawarea(areastruct.area, (caddr_t)clientData, (caddr_t)NULL);
}

/*----------------------------------------------------------------------*/

Tk_EventProc *xctk_resizearea(ClientData clientData, XEvent *eventPtr)
{
   resizearea(areastruct.area, (caddr_t)clientData, (caddr_t)NULL);
   /* Callback to function "arrangetoolbar" */
   Tcl_Eval(xcinterp, "catch xcircuit::arrangetoolbar");
}

/*----------------------------------------------------------------------*/

Tk_EventProc *xctk_buttonhandler(ClientData clientData, XEvent *eventPtr)
{
   buttonhandler((xcWidget)NULL, (caddr_t)clientData, (XButtonEvent *)eventPtr);
}

/*----------------------------------------------------------------------*/

Tk_EventProc *xctk_keyhandler(ClientData clientData, XEvent *eventPtr)
{
   keyhandler((xcWidget)NULL, (caddr_t)clientData, (XKeyEvent *)eventPtr);
}

/*----------------------------------------------------------------------*/
/* Because Tk doesn't filter MotionEvent events based on context, we    */
/* have to filter the context here.                         */
/*----------------------------------------------------------------------*/

Tk_EventProc *xctk_panhbar(ClientData clientData, XEvent *eventPtr)
{
   XMotionEvent *mevent = (XMotionEvent *)eventPtr;
   u_int state = mevent->state;
   if (state & (Button1Mask | Button2Mask))
      panhbar(areastruct.scrollbarh, (caddr_t)clientData, (XButtonEvent *)eventPtr);
}

/*----------------------------------------------------------------------*/

Tk_EventProc *xctk_panvbar(ClientData clientData, XEvent *eventPtr)
{
   XMotionEvent *mevent = (XMotionEvent *)eventPtr;
   u_int state = mevent->state;
   if (state & (Button1Mask | Button2Mask))
      panvbar(areastruct.scrollbarv, (caddr_t)clientData, (XButtonEvent *)eventPtr);
}

/*----------------------------------------------------------------------*/

Tk_EventProc *xctk_drawhbar(ClientData clientData, XEvent *eventPtr)
{
   drawhbar(areastruct.scrollbarh, (caddr_t)clientData, (caddr_t)NULL);
}

Tk_EventProc *xctk_drawvbar(ClientData clientData, XEvent *eventPtr)
{
   drawvbar(areastruct.scrollbarv, (caddr_t)clientData, (caddr_t)NULL);
}

/*----------------------------------------------------------------------*/

Tk_EventProc *xctk_endhbar(ClientData clientData, XEvent *eventPtr)
{
   endhbar(areastruct.scrollbarh, (caddr_t)clientData, (XButtonEvent *)eventPtr);
}

/*----------------------------------------------------------------------*/

Tk_EventProc *xctk_endvbar(ClientData clientData, XEvent *eventPtr)
{
   endvbar(areastruct.scrollbarv, (caddr_t)clientData, (XButtonEvent *)eventPtr);
}

/*----------------------------------------------------------------------*/

Tk_EventProc *xctk_zoomview(ClientData clientData, XEvent *eventPtr)
{
   zoomview((xcWidget)NULL, (caddr_t)clientData, (caddr_t)NULL);
}

/*----------------------------------------------------------------------*/

Tk_EventProc *xctk_swapschem(ClientData clientData, XEvent *eventPtr)
{
   swapschem((xcWidget)NULL, (u_int)clientData, (caddr_t)NULL);
}

/*----------------------------------------------------------------------*/

Tk_EventProc *xctk_drag(ClientData clientData, XEvent *eventPtr)
{
   drag(areastruct.area, (caddr_t)clientData, (XButtonEvent *)eventPtr);
}

/*----------------------------------------------------------------------*/

Tk_EventProc *xctk_simplescroll(ClientData clientData, XEvent *eventPtr)
{  
   Tk_Window sbar;
   XMotionEvent *mevent = (XMotionEvent *)eventPtr;
   u_int state = mevent->state;
   
   sbar = Tk_NameToWindow(xcinterp, ".help.listwin.sb", areastruct.area);
   if (state & (Button1Mask | Button2Mask))
      simplescroll(sbar, (xcWidget)clientData, mevent);
}

/*----------------------------------------------------------------------*/

Tk_EventProc *xctk_drawsb(ClientData clientData, XEvent *eventPtr)
{
   Tk_Window hsb = (Tk_Window)clientData;
   showhsb(hsb, NULL, NULL);
}

/*----------------------------------------------------------------------*/

Tk_EventProc *xctk_drawhelp(ClientData clientData, XEvent *eventPtr)
{
   Tk_Window hspace = (Tk_Window)clientData;
   exposehelp(hspace, NULL, NULL);
}

/*----------------------------------------------------------------------*/
/* This really should be set up so that the "okay" button command tcl   */
/* procedure does the job of lookdirectory().                     */
/*----------------------------------------------------------------------*/

Tk_EventProc *xctk_fileselect(ClientData clientData, XEvent *eventPtr)
{
   XButtonEvent *beventPtr = (XButtonEvent *)eventPtr;
   popupstruct *listp = (popupstruct *)clientData;
   char *curentry;

   if (beventPtr->button == Button2) {
      Tcl_Eval(xcinterp, ".filelist.textent.txt get");
      curentry = Tcl_GetStringResult(xcinterp);

      if (curentry != NULL) {
         if (lookdirectory(curentry))
            newfilelist(listp->filew, listp);
       else
          Tcl_Eval(xcinterp, ".filelist.bbar.okay invoke");
      }
   }
   else
      fileselect(listp->filew, listp, beventPtr);
}

/*----------------------------------------------------------------------*/

Tk_EventProc *xctk_listfiles(ClientData clientData, XEvent *eventPtr)
{
   popupstruct *listp = (popupstruct *)clientData;
   char *filter;

   Tcl_Eval(xcinterp, ".filelist.listwin.win cget -data");
   filter = Tcl_GetStringResult(xcinterp);

   if (filter != NULL) {
      if ((listp->filter == NULL) || (strcmp(filter, listp->filter))) {
         if (listp->filter != NULL)
          free(listp->filter);
         listp->filter = strdup(filter);
         newfilelist(listp->filew, listp);
      }
      else
       listfiles(listp->filew, listp, NULL);
   }
   else {
      if (listp->filter != NULL) {
       free(listp->filter);
       listp->filter = NULL;
      }
      listfiles(listp->filew, listp, NULL);
   }
}

/*----------------------------------------------------------------------*/

Tk_EventProc *xctk_startfiletrack(ClientData clientData, XEvent *eventPtr)
{
   startfiletrack((Tk_Window)clientData, NULL, (XCrossingEvent *)eventPtr);
}

/*----------------------------------------------------------------------*/

Tk_EventProc *xctk_endfiletrack(ClientData clientData, XEvent *eventPtr)
{
   endfiletrack((Tk_Window)clientData, NULL, (XCrossingEvent *)eventPtr);
}

/*----------------------------------------------------------------------*/

Tk_EventProc *xctk_dragfilebox(ClientData clientData, XEvent *eventPtr)
{
   dragfilebox((Tk_Window)clientData, NULL, (XMotionEvent *)eventPtr);
}

/*----------------------------------------------------------------------*/

Tk_EventProc *xctk_draglscroll(ClientData clientData, XEvent *eventPtr)
{
   popupstruct *listp = (popupstruct *)clientData;
   XMotionEvent *mevent = (XMotionEvent *)eventPtr;
   u_int state = mevent->state;
   
   if (state & (Button1Mask | Button2Mask))
      draglscroll(listp->scroll, listp, (XButtonEvent *)eventPtr);
}

/*----------------------------------------------------------------------*/

Tk_EventProc *xctk_showlscroll(ClientData clientData, XEvent *eventPtr)
{
   showlscroll((Tk_Window)clientData, NULL, NULL);
}

/*--------------------------------------*/
/* GUI Initialization under Tk            */
/*--------------------------------------*/

void GUI_init(int objc, Tcl_Obj *CONST objv[])
{
   Tk_Window      tkwind, tktop, tkdraw, tksb;
   int            i;
   XGCValues      values;   
   Window   win;
   popupstruct    *fileliststruct;

   tktop = Tk_MainWindow(xcinterp);

   if (tktop == NULL) {
      Fprintf(stderr, "No Top-Level Tk window available. . .\n");
      return;
   }

   /* Expect a top-level window created by the configuration script */

   tkwind = Tk_NameToWindow(xcinterp, ".xcircuit", tktop);

   if (tkwind == NULL) {
      Fprintf(stderr, "Expected the window hierarchy to be in place. . .\n");
      return;
   }

   /* Fill in global variables from the Tk window values */

   message1 = Tk_NameToWindow(xcinterp, ".xcircuit.menubar.message", tktop);
   message2 = Tk_NameToWindow(xcinterp, ".xcircuit.infobar.message1", tktop);
   message3 = Tk_NameToWindow(xcinterp, ".xcircuit.infobar.message2", tktop);
   areastruct.scrollbarv = Tk_NameToWindow(xcinterp,
      ".xcircuit.mainframe.mainarea.sbleft", tktop);
   areastruct.scrollbarh = Tk_NameToWindow(xcinterp,
      ".xcircuit.mainframe.mainarea.sbbottom", tktop);
   areastruct.area = Tk_NameToWindow(xcinterp,
      ".xcircuit.mainframe.mainarea.drawing", tktop);

   areastruct.areawin = Tk_WindowId(areastruct.area);
   areastruct.width = Tk_Width(areastruct.area);
   areastruct.height = Tk_Height(areastruct.area);

   corner = Tk_NameToWindow(xcinterp, ".xcircuit.mainframe.mainarea.corner", tktop);
   wsymb = Tk_NameToWindow(xcinterp, ".xcircuit.infobar.symb", tktop);
   wschema = Tk_NameToWindow(xcinterp, ".xcircuit.infobar.schem", tktop);
   netbutton = Tk_NameToWindow(xcinterp, ".xcircuit.menubar.netlistbutton", tktop);

   /* Setup event handlers for the drawing area and scrollbars                */
   /* There are purposely no callback functions for these windows---they are  */
   /* defined as type "frame" to keep down the cruft, as I will define my own */
   /* event handlers.                                             */

   Tk_CreateEventHandler(areastruct.area, StructureNotifyMask, 
            (Tk_EventProc *)xctk_resizearea, NULL);
   Tk_CreateEventHandler(areastruct.area, ExposureMask, 
            (Tk_EventProc *)xctk_drawarea, NULL);
   Tk_CreateEventHandler(areastruct.area, ButtonPressMask | ButtonReleaseMask,
            (Tk_EventProc *)xctk_buttonhandler, NULL);
   Tk_CreateEventHandler(areastruct.area, KeyPressMask | KeyReleaseMask,
            (Tk_EventProc *)xctk_keyhandler, NULL);
   Tk_CreateEventHandler(areastruct.scrollbarh, ButtonMotionMask, 
            (Tk_EventProc *)xctk_panhbar, NULL);
   Tk_CreateEventHandler(areastruct.scrollbarv, ButtonMotionMask, 
            (Tk_EventProc *)xctk_panvbar, NULL);
   Tk_CreateEventHandler(areastruct.scrollbarh, StructureNotifyMask | ExposureMask,
            (Tk_EventProc *)xctk_drawhbar, NULL);
   Tk_CreateEventHandler(areastruct.scrollbarv, StructureNotifyMask | ExposureMask,
            (Tk_EventProc *)xctk_drawvbar, NULL);
   Tk_CreateEventHandler(areastruct.scrollbarh, ButtonReleaseMask, 
            (Tk_EventProc *)xctk_endhbar, NULL);
   Tk_CreateEventHandler(areastruct.scrollbarv, ButtonReleaseMask, 
            (Tk_EventProc *)xctk_endvbar, NULL);

   Tk_CreateEventHandler(corner, ButtonPressMask, 
            (Tk_EventProc *)xctk_zoomview, Number(1));
   Tk_CreateEventHandler(wsymb, ButtonPressMask, 
            (Tk_EventProc *)xctk_swapschem, Number(0));
   Tk_CreateEventHandler(wschema, ButtonPressMask, 
            (Tk_EventProc *)xctk_swapschem, Number(0));

   /* Build the pixmap images used by the menu buttons and toolbar */

   /* Build the toolbar */

   /* Make sure the window is mapped */

   Tk_MapWindow(tkwind);

   dpy = Tk_Display(tkwind);
   win = Tk_WindowId(tkwind);
   cmap = Tk_Colormap(tkwind);

   /*-------------------------*/
   /* Create stipple patterns */
   /*-------------------------*/

   for (i = 0; i < STIPPLES; i++)
      STIPPLE[i] = XCreateBitmapFromData(dpy, win, STIPDATA[i], 4, 4);

   /*----------------------------------------*/
   /* Allocate space for the basic color map */
   /*----------------------------------------*/
   
   number_colors = 0; 
   colorlist = (colorindex *)malloc(sizeof(colorindex));
   appcolors = (int *) malloc(NUMBER_OF_COLORS * sizeof(int));

   /*-------------------------------------------------------------------*/
   /* Generate the GC                                       */
   /* Set "graphics_exposures" to False.  Every XCopyArea function      */
   /* copies from virtual memory (dbuf pixmap), which can never be      */
   /* obscured.  Otherwise, the server gets flooded with useless  */
   /* NoExpose events.                                      */
   /*-------------------------------------------------------------------*/

   values.foreground = BlackPixel(dpy, DefaultScreen(dpy));
   values.background = WhitePixel(dpy, DefaultScreen(dpy)); 
   values.graphics_exposures = False;
   areastruct.gc = XCreateGC(dpy, win, GCForeground | GCBackground
            | GCGraphicsExposures, &values);

   XDefineCursor (dpy, win, CROSS);  

   /* The following code replaces the actions of the Application Defaults */
   /* loader and should be doing the equivalent in Tk, not here.  Here,   */
   /* we should be querying the Tk interp for the values.           */

   /*--------------------------*/
   /* Build the color database */
   /*--------------------------*/

   appdata.globalcolor = xc_alloccolor("Orange2");
   appdata.localcolor = xc_alloccolor("Red");
   appdata.infocolor = xc_alloccolor("SeaGreen");
   appdata.bboxpix = xc_alloccolor("greenyellow");

   appdata.parampix = xc_alloccolor("Plum3");
   appdata.auxpix = xc_alloccolor("Green3");
   appdata.barpix = xc_alloccolor("Tan");
   appdata.buttonpix = xc_alloccolor("Gray85");
   appdata.selectpix = xc_alloccolor("Gold3");
   appdata.querypix = xc_alloccolor("Turquoise");
   appdata.filterpix = xc_alloccolor("SteelBlue3");
   appdata.gridpix = xc_alloccolor("Gray95");
   appdata.snappix = xc_alloccolor("Red");
   appdata.axespix = xc_alloccolor("Antique White");
   appdata.bg = xc_alloccolor("White");
   appdata.fg = xc_alloccolor("Black");

   appdata.parampix2 = xc_alloccolor("Plum3");
   appdata.auxpix2 = xc_alloccolor("Green");
   appdata.barpix2 = xc_alloccolor("Tan");
   appdata.buttonpix2 = xc_alloccolor("Gray50");
   appdata.selectpix2 = xc_alloccolor("Gold");
   appdata.querypix2 = xc_alloccolor("Turquoise");
   appdata.filterpix2 = xc_alloccolor("SteelBlue1");
   appdata.gridpix2 = xc_alloccolor("Gray40");
   appdata.snappix2 = xc_alloccolor("Red");
   appdata.axespix2 = xc_alloccolor("NavajoWhite4");
   appdata.bg2 = xc_alloccolor("DarkSlateGray");
   appdata.fg2 = xc_alloccolor("White");

   /* Get some default fonts (Should be asking Tk for some of these. . . ) */

   appdata.xcfont = XLoadQueryFont(dpy, "-*-times-bold-r-normal--14-*");
   appdata.helpfont = XLoadQueryFont(dpy, "-*-helvetica-medium-r-normal--10-*");
   appdata.filefont = XLoadQueryFont(dpy, "-*-helvetica-medium-r-normal--14-*");
   appdata.textfont = XLoadQueryFont(dpy, "-*-courier-medium-r-normal--14-*");
   appdata.titlefont = XLoadQueryFont(dpy, "-*-times-bold-i-normal--14-*");

   /* Other defaults */

   appdata.timeout = 10;
   appdata.width = 950;
   appdata.height = 760;

   /* Create the help and filelist windows and their event handlers */

   tksb = Tk_NameToWindow(xcinterp, ".help.listwin.sb", tktop);
   tkdraw = Tk_NameToWindow(xcinterp, ".help.listwin.win", tktop);

   Tk_CreateEventHandler(tksb, ButtonMotionMask, 
            (Tk_EventProc *)xctk_simplescroll, (ClientData)tkdraw);
   Tk_CreateEventHandler(tksb, ExposureMask, 
            (Tk_EventProc *)xctk_drawsb, (ClientData)tksb);
   Tk_CreateEventHandler(tkdraw, ExposureMask, 
            (Tk_EventProc *)xctk_drawhelp, (ClientData)tkdraw);

   tksb = Tk_NameToWindow(xcinterp, ".filelist.listwin.sb", tktop);
   tkdraw = Tk_NameToWindow(xcinterp, ".filelist.listwin.win", tktop);

   fileliststruct = (popupstruct *) malloc(sizeof(popupstruct));
   fileliststruct->popup = Tk_NameToWindow(xcinterp, ".filelist", tktop);
   fileliststruct->textw = Tk_NameToWindow(xcinterp, ".filelist.textent",
            fileliststruct->popup);
   fileliststruct->filew = tkdraw;
   fileliststruct->scroll = tksb;
   fileliststruct->setvalue = NULL;
   fileliststruct->filter = NULL;

   Tk_CreateEventHandler(tksb, ButtonMotionMask, 
            (Tk_EventProc *)xctk_draglscroll, (ClientData)fileliststruct);
   Tk_CreateEventHandler(tksb, ExposureMask, 
            (Tk_EventProc *)xctk_showlscroll, (ClientData)tksb);
   Tk_CreateEventHandler(tkdraw, ButtonPressMask, 
            (Tk_EventProc *)xctk_fileselect, (ClientData)fileliststruct);
   Tk_CreateEventHandler(tkdraw, ExposureMask,
            (Tk_EventProc *)xctk_listfiles, (ClientData)fileliststruct);
   Tk_CreateEventHandler(tkdraw, EnterWindowMask, 
            (Tk_EventProc *)xctk_startfiletrack, (ClientData)tkdraw);
   Tk_CreateEventHandler(tkdraw, LeaveWindowMask, 
            (Tk_EventProc *)xctk_endfiletrack, (ClientData)tkdraw);
}

/*--------------------------------------*/
/* Inline the main wrapper prodedure      */
/*--------------------------------------*/

int xctcl_start(ClientData clientData, Tcl_Interp *interp,
            int objc, Tcl_Obj *CONST objv[])
{
   FILE *fd;
   char filename[128];
   char *filepath;
   int i, result = TCL_OK;
   Boolean rcoverride = False;
   char *filearg = NULL;

   Fprintf(stdout, "Starting xcircuit under Tcl interpreter\n");

   /* xcircuit initialization routines --- these assume that the */
   /* GUI has been created by the startup script;  otherwise bad */
   /* things will probably occur.                      */

   pre_initialize();
   GUI_init(objc, objv);
   post_initialize();
   ghostinit();

   /* The Tcl version accepts some command-line arguments.  Due   */
   /* to the way ".wishrc" is processed, all arguments are  */
   /* glommed into one Tcl (list) object, objv[1].          */

   if (objc == 2) {
      char **argv;
      int argc;

      Tcl_SplitList(interp, Tcl_GetString(objv[1]), &argc, &argv);
      while (argc) {
         if (**argv == '-') {
          if (!strncmp(*argv, "-exec", 5)) {
             if (--argc > 0) {
              argv++;
                result = Tcl_EvalFile(interp, *argv);
                if (result != TCL_OK)
                 return result;
                else
                 rcoverride = True;
             }
             else {
                Tcl_SetResult(interp, "No filename given to exec argument.", NULL);
                return TCL_ERROR;
             }
          }
       }
       else filearg = *argv;
       argv++;
       argc--;
      }
   }

   if (!rcoverride) loadrcfile();
   composelib(PAGELIB); /* make sure we have a valid page list */
   composelib(LIBLIB);  /* and library directory */
   if ((objc == 2) && (filearg != NULL)) {
      strcpy(_STR2, filearg);
      startloadfile();
   }
   else {
      findcrashfiles();
   }

   /* Note that because the setup has the windows generated and */
   /* mapped prior to calling the xcircuit routines, nothing      */
   /* gets CreateNotify, MapNotify, or other definitive events.   */
   /* So, we have to do all the drawing once.               */

   drawvbar(areastruct.scrollbarv, NULL, NULL);
   drawhbar(areastruct.scrollbarh, NULL, NULL);
   drawarea(areastruct.area, NULL, NULL);

   /* Return back to the interpreter; Tk is handling the GUI */
   return XcTagCallback(interp, objc, objv);
}

/*------------------------------------------------------*/

#endif /* defined(TCL_WRAPPER) && !defined(HAVE_PYTHON) */

Generated by  Doxygen 1.6.0   Back to index