int TnmValidateIpHostName(Tcl_Interp *interp, const char *name) { const char *p = name; char last = ' '; int dots = 0, alpha = 0; /* * A host name must start with one of the characters [a-zA-Z0-9] * and continue with characters from the set [-.a-zA-Z0-9] and * must not end with a '-'. Names that only contain * digits and three dots are also not allowed. * * NOTE: a hostname is allowed to end with a dot, which the previous version of this code * explicitly disallowed. */ if (! isalnum(*p)) { goto error; } while (isalnum(*p) || *p == '-' || *p == '.') { if (*p == '.') dots++; if (isalpha(*p)) alpha++; last = *p++; } if (*p == '\0' && (isalnum(last) || last == '.') && (alpha || dots != 3)) { return TCL_OK; } error: if (interp) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "illegal IP host name \"", name, "\"", (char *) NULL); } return TCL_ERROR; }
LispRef eul_tk_cmd_text ( char *name, Tcl_CmdInfo *cmdPtr, char *command, LispRef args ) { struct infoargs infoArgs; ParseArguments2(&infoArgs, name, command, args); Tcl_ResetResult(interp); int result = (cmdPtr->proc) ( cmdPtr->clientData, interp, infoArgs.argc, infoArgs.argv ); if (result == TCL_OK) { if (strcmp(command, "index") == 0) { LispRef loc = eul_true;; eul_allocate_string(loc, interp->result); return loc; } else { return eul_nil; } } else { return eul_nil; } }
static int ForeachLoopStep (ClientData data[], Tcl_Interp * interp, int result) { ForeachState *const statePtr = data[0]; Tcl_Obj *const varPtr = data[1]; DBFHandle const dbfHandle = data[2]; Tcl_Obj *const bodyPtr = data[3]; switch (result) { case TCL_CONTINUE: result = TCL_OK; case TCL_OK: break; case TCL_BREAK: result = TCL_OK; goto done; case TCL_ERROR: default: goto done; } if (statePtr->length > ++statePtr->i) { if ((result = ForeachAssignments (interp, statePtr, varPtr, dbfHandle)) != TCL_OK) { goto done; } Tcl_NRAddCallback (interp, ForeachLoopStep, statePtr, varPtr, dbfHandle, bodyPtr); return Tcl_NREvalObj (interp, bodyPtr, 0); } Tcl_ResetResult (interp); done: ckfree ((char *) statePtr); return result; }
int observable_calc_tclcommand(observable* self) { Observable_Tclcommand_Arg_Container* container = (Observable_Tclcommand_Arg_Container*) self->container; Tcl_Interp* interp = (Tcl_Interp*) container->interp; int error = Tcl_Eval(interp, container->command); if (error) { return 1; } char* result = Tcl_GetStringResult(interp); char* token; int counter=0; double* A=self->last_value; token = strtok(result, " "); while ( token != NULL && counter < self->n) { A[counter] = atof(token); token = strtok(NULL, " "); counter++; } Tcl_ResetResult(interp); if (counter != self->n) { return 1; } return 0; }
int tclcommand_inter_print_bonded(Tcl_Interp *interp, int i) { char buffer[TCL_INTEGER_SPACE]; Tcl_ResetResult(interp); if(i < 0) { Tcl_AppendResult(interp, "interaction type must be nonnegative", (char *) NULL); return (TCL_ERROR); } /* print specific interaction information */ if(i<n_bonded_ia) { tclprint_to_result_BondedIA(interp, i); return TCL_OK; } sprintf(buffer, "%d", i); Tcl_AppendResult(interp, "unknown bonded interaction number ", buffer, (char *) NULL); return TCL_ERROR; }
/*++ TclGetOctalFromObj Retrieves an octal value from the given object. Arguments: interp - Interpreter to use for error reporting. objPtr - Object to retrieve the octal value from. octalPtr - Address to store the octal value. Return Value: A standard Tcl result. --*/ int TclGetOctalFromObj( Tcl_Interp *interp, Tcl_Obj *objPtr, unsigned long *octalPtr ) { char *input; assert(interp != NULL); assert(objPtr != NULL); assert(octalPtr != NULL); input = Tcl_GetString(objPtr); *octalPtr = strtoul(input, NULL, 8); if (errno == ERANGE) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "expected octal but got \"", input, "\"", NULL); return TCL_ERROR; } return TCL_OK; }
/* * Get the connection Id from the result Id */ int PgGetConnByResultId(Tcl_Interp *interp, CONST84 char *resid_c) { char *mark; Tcl_Channel conn_chan; if (!(mark = strchr(resid_c, '.'))) goto error_out; *mark = '\0'; conn_chan = Tcl_GetChannel(interp, resid_c, 0); *mark = '.'; if (conn_chan && Tcl_GetChannelType(conn_chan) == &Pg_ConnType) { Tcl_SetResult(interp, (char *) Tcl_GetChannelName(conn_chan), TCL_VOLATILE); return TCL_OK; } error_out: Tcl_ResetResult(interp); Tcl_AppendResult(interp, resid_c, " is not a valid connection\n", 0); return TCL_ERROR; }
static void tclconstraints(int del, double a[], int nt, int nm, int nr, int nb) { int ret; if (abortFit) return; clipdepth(del,a,nt,nm,nr,nb); if (fit_constraints) { genshift(a,FALSE); ret = Tcl_Eval(fit_interp, fit_constraints); if (ret == TCL_OK) { /* XXX FIXME XXX we can remove both this genshift and the * genshift in fgen/fsgen */ genshift(a,TRUE); Tcl_ResetResult(fit_interp); } else { if (ret == TCL_ERROR) failure = 1; stopFit(0); } } /* XXX FIXME XXX why did I want to run the event loop during constraints? */ /* flushqueue(); */ }
LispRef eul_tk_set_value_widget ( char *name, Tcl_CmdInfo *cmdPtr, char *index ) { static const char command[] = "set"; struct infoargs infoArgs; ParseArguments3(&infoArgs, name, command, index, eul_nil); Tcl_ResetResult(interp); int result = (cmdPtr->proc) ( cmdPtr->clientData, interp, infoArgs.argc, infoArgs.argv ); return eul_tk_result(result); }
int tclcommand_inter_parse_soft(Tcl_Interp * interp, int part_type_a, int part_type_b, int argc, char ** argv) { /* parameters needed for soft-shere */ double a, n, cut, offset; int change; /* get soft-sphere interaction type */ if (argc < 5) { Tcl_AppendResult(interp, "soft-sphere potential needs 4 parameters: " "<soft_a> <soft_n> <soft_cut> <soft_offset>", (char *) NULL); return 0; } /* copy soft-sphere parameters */ if ((! ARG_IS_D(1, a)) || (! ARG_IS_D(2, n)) || (! ARG_IS_D(3, cut)) || (! ARG_IS_D(4, offset) )) { Tcl_AppendResult(interp, "soft-sphere potential needs 4 parameters: " "<soft_a> <soft_n> <soft_cut> <soft_offset>", (char *) NULL); return 0; } change = 5; Tcl_ResetResult(interp); if (soft_sphere_set_params(part_type_a, part_type_b, a, n, cut, offset) == ES_ERROR) { Tcl_AppendResult(interp, "particle types must be non-negative", (char *) NULL); return 0; } return change; }
static void LostSelection( ClientData clientData) /* Pointer to LostCommand structure. */ { LostCommand *lostPtr = clientData; Tcl_Obj *objPtr; Tcl_Interp *interp; int code; interp = lostPtr->interp; Tcl_Preserve(interp); /* * Execute the command. Save the interpreter's result, if any, and restore * it after executing the command. */ objPtr = Tcl_GetObjResult(interp); Tcl_IncrRefCount(objPtr); Tcl_ResetResult(interp); code = TkCopyAndGlobalEval(interp, lostPtr->command); if (code != TCL_OK) { Tcl_BackgroundException(interp, code); } Tcl_SetObjResult(interp, objPtr); Tcl_DecrRefCount(objPtr); Tcl_Release(interp); /* * Free the storage for the command, since we're done with it now. */ ckfree((char *) lostPtr); }
/// parser for the forcecap int tclcommand_inter_parse_forcecap(Tcl_Interp * interp, int argc, char ** argv) { char buffer[TCL_DOUBLE_SPACE]; double forcecap; if (argc == 0) { if (force_cap == -1.0) Tcl_AppendResult(interp, "forcecap individual", (char *) NULL); else { Tcl_PrintDouble(interp, force_cap, buffer); Tcl_AppendResult(interp, "forcecap ", buffer, (char *) NULL); } return TCL_OK; } if (argc > 1) { Tcl_AppendResult(interp, "inter forcecap takes at most 1 parameter", (char *) NULL); return TCL_ERROR; } if (ARG0_IS_S("individual")){ forcecap = -1.0; CHECK_VALUE(forcecap_set_params(forcecap), "If you can read this, you should change it. (Use the source Luke!)"); } else if (! ARG0_IS_D(forcecap) || forcecap < 0) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "force cap must be a nonnegative double value or \"individual\"", (char *) NULL); return TCL_ERROR; } CHECK_VALUE(forcecap_set_params(forcecap), "If you can read this, you should change it. (Use the source Luke!)"); }
int Tcl_RecordAndEval( Tcl_Interp *interp, /* Token for interpreter in which command will * be executed. */ const char *cmd, /* Command to record. */ int flags) /* Additional flags. TCL_NO_EVAL means only * record: don't execute command. * TCL_EVAL_GLOBAL means use Tcl_GlobalEval * instead of Tcl_Eval. */ { register Tcl_Obj *cmdPtr; int result; if (cmd[0]) { /* * Call Tcl_RecordAndEvalObj to do the actual work. */ cmdPtr = Tcl_NewStringObj(cmd, -1); Tcl_IncrRefCount(cmdPtr); result = Tcl_RecordAndEvalObj(interp, cmdPtr, flags); /* * Discard the Tcl object created to hold the command. */ Tcl_DecrRefCount(cmdPtr); } else { /* * An empty string. Just reset the interpreter's result. */ Tcl_ResetResult(interp); result = TCL_OK; } return result; }
/*----------------------------------------------------------------------------- * EvalTrapCode -- * Run code as the result of a signal. The symbolic signal name is * formatted into the command replacing %S with the symbolic signal name. * * Parameters: * o interp - The interpreter to run the signal in. If an error * occures, then the result will be left in the interp. * o signalNum - The signal number of the signal that occured. * Return: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ static int EvalTrapCode (Tcl_Interp *interp, int signalNum) { int result; Tcl_DString command; Tcl_Obj *saveObjPtr; saveObjPtr = TclX_SaveResultErrorInfo (interp); Tcl_ResetResult (interp); /* * Format the signal name into the command. This also allows the signal * to be reset in the command. */ result = FormatTrapCode (interp, signalNum, &command); if (result == TCL_OK) result = Tcl_GlobalEval (interp, command.string); Tcl_DStringFree (&command); if (result == TCL_ERROR) { char errorInfo [128]; sprintf (errorInfo, "\n while executing signal trap code for %s%s", Tcl_SignalId (signalNum), " signal"); Tcl_AddErrorInfo (interp, errorInfo); return TCL_ERROR; } TclX_RestoreResultErrorInfo (interp, saveObjPtr); return TCL_OK; }
/*int GetRenzInfo(ClientData clientData, Tcl_Interp *interp, int argc, char **argv) { int num_entry; int i; char buf[1024]; if (argc != 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " filename\"", (char*)NULL); return TCL_ERROR; } if (!renzymes) { free_renzymes (renzymes); } renzymes = get_enzyme(argv[1]); printf("num_entry=%d\n", renzymes->used); if (!renzymes) return TCL_OK; num_entry = renzymes->used; Tcl_ResetResult(interp); for (i = 0; i < num_entry; i++) { sprintf(buf, "%s {%s} %s %s %.0f",renzymes->renzyme[i]->name, renzymes->renzyme[i]->rec_seq_text, renzymes->renzyme[i]->prototype, renzymes->renzyme[i]->supplier_codes, renzymes->renzyme[i]->av_frag_size); Tcl_AppendElement(interp, buf); } return TCL_OK; } */ int GetRenzInfo(ClientData clientData, Tcl_Interp *interp, int argc, char **argv) { int num_entry; int i; if (argc != 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " filename\"", (char*)NULL); return TCL_ERROR; } if (!renzymes) { free_renzymes (renzymes); } renzymes = get_enzyme(argv[1]); /* printf("num_entry=%d\n", renzymes->used); */ if (!renzymes) return TCL_OK; num_entry = renzymes->used; Tcl_ResetResult(interp); for (i = 0; i < num_entry; i++) { Tcl_DString dstr; Tcl_DStringInit(&dstr); vTcl_DStringAppendElement(&dstr, "%s", renzymes->renzyme[i]->name); vTcl_DStringAppendElement(&dstr, "%s", renzymes->renzyme[i]->rec_seq_text); vTcl_DStringAppendElement(&dstr, "%s", renzymes->renzyme[i]->prototype); vTcl_DStringAppendElement(&dstr, "%s", renzymes->renzyme[i]->supplier_codes); vTcl_DStringAppendElement(&dstr, "%.f", renzymes->renzyme[i]->av_frag_size); Tcl_AppendElement(interp, Tcl_DStringValue(&dstr)); Tcl_DStringFree(&dstr); } return TCL_OK; }
int tclcommand_inter_magnetic_parse_mdlc_params(Tcl_Interp * interp, int argc, char ** argv) { double pwerror; double gap_size; double far_cut = -1; MDLC_TRACE(fprintf(stderr, "%d: tclcommand_inter_magnetic_parse_mdlc_params().\n", this_node)); if (argc < 2) { Tcl_AppendResult(interp, "either nothing or mdlc <pwerror> <minimal layer distance> {<cutoff>} expected, not \"", argv[0], "\"", (char *)NULL); return TCL_ERROR; } if (!ARG0_IS_D(pwerror)) return TCL_ERROR; if (!ARG1_IS_D(gap_size)) return TCL_ERROR; argc -= 2; argv += 2; if (argc > 0) { // if there, parse away manual cutoff if(ARG0_IS_D(far_cut)) { argc--; argv++; } else Tcl_ResetResult(interp); if(argc > 0) { Tcl_AppendResult(interp, "either nothing or mdlc <pwerror> <minimal layer distance=size of the gap without particles> {<cutoff>} expected, not \"", argv[0], "\"", (char *)NULL); return TCL_ERROR; } } CHECK_VALUE(mdlc_set_params(pwerror,gap_size,far_cut), "choose a 3d electrostatics method prior to use mdlc"); }
/** #ifdef THERMODYNAMIC_FORCE */ int tclcommand_thermodynamic_force(ClientData _data, Tcl_Interp * interp, int argc, char ** argv) { int i, part_type, err_code; double j, prefactor; Tcl_ResetResult(interp); if(argc != 4){ Tcl_AppendResult(interp, "wrong # args: should be \"", "thermodynamic_force <type> <filename> <prefactor>\"", (char *) NULL); err_code = TCL_ERROR; } else { i=ARG_IS_I(1, part_type); j=ARG_IS_D(3,prefactor); if(i && j) err_code = tclcommand_thermodynamic_force_parse_opt(interp, part_type, prefactor, argc-2, argv+2); else err_code = TCL_ERROR; } return err_code; }
static void overloadedGlobFunction( sqlite3_context *pContext, int nArg, sqlite3_value **apArg ){ Tcl_Interp *interp = sqlite3_user_data(pContext); Tcl_DString str; int i; int rc; Tcl_DStringInit(&str); Tcl_DStringAppendElement(&str, "::echo_glob_overload"); for(i=0; i<nArg; i++){ Tcl_DStringAppendElement(&str, (char*)sqlite3_value_text(apArg[i])); } rc = Tcl_Eval(interp, Tcl_DStringValue(&str)); Tcl_DStringFree(&str); if( rc ){ sqlite3_result_error(pContext, Tcl_GetStringResult(interp), -1); }else{ sqlite3_result_text(pContext, Tcl_GetStringResult(interp), -1, SQLITE_TRANSIENT); } Tcl_ResetResult(interp); }
void TclpSetVariables( Tcl_Interp *interp) { #ifndef NO_UNAME struct utsname name; #endif int unameOK; Tcl_DString ds; #ifdef HAVE_COREFOUNDATION char tclLibPath[MAXPATHLEN + 1]; #if MAC_OS_X_VERSION_MAX_ALLOWED > 1020 /* * Set msgcat fallback locale to current CFLocale identifier. */ CFLocaleRef localeRef; if (CFLocaleCopyCurrent != NULL && CFLocaleGetIdentifier != NULL && (localeRef = CFLocaleCopyCurrent())) { CFStringRef locale = CFLocaleGetIdentifier(localeRef); if (locale) { char loc[256]; if (CFStringGetCString(locale, loc, 256, kCFStringEncodingUTF8)) { if (!Tcl_CreateNamespace(interp, "::tcl::mac", NULL, NULL)) { Tcl_ResetResult(interp); } Tcl_SetVar(interp, "::tcl::mac::locale", loc, TCL_GLOBAL_ONLY); } } CFRelease(localeRef); } #endif /* MAC_OS_X_VERSION_MAX_ALLOWED > 1020 */ if (MacOSXGetLibraryPath(interp, MAXPATHLEN, tclLibPath) == TCL_OK) { CONST char *str; CFBundleRef bundleRef; Tcl_SetVar(interp, "tclDefaultLibrary", tclLibPath, TCL_GLOBAL_ONLY); Tcl_SetVar(interp, "tcl_pkgPath", tclLibPath, TCL_GLOBAL_ONLY); Tcl_SetVar(interp, "tcl_pkgPath", " ", TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); str = TclGetEnv("DYLD_FRAMEWORK_PATH", &ds); if ((str != NULL) && (str[0] != '\0')) { char *p = Tcl_DStringValue(&ds); /* * Convert DYLD_FRAMEWORK_PATH from colon to space separated. */ do { if (*p == ':') { *p = ' '; } } while (*p++); Tcl_SetVar(interp, "tcl_pkgPath", Tcl_DStringValue(&ds), TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); Tcl_SetVar(interp, "tcl_pkgPath", " ", TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); Tcl_DStringFree(&ds); } bundleRef = CFBundleGetMainBundle(); if (bundleRef) { CFURLRef frameworksURL; Tcl_StatBuf statBuf; frameworksURL = CFBundleCopyPrivateFrameworksURL(bundleRef); if (frameworksURL) { if (CFURLGetFileSystemRepresentation(frameworksURL, TRUE, (unsigned char*) tclLibPath, MAXPATHLEN) && ! TclOSstat(tclLibPath, &statBuf) && S_ISDIR(statBuf.st_mode)) { Tcl_SetVar(interp, "tcl_pkgPath", tclLibPath, TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); Tcl_SetVar(interp, "tcl_pkgPath", " ", TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); } CFRelease(frameworksURL); } frameworksURL = CFBundleCopySharedFrameworksURL(bundleRef); if (frameworksURL) { if (CFURLGetFileSystemRepresentation(frameworksURL, TRUE, (unsigned char*) tclLibPath, MAXPATHLEN) && ! TclOSstat(tclLibPath, &statBuf) && S_ISDIR(statBuf.st_mode)) { Tcl_SetVar(interp, "tcl_pkgPath", tclLibPath, TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); Tcl_SetVar(interp, "tcl_pkgPath", " ", TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); } CFRelease(frameworksURL); } } Tcl_SetVar(interp, "tcl_pkgPath", pkgPath, TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); } else #endif /* HAVE_COREFOUNDATION */ { Tcl_SetVar(interp, "tcl_pkgPath", pkgPath, TCL_GLOBAL_ONLY); } #ifdef DJGPP Tcl_SetVar2(interp, "tcl_platform", "platform", "dos", TCL_GLOBAL_ONLY); #else Tcl_SetVar2(interp, "tcl_platform", "platform", "unix", TCL_GLOBAL_ONLY); #endif unameOK = 0; #ifndef NO_UNAME if (uname(&name) >= 0) { CONST char *native; unameOK = 1; native = Tcl_ExternalToUtfDString(NULL, name.sysname, -1, &ds); Tcl_SetVar2(interp, "tcl_platform", "os", native, TCL_GLOBAL_ONLY); Tcl_DStringFree(&ds); /* * The following code is a special hack to handle differences in the * way version information is returned by uname. On most systems the * full version number is available in name.release. However, under * AIX the major version number is in name.version and the minor * version number is in name.release. */ if ((strchr(name.release, '.') != NULL) || !isdigit(UCHAR(name.version[0]))) { /* INTL: digit */ Tcl_SetVar2(interp, "tcl_platform", "osVersion", name.release, TCL_GLOBAL_ONLY); } else { #ifdef DJGPP /* * For some obscure reason DJGPP puts major version into * name.release and minor into name.version. As of DJGPP 2.04 this * is documented in djgpp libc.info file. */ Tcl_SetVar2(interp, "tcl_platform", "osVersion", name.release, TCL_GLOBAL_ONLY); Tcl_SetVar2(interp, "tcl_platform", "osVersion", ".", TCL_GLOBAL_ONLY|TCL_APPEND_VALUE); Tcl_SetVar2(interp, "tcl_platform", "osVersion", name.version, TCL_GLOBAL_ONLY|TCL_APPEND_VALUE); #else Tcl_SetVar2(interp, "tcl_platform", "osVersion", name.version, TCL_GLOBAL_ONLY); Tcl_SetVar2(interp, "tcl_platform", "osVersion", ".", TCL_GLOBAL_ONLY|TCL_APPEND_VALUE); Tcl_SetVar2(interp, "tcl_platform", "osVersion", name.release, TCL_GLOBAL_ONLY|TCL_APPEND_VALUE); #endif /* DJGPP */ } Tcl_SetVar2(interp, "tcl_platform", "machine", name.machine, TCL_GLOBAL_ONLY); } #endif /* !NO_UNAME */ if (!unameOK) { Tcl_SetVar2(interp, "tcl_platform", "os", "", TCL_GLOBAL_ONLY); Tcl_SetVar2(interp, "tcl_platform", "osVersion", "", TCL_GLOBAL_ONLY); Tcl_SetVar2(interp, "tcl_platform", "machine", "", TCL_GLOBAL_ONLY); } /* * Copy the username of the real user (according to getuid()) into * tcl_platform(user). */ { struct passwd *pwEnt = TclpGetPwUid(getuid()); const char *user; if (pwEnt == NULL) { user = ""; Tcl_DStringInit(&ds); /* ensure cleanliness */ } else { user = Tcl_ExternalToUtfDString(NULL, pwEnt->pw_name, -1, &ds); } Tcl_SetVar2(interp, "tcl_platform", "user", user, TCL_GLOBAL_ONLY); Tcl_DStringFree(&ds); } }
int tclcommand_inter_coulomb_parse_elc_params(Tcl_Interp * interp, int argc, char ** argv) { double pwerror; double gap_size; double far_cut = -1; double top = 1, mid = 1, bot = 1; double delta_top = 0, delta_bot = 0; int neutralize = 1; double pot_diff = 0; int const_pot_on = 0; if (argc < 2) { Tcl_AppendResult(interp, "either nothing or elc <pwerror> <minimal layer distance> {<cutoff>} <{dielectric <di_top> <di_mid> <di_bottom>} | {dielectric-contrasts <d1> <d2>} | {capacitor <dU>}> {noneutralization} expected, not \"", argv[0], "\"", (char *)NULL); return TCL_ERROR; } if (!ARG0_IS_D(pwerror)) return TCL_ERROR; if (!ARG1_IS_D(gap_size)) return TCL_ERROR; argc -= 2; argv += 2; if (argc > 0) { // if there, parse away manual cutoff if(ARG0_IS_D(far_cut)) { argc--; argv++; } else Tcl_ResetResult(interp); while (argc > 0) { if (ARG0_IS_S("noneutralization") || ARG0_IS_S("-noneutralization")) { neutralize = 0; argc--; argv++; } else if (argc >= 4 && ARG0_IS_S("dielectric")) { Tcl_AppendResult(interp, "There seems to be an error when using ELC with dielectric constrasts. If you are sure you want to use it, you have to deactivate this message manually. ", (char *)NULL); return TCL_ERROR; // just a dummy, not used, as it is only printed for information // purposes. We need to calculate it double space_layer_dummy; if (!ARG_IS_D(1,top) || !ARG_IS_D(2,mid) || !ARG_IS_D(3,bot)) return TCL_ERROR; delta_top = (mid - top)/(mid + top); delta_bot = (mid - bot)/(mid + bot); argc -= 4; argv += 4; if (argc > 0 && ARG_IS_D(4, space_layer_dummy)) { argc--; argv++; } } else if (argc >= 3 && ARG0_IS_S("dielectric-contrasts")) { Tcl_AppendResult(interp, "There seems to be an error when using ELC with dielectric constrasts. If you are sure you want to use it, you have to deactivate this message manually. ", (char *)NULL); return TCL_ERROR; if (!ARG_IS_D(1,delta_top) || !ARG_IS_D(2,delta_bot)) return TCL_ERROR; argc -= 3; argv += 3; } else if (argc >= 1 && ARG0_IS_S("capacitor")) { Tcl_AppendResult(interp, "There seems to be an error when using ELC with dielectric constrasts. If you are sure you want to use it, you have to deactivate this message manually. ", (char *)NULL); return TCL_ERROR; if (!ARG_IS_D(1,pot_diff)) return TCL_ERROR; argc -= 2; argv += 2; const_pot_on = 1; delta_top = -1; delta_bot = -1; } else { Tcl_AppendResult(interp, "either nothing or elc <pwerror> <minimal layer distance> {<cutoff>} <{dielectric <di_top> <di_mid> <di_bottom>} | {dielectric-contrasts <d1> <d2>} | {capacitor <dU>}> {noneutralization} expected, not \"", argv[0], "\"", (char *)NULL); return TCL_ERROR; } } } CHECK_VALUE(ELC_set_params(pwerror, gap_size, far_cut, neutralize, delta_top, delta_bot, const_pot_on, pot_diff), "choose a 3d electrostatics method prior to ELC"); }
int TclKit_AppInit(Tcl_Interp *interp) { char *oldCmd; KITDEBUG("Initializing static packages") %DQKIT_INIT_CODE% Tcl_StaticPackage(0, "Mk4tcl", Mk4tcl_Init, NULL); Tcl_StaticPackage(0, "dqkitpwb", Pwb_Init, NULL); Tcl_StaticPackage(0, "rechan", Rechan_Init, NULL); Tcl_StaticPackage(0, "vfs", Vfs_Init, NULL); Tcl_StaticPackage(0, "zlib", Zlib_Init, NULL); #ifdef _WIN32 Tcl_StaticPackage(0, "dde", Dde_Init, NULL); Tcl_StaticPackage(0, "registry", Registry_Init, NULL); #endif #ifdef KIT_INCLUDES_TK Tcl_StaticPackage(0, "Tk", Tk_Init, Tk_SafeInit); #endif /* the tcl_rcFileName variable only exists in the initial interpreter */ #ifdef _WIN32 Tcl_SetVar(interp, "tcl_rcFileName", "~/tclkitrc.tcl", TCL_GLOBAL_ONLY); #else Tcl_SetVar(interp, "tcl_rcFileName", "~/.tclkitrc", TCL_GLOBAL_ONLY); #ifdef MAC_TCL Tcl_SetVar(interp, "tcl_rcRsrcName", "tclkitrc", TCL_GLOBAL_ONLY); #endif #endif KITDEBUG("TclSetPreInitScript()") oldCmd = TclSetPreInitScript(preInitCmd); KITDEBUG("Tcl_Init()") if (Tcl_Init(interp) == TCL_ERROR) goto error; KITDEBUG("Tcl_Init2()") TclSetPreInitScript(preInitCmd2); #ifdef KIT_INCLUDES_TK KITDEBUG("Initializing Tk") #if defined(_WIN32) || defined(MAC_TCL) if (Tk_Init(interp) == TCL_ERROR) goto error; #ifdef _WIN32 KITDEBUG("Initializing Tk console window") if (Tk_CreateConsoleWindow(interp) == TCL_ERROR) goto error; #else KITDEBUG("Setting up main Tcl interp") SetupMainInterp(interp); #endif #endif #endif KITDEBUG("Tcl_Eval(initScript)") /* messy because TclSetStartupScriptPath is called slightly too late */ if (Tcl_Eval(interp, initScript) == TCL_OK) { Tcl_Obj* path = TclGetStartupScriptPath(); TclSetStartupScriptPath(Tcl_GetObjResult(interp)); if (path == NULL) Tcl_Eval(interp, "incr argc -1; set argv [lrange $argv 1 end]"); } KITDEBUG("returning") Tcl_SetVar(interp, "errorInfo", "", TCL_GLOBAL_ONLY); Tcl_ResetResult(interp); return TCL_OK; error: #ifdef KIT_INCLUDES_TK #ifdef _WIN32 MessageBeep(MB_ICONEXCLAMATION); MessageBox(NULL, Tcl_GetStringResult(interp), "Error in TclKit", MB_ICONSTOP | MB_OK | MB_TASKMODAL | MB_SETFOREGROUND); ExitProcess(1); /* we won't reach this, but we need the return */ #endif #endif return TCL_ERROR; }
int tclcommand_adress_parse_set(Tcl_Interp *interp,int argc, char **argv){ int topo=-1,i,wf=0,set_center=0; double width[2],center[3]; char buffer[3*TCL_DOUBLE_SPACE]; argv+=2;argc-=2; for(i=0;i<3;i++) center[i]=box_l[i]/2; if (argc < 2) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "Wrong # of args! adress set needs at least 2 arguments\n", (char *)NULL); Tcl_AppendResult(interp, "Usage: adress set topo [0|1|2|3] width X.X Y.Y (center X.X Y.Y Z.Z) (wf [0|1])\n", (char *)NULL); Tcl_AppendResult(interp, "topo: 0 - switched off (no more values needed)\n", (char *)NULL); Tcl_AppendResult(interp, " 1 - constant (weight will be first value of width)\n", (char *)NULL); Tcl_AppendResult(interp, " 2 - divided in one direction (default x, or give a negative center coordinate\n", (char *)NULL); Tcl_AppendResult(interp, " 3 - spherical topology\n", (char *)NULL); Tcl_AppendResult(interp, "width: X.X - half of size of ex zone(r0/2 in the papers)\n", (char *)NULL); Tcl_AppendResult(interp, " Y.Y - size of hybrid zone (d in the papers)\n", (char *)NULL); Tcl_AppendResult(interp, " Note: Only one value need for topo 1 \n", (char *)NULL); Tcl_AppendResult(interp, "center: center of the ex zone (default middle of the box) \n", (char *)NULL); Tcl_AppendResult(interp, " Note: x|y|x X.X for topo 2 \n", (char *)NULL); Tcl_AppendResult(interp, " Note: X.X Y.Y Z.Z for topo 3 \n", (char *)NULL); Tcl_AppendResult(interp, "wf: 0 - cos weighting function (default)\n", (char *)NULL); Tcl_AppendResult(interp, " 1 - polynom weighting function\n", (char *)NULL); Tcl_AppendResult(interp, "ALWAYS set box_l first !!!", (char *)NULL); return (TCL_ERROR); } //parse topo if ( (argc<2) || (!ARG0_IS_S("topo")) || (!ARG1_IS_I(topo)) || (topo < 0) || (topo > 3) ) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "expected \'topo 0|1|2|3\'\n", (char *)NULL); return (TCL_ERROR); } argv+=2;argc-=2; //stop if topo is 0 if (topo==0) { adress_vars[0]=0.0; mpi_bcast_parameter(FIELD_ADRESS); return TCL_OK; } //parse width if ( (argc>1) && (ARG0_IS_S("width")) ) { if (topo==1) { if ( (!ARG1_IS_D(width[0])) || (width[0]<0) ){ Tcl_ResetResult(interp); Tcl_AppendResult(interp, "expected \'width X.X (X.X non-negative)\'", (char *)NULL); return (TCL_ERROR); } if ((width[0]> 1.0) || (width[0]< 0.0)) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "for constant topo, first width must be between 0 and 1", (char *)NULL); return (TCL_ERROR); } //stop if topo is 1 adress_vars[0]=1; adress_vars[1]=width[0]; mpi_bcast_parameter(FIELD_ADRESS); return TCL_OK; } else {//topo 2 and 3 are left over if ( (argc<3) || (!ARG1_IS_D(width[0])) || (width[0]<0) ||(!ARG_IS_D(2,width[1])) || (width[1]<0) ){ Tcl_ResetResult(interp); Tcl_AppendResult(interp, "expected \'width X.X Y.Y (both non-negative)\'", (char *)NULL); return (TCL_ERROR); } argv+=3;argc-=3; } } else{ Tcl_ResetResult(interp); Tcl_AppendResult(interp, "expected \'width\'", (char *)NULL); return (TCL_ERROR); } while (argc!=0){ if (ARG0_IS_S("wf")){ if ( (argc<2) || (!ARG1_IS_I(wf)) || (wf < 0) || (wf > 1) ){ Tcl_ResetResult(interp); Tcl_AppendResult(interp, "expected \'wf 0|1\'", (char *)NULL); return (TCL_ERROR); } else{ argv+=2;argc-=2; } } else if (ARG0_IS_S("center")){ if (topo == 2) { if ( (argc<3) || ( (!ARG1_IS_S("x"))&&(!ARG1_IS_S("y"))&&(!ARG1_IS_S("z")) ) || (!ARG_IS_D(2,center[1])) ){ Tcl_ResetResult(interp); Tcl_AppendResult(interp, "expected \'center x|y|z X.X\'", (char *)NULL); return (TCL_ERROR); } if (ARG1_IS_S("x")) center[0]=0; else if (ARG1_IS_S("y")) center[0]=1; else center[0]=2; if ( (center[1]<0) || (center[1]>box_l[(int)center[0]]) ) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "The center component is outside the box", (char *)NULL); return (TCL_ERROR); } set_center=1; argv+=3;argc-=3; } else { //topo 3 if ( (argc<4) || (!ARG_IS_D(1,center[0])) || (!ARG_IS_D(2,center[1])) || (!ARG_IS_D(3,center[2])) ){ Tcl_ResetResult(interp); Tcl_AppendResult(interp, "expected \'center X.X Y.Y Z.Z\'", (char *)NULL); return (TCL_ERROR); } argv+=4;argc-=4; //check components of center for (i=0;i<3;i++){ if ( (center[i]<0)||(center[i]>box_l[i]) ){ Tcl_ResetResult(interp); sprintf(buffer,"%i",i); Tcl_AppendResult(interp, "The ",buffer," th component of center is outside the box\n", (char *)NULL); return (TCL_ERROR); } } } } else{ Tcl_ResetResult(interp); Tcl_AppendResult(interp, "The unknown operation \"", argv[0],"\".", (char *)NULL); return (TCL_ERROR); } } //set standard center value for topo 2 if ((topo==2) && (set_center==0) ) center[0]=0; //width check if (topo==2){ if (width[0]+width[1]>box_l[(int)center[0]]/2){ Tcl_ResetResult(interp); Tcl_AppendResult(interp, "The width of ex+hy must smaller than box_l/2\n", (char *)NULL); return (TCL_ERROR); } } else if (topo==3){ for (i=0;i<3;i++){ if (width[0]+width[1]>box_l[i]/2){ Tcl_ResetResult(interp); sprintf(buffer,"%i",i); Tcl_AppendResult(interp, "The width of ex+hy must smaller than box_l/2 in dim " ,buffer,"\n", (char *)NULL); return (TCL_ERROR); } } } adress_vars[0]=topo; adress_vars[1]=width[0]; adress_vars[2]=width[1]; adress_vars[3]=center[0]; adress_vars[4]=center[1]; adress_vars[5]=center[2]; adress_vars[6]=wf; mpi_bcast_parameter(FIELD_ADRESS); return TCL_OK; }
static int winprint_page_setup_command (ClientData cd, Tcl_Interp *interp, int argc, char **argv) { struct winprint_data *wd = (struct winprint_data *) cd; Tk_Window parent; int i, mode, ret; PAGESETUPDLG psd; parent = Tk_MainWindow (interp); for (i = 2; i < argc; i += 2) { if (i + 1 >= argc) { Tcl_ResetResult (interp); Tcl_AppendStringsToObj (Tcl_GetObjResult (interp), "value for \"", argv[i], "\" missing", (char *) NULL); return TCL_ERROR; } if (strcmp (argv[i], "-parent") == 0) { parent = Tk_NameToWindow (interp, argv[i + 1], Tk_MainWindow (interp)); if (parent == NULL) return TCL_ERROR; } else { Tcl_ResetResult (interp); Tcl_AppendStringsToObj (Tcl_GetObjResult (interp), "unknown option \"", argv[i], "\"", (char *) NULL); return TCL_ERROR; } } if (wd->page_setup != NULL) psd = *wd->page_setup; else { memset (&psd, 0, sizeof (PAGESETUPDLG)); psd.lStructSize = sizeof (PAGESETUPDLG); psd.Flags = PSD_DEFAULTMINMARGINS; } if (Tk_WindowId (parent) == None) Tk_MakeWindowExist (parent); psd.hwndOwner = Tk_GetHWND (Tk_WindowId (parent)); mode = Tcl_SetServiceMode (TCL_SERVICE_ALL); ret = PageSetupDlg (&psd); (void) Tcl_SetServiceMode (mode); if (! ret) { DWORD code; code = CommDlgExtendedError (); if (code == 0) { /* The user pressed cancel. */ return TCL_OK; } else { char buf[20]; sprintf (buf, "0x%lx", (unsigned long) code); Tcl_ResetResult (interp); Tcl_AppendStringsToObj (Tcl_GetObjResult (interp), "Windows common dialog error ", buf, (char *) NULL); return TCL_ERROR; } } if (wd->page_setup == NULL) wd->page_setup = (PAGESETUPDLG *) ckalloc (sizeof (PAGESETUPDLG)); *wd->page_setup = psd; return TCL_OK; }
/* Implement ide_winprint print_text. */ static int winprint_print_command (ClientData cd, Tcl_Interp *interp, int argc, char **argv) { struct winprint_data *wd = (struct winprint_data *) cd; char *queryproc; char *textproc; struct print_text_options pto; PRINTDLG pd; int cancelled; int top, bottom, left; TEXTMETRIC tm; POINT pt; int lineheight; int pageno; int error=0, done, needquery; struct { short len; /* Defined to be 16 bits.... */ char buffer[PRINT_BUFSIZE+1]; } indata; queryproc = argv[2]; textproc = argv[3]; if (winprint_print_text_options (wd, interp, argc, argv, &pto) != TCL_OK) return TCL_ERROR; if (winprint_print_text_dialog (wd, interp, &pto, &pd, &cancelled) != TCL_OK) return TCL_ERROR; if (cancelled) return TCL_OK; if (pto.postscript) { int eps_printing = 33; int result; short bresult = 1; /* EPS printing download suppressed */ result = Escape (pd.hDC, eps_printing, sizeof (BOOL), (LPCSTR)&bresult, NULL); if ( result < 0 ) { /* The EPSPRINTING escape failed! */ Tcl_AppendElement(interp, "ide_winprint: EPSPRINTING escape implemented but failed"); DeleteDC (pd.hDC); return TCL_ERROR; } } else { winprint_get_margins(wd, &pd, &top, &left, &bottom); } if (winprint_start (wd, interp, &pd, &pto, &cancelled) != TCL_OK) { DeleteDC (pd.hDC); return TCL_ERROR; } if (cancelled) { DeleteDC (pd.hDC); return TCL_OK; } /* init and start init-procedure if available */ if (pto.initproc != NULL) { Tcl_DString initStr; char buf[64]; Tcl_DStringInit (&initStr); Tcl_DStringAppend (&initStr, pto.initproc, -1); /* Here we must pass the customer selection from the PrintDialog * as parameters for the init command, */ /* From page */ Tcl_DStringAppendElement (&initStr, "-frompage"); sprintf (buf, "%i", pd.nFromPage); Tcl_DStringAppendElement (&initStr, buf); /* To Page */ Tcl_DStringAppendElement (&initStr, "-topage"); sprintf (buf, "%i", pd.nToPage); Tcl_DStringAppendElement (&initStr, buf); /* # Copies */ Tcl_DStringAppendElement (&initStr, "-copies"); sprintf (buf, "%i", pd.nCopies); Tcl_DStringAppendElement (&initStr, buf); /* Print Selection? */ Tcl_DStringAppendElement (&initStr, "-selection"); Tcl_DStringAppendElement (&initStr, (pd.Flags&PD_SELECTION) ? "1" : "0"); /* Execute tcl/command */ if (Tcl_Eval (interp, Tcl_DStringValue(&initStr)) != TCL_OK) { Tcl_DStringFree (&initStr); return TCL_ERROR; } Tcl_DStringFree (&initStr); } if (pto.postscript) { Tcl_DString pageStr; int status, retval, len, i; char *l, msgbuf[128]; enum winprint_query q = 0; /* Note: NT 4.0 seems to leave the default CTM quite tiny! */ strcpy (indata.buffer, "\r\nsave\r\ninitmatrix\r\n"); indata.len = strlen(indata.buffer); Escape(pd.hDC, PASSTHROUGH, 0, (LPCSTR)&indata, NULL); /* Init command for page-procedure */ if (pto.pageproc != NULL) { Tcl_DStringInit (&pageStr); Tcl_DStringAppend (&pageStr, pto.pageproc, -1); Tcl_DStringAppendElement (&pageStr, "-1"); } /* Start printing */ while (1) { /* Run page-procedure to update the display */ status = winprint_print_text_invoke (interp, Tcl_DStringValue(&pageStr), "page", &q); if (status != TCL_OK || q == Q_DONE) { error = 1; break; } /* query next characters to send to printer */ if (winprint_print_text_invoke (interp, queryproc, "query", &q) != TCL_OK) { error = 1; break; } if (q != Q_CONTINUE) { done = 1; break; } if (Tcl_Eval (interp, textproc) == TCL_ERROR) { error = 1; break; } l = Tcl_GetStringFromObj (Tcl_GetObjResult (interp), &len); for (i=0; i<len; i+=PRINT_BUFSIZE) { int lpos = min (PRINT_BUFSIZE, len-i); strncpy (indata.buffer, l+i, lpos); indata.buffer[lpos] = 0; indata.len = lpos; retval = Escape (pd.hDC, PASSTHROUGH, 0, (LPCSTR)&indata, NULL); if (retval < 0) { Tcl_AppendElement(interp, "ide_winprint: PASSTHROUGH Escape failed"); error = 1; break; } else if (retval != indata.len) { sprintf(msgbuf, "ide_winprint: Short write (%d vs. %d)", retval, indata.len); Tcl_AppendElement(interp, msgbuf); error = 1; break; } } } strcpy (indata.buffer, "\r\nrestore\r\n"); indata.len = strlen(indata.buffer); Escape(pd.hDC, PASSTHROUGH, 0, (LPCSTR)&indata, NULL); } else { GetTextMetrics (pd.hDC, &tm); pt.x = 0; pt.y = tm.tmHeight + tm.tmExternalLeading; LPtoDP (pd.hDC, &pt, 1); lineheight = pt.y; pageno = 1; /* The main print loop. */ done = 0; error = 0; needquery = 1; while (1) { int y; if (wd->aborted) break; /* Start a new page. */ if (pto.pageproc != NULL) { Tcl_DString ds; char buf[20]; enum winprint_query q; int status; Tcl_DStringInit (&ds); Tcl_DStringAppend (&ds, pto.pageproc, -1); sprintf (buf, "%d", pageno); Tcl_DStringAppendElement (&ds, buf); status = winprint_print_text_invoke (interp, Tcl_DStringValue (&ds), "page", &q); Tcl_DStringFree (&ds); if (status != TCL_OK) { error = 1; break; } if (q == Q_DONE) { done = 1; break; } } if (needquery) { enum winprint_query q; if (winprint_print_text_invoke (interp, queryproc, "query", &q) != TCL_OK) { error = 1; break; } if (q == Q_DONE) { done = 1; break; } /* Ignore Q_NEWPAGE, since we're about to start a new page anyhow. */ needquery = 0; } if (StartPage (pd.hDC) <= 0) { windows_error (interp, "StartPage"); error = 1; break; } y = top; /* Print a page. */ while (1) { char *l; int len; enum winprint_query q; if (Tcl_Eval (interp, textproc) == TCL_ERROR) { error = 1; break; } l = Tcl_GetStringFromObj (Tcl_GetObjResult (interp), &len); TextOut (pd.hDC, left, y, l, len); y += lineheight; if (y >= bottom) { needquery = 1; break; } if (winprint_print_text_invoke (interp, queryproc, "query", &q) != TCL_OK) { error = 1; break; } if (q == Q_DONE) { done = 1; break; } else if (q == Q_NEWPAGE) break; } if (error) break; if (EndPage (pd.hDC) <= 0) { /* It's OK for EndPage to return an error if the print job was cancelled. */ if (! wd->aborted) { windows_error (interp, "EndPage"); error = 1; } break; } if (done) break; ++pageno; } } if (winprint_finish (wd, interp, &pd, error) != TCL_OK) error = 1; if (error) return TCL_ERROR; Tcl_ResetResult (interp); return TCL_OK; }
static int winprint_print_text_dialog (struct winprint_data *wd, Tcl_Interp *interp, const struct print_text_options *pto, PRINTDLG *pd, int *cancelled) { int mode, ret; *cancelled = 0; memset (pd, 0, sizeof (PRINTDLG)); pd->lStructSize = sizeof (PRINTDLG); if (! pto->dialog) pd->Flags = PD_RETURNDEFAULT | PD_RETURNDC; else { Tk_Window parent; if (pto->parent == NULL) parent = Tk_MainWindow (interp); else { parent = Tk_NameToWindow (interp, pto->parent, Tk_MainWindow (interp)); if (parent == NULL) return TCL_ERROR; } if (Tk_WindowId (parent) == None) Tk_MakeWindowExist (parent); pd->hwndOwner = Tk_GetHWND (Tk_WindowId (parent)); if (wd->page_setup != NULL) { pd->hDevMode = wd->page_setup->hDevMode; pd->hDevNames = wd->page_setup->hDevNames; } pd->Flags = PD_NOSELECTION | PD_RETURNDC | PD_USEDEVMODECOPIES; pd->nCopies = 1; pd->nFromPage = 1; pd->nToPage = 1; pd->nMinPage = 1; pd->nMaxPage = 0xffff; } mode = Tcl_SetServiceMode (TCL_SERVICE_ALL); ret = PrintDlg (pd); (void) Tcl_SetServiceMode (mode); if (! ret) { DWORD code; code = CommDlgExtendedError (); /* For some errors, the print dialog will already have reported an error. We treat those as though the user pressed cancel. Unfortunately, I do not know just which errors those are. */ if (code == 0 || code == PDERR_NODEFAULTPRN) { *cancelled = 1; return TCL_OK; } else { char buf[20]; sprintf (buf, "0x%lx", (unsigned long) code); Tcl_ResetResult (interp); Tcl_AppendStringsToObj (Tcl_GetObjResult (interp), "Windows common dialog error ", buf, (char *) NULL); return TCL_ERROR; } } return TCL_OK; }
int tclcommand_inter_parse_non_bonded(Tcl_Interp * interp, int part_type_a, int part_type_b, int argc, char ** argv) { int change; Tcl_ResetResult(interp); if (argc <= 0) { Tcl_AppendResult(interp, "wrong # args: should be \"", "inter <type 1> <type 2> ?interaction? ?values?\"", (char *) NULL); return TCL_ERROR; } /* get interaction parameters */ while (argc > 0) { /* The various parsers return the number of parsed parameters. If an error occured, 0 should be returned, since none of the parameters were understood */ /* that's just for the else below... */ if (0); #define REGISTER_NONBONDED(name, parser) \ else if (ARG0_IS_S(name)) \ change = parser(interp, part_type_a, part_type_b, argc, argv) #ifdef LENNARD_JONES REGISTER_NONBONDED("lennard-jones", tclcommand_inter_parse_lj); #endif #ifdef LENNARD_JONES_GENERIC REGISTER_NONBONDED("lj-gen", tclcommand_inter_parse_ljgen); #endif #ifdef LJ_ANGLE REGISTER_NONBONDED("lj-angle", tclcommand_inter_parse_ljangle); #endif #ifdef SMOOTH_STEP REGISTER_NONBONDED("smooth-step", tclcommand_inter_parse_SmSt); #endif #ifdef HERTZIAN REGISTER_NONBONDED("hertzian", tclcommand_inter_parse_hertzian); #endif #ifdef GAUSSIAN REGISTER_NONBONDED("gaussian", tclcommand_inter_parse_gaussian); #endif #ifdef BMHTF_NACL REGISTER_NONBONDED("bmhtf-nacl", tclcommand_inter_parse_BMHTF); #endif #ifdef MORSE REGISTER_NONBONDED("morse", tclcommand_inter_parse_morse); #endif #ifdef LJCOS REGISTER_NONBONDED("lj-cos", tclcommand_inter_parse_ljcos); #endif #ifdef BUCKINGHAM REGISTER_NONBONDED("buckingham", tclcommand_inter_parse_buckingham); #endif #ifdef SOFT_SPHERE REGISTER_NONBONDED("soft-sphere", tclcommand_inter_parse_soft); #endif #ifdef HAT REGISTER_NONBONDED("hat", tclcommand_inter_parse_hat); #endif #ifdef COMFORCE REGISTER_NONBONDED("comforce", tclcommand_inter_parse_comforce); #endif #ifdef LJCOS2 REGISTER_NONBONDED("lj-cos2", tclcommand_inter_parse_ljcos2); #endif #ifdef COMFIXED REGISTER_NONBONDED("comfixed", tclcommand_inter_parse_comfixed); #endif #ifdef GAY_BERNE REGISTER_NONBONDED("gay-berne", tclcommand_inter_parse_gb); #endif #ifdef TABULATED REGISTER_NONBONDED("tabulated", tclcommand_inter_parse_tab); #endif #ifdef INTER_DPD REGISTER_NONBONDED("inter_dpd", tclcommand_inter_parse_inter_dpd); #endif #ifdef INTER_RF REGISTER_NONBONDED("inter_rf", tclcommand_inter_parse_interrf); #endif #ifdef TUNABLE_SLIP REGISTER_NONBONDED("tunable_slip", tclcommand_inter_parse_tunable_slip); #endif #ifdef MOL_CUT REGISTER_NONBONDED("molcut", tclcommand_inter_parse_molcut); #endif #ifdef ADRESS #ifdef INTERFACE_CORRECTION REGISTER_NONBONDED("adress_tab_ic", tclcommand_inter_parse_adress_tab); #endif #endif else { Tcl_AppendResult(interp, "excessive parameter/unknown interaction type \"", argv[0], "\" in parsing non bonded interaction", (char *) NULL); return TCL_ERROR; } if (change <= 0) return TCL_ERROR; argc -= change; argv += change; }
/* v is an array of TkArg */ CAMLprim value camltk_tcl_direct_eval(value v) { int i; int size; /* size of argv */ char **argv, **allocated; int result; Tcl_CmdInfo info; CheckInit(); /* walk the array to compute final size for Tcl */ for(i=0, size=0; i<Wosize_val(v); i++) size += argv_size(Field(v,i)); /* +2: one slot for NULL one slot for "unknown" if command not found */ argv = (char **)stat_alloc((size + 2) * sizeof(char *)); allocated = (char **)stat_alloc(size * sizeof(char *)); /* Copy -- argv[i] must be freed by stat_free */ { int where; for(i=0, where=0; i<Wosize_val(v); i++){ where = fill_args(argv,where,Field(v,i)); } if( size != where ){ tk_error("fill_args error!!! Call the CamlTk maintainer!"); } for(i=0; i<where; i++){ allocated[i] = argv[i]; } argv[size] = NULL; argv[size + 1] = NULL; } /* Eval */ Tcl_ResetResult(cltclinterp); if (Tcl_GetCommandInfo(cltclinterp,argv[0],&info)) { /* command found */ #if (TCL_MAJOR_VERSION >= 8) /* info.proc might be a NULL pointer * We should probably attempt an Obj invocation, but the following quick * hack is easier. */ if (info.proc == NULL) { Tcl_DString buf; Tcl_DStringInit(&buf); Tcl_DStringAppend(&buf, argv[0], -1); for (i=1; i<size; i++) { Tcl_DStringAppend(&buf, " ", -1); Tcl_DStringAppend(&buf, argv[i], -1); } result = Tcl_Eval(cltclinterp, Tcl_DStringValue(&buf)); Tcl_DStringFree(&buf); } else { result = (*info.proc)(info.clientData,cltclinterp,size,argv); } #else result = (*info.proc)(info.clientData,cltclinterp,size,argv); #endif } else { /* implement the autoload stuff */ if (Tcl_GetCommandInfo(cltclinterp,"unknown",&info)) { /* unknown found */ for (i = size; i >= 0; i--) argv[i+1] = argv[i]; argv[0] = "unknown"; result = (*info.proc)(info.clientData,cltclinterp,size+1,argv); } else { /* ah, it isn't there at all */ result = TCL_ERROR; Tcl_AppendResult(cltclinterp, "Unknown command \"", argv[0], "\"", NULL); } } /* Free the various things we allocated */ for(i=0; i< size; i ++){ stat_free((char *) allocated[i]); } stat_free((char *)argv); stat_free((char *)allocated); switch (result) { case TCL_OK: return tcl_string_to_caml (Tcl_GetStringResult(cltclinterp)); case TCL_ERROR: tk_error(Tcl_GetStringResult(cltclinterp)); default: /* TCL_BREAK, TCL_CONTINUE, TCL_RETURN */ tk_error("bad tcl result"); } }
/* * Open/create a framebuffer object. * * Usage: * fb_open [name device [args]] */ HIDDEN int fbo_open_tcl(ClientData clientData, Tcl_Interp *interp, int argc, char **argv) { struct fb_obj *fbop; FBIO *ifp; int width = 512; int height = 512; register int c; struct bu_vls vls; if (argc == 1) { /* get list of framebuffer objects */ for (BU_LIST_FOR(fbop, fb_obj, &HeadFBObj.l)) Tcl_AppendResult(interp, bu_vls_addr(&fbop->fbo_name), " ", (char *)NULL); return TCL_OK; } if (argc < 3) { bu_vls_init(&vls); bu_vls_printf(&vls, "helplib fb_open"); Tcl_Eval(interp, bu_vls_addr(&vls)); bu_vls_free(&vls); return TCL_ERROR; } /* process args */ bu_optind = 3; bu_opterr = 0; while ((c = bu_getopt(argc, argv, "w:W:s:S:n:N:")) != EOF) { switch (c) { case 'W': case 'w': width = atoi(bu_optarg); break; case 'N': case 'n': height = atoi(bu_optarg); break; case 'S': case 's': width = atoi(bu_optarg); height = width; break; case '?': default: Tcl_AppendResult(interp, "fb_open: bad option - ", bu_optarg, (char *)NULL); return TCL_ERROR; } } if ((ifp = fb_open(argv[2], width, height)) == FBIO_NULL) { Tcl_AppendResult(interp, "fb_open: bad device - ", argv[2], (char *)NULL); } if (fb_ioinit(ifp) != 0) { Tcl_AppendResult(interp, "fb_open: fb_ioinit() failed.", (char *) NULL); return TCL_ERROR; } BU_GETSTRUCT(fbop, fb_obj); bu_vls_init(&fbop->fbo_name); bu_vls_strcpy(&fbop->fbo_name, argv[1]); fbop->fbo_fbs.fbs_fbp = ifp; fbop->fbo_fbs.fbs_listener.fbsl_fbsp = &fbop->fbo_fbs; fbop->fbo_fbs.fbs_listener.fbsl_fd = -1; fbop->fbo_fbs.fbs_listener.fbsl_port = -1; /* append to list of fb_obj's */ BU_LIST_APPEND(&HeadFBObj.l, &fbop->l); (void)Tcl_CreateCommand(interp, bu_vls_addr(&fbop->fbo_name), (Tcl_CmdProc *)fbo_cmd, (ClientData)fbop, fbo_deleteProc); /* Return new function name as result */ Tcl_ResetResult(interp); Tcl_AppendResult(interp, bu_vls_addr(&fbop->fbo_name), (char *)NULL); return TCL_OK; }
char * Tk_SetAppName( Tk_Window tkwin, /* Token for any window in the application * to be named: it is just used to identify * the application and the display. */ char *name) /* The name that will be used to * refer to the interpreter in later * "send" commands. Must be globally * unique. */ { TkWindow *winPtr = (TkWindow *) tkwin; Tcl_Interp *interp = winPtr->mainPtr->interp; int i, suffix, offset, result; int createCommand = 0; RegisteredInterp *riPtr, *prevPtr; char *actualName; Tcl_DString dString; Tcl_Obj *resultObjPtr, *interpNamePtr; char *interpName; if (!initialized) { SendInit(interp); } /* * See if the application is already registered; if so, remove its * current name from the registry. The deletion of the command * will take care of disposing of this entry. */ for (riPtr = interpListPtr, prevPtr = NULL; riPtr != NULL; prevPtr = riPtr, riPtr = riPtr->nextPtr) { if (riPtr->interp == interp) { if (prevPtr == NULL) { interpListPtr = interpListPtr->nextPtr; } else { prevPtr->nextPtr = riPtr->nextPtr; } break; } } /* * Pick a name to use for the application. Use "name" if it's not * already in use. Otherwise add a suffix such as " #2", trying * larger and larger numbers until we eventually find one that is * unique. */ actualName = name; suffix = 1; offset = 0; Tcl_DStringInit(&dString); TkGetInterpNames(interp, tkwin); resultObjPtr = Tcl_GetObjResult(interp); Tcl_IncrRefCount(resultObjPtr); for (i = 0; ; ) { result = Tcl_ListObjIndex(NULL, resultObjPtr, i, &interpNamePtr); if (interpNamePtr == NULL) { break; } interpName = Tcl_GetStringFromObj(interpNamePtr, NULL); if (strcmp(actualName, interpName) == 0) { if (suffix == 1) { Tcl_DStringAppend(&dString, name, -1); Tcl_DStringAppend(&dString, " #", 2); offset = Tcl_DStringLength(&dString); Tcl_DStringSetLength(&dString, offset + 10); actualName = Tcl_DStringValue(&dString); } suffix++; sprintf(actualName + offset, "%d", suffix); i = 0; } else { i++; } } Tcl_DecrRefCount(resultObjPtr); Tcl_ResetResult(interp); /* * We have found a unique name. Now add it to the registry. */ riPtr = (RegisteredInterp *) ckalloc(sizeof(RegisteredInterp)); riPtr->interp = interp; riPtr->name = ckalloc(strlen(actualName) + 1); riPtr->nextPtr = interpListPtr; interpListPtr = riPtr; strcpy(riPtr->name, actualName); Tcl_CreateObjCommand(interp, "send", Tk_SendObjCmd, (ClientData) riPtr, NULL /* TODO: DeleteProc */); if (Tcl_IsSafe(interp)) { Tcl_HideCommand(interp, "send", "send"); } Tcl_DStringFree(&dString); return riPtr->name; }
/* ARGSUSED */ int Tk_GrabObjCmd( ClientData clientData, /* Main window associated with interpreter. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { int globalGrab; Tk_Window tkwin; TkDisplay *dispPtr; const char *arg; int index; int len; static const char *const optionStrings[] = { "current", "release", "set", "status", NULL }; static const char *const flagStrings[] = { "-global", NULL }; enum options { GRABCMD_CURRENT, GRABCMD_RELEASE, GRABCMD_SET, GRABCMD_STATUS }; if (objc < 2) { /* * Can't use Tcl_WrongNumArgs here because we want the message to * read: * wrong # args: should be "cmd ?-global? window" or "cmd option * ?arg ...?" * We can fake it with Tcl_WrongNumArgs if we assume the command name * is "grab", but if it has been aliased, the message will be * incorrect. */ Tcl_ResetResult(interp); Tcl_AppendResult(interp, "wrong # args: should be \"", Tcl_GetString(objv[0]), " ?-global? window\" or \"", Tcl_GetString(objv[0]), " option ?arg ...?\"", NULL); return TCL_ERROR; } /* * First check for a window name or "-global" as the first argument. */ arg = Tcl_GetStringFromObj(objv[1], &len); if (arg[0] == '.') { /* [grab window] */ if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "?-global? window"); return TCL_ERROR; } tkwin = Tk_NameToWindow(interp, arg, clientData); if (tkwin == NULL) { return TCL_ERROR; } return Tk_Grab(interp, tkwin, 0); } else if (arg[0] == '-' && len > 1) { if (Tcl_GetIndexFromObj(interp, objv[1], flagStrings, "option", 0, &index) != TCL_OK) { return TCL_ERROR; } /* [grab -global window] */ if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "?-global? window"); return TCL_ERROR; } tkwin = Tk_NameToWindow(interp, Tcl_GetString(objv[2]), clientData); if (tkwin == NULL) { return TCL_ERROR; } return Tk_Grab(interp, tkwin, 1); } /* * First argument is not a window name and not "-global", find out which * option it is. */ if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0, &index) != TCL_OK) { return TCL_ERROR; } switch ((enum options) index) { case GRABCMD_CURRENT: /* [grab current ?window?] */ if (objc > 3) { Tcl_WrongNumArgs(interp, 1, objv, "current ?window?"); return TCL_ERROR; } if (objc == 3) { tkwin = Tk_NameToWindow(interp, Tcl_GetString(objv[2]), clientData); if (tkwin == NULL) { return TCL_ERROR; } dispPtr = ((TkWindow *) tkwin)->dispPtr; if (dispPtr->eventualGrabWinPtr != NULL) { Tcl_SetResult(interp, dispPtr->eventualGrabWinPtr->pathName, TCL_STATIC); } } else { for (dispPtr = TkGetDisplayList(); dispPtr != NULL; dispPtr = dispPtr->nextPtr) { if (dispPtr->eventualGrabWinPtr != NULL) { Tcl_AppendElement(interp, dispPtr->eventualGrabWinPtr->pathName); } } } return TCL_OK; case GRABCMD_RELEASE: /* [grab release window] */ if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "release window"); return TCL_ERROR; } tkwin = Tk_NameToWindow(interp, Tcl_GetString(objv[2]), clientData); if (tkwin == NULL) { Tcl_ResetResult(interp); } else { Tk_Ungrab(tkwin); } break; case GRABCMD_SET: /* [grab set ?-global? window] */ if ((objc != 3) && (objc != 4)) { Tcl_WrongNumArgs(interp, 1, objv, "set ?-global? window"); return TCL_ERROR; } if (objc == 3) { globalGrab = 0; tkwin = Tk_NameToWindow(interp, Tcl_GetString(objv[2]), clientData); } else { globalGrab = 1; /* * We could just test the argument by hand instead of using * Tcl_GetIndexFromObj; the benefit of using the function is that * it sets up the error message for us, so we are certain to be * consistant with the rest of Tcl. */ if (Tcl_GetIndexFromObj(interp, objv[2], flagStrings, "option", 0, &index) != TCL_OK) { return TCL_ERROR; } tkwin = Tk_NameToWindow(interp, Tcl_GetString(objv[3]), clientData); } if (tkwin == NULL) { return TCL_ERROR; } return Tk_Grab(interp, tkwin, globalGrab); case GRABCMD_STATUS: { /* [grab status window] */ TkWindow *winPtr; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "status window"); return TCL_ERROR; } winPtr = (TkWindow *) Tk_NameToWindow(interp, Tcl_GetString(objv[2]), clientData); if (winPtr == NULL) { return TCL_ERROR; } dispPtr = winPtr->dispPtr; if (dispPtr->eventualGrabWinPtr != winPtr) { Tcl_SetResult(interp, "none", TCL_STATIC); } else if (dispPtr->grabFlags & GRAB_GLOBAL) { Tcl_SetResult(interp, "global", TCL_STATIC); } else { Tcl_SetResult(interp, "local", TCL_STATIC); } break; } } return TCL_OK; }