Merge commit '339420dd5dd874c41f6bab5808291fb4036dd022' as 'funtools'

1 files changed, 504 insertions, 0 deletions

diff --git a/funtools/util/tclmainlib.c b/funtools/util/tclmainlib.c
new file mode 100644
index 0000000..0503915
--- /dev/null
+++ b/funtools/util/tclmainlib.c
@@ -0,0 +1,504 @@
+/*
+ *	Copyright (c) 2004 Smithsonian Astrophysical Observatory
+ */
+
+#include <tclmainlib.h>
+
+#if HAVE_TCL
+/*
+ *----------------------------------------------------------------------------
+ *
+ *
+ * 			Private Routines and Data
+ *
+ *
+ *----------------------------------------------------------------------------
+ */
+
+/*
+ *----------------------------------------------------------------------------
+ *
+ *
+ * 			Semi-Public Routines and Data
+ *
+ *
+ *----------------------------------------------------------------------------
+ */
+
+#ifdef ANSI_FUNC
+int
+MainLibInit_Tcl (MainLib ml)
+#else
+int MainLibInit_Tcl (ml)
+     MainLib ml;
+#endif
+{
+  /* sanity check */
+  if( !ml ) return 0;
+
+  /* populate struct with Tcl routines */
+  ml->tcllookup = MainLibLookup_Tcl;
+  ml->tcleval = MainLibEval_Tcl;
+
+  return 1;
+}
+
+/*
+ *----------------------------------------------------------------------------
+ *
+ * Routine:	MainLibLookup_Tcl
+ *
+ * Purpose:	lookup a Tcl command
+ *
+ * Tcl call:
+ *
+ *     NONE
+ *
+ * Returns:	1 if Tcl command, otherwise 0
+ *
+ *----------------------------------------------------------------------------
+ */
+#ifdef ANSI_FUNC
+int
+MainLibLookup_Tcl (void *vinterp, char *s)
+#else
+int MainLibLookup_Tcl (vinterp, s)
+     void *vinterp;
+     char *s;
+#endif
+{
+  Tcl_Interp *interp = (Tcl_Interp *)vinterp;
+  Tcl_CmdInfo info;
+  char lbuf[SZ_LINE];
+  char tbuf[SZ_LINE];
+  int ip=0;
+  int got=0;
+
+  /* create interpreter, if necessary */
+  if( !vinterp ){
+    interp = Tcl_CreateInterp();
+  }
+
+  /* get first token  */
+  strncpy(lbuf, s, SZ_LINE-1);
+  lbuf[SZ_LINE-1] = '\0';
+  if( !word(lbuf, tbuf, &ip) )
+    return 0;
+	  
+  /* lookup Tcl command */
+  if( Tcl_GetCommandInfo(interp, tbuf, &info) )
+    got = 1;
+  else
+    got = 0;
+
+  /* delete interpreter, if necessary */
+  if( !vinterp ){
+    Tcl_DeleteInterp(interp);
+  }
+
+  /* return the news */
+  return got;
+}
+
+/*
+ *----------------------------------------------------------------------------
+ *
+ * Routine:	MainLibEval_Tcl
+ *
+ * Purpose:	lookup a Tcl command
+ *
+ * Tcl call:
+ *
+ *     NONE
+ *
+ * Returns:	1 if Tcl command, otherwise 0
+ *
+ *----------------------------------------------------------------------------
+ */
+#ifdef ANSI_FUNC
+int
+MainLibEval_Tcl (void *vinterp, char *s)
+#else
+int MainLibEval_Tcl (vinterp, s)
+     void *vinterp;
+     char *s;
+#endif
+{
+  Tcl_Interp *interp = (Tcl_Interp *)vinterp;
+  int got=0;
+
+  /* create interpreter, if necessary */
+  if( !vinterp ){
+    interp = Tcl_CreateInterp();
+  }
+
+  /* lookup Tcl command */
+  got = Tcl_EvalEx(interp, s, strlen(s), TCL_EVAL_GLOBAL);
+
+  /* delete interpreter, if necessary */
+  if( !vinterp ){
+    Tcl_DeleteInterp(interp);
+  }
+
+  /* return the news */
+  return got;
+}
+
+/*
+ *----------------------------------------------------------------------------
+ *
+ * Routine:	MainLibProcess_Tcl
+ *
+ * Purpose:	execute the mainlibprocess command
+ *
+ * Tcl call:
+ *
+ *     set result [mainlib $ml "command"]
+ *
+ * Returns:	Tcl error code
+ *
+ *----------------------------------------------------------------------------
+ */
+#ifdef ANSI_FUNC
+int
+MainLibProcess_Tcl(ClientData clientData, Tcl_Interp *interp,
+	    int objc, Tcl_Obj *CONST objv[])
+#else
+int MainLibProcess_Tcl(clientData, interp, objc, objv)
+     ClientData clientData;
+     Tcl_Interp *interp;
+     int objc;
+     Tcl_Obj *CONST objv[];
+#endif
+{
+  int len;
+  int got;
+  int fillbuf=1;
+  void *tml;
+  char *s=NULL;
+  char *t=NULL;
+  char *mode=NULL;
+  char *name=NULL;
+  char *cmd=NULL;
+  char *args=NULL;
+  char *buf=NULL;
+  char tbuf[SZ_LINE];
+  Tcl_Obj *resultPtr;
+  MainLib ml;
+
+  /* avoid -W unused parameter warning */
+  if( 0 ){
+    clientData = clientData;
+  }
+
+  /* make sure argument count is correct */
+  if( (objc != 3) && (objc != 4) ){
+    name = Tcl_GetStringFromObj(objv[0], NULL);
+    if( !strcmp(name, TCL_MAINLIB_NAME) ){
+      Tcl_WrongNumArgs(interp, 1, objv, "ml 'cmd args' [mode]");
+    }
+    else{
+      snprintf(tbuf, SZ_LINE-1, "ml 'args' [mode]");
+      Tcl_WrongNumArgs(interp, 1, objv, tbuf);
+    }
+    return(TCL_ERROR);
+  }
+
+  /* this will hold the result */
+  resultPtr = Tcl_GetObjResult(interp);
+
+  /* get name */
+  name = Tcl_GetStringFromObj(objv[0], NULL);
+
+  /* get mainlib handle */
+  s = Tcl_GetStringFromObj(objv[1], NULL);
+  if( (sscanf(s, "%p", &tml) != 1) ){
+    Tcl_SetStringObj(resultPtr, "MAINLIB$ERROR: invalid mainlib handle", -1);
+    return(TCL_ERROR);
+  }
+  ml = (MainLib)tml;
+
+  /* make sure Tcl routines are in mainlib record */
+  MainLibInit_Tcl(ml);
+  
+  /* if name is the default, then the full command is in argv[1] */
+  name = Tcl_GetStringFromObj(objv[0], NULL);
+  if( !strcmp(name, TCL_MAINLIB_NAME) ){
+    cmd = xstrdup(Tcl_GetStringFromObj(objv[2], NULL));
+  }
+  /* otherwise, the command name is in argv[0] and arguments are in argv[1] */
+  else{
+    args = xstrdup(Tcl_GetStringFromObj(objv[2], NULL));
+    len = strlen(name) + strlen(args) + 2;
+    cmd = malloc(len);
+    snprintf(cmd, len, "%s %s", name, args);
+  }
+
+  /* check for mode */
+  if( objc == 4 ){
+    mode = xstrdup(Tcl_GetStringFromObj(objv[3], NULL));
+  }
+
+  /* reset error/result condition */
+  Tcl_ResetResult(interp);
+
+  /* add tcl=[interp] to mode */
+  snprintf(tbuf, SZ_LINE-1, "tcl=%p", (void *)interp);
+  if( mode ){
+    len = strlen(mode) + strlen(tbuf) + 2;
+    mode = xrealloc(mode, len);
+    snprintf(mode, len, "%s,%s", mode, tbuf);
+  }
+  else{
+    mode = xstrdup(tbuf);
+  }
+
+  /* fillbuf determines meaning of MainLibProcess return value */
+  if( (t = xstrdup(mode)) ){
+    if( keyword(t, "fillbuf",  tbuf, SZ_LINE) ) fillbuf = istrue(tbuf);
+    xfree(t);
+  }
+
+  /* call the mainlib process routine */
+  got = MainLibProcess(ml, cmd, &buf, mode);
+
+  /* free up space */
+  if( args ) xfree(args);
+  if( cmd )  xfree(cmd);
+  if( mode ) xfree(mode);
+
+  /* return buf as the result */
+  if( got >= 0 ){
+    if( fillbuf ){
+      if( buf ){
+	Tcl_SetStringObj(resultPtr, buf, got);
+	xfree(buf);
+      }
+      return(TCL_OK);
+    }
+#if HAVE_CYGWIN==0
+    else{
+      Tcl_Channel chan;
+      /* create a tcl channel corresponding to the pipe */
+      if( !(chan = Tcl_MakeFileChannel((ClientData)got, TCL_READABLE)) ){
+	Tcl_SetResult(interp, "can't create Tcl chan for pipe", TCL_STATIC);
+	return TCL_ERROR;
+      }
+      else{
+	/* register this channel with tcl */
+	Tcl_RegisterChannel(interp, chan);
+	/* return name so that it can be used by tcl */
+	Tcl_SetResult(interp,(char *)Tcl_GetChannelName(chan), TCL_VOLATILE);
+	return(TCL_OK);
+      }
+    }
+#else
+    else{
+      /* this probably is useless */
+      snprintf(tbuf, SZ_LINE-1, "%d", got);
+      Tcl_SetStringObj(resultPtr, tbuf, -1);
+      return(TCL_OK);
+    }
+#endif
+  }
+  else{
+    Tcl_SetStringObj(resultPtr, "unable to execute mainlib command", -1);
+    return(TCL_ERROR);
+  }
+}
+
+/*
+ *----------------------------------------------------------------------------
+ *
+ * Routine:	MainLibProcessCleanup_Tcl
+ *
+ * Purpose:	execute the mainlibprocesscleanup command
+ *
+ * Tcl call:
+ *
+ *     set result [mainlib ml]
+ *
+ * Returns:	Tcl error code
+ *
+ *----------------------------------------------------------------------------
+ */
+#ifdef ANSI_FUNC
+int
+MainLibProcessCleanup_Tcl(ClientData clientData, Tcl_Interp *interp,
+	    int objc, Tcl_Obj *CONST objv[])
+#else
+int MainLibProcessCleanup_Tcl(clientData, interp, objc, objv)
+     ClientData clientData;
+     Tcl_Interp *interp;
+     int objc;
+     Tcl_Obj *CONST objv[];
+#endif
+{
+  int got;
+  char *s=NULL;
+  void *tml;
+  Tcl_Obj *resultPtr;
+  MainLib ml;
+
+  /* avoid -W unused parameter warning */
+  if( 0 ){
+    clientData = clientData;
+  }
+
+  /* make sure argument count is correct */
+  if( objc != 2 ){
+    Tcl_WrongNumArgs(interp, 1, objv, "ml");
+    return(TCL_ERROR);
+  }
+
+  /* this will hold the result */
+  resultPtr = Tcl_GetObjResult(interp);
+
+  /* get mainlib handle */
+  s = Tcl_GetStringFromObj(objv[1], NULL);
+  if( (sscanf(s, "%p", &tml) != 1) ){
+    Tcl_SetStringObj(resultPtr, "MAINLIB$ERROR: invalid mainlib handle", -1);
+    return(TCL_ERROR);
+  }
+  ml = (MainLib)tml;
+
+  /* reset error/result condition */
+  Tcl_ResetResult(interp);
+
+  /* call the mainlib process routine */
+  got = MainLibProcessCleanup(ml);
+
+  /* return buf as the result */
+  if( got == 1 ){
+    return(TCL_OK);
+  }
+  else{
+    Tcl_SetStringObj(resultPtr, "error on mainlibcleanup command", -1);
+    return(TCL_ERROR);
+  }
+
+}
+
+/*
+ *----------------------------------------------------------------------------
+ *
+ * Routine:	MainLibLoad_Tcl
+ *
+ * Purpose:	load shared object and execute the mainlibinit
+ *
+ * Tcl call:
+ *
+ *     set result [mainlibload package sharedlib]
+ *
+ * Returns:	Tcl error code
+ *
+ *----------------------------------------------------------------------------
+ */
+#ifdef ANSI_FUNC
+int
+MainLibLoad_Tcl(ClientData clientData, Tcl_Interp *interp,
+	    int objc, Tcl_Obj *CONST objv[])
+#else
+int MainLibLoad_Tcl(clientData, interp, objc, objv)
+     ClientData clientData;
+     Tcl_Interp *interp;
+     int objc;
+     Tcl_Obj *CONST objv[];
+#endif
+{
+  char *package=NULL;
+  char *shlib=NULL;
+  char *ermsg;
+  char tbuf[SZ_LINE];
+  void *dl=NULL;
+  void *ml=NULL;
+  Tcl_Obj *resultPtr;
+
+  /* avoid -W unused parameter warning */
+  if( 0 ){
+    clientData = clientData;
+  }
+
+  /* make sure argument count is correct */
+  if( objc != 3 ){
+    Tcl_WrongNumArgs(interp, 1, objv,  "package sharedlib"); 
+    return(TCL_ERROR);
+  }
+
+  /* get arguments */
+  package = Tcl_GetStringFromObj(objv[1], NULL);
+  shlib = Tcl_GetStringFromObj(objv[2], NULL);
+
+  /* this will hold the result */
+  resultPtr = Tcl_GetObjResult(interp);
+
+  /* load package and process result */
+  switch(MainLibLoad(package, shlib, &ml, &ermsg)){
+  case -1:
+    snprintf(tbuf, SZ_LINE-1,
+	     "MAINLIB$ERROR: could not load shared library %s (%s)",
+	     shlib, ermsg);
+    Tcl_SetStringObj(resultPtr, tbuf, -1);
+    return(TCL_ERROR);
+  case -2:
+    snprintf(tbuf, SZ_LINE-1,
+	     "MAINLIB$ERROR: could not initialize package %s (%s)",
+	     package, ermsg);
+    Tcl_SetStringObj(resultPtr, tbuf, -1);
+    return(TCL_ERROR);
+  default:
+    snprintf(tbuf, SZ_LINE-1, "%p %p", ml, dl);
+    Tcl_SetStringObj(resultPtr, tbuf, -1);
+    return(TCL_OK);
+    break;
+  }
+}
+
+/*
+ *----------------------------------------------------------------------------
+ *
+ *
+ * 			Public Routines and Data
+ *
+ *
+ *----------------------------------------------------------------------------
+ */
+
+/*
+ *----------------------------------------------------------------------------
+ *
+ * Routine:	Tclmainlib_Init
+ *
+ * Purpose:	initialize Tcl mainlib package
+ *
+ * Returns:	tcl return code
+ *
+ *----------------------------------------------------------------------------
+ */
+#ifdef ANSI_FUNC
+int
+Tclmainlib_Init (void *vinterp)
+#else
+int Tclmainlib_Init (vinterp)
+     void *vinterp;
+#endif
+{
+  Tcl_Interp *interp = (Tcl_Interp *)vinterp;
+
+  /* add mainlib commands to this interpreter */
+  Tcl_CreateObjCommand(interp, TCL_MAINLIB_NAME,
+		       MainLibProcess_Tcl, 
+		       (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
+
+  Tcl_CreateObjCommand(interp, "mainlibcleanup",
+		       MainLibProcessCleanup_Tcl,
+		       (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
+
+  Tcl_CreateObjCommand(interp, "mainlibload",
+		       MainLibLoad_Tcl,
+		       (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
+
+  Tcl_PkgProvide(interp, "tclmainlib", "1.0");
+  return(TCL_OK);
+}
+#endif