Tcl Source Code

2011-05-11  Reinhard Max  <[email protected]>

	* unix/tclUnixSock.c (TcpWatchProc): No need to check for server
	sockets here, as the generic server code already takes care of
	that.
	* tests/socket.test (accept): Add tests to make sure that this
	remains so.

2011-05-10  Don Porter  <[email protected]>

	* generic/tclInt.h:     New internal routines TclScanElement() and
	* generic/tclUtil.c:    TclConvertElement() are rewritten guts of
	machinery to produce string rep of lists.  The new routines avoid
	and correct [Bug 3173086].  See comments for much more detail.

# These functions are vfs aware, but are generally only useful internally.
declare 165 {
    void TclpSetInitialEncodings(void)
}

# New function due to TIP #33
#declare 166 {
#    int TclListObjSetElement(Tcl_Interp *interp, Tcl_Obj *listPtr,
#	    int index, Tcl_Obj *valuePtr)

#}

# VFS-aware versions of Tcl*StartupScriptFileName (158 and 159 above)
# REMOVED - use public Tcl_SetStartupScript()
#declare 167 {
#    void TclSetStartupScriptPath(Tcl_Obj *pathPtr)
#}
# REMOVED - use public Tcl_GetStartupScript()

				 * all.*/
    Tcl_Obj *elements;		/* First list element; the struct is grown to
				 * accomodate all elements. */
} List;

#define LIST_MAX \
	(1 + (int)(((size_t)UINT_MAX - sizeof(List))/sizeof(Tcl_Obj *)))
#define LIST_SIZE(numElems) \
	(unsigned)(sizeof(List) + (((numElems) - 1) * sizeof(Tcl_Obj *)))

/*
 * Macro used to get the elements of a list object.
 */

#define ListRepPtr(listPtr) \
    ((List *) (listPtr)->internalRep.twoPtrValue.ptr1)

				int flags);
/* 163 */
EXTERN const void *	TclGetInstructionTable(void);
/* 164 */
EXTERN void		TclExpandCodeArray(void *envPtr);
/* 165 */
EXTERN void		TclpSetInitialEncodings(void);
/* Slot 166 is reserved */



/* Slot 167 is reserved */
/* Slot 168 is reserved */
/* 169 */
EXTERN int		TclpUtfNcmp2(const char *s1, const char *s2,
				unsigned long n);
/* 170 */
EXTERN int		TclCheckInterpTraces(Tcl_Interp *interp,

    void (*reserved159)(void);
    void (*reserved160)(void);
    int (*tclChannelTransform) (Tcl_Interp *interp, Tcl_Channel chan, Tcl_Obj *cmdObjPtr); /* 161 */
    void (*tclChannelEventScriptInvoker) (ClientData clientData, int flags); /* 162 */
    const void * (*tclGetInstructionTable) (void); /* 163 */
    void (*tclExpandCodeArray) (void *envPtr); /* 164 */
    void (*tclpSetInitialEncodings) (void); /* 165 */
    void (*reserved166)(void);
    void (*reserved167)(void);
    void (*reserved168)(void);
    int (*tclpUtfNcmp2) (const char *s1, const char *s2, unsigned long n); /* 169 */
    int (*tclCheckInterpTraces) (Tcl_Interp *interp, const char *command, int numChars, Command *cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *const objv[]); /* 170 */
    int (*tclCheckExecutionTraces) (Tcl_Interp *interp, const char *command, int numChars, Command *cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *const objv[]); /* 171 */
    int (*tclInThreadExit) (void); /* 172 */
    int (*tclUniCharMatch) (const Tcl_UniChar *string, int strLen, const Tcl_UniChar *pattern, int ptnLen, int flags); /* 173 */

	(tclIntStubsPtr->tclChannelEventScriptInvoker) /* 162 */
#define TclGetInstructionTable \
	(tclIntStubsPtr->tclGetInstructionTable) /* 163 */
#define TclExpandCodeArray \
	(tclIntStubsPtr->tclExpandCodeArray) /* 164 */
#define TclpSetInitialEncodings \
	(tclIntStubsPtr->tclpSetInitialEncodings) /* 165 */

/* Slot 166 is reserved */
/* Slot 167 is reserved */
/* Slot 168 is reserved */
#define TclpUtfNcmp2 \
	(tclIntStubsPtr->tclpUtfNcmp2) /* 169 */
#define TclCheckInterpTraces \
	(tclIntStubsPtr->tclCheckInterpTraces) /* 170 */
#define TclCheckExecutionTraces \

 */

static List *		AttemptNewList(Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
static List *		NewListIntRep(int objc, Tcl_Obj *const objv[], int p);
static void		DupListInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr);
static void		FreeListInternalRep(Tcl_Obj *listPtr);
static int		SetElement(Tcl_Interp *interp, Tcl_Obj *listPtr,
			    int index, Tcl_Obj *valuePtr);
static int		SetListFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
static void		UpdateStringOfList(Tcl_Obj *listPtr);

/*
 * The structure below defines the list Tcl object type by means of functions
 * that can be invoked by generic object code.
 *

	if (p) {
	    Tcl_Panic("max length of a Tcl list (%d elements) exceeded",
		    LIST_MAX);
	}
	return NULL;
    }

    listRepPtr = attemptckalloc(LIST_SIZE(objc));
    if (listRepPtr == NULL) {
	if (p) {
	    Tcl_Panic("list creation failed: unable to alloc %u bytes",
		    LIST_SIZE(objc));
	}
	return NULL;
    }

    listRepPtr->canonicalFlag = 0;
    listRepPtr->refCount = 0;
    listRepPtr->maxElemCount = objc;

	if (objc > LIST_MAX) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "max length of a Tcl list (%d elements) exceeded",
		    LIST_MAX));
	} else {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "list creation failed: unable to alloc %u bytes",
		    LIST_SIZE(objc)));
	}
	Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
    }
    return listRepPtr;
}

/*

int
Tcl_ListObjAppendList(
    Tcl_Interp *interp,		/* Used to report errors if not NULL. */
    register Tcl_Obj *listPtr,	/* List object to append elements to. */
    Tcl_Obj *elemListPtr)	/* List obj with elements to append. */
{
    int objc;
    Tcl_Obj **objv;




    /* Pull the elements to append from elemListPtr */







    if (TCL_OK != TclListObjGetElements(interp, elemListPtr, &objc, &objv)) {

	return TCL_ERROR;
    }

    /*
     * Insert the new elements starting after the lists's last element.
     * Delete zero existing elements.
     */

    return Tcl_ListObjReplace(interp, listPtr, LIST_MAX, 0, objc, objv);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ListObjAppendElement --
 *

int
Tcl_ListObjAppendElement(
    Tcl_Interp *interp,		/* Used to report errors if not NULL. */
    Tcl_Obj *listPtr,		/* List object to append objPtr to. */
    Tcl_Obj *objPtr)		/* Object to append to listPtr's list. */
{
#if 1
    if (Tcl_IsShared(listPtr)) {
	Tcl_Panic("%s called with shared object", "Tcl_ListObjAppendElement");
    }
    return SetElement(interp, listPtr, LIST_MAX, objPtr);
#else
    register List *listRepPtr;
    register Tcl_Obj **elemPtrs;
    int numElems, numRequired, newMax, i;
    unsigned int newSize;

    if (Tcl_IsShared(listPtr)) {
	Tcl_Panic("%s called with shared object", "Tcl_ListObjAppendElement");
    }
    if (listPtr->typePtr != &tclListType) {
	int result;

     * If there is no room in the current array of element pointers, allocate
     * a new, larger array and copy the pointers to it. If the List struct is
     * shared, allocate a new one.
     */

    if (numRequired > listRepPtr->maxElemCount){
	newMax = 2 * numRequired;
	newSize = LIST_SIZE(newMax);
    } else {
	newMax = listRepPtr->maxElemCount;
	newSize = 0;
    }

    if (listRepPtr->refCount > 1) {
	List *oldListRepPtr = listRepPtr;

	     * we know to be unshared.  This call will also deal with the
	     * situation where parentList shares its intrep with other
	     * Tcl_Obj's.  Dealing with the shared intrep case can cause
	     * subListPtr to become shared again, so detect that case and make
	     * and store another copy.
	     */



	    while (1) {
		if (TCL_OK !=
			SetElement(interp, parentList, index, subListPtr)) {
		    goto error;
		}
		if (!Tcl_IsShared(subListPtr)) {
		    break;
		}
		subListPtr = Tcl_DuplicateObj(subListPtr);

	    }

	    /*
	     * The SetElement() calls do not spoil the string rep of
	     * parentList, and that's fine for now, since all we've done so
	     * far is replace a list element with an unshared copy.  The list
	     * value remains the same, so the string rep. is still valid, and
	     * unchanged, which is good because if this whole routine returns
	     * NULL, we'd like to leave no change to the value of the lset
	     * variable.  Later on, when we set valuePtr in its proper place,
	     * then all containing lists will have their values changed, and

    }

    if (result != TCL_OK) {
	/*
	 * Error return; message is already in interp. Clean up any excess
	 * memory.
	 */
    error:
	if (retValuePtr != listPtr) {
	    Tcl_DecrRefCount(retValuePtr);
	}
	return NULL;
    }

    /*
     * Store valuePtr in proper sublist and return.
     */

    Tcl_ListObjLength(NULL, subListPtr, &len);



    if (TCL_OK != SetElement(interp, subListPtr, index, valuePtr)) {
	goto error;
    }
    Tcl_InvalidateStringRep(subListPtr);
    Tcl_IncrRefCount(retValuePtr);
    return retValuePtr;
}

/*
 *----------------------------------------------------------------------
 *
 * SetElement --
 *
 *	Set a single element of a list to a specified value
 *
 * Results:
 *	The return value is normally TCL_OK. If listPtr does not refer to a
 *	list object and cannot be converted to one, TCL_ERROR is returned and
 *	an error message will be left in the interpreter result if interp is

 *
 *	It is the caller's responsibility to invalidate the string
 *	representation of the object.
 *
 *----------------------------------------------------------------------
 */

static int
SetElement(
    Tcl_Interp *interp,		/* Tcl interpreter; used for error reporting
				 * if not NULL. */
    Tcl_Obj *listPtr,		/* List object in which element should be
				 * stored. */
    int index,			/* Index of element to store. */
    Tcl_Obj *valuePtr)		/* Tcl object to store in the designated list
				 * element. */
{
    List *listRepPtr;		/* Internal representation of the list being
				 * modified. */
    Tcl_Obj **elemPtrs;		/* Pointers to elements of the list. */
    int elemCount;		/* Number of elements in the list. */





    int isShared;


    if (listPtr->typePtr != &tclListType) {


	if (listPtr->bytes == tclEmptyStringRep) {

	    Tcl_SetListObj(listPtr, 1, &valuePtr);




	    return TCL_OK;
	}
	if (TCL_OK != SetListFromAny(interp, listPtr)) {

	    return TCL_ERROR;
	}
    }

    listRepPtr = ListRepPtr(listPtr);
    isShared = listRepPtr->refCount > 1;
    elemCount = listRepPtr->elemCount;

    if (index >= elemCount) {
	/* We're appending, not overwriting. */
	List *newPtr = NULL;
	int attempt, needed = elemCount + 1;
	int needGrow = (elemCount == listRepPtr->maxElemCount);

	/* Append to the end (not beyond it). */
	index = elemCount;

	/* Bail out early if required growth exceeds LIST_MAX */
	if (needed > LIST_MAX) {
	    if (interp != NULL) {
		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			"max length of a Tcl list (%d elements) exceeded",
			LIST_MAX));
		Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
	    }
	    return TCL_ERROR;
	}

	if (needGrow && !isShared) {
	    /* Need to grow + unshared intrep => try to realloc */
	    attempt = 2 * needed;
	    if (attempt <= LIST_MAX) {
		newPtr = attemptckrealloc(listRepPtr, LIST_SIZE(attempt));
	    }
	    if (newPtr == NULL) {
		attempt = needed + 1 + TCL_MIN_ELEMENT_GROWTH;
		if (attempt > LIST_MAX) {
		    attempt = LIST_MAX;
		}
		newPtr = attemptckrealloc(listRepPtr, LIST_SIZE(attempt));
	    }
	    if (newPtr == NULL) {
		attempt = needed;
		newPtr = attemptckrealloc(listRepPtr, LIST_SIZE(attempt));
	    }
	    if (newPtr) {
		listRepPtr = newPtr;
		listRepPtr->maxElemCount = attempt;
	    }
	}
	if (isShared || needGrow) {
	    Tcl_Obj **dst, **src = &listRepPtr->elements;

	    /*

	     * Either we have a shared intrep and we must copy to write,
	     * or we need to grow and realloc attempts failed.
	     * Attempt intrep copy.
	     */
	    attempt = 2 * needed;
	    newPtr = AttemptNewList(NULL, attempt, NULL);
	    if (newPtr == NULL) {
		attempt = needed + 1 + TCL_MIN_ELEMENT_GROWTH;
		if (attempt > LIST_MAX) {
		    attempt = LIST_MAX;
		}
		newPtr = AttemptNewList(NULL, attempt, NULL);
	    }
	    if (newPtr == NULL) {
		attempt = needed;
		newPtr = AttemptNewList(interp, attempt, NULL);
	    }
	    if (newPtr == NULL) {
		/* All growth attempts failed; throw the error */
		return TCL_ERROR;
	    }

	    dst = &newPtr->elements;
	    newPtr->refCount++;
	    newPtr->canonicalFlag = listRepPtr->canonicalFlag;

	    if (isShared) {
		/*
		 * The original intrep must remain undisturbed.
		 * Copy into the new one and bump refcounts
		 */
		while (elemCount--) {
		    *dst = *src++;
		    Tcl_IncrRefCount(*dst++);
		}
		listRepPtr->refCount--;
		isShared = 0;
	    } else  {
		/* Old intrep to be freed, re-use refCounts */
		memcpy(dst, src, (size_t) elemCount * sizeof(Tcl_Obj *));

		/* TODO: revise when refactoring */
		/*listRepPtr->refCount--;*/
		ckfree(listRepPtr);
	    }
	    listRepPtr = newPtr;
	}

	listRepPtr->elemCount = needed;

	Tcl_IncrRefCount(valuePtr);
	elemPtrs = &listRepPtr->elements;
	elemPtrs[index] = valuePtr;
	listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr;
	Tcl_InvalidateStringRep(listPtr);
	return TCL_OK;
    }

    /*
     * If the internal rep is shared, replace it with an unshared copy.
     */

    if (isShared) {
	Tcl_Obj **dst, **src = &listRepPtr->elements;
	List *newPtr = AttemptNewList(NULL, listRepPtr->maxElemCount, NULL);



	if (newPtr == NULL) {
	    newPtr = AttemptNewList(interp, elemCount, NULL);
	    if (newPtr == NULL) {
		return TCL_ERROR;
	    }
	}
	newPtr->refCount++;
	newPtr->elemCount = elemCount;
	newPtr->canonicalFlag = listRepPtr->canonicalFlag;

	dst = &newPtr->elements;
	while (elemCount--) {
	    *dst = *src++;
	    Tcl_IncrRefCount(*dst++);
	}

	listRepPtr->refCount--;

	listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr = newPtr;

    }
    elemPtrs = &listRepPtr->elements;

    /*
     * Add a reference to the new list element.
     */

    Tcl_IncrRefCount(valuePtr);

    /*
     * Remove a reference from the old list element.
     */

    Tcl_DecrRefCount(elemPtrs[index]);

    /*
     * Stash the new object in the list.
     */

    elemPtrs[index] = valuePtr;

    Tcl_InvalidateStringRep(listPtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * FreeListInternalRep --

    0, /* 159 */
    0, /* 160 */
    TclChannelTransform, /* 161 */
    TclChannelEventScriptInvoker, /* 162 */
    TclGetInstructionTable, /* 163 */
    TclExpandCodeArray, /* 164 */
    TclpSetInitialEncodings, /* 165 */
    0, /* 166 */
    0, /* 167 */
    0, /* 168 */
    TclpUtfNcmp2, /* 169 */
    TclCheckInterpTraces, /* 170 */
    TclCheckExecutionTraces, /* 171 */
    TclInThreadExit, /* 172 */
    TclUniCharMatch, /* 173 */

	}
	Tcl_GetStringFromObj(objPtr, &length);
	if (length > 0) {
	    break;
	}
    }
    if (i == objc) {



	resPtr = NULL;
	for (i = 0;  i < objc;  i++) {









	    objPtr = objv[i];
	    if (objPtr->bytes && objPtr->length == 0) {
		continue;
	    }


	    if (resPtr) {
		Tcl_ListObjAppendList(NULL, resPtr, objPtr);
	    } else {
		resPtr = TclListObjCopy(NULL, objPtr);

	    }
	}
	if (!resPtr) {
	    resPtr = Tcl_NewObj();
	}
	return resPtr;
    }

    after cancel $timer
    close $s
    return $x
} -cleanup {
    interp bgerror {} $handler
} -result {divide by zero}

test socket_$af-6.2 {
    readable fileevent on server socket
} -setup {
    set sock [socket -server dummy 0]
} -body {
    fileevent $sock readable dummy
} -cleanup {
    close $sock
} -returnCodes 1 -result "channel is not readable"

test socket_$af-6.3 {writable fileevent on server socket} -setup {
    set sock [socket -server dummy 0]
} -body {
    fileevent $sock writable dummy
} -cleanup {
    close $sock
} -returnCodes 1 -result "channel is not writable"

test socket_$af-7.1 {testing socket specific options} -setup {
    file delete $path(script)
    set f [open $path(script) w]
    puts $f {
	set ss [socket -server accept 0]
	proc accept args {
	    global x

TcpWatchProc(
    ClientData instanceData,	/* The socket state. */
    int mask)			/* Events of interest; an OR-ed combination of
				 * TCL_READABLE, TCL_WRITABLE and
				 * TCL_EXCEPTION. */
{
    TcpState *statePtr = (TcpState *) instanceData;








    TcpFdList *fds;

    for (fds = statePtr->fds; fds != NULL; fds = fds->next) {
        if (mask) {
            Tcl_CreateFileHandler(fds->fd, mask,
                                  (Tcl_FileProc *) Tcl_NotifyChannel,
                                  (ClientData) statePtr->channel);
        } else {
            Tcl_DeleteFileHandler(fds->fd);
        }

    }
}

/*
 *----------------------------------------------------------------------
 *
 * TcpGetHandleProc --

		echo "$as_me:$LINENO: result:    Using 64-bit $MACHINE mode" >&5
echo "${ECHO_T}   Using 64-bit $MACHINE mode" >&6
		;;
	    ia64)
		MACHINE="IA64"
		echo "$as_me:$LINENO: result:    Using 64-bit $MACHINE mode" >&5
echo "${ECHO_T}   Using 64-bit $MACHINE mode" >&6
		;;
	    *)
		cat >conftest.$ac_ext <<_ACEOF
/* confdefs.h.  */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h.  */

			#ifdef _WIN64
			#error 64-bit
			#endif

int
main ()
{

  ;
  return 0;
}
_ACEOF
rm -f conftest.$ac_objext
if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
  (eval $ac_compile) 2>conftest.er1
  ac_status=$?
  grep -v '^ *+' conftest.er1 >conftest.err
  rm -f conftest.er1
  cat conftest.err >&5
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); } &&
	 { ac_try='test -z "$ac_c_werror_flag"
			 || test ! -s conftest.err'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; } &&
	 { ac_try='test -s conftest.$ac_objext'
  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
  (eval $ac_try) 2>&5
  ac_status=$?
  echo "$as_me:$LINENO: \$? = $ac_status" >&5
  (exit $ac_status); }; }; then
  tcl_win_64bit=no
else
  echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5

tcl_win_64bit=yes

fi
rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
		if test "$tcl_win_64bit" = "yes" ; then
			do64bit=amd64
			MACHINE="AMD64"
			echo "$as_me:$LINENO: result:    Using 64-bit $MACHINE mode" >&5
echo "${ECHO_T}   Using 64-bit $MACHINE mode" >&6
		fi
		;;
	esac
    else
	if test "${SHARED_BUILD}" = "0" ; then
	    # static
            echo "$as_me:$LINENO: result: using static flags" >&5
echo "${ECHO_T}using static flags" >&6

	    amd64|x64|yes)
		MACHINE="AMD64" ; # assume AMD64 as default 64-bit build
		AC_MSG_RESULT([   Using 64-bit $MACHINE mode])
		;;
	    ia64)
		MACHINE="IA64"
		AC_MSG_RESULT([   Using 64-bit $MACHINE mode])
		;;
	    *)
		AC_TRY_COMPILE([
			#ifdef _WIN64
			#error 64-bit
			#endif
		], [],
			tcl_win_64bit=no,
			tcl_win_64bit=yes
		)
		if test "$tcl_win_64bit" = "yes" ; then
			do64bit=amd64
			MACHINE="AMD64"
			AC_MSG_RESULT([   Using 64-bit $MACHINE mode])
		fi
		;;
	esac
    else
	if test "${SHARED_BUILD}" = "0" ; then
	    # static
            AC_MSG_RESULT([using static flags])
	    runtime=-MT