/*
 * neoXcomma.c --
 *
 * Tcl commands to parse comma-separated ascii exchange formats.
 *---------------------------------------------------------------------------
 * Copyright 1994-1997 Karl Lehenbauer.  All Rights Reserved.
 * Copyright 1998 NeoSoft, Inc.  All Rights Reserved.
 *
 * Permission to use, copy, modify, and distribute this software and its
 * documentation for any purpose and without fee is hereby granted, provided
 * that the above copyright notice appear in all copies.  Karl Lehenbauer and
 * NeoSoft, Inc. make no representations about the suitability of this
 * software for any purpose.  It is provided "as is" without express or
 * implied warranty.
 *-----------------------------------------------------------------------------
 * $Id: neoXcomma.c,v 1.1.1.1 1999/03/31 20:34:37 damon Exp $
 *-----------------------------------------------------------------------------
 */

#include "neo.h"


void
Neo_ListObjAppendString (interp, targetList, string, length)
    Tcl_Interp *interp;
    Tcl_Obj    *targetList;
    char       *string;
    int         length;
{
    Tcl_Obj    *elementObj;

    elementObj = Tcl_NewStringObj (string, length);
    Tcl_ListObjAppendElement (interp, targetList, elementObj);
    /* Tcl_DecrRefCount (elementObj); */
}


/*
 *-----------------------------------------------------------------------------
 *
 * NeoX_CommaObjSplitCmd --
 *
 * Implements the `comma_split' Tcl command:
 *    comma_split $line
 *
 * Results:
 *      A standard Tcl result.
 *
 * Side effects:
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */
int
NeoX_CommaSplitObjCmd (notUsed, interp, objc, objv)
    ClientData   notUsed;
    Tcl_Interp  *interp;
    int          objc;
    Tcl_Obj   *CONST objv[];
{
    char        *first, *next;
    char         c;
    int          stringLength;
    Tcl_Obj     *resultList;

    /* ??? need a way to set this */
    /* true if two quotes ("") in the body of a field maps to one (") */
    int          Neo_quotequoteQuotesQuote = 1;

    /* true if quotes within strings not followed by a comma are allowed */
    int          Neo_quotePairsWithinStrings = 1;

    if (objc != 2)
        return TclX_WrongArgs (interp, objv[0], "string");

    /* get access to a textual representation of the object */
    first = Tcl_GetStringFromObj (objv [1], &stringLength);

    /* handle the trivial case... if the string is empty, so is the result */
    if (stringLength == 0) return TCL_OK;

    next = first;
    resultList = Tcl_GetObjResult (interp);

    /* this loop walks through the comma-separated string we've been passed */
    while (1) {

	/* grab the next character in the buffer */
        c = *next;

	/* if we've got a quote at this point, it is at the start
	 * of a field, scan to the closing quote, make that a field, 
	 * and update */

	if (c == '"') {
	    next = ++first;
	    while (1) {
	        c = *next;
		/*
		 * if we're at the end, we've got an unterminated quoted string
		 */
	        if (c == '\0') goto format_error;

                /*
		 * If we get a double quote, first see if it's a pair of double 
		 * quotes, i.e. a quoted quote, and handle that.
		 */
	        if (c == '"') {
		    /* if consecutive pairs of quotes as quotes of quotes
		     * is enabled and the following char is a double quote,
		     * turn the pair into a single by zooming on down */
		    if (Neo_quotequoteQuotesQuote && (*(next + 1) == '"')) {
			next += 2;
			continue;
		    }

		    /* If double quotes within strings is enabled and the
		     * char following this quote is not a comma, scan forward
		     * for a quote */
		    if (Neo_quotePairsWithinStrings && (*(next + 1) != ',')) {
			next++;
			continue;
		    }
		    /* It's a solo double-quote, not a pair of double-quotes, 
		     * so terminate the element
		     * at the current quote (the closing quote).
		     */
		    Neo_ListObjAppendString (interp,
			      resultList, first, next - first);

		    /* skip the closing quote that we overwrote, and the
		     * following comma if there is one.
		     */

		    ++next;
		    c = *next;

		    /* 
		     *if we get end-of-line here, it's fine... and we're done
		     */

		    if (c == '\0')
			return TCL_OK;

                    /*
		     * It's not end-of-line.  If the next character is
		     * not a comma, it's an error.
		     */
		    if (c != ',') {
		      format_error:
			Tcl_ResetResult (interp);
			Tcl_AppendResult (interp,
					  "format error in string: \"", 
					   first, "\"", (char *) NULL);
			return TCL_ERROR;
		    }

		    /* We're done with that field.  The next one starts one
		     * character past the current one, which is (was) a
		     * comma */
		    first = ++next;
		    break;
		}
		/* It wasn't a quote, look at the next character. */
		next++;
	    }
	    continue;
	}

	/* If we get here, we're at the start of a field that didn't
	 * start with a quote */
	next = first;
	while (1) {
	    c = *next;

            /* If we reach end of the string, append the last element
	     * and return to our caller. */
	    if (c == '\0') {
		Neo_ListObjAppendString (interp, resultList, first, -1);
		return TCL_OK;
	    }

            /* If we get a comma, that's the end of this piece,
	     * stick it into the list.
	     */
	    if (c == ',') {
		Neo_ListObjAppendString (interp,
			  resultList,
			  first, next - first);
		first = ++next;
		break;
	    }
	    next++;
	}
    }
    Neo_ListObjAppendString (interp, resultList, first, -1);
    return TCL_OK;
}


/*
 *-----------------------------------------------------------------------------
 *
 * NeoX_CommaJoinCmd --
 *
 * Implements the `comma_join' Tcl command:
 *    comma_join $list
 *
 * Results:
 *      A standard Tcl result.
 *
 * Side effects:
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */
int
NeoX_CommaJoinObjCmd (notUsed, interp, objc, objv)
    ClientData   notUsed;
    Tcl_Interp  *interp;
    int          objc;
    Tcl_Obj   *CONST objv[];
{
    int         listObjc;
    Tcl_Obj   **listObjv;
    int         listIdx, didField;
    Tcl_Obj    *resultPtr;
    char       *walkPtr;
    char       *strPtr;
    int         stringLength;

    if (objc != 2)
        return TclX_WrongArgs (interp, objv[0], "list");

    resultPtr = Tcl_GetObjResult (interp);

    if (Tcl_ListObjGetElements  (interp, 
				 objv[1], 
				 &listObjc, 
				 &listObjv) != TCL_OK) {
	return TCL_ERROR;
    }

    didField = 0;
    for (listIdx = 0; listIdx < listObjc; listIdx++) {
	/* If it's the first thing we've output, start it out
	 * with a double quote.  If not, terminate the last
	 * element with a double quote, then put out a comma,
	 * then open the next element with a double quote
	 */
	if (didField) {
	    Tcl_AppendToObj (resultPtr, "\",\"", 3);
	} else {
	    Tcl_AppendToObj (resultPtr, "\"", 1);
	    didField = 1;
	}
	walkPtr = strPtr  = Tcl_GetStringFromObj (listObjv[listIdx], &stringLength);
	/* Walk the string of the list element that we're about to
	 * append to the result object.
	 *
	 * For each character, if it isn't a double quote, move on to
	 * the next character until the string is exhausted.
	 */
	for (;stringLength; stringLength--) {
	    if (*walkPtr++ != '"') continue;

	    /* OK, we saw a double quote.  Emit everything up to and
	     * including the double quote, then reset the string to
	     * start at the same double quote (to issue it twice and
	     * pick up where we left off.  Be sure to get the length
	     * calculations right!
	     */

	     Tcl_AppendToObj (resultPtr, strPtr, walkPtr - strPtr);
	     strPtr = walkPtr - 1;
	}
	Tcl_AppendToObj (resultPtr, strPtr, walkPtr - strPtr);
    }
    Tcl_AppendToObj (resultPtr, "\"", 1);
    return TCL_OK;
}


/*
 *-----------------------------------------------------------------------------
 *
 * Tcl_LassignArrayCmd --
 *     Implements the TCL lassign_array command:
 *         lassign_array list arrayname elementname ?elementname...?
 *
 * Results:
 *      Standard TCL results.
 *
 *-----------------------------------------------------------------------------
 */
int
Tcl_LassignArrayCmd (clientData, interp, argc, argv)
    ClientData  clientData;
    Tcl_Interp *interp;
    int         argc;
    char      **argv;
{
    int        listArgc, listIdx, idx, remaining;
    char     **listArgv;
    char      *varValue;

    if (argc < 4) {
        Tcl_AppendResult (interp, tclXWrongArgs, argv [0], 
                          " list arrayname elementname ?elementname..?", (char *) NULL);
        return TCL_ERROR;
    }

    if (Tcl_SplitList (interp, argv[1], &listArgc, &listArgv) == TCL_ERROR)
        return TCL_ERROR;

    for (idx = 3, listIdx = 0; idx < argc; idx++, listIdx++) {
        varValue = (listIdx < listArgc) ? listArgv[listIdx] : "" ;
        if (Tcl_SetVar2 (interp, argv[2], argv[idx], varValue,
	    TCL_LEAVE_ERR_MSG) == NULL) {
            goto error_exit;
        }
    }
    remaining = listArgc - argc + 3;
    if (remaining > 0) {
        Tcl_SetResult (interp,
                       Tcl_Merge (remaining, listArgv + argc - 3),
                       TCL_DYNAMIC);
    }
    ckfree((char *) listArgv);
    return TCL_OK;

  error_exit:
    ckfree((char *) listArgv);
    return TCL_ERROR;
}


/*
 *-----------------------------------------------------------------------------
 *
 * Tcl_LassignFieldsCmd --
 *     Implements the TCL lassign_fields command:
 *         lassign_fields list fieldpositionarray arrayname fieldname ?fieldname...?
 *
 * Results:
 *      Standard TCL results.
 *
 *-----------------------------------------------------------------------------
 */
int
Tcl_LassignFieldsCmd (clientData, interp, argc, argv)
    ClientData  clientData;
    Tcl_Interp *interp;
    int         argc;
    char      **argv;
{
    int        listArgc, listIdx, idx;
    char     **listArgv;
    char      *varValue;
    char      *fieldPositionText;

    if (argc < 5) {
        Tcl_AppendResult (interp, tclXWrongArgs, argv [0], 
                          " list fieldpositionarray arrayname fieldname ?fieldname..?", (char *) NULL);
        return TCL_ERROR;
    }

    if (Tcl_SplitList (interp, argv[1], &listArgc, &listArgv) == TCL_ERROR)
        return TCL_ERROR;

    for (idx = 4; idx < argc; idx++, listIdx++) {
	if ((fieldPositionText = Tcl_GetVar2 (interp, argv[2], argv[idx], 
	        TCL_LEAVE_ERR_MSG)) == NULL)
	    goto error_exit;

        if (Tcl_GetInt (interp, fieldPositionText, &listIdx) != TCL_OK) goto error_exit;

        varValue = (listIdx < listArgc) ? listArgv[listIdx] : "" ;

	/* if the array name field is empty, assign fields to
	 * variables, else assign fields to elements of the named
	 * array. */
	if (*argv[3] == '\0') {
	    if (Tcl_SetVar (interp, argv[idx], varValue,
		    TCL_LEAVE_ERR_MSG) == NULL)
		goto error_exit;
	} else {
	    if (Tcl_SetVar2 (interp, argv[3], argv[idx], varValue,
		    TCL_LEAVE_ERR_MSG) == NULL)
		goto error_exit;
	}
    }
    ckfree((char *) listArgv);
    return TCL_OK;

  error_exit:
    ckfree((char *) listArgv);
    return TCL_ERROR;
}


/*
In the Tcl 8 world, I more want

    lassign_list $list $varNameList

    ...which will assign successive fields of list stored into variables 
    named one-to-one from successive elements of varNameList
    from varNameList

    lassign_list $list arrayName $elementNameList

    ...same as above, except the varNameList becomes element names
    under which the data is stored in arrayName.

The reason for the change is that lists are really fast in Tcl 8.
They used to be slow, so we tended towards using arrays to get
higher performance.

Oh yah, one more...

If the var or element name is a list of two elements, rather than a
single item, the first is the variable name and the second is the
list element number that corresponds to it.
*/
