c4_View MkView::View(Tcl_Interp *interp, Tcl_Obj *obj) {
const char *name = Tcl_GetStringFromObj(obj, 0);
Tcl_CmdInfo ci;
if (!Tcl_GetCommandInfo(interp, (char*)name, &ci) || ci.objProc != MkView
::Dispatcher) {
//Fail("no such view");
c4_View temp;
return temp;
} else {
MkView *v = (MkView*)ci.objClientData;
return v->view;
}
}
void
TclpInitLibraryPath(
char **valuePtr,
int *lengthPtr,
Tcl_Encoding *encodingPtr)
{
#define LIBRARY_SIZE 64
Tcl_Obj *pathPtr;
char installLib[LIBRARY_SIZE];
char *bytes;
pathPtr = Tcl_NewObj();
/*
* Initialize the substring used when locating the script library. The
* installLib variable computes the script library path relative to the
* installed DLL.
*/
sprintf(installLib, "lib/tcl%s", TCL_VERSION);
/*
* Look for the library relative to the TCL_LIBRARY env variable. If the
* last dirname in the TCL_LIBRARY path does not match the last dirname in
* the installLib variable, use the last dir name of installLib in
* addition to the orginal TCL_LIBRARY path.
*/
AppendEnvironment(pathPtr, installLib);
/*
* Look for the library in its default location.
*/
Tcl_ListObjAppendElement(NULL, pathPtr,
TclGetProcessGlobalValue(&defaultLibraryDir));
/*
* Look for the library in its source checkout location.
*/
Tcl_ListObjAppendElement(NULL, pathPtr,
TclGetProcessGlobalValue(&sourceLibraryDir));
*encodingPtr = NULL;
bytes = Tcl_GetStringFromObj(pathPtr, lengthPtr);
*valuePtr = ckalloc((unsigned int)(*lengthPtr)+1);
memcpy(*valuePtr, bytes, (size_t)(*lengthPtr)+1);
Tcl_DecrRefCount(pathPtr);
}
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);
}
/* convert to a string from a var */
Tcl_DString*
TSP_Util_lang_convert_string_var(Tcl_DString* targetVarName, Tcl_Obj* sourceVarName) {
char* str;
int len;
if (targetVarName != NULL) {
Tcl_DStringSetLength(targetVarName, 0);
} else {
targetVarName = (Tcl_DString*) ckalloc(sizeof(Tcl_DString));;
Tcl_DStringInit(targetVarName);
}
str = Tcl_GetStringFromObj(sourceVarName, &len);
Tcl_DStringAppend(targetVarName, str, len);
return targetVarName;
}
void
TclVerifyLocalLiteralTable(
CompileEnv *envPtr) /* Points to CompileEnv whose literal table is
* to be validated. */
{
register LiteralTable *localTablePtr = &(envPtr->localLitTable);
register LiteralEntry *localPtr;
char *bytes;
register int i;
int length, count;
count = 0;
for (i=0 ; i<localTablePtr->numBuckets ; i++) {
for (localPtr=localTablePtr->buckets[i] ; localPtr!=NULL;
localPtr=localPtr->nextPtr) {
count++;
if (localPtr->refCount != -1) {
bytes = Tcl_GetStringFromObj(localPtr->objPtr, &length);
Tcl_Panic("TclVerifyLocalLiteralTable: local literal \"%.*s\" had bad refCount %d",
(length>60? 60 : length), bytes, localPtr->refCount);
}
if (TclLookupLiteralEntry((Tcl_Interp *) envPtr->iPtr,
localPtr->objPtr) == NULL) {
bytes = Tcl_GetStringFromObj(localPtr->objPtr, &length);
Tcl_Panic("TclVerifyLocalLiteralTable: local literal \"%.*s\" is not global",
(length>60? 60 : length), bytes);
}
if (localPtr->objPtr->bytes == NULL) {
Tcl_Panic("TclVerifyLocalLiteralTable: literal has NULL string rep");
}
}
}
if (count != localTablePtr->numEntries) {
Tcl_Panic("TclVerifyLocalLiteralTable: local literal table had %d entries, should be %d",
count, localTablePtr->numEntries);
}
}
void
remove_region_attrs(Tcl_Obj *obj)
{
int len = 0;
Tcl_Obj **objs;
char *key;
int i, j;
int found_material = 0;
if (Tcl_ListObjGetElements(INTERP, obj, &len, &objs) != TCL_OK) {
fprintf(stderr, "Cannot get length of attributes for %s\n",
Tcl_GetStringFromObj(obj, NULL));
bu_exit(1, NULL);
}
if (len == 0)
return;
for (i=len-1; i>0; i -= 2) {
key = Tcl_GetStringFromObj(objs[i-1], NULL);
j = 0;
while (region_attrs[j]) {
if (BU_STR_EQUAL(key, region_attrs[j])) {
Tcl_ListObjReplace(INTERP, obj, i-1, 2, 0, NULL);
break;
}
j++;
}
if (!found_material && BU_STR_EQUAL(key, "material")) {
found_material = 1;
if (!bu_strncmp(Tcl_GetStringFromObj(objs[i], NULL), "gift", 4)) {
Tcl_ListObjReplace(INTERP, obj, i-1, 2, 0, NULL);
}
}
}
}
ClientData
TclNativeCreateNativeRep(
Tcl_Obj *pathPtr)
{
char *nativePathPtr;
Tcl_DString ds;
Tcl_Obj *validPathPtr;
int len;
char *str;
if (TclFSCwdIsNative()) {
/*
* The cwd is native, which means we can use the translated path
* without worrying about normalization (this will also usually be
* shorter so the utf-to-external conversion will be somewhat faster).
*/
validPathPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
if (validPathPtr == NULL) {
return NULL;
}
} else {
/*
* Make sure the normalized path is set.
*/
validPathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
if (validPathPtr == NULL) {
return NULL;
}
Tcl_IncrRefCount(validPathPtr);
}
str = Tcl_GetStringFromObj(validPathPtr, &len);
Tcl_UtfToExternalDString(NULL, str, len, &ds);
len = Tcl_DStringLength(&ds) + sizeof(char);
if (strlen(Tcl_DStringValue(&ds)) < len - sizeof(char)) {
/* See bug [3118489]: NUL in filenames */
Tcl_DecrRefCount(validPathPtr);
Tcl_DStringFree(&ds);
return NULL;
}
Tcl_DecrRefCount(validPathPtr);
nativePathPtr = ckalloc((unsigned) len);
memcpy((void*)nativePathPtr, (void*)Tcl_DStringValue(&ds), (size_t) len);
Tcl_DStringFree(&ds);
return (ClientData)nativePathPtr;
}
/*
* TclSwitchCompare
*
* Performs a partial string comparison for a single switch. This behavior
* is consistent with Tcl commands that accept one switch argument, such
* as 'string match' and 'string map'.
*
* Arguments:
* objPtr - The string value of this object is compared against "name".
* switchName - Full name of the switch.
*
* Returns:
* If "name" and the string value of "objPtr" match partially or completely,
* the return value is non-zero. If they do not match, the return value is zero.
*/
int
TclSwitchCompare(
Tcl_Obj *objPtr,
const char *switchName
)
{
int optionLength;
char *option = Tcl_GetStringFromObj(objPtr, &optionLength);
/*
* The user supplied switch must be at least two characters in
* length, to account for the switch prefix and first letter.
*/
return (optionLength > 2 && strncmp(switchName, option, optionLength) == 0);
}
int
TnmGetPositiveFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int *intPtr)
{
int code;
code = Tcl_GetIntFromObj(interp, objPtr, intPtr);
if (code != TCL_OK || *intPtr < 1) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "expected positive integer but got \"",
Tcl_GetStringFromObj(objPtr, NULL), "\"",
(char *) NULL);
return TCL_ERROR;
}
return TCL_OK;
}
static void
CloseLibraryResource()
{
if (ourResFile != kResFileNotOpened) {
#ifdef TCL_REGISTER_LIBRARY
int length;
TclMacUnRegisterResourceFork(
Tcl_GetStringFromObj(ourResToken, &length),
NULL);
Tcl_DecrRefCount(ourResToken);
#endif
CloseResFile(ourResFile);
ourResFile = kResFileNotOpened;
}
}
static int LiquidValidate_Command(ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[])
{
// * Check the number of arguments
if (objc != 3)
{
Tcl_WrongNumArgs(interp, 1, objv, "<templates> <root template>");
return TCL_ERROR;
}
// Parse the data into a file system
TclLiquid::FileSystem fileSystem(interp,
objv[1]);
// Get the template name
const char* templateNameChars = Tcl_GetStringFromObj(objv[2], NULL);
std::string templateName(templateNameChars);
// Try to get the template source
std::string templateSource;
if (!fileSystem.TryFind(templateName,
templateSource))
LiquidError(LiquidDataError, "Template not found in template list");
// Try to parse the template
Liquid::ParserError parserError;
Liquid::RenderError renderError;
Liquid::Strainer strainer;
Liquid::Template* templ = Liquid::Template::Parse(templateSource,
strainer,
parserError);
if (!templ)
{
// Set the error
std::stringstream errorStream;
errorStream << parserError;
LiquidError(LiquidParseError,
errorStream.str().c_str());
}
// Clean up the data.
delete templ;
return TCL_OK;
}
int
TnmGetTableKeyFromObj(Tcl_Interp *interp, TnmTable *table, Tcl_Obj *objPtr, char *what)
{
char *name;
int value;
name = Tcl_GetStringFromObj(objPtr, NULL);
value = TnmGetTableKey(table, name);
if (value == -1 && interp) {
Tcl_ResetResult(interp);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "unknown ",
what, " \"", name, "\": should be ",
TnmGetTableValues(table), (char *) NULL);
}
return value;
}
/* string must be used immediately */
Tcl_DString*
TSP_Util_lang_get_string_var(Tcl_Obj* sourceVarName) {
static int doInit = 1;
static Tcl_DString ds;
int len;
char* str;
if (doInit) {
Tcl_DStringInit(&ds);
doInit = 0;
} else {
Tcl_DStringSetLength(&ds, 0);
}
str = Tcl_GetStringFromObj(sourceVarName, &len);
Tcl_DStringAppend(&ds, str, len);
return &ds;
}
/*************************************************************************
* FUNCTION : RPMPRoblem_Obj::Get_stringrep *
* ARGUMENTS : none *
* RETURNS : Tcl_Alloc'ed string rep of an object *
* EXCEPTIONS : none *
* PURPOSE : Return the string rep of an RPM header *
*************************************************************************/
char *RPMPRoblem_Obj::Get_stringrep(int &len)
{
// Get our parts as a TCL list
Tcl_Obj *name = Get_parts();
Tcl_IncrRefCount(name);
// we must return dynamaically allocated space, so allocate that
int size = 0;
char *from = Tcl_GetStringFromObj(name,&size);
char *space = Tcl_Alloc(size+1);
assert(space);
strncpy(space,from,size);
space[size] = 0;
Tcl_DecrRefCount(name);
len = size;
return space;
}
static int
GroupCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[])
{
TnmMapItem *itemPtr = (TnmMapItem *) clientData;
int result = TnmMapItemObjCmd(itemPtr, interp, objc, objv);
if (result == TCL_CONTINUE) {
Tcl_AppendResult(interp, "bad option \"",
Tcl_GetStringFromObj(objv[1], NULL),
"\": should be ", (char *) NULL);
TnmMapItemCmdList(itemPtr, interp);
result = TCL_ERROR;
}
return result;
}
unsigned TclUtils::getUInt(Tcl_Interp *interp, Tcl_Obj *objPtr) {
long ret;
if (
TCL_OK != Tcl_GetLongFromObj(interp, objPtr, &ret)
|| ret < std::numeric_limits<unsigned>::min()
|| ret > std::numeric_limits<unsigned>::max()) {
std::string msg("expected unsigned integer but got \"");
msg += Tcl_GetStringFromObj(objPtr, NULL);
msg += "\"";
throw wrong_args_value_exception(msg.c_str());
}
return static_cast<unsigned>(ret);
}
/*
** Register an EvalEvent to evaluate the script pScript in the
** parent interpreter/thread of SqlThread p.
*/
static void postToParent(SqlThread *p, Tcl_Obj *pScript){
EvalEvent *pEvent;
char *zMsg;
int nMsg;
zMsg = Tcl_GetStringFromObj(pScript, &nMsg);
pEvent = (EvalEvent *)ckalloc(sizeof(EvalEvent)+nMsg+1);
pEvent->base.nextPtr = 0;
pEvent->base.proc = tclScriptEvent;
pEvent->zScript = (char *)&pEvent[1];
memcpy(pEvent->zScript, zMsg, nMsg+1);
pEvent->interp = p->interp;
Tcl_ThreadQueueEvent(p->parent, (Tcl_Event *)pEvent, TCL_QUEUE_TAIL);
Tcl_ThreadAlert(p->parent);
}
int
ngx_http_tcl_getv_cmd(ClientData clientData, Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[])
{
ngx_http_request_t *r = getrequest(clientData);
ngx_http_variable_value_t *vv;
Tcl_Obj *varObj;
ngx_str_t varname;
int rc;
int len;
if (objc < 2 || objc > 3) {
Tcl_WrongNumArgs(interp, 1, objv, "varname ?default?");
return TCL_ERROR;
}
varObj = objv[1];
/* TODO: check return */
rc = SetVarFromAny(interp, varObj);
if (rc != TCL_OK) {
return rc;
}
Tcl_GetStringFromObj(varObj, &len);
varname.len = len;
varname.data = (u_char*)varObj->internalRep.ptrAndLongRep.ptr;
vv = ngx_http_get_variable(r, &varname, vartype_get_hash(varObj));
if (vv->not_found) {
if (objc == 3) {
Tcl_SetObjResult(interp, objv[2]);
return TCL_OK;
}
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "variable \"", Tcl_GetString(varObj),
"\" doesn't exist", NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewStringObj((char*)vv->data, vv->len));
return TCL_OK;
}
static char* proxenet_tcl_execute_function(interpreter_t* interpreter, request_t *request)
{
char *buf, *uri;
Tcl_Interp* tcl_interpreter;
Tcl_Obj* tcl_cmds_ptr;
size_t len;
int i;
uri = request->http_infos.uri;
if (!uri)
return NULL;
tcl_interpreter = (Tcl_Interp*) interpreter->vm;
/* create the list of commands to be executed by TCL interpreter */
tcl_cmds_ptr = Tcl_NewListObj (0, NULL);
Tcl_IncrRefCount(tcl_cmds_ptr);
if (request->type == REQUEST)
Tcl_ListObjAppendElement(tcl_interpreter, tcl_cmds_ptr, Tcl_NewStringObj(CFG_REQUEST_PLUGIN_FUNCTION, -1));
else
Tcl_ListObjAppendElement(tcl_interpreter, tcl_cmds_ptr, Tcl_NewStringObj(CFG_RESPONSE_PLUGIN_FUNCTION, -1));
/* pushing arguments */
Tcl_ListObjAppendElement(tcl_interpreter, tcl_cmds_ptr, Tcl_NewIntObj(request->id));
Tcl_ListObjAppendElement(tcl_interpreter, tcl_cmds_ptr, Tcl_NewStringObj(request->data, request->size));
Tcl_ListObjAppendElement(tcl_interpreter, tcl_cmds_ptr, Tcl_NewStringObj(uri, -1));
/* execute the commands */
if (Tcl_EvalObjEx(tcl_interpreter, tcl_cmds_ptr, TCL_EVAL_DIRECT) != TCL_OK) {
return NULL;
}
/* get the result */
Tcl_DecrRefCount(tcl_cmds_ptr);
buf = Tcl_GetStringFromObj( Tcl_GetObjResult(tcl_interpreter), &i);
if (!buf || i<=0)
return NULL;
len = (size_t)i;
buf = proxenet_xstrdup(buf, len);
if (!buf)
return NULL;
request->size = len;
return buf;
}
static AP_Result tcl_coerce_atom(AP_World *w, AP_Obj interp_name, AP_Obj item, AP_Obj atom)
{
Tcl_Interp *interp;
AP_Obj result;
interp = GetInterp(w, interp_name);
if (!interp) return AP_EXCEPTION;
if (AP_ObjType(w, item) == AP_ATOM) result = item;
else {
Tcl_Obj *tcl_obj = PrologToTclObj(w, item, interp);
result = AP_NewUIAFromStr(w, Tcl_GetStringFromObj(tcl_obj, NULL));
Tcl_DecrRefCount(tcl_obj);
}
return AP_Unify(w, result, atom);
}
void
TnmListFromList(Tcl_Obj *objPtr, Tcl_Obj *listPtr, char *pattern)
{
int i, objc, code;
Tcl_Obj **objv;
code = Tcl_ListObjGetElements(NULL, objPtr, &objc, &objv);
if (code != TCL_OK) return;
for (i = 0; i < objc; i++) {
char *s = Tcl_GetStringFromObj(objv[i], NULL);
if (pattern && !Tcl_StringMatch(s, pattern)) {
continue;
}
Tcl_ListObjAppendElement((Tcl_Interp *) NULL, listPtr, objv[i]);
}
}
int MatrixSetOption(
ClientData clientData,
Tcl_Interp *interp, /* Current interp; may be used for errors. */
Tk_Window tkwin, /* Window for which option is being set. */
Tcl_Obj **value, /* Pointer to the pointer to the value object.
* We use a pointer to the pointer because
* we may need to return a value (NULL). */
char *recordPtr, /* Pointer to storage for the widget record. */
int internalOffset, /* Offset within *recordPtr at which the
internal value is to be stored. */
char *oldInternalPtr, /* Pointer to storage for the old value. */
int flags) /* Flags for the option, set Tk_SetOptions. */
{
char *internalPtr; /* Points to location in record where
* internal representation of value should
* be stored, or NULL. */
char *list;
int length;
Tcl_Obj *valuePtr;
TMatrix *newPtr;
valuePtr = *value;
if (internalOffset >= 0) {
internalPtr = recordPtr + internalOffset;
} else {
internalPtr = NULL;
}
if ((flags & TK_OPTION_NULL_OK) && ObjectIsEmpty(valuePtr)) {
valuePtr = NULL;
}
if (internalPtr != NULL) {
if (valuePtr != NULL) {
list = Tcl_GetStringFromObj(valuePtr, &length);
newPtr = (TMatrix *) ckalloc(sizeof(TMatrix));
if (PathGetTMatrix(interp, list, newPtr) != TCL_OK) {
ckfree((char *) newPtr);
return TCL_ERROR;
}
} else {
newPtr = NULL;
}
*((TMatrix **) oldInternalPtr) = *((TMatrix **) internalPtr);
*((TMatrix **) internalPtr) = newPtr;
}
return TCL_OK;
}
int
TnmGetIntRangeFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int min, int max, int *intPtr)
{
int code;
char buffer[40];
code = Tcl_GetIntFromObj(interp, objPtr, intPtr);
if (code != TCL_OK || *intPtr < min || *intPtr > max) {
Tcl_ResetResult(interp);
sprintf(buffer, "%d and %d", min, max);
Tcl_AppendResult(interp, "expected integer between ", buffer,
" but got \"", Tcl_GetStringFromObj(objPtr, NULL), "\"",
(char *) NULL);
return TCL_ERROR;
}
return TCL_OK;
}
SEXP RTcl_StringFromObj(SEXP args)
{
char *str;
SEXP so;
char *s;
Tcl_DString s_ds;
Tcl_Obj *obj;
obj = (Tcl_Obj *) R_ExternalPtrAddr(CADR(args));
if (!obj) error(_("invalid tclObj -- perhaps saved from another session?"));
Tcl_DStringInit(&s_ds);
str = Tcl_GetStringFromObj(obj, NULL);
/* FIXME: could use UTF-8 here */
s = Tcl_UtfToExternalDString(NULL, str, -1, &s_ds);
so = mkString(s);
Tcl_DStringFree(&s_ds);
return(so);
}
static int
SetOp(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv)
{
Tk_Window tkwin = clientData;
int buffer;
char *string;
int length;
buffer = 0;
if (objc == 4) {
if (GetCutNumberFromObj(interp, objv[3], &buffer) != TCL_OK) {
return TCL_ERROR;
}
}
string = Tcl_GetStringFromObj(objv[2], &length);
XStoreBuffer(Tk_Display(tkwin), string, length + 1, buffer);
return TCL_OK;
}
void
TnmSnmpAuthOutMsg(int algorithm, Tcl_Obj *authKey, u_char *msg, int msgLen, u_char *msgAuthenticationParameters)
{
char *keyBytes;
int keyLen;
keyBytes = Tcl_GetStringFromObj(authKey, &keyLen);
switch (algorithm) {
case TNM_SNMP_AUTH_MD5:
if (keyLen != 16) {
Tcl_Panic("illegal length of the MD5 authentication key");
}
MD5AuthOutMsg(keyBytes, msg, msgLen, msgAuthenticationParameters);
break;
default:
Tcl_Panic("unknown authentication algorithm");
}
}
std::vector<std::string> TclUtils::getStringVector(Tcl_Interp *interp, Tcl_Obj *objPtr) {
int length;
int rc = Tcl_ListObjLength(interp, objPtr, &length);
if (TCL_OK != rc) {
throw wrong_args_value_exception(error_message::bad_list_argument);
}
std::vector<std::string> ret;
for (int i = 0; i < length; ++i) {
Tcl_Obj* v;
rc = Tcl_ListObjIndex(interp, objPtr, i, &v);
if (TCL_OK != rc) {
throw wrong_args_value_exception(error_message::bad_list_argument);
}
ret.push_back(std::string(Tcl_GetStringFromObj(v, NULL)));
}
return ret;
}
int
TclGetPathFromObj(
Tcl_Interp *interp,
Tcl_Obj *objPtr,
Tcl_DString *buffer
)
{
char *path;
int pathLenth;
Tcl_Obj *translatedObj;
assert(interp != NULL);
assert(objPtr != NULL);
assert(buffer != NULL);
translatedObj = Tcl_FSGetTranslatedPath(interp, objPtr);
if (translatedObj == NULL) {
return TCL_ERROR;
}
/* Create a dynamic string from the translated path. */
Tcl_DStringInit(buffer);
path = Tcl_GetStringFromObj(translatedObj, &pathLenth);
Tcl_DStringAppend(buffer, path, pathLenth);
Tcl_DecrRefCount(translatedObj);
#ifdef _WINDOWS
{
char *p = Tcl_DStringValue(buffer);
/* Convert forward slashes to backslashes for Windows paths. */
while (*p) {
if (*p == '/') {
*p = '\\';
}
p++;
}
}
#endif /* _WINDOWS */
return TCL_OK;
}
/*++
PartialSwitchCompare
Performs a partial string comparison for a single switch. This behaviour
is consistent with Tcl commands that accept one switch argument, such as
'string match' and 'string map'.
Arguments:
objPtr - The string value of this object is compared against "name".
switchName - Full name of the switch.
Return Value:
If "name" and the string value of "objPtr" match partially or completely,
the return value is non-zero. If they do not match, the return value is
zero.
--*/
int
PartialSwitchCompare(
Tcl_Obj *objPtr,
const char *switchName
)
{
int optionLength;
char *option;
assert(objPtr != NULL);
assert(switchName != NULL);
option = Tcl_GetStringFromObj(objPtr, &optionLength);
//
// The user supplied switch must be at least two characters in
// length, to account for the switch prefix and first letter.
//
return (optionLength > 2 && strncmp(switchName, option, optionLength) == 0);
}
/*-----------------------------------------------------------------------------
* ChmodFileNameObj --
* Change the mode of a file by name.
*
* Parameters:
* o interp - Pointer to the current interpreter, error messages will be
* returned in the result.
* o modeInfo - Infomation with the mode to set the file to.
* o fileName - Name of the file to change.
* Returns:
* TCL_OK or TCL_ERROR.
*-----------------------------------------------------------------------------
*/
static int
ChmodFileNameObj (Tcl_Interp *interp, modeInfo_t modeInfo, Tcl_Obj *fileNameObj)
{
char *filePath;
struct stat fileStat;
Tcl_DString pathBuf;
int newMode;
char *fileName;
Tcl_DStringInit (&pathBuf);
fileName = Tcl_GetStringFromObj (fileNameObj, NULL);
filePath = Tcl_TranslateFileName (interp, fileName, &pathBuf);
if (filePath == NULL) {
Tcl_DStringFree (&pathBuf);
return TCL_ERROR;
}
if (modeInfo.symMode != NULL) {
if (stat (filePath, &fileStat) != 0)
goto fileError;
newMode = ConvSymMode (interp, modeInfo.symMode,
fileStat.st_mode & 07777);
if (newMode < 0)
goto errorExit;
} else {
newMode = modeInfo.absMode;
}
if (TclXOSchmod (interp, filePath, (unsigned short) newMode) < 0)
return TCL_ERROR;
Tcl_DStringFree (&pathBuf);
return TCL_OK;
fileError:
TclX_AppendObjResult (interp, filePath, ": ",
Tcl_PosixError (interp), (char *) NULL);
errorExit:
Tcl_DStringFree (&pathBuf);
return TCL_ERROR;
}
