Intial commit

tcl-dp/examples/conference/README

@@ -0,0 +1,39 @@
+
+        Tcl-DP: N-way Text-based Conferencing Example
+
+This example creates a conference application, similar to CB radio, 
+where anyone can speak and everyone hears.
+
+    room.tcl 	-- the conferencing server, a room where conference
+                   may take place.
+
+    enter.tcl	-- the conferencing client, that enters a room.
+
+After setting up the room and after clients have entered that room,
+clients can type "say string," as in "say hello world!," to talk to
+other participants.  The server will repeat the message to all clients.
+
+--------------------------------------------------------------------
+
+To run a conferencing server...
+
+Run wish.
+Type "source room.tcl" and answer the questions.
+
+--------------------------------------------------------------------
+
+To start a conferencing client...
+
+Run wish.
+Type "source enter.tcl" and answer the questions.
+Type "help" for on-line help.
+
+--------------------------------------------------------------------
+
+Experiment and run the conferencing client several times, to
+represent many people in a conference.
+
+--------------------------------------------------------------------
+
+
+

tcl-dp/examples/conference/enter.tcl

@@ -0,0 +1,85 @@
+
+#
+# enter.tcl -- Tcl/Tk script for conference client.
+#
+
+# Get information from user.
+#
+
+package require dp 4.0
+
+set host localhost;
+set port 9943;
+set name Bubba
+
+# Become an RPC client of the conference server.  Store the
+# file handle that represents the RPC connection in the 
+# global variable server;
+#
+
+set server [dp_MakeRPCClient $host $port]
+
+# The conference server will occasionally RPC a Hear 
+# command to us when we need to hear a message from some speaker.
+#
+
+proc Hear {speaker message} \
+{
+  puts stdout "$speaker --> $message";
+}
+
+# Commands available to user, who invokes these commands from stdin.
+#
+
+proc help {} \
+{
+  puts stdout "Conferencing Commands: ";
+  puts stdout "\thelp";
+  puts stdout "\twho";
+  puts stdout "\tsay ?message?";
+  puts stdout "\tbye or quit or leave";
+}
+
+proc who {} \
+{
+  global server;
+
+  # RPC to the conference server to get the list of all its client names;
+  #
+  puts stdout [dp_RPC $server set names];
+}
+
+proc say {args} \
+{
+  global server;
+
+  # Tell the conference server, by RPC, what I want to said to all clients.
+  # The conference server will repeat my message to all clients, by RPC,
+  # for them to Hear.
+  #
+  dp_RPC $server Say $args;
+}
+
+# To leave, we just exit, and the file is automatically closed.  The
+# conference server will automatically clen up on his end.
+proc leave {} {exit}
+proc bye {} {exit};
+proc quit {} {exit}
+
+# On startup, automatically enter the conference.
+#
+
+proc enter {} \
+{
+  global server;
+  global name;
+
+  # Tell the conference server, by RPC, that I'm Entering the conference.
+  #
+  dp_RPC $server Enter $name;
+  puts stdout "Entered conference.";
+}
+
+enter;
+
+

tcl-dp/examples/conference/room.tcl

@@ -0,0 +1,81 @@
+
+#
+# room.tcl -- Tcl/Tk script for conferencing server;
+#
+
+package require dp 4.0
+
+set port 9943;
+
+# The following command creates an RPC server socket on
+# the given port.
+#
+
+dp_MakeRPCServer $port
+
+# names -- list of room occupants
+# files -- list of active rpc files
+#
+
+set names {};
+set files {};
+
+# The following are procedures available through RPC to 
+# clients of the conferencing server.
+#
+
+proc Enter {name} \
+{
+  # Before any RPC command (such as this Enter) gets evaluated, 
+  # the global variable dp_rpcFile is set to the file handle
+  # of the RPC connection currently being serviced.
+  #
+  global names;
+  global files;
+  global dp_rpcFile;
+
+  # Remember the name and the associated RPC file handle
+  # of the client who just entered the room;
+  #
+  lappend names $name; 
+  lappend files $dp_rpcFile;
+
+  # Arrange to remove the information from the names and files list
+  # when the connection is closed. 
+  dp_atclose $dp_rpcFile append "Leave $name $dp_rpcFile"
+}
+
+# The following command is invoked automatically when a file is closed
+# This can happend because a server dies unexpectedly.  The callback is
+# created by the "dp_atclose" call above.  The two parameters give the
+# rpc file and the name of the person.
+#
+proc Leave {n f} \
+{
+    global names;
+    global files;
+
+    set files [ldelete $files $f]
+    set names [ldelete $names $n]
+}
+
+proc Say {message} \
+{
+  global names;
+  global files;
+  global dp_rpcFile;
+
+  # Figure out the client who said the message;
+  #
+  set speaker [lindex $names [lsearch $files $dp_rpcFile]];
+
+  # Tell all clients to Hear the message from the speaker;
+  #
+  foreach client $files \
+    {
+      dp_RPC $client Hear $speaker $message;
+    }
+}
+
+
+

tcl-dp/examples/ftp/client.tcl

@@ -0,0 +1,200 @@
+##########################################################
+# 
+# A trivial file transfer layer on top of DP.
+#	mperham 3/97
+# 
+# Assumes a server has been started with "fserver"
+# and a client connected to that server via "fconnect"
+#
+# The user interface:
+#
+#    fconnect $host {$port} - open an RPC connection to host:port
+#			    and a data connection to host:port-1
+#			    port is optional
+#    fget $filename - copy remote file, $filename, to local machine.
+#    fput $filename - copy local file, $filename, to remote machine.
+#    fdel $filename - delete a remote file named $filename
+#    fdir - remote directory listing
+#    fpwd - print current remote directory
+#    fcd - change remote directory
+#
+# Problems:
+#
+#    Minimal error handling at best.  Need to catch more.
+#
+
+package require dp 4.0
+
+#//////////////////////////////////////
+
+proc oops {errMsg} {
+    puts stdout "Remote server returned error:"
+    puts stdout "$errMsg"
+}
+
+#//////////////////////////////////////
+
+proc fget {filename} {
+    global f_chan dataPort host 
+
+# Make data channel
+# On server side
+
+    if [catch {
+        dp_RPC $f_chan eval {set dataServ [dp_connect tcp -server 1 -myport} $dataPort {]}
+        dp_RDO $f_chan eval {set dataSC [dp_accept $dataServ]}
+    } msg] {
+        puts stdout "Error opening dataServer socket (fget): $msg"
+        close $f_chan
+        return
+    }
+
+# And on Client side
+    
+    if [catch {
+        set dataClient [dp_connect tcp -host $host -port $dataPort]
+    } msg] {
+        puts stdout "Error connecting to dataServer socket: $msg"
+        close $f_chan
+        return
+    }
+
+# Tell server to send file
+
+    dp_RPC $f_chan eval {set srcFile [open} $filename {r]}
+    dp_RPC $f_chan eval {dp_send [lindex $dataSC 0] [dp_recv $srcFile]}
+
+# Open output file on client
+    set destfile [open $filename {CREAT WRONLY}]
+	
+	puts stdout "Getting $filename from remote host."
+
+# Put all coming stuff to $newfile and close it
+
+    dp_send $destfile [dp_recv $dataClient]
+    close $destfile
+
+# First close the Client, before you close the server !!
+
+    close $dataClient
+
+# Close Server now 
+    dp_RPC $f_chan eval {close $srcFile}
+    dp_RPC $f_chan eval {close [lindex $dataSC 0]}
+    dp_RPC $f_chan eval {close $dataServ}
+}
+
+#//////////////////////////////////////
+
+proc fput {filename} {
+    global f_chan dataPort host
+
+# Make data channel
+# On server side
+
+    if [catch {
+        dp_RPC $f_chan eval {set dataServ [dp_connect tcp -server 1 -myport} $dataPort {]}
+        dp_RDO $f_chan eval {set dataSC [dp_accept $dataServ]}
+    } msg] {
+        puts stdout "Error opening dataServer socket (fput): $msg"
+        close $f_chan
+        return
+    }
+
+# And on client side
+
+    if [catch {
+        set dataClient [dp_connect tcp -host $host -port $dataPort]
+    } msg] {
+        puts stdout "Error connecting to dataServer socket: $msg"
+        close $f_chan
+        return
+    }
+
+# Sending on client side (local) 
+    set srcfile [open $filename r]
+    puts stdout "Putting $filename to remote host."
+    dp_send $dataClient [dp_recv $srcfile]
+
+# Tell server to recv file
+
+    dp_RPC $f_chan eval {set destFile [open} $filename {w]}
+    dp_RPC $f_chan eval {dp_send $destFile [dp_recv [lindex $dataSC 0]]}
+
+#Close client BEFORE you close Server !!
+
+    close $dataClient
+    close $srcfile
+
+# Now close Server
+    dp_RPC $f_chan eval {close $destFile}
+    dp_RPC $f_chan eval {close [lindex $dataSC 0]}
+    dp_RPC $f_chan eval {close $dataServ}
+
+}
+
+#//////////////////////////////////////
+
+proc fpwd {} {
+    global f_chan
+
+    dp_RPC $f_chan if {$tcl_platform(platform) == "windows"} {cmd.exe /c cd} else { pwd }
+}
+
+#//////////////////////////////////////
+
+proc fdir {} {
+    global f_chan
+
+# I think this will be broken for filenames with spaces.
+# The foreach will think they are different files.
+
+    foreach a [dp_RPC $f_chan glob \*] {
+	puts $a
+    }
+}
+
+#//////////////////////////////////////
+
+proc fdel {filename} {
+    global f_chan
+
+    dp_RPC $f_chan file delete $filename
+}
+
+#//////////////////////////////////////
+
+proc fcd {dir} {
+    global f_chan
+
+    dp_RDO $f_chan -onerror oops cd $dir
+}
+
+#//////////////////////////////////////
+
+proc fquit {} {
+    global f_chan
+
+    close $f_chan
+}
+
+#//////////////////////////////////////
+# We need to open one channel on each side; the
+# the data channel - $dataClient here, $dataSC on the server -
+# will be created each time we send or recv a file
+# since we can't send normal data over an RPC channel.
+
+proc fconnect {host_add {port 19743}} {
+    global f_chan dataPort host
+
+	set host $host_add
+    set f_chan [dp_MakeRPCClient $host $port]
+    puts stdout "Connected to $host..."
+    puts stdout "Channel: $f_chan"
+    set dataPort [incr port -1]
+    
+    puts stdout "--------- Directory Listing ----------"
+    fdir
+    puts stdout "--------- Remote Directory -----------"
+    fpwd
+}

tcl-dp/examples/ftp/server.tcl

@@ -0,0 +1,23 @@
+#########################################
+#
+# This is the file transfer server
+#
+# (Not too impressive, huh?)
+#
+#       mperham 3/97
+#
+package forget dp
+package require dp 4.0
+
+# set dataPort 19742
+
+proc fserver {{port 19743}} {
+    dp_MakeRPCServer $port
+}
+
+# call procedure fserver
+# You'll need a vwait here if you want to run this in a tclsh.
+# vwait forever
+
+
+

tcl-dp/examples/tictactoe/README

@@ -0,0 +1,43 @@
+
+                   Tcl-DP: Tic Tac Toe
+
+This creates a simple distributed Tic Tac Toe game, displayed using 
+Tk widgets.  It is an example of using a Tcl-DP distributed object.
+
+  playerX.tcl	-- script for player X, must be run first
+  playerO.tcl	-- script for player O, must be run after playerX.tcl
+
+The following two files are shared by player X and player O.
+
+  board.tcl	-- definition of the distributed board class
+  interface.tcl	-- definition of user interface of Tk widgets
+
+--------------------------------------------------------------------
+
+First, start player X...
+
+Run wish.
+Type "source playerX.tcl" and answer the questions;
+
+--------------------------------------------------------------------
+
+Second, start player O...
+
+Run wish, as another process.
+Type "source playerO.tcl" and answer the questions;
+
+--------------------------------------------------------------------
+
+Player X is the RPC server.  Player O is the RPC client.  (Hence,
+player X must be set up before player O.)  Player X creates a Tic
+Tac Toe board object, which gets distributed to player O.  Each
+player process locally updates its Tk interface, as the Tk
+widgets of the interface are not distributed objects.
+
+Because the board is a distributed object, callbacks from user
+actions are very simple.  Any changes to slots of the board
+object in a callback are automatically propagated to all
+processes.
+
+
+

tcl-dp/examples/tictactoe/board.tcl

@@ -0,0 +1,107 @@
+#
+# board.tcl -- Tcl/Tk script that defines a Tic Tac Toe board object.
+#
+# The board object is defined using Tcl scripting only.  
+# Normally, objects are created in C (as structs), such as 
+# with Tk widgets, and have a Tcl access interface.
+#
+# The board has one slot, state, which is a list of nine entries.
+# Each entry may be X, O, or S (space).
+#
+# board -- creator procedure, works like a Tk widget creator.
+#
+# 	usage : board name ?configure-options ...?
+#
+
+package require dp 4.0
+
+proc board {aBoard args} {
+
+  # Create a procedure to represent a new board object.  
+  # This new board object (procedure) will have the name of $aBoard;
+  #
+  dp_objectCreateProc board $aBoard;
+
+  # Give the new board object one slot, called state;
+  #
+  dp_objectSlotSet $aBoard state {S S S S S S S S S};
+
+  # Finish configuration of the new board object;
+  #
+  eval $aBoard configure $args;
+
+  return $aBoard;
+}
+
+#
+# Method definitions for objects of class Tic Tac Toe board;
+#
+
+# Distributed objects must have the methods of configure and slot-value,
+# according to Tcl-DP distributed object protocol;
+#
+# configure  - configure the slots of board object;
+# slot-value - return value of one slot of board object;
+#
+# The methods configure and slot-value that are defined here 
+# use the object utility procedures that come 
+# with the Tcl-DP package;
+#
+
+proc board.configure {aBoard args} {
+  return [eval dp_objectConfigure board $aBoard $args];
+}
+
+proc board.slot-value {aBoard slot} {
+  return [dp_objectSlot $aBoard $slot];
+}
+
+# In the following board methods, note the use of dp_setf and dp_getf 
+# instead of objectSlotSet and objectSlot;  dp_setf and dp_getf
+# are used for slot access to Tcl-DP distributed objects;
+#
+
+# clear - clear entries of board;
+#
+
+proc board.clear {aBoard} {
+  dp_setf $aBoard state {S S S S S S S S S};
+  return $aBoard;
+}
+
+# entryGet - get entry at position x,y (0-2, 0-2);
+# entrySet - set entry at position x,y (0-2, 0-2);
+#
+
+proc board.entryGet {aBoard x y} {
+  set state [dp_getf $aBoard state];
+  set position [expr ($x*3)+$y];
+  return [lindex $state $position];
+}
+
+proc board.entrySet {aBoard x y value} {
+  set state [dp_getf $aBoard state];
+  set position [expr ($x*3)+$y];
+  dp_setf $aBoard state [lreplace $state $position $position $value];
+  return $value;
+}
+
+# print - pretty print board to stdout;
+#
+
+proc board.print {aBoard} {
+  for {set row 0} {$row <= 2} {incr row} {
+    for {set col 0} {$col <= 2} {incr col} {
+      set entry [$aBoard entryGet $col $row];
+      case $entry in {
+	{S} {set symbol " "}
+	{default} {set symbol $entry}
+      }
+      puts stdout $symbol nonewline;
+    }
+    puts stdout "";
+  }
+}
+
+
+

tcl-dp/examples/tictactoe/interface.tcl

@@ -0,0 +1,88 @@
+
+# interface.tcl -- Tcl/Tk script that defines the GUI interface
+# of the Tic Tac Toe game;  Since both player X and player O 
+# share the same interface, they both use this script.
+#
+
+# The global variable player must be set up beforehand;
+#
+
+wm title . "TTT - $player";
+
+# The following procedure is the callback for when a user 
+# presses a Tic Tac Toe GUI button;
+#
+
+proc mark {col row} {
+  global player;
+
+  # Get the current entry of the board of the given column and row.
+  #
+  set entry [.board entryGet $col $row];
+
+  if {[string compare S $entry] == 0} {
+
+    # Set the entry of the board to the player's symbol, 
+    # if the current entry is an S (space).
+    #
+    .board entrySet $col $row $player;
+
+    # Since the board is a distributed object, any slot changes to 
+    # it will get automatically distributed the other player.
+    #
+
+  } else {
+
+    # Otherwise, complain to the user;
+    #
+    puts stdout "";
+    puts stdout "Cannot mark that entry ($col,$row).";
+    puts stdout "Already marked with an $entry.";
+  }
+}
+
+# Procedure to create a column of Tic Tac Toe GUI buttons;
+#
+
+proc column {w i} {
+  pack append $w \
+    [frame $w.c$i] {left fillx filly};
+  pack append $w.c$i \
+    [button $w.c$i.0 -command "mark $i 0" -width 2] {top fillx} \
+    [button $w.c$i.1 -command "mark $i 1" -width 2] {top fillx} \
+    [button $w.c$i.2 -command "mark $i 2" -width 2] {top fillx};
+}
+
+# Procedure to update the text of those Tic Tac Toe GUI buttons 
+# according to the state of the distributed board object;
+#
+
+proc DisplayUpdate {} {
+  for {set row 0} {$row <= 2} {incr row} {
+    for {set col 0} {$col <= 2} {incr col} {
+      set entry [.board entryGet $col $row];
+      case $entry in {
+	{S} {set symbol " "}
+	{default} {set symbol $entry}
+      }
+      .main.c$col.$row configure -text $symbol;
+    }
+  }
+}
+
+# Instantiate the interface;
+#
+
+pack append . [frame .main] top;
+column .main 0;
+column .main 1;
+column .main 2;
+
+pack append .main \
+  [button .main.clear -text "Clear" -command ".board clear"] \
+    {top fillx} \
+  [button .main.quit  -text "Quit"  -command "exit"] \
+    {top fillx};
+
+
+

tcl-dp/examples/tictactoe/playerO.tcl

@@ -0,0 +1,47 @@
+
+#
+# playerO.tcl -- Tcl/Tk script for player O, the RPC client.
+#
+# This script should be run after running the player X script.
+#
+
+package require dp 4.0
+
+set player O;
+puts stdout "Tic Tac Toe - player O";
+
+# Get information from user;
+#
+
+puts stdout "Enter the host address of player X: " nonewline;
+gets stdin host;
+puts stdout "Enter the port number of player X: " nonewline;
+gets stdin port;
+
+# Connect to server (player X) as an RPC client;
+#
+
+set server [dp_MakeRPCClient $host $port];
+
+# Instead of creating a local board object, we ask the server to
+# distribute its board object to us;
+#
+
+source board.tcl;
+set remFile [dp_RPC $server set dp_rpcFile]
+dp_RPC $server eval dp_DistributeObject .board $remFile board;
+
+# Initialize the user interface;
+#
+
+source interface.tcl;
+
+# Trigger a user interface update whenever the state slot of 
+# the distributed board object changes;
+#
+
+dp_SetTrigger after .board state DisplayUpdate
+
+
+
+

tcl-dp/examples/tictactoe/playerX.tcl

@@ -0,0 +1,43 @@
+
+#
+# playerX.tcl -- Tcl/Tk script for player X, the RPC server.
+#
+# This script should be run before running the player O script.
+#
+
+package require dp 4.0
+
+set player X;
+puts stdout "Tic Tac Toe - player X";
+
+# Get information from user;
+#
+
+puts stdout "Enter an unused port number (ex: 8765) : " nonewline;
+gets stdin port;
+
+# Make an RPC server socket, which will be waiting for player O 
+# to connect through the supplied port number;
+#
+
+dp_MakeRPCServer $port
+
+# Create a local board object that will get distributed to player O;
+#
+
+source board.tcl;
+board .board;
+
+# Initialize the user interface;
+#
+
+source interface.tcl;
+
+# Trigger a user interface update whenever the state slot of 
+# the distributed board object changes;
+#
+
+dp_SetTrigger after .board state DisplayUpdate
+
+
+

tcl-dp/examples/whiteboard/readme

@@ -0,0 +1,6 @@
+This is the Tcl-DP whiteboard example.  To use, simply start wish/tclsh
+and source the wbServer.tcl.  Then you can start as many wishes as you need
+and source wbClient.tcl in each one.  Note that the server cannot be a
+client also.
+
+

tcl-dp/examples/whiteboard/wbClient.tcl

@@ -0,0 +1,65 @@
+package require dp 4.0
+
+puts "Enter hostname of server:"
+set host localhost
+set server [dp_MakeRPCClient $host 4544]
+
+proc DoCmd {args} {
+    global server
+    eval dp_RDO $server BroadCast $args
+}
+
+dp_RDO $server JoinGroup 
+
+wm grid . 1 1 1 1             
+
+# Create menu bar:
+frame .menubar -relief ridge
+menubutton .menubar.file -text "File" -menu .menubar.file.menu
+pack .menubar.file -side left
+menubutton .menubar.object -text "Objects" -menu .menubar.object.menu
+pack .menubar.object -side left
+pack .menubar -side top -fill both
+
+menu .menubar.file.menu
+.menubar.file.menu add command -label "Exit"  -command exit
+
+menu .menubar.object.menu
+.menubar.object.menu add command -label "Clear" -command "DoCmd Clear"
+.menubar.object.menu add command -label "Circle" -command "DoCmd CreateCircle"
+
+# Create canvas
+canvas .c -background blue
+pack .c -fill both
+
+proc CreateRect {x y} {
+    DoCmd .c create rectangle $x $y $x $y -width 4 -outline white
+}
+
+proc CreateCircle {} {
+    set i [.c create oval 150 150 170 170 -fill skyblue]
+    .c bind $i <Any-Enter> "DoCmd .c itemconfig $i -fill red"
+    .c bind $i <Any-Leave> "DoCmd .c itemconfig $i -fill SkyBlue2"
+    .c bind $i <3> "DoCmd plotDown .c $i %x %y"
+    .c bind $i <B3-Motion> "DoCmd plotMove .c $i %x %y"
+}
+
+proc Clear {} {.c delete all}
+
+proc plotDown {w item x y} {
+    global plot
+    $w raise $item
+    set plot(lastX) $x
+    set plot(lastY) $y
+}
+
+proc plotMove {w item x y} {
+    global plot
+    $w move $item [expr $x-$plot(lastX)] [expr $y-$plot(lastY)]
+    set plot(lastX) $x
+    set plot(lastY) $y
+}
+
+bind .c <B1-Motion> {CreateRect %x %y}
+
+

tcl-dp/examples/whiteboard/wbServer.tcl

@@ -0,0 +1,30 @@
+#package require dp 4.0
+
+dp_MakeRPCServer 2002
+
+set files {}
+set log {}
+
+proc JoinGroup {} {
+    global dp_rpcFile files log
+    lappend files $dp_rpcFile
+    foreach cmd $log {
+	eval dp_RDO $dp_rpcFile $cmd
+    }
+    dp_atclose $dp_rpcFile append "dp_Leave $dp_rpcFile"
+}
+
+proc dp_Leave {file} {
+    global files
+    set files [ldelete $files $file]
+}
+
+proc BroadCast {args} {
+    global files log
+    lappend log $args
+    foreach i $files {
+	eval "dp_RDO $i $args"
+    }
+}
+
+