int Tcl_RegExpExecObj( Tcl_Interp *interp, /* Interpreter to use for error reporting. */ Tcl_RegExp re, /* Compiled regular expression; must have been * returned by previous call to * Tcl_GetRegExpFromObj. */ Tcl_Obj *textObj, /* Text against which to match re. */ int offset, /* Character index that marks where matching * should begin. */ int nmatches, /* How many subexpression matches (counting * the whole match as subexpression 0) are of * interest. -1 means all of them. */ int flags) /* Regular expression execution flags. */ { TclRegexp *regexpPtr = (TclRegexp *) re; Tcl_UniChar *udata; int length; int reflags = regexpPtr->flags; #define TCL_REG_GLOBOK_FLAGS \ (TCL_REG_ADVANCED | TCL_REG_NOSUB | TCL_REG_NOCASE) /* * Take advantage of the equivalent glob pattern, if one exists. * This is possible based only on the right mix of incoming flags (0) * and regexp compile flags. */ if ((offset == 0) && (nmatches == 0) && (flags == 0) && !(reflags & ~TCL_REG_GLOBOK_FLAGS) && (regexpPtr->globObjPtr != NULL)) { int nocase = (reflags & TCL_REG_NOCASE) ? TCL_MATCH_NOCASE : 0; /* * Pass to TclStringMatchObj for obj-specific handling. * XXX: Currently doesn't take advantage of exact-ness that * XXX: TclReToGlob tells us about */ return TclStringMatchObj(textObj, regexpPtr->globObjPtr, nocase); } /* * Save the target object so we can extract strings from it later. */ regexpPtr->string = NULL; regexpPtr->objPtr = textObj; udata = Tcl_GetUnicodeFromObj(textObj, &length); if (offset > length) { offset = length; } udata += offset; length -= offset; return RegExpExecUniChar(interp, re, udata, length, nmatches, flags); }
static void DrawMenuUnderline( TkMenu *menuPtr, /* The menu to draw into */ TkMenuEntry *mePtr, /* The entry we are drawing */ Drawable d, /* What we are drawing into */ GC gc, /* The gc to draw into */ Tk_Font tkfont, /* The precalculated font */ const Tk_FontMetrics *fmPtr,/* The precalculated font metrics */ int x, int y, int width, int height) { if ((mePtr->underline >= 0) && (mePtr->labelPtr != NULL)) { int len; /* * Do the unicode call just to prevent overruns. */ Tcl_GetUnicodeFromObj(mePtr->labelPtr, &len); if (mePtr->underline < len) { int activeBorderWidth, leftEdge; const char *label, *start, *end; label = Tcl_GetString(mePtr->labelPtr); start = Tcl_UtfAtIndex(label, mePtr->underline); end = Tcl_UtfNext(start); Tk_GetPixelsFromObj(NULL, menuPtr->tkwin, menuPtr->activeBorderWidthPtr, &activeBorderWidth); leftEdge = x + mePtr->indicatorSpace + activeBorderWidth; if (menuPtr->menuType == MENUBAR) { leftEdge += 5; } Tk_UnderlineChars(menuPtr->display, d, gc, tkfont, label, leftEdge, y + (height + fmPtr->ascent - fmPtr->descent) / 2, start - label, end - label); } } }
/* Process the list of variants by counting the frequency of each * regexp in the main input string "s" and printing the results. */ static void process_variants(int cpu_count, Tcl_Obj* s) { int i = 0; int s_length = 0; int thread_rv = 0; int thread_count = 0; int task_count = 0; pthread_t* threads = NULL; variant_worker_task_t tasks = NULL; struct variant_worker_data data = {PTHREAD_MUTEX_INITIALIZER,}; /* WARNING: Tcl_RegExpExecObj() always does an internal conversion * of "s" to a UCS-2 Unicode string if "s" is in UTF-8 format. * Normally, this is a nice feature, but as of tcl-8.5, it doesn't * appear to be thread-safe. As a work-around, force the * conversion now before starting the threads. */ Tcl_GetUnicodeFromObj(s, &s_length); /* Determine the total number of variants (minus the NULL sentinel). */ task_count = (int)(sizeof(variants) / sizeof(variants[0]) - 1); /* Determine the number of threads to start. */ thread_count = cpu_count * 2; if (thread_count > task_count) { thread_count = task_count; } /* Allocate the "threads" array which holds the thread IDs. */ threads = calloc(thread_count, sizeof(*threads)); if (!threads) { perror("calloc"); exit(1); } /* Allocate the "tasks" array which holds one unit of work per * element in the array. */ tasks = calloc(task_count, sizeof(*tasks)); if (!tasks) { perror("calloc"); exit(1); } /* Initialize the task array. */ for (i = 0 ; i < task_count ; ++i) { tasks[i].variant = variants[i]; tasks[i].s = s; tasks[i].count = 0; } /* Initialize the data shared by the threads. */ data.tasks = tasks; data.next_task = 0; data.total_tasks = task_count; /* Start the threads. */ for (i = 0 ; i < thread_count ; ++i) { thread_rv = pthread_create(&threads[i], NULL, (thread_start_t)process_variant_worker, &data); if (thread_rv) { fprintf(stderr, "*** Error: pthread_create: failed"); exit(1); } } /* Wait for each thread to finish. */ for (i = 0 ; i < thread_count ; ++i) { thread_rv = pthread_join(threads[i], NULL); if (thread_rv) { fprintf(stderr, "*** Error: pthread_join: failed"); exit(1); } } /* Print results. */ for (i = 0 ; i < task_count ; ++i) { printf("%s %lu\n", variants[i], tasks[i].count); } /* Clean up. */ free(tasks); free(threads); }
static int TeststringobjCmd( ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_UniChar *unicode; int varIndex, option, i, length; #define MAX_STRINGS 11 const char *index, *string, *strings[MAX_STRINGS+1]; TestString *strPtr; static const char *const options[] = { "append", "appendstrings", "get", "get2", "length", "length2", "set", "set2", "setlength", "maxchars", "getunicode", "appendself", "appendself2", NULL }; if (objc < 3) { wrongNumArgs: Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?"); return TCL_ERROR; } index = Tcl_GetString(objv[2]); if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, &option) != TCL_OK) { return TCL_ERROR; } switch (option) { case 0: /* append */ if (objc != 5) { goto wrongNumArgs; } if (Tcl_GetIntFromObj(interp, objv[4], &length) != TCL_OK) { return TCL_ERROR; } if (varPtr[varIndex] == NULL) { SetVarToObj(varIndex, Tcl_NewObj()); } /* * If the object bound to variable "varIndex" is shared, we must * "copy on write" and append to a copy of the object. */ if (Tcl_IsShared(varPtr[varIndex])) { SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex])); } string = Tcl_GetString(objv[3]); Tcl_AppendToObj(varPtr[varIndex], string, length); Tcl_SetObjResult(interp, varPtr[varIndex]); break; case 1: /* appendstrings */ if (objc > (MAX_STRINGS+3)) { goto wrongNumArgs; } if (varPtr[varIndex] == NULL) { SetVarToObj(varIndex, Tcl_NewObj()); } /* * If the object bound to variable "varIndex" is shared, we must * "copy on write" and append to a copy of the object. */ if (Tcl_IsShared(varPtr[varIndex])) { SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex])); } for (i = 3; i < objc; i++) { strings[i-3] = Tcl_GetString(objv[i]); } for ( ; i < 12 + 3; i++) { strings[i - 3] = NULL; } Tcl_AppendStringsToObj(varPtr[varIndex], strings[0], strings[1], strings[2], strings[3], strings[4], strings[5], strings[6], strings[7], strings[8], strings[9], strings[10], strings[11]); Tcl_SetObjResult(interp, varPtr[varIndex]); break; case 2: /* get */ if (objc != 3) { goto wrongNumArgs; } if (CheckIfVarUnset(interp, varIndex)) { return TCL_ERROR; } Tcl_SetObjResult(interp, varPtr[varIndex]); break; case 3: /* get2 */ if (objc != 3) { goto wrongNumArgs; } if (CheckIfVarUnset(interp, varIndex)) { return TCL_ERROR; } string = Tcl_GetString(varPtr[varIndex]); Tcl_AppendToObj(Tcl_GetObjResult(interp), string, -1); break; case 4: /* length */ if (objc != 3) { goto wrongNumArgs; } Tcl_SetIntObj(Tcl_GetObjResult(interp), (varPtr[varIndex] != NULL) ? varPtr[varIndex]->length : -1); break; case 5: /* length2 */ if (objc != 3) { goto wrongNumArgs; } if (varPtr[varIndex] != NULL) { Tcl_ConvertToType(NULL, varPtr[varIndex], Tcl_GetObjType("string")); strPtr = (TestString *) (varPtr[varIndex])->internalRep.otherValuePtr; length = (int) strPtr->allocated; } else { length = -1; } Tcl_SetIntObj(Tcl_GetObjResult(interp), length); break; case 6: /* set */ if (objc != 4) { goto wrongNumArgs; } /* * If the object currently bound to the variable with index * varIndex has ref count 1 (i.e. the object is unshared) we can * modify that object directly. Otherwise, if RC>1 (i.e. the * object is shared), we must create a new object to modify/set * and decrement the old formerly-shared object's ref count. This * is "copy on write". */ string = Tcl_GetStringFromObj(objv[3], &length); if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) { Tcl_SetStringObj(varPtr[varIndex], string, length); } else { SetVarToObj(varIndex, Tcl_NewStringObj(string, length)); } Tcl_SetObjResult(interp, varPtr[varIndex]); break; case 7: /* set2 */ if (objc != 4) { goto wrongNumArgs; } SetVarToObj(varIndex, objv[3]); break; case 8: /* setlength */ if (objc != 4) { goto wrongNumArgs; } if (Tcl_GetIntFromObj(interp, objv[3], &length) != TCL_OK) { return TCL_ERROR; } if (varPtr[varIndex] != NULL) { Tcl_SetObjLength(varPtr[varIndex], length); } break; case 9: /* maxchars */ if (objc != 3) { goto wrongNumArgs; } if (varPtr[varIndex] != NULL) { Tcl_ConvertToType(NULL, varPtr[varIndex], Tcl_GetObjType("string")); strPtr = (TestString *) (varPtr[varIndex])->internalRep.otherValuePtr; length = strPtr->maxChars; } else { length = -1; } Tcl_SetIntObj(Tcl_GetObjResult(interp), length); break; case 10: /* getunicode */ if (objc != 3) { goto wrongNumArgs; } Tcl_GetUnicodeFromObj(varPtr[varIndex], NULL); break; case 11: /* appendself */ if (objc != 4) { goto wrongNumArgs; } if (varPtr[varIndex] == NULL) { SetVarToObj(varIndex, Tcl_NewObj()); } /* * If the object bound to variable "varIndex" is shared, we must * "copy on write" and append to a copy of the object. */ if (Tcl_IsShared(varPtr[varIndex])) { SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex])); } string = Tcl_GetStringFromObj(varPtr[varIndex], &length); if (Tcl_GetIntFromObj(interp, objv[3], &i) != TCL_OK) { return TCL_ERROR; } if ((i < 0) || (i > length)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "index value out of range", -1)); return TCL_ERROR; } Tcl_AppendToObj(varPtr[varIndex], string + i, length - i); Tcl_SetObjResult(interp, varPtr[varIndex]); break; case 12: /* appendself2 */ if (objc != 4) { goto wrongNumArgs; } if (varPtr[varIndex] == NULL) { SetVarToObj(varIndex, Tcl_NewObj()); } /* * If the object bound to variable "varIndex" is shared, we must * "copy on write" and append to a copy of the object. */ if (Tcl_IsShared(varPtr[varIndex])) { SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex])); } unicode = Tcl_GetUnicodeFromObj(varPtr[varIndex], &length); if (Tcl_GetIntFromObj(interp, objv[3], &i) != TCL_OK) { return TCL_ERROR; } if ((i < 0) || (i > length)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "index value out of range", -1)); return TCL_ERROR; } Tcl_AppendUnicodeToObj(varPtr[varIndex], unicode + i, length - i); Tcl_SetObjResult(interp, varPtr[varIndex]); break; } return TCL_OK; }