** Attributes **

   name:   MOST
   location:   http://wiki.tcl.tk/MOST
   contact:   mailto:larry@wildopensource.com (Larry Smith)


** Synopsis **

MOST is the Mini Object System for [Tequila] 


***Description***

provides OOP that can be easily distributed across a network using [jcw]'s
Tequila.

[[not to be confused with Maynard Operation Specific Technique,
for example]] - it implements objects
as arrays - not a huge improvement over [LOST] except for one thing:
it was written for the first version of Tequila, which implements
distributed arrays and persistancy.  You can do some absurdly powerful
things with these tools with very little effort.

Because Tequila has moved on to something that is more complex, MOST
doesn't provide as much bang for the buck.  For people looking for
something quicker and easier to deal with, try MOST.  I have included
the source code for the original version of Tequila here as well, to
make it a one-stop solution for people wanting distributed objects.

The T1 source here was extracted from
[http://www.equi4.com/pub/mk/metakit-2.4.9.4.tar.gz]
It was written by [Jean-Claude Wippler].
MOST is by [Larry Smith] and its creation was financed
by [Eolas] as part of another project which has moved on
and no longer requires MOST.  Thanks [Michael Doyle].


***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***

And if you wanted to make "i" a shared object, you would add these lines at the top (with something appropriate instead of "get-host-name"

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

And the following after the "new":

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

Is pretty simple for sharable object system, no? I'm sure it could use a bit of
polish, but I don't have time to do it - and it does seem to work for me.


<<categories>> Object Orientation