Tcl Source Code

.PP
If the option \fB-failindex\fR with a variable name is given, the error reporting
is changed in the following manner:
in case of a conversion error, the position of the input byte causing the error
is returned in the given variable.  The return value of the command are the
converted characters until the first error position.
In case of no error, the value \fI-1\fR is written to the variable.  This option
may not be used together with \fB-nocomplain\fR.
.PP
The option \fB-nocomplain\fR has no effect and is available for compatibility with
TCL 9. In TCL 9, the encoding command fails with an error on any encoding issue.
This switch restores the TCL8.7 behaviour.
.PP
The \fB-strict\fR option follows more strict rules in conversion.  For the \fButf-8\fR
encoder, it disallows invalid byte sequences and surrogates (which -

.PP
If the option \fB-failindex\fR with a variable name is given, the error reporting
is changed in the following manner:
in case of a conversion error, the position of the input character causing the error
is returned in the given variable.  The return value of the command are the
converted bytes until the first error position. No error condition is raised.
In case of no error, the value \fI-1\fR is written to the variable.  This option
may not be used together with \fB-nocomplain\fR.
.PP
The option \fB-nocomplain\fR has no effect and is available for compatibility with
TCL 9. In TCL 9, the encoding command fails with an error on any encoding issue.
This switch restores the TCL8.7 behaviour.
.PP
The \fB-strict\fR option follows more strict rules in conversion.  For the \fButf-8\fR
encoder, it disallows surrogates (which - otherwise - are just passed through).

 * Copyright © 1994-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */

#include "tclInt.h"
#include "tclIO.h"
#ifdef _WIN32
#   include "tclWinInt.h"
#endif
#include "tclArithSeries.h"

/*
 * The state structure used by [foreach]. Note that the actual structure has

     * 7) -failindex val data				-> objc = 4
     * 8) -failindex val encoding data			-> objc = 5
     */

    if (objc == 2) {
	encoding = Tcl_GetEncoding(interp, NULL);
	data = objv[1];
    } else if (objc > 2 && objc < 7) {
	int objcUnprocessed = objc;
	data = objv[objc - 1];
	bytesPtr = Tcl_GetString(objv[1]);
	if (bytesPtr[0] == '-' && bytesPtr[1] == 'n'
		&& !strncmp(bytesPtr, "-nocomplain", strlen(bytesPtr))) {
	    flags = TCL_ENCODING_NOCOMPLAIN;
	    objcUnprocessed--;
	} else if (bytesPtr[0] == '-' && bytesPtr[1] == 's'
		&& !strncmp(bytesPtr, "-strict", strlen(bytesPtr))) {
	    flags = TCL_ENCODING_STRICT;
	    objcUnprocessed--;
		bytesPtr = Tcl_GetString(objv[2]);
		if (bytesPtr[0] == '-' && bytesPtr[1] == 'f'
			&& !strncmp(bytesPtr, "-failindex", strlen(bytesPtr))) {
		    /* at least two additional arguments needed */
		    if (objc < 6) {
			goto encConvFromError;
		    }
		    failVarObj = objv[3];
		    objcUnprocessed -= 2;
		}
	} else if (bytesPtr[0] == '-' && bytesPtr[1] == 'f'
		&& !strncmp(bytesPtr, "-failindex", strlen(bytesPtr))) {
	    /* at least two additional arguments needed */
	    if (objc < 4) {
		goto encConvFromError;
	    }
	    failVarObj = objv[2];
	    flags = ENCODING_FAILINDEX;
	    objcUnprocessed -= 2;
		bytesPtr = Tcl_GetString(objv[3]);
		if (bytesPtr[0] == '-' && bytesPtr[1] == 's'
			&& !strncmp(bytesPtr, "-strict", strlen(bytesPtr))) {
		    flags = TCL_ENCODING_STRICT;
		    objcUnprocessed --;
		}
	}
	switch (objcUnprocessed) {
	    case 3:
		if (Tcl_GetEncodingFromObj(interp, objv[objc - 2], &encoding) != TCL_OK) {
		    return TCL_ERROR;
		}
		break;
	    case 2:
		encoding = Tcl_GetEncoding(interp, NULL);
		break;
	    default:
		goto encConvFromError;
	}
    } else {
    encConvFromError:
	Tcl_WrongNumArgs(interp, 1, objv, "?-nocomplain|?-strict? ?-failindex var?? ?encoding? data");
	return TCL_ERROR;
    }

    /*
     * Convert the string into a byte array in 'ds'
     */
#if !defined(TCL_NO_DEPRECATED) && (TCL_MAJOR_VERSION < 9)

		&& !strncmp(stringPtr, "-nocomplain", strlen(stringPtr))) {
	    flags = TCL_ENCODING_NOCOMPLAIN;
	    objcUnprocessed--;
	} else if (stringPtr[0] == '-' && stringPtr[1] == 's'
		&& !strncmp(stringPtr, "-strict", strlen(stringPtr))) {
	    flags = TCL_ENCODING_STRICT;
	    objcUnprocessed--;
		stringPtr = Tcl_GetString(objv[2]);
		if (stringPtr[0] == '-' && stringPtr[1] == 'f'
			&& !strncmp(stringPtr, "-failindex", strlen(stringPtr))) {
		    /* at least two additional arguments needed */
		    if (objc < 6) {
			goto encConvToError;
		    }
		    failVarObj = objv[3];
		    objcUnprocessed -= 2;
		}
	} else if (stringPtr[0] == '-' && stringPtr[1] == 'f'
		&& !strncmp(stringPtr, "-failindex", strlen(stringPtr))) {
	    /* at least two additional arguments needed */
	    if (objc < 4) {
		goto encConvToError;
	    }
	    failVarObj = objv[2];
	    flags = TCL_ENCODING_STOPONERROR;
	    objcUnprocessed -= 2;
		stringPtr = Tcl_GetString(objv[3]);
		if (stringPtr[0] == '-' && stringPtr[1] == 's'
			&& !strncmp(stringPtr, "-strict", strlen(stringPtr))) {
		    flags = TCL_ENCODING_STRICT;
		    objcUnprocessed --;
		}
	}
	switch (objcUnprocessed) {
	    case 3:
		if (Tcl_GetEncodingFromObj(interp, objv[objc - 2], &encoding) != TCL_OK) {
		    return TCL_ERROR;
		}
		break;
	    case 2:
		encoding = Tcl_GetEncoding(interp, NULL);
		break;
	    default:
		goto encConvToError;
	}
    } else {
    encConvToError:
	Tcl_WrongNumArgs(interp, 1, objv, "?-nocomplain|?-strict? ?-failindex var?? ?encoding? data");
	return TCL_ERROR;
    }

    /*
     * Convert the string to a byte array in 'ds'
     */

/*
 * tclEncoding.c --
 *
 *	Contains the implementation of the encoding conversion package.
 *
 * Copyright © 1996-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */

#include "tclInt.h"
#include "tclIO.h"

typedef size_t (LengthProc)(const char *src);

/*
 * The following data structure represents an encoding, which describes how to
 * convert between various character sets and UTF-8.
 */

	    /*
	     * Copy 7bit characters, but skip null-bytes when we are in input
	     * mode, so that they get converted to 0xC080.
	     */

	    *dst++ = *src++;
	} else if ((UCHAR(*src) == 0xC0) && (src + 1 < srcEnd)
		&& (UCHAR(src[1]) == 0x80) && (!(flags & TCL_ENCODING_MODIFIED) || ((flags & TCL_ENCODING_STRICT) == TCL_ENCODING_STRICT) || (flags & ENCODING_FAILINDEX))) {
	    /*
	     * If in input mode, and -strict or -failindex is specified: This is an error.
	     */
	    if (flags & TCL_ENCODING_MODIFIED) {
		result = TCL_CONVERT_SYNTAX;
		break;
	    }

	    /*

	     */

	    if (flags & TCL_ENCODING_MODIFIED) {
		if ((STOPONERROR) && (flags & TCL_ENCODING_CHAR_LIMIT)) {
		    result = TCL_CONVERT_MULTIBYTE;
		    break;
		}
	    if (((flags & TCL_ENCODING_STRICT) == TCL_ENCODING_STRICT) || (flags & ENCODING_FAILINDEX)) {
		result = TCL_CONVERT_SYNTAX;
		break;
	    }
		ch = UCHAR(*src++);
	    } else {
		char chbuf[2];
		chbuf[0] = UCHAR(*src++); chbuf[1] = 0;

#define CHANNEL_ENCODING_STRICT	(1<<18)	/* set if option
					 * -strictencoding is set to 1 */
#define CHANNEL_INCLOSE		(1<<19)	/* Channel is currently being closed.
					 * Its structures are still live and
					 * usable, but it may not be closed
					 * again from within the close
					 * handler. */
#define ENCODING_FAILINDEX	(1<<20) /* Internal flag, fail on Invalid bytes only */
#define CHANNEL_CLOSEDWRITE	(1<<21)	/* Channel write side has been closed.
					 * No further Tcl-level write IO on
					 * the channel is allowed. */

/*
 * The length of time to wait between synthetic timer events. Must be zero or
 * bad things tend to happen.

    encoding
} -result {wrong # args: should be "encoding subcommand ?arg ...?"}
test cmdAH-4.2 {Tcl_EncodingObjCmd} -returnCodes error -body {
    encoding foo
} -result {unknown or ambiguous subcommand "foo": must be convertfrom, convertto, dirs, names, or system}
test cmdAH-4.3 {Tcl_EncodingObjCmd} -returnCodes error -body {
    encoding convertto
} -result {wrong # args: should be "encoding convertto ?-nocomplain|?-strict? ?-failindex var?? ?encoding? data"}
test cmdAH-4.4 {Tcl_EncodingObjCmd} -returnCodes error -body {
    encoding convertto foo bar
} -result {unknown encoding "foo"}
test cmdAH-4.5 {Tcl_EncodingObjCmd} -setup {
    set system [encoding system]
} -body {
    encoding system jis0208

    encoding system iso8859-1
    encoding convertto jis0208 乎
} -cleanup {
    encoding system $system
} -result 8C
test cmdAH-4.7 {Tcl_EncodingObjCmd} -returnCodes error -body {
    encoding convertfrom
} -result {wrong # args: should be "encoding convertfrom ?-nocomplain|?-strict? ?-failindex var?? ?encoding? data"}
test cmdAH-4.8 {Tcl_EncodingObjCmd} -returnCodes error -body {
    encoding convertfrom foo bar
} -result {unknown encoding "foo"}
test cmdAH-4.9 {Tcl_EncodingObjCmd} -setup {
    set system [encoding system]
} -body {
    encoding system jis0208

    encoding system
} -cleanup {
    encoding system $system
} -result iso8859-1

test cmdAH-4.14.1 {Syntax error, -nocomplain and -failindex, no encoding} -body {
    encoding convertfrom -nocomplain -failindex 2 ABC
} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain|?-strict? ?-failindex var?? ?encoding? data"}
test cmdAH-4.14.2 {Syntax error, -nocomplain and -failindex, no encoding} -body {
    encoding convertto -nocomplain -failindex 2 ABC
} -returnCodes 1 -result {wrong # args: should be "encoding convertto ?-nocomplain|?-strict? ?-failindex var?? ?encoding? data"}
test cmdAH-4.15.1 {Syntax error, -failindex and -nocomplain, no encoding} -body {
    encoding convertfrom -failindex 2 -nocomplain ABC
} -returnCodes 1 -result {unknown encoding "-nocomplain"}
test cmdAH-4.15.2 {Syntax error, -failindex and -nocomplain, no encoding} -body {
    encoding convertto -failindex 2 -nocomplain ABC
} -returnCodes 1 -result {unknown encoding "-nocomplain"}
test cmdAH-4.16.1 {Syntax error, -nocomplain and -failindex, encoding} -body {
    encoding convertfrom -nocomplain -failindex 2 utf-8 ABC
} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain|?-strict? ?-failindex var?? ?encoding? data"}
test cmdAH-4.16.2 {Syntax error, -nocomplain and -failindex, encoding} -body {
    encoding convertto -nocomplain -failindex 2 utf-8 ABC
} -returnCodes 1 -result {wrong # args: should be "encoding convertto ?-nocomplain|?-strict? ?-failindex var?? ?encoding? data"}
test cmdAH-4.17.1 {Syntax error, -failindex and -nocomplain, encoding} -body {
    encoding convertfrom -failindex 2 -nocomplain utf-8 ABC
} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain|?-strict? ?-failindex var?? ?encoding? data"}
test cmdAH-4.17.2 {Syntax error, -failindex and -nocomplain, encoding} -body {
    encoding convertto -failindex 2 -nocomplain utf-8 ABC
} -returnCodes 1 -result {wrong # args: should be "encoding convertto ?-nocomplain|?-strict? ?-failindex var?? ?encoding? data"}
test cmdAH-4.18.1 {Syntax error, -failindex with no var, no encoding} -body {
    encoding convertfrom -failindex ABC
} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain|?-strict? ?-failindex var?? ?encoding? data"}
test cmdAH-4.18.2 {Syntax error, -failindex with no var, no encoding (byte compiled)} -setup {
    proc encoding_test {} {
        encoding convertfrom -failindex ABC
    }
} -body {
    # Compile and execute
    encoding_test
} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain|?-strict? ?-failindex var?? ?encoding? data"} -cleanup {
    rename encoding_test ""
}
test cmdAH-4.18.3 {Syntax error, -failindex with no var, no encoding} -body {
    encoding convertto -failindex ABC
} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertto ?-nocomplain|?-strict? ?-failindex var?? ?encoding? data"}
test cmdAH-4.18.4 {Syntax error, -failindex with no var, no encoding (byte compiled)} -setup {
    proc encoding_test {} {
        encoding convertto -failindex ABC
    }
} -body {
    # Compile and execute
    encoding_test
} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertto ?-nocomplain|?-strict? ?-failindex var?? ?encoding? data"} -cleanup {
    rename encoding_test ""
}
test cmdAH-4.19.1 {convertrom -failindex with correct data} -body {
    encoding convertfrom -failindex test ABC
    set test
} -returnCodes 0 -result -1
test cmdAH-4.19.2 {convertrom -failindex with correct data (byt compiled)} -setup {

} -returnCodes 0 -result {41 1}
test cmdAH-4.20.2 {convertrom -failindex with incomplete utf8 (byte compiled)} -setup {
    proc encoding_test {} {
	set x [encoding convertfrom -failindex i utf-8 A\xc3]
	binary scan $x H* y
	list $y $i
    }
} -body {
    # Compile and execute
    encoding_test
} -returnCodes 0 -result {41 1} -cleanup {
    rename encoding_test ""
}
test cmdAH-4.20.3 {convertrom -failindex with incomplete utf8} -body {
    set x [encoding convertfrom -strict -failindex i utf-8 A\xc3]
    binary scan $x H* y
    list $y $i
} -returnCodes 0 -result {41 1}
test cmdAH-4.20.4 {convertrom -failindex with incomplete utf8 (byte compiled)} -setup {
    proc encoding_test {} {
	set x [encoding convertfrom -strict -failindex i utf-8 A\xc3]
	binary scan $x H* y
	list $y $i
    }
} -body {
    # Compile and execute
    encoding_test
} -returnCodes 0 -result {41 1} -cleanup {
    rename encoding_test ""
}
test cmdAH-4.20.5 {convertrom -failindex with incomplete utf8} -body {
    set x [encoding convertfrom -failindex i -strict utf-8 A\xc3]
    binary scan $x H* y
    list $y $i
} -returnCodes 0 -result {41 1}
test cmdAH-4.20.6 {convertrom -failindex with incomplete utf8 (byte compiled)} -setup {
    proc encoding_test {} {
	set x [encoding convertfrom -failindex i -strict utf-8 A\xc3]
	binary scan $x H* y
	list $y $i
    }
} -body {
    # Compile and execute
    encoding_test
} -returnCodes 0 -result {41 1} -cleanup {
    rename encoding_test ""
}
test cmdAH-4.21.1 {convertto -failindex with wrong character} -body {

    string length [encoding convertfrom -nocomplain "\x20"]
} 1
test encoding-24.21 {Parse with -nocomplain but without providing encoding} {
    string length [encoding convertto -nocomplain "\x20"]
} 1
test encoding-24.22 {Syntax error, two encodings} -body {
    encoding convertfrom iso8859-1 utf-8 "ZX\uD800"
} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain|?-strict? ?-failindex var?? ?encoding? data"}
test encoding-24.23 {Syntax error, two encodings} -body {
    encoding convertto iso8859-1 utf-8 "ZX\uD800"
} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertto ?-nocomplain|?-strict? ?-failindex var?? ?encoding? data"}
test encoding-24.24 {Parse invalid utf-8 with -strict} -body {
    encoding convertfrom -strict utf-8 "\xC0\x80\x00\x00"
} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xC0'}
test encoding-24.25 {Parse invalid utf-8 with -strict} -body {
    encoding convertfrom -strict utf-8 "\x40\x80\x00\x00"
} -returnCodes 1 -result {unexpected byte sequence starting at index 1: '\x80'}
test encoding-24.26 {Parse valid utf-8 with -strict} -body {

} -result foobar
test safe-11.7 {testing safe encoding} -setup {
    set i [safe::interpCreate]
} -body {
    interp eval $i encoding convertfrom
} -returnCodes error -cleanup {
    safe::interpDelete $i
} -result {wrong # args: should be "encoding convertfrom ?-nocomplain|?-strict? ?-failindex var?? ?encoding? data"}
test safe-11.7.1 {testing safe encoding} -setup {
    set i [safe::interpCreate]
} -body {
    catch {interp eval $i encoding convertfrom} m o
    dict get $o -errorinfo
} -match glob -cleanup {
    unset -nocomplain m o
    safe::interpDelete $i
} -result {wrong # args: should be "encoding convertfrom ?-nocomplain|?-strict? ?-failindex var?? ?encoding? data"
    while executing
"encoding convertfrom"
    invoked from within
"encoding convertfrom"
    invoked from within
"interp eval $i encoding convertfrom"}
test safe-11.8 {testing safe encoding} -setup {
    set i [safe::interpCreate]
} -body {
    interp eval $i encoding convertto
} -returnCodes error -cleanup {
    safe::interpDelete $i
} -result {wrong # args: should be "encoding convertto ?-nocomplain|?-strict? ?-failindex var?? ?encoding? data"}
test safe-11.8.1 {testing safe encoding} -setup {
    set i [safe::interpCreate]
} -body {
    catch {interp eval $i encoding convertto} m o
    dict get $o -errorinfo
} -match glob -cleanup {
    unset -nocomplain m o
    safe::interpDelete $i
} -result {wrong # args: should be "encoding convertto ?-nocomplain|?-strict? ?-failindex var?? ?encoding? data"
    while executing
"encoding convertto"
    invoked from within
"encoding convertto"
    invoked from within
"interp eval $i encoding convertto"}