source: cprs/branches/tmg-cprs/m_files/TMGOOL.m@ 1806

Last change on this file since 1806 was 796, checked in by Kevin Toppenberg, 14 years ago

Initial upload
File size: 26.3 KB
Line 
1TMGOOL ;TMG/kst/OO Test code ;03/25/06
2 ;;1.0;TMG-LIB;**1**;04/25/04
3
4 ;"Kevin Toppenberg MD
5 ;"GNU General Public License (GPL) applies
6 ;"------------------------------------------
7
8 ;" new and delete functions below
9 ;"------------------------------------------
10 ;"------------------------------------------
11 ;"Public functions:
12
13 ;"new(objectType,Module) -- constructor for objects
14 ;"delete(objectName) -- destructor for objects
15 ;"inheritFrom(instanceName,Module) -- call this to inherit from another module
16
17 ;"regFn(objectName,FnName,codeS) -- register a function/procedure for object
18 ;"proc(objectName,objectProc,v1,...,v16) -- execute a procedure stored in a object
19 ;"fn(objectName,objectFn,v1,...,v16) -- execute a function stored in a object
20
21 ;"regProp(objectName,propName,initialValue,setFn,getFn,AllowedValues) -- register a property for given object
22 ;"getProp(objectName,propName,outArray) -- get a property for a given object
23 ;"setProp(objectName,propName,value) -- set a property for a given object
24
25 ;"regEvent(objectName,eventName,codeS) -- register an event for an object, and it's handler
26 ;"fireEvent(objectName,eventName,v1,...,v16) -- execute the handler of given event
27
28 ;"fireInhEvent(objectName,CurModule,eventName,v1,...,v16) -- execute an inherited handler of given event
29 ;"procInh(objectName,CurModule,objectProc,v1,..,v16) -- execute the INHERITED procedure stored in a object
30 ;"fnInh(objectName,CurModule,objectFn,v1,...,v16) -- execute the INHERITED function stored in a object
31
32
33 ;"------------------------------------------
34 ;"------------------------------------------
35 ;"Private functions:
36 ;"getInherited(objectName,CurModule,FnName,Type) -- return name of inherited function (if any)
37
38
39 ;"------------------------------------------
40 ;"------------------------------------------
41
42new(objectType,Module)
43 ;"Purpose -- A constructor for objects
44 ;"Input: objectType -- the NAME of the type of the object to be defined.
45 ;" This should be a variable (global or otherwise) that will hold the
46 ;" defined objects. All the instances of a object of a particular type
47 ;" will be held in this one variable. If this variable already holds
48 ;" other instances of the object, it will be added in.
49 ;" Module -- the name of the code block holding the definition of this object
50 ;" e.g. 'TMGWIN01' (not TMGWIN01.m)
51 ;"Result: returns the name of the particular instance --which is really @objectType@(ID)
52
53 ;"Notes: thoughts for enhancements. I could specify a parent object type and establish
54 ;" method overridding etc.
55 ;" Currently this setup below doesn't allow for inheritance of parent variables.
56
57 new ID,constFn,destFn,objectName
58 do
59 . set @objectType@("LAST ID")=$get(@objectType@("LAST ID"))+1
60 . set ID=@objectType@("LAST ID")
61 . set @objectType@("INSTANCES",ID)=""
62 . set @objectType@(ID,"ID")=ID
63 . set @objectType@(ID,"TYPEDEF")=objectType
64 . set objectName=$name(@objectType@(ID))
65 . set constFn="do Constructor^"_$name(@Module@(objectName))
66 . set destFn="do Destructor^"_$name(@Module@(objectName))
67 . set @objectType@("CONSTRUCTOR")=constFn
68 . set @objectType@("DESTRUCTOR")=destFn
69 xecute constFn
70
71 quit objectName
72
73
74delete(objectName)
75 ;"Purpose: A destructor for objects
76 ;" any needed clean up code would go here first.
77 ;"Input: objectName -- the name of the object instance to be deleted.
78 ;" This should be the value returned from defWidget
79
80 new destrFn,ID,typeDef
81 set typeDef=$get(@objectName@("TYPEDEF"))
82
83 set destrFn=$get(@typeDef@("DESTRUCTOR"))
84 if destrFn'="" xecute destrFn
85
86 set ID=$get(@objectName@("ID"))
87 kill @typeDef@("INSTANCES",ID)
88 kill @typeDef@(ID)
89 quit
90
91
92inheritFrom(instanceName,Module)
93 ;"Purpose: call this to inherit from another module
94 ;"Input: instanceName -- the name/ref of the object to inherit into
95 ;" Module -- the module to inherit from, e.g. 'TMGWGOJ', (not TMGWGOJ.m)
96 ;" NOTE: prior data in defArray is NOT killed.
97 ;"results: none
98
99 ;"--------- Set up Inherited Object Stuff -----------------
100 ;"Notice: this creates a copy of the ancestor in the current object, as of the
101 ;" time of creation of the child. Another solution would be to simply
102 ;" store the name/ref of the ancestor. Then when an object's function is
103 ;" evoked and it is not found in the current object, then a search is
104 ;" carried out up the ancestor tree to find it. I think this latter
105 ;" option is more complicated and may not offer any advantages. I will
106 ;" not implement it now, bit I could use it later.
107 ;"
108
109 new typeDef set typeDef=$get(@instanceName@("TYPEDEF"))
110 new rTemp ;"get a unique name, not same at interative caller... :-)
111 if ($extract(typeDef,1)="%")&($length(typeDef)<4) do
112 . new num set num=+$extract(typeDef,2,5)
113IF1 . set rTemp="%"_(num+1)
114 else set rTemp="%1"
115 new @rTemp
116 new temp set temp=$$new^TMGOOL(rTemp,Module)
117 ;"copy releveant parts of new, temporary object into instanceName
118 ;"do GetTypeDef^TMGOOL(temp,.@typeDef)
119
120 kill @rTemp@("MODULE")
121 kill @rTemp@("CONSTRUCTOR")
122 kill @rTemp@("DESTRUCTOR")
123 kill @rTemp@(1,"TYPEDEF")
124 kill @rTemp@("LAST ID")
125 merge @instanceName=@rTemp@(1)
126 kill @rTemp@(1)
127 kill @rTemp@("INSTANCES")
128
129 merge @typeDef=@rTemp
130
131 quit
132
133 ;"NOTE USED (?) -- delete later...
134GetTypeDef(objectName,defArray) ;"-- NOTE!! Should only call from inheritFrom
135 ;"Purpose: to get just the type definition part from objectName
136 ;"Input: objectName -- the name/ref of the object to extract from
137 ;" defArray -- PASS BY REFERENCE -- an array to hold inherited object
138 ;" it will be filled with just the type def part from objectName
139 ;" NOTE: prior data in defArray is NOT killed.
140 ;" GLOBAL SCOPE VARIABLE TMGthis is used as reference to object inheriting
141
142 new temp set temp=$get(@objectName@("TYPEDEF"))
143 if temp="" goto GTDDone
144 new Array
145 merge Array=@temp ;"copy @objectName so kills won't be global
146
147 kill Array("MODULE")
148 kill Array("CONSTRUCTOR")
149 kill Array("DESTRUCTOR")
150 kill Array(1,"TYPEDEF")
151
152 merge @TMGthis=Array(1) ;"only when inheriting is this valid
153 kill Array(1)
154
155 merge defArray=Array
156
157GTDDone
158 quit
159
160
161regEvent(objectName,eventName,codeS)
162 ;"Purpose: to register an event for an object, and it's handler
163 ;"Input: objectName -- the name/ref of the object set up
164 ;" eventName -- the Event Name: e.g. 'CLICK'
165 ;" codeS -- the name of the actual function that will be called.
166 ;" e.g. 'HandleClick^TMGWOJ(T,L)'
167 ;"results: none
168 ;"Note: If there is already a similarly named function present (i.e. if a
169 ;" descendant is overridding an ancestor's function, then this
170 ;" pre-existing function is stored in a way that is will later be callable.
171 ;"Note: the difference between this and regFn is that regFn stores the
172 ;" declaration in the typeDef (i.e. the same for all instances of the
173 ;" object.) This stores the information in the INSTANCE. E.g. different
174 ;" instances of object can execture different code upon an event's firing.
175 if $get(objectName)="" goto REDone
176 new pFns set pFns=$name(@objectName@("EVENTS"))
177 if $get(@pFns@(eventName))'="" do
178 . set @pFns@(eventName_"_INHERITED")=@pFns@(eventName)
179 set @pFns@(eventName)=codeS
180REDone
181 quit
182
183
184fireInhEvent(objectName,CurModule,eventName,v1,v2,v3,v4,v5,v6,v7,v8,v9,v10,v11,v12,v13,v14,v15,v16)
185 ;"Purpose: to execute an inherited handler of given event
186 ;"Input: ObjectName -- the name of the object containing the member function
187 ;" eventName -- the name of the EVENT to be fired
188 ;" v1...v16 -- OPTIONAL input variables. Only the number of variables called for by
189 ;" the specified function will be used.
190 ;"Result -- none
191 ;" Note: if an event handler needs to communicate back to the object firing
192 ;" the event, it can be done via a variable passed by reference (i.e. an
193 ;" OUT parameter.)
194 set eventName=$$getInherited(objectName,CurModule,eventName,"EVENTS") ;"GET INHERITED FUNCTION
195 do fireEvent(objectName,eventName,.v1,.v2,.v3,.v4,.v5,.v6,.v7,.v8,.v9,.v10,.v11,.v12,.v13,.v14,.v15,.v16)
196 quit
197
198fireEvent(objectName,eventName,v1,v2,v3,v4,v5,v6,v7,v8,v9,v10,v11,v12,v13,v14,v15,v16)
199 ;"Purpose: to execute the handler of given event
200 ;"Input: ObjectName -- the name of the object containing the member function
201 ;" eventName -- the name of the EVENT to be fired
202 ;" v1...v16 -- OPTIONAL input variables. Only the number of variables called for by
203 ;" the specified function will be used.
204 ;"Result -- none
205 ;" Note: if an event handler needs to communicate back to the object firing
206 ;" the event, it can be done via a variable passed by reference (i.e. an
207 ;" OUT parameter.)
208
209 if (objectName="")!(objectName[" ") goto feDone
210 new pFn set pFn=$name(@objectName@("EVENTS"))
211
212 new TMGthis set TMGthis=objectName ;"set up global-scope 'this' var pointer for member function use
213 new fn set fn=$get(@pFn@(eventName,"COMPILED"))
214 if fn="" do
215 . set fn=$get(@pFn@(eventName)) if fn="" quit ;"example wgtMultiply^TMGOOWG(x,y)
216 . new Params set Params=$piece($piece(fn,"(",2),")",1)
217 . new numParams set numParams=$length(Params,",") set:Params="" numParams=0
218 . set fn=$piece(fn,"(",1)
219 . new TMGParam,i,comma set TMGParam="",comma="" ;"first cycle comma not added
220 . for i=1:1:numParams set TMGParam=TMGParam_comma_".v"_i,comma=","
221 . set fn="do "_fn_"("_TMGParam_")" ;"e.g. 'do HandleClick^TMGOOWG(x,y)'
222 . set @pFn@(eventName,"COMPILED")=fn
223 ;"note if fn="" --> no error upon execution of null code (i.e. no handler defined)
224 xecute fn ;"<--- call actual function. ;PERHAPS LET OBJECTS DEFINE CUSTOM ERROR TRAP FUNCTIONS??
225feDone quit
226
227
228regFn(objectName,FnName,codeS)
229 ;"Purpose: to register a function/procedure for object
230 ;"Input: objectName -- the name/ref of the object set up
231 ;" FnName -- the name that will be use.
232 ;" e.g. 'ACCEPT CLICK'
233 ;" codeS -- the name of the actual function that will be called.
234 ;" e.g. 'AcceptClick^TMGWOJ(T,L)'
235 ;"results: none
236 ;"Note: If there is already a similarly named function present (i.e. if a
237 ;" descendant is overridding an ancestor's function, then this
238 ;" pre-existing function is stored in a way that is will later be callable.
239
240 new typeDef set typeDef=@objectName@("TYPEDEF")
241 new pFns set pFns=$name(@typeDef@("FN"))
242
243 if $get(@pFns@(FnName))'="" do
244 . set @pFns@(FnName_"_INHERITED")=@pFns@(FnName)
245 set @pFns@(FnName)=codeS
246 quit
247
248getInherited(objectName,CurModule,FnName,Type) ;"GET INHERITED FUNCTION
249 ;"Purpose: for a given function, return name of inherited function (if any)
250 ;"Input: objectName -- the name/ref of the object set up
251 ;" CurModule -- The module of the version requesting parent.
252 ;" FnName -- the name that will be use.
253 ;" e.g. 'PAINT'
254 ;" Type -- should be 'FN' for functions/procedures, or 'EVENTS' for event handlers
255 ;" OPTIONAL -- default is FN
256 ;"Results: Returns the name of the function that can be called directly,
257 ;" e.g. 'PAINT_INHERITED' in the example below.
258
259 ;"Example:
260 ;" GraphicObject.Paint -- stored in TMGWGOJ
261 ;" Window.Paint -- stored in TMGWIN01
262 ;" Splash.Paint -- stored in TMGXXXX
263 ;" In this example, Paint in Splash may want to call it's ancestor
264 ;" before doing it's work. Windows.Paint in turn may call GraphicObject.Paint
265 ;" prior to doing it's painting.
266 ;" So the typedef for the object would look like this:
267 ;" tVar("FN","PAINT")="Paint^TMGXXXX"
268 ;" tVar("FN","PAINT_INHERITED")="Paint^TMGWIN01"
269 ;" tVar("FN","PAINT_INHERITED_INHERITED")="Paint^TMGWGOJ"
270
271 set Type=$get(Type,"FN") ;"--default to looking in FN
272 new typeDef set typeDef=@objectName@("TYPEDEF")
273
274 new pFns
275 if Type="FN" set pFns=$name(@typeDef@(Type))
276 else set pFns=$name(@objectName@(Type))
277
278 ;"first find current function
279 for set code=$get(@pFns@(FnName)) quit:(code="")!(code[CurModule) do
280 . set FnName=FnName_"_INHERITED"
281
282 ;"now look for inherited.
283 if code[CurModule do
284 . set FnName=FnName_"_INHERITED"
285 . set code=$get(@pFns@(FnName))
286 . if code="" set FnName=""
287 else set FnName=""
288
289 quit FnName
290
291
292procInh(objectName,CurModule,objectProc,v1,v2,v3,v4,v5,v6,v7,v8,v9,v10,v11,v12,v13,v14,v15,v16)
293 ;"Purpose: to execute the INHERITED procedure stored in a object
294 ;"Input: ObjectName -- the name of the object containing the member function
295 ;" CurModule -- the module of the function looking for inherited.
296 ;" objectProc -- the name of the procedure to be executed in the member function
297 ;" v1...v16 -- OPTIONAL input variables. Only the number of variables called for by
298 ;" the specified function will be used.
299 ;"Result -- none
300 set objectProc=$$getInherited(objectName,CurModule,objectProc) ;"GET INHERITED FUNCTION
301 new temp set temp=$$fn(objectName,objectProc,.v1,.v2,.v3,.v4,.v5,.v6,.v7,.v8,.v9,.v10,.v11,.v12,.v13,.v14,.v15,.v16)
302 quit
303
304
305proc(objectName,objectProc,v1,v2,v3,v4,v5,v6,v7,v8,v9,v10,v11,v12,v13,v14,v15,v16)
306 ;"Purpose: to execute a procedure stored in a object
307 ;"Input: ObjectName -- the name of the object containing the member function
308 ;" objectProc -- the name of the procedure to be executed in the member function
309 ;" v1...v16 -- OPTIONAL input variables. Only the number of variables called for by
310 ;" the specified function will be used.
311 ;"Result -- none
312 new temp set temp=$$fn(objectName,objectProc,.v1,.v2,.v3,.v4,.v5,.v6,.v7,.v8,.v9,.v10,.v11,.v12,.v13,.v14,.v15,.v16)
313 quit
314
315fnInh(objectName,CurModule,objectFn,v1,v2,v3,v4,v5,v6,v7,v8,v9,v10,v11,v12,v13,v14,v15,v16)
316 ;"Purpose: to execute the INHERITED function stored in a object
317 ;"Input: ObjectName -- the name of the object containing the member function
318 ;" CurModule -- the module of the function looking for inherited.
319 ;" objectFn -- the name of the function to be executed in the member function
320 ;" v1...v16 -- OPTIONAL input variables. Only the number of variables called for by
321 ;" the specified function will be used.
322 ;"Result -- returns the output value of the specified function, or "" if there is not output.
323 set objectFn=$$getInherited(objectName,CurModule,objectFn) ;"GET INHERITED FUNCTION
324 quit $$fn(objectName,objectFn,.v1,.v2,.v3,.v4,.v5,.v6,.v7,.v8,.v9,.v10,.v11,.v12,.v13,.v14,.v15,.v16)
325
326fn(objectName,objectFn,v1,v2,v3,v4,v5,v6,v7,v8,v9,v10,v11,v12,v13,v14,v15,v16)
327 ;"Purpose: to execute a function stored in a object
328 ;"Input: ObjectName -- the name of the object containing the member function
329 ;" objectFn -- the name of the function to be executed in the member function
330 ;" v1...v16 -- OPTIONAL input variables. Only the number of variables called for by
331 ;" the specified function will be used.
332 ;"Result -- returns the output value of the specified function, or "" if there is not output.
333
334 new outVar set outVar="" ;"default result
335 if (objectName="")!(objectName[" ") goto fnDone
336 new typeDef set typeDef=$get(@objectName@("TYPEDEF")) if typeDef="" goto fnDone
337 new pFn set pFn=$name(@typeDef@("FN"))
338
339 new TMGthis set TMGthis=objectName ;"set up global-scope 'this' var pointer for member function use
340 new fn set fn=$get(@pFn@(objectFn,"COMPILED"))
341 if fn="" do
342 . set fn=$get(@pFn@(objectFn)) if fn="" quit ;"example wgtMultiply^TMGOOWG(x,y)
343 . new Params set Params=$piece($piece(fn,"(",2),")",1)
344 . new numParams set numParams=$length(Params,",") set:Params="" numParams=0
345 . set fn=$piece(fn,"(",1)
346 . new TMGParam,i,comma set TMGParam="",comma="" ;"first cycle comma not added
347 . for i=1:1:numParams set TMGParam=TMGParam_comma_".v"_i,comma=","
348 . set fn="set outVar=$$"_fn_"("_TMGParam_")" ;"e.g. 'set outVar=$$wgtMultiply^TMGOOWG(x,y)'
349 . set @pFn@(objectFn,"COMPILED")=fn
350 xecute fn ;"<--- call actual function. ;PERHAPS LET OBJECTS DEFINE CUSTOM ERROR TRAP FUNCTIONS??
351fnDone quit outVar
352
353
354regProp(objectName,propName,initialValue,setFn,getFn,AllowedValues)
355 ;"Purpose: to register a property for given object
356 ;" Note, but using these functions for a property, rather than
357 ;" directly reading, it will allow the creation of setter and reader
358 ;" methods
359 ;"Input: ObjectName -- the name of the object containing the member function
360 ;" propName -- the name of the property to establish
361 ;" initialValue -- OPTIONAL. The initial value. May be passed
362 ;" by reference for storage of an array.
363 ;" setFn -- OPTIONAL: the name of a procedure to set value. Format:
364 ;" e.g. 'MyProc^Module', NOT 'MyProc^Module(var)'
365 ;" In the code module, the actual function that is to be
366 ;" called must be in this format (IF setter fn is specified):
367 ;" e.g. 'MyProc(TMGthis,propName,value)'
368 ;" ** The code should be able to deal with 'value' as an array
369 ;" ** QUIT must NOT return a value
370 ;" getFn -- OPTIONAL: the name of a function to get value. Format:
371 ;" e.g. '$$MyFunct^Module'
372 ;" In the code module, the actual function that is to be
373 ;" called must be in this format (IF getter fn is specified):
374 ;" e.g. 'MyProc(TMGthis,propName,outArray)'
375 ;" ** The could should return the value in outArray, which
376 ;" will be passed by reference.
377 ;" ** QUIT *must* return a value (in addition to outArray)
378 ;" AllowedValues -- OPTIONAL. PASS BY REFERENCE. Format:
379 ;" ** to be implemented **
380 ;" AllowedValues("MyValue#1")="" <-- arbitrary acceptable
381 ;" AllowedValues("MyValue#2")="" <-- arbitrary acceptable
382 ;" AllowedValues("100...200")="" <-- "..." is signal for a RANGE of acceptible values
383 ;" AllowedValues("[ABcDe]")="" <-- "[ ]" is signals a list of allowable flags.
384 ;" Value must some combination of the flags listed
385 ;" Flags must be 1 character
386 ;" AllowedValues("?.N")=""
387 ;" If value has "?" as first character, then interpreted as screening code
388 ;" Value will be accepted if the screening expression evaluates to TRUE
389 ;" Note: If Allowed values is not passed, then it is up to the
390 ;" setter function (if one exists) to screen input. Otherwise
391 ;" ALL values will be accepted
392 ;" If Allowed values is passed, then ONLY values listed as
393 ;" acceptible values, or in one of the ranges will be acceptible
394 ;" ALTERNATE FORMAT for allowed values:
395 ;" AllowedValues="AllowedValue1^AllowedValue2^100...200^Value4^?.N^AnotherValue" etc.
396 ;"Result: returns the value of the property, or "" if not found
397 ;" If a getting/reading function has been specified at the time registration,
398 ;" then result returned will be the value of the function.
399
400 ;"Note: there is no 'inheritence' for properties.
401
402 new typeDef set typeDef=@objectName@("TYPEDEF")
403 kill @objectName@("PROP",propName)
404 if $data(AllowedValues)>0 do
405 . if ($data(AllowedValues)#10=1) do
406 . . new i for i=1:1:$length(AllowedValues,"^") do
407 . . . new oneValue set oneValue=$piece(AllowedValues,"^",i)
408 . . . set AllowedValues(oneValue)=""
409 . set AllowedValues="" ;"<-- setting SETTER fun below will overwrite this position. OK.
410 . merge @typeDef@("OOL_SETTER",propName,"ALLOWED")=AllowedValues
411 if $get(setFn)'="" do
412 . new fn set fn="do "_setFn_"(objectName,"""_propName_""",.value)"
413 . set @typeDef@("OOL_SETTER",propName)=fn
414 if $get(getFn)'="" do
415 . new fn set fn="set result="_getFn_"(objectName,"""_propName_""",.outArray)"
416 . set @typeDef@("OOL_GETTER",propName)=fn
417 do setProp(objectName,propName,.initialValue)
418 quit
419
420
421getProp(objectName,propName,outArray)
422 ;"Purpose: to get a property for a given object
423 ;" Note, but using this function to read the property, rather than
424 ;" directly reading, it will allow the creation of setter and reader
425 ;" methods
426 ;"Input: ObjectName -- the name of the object containing the member function
427 ;" propName -- the name of the property to read
428 ;" outArray -- OPTIONAL. PASS BY REFERENCE, an OUT PARAMETER
429 ;" prior data in outArray will be KILLED
430 ;"Result: returns the value of the property, or "" if not found
431 ;" If a getting/reading function has been specified at the time registration,
432 ;" then result returned will be the value of the function.
433 ;" The results will also be put into outArray (in case value is an array)
434 ;" It is possible that result="" but outArray contains valid data.
435
436 new result set result="" kill outArray
437 if $get(objectName)="" goto gpDone
438 if +objectName=objectName do goto gpDone
439X1 . new temp set temp=1
440 new typeDef set typeDef=$get(@objectName@("TYPEDEF"))
441 if typeDef="" goto gpDone
442 new fn set fn=$get(@typeDef@("OOL_GETTER",propName))
443 if fn'="" do
444 . new $etrap set $etrap="set result="""",$etrap="""",$ecode="""""
445 . xecute fn
446 else do
447 . set result=$get(@objectName@("PROP",propName))
448 . merge outArray=@objectName@("PROP",propName)
449gpDone
450 quit result
451
452
453setProp(objectName,propName,value)
454 ;"Purpose: to set a property for a given object
455 ;" Note, but using this function to read the property, rather than
456 ;" directly reading, it will allow the creation of setter and reader
457 ;" methods
458 ;"Input: ObjectName -- the name of the object containing the member function
459 ;" propName -- the name of the property to set
460 ;" value -- MAY BE PASSED BY REFERENCE (for arrays)
461 ;"Result: none
462 ;"Note: If a setting function has been specified at the time registration,
463 ;" then 'value' will be passed to the setter. The setter will be
464 ;" responsible for storing 'value' if appropriate.
465 ;"Note: If an allowed values set was specified when property was registered, then
466 ;" screen for those allowed values will take place here.
467
468 if $get(objectName)="" goto spDone
469 new typeDef set typeDef=@objectName@("TYPEDEF")
470 new abort set abort=0
471 new result set result=""
472 if $get(objectName)="" goto spDone
473 if $data(@typeDef@("OOL_SETTER",propName,"ALLOWED"))>0 do goto:(abort=1) spDone
474 . new AllowedValues
475 . merge AllowedValues=@typeDef@("OOL_SETTER",propName,"ALLOWED")
476 . if $data(AllowedValues)'>1 quit
477 . ;"**Allowed values set found, so default is now to abort unless allowed value found
478 . set abort=1
479 . new cond set cond=""
480 . new allowedFound set allowedFound=0
481 . for set cond=$order(AllowedValues(cond),-1) quit:(cond="")!(allowedFound=1) do
482 . . if cond["..." do quit ;"<--A range
483 . . . new lo,hi
484 . . . set lo=$piece(cond,"...",1),hi=$piece(cond,"...",2)
485 . . . if (value'<lo)&(value'>hi) set allowedFound=1
486 . . if $extract(cond,1)="?" do quit ;"<--Pattern match code
487 . . . new temp,$etrap
488 . . . set $etrap="set $etrap="""",$ecode="""""
489 . . . xecute "set temp=(value"_cond_")" ;"e.g. 'set temp=(value?.N)'
490 . . . if temp=1 set allowedFound=1
491 . . if (value=cond) set allowedFound=1
492 . . if $extract(cond,1)="[" do quit ;"<--An allowed set of flags (1 character)
493 . . . new goodMatch set goodMatch=1
494 . . . new i for i=1:1:$length(value) do quit:(goodMatch=0) ;"check to see if each character is an allowed flag
495 . . . . new flag set flag=$extract(value,i)
496 . . . . if cond'[flag set goodMatch=0
497 . . . if goodMatch set allowedFound=1
498 . if allowedFound=1 set abort=0 ;"<--Straight matching.
499 new fn set fn=$get(@typeDef@("OOL_SETTER",propName))
500 if fn'="" do
501 . new $etrap set $etrap="set result="""",$etrap="""",$ecode="""""
502 . xecute fn
503 else do
504 . kill @objectName@("PROP",propName)
505 . merge @objectName@("PROP",propName)=value
506spDone
507 quit
508
Note: See TracBrowser for help on using the repository browser.