328 lines
9.5 KiB
Tcl
328 lines
9.5 KiB
Tcl
# rpc.tcl --
|
|
#
|
|
# Utilities to create reentrant RPC clients and servers (full duplex)
|
|
#
|
|
# This file contains the utility procedures to help implement
|
|
# user-friendly remote procedure calls (RPC's) on top of the
|
|
# network primitives provided by the dp_connect, dp_accept, etc. and
|
|
# by various other primitives.
|
|
#
|
|
# Copyright 1992 Regents of the University of California
|
|
# Permission to use, copy, modify, and distribute this
|
|
# software and its documentation for any purpose and without
|
|
# fee is hereby granted, provided that this copyright
|
|
# notice appears in all copies. The University of California
|
|
# makes no representations about the suitability of this
|
|
# software for any purpose. It is provided "as is" without
|
|
# express or implied warranty.
|
|
#
|
|
|
|
########################################################################
|
|
|
|
#
|
|
# Access control lists -- sort of an xhost style implementation
|
|
#
|
|
set dp_Acl {}
|
|
|
|
proc dp_Host {str} {
|
|
global dp_Acl
|
|
set key [string range $str 0 0]
|
|
set str [string range $str 1 end]
|
|
case $key in {
|
|
"+" {
|
|
if {[string length $str] == 0} {
|
|
set dp_Acl {}
|
|
set rv {Access control disabled. Any clients may connect}
|
|
} else {
|
|
if {([string first * $str] != -1) ||
|
|
([string first \[ $str] != -1) ||
|
|
([string first ? $str] != -1) ||
|
|
([string first \] $str] != -1)} {
|
|
set rv "Clients from $str may connect"
|
|
set dp_Acl [Acl+ $dp_Acl $str]
|
|
} else {
|
|
set ipaddr [dp_netinfo -address $str]
|
|
if {$ipaddr == "255.255.255.255"} {
|
|
error "Unknown host $str"
|
|
}
|
|
set dp_Acl [Acl+ $dp_Acl $ipaddr]
|
|
set rv "Clients from $ipaddr may connect"
|
|
}
|
|
}
|
|
}
|
|
|
|
"-" {
|
|
if {[string length $str] == 0} {
|
|
set dp_Acl {{0 *} {0 *}}
|
|
set rv {Access control enabled. No clients may connect}
|
|
} else {
|
|
if {([string first * $str] != -1) ||
|
|
([string first \[ $str] != -1) ||
|
|
([string first ? $str] != -1) ||
|
|
([string first \] $str] != -1)} {
|
|
set rv "Clients from $str may not connect"
|
|
set dp_Acl [Acl- $dp_Acl $str]
|
|
} else {
|
|
set addr [dp_address create $str 0]
|
|
set ipaddr [lindex [dp_address info $addr] 0]
|
|
dp_address delete $addr
|
|
if {$ipaddr == "255.255.255.255"} {
|
|
error "Unknown host $str"
|
|
}
|
|
set dp_Acl [Acl- $dp_Acl $ipaddr]
|
|
set rv "Clients from $ipaddr may not connect"
|
|
}
|
|
}
|
|
}
|
|
|
|
default {return $dp_Acl}
|
|
}
|
|
return $rv
|
|
}
|
|
|
|
########################################################################
|
|
|
|
proc dp_CheckHost {file inetAddr} {
|
|
global dp_Acl
|
|
if {[AclCheck $dp_Acl $inetAddr] == 0} {
|
|
error "Host not authorized"
|
|
}
|
|
}
|
|
|
|
proc dp_AcceptRPCConnection {loginFunc checkCmd file} {
|
|
# puts "dp_AcceptRPCConnection $loginFunc $checkCmd $file"
|
|
set connection [dp_accept $file]
|
|
# puts "connection = $connection"
|
|
set newFile [lindex $connection 0]
|
|
set inetAddr [lindex $connection 1]
|
|
if {[string compare "none" $loginFunc] != 0} {
|
|
set error [catch {eval $loginFunc $file $inetAddr} msg]
|
|
if $error {
|
|
puts $newFile "Connection refused: $msg"
|
|
close $newFile
|
|
return;
|
|
}
|
|
}
|
|
puts $newFile "Connection accepted"
|
|
# puts "Calling dp_admin $newFile -check $checkCmd"
|
|
dp_admin register $newFile -check $checkCmd
|
|
dp_CleanupRPC $newFile
|
|
}
|
|
|
|
########################################################################
|
|
|
|
proc dp_MakeRPCClient {host port {checkCmd none}} {
|
|
# puts "attempting to connect"
|
|
set client [lindex [dp_connect tcp -host $host -port $port] 0]
|
|
# puts "connected -- waiting for reply"
|
|
set return [gets $client]
|
|
# puts stdout $return
|
|
if {[lindex $return 1] == "refused:"} {
|
|
close $client
|
|
error $return
|
|
}
|
|
if {[string match "Server not responding*" $return]} {
|
|
close $client
|
|
error $return
|
|
}
|
|
dp_admin register $client -check $checkCmd
|
|
dp_CleanupRPC $client
|
|
# puts stdout "Created $client"
|
|
return $client
|
|
}
|
|
|
|
proc dp_MakeRPCServer {{port 0} {loginFunc none} {checkCmd none}
|
|
{retPort 0}} {
|
|
# puts "dp_MakeRPCServer $port $loginFunc $checkCmd $retPort"
|
|
set rv [dp_connect tcp -server 1 -myport $port]
|
|
# puts "rv = $rv"
|
|
set server [lindex $rv 0]
|
|
|
|
fileevent $server readable "dp_AcceptRPCConnection $loginFunc $checkCmd $server"
|
|
dp_atexit appendUnique "close $server"
|
|
dp_atclose $server append "dp_ShutdownServer $server"
|
|
return $server
|
|
}
|
|
|
|
#######################################################################
|
|
#
|
|
# This creates two "callbacks" which will clean up RPC connections
|
|
# behind the user's back. If the user calls "close $rpcchan", we
|
|
# "alias" this to "dp_CloseRPC $rpcchan" which is defined below.
|
|
#
|
|
# Likewise, if the user tries to exit tclsh/wish, we close the
|
|
# RPC channel first (which will, in turn, call dp_CloseRPC as above.
|
|
#
|
|
|
|
proc dp_CleanupRPC {file} {
|
|
dp_atclose $file appendUnique "dp_CloseRPC $file"
|
|
dp_atexit appendUnique "close $file"
|
|
}
|
|
|
|
#
|
|
# Shut down the listening socket. This is usually invoked as an
|
|
# atclose callback. It arranges to delete the filehandler once all
|
|
# processing has been done.
|
|
#
|
|
|
|
proc dp_ShutdownServer {file} {
|
|
catch {dp_atexit delete "close $file"}
|
|
}
|
|
|
|
#
|
|
# Shut down a connection by telling the other end to shutdown and
|
|
# removing the filehandler on this file.
|
|
#
|
|
# Step 1: remove the file handler to prevent evaluating any new RPCs
|
|
# Step 2: Send an RDO to the far end to shutdown the connection
|
|
# Step 3: Clean up the call to shutdown the connection on exit.
|
|
#
|
|
|
|
#
|
|
# Close an RPC channel: shut down the other side and unregister.
|
|
# This is a callback done right before the actual close.
|
|
# (Thus no actual close command)
|
|
#
|
|
proc dp_CloseRPC {file} {
|
|
dp_RDO $file dp_CloseRPCFile
|
|
dp_admin delete $file
|
|
dp_atexit delete "close $file"
|
|
# puts stdout "close $file"
|
|
}
|
|
|
|
#
|
|
# Respond to remote sites request to close the rpc file.
|
|
# In this case, we don't want to call dp_CloseRPC (which will,
|
|
# in turn, try to close the remote site which is already closed),
|
|
# so we need to remove the dp_ShutdownRPC call from the atclose
|
|
# callback list before calling close.
|
|
#
|
|
|
|
proc dp_CloseRPCFile {} {
|
|
global dp_rpcFile
|
|
dp_admin delete $dp_rpcFile
|
|
dp_atclose $dp_rpcFile delete "dp_CloseRPC $dp_rpcFile"
|
|
dp_atexit delete "close $dp_rpcFile"
|
|
|
|
# Under Unix, we seem to lose the callback on the server
|
|
# socket unless we pause before closing the socket. I
|
|
# have no idea why this is true, but select() stops
|
|
# responding to connection requests. In any case,
|
|
# this is an ugly hack that seems to work
|
|
|
|
after idle close $dp_rpcFile
|
|
}
|
|
|
|
###########################################################################
|
|
#
|
|
# Trap read errors on sockets and close the socket
|
|
#
|
|
proc tkerror {info} {
|
|
global tk_library
|
|
if [info exists tk_library] {tkerror.tk $info} else {error $info}
|
|
}
|
|
|
|
# This file contains a default version of the tkError procedure. It
|
|
# posts a dialog box with the error message and gives the user a chance
|
|
# to see a more detailed stack trace.
|
|
|
|
proc tkerror.tk err {
|
|
global errorInfo
|
|
set info $errorInfo
|
|
if {[tk_dialog .tkerrorDialog "Error in Tcl Script" \
|
|
"Error: $err" error 0 OK "See Stack Trace"] == 0} {
|
|
return
|
|
}
|
|
|
|
set w .tkerrorTrace
|
|
catch {destroy $w}
|
|
toplevel $w -class ErrorTrace
|
|
wm minsize $w 1 1
|
|
wm title $w "Stack Trace for Error"
|
|
wm iconname $w "Stack Trace"
|
|
button $w.ok -text OK -command "destroy $w"
|
|
text $w.text -relief raised -bd 2 -yscrollcommand "$w.scroll set" \
|
|
-setgrid true -width 40 -height 10
|
|
scrollbar $w.scroll -relief flat -command "$w.text yview"
|
|
pack $w.ok -side bottom -padx 3m -pady 3m -ipadx 2m -ipady 1m
|
|
pack $w.scroll -side right -fill y
|
|
pack $w.text -side left -expand yes -fill both
|
|
$w.text insert 0.0 $info
|
|
$w.text mark set insert 0.0
|
|
|
|
# Center the window on the screen.
|
|
|
|
wm withdraw $w
|
|
update idletasks
|
|
set x [expr [winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \
|
|
- [winfo vrootx [winfo parent $w]]]
|
|
set y [expr [winfo screenheight $w]/2 - [winfo reqheight $w]/2 \
|
|
- [winfo vrooty [winfo parent $w]]]
|
|
wm geom $w +$x+$y
|
|
wm deiconify $w
|
|
}
|
|
|
|
########################################################################
|
|
|
|
set dp_RPROCtable(null) {};
|
|
|
|
proc dp_RPROC {name arguments body} {
|
|
|
|
# RPROC defines a procedure that is callable by RPC clients;
|
|
# RPROC is semantic sugar.
|
|
#
|
|
proc $name $arguments $body;
|
|
|
|
# Record the dp_RPROC in the dp_RPROCtable;
|
|
#
|
|
global dp_RPROCtable;
|
|
set dp_RPROCtable($name) $name;
|
|
}
|
|
|
|
########################################################################
|
|
#
|
|
# auto_load_all
|
|
#
|
|
# This procedure source's all Tcl library scripts not already source'd.
|
|
# This procedure is useful for when you want to later undefine
|
|
# the "proc" command, for making your interpreter RPC safe.
|
|
#
|
|
|
|
proc auto_load_all {} {
|
|
global auto_index;
|
|
|
|
set catchout {}
|
|
set noitcl 1
|
|
#
|
|
# The next info command will either trigger an error or return
|
|
# a null string if itcl has not been initialized. Either way,
|
|
# catchout retains the null string when itcl is not present.
|
|
#
|
|
catch {info namespace all itcl} catchout
|
|
|
|
#
|
|
# If the info command returned the string 'itcl' then
|
|
# itcl is present.
|
|
#
|
|
if {[string compare $catchout "itcl"] == 0} {
|
|
set noitcl 0
|
|
}
|
|
|
|
if {$noitcl} {
|
|
foreach name [array names auto_index] {
|
|
if {[string length [info commands $name]] == 0} {
|
|
uplevel #0 $auto_index($name);
|
|
}
|
|
}
|
|
} else {
|
|
foreach name [array names auto_index] {
|
|
set namespace [info namespace qualifiers $name]
|
|
set cmd [info namespace tail $name]
|
|
if {[string length [namespace $namespace "info commands $cmd"]] == 0} {
|
|
uplevel #0 $auto_index($name)
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|