Tcl Library Source Code

	# builtin gets command with the bogus arguments gives us the
	# necessary error with the proper message.
	tailcall ::chan gets {*}$args
    }

    # Loop until we have a complete line. Yield to the event loop
    # where necessary. During 
    set blocking [::chan configure $chan -blocking]
    while {1} {

        ::chan configure $chan -blocking 0

	try {
	    set result [::chan gets $chan line]
	} on error {result opts} {
            ::chan configure $chan -blocking $blocking
            return -code $result -options $opts

                return $result
            } else {
                return $line
            }
        }
    }
}


proc ::coroutine::util::gets_safety {chan limit varname} {
    # Process arguments.
    # Acceptable syntax:
    # * gets CHAN ?VARNAME?

    # Loop until we have a complete line. Yield to the event loop
    # where necessary. During 
    set blocking [::chan configure $chan -blocking]
    upvar 1 $varname line
    try {
	while {1} {
	    ::chan configure $chan -blocking 0
	    if {[::chan pending input $chan]>= $limit} {
		error {Too many notes, Mozart. Too many notes}
	    }
	    try {
		set result [::chan gets $chan line]
	    } on error {result opts} {
		return -code $result -options $opts
	    }
    
	    if {[::chan blocked $chan]} {
		::chan event $chan readable [list [info coroutine]]
		yield
		::chan event $chan readable {}
	    } else {
		return $result
	    }
	}
    } finally {
        ::chan configure $chan -blocking $blocking
    }
}



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

proc ::coroutine::util::read {args} {
    # Process arguments.
    # Acceptable syntax:
    # * read ?-nonewline ? CHAN

returned.

[call [cmd {coroutine::util gets}] [arg chan] [opt [arg varname]]]

This command reads a line from the channel [arg chan] and returns it
either as its result, or, if a [arg varname] was specified, writes it
to the named variable and returns the number of characters read.

[call [cmd {coroutine::util gets_safety}] [arg chan] [arg limit] [arg varname]]

This command reads a line from the channel [arg chan] up to size [arg limit]
and stores the result in [arg varname]. Of [arg limit] is reached before the
set first newline, an error is thrown. The command returns the number of
characters read.

[call [cmd {coroutine::util global}] [arg varname]...]

This command imports the named global variables of the coroutine into
the current scope. From the technical point of view these variables
reside in level [const #1] of the Tcl stack. I.e. these are not the
regular global variable in to the global namespace, and each coroutine

  }
  
  method connect {sock ip port} {
    ###
    # If an IP address is blocked
    # send a "go to hell" message
    ###
    if {[my Validate_Connection $sock $ip]} {
      catch {close $sock}
      return
    }
    set uuid [::tool::uuid_short] 
    chan configure $sock \
      -blocking 0 \
      -translation {auto crlf} \
      -buffering line
    
    set coro [coroutine [namespace current]::CORO$uuid ::apply [list {uuid sock ip} {
      yield [info coroutine]
      tailcall my Connect $uuid $sock $ip
    } [namespace current]] $uuid $sock $ip]

    chan event $sock readable $coro
  }
  
  method Connect {uuid sock ip} {

    my counter url_hit
    set line {}
    try {
      set readCount [::coroutine::util::gets_safety $sock 4096 line]
      dict set query REMOTE_ADDR     $ip
      dict set query REQUEST_METHOD  [lindex $line 0]
      set uriinfo [::uri::split [lindex $line 1]]
      dict set query REQUEST_URI     [lindex $line 1]
      dict set query REQUEST_PATH    [dict get $uriinfo path]
      dict set query REQUEST_VERSION [lindex [split [lindex $line end] /] end]
      if {[dict get $uriinfo host] eq {}} {

      set reply [my dispatch $query]
      if {[llength $reply]} {
        if {[dict exists $reply class]} {
          set class [dict get $reply class]          
        } else {
          set class [my cget reply_class]
        }  
        set pageobj [$class create [namespace current]::reply$uuid [self]]
        if {[dict exists $reply mixin]} {
          oo::objdefine $pageobj mixin [dict get $reply mixin]
        }
        $pageobj dispatch $sock $reply
        my log HttpAccess $line
      } else {
        try {
          my log HttpMissing $line
          chan puts $sock "HTTP/1.0 404 NOT FOUND"
          dict with query {}
          set body [subst [my template notfound]]
          chan puts $sock "Content-length: [string length $body]"
          chan puts $sock
          chan puts $sock $body
        } on error {err errdat} {
          puts stderr "FAILED ON 404: $err"
        } finally {
          catch {chan close $sock}
          catch {destroy $pageobj}
        }
      }
    } on error {err errdat} {
      try {
        puts stderr [dict print $errdat]
        chan puts $sock "HTTP/1.0 505 INTERNAL ERROR"
        dict with query {}
        set body [subst [my template internal_error]]
        chan puts $sock "Content-length: [string length $body]"
        chan puts $sock
        chan puts $sock $body
        my log HttpError $line
      } on error {err errdat} {
        puts stderr "FAILED ON 505: $::errorInfo"
      } finally {
        catch {chan close $sock}
        catch {destroy $pageobj}
      }
    }
  }

  method counter which {
    my variable counters
    incr counters($which)

  }
  
  ###
  # Return true if this IP address is blocked
  # The socket will be closed immediately after returning
  # This handler is welcome to send a polite error message
  ###
  method Validate_Connection {sock ip} {
    return 0
  }
}

package provide httpd 4.0.1