** Synopsis ** An implementation by Cris Fugate of the [frames] paradigm in Tcl. ** Attributes ** name: framesets location: https://github.com/crisafugate/framesets Updated: 03/2013 Contact: mailto:cfugate@zoho.com (Cris A Fugate) ** Description ** Frames based OO implemention for Tcl. Framesets is based on Marin Minsky's concept of frames and basic set operations. It can currently be found at [https://github.com/crisafugate/framesets]. An older archive can be found through the Internet Wayback Machine at [http://web.archive.org/web/20010422002935/http://sites.netscape.net/tclframes/index.html], 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: [http://groups.google.com/group/comp.lang.tcl/browse_thread/thread/4367f404ae6a8684/20a2bb6930360357?lnk=st&q=comp.lang.tcl+frames+fugate&rnum=6#20a2bb6930360357] ---- '''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 result: return 1 if frames have the same slots return 0 otherwise fcompares (compare slot of two frames) invoke: fcompares result: return 1 if slot is the same in both frames return 0 otherwise fcopyf (copy a frame) invoke: fcopyf result: second frame is a copy of the first frame return 1 if successful, return 0 otherwise fcopys (copy a slot) invoke: fcopys 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 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 result: a new frame is created return 1 if successful, return 0 otherwise fcreatefs (create a frame set) invoke: fcreatefs result: a new frame set is created return 1 if successful, return 0 otherwise fcreatem (create a method facet) invoke: fcreatem 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 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 result: a new slot is created in the frame return 1 if successful, return 0 otherwise fcreatev (create a value facet) invoke: fcreatev 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 result: send code to be executed to server fexecd (execute a demon) invoke: fexecd result: execute the demon in slot of the frame return 1 if successful, return 0 otherwise fexecm (execute a method) invoke: fexecm result: execute the method in the slot of the frame return 1 if successful, return 0 otherwise fexecx (execute agent code) invoke: fexecx result: execute agent code of a frame return 1 if successful, return 0 otherwise fexistd (determine if a demon facet exists) invoke: fexistd result: return 1 if the demon in the slot of the frame exists return 0 otherwise fexistf (determine if a frame exists) invoke: fexistf result: return 1 if the frame exists, return 0 otherwise fexistm (determine if a method facet exists) invoke: fexistm 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 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 result: return 1 if the slot in the frame exists return 0 otherwise fexistv (determine if a value facet exists) invoke: fexistv result: return 1 if the value facet in the slot of the frame exists return 0 otherwise ffetchf (fetch a frame) invoke: ffetchf result: move a frame here from a server return 1 if successful, 0 otherwise ffetchfs (fetch a frame set) invoke: ffetchfs result: move a frame set here from a server return 1 if successful, 0 otherwise ffilterf (filter a frame) invoke: ffilterf result: remove common slots of first frame from second frame return 1 if successful, 0 otherwise fgetd (get demon code) invoke: fgetd result: return the demon code in the slot of the frame return nothing if this fails fgetm (get method code) invoke: fgetm result: return the method code in the slot of the frame return nothing if this fails fgetr (get reference) invoke: fgetr 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 result: return the agent state of a frame return nothing if this fails fgetv (get a value) invoke: fgetv 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 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 result: return the slots of the frame which contain references return empty list if this fails flists (list slots) invoke: flists result: return the slots of the frame return empty list if this fails flistt (list facets) invoke: flistt result: return the facet types for the slot of the frame return empty list if this fails floadf (load a frame) invoke: floadf result: frame is loaded from disk into memory return 1 if successful, return 0 otherwise floadfs (load a frame set) invoke: floadfs result: set is loaded from disk into memory return 1 if successful, return 0 otherwise flockf (lock a frame) invoke: flockf result: lock a frame so it cannot be modified return 1 if successful, 0 otherwise flockfs (lock a frame set) invoke: flockfs result: lock a frame set so it cannot be modified return 1 if successful, 0 otherwise fmergef (merge frames) invoke: fmergef result: copy non-common slots of first frame into second frame return 1 if successful, 0 otherwise fpack (pack a frame) invoke: fpack 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 result: return a list of frame names for each frame in the reference chain fputd (assign demon code) invoke: fputd 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 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 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 result: assign a state to a frame return 1 if successful, return 0 otherwise fputv (assign a value) invoke: fputv 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 result: assign agent code to a frame return 1 if successful, 0 otherwise fremoved (remove a demon facet) invoke: fremoved result: destroy demon facet in slot of the frame return 1 if successful, return 0 otherwise fremovef (remove a frame) invoke: fremovef result: destroy frame return 1 if successful, return 0 otherwise fremovem (remove a method facet) invoke: fremovem result: destory method facet in slot of the frame return 1 if successful, return 0 otherwise fremover (remove a reference) invoke: fremover result: destroy reference facet in slot of the frame return 1 if successful, return 0 otherwise fremoves (remove a slot) invoke: fremoves result: destory slot of the frame return 1 if successful, return 0 otherwise fremovev (remove a value facet) invoke: fremovev result: destroy value facet in slot of the frame return 1 if successful, return 0 otherwise frpc (remote procedure call) invoke: frpc result: send code to be executed to server return results of that execution fscreated (create a demon facet for a frame set) invoke: fscreated 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 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 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 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 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 result: send a frame to a server return 1 if successful, 0 otherwise fsendfs (send a frame set) invoke: fsendfs result: send a frame set to a server return 1 if successful, 0 otherwise fsexcludef (exclude a frame from a frame set) invoke: fsexcludef 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 result: return a reference from a slot if successful, return "" otherwise fsincludef (include a frame in a frame set) invoke: fsincludef result: frame is included in the frame set return 1 if successful, return 0 otherwise fsleepf (put a frame to sleep) invoke: fsleepf 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 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 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 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 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 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 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 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 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 result: destroy value facet in slot of the frame set return 1 if successful, return 0 otherwise fstoref (store a frame) invoke: fstoref result: store the representation of a frame on disk return 1 if successful, return 0 otherwise fstorefs (store a frame set) invoke: fstorefs result: store the representation of a frame set on disk return 1 if successful, return 0 otherwise funlockf (unlock a frame) invoke: funlockf result: unlocks a frame so that it can be modified return 1 if successful, 0 otherwise funlockfs (unlock a frame set) invoke: funlockfs result: unlocks a frame set so that it can be modified return 1 if successful, 0 otherwise funpack (unpack a frame) invoke: funpack result: unpacks and restores a frame from a packed list fupdatef (synchronize a frame) invoke: fupdate result: synchronize frame structure of first frame on second frame return 1 if successful, return 0 otherwise fwakef (wake up a frame) invoke: fwakef 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 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 frame,slots {slot name ..} slot,facets {facet name ..} slot,method slot,value {value ..} slot,ref slot,demon 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 frame,state frame,set {frame name ..} frame,slots {slot name ..} slot,facets {facet name ..} slot,method {} slot,value {} slot,ref 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 # () used in operations involving many elements # (,set) frames in a frameset # (,slots) slots in a frame # (,start) code to execute after frame is sent # (,state) state of a frame # (,) demon facet # (,facets) facets in a slot # (,ifcreatem) ifcreatem demon # (,ifcreater) ifcreater demon # (,ifcreatev) ifcreatev demon # (,ifexecm) ifexecm demon # (,ifexistm) ifexistm demon # (,ifexistr) ifexistr demon # (,ifexistv) ifexistv demon # (,ifgetm) ifgetm demon # (,ifgetr) ifgetr demon # (,ifgetv) ifgetv demon # (,ifputm) ifputm demon # (,ifputr) ifputr demon # (,ifputv) ifputv demon # (,ifref) ifref demon # (,ifremovem) ifremovem demon # (,ifremover) ifremover demon # (,ifremovev) ifremovev demon # (,method) method facet # (,ref) reference facet # (,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 # () used in operations involving many elements # (,set) frames in a frameset # (,slots) slots in a frame # (,) demon facet # (,facets) facets in a slot # (,ifcreatem) ifcreatem demon # (,ifcreater) ifcreater demon # (,ifcreatev) ifcreatev demon # (,ifexecm) ifexecm demon # (,ifexistm) ifexistm demon # (,ifexistr) ifexistr demon # (,ifexistv) ifexistv demon # (,ifgetm) ifgetm demon # (,ifgetr) ifgetr demon # (,ifgetv) ifgetv demon # (,ifputm) ifputm demon # (,ifputr) ifputr demon # (,ifputv) ifputv demon # (,ifref) ifref demon # (,ifremovem) ifremovem demon # (,ifremover) ifremover demon # (,ifremovev) ifremovev demon # (,method) method facet # (,ref) reference facet # (,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 {} } } ====== <> Glossary | Concept | AI