An implementation by Cris Fugate of the frames paradigm in Tcl.
Frames based OO implemention for Tcl.
Framesets is based on Marvin Minsky's concept of frames and basic set operations. It can currently be found at [L1 ]. An older archive can be found through the Internet Wayback Machine at [L2 ], and appended below for posterity. In particular, Marvin Minsky's seminal paper "A Framework for Representing Knowledge" can be found at http://www.bitsavers.org/pdf/mit/ai/aim/AIM-306.pdf
Also see this comp.lang.tcl discussion: [L3 ]
frameagents.README
frameagents.tcl is an extension to the tcl scripting language. It provides
basic frame and frame set mechanisms which can be used to dynamically organize
and perform operations on values and procedures. It also provides mechanisms
which allow frames and frame sets to act as mobile agents. Below is a list of
commands, how to call them, and the result of calling them.
fcomparef (compare two frames)
invoke: fcomparef <frame> <frame>
result: return 1 if frames have the same slots
return 0 otherwise
fcompares (compare slot of two frames)
invoke: fcompares <frame> <slot> <frame>
result: return 1 if slot is the same in both frames
return 0 otherwise
fcopyf (copy a frame)
invoke: fcopyf <frame> <frame>
result: second frame is a copy of the first frame
return 1 if successful, return 0 otherwise
fcopys (copy a slot)
invoke: fcopys <frame> <slot> <frame>
result: second frame has a copy of the slot in the first frame
return 1 if successful, return 0 otherwise
fcreated (create a demon facet)
invoke: fcreated <frame> <slot> <demon>
result: a new demon facet is created in the slot of the frame
return 1 if successful, return 0 otherwise
fcreatef (create a frame)
invoke: fcreatef <frame>
result: a new frame is created
return 1 if successful, return 0 otherwise
fcreatefs (create a frame set)
invoke: fcreatefs <set>
result: a new frame set is created
return 1 if successful, return 0 otherwise
fcreatem (create a method facet)
invoke: fcreatem <frame> <slot>
result: a new method facet is created in the slot of the frame
return 1 if successful, return 0 otherwise
fcreater (create a reference facet)
invoke: fcreater <frame> <slot>
result: a new reference facet is created in the slot of the frame
return 1 if successful, return 0 otherwise
fcreates (create a slot)
invoke: fcreates <frame> <slot>
result: a new slot is created in the frame
return 1 if successful, return 0 otherwise
fcreatev (create a value facet)
invoke: fcreatev <frame> <slot>
result: a new value facet is created in the slot of the frame
return 1 if successful, return 0 otherwise
fdo (remote execution)
invoke: fdo <message> <socket>
result: send code to be executed to server
fexecd (execute a demon)
invoke: fexecd <frame> <slot> <demon>
result: execute the demon in slot of the frame
return 1 if successful, return 0 otherwise
fexecm (execute a method)
invoke: fexecm <frame> <slot>
result: execute the method in the slot of the frame
return 1 if successful, return 0 otherwise
fexecx (execute agent code)
invoke: fexecx <frame>
result: execute agent code of a frame
return 1 if successful, return 0 otherwise
fexistd (determine if a demon facet exists)
invoke: fexistd <frame> <slot> <demon>
result: return 1 if the demon in the slot of the frame exists
return 0 otherwise
fexistf (determine if a frame exists)
invoke: fexistf <frame>
result: return 1 if the frame exists, return 0 otherwise
fexistm (determine if a method facet exists)
invoke: fexistm <frame> <slot>
result: return 1 if the method facet in the slot of the frame exists
return 0 otherwise
fexistr (determine if a reference facet exists)
invoke: fexistr <frame> <slot>
result: return 1 if the reference facet in the slot of the frame exists
return 0 otherwise
fexists (determine if a slot exists)
invoke: fexists <frame> <slot>
result: return 1 if the slot in the frame exists
return 0 otherwise
fexistv (determine if a value facet exists)
invoke: fexistv <frame> <slot>
result: return 1 if the value facet in the slot of the frame exists
return 0 otherwise
ffetchf (fetch a frame)
invoke: ffetchf <frame> <socket>
result: move a frame here from a server
return 1 if successful, 0 otherwise
ffetchfs (fetch a frame set)
invoke: ffetchfs <set> <socket>
result: move a frame set here from a server
return 1 if successful, 0 otherwise
ffilterf (filter a frame)
invoke: ffilterf <frame> <frame>
result: remove common slots of first frame from second frame
return 1 if successful, 0 otherwise
fgetd (get demon code)
invoke: fgetd <frame> <slot> <demon>
result: return the demon code in the slot of the frame
return nothing if this fails
fgetm (get method code)
invoke: fgetm <frame> <slot>
result: return the method code in the slot of the frame
return nothing if this fails
fgetr (get reference)
invoke: fgetr <frame> <slot>
result: return the frame name for the reference in the slot of the frame
return nothing if this fails
fgets (get a frame status)
invoke: fgets <frame>
result: return the agent state of a frame
return nothing if this fails
fgetv (get a value)
invoke: fgetv <frame> <slot>
result: return the value for the value facet in the slot of the frame
return nothing if this fails
fgetx (get agent code)
invoke: fgetx <frame>
result: return the agent code of a frame
return nothing if this fails
flistf (list frames)
invoke: flistf
result: return the frames which exist
flistr (list references)
invoke: flistr <frame>
result: return the slots of the frame which contain references
return empty list if this fails
flists (list slots)
invoke: flists <frame>
result: return the slots of the frame
return empty list if this fails
flistt (list facets)
invoke: flistt <frame> <slot>
result: return the facet types for the slot of the frame
return empty list if this fails
floadf (load a frame)
invoke: floadf <frame>
result: frame is loaded from disk into memory
return 1 if successful, return 0 otherwise
floadfs (load a frame set)
invoke: floadfs <set>
result: set is loaded from disk into memory
return 1 if successful, return 0 otherwise
flockf (lock a frame)
invoke: flockf <frame>
result: lock a frame so it cannot be modified
return 1 if successful, 0 otherwise
flockfs (lock a frame set)
invoke: flockfs <set>
result: lock a frame set so it cannot be modified
return 1 if successful, 0 otherwise
fmergef (merge frames)
invoke: fmergef <frame> <frame>
result: copy non-common slots of first frame into second frame
return 1 if successful, 0 otherwise
fpack (pack a frame)
invoke: fpack <frame>
result: remove a frame and return a packed list of the frame if successful
return an empty list if this fails
fpathr (get path of references)
invoke: fpathr <frame> <slot>
result: return a list of frame names for each frame in the reference chain
fputd (assign demon code)
invoke: fputd <frame> <slot> <demon> <procedure>
result: assign code to the demon facet of the slot of the frame
return 1 if successful, return 0 otherwise
fputm (assign method code)
invoke: fputm <frame> <slot> <procedure>
result: assign code to the method facet of the slot of the frame
return 1 if successful, return 0 otherwise
fputr (assign a reference)
invoke: fputr <frame> <slot> <procedure>
result: assign frame name to the reference facet of the slot of the frame
return 1 if successful, return 0 otherwise
fputs (assign a state)
invoke: fputs <frame> <value>
result: assign a state to a frame
return 1 if successful, return 0 otherwise
fputv (assign a value)
invoke: fputv <frame> <slot> <value>
result: assign value to the value facet of the slot of the frame
return 1 if successful, return 0 otherwise
fputx (assign agent code)
invoke: fputx <frame> <procedure>
result: assign agent code to a frame
return 1 if successful, 0 otherwise
fremoved (remove a demon facet)
invoke: fremoved <frame> <slot> <demon>
result: destroy demon facet in slot of the frame
return 1 if successful, return 0 otherwise
fremovef (remove a frame)
invoke: fremovef <frame>
result: destroy frame
return 1 if successful, return 0 otherwise
fremovem (remove a method facet)
invoke: fremovem <frame> <slot>
result: destory method facet in slot of the frame
return 1 if successful, return 0 otherwise
fremover (remove a reference)
invoke: fremover <frame> <slot>
result: destroy reference facet in slot of the frame
return 1 if successful, return 0 otherwise
fremoves (remove a slot)
invoke: fremoves <frame> <slot>
result: destory slot of the frame
return 1 if successful, return 0 otherwise
fremovev (remove a value facet)
invoke: fremovev <frame> <slot>
result: destroy value facet in slot of the frame
return 1 if successful, return 0 otherwise
frpc (remote procedure call)
invoke: frpc <message> <socket>
result: send code to be executed to server
return results of that execution
fscreated (create a demon facet for a frame set)
invoke: fscreated <set> <slot> <demon>
result: a new demon facet is created in the slot of the frame set
return 1 if successful, return 0 otherwise
fscreatem (create a method facet for a frame set)
invoke: fscreatem <set> <slot>
result: a new method facet is created in the slot of the frame set
return 1 if successful, return 0 otherwise
fscreater (create a reference for a frame set)
invoke: fscreater <set> <slot>
result: a new reference facet is created in the slot of the frame set
return 1 if successful, return 0 otherwise
fscreates (create a slot for a frame set)
invoke: fscreates <set> <slot>
result: a new slot is created in the frame set
return 1 if successful, return 0 otherwise
fscreatev (create a value facet for a frame set)
invoke: fscreatev <set> <slot>
result: a new value facet is created in the slot of the frame set
return 1 if successful, return 0 otherwise
fsendf (send a frame)
invoke: fsendf <frame> <socket>
result: send a frame to a server
return 1 if successful, 0 otherwise
fsendfs (send a frame set)
invoke: fsendfs <set> <socket>
result: send a frame set to a server
return 1 if successful, 0 otherwise
fsexcludef (exclude a frame from a frame set)
invoke: fsexcludef <set> <frame>
result: frame is excluded from the frame set
return 1 if successful, return 0 otherwise
fsgetr (get a reference from a frame set)
invoke: fsgetr <set> <slot>
result: return a reference from a slot if successful, return "" otherwise
fsincludef (include a frame in a frame set)
invoke: fsincludef <set> <frame>
result: frame is included in the frame set
return 1 if successful, return 0 otherwise
fsleepf (put a frame to sleep)
invoke: fsleepf <frame>
result: put a frame to sleep so that methods cannot be invoked
return 1 if successful, 0 otherwise
fsleepfs (put a frame set to sleep)
invoke: fsleepfs <set>
result: put a frame set to sleep so that methods of associated frames
cannot be invoked
return 1 if successful, 0 otherwise
fslistf (get a list of frames in a frame set)
invoke: fslistf <set>
result: return the frames which are part of the frame set
return empty list if this fails
fsmemberf (get a list of frame sets of which a frame is a member)
invoke: fsmemberf <frame>
result: return a list of frame sets of which a frame is a member
return empty list if this fails
fsputr (assign a reference to a frame set)
invoke: fsputr <set> <slot> <frame>
result: put a reference into a slot of the frame set
return 1 if successful, return 0 otherwise
fsremoved (remove a demon facet from a frame set)
invoke: fsremoved <set> <slot> <demon>
result: destroy demon facet in slot of the frame set
return 1 if successful, return 0 otherwise
fsremovem (remove method demon from a frame set)
invoke: fsremovem <set> <slot>
result: destory method facet in slot of the frame set
return 1 if successful, return 0 otherwise
fsremover (remove a reference from a frame set)
invoke: fsremover <set> <slot>
result: destroy reference facet in slot of the frame set
return 1 if successful, return 0 otherwise
fsremoves (remove a slot from a frame set)
invoke: fsremoves <set> <slot>
result: destory slot of the frame set
return 1 if successful, return 0 otherwise
fsremovev (remove a value facet from a frame set)
invoke: fsremovev <set> <slot>
result: destroy value facet in slot of the frame set
return 1 if successful, return 0 otherwise
fstoref (store a frame)
invoke: fstoref <frame>
result: store the representation of a frame on disk
return 1 if successful, return 0 otherwise
fstorefs (store a frame set)
invoke: fstorefs <set>
result: store the representation of a frame set on disk
return 1 if successful, return 0 otherwise
funlockf (unlock a frame)
invoke: funlockf <frame>
result: unlocks a frame so that it can be modified
return 1 if successful, 0 otherwise
funlockfs (unlock a frame set)
invoke: funlockfs <set>
result: unlocks a frame set so that it can be modified
return 1 if successful, 0 otherwise
funpack (unpack a frame)
invoke: funpack <frame> <packed list>
result: unpacks and restores a frame from a packed list
fupdatef (synchronize a frame)
invoke: fupdate <frame> <frame>
result: synchronize frame structure of first frame on second frame
return 1 if successful, return 0 otherwise
fwakef (wake up a frame)
invoke: fwakef <frame>
result: wake up a frame so that methods can be invoked
return 1 if successful, 0 otherwise
fwakefs (wake up a frame set)
invoke: fwakefs <set>
result: wake up a frame set so that methods of associated frames can be invoked
return 1 if successful, 0 otherwise
Internal Structure
The internal structure of the frame system begins with a root variable
containing the names of all the frames. In turn the frames consist of
associative arrays. The elements of an associative array contain agent code,
an agent state, a list of slots, a list of facets, procedure names, frame
names, and values.
fframes = {frame name ..}
frame(frame,start) = code
frame(frame,state) = active | asleep | locked | inactive
frame(frame,slots) = {slot name ..}
frame(slot,facets) = {facet name ..}
frame(slot,method) = code
frame(slot,value) = {value ..}
frame(slot,ref) = frame name
frame(slot,demon) = code
Frame sets also consist of associative arrays. The elements of an
associative array contain agent code, an agent state, a list of frames
included in the frame set, a list of slots, a list of facets, and frame names.
frame(frame,start) = code
frame(frame,state) = active | asleep | locked | inactive
frame(frame,set) = {frame name ..}
frame(frame,slots) = {slot name ..}
frame(slot,facets) = {facet name ..}
frame(slot,method) = {}
frame(slot,value) = {}
frame(slot,ref) = frame name
frame(slot,demon) = {}
Agents
Agents are supposed to be autonomous, so when an agent moves its main
code in frame(frame,start) is automatically started (unless the agent is
asleep). This variable is universal so it cannot be created or removed.
The state of an agent is used for timing. Am active state allows
both invocations and modifications. Asleep prevents invocations. Locked
prevents modifications. An inactive state prevents both invocations and
modifications. This variable is also universal so it cannot be created
or removed either.
References
References are used by method and value operations to locate
method and value facets to operate on. There can only be one reference
in a reference facet. However, there can be an unlimited chain of
references. The only requirements are that a method or value facet must
terminate the chain of references, and all references must be in slots
of the same name.
Demons
Demons (like methods) point to procedures. However, unlike methods,
demons are automatically called when operations are performed on methods,
values, or references.
Demon operations do not directly use references. However, the location
of demons to execute directly depends on the location where method, value,
and reference operations are performed.
The demons which can be defined are ifcreatem, ifcreater, ifcreatev,
ifexecm, ifexistm, ifexistr, ifexistv, ifgetm, ifgetr, ifgetv, ifputm,
ifputr, ifputv, ifref, ifremovem, ifremover, and ifremovev.
List Extension
The list extension provides some service to the frame system. However,
its potential use should be in procedures pointed to by methods and
demons which operate on values stored in the frames.
Frame Set Operations
Commands involving the structure of frames are repeated for every
frame included in the frame set. This does not mean that all frames
included in the frame set have exactly the same structure and values.
It only means that there is a core structure which all the frames
in the frame set pocess.
Frame Storage
Frames are stored by using the frame name as the file name, and saving
each pair of element name and value of the associated array. Loading
a frame then consists of appending the frame name to fframes, and a series
of set statements to restore the structure of the associated array.
file name=frame name
file contents:
frame,start code
frame,state <state>
frame,slots {slot name ..}
slot,facets {facet name ..}
slot,method <code>
slot,value {value ..}
slot,ref <frame>
slot,demon <code>
Frame Set Storage
Frame sets are stored by using the frame name as the file name, and saving
each pair of element name and value of the associated array. Loading
a frame set then consists of appending the frame set name to fframes, a series
of set statements to restore the structure of the associated array, and then
using the list of frames stored in the frame set to repeat the process for
the frames included in the frame set.
file name=frame set name
file contents:
frame,start <code>
frame,state <state>
frame,set {frame name ..}
frame,slots {slot name ..}
slot,facets {facet name ..}
slot,method {}
slot,value {}
slot,ref <frame>
slot,demon {}
This software is OSI Certified Open Source Software.
OSI Certified is a certification mark of the Open Source Initiative.frameagents.tcl
######################################################################
#
# program name: frameagents.tcl
# programmer: Cris A. Fugate
# date written: September 2, 1998 (wrote frames.tcl)
# changed: September 28, 1998 (added floadf and fstoref to frames)
# changed: November 25, 1998 (wrote framesets.tcl)
# changed: February 10, 1999 (added fupdatef to frames,
# added fsgetr, fsputr and fsmemberf to framesets)
# changed: April 16, 1999 (merged frames and framesets)
# changed: November 8, 1999 (added args to fputv,fputm,fputd)
# changed: February 15, 2000 (added agent technology)
#
# description: This program is an extension to the tcl scripting
# language. It provides a frame and frameset
# mechanism which can be used to dynamically organize
# and perform operations on values and procedures.
#
# Copyright (c) 2000 Cris A. Fugate
#
# Permission is hereby granted, free of charge, to any person obtaining
# a copy of this software and associated documentation files (the
# "Software"), to deal in the Software without restriction, including
# without limitation the rights to use, copy, modify, merge, publish,
# distribute, sublicense, and/or sell copies of the Software, and to
# permit persons to whom the Software is furnished to do so, subject to
# the following conditions:
#
# The above copyright notice and this permission notice shall be included
# in all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
# OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
# THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR
# OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE,
# ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
# OTHER DEALINGS IN THE SOFTWARE.
#
######################################################################
#
# Variables
#
# aname array name
# args list of arguments
# avalue array value
# cmp comparison flag
# created create flag
# dname demon type
# elcnt count of list elements
# elema element of a list
# executed execute flag
# exist flag for frame exists
# fframes list of frames
# fh file handle
# fhbuf file handle buffer
# flist list of references in a frame
# fname frame name
# fname1 frame name
# fname2 frame name
# found exist flag
# ftype facet type
# i loop variable
# lista first list to be processed
# listb second list to be processed
# listx first temporary list
# listy second temporary list
# mlist list of framesets of which a frame
# is a member
# msg message to send/receive
# name frameset name
# plist list of frames in a reference chain
# pname procedure name
# put put flag
# r reference
# removed remove flag
# result result returned from server
# s list of frames in the frameset
# sid server socket id
# sname slot name
# sname2 slot name
# status status of a frame
# x variable used in place of expression
# y variable used in place of expression
# <fname>(<ename>) used in operations involving many elements
# <fname>(<fname>,set) frames in a frameset
# <fname>(<fname>,slots) slots in a frame
# <fname>(<fname>,start) code to execute after frame is sent
# <fname>(<fname>,state) state of a frame
# <fname>(<sname>,<ftype>) demon facet
# <fname>(<sname>,facets) facets in a slot
# <fname>(<sname>,ifcreatem) ifcreatem demon
# <fname>(<sname>,ifcreater) ifcreater demon
# <fname>(<sname>,ifcreatev) ifcreatev demon
# <fname>(<sname>,ifexecm) ifexecm demon
# <fname>(<sname>,ifexistm) ifexistm demon
# <fname>(<sname>,ifexistr) ifexistr demon
# <fname>(<sname>,ifexistv) ifexistv demon
# <fname>(<sname>,ifgetm) ifgetm demon
# <fname>(<sname>,ifgetr) ifgetr demon
# <fname>(<sname>,ifgetv) ifgetv demon
# <fname>(<sname>,ifputm) ifputm demon
# <fname>(<sname>,ifputr) ifputr demon
# <fname>(<sname>,ifputv) ifputv demon
# <fname>(<sname>,ifref) ifref demon
# <fname>(<sname>,ifremovem) ifremovem demon
# <fname>(<sname>,ifremover) ifremover demon
# <fname>(<sname>,ifremovev) ifremovev demon
# <fname>(<sname>,method) method facet
# <fname>(<sname>,ref) reference facet
# <fname>(<sname>,value) value facet
#
######################################################################
#
# Procedures
#
# compress order and remove duplicates from a list
# equivalence determine is two lists are equivalent
# fcomparef compare slots of two frames
# fcompares compare two slots
# fcopyf make a copy of a frame
# fcopys make a copy of a slot in another frame
# fcreated create a demon facet
# fcreatef create a frame
# fcreatefs create a frameset
# fcreatem create a method facet
# fcreater create a reference facet
# fcreates create a slot
# fcreatev create a value facet
# fdo do something
# fdos do something service
# fexecd directly execution a demon
# fexecm execute a method
# fexecx execute a frame start method
# fexistd determine if a demon facet exists
# fexistf determine if a frame exists
# fexistm determine if a method facet exists
# fexistr determine if a reference facet exists
# fexistrx (same as fexistr without a demon call)
# fexists determine if a slot exists
# fexistv determine if a value facet exists
# ffetchf fetch a frame
# ffetchfs fetch a frameset
# ffilterf filter a frame based on another frame
# fgetd get the value of a demon facet
# fgetm get the value of a method facet
# fgetr get the value of a reference facet
# fgets get the state of a frame
# fgetv get the value of a value facet
# fgetx get the start code of a frame
# flistf get a list of existing frames
# flistr get a list of references in a frame
# flists get a list of slots for a frame
# flistt get a list of facet types for a slot
# floadf load a frame into memory
# floadfs load a frameset into memory
# flockf lock a frame
# flockfs lock a frameset
# fmergef merge slots of a frame into another frame
# fpack pack a frame
# fpathr get a list of frames in a reference chain
# fputd put a value into a demon facet
# fputm put a value into a method facet
# fputr put a value into a reference facet
# fputs assign a state to a frame
# fputv put a value into a value facet
# fputx assign start code to a frame
# fremoved destroy a demon facet
# fremovef destroy a frame
# fremovefs destroy a frameset
# fremovem destroy a method facet
# fremover destroy a reference facet
# fremoves destroy a slot
# fremovev destroy a value facet
# frpc remote procedure call
# frpcs remote procedure call service
# fscreated create a demon facet in a frameset
# fscreatem create a method facet in a frameset
# fscreater create a reference facet in a frameset
# fscreates create a slot in a frameset
# fscreatev create a value facet in a frameset
# fsendf send a frame
# fsendfs send a frameset
# fsexcludef exclude a frame from a frameset
# fsgetr get a value from a reference facet
# in a frameset
# fsincludef include a frame in a frameset
# fsleepf put a frame to sleep
# fsleepfs put a frameset to sleep
# fslistf get a list of frames in a frameset
# fsmemberf get list of framesets in which
# a frame is a member
# fsputr put a value in a reference facet
# in a frameset
# fsremoved remove a demon facet from a frameset
# fsremovem remove a method facet from a frameset
# fsremover remove a reference facet from a frameset
# fsremoves remove a slot from a frameset
# fsremovev remove a value facet from a frameset
# fstoref store a frame on disk
# fstorefs store a frameset on disk
# funlockf unlock a frame
# funlockfs unlock a frameset
# funpack unpack a frame
# fupdatef synchronize a frame based on another frame
# fwakef wake up a frame
# fwakefs wake up a frameset
# member determine if a value is a member of a list
# remove remove a value from a list
#
#
# compress - order and remove duplicates from a list
# modifies lista
#
proc compress lista {
upvar $lista listx
set listx [lsort $listx]
set listy [lindex $listx 0]
set elema $listy
foreach i $listx {
if {$elema != $i} {
lappend listy $i
}
set elema $i
}
set listx $listy
}
#
# equivalence - determine if two lists are equivalent
#
proc equivalence {lista listb} {
set listx $lista
set listy $listb
compress listx
compress listy
if {$listx == $listy} {
return 1
} else {
return 0
}
}
#
# member - determine if an element is a member of a list
#
proc member {lista elema} {
set elcnt 0
foreach i $lista {
if {$elema == $i} {
incr elcnt
}
}
return $elcnt
}
#
# remove - remove all occurances of an element from a list
# modifies lista
#
proc remove {lista elema} {
upvar $lista listx
set listy {}
foreach i $listx {
if {$elema != $i} {
lappend listy $i
}
}
set listx $listy
}
# initialize frames
set fframes {}
#
# fexistf - determine if a frame exists
# calls member
#
proc fexistf fname {
global fframes
return [member $fframes $fname]
}
#
# fcreatef - create a frame
# requires that fname() does not exist
# modifies fframes, fname(fname,slots)
# calls fexistf
#
proc fcreatef fname {
global fframes
if {![fexistf $fname]} {
lappend fframes $fname
uplevel \#0 "set $fname\($fname,start) {}"
uplevel \#0 "set $fname\($fname,state) {active}"
uplevel \#0 "set $fname\($fname,slots) {}"
return 1
} else {
return 0
}
}
#
# fremovef - remove a frame
# requires that fname() exists and is not locked
# modifies fframes,fname()
# calls fexistf, fgets
#
proc fremovef fname {
global fframes
if {[fexistf $fname] && [fgets $fname] != "locked" && [fgets $fname] != "inactive"} {
foreach i [uplevel \#0 "array names $fname"] {
uplevel \#0 "unset $fname\($i)"
}
remove fframes $fname
return 1
} else {
return 0
}
}
#
# flistf - return list of frames
#
proc flistf {} {
global fframes
return $fframes
}
#
# fcopyf - create a new frame based on another frame
# requires that fname1() exists and fname2() is not locked
# modifies fname2()
# calls fexistf, fremovef
#
proc fcopyf {fname1 fname2} {
if {[fexistf $fname1] && [fgets $fname2] != "locked" && [fgets $fname2] != "inactive"} {
fremovef $fname2
fcreatef $fname2
uplevel \#0 "set $fname2\($fname2,slots) $$fname1\($fname1,slots)"
foreach i [uplevel \#0 "array names $fname1"] {
if {$i != "$fname1,start" && $i != "$fname1,state" && $i != "$fname1,set" && $i != "$fname1,slots"} {
uplevel \#0 "set $fname2\($i) $$fname1\($i)"
}
}
return 1
} else {
return 0
}
}
#
# fcomparef - determine if two frames are equivalent
# requires that fname1() and fname2() exist
# calls fexistf
#
proc fcomparef {fname1 fname2} {
if {[fexistf $fname1] && [fexistf $fname2]} {
set x [uplevel \#0 "set $fname1\($fname1,slots)"]
set y [uplevel \#0 "set $fname2\($fname2,slots)"]
if {[equivalence $x $y]} {
return 1
} else {
return 0
}
} else {
return 0
}
}
#
# fmergef - merge slots of one frame into another other
# requires that fname1() and fname2() exist and fname2() is not locked
# modifies fname2()
# calls fexistf, fgets
#
proc fmergef {fname1 fname2} {
if {[fexistf $fname1] && [fexistf $fname2] && [fgets $fname2] != "locked" && [fgets $fname2] != "inactive"} {
set y [uplevel \#0 "set $fname2\($fname2,slots)"]
foreach i [uplevel \#0 "array names $fname1"] {
if {$i != "$fname1,start" && $i != "$fname1,state" && $i != "$fname1,set" && $i != "$fname1,slots"} {
scan $i "%\[^,]" sname
if {![member $y $sname]} {
uplevel \#0 "set $fname2\($i) $$fname1\($i)"
uplevel \#0 "lappend $fname2\($fname2,slots) $sname"
}
}
}
return 1
} else {
return 0
}
}
#
# floadf - load a frame into memory
# requires that fname() exists on disk, but not in memory
# calls fexistf, remove
#
proc floadf fname {
global fframes
if {[file exists $fname] && ![fexistf $fname]} {
lappend fframes $fname
set fh [open $fname r]
while {![eof $fh]} {
gets $fh fhbuf
set aname [lindex $fhbuf 0]
set avalue [remove fhbuf $aname]
uplevel \#0 "set $fname\($aname) {$avalue}"
}
close $fh
return 1
} else {
return 0
}
}
#
# fstoref - store a frame on disk
# requires that fname() exists
# calls fexistf
#
proc fstoref fname {
if {[fexistf $fname]} {
set fh [open $fname w]
foreach i [uplevel \#0 "array names $fname"] {
set avalue [uplevel \#0 "set $fname\($i)"]
puts $fh "$i $avalue"
}
close $fh
return 1
} else {
return 0
}
}
#
# fupdatef - update structure of a frame from another frame
# requires that both frames exist and fname2() is not locked
# modifies frame2()
# calls fexistf, fgets
#
proc fupdatef {fname1 fname2} {
if {[fexistf $fname1] && [fexistf $fname2] && [fgets $fname2] != "locked" && [fgets $fname2] != "inactive"} {
uplevel \#0 "set $fname2\($fname2,slots) $$fname1\($fname1,slots)"
foreach i [uplevel \#0 "array names $fname2"] {
if {$i != "$fname2,start" && $i != "$fname2,state" && $i != "$fname2,set" && $i != "$fname2,slots"} {
if {![uplevel \#0 "info exists $fname1\($i)"]} {
uplevel \#0 "unset $fname2\($i)"
}
}
}
foreach i [uplevel \#0 "array names $fname1"] {
if {$i != "$fname1,start" && $i != "$fname1,state" && $i != "$fname1,set" && $i != "$fname1,slots"} {
if {![uplevel \#0 "info exists $fname2\($i)"]} {
uplevel \#0 "set $fname2\($i) $$fname1\($i)"
}
}
}
return 1
} else {
return 0
}
}
#
# ffilterf - filter slots of a frame based on another frame
# requires that both frames exist and fname2() is not locked
# modifies frame2()
# calls fexistf, fgets
#
proc ffilterf {fname1 fname2} {
if {[fexistf $fname1] && [fexistf $fname2] && [fgets $fname2] != "locked" && [fgets $fname2] != "inactive"} {
foreach i [uplevel \#0 "array names $fname2"] {
if {$i != "$fname2,start" && $i != "$fname2,state" && $i != "$fname2,set" && $i != "$fname2,slots"} {
if {![uplevel \#0 "info exists $fname1\($i)"]} {
uplevel \#0 "unset $fname2\($i)"
}
}
}
return 1
} else {
return 0
}
}
#
# fexists - determine if a slot exists
# requires that fname() exists
# fexistf
#
proc fexists {fname sname} {
if {[fexistf $fname]} {
if {[uplevel \#0 "member $$fname\($fname,slots) $sname"]} {
return 1
} else {
return 0
}
} else {
return 0
}
}
#
# fcreates - create a slot
# requires that fname() exists and is not locked
# modifies fname(fname,slot),fname(sname,facets)
# calls fexistf, fgets
#
proc fcreates {fname sname} {
if {[fexistf $fname] && [fgets $fname] != "locked" && [fgets $fname] != "inactive"} {
if {[uplevel \#0 "member $$fname\($fname,slots) $sname"] == 0} {
uplevel \#0 "lappend $fname\($fname,slots) $sname"
uplevel \#0 "set $fname\($sname,facets) {}"
return 1
} else {
return 0
}
} else {
return 0
}
}
#
# fremoves - remove a slot
# requires that fname(sname,facets) exists and fname() is not locked
# modifies fname(fname,slots),fname(sname,)
# calls fexists, fgets, remove
#
proc fremoves {fname sname} {
if {[fexists $fname $sname] && [fgets $fname] != "locked" && [fgets $fname] != "inactive"} {
foreach i [uplevel \#0 "array names $fname"] {
scan $i "%\[^,]" sname2
if {$sname == $sname2} {
uplevel \#0 "unset $fname\($i)"
}
}
uplevel \#0 "remove $fname\($fname,slots) $sname"
return 1
} else {
return 0
}
}
#
# flists - list slots of a frame
# requires that fname() exists
# calls fexistf
#
proc flists fname {
if {[fexistf $fname]} {
return [uplevel \#0 "set $fname\($fname,slots)"]
} else {
return {}
}
}
#
# fcopys - copy a slot into another frame
# requires that fname1() and fname2() exist
# modifies fname2(sname,)
# calls fexists, fexistf, fgets, member
#
proc fcopys {fname1 sname fname2} {
if {[fexists $fname1 $sname] && [fexistf $fname2] && [fgets $fname2] != "locked" && [fgets $fname2] != "inactive"} {
if {[uplevel \#0 "member $$fname2\($fname2,slots) $sname"] == 0} {
uplevel \#0 "lappend $fname2\($fname2,slots) $sname"
}
foreach i [uplevel \#0 "array names $fname1"] {
scan $i "%\[^,]" sname2
if {$sname == $sname2} {
uplevel \#0 "set $fname2\($i) $$fname1\($i)"
}
}
return 1
} else {
return 0
}
}
#
# fcompares - compare a slot in two frames
# requires that fname1(sname,facets) and fname2(sname,facets) exist
# calls fexists, equivalence
#
proc fcompares {fname1 sname fname2} {
set cmp 1
if {[fexists $fname1 $sname] && [fexists $fname2 $sname]} {
set x [uplevel \#0 "set $fname1\($sname,facets)"]
set y [uplevel \#0 "set $fname2\($sname,facets)"]
if {[equivalence $x $y]} {
foreach i [uplevel \#0 "array names $fname1"] {
scan $i "%\[^,]" sname2
if {$sname == $sname2} {
set x [uplevel \#0 "set $fname1\($i)"]
set y [uplevel \#0 "set $fname2\($i)"]
if {$x != $y} {
set cmp 0
}
}
}
return $cmp
} else {
return 0
}
} else {
return 0
}
}
#
# flistt - list of facet types in a slot
# requires that fname(sname,facets) exists
# calls fexists
#
proc flistt {fname sname} {
if {[fexists $fname $sname]} {
return [uplevel \#0 "set $fname\($sname,facets)"]
} else {
return {}
}
}
#
# fexistrx - determine if a reference facet exists (internal)
# requires that fname(sname,facets) exists
# fexists, member
#
proc fexistrx {fname sname} {
if {[fexists $fname $sname]} {
if {[uplevel \#0 "member $$fname\($sname,facets) ref"]} {
return 1
} else {
return 0
}
} else {
return 0
}
}
#
# fexistr - determine if a reference facet exists
# requires that fname(sname,facets) exists
# calls fexistrx, member, ifexistr demon
#
proc fexistr {fname sname} {
if {[fexistrx $fname $sname]} {
if {[uplevel \#0 "member $$fname\($sname,facets) ifexistr"]} {
uplevel \#0 "eval $$fname\($sname,ifexistr)"
}
return 1
} else {
return 0
}
}
#
# fcreater - create a reference facet
# requires that fname(sname,facets) exists and fname() is not locked
# modifies fname(sname,facets),fname(sname,ref)
# calls fexists, fgets, member, ifcreater demon
#
proc fcreater {fname sname} {
if {[fexists $fname $sname] && [fgets $fname] != "locked" && [fgets $fname] != "inactive"} {
if {[uplevel \#0 "member $$fname\($sname,facets) ref"] == 0} {
set x [uplevel \#0 "member $$fname\($sname,facets) method"]
set y [uplevel \#0 "member $$fname\($sname,facets) value"]
if {!($x || $y)} {
uplevel \#0 "lappend $fname\($sname,facets) ref"
uplevel \#0 "set $fname\($sname,ref) {}"
if {[uplevel \#0 "member $$fname\($sname,facets) ifcreater"]} {
uplevel \#0 "eval $$fname\($sname,ifcreater)"
}
return 1
} else {
return 0
}
} else {
return 0
}
} else {
return 0
}
}
#
# fremover - remove a reference facet
# requires that fname(sname,ref) exists and fname() is not locked
# modifies fname(sname,facets),fname(sname,ref)
# calls fexistrx, fgets, member, remove, ifremover demon
#
proc fremover {fname sname} {
if {[fexistrx $fname $sname] && [fgets $fname] != "locked" && [fgets $fname] != "inactive"} {
if {[uplevel \#0 "member $$fname\($sname,facets) ifremover"]} {
uplevel \#0 "eval $$fname\($sname,ifremover)"
}
uplevel \#0 "unset $fname\($sname,ref)"
uplevel \#0 "remove $fname\($sname,facets) ref"
return 1
} else {
return 0
}
}
#
# fgetr - get a value from a reference facet
# requires that fname(sname,ref) exists
# calls fexistrx, member, ifgetr demon
#
proc fgetr {fname sname} {
if {[fexistrx $fname $sname]} {
if {[uplevel \#0 "member $$fname\($sname,facets) ifgetr"]} {
uplevel \#0 "eval $$fname\($sname,ifgetr)"
}
return [uplevel \#0 "set $fname\($sname,ref)"]
} else {
return {}
}
}
#
# fputr - put a value in a reference facet
# requires that fname1(sname,ref) exists and fname1() is not locked
# modifies fname(sname,ref)
# calls fexistrx, fgets, member, ifputr demon
#
proc fputr {fname1 sname fname2} {
if {[fexistrx $fname1 $sname] && [fgets $fname1] != "locked" && [fgets $fname1] != "inactive"} {
uplevel \#0 "set $fname1\($sname,ref) $fname2"
if {[uplevel \#0 "member $$fname1\($sname,facets) ifputr"]} {
uplevel \#0 "eval $$fname1\($sname,ifputr)"
}
return 1
} else {
return 0
}
}
#
# flistr - list of references in a frame
# requires that fname() exists
# calls fexistf
#
proc flistr fname {
set flist {}
if {[fexistf $fname]} {
foreach i [uplevel \#0 "array names $fname"] {
scan $i "%\[^,],%s" sname ftype
if {$ftype == "ref"} {
lappend flist $sname
}
}
}
return $flist
}
#
# fpathr - return chain of references
# requires that fname(sname,facets) exists
# calls fexists, member, fpathr
#
proc fpathr {fname sname {plist {}}} {
if {[fexists $fname $sname]} {
if {[member $plist $fname] == 0} {
lappend plist $fname
if {[uplevel \#0 "member $$fname\($sname,facets) ref"]} {
set fname2 [uplevel \#0 "set $fname\($sname,ref)"]
fpathr $fname2 $sname $plist
} else {
return $plist
}
} else {
return $plist
}
} else {
return $plist
}
}
#
# fexistm - determine if a method facet exists
# requires that fname(sname,facets) exists
# calls fexists, fexistrx, member, fexistm, ifref and ifexistm demons
#
proc fexistm {fname sname} {
set found 0
if {[fexists $fname $sname]} {
if {[fexistrx $fname $sname]} {
set fname2 [uplevel \#0 "set $fname\($sname,ref)"]
if {[uplevel \#0 "member $$fname\($sname,facets) ifref"]} {
uplevel \#0 "eval $$fname\($sname,ifref)"
}
set found [fexistm $fname2 $sname]
}
if {[uplevel \#0 "member $$fname\($sname,facets) method"]} {
if {[uplevel \#0 "member $$fname\($sname,facets) ifexistm"]} {
uplevel \#0 "eval $$fname\($sname,ifexistm)"
}
set found 1
}
}
return $found
}
#
# fcreatem - create a method facet
# requires that fname(sname,facets) exists and fname() is not locked
# modifies fname(sname,facets),fname(sname,method) where fname is
# the original or referenced frame
# calls fexists, fgets, member, fcreatem, ifref and ifcreatem demons
#
proc fcreatem {fname sname} {
set created 0
if {[fexists $fname $sname] && [fgets $fname] != "locked" && [fgets $fname] != "inactive"} {
if {[uplevel \#0 "member $$fname\($sname,facets) method"] ||
[uplevel \#0 "member $$fname\($sname,facets) value"]} {
set created 0
} else {
if {[uplevel \#0 "member $$fname\($sname,facets) ref"]} {
set fname2 [uplevel \#0 "set $fname\($sname,ref)"]
if {[uplevel \#0 "member $$fname\($sname,facets) ifref"]} {
uplevel \#0 "eval $$fname\($sname,ifref)"
}
set created [fcreatem $fname2 $sname]
} else {
uplevel \#0 "set $fname\($sname,method) {}"
uplevel \#0 "lappend $fname\($sname,facets) method"
if {[uplevel \#0 "member $$fname\($sname,facets) ifcreatem"]} {
uplevel \#0 "eval $$fname\($sname,ifcreatem)"
}
set created 1
}
}
}
return $created
}
#
# fremovem - remove a method facet
# requires sthat fname(sname,facets) exists and fname() is not locked
# modifies fname(sname,facets),fname(sname,method) where fname is
# the original or referenced frame
# calls fexists, fgets, member, fremovem, remove, ifref and ifremovem demons
#
proc fremovem {fname sname} {
set removed 0
if {[fexists $fname $sname] && [fgets $fname] != "locked" && [fgets $fname] != "inactive"} {
if {[uplevel \#0 "member $$fname\($sname,facets) ref"]} {
set fname2 [uplevel \#0 "set $fname\($sname,ref)"]
if {[uplevel \#0 "member $$fname\($sname,facets) ifref"]} {
uplevel \#0 "eval $$fname\($sname,ifref)"
}
set removed [fremovem $fname2 $sname]
} else {
if {[uplevel \#0 "member $$fname\($sname,facets) method"]} {
if {[uplevel \#0 "member $$fname\($sname,facets) ifremovem"]} {
uplevel \#0 "eval $$fname\($sname,ifremovem)"
}
uplevel \#0 "unset $fname\($sname,method)"
uplevel \#0 "remove $fname\($sname,facets) method"
set removed 1
}
}
}
return $removed
}
#
# fexecm - execute a method
# requires that fname(sname,facets) exists and fname() is not asleep
# calls fexists, fgets, member, fexecm, ifref and ifexecm demons
#
proc fexecm {fname sname} {
set executed 0
if {[fexists $fname $sname] && [fgets $fname] != "asleep" && [fgets $fname] != "inactive"} {
if {[uplevel \#0 "member $$fname\($sname,facets) ref"]} {
set fname2 [uplevel \#0 "set $fname\($sname,ref)"]
if {[uplevel \#0 "member $fname\($sname,facets) ifref"]} {
uplevel \#0 "eval $$fname\($sname,ifref)"
}
set executed [fexecm $fname2 $sname]
} else {
if {[uplevel \#0 "member $$fname\($sname,facets) method"]} {
if {[uplevel \#0 "member $$fname\($sname,facets) ifexecm"]} {
uplevel \#0 "eval $$fname\($sname,ifexecm)"
}
uplevel \#0 "eval $$fname\($sname,method)"
set executed 1
}
}
}
return $executed
}
#
# fgetm - get a value from a method facet
# requires that fname(sname,facets) exists
# calls fexists, member, fgetm, ifref and ifgetm demons
#
proc fgetm {fname sname} {
set pname {}
if {[fexists $fname $sname]} {
if {[uplevel \#0 "member $$fname\($sname,facets) ref"]} {
set fname2 [uplevel \#0 "set $fname\($sname,ref)"]
if {[uplevel \#0 "member $$fname\($sname,facets) ifref"]} {
uplevel \#0 "eval $$fname\($sname,ifref)"
}
set pname [fgetm $fname2 $sname]
} else {
if {[uplevel \#0 "member $$fname\($sname,facets) method"]} {
if {[uplevel \#0 "member $$fname\($sname,facets) ifgetm"]} {
uplevel \#0 "eval $$fname\($sname,ifgetm)"
}
set pname [uplevel \#0 "set $fname\($sname,method)"]
}
}
}
return $pname
}
#
# fputm - put a value in a method facet
# requires that fname(sname,facets) exists and fname() is not locked
# modifies fname(sname,method) where fname is the original or
# referenced frame
# calls fexists, fgets, member, fputm, ifref and ifputm demons
#
proc fputm {fname sname args} {
set put 0
if {[fexists $fname $sname] && [fgets $fname] != "locked" && [fgets $fname] != "inactive"} {
if {[uplevel \#0 "member $$fname\($sname,facets) ref"]} {
set fname2 [uplevel \#0 "set $fname\($sname,ref)"]
if {[uplevel \#0 "member $$fname\($sname,facets) ifref"]} {
uplevel \#0 "eval $$fname\($sname,ifref)"
}
set put [fputm $fname2 $sname $args]
} else {
if {[uplevel \#0 "member $$fname\($sname,facets) method"]} {
if {[uplevel \#0 "member $$fname\($sname,facets) ifputm"]} {
uplevel \#0 "eval $$fname\($sname,ifputm)"
}
uplevel \#0 "set $fname\($sname,method) $args"
set put 1
}
}
}
return $put
}
#
# fexistv - determine if a value facet exists
# requires that fname(sname,facets) exists
# calls fexists, fexistrx, member, fexistv, ifref and ifexistv demons
#
proc fexistv {fname sname} {
set found 0
if {[fexists $fname $sname]} {
if {[fexistrx $fname $sname]} {
set fname2 [uplevel \#0 "set $fname\($sname,ref)"]
if {[uplevel \#0 "member $$fname\($sname,facets) ifref"]} {
uplevel \#0 "eval $$fname\($sname,ifref)"
}
set found [fexistv $fname2 $sname]
}
if {[uplevel \#0 "member $$fname\($sname,facets) value"]} {
if {[uplevel \#0 "member $$fname\($sname,facets) ifexistv"]} {
uplevel \#0 "eval $$fname\($sname,ifexistv)"
}
set found 1
}
}
return $found
}
#
# fcreatev - create a value facet
# requires that fname(sname,facets) exists and fname() is not locked
# modifies fname(sname,facets),fname(sname,value) where fname is
# the original or referenced frame
# calls fexists, fgets, member, fcreatev, ifref and ifcreatev demons
#
proc fcreatev {fname sname} {
set created 0
if {[fexists $fname $sname] && [fgets $fname] != "locked" && [fgets $fname] != "inactive"} {
if {[uplevel \#0 "member $$fname\($sname,facets) method"] ||
[uplevel \#0 "member $$fname\($sname,facets) value"]} {
set created 0
} else {
if {[uplevel \#0 "member $$fname\($sname,facets) ref"]} {
set fname2 [uplevel \#0 "set $fname\($sname,ref)"]
if {[uplevel \#0 "member $$fname\($sname,facets) ifref"]} {
uplevel \#0 "eval $$fname\($sname,ifref)"
}
set created [fcreatev $fname2 $sname]
} else {
uplevel \#0 "set $fname\($sname,value) {}"
uplevel \#0 "lappend $fname\($sname,facets) value"
if {[uplevel \#0 "member $$fname\($sname,facets) ifcreatev"]} {
uplevel \#0 "eval $$fname\($sname,ifcreatev)"
}
set created 1
}
}
}
return $created
}
#
# fremovev - remove a value facet
# requires that fname(sname,facets) exists and fname() is not locked
# modifies fname(sname,facets),fname(sname,value) where fname is
# the original or referenced frame
# calls fexists, fgets, member, fremovev, remove, ifref and ifremovev demons
#
proc fremovev {fname sname} {
set removed 0
if {[fexists $fname $sname] && [fgets $fname] != "locked" && [fgets $fname] != "inactive"} {
if {[uplevel \#0 "member $$fname\($sname,facets) ref"]} {
set fname2 [uplevel \#0 "set $fname\($sname,ref)"]
if {[uplevel \#0 "member $$fname\($sname,facets) ifref"]} {
uplevel \#0 "eval $$fname\($sname,ifref)"
}
set removed [fremovev $fname2 $sname]
} else {
if {[uplevel \#0 "member $$fname\($sname,facets) value"]} {
if {[uplevel \#0 "member $$fname\($sname,facets) ifremovev"]} {
uplevel \#0 "eval $$fname\($sname,ifremovev)"
}
uplevel \#0 "unset $fname\($sname,value)"
uplevel \#0 "remove $fname\($sname,facets) value"
set removed 1
}
}
}
return $removed
}
#
# fgetv - get a value from a value facet
# requires that fname(sname,facets) exists
# calls fexists, member, fgetv, ifref and ifgetv demons
#
proc fgetv {fname sname} {
set pname {}
if {[fexists $fname $sname]} {
if {[uplevel \#0 "member $$fname\($sname,facets) ref"]} {
set fname2 [uplevel \#0 "set $fname\($sname,ref)"]
if {[uplevel \#0 "member $$fname\($sname,facets) ifref"]} {
uplevel \#0 "eval $$fname\($sname,ifref)"
}
set pname [fgetv $fname2 $sname]
} else {
if {[uplevel \#0 "member $$fname\($sname,facets) value"]} {
if {[uplevel \#0 "member $$fname\($sname,facets) ifgetv"]} {
uplevel \#0 "eval $$fname\($sname,ifgetv)"
}
set pname [uplevel \#0 "set $fname\($sname,value)"]
}
}
}
return $pname
}
#
# fputv - put a value in a value facet
# requires that fname(sname,facets) exists and fname() is not locked
# modifies fname(sname,value) where fname is the original or
# referenced frame
# calls fexists, fgets, member, fputv, ifref and ifputv demons
#
proc fputv {fname sname args} {
set put 0
if {[fexists $fname $sname] && [fgets $fname] != "locked" && [fgets $fname] != "inactive"} {
if {[uplevel \#0 "member $$fname\($sname,facets) ref"]} {
set fname2 [uplevel \#0 "set $fname\($sname,ref)"]
if {[uplevel \#0 "member $$fname\($sname,facets) ifref"]} {
uplevel \#0 "eval $$fname\($sname,ifref)"
}
set put [fputv $fname2 $sname $args]
} else {
if {[uplevel \#0 "member $$fname\($sname,facets) value"]} {
uplevel \#0 "set $fname\($sname,value) $args"
if {[uplevel \#0 "member $$fname\($sname,facets) ifputv"]} {
uplevel \#0 "eval $$fname\($sname,ifputv)"
}
set put 1
}
}
}
return $put
}
#
# fexistd - determine if a demon facet exists
# requires that fname(sname,facets) exists
# calls fexists, member
#
proc fexistd {fname sname dname} {
if {[fexists $fname $sname]} {
if {[uplevel \#0 "member $$fname\($sname,facets) $dname"]} {
return 1
} else {
return 0
}
} else {
return 0
}
}
#
# fcreated - create a demon facet
# requires that fname(sname,facets) exists and fname() is not locked
# modifies fname(sname,facets),fname(sname,dname)
# calls fexists, fgets, member
#
proc fcreated {fname sname dname} {
if {[fexists $fname $sname] && [fgets $fname] != "locked" && [fgets $fname] != "inactive"} {
if {[uplevel \#0 "member $$fname\($sname,facets) $dname"] == 0} {
uplevel \#0 "set $fname\($sname,$dname) {}"
uplevel \#0 "lappend $fname\($sname,facets) $dname"
return 1
} else {
return 0
}
} else {
return 0
}
}
#
# fremoved - remove a demon facet
# requires that fname(sname,dname) exists and fname() is not locked
# modifies fname(sname,facets),fname(sname,dname)
# calls fexistd, fgets, remove
#
proc fremoved {fname sname dname} {
if {[fexistd $fname $sname $dname] && [fgets $fname] != "locked" && [fgets $fname] != "inactive"} {
uplevel \#0 "unset $fname\($sname,$dname)"
uplevel \#0 "remove $fname\($sname,facets) $dname"
return 1
} else {
return 0
}
}
#
# fgetd - get a value from a demon facet
# requires that fname(sname,dname) exists
# calls fexistd
#
proc fgetd {fname sname dname} {
if {[fexistd $fname $sname $dname]} {
return [uplevel \#0 "set $fname\($sname,$dname)"]
} else {
return {}
}
}
#
# fputd - put a value in a demon facet
# requires that fname(sname,dname) exists and fname() is not locked
# modifies fname(sname,dname)
# calls fexistd, fgets
#
proc fputd {fname sname dname args} {
if {[fexistd $fname $sname $dname] && [fgets $fname] != "locked" && [fgets $fname] != "inactive"} {
uplevel \#0 "set $fname\($sname,$dname) $args"
return 1
} else {
return 0
}
}
#
# fexecd - directly execute a demon
# requires that fname(sname,dname) exists and fname() is not asleep
# calls fexistd, fgets
#
proc fexecd {fname sname dname} {
if {[fexistd $fname $sname $dname] && [fgets $fname] != "asleep" && [fgets $fname] != "inactive"} {
uplevel \#0 "eval $$fname\($sname,$dname)"
return 1
} else {
return 0
}
}
#
# fcreatefs - create a frameset
# requires that name() does not exist and is not locked
# modifies fframes, name(name,set), name(name,slots)
# calls fexistf
#
proc fcreatefs {name} {
global fframes
if {![fexistf $name]} {
lappend fframes $name
uplevel \#0 "set $name\($name,start) {}"
uplevel \#0 "set $name\($name,state) {active}"
uplevel \#0 "set $name\($name,set) {}"
uplevel \#0 "set $name\($name,slots) {}"
return 1
} else {
return 0
}
}
#
# fremovefs - remove a frameset
# requires that name() exists and is not locked
# modifies fframes, name()
# calls fremovef
#
proc fremovefs {name} {
if {[fremovef $name]} {
return 1
} else {
return 0
}
}
#
# fslistf - return a list of frames in a frameset
# requires that name() exists
# calls fexistf
#
proc fslistf {name} {
if {[fexistf $name]} {
return [uplevel \#0 "set $name\($name,set)"]
} else {
return {}
}
}
#
# floadfs - load a frameset into memory
# requires that name() exist on disk, but not in memory
# calls floadf, fslistf
#
proc floadfs {name} {
if {[floadf $name]} {
set s [fslistf $name]
foreach i $s {
floadf $i
}
return 1
} else {
return 0
}
}
#
# fstorefs - store a frameset on disk
# requires that name() exists
# calls fstoref, fslistf
#
proc fstorefs {name} {
if {[fstoref $name]} {
set s [fslistf $name]
foreach i $s {
fstoref $i
}
return 1
} else {
return 0
}
}
#
# fsincludef - include a frame in a frameset
# requires that name() and fname() exist and name() is not locked
# modifies name(name,set)
# calls fexistf, fgets
#
proc fsincludef {name fname} {
if {[fexistf $name] && [fexistf $fname] && [fgets $name] != "locked" && [fgets $name] != "inactive"} {
uplevel \#0 "lappend $name\($name,set) $fname"
return 1
} else {
return 0
}
}
#
# fsexcludef - exclude a frame from a frameset
# requires that name() exists and is not locked
# modifies name(name,set)
# calls fexistf, fgets, member, remove
#
proc fsexcludef {name fname} {
if {[fexistf $name] && [fgets $name] != "locked" && [fgets $name] != "inactive"} {
if {[uplevel \#0 "member $$name\($name,set) $fname"]} {
uplevel \#0 "remove $name\($name,set) $fname"
return 1
} else {
return 0
}
} else {
return 0
}
}
#
# fscreates - create a slot in a frameset
# requires that name() exists and is not locked
# modifies name(name,slots), name(sname,facets), associated frames
# calls fcreates, fslistf
#
proc fscreates {name sname} {
if {[fcreates $name $sname]} {
set s [fslistf $name]
foreach i $s {
fcreates $i $sname
}
return 1
} else {
return 0
}
}
#
# fsremoves - remove a slot from a frameset
# requires that name(sname,facets) exists and name() is not locked
# modifies name(name,slots), name(sname,), associated frames
# calls fremoves, fslistf
#
proc sremoves {name sname} {
if {[fremoves $name $sname]} {
set s [fslistf $name]
foreach i $s {
fremoves $i $sname
}
return 1
} else {
return 0
}
}
#
# fscreated - create a demon facet in a frameset
# requires that name(sname,facets) exists and name() is not locked
# modifies name(sname,facets), name(sname,dname), associated frames
# calls fcreated, fslistf
#
proc fscreated {name sname dname} {
if {[fcreated $name $sname $dname]} {
set s [fslistf $name]
foreach i $s {
fcreated $i $sname $dname
}
return 1
} else {
return 0
}
}
#
# fsremoved - remove a demon facet from a frameset
# requires that name(sname,dname) exists and name() is not locked
# modifies name(name,slots), name(sname,dname), associated frames
# calls fremoved, fslistf
#
proc sremoved {name sname dname} {
if {[fremoved $name $sname $dname]} {
set s [fslistf $name]
foreach i $s {
fremoved $i $sname $dname
}
return 1
} else {
return 0
}
}
#
# fscreatem - create a method facet in a frameset
# requires that name(sname,facets) exists and name() is not locked
# modifies name(sname,facets), name(sname,method), associated frames
# calls fcreatem, fslistf
#
proc fscreatem {name sname} {
if {[fcreatem $name $sname]} {
set s [fslistf $name]
foreach i $s {
fcreatem $i $sname
}
return 1
} else {
return 0
}
}
#
# fsremovem - remove a method facet from a frameset
# requires that name(sname,facets) exists and name() is not locked
# modifies name(sname,facets), name(sname,method), associated frames
# calls fremovem, fslistf
#
proc fsremovem {name sname} {
if {[fremovem $name $sname]} {
set s [fslistf $name]
foreach i $s {
fremovem $i $sname
}
return 1
} else {
return 0
}
}
#
# fscreater - create a reference facet in a frameset
# requires that name(sname,facets) exists and name() is not locked
# modifies name(sname,facets), name(sname,ref), associated frames
# calls fcreater, fslistf
#
proc fscreater {name sname} {
if {[fcreater $name $sname]} {
set s [fslistf $name]
foreach i $s {
fcreater $i $sname
}
return 1
} else {
return 0
}
}
#
# fsremover - remove a reference facet from a frameset
# requires that name(sname,facets) exists and name() is not locked
# modifies name(sname,facets), name(sname,ref), associated frames
# calls fremover, fslistf
#
proc fsremover {name sname} {
if {[fremover $name $sname]} {
set s [fslistf $name]
foreach i $s {
fremover $i $sname
}
return 1
} else {
return 0
}
}
#
# fscreatev - create a value facet in a frameset
# requires that name(sname,facets) exists and name() is not locked
# modifies name(sname,facets), name(sname,value), associated frames
# calls fcreatev, fslistf
#
proc fscreatev {name sname} {
if {[fcreatev $name $sname]} {
set s [fslistf $name]
foreach i $s {
fcreatev $i $sname
}
return 1
} else {
return 0
}
}
#
# fsremovev - remove a value facet from of a frameset
# requires that name(sname,facets) exists and name() is not locked
# modifies name(sname,facets), name(sname,value), associated frames
# calls fremovev, fslistf
#
proc fsremovev {name sname} {
if {[fremovev $name $sname]} {
set s [fslistf $name]
foreach i $s {
fremovev $i $sname
}
return 1
} else {
return 0
}
}
#
# fsputr - put a value in reference facet in a frameset
# requires that name(sname,facets) exists and name() is not locked
# modifies the name(sname,ref)
# calls fexistr, fputr, fslistf
#
proc fsputr {name sname fname} {
if {[fexistr $name $sname] && [fgets $name] != "locked" && [fgets $name] != "inactive"} {
fputr $name $sname $fname
set s [fslistf $name]
foreach i $s {
fputr $i $sname $fname
}
return 1
} else {
return 0
}
}
#
# fsgetr - get a value from a reference facet in a frameset
# requires that name(sname,ref) exists
# modifies nothing
# calls fexistr, fgetr
#
proc fsgetr {name sname} {
if {[fexistr $name $sname]} {
set r [fgetr $name $sname]
return $r
} else {
return ""
}
}
#
# fsmemberf - get list of framesets in which a frame is a member
# requires that the frame exists
# modifies nothing
# calls fexistf, flistf, member
#
proc fsmemberf {name} {
if {[fexistf $name]} {
foreach i [flistf] {
if {[uplevel \#0 "info exists $i\($i,set)"]} {
if {[member [uplevel \#0 "fslistf $i"] $name]} {
lappend mlist $i
}
}
}
return $mlist
} else {
return {}
}
}
#
# fsendf - send a frame
# requires open socket, fname() exists and is not locked
# modifies location of fname()
# calls fexistf, fgets, fpack
#
proc fsendf {fname sid} {
if {[fexistf $fname] && [fgets $fname] != "locked" && [fgets $fname] != "inactive"} {
set plist [fpack $fname]
puts $sid "funpack $fname {$plist}"
flush $sid
puts $sid "fexecx $fname"
flush $sid
return 1
} else {
return 0
}
}
#
# fsendfs - send a frameset
# requires open socket, fname() exists and is not locked
# modifies location of frames in frameset
# calls fexistf, fgets, fslistf, fpack
#
proc fsendfs {fname sid} {
if {[fexistf $fname] && [fgets $fname] != "locked" && [fgets $fname] != "inactive"} {
set s [fslistf $fname]
set plist [fpack $fname]
puts $sid "funpack $fname {$plist}"
flush $sid
foreach i $s {
fsendf $i $sid
}
puts $sid "fexecx $fname"
flush $sid
return 1
} else {
return 0
}
}
#
# ffetchf - fetch a frame
# requires open socket, fname() exists and is not locked
# modifies location of fname()
# calls frpc, funpack
#
proc ffetchf {fname sid} {
set exist [frpc "fexistf $fname" $sid]
set status [frpc "fgets $fname" $sid]
if {$exist && $status != "locked" && $status != "inactive"} {
set plist [frpc "fpack $fname" $sid]
funpack $fname $plist
fexecx $fname
return 1
} else {
return 0
}
}
#
# ffetchfs - fetch a frameset
# requires open socket, fname() exists and is not locked
# modifies location of frames in frameset
# calls frpc, funpack
#
proc ffetchfs {fname sid} {
set exist [frpc "fexistf $fname" $sid]
set status [frpc "fgets $fname" $sid]
if {$exist && $status != "locked" && $status != "inactive"} {
set s [frpc "fslistf $fname" $sid]
set plist [frpc "fpack $fname" $sid]
funpack $fname $plist
foreach i $s {
set plist [frpc "fpack $i" $sid]
funpack $i $plist
fexecx $i
}
fexecx $fname
return 1
} else {
return 0
}
}
#
# fsleepf - put a frame to sleep
# requires fname() exists and is not locked or asleep
# modifies frame state
# calls fexistf, fgets, fputs
#
proc fsleepf {fname} {
if {[fexistf $fname]} {
if {[fgets $fname] == "active"} {
uplevel \#0 "set $fname\($fname,state) asleep"
return 1
} else {
return 0
}
} else {
return 0
}
}
#
# fsleepfs - put a frameset to sleep
# requires fname() exists and is not locked or asleep
# modifies state of frames in frameset
# calls fexistf, fgets, fsleepf, fslistf
#
proc fsleepfs {fname} {
if {[fexistf $fname]} {
if {[fgets $fname] == "active"} {
fsleepf $fname
set s [fslistf $fname]
foreach i $s {
fsleepf $i
}
return 1
} else {
return 0
}
} else {
return 0
}
}
#
# fwakef - wake up a frame
# requires fname() exists and is asleep but not locked
# modifies frame state
# calls fexistf, fgets, fputs
#
proc fwakef {fname} {
if {[fexistf $fname]} {
if {[fgets $fname] == "asleep"} {
uplevel \#0 "set $fname\($fname,state) active"
return 1
} else {
return 0
}
} else {
return 0
}
}
#
# fwakefs - wake up a frameset
# requires fname() exists and is asleep but not locked
# modifies state of frames in frameset
# calls fexistf, fgets, fwakef
#
proc fwakefs {fname} {
if {[fexistf $fname]} {
if {[fgets $fname] == "asleep"} {
fwakef $fname
set s [fslistf $fname]
foreach i $s {
fwakef $i
}
return 1
} else {
return 0
}
} else {
return 0
}
}
#
# flockf - lock a frame
# requires fname() exists and is not locked
# modifies frame state
# calls fexistf, fgets, fputs
#
proc flockf {fname} {
if {[fexistf $fname]} {
if {[fgets $fname] == "active"} {
uplevel \#0 "set $fname\($fname,state) locked"
return 1
}
if {[fgets $fname] == "asleep"} {
uplevel \#0 "set $fname\($fname,state) inactive"
return 1
}
return 0
} else {
return 0
}
}
#
# flockfs - lock a frameset
# requires fname() exists and is not locked
# modifies state of all frames in frameset
# calls fexistf, fslistf, flockf
#
proc flockfs {fname} {
if {[fexistf $fname]} {
if {[fgets $fname] == "active" || [fgets $fname] == "asleep"} {
flockf $fname
set s [fslistf $fname]
foreach i $s {
flockf $i
}
return 1
} else {
return 0
}
} else {
return 0
}
}
#
# funlockf - unlock a frame
# requires fname() exists and is locked
# modifies frame state
# calls fexistf, fgets, fputs
#
proc funlockf {fname} {
if {[fexistf $fname]} {
if {[fgets $fname] == "locked"} {
uplevel \#0 "set $fname\($fname,state) active"
return 1
}
if {[fgets $fname] == "inactive"} {
uplevel \#0 "set $fname\($fname,state) asleep"
return 1
}
return 0
} else {
return 0
}
}
#
# funlockfs - unlock a frameset
# requires fname() exists and is locked
# modifies state of all frames in frameset
# calls fexistf, funlockf, fslistf
#
proc funlockfs {fname} {
if {[fexistf $fname]} {
if {[fgets $fname] == "locked" || [fgets $fname] == "inactive"} {
funlockf $fname
set s [fslistf $fname]
foreach i $s {
funlockf $i
}
return 1
} else {
return 0
}
} else {
return 0
}
}
#
# fdo - do something
# requires application or open socket
# modifies nothing
#
proc fdo {msg sid} {
puts $sid "fdos {$msg}"
flush $sid
}
#
# fdos - do something service
# requires nothing
# modifies nothing
#
proc fdos {msg} {
uplevel \#0 "eval $msg"
}
#
# frpc - remote procedure call
# requires application or open socket
# modifies nothing
#
proc frpc {msg sid} {
puts $sid "frpcs {$msg}"
flush $sid
gets $sid result
return $result
}
#
# frpcs - remote procedure call service
# requires open socket to client
# modifies nothing
#
proc frpcs {msg cid} {
set result [uplevel \#0 "eval $msg"]
if {[llength $result] > 1} {
puts $cid "$result"
} else {
puts $cid $result
}
flush $cid
}
#
# fpack - pack a frame
# requires fname() exists
# modifies fname() and fframes
# calls fremovef
#
proc fpack {fname} {
set plist {}
foreach i [uplevel \#0 "array names $fname"] {
set avalue [uplevel \#0 "set $fname\($i)"]
lappend plist "$fname\($i) {$avalue}"
}
fremovef $fname
return $plist
}
#
# funpack - unpack a frame
# requires nothing
# modifies ffframes
# calls fexistf, fremovef, fcreatef
#
proc funpack {fname plist} {
funlockf $fname
fremovef $fname
fcreatef $fname
for {set i 0} {$i < [llength $plist]} {incr i} {
uplevel \#0 "set [lindex $plist $i]"
}
}
#
# fexecx - execute a frame start method
# requires fname() exists and is not asleep
# modifies nothing
# calls fexistf, fgets
#
proc fexecx {fname} {
if {[fexistf $fname] && [fgets $fname] != "asleep" && [fgets $fname] != "inactive"} {
uplevel \#0 "eval $$fname\($fname,start)"
return 1
} else {
return 0
}
}
#
# fgetx - get the start code of a frame
# requires that fname() exists
# modifies nothing
# calls fexistf
#
proc fgetx {fname} {
if {[fexistf $fname]} {
return [uplevel \#0 "set $fname\($fname,start)"]
} else {
return ""
}
}
#
# fputx - assign start code to a frame
# requires that fname() exists and is not locked
# modifies the frame start code
# calls fexistf, fgets
#
proc fputx {fname args} {
if {[fexistf $fname] && [fgets $fname] != "locked" && [fgets $fname] != "inactive"} {
uplevel \#0 "set $fname\($fname,start) $args"
return 1
} else {
return 0
}
}
#
# fgets - get the state of a frame
# requires that fname() exists
# modifies nothing
# calls fexistf
#
proc fgets {fname} {
if {[fexistf $fname]} {
return [uplevel \#0 "set $fname\($fname,state)"]
} else {
return ""
}
}
#
# fputs - assign a state to a frame
# requires that fname() exists and is not locked
# modifies the frame state
# calls fexistf, fgets
#
proc fputs {fname state} {
if {[fexistf $fname] && [fgets $fname] != "locked" && [fgets $fname] != "inactive"} {
uplevel \#0 "set $fname\($fname,state) $state"
return 1
} else {
return 0
}
}
----
'''framesets.tcl'''
######################################################################
#
# program name: framesets.tcl 1.1
# programmer: Cris A. Fugate
# date written: September 2, 1998 (wrote frames.tcl)
# changed: September 28, 1998 (added floadf and fstoref to frames)
# changed: November 25, 1998 (wrote framesets.tcl)
# changed: February 10, 1999 (added fupdatef to frames,
# added fsgetr, fsputr and fsmemberf to framesets)
# changed: April 16, 1999 (merged frames and framesets)
# changed: November 8, 1999 (added args to fputv,fputm,fputd)
#
# description: This program is an extension to the tcl scripting
# language. It provides a frame and frameset
# mechanism which can be used to dynamically organize
# and perform operations on values and procedures.
#
# Copyright (c) 1999 Cris A. Fugate
#
# Permission is hereby granted, free of charge, to any person obtaining
# a copy of this software and associated documentation files (the
# "Software"), to deal in the Software without restriction, including
# without limitation the rights to use, copy, modify, merge, publish,
# distribute, sublicense, and/or sell copies of the Software, and to
# permit persons to whom the Software is furnished to do so, subject to
# the following conditions:
#
# The above copyright notice and this permission notice shall be included
# in all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
# OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
# THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR
# OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE,
# ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
# OTHER DEALINGS IN THE SOFTWARE.
#
######################################################################
#
# Variables
#
# aname array name
# args list of arguments
# avalue array value
# cmp comparison flag
# created create flag
# elema element of a list
# dname demon type
# elcnt count of list elements
# executed execute flag
# fframes list of frames
# fh file handle
# fhbuf file handle buffer
# flist list of references in a frame
# fname frame name
# fname1 frame name
# fname2 frame name
# found exist flag
# ftype facet type
# i loop variable
# lista first list to be processed
# listb second list to be processed
# listx first temporary list
# listy second temporary list
# mlist list of framesets of which a frame
# is a member
# name frameset name
# plist list of frames in a reference chain
# pname procedure name
# put put flag
# r reference
# removed remove flag
# s list of frames in the frameset
# sname slot name
# sname2 slot name
# x variable used in place of expression
# y variable used in place of expression
# <fname>(<ename>) used in operations involving many elements
# <fname>(<fname>,set) frames in a frameset
# <fname>(<fname>,slots) slots in a frame
# <fname>(<sname>,<ftype>) demon facet
# <fname>(<sname>,facets) facets in a slot
# <fname>(<sname>,ifcreatem) ifcreatem demon
# <fname>(<sname>,ifcreater) ifcreater demon
# <fname>(<sname>,ifcreatev) ifcreatev demon
# <fname>(<sname>,ifexecm) ifexecm demon
# <fname>(<sname>,ifexistm) ifexistm demon
# <fname>(<sname>,ifexistr) ifexistr demon
# <fname>(<sname>,ifexistv) ifexistv demon
# <fname>(<sname>,ifgetm) ifgetm demon
# <fname>(<sname>,ifgetr) ifgetr demon
# <fname>(<sname>,ifgetv) ifgetv demon
# <fname>(<sname>,ifputm) ifputm demon
# <fname>(<sname>,ifputr) ifputr demon
# <fname>(<sname>,ifputv) ifputv demon
# <fname>(<sname>,ifref) ifref demon
# <fname>(<sname>,ifremovem) ifremovem demon
# <fname>(<sname>,ifremover) ifremover demon
# <fname>(<sname>,ifremovev) ifremovev demon
# <fname>(<sname>,method) method facet
# <fname>(<sname>,ref) reference facet
# <fname>(<sname>,value) value facet
#
######################################################################
#
# Procedures
#
# compress order and remove duplicates from a list
# equivalence determine is two lists are equivalent
# fcomparef compare slots of two frames
# fcompares compare two slots
# fcopyf make a copy of a frame
# fcopys make a copy of a slot in another frame
# fcreated create a demon facet
# fcreatef create a frame
# fcreatefs create a frameset
# fcreatem create a method facet
# fcreater create a reference facet
# fcreates create a slot
# fcreatev create a value facet
# fexecd directly execution a demon
# fexecm execute a method
# fexistd determine if a demon facet exists
# fexistf determine if a frame exists
# fexistm determine if a method facet exists
# fexistr determine if a reference facet exists
# fexistrx (same as fexistr without a demon call)
# fexists determine if a slot exists
# fexistv determine if a value facet exists
# ffilterf filter a frame based on another frame
# fgetd get the value of a demon facet
# fgetm get the value of a method facet
# fgetr get the value of a reference facet
# fgetv get the value of a value facet
# flistf get a list of existing frames
# flistr get a list of references in a frame
# flists get a list of slots for a frame
# flistt get a list of facet types for a slot
# floadf load a frame into memory
# floadfs load a frameset into memory
# fmergef merge slots of a frame into another frame
# fpathr get a list of frames in a reference chain
# fputd put a value into a demon facet
# fputm put a value into a method facet
# fputr put a value into a reference facet
# fputv put a value into a value facet
# fremoved destroy a demon facet
# fremovef destroy a frame
# fremovefs destroy a frameset
# fremovem destroy a method facet
# fremover destroy a reference facet
# fremoves destroy a slot
# fremovev destroy a value facet
# fscreated create a demon facet in a frameset
# fscreatem create a method facet in a frameset
# fscreater create a reference facet in a frameset
# fscreates create a slot in a frameset
# fscreatev create a value facet in a frameset
# fsexcludef exclude a frame from a frameset
# fsgetr get a value from a reference facet
# in a frameset
# fsincludef include a frame in a frameset
# fslistf get a list of frames in a frameset
# fsmemberf get list of framesets in which
# a frame is a member
# fsputr put a value in a reference facet
# in a frameset
# fsremoved remove a demon facet from a frameset
# fsremovem remove a method facet from a frameset
# fsremover remove a reference facet from a frameset
# fsremoves remove a slot from a frameset
# fsremovev remove a value facet from a frameset
# fstoref store a frame on disk
# fstorefs store a frameset on disk
# fupdatef synchronize a frame based on another frame
# member determine if a value is a member of a list
# remove remove a value from a list
#
#
# compress - order and remove duplicates from a list
# modifies lista
#
proc compress lista {
upvar $lista listx
set listx [lsort $listx]
set listy [lindex $listx 0]
set elema $listy
foreach i $listx {
if {$elema != $i} {
lappend listy $i
}
set elema $i
}
set listx $listy
}
#
# equivalence - determine if two lists are equivalent
#
proc equivalence {lista listb} {
set listx $lista
set listy $listb
compress listx
compress listy
if {$listx == $listy} {
return 1
} else {
return 0
}
}
#
# member - determine if an element is a member of a list
#
proc member {lista elema} {
set elcnt 0
foreach i $lista {
if {$elema == $i} {
incr elcnt
}
}
return $elcnt
}
#
# remove - remove all occurances of an element from a list
# modifies lista
#
proc remove {lista elema} {
upvar $lista listx
set listy {}
foreach i $listx {
if {$elema != $i} {
lappend listy $i
}
}
set listx $listy
}
# initialize frames
set fframes {}
#
# fexistf - determine if a frame exists
#
proc fexistf fname {
global fframes
return [member $fframes $fname]
}
#
# fcreatef - create a frame
# requires that fname() does not exist
# modifies fframes, fname(fname,slots)
#
proc fcreatef fname {
global fframes
if {![fexistf $fname]} {
lappend fframes $fname
uplevel \#0 "set $fname\($fname,slots) {}"
return 1
} else {
return 0
}
}
#
# fremovef - remove a frame
# requires that fname() exists
# modifies fframes,fname()
#
proc fremovef fname {
global fframes
if {[fexistf $fname]} {
foreach i [uplevel \#0 "array names $fname"] {
uplevel \#0 "unset $fname\($i)"
}
remove fframes $fname
return 1
} else {
return 0
}
}
#
# flistf - return list of frames
#
proc flistf {} {
global fframes
return $fframes
}
#
# fcopyf - create a new frame based on another frame
# requires that frame1() exists
# modifies fframes,fname2()
#
proc fcopyf {fname1 fname2} {
global fframes
if {[fexistf $fname1]} {
fremovef $fname2
lappend fframes $fname2
foreach i [uplevel \#0 "array names $fname1"] {
uplevel \#0 "set $fname2\($i) $$fname1\($i)"
}
return 1
} else {
return 0
}
}
#
# fcomparef - determine if two frames are equivalent
# requires that fname1() and fname2() exist
#
proc fcomparef {fname1 fname2} {
if {[fexistf $fname1] && [fexistf $fname2]} {
set x [uplevel \#0 "set $fname1\($fname1,slots)"]
set y [uplevel \#0 "set $fname2\($fname2,slots)"]
if {[equivalence $x $y]} {
return 1
} else {
return 0
}
} else {
return 0
}
}
#
# fmergef - merge slots of one frame into another other
# requires that fname1() and fname2() exist
# modifies fname2()
#
proc fmergef {fname1 fname2} {
if {[fexistf $fname1] && [fexistf $fname2]} {
set y [uplevel \#0 "set $fname2\($fname2,slots)"]
foreach i [uplevel \#0 "array names $fname1"] {
if {$i != "$fname1,set" && $i != "$fname1,slots"} {
scan $i "%\[^,]" sname
if {![member $y $sname]} {
uplevel \#0 "set $fname2\($i) $$fname1\($i)"
uplevel \#0 "lappend $fname2\($fname2,slots) $sname"
}
}
}
return 1
} else {
return 0
}
}
#
# floadf - load a frame into memory
# requires that fname() exists on disk, but not in memory
#
proc floadf fname {
global fframes
if {[file exists $fname] && ![fexistf $fname]} {
lappend fframes $fname
set fh [open $fname r]
while {![eof $fh]} {
gets $fh fhbuf
set aname [lindex $fhbuf 0]
set avalue [remove fhbuf $aname]
uplevel \#0 "set $fname\($aname) {$avalue}"
}
close $fh
return 1
} else {
return 0
}
}
#
# fstoref - store a frame on disk
# requires that fname() exists
#
proc fstoref fname {
if {[fexistf $fname]} {
set fh [open $fname w]
foreach i [uplevel \#0 "array names $fname"] {
set avalue [uplevel \#0 "set $fname\($i)"]
puts $fh "$i $avalue"
}
close $fh
return 1
} else {
return 0
}
}
#
# fupdatef - update structure of a frame from another frame
# requires that both frames exist
# modifies frame2()
#
proc fupdatef {fname1 fname2} {
if {[fexistf $fname1] && [fexistf $fname2]} {
uplevel \#0 "set $fname2\($fname2,slots) $$fname1\($fname1,slots)"
foreach i [uplevel \#0 "array names $fname2"] {
if {$i != "$fname2,set" && $i != "$fname2,slots"} {
if {![uplevel \#0 "info exists $fname1\($i)"]} {
uplevel \#0 "unset $fname2\($i)"
}
}
}
foreach i [uplevel \#0 "array names $fname1"] {
if {$i != "$fname1,set" && $i != "$fname1,slots"} {
if {![uplevel \#0 "info exists $fname2\($i)"]} {
uplevel \#0 "set $fname2\($i) $$fname1\($i)"
}
}
}
return 1
} else {
return 0
}
}
#
# ffilterf - filter slots of a frame based on another frame
# requires that both frames exist
# modifies frame2()
#
proc ffilterf {fname1 fname2} {
if {[fexistf $fname1] && [fexistf $fname2]} {
foreach i [uplevel \#0 "array names $fname2"] {
if {$i != "$fname2,set" && $i != "$fname2,slots"} {
if {![uplevel \#0 "info exists $fname1\($i)"]} {
uplevel \#0 "unset $fname2\($i)"
}
}
}
return 1
} else {
return 0
}
}
#
# fexists - determine if a slot exists
# requires that fname() exists
#
proc fexists {fname sname} {
if {[fexistf $fname]} {
if {[uplevel \#0 "member $$fname\($fname,slots) $sname"]} {
return 1
} else {
return 0
}
} else {
return 0
}
}
#
# fcreates - create a slot
# requires that fname() exists
# modifies fname(fname,slot),fname(sname,facets)
#
proc fcreates {fname sname} {
if {[fexistf $fname]} {
if {[uplevel \#0 "member $$fname\($fname,slots) $sname"] == 0} {
uplevel \#0 "lappend $fname\($fname,slots) $sname"
uplevel \#0 "set $fname\($sname,facets) {}"
return 1
} else {
return 0
}
} else {
return 0
}
}
#
# fremoves - remove a slot
# requires that fname(sname,facets) exists
# modifies fname(fname,slots),fname(sname,)
#
proc fremoves {fname sname} {
if {[fexists $fname $sname]} {
foreach i [uplevel \#0 "array names $fname"] {
scan $i "%\[^,]" sname2
if {$sname == $sname2} {
uplevel \#0 "unset $fname\($i)"
}
}
uplevel \#0 "remove $fname\($fname,slots) $sname"
return 1
} else {
return 0
}
}
#
# flists - list slots of a frame
# requires that fname() exists
#
proc flists fname {
if {[fexistf $fname]} {
return [uplevel \#0 "set $fname\($fname,slots)"]
} else {
return {}
}
}
#
# fcopys - copy a slot into another frame
# requires that fname1() and fname2() exist
# modifies fname2(sname,)
#
proc fcopys {fname1 sname fname2} {
if {[fexists $fname1 $sname] && [fexistf $fname2]} {
if {[uplevel \#0 "member $$fname2\($fname2,slots) $sname"] == 0} {
uplevel \#0 "lappend $fname2\($fname2,slots) $sname"
}
foreach i [uplevel \#0 "array names $fname1"] {
scan $i "%\[^,]" sname2
if {$sname == $sname2} {
uplevel \#0 "set $fname2\($i) $$fname1\($i)"
}
}
return 1
} else {
return 0
}
}
#
# fcompares - compare a slot in two frames
# requires that fname1(sname,facets) and fname2(sname,facets) exist
#
proc fcompares {fname1 sname fname2} {
set cmp 1
if {[fexists $fname1 $sname] && [fexists $fname2 $sname]} {
set x [uplevel \#0 "set $fname1\($sname,facets)"]
set y [uplevel \#0 "set $fname2\($sname,facets)"]
if {[equivalence $x $y]} {
foreach i [uplevel \#0 "array names $fname1"] {
scan $i "%\[^,]" sname2
if {$sname == $sname2} {
set x [uplevel \#0 "set $fname1\($i)"]
set y [uplevel \#0 "set $fname2\($i)"]
if {$x != $y} {
set cmp 0
}
}
}
return $cmp
} else {
return 0
}
} else {
return 0
}
}
#
# flistt - list of facet types in a slot
# requires that fname(sname,facets) exists
#
proc flistt {fname sname} {
if {[fexists $fname $sname]} {
return [uplevel \#0 "set $fname\($sname,facets)"]
} else {
return {}
}
}
#
# fexistrx - determine if a reference facet exists (internal)
# requires that fname(sname,facets) exists
#
proc fexistrx {fname sname} {
if {[fexists $fname $sname]} {
if {[uplevel \#0 "member $$fname\($sname,facets) ref"]} {
return 1
} else {
return 0
}
} else {
return 0
}
}
#
# fexistr - determine if a reference facet exists
# requires that fname(sname,facets) exists
# calls ifexistr demon
#
proc fexistr {fname sname} {
if {[fexistrx $fname $sname]} {
if {[uplevel \#0 "member $$fname\($sname,facets) ifexistr"]} {
uplevel \#0 "eval $$fname\($sname,ifexistr)"
}
return 1
} else {
return 0
}
}
#
# fcreater - create a reference facet
# requires that fname(sname,facets) exists
# modifies fname(sname,facets),fname(sname,ref)
# calls ifcreater demon
#
proc fcreater {fname sname} {
if {[fexists $fname $sname]} {
if {[uplevel \#0 "member $$fname\($sname,facets) ref"] == 0} {
set x [uplevel \#0 "member $$fname\($sname,facets) method"]
set y [uplevel \#0 "member $$fname\($sname,facets) value"]
if {!($x || $y)} {
uplevel \#0 "lappend $fname\($sname,facets) ref"
uplevel \#0 "set $fname\($sname,ref) {}"
if {[uplevel \#0 "member $$fname\($sname,facets) ifcreater"]} {
uplevel \#0 "eval $$fname\($sname,ifcreater)"
}
return 1
} else {
return 0
}
} else {
return 0
}
} else {
return 0
}
}
#
# fremover - remove a reference facet
# requires that fname(sname,ref) exists
# modifies fname(sname,facets),fname(sname,ref)
# calls ifremover demon
#
proc fremover {fname sname} {
if {[fexistrx $fname $sname]} {
if {[uplevel \#0 "member $$fname\($sname,facets) ifremover"]} {
uplevel \#0 "eval $$fname\($sname,ifremover)"
}
uplevel \#0 "unset $fname\($sname,ref)"
uplevel \#0 "remove $fname\($sname,facets) ref"
return 1
} else {
return 0
}
}
#
# fgetr - get a value from a reference facet
# requires that fname(sname,ref) exists
# calls ifgetr demon
#
proc fgetr {fname sname} {
if {[fexistrx $fname $sname]} {
if {[uplevel \#0 "member $$fname\($sname,facets) ifgetr"]} {
uplevel \#0 "eval $$fname\($sname,ifgetr)"
}
return [uplevel \#0 "set $fname\($sname,ref)"]
} else {
return {}
}
}
#
# fputr - put a value in a reference facet
# requires that fname(sname,ref) exists
# modifies fname(sname,ref)
# calls ifputr demon
#
proc fputr {fname1 sname fname2} {
if {[fexistrx $fname1 $sname]} {
uplevel \#0 "set $fname1\($sname,ref) $fname2"
if {[uplevel \#0 "member $$fname1\($sname,facets) ifputr"]} {
uplevel \#0 "eval $$fname1\($sname,ifputr)"
}
return 1
} else {
return 0
}
}
#
# flistr - list of references in a frame
# requires that fname() exists
#
proc flistr fname {
set flist {}
if {[fexistf $fname]} {
foreach i [uplevel \#0 "array names $fname"] {
scan $i "%\[^,],%s" sname ftype
if {$ftype == "ref"} {
lappend flist $sname
}
}
}
return $flist
}
#
# fpathr - return chain of references
# requires that fname(sname,facets) exists
#
proc fpathr {fname sname {plist {}}} {
if {[fexists $fname $sname]} {
if {[member $plist $fname] == 0} {
lappend plist $fname
if {[uplevel \#0 "member $$fname\($sname,facets) ref"]} {
set fname2 [uplevel \#0 "set $fname\($sname,ref)"]
fpathr $fname2 $sname $plist
} else {
return $plist
}
} else {
return $plist
}
} else {
return $plist
}
}
#
# fexistm - determine if a method facet exists
# requires that fname(sname,facets) exists
# calls ifref and ifexistm demons
#
proc fexistm {fname sname} {
set found 0
if {[fexists $fname $sname]} {
if {[fexistrx $fname $sname]} {
set fname2 [uplevel \#0 "set $fname\($sname,ref)"]
if {[uplevel \#0 "member $$fname\($sname,facets) ifref"]} {
uplevel \#0 "eval $$fname\($sname,ifref)"
}
set found [fexistm $fname2 $sname]
}
if {[uplevel \#0 "member $$fname\($sname,facets) method"]} {
if {[uplevel \#0 "member $$fname\($sname,facets) ifexistm"]} {
uplevel \#0 "eval $$fname\($sname,ifexistm)"
}
set found 1
}
}
return $found
}
#
# fcreatem - create a method facet
# requires that fname(sname,facets) exists
# modifies fname(sname,facets),fname(sname,method) where fname is
# the original or referenced frame
# calls ifref and ifcreatem demons
#
proc fcreatem {fname sname} {
set created 0
if {[fexists $fname $sname]} {
if {[uplevel \#0 "member $$fname\($sname,facets) method"] ||
[uplevel \#0 "member $$fname\($sname,facets) value"]} {
set created 0
} else {
if {[uplevel \#0 "member $$fname\($sname,facets) ref"]} {
set fname2 [uplevel \#0 "set $fname\($sname,ref)"]
if {[uplevel \#0 "member $$fname\($sname,facets) ifref"]} {
uplevel \#0 "eval $$fname\($sname,ifref)"
}
set created [fcreatem $fname2 $sname]
} else {
uplevel \#0 "set $fname\($sname,method) {}"
uplevel \#0 "lappend $fname\($sname,facets) method"
if {[uplevel \#0 "member $$fname\($sname,facets) ifcreatem"]} {
uplevel \#0 "eval $$fname\($sname,ifcreatem)"
}
set created 1
}
}
}
return $created
}
#
# fremovem - remove a method facet
# requires sthat fname(sname,facets) exists
# modifies fname(sname,facets),fname(sname,method) where fname is
# the original or referenced frame
# calls ifref and ifremovem demons
#
proc fremovem {fname sname} {
set removed 0
if {[fexists $fname $sname]} {
if {[uplevel \#0 "member $$fname\($sname,facets) ref"]} {
set fname2 [uplevel \#0 "set $fname\($sname,ref)"]
if {[uplevel \#0 "member $$fname\($sname,facets) ifref"]} {
uplevel \#0 "eval $$fname\($sname,ifref)"
}
set removed [fremovem $fname2 $sname]
} else {
if {[uplevel \#0 "member $$fname\($sname,facets) method"]} {
if {[uplevel \#0 "member $$fname\($sname,facets) ifremovem"]} {
uplevel \#0 "eval $$fname\($sname,ifremovem)"
}
uplevel \#0 "unset $fname\($sname,method)"
uplevel \#0 "remove $fname\($sname,facets) method"
set removed 1
}
}
}
return $removed
}
#
# fexecm - execute a method
# requires that fname(sname,facets) exists
# calls ifref and ifexecm demons
#
proc fexecm {fname sname} {
set executed 0
if {[fexists $fname $sname]} {
if {[uplevel \#0 "member $$fname\($sname,facets) ref"]} {
set fname2 [uplevel \#0 "set $fname\($sname,ref)"]
if {[uplevel \#0 "member $fname\($sname,facets) ifref"]} {
uplevel \#0 "eval $$fname\($sname,ifref)"
}
set executed [fexecm $fname2 $sname]
} else {
if {[uplevel \#0 "member $$fname\($sname,facets) method"]} {
if {[uplevel \#0 "member $$fname\($sname,facets) ifexecm"]} {
uplevel \#0 "eval $$fname\($sname,ifexecm)"
}
uplevel \#0 "eval $$fname\($sname,method)"
set executed 1
}
}
}
return $executed
}
#
# fgetm - get a value from a method facet
# requires that fname(sname,facets) exists
# calls ifref and ifgetm demons
#
proc fgetm {fname sname} {
set pname {}
if {[fexists $fname $sname]} {
if {[uplevel \#0 "member $$fname\($sname,facets) ref"]} {
set fname2 [uplevel \#0 "set $fname\($sname,ref)"]
if {[uplevel \#0 "member $$fname\($sname,facets) ifref"]} {
uplevel \#0 "eval $$fname\($sname,ifref)"
}
set pname [fgetm $fname2 $sname]
} else {
if {[uplevel \#0 "member $$fname\($sname,facets) method"]} {
if {[uplevel \#0 "member $$fname\($sname,facets) ifgetm"]} {
uplevel \#0 "eval $$fname\($sname,ifgetm)"
}
set pname [uplevel \#0 "set $fname\($sname,method)"]
}
}
}
return $pname
}
#
# fputm - put a value in a method facet
# requires that fname(sname,facets) exists
# modifies fname(sname,method) where fname is the original or
# referenced frame
# calls ifref and ifputm demons
#
proc fputm {fname sname args} {
set put 0
if {[fexists $fname $sname]} {
if {[uplevel \#0 "member $$fname\($sname,facets) ref"]} {
set fname2 [uplevel \#0 "set $fname\($sname,ref)"]
if {[uplevel \#0 "member $$fname\($sname,facets) ifref"]} {
uplevel \#0 "eval $$fname\($sname,ifref)"
}
set put [fputm $fname2 $sname $args]
} else {
if {[uplevel \#0 "member $$fname\($sname,facets) method"]} {
if {[uplevel \#0 "member $$fname\($sname,facets) ifputm"]} {
uplevel \#0 "eval $$fname\($sname,ifputm)"
}
uplevel \#0 "set $fname\($sname,method) $args"
set put 1
}
}
}
return $put
}
#
# fexistv - determine if a value facet exists
# requires that fname(sname,facets) exists
# calls ifref and ifexistv demons
#
proc fexistv {fname sname} {
set found 0
if {[fexists $fname $sname]} {
if {[fexistrx $fname $sname]} {
set fname2 [uplevel \#0 "set $fname\($sname,ref)"]
if {[uplevel \#0 "member $$fname\($sname,facets) ifref"]} {
uplevel \#0 "eval $$fname\($sname,ifref)"
}
set found [fexistv $fname2 $sname]
}
if {[uplevel \#0 "member $$fname\($sname,facets) value"]} {
if {[uplevel \#0 "member $$fname\($sname,facets) ifexistv"]} {
uplevel \#0 "eval $$fname\($sname,ifexistv)"
}
set found 1
}
}
return $found
}
#
# fcreatev - create a value facet
# requires that fname(sname,facets) exists
# modifies fname(sname,facets),fname(sname,value) where fname is
# the original or referenced frame
# calls ifref and ifcreatev demons
#
proc fcreatev {fname sname} {
set created 0
if {[fexists $fname $sname]} {
if {[uplevel \#0 "member $$fname\($sname,facets) method"] ||
[uplevel \#0 "member $$fname\($sname,facets) value"]} {
set created 0
} else {
if {[uplevel \#0 "member $$fname\($sname,facets) ref"]} {
set fname2 [uplevel \#0 "set $fname\($sname,ref)"]
if {[uplevel \#0 "member $$fname\($sname,facets) ifref"]} {
uplevel \#0 "eval $$fname\($sname,ifref)"
}
set created [fcreatev $fname2 $sname]
} else {
uplevel \#0 "set $fname\($sname,value) {}"
uplevel \#0 "lappend $fname\($sname,facets) value"
if {[uplevel \#0 "member $$fname\($sname,facets) ifcreatev"]} {
uplevel \#0 "eval $$fname\($sname,ifcreatev)"
}
set created 1
}
}
}
return $created
}
#
# fremovev - remove a value facet
# requires that fname(sname,facets) exists
# modifies fname(sname,facets),fname(sname,value) where fname is
# the original or referenced frame
# calls ifref and ifremovev demons
#
proc fremovev {fname sname} {
set removed 0
if {[fexists $fname $sname]} {
if {[uplevel \#0 "member $$fname\($sname,facets) ref"]} {
set fname2 [uplevel \#0 "set $fname\($sname,ref)"]
if {[uplevel \#0 "member $$fname\($sname,facets) ifref"]} {
uplevel \#0 "eval $$fname\($sname,ifref)"
}
set removed [fremovev $fname2 $sname]
} else {
if {[uplevel \#0 "member $$fname\($sname,facets) value"]} {
if {[uplevel \#0 "member $$fname\($sname,facets) ifremovev"]} {
uplevel \#0 "eval $$fname\($sname,ifremovev)"
}
uplevel \#0 "unset $fname\($sname,value)"
uplevel \#0 "remove $fname\($sname,facets) value"
set removed 1
}
}
}
return $removed
}
#
# fgetv - get a value from a value facet
# requires that fname(sname,facets) exists
# calls ifref and ifgetv demons
#
proc fgetv {fname sname} {
set pname {}
if {[fexists $fname $sname]} {
if {[uplevel \#0 "member $$fname\($sname,facets) ref"]} {
set fname2 [uplevel \#0 "set $fname\($sname,ref)"]
if {[uplevel \#0 "member $$fname\($sname,facets) ifref"]} {
uplevel \#0 "eval $$fname\($sname,ifref)"
}
set pname [fgetv $fname2 $sname]
} else {
if {[uplevel \#0 "member $$fname\($sname,facets) value"]} {
if {[uplevel \#0 "member $$fname\($sname,facets) ifgetv"]} {
uplevel \#0 "eval $$fname\($sname,ifgetv)"
}
set pname [uplevel \#0 "set $fname\($sname,value)"]
}
}
}
return $pname
}
#
# fputv - put a value in a value facet
# requires that fname(sname,facets) exists
# modifies fname(sname,value) where fname is the original or
# referenced frame
# calls ifref and ifputv demons
#
proc fputv {fname sname args} {
set put 0
if {[fexists $fname $sname]} {
if {[uplevel \#0 "member $$fname\($sname,facets) ref"]} {
set fname2 [uplevel \#0 "set $fname\($sname,ref)"]
if {[uplevel \#0 "member $$fname\($sname,facets) ifref"]} {
uplevel \#0 "eval $$fname\($sname,ifref)"
}
set put [fputv $fname2 $sname $args]
} else {
if {[uplevel \#0 "member $$fname\($sname,facets) value"]} {
uplevel \#0 "set $fname\($sname,value) $args"
if {[uplevel \#0 "member $$fname\($sname,facets) ifputv"]} {
uplevel \#0 "eval $$fname\($sname,ifputv)"
}
set put 1
}
}
}
return $put
}
#
# fexistd - determine if a demon facet exists
# requires that fname(sname,facets) exists
#
proc fexistd {fname sname dname} {
if {[fexists $fname $sname]} {
if {[uplevel \#0 "member $$fname\($sname,facets) $dname"]} {
return 1
} else {
return 0
}
} else {
return 0
}
}
#
# fcreated - create a demon facet
# requires that fname(sname,facets) exists
# modifies fname(sname,facets),fname(sname,dname)
#
proc fcreated {fname sname dname} {
if {[fexists $fname $sname]} {
if {[uplevel \#0 "member $$fname\($sname,facets) $dname"] == 0} {
uplevel \#0 "set $fname\($sname,$dname) {}"
uplevel \#0 "lappend $fname\($sname,facets) $dname"
return 1
} else {
return 0
}
} else {
return 0
}
}
#
# fremoved - remove a demon facet
# requires that fname(sname,dname) exists
# modifies fname(sname,facets),fname(sname,dname)
#
proc fremoved {fname sname dname} {
if {[fexistd $fname $sname $dname]} {
uplevel \#0 "unset $fname\($sname,$dname)"
uplevel \#0 "remove $fname\($sname,facets) $dname"
return 1
} else {
return 0
}
}
#
# fgetd - get a value from a demon facet
# requires that fname(sname,dname) exists
#
proc fgetd {fname sname dname} {
if {[fexistd $fname $sname $dname]} {
return [uplevel \#0 "set $fname\($sname,$dname)"]
} else {
return {}
}
}
#
# fputd - put a value in a demon facet
# requires that fname(sname,dname) exists
# modifies fname(sname,dname)
#
proc fputd {fname sname dname args} {
if {[fexistd $fname $sname $dname]} {
uplevel \#0 "set $fname\($sname,$dname) $args"
return 1
} else {
return 0
}
}
#
# fexecd - directly execute a demon
# requires that fname(sname,dname) exists
#
proc fexecd {fname sname dname} {
if {[fexistd $fname $sname $dname]} {
uplevel \#0 "eval $$fname\($sname,$dname)"
return 1
} else {
return 0
}
}
#
# fcreatefs - create a frameset
# requires that name() does not exist
# modifies fframes, name(name,set), name(name,slots)
#
proc fcreatefs {name} {
global fframes
if {![fexistf $name]} {
lappend fframes $name
uplevel \#0 "set $name\($name,set) {}"
uplevel \#0 "set $name\($name,slots) {}"
return 1
} else {
return 0
}
}
#
# fremovefs - remove a frameset
# requires that name() exists
# modifies fframes, name()
#
proc fremovefs {name} {
if {[fremovef $name]} {
return 1
} else {
return 0
}
}
#
# fslistf - return a list of frames in a frameset
# requires that name() exists
#
proc fslistf {name} {
if {[fexistf $name]} {
return [uplevel \#0 "set $name\($name,set)"]
} else {
return {}
}
}
#
# floadfs - load a frameset into memory
# requires that name() exist on disk, but not in memory
#
proc floadfs {name} {
if {[floadf $name]} {
set s [fslistf $name]
foreach i $s {
floadf $i
}
return 1
} else {
return 0
}
}
#
# fstorefs - store a frameset on disk
# requires that name() exists
#
proc fstorefs {name} {
if {[fstoref $name]} {
set s [fslistf $name]
foreach i $s {
fstoref $i
}
return 1
} else {
return 0
}
}
#
# fsincludef - include a frame in a frameset
# requires that name() and fname() exist
# modifies name(name,set)
#
proc fsincludef {name fname} {
if {[fexistf $name] && [fexistf $fname]} {
uplevel \#0 "lappend $name\($name,set) $fname"
return 1
} else {
return 0
}
}
#
# fsexcludef - exclude a frame from a frameset
# requires that name() exists
# modifies name(name,set)
#
proc fsexcludef {name fname} {
if {[fexistf $name]} {
if {[uplevel \#0 "member $$name\($name,set) $fname"]} {
uplevel \#0 "remove $name\($name,set) $fname"
return 1
} else {
return 0
}
} else {
return 0
}
}
#
# fscreates - create a slot in a frameset
# requires that name() exists
# modifies name(name,slots), name(sname,facets), associated frames
#
proc fscreates {name sname} {
if {[fcreates $name $sname]} {
set s [fslistf $name]
foreach i $s {
fcreates $i $sname
}
return 1
} else {
return 0
}
}
#
# fsremoves - remove a slot from a frameset
# requires that name(sname,facets) exists
# modifies name(name,slots), name(sname,), associated frames
#
proc sremoves {name sname} {
if {[fremoves $name $sname]} {
set s [fslistf $name]
foreach i $s {
fremoves $i $sname
}
return 1
} else {
return 0
}
}
#
# fscreated - create a demon facet in a frameset
# requires that name(sname,facets) exists
# modifies name(sname,facets), name(sname,dname), associated frames
#
proc fscreated {name sname dname} {
if {[fcreated $name $sname $dname]} {
set s [fslistf $name]
foreach i $s {
fcreated $i $sname $dname
}
return 1
} else {
return 0
}
}
#
# fsremoved - remove a demon facet from a frameset
# requires that name(sname,dname) exists
# modifies name(name,slots), name(sname,dname), associated frames
#
proc sremoved {name sname dname} {
if {[fremoved $name $sname $dname]} {
set s [fslistf $name]
foreach i $s {
fremoved $i $sname $dname
}
return 1
} else {
return 0
}
}
#
# fscreatem - create a method facet in a frameset
# requires that name(sname,facets) exists
# modifies name(sname,facets), name(sname,method), associated frames
#
proc fscreatem {name sname} {
if {[fcreatem $name $sname]} {
set s [fslistf $name]
foreach i $s {
fcreatem $i $sname
}
return 1
} else {
return 0
}
}
#
# fsremovem - remove a method facet from a frameset
# requires that name(sname,facets) exists
# modifies name(sname,facets), name(sname,method), associated frames
#
proc fsremovem {name sname} {
if {[fremovem $name $sname]} {
set s [fslistf $name]
foreach i $s {
fremovem $i $sname
}
return 1
} else {
return 0
}
}
#
# fscreater - create a reference facet in a frameset
# requires that name(sname,facets) exists
# modifies name(sname,facets), name(sname,ref), associated frames
#
proc fscreater {name sname} {
if {[fcreater $name $sname]} {
set s [fslistf $name]
foreach i $s {
fcreater $i $sname
}
return 1
} else {
return 0
}
}
#
# fsremover - remove a reference facet from a frameset
# requires that name(sname,facets) exists
# modifies name(sname,facets), name(sname,ref), associated frames
#
proc fsremover {name sname} {
if {[fremover $name $sname]} {
set s [fslistf $name]
foreach i $s {
fremover $i $sname
}
return 1
} else {
return 0
}
}
#
# fscreatev - create a value facet in a frameset
# requires that name(sname,facets) exists
# modifies name(sname,facets), name(sname,value), associated frames
#
proc fscreatev {name sname} {
if {[fcreatev $name $sname]} {
set s [fslistf $name]
foreach i $s {
fcreatev $i $sname
}
return 1
} else {
return 0
}
}
#
# fsremovev - remove a value facet from of a frameset
# requires that name(sname,facets) exists
# modifies name(sname,facets), name(sname,value), associated frames
#
proc fsremovev {name sname} {
if {[fremovev $name $sname]} {
set s [fslistf $name]
foreach i $s {
fremovev $i $sname
}
return 1
} else {
return 0
}
}
#
# fsputr - put a value in reference facet in a frameset
# requires that name(sname,facets) exists
# modifies the name(sname,ref)
#
proc fsputr {name sname fname} {
if {[fexistr $name $sname]} {
fputr $name $sname $fname
set s [fslistf $name]
foreach i $s {
fputr $i $sname $fname
}
return 1
} else {
return 0
}
}
#
# fsgetr - get a value from a reference facet in a frameset
# requires that name(sname,ref) exists
# modifies nothing
#
proc fsgetr {name sname} {
if {[fexistr $name $sname]} {
set r [fgetr $name $sname]
return $r
} else {
return ""
}
}
#
# fsmemberf - get list of framesets in which a frame is a member
# requires that the frame exists
# modifies nothing
#
proc fsmemberf {name} {
if {[fexistf $name]} {
foreach i [flistf] {
if {[uplevel \#0 "info exists $i\($i,set)"]} {
if {[member [uplevel \#0 "fslistf $i"] $name]} {
lappend mlist $i
}
}
}
return $mlist
} else {
return {}
}
}