diff options
| -rw-r--r-- | ChangeLog | 10 | ||||
| -rw-r--r-- | doc/chan.n | 12 | ||||
| -rw-r--r-- | generic/tclBasic.c | 6 | ||||
| -rw-r--r-- | generic/tclIOCmd.c | 70 | ||||
| -rw-r--r-- | generic/tclInt.h | 5 | ||||
| -rw-r--r-- | library/init.tcl | 4 | ||||
| -rw-r--r-- | libtommath/bn_mp_div.c | 6 | ||||
| -rw-r--r-- | tests/chan.test | 114 | ||||
| -rw-r--r-- | tests/ioCmd.test | 4 |
9 files changed, 220 insertions, 11 deletions
@@ -1,5 +1,15 @@ 2006-12-01 Don Porter <dgp@users.sourceforge.net> + TIP#287 IMPLEMENTATION + + * doc/chan.n: New subcommand [chan pending]. + * generic/tclBasic.c: Thanks to Michael Cleverly for proposal + * generic/tclInt.h: and implementation. + * generic/tclIOCmd.c: + * library/init.tcl: + * tests/chan.test: + * tests/ioCmd.test: + TIP#298 IMPLEMENTATION * generic/tcl.decls: Tcl_GetBignumAndClearObj -> Tcl_TakeBignumFromObj. @@ -4,7 +4,7 @@ '\" 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.6 2006/11/16 09:34:17 dkf Exp $ +'\" RCS: @(#) $Id: chan.n,v 1.7 2006/12/01 15:55:44 dgp Exp $ .so man.macros .TH chan n 8.5 Tcl "Tcl Built-In Commands" .BS @@ -493,6 +493,16 @@ 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 pending \fImode channelId\fR +. +Depending on whether \fImode\fr is "input" or "output", returns the number of +bytes of input or output (respectively) currently buffered +internally for \fIchannelId\fr (especially useful in a readable event +callback to impose application-specific limits on input line lengths to avoid +a potential denial-of-service attack where a hostile user crafts +an extremely long line that exceeds the available memory to buffer it). +Returns -1 if the channel was not opened for the mode in question. +.TP \fBchan postevent \fIchannelId eventSpec\fR . This subcommand is used by command handlers specified with \fBchan diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 5df0a81..a3fb387 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.222 2006/11/29 15:01:26 dgp Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.223 2006/12/01 15:55:44 dgp Exp $ */ #include "tclInt.h" @@ -574,6 +574,10 @@ Tcl_CreateInterp(void) Tcl_CreateObjCommand(interp, "::tcl::chan::rPostevent", TclChanPostEventObjCmd, (ClientData) NULL, NULL); + /* TIP #287 */ + Tcl_CreateObjCommand(interp, "::tcl::chan::Pending", + TclChanPendingObjCmd, (ClientData) NULL, NULL); + /* * Register the built-in functions. This is empty now that they are * implemented as commands in the ::tcl::mathfunc namespace. diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index 4b5974b..c2c1bb8 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.34 2006/07/20 06:17:39 das Exp $ + * RCS: @(#) $Id: tclIOCmd.c,v 1.35 2006/12/01 15:55:44 dgp Exp $ */ #include "tclInt.h" @@ -1619,6 +1619,74 @@ Tcl_FcopyObjCmd( } /* + *--------------------------------------------------------------------------- + * + * TclChanPendingObjCmd -- + * + * This function is invoked to process the Tcl "chan pending" + * command (TIP #287). See the user documentation for details on + * what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Sets interp's result to the number of bytes of buffered input or + * output (depending on whether the first argument is "input" or + * "output"), or -1 if the channel wasn't opened for that mode. + * + *--------------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +TclChanPendingObjCmd( + ClientData unused, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *CONST objv[]) /* Argument objects. */ +{ + Tcl_Channel chan; + int index, mode; + char *arg; + static CONST char *options[] = {"input", "output", (char *) NULL}; + enum options {PENDING_INPUT, PENDING_OUTPUT}; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "mode channelId"); + return TCL_ERROR; + } + + if (Tcl_GetIndexFromObj(interp, objv[1], options, "mode", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } + + arg = Tcl_GetString(objv[2]); + chan = Tcl_GetChannel(interp, arg, &mode); + if (chan == NULL) { + return TCL_ERROR; + } + + switch ((enum options) index) { + case PENDING_INPUT: + if ((mode & TCL_READABLE) == 0) { + Tcl_SetObjResult(interp, Tcl_NewIntObj(-1)); + } else { + Tcl_SetObjResult(interp, Tcl_NewIntObj(Tcl_InputBuffered(chan))); + } + return TCL_OK; + case PENDING_OUTPUT: + if ((mode & TCL_WRITABLE) == 0) { + Tcl_SetObjResult(interp, Tcl_NewIntObj(-1)); + } else { + Tcl_SetObjResult(interp, Tcl_NewIntObj(Tcl_OutputBuffered(chan))); + } + return TCL_OK; + } +} + +/* *---------------------------------------------------------------------- * * Tcl_ChanTruncateObjCmd -- diff --git a/generic/tclInt.h b/generic/tclInt.h index 0fb2ebf..e28e849 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.299 2006/11/28 22:20:29 andreas_kupries Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.300 2006/12/01 15:55:45 dgp Exp $ */ #ifndef _TCLINT @@ -2465,6 +2465,9 @@ MODULE_SCOPE int Tcl_CatchObjCmd(ClientData clientData, MODULE_SCOPE int Tcl_CdObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); +MODULE_SCOPE int TclChanPendingObjCmd( + ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]); /* TIP 287 */ MODULE_SCOPE int TclChanTruncateObjCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); diff --git a/library/init.tcl b/library/init.tcl index 13f6d96..838aa7b 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.89 2006/11/20 14:28:03 dkf Exp $ +# RCS: @(#) $Id: init.tcl,v 1.90 2006/12/01 15:55:45 dgp Exp $ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. @@ -78,6 +78,7 @@ namespace eval tcl { # Set up the 'chan' ensemble (TIP #208). namespace eval chan { # TIP #219. Added methods: create, postevent. + # TIP 287. Added method: pending. namespace ensemble create -command ::chan -map { blocked ::tcl::chan::blocked close ::tcl::chan::close @@ -89,6 +90,7 @@ namespace eval tcl { flush ::tcl::chan::flush gets ::tcl::chan::gets names {::file channels} + pending ::tcl::chan::Pending postevent ::tcl::chan::rPostevent puts ::tcl::chan::puts read ::tcl::chan::read diff --git a/libtommath/bn_mp_div.c b/libtommath/bn_mp_div.c index d1b5c48..b80797f 100644 --- a/libtommath/bn_mp_div.c +++ b/libtommath/bn_mp_div.c @@ -87,6 +87,7 @@ LBL_ERR: #else +#if 0 /* Integer signed division. * * c*b + d == a, that is, c = a/b and c = a%b @@ -236,6 +237,7 @@ int mp_div(mp_int* a, mp_int* b, mp_int* c, mp_int* d) return res; } +#endif /* integer signed division. * c*b + d == a [e.g. a/b, c=quotient, d=remainder] @@ -438,5 +440,5 @@ LBL_Q:mp_clear (&q); #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_div.c,v $ */ -/* $Revision: 1.2 $ */ -/* $Date: 2006/12/01 00:31:32 $ */ +/* $Revision: 1.3 $ */ +/* $Date: 2006/12/01 15:55:45 $ */ diff --git a/tests/chan.test b/tests/chan.test index f2376a3..a4d2f8e 100644 --- a/tests/chan.test +++ b/tests/chan.test @@ -7,7 +7,7 @@ # 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.5 2005/08/24 17:56:24 andreas_kupries Exp $ +# RCS: @(#) $Id: chan.test,v 1.6 2006/12/01 15:55:45 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -24,7 +24,7 @@ test chan-1.1 {chan command general syntax} -body { } -returnCodes error -result "wrong # args: should be \"chan subcommand ?argument ...?\"" test chan-1.2 {chan command general syntax} -body { chan FOOBAR -} -returnCodes error -result "unknown or ambiguous subcommand \"FOOBAR\": must be blocked, close, configure, copy, create, eof, event, flush, gets, names, postevent, puts, read, seek, tell, or truncate" +} -returnCodes error -result "unknown or ambiguous subcommand \"FOOBAR\": must be blocked, close, configure, copy, create, eof, event, flush, gets, names, pending, postevent, puts, read, seek, tell, or truncate" test chan-2.1 {chan command: blocked subcommand} -body { chan blocked foo bar @@ -96,6 +96,116 @@ test chan-15.2 {chan command: truncate subcommand} -setup { catch {removeFile $file} } +# TIP 287: chan pending +test chan-16.1 {chan command: pending subcommand} -body { + chan pending +} -returnCodes error -result "wrong # args: should be \"chan pending mode channelId\"" +test chan-16.2 {chan command: pending subcommand} -body { + chan pending stdin +} -returnCodes error -result "wrong # args: should be \"chan pending mode channelId\"" +test chan-16.3 {chan command: pending subcommand} -body { + chan pending stdin stdout stderr +} -returnCodes error -result "wrong # args: should be \"chan pending mode channelId\"" +test chan-16.4 {chan command: pending subcommand} -body { + chan pending {input output} stdout +} -returnCodes error -result "bad mode \"input output\": must be input or output" +test chan-16.5 {chan command: pending input subcommand} -body { + chan pending input stdout +} -result -1 +test chan-16.6 {chan command: pending input subcommand} -body { + chan pending input stdin +} -result 0 +test chan-16.7 {chan command: pending input subcommand} -body { + chan pending input FOOBAR +} -returnCodes error -result "can not find channel named \"FOOBAR\"" +test chan-16.8 {chan command: pending input subcommand} -setup { + set file [makeFile {} testAvailable] + set f [open $file w+] + chan configure $f -translation lf -buffering line +} -body { + chan puts $f foo + chan puts $f bar + chan puts $f baz + chan seek $f 0 + chan gets $f + chan pending input $f +} -result 8 -cleanup { + catch {chan close $f} + catch {removeFile $file} +} +test chan-16.9 {chan command: pending input subcommand} -setup { + proc chan-16.9-accept {sock addr port} { + chan configure $sock -blocking 0 -buffering line -buffersize 32 + chan event $sock readable [list chan-16.9-readable $sock] + } + + proc chan-16.9-readable {sock} { + set r [chan gets $sock line] + set l [string length $line] + set e [chan eof $sock] + set b [chan blocked $sock] + set i [chan pending input $sock] + + lappend ::chan-16.9-data $r $l $e $b $i + + if {$r != -1 || $e || $l || !$b || $i > 128} { + set data [read $sock $i] + lappend ::chan-16.9-data [string range $data 0 2] + lappend ::chan-16.9-data [string range $data end-2 end] + set ::chan-16.9-done 1 + } + } + + proc chan-16.9-client {} { + chan puts -nonewline $::client ABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890 + chan flush $::client + after 100 chan-16.9-client + } + + set ::server [socket -server chan-16.9-accept -myaddr 127.0.0.1 0] + set ::client [socket 127.0.0.1 [lindex [fconfigure $::server -sockname] 2]] + set ::chan-16.9-data [list] + set ::chan-16.9-done 0 +} -body { + after idle chan-16.9-client + vwait ::chan-16.9-done + set ::chan-16.9-data +} -result {-1 0 0 1 36 -1 0 0 1 72 -1 0 0 1 108 -1 0 0 1 144 ABC 890} -cleanup { + catch {chan close $client} + catch {chan close $server} + rename chan-16.9-accept {} + rename chan-16.9-readable {} + rename chan-16.9-client {} + unset -nocomplain ::chan-16.9-data + unset -nocomplain ::chan-16.9-done + unset -nocomplain ::server + unset -nocomplain ::client +} +test chan-16.10 {chan command: pending output subcommand} -body { + chan pending output stdin +} -result -1 +test chan-16.11 {chan command: pending output subcommand} -body { + chan pending output stdout +} -result 0 +test chan-16.12 {chan command: pending output subcommand} -body { + chan pending output FOOBAR +} -returnCodes error -result "can not find channel named \"FOOBAR\"" +test chan-16.13 {chan command: pending output subcommand} -setup { + set file [makeFile {} testPendingOutput] + set f [open $file w+] + chan configure $f -translation lf -buffering full -buffersize 1024 +} -body { + set result [list] + chan puts $f [string repeat x 512] + lappend result [chan pending output $f] + chan flush $f + lappend result [chan pending output $f] +} -result [list 513 0] -cleanup { + unset -nocomplain result + catch {chan close $f} + catch {removeFile $file} +} + cleanupTests return diff --git a/tests/ioCmd.test b/tests/ioCmd.test index e2d8327..9a4a80d 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -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: ioCmd.test,v 1.30 2006/11/03 11:45:34 dkf Exp $ +# RCS: @(#) $Id: ioCmd.test,v 1.31 2006/12/01 15:55:45 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -628,7 +628,7 @@ test iocmd-20.0 {chan, wrong#args} { test iocmd-20.1 {chan, unknown method} { catch {chan foo} msg set msg -} {unknown or ambiguous subcommand "foo": must be blocked, close, configure, copy, create, eof, event, flush, gets, names, postevent, puts, read, seek, tell, or truncate} +} {unknown or ambiguous subcommand "foo": must be blocked, close, configure, copy, create, eof, event, flush, gets, names, pending, postevent, puts, read, seek, tell, or truncate} # --- --- --- --------- --------- --------- # chan create, and method "initalize" |