Tcl Library Source Code

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 {} {
  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]
  }
}

###
# 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 *}} {
  variable timer_event
  variable timer_script

proc ::clay::define::destructor rawbody {
  set body {
# Run the destructor once and only once
set self [self]
my variable DestroyEvent
if {$DestroyEvent} return
set DestroyEvent 1

}
  append body $rawbody
  ::oo::define [current_class] destructor $body
}

proc ::clay::define::Dict {name {values {}}} {
  set class [current_class]

#    (if missing) when the object changes class via the [emph morph] method.
###
proc ::clay::define::Variable {name {default {}}} {
  set class [current_class]
  set name [string trimright $name :/]
  $class clay set variable/ $name $default
}

        }
        foreach class $clayorder {
          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 {
        source [lindex $args 0]
      }

    [example {property variable NAME {default DEFAULT}}]
    [para]
    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::ensemble_methodbody] [arg ensemble] [arg einfo]]


[call proc [cmd clay::define::Ensemble] [arg rawmethod] [opt "[arg args]"]]









[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 "*"]"]]

Cancel a scheduled event

proc ::clay::define::destructor rawbody {
  set body {
# Run the destructor once and only once
set self [self]
my variable DestroyEvent
if {$DestroyEvent} return
set DestroyEvent 1

}
  append body $rawbody
  ::oo::define [current_class] destructor $body
}
proc ::clay::define::Dict {name {values {}}} {
  set class [current_class]
  set name [string trim $name :/]

  }
}
proc ::clay::define::Variable {name {default {}}} {
  set class [current_class]
  set name [string trimright $name :/]
  $class clay set variable/ $name $default
}

















###
# END: metaclass.tcl
###
###
# START: ensemble.tcl
###

        }
        foreach class $clayorder {
          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 {
        source [lindex $args 0]
      }

###
# END: object.tcl
###
###
# START: event.tcl
###
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

  foreach {id event} [array get timer_event $self:$task] {
    ::after cancel $event

#!/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

      ###
      # Send any POST/PUT/etc content
      ###
      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]

    chan puts $chanb $replybuffer
    ###
    # 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
  ###
  method DirectoryListing {local_file} {
    my error 403 {Not Allowed}
    tailcall my DoOutput
  }
}

###
# A metaclass for MIME handling behavior across a live socket
###
clay::define ::httpd::mime {


  method ChannelCopy {in out args} {
    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
  method html_header {{title {}} args} {
    set result {}

      }
    }
    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
  }

}

  }
}

::clay::define ::httpd::content.cache {

  method Dispatch {} {
    my variable 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 {}} {

      tailcall my DoOutput
    }
    if {$chan eq {}} return
    my wait writable $chan
    if {![info exists reply_file]} {
      tailcall my DoOutput
    }

    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



  }
}

    }
    $pageobj clay mixinmap {*}$mixinmap
    if {[dict exists $reply delegate]} {
      $pageobj clay delegate {*}[dict get $reply delegate]
    }
    $pageobj dispatch $sock $reply
    set output [$pageobj output]
    $pageobj clay refcount_decr
    return $output
  }
}

    if {$sock eq {}} {
      my error 404 {Not Found}
      tailcall my DoOutput
    }
    my log HttpAccess {}
    chan event $sock writable [info coroutine]
    yield
    my ChannelRegister $sock
    my ProxyRequest $chan $sock
    my ProxyReply   $sock $chan



  }
}

Terminate the transaction, and close the socket.

[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
content, and closing the connection. (See class writetup).

a timeout error to the request if it has, as well as destroy the object and close the
[arg chan] socket.

[call method [cmd timestamp]]

Return the current system time in the format: [example {%a, %d %b %Y %T %Z}]























[call method [cmd Url_Decode] [arg string]]

De-httpizes a string.

[list_end]

# 	}
# }
#
# }]
###
::clay::define ::httpd::reply {
  superclass ::httpd::mime
  Variable ChannelRegister {}

  Delegate <server> {
    description {The server object which spawned this reply}
  }

  ###
  # A dictionary which will converted into the MIME headers of the reply

    REMOTE_ADDR {}
    REMOTE_HOST {}
    USER_AGENT {}
    SESSION {}
  }

  constructor {ServerObj args} {
    my variable dispatched_time uuid
    set uuid [namespace tail [self]]
    set dispatched_time [clock milliseconds]
    my clay delegate <server> $ServerObj
    foreach {field value} [::clay::args_to_options {*}$args] {
      my clay set config $field: $value
    }
  }

  ###
  # 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 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
  ###
  method Log_Dispatched {} {
    my log Dispatched [dict create \

  # ensemble
  # [para]
  # 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 {
        set mixinmap {}
      }

      }
      my Session_Load
      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
    my DoOutput

        append result $reply_body
      } else {
        append result [my reply output]
      }
      chan puts -nonewline $chan $result
      my log HttpAccess {}
    }

  }

  ###
  # For GET requests, converts the QUERY_DATA header into a key/value list.
  #
  # For POST requests, reads the Post data and converts that information to
  # a key/value list for application/x-www-form-urlencoded posts. For multipart

    }
    return $postdata
  }

  # Manage session data
  method Session_Load {} {}


































  # 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
  }

    my counter url_hit
    try {
      # 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}
          return
        }
        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 -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]
        set uriinfo [::uri::split $uri]
        dict set query http REQUEST_PATH    [dict get $uriinfo path]

    try {
      set pageobj [::httpd::reply create ::httpd::object::$uuid [self]]
      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]]
      $pageobj clay refcount_decr
      catch {chan event readable $sock {}}
      catch {chan event writeable $sock {}}
      catch {chan close $sock}
      return
    }
  }
}

  # normal cases, an object of class [cmd ::http::reply] is created, and that class's
  # [cmd dispatch] method.
  # 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} \
      -buffering line
    my counter url_hit

  # Check open connections for a time out event.
  ###
  method CheckTimeout {} {
    foreach obj [info commands ::httpd::object::*] {
      try {
        $obj timeOutCheck
      } on error {} {
        $obj clay refcount_decr
      }
    }
    ::clay::cleanup
  }

  method debug args {}

  ###
  # Given a key/value list of information, return a data structure describing how
  # the server should reply.

 }

 }]



[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




[call variable [cmd request]]
 A dictionary containing the SCGI transformed HTTP headers for the request




[list_end]
[para]
[class {Delegate}]
[list_begin definitions]
[call delegate [cmd <server>]]The server object which spawned this reply

[list_end]
[para]
[class {Methods}]
[list_begin definitions]
[call method [cmd "constructor"] [arg ServerObj] [opt "[arg args]"]]


[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

 POST or PUSH. Returns an empty string otherwise.



[call method [cmd "Session_Load"]]
 Manage session data


























[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.

}
namespace eval ::httpd {
}
namespace eval ::scgi {
}
clay::define ::httpd::mime {
  method ChannelCopy {in out args} {
    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 "<!DOCTYPE html>\n<HTML><HEAD>"
    if {$title ne {}} {
      append result "<TITLE>$title</TITLE>"

          lappend pathlist $part
        }
      }
    }
    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
###
###
# START: reply.tcl
###
::clay::define ::httpd::reply {
  superclass ::httpd::mime
  Variable ChannelRegister {}
  Delegate <server> {
    description {The server object which spawned this reply}
  }
  Dict reply {}
  Dict request {
    CONTENT_LENGTH 0
    COOKIE {}
    HTTP_HOST {}
    REFERER {}
    REQUEST_URI {}
    REMOTE_ADDR {}
    REMOTE_HOST {}
    USER_AGENT {}
    SESSION {}
  }
  constructor {ServerObj args} {
    my variable dispatched_time uuid
    set uuid [namespace tail [self]]
    set dispatched_time [clock milliseconds]
    my clay delegate <server> $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 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] \
     COOKIE [my request get HTTP_COOKIE] \
     REFERER [my request get HTTP_REFERER] \
     USER_AGENT [my request get HTTP_USER_AGENT] \
     REQUEST_URI [my request get REQUEST_URI] \
     HTTP_HOST [my request get HTTP_HOST] \
     SESSION [my request get SESSION] \
    ]
  }
  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 {
        set mixinmap {}
      }

      }
      my Session_Load
      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
    my DoOutput
  }

        append result $reply_body
      } else {
        append result [my reply output]
      }
      chan puts -nonewline $chan $result
      my log HttpAccess {}
    }

  }
  method FormData {} {
    my variable chan formdata
    # Run this only once
    if {[info exists formdata]} {
      return $formdata
    }

      my variable chan
      chan configure $chan -translation binary -blocking 0 -buffering full -buffersize 4096
      set postdata [::coroutine::util::read $chan $length]
    }
    return $postdata
  }
  method Session_Load {} {}











  method puts line {
    my variable reply_body
    append reply_body $line \n
  }
  method RequestFind {field} {
    my variable request
    if {[dict exists $request $field]} {

    dict set result SERVER_SOFTWARE [my clay get server/ string]
    if {[string match 127.* $ip]} {
      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} \
      -buffering line
    my counter url_hit

    incr counters($which)
  }
  method CheckTimeout {} {
    foreach obj [info commands ::httpd::object::*] {
      try {
        $obj timeOutCheck
      } on error {} {
        $obj clay refcount_decr
      }
    }
    ::clay::cleanup
  }
  method debug args {}
  method dispatch {data} {
    set reply [my Dispatch_Local $data]
    if {[dict size $reply]} {
      return $reply
    }

    set HTTP_STATUS [my reply get Status]
    my puts [subst $msg]
  }
}
::clay::define ::httpd::content.cache {
  method Dispatch {} {
    my variable 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 {}} {
      my reply set Status [my request get HTTP_STATUS]
    }

      tailcall my DoOutput
    }
    if {$chan eq {}} return
    my wait writable $chan
    if {![info exists reply_file]} {
      tailcall my DoOutput
    }

    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
###
###

    if {$sock eq {}} {
      my error 404 {Not Found}
      tailcall my DoOutput
    }
    my log HttpAccess {}
    chan event $sock writable [info coroutine]
    yield
    my ChannelRegister $sock
    my ProxyRequest $chan $sock
    my ProxyReply   $sock $chan



  }
}

###
# END: proxy.tcl
###
###

      ###
      # Send any POST/PUT/etc content
      ###
      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]
    chan event $chana readable {}
    set replyhead [my HttpHeaders $chana]

    chan puts $chanb $replybuffer
    ###
    # 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
  }
}

          return
        }
        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 -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]
        set uriinfo [::uri::split $uri]
        dict set query http REQUEST_PATH    [dict get $uriinfo path]

    try {
      set pageobj [::httpd::reply create ::httpd::object::$uuid [self]]
      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]]
      $pageobj clay refcount_decr
      catch {chan event readable $sock {}}
      catch {chan event writeable $sock {}}
      catch {chan close $sock}
      return
    }
  }
}

    }
    $pageobj clay mixinmap {*}$mixinmap
    if {[dict exists $reply delegate]} {
      $pageobj clay delegate {*}[dict get $reply delegate]
    }
    $pageobj dispatch $sock $reply
    set output [$pageobj output]
    $pageobj clay refcount_decr
    return $output
  }
}

###
# END: plugin.tcl
###

    namespace eval ::httpd {
	namespace export *
    }

} else {
  set TCLLIBMOD [file join $MODDIR .. .. tcllib modules]
}
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
}

testing {
    useLocal httpd.tcl httpd
}

# Set to true for debugging and traces
set ::DEBUG 0
set ::clay::debug $::DEBUG

proc DEBUG args {
    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 {}

























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)

    #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)
    }
}


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
    }
}


###
# 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"
    }
}

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]
    }
}
clay::define ::test::content.file {
    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 $::NOW
    }
}
clay::define ::test::content.error {
    method content {} {
        error {The programmer asked me to die this way}
    }
}
clay::define ::test::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
}

###
# 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} 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} -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} {
    ::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} -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} -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} -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} -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} -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

    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]]
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} 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} -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} -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} -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} -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} -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} -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/assets]



















::DEBUG puts httpd-cgi-0001
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} -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
###


test httpd-memchan-0001 {Memchan GET} {
    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!)


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,"
}

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)

    #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)
    }
}

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

    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

    clay set reply_class ::scgi::test::reply
}

::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} 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} -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} -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} -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} -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} -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

# -------------------------------------------------------------------------

testsuiteCleanup

# Local variables:
# mode: tcl
# indent-tabs-mode: nil

###
# Amalgamated package for practcl
# Do not edit directly, tweak the source in src/ and rerun
# build.tcl
###
package require Tcl 8.6
package provide practcl 0.16.3
namespace eval ::practcl {}

###
# START: httpwget/wget.tcl
###









































###
# END: httpwget/wget.tcl
###
###
# START: clay/clay.tcl
###

proc ::clay::define::destructor rawbody {
  set body {
# Run the destructor once and only once
set self [self]
my variable DestroyEvent
if {$DestroyEvent} return
set DestroyEvent 1

}
  append body $rawbody
  ::oo::define [current_class] destructor $body
}
proc ::clay::define::Dict {name {values {}}} {
  set class [current_class]
  set name [string trim $name :/]

  }
}
proc ::clay::define::Variable {name {default {}}} {
  set class [current_class]
  set name [string trimright $name :/]
  $class clay set variable/ $name $default
}
















::namespace eval ::clay::define {
}
proc ::clay::ensemble_methodbody {ensemble einfo} {
  set default standard
  set preamble {}
  set eswitch {}
  if {[dict exists $einfo default]} {

        }
        foreach class $clayorder {
          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 {
        source [lindex $args 0]
      }

  }
}
::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::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

  foreach {id event} [array get timer_event $self:$task] {
    ::after cancel $event