TkCon Adapter

ad_library {

    Routines for tkcon interface

    @author rildo pragrana, Gustaf Neumann (neumann@wu-wien.ac.at)
    @creation-date 23 Jan 2009
    @cvs-id $Id$
}

if {[info command ::thread::mutex] eq ""} {
  ns_log notice "libthread does not appear to be available, NOT loading tkcon interface"
  return
}

Class tkcon -parameter {port {persistent 1}} -superclass ::xotcl::THREAD
tkcon set ports {8765 8764 8763}
tkcon set per_thread_code {
  #
  # tkcon client adapter
  #
  Class ::TkconClient -parameter {port {myaddr "[ns_info address]"}}
  
  ::TkconClient instproc init {} {
    my instvar socket script server socket port myaddr
    my requireNamespace
    set socket ""; set server ""; set script ""
    my set server [socket -server [list [self] accept] -myaddr $myaddr $port]
    ns_log notice "### starting [self] $myaddr:$port"
  }
  
  ::TkconClient instproc destroy {} {
    my instvar server
    if {$server ne ""} {
      my closesocket
      close $server
    }
    next
  }
  
  ::TkconClient instproc closesocket {} {
    my instvar socket
    catch {close $socket}
    set socket ""
    # Restore [puts]
    rename ::puts ""
    rename [self]::puts ::puts
    if {![ns_conn isconnected]} {
      foreach cmd {ns_getform ns_conn} {
	rename ::$cmd ""
	rename [self]::$cmd ::$cmd
      }
    }
  }
  
  ::TkconClient instproc accept {sock host port} {
    my instvar socket
    fconfigure $sock -blocking 0 -buffering none
    if {$socket ne ""} {
      [self]::puts $sock "Only one connection at a time, please!"
      close $sock
    } else {
      set socket $sock
      fileevent $sock readable [list [self] handle]
      # Redirect [puts]
      rename ::puts [self]::puts
      interp alias {} ::puts {} [self] _puts
      if {![ns_conn isconnected]} {
	foreach cmd {ns_getform ns_conn} {
	  rename ::$cmd [self]::$cmd
	  interp alias {} ::$cmd {} [self] _$cmd
	}
      }
    }
  }
  
  ::TkconClient instproc handle {} {
    my instvar script socket
    if {[eof $socket]} {
      my closesocket
      return
    }
    if {![catch {read $socket} chunk]} {
      if {$chunk eq "bye\n"} {
	puts $socket "Bye!"
	my closesocket
	return
      }
      append script $chunk
      if {[info complete $script]} {
	set error [catch {uplevel "#0" $script} result]
	if {$result ne ""} {
	  [self]::puts $socket $result
	}
	if {$berror} {
	  [self]::puts $socket $::errorInfo
	}
	set script ""
      }
    } else {
      my closesocket
    }
  }
  
  
  ## This procedure is partially borrowed from tkcon
  ::TkconClient instproc _puts args {
    my instvar socket
    set len [llength $args]
    foreach {arg1 arg2 arg3} $args { break }
    ns_log notice "_puts $args -> $len"
    switch $len {
      1 {
	[self]::puts $socket $arg1
      }
      2 {
	switch -- $arg1 {
	  -nonewline - stdout - stderr {
	    [self]::puts $socket $arg2
	  }
	  default {
	    set len 0
	  }
	}
      }
      3 {
	if {$arg1 eq "-nonewline" && ($arg2 eq "stdout" || $arg2 eq "stderr")} {
	  [self]::puts $socket $arg3
	} elseif {($arg1 eq "stdout" || $arg1 eq "stderr") && $arg3 eq "-nonewline"} {
	  [self]::puts $socket $arg2
	} else {
	  set len 0
	}
      }
      default {
	set len 0
      }
    }
    ## $len == 0 means it wasn't handled above.
    if {$len == 0} {
      ns_log notice "LEN=0"
      global errorCode errorInfo
      if {[catch [linsert $args 0 puts] msg]} {
	regsub tkcon_tcl_puts $msg puts msg
	regsub -all tkcon_tcl_puts $errorInfo puts errorInfo
	return -code error $msg
      }
      return $msg
    }
  }
  ::TkconClient instproc _ns_getform {args} {
    ns_log notice "ns_getform called without connection"
    return ""
  }
  ::TkconClient instproc _ns_conn {subcmd} {
    ns_log notice "ns_conn $subcmd called without connection"
    switch -- $subcmd {
      url - 
      package_id {return [::xo::cc $subcmd]}
      query {return [::xo::cc actual_query]}
      default {return [[self]::ns_conn $subcmd]}
    }
    return ""
  }
}

tkcon instproc init {} {
  next [tkcon set per_thread_code]
}
tkcon instproc running {} {
  # Check, if a tkcon thread has currently a server running
  return [my do Object isobject client]
}
tkcon instproc start {} {
  #
  # start this tkcon instance ...
  #
  set c [my do TkconClient create client -port [my port]]
  #
  # ... and return the necessary infos about it (object and host:port)
  #
  return "[self] running at [my do $c myaddr]:[my port]"
}
#
# A certain tkcon instance can be selectively stopped with
# e.g. "::tkcon-8764 stop"
#
tkcon instproc stop {} {
  my do client destroy
}


#
# Create for every defined port an tkcon instance object; threads will
# be created on demand
#
foreach port [tkcon set ports] {
  tkcon create tkcon-$port -port $port
  ns_log notice "created tkcon-$port"
}

tkcon proc start {} {
  #
  # Start a server in the first tkcon thread, where no server runs
  #
  foreach tkcon [my info instances] {
    if {![$tkcon running]} {
      # the start command returns the info of the selected 
      # tkcon adapter
      return [$tkcon start]
    }
  }
}