Tcl Source Code

 */

#define defaultEncoding tclIdentityEncoding
static Tcl_Encoding systemEncoding = NULL;
Tcl_Encoding tclIdentityEncoding = NULL;

/*
 * Small encoding cache (GC) hold N last freed encodings, to avoid too often
 * load of encodings by reuse.
 */
#define ENC_CACHE_SIZE 4
static Encoding *encodingCache[ENC_CACHE_SIZE] = {NULL, NULL, NULL, NULL};

/*
 * The following variable is used in the sparse matrix code for a
 * TableEncoding to represent a page in the table that has no entries.
 */

static unsigned short emptyPage[256];

	 * than systemEncoding got switched, retry (systemEncoding already points
	 * to other value).
	 */
    } while (1);
}

static inline
void
FreeEncodingCache()
{
    int i;



    Tcl_MutexLock(&encodingMutex);
    for (i = ENC_CACHE_SIZE-1; i >= 0; i--) {
	if (encodingCache[i]) {
	    FreeEncoding(encodingCache[i], 0);
	    encodingCache[i] = NULL;
	}
    }
    Tcl_MutexUnlock(&encodingMutex);
}

/*
 * A Tcl_ObjType for holding a cached Tcl_Encoding in the ptrAndLongRep.ptr field
 * of the intrep. This should help the lifetime of encodings be more useful.
 * See concerns raised in [Bug 1077262].
 */

    if (!encodingsInitialized) {
	return;
    }

    /* increase epoch to signal all encodings are obsolete */
    encodingsEpoch++;

    FreeEncodingCache();

    Tcl_MutexLock(&encodingMutex);
    encodingsInitialized = 0;
    FreeEncoding((Encoding *)systemEncoding, 0);
    systemEncoding = NULL;
    FreeEncoding((Encoding *)defaultEncoding, 0);
    defaultEncoding = NULL;


    hPtr = Tcl_FirstHashEntry(&encodingTable, &search);
    while (hPtr != NULL) {
	/*
	 * Call FreeEncoding instead of doing it directly to handle refcounts
	 * like escape encodings use. [Bug 524674] Make sure to call
	 * Tcl_FirstHashEntry repeatedly so that all encodings are eventually

	}
	/* Cache encoding which get free, thereby avoid infinite reqursion
	 * and cache within TclFinalizeEncodingSubsystem process,
	 * also consider epoch (don't store obsolete encodings in cache) */
	if ( lock == 1 && encodingsInitialized
	  && encodingPtr->epoch >= encodingsEpoch
	) {
	    int i;

	    /* hold N last freed encodings (make it reusable) */
	    Tcl_MutexLock(&encodingMutex);
	    if (encodingCache[ENC_CACHE_SIZE-1]) {
		FreeEncoding(encodingCache[ENC_CACHE_SIZE-1], 0);
	    }
	    TclpAtomicIncrFetch(&encodingPtr->refCount);
	    for (i = ENC_CACHE_SIZE-1; i > 0; i--) {
		encodingCache[i] = encodingCache[i-1];
	    }
	    encodingCache[0] = encodingPtr;
	    Tcl_MutexUnlock(&encodingMutex);
	    return;
	}
	if (encodingPtr->freeProc != NULL) {
	    (*encodingPtr->freeProc)(encodingPtr->clientData);
	}

namespace eval ::tclTestPerf-Enc {

namespace path {::tclTestPerf}

proc test-encoding-object {{reptime 1000}} {
  _test_run $reptime {
    # static object and cached encoding (utf-8 must be already there):
    {encoding convertfrom utf-8 xxx}
    {encoding convertto utf-8 xxx}
    # system encoding:
    {encoding convertfrom xxx}
    {encoding convertto xxx}
    # dynamic object :
    {encoding convertfrom [string trimright "shiftjis "] xxx}
    {encoding convertto [string trimright "shiftjis "] xxx}
    # object shimmering :
    {encoding convertfrom jis0208 xxx; llength jis0208}
    {encoding convertto jis0208 xxx; llength jis0208}
  }
}
proc test-multi-encoding {{reptime 1000}} {
  _test_run $reptime {
    # dynamic object 2x convert:
    {encoding convertfrom [string trimright "jis0208 "] [encoding convertto [string trimright "shiftjis "] xxx]}
    # dynamic object 3x convert:
    {encoding convertto [string trimright "jis0212 "] [encoding convertfrom [string trimright "jis0208 "] [encoding convertto [string trimright "shiftjis "] xxx]]}
    # dynamic object 4x convert (with nested encodings load):
    {encoding convertfrom [string trimright "iso2022-kr "] [encoding convertto [string trimright "ebcdic "] [encoding convertfrom [string trimright "dingbats "] [encoding convertto [string trimright "iso2022-jp "] xxx]]]}
  }
}

proc test-channel-encoding {{reptime 1000}} {
  _test_run $reptime {
    setup {set o [fconfigure stdout -encoding]; list}
    # dynamic object :
    {fconfigure stdout -encoding [string trimright "shiftjis "]; fconfigure stdout -encoding $o}
    # static object (shimmering) :
    {fconfigure stdout -encoding shiftjis; fconfigure stdout -encoding $o}
  }
}

proc test {{reptime 1000}} {
  test-encoding-object $reptime
  test-multi-encoding $reptime
  test-channel-encoding $reptime
  puts \n**OK**
}

}; # end of ::tclTestPerf-Enc

# ------------------------------------------------------------------------