#! /bin/env tclsh
namespace eval interface {
package require {ycl proc}
[yclprefix] proc alias alias [yclprefix] proc alias
alias aliases [yclprefix] proc aliases
aliases {
{ycl eval} {
upcall
}
{ycl ns} {
nsjoin join
}
{ycl proc} {
imports
}
}
proc new name {
variable interfacens
set new [upcall 1 [yclprefix] ns object $name]
$new .extend $interfacens
set interface [$new .namespace]::interface
namespace eval $interface {}
imports $interface $interfacens {
{next firstline}
}
$new .extend $interface
return $new
}
set interfacens [nsjoin [namespace parent] interface]
imports [namespace parent] [namespace current] {
new
}
}
namespace eval interface {}
namespace eval system {
namespace eval doc {}
namespace eval util {
package require {ycl proc}
[yclprefix] proc alias alias [yclprefix] proc alias
alias aliases [yclprefix] proc aliases
aliases {
{ycl ns} {
nsjoin join
}
{ycl proc} {
checkargs
imports
}
}
}
::namespace path util
variable doc::init {
description {
Read http headers .
}
args {
_ {}
chan {
description {
Positional . The channel to read from . This object takes
ownership of the channel but does not ever close it .
}
positional 1
process {
chan configure $chan -blocking 0
$_ = chan $chan
}
}
lc {
description {
Ensure that header names are lower case .
}
default {lindex yes}
process {$_ = lc $lc}
}
maxchars {
default {lindex 16777216}
process {$_ = maxchars $maxchars}
}
leadingwhite {
description {
Allow whitespace prior to the first header. Chunk trailers for
example don't tolerate leading whitespace .
}
default {lindex 0}
process {
$_ = leadingwhite $leadingwhite
}
}
}
}
proc init {_ chan args} {
$_ .vars done field name value
checkargs $doc::init {*}$args
set done 0
set field {}
set name {}
set value {}
return $_
}
apply [list {} [string map [list @checkpending@ {
if {![chan configure $chan -blocking]} {
chan event $chan readable [list [info coroutine]]
yield
}
set pending [chan pending output $chan]
if {$pending > $maxchars} {
return -code error [list {line of} $pending exceeds $maxchars]
break
}
gets $chan line
} @remover@ {
if {[string index $line end] eq "\r"} {
set line [string range $line[set line {}] 0 end-1]
}
}] {
variable doc::next {
description {
Return the next header . Yields from the current coroutine if needed .
}
}
proc next_ _ {
$_ .vars blocking chan done field lc maxchars name value
while 1 {
if {$done} {
return -code break
}
@checkpending@
if {$line eq {}} {
set done 1
} else {
@remover@
if {[regexp {^\s+(\S.*)$} $line -> folded]} {
append field { } $folded
continue
}
}
set res $field
set field $line
# It's legal to remove any whitespace from field-name, right?
regexp {^\s*([^:\s]+):\s*(\S.*)\s*$} $res -> name value
if {$lc} {
set name [string tolower $name]
}
if {$name eq {}} {
return -code error [list {bad header} $res]
} else {
return [list $name $value]
}
}
}
proc firstline _ {
$_ .vars chan field leadingwhite maxchars
while 1 {
@checkpending@
if {$line eq {}} {
if {[eof $chan]} {
return -code break
} else continue
} else {
if {$leadingwhite} {
regsub {^\s*} $line[set line {}] {} line
} else {
if {[regexp {\^s+} $line]} {
error [list {leading white space}]
}
}
@remover@
if {$line eq {}} {
return -code break
}
set field $line
rename [$_ .namespace]::interface::next {}
imports [$_ .namespace]::interface [namespace current] {
{next next_}
}
tailcall $_ next
}
}
}
}] [namespace current]]
imports [nsjoin [namespace parent] interface] [namespace current] {
firstline
init
}
}
namespace eval system2 {
proc return {_ args} {
$_ .vars chan name value
set name {}
set value {}
chan event $chan readable {}
tailcall ::return {*}$args
}
}