geos_one/archie
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Intial commit

Browse Source
This commit is contained in:
Mario Fetka
2024-05-27 16:13:40 +02:00
parent f8dc12b10a
commit d71d446104
2495 changed files with 539746 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

58
tcl-dp/library/acl.tcl Normal file
View File

@@ -0,0 +1,58 @@
# acl.tcl --
#
# Access control list (acl) implementation for Tcl
#
# Copyright (c) 1992-1993 The Regents of the University of California.
# All rights reserved.
#
# Permission is hereby granted, without written agreement and without
# license or royalty fees, to use, copy, modify, and distribute this
# software and its documentation for any purpose, provided that the
# above copyright notice and the following two paragraphs appear in
# all copies of this software.
#
# IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
# CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
#
# THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
# AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS
# ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
###########################################################################
#
# Add a "plused" item to an acl. Returns new acl
#
proc Acl+ {acl str} {
lappend acl [list 1 $str]
}
###########################################################################
#
# Add a "minused" item to an acl. Returns new ac
#
proc Acl- {acl str} {
lappend acl [list 0 $str]
}
###########################################################################
#
# Check if a string is "allowed" in an acl
#
proc AclCheck {acl str} {
set result 1
foreach elt $acl {
if {[string match [lindex $elt 1] $str] == 1} {
set result [lindex $elt 0]
}
}
return $result
}

282
tcl-dp/library/distribObj.tcl Normal file
View File

@@ -0,0 +1,282 @@
# distribObj.tcl --
#
# This file contains utilities to manage distributed objects.
#
# 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.
#
################################################################
#
# Support for triggers is kept in the trigger array. This array
# is indexed on object name and slot. The array stores a list of
# commands
#
proc dp_AppendTrigger {beforeAfter obj slot args} {
global trigger
if {[lsearch "before after" $beforeAfter] != -1} {
lappend trigger($obj,$slot,$beforeAfter) $args
} else {
error "bad option \"$beforeAfter\": should be \"before\" or \"after\""
}
}
proc dp_AppendTriggerUnique {beforeAfter obj slot args} {
global trigger
if {[lsearch "before after" $beforeAfter] != -1} {
if {[info exists trigger($obj,$slot,$beforeAfter)] &&
([lsearch $trigger($obj,$slot,$beforeAfter) $args] == -1) &&
([lsearch $trigger($obj,$slot,$beforeAfter) [list $args]] == -1)} {
lappend trigger($obj,$slot,$beforeAfter) $args
}
} else {
error "bad option \"$beforeAfter\": should be \"before\" or \"after\""
}
}
proc dp_SetTrigger {beforeAfter obj slot args} {
global trigger
if {[lsearch "before after" $beforeAfter] != -1} {
set trigger($obj,$slot,$beforeAfter) [list $args]
} else {
error "bad option \"$beforeAfter\": should be \"before\" or \"after\""
}
}
proc dp_ReleaseTrigger {beforeAfter obj slot args} {
global trigger
if {[lsearch "before after" $beforeAfter] != -1} {
set trigger($obj,$slot,$beforeAfter) \
[ldelete $trigger($obj,$slot,$beforeAfter) $args]
} else {
error "bad option \"$beforeAfter\": should be \"before\" or \"after\""
}
}
proc dp_ClearTriggers {beforeAfter obj slot} {
global trigger
if {[lsearch "before after" $beforeAfter] != -1} {
catch {unset trigger($obj,$slot,$beforeAfter)}
} else {
error "bad option \"$beforeAfter\": should be \"before\" or \"after\""
}
}
proc dp_GetTriggers {beforeAfter obj slot} {
global trigger
if {[lsearch "before after" $beforeAfter] != -1} {
if [info exists trigger($obj,$slot,$beforeAfter)] {
return $trigger($obj,$slot,$beforeAfter);
} else {
return {};
}
} else {
error "bad option \"$beforeAfter\": should be \"before\" or \"after\""
}
}
################################################################
#
# Objects are distributed using the dp_RPC mechanism. The distribution
# information is kept in the array distObjInfo, which index on the object
# name and sometimes the process. For each object, we need
# to know the processes the owner process (or, at least,
# the next step in the path to the owner), the reference count for the
# number of times this object has been distributed to a process, and
# the processes it's been distributed to. Thus,
#
# owner process <== $objInfo($obj,owner)
# client processes <== $objInfo($obj,clients)
# ref count to $process <== $objInfo($obj,$process)
#
#
# Distribute an object. Two steps:
# 1. Make up a list of "-slot value" initialization arguments
# 2. Foreach client process, do an RPC to create the object if
# it's not over there, otherwise increment the reference
# count. Return an error if the object already exists on
# the far end (i.e., because someone else made it).
#
proc dp_DistributeObject {obj processes makeCmd} {
global objInfo
# Step 1
set params {}
foreach conf [$obj configure] {
set slot [string trimleft [lindex $conf 0] -]
lappend params -$slot [lindex $conf 2]
}
# Step 2
foreach proc $processes {
if {![info exist objInfo($obj,$proc)]} {
set robj [dp_RPC $proc info procs $obj]
if {[string length $robj] != 0} {
set err "Error while distributing object \"$obj\"\n"
append err "Object already exists on $proc"
error $err
}
if {[catch {dp_RPC $proc -events rpc -timeout 30000 \
dp_CreateRemoteObject $makeCmd $obj $params} msg]} {
error "timeout while creating object $obj on $proc: $msg"
}
set objInfo($obj,$proc) 0
lappend objInfo($obj,clients) $proc
dp_atclose $proc prepend "unset objInfo($obj,$proc)"
}
incr objInfo($obj,$proc)
}
}
#
# Create an object in a process.
# 1. Create the object using the makeCmd
# 2. Record the owner of the object
# 3. Arrange for cleanup if the connection dies.
#
proc dp_CreateRemoteObject {makeCmd obj params} {
global dp_rpcFile
global objInfo
eval $makeCmd $obj $params
set objInfo($obj,owner) $dp_rpcFile
dp_atclose $dp_rpcFile prepend "dp_DeleteRemoteObject $obj"
}
#
# Delete a remote object:
# For each client process:
# 1. Verify that the object has been distributed to the client.
# Error if not.
# 2. Decrement the reference count to the client
# 3. If reference count is zero, delete the object in the client
#
proc dp_UndistributeObject {obj processes} {
global objInfo;
foreach proc $processes {
if {![info exists objInfo($obj,$proc)]} {
set err "Error while undistributing object \"$obj\"\n"
append err "Object not distributed to $proc from this process"
error $err
}
incr objInfo($obj,$proc) -1
if {$objInfo($obj,$proc) == 0} {
dp_RDO $proc dp_DeleteRemoteObject $obj
set objInfo($obj,clients) [ldelete $objInfo($obj,clients) $proc];
unset objInfo($obj,$proc)
dp_atclose $proc delete "unset objInfo($obj,$proc)"
}
}
if {[llength $objInfo($obj,clients)] == 0} {
unset objInfo($obj,clients)
}
}
#
# Get names of all slots in object
#
proc dp_SlotNames {obj} {
set slots {};
foreach conf [$obj configure] {
set slot [string trimleft [lindex $conf 0] -];
lappend slots $slot;
}
return $slots
}
#
# Nuke an object. This cleans up the objInfo array and deletes the
# command from the interpreter.
# 1. Recursively delete the object in all the clients.
# 2. Clean up tables: including object owner and triggers.
# 3. Send the destroy message to the object
# 4 Delete the command from the intepreter.
#
proc dp_DeleteRemoteObject {obj} {
global objInfo
if {[info exists objInfo($obj,clients)]} {
foreach proc $objInfo($obj,clients) {
dp_RDO $proc dp_DeleteRemoteObject $obj
unset objInfo($obj,$proc)
}
unset objInfo($obj,clients)
}
catch {unset objInfo($obj,owner)}
foreach slot [dp_SlotNames $obj] {
catch {unset trigger($obj,$slot)}
}
catch {$obj destroy}
catch {rename $obj ""}
}
#
# Set a slot's value:
# If the object was created remotely (i.e., has an owner),
# then send the change to the owner. Otherwise propagate
# the change to the clients
#
proc dp_setf {obj args} {
global objInfo
if [info exists objInfo($obj,owner)] {
eval dp_RDO $objInfo($obj,owner) dp_setf $obj $args
} else {
eval dp_downsetf $obj $args
}
}
#
# Part of propagating a slot change to a client.
#
# Should be
# 1. Pass the change on to the clients
# 2. Process all the "before" triggers, ignoring errors.
# 3. Set the slot.
# 4. Process all the "after" triggers, ignoring errors.
#
proc dp_downsetf {obj args} {
global trigger objInfo
if [info exists objInfo($obj,clients)] {
foreach proc $objInfo($obj,clients) {
eval dp_RDO $proc dp_downsetf $obj $args
}
}
set len [llength $args]
for {set i 0} {$i < $len} {incr i} {
set slot [lindex $args $i]
incr i
set value [lindex $args $i]
if [info exists trigger($obj,$slot,before)] {
foreach cmd $trigger($obj,$slot,before) {
catch {uplevel #0 eval $cmd}
}
}
$obj configure -$slot $value
if [info exists trigger($obj,$slot,after)] {
foreach cmd $trigger($obj,$slot,after) {
catch {uplevel #0 eval $cmd}
}
}
}
}
#
# Get access to a slot. Just for consistency with setf
#
proc dp_getf {obj slot} {$obj slot-value $slot}

164
tcl-dp/library/dp_atclose.tcl Normal file
View File

@@ -0,0 +1,164 @@
# dp_atclose -- command to install a Tcl callback to be invoked when
# -- the close command is evalutated.
#
# close -- command to close process, after all callbacks installed by
# -- the dp_atclose command have been invoked.
#
#######################################################################
#
# dp_atclose -- manages atclose callbacks.
#
proc dp_atclose {fileId {option list} args} {
# The option may be appendUnique, append, prepend, insert, delete,
# clear, set, or list.
# The args depends on the option specified.
#
# The dp_atclose_callbacks array holds the installed dp_atclose callbacks,
# indexed by fileId.
#
global dp_atclose_callbacks;
if {[catch {set dp_atclose_callbacks($fileId)}]} {
set dp_atclose_callbacks($fileId) {};
}
case $option in {
set {
#
# set callbacks list.
#
set dp_atclose_callbacks($fileId) $args;
}
appendUnique {
#
# append callback to end of the callbacks list.
#
if {[llength $args] != 1} {
error {wrong # args: try "dp_atclose fileId appendUnique callback"};
}
set callback [lindex $args 0];
if {[lsearch $dp_atclose_callbacks($fileId) $callback] == -1} {
lappend dp_atclose_callbacks($fileId) $callback;
}
}
append {
#
# append callback to end of the callbacks list.
#
if {[llength $args] != 1} {
error {wrong # args: try "dp_atclose fileId append callback"};
}
set callback [lindex $args 0];
lappend dp_atclose_callbacks($fileId) $callback;
}
prepend {
#
# prepend callback to front of the callbacks list.
#
if {[llength $args] != 1} {
error {wrong # args: try "dp_atclose fileId prepend callback"};
}
set callback [lindex $args 0];
set dp_atclose_callbacks($fileId) \
"\{$callback\} $dp_atclose_callbacks($fileId)";
}
insert {
#
# insert callback before the "before" callback in the callbacks list.
#
if {[llength $args] != 2} {
error {wrong # args: try "dp_atclose fileId insert before callback"};
}
set before [lindex $args 0];
set callback [lindex $args 1];
set l {};
foreach c $dp_atclose_callbacks($fileId) {
if {[string compare $before $c] == 0} {
lappend l $callback;
}
lappend l $c;
}
set dp_atclose_callbacks($fileId) $l;
}
delete {
#
# delete callback from the callbacks list.
#
if {[llength $args] != 1} {
error {wrong # args : should be "dp_atclose fileId delete callback"};
}
set callback [lindex $args 0];
set l {};
foreach c $dp_atclose_callbacks($fileId) {
if {[string compare $callback $c] != 0} {
lappend l $c;
}
}
set dp_atclose_callbacks($fileId) $l;
}
clear {
#
# clear callbacks list.
#
if {[llength $args] != 0} {
error {wrong # args : should be "dp_atclose fileId clear"};
}
set dp_atclose_callbacks($fileId) {};
}
list {
#
# list currently installed callbacks.
#
}
default {
error {options: appendUnique, append, prepend, insert, delete, clear, set, or list};
}
}
return $dp_atclose_callbacks($fileId);
}
#######################################################################
#
# Hide real close command.
#
rename close dp_atclose_close;
#######################################################################
#
# close -- Wrapper close command that first invokes all callbacks installed
# -- by the dp_atclose command before doing real close.
#
proc close {fileId} {
global dp_atclose_callbacks;
while {1} {
# Every iteration, we rescan dp_atclose_callbacks, in case
# some callback modifies it.
#
if {[catch {set dp_atclose_callbacks($fileId)} callbacks]} {
break;
}
if {[llength $callbacks] <= 0} {
break;
}
set callback [lindex $callbacks 0];
set dp_atclose_callbacks($fileId) [lrange $callbacks 1 end];
catch {uplevel #0 $callback};
}
catch {unset dp_atclose_callbacks($fileId)};
set ret [dp_atclose_close $fileId]
catch {close $fileId}
return $ret
}

202
tcl-dp/library/dp_atexit.tcl Normal file
View File

@@ -0,0 +1,202 @@
#
# dp_atexit -- command to install a Tcl callback to be invoked when
# -- the exit command is evalutated.
#
# exit -- command to exit process, after all callbacks installed by
# -- the dp_atexit command have been invoked.
#
#
# This module is structured as a sequence of "helper" functions and
# a single "dispatch" function that just calls the helpers.
set dp_atexit_inited 0
#######################################################################
#
# dp_atexit_appendUnique --
#
# Helper function to append callback to end of the callbacks list if
# it's not already there.
#
proc dp_atexit_appendUnique args {
global dp_atexit_callbacks;
if {[llength $args] != 1} {
error {wrong # args : should be "dp_atexit appendUnique callback"};
}
# append callback to end of the callbacks list.
set callback [lindex $args 0];
if {[lsearch $dp_atexit_callbacks $callback] == -1} {
lappend dp_atexit_callbacks $callback;
}
}
#######################################################################
#
# dp_atexit_append --
#
# Helper function to append callback to end of the callbacks list
#
proc dp_atexit_append args {
global dp_atexit_callbacks;
if {[llength $args] != 1} {
error {wrong # args : should be "dp_atexit appendUnique callback"};
}
set callback [lindex $args 0];
lappend dp_atexit_callbacks $callback;
}
#######################################################################
#
# dp_atexit_prepend --
#
# Helper function to prepend callback to front of the callbacks list.
#
proc dp_atexit_prepend args {
global dp_atexit_callbacks;
if {[llength $args] != 1} {
error {wrong # args : should be "dp_atexit prepend callback"};
}
set callback [lindex $args 0];
set dp_atexit_callbacks "\{$callback\} $dp_atexit_callbacks";
}
#######################################################################
#
# dp_atexit_insert --
#
# Helper function to insert callback before the "before" callback in the
# callbacks list
#
proc dp_atexit_insert args {
global dp_atexit_callbacks;
if {[llength $args] != 2} {
error {wrong # args : should be "dp_atexit insert before callback"};
}
set before [lindex $args 0];
set callback [lindex $args 1];
set l {};
foreach c $dp_atexit_callbacks {
if {[string compare $before $c] == 0} {
lappend l $callback;
}
lappend l $c;
}
set dp_atexit_callbacks $l;
}
#######################################################################
#
# dp_atexit_delete --
#
# Helper function to delete callback from the callbacks list.
#
proc dp_atexit_delete args {
global dp_atexit_callbacks;
if {[llength $args] != 1} {
error {wrong # args : should be "dp_atexit delete callback"};
}
set callback [lindex $args 0];
set l {};
foreach c $dp_atexit_callbacks {
if {[string compare $callback $c] != 0} {
lappend l $c;
}
}
set dp_atexit_callbacks $l;
}
#######################################################################
#
# dp_atexit_clear --
#
# Helper function to clear callbacks list
#
proc dp_atexit_clear args {
global dp_atexit_callbacks;
if {[llength $args] != 0} {
error {wrong # args : should be "dp_atexit clear"};
}
set dp_atexit_callbacks {};
}
#######################################################################
#
# dp_atexit --
#
# "option" may be appendUnique, append, prepend, insert, delete,
# clear, set, or list.
# "args" depends on the option specified.
#
# The global variable dp_atexit_callbacks is where we store the
# list of installed dp_atexit callbacks.
#
proc dp_atexit {{option list} args} {
global dp_atexit_inited;
global dp_atexit_callbacks;
# Hide real exit command and init the global variable
if {!$dp_atexit_inited} {
incr dp_atexit_inited
rename exit dp_atexit_really_exit
dp_atexit_install_exit
set dp_atexit_callbacks {}
}
case $option in {
set { set dp_atexit_callbacks $args; }
appendUnique { eval dp_atexit_appendUnique $args }
append { eval dp_atexit_append $args }
prepend { eval dp_atexit_prepend $args }
insert { eval dp_atexit_insert $args }
delete { eval dp_atexit_delete $args }
clear { eval dp_atexit_clear $args }
list {return $dp_atexit_callbacks}
default {
error {options: append, appendUnique, prepend, insert, delete,
clear, set, or list};
}
}
return $dp_atexit_callbacks;
}
#######################################################################
#
# dp_atexit_install_exit -- Wrapper to install exit command that first
# invokes all callbacks installed by the dp_atexit command before doing
# real exit.
#
proc dp_atexit_install_exit {} {
uplevel #0 {proc exit {{code 0}} {
global dp_atexit_callbacks;
while {1} {
# Every iteration, we rescan dp_atexit_callbacks, in case
# some callback modifies it.
if {[catch {set dp_atexit_callbacks} callbacks]} {
break;
}
if {[llength $callbacks] <= 0} {
break;
}
set callback [lindex $callbacks 0];
set dp_atexit_callbacks [lrange $callbacks 1 end];
catch {uplevel #0 $callback};
}
catch {unset dp_atexit_callbacks};
catch {dp_atexit_really_exit $code};
}
}
}

22
tcl-dp/library/ldelete.tcl Normal file
View File

@@ -0,0 +1,22 @@
# ldelete.tcl --
#
# This file contains a list element deletion utility procedure.
# It is used in the whiteboard example.
#
# ldelete - search a list for an item and delete the first one found;
# - returns new list;
#
# example: ldelete {a b c a} a ==> b c a
#
proc ldelete {list elt} {
set index [lsearch $list $elt];
if {$index >= 0} {
return [lreplace $list $index $index];
}
return $list;
}

200
tcl-dp/library/oo.tcl Normal file
View File

@@ -0,0 +1,200 @@
# oo.tcl --
#
# Simple object oriented extension to Tcl, in the spirit of the Tk
# widget "objects". Like the GUI widgets in Tk, objects in
# this extension are procedures.
#
# 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.
#
################################################################
#
# dp_objectCreateProc
#
# creates a procedure <object> to represent an
# object of given <class>.
#
# methods on <class> should be defined using
# the form <class>.method1, ..., <class>.methodn.
#
proc dp_objectCreateProc {class object} {
set methodName "$class.\$name"
set body "";
append body {if [string length [info procs}
append body " $methodName";
append body {]] }
append body "{eval $methodName";
append body " $object ";
append body {$args};
append body "} else {"
append body "error "
append body {"}
append body "bad option "
append body {\"$name\"};
append body {"}
append body "}"
proc $object {name args} $body;
return $object;
}
################################################################
#
# dp_objectExists
#
proc dp_objectExists {object} {
if {[lsearch [info procs] $object] < 0} {
return 0;
}
return 1;
}
################################################################
#
# objectFree
#
proc dp_objectFree {object} {
global _objects;
if [dp_objectExists $object] {
foreach slot [dp_objectSlots $object] {
dp_objectSlotFree $object $slot;
}
rename $object "";
}
}
################################################################
#
# dp_objectSlot
# dp_objectSlotSet
# dp_objectSlotAppend
#
# dp_objectSlotFree
#
# object slot abstraction implemented
# using associative arrays.
#
#------------------------------------------------------------
set _objects(null) {};
#------------------------------------------------------------
proc dp_objectSlotFree {object slot} {
global _objects;
catch {unset _objects($object,$slot)};
}
proc dp_objectSlot {object slot} {
global _objects;
return [set _objects($object,$slot)];
}
proc dp_objectSlotSet {object slot value} {
global _objects;
return [set _objects($object,$slot) $value];
}
proc dp_objectSlotAppend {object slot value} {
global _objects;
return [lappend _objects($object,$slot) $value];
}
proc dp_objectSlots {object} {
global _objects;
set objectSlots {};
set slots [array names _objects];
set length [string length $object,];
while {1} {
set index [lsearch $slots $object,*];
if {$index < 0} {
return $objectSlots;
}
lappend objectSlots \
[string range [lindex $slots $index] $length end];
set slots [lrange $slots [incr index] end];
}
}
################################################################
#
# dp_objectConfigure - configure the slots of an object.
#
proc dp_objectConfigure {class object args} {
set argc [llength $args];
if {$argc < 1} {
# Zero args;
#
# Return a list of all the slotnames and values of the object;
#
set configs {};
foreach slot [dp_objectSlots $object] {
lappend configs [list -$slot {} [dp_objectSlot $object $slot]];
}
return $configs;
}
if {$argc == 1} {
# One arg (slotname);
#
# Return the slotname and value for the given slotname in the object;
#
set slot [string trimleft [lindex $args 0] \-];
if {[string length $slot] > 0} {
return [list -$slot {} [dp_objectSlot $object $slot]];
}
}
if {$argc > 1} {
# More than one args (slotname and value pairs);
#
# Recursively set the value of each of the given slots in the object
# to the given values;
#
set slot [string trimleft [lindex $args 0] \-];
eval $class.configure $object [lrange $args 2 end];
dp_objectSlotSet $object $slot [lindex $args 1];
return $object;
}
}

327
tcl-dp/library/rpc.tcl Normal file
View File

@@ -0,0 +1,327 @@
# 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)
}
}
}
}