Exemplo n.º 1
0
int
TkFindStateNumObj(
    Tcl_Interp *interp,		/* Interp for error reporting. */
    Tcl_Obj *optionPtr,		/* String to use when constructing error. */
    const TkStateMap *mapPtr,	/* Lookup table. */
    Tcl_Obj *keyPtr)		/* String key to find in lookup table. */
{
    const TkStateMap *mPtr;
    const char *key;
    const Tcl_ObjType *typePtr;

    /*
     * See if the value is in the object cache.
     */

    if ((keyPtr->typePtr == &tkStateKeyObjType)
	    && (keyPtr->internalRep.twoPtrValue.ptr1 == mapPtr)) {
	return PTR2INT(keyPtr->internalRep.twoPtrValue.ptr2);
    }

    /*
     * Not there. Look in the state map.
     */

    key = Tcl_GetString(keyPtr);
    for (mPtr = mapPtr; mPtr->strKey != NULL; mPtr++) {
	if (strcmp(key, mPtr->strKey) == 0) {
	    typePtr = keyPtr->typePtr;
	    if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) {
		typePtr->freeIntRepProc(keyPtr);
	    }
	    keyPtr->internalRep.twoPtrValue.ptr1 = (void *) mapPtr;
	    keyPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(mPtr->numKey);
	    keyPtr->typePtr = &tkStateKeyObjType;
	    return mPtr->numKey;
	}
    }

    /*
     * Not there either. Generate an error message (if we can) and return the
     * default.
     */

    if (interp != NULL) {
	Tcl_Obj *msgObj;

	mPtr = mapPtr;
	msgObj = Tcl_ObjPrintf(
		"bad %s value \"%s\": must be %s",
		Tcl_GetString(optionPtr), key, mPtr->strKey);
	for (mPtr++; mPtr->strKey != NULL; mPtr++) {
	    Tcl_AppendPrintfToObj(msgObj, ",%s %s",
		    ((mPtr[1].strKey != NULL) ? "" : " or"), mPtr->strKey);
	}
	Tcl_SetObjResult(interp, msgObj);
	Tcl_SetErrorCode(interp, "TK", "LOOKUP", Tcl_GetString(optionPtr),
		key, NULL);
    }
    return mPtr->numKey;
}
Exemplo n.º 2
0
/*
  sequencer device channel create for reading or writing, not both at once.
*/
static int alsa_sequencer_open(ClientData clientData, Tcl_Interp *interp, Tcl_Obj *port, Tcl_Obj *direction) {
  const char *port_name = Tcl_GetString(port), *direction_name = Tcl_GetString(direction);
  static snd_sequencer_t *input, **inputp;
  static snd_sequencer_t *output, **outputp;
  if (strcmp(direction_name, "r") == 0) {
    inputp = &input;
    outputp = NULL;
  } else if (strcmp(direction_name, "w") == 0) {
    inputp = NULL;
    outputp = &output;
  } else {
    Tcl_AppendResult(interp, "open direction must be r or w", NULL);
    return TCL_ERROR;
  }
  int err;
  if ((err = snd_sequencer_open(inputp, outputp, port_name, SND_SEQUENCER_NONBLOCK)) < 0) {
    Tcl_AppendPrintfToObj(Tcl_GetObjResult(interp), "cannot open port \"%s\": %s", port_name, snd_strerror(err));
    return TCL_ERROR;
  }
  if (inputp) {
    snd_sequencer_read(input, NULL, 0); /* trigger reading */
    return sequencer_make_channel(clientData, interp, input, TCL_READABLE);
  }
  if (outputp) {
    if ((err = snd_sequencer_nonblock(output, 0)) < 0) {
      Tcl_AppendResult(interp, "cannot set blocking mode: ", snd_strerror(err), NULL);
      snd_sequencer_close(output);
      return TCL_ERROR;
    }
    return sequencer_make_channel(clientData, interp, output, TCL_WRITABLE);
  }
}
Exemplo n.º 3
0
static int
PlaceInfoCommand(
    Tcl_Interp *interp,		/* Interp into which to place result. */
    Tk_Window tkwin)		/* Token for the window to get info on. */
{
    Slave *slavePtr;
    Tcl_Obj *infoObj;

    slavePtr = FindSlave(tkwin);
    if (slavePtr == NULL) {
	return TCL_OK;
    }
    infoObj = Tcl_NewObj();
    if (slavePtr->masterPtr != NULL) {
	Tcl_AppendToObj(infoObj, "-in", -1);
	Tcl_ListObjAppendElement(NULL, infoObj,
		TkNewWindowObj(slavePtr->masterPtr->tkwin));
	Tcl_AppendToObj(infoObj, " ", -1);
    }
    Tcl_AppendPrintfToObj(infoObj,
	    "-x %d -relx %.4g -y %d -rely %.4g",
	    slavePtr->x, slavePtr->relX, slavePtr->y, slavePtr->relY);
    if (slavePtr->flags & CHILD_WIDTH) {
	Tcl_AppendPrintfToObj(infoObj, " -width %d", slavePtr->width);
    } else {
	Tcl_AppendToObj(infoObj, " -width {}", -1);
    }
    if (slavePtr->flags & CHILD_REL_WIDTH) {
	Tcl_AppendPrintfToObj(infoObj,
		" -relwidth %.4g", slavePtr->relWidth);
    } else {
	Tcl_AppendToObj(infoObj, " -relwidth {}", -1);
    }
    if (slavePtr->flags & CHILD_HEIGHT) {
	Tcl_AppendPrintfToObj(infoObj, " -height %d", slavePtr->height);
    } else {
	Tcl_AppendToObj(infoObj, " -height {}", -1);
    }
    if (slavePtr->flags & CHILD_REL_HEIGHT) {
	Tcl_AppendPrintfToObj(infoObj,
		" -relheight %.4g", slavePtr->relHeight);
    } else {
	Tcl_AppendToObj(infoObj, " -relheight {}", -1);
    }

    Tcl_AppendPrintfToObj(infoObj, " -anchor %s -bordermode %s",
	    Tk_NameOfAnchor(slavePtr->anchor),
	    borderModeStrings[slavePtr->borderMode]);
    Tcl_SetObjResult(interp, infoObj);
    return TCL_OK;
}
Exemplo n.º 4
0
int
TkFindStateNum(
    Tcl_Interp *interp,		/* Interp for error reporting. */
    const char *option,		/* String to use when constructing error. */
    const TkStateMap *mapPtr,	/* Lookup table. */
    const char *strKey)		/* String to try to find in lookup table. */
{
    const TkStateMap *mPtr;

    /*
     * See if the value is in the state map.
     */

    for (mPtr = mapPtr; mPtr->strKey != NULL; mPtr++) {
	if (strcmp(strKey, mPtr->strKey) == 0) {
	    return mPtr->numKey;
	}
    }

    /*
     * Not there. Generate an error message (if we can) and return the
     * default.
     */

    if (interp != NULL) {
	Tcl_Obj *msgObj;

	mPtr = mapPtr;
	msgObj = Tcl_ObjPrintf("bad %s value \"%s\": must be %s",
		option, strKey, mPtr->strKey);
	for (mPtr++; mPtr->strKey != NULL; mPtr++) {
	    Tcl_AppendPrintfToObj(msgObj, ",%s %s",
		    ((mPtr[1].strKey != NULL) ? "" : "or "), mPtr->strKey);
	}
	Tcl_SetObjResult(interp, msgObj);
	Tcl_SetErrorCode(interp, "TK", "LOOKUP", option, strKey, NULL);
    }
    return mPtr->numKey;
}
Exemplo n.º 5
0
static void
PrintUsage(
    Tcl_Interp *interp,		/* Place information in this interp's result
				 * area. */
    const Tcl_ArgvInfo *argTable)
				/* Array of command-specific argument
				 * descriptions. */
{
    register const Tcl_ArgvInfo *infoPtr;
    int width, numSpaces;
#define NUM_SPACES 20
    static const char spaces[] = "                    ";
    char tmp[TCL_DOUBLE_SPACE];
    Tcl_Obj *msg;

    /*
     * First, compute the width of the widest option key, so that we can make
     * everything line up.
     */

    width = 4;
    for (infoPtr = argTable; infoPtr->type != TCL_ARGV_END; infoPtr++) {
	int length;

	if (infoPtr->keyStr == NULL) {
	    continue;
	}
	length = strlen(infoPtr->keyStr);
	if (length > width) {
	    width = length;
	}
    }

    /*
     * Now add the option information, with pretty-printing.
     */

    msg = Tcl_NewStringObj("Command-specific options:", -1);
    for (infoPtr = argTable; infoPtr->type != TCL_ARGV_END; infoPtr++) {
	if ((infoPtr->type == TCL_ARGV_HELP) && (infoPtr->keyStr == NULL)) {
	    Tcl_AppendPrintfToObj(msg, "\n%s", infoPtr->helpStr);
	    continue;
	}
	Tcl_AppendPrintfToObj(msg, "\n %s:", infoPtr->keyStr);
	numSpaces = width + 1 - strlen(infoPtr->keyStr);
	while (numSpaces > 0) {
	    if (numSpaces >= NUM_SPACES) {
		Tcl_AppendToObj(msg, spaces, NUM_SPACES);
	    } else {
		Tcl_AppendToObj(msg, spaces, numSpaces);
	    }
	    numSpaces -= NUM_SPACES;
	}
	Tcl_AppendToObj(msg, infoPtr->helpStr, -1);
	switch (infoPtr->type) {
	case TCL_ARGV_INT:
	    Tcl_AppendPrintfToObj(msg, "\n\t\tDefault value: %d",
		    *((int *) infoPtr->dstPtr));
	    break;
	case TCL_ARGV_FLOAT:
	    Tcl_AppendPrintfToObj(msg, "\n\t\tDefault value: %g",
		    *((double *) infoPtr->dstPtr));
	    sprintf(tmp, "%g", *((double *) infoPtr->dstPtr));
	    break;
	case TCL_ARGV_STRING: {
	    char *string = *((char **) infoPtr->dstPtr);

	    if (string != NULL) {
		Tcl_AppendPrintfToObj(msg, "\n\t\tDefault value: \"%s\"",
			string);
	    }
	    break;
	}
	default:
	    break;
	}
    }
    Tcl_SetObjResult(interp, msg);
}
Exemplo n.º 6
0
static void
PrintUsage(
    Tcl_Interp *interp,		/* Place information in this interp's result
				 * area. */
    const Tk_ArgvInfo *argTable,/* Array of command-specific argument
				 * descriptions. */
    int flags)			/* If the TK_ARGV_NO_DEFAULTS bit is set in
				 * this word, then don't generate information
				 * for default options. */
{
    register const Tk_ArgvInfo *infoPtr;
    size_t width, i, numSpaces;
    Tcl_Obj *message;

    /*
     * First, compute the width of the widest option key, so that we can make
     * everything line up.
     */

    width = 4;
    for (i = 0; i < 2; i++) {
	for (infoPtr = i ? defaultTable : argTable;
		infoPtr->type != TK_ARGV_END; infoPtr++) {
	    size_t length;

	    if (infoPtr->key == NULL) {
		continue;
	    }
	    length = strlen(infoPtr->key);
	    if (length > width) {
		width = length;
	    }
	}
    }

    message = Tcl_NewStringObj("Command-specific options:", -1);
    for (i = 0; ; i++) {
	for (infoPtr = i ? defaultTable : argTable;
		infoPtr->type != TK_ARGV_END; infoPtr++) {
	    if ((infoPtr->type == TK_ARGV_HELP) && (infoPtr->key == NULL)) {
		Tcl_AppendPrintfToObj(message, "\n%s", infoPtr->help);
		continue;
	    }
	    Tcl_AppendPrintfToObj(message, "\n %s:", infoPtr->key);
	    numSpaces = width + 1 - strlen(infoPtr->key);
	    while (numSpaces-- > 0) {
		Tcl_AppendToObj(message, " ", 1);
	    }
	    Tcl_AppendToObj(message, infoPtr->help, -1);
	    switch (infoPtr->type) {
	    case TK_ARGV_INT:
		Tcl_AppendPrintfToObj(message, "\n\t\tDefault value: %d",
			*((int *) infoPtr->dst));
		break;
	    case TK_ARGV_FLOAT:
		Tcl_AppendPrintfToObj(message, "\n\t\tDefault value: %f",
			*((double *) infoPtr->dst));
		break;
	    case TK_ARGV_STRING: {
		char *string = *((char **) infoPtr->dst);

		if (string != NULL) {
		    Tcl_AppendPrintfToObj(message,
			    "\n\t\tDefault value: \"%s\"", string);
		}
		break;
	    }
	    default:
		break;
	    }
	}

	if ((flags & TK_ARGV_NO_DEFAULTS) || (i > 0)) {
	    break;
	}
	Tcl_AppendToObj(message, "\nGeneric options for all commands:", -1);
    }
    Tcl_SetObjResult(interp, message);
}
Exemplo n.º 7
0
static int
ImageToPostscript(
    Tcl_Interp *interp,		/* Leave Postscript or error message here. */
    Tk_Canvas canvas,		/* Information about overall canvas. */
    Tk_Item *itemPtr,		/* Item for which Postscript is wanted. */
    int prepass)		/* 1 means this is a prepass to collect font
				 * information; 0 means final Postscript is
				 * being created.*/
{
    ImageItem *imgPtr = (ImageItem *) itemPtr;
    Tk_Window canvasWin = Tk_CanvasTkwin(canvas);
    double x, y;
    int width, height;
    Tk_Image image;
    Tk_State state = itemPtr->state;

    if (state == TK_STATE_NULL) {
        state = Canvas(canvas)->canvas_state;
    }

    image = imgPtr->image;
    if (Canvas(canvas)->currentItemPtr == itemPtr) {
        if (imgPtr->activeImage != NULL) {
            image = imgPtr->activeImage;
        }
    } else if (state == TK_STATE_DISABLED) {
        if (imgPtr->disabledImage != NULL) {
            image = imgPtr->disabledImage;
        }
    }
    if (image == NULL) {
        /*
         * Image item without actual image specified.
         */

        return TCL_OK;
    }
    Tk_SizeOfImage(image, &width, &height);

    /*
     * Compute the coordinates of the lower-left corner of the image, taking
     * into account the anchor position for the image.
     */

    x = imgPtr->x;
    y = Tk_CanvasPsY(canvas, imgPtr->y);

    switch (imgPtr->anchor) {
    case TK_ANCHOR_NW:
        y -= height;
        break;
    case TK_ANCHOR_N:
        x -= width/2.0;
        y -= height;
        break;
    case TK_ANCHOR_NE:
        x -= width;
        y -= height;
        break;
    case TK_ANCHOR_E:
        x -= width;
        y -= height/2.0;
        break;
    case TK_ANCHOR_SE:
        x -= width;
        break;
    case TK_ANCHOR_S:
        x -= width/2.0;
        break;
    case TK_ANCHOR_SW:
        break;
    case TK_ANCHOR_W:
        y -= height/2.0;
        break;
    case TK_ANCHOR_CENTER:
        x -= width/2.0;
        y -= height/2.0;
        break;
    }

    if (!prepass) {
        Tcl_Obj *psObj = Tcl_GetObjResult(interp);

        if (Tcl_IsShared(psObj)) {
            psObj = Tcl_DuplicateObj(psObj);
            Tcl_SetObjResult(interp, psObj);
        }

        Tcl_AppendPrintfToObj(psObj, "%.15g %.15g translate\n", x, y);
    }

    return Tk_PostscriptImage(image, interp, canvasWin,
                              ((TkCanvas *) canvas)->psInfo, 0, 0, width, height, prepass);
}
Exemplo n.º 8
0
static int
CanvasPsWindow(
    Tcl_Interp *interp,		/* Leave Postscript or error message here. */
    Tk_Window tkwin,		/* window to be printed */
    Tk_Canvas canvas,		/* Information about overall canvas. */
    double x, double y,		/* origin of window. */
    int width, int height)	/* width/height of window. */
{
    XImage *ximage;
    int result;
#ifdef X_GetImage
    Tk_ErrorHandler handle;
#endif
    Tcl_Obj *cmdObj, *psObj;
    Tcl_InterpState interpState = Tcl_SaveInterpState(interp, TCL_OK);

    /*
     * Locate the subwindow within the wider window.
     */

    psObj = Tcl_ObjPrintf(
	    "\n%%%% %s item (%s, %d x %d)\n"	/* Comment */
	    "%.15g %.15g translate\n",		/* Position */
	    Tk_Class(tkwin), Tk_PathName(tkwin), width, height, x, y);

    /*
     * First try if the widget has its own "postscript" command. If it exists,
     * this will produce much better postscript than when a pixmap is used.
     */

    Tcl_ResetResult(interp);
    cmdObj = Tcl_ObjPrintf("%s postscript -prolog 0", Tk_PathName(tkwin));
    Tcl_IncrRefCount(cmdObj);
    result = Tcl_EvalObjEx(interp, cmdObj, 0);
    Tcl_DecrRefCount(cmdObj);

    if (result == TCL_OK) {
	Tcl_AppendPrintfToObj(psObj,
		"50 dict begin\nsave\ngsave\n"
		"0 %d moveto %d 0 rlineto 0 -%d rlineto -%d 0 rlineto closepath\n"
		"1.000 1.000 1.000 setrgbcolor AdjustColor\nfill\ngrestore\n",
		height, width, height, width);
	Tcl_AppendObjToObj(psObj, Tcl_GetObjResult(interp));
	Tcl_AppendToObj(psObj, "\nrestore\nend\n\n\n", -1);
	goto done;
    }

    /*
     * If the window is off the screen it will generate a BadMatch/XError. We
     * catch any BadMatch errors here
     */

#ifdef X_GetImage
    handle = Tk_CreateErrorHandler(Tk_Display(tkwin), BadMatch,
	    X_GetImage, -1, xerrorhandler, tkwin);
#endif

    /*
     * Generate an XImage from the window. We can then read pixel values out
     * of the XImage.
     */

    ximage = XGetImage(Tk_Display(tkwin), Tk_WindowId(tkwin), 0, 0,
	    (unsigned) width, (unsigned) height, AllPlanes, ZPixmap);

#ifdef X_GetImage
    Tk_DeleteErrorHandler(handle);
#endif

    if (ximage == NULL) {
	result = TCL_OK;
    } else {
	Tcl_ResetResult(interp);
	result = TkPostscriptImage(interp, tkwin, Canvas(canvas)->psInfo,
		ximage, 0, 0, width, height);
	Tcl_AppendObjToObj(psObj, Tcl_GetObjResult(interp));
	XDestroyImage(ximage);
    }

    /*
     * Plug the accumulated postscript back into the result.
     */

  done:
    if (result == TCL_OK) {
	(void) Tcl_RestoreInterpState(interp, interpState);
	Tcl_AppendObjToObj(Tcl_GetObjResult(interp), psObj);
    } else {
	Tcl_DiscardInterpState(interpState);
    }
    Tcl_DecrRefCount(psObj);
    return result;
}
Exemplo n.º 9
0
static int obj_Cgmap(ClientData /*UNUSED*/, Tcl_Interp *interp, int argc, Tcl_Obj * const objv[])
{

    Tcl_Obj *atomselect = NULL;
    Tcl_Obj *object = NULL;
    Tcl_Obj *bytes = NULL;
    Tcl_Obj *bytes_append = NULL;
    Tcl_Obj *sel = NULL;
    float *coords = NULL;
    float *coords_append = NULL;
    const char *blockid_field = "user";
    const char *order_field = "user2";
    const char *weight_field= "user3";

    int nframes, natoms, ncoords, result, length;
    int first, last, stride;
    int molid, append_molid;

    natoms = ncoords = result = 0;
    molid = append_molid = 0;
    first = last = 0;
    stride = 1;
    nframes = 1;

    std::vector<float> weight;
    std::vector<int> bead;
    std::vector<int> index;

    // Parse Arguments
    int n = 1;
    while (n < argc) {
        const char *cmd = Tcl_GetString(objv[n]);
        if (!strncmp(cmd, "-molid", 7)) {
            if (Tcl_GetIntFromObj(interp,objv[n+1], &molid) != TCL_OK) {return TCL_ERROR;}
            n += 2;

        } else if (!strncmp(cmd, "-append", 8)) {
            if (Tcl_GetIntFromObj(interp,objv[n+1], &append_molid) != TCL_OK) {return TCL_ERROR;}
            n += 2;

        } else if (!strncmp(cmd, "-sel", 5)) {
            sel = objv[n+1];
            n += 2;

        } else if (!strncmp(cmd, "-first", 5)) {
            if (Tcl_GetIntFromObj(interp,objv[n+1], &first) != TCL_OK) {return TCL_ERROR;}
            n += 2;

        } else if (!strncmp(cmd, "-last", 4)) {
            if (Tcl_GetIntFromObj(interp,objv[n+1], &last) != TCL_OK) {return TCL_ERROR;}
            n += 2;

        } else if (!strncmp(cmd, "-stride", 6)) {
            if (Tcl_GetIntFromObj(interp,objv[n+1], &stride) != TCL_OK) {return TCL_ERROR;}
            n += 2;

        } else if (!strncmp(cmd, "-weight", 7)) {
            weight_field = Tcl_GetString(objv[n+1]);
            n += 2;

        } else if (!strncmp(cmd, "-blockid", 7)) {
            blockid_field = Tcl_GetString(objv[n+1]);
            n += 2;

        } else if (!strncmp(cmd, "-order", 6)) {
            order_field = Tcl_GetString(objv[n+1]);
            n += 2;

        } else {
            Tcl_WrongNumArgs(interp,1,objv, (char *)"molid");
            return TCL_ERROR;
        }
    }

    // Create an internal selection that we can manipulate if none was defined
    // Note that a passed selection overides the passed molid
    if (!sel) {
        Tcl_Obj *script = Tcl_ObjPrintf("atomselect %i all", molid);
        if (Tcl_EvalObjEx(interp, script, TCL_EVAL_DIRECT) != TCL_OK) {
            Tcl_SetResult(interp, (char *) "Cgmap: error calling atomselect", TCL_STATIC);
            return TCL_ERROR;
        }
        atomselect = Tcl_GetObjResult(interp);
        Tcl_IncrRefCount(atomselect);

    } else {
        // Create a internal selection that is a COPY of the passed selection
        atomselect = Tcl_DuplicateObj(sel);
        Tcl_IncrRefCount(atomselect);

        // Get the molid
        Tcl_Obj *script = Tcl_DuplicateObj(sel);
        Tcl_AppendToObj(script, " molid", -1);
        if(Tcl_EvalObjEx(interp, script, TCL_EVAL_DIRECT) != TCL_OK) {
            Tcl_SetResult(interp, (char *) "Cgmap: error calling atomselect", TCL_STATIC);
            return TCL_ERROR;
        }
        Tcl_Obj *molid_result =  Tcl_GetObjResult(interp);
        if (Tcl_GetIntFromObj(interp, molid_result, &molid) != TCL_OK) {return TCL_ERROR;}
    }

    // Get the number of frames
    Tcl_Obj *script = Tcl_ObjPrintf("molinfo %i get numframes", molid);
    if (Tcl_EvalObjEx(interp, script, TCL_EVAL_DIRECT) != TCL_OK) {
        Tcl_SetResult(interp, (char *) "Cgmap: error calling molinfo for nframes", TCL_STATIC);
        return TCL_ERROR;
    }
    object = Tcl_GetObjResult(interp);
    if (Tcl_GetIntFromObj(interp, object, &nframes) != TCL_OK) {
        Tcl_SetResult(interp, (char *) "Cgmap: error parsing number of frames", TCL_STATIC);
        return TCL_ERROR;
    }

    if ( first < 0 || first >= nframes ) {
        Tcl_SetResult(interp, (char *) "Cgmap: illegal value of first_frame", TCL_STATIC);
        return TCL_ERROR;
    }
    if ( last == -1 || last > nframes || last < first ) last = nframes;

    // Get the number of atoms from selection
    script = Tcl_DuplicateObj(atomselect);
    Tcl_AppendToObj(script, " num", -1);
    if (Tcl_EvalObjEx(interp, script, TCL_EVAL_DIRECT) != TCL_OK) {
        Tcl_SetResult(interp, (char *) "Cgmap: error calling atomselect", TCL_STATIC);
        return TCL_ERROR;
    }
    object = Tcl_GetObjResult(interp);
    if (Tcl_GetIntFromObj(interp, object, &natoms) != TCL_OK) {
        Tcl_SetResult(interp, (char *) "Cgmap: error parsing number of atoms", TCL_STATIC);
        return TCL_ERROR;
    }

    // Make sure we actually have some atoms
    if (natoms == 0) {
        Tcl_SetResult(interp, (char *) "Cgmap: Selection or molecule contains no atoms", TCL_STATIC);
        return TCL_ERROR;
    }

    // Get the weights (mass)
    script = Tcl_DuplicateObj(atomselect);
    Tcl_AppendPrintfToObj (script, " get %s", weight_field);
    if (Tcl_EvalObjEx(interp, script, TCL_EVAL_DIRECT) != TCL_OK) {
        Tcl_SetResult(interp, (char *) "Cgmap: error calling atomselect for weights", TCL_STATIC);
        return TCL_ERROR;
    }
    ncoords = parse_vector(Tcl_GetObjResult(interp), weight, interp);
    if (ncoords == -1) {
        Tcl_SetResult(interp, (char *) "Cgmap: error parsing atomselect result", TCL_STATIC);
        return TCL_ERROR;
    }

    // Get the bead IDs
    script = Tcl_DuplicateObj(atomselect);
    Tcl_AppendPrintfToObj (script, " get %s", blockid_field);
    if (Tcl_EvalObjEx(interp, script, TCL_EVAL_DIRECT) != TCL_OK) {
        Tcl_SetResult(interp, (char *) "Cgmap: error calling atomselect for blocks", TCL_STATIC);
        return TCL_ERROR;
    }
    ncoords = parse_ivector(Tcl_GetObjResult(interp), bead, interp, true);
    if (ncoords == -1) {
        Tcl_SetResult(interp, (char *) "Cgmap: error parsing atomselect result", TCL_STATIC);
        return TCL_ERROR;
    }

    // Get the atom IDs, we use these as a map when accessing the coordinate array
    // user2 is set via ::CGit::setBeadID
    script = Tcl_DuplicateObj(atomselect);
    Tcl_AppendPrintfToObj (script, " get %s", order_field);
    if (Tcl_EvalObjEx(interp, script, TCL_EVAL_DIRECT) != TCL_OK) {
        Tcl_SetResult(interp, (char *) "Cgmap: error calling atomselect for order", TCL_STATIC);
        return TCL_ERROR;
    }
    ncoords = parse_ivector(Tcl_GetObjResult(interp), index, interp, true);
    if (ncoords == -1) {
        Tcl_SetResult(interp, (char *) "Cgmap: error parsing atomselect result", TCL_STATIC);
        return TCL_ERROR;
    }

    // Get current frame of the target mol
    script = Tcl_ObjPrintf("molinfo %d get frame", append_molid);
    if (Tcl_EvalObjEx(interp, script,  TCL_EVAL_DIRECT) != TCL_OK) {
        Tcl_SetResult(interp, (char *) "Cgmap: error getting append mol's current frame", TCL_STATIC);
        return TCL_ERROR;
    }
    int append_frame = 0;
    object = Tcl_GetObjResult(interp);
    if (Tcl_GetIntFromObj(interp, object, &append_frame) != TCL_OK) {
        Tcl_SetResult(interp, (char *) "Cgmap: error parsing append mol's current frame", TCL_STATIC);
        return TCL_ERROR;
    }

    //Get number of atoms in target (append) mol
    script = Tcl_ObjPrintf("molinfo %i get numatoms", append_molid);
    if (Tcl_EvalObjEx(interp, script,  TCL_EVAL_DIRECT) != TCL_OK) {
        Tcl_SetResult(interp, (char *) "Cgmap: error getting append mol's number of atoms", TCL_STATIC);
        return TCL_ERROR;
    }
    int append_natoms = 0;
    object = Tcl_GetObjResult(interp);
    if (Tcl_GetIntFromObj(interp, object, &append_natoms) != TCL_OK) {
        Tcl_SetResult(interp, (char *) "Cgmap: error parsing append mol's number of atoms", TCL_STATIC);
        return TCL_ERROR;
    }

    int print = ((last - first) / 10);
    if (print < 10) print = 10;
    if (print > 100) print = 100;

    //Loop over frames, calculate COMS, set coordinates in target mol
    for (int frame = first;
         frame <= last && frame < nframes;
         frame += stride) {

        if (frame % print == 0) {
            //Tcl_Obj *msg = Tcl_ObjPrintf ("puts \"Mapping frame %i\"", frame);
            Tcl_Obj *msg = Tcl_ObjPrintf ("vmdcon -info \"CGit> Mapping frame %i\"", frame);
            result = Tcl_EvalObjEx(interp, msg, TCL_EVAL_DIRECT);
            if (result != TCL_OK) { return TCL_ERROR; }
        }

        //Update the frames
        Tcl_Obj *mol_chgframe = Tcl_ObjPrintf ("molinfo top set frame %i", frame);
        if (Tcl_EvalObjEx(interp, mol_chgframe, TCL_EVAL_DIRECT) != TCL_OK)
            return TCL_ERROR;

        // Get the coordinates of the molecules in the reference mol
        Tcl_Obj *get_ts = Tcl_ObjPrintf("gettimestep %d %i", molid, frame);
        if (Tcl_EvalObjEx(interp, get_ts,  TCL_EVAL_DIRECT) != TCL_OK) {
            Tcl_SetResult(interp, (char *) "Cgmap: error getting coordinates", TCL_STATIC);
            return TCL_ERROR;
        }

        bytes = Tcl_GetObjResult(interp);
        Tcl_IncrRefCount(bytes);
        Tcl_InvalidateStringRep (bytes);
        coords = reinterpret_cast<float *> (Tcl_GetByteArrayFromObj(bytes, &length));

        /** Create a new frame for append_mol **/
        Tcl_ObjPrintf("animate dup %i", append_molid);
        if (Tcl_EvalObjEx(interp, get_ts,  TCL_EVAL_DIRECT) != TCL_OK) {
            Tcl_SetResult(interp, (char *) "Cgmap: error adding frame to append mol", TCL_STATIC);
            return TCL_ERROR;
        }
        append_frame++;

        Tcl_Obj *setframe = Tcl_ObjPrintf("molinfo %i set frame %i; display update", molid, frame);
        if (Tcl_EvalObjEx(interp, setframe,  TCL_EVAL_DIRECT) != TCL_OK) {
            Tcl_SetResult(interp, (char *) "Cgmap: error updating source frame", TCL_STATIC);
            return TCL_ERROR;
        }

        // Copy PBC conditions
        Tcl_Obj *setpbc = Tcl_ObjPrintf("molinfo %i set {a b c} [molinfo %i get {a b c}]", append_molid, molid);
        if (Tcl_EvalObjEx(interp, setpbc,  TCL_EVAL_DIRECT) != TCL_OK) {
            Tcl_SetResult(interp, (char *) "Cgmap: error updating PBC", TCL_STATIC);
            return TCL_ERROR;
        }

        // Get the coordinates of the molecules in the target (append) mol
        get_ts = Tcl_ObjPrintf("gettimestep %d %i", append_molid, append_frame);
        if (Tcl_EvalObjEx(interp, get_ts,  TCL_EVAL_DIRECT) != TCL_OK) {
            Tcl_SetResult(interp, (char *) "Cgmap: error getting coordinates", TCL_STATIC);
            return TCL_ERROR;
        }

        bytes_append = Tcl_GetObjResult(interp);
        Tcl_IncrRefCount(bytes_append);
        Tcl_InvalidateStringRep(bytes_append);
        coords_append = reinterpret_cast<float *> (Tcl_GetByteArrayFromObj(bytes_append, &length));


        //loop over coordinates and beads, calculate COMs
        int current_bead, current_atom;
        current_bead = current_atom = 0;

        // Nested loop to work on each bead at a time
        float w,x,y,z;
        int j = 0;
        for (int start_atom = 0; start_atom < natoms; ) {
            current_bead = bead[start_atom];

            w = x = y = z = 0;
            // Calculate COM for each bead
            for ( current_atom = start_atom;
                  current_atom < natoms && bead[current_atom] == current_bead;
                  current_atom++) {

                //Lookup the atom index from the selection
                unsigned int idx = index[current_atom];
                float tw = weight[current_atom];

                w += tw;
                x += tw * coords[3*idx];
                y += tw * coords[3*idx+1];
                z += tw * coords[3*idx+2];
            }

            if (w == 0) {
                Tcl_SetResult(interp, (char *) "Cgmap: Bad weight can't total zero", TCL_STATIC);
                return TCL_ERROR;
            }

            // Insert calculated COMS into append_mols coordinate array
            // Need to figure out some kind of bounds checking here...
            coords_append[3 * j    ] = x / w;
            coords_append[3 * j + 1] = y / w;
            coords_append[3 * j + 2] = z / w;

            start_atom = current_atom;
            j++;
        } // bead loop

        // call rawtimestep to set byte array for append_mol
        Tcl_Obj *set_ts[5];

        set_ts[0] = Tcl_NewStringObj("rawtimestep", -1);
        set_ts[1] = Tcl_ObjPrintf("%d",append_molid);
        set_ts[2] = bytes_append;
        set_ts[3] = Tcl_NewStringObj("-frame", -1);
        set_ts[4] = Tcl_NewIntObj(append_frame);

        if (Tcl_EvalObjv (interp, 5, set_ts, 0) != TCL_OK)
            return TCL_ERROR;

        //Cleanup
        Tcl_DecrRefCount(bytes);
        Tcl_DecrRefCount(bytes_append);

    } // Frame loop

    //Cleanup
    Tcl_DecrRefCount(atomselect);

    Tcl_SetResult(interp, (char *) "", TCL_STATIC);
    return TCL_OK;
}
Exemplo n.º 10
0
void
TkMakeRawCurvePostscript(
    Tcl_Interp *interp,		/* Interpreter in whose result the Postscript
				 * is to be stored. */
    Tk_Canvas canvas,		/* Canvas widget for which the Postscript is
				 * being generated. */
    double *pointPtr,		/* Array of input coordinates: x0, y0, x1, y1,
				 * etc.. */
    int numPoints)		/* Number of points at pointPtr. */
{
    int i;
    double *segPtr;
    Tcl_Obj *psObj;

    /*
     * Put the first point into the path.
     */

    psObj = Tcl_ObjPrintf("%.15g %.15g moveto\n",
	    pointPtr[0], Tk_CanvasPsY(canvas, pointPtr[1]));

    /*
     * Loop through all the remaining points in the curve, generating a
     * straight line or curve section for every three of them.
     */

    for (i=numPoints-1,segPtr=pointPtr ; i>=3 ; i-=3,segPtr+=6) {
	if (segPtr[0]==segPtr[2] && segPtr[1]==segPtr[3] &&
		segPtr[4]==segPtr[6] && segPtr[5]==segPtr[7]) {
	    /*
	     * The control points on this segment are equal to their
	     * neighbouring knots, so this segment is just a straight line.
	     */

	    Tcl_AppendPrintfToObj(psObj, "%.15g %.15g lineto\n",
		    segPtr[6], Tk_CanvasPsY(canvas, segPtr[7]));
	} else {
	    /*
	     * This is a generic Bezier curve segment.
	     */

	    Tcl_AppendPrintfToObj(psObj,
		    "%.15g %.15g %.15g %.15g %.15g %.15g curveto\n",
		    segPtr[2], Tk_CanvasPsY(canvas, segPtr[3]),
		    segPtr[4], Tk_CanvasPsY(canvas, segPtr[5]),
		    segPtr[6], Tk_CanvasPsY(canvas, segPtr[7]));
	}
    }

    /*
     * If there are any points left that haven't been used, then build the
     * last segment and generate Postscript in the same way for that.
     */

    if (i > 0) {
	int j;
	double control[8];

	for (j=0; j<2*i+2; j++) {
	    control[j] = segPtr[j];
	}
	for (; j<8; j++) {
	    control[j] = pointPtr[j-2*i-2];
	}

	if (control[0]==control[2] && control[1]==control[3] &&
		control[4]==control[6] && control[5]==control[7]) {
	    /*
	     * Straight line.
	     */

	    Tcl_AppendPrintfToObj(psObj, "%.15g %.15g lineto\n",
		    control[6], Tk_CanvasPsY(canvas, control[7]));
	} else {
	    /*
	     * Bezier curve segment.
	     */

	    Tcl_AppendPrintfToObj(psObj,
		    "%.15g %.15g %.15g %.15g %.15g %.15g curveto\n",
		    control[2], Tk_CanvasPsY(canvas, control[3]),
		    control[4], Tk_CanvasPsY(canvas, control[5]),
		    control[6], Tk_CanvasPsY(canvas, control[7]));
	}
    }

    Tcl_AppendObjToObj(Tcl_GetObjResult(interp), psObj);
    Tcl_DecrRefCount(psObj);
}
Exemplo n.º 11
0
void
TkMakeBezierPostscript(
    Tcl_Interp *interp,		/* Interpreter in whose result the Postscript
				 * is to be stored. */
    Tk_Canvas canvas,		/* Canvas widget for which the Postscript is
				 * being generated. */
    double *pointPtr,		/* Array of input coordinates: x0, y0, x1, y1,
				 * etc.. */
    int numPoints)		/* Number of points at pointPtr. */
{
    int closed, i;
    int numCoords = numPoints*2;
    double control[8];
    Tcl_Obj *psObj;

    /*
     * If the curve is a closed one then generate a special spline that spans
     * the last points and the first ones. Otherwise just put the first point
     * into the path.
     */

    if ((pointPtr[0] == pointPtr[numCoords-2])
	    && (pointPtr[1] == pointPtr[numCoords-1])) {
	closed = 1;
	control[0] = 0.5*pointPtr[numCoords-4] + 0.5*pointPtr[0];
	control[1] = 0.5*pointPtr[numCoords-3] + 0.5*pointPtr[1];
	control[2] = 0.167*pointPtr[numCoords-4] + 0.833*pointPtr[0];
	control[3] = 0.167*pointPtr[numCoords-3] + 0.833*pointPtr[1];
	control[4] = 0.833*pointPtr[0] + 0.167*pointPtr[2];
	control[5] = 0.833*pointPtr[1] + 0.167*pointPtr[3];
	control[6] = 0.5*pointPtr[0] + 0.5*pointPtr[2];
	control[7] = 0.5*pointPtr[1] + 0.5*pointPtr[3];
	psObj = Tcl_ObjPrintf(
		"%.15g %.15g moveto\n"
		"%.15g %.15g %.15g %.15g %.15g %.15g curveto\n",
		control[0], Tk_CanvasPsY(canvas, control[1]),
		control[2], Tk_CanvasPsY(canvas, control[3]),
		control[4], Tk_CanvasPsY(canvas, control[5]),
		control[6], Tk_CanvasPsY(canvas, control[7]));
    } else {
	closed = 0;
	control[6] = pointPtr[0];
	control[7] = pointPtr[1];
	psObj = Tcl_ObjPrintf("%.15g %.15g moveto\n",
		control[6], Tk_CanvasPsY(canvas, control[7]));
    }

    /*
     * Cycle through all the remaining points in the curve, generating a curve
     * section for each vertex in the linear path.
     */

    for (i = numPoints-2, pointPtr += 2; i > 0; i--, pointPtr += 2) {
	control[2] = 0.333*control[6] + 0.667*pointPtr[0];
	control[3] = 0.333*control[7] + 0.667*pointPtr[1];

	/*
	 * Set up the last two control points. This is done differently for
	 * the last spline of an open curve than for other cases.
	 */

	if ((i == 1) && !closed) {
	    control[6] = pointPtr[2];
	    control[7] = pointPtr[3];
	} else {
	    control[6] = 0.5*pointPtr[0] + 0.5*pointPtr[2];
	    control[7] = 0.5*pointPtr[1] + 0.5*pointPtr[3];
	}
	control[4] = 0.333*control[6] + 0.667*pointPtr[0];
	control[5] = 0.333*control[7] + 0.667*pointPtr[1];

	Tcl_AppendPrintfToObj(psObj,
		"%.15g %.15g %.15g %.15g %.15g %.15g curveto\n",
		control[2], Tk_CanvasPsY(canvas, control[3]),
		control[4], Tk_CanvasPsY(canvas, control[5]),
		control[6], Tk_CanvasPsY(canvas, control[7]));
    }

    Tcl_AppendObjToObj(Tcl_GetObjResult(interp), psObj);
    Tcl_DecrRefCount(psObj);
}
Exemplo n.º 12
0
static int
TextToPostscript(
    Tcl_Interp *interp,		/* Leave Postscript or error message here. */
    Tk_Canvas canvas,		/* Information about overall canvas. */
    Tk_Item *itemPtr,		/* Item for which Postscript is wanted. */
    int prepass)		/* 1 means this is a prepass to collect font
				 * information; 0 means final Postscript is
				 * being created. */
{
    TextItem *textPtr = (TextItem *) itemPtr;
    double x, y;
    Tk_FontMetrics fm;
    const char *justify;
    XColor *color;
    Pixmap stipple;
    Tk_State state = itemPtr->state;
    Tcl_Obj *psObj;
    Tcl_InterpState interpState;

    if (state == TK_STATE_NULL) {
	state = Canvas(canvas)->canvas_state;
    }
    color = textPtr->color;
    stipple = textPtr->stipple;
    if (state == TK_STATE_HIDDEN || textPtr->color == NULL ||
	    textPtr->text == NULL || *textPtr->text == 0) {
	return TCL_OK;
    } else if (Canvas(canvas)->currentItemPtr == itemPtr) {
	if (textPtr->activeColor != NULL) {
	    color = textPtr->activeColor;
	}
	if (textPtr->activeStipple != None) {
	    stipple = textPtr->activeStipple;
	}
    } else if (state == TK_STATE_DISABLED) {
	if (textPtr->disabledColor != NULL) {
	    color = textPtr->disabledColor;
	}
	if (textPtr->disabledStipple != None) {
	    stipple = textPtr->disabledStipple;
	}
    }

    /*
     * Make our working space.
     */

    psObj = Tcl_NewObj();
    interpState = Tcl_SaveInterpState(interp, TCL_OK);

    /*
     * Generate postscript.
     */

    Tcl_ResetResult(interp);
    if (Tk_CanvasPsFont(interp, canvas, textPtr->tkfont) != TCL_OK) {
	goto error;
    }
    Tcl_AppendObjToObj(psObj, Tcl_GetObjResult(interp));

    if (prepass != 0) {
	goto done;
    }

    Tcl_ResetResult(interp);
    if (Tk_CanvasPsColor(interp, canvas, color) != TCL_OK) {
	goto error;
    }
    Tcl_AppendObjToObj(psObj, Tcl_GetObjResult(interp));

    if (stipple != None) {
	Tcl_ResetResult(interp);
	Tk_CanvasPsStipple(interp, canvas, stipple);
	Tcl_AppendPrintfToObj(psObj, "/StippleText {\n    %s} bind def\n",
		Tcl_GetString(Tcl_GetObjResult(interp)));
    }

    x = 0;  y = 0;  justify = NULL;	/* lint. */
    switch (textPtr->anchor) {
    case TK_ANCHOR_NW:	   x = 0; y = 0; break;
    case TK_ANCHOR_N:	   x = 1; y = 0; break;
    case TK_ANCHOR_NE:	   x = 2; y = 0; break;
    case TK_ANCHOR_E:	   x = 2; y = 1; break;
    case TK_ANCHOR_SE:	   x = 2; y = 2; break;
    case TK_ANCHOR_S:	   x = 1; y = 2; break;
    case TK_ANCHOR_SW:	   x = 0; y = 2; break;
    case TK_ANCHOR_W:	   x = 0; y = 1; break;
    case TK_ANCHOR_CENTER: x = 1; y = 1; break;
    }
    switch (textPtr->justify) {
    case TK_JUSTIFY_LEFT:   justify = "0";   break;
    case TK_JUSTIFY_CENTER: justify = "0.5"; break;
    case TK_JUSTIFY_RIGHT:  justify = "1";   break;
    }

    Tk_GetFontMetrics(textPtr->tkfont, &fm);

    Tcl_AppendPrintfToObj(psObj, "%.15g %.15g %.15g [\n",
	    textPtr->angle, textPtr->x, Tk_CanvasPsY(canvas, textPtr->y));
    Tcl_ResetResult(interp);
    Tk_TextLayoutToPostscript(interp, textPtr->textLayout);
    Tcl_AppendObjToObj(psObj, Tcl_GetObjResult(interp));
    Tcl_AppendPrintfToObj(psObj,
	    "] %d %g %g %s %s DrawText\n",
	    fm.linespace, x / -2.0, y / 2.0, justify,
	    ((stipple == None) ? "false" : "true"));

    /*
     * Plug the accumulated postscript back into the result.
     */

  done:
    (void) Tcl_RestoreInterpState(interp, interpState);
    Tcl_AppendObjToObj(Tcl_GetObjResult(interp), psObj);
    Tcl_DecrRefCount(psObj);
    return TCL_OK;

  error:
    Tcl_DiscardInterpState(interpState);
    Tcl_DecrRefCount(psObj);
    return TCL_ERROR;
}
Exemplo n.º 13
0
Arquivo: tclFCmd.c Projeto: smh377/tcl
static int
CopyRenameOneFile(
    Tcl_Interp *interp,		/* Used for error reporting. */
    Tcl_Obj *source,		/* Pathname of file to copy. May need to be
				 * translated. */
    Tcl_Obj *target,		/* Pathname of file to create/overwrite. May
				 * need to be translated. */
    int copyFlag,		/* If non-zero, copy files. Otherwise, rename
				 * them. */
    int force)			/* If non-zero, overwrite target file if it
				 * exists. Otherwise, error if target already
				 * exists. */
{
    int result;
    Tcl_Obj *errfile, *errorBuffer;
    Tcl_Obj *actualSource=NULL;	/* If source is a link, then this is the real
				 * file/directory. */
    Tcl_StatBuf sourceStatBuf, targetStatBuf;

    if (Tcl_FSConvertToPathType(interp, source) != TCL_OK) {
	return TCL_ERROR;
    }
    if (Tcl_FSConvertToPathType(interp, target) != TCL_OK) {
	return TCL_ERROR;
    }

    errfile = NULL;
    errorBuffer = NULL;
    result = TCL_ERROR;

    /*
     * We want to copy/rename links and not the files they point to, so we use
     * lstat(). If target is a link, we also want to replace the link and not
     * the file it points to, so we also use lstat() on the target.
     */

    if (Tcl_FSLstat(source, &sourceStatBuf) != 0) {
	errfile = source;
	goto done;
    }
    if (Tcl_FSLstat(target, &targetStatBuf) != 0) {
	if (errno != ENOENT) {
	    errfile = target;
	    goto done;
	}
    } else {
	if (force == 0) {
	    errno = EEXIST;
	    errfile = target;
	    goto done;
	}

	/*
	 * Prevent copying or renaming a file onto itself. On Windows since
	 * 8.5 we do get an inode number, however the unsigned short field is
	 * insufficient to accept the Win32 API file id so it is truncated to
	 * 16 bits and we get collisions. See bug #2015723.
	 */

#if !defined(_WIN32) && !defined(__CYGWIN__)
	if ((sourceStatBuf.st_ino != 0) && (targetStatBuf.st_ino != 0)) {
	    if ((sourceStatBuf.st_ino == targetStatBuf.st_ino) &&
		    (sourceStatBuf.st_dev == targetStatBuf.st_dev)) {
		result = TCL_OK;
		goto done;
	    }
	}
#endif

	/*
	 * Prevent copying/renaming a file onto a directory and vice-versa.
	 * This is a policy decision based on the fact that existing
	 * implementations of copy and rename on all platforms also prevent
	 * this.
	 */

	if (S_ISDIR(sourceStatBuf.st_mode)
		&& !S_ISDIR(targetStatBuf.st_mode)) {
	    errno = EISDIR;
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "can't overwrite file \"%s\" with directory \"%s\"",
		    TclGetString(target), TclGetString(source)));
	    goto done;
	}
	if (!S_ISDIR(sourceStatBuf.st_mode)
		&& S_ISDIR(targetStatBuf.st_mode)) {
	    errno = EISDIR;
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "can't overwrite directory \"%s\" with file \"%s\"",
		    TclGetString(target), TclGetString(source)));
	    goto done;
	}

	/*
	 * The destination exists, but appears to be ok to over-write, and
	 * -force is given. We now try to adjust permissions to ensure the
	 * operation succeeds. If we can't adjust permissions, we'll let the
	 * actual copy/rename return an error later.
	 */

	{
	    Tcl_Obj *perm;
	    int index;

	    TclNewLiteralStringObj(perm, "u+w");
	    Tcl_IncrRefCount(perm);
	    if (TclFSFileAttrIndex(target, "-permissions", &index) == TCL_OK) {
		Tcl_FSFileAttrsSet(NULL, index, target, perm);
	    }
	    Tcl_DecrRefCount(perm);
	}
    }

    if (copyFlag == 0) {
	result = Tcl_FSRenameFile(source, target);
	if (result == TCL_OK) {
	    goto done;
	}

	if (errno == EINVAL) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "error renaming \"%s\" to \"%s\": trying to rename a"
		    " volume or move a directory into itself",
		    TclGetString(source), TclGetString(target)));
	    goto done;
	} else if (errno != EXDEV) {
	    errfile = target;
	    goto done;
	}

	/*
	 * The rename failed because the move was across file systems. Fall
	 * through to copy file and then remove original. Note that the
	 * low-level Tcl_FSRenameFileProc in the filesystem is allowed to
	 * implement cross-filesystem moves itself, if it desires.
	 */
    }

    actualSource = source;
    Tcl_IncrRefCount(actualSource);

    /*
     * Activate the following block to copy files instead of links. However
     * Tcl's semantics currently say we should copy links, so any such change
     * should be the subject of careful study on the consequences.
     *
     * Perhaps there could be an optional flag to 'file copy' to dictate which
     * approach to use, with the default being _not_ to have this block
     * active.
     */

#if 0
#ifdef S_ISLNK
    if (copyFlag && S_ISLNK(sourceStatBuf.st_mode)) {
	/*
	 * We want to copy files not links. Therefore we must follow the link.
	 * There are two purposes to this 'stat' call here. First we want to
	 * know if the linked-file/dir actually exists, and second, in the
	 * block of code which follows, some 20 lines down, we want to check
	 * if the thing is a file or directory.
	 */

	if (Tcl_FSStat(source, &sourceStatBuf) != 0) {
	    /*
	     * Actual file doesn't exist.
	     */

	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "error copying \"%s\": the target of this link doesn't"
		    " exist", TclGetString(source)));
	    goto done;
	} else {
	    int counter = 0;

	    while (1) {
		Tcl_Obj *path = Tcl_FSLink(actualSource, NULL, 0);
		if (path == NULL) {
		    break;
		}

		/*
		 * Now we want to check if this is a relative path, and if so,
		 * to make it absolute.
		 */

		if (Tcl_FSGetPathType(path) == TCL_PATH_RELATIVE) {
		    Tcl_Obj *abs = Tcl_FSJoinToPath(actualSource, 1, &path);

		    if (abs == NULL) {
			break;
		    }
		    Tcl_IncrRefCount(abs);
		    Tcl_DecrRefCount(path);
		    path = abs;
		}
		Tcl_DecrRefCount(actualSource);
		actualSource = path;
		counter++;

		/*
		 * Arbitrary limit of 20 links to follow.
		 */

		if (counter > 20) {
		    /*
		     * Too many links.
		     */

		    Tcl_SetErrno(EMLINK);
		    errfile = source;
		    goto done;
		}
	    }
	    /* Now 'actualSource' is the correct file */
	}
    }
#endif /* S_ISLNK */
#endif

    if (S_ISDIR(sourceStatBuf.st_mode)) {
	result = Tcl_FSCopyDirectory(actualSource, target, &errorBuffer);
	if (result != TCL_OK) {
	    if (errno == EXDEV) {
		/*
		 * The copy failed because we're trying to do a
		 * cross-filesystem copy. We do this through our Tcl library.
		 */

		Tcl_Obj *copyCommand, *cmdObj, *opObj;

		TclNewObj(copyCommand);
		TclNewLiteralStringObj(cmdObj, "::tcl::CopyDirectory");
		Tcl_ListObjAppendElement(interp, copyCommand, cmdObj);
		if (copyFlag) {
		    TclNewLiteralStringObj(opObj, "copying");
		} else {
		    TclNewLiteralStringObj(opObj, "renaming");
		}
		Tcl_ListObjAppendElement(interp, copyCommand, opObj);
		Tcl_ListObjAppendElement(interp, copyCommand, source);
		Tcl_ListObjAppendElement(interp, copyCommand, target);
		Tcl_IncrRefCount(copyCommand);
		result = Tcl_EvalObjEx(interp, copyCommand,
			TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT);
		Tcl_DecrRefCount(copyCommand);
		if (result != TCL_OK) {
		    /*
		     * There was an error in the Tcl-level copy. We will pass
		     * on the Tcl error message and can ensure this by setting
		     * errfile to NULL
		     */

		    errfile = NULL;
		}
	    } else {
		errfile = errorBuffer;
		if (Tcl_FSEqualPaths(errfile, source)) {
		    errfile = source;
		} else if (Tcl_FSEqualPaths(errfile, target)) {
		    errfile = target;
		}
	    }
	}
    } else {
	result = Tcl_FSCopyFile(actualSource, target);
	if ((result != TCL_OK) && (errno == EXDEV)) {
	    result = TclCrossFilesystemCopy(interp, source, target);
	}
	if (result != TCL_OK) {
	    /*
	     * We could examine 'errno' to double-check if the problem was
	     * with the target, but we checked the source above, so it should
	     * be quite clear
	     */

	    errfile = target;
	}
	/*
	 * We now need to reset the result, because the above call,
	 * may have left set it.  (Ideally we would prefer not to pass
	 * an interpreter in above, but the channel IO code used by
	 * TclCrossFilesystemCopy currently requires one)
	 */
	Tcl_ResetResult(interp);
    }
    if ((copyFlag == 0) && (result == TCL_OK)) {
	if (S_ISDIR(sourceStatBuf.st_mode)) {
	    result = Tcl_FSRemoveDirectory(source, 1, &errorBuffer);
	    if (result != TCL_OK) {
		errfile = errorBuffer;
		if (Tcl_FSEqualPaths(errfile, source) == 0) {
		    errfile = source;
		}
	    }
	} else {
	    result = Tcl_FSDeleteFile(source);
	    if (result != TCL_OK) {
		errfile = source;
	    }
	}
	if (result != TCL_OK) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf("can't unlink \"%s\": %s",
		    TclGetString(errfile), Tcl_PosixError(interp)));
	    errfile = NULL;
	}
    }

  done:
    if (errfile != NULL) {
	Tcl_Obj *errorMsg = Tcl_ObjPrintf("error %s \"%s\"",
		(copyFlag ? "copying" : "renaming"), TclGetString(source));

	if (errfile != source) {
	    Tcl_AppendPrintfToObj(errorMsg, " to \"%s\"",
		    TclGetString(target));
	    if (errfile != target) {
		Tcl_AppendPrintfToObj(errorMsg, ": \"%s\"",
			TclGetString(errfile));
	    }
	}
	Tcl_AppendPrintfToObj(errorMsg, ": %s", Tcl_PosixError(interp));
	Tcl_SetObjResult(interp, errorMsg);
    }
    if (errorBuffer != NULL) {
	Tcl_DecrRefCount(errorBuffer);
    }
    if (actualSource != NULL) {
	Tcl_DecrRefCount(actualSource);
    }
    return result;
}
Exemplo n.º 14
0
	/* ARGSUSED */
int
TclChannelTransform(
    Tcl_Interp *interp,		/* Interpreter for result. */
    Tcl_Channel chan,		/* Channel to transform. */
    Tcl_Obj *cmdObjPtr)		/* Script to use for transform. */
{
    Channel *chanPtr;		/* The actual channel. */
    ChannelState *statePtr;	/* State info for channel. */
    int mode;			/* Read/write mode of the channel. */
    int objc;
    TransformChannelData *dataPtr;
    Tcl_DString ds;

    if (chan == NULL) {
	return TCL_ERROR;
    }

    if (TCL_OK != Tcl_ListObjLength(interp, cmdObjPtr, &objc)) {
	Tcl_SetObjResult(interp,
		Tcl_NewStringObj("-command value is not a list", -1));
	return TCL_ERROR;
    }

    chanPtr = (Channel *) chan;
    statePtr = chanPtr->state;
    chanPtr = statePtr->topChanPtr;
    chan = (Tcl_Channel) chanPtr;
    mode = (statePtr->flags & (TCL_READABLE|TCL_WRITABLE));

    /*
     * Now initialize the transformation state and stack it upon the specified
     * channel. One of the necessary things to do is to retrieve the blocking
     * regime of the underlying channel and to use the same for us too.
     */

    dataPtr = ckalloc(sizeof(TransformChannelData));

    dataPtr->refCount = 1;
    Tcl_DStringInit(&ds);
    Tcl_GetChannelOption(interp, chan, "-blocking", &ds);
    dataPtr->readIsFlushed = 0;
    dataPtr->eofPending = 0;
    dataPtr->flags = 0;
    if (ds.string[0] == '0') {
	dataPtr->flags |= CHANNEL_ASYNC;
    }
    Tcl_DStringFree(&ds);

    dataPtr->watchMask = 0;
    dataPtr->mode = mode;
    dataPtr->timer = NULL;
    dataPtr->maxRead = 4096;	/* Initial value not relevant. */
    dataPtr->interp = interp;
    dataPtr->command = cmdObjPtr;
    Tcl_IncrRefCount(dataPtr->command);

    ResultInit(&dataPtr->result);

    dataPtr->self = Tcl_StackChannel(interp, &transformChannelType, dataPtr,
	    mode, chan);
    if (dataPtr->self == NULL) {
	Tcl_AppendPrintfToObj(Tcl_GetObjResult(interp),
		"\nfailed to stack channel \"%s\"", Tcl_GetChannelName(chan));
	ReleaseData(dataPtr);
	return TCL_ERROR;
    }
    Tcl_Preserve(dataPtr->self);

    /*
     * At last initialize the transformation at the script level.
     */

    PreserveData(dataPtr);
    if ((dataPtr->mode & TCL_WRITABLE) && ExecuteCallback(dataPtr, NULL,
	    A_CREATE_WRITE, NULL, 0, TRANSMIT_DONT, P_NO_PRESERVE) != TCL_OK){
	Tcl_UnstackChannel(interp, chan);
	ReleaseData(dataPtr);
	return TCL_ERROR;
    }

    if ((dataPtr->mode & TCL_READABLE) && ExecuteCallback(dataPtr, NULL,
	    A_CREATE_READ, NULL, 0, TRANSMIT_DONT, P_NO_PRESERVE) != TCL_OK) {
	ExecuteCallback(dataPtr, NULL, A_DELETE_WRITE, NULL, 0, TRANSMIT_DONT,
		P_NO_PRESERVE);
	Tcl_UnstackChannel(interp, chan);
	ReleaseData(dataPtr);
	return TCL_ERROR;
    }

    ReleaseData(dataPtr);
    return TCL_OK;
}