Attributes  edit

name

MOST

location

http://wiki.tcl.tk/MOST

updated

2007-09

contact

mailto:larry@wildopensource.com (Larry Smith)

Synopsis  edit

Description

http://wiki.tcl.tk/1243

Sources for MOST

# MOST - Mini Object System for Tequila - most.tcl

rename unknown _unknown
proc unknown { name args } {
    upvar $name self
    if {![ catch {set type $self(class)} ]} {
    } else {
        eval _unknown $name $args
        return
    }
    proc $name args "uplevel @ $name \$args"
    uplevel trace variable $name u \[ list rename $name "" \]
    uplevel $name $args
}

proc class { name instvars methods } {
    upvar $name type

    set type(class) $name
    set type(instvars) $instvars
    foreach var $instvars {
        regsub -all $var $methods self(&) methods
    }
    regsub -all class $methods self(&) methods
    foreach { methodname arglist body } $methods {
        set type($methodname-body) $body
        set type($methodname-args) $arglist
    }
}

proc new { class name args } {
    upvar $name self
    upvar $class type
    set self(class) $class
    foreach instvar $type(instvars) {
        set self($instvar) ""
    }
    if { [ llength $args ] > 0 } { uplevel @ $name $args }
}

proc @ { this { msg $ } args } {
    upvar $this self
    upvar $self(class) class
    foreach arg $class($msg-args) {
        set $arg [ lindex $args 0 ]
        set args [ lrange $args 1 end ]
    }
    return [ eval $class($msg-body) ]
}

proc this { args } { 
    upvar this this
    uplevel 2 $this $args
}

Tequila Server - tequilas.tcl

#!/bin/sh
# Copyright (c) 1999-2000 Jean-Claude Wippler <jcw@equi4.com>
#
# Tequilas  -  the "Tequila Server" implements shared persistent arrays
#\
exec tclkit "$0" ${1+"$@"}

# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Imlementation notes:
#
# Commands starting with "Tqs" can be called from the remote client
# The rest uses lowercase "tqs" to prevent this (and for uniqueness)
#
# There is one global array which is used for all information which
# this server needs to carry around and track, called "tqs_info":
#
#   tqs_info(pending)   - id of pending "after" request, unset if none
#   tqs_info(timeout)   - milliSecs before timed commit, unset if never
#   tqs_info(verbose)   - log level: 0=off, 1=req's, 2=notify, 3=reply
#
# External views (type "X") are stored as files in directory, one item
# per text file.  This can be used to store large amounts of text in
# regular files, outside Metakit (though commit doesn't apply to them):
#
#   tqs_external(view)  - directory name, set for each external view
#
# Valid while processing an incoming request:
#   tqs_info(port)      - socket name of current client request
#
# The following will be defined for individual views:
#   tqs_notify($view)   - socket name of client to notify on changes
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

    # conditonal logging output
proc tqsPuts {level msg} {
    global tqs_info
    if {$level <= $tqs_info(verbose)} {
        puts $msg
    }
}

    # return a displayable string of limited length
proc tqsDisplay {str len} {
    if {[string length $str] > $len} {
        set str "[string range $str 0 $len]..."
    }
    regsub -all {[^ -~]} $str {?} str
    return $str
}

    # remote execution of any Metakit command, added 20-02-2000
proc TqsRemote {cmd args} {
        eval mk::$cmd $args
}

    # return the names of all views currently on file
proc TqsInfo {} {
    mk::file views tqs
}

    # get or set log level (see above for meaning of values 0..3)
proc TqsVerbose {{level ""}} {
    global tqs_info
    if {$level != ""} {
        set tqs_info(verbose) $level
    }
    return $tqs_info(verbose)
}

    # define a view (Metakit's equivalent concept for a Tcl array)
    # if the second argument is true, all existing data is removed
    # the third arg is used to specify a binary (B) of memo format (M)
    # if the third arg is "X", use a directory with files for storage
proc TqsDefine {view {clear 0} {type S}} {
    if {$type == "X"} {
        global tqs_external
        set tqs_external($view) ""
        if {$clear} {
            catch {file delete -force $view.data}
            tqsTrace $view "" u
        }
        file mkdir $view.data
        #catch {mk::view delete tqs.$view}
    } else {
        mk::view layout tqs.$view "name text:$type date:I"
        if {$clear && [mk::view size tqs.$view] > 0} {
            mk::view size tqs.$view 0
            tqsTrace $view "" u
        }
        #file delete -force $view.data
    }
    return
}

    # get rid of a view
proc TqsUndefine {view} {
    global tqs_external
    if {[info exists tqs_external($view)]} {
        file delete -force $view.data
        unset tqs_external($view)
    } else {
        mk::view delete tqs.$view
    }
    tqsTrace $view "" u
    return
}

    # return the list of all keys, like "array names view"
proc TqsNames {view} {
    set result {}
    global tqs_external
    if {[info exists tqs_external($view)]} {
        foreach x [glob -nocomplain $view.data/*] {
            regsub {.*/} $x {} x
            lappend result $x
        }
    } else {
        mk::loop c tqs.$view {
            lappend result [mk::get $c name]
        }
    }
    return $result
}

    # return the number of keys, like "array size view"
proc TqsSize {view} {
    set result {}
    global tqs_external
    if {[info exists tqs_external($view)]} {
        set result [llength [glob -nocomplain $view.data/*]]
    } else {
        set result [mk::view size tqs.$view]
    }
    return $result
}

    # return an existing value, lookup by key, like "set view(key)"
proc TqsGet {view key} {
    global tqs_external
    if {[info exists tqs_external($view)]} {
        set fd [open $view.data/$key]
        fconfigure $fd -translation binary
        set v [read $fd]
        close $fd
        return $v
    } else {
        set n [mk::select tqs.$view name $key]
        mk::get tqs.$view!$n text ;# throws error if absent
    }
}

    # store a value, create if necessary, like "set view(key) data"
    # the optional last arg can be used to force a specific timestamp
proc TqsSet {view key data {timestamp ""}} {
    global tqs_external
    if {[info exists tqs_external($view)]} {
        set fd [open $view.data/$key w]
        fconfigure $fd -translation binary
        puts -nonewline $fd $data
        close $fd
        # timestamp is ignored
    } else {
        set n [mk::select tqs.$view name $key]
        if {[llength $n] == 0} {
            set n [mk::view size tqs.$view]
        } elseif {[mk::get tqs.$view!$n text] == $data} {
            return ;# no change, ignore
        }
        if {$timestamp == ""} {
            set timestamp [clock seconds]
        }
        mk::set tqs.$view!$n name $key text $data date $timestamp
    }
    tqsTrace $view $key w
    return
}

    # Append a value, create if entry did not exist
proc TqsAppend {view key data} {
    global tqs_external
    if {[info exists tqs_external($view)]} {
        set fd [open $view.data/$key a]
        fconfigure $fd -translation binary
        puts -nonewline $fd $data
        close $fd
    } else {
        set n [mk::select tqs.$view name $key]
        if {[llength $n] > 0} {
            if {[string length $data] == 0} then return ;# no change
            set data "[mk::get tqs.$view!$n text]$data"
        }
        mk::set tqs.$view!$n name $key text $data date [clock seconds]
    }
    tqsTrace $view $key w
    return
}

    # delete an existing entry by key, similar to "unset view(key)"
proc TqsUnset {view key} {
    global tqs_external
    if {[info exists tqs_external($view)]} {
        file delete $view.data/$key
    } else {
        set n [mk::select tqs.$view name $key]
        if {[llength $n] == 0} {
            return ;# no change, ignore
        }
        mk::row delete tqs.$view!$n
    }
    tqsTrace $view $key u
    return
}

    # return all key/value pairs, like "array get view"
    # if set, the optional arg sets up change notification
proc TqsGetAll {view {tracking 0}} {
    set result {}
    global tqs_external
    if {[info exists tqs_external($view)]} {
        foreach x [TqsNames $view] {
            lappend result $x [TqsGet $view $x]
        }
    } else {
        mk::loop c tqs.$view {
            eval lappend result [mk::get $c name text]
        }
    }
    if {$tracking} { tqsSubscribe $view }
    return $result
}

    # like TqsGetAll, returns modification dates instead of contents
    # this can be used by the client to synchronize and track dates
    # if set, the optional arg sets up change notification
proc TqsListing {view {tracking 0}} {
    set result {}
    global tqs_external
    if {[info exists tqs_external($view)]} {
        foreach x [TqsNames $view] {
            lappend result $x [file mtime $view.data/$x]
        }
    } else {
        mk::loop c tqs.$view {
            eval lappend result [mk::get $c name date]
        }
    }
    if {$tracking} { tqsSubscribe $view }
    return $result
}
    
    # called to set up notification for a client
proc tqsSubscribe {view} {
    global tqs_info tqs_notify
    
        # remember the client IP and listening number for this view
    tqsPuts 1 "Notification set up for '$view': $tqs_info(port)"
    lappend tqs_notify($view) $tqs_info(port)
}

    # called to unset all notifications for a client
proc tqsUnsubscribe {port} {
    global tqs_notify
    
    foreach {k v} [array get tqs_notify] {
        set n [lsearch -exact $v $port]
        if {$n >= 0} {
            tqsPuts 1 "  Forget notify for $k"

            if {[llength $v] > 1} {
                set tqs_notify($k) [lreplace $v $n $n]
            } else {
                unset tqs_notify($k)
                tqsPuts 1 "   No more notifications for $k"
            }
        }
    }
}

    # set a number of key/value pairs, like "array set view pairs"
proc TqsSetAll {view pairs} {
    foreach {key value} $pairs {
        TqsSet $view $key $value
    }
}

    # save changes to file now
proc TqsCommit {} {
    global tqs_info
    
    set n [clock clicks]
    mk::file commit tqs
    tqsPuts 1 "Commit done ([expr {[clock clicks] - $n}])"
    
    after cancel TqsCommit
    catch {unset tqs_info(pending)}
    return
}

    # change commit timer, default is to commit with explicit calls
proc TqsTimer {{timer ""}} {
    global tqs_info
    
    after cancel TqsCommit
    
    if {$timer == ""} {
        catch {unset tqs_info(timeout)}
    } else {
        if {[info exists tqs_info(pending)]} {
            set tqs_info(pending) [after $timer TqsCommit]
        }
        set tqs_info(timeout) $timer
    }
}

    # handles tracing of all view changes (there's no read tracing)
    # this is also the place where delayed commits are scheduled
proc tqsTrace {view key operation} {
    global tqs_info tqs_notify
    
    if [info exists tqs_notify($view)] {
        switch $operation {
            w   { set req [list Set $view $key [TqsGet $view $key]] }
            u   { set req [list Unset $view $key] }
        }
        
            # this is the data that gets sent out
        set msg "[string length $req]\n$req"
        
        foreach p $tqs_notify($view) {
            if {$p == $tqs_info(port)} continue ;# skip originator
            
            if [catch {
                tqsPuts 2 [tqsDisplay "Notify $p - $req" 65]
                puts -nonewline $p $msg
                #flush $p
            } error] {
                tqsPuts 1 "Notify to $p failed for $view $key"
                tqsPuts 1 "  Reason: $error"
                catch {close $p}
                tqsUnsubscribe $p
            }
        }
    }
    
    if {![info exists tqs_info(pending)] && 
            [info exists tqs_info(timeout)]} {
        set tqs_info(pending) [after $tqs_info(timeout) TqsCommit]
    }
}

    # called whenever a request comes in
proc tqsRequest {sock} {
    global tqs_info
    
    if {[gets $sock bytes] > 0} {
        set request [read $sock [lindex $bytes 0]]
        if ![eof $sock] {
                # debugging: incoming request
            tqsPuts 1 [tqsDisplay " $request" 65]
            
            set tqs_info(port) $sock
            
            set err [catch {uplevel #0 Tqs$request} reply]
            set msg [list Reply $err $reply]
            puts -nonewline $sock "[string length $msg]\n$msg"
            
                # debugging: returned results
            if {[string length $reply] > 0} {
                tqsPuts 3 "   result: [tqsDisplay $reply 54]"
            }
            
            #flush $sock
            return
        } 
    }
    
    tqsPuts 1 "Closing $sock"
    close $sock 
    tqsUnsubscribe $sock
}

    # called whenever a connection is opened
proc tqsAccept {sock addr port} {
    global tqs_info
    fconfigure $sock -translation binary -buffering none
    fileevent $sock readable [list tqsRequest $sock]
}

    # this can be called to start a background server
proc tqsStart {port} {
    global tqs_notify tqs_external

    array set tqs_notify {}
    
    foreach x [glob -nocomplain *.data] {
        regsub {\.data$} $x {} x
        set tqs_external($x) ""
    }
    
    socket -server tqsAccept $port
}

    # this wraps the server into a standalone, it runs until shutdown
proc tqsRun {port} {
    global tqs_info
    
    set tqs_info(shutdown) [clock seconds]
    
        # these status messages are not disabled if verbose is off
    puts "Tequila server on port $port started."
    tqsStart $port
    vwait tqs_info(shutdown)
    puts "Tequila server on port $port has been shut down."
}

    # client-callable: terminate a server started with "tqsRun"
proc TqsShutdown {} {
    global tqs_info

        # returns number of seconds since the server was started
        # main effect is setting tqs_info(shutdown), which ends vwait
    set tqs_info(shutdown) [expr {[clock seconds]-$tqs_info(shutdown)}]
}

# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# This script can be used standalone, in which case the code below will
# be run, or as part of a scripted document, which expects a "package
# ifneeded tequilas ..." to have been set up.  In that case, the code
# below will not be executed, allowing the caller so set up different
# parameter values before calling tqsRun or tqsStart (background use).
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

if {[lsearch -exact [package names] tequilas] < 0} {
    package require Mk4tcl
    mk::file open tqs tequilas.dat -nocommit

    set tqs_info(verbose) 0     ;# default logging is off
    TqsTimer 30000              ;# default commit timer is 30 seconds
    tqsRun 20458                ;# default port is 20458
}

Tequila Client - tequilac.tcl

# Copyright (C) 1999-2000 Jean-Claude Wippler <jcw@equi4.com>
#
# Tequila  -  client interface to the Tequila server

package provide tequila 1.5

namespace eval tequila {
    namespace export open close do attach

    variable _socket
    variable _reply
    
        # setup communication with the tequila server
    proc open {addr port} {
        variable _socket
        set _socket [socket $addr $port] 
        fconfigure $_socket -translation binary -buffering none
        fileevent $_socket readable tequila::privRequest
    }

        # setup callback for when link to server fails
    proc failure {cmd} {
        variable _socket
        trace variable _socket u $cmd
    }

        # terminate communication (this is usually not needed)
    proc close {} {
        variable _socket
        ::close $_socket 
    }

        # set up to pass almost all MK requests through to the server
        # note that mk::loop is not implemented, is only works locally
        # added 20-02-2000
    proc proxy {} {
        namespace eval ::mk {
            foreach i {file view row cursor get set select channel} {
                proc $i {args} "eval ::tequila::do Remote $i \$args"
            }
        }
    }
    
        # send a request to the server and wait for a response
    proc do {args} {
        variable _socket
        variable _reply ""
        
        catch {
            puts -nonewline $_socket "[string length $args]\n$args"
            while {[string length $_reply] == 0} {
                vwait tequila::_reply
            }
        }
        
        set error 0
        set results ""
        foreach {error results} $_reply break
        
        if {[string compare $error 0] == 0} {
            return $results
        }
        
        if {[string length $results] > 0} {
            error $results 
        }
        
        error "Failed network request to the server."
    }

        # prepare for automatic change propagation
    proc attach {array args} {
        array set opts {-fetch 1 -tracking 1 -type S}
        array set opts $args
        
        global $array
        do Define $array 0 $opts(-type)
        
        if {$opts(-fetch)} {
            set command GetAll
        } else {
            set command Listing
        }
        
        array set $array [do $command $array $opts(-tracking)]
        
        trace variable $array wu tequila::privTracer
    }

        # called whenever a request comes in (private)
    proc privRequest {} {
        variable _socket
        variable _reply
        
        if {[gets $_socket bytes] > 0} {
            set request [read $_socket $bytes]
            if ![eof $_socket] {
                uplevel #0 tequila::privCallBack_$request
                return
            } 
        }
            # trouble, make sure we stop a pending request
        set _reply [list 1 "Lost connection with the tequila server."]
        ::close $_socket 
        unset _socket
    }

        # handles traces to propagate changes to the server (private)
    proc privTracer {a e op} {
        if {$e != ""} {
            switch $op {
                w   { do Set $a $e [set ::${a}($e)] }
                u   { do Unset $a $e }
            }
        }
    }

        # called by the server to return a result
    proc privCallBack_Reply {args} {
        variable _reply
        set _reply $args
    }

        # called by the server to propagate an element write
    proc privCallBack_Set {a e v} {
        global $a
        if {![info exists ${a}($e)] || [set ${a}($e)] != $v} {
            trace vdelete $a wu tequila::privTracer
            set ${a}($e) $v    
            trace variable $a wu tequila::privTracer
        }
    }

        # called by the server to propagate an element delete
    proc privCallBack_Unset {a e} {
        global $a
        if {[info exists ${a}($e)]} {
            trace vdelete $a wu tequila::privTracer
            unset ${a}($e)
            trace variable $a wu tequila::privTracer
        }
    }
}

Demo for MOST's class definition

source most.tcl

class int {value} {
    =  {} { set value [expr int(round($args))]}
    ++ {} { incr value }
    $  {} { return $value }
    test {} { uplevel $this ++ }
    test2 {} { this ++ }
}

Usage of MOST

new int i = 3
while { [i] < 10 } {
    puts "[i]"
    i ++
}
i test2
puts "after \[i test\] value is [i]"

exit

Demo for Tequila

source tequilac.tcl
# set up a connection to the central Tequila server
eval tequila::open [get-host-name] 20458

# setup for a global object "i" to be shared
tequila::attach i

• Home
• Recent changes
• Help
• WhoAmI/Logout
• Create new page
• Random page
• Previous page
• Next page
• 
  
• Add comments
• Edit
• History
• Edit summary
• References