diff options
| -rw-r--r-- | ChangeLog | 19 | ||||
| -rw-r--r-- | doc/CrtChannel.3 | 84 | ||||
| -rw-r--r-- | doc/OpenFileChnl.3 | 19 | ||||
| -rw-r--r-- | doc/chan.n | 119 | ||||
| -rw-r--r-- | generic/tcl.decls | 11 | ||||
| -rw-r--r-- | generic/tcl.h | 28 | ||||
| -rw-r--r-- | generic/tclBasic.c | 5 | ||||
| -rw-r--r-- | generic/tclIO.c | 84 | ||||
| -rw-r--r-- | generic/tclIOCmd.c | 76 | ||||
| -rw-r--r-- | generic/tclInt.h | 5 | ||||
| -rw-r--r-- | library/init.tcl | 22 | ||||
| -rw-r--r-- | tests/chan.test | 85 | ||||
| -rw-r--r-- | unix/tclUnixChan.c | 51 |
13 files changed, 567 insertions, 41 deletions
@@ -1,3 +1,22 @@ +2005-06-07 Donal K. Fellows <dkf@users.sf.net> + + TIP#208 IMPLEMENTATION + + * library/init.tcl: Create the chan ensemble. + * tests/chan.test: Rudimentary test suite. + * doc/chan.n: General documentation. + + TRUNCATION API (part of TIP#208) + * generic/tcl.h, generic/tcl.decls: Declaration of the API. + * doc/CrtChannel.3, doc/OpenFileChnl.3: Documentation of the API. + * generic/tclBasic.c (Tcl_CreateInterp): Create the mapping into Tcl. + * generic/tclIOCmd.c (TclChanTruncateObjCmd): Implementation of + Tcl-level truncation API. + * generic/tclIO.c (Tcl_TruncateChannel): Generic C-level + truncation API implementation. + * unix/tclUnixChan.c (FileTruncateProc): Basic implementation of + truncating driver. + 2005-06-06 Kevin B. Kenny <kennykb@acm.org> * win/tclWin32Dll.c: Corrected another buglet in the assembly diff --git a/doc/CrtChannel.3 b/doc/CrtChannel.3 index d4f3a20..570cd2d 100644 --- a/doc/CrtChannel.3 +++ b/doc/CrtChannel.3 @@ -5,13 +5,13 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: CrtChannel.3,v 1.29 2005/05/10 18:33:54 kennykb Exp $ +'\" RCS: @(#) $Id: CrtChannel.3,v 1.30 2005/06/06 23:45:42 dkf Exp $ .so man.macros .TH Tcl_CreateChannel 3 8.4 Tcl "Tcl Library Procedures" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME -Tcl_CreateChannel, Tcl_GetChannelInstanceData, Tcl_GetChannelType, Tcl_GetChannelName, Tcl_GetChannelHandle, Tcl_GetChannelMode, Tcl_GetChannelBufferSize, Tcl_SetChannelBufferSize, Tcl_NotifyChannel, Tcl_BadChannelOption, Tcl_ChannelName, Tcl_ChannelVersion, Tcl_ChannelBlockModeProc, Tcl_ChannelCloseProc, Tcl_ChannelClose2Proc, Tcl_ChannelInputProc, Tcl_ChannelOutputProc, Tcl_ChannelSeekProc, Tcl_ChannelWideSeekProc, Tcl_ChannelSetOptionProc, Tcl_ChannelGetOptionProc, Tcl_ChannelWatchProc, Tcl_ChannelGetHandleProc, Tcl_ChannelFlushProc, Tcl_ChannelHandlerProc, Tcl_ChannelThreadActionProc, Tcl_IsChannelShared, Tcl_IsChannelRegistered, Tcl_CutChannel, Tcl_SpliceChannel, Tcl_IsChannelExisting, Tcl_ClearChannelHandlers, Tcl_GetChannelThread, Tcl_ChannelBuffered \- procedures for creating and manipulating channels +Tcl_CreateChannel, Tcl_GetChannelInstanceData, Tcl_GetChannelType, Tcl_GetChannelName, Tcl_GetChannelHandle, Tcl_GetChannelMode, Tcl_GetChannelBufferSize, Tcl_SetChannelBufferSize, Tcl_NotifyChannel, Tcl_BadChannelOption, Tcl_ChannelName, Tcl_ChannelVersion, Tcl_ChannelBlockModeProc, Tcl_ChannelCloseProc, Tcl_ChannelClose2Proc, Tcl_ChannelInputProc, Tcl_ChannelOutputProc, Tcl_ChannelSeekProc, Tcl_ChannelWideSeekProc, Tcl_ChannelTruncateProc, Tcl_ChannelSetOptionProc, Tcl_ChannelGetOptionProc, Tcl_ChannelWatchProc, Tcl_ChannelGetHandleProc, Tcl_ChannelFlushProc, Tcl_ChannelHandlerProc, Tcl_ChannelThreadActionProc, Tcl_IsChannelShared, Tcl_IsChannelRegistered, Tcl_CutChannel, Tcl_SpliceChannel, Tcl_IsChannelExisting, Tcl_ClearChannelHandlers, Tcl_GetChannelThread, Tcl_ChannelBuffered \- procedures for creating and manipulating channels .SH SYNOPSIS .nf \fB#include <tcl.h>\fR @@ -98,6 +98,11 @@ Tcl_DriverWideSeekProc * Tcl_DriverThreadActionProc * \fBTcl_ChannelThreadActionProc\fR(\fItypePtr\fR) .sp +.VS 8.5 +Tcl_DriverTruncateProc * +\fBTcl_ChannelTruncateProc\fR(\fItypePtr\fR) +.VE 8.5 +.sp Tcl_DriverSetOptionProc * \fBTcl_ChannelSetOptionProc\fR(\fItypePtr\fR) .sp @@ -314,22 +319,25 @@ details about the old structure. The \fBTcl_ChannelType\fR structure contains the following fields: .CS typedef struct Tcl_ChannelType { - char *\fItypeName\fR; - Tcl_ChannelTypeVersion \fIversion\fR; - Tcl_DriverCloseProc *\fIcloseProc\fR; - Tcl_DriverInputProc *\fIinputProc\fR; - Tcl_DriverOutputProc *\fIoutputProc\fR; - Tcl_DriverSeekProc *\fIseekProc\fR; - Tcl_DriverSetOptionProc *\fIsetOptionProc\fR; - Tcl_DriverGetOptionProc *\fIgetOptionProc\fR; - Tcl_DriverWatchProc *\fIwatchProc\fR; - Tcl_DriverGetHandleProc *\fIgetHandleProc\fR; - Tcl_DriverClose2Proc *\fIclose2Proc\fR; - Tcl_DriverBlockModeProc *\fIblockModeProc\fR; - Tcl_DriverFlushProc *\fIflushProc\fR; - Tcl_DriverHandlerProc *\fIhandlerProc\fR; - Tcl_DriverWideSeekProc *\fIwideSeekProc\fR; - Tcl_DriverThreadActionProc *\fIthreadActionProc\fR; + char *\fItypeName\fR; + Tcl_ChannelTypeVersion \fIversion\fR; + Tcl_DriverCloseProc *\fIcloseProc\fR; + Tcl_DriverInputProc *\fIinputProc\fR; + Tcl_DriverOutputProc *\fIoutputProc\fR; + Tcl_DriverSeekProc *\fIseekProc\fR; + Tcl_DriverSetOptionProc *\fIsetOptionProc\fR; + Tcl_DriverGetOptionProc *\fIgetOptionProc\fR; + Tcl_DriverWatchProc *\fIwatchProc\fR; + Tcl_DriverGetHandleProc *\fIgetHandleProc\fR; + Tcl_DriverClose2Proc *\fIclose2Proc\fR; + Tcl_DriverBlockModeProc *\fIblockModeProc\fR; + Tcl_DriverFlushProc *\fIflushProc\fR; + Tcl_DriverHandlerProc *\fIhandlerProc\fR; + Tcl_DriverWideSeekProc *\fIwideSeekProc\fR; +.VS 8.5 + Tcl_DriverThreadActionProc *\fIthreadActionProc\fR; + Tcl_DriverTruncateProc *\fItruncateProc\fR; +.VE 8.5 } Tcl_ChannelType; .CE .PP @@ -349,6 +357,9 @@ structure, the following functions should be used to obtain the values: \fBTcl_ChannelClose2Proc\fR, \fBTcl_ChannelInputProc\fR, \fBTcl_ChannelOutputProc\fR, \fBTcl_ChannelSeekProc\fR, \fBTcl_ChannelWideSeekProc\fR, \fBTcl_ChannelThreadActionProc\fR, +.VS 8.5 +\fBTcl_ChannelTruncateProc\fR, +.VE 8.5 \fBTcl_ChannelSetOptionProc\fR, \fBTcl_ChannelGetOptionProc\fR, \fBTcl_ChannelWatchProc\fR, \fBTcl_ChannelGetHandleProc\fR, \fBTcl_ChannelFlushProc\fR, or \fBTcl_ChannelHandlerProc\fR. @@ -373,7 +384,10 @@ that you require. \fBTCL_CHANNEL_VERSION_2\fR is the minimum recommended. \fBTCL_CHANNEL_VERSION_3\fR must be set to specifiy the \fIwideSeekProc\fR member. .VS 8.5 \fBTCL_CHANNEL_VERSION_4\fR must be set to specifiy the -\fIthreadActionProc\fR member (includes \fIwideSeekProc\fR). +\fIthreadActionProc\fR member (includes \fIwideSeekProc\fR), and +\fBTCL_CHANNEL_VERSION_5\fR must be set to specify the +\fItruncateProc\fR member (includes \fIwideSeekProc\fR and +\fIthreadActionProc\fR). .VE 8.5 If it is not set to any of these, then this \fBTcl_ChannelType\fR is assumed to have the original structure. See @@ -382,7 +396,11 @@ and function with either structures, stacked channels must be of at least \fBTCL_CHANNEL_VERSION_2\fR to function correctly. .PP This value can be retrieved with \fBTcl_ChannelVersion\fR, which returns -one of \fBTCL_CHANNEL_VERSION_4\fR, \fBTCL_CHANNEL_VERSION_3\fR, +one of +.VS 8.5 +\fBTCL_CHANNEL_VERSION_5\fR, \fBTCL_CHANNEL_VERSION_4\fR, +.VE 8.5 +\fBTCL_CHANNEL_VERSION_3\fR, \fBTCL_CHANNEL_VERSION_2\fR or \fBTCL_CHANNEL_VERSION_1\fR. .SS BLOCKMODEPROC .PP @@ -798,8 +816,8 @@ might be maintaining using the calling thread as the associate. See .PP .CS typedef void Tcl_DriverThreadActionProc( - ClientData \fIinstanceData\fR, - int \fIaction\fR); + ClientData \fIinstanceData\fR, + int \fIaction\fR); .CE .PP \fIInstanceData\fR is the same as the value passed to @@ -807,7 +825,26 @@ typedef void Tcl_DriverThreadActionProc( .PP These values can be retrieved with \fBTcl_ChannelThreadActionProc\fR, which returns a pointer to the function. - +.SS "TRUNCATEPROC" +.PP +The \fItruncateProc\fR field contains the address of the function +called by the generic layer when a channel is truncated to some +length. It can be NULL. +.PP +.CS +typedef int Tcl_DriverTruncateProc( + ClientData \fIinstanceData\fR, + Tcl_WideInt \fIlength\fR); +.CE +.PP +\fIInstanceData\fR is the same as the value passed to +\fBTcl_CreateChannel\fR when this channel was created, and +\fIlength\fR is the new length of the underlying file, which should +not be negative. The result should be 0 on success or an errno code +(suitable for use with \fBTcl_SetErrno\fR) on failure. +.PP +These values can be retrieved with \fBTcl_ChannelTruncateProc\fR, +which returns a pointer to the function. .SH TCL_BADCHANNELOPTION .PP This procedure generates a "bad option" error message in an @@ -883,6 +920,7 @@ typedef struct Tcl_ChannelType { Tcl_DriverBlockModeProc *\fIblockModeProc\fR; Tcl_DriverFlushProc *\fIflushProc\fR; Tcl_DriverHandlerProc *\fIhandlerProc\fR; + Tcl_DriverTruncateProc *\fItruncateProc\fR; } Tcl_ChannelType; .CE .PP diff --git a/doc/OpenFileChnl.3 b/doc/OpenFileChnl.3 index 73494ce..a5caee4 100644 --- a/doc/OpenFileChnl.3 +++ b/doc/OpenFileChnl.3 @@ -4,13 +4,13 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: OpenFileChnl.3,v 1.31 2005/05/10 18:33:56 kennykb Exp $ +'\" RCS: @(#) $Id: OpenFileChnl.3,v 1.32 2005/06/06 23:45:42 dkf Exp $ .so man.macros .TH Tcl_OpenFileChannel 3 8.3 Tcl "Tcl Library Procedures" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME -Tcl_OpenFileChannel, Tcl_OpenCommandChannel, Tcl_MakeFileChannel, Tcl_GetChannel, Tcl_GetChannelNames, Tcl_GetChannelNamesEx, Tcl_RegisterChannel, Tcl_UnregisterChannel, Tcl_DetachChannel, Tcl_IsStandardChannel, Tcl_Close, Tcl_ReadChars, Tcl_Read, Tcl_GetsObj, Tcl_Gets, Tcl_WriteObj, Tcl_WriteChars, Tcl_Write, Tcl_Flush, Tcl_Seek, Tcl_Tell, Tcl_GetChannelOption, Tcl_SetChannelOption, Tcl_Eof, Tcl_InputBlocked, Tcl_InputBuffered, Tcl_OutputBuffered, Tcl_Ungets, Tcl_ReadRaw, Tcl_WriteRaw \- buffered I/O facilities using channels +Tcl_OpenFileChannel, Tcl_OpenCommandChannel, Tcl_MakeFileChannel, Tcl_GetChannel, Tcl_GetChannelNames, Tcl_GetChannelNamesEx, Tcl_RegisterChannel, Tcl_UnregisterChannel, Tcl_DetachChannel, Tcl_IsStandardChannel, Tcl_Close, Tcl_ReadChars, Tcl_Read, Tcl_GetsObj, Tcl_Gets, Tcl_WriteObj, Tcl_WriteChars, Tcl_Write, Tcl_Flush, Tcl_Seek, Tcl_Tell, Tcl_TruncateChannel, Tcl_GetChannelOption, Tcl_SetChannelOption, Tcl_Eof, Tcl_InputBlocked, Tcl_InputBuffered, Tcl_OutputBuffered, Tcl_Ungets, Tcl_ReadRaw, Tcl_WriteRaw \- buffered I/O facilities using channels .SH SYNOPSIS .nf \fB#include <tcl.h>\fR @@ -99,6 +99,11 @@ Tcl_WideInt Tcl_WideInt \fBTcl_Tell\fR(\fIchannel\fR) .sp +.VS 8.5 +int +\fBTcl_TruncateChannel\fR(\fIchannel, length\fR) +.VE 8.5 +.sp int \fBTcl_GetChannelOption\fR(\fIinterp, channel, optionName, optionValue\fR) .sp @@ -196,6 +201,8 @@ given by \fIseekMode\fR. May be either positive or negative. Relative to which point to seek; used with \fIoffset\fR to calculate the new access point for the channel. Legal values are \fBSEEK_SET\fR, \fBSEEK_CUR\fR, and \fBSEEK_END\fR. +.AP Tcl_WideInt length in +The (non-negative) length to truncate the channel the channel to. .AP "const char" *optionName in The name of an option applicable to this channel, such as \fB\-blocking\fR. May have any of the values accepted by the \fBfconfigure\fR command. @@ -592,6 +599,14 @@ After an error, the access point may or may not have been moved. \fBTcl_Tell\fR returns the current access point for a channel. The returned value is \-1 if the channel does not support seeking. +.SH TCL_TRUNCATECHANNEL +.PP +.VS 8.5 +\fBTcl_TruncateChannel\fR truncates the file underlying \fIchannel\fR +to a given \fIlength\fR of bytes. It returns \fBTCL_OK\fR if the +operation succeeded, and \fBTCL_ERROR\fR otherwise. +.VE 8.5 + .SH TCL_GETCHANNELOPTION .PP \fBTcl_GetChannelOption\fR retrieves, in \fIoptionValue\fR, the value of one of diff --git a/doc/chan.n b/doc/chan.n new file mode 100644 index 0000000..19753cd --- /dev/null +++ b/doc/chan.n @@ -0,0 +1,119 @@ +'\" +'\" Copyright (c) 2005 Donal K. Fellows +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" RCS: @(#) $Id: chan.n,v 1.1 2005/06/06 23:45:41 dkf Exp $ +.so man.macros +.TH chan n 8.5 Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +chan \- Read, write and manipulate channels +.SH SYNOPSIS +\fBchan \fIoption\fR ?\fIarg arg ...\fR? +.BE + +.SH DESCRIPTION +.PP +This command provides several operations for reading from, writing to +and otherwise manipulating open channels (such as have been created +with the \fBopen\fR and \fBsocket\fR commands). \fIOption\fR indicates +what to do with the channel; any unique abbreviation for \fIoption\fR +is acceptable. Valid options are: +.TP +\fBchan blocked \fIchannelId\fR +Test whether the last input operation on the channel called +\fIchannelId\fR failed because it would have otherwise caused the +process to block. +.TP +\fBchan close \fIchannelId\fR +Close and destroy the channel called \fIchannelId\fR. Note that this +deletes all existing file-events registered on the channel. +.TP +\fBchan configure \fIchannelId\fR ?\fIoptionName\fR? ?\fIvalue\fR? ?\fIoptionName value\fR?... +Query or set the configuration options of the channel named +\fIchannelId\fR (see \fBfconfigure\fR for details). +'\" FIXME: describe common channel options here and refer to creator +'\" commands for special option descriptions. +.TP +\fBchan copy \fIinput output\fR ?\fB\-size \fIsize\fR? ?\fB\-command \fIcallback\fR? +Copy the contents of the channel \fIinput\fR, which must have been +opened for reading, to the channel \fIoutput\fR, which must have been +opened for writing. If \fIsize\fR is specified, only that many bytes +will be transferred. If \fIcallback\fR is specified, this command +returns immediately and arranges for \fIcallback\fR to be called when +the requested transfer has completed or an error occurs (assuming that +the event loop is running) with extra arguments appended to +\fIcallback\fR to indicate what happened. +.TP +\fBchan eof \fIchannelId\fR +Test whether the last input operation on the channel called +\fIchannelId\fR failed because the end of the data stream was reached. +.TP +\fBchan event \fIchannelId mode\fR ?\fIscript\fR? +Arrange for the Tcl script \fIscript\fR to be called whenever the +channel called \fIchannelId\fR enters the state described by +\fImode\fR (which must be either \fBreadable\fR or \fBwritable\fR). If +\fIscript\fR is omitted, the currently installed script is returned. +The callback is only performed if the event loop is being serviced. +.TP +\fBchan flush \fIchannelId\fR +Ensures that all pending output for the channel called \fIchannelId\fR +is written. +.TP +\fBchan gets \fIchannelId\fR ?\fIvarName\fR? +Reads a line from the channel called \fIchannelId\fR. If \fIvarName\fR +is not specified, the result of the command will be the line that has +been read (without a trailing newline character) or an empty string +upon error. If \fIvarName\fR is specified, the line that has been read +will be written to the variable called \fIvarName\fR and result will +be the number of characters that have been read or -1 if an error +occurred. +.TP +\fBchan names\fR ?\fIpattern\fR? +Produces a list of all channel names. If \fIpattern\fR is specified, +only those channel names that match it (according to the rules of +\fBstring match\fR) will be returned. +.TP +\fBchan puts\fR ?\fB\-nonewline\fR? ?\fIchannelId\fR? \fIstring\fR +Writes \fIstring\fR to the channel named \fIchannelId\fR (by default, +to the standard output stream) followed by a newline character. If the +optional flag \fB\-nonewline\fR is given, no trailing newline +character is written. +.TP +\fBchan read \fIchannelId\fR ?\fInumChars\fR? +.TP +\fBchan read \fR?\fB\-nonewline\fR? \fIchannelId\fR +In the first form, the result will be the next \fInumChars\fR +characters read from the channel named \fIchannelId\fR; if +\fInumChars\fR is omitted, all characters up to the point when the +channel would signal a failure (whether an end-of-file, blocked or +other error condition) are read. In the second form (i.e. when +\fInumChars\fR has been omitted) the flag \fB\-nonewline\fR may be +given to indicate that any trailing newline in the string that has +been read should be trimmed. +.TP +\fBchan seek \fIchannelId offset\fR ?\fIorigin\fR? +Sets the current position within the underlying data stream for the +channel named \fIchannelId\fR to be \fIoffset\fR bytes relative to +\fIorigin\fR. \fIOrigin\fR should be one of \fBstart\fR (the default +origin), \fBcurrent\fR or \fBend\fR. +.TP +\fBchan tell \fIchannelId\fR +Reports the current byte offset within the underlying data stream for +the channel named \fIchannelId\fR. +.TP +\fBchan truncate \fIchannelId\fR ?\fIlength\fR? +Sets the byte length of the underlying data stream for the channel +named \fIchannelId\fR to be \fIlength\fR (or to the current byte +offset within the underlying data stream if \fIlength\fR is omitted). + +.SH "SEE ALSO" +close(n), eof(n), fblocked(n), fconfigure(n), fcopy(n), file(n), +fileevent(n), flush(n), gets(n), open(n), puts(n), read(n), seek(n), +socket(n), tell(n) + +.SH KEYWORDS +channel, input, output, events, offset diff --git a/generic/tcl.decls b/generic/tcl.decls index 82219aa..6dd904e 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: tcl.decls,v 1.111 2005/05/10 18:34:04 kennykb Exp $ +# RCS: @(#) $Id: tcl.decls,v 1.112 2005/06/06 23:45:42 dkf Exp $ library tcl @@ -2004,6 +2004,15 @@ declare 558 generic { int Tcl_GetBignumFromObj( Tcl_Interp* interp, Tcl_Obj* obj, mp_int* value ) } +# TIP #208: +declare 559 generic { + int Tcl_TruncateChannel(Tcl_Channel chan, Tcl_WideInt length) +} +declare 560 generic { + Tcl_DriverTruncateProc *Tcl_ChannelTruncateProc( + Tcl_ChannelType *chanTypePtr) +} + ############################################################################## # Define the platform specific public Tcl interface. These functions are diff --git a/generic/tcl.h b/generic/tcl.h index bdb8e10..ffbb166 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tcl.h,v 1.198 2005/05/10 18:34:05 kennykb Exp $ + * RCS: @(#) $Id: tcl.h,v 1.199 2005/06/06 23:45:42 dkf Exp $ */ #ifndef _TCL @@ -1461,6 +1461,7 @@ typedef void (Tcl_ScaleTimeProc) _ANSI_ARGS_ ((Tcl_Time* timebuf, ClientData cli #define TCL_CHANNEL_VERSION_2 ((Tcl_ChannelTypeVersion) 0x2) #define TCL_CHANNEL_VERSION_3 ((Tcl_ChannelTypeVersion) 0x3) #define TCL_CHANNEL_VERSION_4 ((Tcl_ChannelTypeVersion) 0x4) +#define TCL_CHANNEL_VERSION_5 ((Tcl_ChannelTypeVersion) 0x5) /* * TIP #218: Channel Actions, Ids for Tcl_DriverThreadActionProc @@ -1504,8 +1505,11 @@ typedef Tcl_WideInt (Tcl_DriverWideSeekProc) _ANSI_ARGS_(( int mode, int *errorCodePtr)); /* TIP #218, Channel Thread Actions */ -typedef void (Tcl_DriverThreadActionProc) _ANSI_ARGS_ (( +typedef void (Tcl_DriverThreadActionProc) _ANSI_ARGS_ (( ClientData instanceData, int action)); +/* TIP #208, File Truncation (etc.) */ +typedef int (Tcl_DriverTruncateProc) _ANSI_ARGS_(( + ClientData instanceData, Tcl_WideInt length)); /* * The following declarations either map ckalloc and ckfree to @@ -1596,16 +1600,24 @@ typedef struct Tcl_ChannelType { * handle 64-bit offsets. May be * NULL, and must be NULL if * seekProc is NULL. */ - - /* - * Only valid in TCL_CHANNEL_VERSION_4 channels or later - * TIP #218, Channel Thread Actions - */ - Tcl_DriverThreadActionProc *threadActionProc; + /* + * Only valid in TCL_CHANNEL_VERSION_4 channels or later + * TIP #218, Channel Thread Actions + */ + Tcl_DriverThreadActionProc *threadActionProc; /* Procedure to call to notify * the driver of thread specific * activity for a channel. * May be NULL. */ + /* + * Only valid TCL_CHANNEL_VERSION_5 channels or later + * TIP#208 (part relating to truncation) + */ + Tcl_DriverTruncateProc *truncateProc; + /* Procedure to call to truncate the + * underlying file to a particular + * length. May be NULL if the channel + * does not support truncation. */ } Tcl_ChannelType; /* diff --git a/generic/tclBasic.c b/generic/tclBasic.c index bc1ff3d..6935782 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclBasic.c,v 1.159 2005/06/01 21:38:40 dgp Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.160 2005/06/06 23:45:43 dkf Exp $ */ #include "tclInt.h" @@ -527,6 +527,9 @@ Tcl_CreateInterp() Tcl_CreateObjCommand(interp, "::tcl::clock::Oldscan", TclClockOldscanObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); + Tcl_CreateObjCommand(interp, "::tcl::chan::Truncate", + TclChanTruncateObjCmd, (ClientData) NULL, + (Tcl_CmdDeleteProc*) NULL); /* * Register the built-in functions diff --git a/generic/tclIO.c b/generic/tclIO.c index ee37035..06fd55b 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIO.c,v 1.86 2005/05/10 18:34:38 kennykb Exp $ + * RCS: @(#) $Id: tclIO.c,v 1.87 2005/06/06 23:45:45 dkf Exp $ */ #include "tclInt.h" @@ -5777,6 +5777,77 @@ Tcl_TellOld(chan) /* *--------------------------------------------------------------------------- * + * Tcl_TruncateChannel -- + * + * Truncate a channel to the given length. + * + * Results: + * TCL_OK on success, TCL_ERROR if the operation failed (e.g. is + * not supported by the type of channel, or the underlying OS + * operation failed in some way). + * + * Side effects: + * Seeks the channel to the current location. Sets errno on OS + * error. + * + *--------------------------------------------------------------------------- + */ + +int +Tcl_TruncateChannel(chan, length) + Tcl_Channel chan; + Tcl_WideInt length; +{ + Channel *chanPtr = (Channel *) chan; + Tcl_DriverTruncateProc *truncateProc = + Tcl_ChannelTruncateProc(chanPtr->typePtr); + int result; + + if (truncateProc == NULL) { + /* + * Feature not supported and it's not emulatable. Pretend it's + * returned an EINVAL, a very generic error! + */ + Tcl_SetErrno(EINVAL); + return TCL_ERROR; + } + + if (!(chanPtr->stateptr->flags & TCL_WRITABLE)) { + /* + * We require that the file was opened of writing. Do that + * check now so that we only flush if we think we're going to + * succeed. + */ + Tcl_SetErrno(EINVAL); + return TCL_ERROR; + } + + /* + * Seek first to force a total flush of all pending buffers and + * ditch any pre-read input data. + */ + + if (Tcl_Seek(chan, 0, SEEK_CUR) == Tcl_LongAsWide(-1)) { + return TCL_ERROR; + } + + /* + * We're all flushed to disk now and we also don't have any + * unfortunate input baggage around either; can truncate with + * impunity. + */ + + result = truncateProc(chanPtr->instanceData, length); + if (result != 0) { + Tcl_SetErrno(result); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * * CheckChannelErrors -- * * See if the channel is in an ready state and can perform the @@ -9367,6 +9438,17 @@ Tcl_ChannelThreadActionProc(chanTypePtr) } } +Tcl_DriverTruncateProc * +Tcl_ChannelTruncateProc(chanTypePtr) + Tcl_ChannelType *chanTypePtr; /* Pointer to channel type. */ +{ + if (HaveVersion(chanTypePtr, TCL_CHANNEL_VERSION_5)) { + return chanTypePtr->truncateProc; + } else { + return NULL; + } +} + #if 0 /* * For future debugging work, a simple function to print the flags of diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index abd789c..ebc5c77 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIOCmd.c,v 1.24 2005/05/10 18:34:40 kennykb Exp $ + * RCS: @(#) $Id: tclIOCmd.c,v 1.25 2005/06/06 23:45:46 dkf Exp $ */ #include "tclInt.h" @@ -1538,3 +1538,77 @@ Tcl_FcopyObjCmd(dummy, interp, objc, objv) return TclCopyChannel(interp, inChan, outChan, toRead, cmdPtr); } + +/* + *---------------------------------------------------------------------- + * + * Tcl_ChanTruncateObjCmd -- + * + * This procedure is invoked to process the "chan truncate" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Truncates a channel (or rather a file underlying a channel). + * + *---------------------------------------------------------------------- + */ + +int +TclChanTruncateObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + Tcl_Channel chan; + Tcl_Obj *cmdPtr; + int mode; + Tcl_WideInt targetLength; + char *chanName; + + if ((objc < 2) || (objc > 3)) { + Tcl_WrongNumArgs(interp, 1, objv, "channelId ?length?"); + return TCL_ERROR; + } + chanName = TclGetString(objv[1]); + chan = Tcl_GetChannel(interp, chanName, &mode); + if (chan == NULL) { + return TCL_ERROR; + } + + if (objc == 3) { + /* + * User is supplying an explicit length. + */ + if (Tcl_GetWideIntFromObj(interp, objv[2], &length) != TCL_OK) { + return TCL_ERROR; + } + if (length < 0) { + Tcl_AppendResult(interp, + "cannot truncate to negative length of file", NULL); + return TCL_ERROR; + } + } else { + /* + * User wants to truncate to the current file position. + */ + length = Tcl_Tell(chan); + if (length == Tcl_WideAsLong(-1)) { + Tcl_AppendResult(interp, + "could not determine current location in \"", chanName, + "\": ", Tcl_PosixError(interp), NULL); + return TCL_ERROR; + } + } + + if (Tcl_TruncateChannel(chan, length) != TCL_OK) { + Tcl_AppendResult(interp, "error during truncate on \"", chanName, + "\": ", Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } + + return TCL_OK; +} diff --git a/generic/tclInt.h b/generic/tclInt.h index 7efd7c1..0e075bb 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclInt.h,v 1.232 2005/05/30 00:04:47 dkf Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.233 2005/06/06 23:45:44 dkf Exp $ */ #ifndef _TCLINT @@ -2141,6 +2141,9 @@ MODULE_SCOPE int Tcl_CatchObjCmd _ANSI_ARGS_((ClientData clientData, MODULE_SCOPE int Tcl_CdObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +MODULE_SCOPE int TclChanTruncateObjCmd _ANSI_ARGS_(( + ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[])); MODULE_SCOPE int TclClockClicksObjCmd _ANSI_ARGS_(( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); diff --git a/library/init.tcl b/library/init.tcl index 0623488..d93a653 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -3,7 +3,7 @@ # Default system startup file for Tcl-based applications. Defines # "unknown" procedure and auto-load facilities. # -# RCS: @(#) $Id: init.tcl,v 1.76 2005/05/24 19:13:45 dgp Exp $ +# RCS: @(#) $Id: init.tcl,v 1.77 2005/06/06 23:45:46 dkf Exp $ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. @@ -72,6 +72,26 @@ namespace eval tcl { lappend Path $Dir unsupported::EncodingDirs $Path } + + # Set up the 'chan' ensemble + namespace eval chan { + namespace ensemble create -command ::chan -map { + blocked ::fblocked + close ::close + configure ::fconfigure + copy ::fcopy + eof ::eof + event ::fileevent + flush ::flush + gets ::gets + names {::file channels} + puts ::puts + read ::read + seek ::seek + tell ::tell + truncate ::tcl::chan::Truncate + } + } } # Windows specific end of initialization diff --git a/tests/chan.test b/tests/chan.test new file mode 100644 index 0000000..ae866bd --- /dev/null +++ b/tests/chan.test @@ -0,0 +1,85 @@ +# This file contains a collection of tests for the Tcl built-in 'chan' +# command. Sourcing this file into Tcl runs the tests and generates +# output for errors. No output means no errors were found. +# +# Copyright (c) 2005 Donal K. Fellows +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: chan.test,v 1.1 2005/06/06 23:45:46 dkf Exp $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest 2 + namespace import -force ::tcltest::* +} + +test chan-1.1 {chan command general syntax} -body { + chan +} -returnCodes error -result "wrong # args: should be \"chan subcommand ...\"" +test chan-1.2 {chan command general syntax} -body { + chan FOOBAR +} -returnCodes error -result "unknown or ambiguous command \"FOOBAR\": should be one of blocked, close, configure, copy, eof, event, flush, gets, names, puts, read, seek, tell, and truncate" + +test chan-2.1 {chan command: blocked subcommand} -body { + chan blocked foo bar +} -returnCodes error -result "wrong # args: should be \"chan blocked channelId\"" + +test chan-3.1 {chan command: close subcommand} -body { + chan close foo bar +} -returnCodes error -result "wrong # args: should be \"chan close channelId\"" + +test chan-4.1 {chan command: configure subcommand} -body { + chan blocked +} -returnCodes error -result "wrong # args: should be \"chan configure channelId ?optionName? ?value? ?optionName value?...\"" + +test chan-5.1 {chan command: copy subcommand} -body { + chan copy foo +} -returnCodes error -result "wrong # args: should be \"chan copy input output ?-size size? ?-command callback?\"" + +test chan-6.1 {chan command: eof subcommand} -body { + chan eof foo bar +} -returnCodes error -result "wrong # args: should be \"chan eof channelId\"" + +test chan-7.1 {chan command: event subcommand} -body { + chan event foo +} -returnCodes error -result "wrong # args: should be \"chan event channelId mode ?script?\"" + +test chan-8.1 {chan command: flush subcommand} -body { + chan flush foo bar +} -returnCodes error -result "wrong # args: should be \"chan flush channelId\"" + +test chan-9.1 {chan command: gets subcommand} -body { + chan gets +} -returnCodes error -result "wrong # args: should be \"chan gets channelId ?varName?\"" + +test chan-10.1 {chan command: names subcommand} -body { + chan names foo bar +} -returnCodes error -result "wrong # args: should be \"chan names ?pattern?\"" + +test chan-11.1 {chan command: puts subcommand} -body { + chan puts foo bar foo bar +} -returnCodes error -result "wrong # args: should be \"chan puts ?-nonewline? ?channelId? string\"" + +test chan-12.1 {chan command: read subcommand} -body { + chan read foo bar +} -returnCodes error -result "wrong # args: should be \"chan read channelId ?numChars?\" or \"chan read ?-nonewline? channelId\"" + +test chan-13.1 {chan command: seek subcommand} -body { + chan seek foo bar foo bar +} -returnCodes error -result "wrong # args: should be \"chan seek channelId offset ?origin?\"" + +test chan-14.1 {chan command: tell subcommand} -body { + chan tell foo bar +} -returnCodes error -result "wrong # args: should be \"chan tell channelId\"" + +test chan-15.1 {chan command: truncate subcommand} -body { + chan truncate foo bar foo bar +} -returnCodes error -result "wrong \# args: should be \"chan truncate channelId ?length?\"" + +cleanupTests +return + +# Local Variables: +# mode: tcl +# End: diff --git a/unix/tclUnixChan.c b/unix/tclUnixChan.c index abc2edc..c055f83 100644 --- a/unix/tclUnixChan.c +++ b/unix/tclUnixChan.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclUnixChan.c,v 1.57 2005/05/14 20:46:48 das Exp $ + * RCS: @(#) $Id: tclUnixChan.c,v 1.58 2005/06/06 23:45:46 dkf Exp $ */ #include "tclInt.h" /* Internal definitions for Tcl. */ @@ -241,8 +241,10 @@ static int FileSeekProc _ANSI_ARGS_((ClientData instanceData, long offset, int mode, int *errorCode)); #ifdef DEPRECATED static void FileThreadActionProc _ANSI_ARGS_ (( - ClientData instanceData, int action)); + ClientData instanceData, int action)); #endif +static int FileTruncateProc _ANSI_ARGS_ ((ClientData instanceData, + Tcl_WideInt length)); static Tcl_WideInt FileWideSeekProc _ANSI_ARGS_((ClientData instanceData, Tcl_WideInt offset, int mode, int *errorCode)); static void FileWatchProc _ANSI_ARGS_((ClientData instanceData, @@ -325,6 +327,7 @@ static Tcl_ChannelType fileChannelType = { #else NULL, #endif + FileTruncateProc, /* truncate proc. */ }; #ifdef SUPPORTS_TTY @@ -354,6 +357,7 @@ static Tcl_ChannelType ttyChannelType = { NULL, /* handler proc. */ NULL, /* wide seek proc. */ NULL, /* thread action proc. */ + NULL, /* truncate proc. */ }; #endif /* SUPPORTS_TTY */ @@ -379,6 +383,7 @@ static Tcl_ChannelType tcpChannelType = { NULL, /* handler proc. */ NULL, /* wide seek proc. */ NULL, /* thread action proc. */ + NULL, /* truncate proc. */ }; @@ -3318,3 +3323,45 @@ FileThreadActionProc (instanceData, action) } } #endif + +/* + *---------------------------------------------------------------------- + * + * FileTruncateProc -- + * + * Truncates a file to a given length. + * + * Results: + * 0 if the operation succeeded, and -1 if it failed (in which + * case *errorCodePtr will be set to errno). + * + * Side effects: + * The underlying file is potentially truncated. This can have a + * wide variety of side effects, including moving file pointers + * that point at places later in the file than the truncate + * point. + * + *---------------------------------------------------------------------- + */ + +int +FileTruncateProc(instanceData, length) + ClientData instanceData; + Tcl_WideInt length; +{ + FileState *fsPtr = (FileState *) instanceData; + int result; + +#ifdef HAVE_TYPE_OFF64_T + /* + * We assume this goes with the type for now... + */ + result = ftruncate64(fsPtr->fd, (off64_t) length); +#else + result = ftruncate(fsPtr->fd, (off_t) length); +#endif + if (result) { + return errno; + } + return 0; +} |