dialog.tcl

Go to the documentation of this file.

/*  -*- tcl -*-*/
/*  Dialog - Dialog Demon (Server, or Client)*/
/*  Copyright (c) 2004, Andreas Kupries <andreas_kupries@users.sourceforge.net>*/

puts "- dialog (coserv-based)"

/*  ### ### ### ######### ######### #########*/
/*  Commands on top of a plain comm server.*/
/*  Assumes that the comm server environment*/
/*  is present. Provides set up and execution*/
/*  of a fixed linear dialog, done from the*/
/*  perspective of a server application.*/

/*  ### ### ### ######### ######### #########*/
/*  Load "comm" into the master.*/

namespace ::dialog {
    variable dtrace    {}
}

/*  ### ### ### ######### ######### #########*/
/*  Start a new dialog server.*/

ret  ::dialog::setup (type type , type cookie) {
    variable id
    variable port

    switch -- $type {
    server  {set server 1}
    client  {set server 0}
    default {return -code error "Bad dialog type \"$type\", expected server, or client"}
    }

    set id [::coserv::start "$type: $cookie"]
    ::coserv::run $id {
    set responses {}
    set strace    {}
    set received  {}
    set conn      {}
    set ilog      {}

    proc Log {text} {
        global ilog ; lappend ilog $text
    }
    proc Strace {text} {
        global strace ; lappend strace $text
    }
    proc Exit {sock reason} {
        Strace $reason
        Log    [list $reason $sock]
        close  $sock
        Done
    }
    proc Done {} {
        global main strace ilog
        comm::comm send $main [list dialog::done [list $strace $ilog]]
        return
    }
    proc ClearTraces {} {
        global strace ; set strace {}
        global ilog   ; set ilog   {}
        return
    }
    proc Step {sock} {
        global responses trace

        if {![llength $responses]} {
        Exit $sock empty
        return
        }

        set now       [lindex $responses 0]
        set responses [lrange $responses 1 end]

        Log  [list ** $sock $now]
        eval [linsert $now end $sock]
        return
    }

    # Step commands ...

    proc .Crlf {sock} {
        Strace crlf
        Log crlf
        fconfigure $sock -translation crlf
        Step $sock
        return
    }
    proc .Binary {sock} {
        Strace bin
        Log binary
        fconfigure $sock -translation binary
        Step $sock
        return
    }
    proc .HaltKeep {sock} {
        Log halt.keep
        Done
        global responses
        set    responses {}
        # No further stepping.
        # This keeps the socket open.
        # Needs external reset/cleanup
        return
    }
    proc .Send {line sock} {
        Strace [list >> $line]
        Log    [list >> $line]

        if {[catch {
        puts  $sock $line
        flush $sock
        } msg]} {
        Exit $sock broken
        return
        }
        Step $sock
        return
    }
    proc .Geval {script sock} {
        Log geval
        uplevel #0 $script
        Step $sock
        return
    }
    proc .Eval {script sock} {
        Log eval
        eval $script
        Step $sock
        return
    }
    proc .SendGvar {vname sock} {
        upvar #0 $vname line
        .Send $line $sock
        return
    }
    proc .Receive {sock} {
        set aid     [after 10000 [list Timeout    $sock]]
        fileevent $sock readable [list Input $aid $sock]
        # No "Step" here. Comes through input.
        Log "   Waiting    \[$aid\]"
        return
    }
    proc Input {aid sock} {
        global received
        if {[eof $sock]} {
        # Clean the timer up
        after cancel $aid
        Exit $sock close
        return
        }
        if {[gets $sock line] < 0} {
        Log "   **|////|**"
        return
        }

        Log "-- -v-"
        Log "   Events off \[$aid, $sock\]"
        fileevent    $sock readable {}
        after cancel $aid

        Strace [list << $line]
        Log    [list << $line]
        lappend received $line

        # Now we can step further
        Step $sock
        return
    }
    proc Timeout {sock} {
        Exit $sock timeout
        return
    }
    proc Accept {sock host port} {
        fconfigure $sock -blocking 0
        ClearTraces
        Step $sock
        return
    }

    proc Server {} {
        global port
        # Start listener for dialog
        set listener [socket -server Accept 0]
        set port     [lindex [fconfigure $listener -sockname] 2]
        # implied return of <port>
    }

    proc Client {port} {
        global conn
        catch {close $conn}

        set conn [set sock [socket localhost $port]]
        fconfigure $sock -blocking 0
        ClearTraces
        Log [list Client @ $port = $sock]
        Log [list Channels $port = [lsort [file channels]]]
        Step $sock
        return
    }
    }

    if {$server} {
    set port [coserv::run $id {Server}]
    }
}

ret  ::dialog::runclient (type port) {
    variable id
    variable dtrace {}
    coserv::task $id [list Client $port]
    return
}

ret  ::dialog::dialog_set (type response_, type script) {
    begin
    uplevel 1 $response_script
    end
    return
}

ret  ::dialog::begin (optional cookie ={)} {
    variable id
    ::coserv::task $id [list set responses {}]
    log::log debug "+============================================ $cookie \\\\"
    return
}

ret  ::dialog::cmd (type command) {
    variable id
    ::coserv::task $id [list lappend responses $command]
    return
}

ret  ::dialog::end () {
    # This implicitly waits for all preceding commands (which are async) to complete.
    variable id
    set responses [::coserv::run $id [list set responses]]
    ::coserv::run $id {set received {}}
    log::log debug |\t[join $responses \n|\t]
    log::log debug +---------------------------------------------
    return
}

ret  ::dialog::crlf.      ()       {cmd .Crlf}
ret  ::dialog::binary.    ()       {cmd .Binary}
ret  ::dialog::send.      (type line)   {cmd [list .Send $line]}
ret  ::dialog::receive.   ()       {cmd .Receive}
ret  ::dialog::respond.   (type line)   {receive. ; send. $line}
ret  ::dialog::request.   (type line)   {send. $line ; receive.}
ret  ::dialog::halt.keep. ()       {cmd .HaltKeep}
ret  ::dialog::sendgvar.  (type vname)  {cmd [list .SendGvar $vname]}
ret  ::dialog::reqgvar.   (type vname)  {sendgvar. $vname ; receive.}
ret  ::dialog::geval.     (type script) {cmd [list .Geval $script]}
ret  ::dialog::eval.      (type script) {cmd [list .Eval  $script]}

ret  ::dialog::done (type traces) {
    variable dtrace $traces
    return
}

ret  ::dialog::waitdone () {
    variable dtrace

    # Loop until we have data from the dialog subprocess.
    # IOW writes which do not create data are ignored.
    while {![llength $dtrace]} {
    vwait ::dialog::dtrace
    }

    foreach {strace ilog} $dtrace break
    set dtrace {}

    log::log debug  +---------------------------------------------
    log::log debug  |\t[join $strace \n|\t]
    log::log debug  +---------------------------------------------
    log::log debug  /\t[join $ilog \n/\t]
    log::log debug "+============================================ //"
    return $strace
}

ret  ::dialog::received () {
    # Wait for all preceding commands to complete.
    variable id
    set received [::coserv::run $id [list set received]]
    ::coserv::run $id [list set received {}]
    return $received
}

ret  ::dialog::listener () {
    variable port
    return $port
}

ret  ::dialog::shutdown () {
    variable id
    variable port
    variable dtrace

    ::coserv::shutdown $id

    set id     {}
    set port   {}
    set dtrace {}
    return
}

/*  ### ### ### ######### ######### #########*/