static Blt_Chain
ImportPbm(Tcl_Interp *interp, int objc, Tcl_Obj *const *objv,
const char **fileNamePtr)
{
Blt_DBuffer dbuffer;
Blt_Chain chain;
PbmImportSwitches switches;
const char *string;
memset(&switches, 0, sizeof(switches));
switches.imageIndex = 1;
switches.gamma = 1.0;
if (Blt_ParseSwitches(interp, importSwitches, objc - 3, objv + 3,
&switches, BLT_SWITCH_DEFAULTS) < 0) {
Blt_FreeSwitches(importSwitches, (char *)&switches, 0);
return NULL;
}
if ((switches.dataObjPtr != NULL) && (switches.fileObjPtr != NULL)) {
Tcl_AppendResult(interp, "more than one import source: ",
"use only one -file or -data flag.", (char *)NULL);
Blt_FreeSwitches(importSwitches, (char *)&switches, 0);
return NULL;
}
dbuffer = Blt_DBuffer_Create();
chain = NULL;
if (switches.dataObjPtr != NULL) {
unsigned char *bytes;
int nBytes;
bytes = Tcl_GetByteArrayFromObj(switches.dataObjPtr, &nBytes);
if (Blt_IsBase64(bytes, nBytes)) {
if (Blt_DBuffer_DecodeBase64(interp, string, nBytes, dbuffer)
!= TCL_OK) {
goto error;
}
} else {
Blt_DBuffer_AppendData(dbuffer, bytes, nBytes);
}
string = "data buffer";
*fileNamePtr = NULL;
} else {
string = Tcl_GetString(switches.fileObjPtr);
*fileNamePtr = string;
if (Blt_DBuffer_LoadFile(interp, string, dbuffer) != TCL_OK) {
goto error;
}
}
chain = PbmToPictures(interp, string, dbuffer, &switches);
error:
Blt_FreeSwitches(importSwitches, (char *)&switches, 0);
Blt_DBuffer_Destroy(dbuffer);
return chain;
}
static int _put(ClientData clientData, Tcl_Interp *interp, int argc, Tcl_Obj* const *objv) {
if (argc != 3)
return fw_error_obj(interp, Tcl_ObjPrintf("usage: %s put string", Tcl_GetString(objv[0])));
_t *data = (_t *)clientData;
int n;
unsigned char *p = Tcl_GetByteArrayFromObj(objv[2], &n);
if (n > 0) {
if (midi_buffer_write_command(&data->midi, 0, p, n) < 0)
return fw_error_str(interp, "error writing midi command");
}
return TCL_OK;
}
/*++
ZlibCompressObj
Compresses data using the Zlib compression algorithm.
Arguments:
sourceObj - Pointer to a Tcl object containing the data to be compressed.
destObj - Pointer to a Tcl object to receive the compressed data.
level - Compression level.
window - Maximum window size for Zlib.
Return Value:
A Zlib status code; Z_OK is returned if successful.
--*/
static int
ZlibCompressObj(
Tcl_Obj *sourceObj,
Tcl_Obj *destObj,
int level,
int window
)
{
int status;
z_stream stream;
//
// The next_in, opaque, zalloc, and zfree data structure members
// must be initialised prior to calling deflateInit2().
//
stream.next_in = Tcl_GetByteArrayFromObj(sourceObj, (int *)&stream.avail_in);
stream.opaque = NULL;
stream.zalloc = ZlibAlloc;
stream.zfree = ZlibFree;
status = deflateInit2(&stream, level, Z_DEFLATED, window,
MAX_MEM_LEVEL, Z_DEFAULT_STRATEGY);
if (status != Z_OK) {
return status;
}
stream.avail_out = deflateBound(&stream, stream.avail_in);
//
// deflateBound() does not always return a sufficient buffer size when
// compressing data into the Gzip format. So this kludge will do...
//
if (window > 15) {
stream.avail_out *= 2;
}
stream.next_out = Tcl_SetByteArrayLength(destObj, (int)stream.avail_out);
//
// The Z_FINISH flag instructs Zlib to compress all data in a single
// pass, flush it to the output buffer, and return with Z_STREAM_END if
// successful.
//
status = deflate(&stream, Z_FINISH);
deflateEnd(&stream);
if (status == Z_STREAM_END) {
Tcl_SetByteArrayLength(destObj, (int)stream.total_out);
return Z_OK;
}
return (status == Z_OK) ? Z_BUF_ERROR : status;
}
/*
*---------------------------------------------------------------------------
*
* HtmlImageAlphaChannel --
*
* Results:
*
* 1 if there are one or more pixels in the image with an alpha
* alpha-channel value of other than 100%. Otherwise 0.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
int
HtmlImageAlphaChannel (HtmlImage2 *pImage)
{
HtmlImage2 *p = (pImage->pUnscaled ? pImage->pUnscaled : pImage);
if (p->eAlpha == ALPHA_CHANNEL_UNKNOWN) {
HtmlTree *pTree= pImage->pImageServer->pTree;
Tk_PhotoHandle photo;
Tk_PhotoImageBlock block;
int x, y;
int w = p->width;
int h = p->height;
Tcl_Obj *pCompressed = getImageCompressed(pImage);
unsigned char *zCompressed;
int nCompressed;
int i;
assert(pCompressed);
zCompressed = Tcl_GetByteArrayFromObj(pCompressed, &nCompressed);
for(i = 0; 1 && i < 16 && i < (nCompressed-4); i++){
if (zCompressed[i] == 'J' &&
zCompressed[i+1] == 'F' &&
zCompressed[i+2] == 'I' &&
zCompressed[i+3] == 'F'
) {
p->eAlpha = ALPHA_CHANNEL_FALSE;
return 0;
}
}
p->eAlpha = ALPHA_CHANNEL_FALSE;
photo = Tk_FindPhoto(pTree->interp, Tcl_GetString(p->pImageName));
if (!photo) return 0;
Tk_PhotoGetImage(photo, &block);
if (!block.pixelPtr) return 0;
for (y = 0; y < h; y++) {
unsigned char *z = &block.pixelPtr[block.pitch*y+block.offset[3]];
for (x = 0; x < w; x++) {
if (*z != 255) {
p->eAlpha = ALPHA_CHANNEL_TRUE;
return 1;
}
z += block.pixelSize;
}
}
}
return ((p->eAlpha == ALPHA_CHANNEL_TRUE) ? 1 : 0);
}
/*
** usage: btree_insert CSR ?KEY? VALUE
**
** Set the size of the cache used by btree $ID.
*/
static int btree_insert(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[]
){
BtCursor *pCur;
int rc;
BtreePayload x;
if( objc!=4 && objc!=3 ){
Tcl_WrongNumArgs(interp, 1, objv, "?-intkey? CSR KEY VALUE");
return TCL_ERROR;
}
memset(&x, 0, sizeof(x));
if( objc==4 ){
if( Tcl_GetIntFromObj(interp, objv[2], &rc) ) return TCL_ERROR;
x.nKey = rc;
x.pData = (void*)Tcl_GetByteArrayFromObj(objv[3], &x.nData);
}else{
x.pKey = (void*)Tcl_GetByteArrayFromObj(objv[2], &rc);
x.nKey = rc;
}
pCur = (BtCursor*)sqlite3TestTextToPtr(Tcl_GetString(objv[1]));
sqlite3_mutex_enter(pCur->pBtree->db->mutex);
sqlite3BtreeEnter(pCur->pBtree);
rc = sqlite3BtreeInsert(pCur, &x, 0, 0);
sqlite3BtreeLeave(pCur->pBtree);
sqlite3_mutex_leave(pCur->pBtree->db->mutex);
Tcl_ResetResult(interp);
if( rc ){
Tcl_AppendResult(interp, sqlite3ErrName(rc), 0);
return TCL_ERROR;
}
return TCL_OK;
}
static int _process(jack_nframes_t nframes, void *arg) {
_t *data = (_t *)arg;
if (data->started) {
// this will work funny if there are xruns happening, as when we try to use --driver netone
jack_nframes_t wframe = sdrkit_last_frame_time(arg);
size_t offset = (wframe&(data->buff_size-1));
if (offset + nframes > data->buff_size) {
fprintf(stderr, "offset = %ld + nframes = %ld > size = %d\n", offset, (long)nframes, data->buff_size);
// need to implement a misaligned copy/set, but I'm betting that jacks frame time is buffer aligned
// and I was winning the bet until I tried to use --driver netone
} else {
float *in0 = jack_port_get_buffer(framework_input(arg,0), nframes);
float *in1 = jack_port_get_buffer(framework_input(arg,1), nframes);
int size;
if (data->opts.as_complex) {
float complex *out = (float complex *)Tcl_GetByteArrayFromObj(data->current->buff, &size);
out += offset;
for (int i = nframes; --i >= 0; )
*out++ = *in0++ + I * *in1++;
} else {
float *out = (float *)Tcl_GetByteArrayFromObj(data->current->buff, &size);
out += offset;
memcpy(out, in0, nframes*sizeof(float));
out += data->buff_size;
memcpy(out, in1, nframes*sizeof(float));
}
// check for end of current buffer
if (offset+nframes == data->buff_size) {
data->current->bframe = wframe - offset;
data->current->bread = 0;
for (int i = 0; i < data->buff_n; i += 1)
if (data->buffs[i].bframe < data->current->bframe && ! Tcl_IsShared(data->buffs[i].buff))
data->current = &data->buffs[i];
data->current->bread = 1;
}
}
}
return 0;
}
void ObjToSqliteContextValue(Tcl_Obj *objP, sqlite3_context *sqlctxP)
{
unsigned char *data;
int len;
if (objP->typePtr) {
/*
* Note there is no return code checking here. Once the typePtr
* is checked, the corresponding Tcl_Get* function should
* always succeed.
*/
if (objP->typePtr == gTclStringTypeP) {
/*
* Do nothing, fall thru below to handle as default type.
* This check is here just so the most common case of text
* columns does not needlessly go through other type checks.
*/
} else if (objP->typePtr == gTclIntTypeP) {
int ival;
Tcl_GetIntFromObj(NULL, objP, &ival);
sqlite3_result_int(sqlctxP, ival);
return;
} else if (objP->typePtr == gTclWideIntTypeP) {
Tcl_WideInt i64val;
Tcl_GetWideIntFromObj(NULL, objP, &i64val);
sqlite3_result_int64(sqlctxP, i64val);
return;
} else if (objP->typePtr == gTclDoubleTypeP) {
double dval;
Tcl_GetDoubleFromObj(NULL, objP, &dval);
sqlite3_result_double(sqlctxP, dval);
return;
} else if (objP->typePtr == gTclBooleanTypeP ||
objP->typePtr == gTclBooleanStringTypeP) {
int bval;
Tcl_GetBooleanFromObj(NULL, objP, &bval);
sqlite3_result_int(sqlctxP, bval);
return;
} else if (objP->typePtr == gTclByteArrayTypeP) {
/* TBD */
data = Tcl_GetByteArrayFromObj(objP, &len);
sqlite3_result_blob(sqlctxP, data, len, SQLITE_TRANSIENT);
return;
}
}
/* Handle everything else as text by default */
data = (unsigned char *)Tcl_GetStringFromObj(objP, &len);
sqlite3_result_text(sqlctxP, data, len, SQLITE_TRANSIENT);
}
/*++
BzipCompressObj
Compresses data using the Bzip2 compression algorithm.
Arguments:
sourceObj - Pointer to a Tcl object containing the data to be compressed.
destObj - Pointer to a Tcl object to receive the compressed data.
level - Compression level.
Return Value:
A Bzip2 status code; BZ_OK is returned if successful.
--*/
static int
BzipCompressObj(
Tcl_Obj *sourceObj,
Tcl_Obj *destObj,
int level
)
{
bz_stream stream;
int status;
unsigned int destLength;
//
// The bzalloc, bzfree, and opaque data structure members
// must be initialised prior to calling BZ2_bzCompressInit().
//
stream.bzalloc = BzipAlloc;
stream.bzfree = BzipFree;
stream.opaque = NULL;
status = BZ2_bzCompressInit(&stream, level, 0, 0);
if (status != BZ_OK) {
return status;
}
stream.next_in = (char *)Tcl_GetByteArrayFromObj(sourceObj, (int *)&stream.avail_in);
//
// According to the Bzip2 documentation, the recommended buffer size
// is 1% larger than the uncompressed data, plus 600 additional bytes.
//
stream.avail_out = destLength = (unsigned int)((double)stream.avail_in * 1.01) + 600;
stream.next_out = (char *)Tcl_SetByteArrayLength(destObj, stream.avail_out);
status = BZ2_bzCompress(&stream, BZ_FINISH);
BZ2_bzCompressEnd(&stream);
if (status == BZ_STREAM_END) {
// Update the object's length.
destLength -= stream.avail_out;
Tcl_SetByteArrayLength(destObj, (int)destLength);
return BZ_OK;
}
return (status == BZ_FINISH_OK) ? BZ_OUTBUFF_FULL : status;
}
int LoadFromFile(Tcl_Interp * interp, CxImage * image, char * fileName, int Type) {
Tcl_Obj *data = Tcl_NewObj();
Tcl_Channel chan = Tcl_OpenFileChannel(interp, fileName, "r", 0);
BYTE * FileData = NULL;
int length = 0;
int retVal;
if (chan == NULL)
return FALSE;
if (Type == CXIMAGE_FORMAT_UNKNOWN) {
Type = GetFileTypeFromFileName((char *)fileName);
}
if (Type == CXIMAGE_FORMAT_UNKNOWN) {
Type = CXIMAGE_FORMAT_GIF;
}
Tcl_SetChannelOption(interp, chan, "-encoding", "binary");
Tcl_SetChannelOption(interp, chan, "-translation", "binary");
Tcl_ReadChars(chan, data, -1, 0);
Tcl_Close(interp, chan);
FileData = Tcl_GetByteArrayFromObj(data, &length);
if (! image->Decode(FileData, length, Type) &&
! image->Decode(FileData, length, CXIMAGE_FORMAT_GIF) &&
! image->Decode(FileData, length, CXIMAGE_FORMAT_PNG) &&
! image->Decode(FileData, length, CXIMAGE_FORMAT_JPG) &&
! image->Decode(FileData, length, CXIMAGE_FORMAT_TGA) &&
! image->Decode(FileData, length, CXIMAGE_FORMAT_BMP))
retVal = FALSE;
else
retVal = TRUE;
Tcl_DecrRefCount(data);
return retVal;
}
static SAFEARRAY *
newSafeArray (Tcl_Obj *pObj, VARTYPE type)
{
int size;
int length;
unsigned char *pSrc = Tcl_GetByteArrayFromObj(pObj, &length);
switch ( type ) {
case VT_I1 : size = 1; break;
case VT_I2 : size = 2; break;
case VT_I4 : size = 4; break;
case VT_UI1 : size = 1; break;
case VT_UI2 : size = 2; break;
case VT_UI4 : size = 4; break;
}
length /= size;
SAFEARRAY *psa = SafeArrayCreateVector(type, 0, length);
if (psa == 0) {
_com_issue_error(E_OUTOFMEMORY);
}
unsigned char *pDest;
HRESULT hr;
hr = SafeArrayAccessData(psa, reinterpret_cast<void **>(&pDest));
if (FAILED(hr)) {
_com_issue_error(hr);
}
memcpy(pDest, pSrc, length*size);
hr = SafeArrayUnaccessData(psa);
if (FAILED(hr)) {
_com_issue_error(hr);
}
return psa;
}
/*
** The "sqlite" command below creates a new Tcl command for each
** connection it opens to an SQLite database. This routine is invoked
** whenever one of those connection-specific commands is executed
** in Tcl. For example, if you run Tcl code like this:
**
** sqlite db1 "my_database"
** db1 close
**
** The first command opens a connection to the "my_database" database
** and calls that connection "db1". The second command causes this
** subroutine to be invoked.
*/
static int DbObjCmd(void *cd, Tcl_Interp *interp, int objc,Tcl_Obj *const*objv){
SqliteDb *pDb = (SqliteDb*)cd;
int choice;
int rc = TCL_OK;
static const char *DB_strs[] = {
"authorizer", "busy", "changes",
"close", "commit_hook", "complete",
"errorcode", "eval", "function",
"last_insert_rowid", "last_statement_changes", "onecolumn",
"progress", "rekey", "timeout",
"trace",
0
};
enum DB_enum {
DB_AUTHORIZER, DB_BUSY, DB_CHANGES,
DB_CLOSE, DB_COMMIT_HOOK, DB_COMPLETE,
DB_ERRORCODE, DB_EVAL, DB_FUNCTION,
DB_LAST_INSERT_ROWID, DB_LAST_STATEMENT_CHANGES, DB_ONECOLUMN,
DB_PROGRESS, DB_REKEY, DB_TIMEOUT,
DB_TRACE
};
if( objc<2 ){
Tcl_WrongNumArgs(interp, 1, objv, "SUBCOMMAND ...");
return TCL_ERROR;
}
if( Tcl_GetIndexFromObj(interp, objv[1], DB_strs, "option", 0, &choice) ){
return TCL_ERROR;
}
switch( (enum DB_enum)choice ){
/* $db authorizer ?CALLBACK?
**
** Invoke the given callback to authorize each SQL operation as it is
** compiled. 5 arguments are appended to the callback before it is
** invoked:
**
** (1) The authorization type (ex: SQLITE_CREATE_TABLE, SQLITE_INSERT, ...)
** (2) First descriptive name (depends on authorization type)
** (3) Second descriptive name
** (4) Name of the database (ex: "main", "temp")
** (5) Name of trigger that is doing the access
**
** The callback should return on of the following strings: SQLITE_OK,
** SQLITE_IGNORE, or SQLITE_DENY. Any other return value is an error.
**
** If this method is invoked with no arguments, the current authorization
** callback string is returned.
*/
case DB_AUTHORIZER: {
if( objc>3 ){
Tcl_WrongNumArgs(interp, 2, objv, "?CALLBACK?");
}else if( objc==2 ){
if( pDb->zAuth ){
Tcl_AppendResult(interp, pDb->zAuth, 0);
}
}else{
char *zAuth;
int len;
if( pDb->zAuth ){
Tcl_Free(pDb->zAuth);
}
zAuth = Tcl_GetStringFromObj(objv[2], &len);
if( zAuth && len>0 ){
pDb->zAuth = Tcl_Alloc( len + 1 );
strcpy(pDb->zAuth, zAuth);
}else{
pDb->zAuth = 0;
}
#ifndef SQLITE_OMIT_AUTHORIZATION
if( pDb->zAuth ){
pDb->interp = interp;
sqlite_set_authorizer(pDb->db, auth_callback, pDb);
}else{
sqlite_set_authorizer(pDb->db, 0, 0);
}
#endif
}
break;
}
/* $db busy ?CALLBACK?
**
** Invoke the given callback if an SQL statement attempts to open
** a locked database file.
*/
case DB_BUSY: {
if( objc>3 ){
Tcl_WrongNumArgs(interp, 2, objv, "CALLBACK");
return TCL_ERROR;
}else if( objc==2 ){
if( pDb->zBusy ){
Tcl_AppendResult(interp, pDb->zBusy, 0);
}
}else{
char *zBusy;
int len;
if( pDb->zBusy ){
Tcl_Free(pDb->zBusy);
}
zBusy = Tcl_GetStringFromObj(objv[2], &len);
if( zBusy && len>0 ){
pDb->zBusy = Tcl_Alloc( len + 1 );
strcpy(pDb->zBusy, zBusy);
}else{
pDb->zBusy = 0;
}
if( pDb->zBusy ){
pDb->interp = interp;
sqlite_busy_handler(pDb->db, DbBusyHandler, pDb);
}else{
sqlite_busy_handler(pDb->db, 0, 0);
}
}
break;
}
/* $db progress ?N CALLBACK?
**
** Invoke the given callback every N virtual machine opcodes while executing
** queries.
*/
case DB_PROGRESS: {
if( objc==2 ){
if( pDb->zProgress ){
Tcl_AppendResult(interp, pDb->zProgress, 0);
}
}else if( objc==4 ){
char *zProgress;
int len;
int N;
if( TCL_OK!=Tcl_GetIntFromObj(interp, objv[2], &N) ){
return TCL_ERROR;
};
if( pDb->zProgress ){
Tcl_Free(pDb->zProgress);
}
zProgress = Tcl_GetStringFromObj(objv[3], &len);
if( zProgress && len>0 ){
pDb->zProgress = Tcl_Alloc( len + 1 );
strcpy(pDb->zProgress, zProgress);
}else{
pDb->zProgress = 0;
}
#ifndef SQLITE_OMIT_PROGRESS_CALLBACK
if( pDb->zProgress ){
pDb->interp = interp;
sqlite_progress_handler(pDb->db, N, DbProgressHandler, pDb);
}else{
sqlite_progress_handler(pDb->db, 0, 0, 0);
}
#endif
}else{
Tcl_WrongNumArgs(interp, 2, objv, "N CALLBACK");
return TCL_ERROR;
}
break;
}
/*
** $db changes
**
** Return the number of rows that were modified, inserted, or deleted by
** the most recent "eval".
*/
case DB_CHANGES: {
Tcl_Obj *pResult;
int nChange;
if( objc!=2 ){
Tcl_WrongNumArgs(interp, 2, objv, "");
return TCL_ERROR;
}
nChange = sqlite_changes(pDb->db);
pResult = Tcl_GetObjResult(interp);
Tcl_SetIntObj(pResult, nChange);
break;
}
/*
** $db last_statement_changes
**
** Return the number of rows that were modified, inserted, or deleted by
** the last statment to complete execution (excluding changes due to
** triggers)
*/
case DB_LAST_STATEMENT_CHANGES: {
Tcl_Obj *pResult;
int lsChange;
if( objc!=2 ){
Tcl_WrongNumArgs(interp, 2, objv, "");
return TCL_ERROR;
}
lsChange = sqlite_last_statement_changes(pDb->db);
pResult = Tcl_GetObjResult(interp);
Tcl_SetIntObj(pResult, lsChange);
break;
}
/* $db close
**
** Shutdown the database
*/
case DB_CLOSE: {
Tcl_DeleteCommand(interp, Tcl_GetStringFromObj(objv[0], 0));
break;
}
/* $db commit_hook ?CALLBACK?
**
** Invoke the given callback just before committing every SQL transaction.
** If the callback throws an exception or returns non-zero, then the
** transaction is aborted. If CALLBACK is an empty string, the callback
** is disabled.
*/
case DB_COMMIT_HOOK: {
if( objc>3 ){
Tcl_WrongNumArgs(interp, 2, objv, "?CALLBACK?");
}else if( objc==2 ){
if( pDb->zCommit ){
Tcl_AppendResult(interp, pDb->zCommit, 0);
}
}else{
char *zCommit;
int len;
if( pDb->zCommit ){
Tcl_Free(pDb->zCommit);
}
zCommit = Tcl_GetStringFromObj(objv[2], &len);
if( zCommit && len>0 ){
pDb->zCommit = Tcl_Alloc( len + 1 );
strcpy(pDb->zCommit, zCommit);
}else{
pDb->zCommit = 0;
}
if( pDb->zCommit ){
pDb->interp = interp;
sqlite_commit_hook(pDb->db, DbCommitHandler, pDb);
}else{
sqlite_commit_hook(pDb->db, 0, 0);
}
}
break;
}
/* $db complete SQL
**
** Return TRUE if SQL is a complete SQL statement. Return FALSE if
** additional lines of input are needed. This is similar to the
** built-in "info complete" command of Tcl.
*/
case DB_COMPLETE: {
Tcl_Obj *pResult;
int isComplete;
if( objc!=3 ){
Tcl_WrongNumArgs(interp, 2, objv, "SQL");
return TCL_ERROR;
}
isComplete = sqlite_complete( Tcl_GetStringFromObj(objv[2], 0) );
pResult = Tcl_GetObjResult(interp);
Tcl_SetBooleanObj(pResult, isComplete);
break;
}
/*
** $db errorcode
**
** Return the numeric error code that was returned by the most recent
** call to sqlite_exec().
*/
case DB_ERRORCODE: {
Tcl_SetObjResult(interp, Tcl_NewIntObj(pDb->rc));
break;
}
/*
** $db eval $sql ?array { ...code... }?
**
** The SQL statement in $sql is evaluated. For each row, the values are
** placed in elements of the array named "array" and ...code... is executed.
** If "array" and "code" are omitted, then no callback is every invoked.
** If "array" is an empty string, then the values are placed in variables
** that have the same name as the fields extracted by the query.
*/
case DB_EVAL: {
CallbackData cbData;
char *zErrMsg;
char *zSql;
#ifdef UTF_TRANSLATION_NEEDED
Tcl_DString dSql;
int i;
#endif
if( objc!=5 && objc!=3 ){
Tcl_WrongNumArgs(interp, 2, objv, "SQL ?ARRAY-NAME CODE?");
return TCL_ERROR;
}
pDb->interp = interp;
zSql = Tcl_GetStringFromObj(objv[2], 0);
#ifdef UTF_TRANSLATION_NEEDED
Tcl_DStringInit(&dSql);
Tcl_UtfToExternalDString(NULL, zSql, -1, &dSql);
zSql = Tcl_DStringValue(&dSql);
#endif
Tcl_IncrRefCount(objv[2]);
if( objc==5 ){
cbData.interp = interp;
cbData.once = 1;
cbData.zArray = Tcl_GetStringFromObj(objv[3], 0);
cbData.pCode = objv[4];
cbData.tcl_rc = TCL_OK;
cbData.nColName = 0;
cbData.azColName = 0;
zErrMsg = 0;
Tcl_IncrRefCount(objv[3]);
Tcl_IncrRefCount(objv[4]);
rc = sqlite_exec(pDb->db, zSql, DbEvalCallback, &cbData, &zErrMsg);
Tcl_DecrRefCount(objv[4]);
Tcl_DecrRefCount(objv[3]);
if( cbData.tcl_rc==TCL_BREAK ){ cbData.tcl_rc = TCL_OK; }
}else{
Tcl_Obj *pList = Tcl_NewObj();
cbData.tcl_rc = TCL_OK;
rc = sqlite_exec(pDb->db, zSql, DbEvalCallback2, pList, &zErrMsg);
Tcl_SetObjResult(interp, pList);
}
pDb->rc = rc;
if( rc==SQLITE_ABORT ){
if( zErrMsg ) free(zErrMsg);
rc = cbData.tcl_rc;
}else if( zErrMsg ){
Tcl_SetResult(interp, zErrMsg, TCL_VOLATILE);
free(zErrMsg);
rc = TCL_ERROR;
}else if( rc!=SQLITE_OK ){
Tcl_AppendResult(interp, sqlite_error_string(rc), 0);
rc = TCL_ERROR;
}else{
}
Tcl_DecrRefCount(objv[2]);
#ifdef UTF_TRANSLATION_NEEDED
Tcl_DStringFree(&dSql);
if( objc==5 && cbData.azColName ){
for(i=0; i<cbData.nColName; i++){
if( cbData.azColName[i] ) free(cbData.azColName[i]);
}
free(cbData.azColName);
cbData.azColName = 0;
}
#endif
return rc;
}
/*
** $db function NAME SCRIPT
**
** Create a new SQL function called NAME. Whenever that function is
** called, invoke SCRIPT to evaluate the function.
*/
case DB_FUNCTION: {
SqlFunc *pFunc;
char *zName;
char *zScript;
int nScript;
if( objc!=4 ){
Tcl_WrongNumArgs(interp, 2, objv, "NAME SCRIPT");
return TCL_ERROR;
}
zName = Tcl_GetStringFromObj(objv[2], 0);
zScript = Tcl_GetStringFromObj(objv[3], &nScript);
pFunc = (SqlFunc*)Tcl_Alloc( sizeof(*pFunc) + nScript + 1 );
if( pFunc==0 ) return TCL_ERROR;
pFunc->interp = interp;
pFunc->pNext = pDb->pFunc;
pFunc->zScript = (char*)&pFunc[1];
strcpy(pFunc->zScript, zScript);
sqlite_create_function(pDb->db, zName, -1, tclSqlFunc, pFunc);
sqlite_function_type(pDb->db, zName, SQLITE_NUMERIC);
break;
}
/*
** $db last_insert_rowid
**
** Return an integer which is the ROWID for the most recent insert.
*/
case DB_LAST_INSERT_ROWID: {
Tcl_Obj *pResult;
int rowid;
if( objc!=2 ){
Tcl_WrongNumArgs(interp, 2, objv, "");
return TCL_ERROR;
}
rowid = sqlite_last_insert_rowid(pDb->db);
pResult = Tcl_GetObjResult(interp);
Tcl_SetIntObj(pResult, rowid);
break;
}
/*
** $db onecolumn SQL
**
** Return a single column from a single row of the given SQL query.
*/
case DB_ONECOLUMN: {
char *zSql;
char *zErrMsg = 0;
if( objc!=3 ){
Tcl_WrongNumArgs(interp, 2, objv, "SQL");
return TCL_ERROR;
}
zSql = Tcl_GetStringFromObj(objv[2], 0);
rc = sqlite_exec(pDb->db, zSql, DbEvalCallback3, interp, &zErrMsg);
if( rc==SQLITE_ABORT ){
rc = SQLITE_OK;
}else if( zErrMsg ){
Tcl_SetResult(interp, zErrMsg, TCL_VOLATILE);
free(zErrMsg);
rc = TCL_ERROR;
}else if( rc!=SQLITE_OK ){
Tcl_AppendResult(interp, sqlite_error_string(rc), 0);
rc = TCL_ERROR;
}
break;
}
/*
** $db rekey KEY
**
** Change the encryption key on the currently open database.
*/
case DB_REKEY: {
int nKey;
void *pKey;
if( objc!=3 ){
Tcl_WrongNumArgs(interp, 2, objv, "KEY");
return TCL_ERROR;
}
pKey = Tcl_GetByteArrayFromObj(objv[2], &nKey);
#ifdef SQLITE_HAS_CODEC
rc = sqlite_rekey(pDb->db, pKey, nKey);
if( rc ){
Tcl_AppendResult(interp, sqlite_error_string(rc), 0);
rc = TCL_ERROR;
}
#endif
break;
}
/*
** $db timeout MILLESECONDS
**
** Delay for the number of milliseconds specified when a file is locked.
*/
case DB_TIMEOUT: {
int ms;
if( objc!=3 ){
Tcl_WrongNumArgs(interp, 2, objv, "MILLISECONDS");
return TCL_ERROR;
}
if( Tcl_GetIntFromObj(interp, objv[2], &ms) ) return TCL_ERROR;
sqlite_busy_timeout(pDb->db, ms);
break;
}
/* $db trace ?CALLBACK?
**
** Make arrangements to invoke the CALLBACK routine for each SQL statement
** that is executed. The text of the SQL is appended to CALLBACK before
** it is executed.
*/
case DB_TRACE: {
if( objc>3 ){
Tcl_WrongNumArgs(interp, 2, objv, "?CALLBACK?");
}else if( objc==2 ){
if( pDb->zTrace ){
Tcl_AppendResult(interp, pDb->zTrace, 0);
}
}else{
char *zTrace;
int len;
if( pDb->zTrace ){
Tcl_Free(pDb->zTrace);
}
zTrace = Tcl_GetStringFromObj(objv[2], &len);
if( zTrace && len>0 ){
pDb->zTrace = Tcl_Alloc( len + 1 );
strcpy(pDb->zTrace, zTrace);
}else{
pDb->zTrace = 0;
}
if( pDb->zTrace ){
pDb->interp = interp;
sqlite_trace(pDb->db, DbTraceHandler, pDb);
}else{
sqlite_trace(pDb->db, 0, 0);
}
}
break;
}
} /* End of the SWITCH statement */
return rc;
}
/*
** sqlite DBNAME FILENAME ?MODE? ?-key KEY?
**
** This is the main Tcl command. When the "sqlite" Tcl command is
** invoked, this routine runs to process that command.
**
** The first argument, DBNAME, is an arbitrary name for a new
** database connection. This command creates a new command named
** DBNAME that is used to control that connection. The database
** connection is deleted when the DBNAME command is deleted.
**
** The second argument is the name of the directory that contains
** the sqlite database that is to be accessed.
**
** For testing purposes, we also support the following:
**
** sqlite -encoding
**
** Return the encoding used by LIKE and GLOB operators. Choices
** are UTF-8 and iso8859.
**
** sqlite -version
**
** Return the version number of the SQLite library.
**
** sqlite -tcl-uses-utf
**
** Return "1" if compiled with a Tcl uses UTF-8. Return "0" if
** not. Used by tests to make sure the library was compiled
** correctly.
*/
static int DbMain(void *cd, Tcl_Interp *interp, int objc,Tcl_Obj *const*objv){
int mode;
SqliteDb *p;
void *pKey = 0;
int nKey = 0;
const char *zArg;
char *zErrMsg;
const char *zFile;
char zBuf[80];
if( objc==2 ){
zArg = Tcl_GetStringFromObj(objv[1], 0);
if( strcmp(zArg,"-encoding")==0 ){
Tcl_AppendResult(interp,sqlite_encoding,0);
return TCL_OK;
}
if( strcmp(zArg,"-version")==0 ){
Tcl_AppendResult(interp,sqlite_version,0);
return TCL_OK;
}
if( strcmp(zArg,"-has-codec")==0 ){
#ifdef SQLITE_HAS_CODEC
Tcl_AppendResult(interp,"1",0);
#else
Tcl_AppendResult(interp,"0",0);
#endif
return TCL_OK;
}
if( strcmp(zArg,"-tcl-uses-utf")==0 ){
#ifdef TCL_UTF_MAX
Tcl_AppendResult(interp,"1",0);
#else
Tcl_AppendResult(interp,"0",0);
#endif
return TCL_OK;
}
}
if( objc==5 || objc==6 ){
zArg = Tcl_GetStringFromObj(objv[objc-2], 0);
if( strcmp(zArg,"-key")==0 ){
pKey = Tcl_GetByteArrayFromObj(objv[objc-1], &nKey);
objc -= 2;
}
}
if( objc!=3 && objc!=4 ){
Tcl_WrongNumArgs(interp, 1, objv,
#ifdef SQLITE_HAS_CODEC
"HANDLE FILENAME ?-key CODEC-KEY?"
#else
"HANDLE FILENAME ?MODE?"
#endif
);
return TCL_ERROR;
}
if( objc==3 ){
mode = 0666;
}else if( Tcl_GetIntFromObj(interp, objv[3], &mode)!=TCL_OK ){
return TCL_ERROR;
}
zErrMsg = 0;
p = (SqliteDb*)Tcl_Alloc( sizeof(*p) );
if( p==0 ){
Tcl_SetResult(interp, "malloc failed", TCL_STATIC);
return TCL_ERROR;
}
memset(p, 0, sizeof(*p));
zFile = Tcl_GetStringFromObj(objv[2], 0);
#ifdef SQLITE_HAS_CODEC
p->db = sqlite_open_encrypted(zFile, pKey, nKey, 0, &zErrMsg);
#else
p->db = sqlite_open(zFile, mode, &zErrMsg);
#endif
if( p->db==0 ){
Tcl_SetResult(interp, zErrMsg, TCL_VOLATILE);
Tcl_Free((char*)p);
free(zErrMsg);
return TCL_ERROR;
}
zArg = Tcl_GetStringFromObj(objv[1], 0);
Tcl_CreateObjCommand(interp, zArg, DbObjCmd, (char*)p, DbDeleteCmd);
/* The return value is the value of the sqlite* pointer
*/
sprintf(zBuf, "%p", p->db);
if( strncmp(zBuf,"0x",2) ){
sprintf(zBuf, "0x%p", p->db);
}
Tcl_AppendResult(interp, zBuf, 0);
/* If compiled with SQLITE_TEST turned on, then register the "md5sum"
** SQL function.
*/
#ifdef SQLITE_TEST
{
extern void Md5_Register(sqlite*);
Md5_Register(p->db);
}
#endif
return TCL_OK;
}
/*
* ZlibDecompressObj
*
* Decompresses Zlib compressed data.
*
* Arguments:
* sourceObj - Pointer to a Tcl object containing the data to be decompressed.
* destObj - Pointer to a Tcl object to receive the decompressed data.
* window - Maximum window size for Zlib.
*
* Return Value:
* A Zlib status code; Z_OK is returned if successful.
*/
static int
ZlibDecompressObj(
Tcl_Obj *sourceObj,
Tcl_Obj *destObj,
int window
)
{
int status;
uInt destLength;
uInt factor;
uInt sourceLength;
unsigned char *dest;
z_stream stream;
assert(sourceObj != NULL);
assert(destObj != NULL);
/*
* The avail_in, next_in, opaque, zalloc, and zfree data structure
* members must be initialised prior to calling inflateInit2().
*/
stream.next_in = Tcl_GetByteArrayFromObj(sourceObj, (int *)&sourceLength);
if (sourceLength < 1) {
return Z_DATA_ERROR;
}
stream.avail_in = sourceLength;
stream.opaque = NULL;
stream.zalloc = ZlibAlloc;
stream.zfree = ZlibFree;
status = inflateInit2(&stream, window);
if (status != Z_OK) {
return status;
}
/* Double the destination buffer size each attempt. */
for (factor = 1; factor < 20; factor++) {
destLength = sourceLength * (1 << factor);
dest = Tcl_SetByteArrayLength(destObj, (int)destLength);
stream.next_out = dest + stream.total_out;
stream.avail_out = destLength - stream.total_out;
/*
* inflate() returns:
* - Z_STREAM_END if all input data has been exhausted.
* - Z_OK if the inflation was successful but there is remaining input data.
* - Otherwise an error has occurred while inflating the data.
*/
status = inflate(&stream, Z_SYNC_FLUSH);
if (status != Z_OK) {
break;
}
/*
* If inflate() returns Z_OK without exhausting the output buffer,
* it's assumed we've unexpectedly reached the stream's end.
*/
if (stream.avail_out > 0) {
status = Z_STREAM_ERROR;
break;
}
/* Increase the destination buffer size and try again. */
status = Z_BUF_ERROR;
}
inflateEnd(&stream);
if (status == Z_STREAM_END) {
/* Update the object's length. */
Tcl_SetByteArrayLength(destObj, (int)stream.total_out);
return Z_OK;
}
return status;
}
static int
QueryConfigObjCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
struct Tcl_Obj *const *objv)
{
QCCD *cdPtr = clientData;
Tcl_Obj *pkgName = cdPtr->pkg;
Tcl_Obj *pDB, *pkgDict, *val, *listPtr;
int n, index;
static const char *const subcmdStrings[] = {
"get", "list", NULL
};
enum subcmds {
CFG_GET, CFG_LIST
};
Tcl_DString conv;
Tcl_Encoding venc = NULL;
const char *value;
if ((objc < 2) || (objc > 3)) {
Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], subcmdStrings, "subcommand", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
pDB = GetConfigDict(interp);
if (Tcl_DictObjGet(interp, pDB, pkgName, &pkgDict) != TCL_OK
|| pkgDict == NULL) {
/*
* Maybe a Tcl_Panic is better, because the package data has to be
* present.
*/
Tcl_SetObjResult(interp, Tcl_NewStringObj("package not known", -1));
Tcl_SetErrorCode(interp, "TCL", "FATAL", "PKGCFG_BASE",
TclGetString(pkgName), NULL);
return TCL_ERROR;
}
switch ((enum subcmds) index) {
case CFG_GET:
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "key");
return TCL_ERROR;
}
if (Tcl_DictObjGet(interp, pkgDict, objv[2], &val) != TCL_OK
|| val == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("key not known", -1));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CONFIG",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
}
if (cdPtr->encoding) {
venc = Tcl_GetEncoding(interp, cdPtr->encoding);
if (!venc) {
return TCL_ERROR;
}
}
/*
* Value is stored as-is in a byte array, see Bug [9b2e636361],
* so we have to decode it first.
*/
value = (const char *) Tcl_GetByteArrayFromObj(val, &n);
value = Tcl_ExternalToUtfDString(venc, value, n, &conv);
Tcl_SetObjResult(interp, Tcl_NewStringObj(value,
Tcl_DStringLength(&conv)));
Tcl_DStringFree(&conv);
return TCL_OK;
case CFG_LIST:
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
Tcl_DictObjSize(interp, pkgDict, &n);
listPtr = Tcl_NewListObj(n, NULL);
if (!listPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"insufficient memory to create list", -1));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
return TCL_ERROR;
}
if (n) {
Tcl_DictSearch s;
Tcl_Obj *key;
int done;
for (Tcl_DictObjFirst(interp, pkgDict, &s, &key, NULL, &done);
!done; Tcl_DictObjNext(&s, &key, NULL, &done)) {
Tcl_ListObjAppendElement(NULL, listPtr, key);
}
}
Tcl_SetObjResult(interp, listPtr);
return TCL_OK;
default:
Tcl_Panic("QueryConfigObjCmd: Unknown subcommand to 'pkgconfig'. This can't happen");
break;
}
return TCL_ERROR;
}
static int
FNAME(UnpackData,ITYPENAME,OTYPENAME) (
Tcl_Interp* interp, /* Tcl interpreter for error reporting */
Tcl_Obj* mapObj, /* Tcl object containing the packed map */
size_t* nPtr, /* Pointer to the count of elements */
const ITYPE** xPtr, /* Pointer to the array of abscissae */
const OTYPE** yPtr /* Pointer to the array of ordinates */
) {
int n;
int length;
const unsigned char* bytes;
Tcl_Obj** parts;
/* Take the map object apart into abscissa and ordinate. */
if (Tcl_ListObjGetElements(interp, mapObj, &n, &parts) != TCL_OK) {
return TCL_ERROR;
}
if (n != 2) {
if (interp != NULL) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("map must be a 2-element list",
-1));
Tcl_SetErrorCode(interp, "CRIMP", "WRONGDATA", "2ELEMENTLIST",
NULL);
}
return TCL_ERROR;
}
/* Get the binary data for the abscissae */
bytes = Tcl_GetByteArrayFromObj(parts[0], &n);
if (n % sizeof(ITYPE) != 0) {
if (interp != NULL) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("first element of map must be a "
"binary array of "
STRINGIZE(ITYPENAME),
-1));
Tcl_SetErrorCode(interp, "CRIMP", "WRONGDATA", "ARRAYOF",
STRINGIZE(ITYPENAME), NULL);
}
return TCL_ERROR;
}
*xPtr = (const ITYPE*) bytes;
*nPtr = n / sizeof(ITYPE);
/* Get the binary data for the ordinates */
bytes = Tcl_GetByteArrayFromObj(parts[1], &n);
if (n != *nPtr * sizeof(OTYPE)) {
if (interp != NULL) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("input and output arrays of map "
"must have equal size", -1));
Tcl_SetErrorCode(interp, "CRIMP", "WRONGDATA", "EQUALSIZEARRAY",
NULL);
}
return TCL_ERROR;
}
*yPtr = (const OTYPE*) bytes;
return TCL_OK;
}
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;
}
static int
ReadPPMStringHeader(
Tcl_Obj *dataPtr, /* Object to read the header from. */
int *widthPtr, int *heightPtr,
/* The dimensions of the image are returned
* here. */
int *maxIntensityPtr, /* The maximum intensity value for the image
* is stored here. */
unsigned char **dataBufferPtr,
int *dataSizePtr)
{
#define BUFFER_SIZE 1000
char buffer[BUFFER_SIZE], c;
int i, numFields, dataSize, type = 0;
unsigned char *dataBuffer;
dataBuffer = Tcl_GetByteArrayFromObj(dataPtr, &dataSize);
/*
* Read 4 space-separated fields from the string, ignoring comments (any
* line that starts with "#").
*/
if (dataSize-- < 1) {
return 0;
}
c = (char) (*dataBuffer++);
i = 0;
for (numFields = 0; numFields < 4; numFields++) {
/*
* Skip comments and white space.
*/
while (1) {
while (isspace(UCHAR(c))) {
if (dataSize-- < 1) {
return 0;
}
c = (char) (*dataBuffer++);
}
if (c != '#') {
break;
}
do {
if (dataSize-- < 1) {
return 0;
}
c = (char) (*dataBuffer++);
} while (c != '\n');
}
/*
* Read a field (everything up to the next white space).
*/
while (!isspace(UCHAR(c))) {
if (i < (BUFFER_SIZE-2)) {
buffer[i] = c;
i++;
}
if (dataSize-- < 1) {
goto done;
}
c = (char) (*dataBuffer++);
}
if (i < (BUFFER_SIZE-1)) {
buffer[i] = ' ';
i++;
}
}
done:
buffer[i] = 0;
/*
* Parse the fields, which are: id, width, height, maxIntensity.
*/
if (strncmp(buffer, "P6 ", 3) == 0) {
type = PPM;
} else if (strncmp(buffer, "P5 ", 3) == 0) {
type = PGM;
} else {
return 0;
}
if (sscanf(buffer+3, "%d %d %d", widthPtr, heightPtr, maxIntensityPtr)
!= 3) {
return 0;
}
if (dataBufferPtr != NULL) {
*dataBufferPtr = dataBuffer;
*dataSizePtr = dataSize;
}
return type;
}
static int
ExecuteCallback(
TransformChannelData *dataPtr,
/* Transformation with the callback. */
Tcl_Interp *interp, /* Current interpreter, possibly NULL. */
unsigned char *op, /* Operation invoking the callback. */
unsigned char *buf, /* Buffer to give to the script. */
int bufLen, /* And its length. */
int transmit, /* Flag, determines whether the result of the
* callback is sent to the underlying channel
* or not. */
int preserve) /* Flag. If true the procedure will preserve
* the result state of all accessed
* interpreters. */
{
Tcl_Obj *resObj; /* See below, switch (transmit). */
int resLen;
unsigned char *resBuf;
Tcl_InterpState state = NULL;
int res = TCL_OK;
Tcl_Obj *command = TclListObjCopy(NULL, dataPtr->command);
Tcl_Interp *eval = dataPtr->interp;
Tcl_Preserve(eval);
/*
* Step 1, create the complete command to execute. Do this by appending
* operation and buffer to operate upon to a copy of the callback
* definition. We *cannot* create a list containing 3 objects and then use
* 'Tcl_EvalObjv', because the command may contain additional prefixed
* arguments. Feather's curried commands would come in handy here.
*/
if (preserve == P_PRESERVE) {
state = Tcl_SaveInterpState(eval, res);
}
Tcl_IncrRefCount(command);
Tcl_ListObjAppendElement(NULL, command, Tcl_NewStringObj((char *) op, -1));
/*
* Use a byte-array to prevent the misinterpretation of binary data coming
* through as UTF while at the tcl level.
*/
Tcl_ListObjAppendElement(NULL, command, Tcl_NewByteArrayObj(buf, bufLen));
/*
* Step 2, execute the command at the global level of the interpreter used
* to create the transformation. Destroy the command afterward. If an
* error occured and the current interpreter is defined and not equal to
* the interpreter for the callback, then copy the error message into
* current interpreter. Don't copy if in preservation mode.
*/
res = Tcl_EvalObjEx(eval, command, TCL_EVAL_GLOBAL);
Tcl_DecrRefCount(command);
command = NULL;
if ((res != TCL_OK) && (interp != NULL) && (eval != interp)
&& (preserve == P_NO_PRESERVE)) {
Tcl_SetObjResult(interp, Tcl_GetObjResult(eval));
Tcl_Release(eval);
return res;
}
/*
* Step 3, transmit a possible conversion result to the underlying
* channel, or ourselves.
*/
switch (transmit) {
case TRANSMIT_DONT:
/* nothing to do */
break;
case TRANSMIT_DOWN:
if (dataPtr->self == NULL) {
break;
}
resObj = Tcl_GetObjResult(eval);
resBuf = Tcl_GetByteArrayFromObj(resObj, &resLen);
Tcl_WriteRaw(Tcl_GetStackedChannel(dataPtr->self), (char *) resBuf,
resLen);
break;
case TRANSMIT_SELF:
if (dataPtr->self == NULL) {
break;
}
resObj = Tcl_GetObjResult(eval);
resBuf = Tcl_GetByteArrayFromObj(resObj, &resLen);
Tcl_WriteRaw(dataPtr->self, (char *) resBuf, resLen);
break;
case TRANSMIT_IBUF:
resObj = Tcl_GetObjResult(eval);
resBuf = Tcl_GetByteArrayFromObj(resObj, &resLen);
ResultAdd(&dataPtr->result, resBuf, resLen);
break;
case TRANSMIT_NUM:
/*
* Interpret result as integer number.
*/
resObj = Tcl_GetObjResult(eval);
TclGetIntFromObj(eval, resObj, &dataPtr->maxRead);
break;
}
Tcl_ResetResult(eval);
if (preserve == P_PRESERVE) {
(void) Tcl_RestoreInterpState(eval, state);
}
Tcl_Release(eval);
return res;
}
/*++
BzipDecompressObj
Decompresses Bzip2 compressed data.
Arguments:
sourceObj - Pointer to a Tcl object containing the data to be decompressed.
destObj - Pointer to a Tcl object to receive the decompressed data.
Return Value:
A Bzip2 status code; BZ_OK is returned if successful.
--*/
static int
BzipDecompressObj(
Tcl_Obj *sourceObj,
Tcl_Obj *destObj
)
{
bz_stream stream;
char *dest;
int status;
unsigned int destLength;
unsigned int factor;
unsigned int sourceLength;
Tcl_WideUInt totalOut;
stream.next_in = (char *)Tcl_GetByteArrayFromObj(sourceObj, (int *)&sourceLength);
if (sourceLength < 3) {
// The Bzip2 header is at least 3 characters in length, 'BZh'.
return BZ_DATA_ERROR_MAGIC;
}
//
// The bzalloc, bzfree, and opaque data structure members
// must be initialised prior to calling BZ2_bzDecompressInit().
//
stream.bzalloc = BzipAlloc;
stream.bzfree = BzipFree;
stream.opaque = NULL;
status = BZ2_bzDecompressInit(&stream, 0, 0);
if (status != BZ_OK) {
return status;
}
stream.avail_in = sourceLength;
for (factor = 1; factor < 20; factor++) {
// Double the destination buffer size each attempt.
destLength = sourceLength * (1 << factor);
dest = (char *)Tcl_SetByteArrayLength(destObj, (int)destLength);
totalOut = ((Tcl_WideUInt)stream.total_out_hi32 << 32) + stream.total_out_lo32;
stream.next_out = dest + totalOut;
stream.avail_out = destLength - (unsigned int)totalOut;
//
// BZ2_bzDecompress() returns:
// - BZ_STREAM_END if the logical end of the stream has been reached.
// - BZ_OK if the decompression was successful but there is remaining input data.
// - Otherwise an error has occurred while decompressing the data.
//
status = BZ2_bzDecompress(&stream);
if (status != BZ_OK) {
break;
}
//
// If BZ2_bzDecompress() returns BZ_OK without exhausting the output
// buffer, it's assumed we've unexpectedly reached the stream's end.
//
if (stream.avail_out > 0) {
status = BZ_UNEXPECTED_EOF;
break;
}
// Increase the destination buffer size and try again.
status = BZ_OUTBUFF_FULL;
}
BZ2_bzDecompressEnd(&stream);
if (status == BZ_STREAM_END) {
// Update the object's length.
destLength -= stream.avail_out;
Tcl_SetByteArrayLength(destObj, (int)destLength);
return BZ_OK;
}
return status;
}
