#! /bin/env tclsh
variable doc {
description {
a generic channel transform for routines written in C
encoding must not be changed
not seekable
}
}
package require critcl
::critcl::tcl 8.6
::critcl::cheaders clib.h
::critcl::ccode {
#include <errno.h>
#include <stdarg.h>
#include <string.h>
#include "clib.h"
enum filterFlags {
FILTERFLAGSZERO
, ENDOFFILE /* has the underlying channel reached eof? */
};
enum transformFlags {
TRANSFORMFLAGSZERO
, REQUIREBINARY
};
typedef struct filter_t {
Tcl_Channel channel;
Tcl_Encoding encoding;
int flags;
int opened;
Tcl_TimerToken timer;
Tcl_DString raw; /* raw data */
Tcl_EncodingState rawState;
int rawFlags;
Tcl_DString utfString; /* data converted to utf-8 */
int utfStringCharNum;
int utfStringCursor;
Tcl_DString optionEncoding;
Tcl_DString optionTranslation;
Tcl_DString output;
int outputFlags;
Tcl_EncodingState outputState;
int outputcursor;
Tcl_DString bytesOut;
int bytesOutCursor;
Tcl_DString tmpDString;
ycl_chan_process *transform;
int status;
Tcl_Obj *error;
ycl_chan_transform_eofProc *eofProc;
ycl_chan_transform_closeProc *closeProc;
ClientData clientData;
} filter_t;
void filterFree(filter_t* filter) {
Tcl_DStringFree(&filter->raw);
Tcl_DStringFree(&filter->utfString);
Tcl_DStringFree(&filter->output);
Tcl_DStringFree(&filter->bytesOut);
Tcl_DStringFree(&filter->optionEncoding);
Tcl_DStringFree(&filter->optionTranslation);
ckfree(filter);
}
static int close2Proc(
ClientData clientData ,Tcl_Interp *interp ,int flags) {
filter_t *filter = clientData;
int status = TCL_OK;
if (filter->closeProc != NULL) {
status = filter->closeProc(interp ,filter->clientData ,&filter->output ,flags);
};
filter->opened =~ flags;
if (flags & TCL_CLOSE_READ) {
} else if (flags & TCL_CLOSE_WRITE) {
} else {
Tcl_FreeEncoding(filter->encoding);
if (filter->status != 0) {
status = filter->status;
}
if (filter->error != NULL) {
Tcl_SetObjResult(interp, filter->error);
Tcl_DecrRefCount(filter->error);
filter->error = NULL;
}
filterFree(filter);
}
return status;
}
static int errorMsg (Tcl_Interp *interp ,int argcount ,...) {
int i;
va_list args;
char *msg;
Tcl_Obj *result = Tcl_NewListObj(0,NULL);
va_start(args ,argcount);
for (i = 0; i < argcount; i++) {
msg = va_arg(args ,char *);
Tcl_ListObjAppendElement(interp, result
, Tcl_NewStringObj( msg ,-1));
}
va_end(args);
Tcl_SetObjResult(interp ,result);
return TCL_OK;
}
void dStringTrim(Tcl_DString* dstring ,int bytes ,Tcl_DString *tmp) {
Tcl_DStringAppend(
tmp
,Tcl_DStringValue(dstring) + bytes
,Tcl_DStringLength(dstring) - bytes
);
Tcl_DStringSetLength(dstring ,0);
Tcl_DStringAppend(dstring
,Tcl_DStringValue(tmp)
,Tcl_DStringLength(tmp)
);
Tcl_DStringSetLength(tmp ,0);
return;
}
static int flushProc(ClientData clientData) {
return EINVAL;
}
static int handlerProc(ClientData clientData ,int interestMask) {
return EINVAL;
}
static int inputProc(
ClientData clientData ,char *buf ,int bufSize , int *errorCodePtr) {
int buffered ,bufWrote ,charbytes ,dstChars ,dstWrote ,i ,srcRead
,read ,status;
bufWrote = 0;
char tmpBuf[8192];
char externbuf[8192];
filter_t *filter = clientData;
Tcl_Channel down = Tcl_GetStackedChannel(filter->channel);
Tcl_UniChar uchar;
buffered = Tcl_InputBuffered(down);
bytesOut:
while (bufWrote < bufSize
&& filter->bytesOutCursor < Tcl_DStringLength(&filter->bytesOut))
{
*buf++ = Tcl_DStringValue(&filter->bytesOut)[
filter->bytesOutCursor++];
bufWrote++;
}
if (filter->bytesOutCursor < Tcl_DStringLength(&filter->bytesOut)) {
dStringTrim(&filter->bytesOut
,filter->bytesOutCursor
,&filter->tmpDString
);
} else {
Tcl_DStringSetLength(&filter->bytesOut ,0);
}
filter->bytesOutCursor = 0;
if (bufWrote == bufSize || (
(filter->flags & ENDOFFILE) && (Tcl_DStringLength(&filter->output) == 0))) {
if (
filter->eofProc != NULL
&&
(filter->flags & ENDOFFILE) && (Tcl_DStringLength(&filter->output) == 0)) {
filter->eofProc(filter->clientData);
}
return bufWrote;
}
/* present any error only after the output buffer is drained */
if (filter->status != 0) {
*errorCodePtr = filter->status;
return -1;
}
/*
utfString may still be full because tmpBuf couldn't hold all the data
drain utfString as much as possible before reading more bytes from
the underlying channel
*/
output:
if (Tcl_DStringLength(&filter->output)) {
status = Tcl_UtfToExternal(
NULL
,filter->encoding
,Tcl_DStringValue(&filter->output)
,Tcl_DStringLength(&filter->output)
,filter->outputFlags
,&filter->outputState
,tmpBuf ,8192
,&srcRead ,&dstWrote ,&dstChars
);
if (srcRead > 0) {
Tcl_DStringAppend(&filter->bytesOut ,tmpBuf, srcRead);
if (srcRead < Tcl_DStringLength(&filter->output)) {
dStringTrim(&filter->output ,srcRead ,&filter->tmpDString);
} else {
Tcl_DStringSetLength(&filter->output ,0);
}
if (status == TCL_CONVERT_NOSPACE) {
goto output;
} else {
goto bytesOut;
}
}
switch (status) {
case TCL_CONVERT_SYNTAX:
filter->status = TCL_CONVERT_SYNTAX;
filter->error = Tcl_NewStringObj(
"channel transform\n"
"\tinvalid utf-8 in filter output" ,-1);
Tcl_IncrRefCount(filter->error);
break;
case TCL_CONVERT_UNKNOWN:
filter->status = TCL_CONVERT_UNKNOWN;
filter->error = Tcl_NewStringObj(
"channel transform\n"
"\tcan not convert character to target encoding" ,-1);
Tcl_IncrRefCount(filter->error);
break;
}
}
read = Tcl_ReadRaw(down ,buf ,bufSize);
if (read < 0) {
filter->status = Tcl_GetErrno();
return read;
} if (Tcl_Eof(down) != 0) {
filter->flags |= ENDOFFILE;
}
Tcl_DStringAppend(&filter->raw , buf ,read);
status = Tcl_ExternalToUtf(NULL
, filter->encoding
, Tcl_DStringValue(&filter->raw)
, Tcl_DStringLength(&filter->raw)
, filter->rawFlags
, &filter->rawState
, externbuf
, 8192
, &srcRead
, &dstWrote
, &dstChars
);
if (srcRead < Tcl_DStringLength(&filter->raw)) {
dStringTrim(&filter->raw ,srcRead ,&filter->tmpDString);
} else {
Tcl_DStringSetLength(&filter->raw ,0);
}
if (srcRead > 0) {
Tcl_DStringAppend(
&filter->utfString
,externbuf
,dstWrote
);
filter->utfStringCharNum += dstChars;
}
switch (status) {
case TCL_CONVERT_SYNTAX:
filter->status = TCL_CONVERT_SYNTAX;
filter->error = Tcl_NewStringObj(
"channel transform\n"
"\tinvalid character sequence in filter input" ,-1);
Tcl_IncrRefCount(filter->error);
break;
case TCL_CONVERT_UNKNOWN:
filter->status = TCL_CONVERT_UNKNOWN;
filter->error = Tcl_NewStringObj(
"channel transform\n"
"\tcan not convert character to Unicode" ,-1);
Tcl_IncrRefCount(filter->error);
break;
}
for (i = 0
;filter->utfStringCharNum > 0
;filter->utfStringCharNum--
) {
i += Tcl_UtfToUniChar(Tcl_DStringValue(&filter->utfString) + i, &uchar);
/*
call the filter even if nothing was read so that it can react to eof
*/
status = filter->transform(filter->clientData ,uchar ,&filter->output);
if (status != 0) {
filter->status = status;
break;
}
}
Tcl_DStringSetLength(&filter->utfString ,0);
goto bytesOut;
}
static int outputProc(
ClientData clientData ,const char *buf ,int toWrite ,int *errorCodePtr
) {
return EINVAL;
}
static int seekProc(
ClientData clientData ,long offset ,int seekMode , int *errorCodePtr
) {
return EINVAL;
}
static void threadActionProc(ClientData clientData ,int action) {
return;
}
static int truncateProc(ClientData clientData ,Tcl_WideInt length) {
return EINVAL;
}
static void watchProc(ClientData clientData ,int mask) {
/*
The thinking here is that this channel needs to do nothing because
notification from the downstream channel is sufficient to drive the
bytes both ways. But is this actually true?
*/
filter_t *filter;
filter = clientData;
Tcl_Channel down = Tcl_GetStackedChannel(filter->channel);
Tcl_ChannelWatchProc(Tcl_GetChannelType(down))(
Tcl_GetChannelInstanceData(down) ,mask);
return;
}
static Tcl_WideInt wideSeekProc(ClientData clientData
,Tcl_WideInt offset ,int seekMode ,int *errorCodePtr) {
}
Tcl_ChannelType filterChanType = {
"filter"
, TCL_CHANNEL_VERSION_4
, TCL_CLOSE2PROC
, inputProc
, outputProc
, seekProc
, NULL
, NULL
, watchProc
, NULL /* getHandleProc */
, close2Proc
, NULL
, flushProc
, handlerProc
, wideSeekProc
, threadActionProc
, truncateProc
};
Tcl_ChannelType *getFilterChanType() {
return &filterChanType;
}
/*
obsoleted by pushTransform
*/
void filter (Tcl_Interp *interp ,Tcl_Channel inchan ,Tcl_Channel outchan, ycl_chan_process process) {
int i ,utflen ,len ,outidx ,readsize = 65536 ,written;
char *utfString;
Tcl_UniChar uchar , *ustring;
Tcl_Obj *chars = Tcl_NewObj() , *ucharobj = Tcl_NewIntObj(0);
Tcl_IncrRefCount(chars);
Tcl_DString data;
Tcl_DStringInit(&data);
while (1) {
len = Tcl_ReadChars(inchan ,chars ,readsize ,0);
ustring = Tcl_GetUnicode(chars);
for (i = 0; i < len; i++) {
uchar = ustring[i];
process(NULL ,uchar ,&data);
}
utfString = Tcl_DStringValue(&data);
utflen = Tcl_DStringLength(&data);
written = 0;
while (written < utflen) {
written += Tcl_WriteChars(outchan , utfString + written ,(utflen - written));
}
Tcl_DStringSetLength(&data ,0);
if (Tcl_Eof(inchan)) {
break;
}
}
Tcl_DecrRefCount(chars);
}
int pushTransform (
Tcl_Interp *interp
, char *name
, ClientData clientData
, ycl_chan_process transform
, ycl_chan_transform_eofProc eofProc
, ycl_chan_transform_closeProc closeProc
, int flags
) {
filter_t *filter;
int dummy ,mask ,status = TCL_OK;
Tcl_Channel chan = Tcl_GetChannel(interp ,name ,&mask);
char buf[1];
if (chan == NULL) {
errorMsg(interp , 2 ,"channel transform" , "no such channel");
return TCL_ERROR;
}
filter = ckalloc(sizeof(filter_t));
memset(filter ,0 ,sizeof(filter_t));
filter->opened = mask;
filter->transform = transform;
filter->rawFlags = TCL_ENCODING_STOPONERROR;
Tcl_DStringInit(&filter->raw);
Tcl_DStringInit(&filter->utfString);
Tcl_DStringInit(&filter->output);
filter->outputFlags |= TCL_ENCODING_STOPONERROR;
Tcl_DStringInit(&filter->bytesOut);
Tcl_DStringInit(&filter->optionEncoding);
Tcl_DStringInit(&filter->optionTranslation);
Tcl_DStringInit(&filter->tmpDString);
Tcl_GetChannelOption(NULL ,chan ,"-encoding" ,&filter->optionEncoding);
Tcl_GetChannelOption(NULL ,chan ,"-translation" ,&filter->optionTranslation);
if ((strcmp("binary", Tcl_DStringValue(&filter->optionEncoding))) == 0) {
filter->encoding = Tcl_GetEncoding(interp ,"iso8859-1");
} else {
if (flags & REQUIREBINARY) {
if (strcmp("iso8859-1"
,Tcl_DStringValue(&filter->optionEncoding))) {
errorMsg(interp , 2
,"chan encoding must be one of" , "iso8859-1 binary");
goto error;
}
if (strcmp("binary"
,Tcl_DStringValue(&filter->optionTranslation))) {
errorMsg(interp , 1 ,"chan translation must be binary");
goto error;
}
}
filter->encoding = Tcl_GetEncoding(interp ,Tcl_DStringValue(
&filter->optionEncoding));
}
if (filter->encoding == NULL) {
goto error;
}
if ((filter->channel = Tcl_StackChannel(
interp ,getFilterChanType() ,filter ,mask ,chan)) == NULL) {
errorMsg(interp , 1 ,"could not stack channel");
goto error;
};
filter->eofProc = eofProc;
filter->closeProc = closeProc;
filter->clientData = clientData;
goto ok;
error:
filterFree(filter);
return TCL_ERROR;
ok:
return TCL_OK;
}
unsigned int requireBinary () {
return REQUIREBINARY;
}
}
::critcl::api header clib.h
::critcl::api function void filter {
Tcl_Interp *interp Tcl_Channel inchan Tcl_Channel
outchan ycl_chan_process process
}
::critcl::api function int pushTransform {
Tcl_Interp *interp
char *name
ClientData clientData
ycl_chan_process transform
ycl_chan_transform_eofProc eofProc
ycl_chan_transform_closeProc closeProc
int flags
}
::critcl::api function Tcl_ChannelType *getFilterChanType {}
::critcl::api function {unsigned int} requireBinary {}
::critcl::debug symbols
::critcl::load
# fake command to make critcl happy
if 0 {
package provide ycl_chan_clib 0.1
}