tclcmdah.c

linux系统下的音频通信

	char msg[60];
	sprintf(msg, "\n    (\"eval\" body line %d)", interp->errorLine);
	Tcl_AddObjErrorInfo(interp, msg, -1);
    }
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ExitObjCmd --
 *
 *	This procedure is invoked to process the "exit" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl object result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_ExitObjCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    int value;

    if ((objc != 1) && (objc != 2)) {
	Tcl_WrongNumArgs(interp, 1, objv, "?returnCode?");
	return TCL_ERROR;
    }
    
    if (objc == 1) {
	value = 0;
    } else if (Tcl_GetIntFromObj(interp, objv[1], &value) != TCL_OK) {
	return TCL_ERROR;
    }
    Tcl_Exit(value);
    /*NOTREACHED*/
    return TCL_OK;			/* Better not ever reach this! */
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ExprObjCmd --
 *
 *	This object-based procedure is invoked to process the "expr" Tcl
 *	command. See the user documentation for details on what it does.
 *
 *	With the bytecode compiler, this procedure is called in two
 *	circumstances: 1) to execute expr commands that are too complicated
 *	or too unsafe to try compiling directly into an inline sequence of
 *	instructions, and 2) to execute commands where the command name is
 *	computed at runtime and is "expr" or the name to which "expr" was
 *	renamed (e.g., "set z expr; $z 2+3")
 *
 * Results:
 *	A standard Tcl object result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_ExprObjCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    register Tcl_Obj *objPtr;
    Tcl_Obj *resultPtr;
    register char *bytes;
    int length, i, result;

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "arg ?arg ...?");
	return TCL_ERROR;
    }

    if (objc == 2) {
	result = Tcl_ExprObj(interp, objv[1], &resultPtr);
	if (result == TCL_OK) {
	    Tcl_SetObjResult(interp, resultPtr);
	    Tcl_DecrRefCount(resultPtr);  /* done with the result object */
	}
	return result;
    }

    /*
     * Create a new object holding the concatenated argument strings.
     * THIS FAILS IF AN OBJECT'S STRING REP HAS A NULL BYTE.
     */

    bytes = Tcl_GetStringFromObj(objv[1], &length);
    objPtr = Tcl_NewStringObj(bytes, length);
    Tcl_IncrRefCount(objPtr);
    for (i = 2;  i < objc;  i++) {
	Tcl_AppendToObj(objPtr, " ", 1);
	bytes = Tcl_GetStringFromObj(objv[i], &length);
	Tcl_AppendToObj(objPtr, bytes, length);
    }

    /*
     * Evaluate the concatenated string object.
     */

    result = Tcl_ExprObj(interp, objPtr, &resultPtr);
    if (result == TCL_OK) {
	Tcl_SetObjResult(interp, resultPtr);
	Tcl_DecrRefCount(resultPtr);  /* done with the result object */
    }

    /*
     * Free allocated resources.
     */
    
    Tcl_DecrRefCount(objPtr);
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FileObjCmd --
 *
 *	This procedure is invoked to process the "file" Tcl command.
 *	See the user documentation for details on what it does.
 *	PLEASE NOTE THAT THIS FAILS WITH FILENAMES AND PATHS WITH
 *	EMBEDDED NULLS, WHICH COULD THEORETICALLY HAPPEN ON A MAC.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_FileObjCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    char *fileName, *extension, *errorString;
    int statOp = 0;		/* Init. to avoid compiler warning. */
    int length;
    int mode = 0;			/* Initialized only to prevent
					 * compiler warning message. */
    struct stat statBuf;
    Tcl_DString buffer;
    Tcl_Obj *resultPtr;
    int index, result;

/*
 * This list of constants should match the fileOption string array below.
 */

enum {FILE_ATIME, FILE_ATTRIBUTES, FILE_COPY, FILE_DELETE, FILE_DIRNAME,
	FILE_EXECUTABLE, FILE_EXISTS, FILE_EXTENSION, FILE_ISDIRECTORY,
	FILE_ISFILE, FILE_JOIN, FILE_LSTAT, FILE_MTIME, FILE_MKDIR,
	FILE_NATIVENAME, FILE_OWNED, FILE_PATHTYPE, FILE_READABLE,
	FILE_READLINK, FILE_RENAME, FILE_ROOTNAME, FILE_SIZE, FILE_SPLIT,
	FILE_STAT, FILE_TAIL, FILE_TYPE, FILE_VOLUMES, FILE_WRITABLE};


    static char *fileOptions[] = {"atime", "attributes", "copy", "delete", 
    	    "dirname", "executable", "exists", "extension", "isdirectory", 
    	    "isfile", "join", "lstat", "mtime", "mkdir", "nativename", 
    	    "owned", "pathtype", "readable", "readlink", "rename",
    	    "rootname", "size", "split", "stat", "tail", "type", "volumes", 
    	    "writable", (char *) NULL};

    if (objc < 2) {
    	Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
        return TCL_ERROR;
    }

    if (Tcl_GetIndexFromObj(interp, objv[1], fileOptions, "option", 0, &index)
	    != TCL_OK) {
    	return TCL_ERROR;
    }
    
    result = TCL_OK;
    /* 
     * First, do the volumes command, since it is the only one that
     * has objc == 2.
     */
	
    if ( index == FILE_VOLUMES) {
        if ( objc != 2 ) {
	    Tcl_WrongNumArgs(interp, 1, objv, "volumes");
	    return TCL_ERROR;
	}
	result = TclpListVolumes(interp);
	return result;
    }
    
    if (objc < 3) {
	Tcl_WrongNumArgs(interp, 2, objv, "name ?arg ...?");
	return TCL_ERROR;
    }

    Tcl_DStringInit(&buffer);
    resultPtr = Tcl_GetObjResult(interp);
    

    /*
     * Handle operations on the file name.
     */
    
    switch (index) {
        case FILE_ATTRIBUTES:
            result = TclFileAttrsCmd(interp, objc - 2, objv + 2);
    	    goto done;
    	case FILE_DIRNAME:	{
    	    int pargc;
	    char **pargv;

	    if (objc != 3) {
	    	errorString = "dirname name";
	    	goto not3Args;
	    }

	    fileName = Tcl_GetStringFromObj(objv[2], &length);

	    /*
	     * If there is only one element, and it starts with a tilde,
	     * perform tilde substitution and resplit the path.
	     */

	    Tcl_SplitPath(fileName, &pargc, &pargv);
	    if ((pargc == 1) && (*fileName == '~')) {
	        ckfree((char*) pargv);
	        fileName = Tcl_TranslateFileName(interp, fileName, &buffer);
	        if (fileName == NULL) {
		    result = TCL_ERROR;
		    goto done;
	        }
	        Tcl_SplitPath(fileName, &pargc, &pargv);
	        Tcl_DStringSetLength(&buffer, 0);
	    }

	    /*
	     * Return all but the last component.  If there is only one
	     * component, return it if the path was non-relative, otherwise
	     * return the current directory.
	     */

	    if (pargc > 1) {
	    	Tcl_JoinPath(pargc-1, pargv, &buffer);
	    	Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&buffer),
	    		buffer.length);
	    } else if ((pargc == 0)
		    || (Tcl_GetPathType(pargv[0]) == TCL_PATH_RELATIVE)) {
		Tcl_SetStringObj(resultPtr, (tclPlatform == TCL_PLATFORM_MAC)
			? ":" : ".", 1);
	    } else {
	    	Tcl_SetStringObj(resultPtr, pargv[0], -1);	    }
	    ckfree((char *)pargv);
	    goto done;
	}
    	case FILE_TAIL: {
	    int pargc;
	    char **pargv;

	    if (objc != 3) {
	    	errorString = "tail name";
	    	goto not3Args;
	    }
	    
	    fileName = Tcl_GetStringFromObj(objv[2], &length);

	    /*
	     * If there is only one element, and it starts with a tilde,
	     * perform tilde substitution and resplit the path.
	     */

	    Tcl_SplitPath(fileName, &pargc, &pargv);
	    if ((pargc == 1) && (*fileName == '~')) {
	    	ckfree((char*) pargv);
	    	fileName = Tcl_TranslateFileName(interp, fileName, &buffer);
	    	if (fileName == NULL) {
		    result = TCL_ERROR;
		    goto done;
	        }
	        Tcl_SplitPath(fileName, &pargc, &pargv);
	        Tcl_DStringSetLength(&buffer, 0);
	    }

	    /*
	     * Return the last component, unless it is the only component,
	     * and it is the root of an absolute path.
	     */

	    if (pargc > 0) {
	    	if ((pargc > 1)
		    	|| (Tcl_GetPathType(pargv[0]) == TCL_PATH_RELATIVE)) {
		    Tcl_SetStringObj(resultPtr, pargv[pargc - 1], -1);
	    	}
	    }
	    ckfree((char *)pargv);
	    goto done;
	}
	case FILE_ROOTNAME: {
	    char *fileName;
	    
	    if (objc != 3) {
	    	errorString = "rootname name";
	    	goto not3Args;
	    }
	    
	    fileName = Tcl_GetStringFromObj(objv[2], &length);
	    extension = TclGetExtension(fileName);
	    if (extension == NULL) {
	    	Tcl_SetObjResult(interp, objv[2]);
	    } else {
	        Tcl_SetStringObj(resultPtr, fileName,
			(int) (length - strlen(extension)));
	    }
	    goto done;
	}
	case FILE_EXTENSION:
	    if (objc != 3) {
	    	errorString = "extension name";
	    	goto not3Args;
	    }
	    extension = TclGetExtension(Tcl_GetStringFromObj(objv[2],&length));

	    if (extension != NULL) {
	    	Tcl_SetStringObj(resultPtr, extension, (int)strlen(extension));
	    }
	    goto done;
	case FILE_PATHTYPE:
	    if (objc != 3) {
	    	errorString = "pathtype name";
	    	goto not3Args;
	    }
	    switch (Tcl_GetPathType(Tcl_GetStringFromObj(objv[2], &length))) {
	    	case TCL_PATH_ABSOLUTE:
	    	    Tcl_SetStringObj(resultPtr, "absolute", -1);
		    break;
	    	case TCL_PATH_RELATIVE:
	    	    Tcl_SetStringObj(resultPtr, "relative", -1);
	    	    break;
	    	case TCL_PATH_VOLUME_RELATIVE:
		    Tcl_SetStringObj(resultPtr, "volumerelative", -1);
		    break;
	    }
	    goto done;
	case FILE_SPLIT: {
	    int pargc, i;
	    char **pargvList;
	    Tcl_Obj *listObjPtr;
		
	    if (objc != 3) {
    	    	errorString = "split name";
	    	goto not3Args;
	    }
		
	    Tcl_SplitPath(Tcl_GetStringFromObj(objv[2], &length), &pargc,
	    	    &pargvList);
	    listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
	    for (i = 0; i < pargc; i++) {
	    	Tcl_ListObjAppendElement(interp, listObjPtr,
			Tcl_NewStringObj(pargvList[i], -1));
	    }
	    ckfree((char *) pargvList);
	    Tcl_SetObjResult(interp, listObjPtr);
	    goto done;
	}
	case FILE_JOIN: {
	    char **pargv = (char **) ckalloc((objc - 2) * sizeof(char *));
	    int i;
	    
	    for (i = 2; i < objc; i++) {
	    	pargv[i - 2] = Tcl_GetStringFromObj(objv[i], &length);
	    }
	    Tcl_JoinPath(objc - 2, pargv, &buffer);
	    Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&buffer), 
                    buffer.length);
	    ckfree((char *) pargv);
	    Tcl_DStringFree(&buffer);
	    goto done;
	}
	case FILE_RENAME: {
	    char **pargv = (char **) ckalloc(objc * sizeof(char *));
	    int i;
	    
	    for (i = 0; i < objc; i++) {
	    	pargv[i] = Tcl_GetStringFromObj(objv[i], &length);
	    }
	    result = TclFileRenameCmd(interp, objc, pargv);
	    ckfree((char *) pargv);
	    goto done;
	}
	case FILE_MKDIR: {
	    char **pargv = (char **) ckalloc(objc * sizeof(char *));
	    int i;
	    
	    for (i = 0; i < objc; i++) {
	    	pargv[i] = Tcl_GetStringFromObj(objv[i], &length);
	    }
	    result = TclFileMakeDirsCmd(interp, objc, pargv);
	    ckfree((char *) pargv);
	    goto done;
	}
	case FILE_DELETE: {
	    char **pargv = (char **) ckalloc(objc * sizeof(char *));
	    int i;
	    
	    for (i = 0; i < objc; i++) {
	    	pargv[i] = Tcl_GetStringFromObj(objv[i], &length);
	    }
	    result = TclFileDeleteCmd(interp, objc, pargv);
	    ckfree((char *) pargv);
	    goto done;
	}
	case FILE_COPY: {
	    char **pargv = (char **) ckalloc(objc * sizeof(char *));
	    int i;
	    
	    for (i = 0; i < objc; i++) {
	    	pargv[i] = Tcl_GetStringFromObj(objv[i], &length);
	    }
	    result = TclFileCopyCmd(interp, objc, pargv);
	    ckfree((char *) pargv);
	    goto done;
	}
	case FILE_NATIVENAME:
	    fileName = Tcl_TranslateFileName(interp,
	    	    Tcl_GetStringFromObj(objv[2], &length), &buffer);
	    if (fileName == NULL) {
		result = TCL_ERROR ;
	    } else {
		Tcl_SetStringObj(resultPtr, fileName, -1);
	    }
	    goto done;
    }

    /*
     * Next, handle operations that can be satisfied with the "access"
     * kernel call.
     */

    fileName = Tcl_TranslateFileName(interp,
	    Tcl_GetStringFromObj(objv[2], &length), &buffer);
	
    switch (index) {
    	case FILE_READABLE:
    	    if (objc != 3) {
	    	errorString = "readable name";
	    	goto not3Args;
	    }
	    mode = R_OK;
checkAccess:
	    /*
	     * The result might have been set within Tcl_TranslateFileName
	     * (like no such user "blah" for file exists ~blah)
	     * but we don't want to flag an error in that case.
	     */
	    if (fileName == NULL) {
		Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0));
	    } else {
		Tcl_SetBooleanObj(resultPtr, (TclAccess(fileName, mode) != -1));
	    }
	    goto done;
	  case FILE_WRITABLE:
	    if (objc != 3) {
	    	errorString = "writable name";
	    	goto not3Args;
	    }
	    mode = W_OK;
	    goto checkAccess;
	  case FILE_EXECUTABLE:
	    if (objc != 3) {
	    	errorString = "executable name";
	    	goto not3Args;
	    }
	    mode = X_OK;