Пример #1
0
int
TkpUseWindow(
    Tcl_Interp *interp,		/* If not NULL, used for error reporting if
				 * string is bogus. */
    Tk_Window tkwin,		/* Tk window that does not yet have an
				 * associated X window. */
    const char *string)		/* String identifying an X window to use for
				 * tkwin; must be an integer value. */
{
    TkWindow *winPtr = (TkWindow *) tkwin;
    TkWindow *usePtr;
    int id, anyError;
    Window parent;
    Tk_ErrorHandler handler;
    Container *containerPtr;
    XWindowAttributes parentAtts;
    ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
            Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));

    if (winPtr->window != None) {
	Tcl_AppendResult(interp,
		"can't modify container after widget is created", NULL);
	return TCL_ERROR;
    }
    if (Tcl_GetInt(interp, string, &id) != TCL_OK) {
	return TCL_ERROR;
    }
    parent = (Window) id;

    usePtr = (TkWindow *) Tk_IdToWindow(winPtr->display, parent);
    if (usePtr != NULL) {
	if (!(usePtr->flags & TK_CONTAINER)) {
	    Tcl_AppendResult(interp, "window \"", usePtr->pathName,
                    "\" doesn't have -container option set", NULL);
	    return TCL_ERROR;
	}
    }

    /*
     * Tk sets the window colormap to the screen default colormap in
     * tkWindow.c:AllocWindow. This doesn't work well for embedded windows. So
     * we override the colormap and visual settings to be the same as the
     * parent window (which is in the container app).
     */

    anyError = 0;
    handler = Tk_CreateErrorHandler(winPtr->display, -1, -1, -1,
	    EmbedErrorProc, (ClientData) &anyError);
    if (!XGetWindowAttributes(winPtr->display, parent, &parentAtts)) {
        anyError = 1;
    }
    XSync(winPtr->display, False);
    Tk_DeleteErrorHandler(handler);
    if (anyError) {
	if (interp != NULL) {
	    Tcl_AppendResult(interp, "couldn't create child of window \"",
		    string, "\"", NULL);
	}
	return TCL_ERROR;
    }
    Tk_SetWindowVisual(tkwin, parentAtts.visual, parentAtts.depth,
	    parentAtts.colormap);

    /*
     * Create an event handler to clean up the Container structure when tkwin
     * is eventually deleted.
     */

    Tk_CreateEventHandler(tkwin, StructureNotifyMask, EmbeddedEventProc,
	    (ClientData) winPtr);

    /*
     * Save information about the container and the embedded window in a
     * Container structure. If there is already an existing Container
     * structure, it means that both container and embedded app. are in the
     * same process.
     */

    for (containerPtr = tsdPtr->firstContainerPtr; containerPtr != NULL;
	    containerPtr = containerPtr->nextPtr) {
	if (containerPtr->parent == parent) {
	    winPtr->flags |= TK_BOTH_HALVES;
	    containerPtr->parentPtr->flags |= TK_BOTH_HALVES;
	    break;
	}
    }
    if (containerPtr == NULL) {
	containerPtr = (Container *) ckalloc(sizeof(Container));
	containerPtr->parent = parent;
	containerPtr->parentRoot = parentAtts.root;
	containerPtr->parentPtr = NULL;
	containerPtr->wrapper = None;
	containerPtr->nextPtr = tsdPtr->firstContainerPtr;
	tsdPtr->firstContainerPtr = containerPtr;
    }
    containerPtr->embeddedPtr = winPtr;
    winPtr->flags |= TK_EMBEDDED;
    return TCL_OK;
}
Пример #2
0
static int tcl_whom(ClientData cd, Tcl_Interp *irp,
                    int argc, char *argv[])
{
  int chan, i;
  char c[2], idle[11], work[20], *p;
  long tv = 0;
  EGG_CONST char *list[7];

  BADARGS(2, 2, " chan");

  if (argv[1][0] == '*')
    chan = -1;
  else {
    if ((argv[1][0] < '0') || (argv[1][0] > '9')) {
      Tcl_SetVar(interp, "chan", argv[1], 0);
      if ((Tcl_VarEval(interp, "assoc ", "$chan", NULL) != TCL_OK) ||
          !interp->result[0]) {
        Tcl_AppendResult(irp, "channel name is invalid", NULL);
        return TCL_ERROR;
      }
      chan = atoi(interp->result);
    } else
      chan = atoi(argv[1]);
    if ((chan < 0) || (chan > 199999)) {
      Tcl_AppendResult(irp, "channel out of range; must be 0 through 199999",
                       NULL);
      return TCL_ERROR;
    }
  }
  for (i = 0; i < dcc_total; i++)
    if (dcc[i].type == &DCC_CHAT) {
      if (dcc[i].u.chat->channel == chan || chan == -1) {
        c[0] = geticon(i);
        c[1] = 0;
        tv = (now - dcc[i].timeval) / 60;
        egg_snprintf(idle, sizeof idle, "%li", tv);
        list[0] = dcc[i].nick;
        list[1] = botnetnick;
        list[2] = dcc[i].host;
        list[3] = c;
        list[4] = idle;
        list[5] = dcc[i].u.chat->away ? dcc[i].u.chat->away : "";
        if (chan == -1) {
          egg_snprintf(work, sizeof work, "%d", dcc[i].u.chat->channel);
          list[6] = work;
        }
        p = Tcl_Merge((chan == -1) ? 7 : 6, list);
        Tcl_AppendElement(irp, p);
        Tcl_Free((char *) p);
      }
    }
  for (i = 0; i < parties; i++) {
    if (party[i].chan == chan || chan == -1) {
      c[0] = party[i].flag;
      c[1] = 0;
      if (party[i].timer == 0L)
        strcpy(idle, "0");
      else {
        tv = (now - party[i].timer) / 60;
        egg_snprintf(idle, sizeof idle, "%li", tv);
      }
      list[0] = party[i].nick;
      list[1] = party[i].bot;
      list[2] = party[i].from ? party[i].from : "";
      list[3] = c;
      list[4] = idle;
      list[5] = party[i].status & PLSTAT_AWAY ? party[i].away : "";
      if (chan == -1) {
        egg_snprintf(work, sizeof work, "%d", party[i].chan);
        list[6] = work;
      }
      p = Tcl_Merge((chan == -1) ? 7 : 6, list);
      Tcl_AppendElement(irp, p);
      Tcl_Free((char *) p);
    }
  }
  return TCL_OK;
}
Пример #3
0
static int
SetPixelFromAny(
    Tcl_Interp *interp,		/* Used for error reporting if not NULL. */
    Tcl_Obj *objPtr)		/* The object to convert. */
{
    const Tcl_ObjType *typePtr;
    char *string, *rest;
    double d;
    int i, units;

    string = Tcl_GetString(objPtr);

    d = strtod(string, &rest);
    if (rest == string) {
	goto error;
    }
    while ((*rest != '\0') && isspace(UCHAR(*rest))) {
	rest++;
    }

    switch (*rest) {
    case '\0':
	units = -1;
	break;
    case 'm':
	units = 0;
	break;
    case 'c':
	units = 1;
	break;
    case 'i':
	units = 2;
	break;
    case 'p':
	units = 3;
	break;
    default:
	goto error;
    }

    /*
     * Free the old internalRep before setting the new one.
     */

    typePtr = objPtr->typePtr;
    if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) {
	(*typePtr->freeIntRepProc)(objPtr);
    }

    objPtr->typePtr = &pixelObjType;

    i = (int) d;
    if ((units < 0) && (i == d)) {
	SET_SIMPLEPIXEL(objPtr, i);
    } else {
	PixelRep *pixelPtr = (PixelRep *) ckalloc(sizeof(PixelRep));

	pixelPtr->value = d;
	pixelPtr->units = units;
	pixelPtr->tkwin = NULL;
	pixelPtr->returnValue = i;
	SET_COMPLEXPIXEL(objPtr, pixelPtr);
    }
    return TCL_OK;

  error:
    if (interp != NULL) {
	/*
	 * Must copy string before resetting the result in case a caller is
	 * trying to convert the interpreter's result to pixels.
	 */

	char buf[100];

	sprintf(buf, "bad screen distance \"%.50s\"", string);
	Tcl_ResetResult(interp);
	Tcl_AppendResult(interp, buf, NULL);
    }
    return TCL_ERROR;
}
Пример #4
0
int tclcommand_metadynamics_print_status(Tcl_Interp *interp)
{
  char buffer[TCL_DOUBLE_SPACE];
  /* metadynamics not initialized */
  if(meta_pid1 == -1 || meta_pid2 == -1) {
    Tcl_AppendResult(interp,"{ not initialized } ", (char *)NULL);
    return (TCL_OK);
  }

  /* metdynamics off */
  if(meta_switch == META_OFF) {
    Tcl_AppendResult(interp,"{ off } ", (char *)NULL);
    return (TCL_OK);
  }

  /* distance */
  if(meta_switch == META_DIST ) {
    sprintf(buffer,"%i", meta_pid1);
    Tcl_AppendResult(interp,"{ distance ",buffer, (char *)NULL);
    sprintf(buffer,"%i", meta_pid2);
    Tcl_AppendResult(interp," ",buffer, (char *)NULL);
    Tcl_PrintDouble(interp, meta_xi_min, buffer);
    Tcl_AppendResult(interp," ",buffer, (char *)NULL);
    Tcl_PrintDouble(interp, meta_xi_max, buffer);
    Tcl_AppendResult(interp," ",buffer, (char *)NULL);
    Tcl_PrintDouble(interp, meta_bias_height, buffer);
    Tcl_AppendResult(interp," ",buffer, (char *)NULL); 
    Tcl_PrintDouble(interp, meta_bias_width, buffer);
    Tcl_AppendResult(interp," ",buffer, (char *)NULL);
    Tcl_PrintDouble(interp, meta_f_bound, buffer);
    Tcl_AppendResult(interp," ",buffer, (char *)NULL);
    sprintf(buffer,"%i", meta_xi_num_bins);
    Tcl_AppendResult(interp," ",buffer," } ", (char *)NULL);
  }

  /* relative_z */
  if(meta_switch == META_REL_Z ) {
    sprintf(buffer,"%i", meta_pid1);
    Tcl_AppendResult(interp,"{ relative_z ",buffer, (char *)NULL);
    sprintf(buffer,"%i", meta_pid2);
    Tcl_AppendResult(interp," ",buffer, (char *)NULL);
    Tcl_PrintDouble(interp, meta_xi_min, buffer);
    Tcl_AppendResult(interp," ",buffer, (char *)NULL);
    Tcl_PrintDouble(interp, meta_xi_max, buffer);
    Tcl_AppendResult(interp," ",buffer, (char *)NULL);
    Tcl_PrintDouble(interp, meta_bias_height, buffer);
    Tcl_AppendResult(interp," ",buffer, (char *)NULL); 
    Tcl_PrintDouble(interp, meta_bias_width, buffer);
    Tcl_AppendResult(interp," ",buffer, (char *)NULL);
    Tcl_PrintDouble(interp, meta_f_bound, buffer);
    Tcl_AppendResult(interp," ",buffer, (char *)NULL);
    sprintf(buffer,"%i", meta_xi_num_bins);
    Tcl_AppendResult(interp," ",buffer," } ", (char *)NULL);
  }

  return (TCL_OK);
}
Пример #5
0
/** Reads a Tcl matrix and returns a C matrix.

    \param interp The Tcl interpreter
    \param data_in String containing a Tcl matrix of doubles
    \param data Pointer to the C matrix
    \param nrows Pointer to an int to store the height of the matrix
    \param ncols Pointer to an int to store the width of the matrix
    \return \em TCL_OK if everything went fine \em TCL_ERROR otherwise and 
            interp->result is set to an error message.

	    If \em TCL_OK is returned you have to make sure to free the memory
	    pointed to by data.
 */
int uwerr_read_matrix(Tcl_Interp *interp, char * data_in ,
		      double *** data, int * nrows, int * ncols)
{
  char ** row;
  char ** col;
  int tmp_ncols = -1, i, j, k;

  *nrows = *ncols = -1;

  if (Tcl_SplitList(interp, data_in, nrows, &row) == TCL_ERROR)
    return TCL_ERROR;

  if (*nrows < 1) {
    Tcl_AppendResult(interp, "first argument has to be a matrix.",
		     (char *)NULL);
    return TCL_ERROR;
  }

  if (!(*data = (double**)malloc(*nrows*sizeof(double*)))) {
    Tcl_AppendResult(interp, "Out of Memory.",
		     (char *)NULL);
    Tcl_Free((char *)row);
    return TCL_ERROR;
  }

  for (i = 0; i < *nrows; ++i) {
    tmp_ncols = -1;
    
    if (Tcl_SplitList(interp, row[i], &tmp_ncols, &col) == TCL_ERROR) {
      Tcl_Free((char*)row);
      return TCL_ERROR;
    }

    if (i == 0) {
      if (tmp_ncols < 1) {
	Tcl_AppendResult(interp, "first argument has to be a matrix.",
			 (char *)NULL);
	Tcl_Free((char *)col);
	Tcl_Free((char*)row);
	return TCL_ERROR;
      }

      *ncols = tmp_ncols;

    } else if (*ncols != tmp_ncols) {
      Tcl_AppendResult(interp, "number of columns changed.",
		       (char *)NULL);
      Tcl_Free((char *)col);
      Tcl_Free((char*)row);
      return TCL_ERROR;
    }

    if (!((*data)[i] = (double*)malloc(*ncols*sizeof(double)))) {
      Tcl_AppendResult(interp,"Out of Memory.",
		       (char *)NULL);
      Tcl_Free((char *)row);
      Tcl_Free((char *)col);
      for (k = 0; k < i; ++k)
	free((*data)[i]);
      free(*data);
      return TCL_ERROR;
    };

    for (j = 0; j < *ncols; ++j) {
      if (Tcl_GetDouble(interp, col[j], &((*data)[i][j])) == TCL_ERROR) {
	Tcl_Free((char *)col);
	Tcl_Free((char *)row);
	for (k = 0; k <= i; ++k)
	  free((*data)[i]);
	free(*data);
	return TCL_ERROR;
      }
    }

    Tcl_Free((char *)col);
  }

  Tcl_Free((char *)row);

  return TCL_OK;
}
Пример #6
0
/*!
 tux_events Tcl callback
 Here's a sample call to tux_events:

 tux_events {
 {
 -name "Herring Run" -icon noicon -cups {
 {
 -name "Cup 1" -icon noicon -races {
 {
 -course path_of_daggers \
 -description "nice long description" \
 -herring { 15 20 25 30 } \
 -time { 40.0 35.0 30.0 25.0 } \
 -score { 0 0 0 0 } \
 -mirrored yes -conditions cloudy \
 -windy no -snowing no
 }
 {
 -course ingos_speedway \
 -description "nice long description" \
 -herring { 15 20 25 30 } \
 -time { 40.0 35.0 30.0 25.0 } \
 -score { 0 0 0 0 } \
 -mirrored yes -conditions cloudy \
 -windy no -snowing no
 }
 }
 -name "Cup 2" -icon noicon -races {
 {
 -course penguins_cant_fly \
 -description "nice long description" \
 -herring { 15 20 25 30 } \
 -time { 40.0 35.0 30.0 25.0 } \
 -score { 0 0 0 0 } \
 -mirrored yes -conditions cloudy \
 -windy no -snowing no
 }
 {
 -course ingos_speedway \
 -description "nice long description" \
 -herring { 15 20 25 30 } \
 -time { 40.0 35.0 30.0 25.0 } \
 -score { 0 0 0 0 } \
 -mirrored yes -conditions cloudy \
 -windy no -snowing no
 }
 }
 }
 }
 }
 }

 \return  Tcl error code
 \author  jfpatry
 \date    Created:  2000-09-19
 \date    Modified: 2000-09-19
 */
static int events_cb( ClientData cd, Tcl_Interp *ip,
                      int argc, const char **argv )
{
    char *err_msg;
    const char **list = NULL;
    int num_events;
    list_elem_t last_event = NULL;
    int i;

    /* Make sure module has been initialized */
    check_assertion( initialized,
                     "course_mgr module not initialized" );

    if ( argc != 2 ) {
        err_msg = "Incorrect number of arguments";
        goto bail_events;
    }

    if ( Tcl_SplitList( ip, argv[1], &num_events, &list ) == TCL_ERROR ) {
        err_msg = "Argument is not a list";
        goto bail_events;
    }

    /* We currently only allow tux_events to be called once */
    last_event = get_list_tail( event_list );

    if ( last_event != NULL ) {
        err_msg = "tux_events has already been called; it can only be called "
                  "once.";
        goto bail_events;
    }

    for (i=0; i<num_events; i++) {
        event_data_t *data = create_event_data( ip, list[i], &err_msg );

        if ( data == NULL ) {
            goto bail_events;
        }

        last_event = insert_list_elem( event_list, last_event,
                                       (list_elem_data_t) data );
    }

    Tcl_Free( (char*) list );
    list = NULL;

    return TCL_OK;

bail_events:
    if ( list != NULL ) {
        Tcl_Free( (char*) list );
    }

    /* Clean out event list */
    if ( event_list != NULL ) {
        last_event = get_list_tail( event_list );
        while ( last_event != NULL ) {
            event_data_t *data;
            data = (event_data_t*) delete_list_elem( event_list,
                    last_event );
            free( data );
            last_event = get_list_tail( event_list );
        }
    }

    Tcl_AppendResult(
        ip,
        "Error in call to tux_events: ",
        err_msg,
        "\n",
        "Usage: tux_events { list of event data }",
        (NULL) );
    return TCL_ERROR;
}
Пример #7
0
Tk_Cursor
Tk_GetCursorFromData(
    Tcl_Interp *interp,		/* Interpreter to use for error reporting. */
    Tk_Window tkwin,		/* Window in which cursor will be used. */
    const char *source,		/* Bitmap data for cursor shape. */
    const char *mask,		/* Bitmap data for cursor mask. */
    int width, int height,	/* Dimensions of cursor. */
    int xHot, int yHot,		/* Location of hot-spot in cursor. */
    Tk_Uid fg,			/* Foreground color for cursor. */
    Tk_Uid bg)			/* Background color for cursor. */
{
    DataKey dataKey;
    Tcl_HashEntry *dataHashPtr;
    register TkCursor *cursorPtr;
    int isNew;
    XColor fgColor, bgColor;
    TkDisplay *dispPtr = ((TkWindow *) tkwin)->dispPtr;

    if (!dispPtr->cursorInit) {
	CursorInit(dispPtr);
    }

    dataKey.source = source;
    dataKey.mask = mask;
    dataKey.width = width;
    dataKey.height = height;
    dataKey.xHot = xHot;
    dataKey.yHot = yHot;
    dataKey.fg = fg;
    dataKey.bg = bg;
    dataKey.display = Tk_Display(tkwin);
    dataHashPtr = Tcl_CreateHashEntry(&dispPtr->cursorDataTable,
	    (char *) &dataKey, &isNew);
    if (!isNew) {
	cursorPtr = Tcl_GetHashValue(dataHashPtr);
	cursorPtr->resourceRefCount++;
	return cursorPtr->cursor;
    }

    /*
     * No suitable cursor exists yet. Make one using the data available and
     * add it to the database.
     */

    if (XParseColor(dataKey.display, Tk_Colormap(tkwin), fg, &fgColor) == 0) {
	Tcl_AppendResult(interp, "invalid color name \"", fg, "\"", NULL);
	goto error;
    }
    if (XParseColor(dataKey.display, Tk_Colormap(tkwin), bg, &bgColor) == 0) {
	Tcl_AppendResult(interp, "invalid color name \"", bg, "\"", NULL);
	goto error;
    }

    cursorPtr = TkCreateCursorFromData(tkwin, source, mask, width, height,
	    xHot, yHot, fgColor, bgColor);

    if (cursorPtr == NULL) {
	goto error;
    }

    cursorPtr->resourceRefCount = 1;
    cursorPtr->otherTable = &dispPtr->cursorDataTable;
    cursorPtr->hashPtr = dataHashPtr;
    cursorPtr->objRefCount = 0;
    cursorPtr->idHashPtr = Tcl_CreateHashEntry(&dispPtr->cursorIdTable,
	    (char *) cursorPtr->cursor, &isNew);
    cursorPtr->nextPtr = NULL;

    if (!isNew) {
	Tcl_Panic("cursor already registered in Tk_GetCursorFromData");
    }
    Tcl_SetHashValue(dataHashPtr, cursorPtr);
    Tcl_SetHashValue(cursorPtr->idHashPtr, cursorPtr);
    return cursorPtr->cursor;

  error:
    Tcl_DeleteHashEntry(dataHashPtr);
    return None;
}
Пример #8
0
int
TkTextWindowCmd(
    register TkText *textPtr,	/* Information about text widget. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. Someone else has already
				 * parsed this command enough to know that
				 * objv[1] is "window". */
{
    int optionIndex;
    static const char *const windOptionStrings[] = {
	"cget", "configure", "create", "names", NULL
    };
    enum windOptions {
	WIND_CGET, WIND_CONFIGURE, WIND_CREATE, WIND_NAMES
    };
    register TkTextSegment *ewPtr;

    if (objc < 3) {
	Tcl_WrongNumArgs(interp, 2, objv, "option ?arg ...?");
	return TCL_ERROR;
    }
    if (Tcl_GetIndexFromObj(interp, objv[2], windOptionStrings,
	    "window option", 0, &optionIndex) != TCL_OK) {
	return TCL_ERROR;
    }
    switch ((enum windOptions) optionIndex) {
    case WIND_CGET: {
	TkTextIndex index;
	TkTextSegment *ewPtr;
	Tcl_Obj *objPtr;
	TkTextEmbWindowClient *client;

	if (objc != 5) {
	    Tcl_WrongNumArgs(interp, 3, objv, "index option");
	    return TCL_ERROR;
	}
	if (TkTextGetObjIndex(interp, textPtr, objv[3], &index) != TCL_OK) {
	    return TCL_ERROR;
	}
	ewPtr = TkTextIndexToSeg(&index, NULL);
	if (ewPtr->typePtr != &tkTextEmbWindowType) {
	    Tcl_AppendResult(interp, "no embedded window at index \"",
		    Tcl_GetString(objv[3]), "\"", NULL);
	    return TCL_ERROR;
	}

	/*
	 * Copy over client specific value before querying.
	 */

	client = EmbWinGetClient(textPtr, ewPtr);
	if (client != NULL) {
	    ewPtr->body.ew.tkwin = client->tkwin;
	} else {
	    ewPtr->body.ew.tkwin = NULL;
	}

	objPtr = Tk_GetOptionValue(interp, (char *) &ewPtr->body.ew,
		ewPtr->body.ew.optionTable, objv[4], textPtr->tkwin);
	if (objPtr == NULL) {
	    return TCL_ERROR;
	}
	Tcl_SetObjResult(interp, objPtr);
	return TCL_OK;
    }
    case WIND_CONFIGURE: {
	TkTextIndex index;
	TkTextSegment *ewPtr;

	if (objc < 4) {
	    Tcl_WrongNumArgs(interp, 3, objv, "index ?-option value ...?");
	    return TCL_ERROR;
	}
	if (TkTextGetObjIndex(interp, textPtr, objv[3], &index) != TCL_OK) {
	    return TCL_ERROR;
	}
	ewPtr = TkTextIndexToSeg(&index, NULL);
	if (ewPtr->typePtr != &tkTextEmbWindowType) {
	    Tcl_AppendResult(interp, "no embedded window at index \"",
		    Tcl_GetString(objv[3]), "\"", NULL);
	    return TCL_ERROR;
	}
	if (objc <= 5) {
	    TkTextEmbWindowClient *client;
	    Tcl_Obj* objPtr;

	    /*
	     * Copy over client specific value before querying.
	     */

	    client = EmbWinGetClient(textPtr, ewPtr);
	    if (client != NULL) {
		ewPtr->body.ew.tkwin = client->tkwin;
	    } else {
		ewPtr->body.ew.tkwin = NULL;
	    }

	    objPtr = Tk_GetOptionInfo(interp, (char *) &ewPtr->body.ew,
		    ewPtr->body.ew.optionTable, (objc == 5) ? objv[4] : NULL,
		    textPtr->tkwin);
	    if (objPtr == NULL) {
		return TCL_ERROR;
	    }
	    Tcl_SetObjResult(interp, objPtr);
	    return TCL_OK;
	} else {
	    TkTextChanged(textPtr->sharedTextPtr, NULL, &index, &index);

	    /*
	     * It's probably not true that all window configuration can change
	     * the line height, so we could be more efficient here and only
	     * call this when necessary.
	     */

	    TkTextInvalidateLineMetrics(textPtr->sharedTextPtr, NULL,
		    index.linePtr, 0, TK_TEXT_INVALIDATE_ONLY);
	    return EmbWinConfigure(textPtr, ewPtr, objc-4, objv+4);
	}
    }
    case WIND_CREATE: {
	TkTextIndex index;
	int lineIndex;
	TkTextEmbWindowClient *client;
	int res;

	/*
	 * Add a new window. Find where to put the new window, and mark that
	 * position for redisplay.
	 */

	if (objc < 4) {
	    Tcl_WrongNumArgs(interp, 3, objv, "index ?-option value ...?");
	    return TCL_ERROR;
	}
	if (TkTextGetObjIndex(interp, textPtr, objv[3], &index) != TCL_OK) {
	    return TCL_ERROR;
	}

	/*
	 * Don't allow insertions on the last (dummy) line of the text.
	 */

	lineIndex = TkBTreeLinesTo(textPtr, index.linePtr);
	if (lineIndex == TkBTreeNumLines(textPtr->sharedTextPtr->tree,
		textPtr)) {
	    lineIndex--;
	    TkTextMakeByteIndex(textPtr->sharedTextPtr->tree, textPtr,
		    lineIndex, 1000000, &index);
	}

	/*
	 * Create the new window segment and initialize it.
	 */

	ewPtr = (TkTextSegment *) ckalloc(EW_SEG_SIZE);
	ewPtr->typePtr = &tkTextEmbWindowType;
	ewPtr->size = 1;
	ewPtr->body.ew.sharedTextPtr = textPtr->sharedTextPtr;
	ewPtr->body.ew.linePtr = NULL;
	ewPtr->body.ew.tkwin = NULL;
	ewPtr->body.ew.create = NULL;
	ewPtr->body.ew.align = ALIGN_CENTER;
	ewPtr->body.ew.padX = ewPtr->body.ew.padY = 0;
	ewPtr->body.ew.stretch = 0;
	ewPtr->body.ew.optionTable = Tk_CreateOptionTable(interp, optionSpecs);

	client = (TkTextEmbWindowClient *)
		ckalloc(sizeof(TkTextEmbWindowClient));
	client->next = NULL;
	client->textPtr = textPtr;
	client->tkwin = NULL;
	client->chunkCount = 0;
	client->displayed = 0;
	client->parent = ewPtr;
	ewPtr->body.ew.clients = client;

	/*
	 * Link the segment into the text widget, then configure it (delete it
	 * again if the configuration fails).
	 */

	TkTextChanged(textPtr->sharedTextPtr, NULL, &index, &index);
	TkBTreeLinkSegment(ewPtr, &index);
	res = EmbWinConfigure(textPtr, ewPtr, objc-4, objv+4);
	client->tkwin = ewPtr->body.ew.tkwin;
	if (res != TCL_OK) {
	    TkTextIndex index2;

	    TkTextIndexForwChars(NULL, &index, 1, &index2, COUNT_INDICES);
	    TkBTreeDeleteIndexRange(textPtr->sharedTextPtr->tree, &index,
		    &index2);
	    return TCL_ERROR;
	}
	TkTextInvalidateLineMetrics(textPtr->sharedTextPtr, NULL,
		index.linePtr, 0, TK_TEXT_INVALIDATE_ONLY);
	break;
    }
    case WIND_NAMES: {
	Tcl_HashSearch search;
	Tcl_HashEntry *hPtr;

	if (objc != 3) {
	    Tcl_WrongNumArgs(interp, 3, objv, NULL);
	    return TCL_ERROR;
	}
	for (hPtr = Tcl_FirstHashEntry(&textPtr->sharedTextPtr->windowTable,
		&search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
	    Tcl_AppendElement(interp,
		    Tcl_GetHashKey(&textPtr->sharedTextPtr->markTable, hPtr));
	}
	break;
    }
    }
    return TCL_OK;
}
Пример #9
0
static int
EmbWinConfigure(
    TkText *textPtr,		/* Information about text widget that contains
				 * embedded window. */
    TkTextSegment *ewPtr,	/* Embedded window to be configured. */
    int objc,			/* Number of strings in objv. */
    Tcl_Obj *const objv[])	/* Array of objects describing configuration
				 * options. */
{
    Tk_Window oldWindow;
    TkTextEmbWindowClient *client;

    /*
     * Copy over client specific value before querying or setting.
     */

    client = EmbWinGetClient(textPtr, ewPtr);
    if (client != NULL) {
	ewPtr->body.ew.tkwin = client->tkwin;
    } else {
	ewPtr->body.ew.tkwin = NULL;
    }

    oldWindow = ewPtr->body.ew.tkwin;
    if (Tk_SetOptions(textPtr->interp, (char *) &ewPtr->body.ew,
	    ewPtr->body.ew.optionTable, objc, objv, textPtr->tkwin, NULL,
	    NULL) != TCL_OK) {
	return TCL_ERROR;
    }

    if (oldWindow != ewPtr->body.ew.tkwin) {
	if (oldWindow != NULL) {
	    Tcl_DeleteHashEntry(Tcl_FindHashEntry(
		    &textPtr->sharedTextPtr->windowTable,
		    Tk_PathName(oldWindow)));
	    Tk_DeleteEventHandler(oldWindow, StructureNotifyMask,
		    EmbWinStructureProc, (ClientData) client);
	    Tk_ManageGeometry(oldWindow, NULL, (ClientData) NULL);
	    if (textPtr->tkwin != Tk_Parent(oldWindow)) {
		Tk_UnmaintainGeometry(oldWindow, textPtr->tkwin);
	    } else {
		Tk_UnmapWindow(oldWindow);
	    }
	}
	if (client != NULL) {
	    client->tkwin = NULL;
	}
	if (ewPtr->body.ew.tkwin != NULL) {
	    Tk_Window ancestor, parent;
	    Tcl_HashEntry *hPtr;
	    int isNew;

	    /*
	     * Make sure that the text is either the parent of the embedded
	     * window or a descendant of that parent. Also, don't allow a
	     * top-level window to be managed inside a text.
	     */

	    parent = Tk_Parent(ewPtr->body.ew.tkwin);
	    for (ancestor = textPtr->tkwin; ; ancestor = Tk_Parent(ancestor)) {
		if (ancestor == parent) {
		    break;
		}
		if (Tk_TopWinHierarchy(ancestor)) {
		badMaster:
		    Tcl_AppendResult(textPtr->interp, "can't embed ",
			    Tk_PathName(ewPtr->body.ew.tkwin), " in ",
			    Tk_PathName(textPtr->tkwin), NULL);
		    ewPtr->body.ew.tkwin = NULL;
		    if (client != NULL) {
			client->tkwin = NULL;
		    }
		    return TCL_ERROR;
		}
	    }
	    if (Tk_TopWinHierarchy(ewPtr->body.ew.tkwin)
		    || (ewPtr->body.ew.tkwin == textPtr->tkwin)) {
		goto badMaster;
	    }

	    if (client == NULL) {
		/*
		 * Have to make the new client.
		 */

		client = (TkTextEmbWindowClient *)
			ckalloc(sizeof(TkTextEmbWindowClient));
		client->next = ewPtr->body.ew.clients;
		client->textPtr = textPtr;
		client->tkwin = NULL;
		client->chunkCount = 0;
		client->displayed = 0;
		client->parent = ewPtr;
		ewPtr->body.ew.clients = client;
	    }
	    client->tkwin = ewPtr->body.ew.tkwin;

	    /*
	     * Take over geometry management for the window, plus create an
	     * event handler to find out when it is deleted.
	     */

	    Tk_ManageGeometry(ewPtr->body.ew.tkwin, &textGeomType,
		    (ClientData) client);
	    Tk_CreateEventHandler(ewPtr->body.ew.tkwin, StructureNotifyMask,
		    EmbWinStructureProc, (ClientData) client);

	    /*
	     * Special trick!  Must enter into the hash table *after* calling
	     * Tk_ManageGeometry: if the window was already managed elsewhere
	     * in this text, the Tk_ManageGeometry call will cause the entry
	     * to be removed, which could potentially lose the new entry.
	     */

	    hPtr = Tcl_CreateHashEntry(&textPtr->sharedTextPtr->windowTable,
		    Tk_PathName(ewPtr->body.ew.tkwin), &isNew);
	    Tcl_SetHashValue(hPtr, ewPtr);
	}
    }
    return TCL_OK;
}
Пример #10
0
/* parser for hole cluster analyzation:
   analyze holes <prob_part_type_number> <mesh_size>.
   Needs feature LENNARD_JONES compiled in. */
int tclcommand_analyze_parse_holes(Tcl_Interp *interp, int argc, char **argv)
{
  int i,j;
  int probe_part_type;
  int mesh_size=1, meshdim[3];
  double freevol=0.0;
  char buffer[TCL_INTEGER_SPACE+TCL_DOUBLE_SPACE];

  IntList mesh;

  int n_holes;
  int **holes;
  int max_size=0;
  int *surface;

#ifndef LENNARD_JONES
   Tcl_AppendResult(interp, "analyze holes needs feature LENNARD_JONES compiled in.\n", (char *)NULL);
    return TCL_ERROR;
#endif

  /* check # of parameters */
  if (argc < 2) {
    Tcl_AppendResult(interp, "analyze holes needs 2 parameters:\n", (char *)NULL);
    Tcl_AppendResult(interp, "<prob_part_type_number> <mesh_size>", (char *)NULL);
    return TCL_ERROR;
  }

  /* check parameter types */
  if( (! ARG_IS_I(0, probe_part_type)) ||
      (! ARG_IS_I(1, mesh_size))  ) {
    Tcl_AppendResult(interp, "analyze holes needs 2 parameters of type and meaning:\n", (char *)NULL);
    Tcl_AppendResult(interp, "INT INT\n", (char *)NULL);
    Tcl_AppendResult(interp, "<prob_part_type_number> <mesh_size>", (char *)NULL);
    return TCL_ERROR;
  }

  /* check parameter values */
  if( probe_part_type > n_particle_types || probe_part_type < 0 ) {
    Tcl_AppendResult(interp, "analyze holes: probe particle type number does not exist", (char *)NULL);
    return TCL_ERROR;
  }
  if( mesh_size < 1  ) {
    Tcl_AppendResult(interp, "analyze holes: mesh size must be positive (min=1)", (char *)NULL);
    return TCL_ERROR;
  }

  /* preparation */
  updatePartCfg(WITHOUT_BONDS);
  meshdim[0]=mesh_size;
  meshdim[1]=mesh_size;
  meshdim[2]=mesh_size;
  alloc_intlist(&mesh, (meshdim[0]*meshdim[1]*meshdim[2]));

  /* perform free space identification*/
  create_free_volume_grid(mesh, meshdim, probe_part_type);
  /* perfrom hole cluster algorithm */
  n_holes = cluster_free_volume_grid(mesh, meshdim, &holes);
  /* surface to volume ratio */
  surface = (int *) malloc(sizeof(int)*(n_holes+1));
  cluster_free_volume_surface(mesh, meshdim, n_holes, holes, surface);
  /* calculate accessible volume / max size*/
  for ( i=0; i<=n_holes; i++ ) { 
    freevol += holes[i][0];
    if ( holes[i][0]> max_size ) max_size = holes[i][0];
  }

  /* Append result to tcl interpreter */
  Tcl_AppendResult(interp, "{ n_holes mean_hole_size max_hole_size free_volume_fraction { sizes } { surfaces }  { element_lists } } ", (char *)NULL);

  Tcl_AppendResult(interp, "{", (char *)NULL);

  /* number of holes */
  sprintf(buffer,"%d ",n_holes+1); Tcl_AppendResult(interp, buffer, " ", (char *)NULL);
  /* mean hole size */
  sprintf(buffer,"%f ",freevol/(n_holes+1.0)); Tcl_AppendResult(interp, buffer, " ", (char *)NULL);
  /* max hole size */
  sprintf(buffer,"%d ",max_size); Tcl_AppendResult(interp, buffer, " ", (char *)NULL);
  /* free volume fraction */
  sprintf(buffer,"%f ",freevol/(meshdim[0]*meshdim[1]*meshdim[2]));
  Tcl_AppendResult(interp, buffer, " ", (char *)NULL);
  /* hole sizes */
  Tcl_AppendResult(interp, "{ ", (char *)NULL);
  for ( i=0; i<=n_holes; i++ ) { 
    sprintf(buffer,"%d ",holes[i][0]); Tcl_AppendResult(interp, buffer, " ", (char *)NULL);
  }
  Tcl_AppendResult(interp, "} ", (char *)NULL);
  /* hole surfaces */
  Tcl_AppendResult(interp, "{ ", (char *)NULL);
  for ( i=0; i<=n_holes; i++ ) { 
    sprintf(buffer,"%d ",surface[i]); Tcl_AppendResult(interp, buffer, " ", (char *)NULL);
  }
  Tcl_AppendResult(interp, "} ", (char *)NULL);
  /* hole elements */ 
  Tcl_AppendResult(interp, "{ ", (char *)NULL);
  for ( i=0; i<=n_holes; i++ ) { 
    Tcl_AppendResult(interp, "{ ", (char *)NULL);
    for ( j=1; j <= holes[i][0]; j++ ) {
      sprintf(buffer,"%d",holes[i][j]);
      Tcl_AppendResult(interp, buffer, " ",(char *)NULL);
    }
    Tcl_AppendResult(interp, "} ", (char *)NULL);
  }
  Tcl_AppendResult(interp, "} ", (char *)NULL);
  
  Tcl_AppendResult(interp, "}", (char *)NULL);

  /* free allocated memory */
  realloc_intlist(&mesh, 0);
  free(surface);
  for ( i=0; i<=n_holes; i++ ) { free(holes[i]); }
  free(holes);

  return (TCL_OK);
}
Пример #11
0
/* parser for necklace cluster analyzation:
   analyze necklace <pearl_treshold> <back_dist> <space_dist> <first> <length> 
 */
int tclcommand_analyze_parse_necklace(Tcl_Interp *interp, int argc, char **argv)
{
  double space_dist;
  int first,length;
  Particle *part;
  Cluster *cluster;
  char buffer[TCL_INTEGER_SPACE];
  int n_pearls;

  /* check # of parameters */
  if (argc < 5) {
    Tcl_AppendResult(interp, "analyze necklace needs 5 parameters:\n", (char *)NULL);
    Tcl_AppendResult(interp, "<pearl_treshold> <back_dist> <space_dist> <first> <length>", (char *)NULL);
    return TCL_ERROR;
  }

  /* check parameter types */
  if( (! ARG_IS_I(0, pearl_treshold)) ||
      (! ARG_IS_I(1, backbone_distance))  ||
      (! ARG_IS_D(2, space_dist))     ||
      (! ARG_IS_I(3, first))          ||
      (! ARG_IS_I(4, length)) ) {
    Tcl_AppendResult(interp, "analyze necklace needs 5 parameters of type and meaning:\n", (char *)NULL);
    Tcl_AppendResult(interp, "INT INT DOUBLE INT INT\n", (char *)NULL);
    Tcl_AppendResult(interp, "<pearl_treshold> <back_dist> <space_dist> <first> <length>", (char *)NULL);
    return TCL_ERROR;
  }

  /* check parameter values */
  if( pearl_treshold < 10 ) {
    Tcl_AppendResult(interp, "analyze necklace: pearl_treshold should be >= 10", (char *)NULL);
    return TCL_ERROR;
  }
  if( backbone_distance < 2 ) {
    Tcl_AppendResult(interp, "analyze necklace: backbone_dist should be >= 2", (char *)NULL);
    return TCL_ERROR;
  }
  if( space_dist <= 0.0 ) {
    Tcl_AppendResult(interp, "analyze necklace: space_dist must be positive", (char *)NULL);
    return TCL_ERROR;
  }
  if( first < 0 ) {
    Tcl_AppendResult(interp, "analyze necklace: identity of first particle can not be negative", (char *)NULL);
    return TCL_ERROR;
  }
  if( first+length > n_total_particles+1) {
    Tcl_AppendResult(interp, "analyze necklace: identity of last particle out of partCfg array", (char *)NULL);
    return TCL_ERROR;
  }

  /* preparation */
  space_distance2 = SQR(space_dist);
  sortPartCfg();
  part = &partCfg[first];

  /* perform necklace cluster algorithm */
  n_pearls = analyze_necklace(part, length) ;

  /* Append result to tcl interpreter */
  sprintf(buffer,"%d",n_pearls);
  Tcl_AppendResult(interp, buffer, " pearls { ", (char *)NULL);
  if( n_pearls > 0 ) {
    cluster = first_cluster;
    sprintf(buffer,"%d",cluster->size);
    Tcl_AppendResult(interp, buffer, " ",(char *)NULL);
    cluster = cluster->next;
    while(cluster->prev != last_cluster) { 
      sprintf(buffer,"%d",cluster->size);
      Tcl_AppendResult(interp, buffer, " ",(char *)NULL);
      cluster = cluster->next;
    }
  }
  Tcl_AppendResult(interp, "} ", (char *)NULL);

   /* free analyzation memory */
  cluster_free();
  
  return (TCL_OK);
}
Пример #12
0
/*
 *---------------------------------------------------------------------------
 *
 * HtmlImageServerGet --
 *
 *     Retrieve an HtmlImage2 object for the image at URL zUrl from 
 *     an image-server. The caller should match this call with a single
 *     HtmlImageFree() when the image object is no longer required.
 *
 *     If the image is not already in the cache, the Tcl script 
 *     configured as the widget -imagecmd is invoked. If this command
 *     raises an error or returns an invalid result, then this function 
 *     returns NULL. A Tcl back-ground error is propagated in this case 
 *     also.
 *
 * Results:
 *     Pointer to HtmlImage2 object containing the image from zUrl, or
 *     NULL, if zUrl was invalid for some reason.
 *
 * Side effects:
 *     May invoke -imagecmd script.
 *
 *---------------------------------------------------------------------------
 */
HtmlImage2 *
HtmlImageServerGet (HtmlImageServer *p, const char *zUrl) 
{
    Tcl_Obj *pImageCmd = p->pTree->options.imagecmd;
    Tcl_Interp *interp = p->pTree->interp;
    Tcl_HashEntry *pEntry = 0;
    HtmlImage2 *pImage = 0;

    /* Try to find the requested image in the hash table. */
    if (pImageCmd) {
        int new_entry;
        pEntry = Tcl_CreateHashEntry(&p->aImage, zUrl, &new_entry);
        if (new_entry) {
            Tcl_Obj *pEval;
            Tcl_Obj *pResult;
            int rc;
            int nObj;
            Tcl_Obj **apObj = 0;
            Tk_Image img;
           
	    /* The image could not be found in the hash table and an 
             * -imagecmd callback is configured. The callback script 
             * must be executed to obtain an image. Build up a script 
             * in pEval and execute it. Put the result in variable pResult.
             */
            pEval = Tcl_DuplicateObj(pImageCmd);
            Tcl_IncrRefCount(pEval);
            Tcl_ListObjAppendElement(interp, pEval, Tcl_NewStringObj(zUrl, -1));
            rc = Tcl_EvalObjEx(interp, pEval, TCL_EVAL_DIRECT|TCL_EVAL_GLOBAL);
            Tcl_DecrRefCount(pEval);
            if (rc != TCL_OK) {
                goto image_get_out;
            }
            pResult = Tcl_GetObjResult(interp);
    
            /* Read the result into array apObj. If the result was
             * not a valid Tcl list, return NULL and raise a background
             * error about the badly formed list.
             */
            rc = Tcl_ListObjGetElements(interp, pResult, &nObj, &apObj);
            if (rc != TCL_OK) {
                goto image_get_out;
            }
            if (nObj==0) {
                Tcl_DeleteHashEntry(pEntry);
                goto image_unavailable;
            }

            pImage = HtmlNew(HtmlImage2);
            if (nObj == 1 || nObj == 2) {
                img = Tk_GetImage(
                    interp, p->pTree->tkwin, Tcl_GetString(apObj[0]),
                    imageChanged, pImage
                );
            }
            if ((nObj != 1 && nObj != 2) || !img) {
                Tcl_ResetResult(interp);
                Tcl_AppendResult(interp,  "-imagecmd returned bad value", 0);
                HtmlFree(pImage);
                pImage = 0;
                goto image_get_out;
            }

            Tcl_SetHashValue(pEntry, (ClientData)pImage);
            Tcl_IncrRefCount(apObj[0]);
            pImage->pImageName = apObj[0];
            if (nObj == 2) {
                Tcl_IncrRefCount(apObj[1]);
                pImage->pDelete = apObj[1];
            }
            pImage->pImageServer = p;
            pImage->zUrl = Tcl_GetHashKey(&p->aImage, pEntry);
            pImage->image = img;
            Tk_SizeOfImage(pImage->image, &pImage->width, &pImage->height);
            pImage->isValid = 1;
            HtmlImagePixmap(pImage);
        }
    }

image_get_out:
    pImage = (HtmlImage2 *)(pEntry ? Tcl_GetHashValue(pEntry) : 0);
    HtmlImageRef(pImage);
    if (!pImage && pImageCmd) {
        Tcl_BackgroundError(interp);
        Tcl_ResetResult(interp);
        assert(pEntry);
        Tcl_DeleteHashEntry(pEntry);
    }

image_unavailable:
    return pImage;
}
Пример #13
0
int
Tclae_Init(Tcl_Interp *interp)
{
    OSErr		err;
    SInt32		attr;
    
    //Check for AppleEvents
    err = Gestalt(gestaltAppleEventsAttr, &attr);
    if ((err != noErr)
    ||  !(attr & (1 << gestaltAppleEventsPresent))) {
	Tcl_ResetResult(interp);
	Tcl_AppendResult(interp, "The AppleEvent Manager is either missing or misbehaving",
			 (char *) NULL);
    }
    err = AEObjectInit();
    
    
    if (Tcl_InitStubs(interp, "8.0", 0) == NULL) {
	return TCL_ERROR;
    }
    if (Tcl_PkgRequire(interp, "Tcl", TCL_VERSION, 0) == NULL) {
	if (TCL_VERSION[0] == '7') {
	    if (Tcl_PkgRequire(interp, "Tcl", "8.0", 0) == NULL) {
		return TCL_ERROR;
	    }
	}
    }
    
    if (Tcl_PkgProvide(interp, TCLAE_NAME, TCLAE_BASIC_VERSION) != TCL_OK) {
		return TCL_ERROR;
    }

    /* Why?!? */
    Tcl_SetVar(interp, "tclAE_version", TCLAE_VERSION, TCL_GLOBAL_ONLY);
    
    tclAE_macRoman_encoding = Tcl_GetEncoding(interp,"macRoman");
    
    TclaeInitAEAddresses();
    TclaeInitAEDescs();
    TclaeInitEventHandlers(interp);
    TclaeInitCoercionHandlers(interp);
    TclaeInitObjectAccessors(interp);
    
    /* Define Tcl commands */
    
    Tcl_CreateObjCommand(interp, "tclAE::build", Tclae_BuildCmd, NULL, 0L);
    Tcl_CreateObjCommand(interp, "tclAE::send", Tclae_SendCmd, NULL, 0L);
    
    /* Handler commands */
    
    Tcl_CreateObjCommand(interp, "tclAE::getCoercionHandler", Tclae_GetCoercionHandlerCmd, NULL, 0L);
    Tcl_CreateObjCommand(interp, "tclAE::getEventHandler", Tclae_GetEventHandlerCmd, NULL, 0L);
    Tcl_CreateObjCommand(interp, "tclAE::installCoercionHandler", Tclae_InstallCoercionHandlerCmd, NULL, 0L);
    Tcl_CreateObjCommand(interp, "tclAE::installEventHandler", Tclae_InstallEventHandlerCmd, NULL, 0L);
    Tcl_CreateObjCommand(interp, "tclAE::removeCoercionHandler", Tclae_RemoveCoercionHandlerCmd, NULL, 0L);
    Tcl_CreateObjCommand(interp, "tclAE::removeEventHandler", Tclae_RemoveEventHandlerCmd, NULL, 0L);
    
    /* Target commands */
    
#if !TARGET_API_MAC_CARBON  && !defined(TCLAE_NO_EPPC) // das 25/10/00: Carbonization
    Tcl_CreateObjCommand(interp, "tclAE::IPCListPorts", Tclae_IPCListPortsCmd, NULL, 0L);
    Tcl_CreateObjCommand(interp, "tclAE::PPCBrowser", Tclae_PPCBrowserCmd, NULL, 0L);
#endif
    
#if TARGET_API_MAC_CARBON	
    Tcl_CreateObjCommand(interp, "tclAE::getPOSIXPath", Tclae_GetPOSIXPathCmd, NULL, 0L);
    Tcl_CreateObjCommand(interp, "tclAE::getHFSPath", Tclae_GetHFSPathCmd, NULL, 0L);
#endif

    Tcl_CreateObjCommand(interp, "tclAE::launch", Tclae_LaunchCmd, NULL, 0L);
    Tcl_CreateObjCommand(interp, "tclAE::processes", Tclae_ProcessesCmd, NULL, 0L);
    Tcl_CreateObjCommand(interp, "tclAE::remoteProcessResolverGetProcesses", Tclae_RemoteProcessResolverGetProcessesCmd, NULL, 0L);
    
    /* AEDesc commands */
    
    Tcl_CreateObjCommand(interp, "tclAE::coerceData", Tclae_CoerceDataCmd, NULL, 0L);
    Tcl_CreateObjCommand(interp, "tclAE::coerceDesc", Tclae_CoerceDescCmd, NULL, 0L);
    Tcl_CreateObjCommand(interp, "tclAE::countItems", Tclae_CountItemsCmd, NULL, 0L);
    Tcl_CreateObjCommand(interp, "tclAE::createDesc", Tclae_CreateDescCmd, NULL, 0L);
    Tcl_CreateObjCommand(interp, "tclAE::createList", Tclae_CreateListCmd, NULL, 0L);
    Tcl_CreateObjCommand(interp, "tclAE::deleteItem", Tclae_DeleteItemCmd, NULL, 0L);
    Tcl_CreateObjCommand(interp, "tclAE::deleteKeyDesc", Tclae_DeleteKeyDescCmd, NULL, 0L);
    Tcl_CreateObjCommand(interp, "tclAE::duplicateDesc", Tclae_DuplicateDescCmd, NULL, 0L);
    Tcl_CreateObjCommand(interp, "tclAE::getAttributeData", Tclae_GetAttributeDataCmd, NULL, 0L);
    Tcl_CreateObjCommand(interp, "tclAE::getAttributeDesc", Tclae_GetAttributeDescCmd, NULL, 0L);
    Tcl_CreateObjCommand(interp, "tclAE::getData", Tclae_GetDataCmd, NULL, 0L);
    Tcl_CreateObjCommand(interp, "tclAE::getDescType", Tclae_GetDescTypeCmd, NULL, 0L);
    Tcl_CreateObjCommand(interp, "tclAE::getKeyData", Tclae_GetKeyDataCmd, NULL, 0L);
    Tcl_CreateObjCommand(interp, "tclAE::getKeyDesc", Tclae_GetKeyDescCmd, NULL, 0L);
    Tcl_CreateObjCommand(interp, "tclAE::getNthData", Tclae_GetNthDataCmd, NULL, 0L);
    Tcl_CreateObjCommand(interp, "tclAE::getNthDesc", Tclae_GetNthDescCmd, NULL, 0L);
    Tcl_CreateObjCommand(interp, "tclAE::putData", Tclae_PutDataCmd, NULL, 0L);
    Tcl_CreateObjCommand(interp, "tclAE::putDesc", Tclae_PutDescCmd, NULL, 0L);
    Tcl_CreateObjCommand(interp, "tclAE::putKeyData", Tclae_PutKeyDataCmd, NULL, 0L);
    Tcl_CreateObjCommand(interp, "tclAE::putKeyDesc", Tclae_PutKeyDescCmd, NULL, 0L);
    Tcl_CreateObjCommand(interp, "tclAE::replaceDescData", Tclae_ReplaceDescDataCmd, NULL, 0L);
    Tcl_CreateObjCommand(interp, "tclAE::setDescType", Tclae_SetDescTypeCmd, NULL, 0L);
    
    Tcl_CreateObjCommand(interp, "tclAE::_private::_getAEDesc", Tclae__GetAEDescCmd, NULL, 0L);
    
    /* Object commands */
    
    Tcl_CreateObjCommand(interp, "tclAE::setObjectCallbacks", Tclae_SetObjectCallbacksCmd, NULL, 0L);
    Tcl_CreateObjCommand(interp, "tclAE::resolve", Tclae_ResolveCmd, NULL, 0L);
    Tcl_CreateObjCommand(interp, "tclAE::callObjectAccessor", Tclae_CallObjectAccessorCmd, NULL, 0L);
    Tcl_CreateObjCommand(interp, "tclAE::getObjectAccessor", Tclae_GetObjectAccessorCmd, NULL, 0L);
    Tcl_CreateObjCommand(interp, "tclAE::installObjectAccessor", Tclae_InstallObjectAccessorCmd, NULL, 0L);
    Tcl_CreateObjCommand(interp, "tclAE::removeObjectAccessor", Tclae_RemoveObjectAccessorCmd, NULL, 0L);
    Tcl_CreateObjCommand(interp, "tclAE::disposeToken", Tclae_DisposeTokenCmd, NULL, 0L);
    
    
	return TCL_OK;
}
static int
PyAggImagePhoto(ClientData clientdata, Tcl_Interp* interp,
                int argc, char **argv)
{
    Tk_PhotoHandle photo;
    Tk_PhotoImageBlock block;
    PyObject* aggo;

    // vars for blitting
    PyObject* bboxo;

    unsigned long aggl, bboxl;
    bool has_bbox;
    agg::int8u *destbuffer;
    double l, b, r, t;
    int destx, desty, destwidth, destheight, deststride;
    //unsigned long tmp_ptr;

    long mode;
    long nval;
    if (Tk_MainWindow(interp) == NULL)
    {
        // Will throw a _tkinter.TclError with "this isn't a Tk application"
        return TCL_ERROR;
    }

    if (argc != 5)
    {
        Tcl_AppendResult(interp, "usage: ", argv[0],
                         " destPhoto srcImage", (char *) NULL);
        return TCL_ERROR;
    }

    /* get Tcl PhotoImage handle */
    photo = Tk_FindPhoto(interp, argv[1]);
    if (photo == NULL)
    {
        Tcl_AppendResult(interp, "destination photo must exist", (char *) NULL);
        return TCL_ERROR;
    }
    /* get array (or object that can be converted to array) pointer */
    if (sscanf(argv[2], "%lu", &aggl) != 1)
    {
        Tcl_AppendResult(interp, "error casting pointer", (char *) NULL);
        return TCL_ERROR;
    }
    aggo = (PyObject*)aggl;
    //aggo = (PyObject*)atol(argv[2]);

    //std::stringstream agg_ptr_ss;
    //agg_ptr_ss.str(argv[2]);
    //agg_ptr_ss >> tmp_ptr;
    //aggo = (PyObject*)tmp_ptr;
    RendererAgg *aggRenderer = (RendererAgg *)aggo;
    int srcheight = (int)aggRenderer->get_height();

    /* XXX insert aggRenderer type check */

    /* get array mode (0=mono, 1=rgb, 2=rgba) */
    mode = atol(argv[3]);
    if ((mode != 0) && (mode != 1) && (mode != 2))
    {
        Tcl_AppendResult(interp, "illegal image mode", (char *) NULL);
        return TCL_ERROR;
    }

    /* check for bbox/blitting */
    if (sscanf(argv[4], "%lu", &bboxl) != 1)
    {
        Tcl_AppendResult(interp, "error casting pointer", (char *) NULL);
        return TCL_ERROR;
    }
    bboxo = (PyObject*)bboxl;

    //bboxo = (PyObject*)atol(argv[4]);
    //std::stringstream bbox_ptr_ss;
    //bbox_ptr_ss.str(argv[4]);
    //bbox_ptr_ss >> tmp_ptr;
    //bboxo = (PyObject*)tmp_ptr;
    if (py_convert_bbox(bboxo, l, b, r, t))
    {
        has_bbox = true;

        destx = (int)l;
        desty = srcheight - (int)t;
        destwidth = (int)(r - l);
        destheight = (int)(t - b);
        deststride = 4 * destwidth;

        destbuffer = new agg::int8u[deststride*destheight];
        if (destbuffer == NULL)
        {
            throw Py::MemoryError("_tkagg could not allocate memory for destbuffer");
        }

        agg::rendering_buffer destrbuf;
        destrbuf.attach(destbuffer, destwidth, destheight, deststride);
        pixfmt destpf(destrbuf);
        renderer_base destrb(destpf);

        agg::rect_base<int> region(destx, desty, (int)r, srcheight - (int)b);
        destrb.copy_from(aggRenderer->renderingBuffer, &region,
                         -destx, -desty);
    }
    else
    {
        has_bbox = false;
        destbuffer = NULL;
        destx = desty = destwidth = destheight = deststride = 0;
    }

    /* setup tkblock */
    block.pixelSize = 1;
    if (mode == 0)
    {
        block.offset[0] = block.offset[1] = block.offset[2] = 0;
        nval = 1;
    }
    else
    {
        block.offset[0] = 0;
        block.offset[1] = 1;
        block.offset[2] = 2;
        if (mode == 1)
        {
            block.offset[3] = 0;
            block.pixelSize = 3;
            nval = 3;
        }
        else
        {
            block.offset[3] = 3;
            block.pixelSize = 4;
            nval = 4;
        }
    }

    if (has_bbox)
    {
        block.width  = destwidth;
        block.height = destheight;
        block.pitch = deststride;
        block.pixelPtr = destbuffer;

        Tk_PhotoPutBlock(photo, &block, destx, desty, destwidth, destheight);
        delete [] destbuffer;

    }
    else
    {
        block.width  = aggRenderer->get_width();
        block.height = aggRenderer->get_height();
        block.pitch = block.width * nval;
        block.pixelPtr =  aggRenderer->pixBuffer;

        /* Clear current contents */
        Tk_PhotoBlank(photo);
        /* Copy opaque block to photo image, and leave the rest to TK */
        Tk_PhotoPutBlock(photo, &block, 0, 0, block.width, block.height);
    }

    return TCL_OK;
}
Пример #15
0
int
Pg_execute(ClientData cData, Tcl_Interp *interp, int argc, CONST84 char *argv[])
{
	Pg_ConnectionId *connid;
	PGconn	   *conn;
	PGresult   *result;
	int			i;
	int			tupno;
	int			ntup;
	int			loop_rc;
	CONST84 char *oid_varname = NULL;
	CONST84 char *array_varname = NULL;
	char		buf[64];

	char	   *usage = "Wrong # of arguments\n"
	"pg_execute ?-array arrayname? ?-oid varname? "
	"connection queryString ?loop_body?";

	/*
	 * First we parse the options
	 */
	i = 1;
	while (i < argc)
	{
		if (argv[i][0] != '-')
			break;

		if (strcmp(argv[i], "-array") == 0)
		{
			/*
			 * The rows should appear in an array vs. to single variables
			 */
			i++;
			if (i == argc)
			{
				Tcl_SetResult(interp, usage, TCL_VOLATILE);
				return TCL_ERROR;
			}
			array_varname = argv[i++];
			continue;
		}

		if (strcmp(argv[i], "-oid") == 0)
		{
			/*
			 * We should place PQoidValue() somewhere
			 */
			i++;
			if (i == argc)
			{
				Tcl_SetResult(interp, usage, TCL_VOLATILE);
				return TCL_ERROR;
			}
			oid_varname = argv[i++];
			continue;
		}

		Tcl_AppendResult(interp, "Unknown option '", argv[i], "'", NULL);
		return TCL_ERROR;
	}

	/*
	 * Check that after option parsing at least 'connection' and 'query'
	 * are left
	 */
	if (argc - i < 2)
	{
		Tcl_SetResult(interp, usage, TCL_VOLATILE);
		return TCL_ERROR;
	}

	/*
	 * Get the connection and make sure no COPY command is pending
	 */
	conn = PgGetConnectionId(interp, argv[i++], &connid);
	if (conn == (PGconn *) NULL)
		return TCL_ERROR;

	if (connid->res_copyStatus != RES_COPY_NONE)
	{
		Tcl_SetResult(interp, "Attempt to query while COPY in progress", TCL_STATIC);
		return TCL_ERROR;
	}

	/*
	 * Execute the query
	 */
	result = PQexec(conn, argv[i++]);

	/*
	 * Transfer any notify events from libpq to Tcl event queue.
	 */
	PgNotifyTransferEvents(connid);

	/*
	 * Check for errors
	 */
	if (result == NULL)
	{
		Tcl_SetResult(interp, PQerrorMessage(conn), TCL_VOLATILE);
		return TCL_ERROR;
	}

	/*
	 * Set the oid variable to the returned oid of an INSERT statement if
	 * requested (or 0 if it wasn't an INSERT)
	 */
	if (oid_varname != NULL)
	{
		char		oid_buf[32];

		sprintf(oid_buf, "%u", PQoidValue(result));
		if (Tcl_SetVar(interp, oid_varname, oid_buf,
					   TCL_LEAVE_ERR_MSG) == NULL)
		{
			PQclear(result);
			return TCL_ERROR;
		}
	}

	/*
	 * Decide how to go on based on the result status
	 */
	switch (PQresultStatus(result))
	{
		case PGRES_TUPLES_OK:
			/* fall through if we have tuples */
			break;

		case PGRES_EMPTY_QUERY:
		case PGRES_COMMAND_OK:
		case PGRES_COPY_IN:
		case PGRES_COPY_OUT:
			/* tell the number of affected tuples for non-SELECT queries */
			Tcl_SetResult(interp, PQcmdTuples(result), TCL_VOLATILE);
			PQclear(result);
			return TCL_OK;

		default:
			/* anything else must be an error */
			Tcl_ResetResult(interp);
			Tcl_AppendElement(interp, PQresStatus(PQresultStatus(result)));
			Tcl_AppendElement(interp, PQresultErrorMessage(result));
			PQclear(result);
			return TCL_ERROR;
	}

	/*
	 * We reach here only for queries that returned tuples
	 */
	if (i == argc)
	{
		/*
		 * We don't have a loop body. If we have at least one result row,
		 * we set all the variables to the first one and return.
		 */
		if (PQntuples(result) > 0)
		{
			if (execute_put_values(interp, array_varname, result, 0) != TCL_OK)
			{
				PQclear(result);
				return TCL_ERROR;
			}
		}

		sprintf(buf, "%d", PQntuples(result));
		Tcl_SetResult(interp, buf, TCL_VOLATILE);
		PQclear(result);
		return TCL_OK;
	}

	/*
	 * We have a loop body. For each row in the result set put the values
	 * into the Tcl variables and execute the body.
	 */
	ntup = PQntuples(result);
	for (tupno = 0; tupno < ntup; tupno++)
	{
		if (execute_put_values(interp, array_varname, result, tupno) != TCL_OK)
		{
			PQclear(result);
			return TCL_ERROR;
		}

		loop_rc = Tcl_Eval(interp, argv[i]);

		/* The returncode of the loop body controls the loop execution */
		if (loop_rc == TCL_OK || loop_rc == TCL_CONTINUE)
			/* OK or CONTINUE means start next loop invocation */
			continue;
		if (loop_rc == TCL_RETURN)
		{
			/* RETURN means hand up the given interpreter result */
			PQclear(result);
			return TCL_RETURN;
		}
		if (loop_rc == TCL_BREAK)
			/* BREAK means leave the loop */
			break;

		PQclear(result);
		return TCL_ERROR;
	}

	/*
	 * At the end of the loop we put the number of rows we got into the
	 * interpreter result and clear the result set.
	 */
	sprintf(buf, "%d", ntup);
	Tcl_SetResult(interp, buf, TCL_VOLATILE);
	PQclear(result);
	return TCL_OK;
}
Пример #16
0
	/*ARGSUSED*/
static int
EmbWinLayoutProc(
    TkText *textPtr,		/* Text widget being layed out. */
    TkTextIndex *indexPtr,	/* Identifies first character in chunk. */
    TkTextSegment *ewPtr,	/* Segment corresponding to indexPtr. */
    int offset,			/* Offset within segPtr corresponding to
				 * indexPtr (always 0). */
    int maxX,			/* Chunk must not occupy pixels at this
				 * position or higher. */
    int maxChars,		/* Chunk must not include more than this many
				 * characters. */
    int noCharsYet,		/* Non-zero means no characters have been
				 * assigned to this line yet. */
    TkWrapMode wrapMode,	/* Wrap mode to use for line:
				 * TEXT_WRAPMODE_CHAR, TEXT_WRAPMODE_NONE, or
				 * TEXT_WRAPMODE_WORD. */
    register TkTextDispChunk *chunkPtr)
				/* Structure to fill in with information about
				 * this chunk. The x field has already been
				 * set by the caller. */
{
    int width, height;
    TkTextEmbWindowClient *client;

    if (offset != 0) {
	Tcl_Panic("Non-zero offset in EmbWinLayoutProc");
    }

    client = EmbWinGetClient(textPtr, ewPtr);
    if (client == NULL) {
	ewPtr->body.ew.tkwin = NULL;
    } else {
	ewPtr->body.ew.tkwin = client->tkwin;
    }

    if ((ewPtr->body.ew.tkwin == NULL) && (ewPtr->body.ew.create != NULL)) {
	int code, isNew;
	Tk_Window ancestor;
	Tcl_HashEntry *hPtr;
	const char *before, *string;
	Tcl_DString name, buf, *dsPtr = NULL;

	before = ewPtr->body.ew.create;

	/*
	 * Find everything up to the next % character and append it to the
	 * result string.
	 */

	string = before;
	while (*string != 0) {
	    if ((*string == '%') && (string[1] == '%' || string[1] == 'W')) {
		if (dsPtr == NULL) {
		    Tcl_DStringInit(&buf);
		    dsPtr = &buf;
		}
		if (string != before) {
		    Tcl_DStringAppend(dsPtr, before, (int) (string-before));
		    before = string;
		}
		if (string[1] == '%') {
		    Tcl_DStringAppend(dsPtr, "%", 1);
		} else {
		    /*
		     * Substitute string as proper Tcl list element.
		     */

		    int spaceNeeded, cvtFlags, length;
		    const char *str = Tk_PathName(textPtr->tkwin);

		    spaceNeeded = Tcl_ScanElement(str, &cvtFlags);
		    length = Tcl_DStringLength(dsPtr);
		    Tcl_DStringSetLength(dsPtr, length + spaceNeeded);
		    spaceNeeded = Tcl_ConvertElement(str,
			    Tcl_DStringValue(dsPtr) + length,
			    cvtFlags | TCL_DONT_USE_BRACES);
		    Tcl_DStringSetLength(dsPtr, length + spaceNeeded);
		}
		before += 2;
		string++;
	    }
	    string++;
	}

	/*
	 * The window doesn't currently exist. Create it by evaluating the
	 * creation script. The script must return the window's path name:
	 * look up that name to get back to the window token. Then register
	 * ourselves as the geometry manager for the window.
	 */

	if (dsPtr != NULL) {
	    Tcl_DStringAppend(dsPtr, before, (int) (string-before));
	    code = Tcl_GlobalEval(textPtr->interp, Tcl_DStringValue(dsPtr));
	    Tcl_DStringFree(dsPtr);
	} else {
	    code = Tcl_GlobalEval(textPtr->interp, ewPtr->body.ew.create);
	}
	if (code != TCL_OK) {
	createError:
	    Tcl_BackgroundException(textPtr->interp, code);
	    goto gotWindow;
	}
	Tcl_DStringInit(&name);
	Tcl_DStringAppend(&name, Tcl_GetStringResult(textPtr->interp), -1);
	Tcl_ResetResult(textPtr->interp);
	ewPtr->body.ew.tkwin = Tk_NameToWindow(textPtr->interp,
		Tcl_DStringValue(&name), textPtr->tkwin);
	Tcl_DStringFree(&name);
	if (ewPtr->body.ew.tkwin == NULL) {
	    goto createError;
	}
	for (ancestor = textPtr->tkwin; ; ancestor = Tk_Parent(ancestor)) {
	    if (ancestor == Tk_Parent(ewPtr->body.ew.tkwin)) {
		break;
	    }
	    if (Tk_TopWinHierarchy(ancestor)) {
	    badMaster:
		Tcl_AppendResult(textPtr->interp, "can't embed ",
			Tk_PathName(ewPtr->body.ew.tkwin), " relative to ",
			Tk_PathName(textPtr->tkwin), NULL);
		Tcl_BackgroundError(textPtr->interp);
		ewPtr->body.ew.tkwin = NULL;
		goto gotWindow;
	    }
	}
	if (Tk_TopWinHierarchy(ewPtr->body.ew.tkwin)
		|| (textPtr->tkwin == ewPtr->body.ew.tkwin)) {
	    goto badMaster;
	}

	if (client == NULL) {
	    /*
	     * We just used a '-create' script to make a new window, which we
	     * now need to add to our client list.
	     */

	    client = (TkTextEmbWindowClient *)
		    ckalloc(sizeof(TkTextEmbWindowClient));
	    client->next = ewPtr->body.ew.clients;
	    client->textPtr = textPtr;
	    client->tkwin = NULL;
	    client->chunkCount = 0;
	    client->displayed = 0;
	    client->parent = ewPtr;
	    ewPtr->body.ew.clients = client;
	}

	client->tkwin = ewPtr->body.ew.tkwin;
	Tk_ManageGeometry(client->tkwin, &textGeomType,
		(ClientData) client);
	Tk_CreateEventHandler(client->tkwin, StructureNotifyMask,
		EmbWinStructureProc, (ClientData) client);

	/*
	 * Special trick! Must enter into the hash table *after* calling
	 * Tk_ManageGeometry: if the window was already managed elsewhere in
	 * this text, the Tk_ManageGeometry call will cause the entry to be
	 * removed, which could potentially lose the new entry.
	 */

	hPtr = Tcl_CreateHashEntry(&textPtr->sharedTextPtr->windowTable,
		Tk_PathName(client->tkwin), &isNew);
	Tcl_SetHashValue(hPtr, ewPtr);
    }

    /*
     * See if there's room for this window on this line.
     */

  gotWindow:
    if (ewPtr->body.ew.tkwin == NULL) {
	width = 0;
	height = 0;
    } else {
	width = Tk_ReqWidth(ewPtr->body.ew.tkwin) + 2*ewPtr->body.ew.padX;
	height = Tk_ReqHeight(ewPtr->body.ew.tkwin) + 2*ewPtr->body.ew.padY;
    }
    if ((width > (maxX - chunkPtr->x))
	    && !noCharsYet && (textPtr->wrapMode != TEXT_WRAPMODE_NONE)) {
	return 0;
    }

    /*
     * Fill in the chunk structure.
     */

    chunkPtr->displayProc = TkTextEmbWinDisplayProc;
    chunkPtr->undisplayProc = EmbWinUndisplayProc;
    chunkPtr->measureProc = NULL;
    chunkPtr->bboxProc = EmbWinBboxProc;
    chunkPtr->numBytes = 1;
    if (ewPtr->body.ew.align == ALIGN_BASELINE) {
	chunkPtr->minAscent = height - ewPtr->body.ew.padY;
	chunkPtr->minDescent = ewPtr->body.ew.padY;
	chunkPtr->minHeight = 0;
    } else {
	chunkPtr->minAscent = 0;
	chunkPtr->minDescent = 0;
	chunkPtr->minHeight = height;
    }
    chunkPtr->width = width;
    chunkPtr->breakIndex = -1;
    chunkPtr->breakIndex = 1;
    chunkPtr->clientData = (ClientData) ewPtr;
    if (client != NULL) {
	client->chunkCount += 1;
    }
    return 1;
}
Пример #17
0
int
TclpMatchInDirectory(
    Tcl_Interp *interp,		/* Interpreter to receive errors. */
    Tcl_Obj *resultPtr,		/* List object to lappend results. */
    Tcl_Obj *pathPtr,		/* Contains path to directory to search. */
    CONST char *pattern,	/* Pattern to match against. */
    Tcl_GlobTypeData *types)	/* Object containing list of acceptable types.
				 * May be NULL. In particular the directory
				 * flag is very important. */
{
    CONST char *native;
    Tcl_Obj *fileNamePtr;
    int matchResult = 0;

    if (types != NULL && types->type == TCL_GLOB_TYPE_MOUNT) {
	/*
	 * The native filesystem never adds mounts.
	 */

	return TCL_OK;
    }

    fileNamePtr = Tcl_FSGetTranslatedPath(interp, pathPtr);
    if (fileNamePtr == NULL) {
	return TCL_ERROR;
    }

    if (pattern == NULL || (*pattern == '\0')) {
	/*
	 * Match a file directly.
	 */
	Tcl_Obj *tailPtr;
	CONST char *nativeTail;

	native = (CONST char*) Tcl_FSGetNativePath(pathPtr);
	tailPtr = TclPathPart(interp, pathPtr, TCL_PATH_TAIL);
	nativeTail = (CONST char*) Tcl_FSGetNativePath(tailPtr);
	matchResult = NativeMatchType(interp, native, nativeTail, types);
	if (matchResult == 1) {
	    Tcl_ListObjAppendElement(interp, resultPtr, pathPtr);
	}
	Tcl_DecrRefCount(tailPtr);
	Tcl_DecrRefCount(fileNamePtr);
    } else {
	DIR *d;
	Tcl_DirEntry *entryPtr;
	CONST char *dirName;
	int dirLength;
	int matchHidden, matchHiddenPat;
	int nativeDirLen;
	Tcl_StatBuf statBuf;
	Tcl_DString ds;		/* native encoding of dir */
	Tcl_DString dsOrig;	/* utf-8 encoding of dir */

	Tcl_DStringInit(&dsOrig);
	dirName = Tcl_GetStringFromObj(fileNamePtr, &dirLength);
	Tcl_DStringAppend(&dsOrig, dirName, dirLength);

	/*
	 * Make sure that the directory part of the name really is a
	 * directory.  If the directory name is "", use the name "." instead,
	 * because some UNIX systems don't treat "" like "." automatically.
	 * Keep the "" for use in generating file names, otherwise "glob
	 * foo.c" would return "./foo.c".
	 */

	if (dirLength == 0) {
	    dirName = ".";
	} else {
	    dirName = Tcl_DStringValue(&dsOrig);

	    /*
	     * Make sure we have a trailing directory delimiter.
	     */

	    if (dirName[dirLength-1] != '/') {
		dirName = Tcl_DStringAppend(&dsOrig, "/", 1);
		dirLength++;
	    }
	}

	/*
	 * Now open the directory for reading and iterate over the contents.
	 */

	native = Tcl_UtfToExternalDString(NULL, dirName, -1, &ds);

	if ((TclOSstat(native, &statBuf) != 0)		/* INTL: Native. */
		|| !S_ISDIR(statBuf.st_mode)) {
	    Tcl_DStringFree(&dsOrig);
	    Tcl_DStringFree(&ds);
	    Tcl_DecrRefCount(fileNamePtr);
	    return TCL_OK;
	}

	d = opendir(native);				/* INTL: Native. */
	if (d == NULL) {
	    Tcl_DStringFree(&ds);
	    if (interp != NULL) {
		Tcl_ResetResult(interp);
		Tcl_AppendResult(interp, "couldn't read directory \"",
			Tcl_DStringValue(&dsOrig), "\": ",
			Tcl_PosixError(interp), (char *) NULL);
	    }
	    Tcl_DStringFree(&dsOrig);
	    Tcl_DecrRefCount(fileNamePtr);
	    return TCL_ERROR;
	}

	nativeDirLen = Tcl_DStringLength(&ds);

	/*
	 * Check to see if -type or the pattern requests hidden files.
	 */

	matchHiddenPat = (pattern[0] == '.')
		|| ((pattern[0] == '\\') && (pattern[1] == '.'));
	matchHidden = matchHiddenPat 
		|| (types && (types->perm & TCL_GLOB_PERM_HIDDEN));
	while ((entryPtr = TclOSreaddir(d)) != NULL) {	/* INTL: Native. */
	    Tcl_DString utfDs;
	    CONST char *utfname;

	    /*
	     * Skip this file if it doesn't agree with the hidden parameters
	     * requested by the user (via -type or pattern).
	     */

	    if (*entryPtr->d_name == '.') {
		if (!matchHidden) continue;
	    } else {
#ifdef MAC_OSX_TCL
		if (matchHiddenPat) continue;
		/* Also need to check HFS hidden flag in TclMacOSXMatchType. */
#else
		if (matchHidden) continue;
#endif
	    }

	    /*
	     * Now check to see if the file matches, according to both type
	     * and pattern. If so, add the file to the result.
	     */

	    utfname = Tcl_ExternalToUtfDString(NULL, entryPtr->d_name, -1,
		    &utfDs);
	    if (Tcl_StringCaseMatch(utfname, pattern, 0)) {
		int typeOk = 1;

		if (types != NULL) {
		    Tcl_DStringSetLength(&ds, nativeDirLen);
		    native = Tcl_DStringAppend(&ds, entryPtr->d_name, -1);
		    matchResult = NativeMatchType(interp, native,
			    entryPtr->d_name, types);
		    typeOk = (matchResult == 1);
		}
		if (typeOk) {
		    Tcl_ListObjAppendElement(interp, resultPtr,
			    TclNewFSPathObj(pathPtr, utfname,
			    Tcl_DStringLength(&utfDs)));
		}
	    }
	    Tcl_DStringFree(&utfDs);
	    if (matchResult < 0) {
		break;
	    }
	}

	closedir(d);
	Tcl_DStringFree(&ds);
	Tcl_DStringFree(&dsOrig);
	Tcl_DecrRefCount(fileNamePtr);
    }
    if (matchResult < 0) {
	return TCL_ERROR;
    } else {
	return TCL_OK;
    }
}
Пример #18
0
int adress_set(Tcl_Interp *interp,int argc, char **argv){
   int topo=-1,i,wf=0,set_center=0;
   double width[2],center[3];
   char buffer[3*TCL_DOUBLE_SPACE];
   argv+=2;argc-=2;

   for(i=0;i<3;i++) center[i]=box_l[i]/2;

   if (argc < 2) {
      Tcl_ResetResult(interp);
      Tcl_AppendResult(interp, "Wrong # of args! adress set needs at least 2 arguments\n", (char *)NULL);
      Tcl_AppendResult(interp, "Usage: adress set topo [0|1|2|3] width X.X Y.Y (center X.X Y.Y Z.Z) (wf [0|1])\n", (char *)NULL);
      Tcl_AppendResult(interp, "topo:   0 - switched off (no more values needed)\n", (char *)NULL);
      Tcl_AppendResult(interp, "        1 - constant (weight will be first value of width)\n", (char *)NULL);
      Tcl_AppendResult(interp, "        2 - divided in one direction (default x, or give a negative center coordinate\n", (char *)NULL);
      Tcl_AppendResult(interp, "        3 - spherical topology\n", (char *)NULL);
      Tcl_AppendResult(interp, "width:  X.X  - half of size of ex zone(r0/2 in the papers)\n", (char *)NULL);
      Tcl_AppendResult(interp, "        Y.Y  - size of hybrid zone (d in the papers)\n", (char *)NULL);
      Tcl_AppendResult(interp, "        Note: Only one value need for topo 1 \n", (char *)NULL);
      Tcl_AppendResult(interp, "center: center of the ex zone (default middle of the box) \n", (char *)NULL);
      Tcl_AppendResult(interp, "        Note: x|y|x X.X for topo 2  \n", (char *)NULL);
      Tcl_AppendResult(interp, "        Note: X.X Y.Y Z.Z for topo 3  \n", (char *)NULL);
      Tcl_AppendResult(interp, "wf:     0 - cos weighting function (default)\n", (char *)NULL);
      Tcl_AppendResult(interp, "        1 - polynom weighting function\n", (char *)NULL);
      Tcl_AppendResult(interp, "ALWAYS set box_l first !!!", (char *)NULL);
      return (TCL_ERROR);
   }

   //parse topo
   if ( (argc<2) || (!ARG0_IS_S("topo"))  || (!ARG1_IS_I(topo)) || (topo < 0) || (topo > 3) ) {
      Tcl_ResetResult(interp);
      Tcl_AppendResult(interp, "expected \'topo 0|1|2|3\'\n", (char *)NULL);
      return (TCL_ERROR);
   }
   argv+=2;argc-=2;
   
   //stop if topo is 0
   if (topo==0) {
      adress_vars[0]=0.0;
      mpi_bcast_parameter(FIELD_ADRESS);
      return TCL_OK;
   }

   //parse width
   if ( (argc>1) && (ARG0_IS_S("width")) ) {
      if (topo==1) {
         if ( (!ARG1_IS_D(width[0])) || (width[0]<0) ){
            Tcl_ResetResult(interp);
            Tcl_AppendResult(interp, "expected \'width X.X (X.X non-negative)\'", (char *)NULL);
            return (TCL_ERROR);
         }
         if ((width[0]> 1.0) || (width[0]< 0.0)) {
            Tcl_ResetResult(interp);
            Tcl_AppendResult(interp, "for constant topo, first width must be between 0 and 1", (char *)NULL);
            return (TCL_ERROR);
         }
         //stop if topo is 1
         adress_vars[0]=1;
         adress_vars[1]=width[0];
         mpi_bcast_parameter(FIELD_ADRESS);
         return TCL_OK;
      }
      else {//topo 2 and 3 are left over
         if ( (argc<3) || (!ARG1_IS_D(width[0])) || (width[0]<0) ||(!ARG_IS_D(2,width[1])) || (width[1]<0) ){
            Tcl_ResetResult(interp);
            Tcl_AppendResult(interp, "expected \'width X.X Y.Y (both non-negative)\'", (char *)NULL);
            return (TCL_ERROR);
         }
         argv+=3;argc-=3;
      }
   }
   else{
      Tcl_ResetResult(interp);
      Tcl_AppendResult(interp, "expected \'width\'", (char *)NULL);
      return (TCL_ERROR);
   }

   while (argc!=0){
      if (ARG0_IS_S("wf")){
         if ( (argc<2) || (!ARG1_IS_I(wf)) || (wf < 0) || (wf > 1) ){
            Tcl_ResetResult(interp);
            Tcl_AppendResult(interp, "expected \'wf 0|1\'", (char *)NULL);
            return (TCL_ERROR);
         }
         else{
            argv+=2;argc-=2;
         }
      }
      else if (ARG0_IS_S("center")){
         if (topo == 2) {
            if ( (argc<3) || ( (!ARG1_IS_S("x"))&&(!ARG1_IS_S("y"))&&(!ARG1_IS_S("z")) ) || (!ARG_IS_D(2,center[1])) ){
               Tcl_ResetResult(interp);
               Tcl_AppendResult(interp, "expected \'center x|y|z X.X\'", (char *)NULL);
               return (TCL_ERROR);
            }
            if (ARG1_IS_S("x")) center[0]=0;
            else if  (ARG1_IS_S("y")) center[0]=1;
            else center[0]=2;
            if ( (center[1]<0) || (center[1]>box_l[(int)center[0]]) ) {
               Tcl_ResetResult(interp);
               Tcl_AppendResult(interp, "The center component is outside the box", (char *)NULL);
               return (TCL_ERROR);
            }
            set_center=1;
            argv+=3;argc-=3;
         }
         else  { //topo 3
            if ( (argc<4) || (!ARG_IS_D(1,center[0])) || (!ARG_IS_D(2,center[1])) || (!ARG_IS_D(3,center[2])) ){
               Tcl_ResetResult(interp);
               Tcl_AppendResult(interp, "expected \'center X.X Y.Y Z.Z\'", (char *)NULL);
               return (TCL_ERROR);
            }
            argv+=4;argc-=4;
            //check components of center
            for (i=0;i<3;i++){
               if ( (center[i]<0)||(center[i]>box_l[i]) ){
                  Tcl_ResetResult(interp);
                  sprintf(buffer,"%i",i);
                  Tcl_AppendResult(interp, "The ",buffer," th component of center is outside the box\n", (char *)NULL);
                  return (TCL_ERROR);
               }
            }
         }
      }
      else{
         Tcl_ResetResult(interp);
         Tcl_AppendResult(interp, "The unknown operation \"", argv[0],"\".", (char *)NULL);
         return (TCL_ERROR);
      }
   }

   //set standard center value for topo 2
   if ((topo==2) && (set_center==0) ) center[0]=0;

   //width check
   if (topo==2){
      if (width[0]+width[1]>box_l[(int)center[0]]/2){
         Tcl_ResetResult(interp);
         Tcl_AppendResult(interp, "The width of ex+hy must smaller than box_l/2\n", (char *)NULL);
         return (TCL_ERROR);
      }
   }
   else if (topo==3){
      for (i=0;i<3;i++){
         if (width[0]+width[1]>box_l[i]/2){
            Tcl_ResetResult(interp);
            sprintf(buffer,"%i",i);
            Tcl_AppendResult(interp, "The width of ex+hy must smaller than box_l/2 in dim " ,buffer,"\n", (char *)NULL);
            return (TCL_ERROR);
         }
      }
   }

   adress_vars[0]=topo;
   adress_vars[1]=width[0];
   adress_vars[2]=width[1];
   adress_vars[3]=center[0];
   adress_vars[4]=center[1];
   adress_vars[5]=center[2];
   adress_vars[6]=wf;

   mpi_bcast_parameter(FIELD_ADRESS);

   return TCL_OK;
}
Пример #19
0
/*!
 tux_open_courses Tcl callback
 \author  jfpatry
 \date    Created:  2000-09-19
 \date    Modified: 2000-09-19
 */
static int open_courses_cb( ClientData cd, Tcl_Interp *ip,
                            int argc, const char **argv )
{
    char *err_msg;
    const char **list = NULL;
    int num_courses;
    list_elem_t last_elem = NULL;
    list_elem_t last_speed_elem = NULL;
    list_elem_t last_score_elem = NULL;
    int i, j;
    char preview_file[100];

    check_assertion( initialized,
                     "course_mgr module not initialized" );

    if ( argc != 2 ) {
        err_msg = "Wrong number of arguments";
        goto bail_open_courses;
    }

    if ( Tcl_SplitList( ip, argv[1], &num_courses, &list ) == TCL_ERROR ) {
        err_msg = "Argument is not a list";
        goto bail_open_courses;
    }

    /* Add items to end of list */
    last_elem = get_list_tail( open_course_list );
    last_speed_elem = get_list_tail( speed_course_list );
    last_score_elem = get_list_tail( score_course_list );

    for ( i=0; i<num_courses; i++ ) {
        open_course_data_t *data;
        data = create_open_course_data( ip, list[i], &err_msg );

#ifdef __ANDROID__
        sprintf(preview_file, "courses/%s/preview.jpg", data->course);
#else
        sprintf(preview_file, "%s/courses/%s/preview.jpg", getparam_data_dir(), data->course);
#endif

        load_texture(data->course, preview_file, 1);
        bind_texture(data->course, data->course);

        if ( data == NULL ) {
            goto bail_open_courses;
        }

        last_elem = insert_list_elem(
                        open_course_list,
                        last_elem,
                        (list_elem_data_t) data );
        if(data->speed)
        {
            last_speed_elem = insert_list_elem(
                                  speed_course_list,
                                  last_speed_elem,
                                  (list_elem_data_t) data );
        }
        if(data->score)
        {
            last_score_elem = insert_list_elem(
                                  score_course_list,
                                  last_score_elem,
                                  (list_elem_data_t) data );
        }

    }

    Tcl_Free( (char*) list );
    list = NULL;

    return TCL_OK;

bail_open_courses:

    /* We'll leave the data that was successfully added in the list. */

    Tcl_AppendResult(
        ip,
        "Error in call to tux_open_courses: ",
        err_msg,
        "\n",
        "Usage: tux_open_courses { list of open courses }",
        (NULL) );
    return TCL_ERROR;
}
Пример #20
0
int tclcommand_analyze_parse_and_print_energy(Tcl_Interp *interp, int argc, char **argv)
{
  /* 'analyze energy [{ fene <type_num> | harmonic <type_num> | subt_lj_harm <type_num> | subt_lj_fene <type_num> | subt_lj <type_num> | lj <type1> <type2> | ljcos <type1> <type2> | ljcos2 <type1> <type2> | gb <type1> <type2> | coulomb | kinetic | total }]' */
  char buffer[TCL_DOUBLE_SPACE + TCL_INTEGER_SPACE + 2];
  int i, j;
  double value;
  value = 0.0;
  if (n_part == 0) {
    Tcl_AppendResult(interp, "(no particles)",
		     (char *)NULL);
    return (TCL_OK);
  }

  if (total_energy.init_status == 0) {
    init_energies(&total_energy);
    master_energy_calc();
  }

  if (argc == 0)
    tclcommand_analyze_print_all(interp);
  else {

    if      (ARG0_IS_S("kinetic"))
      value = total_energy.data.e[0];
    else if (ARG0_IS_S("bonded") ||
	     ARG0_IS_S("fene") ||
	     ARG0_IS_S("subt_lj_harm") ||
	     ARG0_IS_S("subt_lj_fene") ||
	     ARG0_IS_S("subt_lj") ||
	     ARG0_IS_S("harmonic") ||
       ARG0_IS_S("umbrella") || 
	     ARG0_IS_S("endangledist")) {
      if(argc<2 || ! ARG1_IS_I(i)) {
	Tcl_ResetResult(interp);
	Tcl_AppendResult(interp, "wrong # or type of arguments for: analyze energy bonded <type_num>",
			 (char *)NULL);
	return (TCL_ERROR);
      }
      if(i < 0 || i >= n_bonded_ia) {
	Tcl_AppendResult(interp, "bond type does not exist", (char *)NULL);
	return (TCL_ERROR);
      }
      value = *obsstat_bonded(&total_energy, i);
    }
    else if (ARG0_IS_S("nonbonded") ||
	     ARG0_IS_S("lj") ||
	     ARG0_IS_S("buckingham") ||
	     ARG0_IS_S("lj-cos") ||
             ARG0_IS_S("lj-cos2") ||
       ARG0_IS_S("cos2") ||
	     ARG0_IS_S("gb") ||
	     ARG0_IS_S("tabulated")) {
      if(argc<3 || ! ARG_IS_I(1, i) || ! ARG_IS_I(2, j)) {
	Tcl_ResetResult(interp);
	Tcl_AppendResult(interp, "wrong # or type of arguments for: analyze energy nonbonded <type1> <type2>",
			 (char *)NULL);
	return (TCL_ERROR);
      }
      if(i < 0 || i >= n_particle_types || j < 0 || j >= n_particle_types) {
	Tcl_AppendResult(interp, "particle type does not exist", (char *)NULL);
	return (TCL_ERROR);
      }
      value = *obsstat_nonbonded(&total_energy, i, j);
    }
 
    else if( ARG0_IS_S("coulomb")) {
#ifdef ELECTROSTATICS
      value = 0;
      for (i = 0; i < total_energy.n_coulomb; i++)
	value += total_energy.coulomb[i];
#else
      Tcl_AppendResult(interp, "ELECTROSTATICS not compiled (see myconfig.hpp)\n", (char *)NULL);
#endif
    }    
    else if( ARG0_IS_S("magnetic")) {
#ifdef DIPOLES
      value = 0;
      for (i = 0; i < total_energy.n_dipolar; i++)
	value += total_energy.dipolar[i];
#else
      Tcl_AppendResult(interp, "DIPOLES not compiled (see myconfig.hpp)\n", (char *)NULL);
#endif
    }
    
    else if (ARG0_IS_S("total")) {
      value = total_energy.data.e[0];
      for (i = 1; i < total_energy.data.n; i++)
	value += total_energy.data.e[i];
      for (i = 0; i < n_external_potentials; i++) {
        value += external_potentials[i].energy;
      }

    }
    else {
      Tcl_AppendResult(interp, "unknown feature of: analyze energy",
		       (char *)NULL);
      return (TCL_ERROR);
    }
    Tcl_PrintDouble(interp, value, buffer);
    Tcl_AppendResult(interp, buffer, (char *)NULL);
  }

  return (TCL_OK);
}
Пример #21
0
int tclcommand_metadynamics_parse_load_stat(Tcl_Interp *interp, int argc, char **argv){
  /* Parse free energy profile and biased force that were provided from an 
   * earlier simulation. Allows one to restart from a loaded state, and can 
   * even be used to allow multiple walkers communicating their data through TCL. */
  
  if(meta_switch == META_OFF) {
    Tcl_AppendResult(interp, "Metadynamics hasn't been initialized yet", (char *)NULL);
    return (TCL_ERROR);
  }
							       
  argc -= 1; argv += 1;
  
  // There should be
  if (argc != 3) {
    Tcl_AppendResult(interp, "Incorrect number of arguments: 'metadynamics load_stat <profile_list> <force_list>'", (char *)NULL);
    return (TCL_ERROR);
  }
							       
  // load free energy profile
  int i, tmp_argc, parse_error = 0, empty_line=0;
  char  **tmp_argv;
  DoubleList profile, force;
  
  init_doublelist(&profile);
  Tcl_ResetResult(interp);
  Tcl_SplitList(interp, argv[1], &tmp_argc, (const char ***)&tmp_argv);
  realloc_doublelist(&profile, profile.n = tmp_argc);
  //printf("profile.n %d, meta_xi_num_bins %d\n",profile.n,meta_xi_num_bins);
  /* Now check that the number of items parsed is equal to the number of bins */
  /* If there's one extra line, assume it's an empty line */
  if (profile.n == meta_xi_num_bins+1)
      empty_line = 1;
  else if (profile.n != meta_xi_num_bins) {
      Tcl_AppendResult(interp, "Size of profile list loaded is different than expected from number of bins", (char *)NULL);
      return (TCL_ERROR);
  }
  /* call meta_init() in case it has been loaded yet */
  meta_init();
  
  for(i = 0 ; i < tmp_argc-empty_line; i++) {
    int tmp_argc2;
    char  **tmp_argv2;
    Tcl_SplitList(interp, tmp_argv[i], &tmp_argc2, (const char ***)&tmp_argv2);
    if (tmp_argc2 != 1) {
      Tcl_AppendResult(interp, "data set has to be a list of doubles", (char *) NULL);
      parse_error = 1; break;
    }
    if (Tcl_GetDouble(interp, tmp_argv2[0], &(profile.e[i])) == TCL_ERROR) { parse_error = 1; break; }
    /* Load data into meta_acc_fprofile */
    meta_acc_fprofile[i] = profile.e[i];
    
    Tcl_Free((char *)tmp_argv2);
  }
  Tcl_Free((char *)tmp_argv);
  if (parse_error) return TCL_ERROR;   
 

  // load force
  argc -= 1; argv += 1;
  init_doublelist(&force);
  Tcl_ResetResult(interp);
  Tcl_SplitList(interp, argv[1], &tmp_argc, (const char ***)&tmp_argv);
  realloc_doublelist(&force, force.n = tmp_argc);
  /* Now check that the number of items parsed is equal to the number of bins */
  if (profile.n == meta_xi_num_bins+1)
      empty_line = 1;
  else if (profile.n != meta_xi_num_bins) {
    Tcl_AppendResult(interp, "Size of force list loaded is different than expected from number of bins", (char *)NULL);
    return (TCL_ERROR);
  }
  for(i = 0 ; i < tmp_argc-empty_line; i++) {
    int tmp_argc2;
    char  **tmp_argv2;
    Tcl_SplitList(interp, tmp_argv[i], &tmp_argc2, (const char ***)&tmp_argv2);
    if (tmp_argc2 != 1) {
      Tcl_AppendResult(interp, "data set has to be a list of doubles", (char *) NULL);
      parse_error = 1; break;
    }
    if (Tcl_GetDouble(interp, tmp_argv2[0], &(force.e[i])) == TCL_ERROR) { parse_error = 1; break; }
    /* Load data into meta_acc_fprofile */
    meta_acc_force[i] = -1.*force.e[i];
    
    Tcl_Free((char *)tmp_argv2);
  }
  Tcl_Free((char *)tmp_argv);
  if (parse_error) return TCL_ERROR;   

  return (TCL_OK);
}
Пример #22
0
static void tclcommand_analyze_print_all(Tcl_Interp *interp)
{
  char buffer[TCL_DOUBLE_SPACE + TCL_INTEGER_SPACE + 2];
  double value;
  int i, j;

  value = total_energy.data.e[0];
  for (i = 1; i < total_energy.data.n; i++)
    value += total_energy.data.e[i];
  
  for (i = 0; i < n_external_potentials; i++) {
    value+=external_potentials[i].energy;
  }

  Tcl_PrintDouble(interp, value, buffer);
  Tcl_AppendResult(interp, "{ energy ", buffer, " } ", (char *)NULL);

  Tcl_PrintDouble(interp, total_energy.data.e[0], buffer);
  Tcl_AppendResult(interp, "{ kinetic ", buffer, " } ", (char *)NULL);

  for(i=0;i<n_bonded_ia;i++) {
    if (bonded_ia_params[i].type != BONDED_IA_NONE) {
      sprintf(buffer, "%d ", i);
      Tcl_AppendResult(interp, "{ ", buffer, (char *)NULL);
      Tcl_PrintDouble(interp, *obsstat_bonded(&total_energy, i), buffer);
      Tcl_AppendResult(interp,
		       get_name_of_bonded_ia(bonded_ia_params[i].type),
		       " ", buffer, " } ", (char *) NULL);
    }
  }

  for (i = 0; i < n_particle_types; i++)
    for (j = i; j < n_particle_types; j++) {
      if (checkIfParticlesInteract(i, j)) {
	sprintf(buffer, "%d ", i);
	Tcl_AppendResult(interp, "{ ", buffer, (char *)NULL);
	sprintf(buffer, "%d ", j);
	Tcl_AppendResult(interp, " ", buffer, (char *)NULL);
	Tcl_PrintDouble(interp, *obsstat_nonbonded(&total_energy, i, j), buffer);
	Tcl_AppendResult(interp, "nonbonded ", buffer, " } ", (char *)NULL);	    
      }
    }

#if defined(ELECTROSTATICS) || defined(DIPOLES)
  if(
#if defined(ELECTROSTATICS) && defined(DIPOLES) 
     coulomb.method != COULOMB_NONE || coulomb.Dmethod != DIPOLAR_NONE
#elif defined(ELECTROSTATICS)
     coulomb.method != COULOMB_NONE
#elif defined(DIPOLES)     
     coulomb.Dmethod != DIPOLAR_NONE
#endif
     ) {
    /* total Coulomb energy */
    value = 0;
    for (i = 0; i < total_energy.n_coulomb; i++)
      value += total_energy.coulomb[i];
    for (i = 0; i < total_energy.n_dipolar; i++)
      value += total_energy.dipolar[i];
    Tcl_PrintDouble(interp, value, buffer);
    
#if defined(ELECTROSTATICS) && defined(DIPOLES) 
    Tcl_AppendResult(interp, "{ coulomb+magdipoles ", buffer, (char *)NULL);  
#elif defined(ELECTROSTATICS)
    Tcl_AppendResult(interp, "{ coulomb ", buffer, (char *)NULL);
#elif defined(DIPOLES)
    Tcl_AppendResult(interp, "{ magdipoles ", buffer, (char *)NULL);  
#endif

    /* if it is split up, then print the split up parts */
#ifdef ELECTROSTATICS
    if (total_energy.n_coulomb > 1) {
      for (i = 0; i < total_energy.n_coulomb; i++) {
	Tcl_PrintDouble(interp, total_energy.coulomb[i], buffer);
	Tcl_AppendResult(interp, " ", buffer, (char *)NULL);
      }
    }
    Tcl_AppendResult(interp, " }", (char *)NULL);
#endif

#ifdef DIPOLES
    if (total_energy.n_dipolar > 1) {
      for (i = 0; i < total_energy.n_dipolar; i++) {
 	Tcl_PrintDouble(interp, total_energy.dipolar[i], buffer);
	Tcl_AppendResult(interp, " ", buffer, (char *)NULL);
      }
    }
#endif
  }

#endif
  if (n_external_potentials > 0) {
	  Tcl_AppendResult(interp, " { external_potential", (char *)NULL);
    for (i = 0; i < n_external_potentials; i++) {
 	    Tcl_PrintDouble(interp, external_potentials[i].energy, buffer);
	    Tcl_AppendResult(interp, " ", buffer, (char *)NULL);
    }
  }

}
Пример #23
0
/** The main function.

    The function implementing the algorithm described in

    arXiv:hep-lat/0306017 v1 13 Jun 2003 \em Wolff, U. \em Monte Carlo errors with less errors.
*/
int UWerr_f(Tcl_Interp *interp, Tcl_CmdInfo * cmdInfo, int argc, char ** argv,
	    double ** data, int rows, int cols,
	    int * n_rep, int len, double s_tau, int plot)
{
  struct UWerr_t ret;
  int a, k, i, sum = 0, W_opt = 0, W_max = 0;
  double Fbb = 0, bF = 0, Fb = 0, * abb = 0L, tau = 0, tmp;
  double ** abr = 0L, * Fbr = 0L, * fgrad = 0L, * delpro = 0L;
  double * gFbb = 0L, CFbb_opt = 0, G_int = 0, std_a;
  char flag = 0;
  char * str = 0L;
  char * tcl_vector = 0L;
  char ** my_argv;

  FILE * plotDataf, * plotScriptf;

  ret.Q_val = 0;

  if (!data) {
    Tcl_AppendElement(interp, "No data matrix given.");
    return TCL_ERROR;
  }
  if (rows < 1) {
    Tcl_AppendElement(interp, "Data matrix has no rows.");
    return TCL_ERROR;
  }
  if (cols < 1) {
    Tcl_AppendElement(interp, "Data matrix has no columns.");
    return TCL_ERROR;
  }
  if(!cmdInfo && !cmdInfo->proc) {
    Tcl_AppendElement(interp, "No function to call given.");
    return TCL_ERROR;
  }
  if (!n_rep) {
    Tcl_AppendElement(interp, "No representations vector given.");
    return TCL_ERROR;
  }
  if (len < 1) {
    Tcl_AppendElement(interp, "Representations vector is empty.");
    return TCL_ERROR;
  }
  
  /* \sum_{i=1}^{len} n_rep[i-1] = rows */

  k = rows; /* for now k is going to be min(n_rep) */
  for (i = 0; i < len; ++i) {
    sum += n_rep[i];
    if (n_rep[i] < k)
      k = n_rep[i];
  }

  if (sum != rows || k <= 0) {
    Tcl_AppendElement(interp, "Representations vector is invalid.");
    return TCL_ERROR;
  }

  if (s_tau > 0) {
    W_max = (int)rint(k/2.); /* until here: k = min(n_rep) */
    flag = 1;
    if (W_max < 1) W_max = 1;
  }

  /* string for output of numbers */
  str = (char *)malloc((TCL_INTEGER_SPACE + TCL_DOUBLE_SPACE)*sizeof(char));

  if (!(delpro = (double*)malloc(rows*sizeof(double)))) {
    Tcl_AppendResult(interp, "Out of Memory.", __LINE__, (char *) NULL);
    free(str);
    return TCL_ERROR;
  }

  if (!(Fbr = (double*)malloc(len*sizeof(double)))) {
    free(delpro);
    free(str);
    Tcl_AppendResult(interp, "Out of Memory.", __LINE__, (char *) NULL);
    return TCL_ERROR;
  }

  if (!(fgrad = (double*)malloc(cols*sizeof(double)))) {
    free(delpro);
    free(Fbr);
    free(str);
    Tcl_AppendResult(interp, "Out of Memory.", __LINE__, (char *) NULL);
    return TCL_ERROR;
  }

  if (!(abb = (double*)malloc(cols*sizeof(double)))) {
    free(delpro);
    free(Fbr);
    free(fgrad);
    free(str);
    Tcl_AppendResult(interp, "Out of Memory.", __LINE__, (char *) NULL);
    return TCL_ERROR;
  }

  /* abr \in (\Real)_{len, cols} */
  if (!(abr = (double**)malloc(len*sizeof(double*)))) {
    free(delpro);
    free(Fbr);
    free(fgrad);
    free(abb);
    free(str);
    Tcl_AppendResult(interp, "Out of Memory.", __LINE__, (char *) NULL);
    return TCL_ERROR;
  }
  for (i = 0; i < len; ++i)
    if (!(abr[i] = (double*)malloc(cols*sizeof(double)))) {
      for (k = 0; k < i; ++k)
	free(abr[k]);

      free(abr);
      free(delpro);
      free(Fbr);
      free(fgrad);
      free(abb);
      free(str);
    
      Tcl_AppendResult(interp, "Out of Memory.", __LINE__, (char *) NULL);
      return TCL_ERROR;
    }

  
  if (W_max > 0) {
    if (!(gFbb = (double*)malloc((W_max+1)*sizeof(double)))) {
      free(delpro);
      free(Fbr);
      free(fgrad);
      free(abb);
      for (k = 0; k < len; ++k)
	free(abr[k]);
      free(abr);

      free(str);
      Tcl_AppendResult(interp, "Out of Memory.", __LINE__, (char *) NULL);
      return TCL_ERROR;
    }
  }
  
  if (uwerr_create_tcl_vector(&tcl_vector, cols)) {
      free(delpro);
      free(Fbr);
      free(fgrad);
      free(abb);
      for (k = 0; k < len; ++k)
	free(abr[k]);
      free(abr);
      free(gFbb);

      free(str);
      Tcl_AppendResult(interp, "Out of Memory.", __LINE__, (char *) NULL);
      return TCL_ERROR;
  }

  if (!(my_argv=(char**)malloc((argc+1)*sizeof(char*)))) {
      free(delpro);
      free(Fbr);
      free(fgrad);
      free(abb);
      for (k = 0; k < len; ++k)
	free(abr[k]);
      free(abr);
      free(gFbb);

      free(str);
      uwerr_free_tcl_vector(tcl_vector);
      Tcl_AppendResult(interp, "Out of Memory.", __LINE__, (char *) NULL);
      return TCL_ERROR;
  }

  my_argv[0] = argv[0];
  my_argv[1] = tcl_vector;
  for (i = 1; i < argc; ++i)
    my_argv[i+1] = argv[i];


  /* first we calculate N_r\bar{a}_\alpha^r \forall r, alpha */
  
  sum = 0;
  for (k = 0; k < len; ++k) {
    for (i = 0; i < n_rep[k]; ++i) {
      for (a = 0; a < cols; ++a) {
	if (i > 0)
	  abr[k][a] += data[sum + i][a];
	else
	  abr[k][a] = data[sum][a];
      }
    }
    sum += n_rep[k];
  }

  /* now we calculate \bar{\bar{a}}_\alpha \forall \alpha */

  for (k = 0; k < len; ++k) {
    for (a = 0; a < cols; ++a) {
      if (k > 0)
	abb[a] += abr[k][a];
      else
	abb[a] = abr[k][a];
    }
  }
  for (a =0; a < cols; ++a)
    abb[a] /= rows;

  /* now we calculate \bar{a}_\alpha^r with \forall \alpha */
  for (k = 0; k < len; ++k)
    for (a = 0; a < cols; ++a)
      abr[k][a] /= n_rep[k];

  uwerr_write_tcl_vector(interp, abb, cols, tcl_vector);
  Tcl_ResetResult(interp);

  if (cmdInfo->proc(cmdInfo->clientData, interp, argc+1, my_argv) != TCL_OK)
    goto err_exit;

  Fbb = strtod(Tcl_GetStringResult(interp),0);
  for (k = 0; k < len; ++k) {
    uwerr_write_tcl_vector(interp, abr[k], cols, tcl_vector);
    Tcl_ResetResult(interp);

    if (cmdInfo->proc(cmdInfo->clientData, interp, argc+1, my_argv) != TCL_OK)
      goto err_exit;
    Fbr[k] = strtod(Tcl_GetStringResult(interp),0);
  }

  Fb  = UWerr_dsum_int(n_rep, Fbr, len);
  Fb /= rows;

  for (a = 0; a < cols; ++a) {
    std_a = 0;
    for (k = 0; k < rows; ++k)
      std_a += (data[k][a]-abb[a])*(data[k][a]-abb[a]);
    std_a = sqrt(std_a)/rows;

    
    /* calc the gradient of f using df/da ~ (f(a+h)-f(a-h))/2*h 
       where h is the standard deviation divided by the sqrt of the 
       number of samples (= rows).
       Remember: abb[a] is the average for column a of data */

    if (std_a == 0)
      fgrad[a] = 0;
    else {
      tmp = abb[a];
      abb[a] += std_a;

      uwerr_write_tcl_vector(interp, abb, cols, tcl_vector);
      Tcl_ResetResult(interp);
      if (cmdInfo->proc(cmdInfo->clientData, interp, argc+1, my_argv) != TCL_OK)
	goto err_exit;
      fgrad[a] = strtod(Tcl_GetStringResult(interp),0);

      abb[a] = tmp - std_a;

      uwerr_write_tcl_vector(interp, abb, cols, tcl_vector);
      Tcl_ResetResult(interp);
      if (cmdInfo->proc(cmdInfo->clientData, interp, argc+1, my_argv) != TCL_OK)
	goto err_exit;
      fgrad[a] -= strtod(Tcl_GetStringResult(interp),0);

      abb[a] = tmp;
      fgrad[a] /= 2*std_a;
    }
  }

  /* calc delpro = data*fgrad - abb.*fgrad and
     the mean of delpro.^2 = gFbb[0] */

  tmp = UWerr_dsum_double(abb, fgrad, cols);
  gFbb[0] = 0;
  for (i = 0; i < rows; ++i) {
    delpro[i] = 0;

    for (a = 0; a < cols; a++) {
      delpro[i] += data[i][a]*fgrad[a];
    }
    delpro[i] -= tmp;

    gFbb[0] += delpro[i]*delpro[i];
  }
  gFbb[0] /= rows;

  i = 0;
  while(i < W_max) {
    gFbb[i+1] = 0;
    sum = 0;
    for (k = 0; k < len; ++k) {
      gFbb[i+1] += UWerr_dsum_double(delpro + sum, delpro + sum + i + 1, n_rep[k]-i-1);
      sum += n_rep[k];
    }
    gFbb[i+1] /= rows-(i+1)*len;

    if (flag) {
      G_int += gFbb[i+1]/gFbb[0];
      if (G_int <= 0)
	tau = UW_EPS;
      else
	tau = s_tau/log((G_int+1)/G_int);
      if (exp(-(i+1)/tau)-tau/sqrt((i+1)*rows) < 0) {
	W_opt = i+1;
	W_max = (W_max < 2*W_opt) ? W_max : 2*W_opt;
	flag = 0;
      }
    }
    ++i;
  }
  --i;

  if (flag) {
    W_opt = W_max;
    sprintf(str, "%d", W_max);
    Tcl_AppendResult(interp, "Windowing condition failed up to W = ", str, ".\n", (char *)NULL);
  }
  ret.W = W_opt;

  CFbb_opt = (gFbb[0] + 2*UWerr_sum(gFbb+1, W_opt))/rows;
  for (k = 0; k < i; ++k)
    gFbb[k] += CFbb_opt;
  CFbb_opt = (gFbb[0] + 2*UWerr_sum(gFbb+1, W_opt));

  ret.dvalue = sqrt(CFbb_opt/rows); /* sigmaF */
  
  if (len >= 2) {
    bF = (Fb-Fbb)/(len-1);
    Fbb -= bF;
    if (fabs(bF) > ret.dvalue/4) {
      Tcl_PrintDouble(interp, bF/ret.dvalue, str);
      Tcl_AppendResult(interp, "A ", str, " sigma bias of the mean has been cancelled./n", (char *)NULL);
    }
    for (i = 0; i < len; ++i)
      Fbr[i] -= bF*rows/n_rep[i];
    Fb -= bF*len;
    
    ret.bias = bF/ret.dvalue;
  }

  ret.tau_int = 0;
  for (i = 0; i <= W_opt; ++i)
    ret.tau_int += gFbb[i];
      
  ret.tau_int /= gFbb[0];
  ret.tau_int -= .5;

  ret.value  = Fbb;
  ret.ddvalue = ret.dvalue*sqrt((W_opt + .5)/rows);
  ret.dtau_int = 2 * ret.tau_int * sqrt((W_opt + .5 - ret.tau_int)/rows);

  if (len > 1) {
    for (i = 0; i < len; ++i)
      Fbr[i] = (Fbr[i] - Fb)*(Fbr[i] - Fb)*n_rep[i];
    
    ret.Q_val = UWerr_sum(Fbr, len);
    ret.Q_val /= CFbb_opt;
    ret.Q_val = gammaq((len-1)/2., ret.Q_val/2.);
  }

  if (plot) {
    plotScriptf = fopen("uwerr_plot_script", "w");

    fprintf(plotScriptf, "set ylabel \"Gamma\"; set xlabel \"W\"; set label \"W_opt=%d\" at %d,0 center; plot f(x) = 0, f(x) notitle, 'uwerr_plot_data' using 1:2 title \"normalized autocorrelation\" with lines; show label; pause -1\n", W_opt, W_opt);
    fprintf(plotScriptf, "set ylabel \"tau_int\"; plot f(x) = %.3f, 'uwerr_plot_data' using 1:3 title \"tau_int with statistical errors\" with lines,", ret.tau_int);
    fprintf(plotScriptf, " 'uwerr_plot_data' using 1:3:4 notitle with errorbars, f(x) title \"estimate\"; pause -1\n");

    fclose(plotScriptf);

    plotDataf = fopen("uwerr_plot_data", "w");
    tmp = 0;
    for (i = 0; i < W_max; ++i) {
      tmp += gFbb[i];
      /* print values for x-Axis, Gamma/Gamma[0], tau_int, and its errors */
      fprintf(plotDataf, "%d %.3f %.3f %.3f\n", i, gFbb[i]/gFbb[0],
	      tmp/gFbb[0]-.5, 2*sqrt((i+tmp/gFbb[0])/rows));
    }
    fclose(plotDataf);

    puts("Press Return to continue ...");
    Tcl_Eval(interp, "[exec gnuplot uwerr_plot_script]");
  }

  Tcl_ResetResult(interp);
  Tcl_PrintDouble(interp, ret.value, str);
  Tcl_AppendResult(interp, str, " ", (char *)NULL);
  Tcl_PrintDouble(interp, ret.dvalue, str);
  Tcl_AppendResult(interp, str, " ", (char *)NULL);
  Tcl_PrintDouble(interp, ret.ddvalue, str);
  Tcl_AppendResult(interp, str, " ", (char *)NULL);
  Tcl_PrintDouble(interp, ret.tau_int, str);
  Tcl_AppendResult(interp, str, " ", (char *)NULL);
  Tcl_PrintDouble(interp, ret.dtau_int, str);
  Tcl_AppendResult(interp, str, (char *)NULL);
  if (len > 1) {
    Tcl_PrintDouble(interp, ret.Q_val, str);
    Tcl_AppendResult(interp, " ", str, (char *)NULL);
  }

 err_exit:
  free(abb);
  for (k = 0; k < len; ++k)
    free(abr[k]);
  free(abr);
  free(delpro);
  free(gFbb);
  free(Fbr);
  free(fgrad);
  free(str);
  free(my_argv);
  uwerr_free_tcl_vector(tcl_vector);

  return TCL_OK;
}
Пример #24
0
int
Pg_lo_open(ClientData cData, Tcl_Interp *interp, int argc, CONST84 char *argv[])
{
	PGconn	   *conn;
	int			lobjId;
	int			mode;
	int			fd;

	if (argc != 4)
	{
		Tcl_AppendResult(interp, "Wrong # of arguments\n",
						 "pg_lo_open connection lobjOid mode", 0);
		return TCL_ERROR;
	}

	conn = PgGetConnectionId(interp, argv[1], (Pg_ConnectionId **) NULL);
	if (conn == (PGconn *) NULL)
		return TCL_ERROR;

	lobjId = atoi(argv[2]);
	if (strlen(argv[3]) < 1 ||
		strlen(argv[3]) > 2)
	{
		Tcl_AppendResult(interp, "mode argument must be 'r', 'w', or 'rw'", 0);
		return TCL_ERROR;
	}
	switch (argv[3][0])
	{
		case 'r':
		case 'R':
			mode = INV_READ;
			break;
		case 'w':
		case 'W':
			mode = INV_WRITE;
			break;
		default:
			Tcl_AppendResult(interp, "mode argument must be 'r', 'w', or 'rw'", 0);
			return TCL_ERROR;
	}
	switch (argv[3][1])
	{
		case '\0':
			break;
		case 'r':
		case 'R':
			mode |= INV_READ;
			break;
		case 'w':
		case 'W':
			mode |= INV_WRITE;
			break;
		default:
			Tcl_AppendResult(interp, "mode argument must be 'r', 'w', or 'rw'", 0);
			return TCL_ERROR;
	}

	fd = lo_open(conn, lobjId, mode);
	sprintf(interp->result, "%d", fd);
	return TCL_OK;
}
Пример #25
0
int uwerr(ClientData cd, Tcl_Interp *interp, int argc, char *argv[])
{
  int i, nrows, ncols, len, plot = 0,
    col_to_analyze = -1, analyze_col = 0, error = 0,
    result = TCL_OK;
  double s_tau = 1.5;
  int * nrep;
  double ** data;
  char * str;
  char ** my_argv;
  Tcl_CmdInfo cmdInfo;

  if (argc < 4) {
    Tcl_AppendResult(interp, argv[0], " needs at least 3 arguments.\n",
		     "usage: ", argv[0], " <data> <nrep> {<col>|<f>} [<s_tau> [<f_args>]] [plot]\n",
		     (char *)NULL);
    return TCL_ERROR;
  }

  /* read the matrix containing the data */
  if (uwerr_read_matrix(interp, argv[1], &data, &nrows, &ncols) == TCL_ERROR)
    return TCL_ERROR;

  /* read the vector containing the length of each representation */
  if (uwerr_read_int_vector(interp, argv[2], &nrep, &len) == TCL_ERROR)
    return TCL_ERROR;

  /* check if we analyze a column or a function of the columns */
  if (!Tcl_GetCommandInfo(interp, argv[3], &cmdInfo)) {
    analyze_col = 1;
    if (Tcl_GetInt(interp, argv[3], &col_to_analyze) == TCL_ERROR) {
      error = 1;
      str = (char *)malloc(TCL_INTEGER_SPACE*sizeof(char));
      sprintf(str, "%d", ncols);
      Tcl_AppendResult(interp, "third argument has to be a function or a ",
		       "number between 1 and ", str, "!", (char *)NULL);
      free(str);
    }
  }
  
  if (!error && analyze_col &&
      (col_to_analyze < 1 || col_to_analyze > ncols)) {
    error = 1;
    str = (char *)malloc(TCL_INTEGER_SPACE*sizeof(char));
    sprintf(str, "%d", ncols);
    Tcl_AppendResult(interp, "third argument has to be a function or a ",
		     "number between 1 and ", str, ".", (char *)NULL);
    free(str);
  }

  /* check for plot as fourth argument */
  if (argc > 4 && !error) {
    if (!strcmp(argv[4], "plot"))
      plot = 1;
    else {

      /* read s_tau if there is a fourth arg */
      if (Tcl_GetDouble(interp, argv[4], &s_tau) == TCL_ERROR) {
	error = 1;
	Tcl_AppendResult(interp, "fourth argument has to be a double or 'plot'.", (char *)NULL);
      }

    }
  }

  if (argc > 5 && ! error)
    if (!strcmp(argv[argc-1], "plot"))
      plot = 1;

  if (!error && analyze_col) {
    result = UWerr(interp, data, nrows, ncols,
		   col_to_analyze-1, nrep, len, s_tau, plot);
  }

  if (!error && !analyze_col) {
    my_argv = (char**)malloc((argc-3)*sizeof(char*));
    my_argv[0] = argv[3];
    for (i = 0; i < argc-5-plot; ++i)
      my_argv[i+1] = argv[5+i];
    result = UWerr_f(interp, &cmdInfo, argc-plot>4?argc-plot-4:1, my_argv,
		     data, nrows, ncols, nrep, len, s_tau, plot);
    free(my_argv);
  }
  
  for (i = 0; i < nrows; ++i)
    free(data[i]);
  free(data);

  free(nrep);

  return error ? TCL_ERROR : TCL_OK;
}
Пример #26
0
int
Pg_connect(ClientData cData, Tcl_Interp *interp, int argc, CONST84 char *argv[])
{
	const char *pghost = NULL;
	const char *pgtty = NULL;
	const char *pgport = NULL;
	const char *pgoptions = NULL;
	const char *dbName;
	int			i;
	PGconn	   *conn;

	if (argc == 1)
	{
		Tcl_AppendResult(interp, "pg_connect: database name missing\n", 0);
		Tcl_AppendResult(interp, "pg_connect databaseName [-host hostName] [-port portNumber] [-tty pgtty]\n", 0);
		Tcl_AppendResult(interp, "pg_connect -conninfo conninfoString", 0);
		return TCL_ERROR;

	}

	if (!strcmp("-conninfo", argv[1]))
	{
		/*
		 * Establish a connection using the new PQconnectdb() interface
		 */
		if (argc != 3)
		{
			Tcl_AppendResult(interp, "pg_connect: syntax error\n", 0);
			Tcl_AppendResult(interp, "pg_connect -conninfo conninfoString", 0);
			return TCL_ERROR;
		}
		conn = PQconnectdb(argv[2]);
	}
	else
	{
		/*
		 * Establish a connection using the old PQsetdb() interface
		 */
		if (argc > 2)
		{
			/* parse for pg environment settings */
			i = 2;
			while (i + 1 < argc)
			{
				if (strcmp(argv[i], "-host") == 0)
				{
					pghost = argv[i + 1];
					i += 2;
				}
				else if (strcmp(argv[i], "-port") == 0)
				{
					pgport = argv[i + 1];
					i += 2;
				}
				else if (strcmp(argv[i], "-tty") == 0)
				{
					pgtty = argv[i + 1];
					i += 2;
				}
				else if (strcmp(argv[i], "-options") == 0)
				{
					pgoptions = argv[i + 1];
					i += 2;
				}
				else
				{
					Tcl_AppendResult(interp, "Bad option to pg_connect: ",
									 argv[i], 0);
					Tcl_AppendResult(interp, "\npg_connect databaseName [-host hostName] [-port portNumber] [-tty pgtty]", 0);
					return TCL_ERROR;
				}
			}					/* while */
			if ((i % 2 != 0) || i != argc)
			{
				Tcl_AppendResult(interp, "wrong # of arguments to pg_connect: ",
								 argv[i], 0);
				Tcl_AppendResult(interp, "\npg_connect databaseName [-host hostName] [-port portNumber] [-tty pgtty]", 0);
				return TCL_ERROR;
			}
		}
		dbName = argv[1];
		conn = PQsetdb(pghost, pgport, pgoptions, pgtty, dbName);
	}

	if (PQstatus(conn) == CONNECTION_OK)
	{
		PgSetConnectionId(interp, conn);
		return TCL_OK;
	}
	else
	{
		Tcl_AppendResult(interp, "Connection to database failed\n",
						 PQerrorMessage(conn), 0);
		PQfinish(conn);
		return TCL_ERROR;
	}
}
Пример #27
0
/* Create a new listening port (or destroy one)
 *
 * listen <port> bots/all/users [mask]
 * listen <port> script <proc> [flag]
 * listen <port> off
 */
static int tcl_listen(ClientData cd, Tcl_Interp *irp,
                      int argc, char *argv[])
{
  int i, j, idx = -1, port, realport;
  char s[11], msg[256];
  struct portmap *pmap = NULL, *pold = NULL;

  BADARGS(3, 5, " port type ?mask?/?proc ?flag??");

  port = realport = atoi(argv[1]);
  for (pmap = root; pmap; pold = pmap, pmap = pmap->next)
    if (pmap->realport == port) {
      port = pmap->mappedto;
      break;
  }
  for (i = 0; i < dcc_total; i++)
    if ((dcc[i].type == &DCC_TELNET) && (dcc[i].port == port))
      idx = i;
  if (!egg_strcasecmp(argv[2], "off")) {
    if (pmap) {
      if (pold)
        pold->next = pmap->next;
      else
        root = pmap->next;
      nfree(pmap);
    }
    /* Remove */
    if (idx < 0) {
      Tcl_AppendResult(irp, "no such listen port is open", NULL);
      return TCL_ERROR;
    }
    killsock(dcc[idx].sock);
    lostdcc(idx);
    return TCL_OK;
  }
  if (idx < 0) {
    /* Make new one */
    if (dcc_total >= max_dcc) {
      Tcl_AppendResult(irp, "No more DCC slots available.", NULL);
      return TCL_ERROR;
    }
    /* Try to grab port */
    j = port + 20;
    i = -1;
    while (port < j && i < 0) {
      i = open_listen(&port);
      if (i == -1)
        port++;
      else if (i == -2)
        break;
    }
    if (i == -1) {
      egg_snprintf(msg, sizeof msg, "Couldn't listen on port '%d' on the "
                   "given address. Please make sure 'my-ip' is set correctly, "
                   "or try a different port.", realport);
      Tcl_AppendResult(irp, msg, NULL);
      return TCL_ERROR;
    } else if (i == -2) {
      Tcl_AppendResult(irp, "Couldn't assign the requested IP. Please make "
                       "sure 'my-ip' is set properly.", NULL);
      return TCL_ERROR;
    }
    idx = new_dcc(&DCC_TELNET, 0);
    dcc[idx].addr = iptolong(getmyip());
    dcc[idx].port = port;
    dcc[idx].sock = i;
    dcc[idx].timeval = now;
  }
  /* script? */
  if (!strcmp(argv[2], "script")) {
    strcpy(dcc[idx].nick, "(script)");
    if (argc < 4) {
      Tcl_AppendResult(irp, "a proc name must be specified for a script listen", NULL);
      killsock(dcc[idx].sock);
      lostdcc(idx);
      return TCL_ERROR;
    }
    if (argc == 5) {
      if (strcmp(argv[4], "pub")) {
        Tcl_AppendResult(irp, "unknown flag: ", argv[4], ". allowed flags: pub",
                         NULL);
        killsock(dcc[idx].sock);
        lostdcc(idx);
        return TCL_ERROR;
      }
      dcc[idx].status = LSTN_PUBLIC;
    }
    strncpyz(dcc[idx].host, argv[3], UHOSTMAX);
    egg_snprintf(s, sizeof s, "%d", port);
    Tcl_AppendResult(irp, s, NULL);
    return TCL_OK;
  }
  /* bots/users/all */
  if (!strcmp(argv[2], "bots"))
    strcpy(dcc[idx].nick, "(bots)");
  else if (!strcmp(argv[2], "users"))
    strcpy(dcc[idx].nick, "(users)");
  else if (!strcmp(argv[2], "all"))
    strcpy(dcc[idx].nick, "(telnet)");
  if (!dcc[idx].nick[0]) {
    Tcl_AppendResult(irp, "invalid listen type: must be one of ",
                     "bots, users, all, off, script", NULL);
    killsock(dcc[idx].sock);
    dcc_total--;
    return TCL_ERROR;
  }
  if (argc == 4)
    strncpyz(dcc[idx].host, argv[3], UHOSTMAX);
  else
    strcpy(dcc[idx].host, "*");
  egg_snprintf(s, sizeof s, "%d", port);
  Tcl_AppendResult(irp, s, NULL);
  if (!pmap) {
    pmap = nmalloc(sizeof(struct portmap));
    pmap->next = root;
    root = pmap;
  }
  pmap->realport = realport;
  pmap->mappedto = port;
  putlog(LOG_MISC, "*", "Listening at telnet port %d (%s).", port, argv[2]);
  return TCL_OK;
}
Пример #28
0
/**********************************
 * pg_result
 get information about the results of a query

 syntax:

	pg_result result ?option?

 the options are:

	-status		the status of the result

	-error		the error message, if the status indicates error; otherwise
				an empty string

	-conn		the connection that produced the result

	-oid		if command was an INSERT, the OID of the inserted tuple

	-numTuples	the number of tuples in the query

	-cmdTuples	the number of tuples affected by the query

	-numAttrs	returns the number of attributes returned by the query

	-assign arrayName
				assign the results to an array, using subscripts of the form
				(tupno,attributeName)

	-assignbyidx arrayName ?appendstr?
				assign the results to an array using the first field's value
				as a key.
				All but the first field of each tuple are stored, using
				subscripts of the form (field0value,attributeNameappendstr)

	-getTuple tupleNumber
				returns the values of the tuple in a list

	-tupleArray tupleNumber arrayName
				stores the values of the tuple in array arrayName, indexed
				by the attributes returned

	-attributes
				returns a list of the name/type pairs of the tuple attributes

	-lAttributes
				returns a list of the {name type len} entries of the tuple
				attributes

	-clear		clear the result buffer. Do not reuse after this

 **********************************/
int
Pg_result(ClientData cData, Tcl_Interp *interp, int argc, CONST84 char *argv[])
{
	PGresult   *result;
	const char *opt;
	int			i;
	int			tupno;
	CONST84 char *arrVar;
	char		nameBuffer[256];
	const char *appendstr;

	if (argc < 3 || argc > 5)
	{
		Tcl_AppendResult(interp, "Wrong # of arguments\n", 0);
		goto Pg_result_errReturn;		/* append help info */
	}

	result = PgGetResultId(interp, argv[1]);
	if (result == (PGresult *) NULL)
	{
		Tcl_AppendResult(interp, "\n",
						 argv[1], " is not a valid query result", 0);
		return TCL_ERROR;
	}

	opt = argv[2];

	if (strcmp(opt, "-status") == 0)
	{
		Tcl_AppendResult(interp, PQresStatus(PQresultStatus(result)), 0);
		return TCL_OK;
	}
	else if (strcmp(opt, "-error") == 0)
	{
		Tcl_SetResult(interp, (char *) PQresultErrorMessage(result),
					  TCL_STATIC);
		return TCL_OK;
	}
	else if (strcmp(opt, "-conn") == 0)
		return PgGetConnByResultId(interp, argv[1]);
	else if (strcmp(opt, "-oid") == 0)
	{
		sprintf(interp->result, "%u", PQoidValue(result));
		return TCL_OK;
	}
	else if (strcmp(opt, "-clear") == 0)
	{
		PgDelResultId(interp, argv[1]);
		PQclear(result);
		return TCL_OK;
	}
	else if (strcmp(opt, "-numTuples") == 0)
	{
		sprintf(interp->result, "%d", PQntuples(result));
		return TCL_OK;
	}
	else if (strcmp(opt, "-cmdTuples") == 0)
	{
		sprintf(interp->result, "%s", PQcmdTuples(result));
		return TCL_OK;
	}
	else if (strcmp(opt, "-numAttrs") == 0)
	{
		sprintf(interp->result, "%d", PQnfields(result));
		return TCL_OK;
	}
	else if (strcmp(opt, "-assign") == 0)
	{
		if (argc != 4)
		{
			Tcl_AppendResult(interp, "-assign option must be followed by a variable name", 0);
			return TCL_ERROR;
		}
		arrVar = argv[3];

		/*
		 * this assignment assigns the table of result tuples into a giant
		 * array with the name given in the argument. The indices of the
		 * array are of the form (tupno,attrName). Note we expect field
		 * names not to exceed a few dozen characters, so truncating to
		 * prevent buffer overflow shouldn't be a problem.
		 */
		for (tupno = 0; tupno < PQntuples(result); tupno++)
		{
			for (i = 0; i < PQnfields(result); i++)
			{
				sprintf(nameBuffer, "%d,%.200s", tupno, PQfname(result, i));
				if (Tcl_SetVar2(interp, arrVar, nameBuffer,
#ifdef TCL_ARRAYS
								tcl_value(PQgetvalue(result, tupno, i)),
#else
								PQgetvalue(result, tupno, i),
#endif
								TCL_LEAVE_ERR_MSG) == NULL)
					return TCL_ERROR;
			}
		}
		Tcl_AppendResult(interp, arrVar, 0);
		return TCL_OK;
	}
	else if (strcmp(opt, "-assignbyidx") == 0)
	{
		if (argc != 4 && argc != 5)
		{
			Tcl_AppendResult(interp, "-assignbyidx option requires an array name and optionally an append string", 0);
			return TCL_ERROR;
		}
		arrVar = argv[3];
		appendstr = (argc == 5) ? (const char *) argv[4] : "";

		/*
		 * this assignment assigns the table of result tuples into a giant
		 * array with the name given in the argument.  The indices of the
		 * array are of the form (field0Value,attrNameappendstr). Here, we
		 * still assume PQfname won't exceed 200 characters, but we dare
		 * not make the same assumption about the data in field 0 nor the
		 * append string.
		 */
		for (tupno = 0; tupno < PQntuples(result); tupno++)
		{
			const char *field0 =
#ifdef TCL_ARRAYS
			tcl_value(PQgetvalue(result, tupno, 0));

#else
			PQgetvalue(result, tupno, 0);
#endif
			char	   *workspace = malloc(strlen(field0) + strlen(appendstr) + 210);

			for (i = 1; i < PQnfields(result); i++)
			{
				sprintf(workspace, "%s,%.200s%s", field0, PQfname(result, i),
						appendstr);
				if (Tcl_SetVar2(interp, arrVar, workspace,
#ifdef TCL_ARRAYS
								tcl_value(PQgetvalue(result, tupno, i)),
#else
								PQgetvalue(result, tupno, i),
#endif
								TCL_LEAVE_ERR_MSG) == NULL)
				{
					free(workspace);
					return TCL_ERROR;
				}
			}
			free(workspace);
		}
		Tcl_AppendResult(interp, arrVar, 0);
		return TCL_OK;
	}
	else if (strcmp(opt, "-getTuple") == 0)
	{
		if (argc != 4)
		{
			Tcl_AppendResult(interp, "-getTuple option must be followed by a tuple number", 0);
			return TCL_ERROR;
		}
		tupno = atoi(argv[3]);
		if (tupno < 0 || tupno >= PQntuples(result))
		{
			Tcl_AppendResult(interp, "argument to getTuple cannot exceed number of tuples - 1", 0);
			return TCL_ERROR;
		}
#ifdef TCL_ARRAYS
		for (i = 0; i < PQnfields(result); i++)
			Tcl_AppendElement(interp, tcl_value(PQgetvalue(result, tupno, i)));
#else
		for (i = 0; i < PQnfields(result); i++)
			Tcl_AppendElement(interp, PQgetvalue(result, tupno, i));
#endif
		return TCL_OK;
	}
	else if (strcmp(opt, "-tupleArray") == 0)
	{
		if (argc != 5)
		{
			Tcl_AppendResult(interp, "-tupleArray option must be followed by a tuple number and array name", 0);
			return TCL_ERROR;
		}
		tupno = atoi(argv[3]);
		if (tupno < 0 || tupno >= PQntuples(result))
		{
			Tcl_AppendResult(interp, "argument to tupleArray cannot exceed number of tuples - 1", 0);
			return TCL_ERROR;
		}
		for (i = 0; i < PQnfields(result); i++)
		{
			if (Tcl_SetVar2(interp, argv[4], PQfname(result, i),
#ifdef TCL_ARRAYS
							tcl_value(PQgetvalue(result, tupno, i)),
#else
							PQgetvalue(result, tupno, i),
#endif
							TCL_LEAVE_ERR_MSG) == NULL)
				return TCL_ERROR;
		}
		return TCL_OK;
	}
	else if (strcmp(opt, "-attributes") == 0)
	{
		for (i = 0; i < PQnfields(result); i++)
			Tcl_AppendElement(interp, PQfname(result, i));
		return TCL_OK;
	}
	else if (strcmp(opt, "-lAttributes") == 0)
	{
		for (i = 0; i < PQnfields(result); i++)
		{
			/* start a sublist */
			if (i > 0)
				Tcl_AppendResult(interp, " {", 0);
			else
				Tcl_AppendResult(interp, "{", 0);
			Tcl_AppendElement(interp, PQfname(result, i));
			sprintf(nameBuffer, "%ld", (long) PQftype(result, i));
			Tcl_AppendElement(interp, nameBuffer);
			sprintf(nameBuffer, "%ld", (long) PQfsize(result, i));
			Tcl_AppendElement(interp, nameBuffer);
			/* end the sublist */
			Tcl_AppendResult(interp, "}", 0);
		}
		return TCL_OK;
	}
	else
	{
		Tcl_AppendResult(interp, "Invalid option\n", 0);
		goto Pg_result_errReturn;		/* append help info */
	}


Pg_result_errReturn:
	Tcl_AppendResult(interp,
					 "pg_result result ?option? where option is\n",
					 "\t-status\n",
					 "\t-error\n",
					 "\t-conn\n",
					 "\t-oid\n",
					 "\t-numTuples\n",
					 "\t-cmdTuples\n",
					 "\t-numAttrs\n"
					 "\t-assign arrayVarName\n",
					 "\t-assignbyidx arrayVarName ?appendstr?\n",
					 "\t-getTuple tupleNumber\n",
					 "\t-tupleArray tupleNumber arrayVarName\n",
					 "\t-attributes\n"
					 "\t-lAttributes\n"
					 "\t-clear\n",
					 (char *) 0);
	return TCL_ERROR;


}
Пример #29
0
static int
SetMMFromAny(
    Tcl_Interp *interp,		/* Used for error reporting if not NULL. */
    Tcl_Obj *objPtr)		/* The object to convert. */
{
    ThreadSpecificData *typeCache = GetTypeCache();
    const Tcl_ObjType *typePtr;
    char *string, *rest;
    double d;
    int units;
    MMRep *mmPtr;

    if (objPtr->typePtr == typeCache->doubleTypePtr) {
	Tcl_GetDoubleFromObj(interp, objPtr, &d);
	units = -1;
    } else if (objPtr->typePtr == typeCache->intTypePtr) {
	Tcl_GetIntFromObj(interp, objPtr, &units);
	d = (double) units;
	units = -1;

	/*
	 * In the case of ints, we need to ensure that a valid string exists
	 * in order for int-but-not-string objects to be converted back to
	 * ints again from mm obj types.
	 */

	(void) Tcl_GetString(objPtr);
    } else {
	/*
	 * It wasn't a known int or double, so parse it.
	 */

	string = Tcl_GetString(objPtr);

	d = strtod(string, &rest);
	if (rest == string) {
	    /*
	     * Must copy string before resetting the result in case a caller
	     * is trying to convert the interpreter's result to mms.
	     */

	error:
	    Tcl_AppendResult(interp, "bad screen distance \"", string,
		    "\"", NULL);
	    return TCL_ERROR;
	}
	while ((*rest != '\0') && isspace(UCHAR(*rest))) {
	    rest++;
	}

	switch (*rest) {
	case '\0':
	    units = -1;
	    break;
	case 'c':
	    units = 0;
	    break;
	case 'i':
	    units = 1;
	    break;
	case 'm':
	    units = 2;
	    break;
	case 'p':
	    units = 3;
	    break;
	default:
	    goto error;
	}
    }

    /*
     * Free the old internalRep before setting the new one.
     */

    typePtr = objPtr->typePtr;
    if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) {
	(*typePtr->freeIntRepProc)(objPtr);
    }

    objPtr->typePtr = &mmObjType;

    mmPtr = (MMRep *) ckalloc(sizeof(MMRep));
    mmPtr->value = d;
    mmPtr->units = units;
    mmPtr->tkwin = NULL;
    mmPtr->returnValue	= d;

    objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) mmPtr;

    return TCL_OK;
}
Пример #30
0
int tclcommand_inter_parse_non_bonded(Tcl_Interp * interp,
			   int part_type_a, int part_type_b,
			   int argc, char ** argv)
{
  int change;
  
  Tcl_ResetResult(interp);

  if (argc <= 0) {
    Tcl_AppendResult(interp, "wrong # args:  should be \"",
		     "inter <type 1> <type 2> ?interaction? ?values?\"",
		     (char *) NULL);
    return TCL_ERROR;
  }

  /* get interaction parameters */

  while (argc > 0) {
    /* The various parsers return the number of parsed parameters.
       If an error occured, 0 should be returned, since none of the parameters were
       understood */

    /* that's just for the else below... */
    if (0);

#define REGISTER_NONBONDED(name, parser)				\
    else if (ARG0_IS_S(name))						\
      change = parser(interp, part_type_a, part_type_b, argc, argv)

#ifdef LENNARD_JONES
    REGISTER_NONBONDED("lennard-jones", tclcommand_inter_parse_lj);
#endif

#ifdef LENNARD_JONES_GENERIC
    REGISTER_NONBONDED("lj-gen", tclcommand_inter_parse_ljgen);
#endif

#ifdef LJ_ANGLE
    REGISTER_NONBONDED("lj-angle", tclcommand_inter_parse_ljangle);
#endif

#ifdef SMOOTH_STEP
    REGISTER_NONBONDED("smooth-step", tclcommand_inter_parse_SmSt);
#endif

#ifdef HERTZIAN
    REGISTER_NONBONDED("hertzian", tclcommand_inter_parse_hertzian);
#endif

#ifdef GAUSSIAN
    REGISTER_NONBONDED("gaussian", tclcommand_inter_parse_gaussian);
#endif

#ifdef BMHTF_NACL
    REGISTER_NONBONDED("bmhtf-nacl", tclcommand_inter_parse_BMHTF);
#endif

#ifdef MORSE
    REGISTER_NONBONDED("morse", tclcommand_inter_parse_morse);
#endif

#ifdef LJCOS
    REGISTER_NONBONDED("lj-cos", tclcommand_inter_parse_ljcos);
#endif

#ifdef BUCKINGHAM
    REGISTER_NONBONDED("buckingham", tclcommand_inter_parse_buckingham);
#endif

#ifdef SOFT_SPHERE
    REGISTER_NONBONDED("soft-sphere", tclcommand_inter_parse_soft);
#endif

#ifdef AFFINITY
    REGISTER_NONBONDED("affinity", tclcommand_inter_parse_affinity);
#endif
      
#ifdef MEMBRANE_COLLISION
    REGISTER_NONBONDED("membrane", tclcommand_inter_parse_membrane);
#endif

#ifdef HAT
    REGISTER_NONBONDED("hat", tclcommand_inter_parse_hat);
#endif

#ifdef COMFORCE
    REGISTER_NONBONDED("comforce", tclcommand_inter_parse_comforce);
#endif

#ifdef LJCOS2
    REGISTER_NONBONDED("lj-cos2", tclcommand_inter_parse_ljcos2);
#endif

#ifdef COS2
    REGISTER_NONBONDED("cos2", tclcommand_inter_parse_cos2);
#endif


#ifdef COMFIXED
    REGISTER_NONBONDED("comfixed", tclcommand_inter_parse_comfixed);
#endif

#ifdef GAY_BERNE
    REGISTER_NONBONDED("gay-berne", tclcommand_inter_parse_gb);
#endif

#ifdef TABULATED
    REGISTER_NONBONDED("tabulated", tclcommand_inter_parse_tab);
#endif
#ifdef INTER_DPD
    REGISTER_NONBONDED("inter_dpd", tclcommand_inter_parse_inter_dpd);
#endif
#ifdef INTER_RF
    REGISTER_NONBONDED("inter_rf", tclcommand_inter_parse_interrf);
#endif
#ifdef TUNABLE_SLIP
    REGISTER_NONBONDED("tunable_slip", tclcommand_inter_parse_tunable_slip);
#endif
#ifdef MOL_CUT
    REGISTER_NONBONDED("molcut", tclcommand_inter_parse_molcut);
#endif
  
#ifdef SHANCHEN
    REGISTER_NONBONDED("affinity",tclcommand_inter_parse_affinity);
#endif
 
    else {
      Tcl_AppendResult(interp, "excessive parameter/unknown interaction type \"", argv[0],
		       "\" in parsing non bonded interaction",
		       (char *) NULL);
      return TCL_ERROR;
    }

    if (change <= 0)
      return TCL_ERROR;

    argc -= change;
    argv += change;
  }