Index: modules/clay/build/event.tcl ================================================================== --- modules/clay/build/event.tcl +++ modules/clay/build/event.tcl @@ -1,19 +1,11 @@ -::namespace eval ::clay::event {} - -### -# Mark an object for destruction on the next cleanup -### -proc ::clay::destroy args { - if {![info exists ::clay::idle_destroy]} { - set ::clay::idle_destroy {} - } - foreach object $args { - if {$object in $::clay::idle_destroy} continue - lappend ::clay::idle_destroy $object - } -} +if {[info commands ::cron::object_destroy] eq {}} { + # Provide a noop if we aren't running with the cron scheduler + namespace eval ::cron {} + proc ::cron::object_destroy args {} +} +::namespace eval ::clay::event {} ### # Process the queue of objects to be destroyed ### proc ::clay::cleanup {} { @@ -23,10 +15,39 @@ catch {$obj destroy} } } set ::clay::idle_destroy {} } + +proc ::clay::object_create {objname {class {}}} { + #if {$::clay::trace>0} { + # puts [list $objname CREATE] + #} +} + +proc ::clay::object_rename {object newname} { + if {$::clay::trace>0} { + puts [list $object RENAME -> $newname] + } +} + +### +# Mark an objects for destruction on the next cleanup +### +proc ::clay::object_destroy args { + if {![info exists ::clay::idle_destroy]} { + set ::clay::idle_destroy {} + } + foreach objname $args { + if {$::clay::trace>0} { + puts [list $objname DESTROY] + } + ::cron::object_destroy $objname + if {$objname in $::clay::idle_destroy} continue + lappend ::clay::idle_destroy $objname + } +} ### # description: Cancel a scheduled event ### proc ::clay::event::cancel {self {task *}} { Index: modules/clay/build/metaclass.tcl ================================================================== --- modules/clay/build/metaclass.tcl +++ modules/clay/build/metaclass.tcl @@ -107,11 +107,10 @@ # Run the destructor once and only once set self [self] my variable DestroyEvent if {$DestroyEvent} return set DestroyEvent 1 -::clay::object_destroy $self } append body $rawbody ::oo::define [current_class] destructor $body } @@ -193,25 +192,5 @@ proc ::clay::define::Variable {name {default {}}} { set class [current_class] set name [string trimright $name :/] $class clay set variable/ $name $default } - -proc ::clay::object_create {objname {class {}}} { - #if {$::clay::trace>0} { - # puts [list $objname CREATE] - #} -} - -proc ::clay::object_rename {object newname} { - if {$::clay::trace>0} { - puts [list $object RENAME -> $newname] - } -} - -proc ::clay::object_destroy objname { - if {$::clay::trace>0} { - puts [list $objname DESTROY] - } - #::cron::object_destroy $objname -} - Index: modules/clay/build/object.tcl ================================================================== --- modules/clay/build/object.tcl +++ modules/clay/build/object.tcl @@ -459,10 +459,28 @@ if {[$class clay exists {*}$args]} { return $class } } return {} + } + refcount { + my variable refcount + if {![info exists refcount]} { + return 0 + } + return $refcount + } + refcount_incr { + my variable refcount + incr refcount + } + refcount_decr { + my variable refcount + incr refcount -1 + if {$refcount <= 0} { + ::clay::object_destroy [self] + } } replace { set clay [lindex $args 0] } source { Index: modules/clay/clay.man ================================================================== --- modules/clay/clay.man +++ modules/clay/clay.man @@ -445,37 +445,34 @@ Variables registered in the variable property are also initialized (if missing) when the object changes class via the [emph morph] method. - -[call proc [cmd clay::object_create] [arg objname] [opt "[arg class] [const ""]"]] - - -[call proc [cmd clay::object_rename] [arg object] [arg newname]] - - -[call proc [cmd clay::object_destroy] [arg objname]] - [call proc [cmd clay::ensemble_methodbody] [arg ensemble] [arg einfo]] [call proc [cmd clay::define::Ensemble] [arg rawmethod] [opt "[arg args]"]] - -[call proc [cmd clay::destroy] [opt "[arg args]"]] - - Mark an object for destruction on the next cleanup - - - [call proc [cmd clay::cleanup]] Process the queue of objects to be destroyed + + + +[call proc [cmd clay::object_create] [arg objname] [opt "[arg class] [const ""]"]] + + +[call proc [cmd clay::object_rename] [arg object] [arg newname]] + + +[call proc [cmd clay::object_destroy] [opt "[arg args]"]] + + Mark an objects for destruction on the next cleanup + [call proc [cmd clay::event::cancel] [arg self] [opt "[arg task] [const "*"]"]] Index: modules/clay/clay.tcl ================================================================== --- modules/clay/clay.tcl +++ modules/clay/clay.tcl @@ -1027,11 +1027,10 @@ # Run the destructor once and only once set self [self] my variable DestroyEvent if {$DestroyEvent} return set DestroyEvent 1 -::clay::object_destroy $self } append body $rawbody ::oo::define [current_class] destructor $body } proc ::clay::define::Dict {name {values {}}} { @@ -1090,26 +1089,10 @@ proc ::clay::define::Variable {name {default {}}} { set class [current_class] set name [string trimright $name :/] $class clay set variable/ $name $default } -proc ::clay::object_create {objname {class {}}} { - #if {$::clay::trace>0} { - # puts [list $objname CREATE] - #} -} -proc ::clay::object_rename {object newname} { - if {$::clay::trace>0} { - puts [list $object RENAME -> $newname] - } -} -proc ::clay::object_destroy objname { - if {$::clay::trace>0} { - puts [list $objname DESTROY] - } - #::cron::object_destroy $objname -} ### # END: metaclass.tcl ### ### @@ -1771,10 +1754,28 @@ if {[$class clay exists {*}$args]} { return $class } } return {} + } + refcount { + my variable refcount + if {![info exists refcount]} { + return 0 + } + return $refcount + } + refcount_incr { + my variable refcount + incr refcount + } + refcount_decr { + my variable refcount + incr refcount -1 + if {$refcount <= 0} { + ::clay::object_destroy [self] + } } replace { set clay [lindex $args 0] } source { @@ -1907,29 +1908,48 @@ # END: object.tcl ### ### # START: event.tcl ### -::namespace eval ::clay::event { -} -proc ::clay::destroy args { - if {![info exists ::clay::idle_destroy]} { - set ::clay::idle_destroy {} - } - foreach object $args { - if {$object in $::clay::idle_destroy} continue - lappend ::clay::idle_destroy $object - } +if {[info commands ::cron::object_destroy] eq {}} { + # Provide a noop if we aren't running with the cron scheduler + namespace eval ::cron {} + proc ::cron::object_destroy args {} +} +::namespace eval ::clay::event { } proc ::clay::cleanup {} { if {![info exists ::clay::idle_destroy]} return foreach obj $::clay::idle_destroy { if {[info commands $obj] ne {}} { catch {$obj destroy} } } set ::clay::idle_destroy {} +} +proc ::clay::object_create {objname {class {}}} { + #if {$::clay::trace>0} { + # puts [list $objname CREATE] + #} +} +proc ::clay::object_rename {object newname} { + if {$::clay::trace>0} { + puts [list $object RENAME -> $newname] + } +} +proc ::clay::object_destroy args { + if {![info exists ::clay::idle_destroy]} { + set ::clay::idle_destroy {} + } + foreach objname $args { + if {$::clay::trace>0} { + puts [list $objname DESTROY] + } + ::cron::object_destroy $objname + if {$objname in $::clay::idle_destroy} continue + lappend ::clay::idle_destroy $objname + } } proc ::clay::event::cancel {self {task *}} { variable timer_event variable timer_script ADDED modules/httpd/assets/test_cgi.tcl Index: modules/httpd/assets/test_cgi.tcl ================================================================== --- /dev/null +++ modules/httpd/assets/test_cgi.tcl @@ -0,0 +1,14 @@ +#!/usr/bin/tclsh + +puts stdout "Status: 200 OK" +if {$::env(CONTENT_LENGTH) > 0} { + puts stdout "Content-Type: $::env(CONTENT_TYPE)" + set dat [read stdin $::env(CONTENT_LENGTH)] +} else { + puts stdout "Content-Type: text/plain" + set dat "Hi!" +} +puts stdout "Content-Length: [string length $dat]" +puts stdout {} +puts stdout $dat +exit 0 Index: modules/httpd/build/cgi.tcl ================================================================== --- modules/httpd/build/cgi.tcl +++ modules/httpd/build/cgi.tcl @@ -92,10 +92,11 @@ ### my ChannelCopy $chana $chanb -size $length } else { chan flush $chanb } + my clay refcount_incr chan event $chanb readable [info coroutine] yield } @@ -122,10 +123,11 @@ # Output the body. With no -size flag, channel will copy until EOF ### chan configure $chana -translation binary -blocking 0 -buffering full -buffersize 4096 chan configure $chanb -translation binary -blocking 0 -buffering full -buffersize 4096 my ChannelCopy $chana $chanb -chunk 4096 + my clay refcount_decr } ### # For most CGI applications a directory list is vorboten ### Index: modules/httpd/build/core.tcl ================================================================== --- modules/httpd/build/core.tcl +++ modules/httpd/build/core.tcl @@ -32,46 +32,51 @@ ### clay::define ::httpd::mime { method ChannelCopy {in out args} { - set chunk 4096 - set size -1 - foreach {f v} $args { - set [string trim $f -] $v - } - dict set info coroutine [info coroutine] - if {$size>0 && $chunk>$size} { - set chunk $size - } - set bytes 0 - set sofar 0 - set method [self method] - while 1 { - set command {} - set error {} - if {$size>=0} { - incr sofar $bytes - set remaining [expr {$size-$sofar}] - if {$remaining <= 0} { - break - } elseif {$chunk > $remaining} { - set chunk $remaining - } - } - lassign [yieldto chan copy $in $out -size $chunk \ - -command [list [info coroutine] $method]] \ - command bytes error - if {$command ne $method} { - error "Subroutine $method interrupted" - } - if {[string length $error]} { - error $error - } - if {[chan eof $in]} { - break - } + try { + my clay refcount_incr + set chunk 4096 + set size -1 + foreach {f v} $args { + set [string trim $f -] $v + } + dict set info coroutine [info coroutine] + if {$size>0 && $chunk>$size} { + set chunk $size + } + set bytes 0 + set sofar 0 + set method [self method] + while 1 { + set command {} + set error {} + if {$size>=0} { + incr sofar $bytes + set remaining [expr {$size-$sofar}] + if {$remaining <= 0} { + break + } elseif {$chunk > $remaining} { + set chunk $remaining + } + } + lassign [yieldto chan copy $in $out -size $chunk \ + -command [list [info coroutine] $method]] \ + command bytes error + if {$command ne $method} { + error "Subroutine $method interrupted" + } + if {[string length $error]} { + error $error + } + if {[chan eof $in]} { + break + } + } + } finally { + my clay refcount_decr } } ### # Returns a block of HTML @@ -299,16 +304,18 @@ return $pathlist } method wait {mode sock} { + my clay refcount_incr if {[info coroutine] eq {}} { chan event $sock $mode [list set ::httpd::lock_$sock $mode] vwait ::httpd::lock_$sock } else { chan event $sock $mode [info coroutine] yield } chan event $sock $mode {} + my clay refcount_decr } } Index: modules/httpd/build/dispatch.tcl ================================================================== --- modules/httpd/build/dispatch.tcl +++ modules/httpd/build/dispatch.tcl @@ -27,19 +27,13 @@ ::clay::define ::httpd::content.cache { method Dispatch {} { my variable chan - try { - my wait writable $chan - chan configure $chan -translation {binary binary} - chan puts -nonewline $chan [my clay get cache/ data] - } on error {err info} { - my debug [dict get $info -errorinfo] - } finally { - my TransferComplete $chan - } + my wait writable $chan + chan configure $chan -translation {binary binary} + chan puts -nonewline $chan [my clay get cache/ data] } } ::clay::define ::httpd::content.template { Index: modules/httpd/build/file.tcl ================================================================== --- modules/httpd/build/file.tcl +++ modules/httpd/build/file.tcl @@ -129,27 +129,24 @@ if {$chan eq {}} return my wait writable $chan if {![info exists reply_file]} { tailcall my DoOutput } - try { - chan configure $chan -translation {binary binary} - my log HttpAccess {} - ### - # Return a stream of data from a file - ### - set size [file size $reply_file] - my reply set Content-Length $size - append result [my reply output] \n - chan puts -nonewline $chan $result - set reply_chan [open $reply_file r] - my log SendReply [list length $size] - ### - # Output the file contents. With no -size flag, channel will copy until EOF - ### - chan configure $reply_chan -translation {binary binary} -buffersize 4096 -buffering full -blocking 0 - my ChannelCopy $reply_chan $chan -chunk 4096 - } finally { - my TransferComplete $reply_chan $chan - } + chan configure $chan -translation {binary binary} + my log HttpAccess {} + ### + # Return a stream of data from a file + ### + set size [file size $reply_file] + my reply set Content-Length $size + append result [my reply output] \n + chan puts -nonewline $chan $result + set reply_chan [open $reply_file r] + my ChannelRegister $reply_chan + my log SendReply [list length $size] + ### + # Output the file contents. With no -size flag, channel will copy until EOF + ### + chan configure $reply_chan -translation {binary binary} -buffersize 4096 -buffering full -blocking 0 + my ChannelCopy $reply_chan $chan -chunk 4096 } } Index: modules/httpd/build/plugin.tcl ================================================================== --- modules/httpd/build/plugin.tcl +++ modules/httpd/build/plugin.tcl @@ -201,10 +201,10 @@ if {[dict exists $reply delegate]} { $pageobj clay delegate {*}[dict get $reply delegate] } $pageobj dispatch $sock $reply set output [$pageobj output] - catch {$pageobj destroy} + $pageobj clay refcount_decr return $output } } Index: modules/httpd/build/proxy.tcl ================================================================== --- modules/httpd/build/proxy.tcl +++ modules/httpd/build/proxy.tcl @@ -157,13 +157,10 @@ tailcall my DoOutput } my log HttpAccess {} chan event $sock writable [info coroutine] yield - try { - my ProxyRequest $chan $sock - my ProxyReply $sock $chan - } finally { - my TransferComplete $chan $sock - } + my ChannelRegister $sock + my ProxyRequest $chan $sock + my ProxyReply $sock $chan } } Index: modules/httpd/build/reply.man ================================================================== --- modules/httpd/build/reply.man +++ modules/httpd/build/reply.man @@ -131,10 +131,15 @@ [call method [cmd HttpHeaders] [arg sock] [arg ?debug?]] Stream MIME headers from the socket [arg sock], stopping at an empty line. Returns the stream as a block of text. + +[call method [cmd ChannelRegister] [arg chan]] + +Registers a channel that will need to be flushed and closed when the object's destructor +invokes the close method. [call method [cmd dispatch] [arg newsock] [arg datastate]] Take over control of the socket [arg newsock], and store that as the [arg chan] variable for the object. This method runs through all of the steps of reading HTTP headers, generating @@ -266,32 +271,10 @@ [call method [cmd timestamp]] Return the current system time in the format: [example {%a, %d %b %Y %T %Z}] -[call method [cmd TransferComplete] [arg args]] - -Intended to be invoked from [cmd {chan copy}] as a callback. This closes every channel -fed to it on the command line, and then destroys the object. - -[example { - ### - # Output the body - ### - chan configure $sock -translation binary -blocking 0 -buffering full -buffersize 4096 - chan configure $chan -translation binary -blocking 0 -buffering full -buffersize 4096 - if {$length} { - ### - # Send any POST/PUT/etc content - ### - chan copy $sock $chan -size $SIZE -command [info coroutine] - yield - } - catch {close $sock} - chan flush $chan -}] - [call method [cmd Url_Decode] [arg string]] De-httpizes a string. [list_end] Index: modules/httpd/build/reply.tcl ================================================================== --- modules/httpd/build/reply.tcl +++ modules/httpd/build/reply.tcl @@ -97,10 +97,11 @@ # # }] ### ::clay::define ::httpd::reply { superclass ::httpd::mime + Variable ChannelRegister {} Delegate { description {The server object which spawned this reply} } @@ -123,11 +124,11 @@ USER_AGENT {} SESSION {} } constructor {ServerObj args} { - my variable chan dispatched_time uuid + my variable dispatched_time uuid set uuid [namespace tail [self]] set dispatched_time [clock milliseconds] my clay delegate $ServerObj foreach {field value} [::clay::args_to_options {*}$args] { my clay set config $field: $value @@ -138,23 +139,39 @@ # clean up on exit ### destructor { my close } + + # Registers a channel to be closed by the close method + method ChannelRegister args { + my variable ChannelRegister + if {![info exists ChannelRegister]} { + set ChannelRegister {} + } + foreach c $args { + if {$c ni $ChannelRegister} { + lappend ChannelRegister $c + } + } + } ### # Close channels opened by this object ### method close {} { - my variable chan - if {[info exists chan] && $chan ne {}} { - catch {chan event $chan readable {}} - catch {chan event $chan writable {}} - catch {chan flush $chan} - catch {chan close $chan} - set chan {} - } + my variable ChannelRegister + if {![info exists ChannelRegister]} { + return + } + foreach c $ChannelRegister { + catch {chan event $c readable {}} + catch {chan event $c writable {}} + catch {chan flush $c} + catch {chan close $c} + } + set ChannelRegister {} } ### # Record a dispatch event ### @@ -185,11 +202,13 @@ # All other fields are passed along to the [method clay] structure of the object. ### method dispatch {newsock datastate} { my variable chan request try { + my clay refcount_incr set chan $newsock + my ChannelRegister $chan chan event $chan readable {} chan configure $chan -translation {auto crlf} -buffering line if {[dict exists $datastate mixin]} { set mixinmap [dict get $datastate mixin] } else { @@ -221,10 +240,13 @@ my Log_Dispatched my Dispatch } on error {err errdat} { my error 500 $err [dict get $errdat -errorinfo] my DoOutput + } finally { + my close + my clay refcount_decr } } method Dispatch {} { # Invoke the URL implementation. @@ -336,11 +358,10 @@ append result [my reply output] } chan puts -nonewline $chan $result my log HttpAccess {} } - my destroy } ### # For GET requests, converts the QUERY_DATA header into a key/value list. # @@ -421,43 +442,10 @@ } # Manage session data method Session_Load {} {} - - - # Intended to be invoked from [cmd {chan copy}] as a callback. This closes every channel - # fed to it on the command line, and then destroys the object. - # - # [example { - # ### - # # Output the body - # ### - # chan configure $sock -translation binary -blocking 0 -buffering full -buffersize 4096 - # chan configure $chan -translation binary -blocking 0 -buffering full -buffersize 4096 - # if {$length} { - # ### - # # Send any POST/PUT/etc content - # ### - # chan copy $sock $chan -size $SIZE -command [info coroutine] - # yield - # } - # catch {close $sock} - # chan flush $chan - # }] - method TransferComplete args { - my log TransferComplete - set chan {} - foreach c $args { - catch {chan event $c readable {}} - catch {chan event $c writable {}} - catch {chan flush $c} - catch {chan close $c} - } - my destroy - } - # Appends the value of [arg string] to the end of [arg reply_body], as well as a trailing newline # character. method puts line { my variable reply_body append reply_body $line \n Index: modules/httpd/build/scgi.tcl ================================================================== --- modules/httpd/build/scgi.tcl +++ modules/httpd/build/scgi.tcl @@ -119,10 +119,11 @@ # Read the SCGI request on byte at a time until we reach a ":" dict set query http HTTP_HOST {} dict set query http CONTENT_LENGTH 0 dict set query http REQUEST_URI / dict set query http REMOTE_ADDR $ip + dict set query http DOCUMENT_ROOT [my clay get server/ doc_root] set size {} while 1 { set char [::coroutine::util::read $sock 1] if {[chan eof $sock]} { catch {close $sock} @@ -131,11 +132,11 @@ if {$char eq ":"} break append size $char } # With length in hand, read the netstring encoded headers set inbuffer [::coroutine::util::read $sock [expr {$size+1}]] - chan configure $sock -blocking 0 -buffersize 4096 -buffering full + chan configure $sock -translation {auto crlf} -blocking 0 -buffersize 4096 -buffering full foreach {f v} [lrange [split [string range $inbuffer 0 end-1] \0] 0 end-1] { dict set query http $f $v } if {![dict exists $query http REQUEST_PATH]} { set uri [dict get $query http REQUEST_URI] @@ -163,13 +164,13 @@ dict set reply mixin protocol ::httpd::protocol.scgi $pageobj dispatch $sock $reply } on error {err errdat} { my debug [list ip: $ip error: $err errorinfo: [dict get $errdat -errorinfo]] my log BadRequest $uuid [list ip: $ip error: $err errorinfo: [dict get $errdat -errorinfo]] - catch {$pageobj destroy} + $pageobj clay refcount_decr catch {chan event readable $sock {}} catch {chan event writeable $sock {}} catch {chan close $sock} return } } } Index: modules/httpd/build/server.tcl ================================================================== --- modules/httpd/build/server.tcl +++ modules/httpd/build/server.tcl @@ -112,10 +112,11 @@ # This action passes control of the socket to # the reply object. The reply object manages the rest of the transaction, including # closing the socket. ### method Connect {uuid sock ip} { + ::clay::cleanup yield [info coroutine] chan event $sock readable {} chan configure $sock \ -blocking 0 \ -translation {auto crlf} \ @@ -160,13 +161,14 @@ method CheckTimeout {} { foreach obj [info commands ::httpd::object::*] { try { $obj timeOutCheck } on error {} { - catch {$obj destroy} + $obj clay refcount_decr } } + ::clay::cleanup } method debug args {} ### Index: modules/httpd/httpd.man ================================================================== --- modules/httpd/httpd.man +++ modules/httpd/httpd.man @@ -228,18 +228,14 @@ }] [para] -[class {Delegate}] -[list_begin definitions] -[call delegate [cmd ]]The server object which spawned this reply - -[list_end] -[para] [class {Variable}] [list_begin definitions] +[call variable [cmd ChannelRegister]] + [call variable [cmd reply]] A dictionary which will converted into the MIME headers of the reply @@ -248,10 +244,16 @@ A dictionary containing the SCGI transformed HTTP headers for the request +[list_end] +[para] +[class {Delegate}] +[list_begin definitions] +[call delegate [cmd ]]The server object which spawned this reply + [list_end] [para] [class {Methods}] [list_begin definitions] [call method [cmd "constructor"] [arg ServerObj] [opt "[arg args]"]] @@ -260,10 +262,15 @@ [call method [cmd "destructor"] [opt "[arg dictargs]"]] clean up on exit + + +[call method [cmd "ChannelRegister"] [opt "[arg args]"]] + Registers a channel to be closed by the close method + [call method [cmd "close"]] Close channels opened by this object @@ -358,33 +365,10 @@ [call method [cmd "Session_Load"]] Manage session data - - -[call method [cmd "TransferComplete"] [opt "[arg args]"]] - Intended to be invoked from [cmd {chan copy}] as a callback. This closes every channel - fed to it on the command line, and then destroys the object. - - [example { - ### - # Output the body - ### - chan configure $sock -translation binary -blocking 0 -buffering full -buffersize 4096 - chan configure $chan -translation binary -blocking 0 -buffering full -buffersize 4096 - if {$length} { - ### - # Send any POST/PUT/etc content - ### - chan copy $sock $chan -size $SIZE -command [info coroutine] - yield - } - catch {close $sock} - chan flush $chan - }] - [call method [cmd "puts"] [arg line]] Appends the value of [arg string] to the end of [arg reply_body], as well as a trailing newline character. Index: modules/httpd/httpd.tcl ================================================================== --- modules/httpd/httpd.tcl +++ modules/httpd/httpd.tcl @@ -28,46 +28,51 @@ } namespace eval ::scgi { } clay::define ::httpd::mime { method ChannelCopy {in out args} { - set chunk 4096 - set size -1 - foreach {f v} $args { - set [string trim $f -] $v - } - dict set info coroutine [info coroutine] - if {$size>0 && $chunk>$size} { - set chunk $size - } - set bytes 0 - set sofar 0 - set method [self method] - while 1 { - set command {} - set error {} - if {$size>=0} { - incr sofar $bytes - set remaining [expr {$size-$sofar}] - if {$remaining <= 0} { - break - } elseif {$chunk > $remaining} { - set chunk $remaining - } - } - lassign [yieldto chan copy $in $out -size $chunk \ - -command [list [info coroutine] $method]] \ - command bytes error - if {$command ne $method} { - error "Subroutine $method interrupted" - } - if {[string length $error]} { - error $error - } - if {[chan eof $in]} { - break - } + try { + my clay refcount_incr + set chunk 4096 + set size -1 + foreach {f v} $args { + set [string trim $f -] $v + } + dict set info coroutine [info coroutine] + if {$size>0 && $chunk>$size} { + set chunk $size + } + set bytes 0 + set sofar 0 + set method [self method] + while 1 { + set command {} + set error {} + if {$size>=0} { + incr sofar $bytes + set remaining [expr {$size-$sofar}] + if {$remaining <= 0} { + break + } elseif {$chunk > $remaining} { + set chunk $remaining + } + } + lassign [yieldto chan copy $in $out -size $chunk \ + -command [list [info coroutine] $method]] \ + command bytes error + if {$command ne $method} { + error "Subroutine $method interrupted" + } + if {[string length $error]} { + error $error + } + if {[chan eof $in]} { + break + } + } + } finally { + my clay refcount_decr } } method html_header {{title {}} args} { set result {} append result "\n" @@ -276,18 +281,20 @@ } } return $pathlist } method wait {mode sock} { + my clay refcount_incr if {[info coroutine] eq {}} { chan event $sock $mode [list set ::httpd::lock_$sock $mode] vwait ::httpd::lock_$sock } else { chan event $sock $mode [info coroutine] yield } chan event $sock $mode {} + my clay refcount_decr } } ### # END: core.tcl @@ -295,10 +302,11 @@ ### # START: reply.tcl ### ::clay::define ::httpd::reply { superclass ::httpd::mime + Variable ChannelRegister {} Delegate { description {The server object which spawned this reply} } Dict reply {} Dict request { @@ -311,30 +319,44 @@ REMOTE_HOST {} USER_AGENT {} SESSION {} } constructor {ServerObj args} { - my variable chan dispatched_time uuid + my variable dispatched_time uuid set uuid [namespace tail [self]] set dispatched_time [clock milliseconds] my clay delegate $ServerObj foreach {field value} [::clay::args_to_options {*}$args] { my clay set config $field: $value } } destructor { my close + } + method ChannelRegister args { + my variable ChannelRegister + if {![info exists ChannelRegister]} { + set ChannelRegister {} + } + foreach c $args { + if {$c ni $ChannelRegister} { + lappend ChannelRegister $c + } + } } method close {} { - my variable chan - if {[info exists chan] && $chan ne {}} { - catch {chan event $chan readable {}} - catch {chan event $chan writable {}} - catch {chan flush $chan} - catch {chan close $chan} - set chan {} - } + my variable ChannelRegister + if {![info exists ChannelRegister]} { + return + } + foreach c $ChannelRegister { + catch {chan event $c readable {}} + catch {chan event $c writable {}} + catch {chan flush $c} + catch {chan close $c} + } + set ChannelRegister {} } method Log_Dispatched {} { my log Dispatched [dict create \ REMOTE_ADDR [my request get REMOTE_ADDR] \ REMOTE_HOST [my request get REMOTE_HOST] \ @@ -347,11 +369,13 @@ ] } method dispatch {newsock datastate} { my variable chan request try { + my clay refcount_incr set chan $newsock + my ChannelRegister $chan chan event $chan readable {} chan configure $chan -translation {auto crlf} -buffering line if {[dict exists $datastate mixin]} { set mixinmap [dict get $datastate mixin] } else { @@ -383,10 +407,13 @@ my Log_Dispatched my Dispatch } on error {err errdat} { my error 500 $err [dict get $errdat -errorinfo] my DoOutput + } finally { + my close + my clay refcount_decr } } method Dispatch {} { # Invoke the URL implementation. my content @@ -475,11 +502,10 @@ append result [my reply output] } chan puts -nonewline $chan $result my log HttpAccess {} } - my destroy } method FormData {} { my variable chan formdata # Run this only once if {[info exists formdata]} { @@ -544,21 +570,10 @@ set postdata [::coroutine::util::read $chan $length] } return $postdata } method Session_Load {} {} - method TransferComplete args { - my log TransferComplete - set chan {} - foreach c $args { - catch {chan event $c readable {}} - catch {chan event $c writable {}} - catch {chan flush $c} - catch {chan close $c} - } - my destroy - } method puts line { my variable reply_body append reply_body $line \n } method RequestFind {field} { @@ -784,10 +799,11 @@ dict set result LOCALHOST [expr {[lindex [split [dict getnull $result HTTP_HOST] :] 0] eq "localhost"}] } return $result } method Connect {uuid sock ip} { + ::clay::cleanup yield [info coroutine] chan event $sock readable {} chan configure $sock \ -blocking 0 \ -translation {auto crlf} \ @@ -826,13 +842,14 @@ method CheckTimeout {} { foreach obj [info commands ::httpd::object::*] { try { $obj timeOutCheck } on error {} { - catch {$obj destroy} + $obj clay refcount_decr } } + ::clay::cleanup } method debug args {} method dispatch {data} { set reply [my Dispatch_Local $data] if {[dict size $reply]} { @@ -1090,19 +1107,13 @@ } } ::clay::define ::httpd::content.cache { method Dispatch {} { my variable chan - try { - my wait writable $chan - chan configure $chan -translation {binary binary} - chan puts -nonewline $chan [my clay get cache/ data] - } on error {err info} { - my debug [dict get $info -errorinfo] - } finally { - my TransferComplete $chan - } + my wait writable $chan + chan configure $chan -translation {binary binary} + chan puts -nonewline $chan [my clay get cache/ data] } } ::clay::define ::httpd::content.template { method content {} { if {[my request get HTTP_STATUS] ne {}} { @@ -1240,30 +1251,27 @@ if {$chan eq {}} return my wait writable $chan if {![info exists reply_file]} { tailcall my DoOutput } - try { - chan configure $chan -translation {binary binary} - my log HttpAccess {} - ### - # Return a stream of data from a file - ### - set size [file size $reply_file] - my reply set Content-Length $size - append result [my reply output] \n - chan puts -nonewline $chan $result - set reply_chan [open $reply_file r] - my log SendReply [list length $size] - ### - # Output the file contents. With no -size flag, channel will copy until EOF - ### - chan configure $reply_chan -translation {binary binary} -buffersize 4096 -buffering full -blocking 0 - my ChannelCopy $reply_chan $chan -chunk 4096 - } finally { - my TransferComplete $reply_chan $chan - } + chan configure $chan -translation {binary binary} + my log HttpAccess {} + ### + # Return a stream of data from a file + ### + set size [file size $reply_file] + my reply set Content-Length $size + append result [my reply output] \n + chan puts -nonewline $chan $result + set reply_chan [open $reply_file r] + my ChannelRegister $reply_chan + my log SendReply [list length $size] + ### + # Output the file contents. With no -size flag, channel will copy until EOF + ### + chan configure $reply_chan -translation {binary binary} -buffersize 4096 -buffering full -blocking 0 + my ChannelCopy $reply_chan $chan -chunk 4096 } } ### # END: file.tcl @@ -1419,16 +1427,13 @@ tailcall my DoOutput } my log HttpAccess {} chan event $sock writable [info coroutine] yield - try { - my ProxyRequest $chan $sock - my ProxyReply $sock $chan - } finally { - my TransferComplete $chan $sock - } + my ChannelRegister $sock + my ProxyRequest $chan $sock + my ProxyReply $sock $chan } } ### # END: proxy.tcl @@ -1527,10 +1532,11 @@ ### my ChannelCopy $chana $chanb -size $length } else { chan flush $chanb } + my clay refcount_incr chan event $chanb readable [info coroutine] yield } method ProxyReply {chana chanb args} { my log ProxyReply [list args $args] @@ -1555,10 +1561,11 @@ # Output the body. With no -size flag, channel will copy until EOF ### chan configure $chana -translation binary -blocking 0 -buffering full -buffersize 4096 chan configure $chanb -translation binary -blocking 0 -buffering full -buffersize 4096 my ChannelCopy $chana $chanb -chunk 4096 + my clay refcount_decr } method DirectoryListing {local_file} { my error 403 {Not Allowed} tailcall my DoOutput } @@ -1686,11 +1693,11 @@ if {$char eq ":"} break append size $char } # With length in hand, read the netstring encoded headers set inbuffer [::coroutine::util::read $sock [expr {$size+1}]] - chan configure $sock -blocking 0 -buffersize 4096 -buffering full + chan configure $sock -translation {auto crlf} -blocking 0 -buffersize 4096 -buffering full foreach {f v} [lrange [split [string range $inbuffer 0 end-1] \0] 0 end-1] { dict set query http $f $v } if {![dict exists $query http REQUEST_PATH]} { set uri [dict get $query http REQUEST_URI] @@ -1718,11 +1725,11 @@ dict set reply mixin protocol ::httpd::protocol.scgi $pageobj dispatch $sock $reply } on error {err errdat} { my debug [list ip: $ip error: $err errorinfo: [dict get $errdat -errorinfo]] my log BadRequest $uuid [list ip: $ip error: $err errorinfo: [dict get $errdat -errorinfo]] - catch {$pageobj destroy} + $pageobj clay refcount_decr catch {chan event readable $sock {}} catch {chan event writeable $sock {}} catch {chan close $sock} return } @@ -1889,11 +1896,11 @@ if {[dict exists $reply delegate]} { $pageobj clay delegate {*}[dict get $reply delegate] } $pageobj dispatch $sock $reply set output [$pageobj output] - catch {$pageobj destroy} + $pageobj clay refcount_decr return $output } } ### Index: modules/httpd/httpd.test ================================================================== --- modules/httpd/httpd.test +++ modules/httpd/httpd.test @@ -11,688 +11,625 @@ } source [file join $TCLLIBMOD devtools testutilities.tcl] testsNeedTcl 8.6 ;# tool requires 8.6 testsNeedTcltest 2 - +set NOW [clock seconds] testsNeed TclOO 1 support { - use [file join ${TCLLIBMOD} fumagic rtcore.tcl] fileutil::magic::rt - use [file join ${TCLLIBMOD} fumagic filetypes.tcl] fileutil::magic::filetype - use [file join ${TCLLIBMOD} textutil string.tcl] textutil::string - use [file join ${TCLLIBMOD} textutil repeat.tcl] textutil::repeat - use [file join ${TCLLIBMOD} textutil tabify.tcl] textutil::tabify - use [file join ${TCLLIBMOD} markdown markdown.tcl] Markdown - use [file join ${TCLLIBMOD} ncgi ncgi.tcl] ncgi - use [file join ${TCLLIBMOD} log logger.tcl] logger - use [file join ${TCLLIBMOD} base64 base64.tcl] base64 - use [file join ${TCLLIBMOD} md5 md5x.tcl] md5 - use [file join ${TCLLIBMOD} mime mime.tcl] mime - use [file join ${TCLLIBMOD} uuid uuid.tcl] uuid - use [file join ${TCLLIBMOD} cmdline cmdline.tcl] cmdline - use [file join ${TCLLIBMOD} fileutil fileutil.tcl] fileutil - use [file join ${TCLLIBMOD} sha1 sha1.tcl] sha1 - use [file join ${TCLLIBMOD} uri uri.tcl] uri - use [file join ${TCLLIBMOD} ncgi ncgi.tcl] ncgi - use [file join ${TCLLIBMOD} dns ip.tcl] ip - use [file join ${TCLLIBMOD} nettool nettool.tcl] nettool - use [file join ${TCLLIBMOD} coroutine coroutine.tcl] coroutine - use [file join ${TCLLIBMOD} dicttool dicttool.tcl] dicttool - use [file join ${TCLLIBMOD} cron cron.tcl] cron - use [file join ${TCLLIBMOD} virtchannel_core core.tcl] tcl::chan::core - use [file join ${TCLLIBMOD} virtchannel_core events.tcl] tcl::chan::events - use [file join ${TCLLIBMOD} virtchannel_base memchan.tcl] tcl::chan::memchan - use [file join ${TCLLIBMOD} websocket websocket.tcl] websocket - use [file join ${MODDIR} clay clay.tcl] clay + use [file join ${TCLLIBMOD} fumagic rtcore.tcl] fileutil::magic::rt + use [file join ${TCLLIBMOD} fumagic filetypes.tcl] fileutil::magic::filetype + use [file join ${TCLLIBMOD} textutil string.tcl] textutil::string + use [file join ${TCLLIBMOD} textutil repeat.tcl] textutil::repeat + use [file join ${TCLLIBMOD} textutil tabify.tcl] textutil::tabify + use [file join ${TCLLIBMOD} markdown markdown.tcl] Markdown + use [file join ${TCLLIBMOD} ncgi ncgi.tcl] ncgi + use [file join ${TCLLIBMOD} log logger.tcl] logger + use [file join ${TCLLIBMOD} base64 base64.tcl] base64 + use [file join ${TCLLIBMOD} md5 md5x.tcl] md5 + use [file join ${TCLLIBMOD} mime mime.tcl] mime + use [file join ${TCLLIBMOD} uuid uuid.tcl] uuid + use [file join ${TCLLIBMOD} cmdline cmdline.tcl] cmdline + use [file join ${TCLLIBMOD} fileutil fileutil.tcl] fileutil + use [file join ${TCLLIBMOD} sha1 sha1.tcl] sha1 + use [file join ${TCLLIBMOD} uri uri.tcl] uri + use [file join ${TCLLIBMOD} ncgi ncgi.tcl] ncgi + use [file join ${TCLLIBMOD} dns ip.tcl] ip + use [file join ${TCLLIBMOD} nettool nettool.tcl] nettool + use [file join ${TCLLIBMOD} coroutine coroutine.tcl] coroutine + use [file join ${TCLLIBMOD} dicttool dicttool.tcl] dicttool + use [file join ${TCLLIBMOD} cron cron.tcl] cron + use [file join ${TCLLIBMOD} virtchannel_core core.tcl] tcl::chan::core + use [file join ${TCLLIBMOD} virtchannel_core events.tcl] tcl::chan::events + use [file join ${TCLLIBMOD} virtchannel_base memchan.tcl] tcl::chan::memchan + use [file join ${TCLLIBMOD} websocket websocket.tcl] websocket + use [file join ${MODDIR} clay clay.tcl] clay } testing { - useLocal httpd.tcl httpd + useLocal httpd.tcl httpd } # Set to true for debugging and traces set ::DEBUG 0 set ::clay::debug $::DEBUG proc DEBUG args { - if {$::DEBUG} { + if {!$::DEBUG} return uplevel 1 $args - } +} + +# ------------------------------------------------------------------------- +# Constructors for various expected replies. +proc IndexReply {{head {HTTP/1.0}}} { + global TESTDIR + set fin [open [file join $TESTDIR pkgIndex.tcl] r] + set replyfile [read $fin] + close $fin + + append checkreply "$head 200 OK" \n + append checkreply "Content-Type: text/plain" \n + append checkreply "Connection: close" \n + append checkreply "Content-Length: [string length $replyfile]" \n + append checkreply \n + append checkreply $replyfile + + return $checkreply +} + +proc 404 {} { + lappend map " " "" + lappend map " " "" + # The map removes the indentation of the value + return [string map $map {HTTP/1.0 404 Not Found + Content-Type: text/plain + Connection: close + Content-Length: * + + 404 Not Found + }] +} + +proc 200 {text {len *}} { + lappend map " " "" + # The map removes the indentation of the value + # and inserts the dynamic parts + lappend map @C $text + lappend map @L $len + return [string map $map {HTTP/1.0 200 OK + Content-Type: text/plain + Connection: close + Content-Length: @L + + @C}] +} + +proc 200+status-head {text {len *}} { + lappend map " " "" + # The map removes the indentation of the value + # and inserts the dynamic parts + lappend map @C $text + lappend map @L $len + return [string map $map {Status: 200 OK + Content-Type: text/plain + Connection: close + Content-Length: @L + + @C}] +} + +proc 200+status-conn {text {len *}} { + lappend map " " "" + # The map removes the indentation of the value + # and inserts the dynamic parts + lappend map @C $text + lappend map @L $len + return [string map $map {HTTP/1.0 200 OK + Status: 200 OK + Content-Type: text/plain + Content-Length: @L + + @C}] +} + +proc 500 {} { + lappend map " " "" + lappend map " " "" + # The map removes the indentation of the value + return [string map $map {HTTP/1.0 500 Server Internal Error + Content-Type: text/plain + Connection: close + Content-Length: * + + 500 Server Internal Error + }] +} + +proc 500+status-head {} { + lappend map " " "" + lappend map " " "" + # The map removes the indentation of the value + return [string map $map {Status: 500 Server Internal Error + Content-Type: text/plain + Connection: close + Content-Length: * + + 500 Server Internal Error + }] } +# Likely a band aid, see AKU +proc norm-eol {x} { string map [list "\r\n" "\n"] $x } + # ------------------------------------------------------------------------- namespace eval ::httpd {} namespace eval ::httpd::test {} -### -# Minimal test harness for the .tests -# Not intended for public consumption -# (But if you find it handy, please steal!) -proc ::httpd::test::compare {actual correct} { - set result {} - set cbuf [split $correct \n] - set abuf [split $actual \n] - for {set i 0} {$i < [llength $cbuf]} {incr i} { - set cline [string trim [lindex $cbuf $i]] - set aline [string trim [lindex $abuf $i]] - if {![string match $cline $aline]} { - if {$cline ne $aline} { - append result "Line $i differs [list $aline] != [list $cline]" \n - } - } - } - if {[llength $result]} { - puts [list ACTUAL $actual] - puts [list CORRECT $correct] - } - return $result -} - proc ::httpd::test::send {port http headers body} { - set sock [socket localhost $port] - variable reply - set reply($sock) {} - chan configure $sock -translation {crlf crlf} -blocking 0 -buffering full -buffersize 4096 - chan event $sock readable [list ::httpd::test::get_reply $sock] - - puts $sock $http - if {![dict exists $headers Host]} { - dict set headers Host localhost - } - if {[string length $body]} { - if {![dict exists $headers Content-Type]} { - dict set headers Content_Type text/plain - } - dict set headers Content-Length [string length $body] - } - foreach {f v} $headers { - puts $sock "${f}: $v" - } - puts $sock {} - if {[string length $body]} { - chan configure $sock -translation binary -blocking 0 -buffering full -buffersize 4096 - puts -nonewline $sock $body - } - flush $sock - while {$reply($sock) eq {}} { - update - } - #vwait [namespace current]::reply($sock) - return $reply($sock) + set sock [socket localhost $port] + variable reply + set reply($sock) {} + chan configure $sock -translation {crlf crlf} -blocking 0 -buffering full -buffersize 4096 + chan event $sock readable [list ::httpd::test::get_reply $sock] + + puts $sock $http + if {![dict exists $headers Host]} { + dict set headers Host localhost + } + if {[string length $body]} { + if {![dict exists $headers Content-Type]} { + dict set headers Content_Type text/plain + } + dict set headers Content-Length [string length $body] + } + foreach {f v} $headers { + puts $sock "${f}: $v" + } + puts $sock {} + if {[string length $body]} { + chan configure $sock -translation binary -blocking 0 -buffering full -buffersize 4096 + puts -nonewline $sock $body + } + flush $sock + while {$reply($sock) eq {}} { + update + } + #vwait [namespace current]::reply($sock) + + #puts ZZ\t[join [split $reply($sock) \n] "|\nZZ\t"]| + return $reply($sock) } proc ::httpd::test::get_reply {sock} { - variable buffer - set data [read $sock] - append buffer($sock) $data - if {[eof $sock]} { - chan event $sock readable {} - set [namespace current]::reply($sock) $buffer($sock) - unset buffer($sock) - } -} - + variable buffer + set data [read $sock] + append buffer($sock) $data + if {[eof $sock]} { + chan event $sock readable {} + set [namespace current]::reply($sock) $buffer($sock) + unset buffer($sock) + } +} clay::define ::httpd::server { - method log args {} - - method TemplateSearch page { - set doc_root [my clay get server/ doc_root] - if {$doc_root ne {} && [file exists [file join $doc_root $page.tml]]} { - return [::fileutil::cat [file join $doc_root $page.tml]] - } - if {$doc_root ne {} && [file exists [file join $doc_root $page.html]]} { - return [::fileutil::cat [file join $doc_root $page.html]] - } - switch $page { - redirect { - return {300 Redirect} - } - notfound { - return {404 Not Found} - } - internal_error { - return {500 Server Internal Error} - } - } - } - - - ::DEBUG method debug args { - puts stderr $args - } - - ::DEBUG method log args { - puts stdout $args - } + method log args {} + + method TemplateSearch page { + set doc_root [my clay get server/ doc_root] + if {$doc_root ne {} && [file exists [file join $doc_root $page.tml]]} { + return [::fileutil::cat [file join $doc_root $page.tml]] + } + if {$doc_root ne {} && [file exists [file join $doc_root $page.html]]} { + return [::fileutil::cat [file join $doc_root $page.html]] + } + switch $page { + redirect { + return {300 Redirect} + } + notfound { + return {404 Not Found} + } + internal_error { + return {500 Server Internal Error} + } + } + } + + + ::DEBUG method debug args { + puts stderr $args + } + + ::DEBUG method log args { + puts stdout $args + } } ### # Modify the reply class to return plain text ### clay::define ::httpd::reply { - method HttpHeaders_Default {} { - return {Status {200 OK} - Content-Type {text/plain} - Connection close} - } - - method reset {} { - my variable reply_body - my reply replace [my HttpHeaders_Default] - set reply_body {} - } - - method error {code {msg {}} {errorInfo {}}} { - my clay set HTTP_ERROR $code - my reset - set errorstring [my http_code_string $code] - set qheaders [my clay dump] - dict with qheaders {} - my reply replace {} - my reply set Status "$code $errorstring" - my reply set Content-Type text/plain - my puts "$code $errorstring" - } + method HttpHeaders_Default {} { + return { + Status {200 OK} + Content-Type {text/plain} + Connection close + } + } + + method reset {} { + my variable reply_body + my reply replace [my HttpHeaders_Default] + set reply_body {} + } + + method error {code {msg {}} {errorInfo {}}} { + my clay set HTTP_ERROR $code + my reset + set errorstring [my http_code_string $code] + set qheaders [my clay dump] + dict with qheaders {} + my reply replace {} + my reply set Status "$code $errorstring" + my reply set Content-Type text/plain + my puts "$code $errorstring" + } } clay::define ::test::content.echo { - method content {} { - my variable reply_body - set reply_body [my PostData [my request get CONTENT_LENGTH]] - #puts [list REPLY BODY WAS $reply_body] - } + method content {} { + my variable reply_body + set reply_body [my PostData [my request get CONTENT_LENGTH]] + #puts [list REPLY BODY WAS $reply_body] + } } clay::define ::test::content.file { - superclass ::httpd::content.file - method content {} { - my reset - set doc_root [my request get DOCUMENT_ROOT] - my variable reply_file - set reply_file [file join $doc_root pkgIndex.tcl] - } + superclass ::httpd::content.file + method content {} { + my reset + set doc_root [my clay get path] + my variable reply_file + set reply_file [file join $doc_root pkgIndex.tcl] + } } clay::define ::test::content.time { - method content {} { - my variable reply_body - set reply_body [clock seconds] - } + method content {} { + my variable reply_body + set reply_body $::NOW + } } clay::define ::test::content.error { - method content {} { - error {The programmer asked me to die this way} - } + method content {} { + error {The programmer asked me to die this way} + } } clay::define ::test::content.cgi { - superclass ::httpd::content.cgi - + superclass ::httpd::content.cgi } - +clay::define ::test::content.string { + method content {} { + my variable reply_body + set reply_body [my clay get hardcoded_string] + } +} clay::define ::httpd::test::reply { - superclass ::httpd::reply ::test::content.echo + superclass ::httpd::reply ::test::content.echo } ### # Build the server ### + ::httpd::server create TESTAPP port 10001 doc_root $::TESTDIR TESTAPP plugin dict_dispatch -TESTAPP uri add * / [list mixin {reply ::test::content.echo}] -TESTAPP uri add * /echo [list mixin {reply ::test::content.echo}] -TESTAPP uri add * /file [list mixin {reply ::test::content.file}] -TESTAPP uri add * /time [list mixin {reply ::test::content.time}] -TESTAPP uri add * /error [list mixin {replyy ::test::content.error}] +TESTAPP uri add * / [list mixin {reply ::test::content.echo}] +TESTAPP uri add * /echo [list mixin {reply ::test::content.echo}] +TESTAPP uri add * /file [list mixin {reply ::test::content.file} path $::TESTDIR] +TESTAPP uri add * /time [list mixin {reply ::test::content.time}] +TESTAPP uri add * /error [list mixin {reply ::test::content.error}] +TESTAPP uri add * /string [list mixin {reply ::test::content.string} hardcoded_string apple] # Catch all #TESTAPP uri add * * [list mixin {reply httpd::content.echo}] ::DEBUG puts httpd-client-0001 -test httpd-client-0001 {Do an echo request} { - -set reply [::httpd::test::send 10001 {POST /echo HTTP/1.0} {} {THIS IS MY CODE}] -::httpd::test::compare $reply {HTTP/1.0 200 OK -Content-Type: text/plain -Connection: close -Content-Length: * - -THIS IS MY CODE} -} {} +test httpd-client-0001 {Do an echo request} -body { + ::httpd::test::send 10001 {POST /echo HTTP/1.0} {} {THIS IS MY CODE} +} -match glob -result [200 {THIS IS MY CODE}] ::DEBUG puts httpd-client-0002 test httpd-client-0002 {Do another echo request} { -set reply [::httpd::test::send 10001 {POST /echo HTTP/1.0} {} {THOUGH THERE ARE MANY LIKE IT}] -::httpd::test::compare $reply {HTTP/1.0 200 OK -Content-Type: text/plain -Connection: close -Content-Length: 29 - -THOUGH THERE ARE MANY LIKE IT} -} {} + ::httpd::test::send 10001 {POST /echo HTTP/1.0} {} {THOUGH THERE ARE MANY LIKE IT} +} [200 {THOUGH THERE ARE MANY LIKE IT} 29] ::DEBUG puts httpd-client-0003 -test httpd-client-0003 {Do another echo request} { -set reply [::httpd::test::send 10001 {POST /echo HTTP/1.0} {} {THIS ONE ALONE IS MINE}] -::httpd::test::compare $reply {HTTP/1.0 200 OK -Content-Type: text/plain -Connection: close -Content-Length: * - -THIS ONE ALONE IS MINE} -} {} +test httpd-client-0003 {Do another echo request} -body { + ::httpd::test::send 10001 {POST /echo HTTP/1.0} {} {THIS ONE ALONE IS MINE} +} -match glob -result [200 {THIS ONE ALONE IS MINE}] ::DEBUG puts httpd-client-0004 -test httpd-client-0004 {URL Generates Error} { - -set reply [::httpd::test::send 10001 {POST /error HTTP/1.0} {} {THIS ONE ALONE IS MINE}] - -::httpd::test::compare $reply {HTTP/1.0 500 Server Internal Error -Content-Type: text/plain -Connection: close -Content-Length: * - -500 Server Internal Error} -} {} - -set checkreply [subst {HTTP/1.0 200 OK -Content-Type: text/plain -Connection: close -Content-Length: * - -[clock seconds]}] +test httpd-client-0004 {URL Generates Error} -body { + ::httpd::test::send 10001 {POST /error HTTP/1.0} {} {THIS ONE ALONE IS MINE} +} -match glob -result [500] ::DEBUG puts httpd-client-0005 -test httpd-client-0005 {URL Different output with a different request} { -set reply [::httpd::test::send 10001 {POST /time HTTP/1.0} {} {THIS ONE ALONE IS MINE}] -::httpd::test::compare $reply $checkreply -} {} - -set fin [open [file join $TESTDIR pkgIndex.tcl] r] -set replyfile [read $fin] -close $fin -set checkreply "HTTP/1.0 200 OK -Content-Type: text/plain -Connection: close -Content-Length: [string length $replyfile] - -$replyfile" +test httpd-client-0005 {URL Different output with a different request} -body { + ::httpd::test::send 10001 {POST /time HTTP/1.0} {} {THIS ONE ALONE IS MINE} +} -match glob -result [200 $::NOW] ::DEBUG puts httpd-client-0006 -test httpd-client-0006 {Return a file} { -set reply [::httpd::test::send 10001 {GET /file HTTP/1.0} {} {}] -::httpd::test::compare $reply $checkreply -} {} +test httpd-client-0006 {Return a file} -body { + ::httpd::test::send 10001 {GET /file HTTP/1.0} {} {} +} -result [IndexReply] ::DEBUG puts httpd-client-0007 -test httpd-client-0007 {URL Generates Not Found} { - -set reply [::httpd::test::send 10001 {POST /doesnotexist HTTP/1.0} {} {THIS ONE ALONE IS MINE}] - -::httpd::test::compare $reply {HTTP/1.0 404 Not Found -Content-Type: text/plain -Connection: close -Content-Length: * - -404 Not Found} -} {} - +test httpd-client-0007 {URL Generates Not Found} -body { + ::httpd::test::send 10001 {POST /doesnotexist HTTP/1.0} {} {THIS ONE ALONE IS MINE} +} -match glob -result [404] + +::DEBUG puts httpd-client-0008 +test httpd-client-0008 {Pull a constant string} -body { + ::httpd::test::send 10001 {GET /string HTTP/1.0} {} {} +} -match glob -result [200 apple] # ------------------------------------------------------------------------- # Test proxies clay::define ::test::content.proxy { - superclass ::httpd::content.proxy + superclass ::httpd::content.proxy - method proxy_channel {} { - return [::socket localhost [my clay get proxy_port]] - } + method proxy_channel {} { + return [::socket localhost [my clay get proxy_port]] + } } - ::httpd::server create TESTPROXY port 10002 doc_root $::TESTDIR -TESTAPP uri add * /proxy* [list mixin {reply ::test::content.proxy} proxy_port [TESTPROXY port_listening]] +TESTAPP uri add * /proxy* [list mixin {reply ::test::content.proxy} proxy_port [TESTPROXY port_listening]] TESTPROXY plugin dict_dispatch -TESTPROXY uri add * / [list mixin {reply ::test::content.echo}] -TESTPROXY uri add * /echo [list mixin {reply ::test::content.echo}] -TESTPROXY uri add * /file [list mixin {reply ::test::content.file}] -TESTPROXY uri add * /time [list mixin {reply ::test::content.time}] -TESTPROXY uri add * /error [list mixin {reply ::test::content.error}] +TESTPROXY uri add * / [list mixin {reply ::test::content.echo}] +TESTPROXY uri add * /echo [list mixin {reply ::test::content.echo}] +TESTPROXY uri add * /file [list mixin {reply ::test::content.file} path $::TESTDIR] +TESTPROXY uri add * /time [list mixin {reply ::test::content.time}] +TESTPROXY uri add * /error [list mixin {reply ::test::content.error}] +TESTPROXY uri add * /string [list mixin {reply ::test::content.string} hardcoded_string banana] + +## AKU ## +# +# Note: Proxy replies are not normalized to \n. They contain \r\n +# endings. The old test::compare was ok with that due to running a +# trim on the lines it was comparing. Here we properly normalize +# before feeding into the comparison. +# +# Note 2: I suspect that this leakage / non-normalization of of \r\n +# in the server is a bug which should be fixed. If so, norm-eol +# becomes superfluous. Right now it feels like a band-aid ::DEBUG puts httpd-proxy-0001 -test httpd-proxy-0001 {Do an echo request} { - -set reply [::httpd::test::send 10001 {POST /proxy/echo HTTP/1.0} {} {THIS IS MY CODE}] -::httpd::test::compare $reply {HTTP/1.0 200 OK -Content-Type: text/plain -Connection: close -Content-Length: * - -THIS IS MY CODE} -} {} +test httpd-proxy-0001 {Do an echo request} -body { + norm-eol [::httpd::test::send 10001 {POST /proxy/echo HTTP/1.0} {} {THIS IS MY CODE}] +} -match glob -result [200 {THIS IS MY CODE}] ::DEBUG puts httpd-proxy-0002 -test httpd-proxy-0002 {Do another echo request} { -set reply [::httpd::test::send 10001 {POST /proxy/echo HTTP/1.0} {} {THOUGH THERE ARE MANY LIKE IT}] -::httpd::test::compare $reply {HTTP/1.0 200 OK -Content-Type: text/plain -Connection: close -Content-Length: 29 - -THOUGH THERE ARE MANY LIKE IT} -} {} +test httpd-proxy-0002 {Do another echo request} -body { + norm-eol [::httpd::test::send 10001 {POST /proxy/echo HTTP/1.0} {} {THOUGH THERE ARE MANY LIKE IT}] +} -result [200 {THOUGH THERE ARE MANY LIKE IT} 29] ::DEBUG puts httpd-proxy-0003 -test httpd-proxy-0003 {Do another echo request} { -set reply [::httpd::test::send 10001 {POST /proxy/echo HTTP/1.0} {} {THIS ONE ALONE IS MINE}] -::httpd::test::compare $reply {HTTP/1.0 200 OK -Content-Type: text/plain -Connection: close -Content-Length: * - -THIS ONE ALONE IS MINE} -} {} +test httpd-proxy-0003 {Do another echo request} -body { + norm-eol [::httpd::test::send 10001 {POST /proxy/echo HTTP/1.0} {} {THIS ONE ALONE IS MINE}] +} -match glob -result [200 {THIS ONE ALONE IS MINE}] ::DEBUG puts httpd-proxy-0004 -test httpd-proxy-0004 {URL Generates Error} { - -set reply [::httpd::test::send 10001 {POST /proxy/error HTTP/1.0} {} {THIS ONE ALONE IS MINE}] - -::httpd::test::compare $reply {HTTP/1.0 500 Server Internal Error -Content-Type: text/plain -Connection: close -Content-Length: * - -500 Server Internal Error} -} {} - -set checkreply [subst {HTTP/1.0 200 OK -Content-Type: text/plain -Connection: close -Content-Length: * - -[clock seconds]}] +test httpd-proxy-0004 {URL Generates Error} -body { + norm-eol [::httpd::test::send 10001 {POST /proxy/error HTTP/1.0} {} {THIS ONE ALONE IS MINE}] +} -match glob -result [500] ::DEBUG puts httpd-proxy-0005 -test httpd-proxy-0005 {URL Different output with a different request} { -set reply [::httpd::test::send 10001 {POST /proxy/time HTTP/1.0} {} {THIS ONE ALONE IS MINE}] -::httpd::test::compare $reply $checkreply -} {} - -set fin [open [file join $TESTDIR pkgIndex.tcl] r] -set replyfile [read $fin] -close $fin -set checkreply "HTTP/1.0 200 OK -Content-Type: text/plain -Connection: close -Content-Length: [string length $replyfile] - -$replyfile" +test httpd-proxy-0005 {URL Different output with a different request} -body { + norm-eol [::httpd::test::send 10001 {POST /proxy/time HTTP/1.0} {} {THIS ONE ALONE IS MINE}] +} -match glob -result [200 $::NOW] ::DEBUG puts httpd-proxy-0006 -test httpd-proxy-0006 {Return a file} { -set reply [::httpd::test::send 10001 {GET /proxy/file HTTP/1.0} {} {}] -::httpd::test::compare $reply $checkreply -} {} +test httpd-proxy-0006 {Return a file} -body { + norm-eol [::httpd::test::send 10001 {GET /proxy/file HTTP/1.0} {} {}] +} -result [IndexReply] +::DEBUG puts httpd-proxy-0008 +test httpd-proxy-0008 {Pull a constant string} -body { + norm-eol [::httpd::test::send 10001 {GET /proxy/string HTTP/1.0} {} {}] +} -result [200 banana 6] # ------------------------------------------------------------------------- # cgi + TESTAPP plugin local_memchan - -TESTAPP uri add * /cgi-bin* [list mixin {reply ::test::content.cgi} path $::TESTDIR] - -set fout [open [file join $TESTDIR test.tcl] w] -puts $fout {#!/usr/bin/tclsh - -puts stdout "Status: 200 OK" -if {$::env(CONTENT_LENGTH) > 0} { - puts stdout "Content-Type: $::env(CONTENT_TYPE)" - set dat [read stdin $::env(CONTENT_LENGTH)] -} else { - puts stdout "Content-Type: text/plain" - set dat "Hi!" -} -puts stdout "Content-Length: [string length $dat]" -puts stdout {} -puts stdout $dat -exit 0 -} -close $fout +TESTAPP uri add * /cgi-bin* [list mixin {reply ::test::content.cgi} path $::TESTDIR/assets] ::DEBUG puts httpd-cgi-0001 -test httpd-cgi-0001 {CGI Post} { - -set reply [::httpd::test::send 10001 {POST /cgi-bin/test.tcl HTTP/1.0} {} {THIS IS MY CODE}] -::httpd::test::compare $reply {HTTP/1.0 200 OK -Status: 200 OK -Content-Type: text/plain -Content-Length: * - -THIS IS MY CODE} -} {} +test httpd-cgi-0001 {CGI Post} -body { + norm-eol [::httpd::test::send 10001 {POST /cgi-bin/test_cgi.tcl HTTP/1.0} {} {THIS IS MY CODE}] +} -match glob -result [200+status-conn {THIS IS MY CODE +}] ::DEBUG puts httpd-cgi-0002 -test httpd-cgi-0002 {CGI Get} { - -set reply [::httpd::test::send 10001 {GET /cgi-bin/test.tcl HTTP/1.0} {} {}] -::httpd::test::compare $reply {HTTP/1.0 200 OK -Status: 200 OK -Content-Type: text/plain -Content-Length: * - -Hi!} -} {} +test httpd-cgi-0002 {CGI Get} -body { + ::httpd::test::send 10001 {GET /cgi-bin/test_cgi.tcl HTTP/1.0} {} {} +} -match glob -result [200+status-conn {Hi! +}] ### # Test the local geturl method ### -set now [clock seconds] -set dat [TESTAPP local_memchan geturl /time] test httpd-memchan-0001 {Memchan GET} { - TESTAPP local_memchan geturl /time -} $now + TESTAPP local_memchan geturl /time +} $NOW # ------------------------------------------------------------------------- namespace eval ::scgi {} namespace eval ::scgi::test {} ### # Minimal test harness for the .tests # Not intended for public consumption # (But if you find it handy, please steal!) -namespace eval ::scgi::test {} proc ::scgi::encode_request {headers body info} { - variable server_block - - dict set outdict CONTENT_LENGTH [string length $body] - set outdict [dict merge $outdict $server_block $info] - dict set outdict PWD [pwd] - foreach {key value} $headers { - if {$key in { - DOCUMENT_ROOT - HTTPS - PATH - REQUEST_METHOD REQUEST_URI - REMOTE_HOST REMOTE_ADDR REMOTE_PORT - SCRIPT_NAME - } || [string range $key 0 5] eq "HTTP_"} { - dict set outdict $key $value - } else { - dict set outdict HTTP_[string map {"-" "_"} [string toupper $key]] $value - } - } - set result {} - foreach {name value} $outdict { - append result $name \x00 $value \x00 - } - return "[string length $result]:$result," + variable server_block + + dict set outdict CONTENT_LENGTH [string length $body] + set outdict [dict merge $outdict $server_block $info] + dict set outdict PWD [pwd] + + foreach {key value} $headers { + if {$key in { + DOCUMENT_ROOT + HTTPS + PATH + REQUEST_METHOD REQUEST_URI + REMOTE_HOST REMOTE_ADDR REMOTE_PORT + SCRIPT_NAME + } || [string range $key 0 5] eq "HTTP_"} { + dict set outdict $key $value + } else { + dict set outdict HTTP_[string map {"-" "_"} [string toupper $key]] $value + } + } + set result {} + foreach {name value} $outdict { + append result $name \x00 $value \x00 + } + return "[string length $result]:$result," } proc ::scgi::test::send {port headers body} { - set sock [socket localhost $port] - variable reply - set reply($sock) {} - if {![dict exists $headers HOST]} { - dict set headers HOST localhost - } - dict set headers REMOTE_IP 127.0.0.1 - dict set headers REMOTE_HOST localhost - - chan configure $sock -translation binary -blocking 0 -buffering full -buffersize 4096 - chan event $sock readable [list ::scgi::test::get_reply $sock] - set block [::scgi::encode_request $headers $body {}] - puts -nonewline $sock $block - flush $sock - puts -nonewline $sock $body - flush $sock - while {$reply($sock) eq {}} { - update - } - #vwait [namespace current]::reply($sock) - return $reply($sock) + set sock [socket localhost $port] + variable reply + set reply($sock) {} + + if {![dict exists $headers HOST]} { + dict set headers HOST localhost + } + dict set headers REMOTE_IP 127.0.0.1 + dict set headers REMOTE_HOST localhost + + chan configure $sock -translation binary -blocking 0 -buffering full -buffersize 4096 + chan event $sock readable [list ::scgi::test::get_reply $sock] + + set block [::scgi::encode_request $headers $body {}] + + puts -nonewline $sock $block + flush $sock + puts -nonewline $sock $body + flush $sock + + while {$reply($sock) eq {}} { + update + } + + #vwait [namespace current]::reply($sock) + + #puts ZZ\t[join [split $reply($sock) \n] "|\nZZ\t"]| + return $reply($sock) } proc ::scgi::test::get_reply {sock} { - variable buffer - set data [read $sock] - append buffer($sock) $data - if {[eof $sock]} { - chan event $sock readable {} - set [namespace current]::reply($sock) $buffer($sock) - unset buffer($sock) - } + variable buffer + set data [read $sock] + append buffer($sock) $data + if {[eof $sock]} { + chan event $sock readable {} + set [namespace current]::reply($sock) $buffer($sock) + unset buffer($sock) + } } namespace eval ::scgi { variable server_block {SCGI 1.0 SERVER_SOFTWARE {TclScgiServer/0.1}} } ### # Build the reply class ### + ::clay::define ::scgi::test::reply { - superclass ::httpd::reply + superclass ::httpd::reply - method reset {} { - my variable reply_body - my reply replace [my HttpHeaders_Default] - set reply_body {} - } + method reset {} { + my variable reply_body + my reply replace [my HttpHeaders_Default] + set reply_body {} + } } ### # Build the server ### + ::clay::define scgi::test::app { - superclass ::httpd::server.scgi + superclass ::httpd::server.scgi - clay set reply_class ::scgi::test::reply + clay set reply_class ::scgi::test::reply } -puts [list ::test::content.file [info commands ::test::content.file]] +::DEBUG puts [list ::test::content.file [info commands ::test::content.file]] + scgi::test::app create TESTSCGI port 10003 doc_root $::TESTDIR + TESTSCGI plugin dict_dispatch -TESTSCGI uri add * / [list mixin {reply ::test::content.echo}] -TESTSCGI uri add * /echo [list mixin {reply ::test::content.echo}] -TESTSCGI uri add * /file [list mixin {reply ::test::content.file}] -TESTSCGI uri add * /time [list mixin {reply ::test::content.time}] +TESTSCGI uri add * / [list mixin {reply ::test::content.echo}] +TESTSCGI uri add * /echo [list mixin {reply ::test::content.echo}] +TESTSCGI uri add * /file [list mixin {reply ::test::content.file} path $::TESTDIR] +TESTSCGI uri add * /time [list mixin {reply ::test::content.time}] TESTSCGI uri add * /error [list mixin {reply ::test::content.error}] +TESTSCGI uri add * /string [list mixin {reply ::test::content.string} hardcoded_string cherry] ::DEBUG puts scgi-client-0001 -test scgi-client-0001 {Do an echo request} { - -set reply [::scgi::test::send 10003 {REQUEST_METHOD POST REQUEST_URI /echo} {THIS IS MY CODE}] -set checkreply {Status: 200 OK -Content-Type: text/plain -Connection: close -Content-Length: * - -THIS IS MY CODE} -::httpd::test::compare $reply $checkreply -} {} - +test scgi-client-0001 {Do an echo request} -body { + ::scgi::test::send 10003 {REQUEST_METHOD POST REQUEST_URI /echo} {THIS IS MY CODE} +} -match glob -result [200+status-head {THIS IS MY CODE}] ::DEBUG puts scgi-client-0002 -test scgi-client-0002 {Do another echo request} { -set reply [::scgi::test::send 10003 {REQUEST_METHOD POST REQUEST_URI /echo} {THOUGH THERE ARE MANY LIKE IT}] -set checkreply {Status: 200 OK -Content-Type: text/plain -Connection: close -Content-Length: * - -THOUGH THERE ARE MANY LIKE IT} -::httpd::test::compare $reply $checkreply -} {} +test scgi-client-0002 {Do another echo request} -body { + ::scgi::test::send 10003 {REQUEST_METHOD POST REQUEST_URI /echo} {THOUGH THERE ARE MANY LIKE IT} +} -match glob -result [200+status-head {THOUGH THERE ARE MANY LIKE IT}] ::DEBUG puts scgi-client-0003 -test scgi-client-0003 {Do another echo request} { -set reply [::scgi::test::send 10003 {REQUEST_METHOD POST REQUEST_URI /echo} {THIS ONE ALONE IS MINE}] -set checkreply {Status: 200 OK -Content-Type: text/plain -Connection: close -Content-Length: * - -THIS ONE ALONE IS MINE} -::httpd::test::compare $reply $checkreply -} {} +test scgi-client-0003 {Do another echo request} -body { + ::scgi::test::send 10003 {REQUEST_METHOD POST REQUEST_URI /echo} {THIS ONE ALONE IS MINE} +} -match glob -result [200+status-head {THIS ONE ALONE IS MINE}] ::DEBUG puts scgi-client-0004 -test scgi-client-0004 {URL Generates Error} { - -set reply [::scgi::test::send 10003 {REQUEST_METHOD POST REQUEST_URI /error} {THIS ONE ALONE IS MINE}] - -set checkreply {Status: 500 Server Internal Error -Content-Type: text/plain -Connection: close -Content-Length: * - -500 Server Internal Error -} -::httpd::test::compare $reply $checkreply -} {} - -set checkreply [subst {Status: 200 OK -Content-Type: text/plain -Connection: close -Content-Length: * - -[clock seconds]}] +test scgi-client-0004 {URL Generates Error} -body { + ::scgi::test::send 10003 {REQUEST_METHOD POST REQUEST_URI /error} {THIS ONE ALONE IS MINE} +} -match glob -result [500+status-head] ::DEBUG puts scgi-client-0005 -test scgi-client-0005 {URL Different output with a different request} { -set reply [::scgi::test::send 10003 {REQUEST_METHOD POST REQUEST_URI /time} {THIS ONE ALONE IS MINE}] - -::httpd::test::compare $reply $checkreply -} {} - -set fin [open [file join $TESTDIR pkgIndex.tcl] r] -set checkfile [read $fin] -close $fin - -### -# Nerfed: There is something screwy that is preventing this test from working -# properly in Sak. But only this test, and not the other two (normal client and proxy) -# who are doing essentially the same operation -# Investigate at some point - Sean -### -#::DEBUG puts scgi-client-0006 -#test scgi-client-0006 {Return a file} { -#set reply [::scgi::test::send 10003 {REQUEST_METHOD GET REQUEST_URI /file} {}] - -#set checkreply "Status: 200 OK -#Content-Type: text/plain -#Connection: close -#Content-Length: [string length $checkfile] - -#$checkfile" -#::httpd::test::compare $reply $checkreply -#} {} +test scgi-client-0005 {URL Different output with a different request} -body { + ::scgi::test::send 10003 {REQUEST_METHOD POST REQUEST_URI /time} {THIS ONE ALONE IS MINE} +} -match glob -result [200+status-head $::NOW] + +::DEBUG puts scgi-client-0006 +test scgi-client-0006 {Return a file} -body { + ::scgi::test::send 10003 {REQUEST_METHOD GET REQUEST_URI /file} {} +} -result [IndexReply Status:] + + +::DEBUG puts scgi-client-0008 +test scgi-client-0008 {Pull a constant string} -body { + ::scgi::test::send 10003 {REQUEST_METHOD GET REQUEST_URI /string} {} +} -match glob -result [200+status-head cherry] +### +# Test the all object have been destroyed after ::clay::cleanup +### +test httpd-garbage-collection {Test that garbage collection leaves nothing behind} -body { + ::clay::cleanup + info commands ::httpd::object::* +} -result {} ::DEBUG puts all-tests-finished -file delete [file join $TESTDIR test.tcl] # ------------------------------------------------------------------------- testsuiteCleanup # Local variables: Index: modules/practcl/practcl.tcl ================================================================== --- modules/practcl/practcl.tcl +++ modules/practcl/practcl.tcl @@ -8,50 +8,10 @@ namespace eval ::practcl {} ### # START: httpwget/wget.tcl ### -package provide http::wget 0.1 -package require http -::namespace eval ::http { -} -proc ::http::_followRedirects {url args} { - while 1 { - set token [geturl $url -validate 1] - set ncode [ncode $token] - if { $ncode eq "404" } { - error "URL Not found" - } - switch -glob $ncode { - 30[1237] {### redirect - see below ###} - default {cleanup $token ; return $url} - } - upvar #0 $token state - array set meta [set ${token}(meta)] - cleanup $token - if {![info exists meta(Location)]} { - return $url - } - set url $meta(Location) - unset meta - } - return $url -} -proc ::http::wget {url destfile {verbose 1}} { - set tmpchan [open $destfile w] - fconfigure $tmpchan -translation binary - if { $verbose } { - puts [list GETTING [file tail $destfile] from $url] - } - set real_url [_followRedirects $url] - set token [geturl $real_url -channel $tmpchan -binary yes] - if {[ncode $token] != "200"} { - error "DOWNLOAD FAILED" - } - cleanup $token - close $tmpchan -} ### # END: httpwget/wget.tcl ### ### @@ -1008,11 +968,10 @@ # Run the destructor once and only once set self [self] my variable DestroyEvent if {$DestroyEvent} return set DestroyEvent 1 -::clay::object_destroy $self } append body $rawbody ::oo::define [current_class] destructor $body } proc ::clay::define::Dict {name {values {}}} { @@ -1071,26 +1030,10 @@ proc ::clay::define::Variable {name {default {}}} { set class [current_class] set name [string trimright $name :/] $class clay set variable/ $name $default } -proc ::clay::object_create {objname {class {}}} { - #if {$::clay::trace>0} { - # puts [list $objname CREATE] - #} -} -proc ::clay::object_rename {object newname} { - if {$::clay::trace>0} { - puts [list $object RENAME -> $newname] - } -} -proc ::clay::object_destroy objname { - if {$::clay::trace>0} { - puts [list $objname DESTROY] - } - #::cron::object_destroy $objname -} ::namespace eval ::clay::define { } proc ::clay::ensemble_methodbody {ensemble einfo} { set default standard set preamble {} @@ -1731,10 +1674,28 @@ if {[$class clay exists {*}$args]} { return $class } } return {} + } + refcount { + my variable refcount + if {![info exists refcount]} { + return 0 + } + return $refcount + } + refcount_incr { + my variable refcount + incr refcount + } + refcount_decr { + my variable refcount + incr refcount -1 + if {$refcount <= 0} { + ::clay::object_destroy [self] + } } replace { set clay [lindex $args 0] } source { @@ -1860,29 +1821,48 @@ ::clay::object clay branch array ::clay::object clay branch mixin ::clay::object clay branch option ::clay::object clay branch dict clay ::clay::object clay set variable DestroyEvent 0 +if {[info commands ::cron::object_destroy] eq {}} { + # Provide a noop if we aren't running with the cron scheduler + namespace eval ::cron {} + proc ::cron::object_destroy args {} +} ::namespace eval ::clay::event { } -proc ::clay::destroy args { - if {![info exists ::clay::idle_destroy]} { - set ::clay::idle_destroy {} - } - foreach object $args { - if {$object in $::clay::idle_destroy} continue - lappend ::clay::idle_destroy $object - } -} proc ::clay::cleanup {} { if {![info exists ::clay::idle_destroy]} return foreach obj $::clay::idle_destroy { if {[info commands $obj] ne {}} { catch {$obj destroy} } } set ::clay::idle_destroy {} +} +proc ::clay::object_create {objname {class {}}} { + #if {$::clay::trace>0} { + # puts [list $objname CREATE] + #} +} +proc ::clay::object_rename {object newname} { + if {$::clay::trace>0} { + puts [list $object RENAME -> $newname] + } +} +proc ::clay::object_destroy args { + if {![info exists ::clay::idle_destroy]} { + set ::clay::idle_destroy {} + } + foreach objname $args { + if {$::clay::trace>0} { + puts [list $objname DESTROY] + } + ::cron::object_destroy $objname + if {$objname in $::clay::idle_destroy} continue + lappend ::clay::idle_destroy $objname + } } proc ::clay::event::cancel {self {task *}} { variable timer_event variable timer_script