TMGOOL ;TMG/kst/OO Test code ;03/25/06 ;;1.0;TMG-LIB;**1**;04/25/04 ;"Kevin Toppenberg MD ;"GNU General Public License (GPL) applies ;"------------------------------------------ ;" new and delete functions below ;"------------------------------------------ ;"------------------------------------------ ;"Public functions: ;"new(objectType,Module) -- constructor for objects ;"delete(objectName) -- destructor for objects ;"inheritFrom(instanceName,Module) -- call this to inherit from another module ;"regFn(objectName,FnName,codeS) -- register a function/procedure for object ;"proc(objectName,objectProc,v1,...,v16) -- execute a procedure stored in a object ;"fn(objectName,objectFn,v1,...,v16) -- execute a function stored in a object ;"regProp(objectName,propName,initialValue,setFn,getFn,AllowedValues) -- register a property for given object ;"getProp(objectName,propName,outArray) -- get a property for a given object ;"setProp(objectName,propName,value) -- set a property for a given object ;"regEvent(objectName,eventName,codeS) -- register an event for an object, and it's handler ;"fireEvent(objectName,eventName,v1,...,v16) -- execute the handler of given event ;"fireInhEvent(objectName,CurModule,eventName,v1,...,v16) -- execute an inherited handler of given event ;"procInh(objectName,CurModule,objectProc,v1,..,v16) -- execute the INHERITED procedure stored in a object ;"fnInh(objectName,CurModule,objectFn,v1,...,v16) -- execute the INHERITED function stored in a object ;"------------------------------------------ ;"------------------------------------------ ;"Private functions: ;"getInherited(objectName,CurModule,FnName,Type) -- return name of inherited function (if any) ;"------------------------------------------ ;"------------------------------------------ new(objectType,Module) ;"Purpose -- A constructor for objects ;"Input: objectType -- the NAME of the type of the object to be defined. ;" This should be a variable (global or otherwise) that will hold the ;" defined objects. All the instances of a object of a particular type ;" will be held in this one variable. If this variable already holds ;" other instances of the object, it will be added in. ;" Module -- the name of the code block holding the definition of this object ;" e.g. 'TMGWIN01' (not TMGWIN01.m) ;"Result: returns the name of the particular instance --which is really @objectType@(ID) ;"Notes: thoughts for enhancements. I could specify a parent object type and establish ;" method overridding etc. ;" Currently this setup below doesn't allow for inheritance of parent variables. new ID,constFn,destFn,objectName do . set @objectType@("LAST ID")=$get(@objectType@("LAST ID"))+1 . set ID=@objectType@("LAST ID") . set @objectType@("INSTANCES",ID)="" . set @objectType@(ID,"ID")=ID . set @objectType@(ID,"TYPEDEF")=objectType . set objectName=$name(@objectType@(ID)) . set constFn="do Constructor^"_$name(@Module@(objectName)) . set destFn="do Destructor^"_$name(@Module@(objectName)) . set @objectType@("CONSTRUCTOR")=constFn . set @objectType@("DESTRUCTOR")=destFn xecute constFn quit objectName delete(objectName) ;"Purpose: A destructor for objects ;" any needed clean up code would go here first. ;"Input: objectName -- the name of the object instance to be deleted. ;" This should be the value returned from defWidget new destrFn,ID,typeDef set typeDef=$get(@objectName@("TYPEDEF")) set destrFn=$get(@typeDef@("DESTRUCTOR")) if destrFn'="" xecute destrFn set ID=$get(@objectName@("ID")) kill @typeDef@("INSTANCES",ID) kill @typeDef@(ID) quit inheritFrom(instanceName,Module) ;"Purpose: call this to inherit from another module ;"Input: instanceName -- the name/ref of the object to inherit into ;" Module -- the module to inherit from, e.g. 'TMGWGOJ', (not TMGWGOJ.m) ;" NOTE: prior data in defArray is NOT killed. ;"results: none ;"--------- Set up Inherited Object Stuff ----------------- ;"Notice: this creates a copy of the ancestor in the current object, as of the ;" time of creation of the child. Another solution would be to simply ;" store the name/ref of the ancestor. Then when an object's function is ;" evoked and it is not found in the current object, then a search is ;" carried out up the ancestor tree to find it. I think this latter ;" option is more complicated and may not offer any advantages. I will ;" not implement it now, bit I could use it later. ;" new typeDef set typeDef=$get(@instanceName@("TYPEDEF")) new rTemp ;"get a unique name, not same at interative caller... :-) if ($extract(typeDef,1)="%")&($length(typeDef)<4) do . new num set num=+$extract(typeDef,2,5) IF1 . set rTemp="%"_(num+1) else set rTemp="%1" new @rTemp new temp set temp=$$new^TMGOOL(rTemp,Module) ;"copy releveant parts of new, temporary object into instanceName ;"do GetTypeDef^TMGOOL(temp,.@typeDef) kill @rTemp@("MODULE") kill @rTemp@("CONSTRUCTOR") kill @rTemp@("DESTRUCTOR") kill @rTemp@(1,"TYPEDEF") kill @rTemp@("LAST ID") merge @instanceName=@rTemp@(1) kill @rTemp@(1) kill @rTemp@("INSTANCES") merge @typeDef=@rTemp quit ;"NOTE USED (?) -- delete later... GetTypeDef(objectName,defArray) ;"-- NOTE!! Should only call from inheritFrom ;"Purpose: to get just the type definition part from objectName ;"Input: objectName -- the name/ref of the object to extract from ;" defArray -- PASS BY REFERENCE -- an array to hold inherited object ;" it will be filled with just the type def part from objectName ;" NOTE: prior data in defArray is NOT killed. ;" GLOBAL SCOPE VARIABLE TMGthis is used as reference to object inheriting new temp set temp=$get(@objectName@("TYPEDEF")) if temp="" goto GTDDone new Array merge Array=@temp ;"copy @objectName so kills won't be global kill Array("MODULE") kill Array("CONSTRUCTOR") kill Array("DESTRUCTOR") kill Array(1,"TYPEDEF") merge @TMGthis=Array(1) ;"only when inheriting is this valid kill Array(1) merge defArray=Array GTDDone quit regEvent(objectName,eventName,codeS) ;"Purpose: to register an event for an object, and it's handler ;"Input: objectName -- the name/ref of the object set up ;" eventName -- the Event Name: e.g. 'CLICK' ;" codeS -- the name of the actual function that will be called. ;" e.g. 'HandleClick^TMGWOJ(T,L)' ;"results: none ;"Note: If there is already a similarly named function present (i.e. if a ;" descendant is overridding an ancestor's function, then this ;" pre-existing function is stored in a way that is will later be callable. ;"Note: the difference between this and regFn is that regFn stores the ;" declaration in the typeDef (i.e. the same for all instances of the ;" object.) This stores the information in the INSTANCE. E.g. different ;" instances of object can execture different code upon an event's firing. if $get(objectName)="" goto REDone new pFns set pFns=$name(@objectName@("EVENTS")) if $get(@pFns@(eventName))'="" do . set @pFns@(eventName_"_INHERITED")=@pFns@(eventName) set @pFns@(eventName)=codeS REDone quit fireInhEvent(objectName,CurModule,eventName,v1,v2,v3,v4,v5,v6,v7,v8,v9,v10,v11,v12,v13,v14,v15,v16) ;"Purpose: to execute an inherited handler of given event ;"Input: ObjectName -- the name of the object containing the member function ;" eventName -- the name of the EVENT to be fired ;" v1...v16 -- OPTIONAL input variables. Only the number of variables called for by ;" the specified function will be used. ;"Result -- none ;" Note: if an event handler needs to communicate back to the object firing ;" the event, it can be done via a variable passed by reference (i.e. an ;" OUT parameter.) set eventName=$$getInherited(objectName,CurModule,eventName,"EVENTS") ;"GET INHERITED FUNCTION do fireEvent(objectName,eventName,.v1,.v2,.v3,.v4,.v5,.v6,.v7,.v8,.v9,.v10,.v11,.v12,.v13,.v14,.v15,.v16) quit fireEvent(objectName,eventName,v1,v2,v3,v4,v5,v6,v7,v8,v9,v10,v11,v12,v13,v14,v15,v16) ;"Purpose: to execute the handler of given event ;"Input: ObjectName -- the name of the object containing the member function ;" eventName -- the name of the EVENT to be fired ;" v1...v16 -- OPTIONAL input variables. Only the number of variables called for by ;" the specified function will be used. ;"Result -- none ;" Note: if an event handler needs to communicate back to the object firing ;" the event, it can be done via a variable passed by reference (i.e. an ;" OUT parameter.) if (objectName="")!(objectName[" ") goto feDone new pFn set pFn=$name(@objectName@("EVENTS")) new TMGthis set TMGthis=objectName ;"set up global-scope 'this' var pointer for member function use new fn set fn=$get(@pFn@(eventName,"COMPILED")) if fn="" do . set fn=$get(@pFn@(eventName)) if fn="" quit ;"example wgtMultiply^TMGOOWG(x,y) . new Params set Params=$piece($piece(fn,"(",2),")",1) . new numParams set numParams=$length(Params,",") set:Params="" numParams=0 . set fn=$piece(fn,"(",1) . new TMGParam,i,comma set TMGParam="",comma="" ;"first cycle comma not added . for i=1:1:numParams set TMGParam=TMGParam_comma_".v"_i,comma="," . set fn="do "_fn_"("_TMGParam_")" ;"e.g. 'do HandleClick^TMGOOWG(x,y)' . set @pFn@(eventName,"COMPILED")=fn ;"note if fn="" --> no error upon execution of null code (i.e. no handler defined) xecute fn ;"<--- call actual function. ;PERHAPS LET OBJECTS DEFINE CUSTOM ERROR TRAP FUNCTIONS?? feDone quit regFn(objectName,FnName,codeS) ;"Purpose: to register a function/procedure for object ;"Input: objectName -- the name/ref of the object set up ;" FnName -- the name that will be use. ;" e.g. 'ACCEPT CLICK' ;" codeS -- the name of the actual function that will be called. ;" e.g. 'AcceptClick^TMGWOJ(T,L)' ;"results: none ;"Note: If there is already a similarly named function present (i.e. if a ;" descendant is overridding an ancestor's function, then this ;" pre-existing function is stored in a way that is will later be callable. new typeDef set typeDef=@objectName@("TYPEDEF") new pFns set pFns=$name(@typeDef@("FN")) if $get(@pFns@(FnName))'="" do . set @pFns@(FnName_"_INHERITED")=@pFns@(FnName) set @pFns@(FnName)=codeS quit getInherited(objectName,CurModule,FnName,Type) ;"GET INHERITED FUNCTION ;"Purpose: for a given function, return name of inherited function (if any) ;"Input: objectName -- the name/ref of the object set up ;" CurModule -- The module of the version requesting parent. ;" FnName -- the name that will be use. ;" e.g. 'PAINT' ;" Type -- should be 'FN' for functions/procedures, or 'EVENTS' for event handlers ;" OPTIONAL -- default is FN ;"Results: Returns the name of the function that can be called directly, ;" e.g. 'PAINT_INHERITED' in the example below. ;"Example: ;" GraphicObject.Paint -- stored in TMGWGOJ ;" Window.Paint -- stored in TMGWIN01 ;" Splash.Paint -- stored in TMGXXXX ;" In this example, Paint in Splash may want to call it's ancestor ;" before doing it's work. Windows.Paint in turn may call GraphicObject.Paint ;" prior to doing it's painting. ;" So the typedef for the object would look like this: ;" tVar("FN","PAINT")="Paint^TMGXXXX" ;" tVar("FN","PAINT_INHERITED")="Paint^TMGWIN01" ;" tVar("FN","PAINT_INHERITED_INHERITED")="Paint^TMGWGOJ" set Type=$get(Type,"FN") ;"--default to looking in FN new typeDef set typeDef=@objectName@("TYPEDEF") new pFns if Type="FN" set pFns=$name(@typeDef@(Type)) else set pFns=$name(@objectName@(Type)) ;"first find current function for set code=$get(@pFns@(FnName)) quit:(code="")!(code[CurModule) do . set FnName=FnName_"_INHERITED" ;"now look for inherited. if code[CurModule do . set FnName=FnName_"_INHERITED" . set code=$get(@pFns@(FnName)) . if code="" set FnName="" else set FnName="" quit FnName procInh(objectName,CurModule,objectProc,v1,v2,v3,v4,v5,v6,v7,v8,v9,v10,v11,v12,v13,v14,v15,v16) ;"Purpose: to execute the INHERITED procedure stored in a object ;"Input: ObjectName -- the name of the object containing the member function ;" CurModule -- the module of the function looking for inherited. ;" objectProc -- the name of the procedure to be executed in the member function ;" v1...v16 -- OPTIONAL input variables. Only the number of variables called for by ;" the specified function will be used. ;"Result -- none set objectProc=$$getInherited(objectName,CurModule,objectProc) ;"GET INHERITED FUNCTION new temp set temp=$$fn(objectName,objectProc,.v1,.v2,.v3,.v4,.v5,.v6,.v7,.v8,.v9,.v10,.v11,.v12,.v13,.v14,.v15,.v16) quit proc(objectName,objectProc,v1,v2,v3,v4,v5,v6,v7,v8,v9,v10,v11,v12,v13,v14,v15,v16) ;"Purpose: to execute a procedure stored in a object ;"Input: ObjectName -- the name of the object containing the member function ;" objectProc -- the name of the procedure to be executed in the member function ;" v1...v16 -- OPTIONAL input variables. Only the number of variables called for by ;" the specified function will be used. ;"Result -- none new temp set temp=$$fn(objectName,objectProc,.v1,.v2,.v3,.v4,.v5,.v6,.v7,.v8,.v9,.v10,.v11,.v12,.v13,.v14,.v15,.v16) quit fnInh(objectName,CurModule,objectFn,v1,v2,v3,v4,v5,v6,v7,v8,v9,v10,v11,v12,v13,v14,v15,v16) ;"Purpose: to execute the INHERITED function stored in a object ;"Input: ObjectName -- the name of the object containing the member function ;" CurModule -- the module of the function looking for inherited. ;" objectFn -- the name of the function to be executed in the member function ;" v1...v16 -- OPTIONAL input variables. Only the number of variables called for by ;" the specified function will be used. ;"Result -- returns the output value of the specified function, or "" if there is not output. set objectFn=$$getInherited(objectName,CurModule,objectFn) ;"GET INHERITED FUNCTION quit $$fn(objectName,objectFn,.v1,.v2,.v3,.v4,.v5,.v6,.v7,.v8,.v9,.v10,.v11,.v12,.v13,.v14,.v15,.v16) fn(objectName,objectFn,v1,v2,v3,v4,v5,v6,v7,v8,v9,v10,v11,v12,v13,v14,v15,v16) ;"Purpose: to execute a function stored in a object ;"Input: ObjectName -- the name of the object containing the member function ;" objectFn -- the name of the function to be executed in the member function ;" v1...v16 -- OPTIONAL input variables. Only the number of variables called for by ;" the specified function will be used. ;"Result -- returns the output value of the specified function, or "" if there is not output. new outVar set outVar="" ;"default result if (objectName="")!(objectName[" ") goto fnDone new typeDef set typeDef=$get(@objectName@("TYPEDEF")) if typeDef="" goto fnDone new pFn set pFn=$name(@typeDef@("FN")) new TMGthis set TMGthis=objectName ;"set up global-scope 'this' var pointer for member function use new fn set fn=$get(@pFn@(objectFn,"COMPILED")) if fn="" do . set fn=$get(@pFn@(objectFn)) if fn="" quit ;"example wgtMultiply^TMGOOWG(x,y) . new Params set Params=$piece($piece(fn,"(",2),")",1) . new numParams set numParams=$length(Params,",") set:Params="" numParams=0 . set fn=$piece(fn,"(",1) . new TMGParam,i,comma set TMGParam="",comma="" ;"first cycle comma not added . for i=1:1:numParams set TMGParam=TMGParam_comma_".v"_i,comma="," . set fn="set outVar=$$"_fn_"("_TMGParam_")" ;"e.g. 'set outVar=$$wgtMultiply^TMGOOWG(x,y)' . set @pFn@(objectFn,"COMPILED")=fn xecute fn ;"<--- call actual function. ;PERHAPS LET OBJECTS DEFINE CUSTOM ERROR TRAP FUNCTIONS?? fnDone quit outVar regProp(objectName,propName,initialValue,setFn,getFn,AllowedValues) ;"Purpose: to register a property for given object ;" Note, but using these functions for a property, rather than ;" directly reading, it will allow the creation of setter and reader ;" methods ;"Input: ObjectName -- the name of the object containing the member function ;" propName -- the name of the property to establish ;" initialValue -- OPTIONAL. The initial value. May be passed ;" by reference for storage of an array. ;" setFn -- OPTIONAL: the name of a procedure to set value. Format: ;" e.g. 'MyProc^Module', NOT 'MyProc^Module(var)' ;" In the code module, the actual function that is to be ;" called must be in this format (IF setter fn is specified): ;" e.g. 'MyProc(TMGthis,propName,value)' ;" ** The code should be able to deal with 'value' as an array ;" ** QUIT must NOT return a value ;" getFn -- OPTIONAL: the name of a function to get value. Format: ;" e.g. '$$MyFunct^Module' ;" In the code module, the actual function that is to be ;" called must be in this format (IF getter fn is specified): ;" e.g. 'MyProc(TMGthis,propName,outArray)' ;" ** The could should return the value in outArray, which ;" will be passed by reference. ;" ** QUIT *must* return a value (in addition to outArray) ;" AllowedValues -- OPTIONAL. PASS BY REFERENCE. Format: ;" ** to be implemented ** ;" AllowedValues("MyValue#1")="" <-- arbitrary acceptable ;" AllowedValues("MyValue#2")="" <-- arbitrary acceptable ;" AllowedValues("100...200")="" <-- "..." is signal for a RANGE of acceptible values ;" AllowedValues("[ABcDe]")="" <-- "[ ]" is signals a list of allowable flags. ;" Value must some combination of the flags listed ;" Flags must be 1 character ;" AllowedValues("?.N")="" ;" If value has "?" as first character, then interpreted as screening code ;" Value will be accepted if the screening expression evaluates to TRUE ;" Note: If Allowed values is not passed, then it is up to the ;" setter function (if one exists) to screen input. Otherwise ;" ALL values will be accepted ;" If Allowed values is passed, then ONLY values listed as ;" acceptible values, or in one of the ranges will be acceptible ;" ALTERNATE FORMAT for allowed values: ;" AllowedValues="AllowedValue1^AllowedValue2^100...200^Value4^?.N^AnotherValue" etc. ;"Result: returns the value of the property, or "" if not found ;" If a getting/reading function has been specified at the time registration, ;" then result returned will be the value of the function. ;"Note: there is no 'inheritence' for properties. new typeDef set typeDef=@objectName@("TYPEDEF") kill @objectName@("PROP",propName) if $data(AllowedValues)>0 do . if ($data(AllowedValues)#10=1) do . . new i for i=1:1:$length(AllowedValues,"^") do . . . new oneValue set oneValue=$piece(AllowedValues,"^",i) . . . set AllowedValues(oneValue)="" . set AllowedValues="" ;"<-- setting SETTER fun below will overwrite this position. OK. . merge @typeDef@("OOL_SETTER",propName,"ALLOWED")=AllowedValues if $get(setFn)'="" do . new fn set fn="do "_setFn_"(objectName,"""_propName_""",.value)" . set @typeDef@("OOL_SETTER",propName)=fn if $get(getFn)'="" do . new fn set fn="set result="_getFn_"(objectName,"""_propName_""",.outArray)" . set @typeDef@("OOL_GETTER",propName)=fn do setProp(objectName,propName,.initialValue) quit getProp(objectName,propName,outArray) ;"Purpose: to get a property for a given object ;" Note, but using this function to read the property, rather than ;" directly reading, it will allow the creation of setter and reader ;" methods ;"Input: ObjectName -- the name of the object containing the member function ;" propName -- the name of the property to read ;" outArray -- OPTIONAL. PASS BY REFERENCE, an OUT PARAMETER ;" prior data in outArray will be KILLED ;"Result: returns the value of the property, or "" if not found ;" If a getting/reading function has been specified at the time registration, ;" then result returned will be the value of the function. ;" The results will also be put into outArray (in case value is an array) ;" It is possible that result="" but outArray contains valid data. new result set result="" kill outArray if $get(objectName)="" goto gpDone if +objectName=objectName do goto gpDone X1 . new temp set temp=1 new typeDef set typeDef=$get(@objectName@("TYPEDEF")) if typeDef="" goto gpDone new fn set fn=$get(@typeDef@("OOL_GETTER",propName)) if fn'="" do . new $etrap set $etrap="set result="""",$etrap="""",$ecode=""""" . xecute fn else do . set result=$get(@objectName@("PROP",propName)) . merge outArray=@objectName@("PROP",propName) gpDone quit result setProp(objectName,propName,value) ;"Purpose: to set a property for a given object ;" Note, but using this function to read the property, rather than ;" directly reading, it will allow the creation of setter and reader ;" methods ;"Input: ObjectName -- the name of the object containing the member function ;" propName -- the name of the property to set ;" value -- MAY BE PASSED BY REFERENCE (for arrays) ;"Result: none ;"Note: If a setting function has been specified at the time registration, ;" then 'value' will be passed to the setter. The setter will be ;" responsible for storing 'value' if appropriate. ;"Note: If an allowed values set was specified when property was registered, then ;" screen for those allowed values will take place here. if $get(objectName)="" goto spDone new typeDef set typeDef=@objectName@("TYPEDEF") new abort set abort=0 new result set result="" if $get(objectName)="" goto spDone if $data(@typeDef@("OOL_SETTER",propName,"ALLOWED"))>0 do goto:(abort=1) spDone . new AllowedValues . merge AllowedValues=@typeDef@("OOL_SETTER",propName,"ALLOWED") . if $data(AllowedValues)'>1 quit . ;"**Allowed values set found, so default is now to abort unless allowed value found . set abort=1 . new cond set cond="" . new allowedFound set allowedFound=0 . for set cond=$order(AllowedValues(cond),-1) quit:(cond="")!(allowedFound=1) do . . if cond["..." do quit ;"<--A range . . . new lo,hi . . . set lo=$piece(cond,"...",1),hi=$piece(cond,"...",2) . . . if (value'hi) set allowedFound=1 . . if $extract(cond,1)="?" do quit ;"<--Pattern match code . . . new temp,$etrap . . . set $etrap="set $etrap="""",$ecode=""""" . . . xecute "set temp=(value"_cond_")" ;"e.g. 'set temp=(value?.N)' . . . if temp=1 set allowedFound=1 . . if (value=cond) set allowedFound=1 . . if $extract(cond,1)="[" do quit ;"<--An allowed set of flags (1 character) . . . new goodMatch set goodMatch=1 . . . new i for i=1:1:$length(value) do quit:(goodMatch=0) ;"check to see if each character is an allowed flag . . . . new flag set flag=$extract(value,i) . . . . if cond'[flag set goodMatch=0 . . . if goodMatch set allowedFound=1 . if allowedFound=1 set abort=0 ;"<--Straight matching. new fn set fn=$get(@typeDef@("OOL_SETTER",propName)) if fn'="" do . new $etrap set $etrap="set result="""",$etrap="""",$ecode=""""" . xecute fn else do . kill @objectName@("PROP",propName) . merge @objectName@("PROP",propName)=value spDone quit