/* 

 * tclCmdAH.c --

 *

 *	This file contains the top-level command routines for most of

 *	the Tcl built-in commands whose names begin with the letters

 *	A to H.

 *

 * Copyright (c) 1987-1993 The Regents of the University of California.

 * Copyright (c) 1994-1997 Sun Microsystems, Inc.

 * Portions Copyright (c) 2007 Nokia Corporation and/or its subsidiaries. All rights reserved.   

 *

 * See the file "license.terms" for information on usage and redistribution

 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.

 *

 * RCS: @(#) $Id: tclCmdAH.c,v 1.27.2.16 2006/11/28 22:20:00 andreas_kupries Exp $

 */

#include "tclInt.h"

#include "tclPort.h"

#include <locale.h>

#if defined(__SYMBIAN32__) 

#include "tclSymbianGlobals.h"

#endif 

/*

 * Prototypes for local procedures defined in this file:

 */

static int		CheckAccess _ANSI_ARGS_((Tcl_Interp *interp,

			    Tcl_Obj *objPtr, int mode));

static int		GetStatBuf _ANSI_ARGS_((Tcl_Interp *interp,

			    Tcl_Obj *objPtr, Tcl_FSStatProc *statProc,

			    Tcl_StatBuf *statPtr));

static char *		GetTypeFromMode _ANSI_ARGS_((int mode));

static int		StoreStatData _ANSI_ARGS_((Tcl_Interp *interp,

			    char *varName, Tcl_StatBuf *statPtr));

/*

 *----------------------------------------------------------------------

 *

 * Tcl_BreakObjCmd --

 *

 *	This procedure is invoked to process the "break" Tcl command.

 *	See the user documentation for details on what it does.

 *

 *	With the bytecode compiler, this procedure is only called when

 *	a command name is computed at runtime, and is "break" or the name

 *	to which "break" was renamed: e.g., "set z break; $z"

 *

 * Results:

 *	A standard Tcl result.

 *

 * Side effects:

 *	See the user documentation.

 *

 *----------------------------------------------------------------------

 */

	/* ARGSUSED */

int

Tcl_BreakObjCmd(dummy, interp, objc, objv)

    ClientData dummy;			/* Not used. */

    Tcl_Interp *interp;			/* Current interpreter. */

    int objc;				/* Number of arguments. */

    Tcl_Obj *CONST objv[];		/* Argument objects. */

{

    if (objc != 1) {

	Tcl_WrongNumArgs(interp, 1, objv, NULL);

	return TCL_ERROR;

    }

    return TCL_BREAK;

}

/*

 *----------------------------------------------------------------------

 *

 * Tcl_CaseObjCmd --

 *

 *	This procedure is invoked to process the "case" 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_CaseObjCmd(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 int i;

    int body, result, caseObjc;

    char *string, *arg;

    Tcl_Obj *CONST *caseObjv;

    Tcl_Obj *armPtr;

    if (objc < 3) {

	Tcl_WrongNumArgs(interp, 1, objv,

		"string ?in? patList body ... ?default body?");

	return TCL_ERROR;

    }

    string = Tcl_GetString(objv[1]);

    body = -1;

    arg = Tcl_GetString(objv[2]);

    if (strcmp(arg, "in") == 0) {

	i = 3;

    } else {

	i = 2;

    }

    caseObjc = objc - i;

    caseObjv = objv + i;

    /*

     * If all of the pattern/command pairs are lumped into a single

     * argument, split them out again.

     */

    if (caseObjc == 1) {

	Tcl_Obj **newObjv;

	Tcl_ListObjGetElements(interp, caseObjv[0], &caseObjc, &newObjv);

	caseObjv = newObjv;

    }

    for (i = 0;  i < caseObjc;  i += 2) {

	int patObjc, j;

	CONST char **patObjv;

	char *pat;

	unsigned char *p;

	if (i == (caseObjc - 1)) {

	    Tcl_ResetResult(interp);

	    Tcl_AppendToObj(Tcl_GetObjResult(interp),

	            "extra case pattern with no body", -1);

	    return TCL_ERROR;

	}

	/*

	 * Check for special case of single pattern (no list) with

	 * no backslash sequences.

	 */

	pat = Tcl_GetString(caseObjv[i]);

	for (p = (unsigned char *) pat; *p != '\0'; p++) {

	    if (isspace(*p) || (*p == '\\')) {	/* INTL: ISO space, UCHAR */

		break;

	    }

	}

	if (*p == '\0') {

	    if ((*pat == 'd') && (strcmp(pat, "default") == 0)) {

		body = i + 1;

	    }

	    if (Tcl_StringMatch(string, pat)) {

		body = i + 1;

		goto match;

	    }

	    continue;

	}

	/*

	 * Break up pattern lists, then check each of the patterns

	 * in the list.

	 */

	result = Tcl_SplitList(interp, pat, &patObjc, &patObjv);

	if (result != TCL_OK) {

	    return result;

	}

	for (j = 0; j < patObjc; j++) {

	    if (Tcl_StringMatch(string, patObjv[j])) {

		body = i + 1;

		break;

	    }

	}

	ckfree((char *) patObjv);

	if (j < patObjc) {

	    break;

	}

    }

    match:

    if (body != -1) {

	armPtr = caseObjv[body - 1];

	result = Tcl_EvalObjEx(interp, caseObjv[body], 0);

	if (result == TCL_ERROR) {

	    char msg[100 + TCL_INTEGER_SPACE];

	    arg = Tcl_GetString(armPtr);

	    sprintf(msg,

		    "\n    (\"%.50s\" arm line %d)", arg,

	            interp->errorLine);

	    Tcl_AddObjErrorInfo(interp, msg, -1);

	}

	return result;

    }

    /*

     * Nothing matched: return nothing.

     */

    return TCL_OK;

}

/*

 *----------------------------------------------------------------------

 *

 * Tcl_CatchObjCmd --

 *

 *	This object-based procedure is invoked to process the "catch" 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_CatchObjCmd(dummy, interp, objc, objv)

    ClientData dummy;		/* Not used. */

    Tcl_Interp *interp;		/* Current interpreter. */

    int objc;			/* Number of arguments. */

    Tcl_Obj *CONST objv[];	/* Argument objects. */

{

    Tcl_Obj *varNamePtr = NULL;

    int result;

#ifdef TCL_TIP280

    Interp* iPtr = (Interp*) interp;

#endif

    if ((objc != 2) && (objc != 3)) {

	Tcl_WrongNumArgs(interp, 1, objv, "command ?varName?");

	return TCL_ERROR;

    }

    if (objc == 3) {

	varNamePtr = objv[2];

    }

#ifndef TCL_TIP280

    result = Tcl_EvalObjEx(interp, objv[1], 0);

#else

    /* TIP #280. Make invoking context available to caught script */

    result = TclEvalObjEx(interp, objv[1], 0, iPtr->cmdFramePtr,1);

#endif

    if (objc == 3) {

	if (Tcl_ObjSetVar2(interp, varNamePtr, NULL,

		Tcl_GetObjResult(interp), 0) == NULL) {

	    Tcl_ResetResult(interp);

	    Tcl_AppendToObj(Tcl_GetObjResult(interp),  

	            "couldn't save command result in variable", -1);

	    return TCL_ERROR;

	}

    }

    /*

     * Set the interpreter's object result to an integer object holding the

     * integer Tcl_EvalObj result. Note that we don't bother generating a

     * string representation. We reset the interpreter's object result

     * to an unshared empty object and then set it to be an integer object.

     */

    Tcl_ResetResult(interp);

    Tcl_SetIntObj(Tcl_GetObjResult(interp), result);

    return TCL_OK;

}

/*

 *----------------------------------------------------------------------

 *

 * Tcl_CdObjCmd --

 *

 *	This procedure is invoked to process the "cd" Tcl command.

 *	See the user documentation for details on what it does.

 *

 * Results:

 *	A standard Tcl result.

 *

 * Side effects:

 *	See the user documentation.

 *

 *----------------------------------------------------------------------

 */

	/* ARGSUSED */

int

Tcl_CdObjCmd(dummy, interp, objc, objv)

    ClientData dummy;		/* Not used. */

    Tcl_Interp *interp;		/* Current interpreter. */

    int objc;			/* Number of arguments. */

    Tcl_Obj *CONST objv[];	/* Argument objects. */

{

    Tcl_Obj *dir;

    int result;

    if (objc > 2) {

	Tcl_WrongNumArgs(interp, 1, objv, "?dirName?");

	return TCL_ERROR;

    }

    if (objc == 2) {

	dir = objv[1];

    } else {

	dir = Tcl_NewStringObj("~",1);

	Tcl_IncrRefCount(dir);

    }

    if (Tcl_FSConvertToPathType(interp, dir) != TCL_OK) {

	result = TCL_ERROR;

    } else {

	result = Tcl_FSChdir(dir);

	if (result != TCL_OK) {

	    Tcl_AppendResult(interp, "couldn't change working directory to \"",

		    Tcl_GetString(dir), "\": ", Tcl_PosixError(interp), (char *) NULL);

	    result = TCL_ERROR;

	}

    }

    if (objc != 2) {

	Tcl_DecrRefCount(dir);

    }

    return result;

}

/*

 *----------------------------------------------------------------------

 *

 * Tcl_ConcatObjCmd --

 *

 *	This object-based procedure is invoked to process the "concat" 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_ConcatObjCmd(dummy, interp, objc, objv)

    ClientData dummy;		/* Not used. */

    Tcl_Interp *interp;		/* Current interpreter. */

    int objc;			/* Number of arguments. */

    Tcl_Obj *CONST objv[];	/* Argument objects. */

{

    if (objc >= 2) {

	Tcl_SetObjResult(interp, Tcl_ConcatObj(objc-1, objv+1));

    }

    return TCL_OK;

}

/*

 *----------------------------------------------------------------------

 *

 * Tcl_ContinueObjCmd -

 *

 *	This procedure is invoked to process the "continue" Tcl command.

 *	See the user documentation for details on what it does.

 *

 *	With the bytecode compiler, this procedure is only called when

 *	a command name is computed at runtime, and is "continue" or the name

 *	to which "continue" was renamed: e.g., "set z continue; $z"

 *

 * Results:

 *	A standard Tcl result.

 *

 * Side effects:

 *	See the user documentation.

 *

 *----------------------------------------------------------------------

 */

	/* ARGSUSED */

int

Tcl_ContinueObjCmd(dummy, interp, objc, objv)

    ClientData dummy;			/* Not used. */

    Tcl_Interp *interp;			/* Current interpreter. */

    int objc;				/* Number of arguments. */

    Tcl_Obj *CONST objv[];		/* Argument objects. */

{

    if (objc != 1) {

	Tcl_WrongNumArgs(interp, 1, objv, NULL);

	return TCL_ERROR;

    }

    return TCL_CONTINUE;

}

/*

 *----------------------------------------------------------------------

 *

 * Tcl_EncodingObjCmd --

 *

 *	This command manipulates encodings.

 *

 * Results:

 *	A standard Tcl result.

 *

 * Side effects:

 *	See the user documentation.

 *

 *----------------------------------------------------------------------

 */

int

Tcl_EncodingObjCmd(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 index, length;

    Tcl_Encoding encoding;

    char *string;

    Tcl_DString ds;

    Tcl_Obj *resultPtr;

    static CONST char *optionStrings[] = {

	"convertfrom", "convertto", "names", "system",

	NULL

    };

    enum options {

	ENC_CONVERTFROM, ENC_CONVERTTO, ENC_NAMES, ENC_SYSTEM

    };

    if (objc < 2) {

    	Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");

        return TCL_ERROR;

    }

    if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0,

	    &index) != TCL_OK) {

	return TCL_ERROR;

    }

    switch ((enum options) index) {

	case ENC_CONVERTTO:

	case ENC_CONVERTFROM: {

	    Tcl_Obj *data;

	    if (objc == 3) {

		encoding = Tcl_GetEncoding(interp, NULL);

		data = objv[2];

	    } else if (objc == 4) {

		if (TclGetEncodingFromObj(interp, objv[2], &encoding)

			!= TCL_OK) {

		    return TCL_ERROR;

		}

		data = objv[3];

	    } else {

		Tcl_WrongNumArgs(interp, 2, objv, "?encoding? data");

		return TCL_ERROR;

	    }

	    if ((enum options) index == ENC_CONVERTFROM) {

		/*

		 * Treat the string as binary data.

		 */

		string = (char *) Tcl_GetByteArrayFromObj(data, &length);

		Tcl_ExternalToUtfDString(encoding, string, length, &ds);

		/*

		 * Note that we cannot use Tcl_DStringResult here because

		 * it will truncate the string at the first null byte.

		 */

		Tcl_SetStringObj(Tcl_GetObjResult(interp),

			Tcl_DStringValue(&ds), Tcl_DStringLength(&ds));

		Tcl_DStringFree(&ds);

	    } else {

		/*

		 * Store the result as binary data.

		 */

		string = Tcl_GetStringFromObj(data, &length);

		Tcl_UtfToExternalDString(encoding, string, length, &ds);

		resultPtr = Tcl_GetObjResult(interp);

		Tcl_SetByteArrayObj(resultPtr, 

			(unsigned char *) Tcl_DStringValue(&ds),

			Tcl_DStringLength(&ds));

		Tcl_DStringFree(&ds);

	    }

	    Tcl_FreeEncoding(encoding);

	    break;

	}

	case ENC_NAMES: {

	    if (objc > 2) {

		Tcl_WrongNumArgs(interp, 2, objv, NULL);

		return TCL_ERROR;

	    }

	    Tcl_GetEncodingNames(interp);

	    break;

	}

	case ENC_SYSTEM: {

	    if (objc > 3) {

		Tcl_WrongNumArgs(interp, 2, objv, "?encoding?");

		return TCL_ERROR;

	    }

	    if (objc == 2) {

		Tcl_SetStringObj(Tcl_GetObjResult(interp),

			Tcl_GetEncodingName(NULL), -1);

	    } else {

	        return Tcl_SetSystemEncoding(interp,

			Tcl_GetStringFromObj(objv[2], NULL));

	    }

	    break;

	}

    }

    return TCL_OK;

}