Пример #1
0
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;
}
Пример #2
0
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;
    }
}
Пример #3
0
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;
}
Пример #5
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;
}
Пример #6
0
/*++

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;
}
Пример #7
0
/*
 * 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;
}
Пример #8
0
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(); */
}
Пример #9
0
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);
}
Пример #10
0
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;
}
Пример #11
0
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);
}
Пример #12
0
/// 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!)");
}
Пример #13
0
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;
}
Пример #14
0
/*-----------------------------------------------------------------------------
 * 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;
}
Пример #15
0
/*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;
}
Пример #16
0
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");
}
Пример #17
0
/** #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;
}
Пример #18
0
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);
}
Пример #19
0
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);
    }
}
Пример #20
0
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");
}
Пример #21
0
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;
}
Пример #22
0
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;
}
Пример #23
0
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;
}
Пример #24
0
/* 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;
}
Пример #25
0
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;
}
Пример #26
0
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;
  }
Пример #27
0
/* 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");
  }
}
Пример #28
0
/*
 * 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;
}
Пример #29
0
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;
}
Пример #30
0
	/* 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;
}