Version 1 of rpc-DB

Updated 2003-01-31 22:27:19

MDD:

I've made a pure-Tcl client/server DP-RPC-compatible version of my A Mini Database Manager. It uses the dp_RPC facility (http://www.eolas.net/tcl/spynergy/rpc/dp_RPC.tcl ) that was part of Eolas' old Spynergy Toolkit.

BTW: You'll need the Tables.txt and Introduction.txt table files from A Mini Database Manager to be in the launch directory.

Here's the code for the server:

 #######
 #
 #  rpc-DB-srv  Mini Database Manager server, based on Eolas' dp_RPC.tcl system
 #  by Mike Doyle ([email protected])
 #    also based on Richard Suchenwirth's Little Database API, Little Database Gui, 
 #    and  Persistent array utility
 #
 #######
 source dp_RPC.tcl

 set port 8088
 console show
 wm withdraw .

 global db dir result port

 set dir [pwd] 

 proc quit {} {

         stop_server
         exit
 }

 proc start_server {} {
 global port

         puts "t-DB Server started on port: [dp_MakeRPCServer $port]"
         #add approved client hostname -- one line for each host
         puts [dp_Host +localhost]
       puts [dp_Host +205.229.151.3]
 }


 proc stop_server {} {
 global port

         dp_CloseRPC $port
         puts "Server stopped on port $port"

 }


 proc persistentArray {arrName {filename {}}} {
    upvar 1 $arrName arr
    array set arr {} ;# to make sure it exists, and is an array
    if {$filename==""} {set filename $arrName.txt}
    set filename [file join [pwd] $filename]
    if [file exists $filename] {
        set fp [open $filename]
        array set arr [read $fp]
        close $fp
    }
    uplevel 1 [list trace var $arrName wu [list persist'save $filename]]
 }

 proc persist'save {filename arrName el op} {
    upvar 1 $arrName arr
    switch -- $op {
        w {set value $arr($el)}
        u {set value {}}
    }
    set    fp [open $filename a]
    puts  $fp [list $el $value]
    close $fp
 }

 proc db {table args} {

    upvar #0 $table db
    set key "" ;# in case args is empty
    foreach {- key item value} $args break
    set exists [info exists db($key)]

    set res {}
    switch [llength $args] {
        0 {
            array set db {} ;# force to be an array
            interp alias {} $table {} db $table -
            set res $table
        }
        1 {set res [array names db]}
        2 {if {$key != ""} {
                if {$exists} {set res $db($key)}
           } else {array unset db}
        }
        3 {if {$item != ""} {
                if {$exists} {
                    set t $db($key)
                    if {!([set pos [lsearch $t $item]]%2)} {
                        set res [lindex $t [incr pos]]
                    }
                }
           } elseif {$exists} {unset db($key)}
        }
        4 {
            if {$exists} {
                if {!([set pos [lsearch $db($key) $item]]%2)} {
                    if {$value != ""} {
                      set db($key) [lreplace $db($key) [incr pos] $pos $value]
                    } else {set db($key) [lreplace $db($key) $pos [incr pos]]}
                } elseif {$value != ""} {
                    lappend db($key) $item $value
                }
            } elseif {$value != ""} {set db($key) [list $item $value]}
            set res $value ;# to be returned
        }
        default {
            if {[llength $args]%2} {error "non-paired item/value list"}
            foreach {item value} [lrange $args 2 end] {
                db $table - $key $item $value
            }
        }
    }
    set res
 }

 db Tables
 persistentArray Tables
 foreach i [lsort -dic [Tables]] {persistentArray $i; db $i}

 start_server

 # End client code
 ###########################

And here's the code for the client:

coming...