/*
*---------------------------------------------------------------------------
*
* PictureToTif --
*
* Writes a TIFF format image to the provided data buffer.
*
* Results:
* A standard TCL result. If an error occured, TCL_ERROR is
* returned and an error message will be place in the interpreter
* result. Otherwise, the data sink will contain the binary
* output of the image.
*
* Side Effects:
* Memory is allocated for the data sink.
*
*---------------------------------------------------------------------------
*/
static int
PictureToTif(Tcl_Interp *interp, Blt_Picture picture, Blt_DBuffer dbuffer,
TifExportSwitches *switchesPtr)
{
TIFF *tifPtr;
TIFFErrorHandler oldErrorHandler, oldWarningHandler;
TifMessage message;
int photometric, samplesPerPixel;
int compress, result, nColors;
Picture *srcPtr;
compress = tifCompressionSchemes[switchesPtr->compress];
if (compress == COMPRESSION_NONE) {
fprintf(stderr, "not compressing TIFF output\n");
}
#ifdef notdef
if (!TIFFIsCODECConfigured((unsigned short int)compress)) {
compress = COMPRESSION_NONE;
}
#endif
srcPtr = picture;
Tcl_DStringInit(&message.errors);
Tcl_DStringInit(&message.warnings);
Tcl_DStringAppend(&message.errors, "error writing TIF output: ", -1);
tifMessagePtr = &message;
message.nErrors = message.nWarnings = 0;
oldErrorHandler = TIFFSetErrorHandler(TifError);
oldWarningHandler = TIFFSetWarningHandler(TifWarning);
tifPtr = TIFFClientOpen("data buffer", "w", (thandle_t)dbuffer,
TifRead, /* TIFFReadWriteProc */
TifWrite, /* TIFFReadWriteProc */
TifSeek, /* TIFFSeekProc */
TifClose, /* TIFFCloseProc */
TifSize, /* TIFFSizeProc */
TifMapFile, /* TIFFMapFileProc */
TifUnmapFile); /* TIFFUnmapFileProc */
if (tifPtr == NULL) {
Tcl_AppendResult(interp, "can't register TIF procs: ", (char *)NULL);
return TCL_ERROR;
}
nColors = Blt_QueryColors(srcPtr, (Blt_HashTable *)NULL);
if (Blt_PictureIsColor(srcPtr)) {
samplesPerPixel = (Blt_PictureIsOpaque(srcPtr)) ? 3 : 4;
photometric = PHOTOMETRIC_RGB;
} else {
if (!Blt_PictureIsOpaque(srcPtr)) {
Blt_Picture background;
Blt_Pixel white;
/* Blend picture with solid color background. */
background = Blt_CreatePicture(srcPtr->width, srcPtr->height);
white.u32 = 0xFFFFFFFF;
Blt_BlankPicture(background, &white); /* White background. */
Blt_BlendPictures(background, srcPtr, 0, 0, srcPtr->width,
srcPtr->height, 0, 0);
srcPtr = background;
}
samplesPerPixel = 1;
photometric = PHOTOMETRIC_MINISBLACK;
}
TIFFSetField(tifPtr, TIFFTAG_BITSPERSAMPLE, 8);
TIFFSetField(tifPtr, TIFFTAG_COMPRESSION, (unsigned short int)compress);
TIFFSetField(tifPtr, TIFFTAG_IMAGELENGTH, srcPtr->height);
TIFFSetField(tifPtr, TIFFTAG_IMAGEWIDTH, srcPtr->width);
TIFFSetField(tifPtr, TIFFTAG_ORIENTATION, ORIENTATION_TOPLEFT);
TIFFSetField(tifPtr, TIFFTAG_PHOTOMETRIC, photometric);
TIFFSetField(tifPtr, TIFFTAG_PLANARCONFIG, PLANARCONFIG_CONTIG);
TIFFSetField(tifPtr, TIFFTAG_RESOLUTIONUNIT, 2);
TIFFSetField(tifPtr, TIFFTAG_ROWSPERSTRIP, srcPtr->height);
TIFFSetField(tifPtr, TIFFTAG_SAMPLESPERPIXEL, samplesPerPixel);
TIFFSetField(tifPtr, TIFFTAG_SOFTWARE, TIFFGetVersion());
TIFFSetField(tifPtr, TIFFTAG_XRESOLUTION, 300.0f);
TIFFSetField(tifPtr, TIFFTAG_YRESOLUTION, 300.0f);
#ifdef WORD_BIGENDIAN
TIFFSetField(tifPtr, TIFFTAG_FILLORDER, FILLORDER_MSB2LSB);
#else
TIFFSetField(tifPtr, TIFFTAG_FILLORDER, FILLORDER_LSB2MSB);
#endif
result = -1;
{
Blt_Pixel *srcRowPtr;
int destBitsSize;
int y;
unsigned char *destBits;
unsigned char *dp;
destBitsSize = srcPtr->width * srcPtr->height * sizeof(uint32);
destBits = (unsigned char *)_TIFFmalloc(destBitsSize);
if (destBits == NULL) {
TIFFError("tiff", "can't allocate space for TIF buffer");
TIFFClose(tifPtr);
return TCL_ERROR;
}
dp = destBits;
srcRowPtr = srcPtr->bits;
switch (samplesPerPixel) {
case 4:
for (y = 0; y < srcPtr->height; y++) {
Blt_Pixel *sp;
int x;
sp = srcRowPtr;
for (x = 0; x < srcPtr->width; x++) {
dp[0] = sp->Red;
dp[1] = sp->Green;
dp[2] = sp->Blue;
dp[3] = sp->Alpha;
dp += 4, sp++;
}
srcRowPtr += srcPtr->pixelsPerRow;
}
break;
case 3: /* RGB, 100% opaque image. */
for (y = 0; y < srcPtr->height; y++) {
Blt_Pixel *sp;
int x;
sp = srcRowPtr;
for (x = 0; x < srcPtr->width; x++) {
dp[0] = sp->Red;
dp[1] = sp->Green;
dp[2] = sp->Blue;
dp += 3, sp++;
}
srcRowPtr += srcPtr->pixelsPerRow;
}
break;
case 1:
for (y = 0; y < srcPtr->height; y++) {
Blt_Pixel *sp;
int x;
sp = srcRowPtr;
for (x = 0; x < srcPtr->width; x++) {
*dp++ = sp->Red;
sp++;
}
srcRowPtr += srcPtr->pixelsPerRow;
}
break;
}
result = TIFFWriteEncodedStrip(tifPtr, 0, destBits, destBitsSize);
if (result < 0) {
Tcl_AppendResult(interp, "error writing TIFF encoded strip",
(char *)NULL);
}
_TIFFfree(destBits);
}
TIFFClose(tifPtr);
if (result == -1) {
Blt_DBuffer_Free(dbuffer);
}
TIFFSetErrorHandler(oldErrorHandler);
TIFFSetWarningHandler(oldWarningHandler);
if (message.nWarnings > 0) {
Tcl_SetErrorCode(interp, "PICTURE", "TIF_WRITE_WARNINGS",
Tcl_DStringValue(&message.warnings), (char *)NULL);
} else {
Tcl_SetErrorCode(interp, "NONE", (char *)NULL);
}
Tcl_DStringFree(&message.warnings);
if (message.nErrors > 0) {
Tcl_DStringResult(interp, &message.errors);
}
Tcl_DStringFree(&message.errors);
if (srcPtr != picture) {
Blt_FreePicture(srcPtr);
}
return (result == -1) ? TCL_ERROR : TCL_OK;
}
int
TclOOSelfObjCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
static const char *const subcmds[] = {
"call", "caller", "class", "filter", "method", "namespace", "next",
"object", "target", NULL
};
enum SelfCmds {
SELF_CALL, SELF_CALLER, SELF_CLASS, SELF_FILTER, SELF_METHOD, SELF_NS,
SELF_NEXT, SELF_OBJECT, SELF_TARGET
};
Interp *iPtr = (Interp *) interp;
CallFrame *framePtr = iPtr->varFramePtr;
CallContext *contextPtr;
Tcl_Obj *result[3];
int index;
#define CurrentlyInvoked(contextPtr) \
((contextPtr)->callPtr->chain[(contextPtr)->index])
/*
* Start with sanity checks on the calling context and the method context.
*/
if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s may only be called from inside a method",
TclGetString(objv[0])));
Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
return TCL_ERROR;
}
contextPtr = framePtr->clientData;
/*
* Now we do "conventional" argument parsing for a while. Note that no
* subcommand takes arguments.
*/
if (objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "subcommand");
return TCL_ERROR;
} else if (objc == 1) {
index = SELF_OBJECT;
} else if (Tcl_GetIndexFromObj(interp, objv[1], subcmds, "subcommand", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum SelfCmds) index) {
case SELF_OBJECT:
Tcl_SetObjResult(interp, TclOOObjectName(interp, contextPtr->oPtr));
return TCL_OK;
case SELF_NS:
Tcl_SetObjResult(interp, Tcl_NewStringObj(
contextPtr->oPtr->namespacePtr->fullName,-1));
return TCL_OK;
case SELF_CLASS: {
Class *clsPtr = CurrentlyInvoked(contextPtr).mPtr->declaringClassPtr;
if (clsPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"method not defined by a class", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, TclOOObjectName(interp, clsPtr->thisPtr));
return TCL_OK;
}
case SELF_METHOD:
if (contextPtr->callPtr->flags & CONSTRUCTOR) {
Tcl_SetObjResult(interp, contextPtr->oPtr->fPtr->constructorName);
} else if (contextPtr->callPtr->flags & DESTRUCTOR) {
Tcl_SetObjResult(interp, contextPtr->oPtr->fPtr->destructorName);
} else {
Tcl_SetObjResult(interp,
CurrentlyInvoked(contextPtr).mPtr->namePtr);
}
return TCL_OK;
case SELF_FILTER:
if (!CurrentlyInvoked(contextPtr).isFilter) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"not inside a filtering context", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", NULL);
return TCL_ERROR;
} else {
register struct MInvoke *miPtr = &CurrentlyInvoked(contextPtr);
Object *oPtr;
const char *type;
if (miPtr->filterDeclarer != NULL) {
oPtr = miPtr->filterDeclarer->thisPtr;
type = "class";
} else {
oPtr = contextPtr->oPtr;
type = "object";
}
result[0] = TclOOObjectName(interp, oPtr);
result[1] = Tcl_NewStringObj(type, -1);
result[2] = miPtr->mPtr->namePtr;
Tcl_SetObjResult(interp, Tcl_NewListObj(3, result));
return TCL_OK;
}
case SELF_CALLER:
if ((framePtr->callerVarPtr == NULL) ||
!(framePtr->callerVarPtr->isProcCallFrame & FRAME_IS_METHOD)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"caller is not an object", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
return TCL_ERROR;
} else {
CallContext *callerPtr = framePtr->callerVarPtr->clientData;
Method *mPtr = callerPtr->callPtr->chain[callerPtr->index].mPtr;
Object *declarerPtr;
if (mPtr->declaringClassPtr != NULL) {
declarerPtr = mPtr->declaringClassPtr->thisPtr;
} else if (mPtr->declaringObjectPtr != NULL) {
declarerPtr = mPtr->declaringObjectPtr;
} else {
/*
* This should be unreachable code.
*/
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"method without declarer!", -1));
return TCL_ERROR;
}
result[0] = TclOOObjectName(interp, declarerPtr);
result[1] = TclOOObjectName(interp, callerPtr->oPtr);
if (callerPtr->callPtr->flags & CONSTRUCTOR) {
result[2] = declarerPtr->fPtr->constructorName;
} else if (callerPtr->callPtr->flags & DESTRUCTOR) {
result[2] = declarerPtr->fPtr->destructorName;
} else {
result[2] = mPtr->namePtr;
}
Tcl_SetObjResult(interp, Tcl_NewListObj(3, result));
return TCL_OK;
}
case SELF_NEXT:
if (contextPtr->index < contextPtr->callPtr->numChain-1) {
Method *mPtr =
contextPtr->callPtr->chain[contextPtr->index+1].mPtr;
Object *declarerPtr;
if (mPtr->declaringClassPtr != NULL) {
declarerPtr = mPtr->declaringClassPtr->thisPtr;
} else if (mPtr->declaringObjectPtr != NULL) {
declarerPtr = mPtr->declaringObjectPtr;
} else {
/*
* This should be unreachable code.
*/
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"method without declarer!", -1));
return TCL_ERROR;
}
result[0] = TclOOObjectName(interp, declarerPtr);
if (contextPtr->callPtr->flags & CONSTRUCTOR) {
result[1] = declarerPtr->fPtr->constructorName;
} else if (contextPtr->callPtr->flags & DESTRUCTOR) {
result[1] = declarerPtr->fPtr->destructorName;
} else {
result[1] = mPtr->namePtr;
}
Tcl_SetObjResult(interp, Tcl_NewListObj(2, result));
}
return TCL_OK;
case SELF_TARGET:
if (!CurrentlyInvoked(contextPtr).isFilter) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"not inside a filtering context", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", NULL);
return TCL_ERROR;
} else {
Method *mPtr;
Object *declarerPtr;
int i;
for (i=contextPtr->index ; i<contextPtr->callPtr->numChain ; i++) {
if (!contextPtr->callPtr->chain[i].isFilter) {
break;
}
}
if (i == contextPtr->callPtr->numChain) {
Tcl_Panic("filtering call chain without terminal non-filter");
}
mPtr = contextPtr->callPtr->chain[i].mPtr;
if (mPtr->declaringClassPtr != NULL) {
declarerPtr = mPtr->declaringClassPtr->thisPtr;
} else if (mPtr->declaringObjectPtr != NULL) {
declarerPtr = mPtr->declaringObjectPtr;
} else {
/*
* This should be unreachable code.
*/
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"method without declarer!", -1));
return TCL_ERROR;
}
result[0] = TclOOObjectName(interp, declarerPtr);
result[1] = mPtr->namePtr;
Tcl_SetObjResult(interp, Tcl_NewListObj(2, result));
return TCL_OK;
}
case SELF_CALL:
result[0] = TclOORenderCallChain(interp, contextPtr->callPtr);
result[1] = Tcl_NewIntObj(contextPtr->index);
Tcl_SetObjResult(interp, Tcl_NewListObj(2, result));
return TCL_OK;
}
return TCL_ERROR;
}
/*
*---------------------------------------------------------------------------
*
* TifToPicture --
*
* Reads a TIFF file and converts it into a picture.
*
* Results:
* The picture is returned. If an error occured, such as the
* designated file could not be opened, NULL is returned.
*
*---------------------------------------------------------------------------
*/
static Blt_Chain
TifToPicture(
Tcl_Interp *interp,
const char *fileName,
Blt_DBuffer dbuffer,
TifImportSwitches *switchesPtr)
{
Blt_Chain chain;
TIFF *tifPtr;
TIFFErrorHandler oldErrorHandler, oldWarningHandler;
TifMessage message;
message.nWarnings = message.nErrors = 0;
Tcl_DStringInit(&message.errors);
Tcl_DStringInit(&message.warnings);
Tcl_DStringAppend(&message.errors, "error reading \"", -1);
Tcl_DStringAppend(&message.errors, fileName, -1);
Tcl_DStringAppend(&message.errors, "\": ", -1);
tifMessagePtr = &message;
oldErrorHandler = TIFFSetErrorHandler(TifError);
oldWarningHandler = TIFFSetWarningHandler(TifWarning);
chain = NULL;
tifPtr = TIFFClientOpen(fileName, "r", (thandle_t)dbuffer,
TifRead, /* TIFFReadProc */
TifWrite, /* TIFFWriteProc */
TifSeek, /* TIFFSeekProc */
TifClose, /* TIFFCloseProc */
TifSize, /* TIFFSizeProc */
TifMapFile, /* TIFFMapFileProc */
TifUnmapFile); /* TIFFUnmapFileProc */
if (tifPtr == NULL) {
goto bad;
}
chain = Blt_Chain_Create();
do {
if (TifReadImage(interp, tifPtr, chain) != TCL_OK) {
goto bad;
}
} while (TIFFReadDirectory(tifPtr));
bad:
if (tifPtr != NULL) {
TIFFClose(tifPtr);
}
TIFFSetErrorHandler(oldErrorHandler);
TIFFSetWarningHandler(oldWarningHandler);
if (message.nWarnings > 0) {
Tcl_SetErrorCode(interp, "PICTURE", "TIF_READ_WARNINGS",
Tcl_DStringValue(&message.warnings), (char *)NULL);
} else {
Tcl_SetErrorCode(interp, "NONE", (char *)NULL);
}
Tcl_DStringFree(&message.warnings);
if (message.nErrors > 0) {
Tcl_AppendResult(interp, Tcl_DStringValue(&message.errors),
(char *)NULL);
}
Tcl_DStringFree(&message.errors);
return chain;
}
int
TclOO_Object_VarName(
ClientData clientData, /* Ignored. */
Tcl_Interp *interp, /* Interpreter in which to create the object;
* also used for error reporting. */
Tcl_ObjectContext context, /* The object/call context. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* The actual arguments. */
{
Var *varPtr, *aryVar;
Tcl_Obj *varNamePtr, *argPtr;
const char *arg;
if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"varName");
return TCL_ERROR;
}
argPtr = objv[objc-1];
arg = Tcl_GetString(argPtr);
/*
* Convert the variable name to fully-qualified form if it wasn't already.
* This has to be done prior to lookup because we can run into problems
* with resolvers otherwise. [Bug 3603695]
*
* We still need to do the lookup; the variable could be linked to another
* variable and we want the target's name.
*/
if (arg[0] == ':' && arg[1] == ':') {
varNamePtr = argPtr;
} else {
Tcl_Namespace *namespacePtr =
Tcl_GetObjectNamespace(Tcl_ObjectContextObject(context));
varNamePtr = Tcl_NewStringObj(namespacePtr->fullName, -1);
Tcl_AppendToObj(varNamePtr, "::", 2);
Tcl_AppendObjToObj(varNamePtr, argPtr);
}
Tcl_IncrRefCount(varNamePtr);
varPtr = TclObjLookupVar(interp, varNamePtr, NULL,
TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG, "refer to", 1, 1, &aryVar);
Tcl_DecrRefCount(varNamePtr);
if (varPtr == NULL) {
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE", arg, NULL);
return TCL_ERROR;
}
/*
* Now that we've pinned down what variable we're really talking about
* (including traversing variable links), convert back to a name.
*/
varNamePtr = Tcl_NewObj();
if (aryVar != NULL) {
Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
Tcl_GetVariableFullName(interp, (Tcl_Var) aryVar, varNamePtr);
/*
* WARNING! This code pokes inside the implementation of hash tables!
*/
hPtr = Tcl_FirstHashEntry((Tcl_HashTable *) aryVar->value.tablePtr,
&search);
while (hPtr != NULL) {
if (varPtr == Tcl_GetHashValue(hPtr)) {
Tcl_AppendToObj(varNamePtr, "(", -1);
Tcl_AppendObjToObj(varNamePtr, hPtr->key.objPtr);
Tcl_AppendToObj(varNamePtr, ")", -1);
break;
}
hPtr = Tcl_NextHashEntry(&search);
}
} else {
Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, varNamePtr);
}
Tcl_SetObjResult(interp, varNamePtr);
return TCL_OK;
}
int
TclOONextToObjCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Interp *iPtr = (Interp *) interp;
CallFrame *framePtr = iPtr->varFramePtr;
Class *classPtr;
CallContext *contextPtr;
int i;
Tcl_Object object;
const char *methodType;
/*
* Start with sanity checks on the calling context to make sure that we
* are invoked from a suitable method context. If so, we can safely
* retrieve the handle to the object call context.
*/
if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s may only be called from inside a method",
TclGetString(objv[0])));
Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
return TCL_ERROR;
}
contextPtr = framePtr->clientData;
/*
* Sanity check the arguments; we need the first one to refer to a class.
*/
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "class ?arg...?");
return TCL_ERROR;
}
object = Tcl_GetObjectFromObj(interp, objv[1]);
if (object == NULL) {
return TCL_ERROR;
}
classPtr = ((Object *)object)->classPtr;
if (classPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" is not a class", TclGetString(objv[1])));
Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_REQUIRED", NULL);
return TCL_ERROR;
}
/*
* Search for an implementation of a method associated with the current
* call on the call chain past the point where we currently are. Do not
* allow jumping backwards!
*/
for (i=contextPtr->index+1 ; i<contextPtr->callPtr->numChain ; i++) {
struct MInvoke *miPtr = contextPtr->callPtr->chain + i;
if (!miPtr->isFilter && miPtr->mPtr->declaringClassPtr == classPtr) {
/*
* Invoke the (advanced) method call context in the caller
* context. Note that this is like [uplevel 1] and not [eval].
*/
TclNRAddCallback(interp, NextRestoreFrame, framePtr,
contextPtr, INT2PTR(contextPtr->index), NULL);
contextPtr->index = i-1;
iPtr->varFramePtr = framePtr->callerVarPtr;
return TclNRObjectContextInvokeNext(interp,
(Tcl_ObjectContext) contextPtr, objc, objv, 2);
}
}
/*
* Generate an appropriate error message, depending on whether the value
* is on the chain but unreachable, or not on the chain at all.
*/
if (contextPtr->callPtr->flags & CONSTRUCTOR) {
methodType = "constructor";
} else if (contextPtr->callPtr->flags & DESTRUCTOR) {
methodType = "destructor";
} else {
methodType = "method";
}
for (i=contextPtr->index ; i>=0 ; i--) {
struct MInvoke *miPtr = contextPtr->callPtr->chain + i;
if (!miPtr->isFilter && miPtr->mPtr->declaringClassPtr == classPtr) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s implementation by \"%s\" not reachable from here",
methodType, TclGetString(objv[1])));
Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_NOT_REACHABLE",
NULL);
return TCL_ERROR;
}
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s has no non-filter implementation by \"%s\"",
methodType, TclGetString(objv[1])));
Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_NOT_THERE", NULL);
return TCL_ERROR;
}
int
TclOO_Object_Unknown(
ClientData clientData, /* Ignored. */
Tcl_Interp *interp, /* Interpreter in which to create the object;
* also used for error reporting. */
Tcl_ObjectContext context, /* The object/call context. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* The actual arguments. */
{
CallContext *contextPtr = (CallContext *) context;
Object *oPtr = contextPtr->oPtr;
const char **methodNames;
int numMethodNames, i, skip = Tcl_ObjectContextSkippedArgs(context);
Tcl_Obj *errorMsg;
/*
* If no method name, generate an error asking for a method name. (Only by
* overriding *this* method can an object handle the absence of a method
* name without an error).
*/
if (objc < skip+1) {
Tcl_WrongNumArgs(interp, skip, objv, "method ?arg ...?");
return TCL_ERROR;
}
/*
* Get the list of methods that we want to know about.
*/
numMethodNames = TclOOGetSortedMethodList(oPtr,
contextPtr->callPtr->flags & PUBLIC_METHOD, &methodNames);
/*
* Special message when there are no visible methods at all.
*/
if (numMethodNames == 0) {
Tcl_Obj *tmpBuf = TclOOObjectName(interp, oPtr);
const char *piece;
if (contextPtr->callPtr->flags & PUBLIC_METHOD) {
piece = "visible methods";
} else {
piece = "methods";
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"object \"%s\" has no %s", TclGetString(tmpBuf), piece));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[skip]), NULL);
return TCL_ERROR;
}
errorMsg = Tcl_ObjPrintf("unknown method \"%s\": must be ",
TclGetString(objv[skip]));
for (i=0 ; i<numMethodNames-1 ; i++) {
if (i) {
Tcl_AppendToObj(errorMsg, ", ", -1);
}
Tcl_AppendToObj(errorMsg, methodNames[i], -1);
}
if (i) {
Tcl_AppendToObj(errorMsg, " or ", -1);
}
Tcl_AppendToObj(errorMsg, methodNames[i], -1);
ckfree(methodNames);
Tcl_SetObjResult(interp, errorMsg);
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[skip]), NULL);
return TCL_ERROR;
}
int
TclOO_Object_LinkVar(
ClientData clientData, /* Ignored. */
Tcl_Interp *interp, /* Interpreter in which to create the object;
* also used for error reporting. */
Tcl_ObjectContext context, /* The object/call context. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* The actual arguments. */
{
Interp *iPtr = (Interp *) interp;
Tcl_Object object = Tcl_ObjectContextObject(context);
Namespace *savedNsPtr;
int i;
if (objc-Tcl_ObjectContextSkippedArgs(context) < 0) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"?varName ...?");
return TCL_ERROR;
}
/*
* A sanity check. Shouldn't ever happen. (This is all that remains of a
* more complex check inherited from [global] after we have applied the
* fix for [Bug 2903811]; note that the fix involved *removing* code.)
*/
if (iPtr->varFramePtr == NULL) {
return TCL_OK;
}
for (i=Tcl_ObjectContextSkippedArgs(context) ; i<objc ; i++) {
Var *varPtr, *aryPtr;
const char *varName = TclGetString(objv[i]);
/*
* The variable name must not contain a '::' since that's illegal in
* local names.
*/
if (strstr(varName, "::") != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"variable name \"%s\" illegal: must not contain namespace"
" separator", varName));
Tcl_SetErrorCode(interp, "TCL", "UPVAR", "INVERTED", NULL);
return TCL_ERROR;
}
/*
* Switch to the object's namespace for the duration of this call.
* Like this, the variable is looked up in the namespace of the
* object, and not in the namespace of the caller. Otherwise this
* would only work if the caller was a method of the object itself,
* which might not be true if the method was exported. This is a bit
* of a hack, but the simplest way to do this (pushing a stack frame
* would be horribly expensive by comparison).
*/
savedNsPtr = iPtr->varFramePtr->nsPtr;
iPtr->varFramePtr->nsPtr = (Namespace *)
Tcl_GetObjectNamespace(object);
varPtr = TclObjLookupVar(interp, objv[i], NULL, TCL_NAMESPACE_ONLY,
"define", 1, 0, &aryPtr);
iPtr->varFramePtr->nsPtr = savedNsPtr;
if (varPtr == NULL || aryPtr != NULL) {
/*
* Variable cannot be an element in an array. If aryPtr is not
* NULL, it is an element, so throw up an error and return.
*/
TclVarErrMsg(interp, varName, NULL, "define",
"name refers to an element in an array");
Tcl_SetErrorCode(interp, "TCL", "UPVAR", "LOCAL_ELEMENT", NULL);
return TCL_ERROR;
}
/*
* Arrange for the lifetime of the variable to be correctly managed.
* This is copied out of Tcl_VariableObjCmd...
*/
if (!TclIsVarNamespaceVar(varPtr)) {
TclSetVarNamespaceVar(varPtr);
}
if (TclPtrMakeUpvar(interp, varPtr, varName, 0, -1) != TCL_OK) {
return TCL_ERROR;
}
}
return TCL_OK;
}
int
TclOO_Class_CreateNs(
ClientData clientData, /* Ignored. */
Tcl_Interp *interp, /* Interpreter in which to create the object;
* also used for error reporting. */
Tcl_ObjectContext context, /* The object/call context. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* The actual arguments. */
{
Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
const char *objName, *nsName;
int len;
/*
* Sanity check; should not be possible to invoke this method on a
* non-class.
*/
if (oPtr->classPtr == NULL) {
Tcl_Obj *cmdnameObj = TclOOObjectName(interp, oPtr);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"object \"%s\" is not a class", TclGetString(cmdnameObj)));
Tcl_SetErrorCode(interp, "TCL", "OO", "INSTANTIATE_NONCLASS", NULL);
return TCL_ERROR;
}
/*
* Check we have the right number of (sensible) arguments.
*/
if (objc - Tcl_ObjectContextSkippedArgs(context) < 2) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"objectName namespaceName ?arg ...?");
return TCL_ERROR;
}
objName = Tcl_GetStringFromObj(
objv[Tcl_ObjectContextSkippedArgs(context)], &len);
if (len == 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"object name must not be empty", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", NULL);
return TCL_ERROR;
}
nsName = Tcl_GetStringFromObj(
objv[Tcl_ObjectContextSkippedArgs(context)+1], &len);
if (len == 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"namespace name must not be empty", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", NULL);
return TCL_ERROR;
}
/*
* Make the object and return its name.
*/
return TclNRNewObjectInstance(interp, (Tcl_Class) oPtr->classPtr,
objName, nsName, objc, objv,
Tcl_ObjectContextSkippedArgs(context)+2,
AddConstructionFinalizer(interp));
}
int AsnSe_TypeDesc::mandatmemberr (Tcl_Interp *interp, const char *membername) const
{
sprintf (interp->result, "(in type %s.%s:) member %s is mandatory and can't be deleted", getmodule()->name, getname(), membername);
Tcl_SetErrorCode (interp, "SNACC", "MANDMEMB", NULL);
return TCL_ERROR;
}
static int
GetTextIndex(
Tcl_Interp *interp, /* Used for error reporting. */
Tk_Canvas canvas, /* Canvas containing item. */
Tk_Item *itemPtr, /* Item for which the index is being
* specified. */
Tcl_Obj *obj, /* Specification of a particular character in
* itemPtr's text. */
int *indexPtr) /* Where to store converted character
* index. */
{
TextItem *textPtr = (TextItem *) itemPtr;
int length;
int c;
TkCanvas *canvasPtr = (TkCanvas *) canvas;
Tk_CanvasTextInfo *textInfoPtr = textPtr->textInfoPtr;
const char *string = Tcl_GetStringFromObj(obj, &length);
c = string[0];
if ((c == 'e') && (strncmp(string, "end", (unsigned) length) == 0)) {
*indexPtr = textPtr->numChars;
} else if ((c == 'i')
&& (strncmp(string, "insert", (unsigned) length) == 0)) {
*indexPtr = textPtr->insertPos;
} else if ((c == 's') && (length >= 5)
&& (strncmp(string, "sel.first", (unsigned) length) == 0)) {
if (textInfoPtr->selItemPtr != itemPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"selection isn't in item", -1));
Tcl_SetErrorCode(interp, "TK", "CANVAS", "UNSELECTED", NULL);
return TCL_ERROR;
}
*indexPtr = textInfoPtr->selectFirst;
} else if ((c == 's') && (length >= 5)
&& (strncmp(string, "sel.last", (unsigned) length) == 0)) {
if (textInfoPtr->selItemPtr != itemPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"selection isn't in item", -1));
Tcl_SetErrorCode(interp, "TK", "CANVAS", "UNSELECTED", NULL);
return TCL_ERROR;
}
*indexPtr = textInfoPtr->selectLast;
} else if (c == '@') {
int x, y;
double tmp, c = textPtr->cosine, s = textPtr->sine;
char *end;
const char *p;
p = string+1;
tmp = strtod(p, &end);
if ((end == p) || (*end != ',')) {
goto badIndex;
}
x = (int) ((tmp < 0) ? tmp - 0.5 : tmp + 0.5);
p = end+1;
tmp = strtod(p, &end);
if ((end == p) || (*end != 0)) {
goto badIndex;
}
y = (int) ((tmp < 0) ? tmp - 0.5 : tmp + 0.5);
x += canvasPtr->scrollX1 - (int) textPtr->drawOrigin[0];
y += canvasPtr->scrollY1 - (int) textPtr->drawOrigin[1];
*indexPtr = Tk_PointToChar(textPtr->textLayout,
(int) (x*c - y*s), (int) (y*c + x*s));
} else if (Tcl_GetIntFromObj(NULL, obj, indexPtr) == TCL_OK) {
if (*indexPtr < 0) {
*indexPtr = 0;
} else if (*indexPtr > textPtr->numChars) {
*indexPtr = textPtr->numChars;
}
} else {
/*
* Some of the paths here leave messages in the interp's result, so we
* have to clear it out before storing our own message.
*/
badIndex:
Tcl_SetObjResult(interp, Tcl_ObjPrintf("bad index \"%s\"", string));
Tcl_SetErrorCode(interp, "TK", "CANVAS", "ITEM_INDEX", "TEXT", NULL);
return TCL_ERROR;
}
return TCL_OK;
}
static Cursor
CreateCursorFromTableOrFile(
Tcl_Interp *interp, /* Interpreter to use for error reporting. */
Tk_Window tkwin, /* Window in which cursor will be used. */
int argc,
const char **argv, /* Cursor spec parsed into elements. */
const struct TkCursorName *tkCursorPtr)
/* Non-NULL when cursor is defined in Tk
* table. */
{
Cursor cursor = None;
int width, height, maskWidth, maskHeight;
int xHot = -1, yHot = -1;
int dummy1, dummy2;
XColor fg, bg;
const char *fgColor;
const char *bgColor;
int inTkTable = (tkCursorPtr != NULL);
Display *display = Tk_Display(tkwin);
Drawable drawable = RootWindowOfScreen(Tk_Screen(tkwin));
Pixmap source = None;
Pixmap mask = None;
/*
* A cursor defined in a file accepts either 2 or 4 arguments.
*
* {srcfile fg}
* {srcfile maskfile fg bg}
*
* A cursor defined in the Tk table accepts 1, 2, or 3 arguments.
*
* {tkcursorname}
* {tkcursorname fg}
* {tkcursorname fg bg}
*/
if (inTkTable) {
/*
* This logic is like TkReadBitmapFile().
*/
char *data;
data = TkGetBitmapData(NULL, tkCursorPtr->data, NULL,
&width, &height, &xHot, &yHot);
if (data == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"error reading bitmap data for \"%s\"", argv[0]));
Tcl_SetErrorCode(interp, "TK", "CURSOR", "BITMAP_DATA", NULL);
goto cleanup;
}
source = XCreateBitmapFromData(display, drawable, data, width,height);
ckfree(data);
} else {
if (TkReadBitmapFile(display, drawable, &argv[0][1],
(unsigned *) &width, (unsigned *) &height,
&source, &xHot, &yHot) != BitmapSuccess) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"cleanup reading bitmap file \"%s\"", &argv[0][1]));
Tcl_SetErrorCode(interp, "TK", "CURSOR", "BITMAP_FILE", NULL);
goto cleanup;
}
}
if ((xHot < 0) || (yHot < 0) || (xHot >= width) || (yHot >= height)) {
if (inTkTable) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad hot spot in bitmap data for \"%s\"", argv[0]));
} else {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad hot spot in bitmap file \"%s\"", &argv[0][1]));
}
Tcl_SetErrorCode(interp, "TK", "CURSOR", "HOTSPOT", NULL);
goto cleanup;
}
/*
* Parse color names from optional fg and bg arguments
*/
if (argc == 1) {
fg.red = fg.green = fg.blue = 0;
bg.red = bg.green = bg.blue = 65535;
} else if (argc == 2) {
fgColor = argv[1];
if (TkParseColor(display, Tk_Colormap(tkwin), fgColor, &fg) == 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid color name \"%s\"", fgColor));
Tcl_SetErrorCode(interp, "TK", "CURSOR", "COLOR", NULL);
goto cleanup;
}
if (inTkTable) {
bg.red = bg.green = bg.blue = 0;
} else {
bg = fg;
}
} else {
/* 3 or 4 arguments */
if (inTkTable) {
fgColor = argv[1];
bgColor = argv[2];
} else {
fgColor = argv[2];
bgColor = argv[3];
}
if (TkParseColor(display, Tk_Colormap(tkwin), fgColor, &fg) == 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid color name \"%s\"", fgColor));
Tcl_SetErrorCode(interp, "TK", "CURSOR", "COLOR", NULL);
goto cleanup;
}
if (TkParseColor(display, Tk_Colormap(tkwin), bgColor, &bg) == 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid color name \"%s\"", bgColor));
Tcl_SetErrorCode(interp, "TK", "CURSOR", "COLOR", NULL);
goto cleanup;
}
}
/*
* If there is no mask data, then create the cursor now.
*/
if ((!inTkTable && (argc == 2)) || (inTkTable && tkCursorPtr->mask == NULL)) {
cursor = XCreatePixmapCursor(display, source, source,
&fg, &fg, (unsigned) xHot, (unsigned) yHot);
goto cleanup;
}
/*
* Parse bitmap mask data and create cursor with fg and bg colors.
*/
if (inTkTable) {
/*
* This logic is like TkReadBitmapFile().
*/
char *data;
data = TkGetBitmapData(NULL, tkCursorPtr->mask, NULL,
&maskWidth, &maskHeight, &dummy1, &dummy2);
if (data == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"error reading bitmap mask data for \"%s\"", argv[0]));
Tcl_SetErrorCode(interp, "TK", "CURSOR", "MASK_DATA", NULL);
goto cleanup;
}
mask = XCreateBitmapFromData(display, drawable, data, maskWidth,
maskHeight);
ckfree(data);
} else {
if (TkReadBitmapFile(display, drawable, argv[1],
(unsigned int *) &maskWidth, (unsigned int *) &maskHeight,
&mask, &dummy1, &dummy2) != BitmapSuccess) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"cleanup reading bitmap file \"%s\"", argv[1]));
Tcl_SetErrorCode(interp, "TK", "CURSOR", "MASK_FILE", NULL);
goto cleanup;
}
}
if ((maskWidth != width) || (maskHeight != height)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"source and mask bitmaps have different sizes", -1));
Tcl_SetErrorCode(interp, "TK", "CURSOR", "SIZE_MATCH", NULL);
goto cleanup;
}
cursor = XCreatePixmapCursor(display, source, mask,
&fg, &bg, (unsigned) xHot, (unsigned) yHot);
cleanup:
if (source != None) {
Tk_FreePixmap(display, source);
}
if (mask != None) {
Tk_FreePixmap(display, mask);
}
return cursor;
}
TkCursor *
TkGetCursorByName(
Tcl_Interp *interp, /* Interpreter to use for error reporting. */
Tk_Window tkwin, /* Window in which cursor will be used. */
Tk_Uid string) /* Description of cursor. See manual entry for
* details on legal syntax. */
{
TkUnixCursor *cursorPtr = NULL;
Cursor cursor = None;
int argc;
const char **argv = NULL;
Display *display = Tk_Display(tkwin);
int inTkTable = 0;
const struct TkCursorName *tkCursorPtr = NULL;
if (Tcl_SplitList(interp, string, &argc, &argv) != TCL_OK) {
return NULL;
}
if (argc == 0) {
goto badString;
}
/*
* Check Tk specific table of cursor names. The cursor names don't overlap
* with cursors defined in the X table so search order does not matter.
*/
if (argv[0][0] != '@') {
for (tkCursorPtr = tkCursorNames; ; tkCursorPtr++) {
if (tkCursorPtr->name == NULL) {
tkCursorPtr = NULL;
break;
}
if ((tkCursorPtr->name[0] == argv[0][0]) &&
(strcmp(tkCursorPtr->name, argv[0]) == 0)) {
inTkTable = 1;
break;
}
}
}
if ((argv[0][0] != '@') && !inTkTable) {
XColor fg, bg;
unsigned int maskIndex;
register const struct CursorName *namePtr;
TkDisplay *dispPtr;
/*
* The cursor is to come from the standard cursor font. If one arg, it
* is cursor name (use black and white for fg and bg). If two args,
* they are name and fg color (ignore mask). If three args, they are
* name, fg, bg. Some of the code below is stolen from the
* XCreateFontCursor Xlib function.
*/
if (argc > 3) {
goto badString;
}
for (namePtr = cursorNames; ; namePtr++) {
if (namePtr->name == NULL) {
goto badString;
}
if ((namePtr->name[0] == argv[0][0])
&& (strcmp(namePtr->name, argv[0]) == 0)) {
break;
}
}
maskIndex = namePtr->shape + 1;
if (argc == 1) {
fg.red = fg.green = fg.blue = 0;
bg.red = bg.green = bg.blue = 65535;
} else {
if (TkParseColor(display, Tk_Colormap(tkwin), argv[1], &fg) == 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid color name \"%s\"", argv[1]));
Tcl_SetErrorCode(interp, "TK", "CURSOR", "COLOR", NULL);
goto cleanup;
}
if (argc == 2) {
bg.red = bg.green = bg.blue = 0;
maskIndex = namePtr->shape;
} else if (TkParseColor(display, Tk_Colormap(tkwin), argv[2],
&bg) == 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid color name \"%s\"", argv[2]));
Tcl_SetErrorCode(interp, "TK", "CURSOR", "COLOR", NULL);
goto cleanup;
}
}
dispPtr = ((TkWindow *) tkwin)->dispPtr;
if (dispPtr->cursorFont == None) {
dispPtr->cursorFont = XLoadFont(display, CURSORFONT);
if (dispPtr->cursorFont == None) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"couldn't load cursor font", -1));
Tcl_SetErrorCode(interp, "TK", "CURSOR", "FONT", NULL);
goto cleanup;
}
}
cursor = XCreateGlyphCursor(display, dispPtr->cursorFont,
dispPtr->cursorFont, namePtr->shape, maskIndex,
&fg, &bg);
} else {
/*
* Prevent file system access in safe interpreters.
*/
if (!inTkTable && Tcl_IsSafe(interp)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"can't get cursor from a file in a safe interpreter",
-1));
Tcl_SetErrorCode(interp, "TK", "SAFE", "CURSOR_FILE", NULL);
cursorPtr = NULL;
goto cleanup;
}
/*
* If the cursor is to be created from bitmap files, then there should
* be either two elements in the list (source, color) or four (source
* mask fg bg). A cursor defined in the Tk table accepts the same
* arguments as an X cursor.
*/
if (inTkTable && (argc != 1) && (argc != 2) && (argc != 3)) {
goto badString;
}
if (!inTkTable && (argc != 2) && (argc != 4)) {
goto badString;
}
cursor = CreateCursorFromTableOrFile(interp, tkwin, argc, argv,
tkCursorPtr);
}
if (cursor != None) {
cursorPtr = ckalloc(sizeof(TkUnixCursor));
cursorPtr->info.cursor = (Tk_Cursor) cursor;
cursorPtr->display = display;
}
cleanup:
if (argv != NULL) {
ckfree(argv);
}
return (TkCursor *) cursorPtr;
badString:
if (argv) {
ckfree(argv);
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf("bad cursor spec \"%s\"", string));
Tcl_SetErrorCode(interp, "TK", "VALUE", "CURSOR", NULL);
return NULL;
}
