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;
}
/*
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);
}
}
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;
}
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;
}
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);
}
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);
}
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);
}
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;
}
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;
}
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);
}
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);
}
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;
}
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;
}
/* 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;
}
